Add TrackingNumber validator (with tests and doc)

MANIFEST

@@ -20,6 +20,7 @@ lib/Data/Transpose/Validator/PasswordPolicy.pm
 lib/Data/Transpose/Validator/Set.pm
 lib/Data/Transpose/Validator/String.pm
 lib/Data/Transpose/Validator/Subrefs.pm
+lib/Data/Transpose/Validator/TrackingNumber.pm
 lib/Data/Transpose/Validator/URL.pm
 Makefile.PL
 MANIFEST			This list of files
@@ -48,6 +49,7 @@ t/transpose-validation-classes.t
 t/transpose-validation-datetime.t
 t/transpose-validation-forms.t
 t/transpose-validation-objects.t
+t/transpose-validation-tracking-numbers.t
 t/transpose-validation.t
 t/transpose-validator-field.t
 t/transpose-validator-options.t

Makefile.PL

@@ -24,6 +24,7 @@ WriteMakefile(
         'Business::CreditCard' => 0.32,
         'Moo' => 0,
         'MooX::Types::MooseLike' => 0,
+        'Type::Tiny' => 0,
         'namespace::clean' => 0,
     },
     META_MERGE        => {

lib/Data/Transpose/Validator/TrackingNumber.pm

@@ -0,0 +1,98 @@
+package Data::Transpose::Validator::TrackingNumber;
+
+use strict;
+use warnings;
+use Moo;
+use Types::Standard qw/ArrayRef Str/;
+extends 'Data::Transpose::Validator::Base';
+
+=head1 NAME
+
+Data::Transpose::Validator::TrackingNumber - Validator for Tracking numbers
+
+=head1 SYNOPSIS
+
+  my $v = Data::Transpose::Validator::TrackingNumber->new;
+  ok ($v->is_valid('123456789012'));
+
+=head1 DESCRIPTION
+
+This module validates the tracking numbers for commonly used carriers.
+
+=head1 ACCESSORS
+
+=head2 carriers
+
+An arrayref of carriers. See "SUPPORTED CARRIERS" for the list of
+available values.
+
+Default to all known carriers.
+
+=head1 METHODS
+
+=head2 is_valid($number)
+
+This is the main method and returns the validated number if valid,
+false otherwise.
+
+=head1 SUPPORTED CARRIERS
+
+=over 4
+
+=item DHL
+
+=item UPS
+
+=item Hermes
+
+=item DPD
+
+=back
+
+=cut
+
+has carriers => (is => 'rw',
+                 isa => ArrayRef[Str],
+                 default => sub { [qw/UPS Hermes DPD DHL/] });
+
+sub is_valid {
+    my ($self, $string) = @_;
+    $self->reset_errors;
+    unless (defined $string) {
+        $self->error(["undefined", "String is undefined"]);
+        return 0;
+    }
+    my $valid;
+
+    my %checks = (
+                  dpd => qr/([0-9A-Za-z]{14})/x,
+                  ups => qr/([0-9A-Za-z]{18})/x,
+                  hermes => qr/([0-9A-Za-z]{14})/x,
+                  dhl => qr/(
+                                [0-9]{12} |
+                                [0-9a-zA-Z]{16} |
+                                [0-9a-zA-Z]{20}
+                            )/x,
+                 );
+  CARRIER:
+    foreach my $carrier (@{$self->carriers}) {
+        my $name = lc($carrier);
+        $name =~ s/\s/_/g;
+        my $re = $checks{$name} or die "Unknown carrier $carrier";
+        if ($string =~ m/\A$checks{$name}\z/) {
+            $valid = $1;
+            last CARRIER;
+        }
+    }
+    if ($valid) {
+        return $valid;
+    }
+    else {
+        $self->error(["notrackingnumber",
+                      "Tracking number is not valid for " . join(' ', @{$self->carriers})
+                     ]);
+        return undef;
+    }
+}
+
+1;

t/transpose-validation-tracking-numbers.t

@@ -0,0 +1,79 @@
+#!perl
+
+use strict;
+use warnings;
+use Test::More tests => 86;
+use Data::Transpose::Validator::TrackingNumber;
+use Data::Transpose::Validator;
+use Data::Dumper;
+
+my $v = Data::Transpose::Validator::TrackingNumber->new(carriers => [qw/DHL/]);
+my @good = (qw/123456789012
+               123456789012abcd
+               123456789012abcdefgh
+              /);
+my @bad = (qw/1234
+              1234567890123
+              1234567a9012
+              123456789012abc=
+              *23456789012abcdefgh
+              461363/,
+           '=a134!@$');
+
+foreach my $n (@good) {
+    ok($v->is_valid($n), "$n is valid");
+    ok(!$v->error, "no error");
+}
+foreach my $n (@bad) {
+    ok(!$v->is_valid($n), "$n is not valid");
+    ok($v->error, "has error") and diag Dumper($v->error);
+}
+
+foreach my $n (@good) {
+    my $dtv = Data::Transpose::Validator->new();
+    $dtv->prepare(tracking_number => { validator => {
+                                                     class => "TrackingNumber",
+                                                     options => { carriers => [qw/DHL UPS/] },
+                                                    }
+                                     });
+    my $form = { tracking_number => $n };
+    my $clean = $dtv->transpose($form);
+    ok $clean;
+    is_deeply($clean, { tracking_number => $n });
+}
+foreach my $n (@bad) {
+    my $dtv = Data::Transpose::Validator->new();
+    $dtv->prepare(tracking_number => { validator => {
+                                                     class => "TrackingNumber",
+                                                     options => { carriers => [qw/DHL UPS DPD/] },
+                                                    }
+                                     });
+    my $form = { tracking_number => $n };
+    my $clean = $dtv->transpose($form);
+    ok !$clean;
+    ok($dtv->errors, "Errors found:" . $dtv->packed_errors);
+    like $dtv->packed_errors, qr{dhl}i;
+    unlike $dtv->packed_errors, qr{hermes}i;
+}
+
+my $vstrict = Data::Transpose::Validator::TrackingNumber->new(carriers => [qw/UPS/]);
+
+foreach my $n (@good, @bad) {
+    ok(!$vstrict->is_valid($n), "$n is not valid");
+    ok($v->error, "has error") and diag Dumper($v->error);
+}
+
+my %carriers = (
+                dhl    => 'L2345678901234567890',
+                ups    => 'L23456789012345678',
+                hermes => 'L2345678901234',
+                dpd    => 'L2345678901234',
+               );
+foreach my $carrier (keys %carriers) {
+    my $validator = Data::Transpose::Validator::TrackingNumber->new(carriers => [uc($carrier)]);
+    ok $validator->is_valid($carriers{$carrier}),
+      "$carriers{$carrier} is valid for $carrier";
+    ok !$validator->is_valid($carriers{$carrier} . 'x'),
+      "$carriers{$carrier}x is not valid for $carrier";
+    ok($validator->error, "has error") and diag Dumper($validator->error);
+}