File Coverage

blib/lib/Algorithm/CouponCode.pm

Criterion	Covered	Total	%
statement	86	89	96.6
branch	21	24	87.5
condition	10	13	76.9
subroutine	12	12	100.0
pod	3	3	100.0
total	132	141	93.6

package Algorithm::CouponCode;
{
  $Algorithm::CouponCode::VERSION = '1.004';
}

=head1 NAME

Algorithm::CouponCode - Generate and validate 'CouponCode' strings

=cut

use 5.010;
use warnings;
use strict;


use Exporter     qw(import);
use Digest::SHA  qw(sha1);


our @EXPORT_OK   = qw(cc_generate cc_validate make_bad_regex);

my $sym_str      = '0123456789ABCDEFGHJKLMNPQRTUVWXY';
my @sym          = split //, $sym_str;
my $urandom_path = '/dev/urandom';
my $have_urandom = -r $urandom_path;
my $bad_regex    = make_bad_regex();


sub cc_generate {
    my %arg = @_;

    my $parts     = $arg{parts} || 3;
    my $plaintext = $arg{plaintext} // _random_plaintext();
    my $bad_words = $arg{bad_regex} || $bad_regex;
    my($sha1_hash, @code);

    RANDOM_HASH: {
        $sha1_hash = sha1($plaintext);
        my @bytes  = map { ord($_) & 31 } split //, $sha1_hash;
        TRY_PART: while(@code < $parts) {
            if(@bytes < 3) {
                $plaintext = $sha1_hash;
                redo RANDOM_HASH;
            }
            my $i    = @code + 1;
            my $str  = join '', map { $sym[shift @bytes] } (0, 1, 2);
            my $part = $str . _checkdigit_alg_1($str, $i);
            next TRY_PART if $part =~ $bad_words;
            next TRY_PART if _valid_when_swapped($part, $i);
            push @code, $part;
        }
    }

    return join '-', @code;
}


sub cc_validate {
    my %arg = @_;

    my $code   = $arg{code} or return;
    my $parts  = $arg{parts} // 3;

    $code =  uc($code);
    $code =~ s{[^0-9A-Z]+}{}g;
    $code =~ tr{OIZS}{0125};
    my(@parts) = $code =~ m{([0-9A-Z]{4})}g;
    return unless scalar(@parts) == $parts;

    foreach my $i (1..$parts) {
        my($str, $check) = $parts[$i - 1] =~ m{^(...)(.)};
        return unless $check eq _checkdigit_alg_1($str, $i);
    }
    return join '-', @parts;
}


sub make_bad_regex {
    my %arg = @_;

    my @word_list = _default_bad_word_list();
    if($arg{words}) {
        if($arg{mode} && $arg{mode} eq 'replace') {
            @word_list = @{ $arg{words} };
        }
        else {
            push @word_list, @{ $arg{words} };
        }
    }
    my $words = join '|', map {
        $_ = uc($_);
        s/[I1]/[I1]/g;
        s/[O0]/[O0]/g;
        s/[S5]/[S5]/g;
        s/[Z2]/[Z2]/g;
        s/[E3]/[E3]/g;
        s/[A4]/[A4]/g;
        $_;
    } @word_list;
    return qr{\A(?:$words)\z};
}


sub _default_bad_word_list {
    # Yay for rot13
    return map { my $w = $_; $w =~ tr/A-Z/N-ZA-M/; $w } qw{
        SHPX PHAG JNAX JNAT CVFF PBPX FUVG GJNG GVGF SNEG URYY ZHSS QVPX XABO
        NEFR FUNT GBFF FYHG GHEQ FYNT PENC CBBC OHGG SRPX OBBO WVFZ WVMM CUNG
    };
}


sub _random_plaintext {
    if($have_urandom) {
        open my $fh, '<', $urandom_path or die "open($urandom_path): $!";
        sysread $fh, my $buf, 8;
        return $buf;
    }
    else {
        return $$ . localtime() . rand();
    }
}


sub _checkdigit_alg_1 {
    my($data, $pos) = @_;
    my @char = split //, $data;

    my $check = $pos;
    foreach my $i (0..2) {
        my $k = index($sym_str, $char[$i]);
        $check = $check * 19 + $k;
    }
    return $sym[ $check % 31 ];
}


sub _valid_when_swapped {
    my($orig, $pos) = @_;

    my($a, $b, $c, $d) = split //, $orig;
    foreach my $code (
        "$b$a$c$d",
        "$a$c$b$d",
        "$a$b$d$c",
    ) {
        next if $code eq $orig;
        if(_checkdigit_alg_1(substr($code, 0, 3), $pos) eq substr($code, 3, 1)) {
            return 1;
        }
    }
    return 0;
}

1;
__END__