Authen::Htpasswd - interface to read and modify Apache .htpasswd files

    my $pwfile = Authen::Htpasswd->new('user.txt', { encrypt_hash => 'md5' });

    # authenticate a user (checks all hash methods by default)
    if ($pwfile->check_user_password('bob', 'foo')) { ... }

    # modify the file (writes immediately)
    $pwfile->update_user('bob', $password, $info);
    $pwfile->add_user('jim', $password);
    $pwfile->delete_user('jim');

    # get user objects tied to a file
    my $user = $pwfile->lookup_user('bob');
    if ($user->check_password('vroom', [qw/ md5 sha1 /])) { ... } # only use secure hashes
    $user->password('foo'); # writes to file
    $user->set(password => 'bar', extra_info => 'editor'); # change more than one thing at once

    # or manage the file yourself
    my $user = Authen::Htpasswd::User->new('bill', { hashed_password => 'iQ.IuWbUIhlPE' });
    my $user = Authen::Htpasswd::User->new('bill', 'bar', 'staff', { encrypt_hash => 'crypt' });
    print PASSWD $user->to_line, "\n";

    my $pwfile = Authen::Htpasswd->new($filename, \%options);

    my $userobj = $pwfile->lookup_user($username);

    my @users = $pwfile->all_users;

    $pwfile->check_user_password($username,$password);

    $pwfile->update_user($userobj);
    $pwfile->update_user($username, $password[, @extra_info], \%options);

    $pwfile->add_user($userobj);
    $pwfile->add_user($username, $password[, @extra_info], \%options);

    $pwfile->delete_user($userobj);
    $pwfile->delete_user($username);

    Copyright (c) 2005 - 2007 the aforementioned authors.

    This program is free software; you can redistribute
    it and/or modify it under the same terms as Perl itself.

package Authen::Htpasswd;
use 5.005;
use strict;
use base 'Class::Accessor::Fast';
use Carp;
use IO::File;
use IO::LockedFile;
use Authen::Htpasswd::User;

use vars qw{$VERSION $SUFFIX};
BEGIN {
    $VERSION = '0.161';
    $SUFFIX = '.new';
}

__PACKAGE__->mk_accessors(qw/ file encrypt_hash check_hashes /);

sub new {
    my $class = shift;
    my $self  = ref $_[-1] eq 'HASH' ? pop @_ : {};
    $self->{file} = $_[0] if $_[0];
    croak "no file specified" unless $self->{file};
    if (!-e $self->{file}) {
        open my $file, '>', $self->{file} or die $!;
        close $file or die $!;
    }
    
    $self->{encrypt_hash} ||= 'crypt';        
    $self->{check_hashes} ||= [ Authen::Htpasswd::Util::supported_hashes() ];
    unless ( defined $self->{write_locking} ) {
        if ( $^O eq 'MSWin32' or $^O eq 'cygwin' ) {
            $self->{write_locking} = 0;
        } else {
            $self->{write_locking} = 1;
        }
    }
    
    bless $self, $class;
}

sub lookup_user {
    my ($self,$search_username) = @_;
    
    my $file = IO::LockedFile->new($self->file, 'r') or die $!;
    while (defined(my $line = <$file>)) {
        chomp $line;
        my ($username,$hashed_password,@extra_info) = split /:/, $line;
        if ($username eq $search_username) {
            $file->close or die $!;
            return Authen::Htpasswd::User->new($username,undef,@extra_info, {
                    file            => $self, 
                    hashed_password => $hashed_password,
                    encrypt_hash    => $self->encrypt_hash, 
                    check_hashes    => $self->check_hashes 
                });
        }
    }
    $file->close or die $!;
    return undef;
}

