File Coverage

lib/CtrlO/Crypt/XkcdPassword.pm

Criterion	Covered	Total	%
statement	96	96	100.0
branch	20	20	100.0
condition	11	13	84.6
subroutine	20	20	100.0
pod	2	2	100.0
total	149	151	98.6

package CtrlO::Crypt::XkcdPassword;
use strict;
use warnings;

# ABSTRACT: Yet another xkcd style password generator

our $VERSION = '1.009'; # VERSION

use Carp qw(croak);
use Crypt::Rijndael;
use Crypt::URandom;
use Data::Entropy qw(with_entropy_source);
use Data::Entropy::Algorithms qw(rand_int pick_r shuffle_r choose_r);
use Data::Entropy::RawSource::CryptCounter;
use Data::Entropy::Source;
use Data::Handle;
use Module::Runtime qw(use_module);

use base 'Class::Accessor::Fast';

__PACKAGE__->mk_accessors(qw(entropy wordlist language _list _pid));


sub new {
    my ( $class, %args ) = @_;

    my %object;

    # init the word list
    my @list;
    if ( $args{wordlist} ) {
        $object{wordlist} = $args{wordlist};
    }
    else {
        my $lang = lc( $args{language} || 'en-GB' );
        $lang =~ s/-/_/g;
        $object{wordlist} = 'CtrlO::Crypt::XkcdPassword::Wordlist::' . $lang;
    }

    if ( -r $object{wordlist} ) {
        open( my $fh, '<:encoding(UTF-8)', $object{wordlist} );
        while ( my $word = <$fh> ) {
            chomp($word);
            $word =~ s/\s//g;
            push( @list, $word );
        }
        $object{_list} = \@list;
    }
    elsif ( $object{wordlist} =~ /::/ ) {
        eval { use_module( $object{wordlist} ); };
        if ($@) {
            croak( "Cannot load word list module " . $object{wordlist} );
        }
        my $pkg = $object{wordlist};
        no strict 'refs';

        # do we have a __DATA__ section, indication a subclass of https://metacpan.org/release/WordList
        my $handle = eval { Data::Handle->new($pkg) };
        if ($handle) {
            $object{_list} = [ map { s/\n//g; chomp; $_ } $handle->getlines ];
        }

        # do we have @Words, indication Crypt::Diceware
        elsif ( @{"${pkg}::Words"} ) {
            $object{_list} = \@{"${pkg}::Words"};
        }
        else {
            croak("Cannot find word list in $pkg");
        }
    }
    else {
        croak(    'Invalid word list: >'
                . $object{wordlist}
                . '<. Has to be either a Perl module or a file' );
    }

    # poor person's lazy_build
    $object{entropy} = $args{entropy} || $class->_build_entropy;
    $object{_pid} = $$;

    return bless \%object, $class;
}

sub _build_entropy {
    my $class = shift;
    return Data::Entropy::Source->new(
        Data::Entropy::RawSource::CryptCounter->new(
            Crypt::Rijndael->new( Crypt::URandom::urandom(32) )
        ),
        "getc"
    );
}


sub xkcd {
    my ( $self, %args ) = @_;
    if ( $self->_pid != $$ ) {
        $self->_reinit_after_fork;
    }

    foreach my $key (keys %args) {
        croak "Invalid key [$key] received."
            unless ($key eq 'words' || $key eq 'digits');

        if (defined $args{$key} && ($args{$key} !~ /^[0-9]+$/)) {
            croak "Invalid value [$args{$key}] for key [$key].";
        }
    }

    my $word_count = $args{words} || 4;

    my $words = with_entropy_source(
        $self->entropy,
        sub {
            shuffle_r( choose_r( $word_count, $self->_list ) );
        }
    );

    if ( my $d = $args{digits} ) {
        push(
            @$words,
            sprintf(
                '%0' . $d . 'u',
                with_entropy_source(
                    $self->entropy, sub { rand_int( 10**$d ) }
                )
            )
        );
    }
    return join( '', map {ucfirst} @$words );
}

sub _reinit_after_fork {
    my $self = shift;
    $self->_pid($$);
    $self->entropy( $self->_build_entropy );
}

'correct horse battery staple';

__END__