File Coverage

blib/lib/Authen/Htpasswd.pm

Criterion	Covered	Total	%
statement	111	130	85.3
branch	35	72	48.6
condition	9	21	42.8
subroutine	20	21	95.2
pod	7	7	100.0
total	182	251	72.5

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 Scalar::Util qw(blessed);

use vars qw{$VERSION $SUFFIX};

$VERSION = '0.171';
$VERSION = eval $VERSION;
$SUFFIX = '.new';

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

=head1 NAME

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

=head1 SYNOPSIS

    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";

=head1 DESCRIPTION

This module provides a convenient, object-oriented interface to Apache-style
F<.htpasswd> files.

It supports passwords encrypted via MD5, SHA1, and crypt, as well as plain
(cleartext) passwords.

Additional fields after username and password, if present, are accessible via
the C array.

=head1 METHODS

=head2 new

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

Creates an object for a given F<.htpasswd> file. Options:

=over 4

=item encrypt_hash

How passwords should be encrypted if a user is added or changed. Valid values are C, C,
C, and C. Default is C.

=item check_hashes

An array of hash methods to try when checking a password. The methods will be tried in the order
given. Default is C, C, C, C.

=back

=cut

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;
}

=head2 lookup_user

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

Returns an L object for the given user in the password file.

=cut

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;
}

=head2 all_users

    my @users = $pwfile->all_users;

=cut

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;
}

=head2 check_user_password

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

Returns whether the password is valid. Shortcut for
C<< $pwfile->lookup_user($username)->check_password($password) >>.

=cut

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);
}

=head2 update_user

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

Modifies the entry for a user saves it to the file. If the user entry does not
exist, it is created. The options in the second form are passed to L.

=cut

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);
}

=head2 add_user

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

Adds a user entry to the file. If the user entry already exists, an exception is raised.
The options in the second form are passed to L.

=cut

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);
}

=head2 delete_user

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

Removes a user entry from the file.

=cut

sub delete_user {
    my $self = shift;
    my $username = blessed($_[0]) && $_[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 blessed($_[0]) && $_[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;
    }
}

=head1 AUTHOR

David Kamholz C

Yuval Kogman

=head1 SEE ALSO

L.

=head1 COPYRIGHT & LICENSE

    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.

=cut

1;