# Bruterate.pm      brute force list iterator generator     03jul09waw

package Bruterate; {  # begin Bruterate private package closure

use warnings FATAL => 'all';
# use warnings;
use strict;

use Exporter;
our @ISA = qw(Exporter);

our $VERSION = '0.1.0';

our @EXPORT    =   ();           # default exports
our @EXPORT_OK = qw(bruterate);  # optional exports

sub Iterator (&) { return $_[0] }  # syntactic sugar per hop


# return iterator that will iterate over all elements of a set
# of referenced arrays.  referenced arrays that are empty are
# ignored.  elements in array referenced by right-most argument
# in call to function are iterated most rapidly, elements in
# array referenced by left-most argument least rapidly.

sub bruterate {

    # ignore any referenced arrays that are empty.
    my @ar_non_empty = grep @$_ > 0, @_;

    # no referenced non-empty arrays to iterate over.
    return Iterator { return } unless @ar_non_empty;

    # at least one referenced non-empty array to iterate over.
    my @items = @{ shift @ar_non_empty };
    my $item  = $[;

    # is this the rightmost referenced non-empty array to be iterated?
    @ar_non_empty == 0 and return Iterator {
        $item = $[, return if $item > $#items;
        return [ $items[$item++] ];
        };

    # there are more referenced arrays (to the right) to iterate.
    my $cr_get_rightward_items = bruterate(@ar_non_empty);
    return Iterator {
        my $ar_rightward = $cr_get_rightward_items->();
        return [ $items[$item], @$ar_rightward ] if $ar_rightward;
        ++$item;
        $item = $[, return if $item > $#items;
        return [ $items[$item], @{ $cr_get_rightward_items->() } ];
        };

    }  # end sub bruterate()


}  # end Bruterate private package closure


1;
[download]

# crack_pw_2.pl                                             08jul09waw

use warnings;
use strict;

use Bruterate qw(bruterate);


# guess that pw is probably:
#   1. english or english-like word, so all alphas;
#   2. english or english-like word, so starts with consonant-vowel;
#   3. lower case if an alpha (people are lazy).

my @alphas   = ('a' .. 'z', 'A' .. 'Z');  # lower case first!
my @digits   = ('0' .. '9');
my @oddballs = (qw(! @ $ % ^ & *), '#', ' ');

my @vowels = qw(a e i o u A E I O U);

my $rx_consonants = qr{ [^@{[ join '', @vowels ]}] }xms;
my @consonants    = ( grep /$rx_consonants/, @alphas );

my $char1    = [ @consonants, @vowels,     @digits, @oddballs ];
my $char2    = [ @vowels,     @consonants, @digits, @oddballs ];
my $any_char = [ @alphas,                  @digits, @oddballs ];

# this contrary, 'worst guess' order will try vowel-vowel alpha
# combinations first (and upper case, too), but only after trying
# oddballs, then digits.
my $contrary = [ reverse @$char1 ];

my $reti4 = bruterate(
    ($contrary) x 4  # worst 4 char guess
    );

my $iter1 = bruterate($any_char);                            # 1 char
my $iter2 = bruterate($char1, $any_char);                    # 2 chars
my $iter3 = bruterate($char1, $char2, $any_char);            # 3 chars
my $iter4 = bruterate($char1, $char2, $any_char, $any_char); # 4 chars

my $password  = shift or die "usage: perl $0 password \n";
my $tries     = 0;
my $starttime = time();

# work through iterators of increasing length trying to guess
# password by brute force.
LEN:
for my $iter ($iter1, $iter2, $iter3, $iter4) {

    GUESS:
    while (my $ar_guess_chars = $iter->()) {

        ++$tries;

        my $guess = join '', @$ar_guess_chars;

        next GUESS if $guess ne $password;

        my $elapsed = time() - $starttime;
        print "found password '$guess' ",
              "in $elapsed seconds with $tries tries \n";
        exit;

        }  # end while GUESS

    }  # end for LEN

my $elapsed = time() - $starttime;
die "FAILED to find password '$password' ",
    "in $elapsed seconds with $tries tries \n";
[download]