Business-DK-CPR
view release on metacpan or search on metacpan
lib/Business/DK/CPR.pm view on Meta::CPAN
use base 'Exporter';
use integer;
use Tie::IxHash;
use Readonly;
use Params::Validate qw( validate_pos SCALAR ARRAYREF );
use 5.012; #5.12.0
our $VERSION = '0.17';
our @EXPORT_OK = qw(
validate
validateCPR
generate
validate1968
generate1968
validate2007
generate2007
calculate
);
use constant MODULUS_OPERAND_1968 => 11;
use constant MODULUS_OPERAND_2007 => 6;
use constant DATE_LENGTH => 6;
use constant CONTROL_CIFER_LENGTH => 4;
use constant VALID => 1;
use constant VALID_MALE => 1;
use constant VALID_FEMALE => 2;
use constant INVALID => 0;
use constant FEMALE => 'female';
use constant MALE => 'male';
Readonly my @controlcifers => qw(4 3 2 7 6 5 4 3 2 1);
my %female_seeds;
tie %female_seeds, 'Tie::IxHash',
4 => { max => 9994, min => 10 },
2 => { max => 9998, min => 8 },
6 => { max => 9996, min => 12 };
my %male_seeds;
tie %male_seeds, 'Tie::IxHash',
1 => { max => 9997, min => 7 },
3 => { max => 9999, min => 9 },
5 => { max => 9995, min => 11 };
sub merge {
my ( $left_hashref, $right_hashref ) = @_;
my %hash = %{$right_hashref};
foreach ( keys %{$left_hashref} ) {
$hash{$_} = $left_hashref->{$_};
}
return \%hash;
}
sub calculate {
my ($birthdate) = @_;
validate_pos( @_,
{ type => SCALAR, callbacks => { 'date' => \&_checkdate } } );
my @cprs;
for ( 1 .. 999 ) {
my $n = sprintf '%03s', $_;
#From DK::Business::CVR
my $sum = _calculate_sum( ( $birthdate . $n ), \@controlcifers );
my $mod = $sum % MODULUS_OPERAND_1968;
my $checkciffer = ( MODULUS_OPERAND_1968 - $mod );
if ( $checkciffer < 10 ) {
push @cprs, ( $birthdate . $n . $checkciffer );
}
}
if (wantarray) {
return @cprs;
}
else {
return scalar @cprs;
}
}
sub validateCPR {
#We postpone parameter validation
return validate(shift);
}
sub _length {
my ( $number, $length ) = @_;
if ( length($number) != $length ) {
croak "argument: $number has to be $length digits long";
}
return 1;
}
sub validate {
my ($controlnumber) = @_;
#We postpone parameter validation
my $rv;
if ( $rv = validate1968($controlnumber) ) {
return $rv;
}
else {
return validate2007($controlnumber);
}
}
sub validate2007 {
my ($controlnumber) = @_;
validate_pos( @_, { type => SCALAR, regex => qr/^\d+$/ } );
_checkdate( substr $controlnumber, 0, DATE_LENGTH );
_assert_controlnumber($controlnumber);
lib/Business/DK/CPR.pm view on Meta::CPAN
if ( _is_equal($sum) ) {
return VALID_MALE;
}
else {
return VALID_FEMALE;
}
}
}
sub _is_equal {
my ($operand) = @_;
validate_pos( @_, { type => SCALAR, regex => qr/^\d+$/ } );
return ( not( $operand % 2 ) );
}
sub _assert_controlnumber {
my ($controlnumber) = @_;
validate_pos( @_, { type => SCALAR, regex => qr/^\d+$/ } );
_length( $controlnumber, scalar @controlcifers );
return VALID;
}
sub _checkdate {
my $dateregex = qr{
\A #beginning of line
(\d{2}) #day of month, 2 digit representation, 01-31
(\d{2}) #month, 2 digit representation jan 01 - dec 12
(\d{2}) #year, 2 digit representation
\Z #end of line
}xsm;
#According to the documentation validate_pos gets two paramters, hence the
#second optional argument specification
validate_pos(
@_,
{ type => SCALAR, regex => $dateregex },
{ type => ARRAYREF, optional => 1 },
);
#Params::Validate does not capture for us, so we re-do our regex
$_[0] =~ m/$dateregex/;
if ( not check_date( $3, $2, $1 ) ) {
croak "argument: $_[0] has to be a valid date in the format: ddmmyy";
}
return VALID;
}
sub generate {
my ( $birthdate, $gender ) = @_;
validate_pos(
@_,
{ type => SCALAR, callbacks => { 'date' => \&_checkdate }, },
{ type => SCALAR, optional => 1, default => q{} },
);
my @genders;
if ($gender) {
push @genders, $gender;
}
else {
@genders = qw(male female);
}
my %cprs;
foreach my $g (@genders) {
my @cprs2007 = generate2007( $birthdate, $g );
my $i = 1;
foreach my $cpr (@cprs2007) {
$cprs{$cpr}++;
}
}
if (wantarray) {
return keys %cprs;
}
else {
return scalar keys %cprs;
}
}
sub generate2007 {
my ( $birthdate, $gender ) = @_;
#TODO assert gender?
validate_pos(
@_,
{ type => SCALAR, callbacks => { 'date' => \&_checkdate }, },
{ type => SCALAR, optional => 1 },
);
my @cprs;
my %seeds;
if ( defined $gender ) {
if ( $gender eq MALE ) {
%seeds = %male_seeds;
}
elsif ( $gender eq FEMALE ) {
%seeds = %female_seeds;
}
else {
carp("Unknown gender: $gender, assuming no gender");
$gender = undef;
}
}
if ( not $gender ) {
%seeds = %{ merge( \%female_seeds, \%male_seeds ) };
}
foreach my $seed ( keys %seeds ) {
my $s = $seeds{$seed}->{min};
while ( $s < $seeds{$seed}->{max} ) {
$s += MODULUS_OPERAND_2007;
push @cprs, ( $birthdate . sprintf '%04d', $s );
}
}
if (wantarray) {
return @cprs;
}
else {
return scalar @cprs;
}
}
sub generate1968 {
my ( $birthdate, $gender ) = @_;
#TODO assert gender?
validate_pos(
@_,
{ type => SCALAR, callbacks => { 'date' => \&_checkdate }, },
{ type => SCALAR, optional => 1, default => q{} },
);
my @cprs;
my @malecprs;
my @femalecprs;
my $checksum = 0;
while ( $checksum < 9999 ) {
my $cpr = $birthdate . sprintf '%04d', $checksum;
if ( my $rv = validate1968($cpr) ) {
if ( defined $gender and $rv ) {
if ( $rv == VALID_MALE ) {
push @malecprs, $cpr;
}
elsif ( $rv == VALID_FEMALE ) {
push @femalecprs, $cpr;
}
}
else {
push @cprs, $cpr;
}
}
$checksum++;
}
if ( $gender and $gender eq FEMALE ) {
@cprs = @femalecprs;
}
elsif ( $gender and $gender eq MALE ) {
@cprs = @malecprs;
}
if (wantarray) {
return @cprs;
}
else {
return scalar @cprs;
}
}
1;
__END__
=pod
=begin markdown
[](http://badge.fury.io/pl/Business-DK-CPR)
[](https://travis-ci.org/jonasbn/bdkcpr)
[](https://coveralls.io/r/jonasbn/bdkcpr)
=end markdown
=head1 NAME
Business::DK::CPR - Danish CPR (SSN) number generator/validator
=head1 VERSION
This documentation describes version 0.17
=head1 SYNOPSIS
use Business::DK::CPR qw(validate);
my $rv;
eval { $rv = validate(1501721111); };
if ($@) {
die "Code is not of the expected format - $@";
}
if ($rv) {
print 'CPR is valid';
} else {
print 'CPR is not valid';
}
use Business::DK::CPR qw(calculate);
my @cprs = calculate(150172);
my $number_of_valid_cprs = calculate(150172);
#Using with Params::Validate
#See also examples/
use Params::Validate qw(:all);
use Business::DK::CPR qw(validateCPR);
sub check_cpr {
validate( @_,
{ cpr =>
{ callbacks =>
{ 'validate_cpr' => sub { validateCPR($_[0]); } } } } );
print $_[1]." is a valid CPR\n";
}
=head1 DESCRIPTION
CPR stands for Central Person Registration and is the social security number
used in Denmark.
=head1 SUBROUTINES AND METHODS
All methods are exported by explicit request. None are exported implicitly.
=head2 validate
This function checks a CPR number for validity. It takes a CPR number as
argument and returns:
=over
=item * 1 (true) for valid male CPR number
=item * 2 (true) for a valid female CPR number
=item * 0 (false) for invalid CPR number
=back
It dies if the CPR number is malformed or in any way unparsable, be aware that
the 6 first digits are representing a date (SEE: L<_checkdate|/_checkdate> function below).
In brief, the date indicate the person's birthday, the last 4 digits are
representing a serial number and control cipher.
For a more thorough discussion on the format of CPR numbers please refer to the
L<SEE ALSO|/SEE ALSO> section.
L<validate1968|/validate1968> is the old form of the CPR number. It is validated
using modulus 11.
The new format introduced in 2001 (put to use in 2007, hence the name used
throughout this package) can be validated using L<validate2007|/validate2007> and
generate using L<generate2007|/generate2007>.
The L<validate|/validate> subroutine wraps both validators and checks using against both.
The L<generate|/generate> subroutine wraps both generators and accumulated the results.
NB! it is possible to make fake CPR numbers that appear valid, please see
MOTIVATION and the L</calculate> function.
L<validate|/validate> is also exported as: L<validateCPR|/validateCPR>, which is less imposing.
=head2 validateCPR
Better name for export. This is just a wrapper for L</validate>
=head2 validate1968
( run in 0.691 second using v1.01-cache-2.11-cpan-98e64b0badf )