File Coverage

blib/lib/Validate/CodiceFiscale.pm

Criterion	Covered	Total	%
statement	211	227	92.9
branch	63	76	82.8
condition	39	44	88.6
subroutine	27	28	96.4
pod	5	5	100.0
total	345	380	90.7

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

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),
      checksum => substr($cf, 15, 1),
   );
   my $retval = {portions => \%portions};

   return $retval
     if $portions{name} !~ m{\A$namish\z}mxs
     && !$cb->('invalid name');

   return $retval
     if $portions{surname} !~ m{\A$namish\z}mxs
     && !$cb->('invalid surname');

   my ($y, $m, $d, $sex) = _expand_date($portions{date}, $data);
   $retval->@{qw< year month day sex >} = ($y, $m, $d, $sex);
   return $retval
     if !_is_valid_cf_date($y, $m, $d)
     && !$cb->('invalid birth date');

   my $date;
   $date = $retval->{date} = sprintf('%04d-%02d-%02d', $y, $m, $d)
     if defined($y);

   if (defined(my $p = _place_name_for($portions{place}, $date))) {
      $retval->{place} = $p;
   }
   else {
      return $retval unless $cb->('invalid birth place');
   }

   my $checksum = _cf_checksum($cf);
   return $retval
     if $checksum ne substr($cf, -1, 1)
     && !$cb->("invalid checksum (should be: $checksum)");

   return $retval unless $data;

   if (defined(my $surname = $data->{surname})) {
      return $retval
        if substr($cf, 0, 3) ne _compact_surname($surname)
        && !$cb->('surname mismatch');
   }
   if (defined(my $name = $data->{name})) {
      return $retval
        if substr($cf, 3, 3) ne _compact_name($name)
        && !$cb->('name mismatch');
   }
   if (defined(my $birthdate = $data->{date})) {
      my ($male, $female) = _compact_birthdates($birthdate);
      my $got = _normalized_birthdate(substr($cf, 6, 5));
      return $retval
           if ($got ne $male)
        && ($got ne $female)
        && !$cb->('birth date mismatch');
   } ## end if (defined(my $birthdate...))
   if (defined(my $sex = $data->{sex})) {
      my $got = _normalized_birthdate(substr($cf, 6, 5));
      my $day = substr($got, -2, 2) + 0;
      return $retval
        if ((lc($sex) eq 'm' && $day > 31)
         || (lc($sex) eq 'f' && $day < 41))
        && !$cb->('sex mismatch');
   } ## end if (defined(my $sex = ...))
   if (defined(my $place = $data->{place})) {
      my $got = $retval->{place} //
         _normalized_birthplace($portions{place});
      return $retval
        if fc($got) ne fc($place)
        && !$cb->('birth place mismatch');
   } ## end if (defined(my $place ...))

   return $retval;
} ## end sub _validate_cf

sub _cf_checksum ($cf) {
   state $odd_checksums = {
      0 => 1,
      1 => 0,
      2 => 5,
      3 => 7,
      4 => 9,
      5 => 13,
      6 => 15,
      7 => 17,
      8 => 19,
      9 => 21,
      A => 1,
      B => 0,
      C => 5,
      D => 7,
      E => 9,
      F => 13,
      G => 15,
      H => 17,
      I => 19,
      J => 21,
      K => 2,
      L => 4,
      M => 18,
      N => 20,
      O => 11,
      P => 3,
      Q => 6,
      R => 8,
      S => 12,
      T => 14,
      U => 16,
      V => 10,
      W => 22,
      X => 25,
      Y => 24,
      Z => 23,
     },
     my $even_checksums = {
      0 => 0,
      1 => 1,
      2 => 2,
      3 => 3,
      4 => 4,
      5 => 5,
      6 => 6,
      7 => 7,
      8 => 8,
      9 => 9,
      A => 0,
      B => 1,
      C => 2,
      D => 3,
      E => 4,
      F => 5,
      G => 6,
      H => 7,
      I => 8,
      J => 9,
      K => 10,
      L => 11,
      M => 12,
      N => 13,
      O => 14,
      P => 15,
      Q => 16,
      R => 17,
      S => 18,
      T => 19,
      U => 20,
      V => 21,
      W => 22,
      X => 23,
      Y => 24,
      Z => 25,
     };
   state $checksums_for = [$odd_checksums, $even_checksums];
   my @chars = split m{}mxs, substr($cf, 0, 15);    # no checksum
   my $sum = sum map { $checksums_for->[$_ % 2]{$chars[$_]} } 0 .. $#chars;
   chr(ord('A') + ($sum % 26));
} ## end sub _cf_checksum

