File Coverage

blib/lib/Number/Phone/FR.pm
Criterion Covered Total %
statement 101 123 82.1
branch 25 46 54.3
condition 3 6 50.0
subroutine 23 38 60.5
pod 23 23 100.0
total 175 236 74.1


line stmt bran cond sub pod time code
1 12     12   188977 use utf8;
  12         213  
  12         164  
2 12     12   565 use strict;
  12         113  
  12         408  
3 12     12   101 use warnings;
  12         36  
  12         1027  
4              
5             package Number::Phone::FR;
6              
7             # $VERSION is limited to 2 digits after the dot
8             # Other digits are reserved for ARCEP data versonning
9             # in Number::Phone::FR::Full
10             our $VERSION = '0.09';
11              
12 12     12   5972 use Number::Phone;
  12         98738  
  12         85  
13 12     12   8205 use parent 'Number::Phone';
  12         4453  
  12         85  
14              
15 12     12   949 use Carp;
  12         54  
  12         1186  
16 12     12   106 use Scalar::Util 'blessed';
  12         33  
  12         8292  
17              
18             my %pkg2impl;
19              
20             # Select the implementation to use via "use Number::Phone::FR"
21              
22             sub import
23             {
24 68     68   45829 my $class = shift;
25 68 50       720 croak "invalid sub-class" unless $class->isa(__PACKAGE__);
26 68 50       314 if ($class eq __PACKAGE__) {
27 68 100       2985 if (@_) {
28 8         26 $class = $_[0];
29 8         110 $class =~ s/^:?(.)/\U$1/;
30 8         45 substr($class, 0, 0) = __PACKAGE__.'::';
31              
32 8         23 my $level = 0;
33 8         23 my $pkg;
34 8         136 while (($pkg = (caller $level)[0]) =~ /^Number::Phone(?:::|$)/) {
35 0         0 $level++;
36             }
37 8         39 $pkg2impl{$pkg} = $class;
38              
39             # Load the class
40 8 50       808 eval "require $class; 1" or croak "$@\n";
41 8 50       10243 $class->isa(__PACKAGE__) or croak "$class is not a valid class";
42             }
43             } else {
44             #croak "unexpected arguments for import" if @_;
45 0         0 my $pkg = (caller)[0];
46 0 0       0 croak "$class is private" unless $pkg =~ m/^Number::Phone(?:::|$)/;
47 0         0 $pkg2impl{$pkg} = $class;
48             }
49             }
50              
51             #END {
52             # foreach (sort keys %pkg2impl) {
53             # print STDERR "# $_ => $pkg2impl{$_}\n";
54             # }
55             #}
56              
57              
58             # Select the implementation based on $pkg2impl
59             sub _get_class
60             {
61 744     744   1875 my ($class) = @_;
62 744 50 66     3499 return $class if defined $class && $class ne __PACKAGE__;
63 744         1784 my $level = 0;
64 744         1578 my ($pkg, $impl);
65 744         7507 while ($pkg = (caller $level)[0]) {
66 2152         6923 $impl = $pkg2impl{$pkg};
67 2152 100       7163 return $impl if defined $impl;
68 1658         9019 $level++;
69             }
70             # Default implementation
71 250         714 return __PACKAGE__;
72             }
73              
74              
75 12         2714 use constant RE_SUBSCRIBER =>
76             qr{
77             \A
78             (?:
79             \+33 # Préfixe international (+33 numéro)
80             | (?:3651)?
81             (?:
82             [04789] # Transporteur par défaut (0) ou Sélection du transporteur
83             | 16 [0-9]{2} # Sélection du transporteur
84             ) (?:033)? # Préfixe international (0033 numéro)
85             ) ([1-9][0-9]{8}) # Numéro de ligne
86             \z
87 12     12   128 }xs;
  12         42  
