File Coverage

blib/lib/Business/DK/CPR.pm

Criterion	Covered	Total	%
statement	138	190	72.6
branch	27	58	46.5
condition	5	15	33.3
subroutine	34	34	100.0
pod	9	9	100.0
total	213	306	69.6

package Business::DK::CPR;

use strict;
use warnings;
use Carp qw(croak carp);
use Business::DK::CVR qw(_calculate_sum);
use Date::Calc qw(check_date);
use base 'Exporter';
use integer;
use Tie::IxHash;
use Readonly;
use Params::Validate qw( validate_pos SCALAR ARRAYREF );
use 5.010;    #5.10.0

our $VERSION   = '0.15';
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);

    my $control = substr $controlnumber, DATE_LENGTH, CONTROL_CIFER_LENGTH;

    my $remainder = $control % MODULUS_OPERAND_2007;

    #Our own merge, could be Hash::Merge's merge
    my %seeds = %{ merge( \%male_seeds, \%female_seeds ) };

    if ( my $series = $seeds{$remainder} ) {
        if ( $control < $seeds{$remainder}->{min} ) {
            return INVALID;
        }
        elsif ( $control > $seeds{$remainder}->{max} ) {
            return INVALID;
        }
    }
    elsif ( ( $control == 0 or $control == 6 ) && $remainder == 0 ) {
        return INVALID;
    }

    if ( $female_seeds{$remainder} ) {
        return VALID_FEMALE;
    }
    elsif ( $male_seeds{$remainder} ) {
        return VALID_MALE;
    }
    elsif ( $remainder == 0 ) {
        if ( _is_equal($control) ) {
            return VALID_FEMALE;
        }
        else {
            return VALID_MALE;
        }
    }
    else {
        return INVALID;
    }
}

sub validate1968 {
    my ($controlnumber) = @_;

    validate_pos( @_, { type => SCALAR, regex => qr/^\d+$/ } );

    _checkdate( substr $controlnumber, 0, DATE_LENGTH );
    _assert_controlnumber($controlnumber);

    my $sum = _calculate_sum( $controlnumber, \@controlcifers );

    #Note this might look like it is turned upside down but no rest from the
    #modulus calculation indicated validity
    if ( $sum % MODULUS_OPERAND_1968 ) {
        return INVALID;
    }
    else {
        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__