File Coverage

blib/lib/Apache/Htpasswd.pm

Criterion	Covered	Total	%
statement	225	259	86.8
branch	70	94	74.4
condition	9	21	42.8
subroutine	22	23	95.6
pod	11	12	91.6
total	337	409	82.4

package Apache::Htpasswd;

use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
use warnings;
use strict;    # Restrict unsafe variables, references, barewords
use Carp;

use POSIX qw ( SEEK_SET SEEK_END );
use Fcntl qw ( LOCK_EX LOCK_UN );

@ISA = qw(Exporter);

@EXPORT = qw();

@EXPORT_OK =
  qw(htpasswd htDelete fetchPass fetchInfo writeInfo htCheckPassword error Version);

%EXPORT_TAGS = ( all => [@EXPORT_OK] );

$VERSION = '1.9';

sub Version {
    return $VERSION;
}

#-----------------------------------------------------------#
# Public Methods
#-----------------------------------------------------------#

sub new {
    my $proto = shift;
    my $args  = shift;
    my $passwdFile;

    if ( ref $args eq 'HASH' ) {
        $passwdFile = $args->{'passwdFile'};
    }
    else {
        $passwdFile = $args;
    }

    my $class = ref($proto) || $proto;
    my ($self) = {};
    bless( $self, $class );

    $self->{'PASSWD'}   = $passwdFile;
    $self->{'ERROR'}    = "";
    $self->{'LOCK'}     = 0;
    $self->{'OPEN'}     = 0;
    $self->{'READONLY'} = $args->{'ReadOnly'} if ref $args eq 'HASH';
    $self->{'USEMD5'} = $args->{'UseMD5'} if ref $args eq 'HASH';
    $self->{'USEPLAIN'} = $args->{'UsePlain'} if ref $args eq 'HASH';

    return $self;
}

#-----------------------------------------------------------#

sub error {
    my $self = shift;
    return $self->{'ERROR'};
}

#-----------------------------------------------------------#

sub htCheckPassword {
    my $self = shift;
    my $Id   = shift;
    my $pass = shift;
    my $MD5Magic = '$apr1$';
    my $SHA1Magic = '{SHA}';

    my $cryptPass = $self->fetchPass($Id);
    if ( !$cryptPass ) { return undef; }

    if (index($cryptPass, $MD5Magic) == 0) {
        # This is an MD5 password
        require Crypt::PasswdMD5;
        my $salt = $cryptPass;
        $salt =~ s/^\Q$MD5Magic//;      # Take care of the magic string if present
        $salt =~ s/^(.*)\$/$1/;         # Salt can have up to 8 chars...
        $salt = substr( $salt, 0, 8 );  # That means no more than 8 chars too.
        return 1 if Crypt::PasswdMD5::apache_md5_crypt( $pass, $salt ) eq $cryptPass;
    }
    elsif (index($cryptPass, $SHA1Magic) == 0) {
        # This is an SHA1 password
        require Digest::SHA;
        require MIME::Base64;
        return 1 if '{SHA}'.MIME::Base64::encode_base64( Digest::SHA::sha1( $pass ), '' ) eq $cryptPass;
    }

    # See if it is encrypted using crypt
    return 1 if crypt($pass, $cryptPass) eq $cryptPass;

    # See if it is a plain, unencrypted password
    return 1 if $self->{USEPLAIN} && $pass eq $cryptPass;

    $self->{'ERROR'} =
        __PACKAGE__ . "::htCheckPassword - Passwords do not match.";
    carp $self->error() if caller eq $self;
    return 0;
}

#-----------------------------------------------------------#

sub htpasswd {
    my $self    = shift;
    my $Id      = shift;
    my $newPass = shift;
    my $oldPass = shift;
    my $noOld = 0;

    if ( $self->{READONLY} ) {
        $self->{'ERROR'} =
          __PACKAGE__ . "::htpasswd - Can't change passwords in ReadOnly mode";
        carp $self->error();
        return undef;
    }

    if ( !defined($oldPass) ) {
			$noOld = 1;
		}

    if ( defined($oldPass) && ref $oldPass eq 'HASH' ) {
        if ($oldPass->{'overwrite'}) {
            $newPass = $Id unless $newPass;
            my $newEncrypted = $self->CryptPasswd($newPass);
            return $self->writePassword( $Id, $newEncrypted );
        }
    }

    # New Entry
    if ($noOld) {
        my $passwdFile = $self->{'PASSWD'};

        # Encrypt new password string

        my $passwordCrypted = $self->CryptPasswd($newPass);

        $self->_open();

        if ( $self->fetchPass($Id) ) {

            # User already has a password in the file.
            $self->{'ERROR'} =
              __PACKAGE__ . "::htpasswd - $Id already exists in $passwdFile";
            carp $self->error();
            $self->_close();
            return undef;
        }
        else {

            # If we can add the user.
            seek( FH, 0, SEEK_END );
            print FH "$Id\:$passwordCrypted\n";

            $self->_close();
            return 1;
        }

        $self->_close();

    }
    else {
        $self->_open();

        my $exists = $self->htCheckPassword( $Id, $oldPass );

        if ($exists) {
            my ($newCrypted) = $self->CryptPasswd($newPass);
            return $self->writePassword( $Id, $newCrypted );
        }
        else {

            # ERROR returned from htCheckPass
            $self->{'ERROR'} =
              __PACKAGE__ . "::htpasswd - Password not changed.";
            carp $self->error();
            return undef;
        }

        $self->_close();
    }
}    # end htpasswd

