File Coverage

lib/Crypt/Password.pm

Criterion	Covered	Total	%
statement	57	77	74.0
branch	15	30	50.0
condition	5	12	41.6
subroutine	14	17	82.3
pod	3	9	33.3
total	94	145	64.8

package Crypt::Password;
use Exporter 'import';
@EXPORT = (qw'password crypt_password check_password');
our $VERSION = "0.28";
our $TESTMODE = 0;

use Carp;

# from libc6 crypt/crypt-entry.c
our %alg_to_id = (
    md5 => '1',
    blowfish => '2',
    sha256 => '5',
    sha512 => '6',
);
our %id_to_alg = reverse %alg_to_id;

# switches off embodying crypted-looking passwords, like crypt_password()
our $definitely_crypt;

our $crypt_flav = do {
    $^O =~ /^MSWin|cygwin/ ? 'windows' : do {
    $_ = (`man crypt`)[-1];
    !defined($_) ? 'freesec' :
    /DragonFly/ ? 'dragonflybsd' :
    /NetBSD/ ? 'netbsd' :
    /OpenBSD/ ? 'openbsd' :
    /FreeBSD/ ? do {
        /FreeBSD ([\d\.]+)/; # seems 9.0 starts supporting Modular format
        $1 >= 9 ? 'freebsd' : 'freebsd_lt_9'
    } :
    /MirOS/ ? 'windows' :
    /FreeSec/ ? 'freesec' :
                'glib'
    }
};
our $flav_dispatch = {
    glib => {
        looks_crypted => sub {
            return $_[0] =~ m{^\$.+\$.*\$.+$}
        },
        salt_provided => sub {
            return shift;
        },
        extract_salt => sub {
            return (split /\$/, $_[0])[2]
        },
        format_crypted => sub {
            return shift;
        },
        form_salt => sub {
            my ($s, $self) = @_;
            unless ($s =~ /^\$.+\$.*(\$.+)?$/) {
                if ($self->{algorithm_id}) {
                    # put algorithm id in the salt
                    $s =~ s/^/\$$self->{algorithm_id}\$/;
                }
                else {
                    # ->check(), alg and salt from ourselves, the rest be ignored
                    $s = "$self";
                }
            }
            $s = $1 if $s =~ /^(\$.+?\$.+?)\$/;
            return $s;
        },
        default_algorithm => sub {
            return "sha256";
        },
    },
    freesec => { # {{{
        looks_crypted => sub {
            # with our dollar-signs added in around the salt
            return $_[0] =~ /^\$(_.{8}|.{2})\$ (.{11})?$/x
        },
        salt_provided => sub {
            my $provided = shift;
            # salt must be 2 or 8 or entropy leaks in around the side
            # I am serious
            if ($provided =~    m/^\$(_.{8}|_?.{2})\$(.{11})?$/
                || $provided =~ m/^  (_.{8}|_?.{2})  (.{11})?$/x) {
                $provided = $1;
            }
            if ($provided =~ /^_..?$/) {
                croak "Bad salt input:"
                    ." 2-character salt cannot start with _";
            }
            $provided =~ s/^_//;
            if ($provided !~ m/^(.{8}|.{2})$/) {
                croak "Bad salt input:"
                    ." salt must be 2 or 8 characters long";
            }
            return $provided;
        },
        extract_salt => sub {
            $_[0] =~ /^\$(_.{8}|.{2})\$ (.{11})?$/x;
            my $s = $1;
            $s || croak "Bad crypted input:"
                    ." salt must be 2 or 8 characters long";
            $s =~ s/^_//;
            return $s
        },
        format_crypted => sub {
            my $crypt = shift;
            # makes pretty ambiguous crypt strings, lets add some dollar signs
            $crypt =~ s/^(_.{8}|..)(.{11})$/\$$1\$$2/
                || croak "failed to understand Extended-format crypt: '$crypt'";
            return $crypt;
        },
        form_salt => sub {
            my ($s) = @_;
            if (length($s) == 8) {
                $s = "_$s"
            }
            return $s;
        },
        default_algorithm => sub {
            return "DES" # does nothing
        },
    }, # }}}
    freebsd_lt_9 => {
        base => "freesec",
    },
    netbsd => {
        base => "freebsd_lt_9",
    },
    openbsd => {
        base => "freebsd_lt_9",
    },
    dragonflybsd => {
        base => "freebsd_lt_9",
    },
    freebsd => {
        base => "glib",
    },
    windows => {
        base => "freesec",
        looks_crypted => sub {
            return $_[0] =~ /^\$.+\$.+$/
        },
        salt_provided => sub {
            $_[0] =~ /^\$(.+?)\$.+/ ? $1 : $_[0]
        },
        extract_salt => sub {
            $_[0] =~ /^\$(.+?)\$.+$/; return $1
        },
        format_crypted => sub {
            my ($c, $i, $s) = @_;
            my ($sa, $sb) = $s =~ /^(..)(.+)$/;
            if ($TESTMODE) {
                warn "# '$c' ".($c =~ /^$sb(?!$sa)/?"":"!")."= first 2 chars of salt ($s";
            }
            # first two characters of salt is used, it seems
            $c =~ s/^$sa/\$$s\$/;
            return $1;
        },
        form_salt => sub {
            return shift;
            $_[0] =~ /^(\$|,|_)/ ? $_[0] : "_$_[0]"
        },
    },
};

