view release on metacpan or  search on metacpan

lib/Validate/CodiceFiscale.pm  view on Meta::CPAN

package Validate::CodiceFiscale;
use v5.24;
use Carp;
use experimental qw< signatures >;
{ our $VERSION = '0.004' }

use List::Util 'sum';
use Time::Local 'timegm';
use JSON::PP 'decode_json';
use Exporter 'import';

our @EXPORT_OK = qw< assert_valid_cf decode_cf is_valid_cf validate_cf r >;

# PUBLIC interface

sub assert_valid_cf ($cf, %options) {
   my $errors = validate_cf($cf, all_errors => 0, %options) or return;

   defined(my $ecb = $options{on_error})
     or croak join ', ', $errors->@*;

   my $exception = $ecb->($errors->@*);
   die $exception;    # just as a fallback, $ecb might throw by itself
} ## end sub assert_valid_cf

sub decode_cf ($cf, %options) {
   return _decode_and_validate($cf, %options, all_errors => 1);
}

sub is_valid_cf ($cf, %options) {
   my $error = 0;
   _validate_cf($cf, $options{data}, sub { $error = 1; return 0 });
   return !$error;
}

sub validate_cf ($cf, %options) {
   my $r = _decode_and_validate($cf, %options);
   my $errors = $r->{errors} // [];
   return scalar($errors->@*) ? $errors : undef;
} ## end sub validate_cf

# The following is useful for one-lines:
#
#     $ perl -MValidate::CodiceFiscale=r -er bcadfe88a48h501p
#
sub r (@args) {
   @args = @ARGV unless @args;
   my $i = 0;
   my $n = 0;
   for my $cf (@ARGV) {
      if (my $errors = validate_cf($cf)) {
         say "$i not ok - " . join(', ', $errors->@*);
         ++$n;
      }
      else {
         say "$i ok - $cf";
      }
      ++$i;
   } ## end for my $cf (@ARGV)
   return $n ? 1 : 0;
} ## end sub r

exit r(@ARGV) unless caller();    # modulino

# PRIVATE interface

sub _decode_and_validate ($cf, %options) {
   my $data = $options{data} // undef;

   my $collect_all_errors = $options{all_errors} // 1;
   my @errors;
   my $callback = sub ($msg) {
      push @errors, $msg;
      return $collect_all_errors;
   };

   my $r = _validate_cf($cf, $data, $callback);
   $r->{errors} = \@errors;
   return $r;
}

sub _validate_cf ($cf, $data, $cb) {
   state $consonant = qr{(?imxs:[BCDFGHJKLMNPQRSTVWXYZ])};
   state $vowel     = qr{(?imxs:[AEIOU])};
   state $namish    = qr{(?imxs:
         $consonant  $consonant  $consonant  # includes CCX, CXX, XXX
      |  $consonant  $consonant  $vowel
      |  $consonant  $vowel      $vowel
      |  $consonant  $vowel      X
      |  $vowel      $vowel      $vowel
      |  $vowel      $vowel      X
      |  $vowel      X           X
   )};
   state $digitish = qr{(?imxs:[0-9LMNPQRSTUV])};

   if (length($cf) != 16) {
      $cb->('invalid length');
      return {};
   }

   $cf = uc($cf);
   my %portions = (
      surname  => substr($cf, 0,  3),
      name     => substr($cf, 3,  3),
      date     => substr($cf, 6,  5),
      place    => substr($cf, 11, 4),