#-----------------------------------------------------------#

sub htDelete {
    my $self       = shift;
    my $Id         = shift;
    my $passwdFile = $self->{'PASSWD'};
    my @cache;
    my $return;

    # Loop through the file, building a cache of exising records
    # which don't match the Id.

    $self->_open();

    seek( FH, 0, SEEK_SET );
    while () {

        if (/^$Id\:/) {
            $return = 1;
        }
        else {
            push ( @cache, $_ );
        }
    }

    # Write out the @cache if needed.

    if ($return) {

        # Return to beginning of file
        seek( FH, 0, SEEK_SET );

        while (@cache) {
            print FH shift (@cache);
        }

        # Cut everything beyond current position
        truncate( FH, tell(FH) );

    }
    else {
        $self->{'ERROR'} =
          __PACKAGE__ . "::htDelete - User $Id not found in $passwdFile: $!";
        carp $self->error();
    }

    $self->_close();

    return $return;
}

#-----------------------------------------------------------#

sub fetchPass {
    my $self       = shift;
    my $Id         = shift;
    my $passwdFile = $self->{'PASSWD'};

    my $passwd = 0;

    $self->_open();

    while () {
        chop;
        my @tmp = split ( /:/, $_, 3 );
        if ( $tmp[0] eq $Id ) {
            $passwd = $tmp[1];
            last;
        }
    }

    $self->_close();

    return $passwd;
}

#-----------------------------------------------------------#

sub writePassword {
    my $self    = shift;
    my $Id      = shift;
    my $newPass = shift;

    my $passwdFile = $self->{'PASSWD'};
    my @cache;
    my $return;

    $self->_open();
    seek( FH, 0, SEEK_SET );

    while () {

        my @tmp = split ( /:/, $_, 3 );
        if ( $tmp[0] eq $Id ) {
            my $info = $tmp[2] ? $tmp[2] : "";
            chomp $info;
            push ( @cache, "$Id\:$newPass\:$info\n" );
            $return = 1;

        }
        else {
            push ( @cache, $_ );
        }
    }

    # Write out the @cache, if needed.

    if ($return) {

        # Return to beginning of file
        seek( FH, 0, SEEK_SET );

        while (@cache) {
            print FH shift (@cache);
        }

        # Cut everything beyond current position
        truncate( FH, tell(FH) );

    }
    else {
        $self->{'ERROR'} = __PACKAGE__
          . "::writePassword - User $Id not found in $passwdFile: $!";
        carp $self->error() . "\n";
    }

    $self->_close();

    return $return;
}

#-----------------------------------------------------------#

sub fetchInfo {
    my $self       = shift;
    my $Id         = shift;
    my $passwdFile = $self->{'PASSWD'};

    my $info = 0;

    $self->_open();

    while () {
        chop;
        my @tmp = split ( /:/, $_, 3 );
        if ( $tmp[0] eq $Id ) {
            $info = $tmp[2];
            last;
        }
    }

    $self->_close();

    return $info;
}

#-----------------------------------------------------------#

sub fetchUsers {
    my $self       = shift;
    my $passwdFile = $self->{'PASSWD'};
    my $count      = 0;
    my @users;

    $self->_open();

    while () {
        chop;
        my @tmp = split ( /:/, $_, 3 );
        push ( @users, $tmp[0] ) unless !$tmp[0];
    }

    $self->_close();

    return wantarray() ? @users : scalar @users;
}

#-----------------------------------------------------------#

