File Coverage

blib/lib/String/MkPasswd.pm

Criterion	Covered	Total	%
statement	106	106	100.0
branch	32	40	80.0
condition	4	5	80.0
subroutine	16	16	100.0
pod	0	1	0.0
total	158	168	94.0

package String::MkPasswd;

use 5.006001;
use strict;
use base qw(Exporter);

use Carp qw(croak);

# Defaults.
use constant LENGTH		=> 9;
use constant MINNUM		=> 2;
use constant MINLOWER	=> 2;
use constant MINUPPER	=> 2;
use constant MINSPECIAL	=> 1;
use constant DISTRIBUTE	=> "";
use constant FATAL		=> "";

# A few conveniences for dealing with homographs
use constant ALLOWAMBIGUOUS => 0;
use constant NOAMBIGUOUS    => 1;
our %IS_AMBIGUOUS = (
	'o' => 1, # easily confused with zero, especially when capitalized
	'0' => 1, # easily confused with capital O
	'1' => 1, # easily confused for lower l or capital I
	'i' => 1, # especially when capitalized, easily confused for 1, lower l, or pipe
	'l' => 1, # easily confused for 1 or capital I
	'v' => 1, # a pair of these looks like w
	'w' => 1, # one of these looks like a pair of v's
	'c' => 1, # can be confused for a paren
	'|' => 1, # easily confused with 1, lower l, or capital I
	'_' => 1, # easily confused with dash
	'-' => 1, # easily confused with underscore
	'.' => 1, # easily confused with comma
	',' => 1, # easily confused with period
	':' => 1, # easily confused with colon
	';' => 1, # easily confused with semicolon
	']' => 1, # easily confused with } and )
	'[' => 1, # easily confused with { and (
	'(' => 1, # easily confused with { and [
	')' => 1, # easily confused with } and ]
	'{' => 1, # easily confused with ( and [
	'}' => 1, # easily confused with ) and ]
);

our %EXPORT_TAGS = (
	all	=> [ qw(mkpasswd) ],
);
our @EXPORT_OK = @{ $EXPORT_TAGS{all} };
our $VERSION = "0.05";
our $FATAL = "";

