#!/usr/bin/perl require 5; #$DEBUG =1; $version = "5.0"; ################################################### # PASS.CGI v5.0 # Copyright 1998-2006 Right Connection, Inc. # For use by their customers only for integrating IPPS # Password Management to their website # # Please be sure and set all of the variables below. If they are # not properly set ....... the Password Management will not work # ################################################### ## Un-Comment ONLY ONE of these options depending upon what version of Apache you are running ## Apache 1.x series #BEGIN { @AnyDBM_File::ISA = qw(NDBM_File) } ## Apache 2.x Series #BEGIN { @AnyDBM_File::ISA = qw(SDBM_File) } # What is the directory where your encrypted password file is located ? $pass_dir = "/path/to/.htpasswd/directory"; # What is the name of your encrypte password file ? (Should be pass_dbm). $pass_file = "pass_dbm"; # What is the URL the NEW customer should be taken to when they sign-up? $members_url = "http://www.yourwebsite.com/members/"; # The BODY tag variables for the script $bgcolor = "FFFFFF"; $text = "000000"; $link = "FF0000"; $vlink = "FF00FF"; $alink = "FFFF00"; ################################################### # NO CHANGES ARE NEEDED BEYOND THIS POINT ################################################### use Fcntl; use AnyDBM_File (); &read_parse; $refering_url = $ENV{'HTTP_REFERER'}; $LOCK_EX = 2; $LOCK_UN = 8; if ($contents{'mode'} eq "" || $contents{'mode'} eq "add") { &new_signup; } if ($contents{'mode'} eq "stat") { &stat; } if ($contents{'mode'} eq "update") { &update(@user_pairs); } &error("No Commands were received"); exit; sub read_parse { local (*contents) = @_; local ( $request_method, $query_string, @key_value_pairs, $key_value, $key, $value, $data); $data_string = ""; $request_method = $ENV{'REQUEST_METHOD'}; if ($request_method eq "GET") { $query_string = $ENV{'QUERY_STRING'}; } elsif ($request_method eq "POST") { read (STDIN, $query_string, $ENV{'CONTENT_LENGTH'}); } @key_value_pairs = split (/&/, $query_string); foreach $key_value (@key_value_pairs) { ($key, $value) = split (/=/, $key_value); $value =~ tr/+/ /; $value =~ s/\r/\n/g; $value =~ s/%([\dA-Fa-f][\dA-Fa-f])/pack ("C", hex ($1))/eg; if (defined($FORM_DATA{$key})) { $contents{$key} = join ("\0", $contents{$key}, $value); } else { $contents{$key} = $value; } $data_string .= "$key - $value\n"; if ($contents{'userpair'} ne "") { push(@user_pairs,$contents{'userpair'}); } } if (@user_pairs) { $data_string .= "userpairs\n@user_pairs\n"; } } sub error { local($errormsg) = @_; print "Content-Type: text/html\n\n"; print "\n"; print "\n"; print "
\n\n\n"; print "\n$errormsg\n\n"; print "
\n\n"; print "Your Membership sign-up is complete.
You may now enter the \n";
print "MEMBERS AREA using your User ID of \n";
print "$contents{'username'} and Password of $contents{'password'}
\n";
if ($DEBUG) {
print "\n";
}
print "\n";
print "Version: " . $Version . "
\n";
print "";
exit;
}
sub stat {
open(FILE, "$pass_dir/$pass_file") || &error("Can't stat file $pass_dir/$pass_file ($!)");
$filesize = -s FILE;
close(FILE);
&good_stat;
}
sub good_stat {
print "Connection: close\n";
print "Content-Type: text/plain\n\n";
print "\n";
print "$filesize\n";
print "\n";
if ($DEBUG) {
print "\n";
}
exit;
}
sub update {
my(@users) = @_;
my %DB = ();
my @range = ();
my($mode, $flags) = (0666 , O_RDWR|O_CREAT);
$key = $contents{'username'};
$file = $pass_dir . "/" . $pass_file;
tie (%DB, "AnyDBM_File", $file, $flags, $mode) || die "Can't tie $file: $!";
foreach my $key (keys %DB) {
delete $DB{$key};
}
foreach $user (@users) {
($username, $cpw) = split(':',$user);
$groups = '' if $groups eq '-';
$comment = '' if $comment eq '-';
$groups .= ":" . $comment if $comment;
$cpw .= ":" . $groups if $groups;
$DB{$username} = $cpw;
}
untie %DB;
print "Connection: close\n";
print "Content-Type: text/plain\n\n";
print "\n";
print "OK\n";
print "\n";
if ($DEBUG) {
print "\n";
}
exit;
}