sub all_users {
    my $self = shift;

    my @users;
    my $file = IO::LockedFile->new($self->file, 'r') or die $!;
    while (defined(my $line = <$file>)) {
        chomp $line;
        my ($username,$hashed_password,@extra_info) = split /:/, $line;
        push(@users, Authen::Htpasswd::User->new($username,undef,@extra_info, {
                file => $self, 
                hashed_password => $hashed_password,
                encrypt_hash => $self->encrypt_hash, 
                check_hashes => $self->check_hashes 
            }));
    }
    $file->close or die $!;
    return @users;
}

sub check_user_password {
    my ($self,$username,$password) = @_;
    my $user = $self->lookup_user($username);
    croak "could not find user $username" unless $user;
    return $user->check_password($password);
}

sub update_user {
    my $self = shift;
    my $user = $self->_get_user(@_);
    my $username = $user->username;

    my ($old,$new) = $self->_start_rewrite;
    my $seen = 0;
    while (defined(my $line = <$old>)) {
        if ($line =~ /^\Q$username\E:/) {
            chomp $line;
            my (undef,undef,@extra_info) = split /:/, $line;
            $user->{extra_info} ||= [ @extra_info ] if scalar @extra_info;
            $self->_print( $new, $user->to_line . "\n" );
            $seen++;
        } else {
            $self->_print( $new, $line );
        }
    }
    $self->_print( $new, $user->to_line . "\n" ) unless $seen;
    $self->_finish_rewrite($old,$new);
}

sub add_user {
    my $self = shift;
    my $user = $self->_get_user(@_);
    my $username = $user->username;

    my ($old,$new) = $self->_start_rewrite;
    while (defined(my $line = <$old>)) {
        if ($line =~ /^\Q$username\E:/) {
            $self->_abort_rewrite($old,$new);
            croak "user $username already exists in " . $self->file . "!";
        }
        $self->_print( $new, $line );
    }
    $self->_print( $new, $user->to_line . "\n" );
    $self->_finish_rewrite($old,$new);
}

sub delete_user {
    my $self = shift;
    my $username = $_[0]->isa('Authen::Htpasswd::User') ? $_[0]->username : $_[0];

    my ($old,$new) = $self->_start_rewrite;
    while (defined(my $line = <$old>)) {
        next if $line =~ /^\Q$username\E:/;
        $self->_print( $new, $line );
    }
    $self->_finish_rewrite($old,$new);
}

sub _print {
    my ($self,$new,$string) = @_;
    if ( $self->{write_locking} ) {
        print $new $string;
    } else {
        $$new .= $string;
    }
}

sub _get_user {
    my $self = shift;
    return $_[0] if $_[0]->isa('Authen::Htpasswd::User');
    my $attr = ref $_[-1] eq 'HASH' ? pop @_ : {};
    $attr->{encrypt_hash} ||= $self->encrypt_hash;
    $attr->{check_hashes} ||= $self->check_hashes;
    return Authen::Htpasswd::User->new(@_, $attr);
}

sub _start_rewrite {
    my $self = shift;
    if ( $self->{write_locking} ) {
        my $old = IO::LockedFile->new($self->file, 'r+') or die $!;
        my $new = IO::File->new($self->file . $SUFFIX, 'w') or die $!;
        return ($old,$new);
    } else {
        my $old = IO::File->new( $self->file, 'r' ) or die $!;
        my $new = "";
        return ($old, \$new);
    }
}

sub _finish_rewrite {
    my ($self,$old,$new) = @_;
    if ( $self->{write_locking} ) {
        $new->close or die $!;
        rename $self->file . $SUFFIX, $self->file or die $!;
        $old->close or die $!;
    } else {
        $old->close or die $!;
        $old = IO::File->new( $self->file, 'w' ) or die $!;
        print $old $$new;
        $old->close or die $!;
    }
}

sub _abort_rewrite {
    my ($self,$old,$new) = @_;
    if ( $self->{write_locking} ) {
      $new->close;
      $old->close;
      unlink $self->file . $SUFFIX;
    } else {
      $old->close;
    }
}

1;