sub writeInfo {
    my $self    = shift;
    my $Id      = shift;
    my $newInfo = shift;

    my ($passwdFile) = $self->{'PASSWD'};
    my (@cache);

    my ($return);

    $self->_open();
    seek( FH, 0, SEEK_SET );

    while () {

        my @tmp = split ( /:/, $_, 3 );

        if ( $tmp[0] eq $Id ) {
            chomp $tmp[1] if ( @tmp == 2 );   # Cut out EOL if there was no info
            push ( @cache, "$Id\:$tmp[1]\:$newInfo\n" );
            $return = 1;

        }
        else {
            push ( @cache, $_ );
        }
    }

    # Write out the @cache, if needed.

    if ($return) {

        # Return to beginning of file
        seek( FH, 0, SEEK_SET );

        while (@cache) {
            print FH shift (@cache);
        }

        # Cut everything beyond current position
        truncate( FH, tell(FH) );

    }
    else {
        $self->{'ERROR'} =
          __PACKAGE__ . "::writeInfo - User $Id not found in $passwdFile: $!";
        carp $self->error() . "\n";
    }

    $self->_close();

    return $return;
}

#-----------------------------------------------------------#

sub CryptPasswd {
    my $self   = shift;
    my $passwd = shift;
    my $salt   = shift;
    my @chars  = ( '.', '/', 0 .. 9, 'A' .. 'Z', 'a' .. 'z' );
    my $Magic = '$apr1$';    # Apache specific Magic chars
    my $cryptType = (  $^O =~ /^MSWin/i || $self->{'USEMD5'} ) ? "MD5" : "crypt";

    if ( $salt && $cryptType =~ /MD5/i && $salt =~ /^\Q$Magic/ ) {

        # Borrowed from Crypt::PasswdMD5
        $salt =~ s/^\Q$Magic//;       # Take care of the magic string if present
        $salt =~ s/^(.*)\$.*$/$1/;    # Salt can have up to 8 chars...
        $salt = substr( $salt, 0, 8 );    # That means no more than 8 chars too.
                                          # For old crypt only
    }
    elsif ( $salt && $cryptType =~ /crypt/i ) {
        if ($salt =~ /\$2a\$\d+\$(.{23})/) {
            $salt = $1;
        } else {
            # Make sure only use 2 chars
            $salt = substr( $salt, 0, 2 );
        }
    }
    else {

# If we use MD5, create apache MD5 with 8 char salt: 3 randoms, 5 dots
        if ( $cryptType =~ /MD5/i ) {
            $salt =
              join ( '', map { $chars[ int rand @chars ] } ( 0 .. 2 ) )
              . "." x 5;

            # Otherwise fallback to standard archaic crypt
        }
        else {
            $salt = join ( '', map { $chars[ int rand @chars ] } ( 0 .. 1 ) );
        }
    }

    if ( $cryptType =~ /MD5/i ) {
				require Crypt::PasswdMD5;
        return Crypt::PasswdMD5::apache_md5_crypt( $passwd, $salt );
    }
    else {
        return crypt( $passwd, $salt );
    }
}

#-----------------------------------------------------------#

sub DESTROY { close(FH); };

#-----------------------------------------------------------#

sub _lock {
    my $self = shift;

    # Lock if we don't have the lock
    flock( FH, LOCK_EX ) if ( $self->{'LOCK'} == 0 );

    # We have the lock
    $self->{'LOCK'} = 1;

    # Seek to head
    seek( FH, 0, SEEK_SET );
}

#-----------------------------------------------------------#

sub _unlock {
    my $self = shift;

    flock( FH, LOCK_UN );

    $self->{'LOCK'} = 0;
}

#-----------------------------------------------------------#

sub _open {
    my $self = shift;

    if ( $self->{'OPEN'} > 0 ) {
        $self->{'OPEN'}++;
        $self->_lock();
        return;
    }

    my $passwdFile = $self->{'PASSWD'};

    if ( $self->{READONLY} ) {
        if ( !open( FH, $passwdFile ) ) {
            $self->{'ERROR'} =
              __PACKAGE__ . "::fetchPass - Cannot open $passwdFile: $!";
            croak $self->error();
        }
    }
    else {
        if ( !open( FH, "+<$passwdFile" ) ) {
            $self->{'ERROR'} =
              __PACKAGE__ . "::fetchPass - Cannot open $passwdFile: $!";
            croak $self->error();
        }
    }

    binmode(FH);
    $self->{'OPEN'}++;
    $self->_lock() unless $self->{READONLY};    # No lock on r/o
}

#-----------------------------------------------------------#

sub _close {
    my $self = shift;
    $self->_unlock() unless $self->{READONLY};

    $self->{'OPEN'}--;

    if ( $self->{'OPEN'} > 0 ) { return; }

    if ( !close(FH) ) {
        my $passwdFile = $self->{'PASSWD'};
        $self->{'ERROR'} =
          __PACKAGE__ . "::htDelete - Cannot close $passwdFile: $!";
        carp $self->error();
        return undef;
    }
}

#-----------------------------------------------------------#

1;

__END__