88              
89 12         32471 use constant RE_FULL =>
90             qr{
91             \A (?:
92             1 (?:
93             0[0-9]{2} # Opérateur
94             | 5 # SAMU
95             | 7 # Police/gendarmerie
96             | 8 # Pompiers
97             | 1 (?:
98             2 # Numéro d'urgence européen
99             | 5 # Urgences sociales
100             | 6000 # 116000 : Enfance maltraitée
101             | 8[0-9]{3} # 118XYZ : Renseignements téléphoniques
102             | 9 # Enfance maltraitée
103             )
104             )
105             | 3[0-9]{3}
106             | (?:
107             \+33 # Préfixe international (+33 numéro)
108             | (?:3651)? # Préfixe d'anonymisation
109             (?:
110             [04789] # Transporteur par défaut (0) ou Sélection du transporteur
111             | 16 [0-9]{2} # Sélection du transporteur
112             ) (?:033)? # Préfixe international (0033 numéro)
113             ) [1-9][0-9]{8} # Numéro de ligne
114             ) \z
115 12     12   109 }xs;
  12         43  
116              
117              
118              
119              
120             sub country_code() { 33 }
121              
122             # Number::Phone's implementation of country() does not yet allow
123             # clean subclassing so we explicitely implement it here
124             sub country() { 'FR' }
125              
126              
127             sub new
128             {
129 231     231 1 111463 my $class = shift;
130 231         588 my $number = shift;
131 231 50       843 $class = ref $class if ref $class;
132              
133 231         746 $class = _get_class($class);
134              
135 231 50       892 croak "No number given to ".__PACKAGE__."->new()\n" unless defined $number;
136 231 50       776 croak "Invalid phone number (scalar expected)" if ref $number;
137              
138 231         592 my $num = $number;
139 231         839 $num =~ s/[^+0-9]//g;
140 231 50       1526 return Number::Phone->new("+$1") if $num =~ /\A(?:\+|00)((?:[^3]|3[^3]).*)\z/;
141              
142 231 100       847 return is_valid($number) ? bless(\$num, $class) : undef;
143             }
144              
145              
146             sub is_valid
147             {
148 324     324 1 195834 my ($number) = (@_);
149 324 50 33     1818 return 1 if blessed($number) && $number->isa(__PACKAGE__);
150              
151 324         1185 my $class = _get_class();
152 324         4049 return $number =~ $class->RE_FULL;
153             }
154              
155              
156             sub is_allocated
157             {
158             undef
159 0     0 1 0 }
160              
161             sub is_in_use
162             {
163             undef
164 0     0 1 0 }
165              
166             sub _num(\@)
167             {
168 392     392   888 my $args = shift;
169 392         951 my $num = shift @$args;
170 392         1015 my $class = ref $num;
171 392 100       1104 if ($class) {
172 203         861 $num = ${$num};
  203         571  
173             } else {
174 189         540 $class = _get_class();
175 189         523 $num = shift @$args;
176             }
177 392         1837 return ($class, $num);
178             }
179              
180             # Vérifie les chiffres du numéro de ligne
181             # Les numéros spéciaux ne matchent pas
182             sub _check_line
183             {
184 180     180   614 my ($class, $num) = _num(@_);
185 180         1662 my @matches = ($num =~ $class->RE_SUBSCRIBER);
186 180 50       798 return 0 unless @matches;
187 180         509 my $line = (grep { defined } @matches)[0];
  240         854  
188 180 100       1676 return 1 if $line =~ shift;
189             undef
190 90         772 }
191              
192             sub is_geographic
193             {
194 60     60 1 387 return _check_line(@_, qr/\A[1-5].{8}\z/)
195             }
196              
197             sub is_fixed_line
198             {
199 60     60 1 367 return _check_line(@_, qr/\A[1-5].{8}\z/)
200             }
201              
202             sub is_mobile
203             {
204 60     60 1 8107 return _check_line(@_, qr/\A[67].{8}\z/)
205             }
206              
207             sub is_pager
208             {
209             undef
210 0     0 1 0 }
211              
212             sub is_ipphone
213             {
214 0     0 1 0 return _check_line(@_, qr/\A9/)
215             }
216              
217             sub is_isdn
218             {
219             undef
220 0     0 1 0 }
221              
222             sub is_tollfree
223             {
224             #return 1
225             # FIXME Gérer les préfixes
226 0 0   0 1 0 return 0 unless $_[1] =~ /\A08[0-9]{8}\z/;
227             undef
228 0         0 }
229              
230             sub is_specialrate
231             {
232             # FIXME Gérer les préfixes
233 0 0   0 1 0 return 0 unless $_[1] =~ /\A08[0-9]{8}\z/;
234 0         0 1
235             }
236              
237             sub is_adult
238             {
239 0 0   0 1 0 return 0 unless _check_line(@_, qr/\A8/);
240             undef
241 0         0 }
242              
243             sub is_personal
244             {
245             undef
246 0     0 1 0 }
247              
248             sub is_corporate
249             {
250             undef
251 0     0 1 0 }
252              
253             sub is_government
254             {
255             undef
256 0     0 1 0 }
257              
258             sub is_international
259             {
260             undef
261 0     0 1 0 }
262              
263             sub is_network_service
264             {
265 54     54 1 14065 my ($class, $num) = _num(@_);
266             # Les services réseau sont en direct : jamais de préfixe
267 54 50       528 ($num =~ /\A1(?:|[578]|0[0-9]{2}|1(?:[259]|6000|8[0-9]{3}))\z/) ? 1 : 0
268             }
269              
270             sub areacode
271             {
272             undef
273 0     0 1 0 }
274              
275             sub areaname
276             {
277             undef
278 0     0 1 0 }
279              
280             sub location
281             {
282             undef
283 0     0 1 0 }
284              
285             sub subscriber
286             {
287 152     152 1 12180 my ($class, $num) = _num(@_);
288 152         1285 my @m = ($num =~ $class->RE_SUBSCRIBER);
289 152 100       787 return undef unless @m;
290 98         284 @m = grep { defined } @m;
  136         657  
291 98         711 $m[0];
292             }
293              
294             my %length_to_format = (
295             # 2 => as is
296             4 => sub { s/\A(..)(..)/$1 $2/ },
297             6 => sub { s/\A(...)(...)/$1 $2/ },
298             10 => sub { s/(\d\d)(?=.)/$1 /g },
299             13 => sub {
300             s/\A(00)(33)(.)(..)(..)(..)(..)\z/+$2 $3 $4 $5 $6 $7/
301             || s/\A(....)(.)(..)(..)(..)(..)\z/+33 $1 $2 $3 $4 $5 $6/
302             },
303             14 => sub { s/\A(....)(..)(..)(..)(..)(..)\z/$1 $2 $3 $4 $5 $6/ },
304             12 => sub { s/\A(\+33)(.)(..)(..)(..)(..)\z/$1 $2 $3 $4 $5 $6/ },
305             16 => sub { s/\A(\+33)(....)(.)(..)(..)(..)(..)\z/$1 $2 $3 $4 $5 $6 $7/ },
306             );
307              
308             sub format
309             {
310 6     6 1 8569 my ($class, $num) = _num(@_);
311 6         21 my $l = length $num;
312 6         23 my $fmt = $length_to_format{$l};
313             return defined $fmt
314 6 50       33 ? do {
315 6         19 local $_ = $num;
316 6         29 $fmt->();
317 6         59 $_;
318             }
319             : $num;
320             }
321              
322              
323              
324             package Number::Phone::FR::Simple;
325              
326 12     12   310 use parent 'Number::Phone::FR';
  12         58  
  12         89  
327              
328             BEGIN {
329 12     12   1619 $INC{'Number/Phone/FR/Simple.pm'} = __FILE__;
330             }
331              
332             1;
333             __END__