package Se::PersonNr;

use strict;
use warnings;

our $VERSION = '0.01';

sub new {
	my $proto = shift;
	my $class = ref($proto) || $proto;

	my $self  = {
		year => '',
		month => '',
		day => '',
		serial => '',
		checksum => '',
	};
	
	bless ($self, $class);

	$self->personnr(shift) if (@_);

	return $self;
}


sub personnr {
	my $self = shift;
	
	if (@_) {
		my $number = shift;
	
		$self->{checksum} = chop($number);

		$self->{serial} = chop($number);
		$self->{serial} = chop($number) . $self->{serial};
		$self->{serial} = chop($number) . $self->{serial};
	
		if (length($number) < 8) {
			$self->{year} = substr($number, 0, 2);
			$number = substr($number, 2);
		} else {
			$self->{year} = substr($number, 0, 4);
			$number = substr($number, 4);
		}
	
		$self->{month} = substr($number, 0, 2);
		$self->{day} = substr($number, 2, 2);
	
		my ($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) = gmtime;
		$year += 1900;
	
		if (length($self->{year}) < 4) {
			if ($self->{year} > substr($year, 2, 2)) {
				$self->{year} = (substr($year, 0, 2) - 1)  . $self->{year};
			} else {
				$self->{year} = substr($year, 0, 2)  . $self->{year};
			}
	
			if (length($number) == 5) {
				if (substr($number, 4, 1) eq '+') {
					$self->{year} = (substr($self->{year}, 0, 2) - 1)  . substr($self->{year}, 2, 2);
				}
			}
		}
	
	}

	my ($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) = gmtime;
	$year += 1900;
	
	my $yearsign = '-';

	if ($year > ($self->{year} + 100)) {
		$yearsign = '+';
	}
	
	return substr($self->{year}, 2, 2) . $self->{month} . $self->{day} . $yearsign . $self->{serial} . $self->{checksum};
}


sub year {
	my $self = shift;
	$self->{year} = shift if (@_);
	return $self->{year};
}


sub month {
	my $self = shift;
	$self->{month} = shift if (@_);
	return $self->{month};
}


sub day {
	my $self = shift;
	$self->{day} = shift if (@_);
	return $self->{day};
}

sub serial {
	my $self = shift;
	$self->{serial} = shift if (@_);
	return $self->{serial};
}

sub checksum {
	my $self = shift;
	$self->{checksum} = shift if (@_);
	return $self->{checksum};
}


sub is_valid {
	my $self = shift;
	
	if ($self->{checksum} == $self->get_valid(substr($self->{year}, 2, 2) . $self->{month} . $self->{day} . $self->{serial})) {
		return 1;
	}
	
	return 0;
}


sub get_valid {
	my $self = shift;
	my $stn;
	
	if (@_) {
		$stn = shift;
	} else {
		$stn = substr($self->{year}, 2, 2) . $self->{month} . $self->{day} . $self->{serial};
	}
	
	my $digits;
	my $thismod = 2;
	
	# go through each digit and multiply with 2 and 1 alternated
	while (length($stn) > 0) {
		$digits .= chop($stn) * $thismod;

		if ($thismod > 1) {
			$thismod = 1;
		} else {
			$thismod = 2;
		}
	}

	# get the sum of all digits
	$stn = 0;
	while (length($digits) > 0) {
		$stn += int(chop($digits));
	}

	# subtract the rightmost digit from 10 to get checksum
	$digits = 10 - substr($stn, -1, 1);

	return $digits;
}


1;

__END__


=head1 NAME

Se::PersonNr - Module for validating and generating a Swedish personnummer.



=head1 SYNOPSIS

  use Se::PersonNr;
  my $pnr = new Se::PersonNr('511013-3815'); # faked, but valid
  print "It's fake! Checksum should be: " . $pnr->get_valid() unless ($pnr->is_valid());



=head1 DESCRIPTION

Se::PersonNr is a module that is used to validate a Swedish personnummer. A personnummer is a
unique number generated by the government for each indivual in Sweden. They are also used as
registration numbers for corporations and other business entities.

A personnummer consists of six digits representing date of birth follow by three serial number
digits and a checksum digit. The date of birth and serial number is split by a plus or minus sign.
(The minus sign is replaced by a plus sign when he or she turn 100.) The date part is two digits
for the year followed by two for the month and another two for the day of month.

Example: A man born on the 13th of October 1951 with serial number 381 gets the personnummer
511013-3815.

The module will accept personnummer in the formats yymmdd-sssc, yymmddsssc, yyyymmdd-sssc
and yyyymmddsssc but only return the first format. The first format may also use the plus sign.

More information about personnummer can be found at: http://www.rsv.se/pdf/70407.pdf (it's
in Swedish).



=head1 METHODS

=over 4

=item $pnr = Se::PersonNr->new($personnummer)

Create a new PersonNr object. Optionally you may pass the personummer in the constructor
directly.


=item $personnummer = $pnr->personnr($newpersonnummer);

Returns the personummer in the object and sets a new one if supplied.


=item $year = $pnr->year($newyear);

Returns the year of birth for the person and sets a new one if supplied.


=item $month = $pnr->month($newmonth);

Returns the month of birth for the person and sets a new one if supplied.


=item $day = $pnr->day($newday);

Returns the day of birth for the person and sets a new one if supplied.


=item $serial = $pnr->serial($newserial);

Returns the serial number for the person and sets a new one if supplied.


=item $checksum = $pnr->checksum($newchecksum);

Returns the checksum digit for the person and sets a new one if supplied.


=item $validity = $pnr->is_valid();

Returns 1 if the checksum digit is valid. No other validation is made. Returns 0 if fake.


=item $correctchecksum = $pnr->get_valid($incomplete);

Returns the correct checksum digit for the incomplete personnummer supplied. The personnummer
passed should have the format yymmddsss. If no incomplete personnummer is passed, it uses
the one in the object.

=back


=head1 TODO

=over 4

=item Date validation

Check to make sure days and months actually are valid.

=item Organisationsnummer

Detect corporate and government identities. These numbers have the same format as personnummer.

=item Sex

Decide if the person is male or female.

=item Sammordningsnummer

A personnummer registered for a different purpose.

=back



=head1 AUTHOR

Erik Bosrup, erik@bosrup.com

Copyright (c) 2001 Erik Bosrup. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. 



=head1 SEE ALSO

perl(1).

=cut