home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / xampp / xampp-perl-addon-1.4.9-installer.exe / Htpasswd.pm < prev    next >
Encoding:
Perl POD Document  |  2002-08-14  |  15.5 KB  |  716 lines
  1. package Apache::Htpasswd;
  2.  
  3. use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  4. use strict;        # Restrict unsafe variables, references, barewords
  5. use Carp;
  6.  
  7. use POSIX qw ( SEEK_SET SEEK_END );
  8. use Fcntl qw ( LOCK_EX LOCK_UN );
  9.  
  10. @ISA = qw(Exporter);
  11.  
  12. @EXPORT = qw();
  13.  
  14. @EXPORT_OK = qw(htpasswd htDelete fetchPass fetchInfo writeInfo htCheckPassword error Version);
  15.  
  16. %EXPORT_TAGS = (all => [@EXPORT_OK]);
  17.  
  18. $VERSION = '1.5.5';
  19.  
  20. sub Version {
  21.     return $VERSION;
  22. }
  23.  
  24. #-----------------------------------------------------------#
  25. # Public Methods
  26. #-----------------------------------------------------------#
  27.  
  28. sub new {
  29.     my $proto = shift;
  30.     my $args = shift;
  31.     my $passwdFile;
  32.  
  33.     if (ref $args eq 'HASH') {
  34.         $passwdFile = $args->{'passwdFile'};
  35.     } else {
  36.         $passwdFile = $args;
  37.     }
  38.  
  39.     my $class = ref($proto) || $proto;
  40.     my ($self) = {};
  41.     bless ($self, $class);
  42.  
  43.     $self->{'PASSWD'}   = $passwdFile;
  44.     $self->{'ERROR'}    = "";
  45.     $self->{'LOCK'}     = 0;
  46.     $self->{'OPEN'}     = 0;
  47.     $self->{'READONLY'} = $args->{'ReadOnly'} if ref $args eq 'HASH';
  48.     
  49.     return $self;
  50. }
  51.  
  52. #-----------------------------------------------------------#
  53.  
  54. sub error {
  55.     my $self = shift;
  56.     return $self->{'ERROR'};
  57. }
  58.  
  59. #-----------------------------------------------------------#
  60.  
  61. sub htCheckPassword {
  62.     my $self = shift;
  63.     my ($Id, $pass) = @_;
  64.  
  65.     my $cryptPass = $self->fetchPass($Id);
  66.  
  67.     if (!$cryptPass) { return undef; }
  68.  
  69.     my $fooCryptPass = $self->CryptPasswd($pass, $cryptPass);
  70.  
  71.     if ($fooCryptPass eq $cryptPass) {
  72.         return 1;
  73.     } else {
  74.         $self->{'ERROR'} = __PACKAGE__."::htCheckPassword - Passwords do not match.";
  75.         carp $self->error() unless caller ne $self;
  76.         return 0;
  77.     }
  78. }
  79.  
  80. #-----------------------------------------------------------#
  81.  
  82. sub htpasswd {
  83.     my $self      = shift;
  84.     my $Id        = shift;
  85.     my $newPass   = shift;
  86.     my ($oldPass) = @_ if (@_);
  87.     my $noOld     = 0;
  88.  
  89.     if ($self->{READONLY}) {
  90.         $self->{'ERROR'} = __PACKAGE__. "::htpasswd - Can't change passwords in ReadOnly mode";
  91.         carp $self->error();
  92.         return undef;
  93.     }
  94.  
  95.     if (!defined($oldPass)) { $noOld=1;}
  96.     if (defined($oldPass) && $oldPass =~ /^\d$/) {
  97.         if ($oldPass) {
  98.             $newPass = $Id unless $newPass;
  99.             my $newEncrypted = $self->CryptPasswd($newPass);
  100.             return $self->writePassword($Id, $newEncrypted);
  101.         }
  102.     }
  103.  
  104.     # New Entry
  105.     if ($noOld) {
  106.         my $passwdFile = $self->{'PASSWD'};
  107.  
  108.         # Encrypt new password string
  109.  
  110.         my $passwordCrypted = $self->CryptPasswd($newPass);
  111.  
  112.             $self->_open();
  113.  
  114.         if ($self->fetchPass($Id)) {
  115.             # User already has a password in the file. 
  116.             $self->{'ERROR'} = __PACKAGE__. "::htpasswd - $Id already exists in $passwdFile";
  117.             carp $self->error();
  118.             $self->_close();  
  119.             return undef;
  120.         } else {
  121.             # If we can add the user.
  122.                 seek(FH, 0, SEEK_END);
  123.                 print FH "$Id\:$passwordCrypted\n";
  124.         
  125.                 $self->_close();  
  126.                 return 1;
  127.         }
  128.  
  129.             $self->_close();
  130.  
  131.     } else {
  132.             $self->_open();
  133.  
  134.         my $exists = $self->htCheckPassword($Id, $oldPass);
  135.  
  136.         if ($exists) {
  137.             my ($newCrypted) = $self->CryptPasswd($newPass);
  138.             return $self->writePassword($Id, $newCrypted);
  139.         } else {
  140.             # ERROR returned from htCheckPass
  141.             $self->{'ERROR'} = __PACKAGE__."::htpasswd - Password not changed.";
  142.             carp $self->error();
  143.             return undef;
  144.         }
  145.  
  146.             $self->_close();
  147.         }
  148. } # end htpasswd
  149.  
  150. #-----------------------------------------------------------#
  151.  
  152. sub htDelete {
  153.     my ($self, $Id) = @_;
  154.     my ($passwdFile) = $self->{'PASSWD'};
  155.     my (@cache);
  156.     my ($return);
  157.  
  158.     # Loop through the file, building a cache of exising records
  159.     # which don't match the Id.
  160.  
  161.     $self->_open();
  162.  
  163.     seek(FH, 0, SEEK_SET);
  164.     while (<FH>) {
  165.  
  166.         if (/^$Id\:/) {
  167.             $return = 1; 
  168.         } else {
  169.             push(@cache, $_);
  170.         }
  171.     }
  172.  
  173.  
  174.     # Write out the @cache if needed.
  175.  
  176.     if ($return) {
  177.  
  178.         # Return to beginning of file
  179.         seek(FH, 0, SEEK_SET);
  180.         
  181.         while (@cache) { 
  182.         print FH shift (@cache); 
  183.         }
  184.  
  185.         # Cut everything beyond current position
  186.         truncate(FH, tell(FH));
  187.  
  188.     } else {
  189.         $self->{'ERROR'} = __PACKAGE__. "::htDelete - User $Id not found in $passwdFile: $!";
  190.         carp $self->error();
  191.     }
  192.  
  193.     $self->_close();
  194.  
  195.     return $return;
  196. }
  197.  
  198. #-----------------------------------------------------------#
  199.  
  200. sub fetchPass {
  201.     my ($self) = shift;
  202.     my ($Id) = @_;
  203.     my ($passwdFile) = $self->{'PASSWD'};
  204.  
  205.     my $passwd = 0;
  206.  
  207.     $self->_open();
  208.     
  209.     while (<FH>) {
  210.         chop;
  211.         my @tmp = split(/:/,$_,3);
  212.         if ( $tmp[0] eq $Id ) {
  213.             $passwd = $tmp[1];
  214.             last;
  215.         }
  216.     }
  217.  
  218.     $self->_close();
  219.  
  220.     return $passwd;
  221. }
  222.  
  223. #-----------------------------------------------------------#
  224.  
  225. sub writePassword {
  226.     my $self = shift;
  227.     my ($Id, $newPass) = @_;
  228.  
  229.     my $passwdFile = $self->{'PASSWD'};
  230.     my @cache;
  231.     my $return;
  232.     
  233.     $self->_open();
  234.     seek(FH, 0, SEEK_SET);
  235.  
  236.     while (<FH>) {
  237.  
  238.         my @tmp = split(/:/,$_,3);
  239.         if ( $tmp[0] eq $Id ) {
  240.         my $info = $tmp[2] ? $tmp[2] : "";
  241.         chomp $info;
  242.             push (@cache, "$Id\:$newPass\:$info\n");
  243.             $return = 1; 
  244.  
  245.         } else {
  246.             push (@cache, $_);
  247.         }
  248.     }
  249.  
  250.     # Write out the @cache, if needed.
  251.  
  252.     if ($return) {
  253.         
  254.         # Return to beginning of file
  255.         seek(FH, 0, SEEK_SET);
  256.  
  257.         while (@cache) { 
  258.             print FH shift (@cache); 
  259.         }
  260.  
  261.         # Cut everything beyond current position
  262.         truncate(FH, tell(FH));
  263.  
  264.     } else {
  265.         $self->{'ERROR'} = __PACKAGE__. "::writePassword - User $Id not found in $passwdFile: $!";
  266.         carp $self->error() . "\n";
  267.     }
  268.  
  269.     $self->_close();
  270.  
  271.     return $return;
  272. }
  273.  
  274. #-----------------------------------------------------------#
  275.  
  276. sub fetchInfo {
  277.     my ($self) = shift;
  278.     my ($Id) = @_;
  279.     my ($passwdFile) = $self->{'PASSWD'};
  280.  
  281.     my $info = 0;
  282.  
  283.     $self->_open();
  284.     
  285.     while (<FH>) {
  286.         chop;
  287.         my @tmp = split(/:/,$_,3);
  288.         if ( $tmp[0] eq $Id ) {
  289.             $info = $tmp[2];
  290.             last;
  291.         }
  292.     }
  293.  
  294.     $self->_close();
  295.  
  296.     return $info;
  297. }
  298.  
  299. #-----------------------------------------------------------#
  300.  
  301. sub fetchUsers {
  302.     my $self       = shift;
  303.     my $passwdFile = $self->{'PASSWD'};
  304.     my $count = 0;
  305.     my @users;
  306.  
  307.     $self->_open();
  308.  
  309.     while (<FH>) {
  310.         chop;
  311.         my @tmp = split(/:/,$_,3);
  312.         push (@users, $tmp[0]) unless !$tmp[0];
  313.     }
  314.  
  315.     $self->_close();
  316.  
  317.     return wantarray() ? @users : scalar @users;
  318. }
  319.  
  320. #-----------------------------------------------------------#
  321.  
  322. sub writeInfo {
  323.     my ($self) = shift;
  324.     my ($Id, $newInfo) = @_;
  325.  
  326.     my ($passwdFile) = $self->{'PASSWD'};
  327.     my (@cache);
  328.  
  329.     my ($return);
  330.     
  331.     $self->_open();
  332.     seek(FH, 0, SEEK_SET);
  333.  
  334.     while (<FH>) {
  335.  
  336.             my @tmp = split(/:/,$_,3);
  337.  
  338.         if ( $tmp[0] eq $Id ) {
  339.             chomp $tmp[1] if (@tmp == 2); # Cut out EOL if there was no info
  340.             push (@cache, "$Id\:$tmp[1]\:$newInfo\n");
  341.             $return = 1; 
  342.  
  343.         } else {
  344.             push (@cache, $_);
  345.         }
  346.     }
  347.  
  348.     # Write out the @cache, if needed.
  349.  
  350.     if ($return) {
  351.         
  352.         # Return to beginning of file
  353.         seek(FH, 0, SEEK_SET);
  354.  
  355.         while (@cache) { 
  356.             print FH shift (@cache); 
  357.         }
  358.  
  359.         # Cut everything beyond current position
  360.         truncate(FH, tell(FH));
  361.  
  362.     } else {
  363.         $self->{'ERROR'} = __PACKAGE__. "::writeInfo - User $Id not found in $passwdFile: $!";
  364.         carp $self->error() . "\n";
  365.     }
  366.  
  367.     $self->_close();
  368.  
  369.     return $return;
  370. }
  371.  
  372. #-----------------------------------------------------------#
  373.  
  374. sub CryptPasswd {
  375.     my ($self) = shift;
  376.     my ($passwd, $salt) = @_;
  377.  
  378.     if ($salt) {
  379.         # Make sure only use 2 chars
  380.         $salt = substr ($salt, 0, 2);
  381.     } else {
  382.         ($salt = substr ($0, 0, 2)) =~ tr/:/C/; 
  383.     }
  384.  
  385.     return crypt ($passwd, $salt);
  386. }
  387.  
  388. #-----------------------------------------------------------#
  389.  
  390. sub DESTROY { close(FH); };
  391.  
  392. #-----------------------------------------------------------#
  393.  
  394.     sub _lock {
  395.     my ($self) = shift;
  396.     
  397.     # Lock if we don't have the lock
  398.         flock(FH, LOCK_EX) if($self->{'LOCK'} == 0);
  399.  
  400.     # We have the lock
  401.     $self->{'LOCK'} = 1;
  402.  
  403.     # Seek to head
  404.         seek(FH, 0, SEEK_SET);
  405.     }
  406.  
  407. #-----------------------------------------------------------#
  408.  
  409.     sub _unlock {
  410.     my ($self) = shift;
  411.  
  412.         flock(FH, LOCK_UN);
  413.  
  414.     $self->{'LOCK'} = 0;
  415.     }
  416.  
  417. #-----------------------------------------------------------#
  418.  
  419. sub _open {
  420.     my $self = shift;
  421.  
  422.     if($self->{'OPEN'} > 0) {
  423.     $self->{'OPEN'}++;
  424.     $self->_lock();
  425.     return;
  426.     }
  427.  
  428.     my $passwdFile = $self->{'PASSWD'};
  429.  
  430.     if ($self->{READONLY}) {
  431.         if (!open(FH, $passwdFile)) {
  432.         $self->{'ERROR'} = __PACKAGE__. "::fetchPass - Cannot open $passwdFile: $!";
  433.         croak $self->error();
  434.     }
  435.     } else {
  436.     if (!open(FH,"+<$passwdFile")) {
  437.         $self->{'ERROR'} = __PACKAGE__. "::fetchPass - Cannot open $passwdFile: $!";
  438.         croak $self->error();
  439.         }
  440.     }
  441.  
  442.     binmode(FH);    
  443.     $self->{'OPEN'}++;
  444.     $self->_lock() unless $self->{READONLY}; # No lock on r/o
  445. }
  446.  
  447. #-----------------------------------------------------------#
  448.  
  449. sub _close {
  450.     my $self = shift;
  451.     $self->_unlock() unless $self->{READONLY};
  452.  
  453.     $self->{'OPEN'}--;
  454.  
  455.     if($self->{'OPEN'} > 0) { return; }
  456.  
  457.     if (!close(FH)) {
  458.     my $passwdFile = $self->{'PASSWD'};
  459.     $self->{'ERROR'} = __PACKAGE__. "::htDelete - Cannot close $passwdFile: $!";
  460.     carp $self->error();
  461.     return undef;
  462.     }
  463. }
  464.  
  465. #-----------------------------------------------------------#
  466.  
  467. 1; 
  468.  
  469. __END__
  470.  
  471. =head1 NAME
  472.  
  473. Apache::Htpasswd - Manage Unix crypt-style password file.
  474.  
  475. =head1 SYNOPSIS
  476.  
  477.     use Apache::Htpasswd;
  478.  
  479.     $foo = new Apache::Htpasswd("path-to-file");
  480.  
  481.     $foo = new Apache::Htpasswd({passwdFile => "path-to-file",
  482.                  ReadOnly   => 1}
  483.                 );
  484.  
  485.     # Add an entry    
  486.     $foo->htpasswd("zog", "password");
  487.  
  488.     # Change a password    
  489.     $foo->htpasswd("zog", "new-password", "old-password");
  490.     
  491.     # Change a password without checking against old password
  492.     # The 1 signals that the change is being forced.
  493.     
  494.     $foo->htpasswd("zog", "new-password", 1);
  495.         
  496.     # Check that a password is correct
  497.     $pwdFile->htCheckPassword("zog", "password");
  498.  
  499.     # Fetch an encrypted password 
  500.     $foo->fetchPass("foo");
  501.     
  502.     # Delete entry
  503.     $foo->htDelete("foo");
  504.  
  505.     # If something fails, check error
  506.     $foo->error;
  507.  
  508.     # Write in the extra info field
  509.     $foo->writeInfo("login", "info");
  510.  
  511.     # Get extra info field for a user
  512.     $foo->fetchInfo("login");
  513.  
  514. =head1 DESCRIPTION
  515.  
  516. This module comes with a set of methods to use with htaccess password
  517. files. These files (and htaccess) are used to do Basic Authentication
  518. on a web server.
  519.  
  520. The passwords file is a flat-file with login name and their associated
  521. crypted password. You can use this for non-Apache files if you wish, but
  522. it was written specifically for .htaccess style files.
  523.  
  524. =head2 FUNCTIONS
  525.  
  526. =over 4
  527.  
  528. =item Apache::Htpasswd->new(...);
  529.  
  530. As of version 1.5.4 named params have been added, and it is suggested that
  531. you use them from here on out.
  532.  
  533.     Apache::Htpasswd->new("path-to-file");
  534.     
  535. "path-to-file" should be the path and name of the file containing
  536. the login/password information.
  537.  
  538.     Apache::Htpasswd->new({passwdFile => "path-to-file",
  539.                    ReadOnly   => 1,
  540.                  });
  541.  
  542. This is the prefered way to instantiate an object. The 'ReadOnly' param
  543. is optional, and will open the file in read-only mode if used.
  544.  
  545. =item error;
  546.  
  547. If a method returns an error, or a method fails, the error can
  548. be retrived by calling error()
  549.  
  550.  
  551. =item htCheckPassword("login", "password");
  552.  
  553. Finds if the password is valid for the given login.
  554.  
  555. Returns 1 if passes.
  556. Returns 0 if fails.
  557.  
  558.  
  559. =item htpasswd("login", "password");
  560.  
  561. This will add a new user to the password file.
  562. Returns 1 if succeeds.
  563. Returns undef on failure.
  564.  
  565.  
  566. =item htDelete("login")
  567.  
  568. Delete users entry in password file.
  569.  
  570. Returns 1 on success
  571. Returns undef on failure.
  572.  
  573.  
  574. =item htpasswd("login", "new-password", "old-password");
  575.  
  576. If the I<old-password> matches the I<login's> password, then
  577. it will replace it with I<new-password>. If the I<old-password>
  578. is not correct, will return 0.
  579.  
  580.  
  581. =item htpasswd("login", "new-password", 1);
  582.  
  583. Will replace the password for the login. This will force the password
  584. to be changed. It does no verification of old-passwords.
  585.  
  586. Returns 1 if succeeds
  587. Returns undef if fails
  588.  
  589. =item fetchPass("login");
  590.  
  591. Returns I<encrypted> password if succeeds.
  592. Returns 0 if login is invalid.
  593. Returns undef otherwise.
  594.  
  595. =item fetchInfo("login");
  596.  
  597. Returns additional information if succeeds.
  598. Returns 0 if login is invalid.
  599. Returns undef otherwise.
  600.  
  601. =item fetchUsers();
  602.  
  603. Will return either a list of all the user names, or a count of all the 
  604. users.
  605.  
  606. The following will return a list:
  607. my @users = $Htpasswd->fetchUsers();
  608.  
  609. The following will return the count:
  610. my $user_count = $Htpasswd->fetchUsers();
  611.  
  612. =item writeInfo("login", "info");
  613.  
  614. Will replace the additional information for the login.
  615. Returns 0 if login is invalid.
  616. Returns undef otherwise.
  617.  
  618.  
  619. =item CryptPasswd("password", "salt");
  620.  
  621. Will return an encrypted password using 'crypt'. If I<salt> is
  622. ommitted, a salt will be given by the subroutine using the first 2
  623. character of $0.
  624.  
  625. =back
  626.  
  627. =head1 INSTALLATION
  628.  
  629. You install Apache::Htpasswd, as you would install any perl module library,
  630. by running these commands:
  631.  
  632.    perl Makefile.PL
  633.    make
  634.    make test
  635.    make install
  636.    make clean
  637.  
  638. =head1 DOCUMENTATION
  639.  
  640. POD style documentation is included in the module.  
  641. These are normally converted to manual pages and installed as part 
  642. of the "make install" process.  You should also be able to use 
  643. the 'perldoc' utility to extract and read documentation from the 
  644. module files directly.
  645.  
  646.  
  647. =head1 AVAILABILITY
  648.  
  649. The latest version of Apache::Htpasswd should always be available from:
  650.  
  651.     $CPAN/modules/by-authors/id/K/KM/KMELTZ/
  652.  
  653. Visit <URL:http://www.perl.com/CPAN/> to find a CPAN
  654. site near you.
  655.  
  656. =head1 CHANGES
  657.  
  658. Revision 1.5.5  2002/08/14 11:27:05 Newline issue fixed for certain conditions.
  659.  
  660. Revision 1.5.4  2002/07/26 12:17:43 kevin doc fixes, new fetchUsers method,
  661. new ReadOnly option, named params for new(), various others
  662.  
  663. Revision 1.5.3  2001/05/02 08:21:18 kevin
  664. Minor bugfix
  665.  
  666. Revision 1.5.2  2001/04/03 09:14:57 kevin
  667. Really fixed newline problem :)
  668.  
  669. Revision 1.5.1  2001/03/26 08:25:38 kevin
  670. Fixed another newline problem
  671.  
  672. Revision 1.5  2001/03/15 01:50:12 kevin
  673. Fixed bug to remove newlines
  674.  
  675. Revision 1.4  2001/02/23 08:23:46 kevin
  676. Added support for extra info fields
  677.  
  678. Revision 1.3  2000/04/04 15:00:15 meltzek
  679. Made file locking safer to avoid race conditions. Fixed
  680. typo in docs.
  681.  
  682. Revision 1.2  1999/01/28 22:43:45  meltzek
  683. Added slightly more verbose error croaks. Made sure error from htCheckPassword is only called when called directly, and not by $self.
  684.  
  685. Revision 1.1  1998/10/22 03:12:08  meltzek
  686. Slightly changed how files lock.
  687. Made more use out of carp and croak.
  688. Made sure there were no ^M's as per Randal Schwartz's request.
  689.  
  690.  
  691. =head1 BUGS
  692.  
  693. None knows at time of writting.
  694.  
  695. =head1 AUTHOR INFORMATION
  696.  
  697. Copyright 1998..2002, Kevin Meltzer.  All rights reserved.  It may
  698. be used and modified freely, but I do request that this copyright
  699. notice remain attached to the file.  You may modify this module as you
  700. wish, but if you redistribute a modified version, please attach a note
  701. listing the modifications you have made.
  702.  
  703. This is released under the same terms as Perl itself.
  704.  
  705. Address bug reports and comments to:
  706. perlguy@perlguy.com
  707.  
  708. The author makes no warranties, promises, or gaurentees of this software. As with all
  709. software, use at your own risk.
  710.  
  711. =head1 SEE ALSO
  712.  
  713. L<Apache::Htgroup>
  714.  
  715. =cut
  716.