source: locker/bin/webaccess @ 127

#!/usr/bin/perl
use strict;

my ($op, $username) = @ARGV;

if(defined $op and $op eq "reset") {
        system("rm -f .htaccess .htpasswd");
    print "\nDone.  All access restrictions removed.\n\n";
        exit(0);
}

if(!defined $op or !defined $username or
        ($op ne "allow" and $op ne "remove")) {
        print "Usage: webaccess [allow username] [remove username] [reset]\n";
        exit(0);
}

if($op eq "allow" or $op eq "remove") {
        open(HTPASSWD, ".htpasswd");
        open(TMP, ">.htpasswd_tmp");
        while(my $line = <HTPASSWD>) {
                print TMP "$line" unless($line =~ /$username\:/);
        }
        close(TMP);
        close(HTPASSWD);
        system("mv .htpasswd_tmp .htpasswd");
}

if($op eq "allow") {
        my $password;
        print "Enter new password for $username: ";
        system("stty -echo");
        chop($password = <STDIN>);
        system("stty echo");
        print "\n";

        open(HTACCESS, ">.htaccess");
        print HTACCESS <<ENDFILE;
AuthUserFile $ENV{PWD}/.htpasswd
AuthName Private
AuthType Basic
<Limit GET>
require valid-user
</Limit>
ENDFILE
        close(HTACCESS);
        chmod(0777, ".htaccess");

        my $salt = substr($username, 0, 2);
        $password = crypt($password, $salt);

        open(HTPASSWD, ">>.htpasswd");
        print HTPASSWD "$username\:$password\n";
        close(HTPASSWD);
        chmod(0777, ".htpasswd");
}

print "\nDone.  New list of valid usernames:\n";
open(HTPASSWD, ".htpasswd");
while(my $line = <HTPASSWD>) {
        $line =~ /(.*):/;
        print "$1\n";
}
close(HTPASSWD);
print "\n";