sub flav {
    my $func = shift;
    my $flav = $flav_dispatch->{$crypt_flav} || die;
    unless (exists $flav->{$func}) {
        if (exists $flav->{base}) {
            local $crypt_flav = $flav->{base};
            return flav($func, @_);
        }
        die "no $func handler for (crypt flavour: $crypt_flav)";
    }
    return $flav->{$func}->(@_);
}

sub new {
    shift;
    password(@_);
}

sub password {
    return _password(@_)->{crypted}
}

sub crypt_password {
    local $definitely_crypt = 1;
    return password(@_);
}

sub check_password {
    my ($saved, $wild) = @_;
    return $saved eq crypt_password($wild, $saved);
}

sub _password {
    my $self = bless {}, __PACKAGE__;

    $self->input(shift);

    unless ($self->{crypted}) {
        $self->salt(shift);

        $self->algorithm(shift);

        $self->crypt();
    }

    $self;
}

sub crypt {
    my $self = shift;

    $self->{crypted} ||= $self->_crypt;

    return "$self->{crypted}";
}

sub input {
    my $self = shift;
    $self->{input} = shift;
    if (!$definitely_crypt && $self->_looks_crypted($self->{input})) {
        $self->{crypted} = delete $self->{input}
    }
}

sub _looks_crypted {
    my $self = shift;
    my $string = shift || return;

    return flav(looks_crypted => $string);
}

sub salt {
    my $self = shift;
    my $provided = shift;
    if (defined $provided) {
        $self->{salt} = flav(salt_provided => $provided);
    }
    else {
        return $self->{salt} if defined $self->{salt};
        return $self->{salt} = do {
            if ($self->{crypted}) {
                return flav(extract_salt => $self->{crypted});
            }
            else {
                $self->_invent_salt()
            }
        };
    }
}

sub algorithm {
    my $self = shift;
    $alg = shift;
    if ($alg) {
        $alg =~ s/^\$?(.+)\$?$/$1/;
        if (exists $alg_to_id{lc $alg}) {
            $self->{algorithm_id} = $alg_to_id{lc $alg};
            $self->{algorithm} = lc $alg;
        }
        else {
            # $alg will be passed anyway, it may not be known to %id_to_alg
            $self->{algorithm_id} = $alg;
            $self->{algorithm} = $id_to_alg{lc $alg};
        }
    }
    elsif (!$self->{algorithm}) {
        $self->algorithm(flav("default_algorithm"));
    }
    else {
        $self->{algorithm}
    }
}

sub _crypt {
    my $self = shift;

    defined $self->{input} || croak "no input!";
    $self->{algorithm_id} || croak "no algorithm!";
    defined $self->{salt} || croak "invalid salt!";

    my $input = delete $self->{input};
    my $salt = $self->_form_salt();

    return _do_crypt($input, $salt);
}

sub _do_crypt {
    my ($input, $salt) = @_;
    my $crypt = CORE::crypt($input, $salt);
    $crypt = flav(format_crypted => $crypt, $input, $salt);
    warn "# $input $salt = $crypt\n" if $TESTMODE;
    return $crypt;
}

sub _form_salt {
    my $self = shift;
    my $s = $self->salt;
    croak "undef salt!?" unless defined $s;
    return flav(form_salt => $s, $self);
}

our @valid_salt = ( "/", ".", "a".."z", "A".."Z", "0".."9" );

sub _invent_salt {
    my $many = $_[1] || 8;
    join "", map { $valid_salt[rand(@valid_salt)] } 1..$many;
}

1;

__END__