package Algorithm::CouponCode;

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{

};

}

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;