my %keys = (
	ALLOWAMBIGUOUS() => {
		dist => {
			lkeys	=> [ qw(q w e r t a s d f g z x c v b) ],
			rkeys	=> [ qw(y u i o p h j k l n m) ],
			lnums	=> [ qw(1 2 3 4 5 6) ],
			rnums	=> [ qw(7 8 9 0) ],
			lspec	=> [ qw(! @ $ %), "#" ],
			rspec	=> [
				qw(^ & * ( ) - = _ + [ ] { } \ | ; : ' " < > . ? /), ","
			],
		},
		undist => {
			lkeys	=> [
				qw(a b c d e f g h i j k l m n o p q r s t u v w x y z)
			],
			lkeys => [
				qw(a b c d e f g h i j k l m n o p q r s t u v w x y z)
			],
			rkeys	=> [
				qw(a b c d e f g h i j k l m n o p q r s t u v w x y z)
			],
			lnums	=> [ qw(0 1 2 3 4 5 6 7 8 9) ],
			rnums	=> [ qw(0 1 2 3 4 5 6 7 8 9) ],
			lspec	=> [
				qw(! @ $ % ~ ^ & * ( ) - = _ + [ ] { } \ | ; : ' " < > . ? /),
				"#", ","
			],
			rspec	=> [
				qw(! @ $ % ~ ^ & * ( ) - = _ + [ ] { } \ | ; : ' " < > . ? /),
				"#", ","
			],
		},
	}
);


# Build unambiguous (NOAMBIGUOUS) keys entries from the ALLOWAMBIGUOUS set
foreach my $distribution ( keys %{ $keys{ ALLOWAMBIGUOUS() } } ) {
	foreach my $block ( keys %{ $keys{ ALLOWAMBIGUOUS() }->{ $distribution } } ) {
		$keys{ NOAMBIGUOUS() }->{ $distribution }->{ $block } = [
			grep
				{ ! $IS_AMBIGUOUS{ $_ } }
				@{ $keys{ ALLOWAMBIGUOUS() }->{ $distribution }->{ $block } }
		];
	}
}

sub mkpasswd {
	my $class	= shift if UNIVERSAL::isa $_[0], __PACKAGE__;
	my %args	= @_;

	# Configuration.
	my $length		= $args{"-length"}     || LENGTH;
	my $minnum		= defined $args{"-minnum"}
		? $args{"-minnum"}
		: MINNUM;
	my $minlower	= defined $args{"-minlower"}
		? $args{"-minlower"}
		: MINLOWER;
	my $minupper	= defined $args{"-minupper"}
		? $args{"-minupper"}
		: MINUPPER;
	my $minspecial	= defined $args{"-minspecial"}
		? $args{"-minspecial"}
		: MINSPECIAL;
	my $distribute	= defined $args{"-distribute"}
		? $args{"-distribute"}
		: DISTRIBUTE;
	my $ambiguousity = defined $args{"-noambiguous"}
		? $args{"-noambiguous"}
		: ALLOWAMBIGUOUS;
	my $fatal		= defined $args{"-fatal"}
		? $args{"-fatal"}
		: FATAL;

	if ( $minnum + $minlower + $minupper + $minspecial > $length ) {
		if ( $fatal || $FATAL ) {
			croak "Impossible to generate $length-character password with "
					. "$minnum numbers, $minlower lowercase letters, "
					. "$minupper uppercase letters and $minspecial special "
					. "characters";
		} else {
			return;
		}
	}

	# If there is any underspecification, use additional lowercase letters.
	$minlower = $length - ($minnum + $minupper + $minspecial);

	# Choose left or right starting hand.
	my $initially_left = my $isleft = int rand 2;

	# Select distribution of keys.
	my $lkeys = $distribute ? $keys{$ambiguousity}{dist}{lkeys} : $keys{$ambiguousity}{undist}{lkeys};
	my $rkeys = $distribute ? $keys{$ambiguousity}{dist}{rkeys} : $keys{$ambiguousity}{undist}{rkeys};
	my $lnums = $distribute ? $keys{$ambiguousity}{dist}{lnums} : $keys{$ambiguousity}{undist}{lnums};
	my $rnums = $distribute ? $keys{$ambiguousity}{dist}{rnums} : $keys{$ambiguousity}{undist}{rnums};
	my $lspec = $distribute ? $keys{$ambiguousity}{dist}{lspec} : $keys{$ambiguousity}{undist}{lspec};
	my $rspec = $distribute ? $keys{$ambiguousity}{dist}{rspec} : $keys{$ambiguousity}{undist}{rspec};

	# Generate password.

	my @lpass = (undef) x $length;	# password chars typed by left hand
	my @rpass = (undef) x $length;	# password chars typed by right hand
	my ($left, $right);

	($left, $right) = &_psplit($minnum, \$isleft);
	for ( my $i = 0; $i < $left; $i++ ) {
		&_insert(\@lpass, $lnums->[rand @$lnums]);
	}
	for ( my $i = 0; $i < $right; $i++ ) {
		&_insert(\@rpass, $rnums->[rand @$rnums]);
	}

	($left, $right) = &_psplit($minlower, \$isleft);
	for ( my $i = 0; $i < $left; $i++ ) {
		&_insert(\@lpass, $lkeys->[rand @$lkeys]);
	}
	for ( my $i = 0; $i < $right; $i++ ) {
		&_insert(\@rpass, $rkeys->[rand @$rkeys]);
	}

	($left, $right) = &_psplit($minupper, \$isleft);
	for ( my $i = 0; $i < $left; $i++ ) {
		&_insert(\@lpass, uc $lkeys->[rand @$lkeys]);
	}
	for ( my $i = 0; $i < $right; $i++ ) {
		&_insert(\@rpass, uc $rkeys->[rand @$rkeys]);
	}

	($left, $right) = &_psplit($minspecial, \$isleft);
	for ( my $i = 0; $i < $left; $i++ ) {
		&_insert(\@lpass, $lspec->[rand @$lspec]);
	}
	for ( my $i = 0; $i < $right; $i++ ) {
		&_insert(\@rpass, $rspec->[rand @$rspec]);
	}

	# Merge results together.
	my $lpass = join "", map { defined $_ ? $_ : () } @lpass;
	my $rpass = join "", map { defined $_ ? $_ : () } @rpass;

	return $initially_left ? "$lpass$rpass" : "$rpass$lpass";
}

# Insert $char into password at a random position, thereby spreading the
# different kinds of characters throughout the password.
sub _insert {
	my $pass	= shift;	# ref = ARRAY
	my $char	= shift;

	my $pos;
	do {
		$pos = int rand(1 + @$pass);
	} while ( defined $pass->[$pos] );

	$pass->[$pos] = $char;
}

# Given a size, distribute between left and right hands, taking into account
# where we left off.
sub _psplit {
	my $max		= shift;
	my $isleft	= shift;	# ref = SCALAR

	my ($left, $right);

	if ( $$isleft ) {
		$right = int($max / 2);
		$left = $max - $right;
		$$isleft = !($max % 2);
	} else {
		$left = int($max / 2);
		$right = $max - $left;
		$$isleft = !($max % 2);
	}

	return ($left, $right);
}

1;

__END__