line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package String::CodiceFiscale; |
2
|
|
|
|
|
|
|
|
3
|
|
|
|
|
|
|
$String::CodiceFiscale::VERSION = '0.01'; |
4
|
|
|
|
|
|
|
|
5
|
1
|
|
|
1
|
|
1323
|
use strict; |
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
52
|
|
6
|
1
|
|
|
1
|
|
6
|
no utf8; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
7
|
|
7
|
1
|
|
|
1
|
|
37
|
no locale; |
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
7
|
|
8
|
1
|
|
|
1
|
|
26
|
use base qw(Class::Data::Inheritable); |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
1133
|
|
9
|
1
|
|
|
1
|
|
1448
|
use Time::Piece; |
|
1
|
|
|
|
|
17976
|
|
|
1
|
|
|
|
|
8
|
|
10
|
1
|
|
|
1
|
|
175
|
use Carp; |
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
6044
|
|
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
our %CRC = ( |
13
|
|
|
|
|
|
|
A => [0, 1], B => [1, 0], C => [2, 5], |
14
|
|
|
|
|
|
|
D => [3, 7], E => [4, 9], F => [5, 13], |
15
|
|
|
|
|
|
|
G => [6, 15], H => [7, 17], I => [8, 19], |
16
|
|
|
|
|
|
|
J => [9, 21], K => [10, 2], L => [11, 4], |
17
|
|
|
|
|
|
|
M => [12, 18], N => [13, 20], O => [14, 11], |
18
|
|
|
|
|
|
|
P => [15, 3], Q => [16, 6], R => [17, 8], |
19
|
|
|
|
|
|
|
S => [18, 12], T => [19, 14], U => [20, 16], |
20
|
|
|
|
|
|
|
V => [21, 10], W => [22, 22], X => [23, 25], |
21
|
|
|
|
|
|
|
Y => [24, 24], Z => [25, 23], 0 => [0, 1], |
22
|
|
|
|
|
|
|
1 => [1, 0], 2 => [2, 5], 3 => [3, 7], |
23
|
|
|
|
|
|
|
4 => [4, 9], 5 => [5, 13], 6 => [6, 15], |
24
|
|
|
|
|
|
|
7 => [7, 17], 8 => [8, 19], 9 => [9, 21], |
25
|
|
|
|
|
|
|
); |
26
|
|
|
|
|
|
|
|
27
|
|
|
|
|
|
|
__PACKAGE__->mk_classdata('ERROR'); |
28
|
|
|
|
|
|
|
|
29
|
|
|
|
|
|
|
our ($MONTHS, @MONTHS, %MONTHS); #code to/from month |
30
|
|
|
|
|
|
|
@MONTHS[1..12] = qw(A B C D E H L M P R S T); |
31
|
|
|
|
|
|
|
@MONTHS{@MONTHS[1..12]} = 1..12; |
32
|
|
|
|
|
|
|
$MONTHS = join '', @MONTHS[1..12]; |
33
|
|
|
|
|
|
|
|
34
|
|
|
|
|
|
|
our ($XNUMS, @XNUMS, %XNUMS); #coded numbers for rare collision cases |
35
|
|
|
|
|
|
|
@XNUMS = qw(L M N P Q R S T U V); |
36
|
|
|
|
|
|
|
@XNUMS{@XNUMS} = 0..9; #not used anymore, but here "just in case" |
37
|
|
|
|
|
|
|
$XNUMS = join '', @XNUMS; |
38
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
our $CONSONANTS = 'BCDFGHJKLMNPQRSTVWXYZ'; |
40
|
|
|
|
|
|
|
our $VOWELS = 'AEIOU'; |
41
|
|
|
|
|
|
|
|
42
|
|
|
|
|
|
|
our $RE_cf = qr/ |
43
|
|
|
|
|
|
|
^ #start |
44
|
|
|
|
|
|
|
([A-Z]{3}) #surname coded |
45
|
|
|
|
|
|
|
([A-Z]{3}) #firstname coded |
46
|
|
|
|
|
|
|
([\d$XNUMS]{2}) #year |
47
|
|
|
|
|
|
|
([$MONTHS]) #month coded |
48
|
|
|
|
|
|
|
([\d$XNUMS]{2}) #day and sex |
49
|
|
|
|
|
|
|
([A-Z][\d$XNUMS]{3}) #birthplace coded |
50
|
|
|
|
|
|
|
([A-Z]) #crc |
51
|
|
|
|
|
|
|
$ #end |
52
|
|
|
|
|
|
|
/xo; |
53
|
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
our $RE_nc = qr/^[$CONSONANTS]*[$VOWELS]*X*$/xo; |
55
|
|
|
|
|
|
|
|
56
|
|
|
|
|
|
|
our %OPTS = map {$_ => 1} qw( |
57
|
|
|
|
|
|
|
sn sn_c fn fn_c date year year_c |
58
|
|
|
|
|
|
|
month month_c day day_c sex bp bp_c |
59
|
|
|
|
|
|
|
); |
60
|
|
|
|
|
|
|
|
61
|
|
|
|
|
|
|
sub new { |
62
|
10
|
|
|
10
|
1
|
483
|
my $class = shift; |
63
|
10
|
|
|
|
|
41
|
my $self = bless {}, $class; |
64
|
10
|
|
|
|
|
54
|
while (my ($k, $v) = splice(@_, 0, 2)) { |
65
|
47
|
50
|
|
|
|
156
|
$self->_croak(qq(Not such an options "$k")) unless $OPTS{$k}; |
66
|
47
|
|
|
|
|
124
|
$self->$k($v); |
67
|
|
|
|
|
|
|
} |
68
|
10
|
|
|
|
|
23
|
return $self; |
69
|
|
|
|
|
|
|
} |
70
|
|
|
|
|
|
|
|
71
|
|
|
|
|
|
|
sub sn { |
72
|
7
|
|
|
7
|
1
|
300
|
my $self = shift; |
73
|
7
|
|
|
|
|
19
|
my ($sn) = @_; |
74
|
7
|
100
|
|
|
|
19
|
if (defined $sn) { |
75
|
5
|
|
|
|
|
12
|
$sn = uc($sn); |
76
|
5
|
|
|
|
|
19
|
$self->{sn} = $sn; |
77
|
5
|
|
|
|
|
9
|
$self->{sn_c} = undef; |
78
|
5
|
|
|
|
|
8
|
$self->{sn_re} = undef; |
79
|
|
|
|
|
|
|
} |
80
|
7
|
|
|
|
|
23
|
return $sn; |
81
|
|
|
|
|
|
|
} |
82
|
|
|
|
|
|
|
|
83
|
|
|
|
|
|
|
sub sn_c { |
84
|
34
|
|
|
34
|
0
|
64
|
my $self = shift; |
85
|
34
|
|
|
|
|
53
|
my ($sn_c) = @_; |
86
|
34
|
100
|
|
|
|
77
|
if (defined $sn_c) { |
87
|
17
|
|
|
|
|
31
|
$sn_c = uc($sn_c); |
88
|
17
|
100
|
|
|
|
160
|
unless ($sn_c =~ /$RE_nc/) { |
89
|
1
|
|
|
|
|
4
|
$self->error('Coded surname cannot contain ' . |
90
|
|
|
|
|
|
|
'vowels followed by consonants'); |
91
|
1
|
|
|
|
|
5
|
return; |
92
|
|
|
|
|
|
|
} |
93
|
16
|
100
|
|
|
|
48
|
unless (length($sn_c) == 3) { |
94
|
2
|
|
|
|
|
8
|
$self->error('Coded surname must be 3 chars in length'); |
95
|
2
|
|
|
|
|
8
|
return; |
96
|
|
|
|
|
|
|
} |
97
|
14
|
|
|
|
|
31
|
$self->{sn_c} = $sn_c; |
98
|
14
|
|
|
|
|
25
|
$self->{sn} = undef; |
99
|
14
|
|
|
|
|
29
|
$self->{sn_re} = undef; |
100
|
|
|
|
|
|
|
} |
101
|
31
|
100
|
66
|
|
|
120
|
if (defined $self->{sn} and not defined $self->{sn_c}) { |
102
|
5
|
|
|
|
|
9
|
my $temp = ''; |
103
|
|
|
|
|
|
|
OUTER: { |
104
|
5
|
|
|
|
|
7
|
while ($self->{sn} =~ /([$CONSONANTS])/go) { |
|
5
|
|
|
|
|
41
|
|
105
|
11
|
|
|
|
|
24
|
$temp .= $1; |
106
|
11
|
100
|
|
|
|
54
|
last OUTER if length $temp >= 3; |
107
|
|
|
|
|
|
|
} |
108
|
3
|
|
|
|
|
31
|
while ($self->{sn} =~ /([$VOWELS])/go) { |
109
|
3
|
|
|
|
|
7
|
$temp .= $1; |
110
|
3
|
100
|
|
|
|
12
|
last OUTER if length $temp >= 3; |
111
|
|
|
|
|
|
|
} |
112
|
1
|
|
|
|
|
4
|
while (length $temp < 3) { |
113
|
1
|
|
|
|
|
4
|
$temp .= 'X'; |
114
|
|
|
|
|
|
|
} |
115
|
|
|
|
|
|
|
} |
116
|
5
|
|
|
|
|
12
|
$self->{sn_c} = $temp; |
117
|
|
|
|
|
|
|
} |
118
|
31
|
|
|
|
|
153
|
return $self->{sn_c}; |
119
|
|
|
|
|
|
|
} |
120
|
|
|
|
|
|
|
|
121
|
|
|
|
|
|
|
sub sn_re { |
122
|
3
|
|
|
3
|
0
|
5
|
my $self = shift; |
123
|
3
|
|
|
|
|
10
|
return $self->_n_re('sn_c'); |
124
|
|
|
|
|
|
|
} |
125
|
|
|
|
|
|
|
|
126
|
|
|
|
|
|
|
|
127
|
|
|
|
|
|
|
sub sn_match { |
128
|
2
|
|
|
2
|
1
|
9
|
my $self = shift; |
129
|
2
|
|
|
|
|
5
|
my ($tm) = @_; |
130
|
2
|
50
|
|
|
|
8
|
return unless defined $tm; |
131
|
2
|
|
|
|
|
5
|
$tm = uc $tm; |
132
|
2
|
|
|
|
|
9
|
$self->_fix_name($tm); |
133
|
2
|
50
|
|
|
|
228
|
if (defined(my $sn = $self->sn)) { |
134
|
0
|
|
|
|
|
0
|
$self->_fix_name($sn); |
135
|
0
|
|
|
|
|
0
|
return $tm eq $self->sn; |
136
|
|
|
|
|
|
|
} |
137
|
2
|
50
|
|
|
|
7
|
if (defined $self->sn_c) { |
138
|
2
|
|
|
|
|
8
|
return $tm =~ $self->sn_re; |
139
|
|
|
|
|
|
|
} |
140
|
0
|
|
|
|
|
0
|
return; |
141
|
|
|
|
|
|
|
} |
142
|
|
|
|
|
|
|
|
143
|
|
|
|
|
|
|
sub fn { |
144
|
10
|
|
|
10
|
1
|
18
|
my $self = shift; |
145
|
10
|
|
|
|
|
17
|
my ($fn) = @_; |
146
|
10
|
100
|
|
|
|
29
|
if (defined $fn) { |
147
|
6
|
|
|
|
|
13
|
$fn = uc($fn); |
148
|
6
|
|
|
|
|
13
|
$self->{fn} = $fn; |
149
|
6
|
|
|
|
|
12
|
$self->{fn_c} = undef; |
150
|
6
|
|
|
|
|
11
|
$self->{fn_re} = undef; |
151
|
|
|
|
|
|
|
} |
152
|
10
|
|
|
|
|
38
|
return $fn; |
153
|
|
|
|
|
|
|
} |
154
|
|
|
|
|
|
|
|
155
|
|
|
|
|
|
|
sub fn_c { |
156
|
41
|
|
|
41
|
0
|
74
|
my $self = shift; |
157
|
41
|
|
|
|
|
55
|
my ($fn_c) = @_; |
158
|
41
|
100
|
|
|
|
117
|
if (defined $fn_c) { |
159
|
19
|
|
|
|
|
37
|
$fn_c = uc($fn_c); |
160
|
19
|
100
|
|
|
|
124
|
unless ($fn_c =~ /$RE_nc/) { |
161
|
1
|
|
|
|
|
4
|
$self->error('Coded name cannot contain ' . |
162
|
|
|
|
|
|
|
'vowels followed by consonants'); |
163
|
1
|
|
|
|
|
4
|
return; |
164
|
|
|
|
|
|
|
} |
165
|
18
|
100
|
|
|
|
52
|
unless (length($fn_c) == 3) { |
166
|
2
|
|
|
|
|
6
|
$self->error('Coded name must be 3 chars in length'); |
167
|
2
|
|
|
|
|
9
|
return; |
168
|
|
|
|
|
|
|
} |
169
|
16
|
|
|
|
|
34
|
$self->{fn_c} = $fn_c; |
170
|
16
|
|
|
|
|
26
|
$self->{fn} = undef; |
171
|
16
|
|
|
|
|
32
|
$self->{fn_re} = undef; |
172
|
|
|
|
|
|
|
} |
173
|
38
|
100
|
66
|
|
|
128
|
if (defined $self->{fn} and not defined $self->{fn_c}) { |
174
|
6
|
|
|
|
|
10
|
my $temp = ''; |
175
|
6
|
|
|
|
|
18
|
my $skip = $self->_count_consonants($self->{fn}) > 3; |
176
|
|
|
|
|
|
|
OUTER: { |
177
|
6
|
|
|
|
|
11
|
while ($self->{fn} =~ /([$CONSONANTS])/go) { |
|
6
|
|
|
|
|
40
|
|
178
|
14
|
100
|
100
|
|
|
47
|
if ($skip and length($temp) == 1) { |
179
|
2
|
|
|
|
|
3
|
$skip = 0; |
180
|
2
|
|
|
|
|
7
|
next; |
181
|
|
|
|
|
|
|
} |
182
|
12
|
|
|
|
|
20
|
$temp .= $1; |
183
|
12
|
100
|
|
|
|
55
|
last OUTER if length $temp >= 3; |
184
|
|
|
|
|
|
|
} |
185
|
4
|
|
|
|
|
24
|
while ($self->{fn} =~ /([$VOWELS])/go) { |
186
|
5
|
|
|
|
|
9
|
$temp .= $1; |
187
|
5
|
100
|
|
|
|
20
|
last OUTER if length $temp >= 3; |
188
|
|
|
|
|
|
|
} |
189
|
1
|
|
|
|
|
5
|
while (length $temp < 3) { |
190
|
1
|
|
|
|
|
3
|
$temp .= 'X'; |
191
|
|
|
|
|
|
|
} |
192
|
|
|
|
|
|
|
} |
193
|
6
|
|
|
|
|
16
|
$self->{fn_c} = $temp; |
194
|
|
|
|
|
|
|
} |
195
|
38
|
|
|
|
|
419
|
return $self->{fn_c}; |
196
|
|
|
|
|
|
|
} |
197
|
|
|
|
|
|
|
|
198
|
|
|
|
|
|
|
sub fn_re { |
199
|
5
|
|
|
5
|
0
|
8
|
my $self = shift; |
200
|
5
|
|
|
|
|
26
|
return $self->_n_re('fn_c'); |
201
|
|
|
|
|
|
|
} |
202
|
|
|
|
|
|
|
|
203
|
|
|
|
|
|
|
sub fn_match { |
204
|
4
|
|
|
4
|
1
|
9
|
my $self = shift; |
205
|
4
|
|
|
|
|
19
|
my ($tm) = @_; |
206
|
4
|
50
|
|
|
|
13
|
return unless defined $tm; |
207
|
4
|
|
|
|
|
9
|
$tm = uc $tm; |
208
|
4
|
|
|
|
|
58
|
$self->_fix_name($tm); |
209
|
4
|
50
|
|
|
|
14
|
if (defined(my $fn = $self->fn)) { |
210
|
0
|
|
|
|
|
0
|
$self->_fix_name($fn); |
211
|
0
|
|
|
|
|
0
|
return $tm eq $fn; |
212
|
|
|
|
|
|
|
} |
213
|
4
|
50
|
|
|
|
13
|
if (defined $self->fn_c) { |
214
|
4
|
|
|
|
|
18
|
return $tm =~ $self->fn_re; |
215
|
|
|
|
|
|
|
} |
216
|
0
|
|
|
|
|
0
|
return; |
217
|
|
|
|
|
|
|
} |
218
|
|
|
|
|
|
|
|
219
|
|
|
|
|
|
|
|
220
|
|
|
|
|
|
|
sub date { |
221
|
5
|
|
|
5
|
1
|
1543
|
my $self = shift; |
222
|
5
|
|
|
|
|
10
|
my ($date) = @_; |
223
|
5
|
100
|
|
|
|
14
|
if (defined $date) { |
224
|
4
|
|
|
|
|
5
|
my $t; |
225
|
4
|
|
|
|
|
7
|
eval { $t = Time::Piece->strptime($date, '%Y-%m-%d') }; |
|
4
|
|
|
|
|
22
|
|
226
|
4
|
100
|
|
|
|
132
|
if ($@) { |
227
|
1
|
|
|
|
|
4
|
$self->error("Invalid date"); |
228
|
1
|
|
|
|
|
5
|
return; |
229
|
|
|
|
|
|
|
} |
230
|
3
|
|
|
|
|
17
|
my %date = ( |
231
|
|
|
|
|
|
|
year => $t->year, |
232
|
|
|
|
|
|
|
month => $t->mon, |
233
|
|
|
|
|
|
|
day => $t->mday, |
234
|
|
|
|
|
|
|
); |
235
|
3
|
|
|
|
|
154
|
for (qw(year month day)) { |
236
|
9
|
50
|
|
|
|
41
|
unless ( $self->$_($date{$_}) ) { |
237
|
0
|
|
|
|
|
0
|
$self->error("Couldn't parse $_"); |
238
|
0
|
|
|
|
|
0
|
return; |
239
|
|
|
|
|
|
|
} |
240
|
|
|
|
|
|
|
} |
241
|
|
|
|
|
|
|
} else { |
242
|
1
|
|
|
|
|
4
|
my %date; |
243
|
1
|
|
|
|
|
3
|
for (qw(year month day)) { |
244
|
3
|
|
|
|
|
11
|
$date{$_} = $self->$_; |
245
|
3
|
50
|
|
|
|
13
|
unless (defined $date{$_}) { |
246
|
0
|
|
|
|
|
0
|
$self->error("Couldn't retrieve $_"); |
247
|
0
|
|
|
|
|
0
|
return; |
248
|
|
|
|
|
|
|
} |
249
|
|
|
|
|
|
|
} |
250
|
1
|
|
|
|
|
118
|
return sprintf("%04d-%02d-%02d", @date{qw(year month day)}); |
251
|
|
|
|
|
|
|
} |
252
|
3
|
|
|
|
|
14
|
return $date; |
253
|
|
|
|
|
|
|
} |
254
|
|
|
|
|
|
|
|
255
|
|
|
|
|
|
|
sub year { |
256
|
7
|
|
|
7
|
1
|
15
|
my $self = shift; |
257
|
7
|
|
|
|
|
12
|
my ($y) = @_; |
258
|
7
|
100
|
|
|
|
19
|
if (defined $y) { |
259
|
5
|
100
|
|
|
|
158
|
unless ($y =~ /^\d+$/) { |
260
|
1
|
|
|
|
|
3
|
$self->error('A year should be an unsigned integer'); |
261
|
1
|
|
|
|
|
5
|
return; |
262
|
|
|
|
|
|
|
} |
263
|
4
|
|
|
|
|
12
|
$self->{year} = $y; |
264
|
4
|
|
|
|
|
11
|
$self->{year_c} = undef; |
265
|
|
|
|
|
|
|
} |
266
|
6
|
100
|
66
|
|
|
33
|
if (not defined $self->{year} and defined $self->{year_c}) { |
267
|
2
|
|
|
|
|
8
|
my $year = $self->_xnums($self->{year_c}); |
268
|
2
|
|
|
|
|
22
|
my $cy = (localtime(time))[5] % 100; # this is making a guess |
269
|
2
|
50
|
|
|
|
217
|
if ($year > $cy) { |
270
|
2
|
|
|
|
|
13
|
$self->{year} = sprintf "19%02d", $year; |
271
|
|
|
|
|
|
|
} else { |
272
|
0
|
|
|
|
|
0
|
$self->{year} = sprintf "20%02d", $year; |
273
|
|
|
|
|
|
|
} |
274
|
|
|
|
|
|
|
} |
275
|
6
|
|
|
|
|
33
|
return $self->{year}; |
276
|
|
|
|
|
|
|
} |
277
|
|
|
|
|
|
|
|
278
|
|
|
|
|
|
|
sub year_c { |
279
|
18
|
|
|
18
|
0
|
22
|
my $self = shift; |
280
|
18
|
|
|
|
|
28
|
my ($ycx) = @_; |
281
|
18
|
100
|
|
|
|
38
|
if (defined $ycx) { |
282
|
9
|
|
|
|
|
25
|
my $yc = $self->_xnums($ycx); |
283
|
9
|
100
|
|
|
|
248
|
unless ($yc =~ /^\d\d$/) { |
284
|
1
|
|
|
|
|
5
|
$self->error('A year in Codice Fiscale is 2 digit long'); |
285
|
1
|
|
|
|
|
6
|
return; |
286
|
|
|
|
|
|
|
} |
287
|
8
|
|
|
|
|
21
|
$self->{year_c} = $ycx; |
288
|
8
|
|
|
|
|
24
|
$self->{year} = undef; |
289
|
|
|
|
|
|
|
} |
290
|
17
|
100
|
66
|
|
|
78
|
if (not defined $self->{year_c} and defined $self->{year}) { |
291
|
1
|
|
|
|
|
5
|
$self->{year_c} = $self->{year} % 100; |
292
|
|
|
|
|
|
|
} |
293
|
17
|
|
|
|
|
139
|
return $self->{year_c}; |
294
|
|
|
|
|
|
|
} |
295
|
|
|
|
|
|
|
|
296
|
|
|
|
|
|
|
sub month { |
297
|
8
|
|
|
8
|
1
|
17
|
my $self = shift; |
298
|
8
|
|
|
|
|
10
|
my ($m) = @_; |
299
|
8
|
100
|
|
|
|
57
|
if (defined $m) { |
300
|
6
|
100
|
66
|
|
|
62
|
unless ($m =~ /^\d+$/ and $m >= 1 and $m <= 12) { |
|
|
|
100
|
|
|
|
|
301
|
2
|
|
|
|
|
6
|
$self->error('Month must be numeric and between 1 and 12'); |
302
|
2
|
|
|
|
|
7
|
return; |
303
|
|
|
|
|
|
|
} |
304
|
4
|
|
|
|
|
10
|
$self->{month} = $m; |
305
|
4
|
|
|
|
|
8
|
$self->{month_c} = undef; |
306
|
|
|
|
|
|
|
} |
307
|
6
|
100
|
66
|
|
|
29
|
if (not defined $self->{month} and defined $self->{month_c}) { |
308
|
2
|
|
|
|
|
8
|
$self->{month} = $MONTHS{$self->{month_c}}; |
309
|
|
|
|
|
|
|
} |
310
|
6
|
|
|
|
|
24
|
return $self->{month}; |
311
|
|
|
|
|
|
|
} |
312
|
|
|
|
|
|
|
|
313
|
|
|
|
|
|
|
sub month_c { |
314
|
18
|
|
|
18
|
0
|
26
|
my $self = shift; |
315
|
18
|
|
|
|
|
27
|
my ($mc) = @_; |
316
|
18
|
100
|
|
|
|
35
|
if (defined $mc) { |
317
|
8
|
50
|
|
|
|
51
|
unless ($mc =~ /^[$MONTHS]$/o) { |
318
|
0
|
|
|
|
|
0
|
$self->error('Month not correctly encoded'); |
319
|
0
|
|
|
|
|
0
|
return; |
320
|
|
|
|
|
|
|
} |
321
|
8
|
|
|
|
|
20
|
$self->{month_c} = $mc; |
322
|
8
|
|
|
|
|
16
|
$self->{month} = undef; |
323
|
|
|
|
|
|
|
} |
324
|
18
|
100
|
66
|
|
|
116
|
if (not defined $self->{month_c} and defined $self->{month}) { |
325
|
2
|
|
|
|
|
7
|
$self->{month_c} = $MONTHS[$self->{month}]; |
326
|
|
|
|
|
|
|
} |
327
|
18
|
|
|
|
|
62
|
return $self->{month_c}; |
328
|
|
|
|
|
|
|
} |
329
|
|
|
|
|
|
|
|
330
|
|
|
|
|
|
|
sub day { |
331
|
7
|
|
|
7
|
1
|
14
|
my $self = shift; |
332
|
7
|
|
|
|
|
11
|
my ($d) = @_; |
333
|
7
|
100
|
|
|
|
18
|
if (defined $d) { |
334
|
5
|
100
|
33
|
|
|
54
|
unless ($d =~ /^\d+$/ and 1 <= $d and $d <= 31) { |
|
|
|
66
|
|
|
|
|
335
|
1
|
|
|
|
|
5
|
$self->error('Day is out of range'); |
336
|
1
|
|
|
|
|
5
|
return; |
337
|
|
|
|
|
|
|
} |
338
|
4
|
|
|
|
|
7
|
$self->{day} = $d; |
339
|
4
|
|
|
|
|
12
|
$self->{day_c} = undef; |
340
|
|
|
|
|
|
|
} |
341
|
6
|
100
|
66
|
|
|
29
|
if (not defined $self->{day} and defined $self->{day_c}) { |
342
|
2
|
|
|
|
|
7
|
my $dayx = $self->_xnums($self->{day_c}); |
343
|
2
|
100
|
|
|
|
19
|
$self->{day} = $dayx > 40 ? $dayx - 40 : $dayx; |
344
|
|
|
|
|
|
|
} |
345
|
6
|
|
|
|
|
43
|
return $self->{day}; |
346
|
|
|
|
|
|
|
} |
347
|
|
|
|
|
|
|
|
348
|
|
|
|
|
|
|
sub day_c { |
349
|
20
|
|
|
20
|
0
|
29
|
my $self = shift; |
350
|
20
|
|
|
|
|
27
|
my ($dcx) = @_; |
351
|
20
|
100
|
|
|
|
43
|
if (defined $dcx) { |
352
|
9
|
|
|
|
|
21
|
my $dc = $self->_xnums($dcx); |
353
|
9
|
50
|
|
|
|
43
|
unless ($dc =~ /^\d+$/) { |
354
|
0
|
|
|
|
|
0
|
$self->error('Invalid coding of day'); |
355
|
0
|
|
|
|
|
0
|
return; |
356
|
|
|
|
|
|
|
} |
357
|
9
|
100
|
100
|
|
|
346
|
unless ($dc > 0 and not ($dc > 31 and $dc < 41) and $dc <= 71) { |
|
|
|
66
|
|
|
|
|
|
|
|
66
|
|
|
|
|
358
|
1
|
|
|
|
|
3
|
$self->error('Day out of range'); |
359
|
1
|
|
|
|
|
5
|
return; |
360
|
|
|
|
|
|
|
} |
361
|
8
|
|
|
|
|
23
|
$self->{day_c} = $dcx; |
362
|
8
|
|
|
|
|
22
|
$self->{day} = undef; |
363
|
8
|
|
|
|
|
19
|
$self->{sex} = undef; |
364
|
|
|
|
|
|
|
} |
365
|
19
|
50
|
66
|
|
|
241
|
if (not defined $self->{day_c} and defined $self->{day} |
|
|
|
66
|
|
|
|
|
366
|
|
|
|
|
|
|
and defined $self->{sex}) { |
367
|
3
|
|
|
|
|
7
|
$self->{day_c} = $self->{day}; |
368
|
3
|
100
|
|
|
|
18
|
$self->{day_c} += 40 if $self->{sex} eq 'F'; |
369
|
|
|
|
|
|
|
} |
370
|
19
|
|
|
|
|
71
|
return $self->{day_c}; |
371
|
|
|
|
|
|
|
} |
372
|
|
|
|
|
|
|
|
373
|
|
|
|
|
|
|
sub sex { |
374
|
5
|
|
|
5
|
1
|
10
|
my $self = shift; |
375
|
5
|
|
|
|
|
8
|
my ($sex) = @_; |
376
|
5
|
100
|
|
|
|
16
|
if (defined $sex) { |
377
|
3
|
50
|
|
|
|
14
|
unless ($sex =~ /^[MF]$/i) { |
378
|
0
|
|
|
|
|
0
|
$self->error('Sex can be either "M" or "F"'); |
379
|
0
|
|
|
|
|
0
|
return; |
380
|
|
|
|
|
|
|
} |
381
|
3
|
|
|
|
|
7
|
$self->{sex} = $sex; |
382
|
3
|
|
|
|
|
5
|
$self->{day_c} = undef; |
383
|
|
|
|
|
|
|
} |
384
|
5
|
100
|
66
|
|
|
42
|
if (not defined $self->{sex} and defined $self->{day_c}) { |
385
|
2
|
|
|
|
|
8
|
my $dayx = $self->_xnums($self->{day_c}); |
386
|
2
|
100
|
|
|
|
13
|
$self->{sex} = $dayx > 40 ? 'F' : 'M'; |
387
|
|
|
|
|
|
|
} |
388
|
5
|
|
|
|
|
24
|
return $self->{sex}; |
389
|
|
|
|
|
|
|
} |
390
|
|
|
|
|
|
|
|
391
|
|
|
|
|
|
|
sub bp { |
392
|
7
|
|
|
7
|
1
|
15
|
my $self = shift; |
393
|
7
|
|
|
|
|
10
|
my ($bp) = @_; |
394
|
7
|
100
|
|
|
|
20
|
if (defined $bp) { |
395
|
4
|
100
|
|
|
|
24
|
unless ($bp =~ /^[A-Z]\d\d\d$/) { # we could improve this |
396
|
2
|
|
|
|
|
5
|
$self->error('Invalid birthplace code'); |
397
|
2
|
|
|
|
|
8
|
return; |
398
|
|
|
|
|
|
|
} |
399
|
2
|
|
|
|
|
7
|
$self->{bp} = $bp; |
400
|
2
|
|
|
|
|
7
|
$self->{bp_c} = undef; |
401
|
|
|
|
|
|
|
} |
402
|
5
|
100
|
66
|
|
|
27
|
if (not defined $self->{bp} and defined $self->{bp_c}) { |
403
|
2
|
|
|
|
|
3
|
my $bpc = $self->{bp_c}; |
404
|
2
|
|
|
|
|
10
|
substr($bpc, 1) = $self->_xnums(substr($bpc, 1)); |
405
|
2
|
|
|
|
|
5
|
$self->{bp} = $bpc; |
406
|
|
|
|
|
|
|
} |
407
|
5
|
|
|
|
|
22
|
return $self->{bp}; |
408
|
|
|
|
|
|
|
} |
409
|
|
|
|
|
|
|
|
410
|
|
|
|
|
|
|
sub bp_c { |
411
|
19
|
|
|
19
|
0
|
30
|
my $self = shift; |
412
|
19
|
|
|
|
|
28
|
my ($bpcx) = @_; |
413
|
19
|
100
|
|
|
|
37
|
if (defined $bpcx) { |
414
|
10
|
|
|
|
|
16
|
my $bpc = $bpcx; |
415
|
10
|
|
|
|
|
34
|
substr($bpc, 1) = $self->_xnums(substr($bpc, 1)); |
416
|
10
|
100
|
|
|
|
48
|
unless ($bpc =~ /^[A-Z]\d\d\d$/) { # we could improve this |
417
|
1
|
|
|
|
|
5
|
$self->error('Invalid birthplace code'); |
418
|
1
|
|
|
|
|
4
|
return; |
419
|
|
|
|
|
|
|
} |
420
|
9
|
|
|
|
|
20
|
$self->{bp_c} = $bpcx; |
421
|
9
|
|
|
|
|
18
|
$self->{bp} = undef; |
422
|
|
|
|
|
|
|
} |
423
|
18
|
100
|
66
|
|
|
56
|
if (not defined $self->{bp_c} and defined $self->{bp}) { |
424
|
1
|
|
|
|
|
3
|
$self->{bp_c} = $self->{bp}; |
425
|
|
|
|
|
|
|
} |
426
|
18
|
|
|
|
|
62
|
return $self->{bp_c}; |
427
|
|
|
|
|
|
|
} |
428
|
|
|
|
|
|
|
|
429
|
|
|
|
|
|
|
sub bd_c { |
430
|
9
|
|
|
9
|
0
|
14
|
my $self = shift; |
431
|
9
|
|
|
|
|
83
|
my $bdc = ''; |
432
|
9
|
|
|
|
|
18
|
for (qw(year_c month_c day_c)) { |
433
|
27
|
|
|
|
|
193
|
my $t = $self->$_; |
434
|
27
|
50
|
|
|
|
124
|
unless (defined $t) { |
435
|
0
|
|
|
|
|
0
|
$self->error("Could not produce $_: some data is missing"); |
436
|
0
|
|
|
|
|
0
|
return; |
437
|
|
|
|
|
|
|
} |
438
|
27
|
|
|
|
|
52
|
$bdc .= $t; |
439
|
|
|
|
|
|
|
} |
440
|
9
|
|
|
|
|
19
|
return $bdc; |
441
|
|
|
|
|
|
|
} |
442
|
|
|
|
|
|
|
|
443
|
|
|
|
|
|
|
sub cf { |
444
|
2
|
|
|
2
|
1
|
275
|
my $self = shift; |
445
|
2
|
|
|
|
|
7
|
return $self->_crc(1); |
446
|
|
|
|
|
|
|
} |
447
|
|
|
|
|
|
|
|
448
|
|
|
|
|
|
|
sub crc { |
449
|
7
|
|
|
7
|
1
|
12
|
my $self = shift; |
450
|
7
|
|
|
|
|
19
|
return $self->_crc(0); |
451
|
|
|
|
|
|
|
} |
452
|
|
|
|
|
|
|
|
453
|
|
|
|
|
|
|
sub cf_nocrc { |
454
|
9
|
|
|
9
|
0
|
11
|
my $self = shift; |
455
|
9
|
|
|
|
|
16
|
my $cf = ''; |
456
|
9
|
|
|
|
|
19
|
for (qw(sn_c fn_c bd_c bp_c)) { |
457
|
36
|
|
|
|
|
88
|
my $t = $self->$_; |
458
|
36
|
50
|
|
|
|
73
|
unless (defined $t) { |
459
|
0
|
|
|
|
|
0
|
$self->error("Could not produce $_: some data is missing"); |
460
|
0
|
|
|
|
|
0
|
return; |
461
|
|
|
|
|
|
|
} |
462
|
36
|
|
|
|
|
68
|
$cf .= $t; |
463
|
|
|
|
|
|
|
} |
464
|
9
|
|
|
|
|
35
|
my $nums = substr($cf, 6, 2) . substr($cf, 9, 2) . substr($cf, 12, 3); |
465
|
9
|
50
|
|
|
|
21
|
unless ($self->_xnums($nums)) { |
466
|
0
|
|
|
|
|
0
|
$self->error('Invalid special characters'); |
467
|
0
|
|
|
|
|
0
|
return; |
468
|
|
|
|
|
|
|
} |
469
|
9
|
|
|
|
|
23
|
return $cf; |
470
|
|
|
|
|
|
|
} |
471
|
|
|
|
|
|
|
|
472
|
|
|
|
|
|
|
sub _crc { |
473
|
9
|
|
|
9
|
|
11
|
my $self = shift; |
474
|
9
|
|
|
|
|
15
|
my ($cf_out) = @_; |
475
|
9
|
|
|
|
|
29
|
my $cf = $self->cf_nocrc; |
476
|
9
|
50
|
|
|
|
21
|
unless ($cf) { |
477
|
0
|
|
|
|
|
0
|
$self->error("Cannot produce a Codice Fiscale: missing data"); |
478
|
0
|
|
|
|
|
0
|
return; |
479
|
|
|
|
|
|
|
} |
480
|
9
|
|
|
|
|
13
|
my $count = 0; |
481
|
9
|
|
|
|
|
24
|
for (my $i = 0; $i <= 14; $i++) { |
482
|
135
|
|
|
|
|
421
|
$count += $CRC{substr($cf, $i, 1)}[($i + 1) % 2]; |
483
|
|
|
|
|
|
|
} |
484
|
9
|
|
|
|
|
12
|
$count %= 26; |
485
|
9
|
100
|
|
|
|
64
|
return ($cf_out ? $cf : '') . chr(65 + $count); |
486
|
|
|
|
|
|
|
} |
487
|
|
|
|
|
|
|
|
488
|
|
|
|
|
|
|
sub parse { |
489
|
8
|
|
|
8
|
1
|
2375
|
my $proto = shift; |
490
|
8
|
|
|
|
|
248
|
my ($cf) = @_; |
491
|
8
|
|
|
|
|
21
|
$cf = uc $cf; |
492
|
8
|
100
|
|
|
|
27
|
unless (length($cf) == 16) { |
493
|
1
|
|
|
|
|
13
|
$proto->error('A valid Codice Fiscale must be exactly 16 chars long'); |
494
|
1
|
|
|
|
|
7
|
return; |
495
|
|
|
|
|
|
|
} |
496
|
7
|
|
|
|
|
80
|
my ($sn, $fn, $year, $month, $dayx, $born, $crc) = $cf =~ /$RE_cf/; |
497
|
7
|
50
|
|
|
|
21
|
unless ($crc) { |
498
|
0
|
|
|
|
|
0
|
$proto->error('Cannot parse: invalid format'); |
499
|
0
|
|
|
|
|
0
|
return; |
500
|
|
|
|
|
|
|
} |
501
|
|
|
|
|
|
|
|
502
|
7
|
|
|
|
|
29
|
my $obj = $proto->new( |
503
|
|
|
|
|
|
|
sn_c => $sn, |
504
|
|
|
|
|
|
|
fn_c => $fn, |
505
|
|
|
|
|
|
|
year_c => $year, |
506
|
|
|
|
|
|
|
month_c => $month, |
507
|
|
|
|
|
|
|
day_c => $dayx, |
508
|
|
|
|
|
|
|
bp_c => $born, |
509
|
|
|
|
|
|
|
); |
510
|
|
|
|
|
|
|
|
511
|
7
|
100
|
|
|
|
21
|
unless ($crc eq $obj->crc) { |
512
|
2
|
|
|
|
|
9
|
$proto->error('Invalid control character'); |
513
|
2
|
|
|
|
|
19
|
return; |
514
|
|
|
|
|
|
|
} |
515
|
5
|
|
|
|
|
18
|
return $obj; |
516
|
|
|
|
|
|
|
} |
517
|
|
|
|
|
|
|
|
518
|
|
|
|
|
|
|
sub validate { |
519
|
4
|
|
|
4
|
1
|
7
|
my $proto = shift; |
520
|
4
|
|
|
|
|
8
|
my ($cf) = @_; |
521
|
4
|
|
|
|
|
11
|
my $obj = $proto->parse($cf); |
522
|
4
|
100
|
|
|
|
21
|
return 1 if $obj; |
523
|
2
|
|
|
|
|
9
|
return; |
524
|
|
|
|
|
|
|
} |
525
|
|
|
|
|
|
|
|
526
|
|
|
|
|
|
|
|
527
|
|
|
|
|
|
|
sub error { |
528
|
19
|
|
|
19
|
1
|
31
|
my $proto = shift; |
529
|
19
|
|
|
|
|
27
|
my ($err) = @_; |
530
|
19
|
100
|
|
|
|
47
|
if (ref $proto) { |
531
|
16
|
50
|
|
|
|
45
|
$proto->{_err} = $err if defined $err; |
532
|
16
|
|
|
|
|
35
|
return $proto->{_err}; |
533
|
|
|
|
|
|
|
} |
534
|
|
|
|
|
|
|
|
535
|
3
|
50
|
|
|
|
17
|
$proto->ERROR($err) if defined $err; |
536
|
3
|
|
|
|
|
33
|
return $proto->ERROR; |
537
|
|
|
|
|
|
|
} |
538
|
|
|
|
|
|
|
|
539
|
|
|
|
|
|
|
{ |
540
|
|
|
|
|
|
|
|
541
|
|
|
|
|
|
|
my $tr_xnums = eval "sub {\$_[0] =~ tr/$XNUMS/0123456789/}"; |
542
|
|
|
|
|
|
|
|
543
|
|
|
|
|
|
|
sub _xnums { |
544
|
45
|
|
|
45
|
|
59
|
my $self = shift; |
545
|
45
|
|
|
|
|
68
|
my ($nums) = @_; |
546
|
45
|
50
|
|
|
|
212
|
return unless $nums =~ /^\d*[$XNUMS]*$/o; |
547
|
45
|
|
|
|
|
2076
|
$tr_xnums->($nums); |
548
|
45
|
|
|
|
|
412
|
return $nums; |
549
|
|
|
|
|
|
|
} |
550
|
|
|
|
|
|
|
|
551
|
|
|
|
|
|
|
} |
552
|
|
|
|
|
|
|
|
553
|
|
|
|
|
|
|
sub _n_re { |
554
|
8
|
|
|
8
|
|
15
|
my $self = shift; |
555
|
8
|
|
|
|
|
13
|
my ($method) = @_; |
556
|
8
|
|
|
|
|
46
|
(my $attr = $method) =~ s/_c$/_re/; |
557
|
8
|
100
|
|
|
|
212
|
return $self->{$attr} if defined $self->{$attr}; |
558
|
6
|
|
|
|
|
18
|
my $nc = $self->$method; |
559
|
6
|
50
|
|
|
|
60
|
unless ($nc) { |
560
|
0
|
0
|
|
|
|
0
|
$self->error('There is no coded ' . |
561
|
|
|
|
|
|
|
($method eq 'sn_c' ? 'sur' : '') . 'name set'); |
562
|
0
|
|
|
|
|
0
|
return; |
563
|
|
|
|
|
|
|
} |
564
|
|
|
|
|
|
|
|
565
|
6
|
|
|
|
|
77
|
my ($c, $v, $x) = $nc =~ /^([$CONSONANTS]*)([$VOWELS]*)(X*)$/o; |
566
|
6
|
|
|
|
|
12
|
my $pat; |
567
|
|
|
|
|
|
|
|
568
|
6
|
100
|
66
|
|
|
40
|
if (3 == length $c) { |
|
|
100
|
33
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
569
|
4
|
|
|
|
|
65
|
my @c = split('', $c); |
570
|
4
|
50
|
|
|
|
15
|
if ($method eq 'fn_c') { |
571
|
4
|
|
|
|
|
1000
|
$pat = qr/^(?: |
572
|
|
|
|
|
|
|
[$VOWELS]* $c[0] [$VOWELS]* |
573
|
|
|
|
|
|
|
[$CONSONANTS] [$VOWELS]* |
574
|
|
|
|
|
|
|
$c[1] [$VOWELS]* |
575
|
|
|
|
|
|
|
$c[2] [A-Z]* |
576
|
|
|
|
|
|
|
| |
577
|
|
|
|
|
|
|
[$VOWELS]* $c[0] [$VOWELS]* |
578
|
|
|
|
|
|
|
$c[1] [$VOWELS]* |
579
|
|
|
|
|
|
|
$c[2] [$VOWELS]* |
580
|
|
|
|
|
|
|
)$/xi; |
581
|
|
|
|
|
|
|
} else { |
582
|
0
|
|
|
|
|
0
|
$pat = qr/^ |
583
|
|
|
|
|
|
|
[$VOWELS]* $c[0] [$VOWELS]* |
584
|
|
|
|
|
|
|
$c[1] [$VOWELS]* |
585
|
|
|
|
|
|
|
$c[2] [A-Z]* |
586
|
|
|
|
|
|
|
$/xi; |
587
|
|
|
|
|
|
|
} |
588
|
|
|
|
|
|
|
} elsif (2 == length($c) and 1 == length($v)) { |
589
|
1
|
|
|
|
|
4
|
my @c = split('', $c); |
590
|
1
|
|
|
|
|
81
|
$pat = qr/^(?: |
591
|
|
|
|
|
|
|
$v [$VOWELS]* $c[0] [$VOWELS]* $c[1] [$VOWELS]* |
592
|
|
|
|
|
|
|
| |
593
|
|
|
|
|
|
|
$c[0] $v [$VOWELS]* $c[1] [$VOWELS]* |
594
|
|
|
|
|
|
|
| |
595
|
|
|
|
|
|
|
$c[0] $c[1] $v [$VOWELS]* |
596
|
|
|
|
|
|
|
)$/xi; |
597
|
|
|
|
|
|
|
} elsif (1 == length($c) and 2 == length($v)) { |
598
|
0
|
|
|
|
|
0
|
my @v = split('', $v); |
599
|
0
|
|
|
|
|
0
|
$pat = qr/^(?: |
600
|
|
|
|
|
|
|
$c $v[0] $v[1] [$VOWELS]* |
601
|
|
|
|
|
|
|
| |
602
|
|
|
|
|
|
|
$v[0] $c $v[1] [$VOWELS]* |
603
|
|
|
|
|
|
|
| |
604
|
|
|
|
|
|
|
$v[0] $v[1] [$VOWELS]* $c [$VOWELS]* |
605
|
|
|
|
|
|
|
)$/xi; |
606
|
|
|
|
|
|
|
} elsif (3 == length $v) { |
607
|
0
|
|
|
|
|
0
|
$pat = qr/^ $v [$VOWELS]* $/xi; |
608
|
|
|
|
|
|
|
} elsif (1 == length $x) { |
609
|
1
|
50
|
|
|
|
48
|
if (1 == length($c)) { |
610
|
1
|
|
|
|
|
212
|
$pat = qr/^(?: $c $v | $v $c )$/xi; |
611
|
|
|
|
|
|
|
} else { |
612
|
0
|
|
|
|
|
0
|
$pat = qr/^ $v $/xi; |
613
|
|
|
|
|
|
|
} |
614
|
|
|
|
|
|
|
} elsif (2 == length $x) { |
615
|
0
|
|
|
|
|
0
|
$pat = qr/^ $v $/xi; |
616
|
|
|
|
|
|
|
} else { |
617
|
0
|
|
|
|
|
0
|
$pat = qr/^ .* $/xi; |
618
|
|
|
|
|
|
|
} |
619
|
|
|
|
|
|
|
|
620
|
6
|
|
|
|
|
99
|
return $self->{$attr} = $pat; |
621
|
|
|
|
|
|
|
} |
622
|
|
|
|
|
|
|
|
623
|
|
|
|
|
|
|
sub _fix_name { |
624
|
6
|
|
|
6
|
|
15
|
$_[1] =~ tr/àÀèéÈÉìÌòÒùÙ/AAEEEEIIOOUU/; |
625
|
6
|
|
|
|
|
16
|
$_[1] =~ tr/a-zA-Z//cd; |
626
|
|
|
|
|
|
|
} |
627
|
|
|
|
|
|
|
|
628
|
|
|
|
|
|
|
{ |
629
|
|
|
|
|
|
|
|
630
|
|
|
|
|
|
|
my $count_consonants = eval "sub {\$_[0] =~ tr/$CONSONANTS/$CONSONANTS/}"; |
631
|
|
|
|
|
|
|
|
632
|
6
|
|
|
6
|
|
217
|
sub _count_consonants { return $count_consonants->($_[1]) } |
633
|
|
|
|
|
|
|
|
634
|
|
|
|
|
|
|
} |
635
|
|
|
|
|
|
|
|
636
|
|
|
|
|
|
|
|
637
|
|
|
|
|
|
|
sub _croak { |
638
|
0
|
|
|
0
|
|
|
my $self = shift; |
639
|
0
|
|
|
|
|
|
confess @_; |
640
|
|
|
|
|
|
|
} |
641
|
|
|
|
|
|
|
|
642
|
|
|
|
|
|
|
1; |
643
|
|
|
|
|
|
|
__END__ |