sub _normalized_string ($string, @positions) {
   state $letters   = [qw< L M N P Q R S T U V >];
   state $digit_for = {map { $letters->[$_] => $_ } 0 .. $letters->$#*};
   for my $i (@positions) {
      my $current = substr($string, $i, 1);
      substr($string, $i, 1, $digit_for->{$current})
        if exists $digit_for->{$current};
   }
   return $string;
} ## end sub _normalized_string

sub _normalized_birthplace ($place) { _normalized_string($place, 1 .. 3) }
sub _normalized_birthdate ($date) { _normalized_string($date, 0, 1, 3, 4) }

sub _expand_date ($date, $opts) {
   state $mlf       = [split m{}mxs, 'ABCDEHLMPRST'];
   state $month_for = {map { $mlf->[$_] => $_ } 0 .. $mlf->$#*};

   $date = _normalized_birthdate($date);
   my ($y, $mc, $d) = $date =~ m{\A(\d\d)([ABCDEHLMPRST])(\d\d)\z}mxs
     or return;
   my $m = 1 + $month_for->{$mc};
   $_ += 0 for ($d, $y);
   my $sex = $d > 40 ? 'F' : 'M';
   $d -= 40 if $d > 40;

   # century: the initial digits of a year
   if (defined(my $years_baseline = ($opts // {})->{years_baseline})) {
      $y += $years_baseline;
   }
   else {    # whatever in the last 100 years
      my $this_year = 1900 + (localtime)[5];
      $y += 100 * int($this_year / 100);
      $y -= 100 if $y > $this_year;
   }

   return ($y, $m, $d, $sex);
} ## end sub _expand_date

sub _is_valid_cf_date ($y, $m, $d) {
   return !!(eval { timegm(30, 30, 12, $d, $m - 1, $y); 1 });
}

sub _compact_birthdates ($birthdate) {
   state $month_letter_for = ['', split m{}mxs, 'ABCDEHLMPRST'];
   my ($y, $m, $d) = split m{\D}mxs, $birthdate;
   ($y, $d) = ($d, $y) if $d > 31;
   $y %= 100;
   $m = $month_letter_for->[$m + 0];
   map { sprintf '%02d%s%02d', $y, $m, $_ } ($d, $d + 40);
} ## end sub _compact_birthdates

sub _compact_surname ($surname) {
   my ($cs, $vs) = _consonants_and_vowels($surname);
   my @retval = ($cs->@*, $vs->@*, ('X') x 3);
   return join '', @retval[0 .. 2];
}

sub _compact_name ($name) {
   my ($cs, $vs) = _consonants_and_vowels($name);
   splice $cs->@*, 1, 1 if $cs->@* > 3;
   my @retval = ($cs->@*, $vs->@*, ('X') x 3);
   return join '', @retval[0 .. 2];
} ## end sub _compact_name

sub _consonants_and_vowels ($string) {
   my (@consonants, @vowels);
   for my $char (grep { m{[A-Z]}mxs } split m{}mxs, uc($string)) {
      if   ($char =~ m{[AEIOU]}mxs) { push @vowels,     $char }
      else                          { push @consonants, $char }
   }
   return (\@consonants, \@vowels);
} ## end sub _consonants_and_vowels

sub _places {
   state $retval = do {
      local $/;
      binmode DATA, ':raw';
      (my $json = readline(DATA)) =~ s{\n+}{}gmxs;
      decode_json($json);
   };
}

sub _place_name_for ($place, $birthdate) {
   state $place_for = _places();
   my $record = $place_for->{_normalized_birthplace($place)} or return;
   return "[$record->[-1]{name}]" unless defined($birthdate);
   for my $candidate ($record->@*) {
      next if $birthdate gt $candidate->{end};
      last if $birthdate lt $candidate->{start};
      return $candidate->{name};
   }
   return;
} ## end sub _place_name_for

1;

__DATA__