File Coverage

blib/lib/Business/BR/PIS.pm

Criterion	Covered	Total	%
statement	28	36	77.7
branch	10	14	71.4
condition	2	3	66.6
subroutine	8	10	80.0
pod	0	5	0.0
total	48	68	70.5

package Business::BR::PIS;

use 5;
use strict;
use warnings;

require Exporter;

our @ISA = qw(Exporter);

#our %EXPORT_TAGS = ( 'all' => [ qw() ] );
#our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
#our @EXPORT = qw();

our @EXPORT_OK = qw( canon_pis format_pis parse_pis random_pis );
our @EXPORT = qw( test_pis );

our $VERSION = '0.00_16';

use Business::BR::Ids::Common qw(_dot _canon_id);

sub canon_pis {
  return _canon_id(shift, size => 11);
}


# there is a subtle difference here between the return for
# for an input which is not 11 digits long (undef)
# and one that does not satisfy the check equations (0).
# Correct PIS numbers return 1.
sub test_pis {
  my $pis = canon_pis shift;
  return undef if length $pis != 11;
  my @pis = split '', $pis;
  my $sum = _dot([qw(3 2 9 8 7 6 5 4 3 2 1)], \@pis) % 11;
  return ($sum==0 || $sum==1 && $pis[10]==0) ? 1 : 0;
}

sub format_pis {
  my $pis = canon_pis shift;
  $pis =~ s/^(...)(.....)(..)(.).*/$1.$2.$3-$4/; # 999.99999.99-9
  return $pis;
}

sub parse_pis {
  my $pis = canon_pis shift;
  my ($base, $dv) = $pis =~ /(\d{10})(\d{1})/;
  if (wantarray) {
    return ($base, $dv);
  }
  return { base => $base, dv => $dv };
}

# my $dv = _dv_pis('121.51144.13-7') # => $dv1 =
# my $dv = _dv_pis('121.51144.13-7', 0) # computes non-valid check digit
#
# computes the check digit of the candidate PIS number given as argument
# (only the first 10 digits enter the computation)
#
# In list context, it returns the check digit.
# In scalar context, it returns the complete PIS (base and check digits)
sub _dv_pis {
	my $base = shift; # expected to be canon'ed already ?!
	my $valid = @_ ? shift : 1;
	my $dev = $valid ? 0 : 2; # deviation (to make PIS invalid)
	my @base = split '', substr($base, 0, 10);
	my $dv = (-_dot([qw(3 2 9 8 7 6 5 4 3 2)], \@base) + $dev) % 11 % 10;
	return ($dv) if wantarray;
	substr($base, 10, 1) = $dv;
	return $base;
}

# generates a random (correct or incorrect) PIS
# $pis = rand_pis();
# $pis = rand_pis($valid);
#
# if $valid==0, produces an invalid PIS.
sub random_pis {
	my $valid = @_ ? shift : 1; # valid PIS by default
	my $base = sprintf "%010s?", int(rand(1E10)); # 10 dígitos
	return scalar _dv_pis($base, $valid);
}

1;

__END__