File Coverage

blib/lib/Number/Phone/JP.pm
Criterion Covered Total %
statement 122 133 91.7
branch 22 28 78.5
condition 1 3 33.3
subroutine 45 45 100.0
pod 30 30 100.0
total 220 239 92.0


line stmt bran cond sub pod time code
1             package Number::Phone::JP;
2              
3 22     22   263888 use strict;
  22         53  
  22         734  
4 22     22   111 use warnings;
  22         39  
  22         575  
5 22     22   387 use 5.008_001;
  22         82  
6 22     22   9382 use parent qw(Number::Phone);
  22         6564  
  22         107  
7 22     22   574795 use Carp;
  22         52  
  22         1356  
8 22     22   9869 use UNIVERSAL::require;
  22         23797  
  22         195  
9              
10             our $VERSION = '0.20190507';
11             our %TEL_TABLE = ();
12              
13             sub import {
14 89     89   20628 my $self = shift;
15 89         2183 %TEL_TABLE = ();
16 89 100       563 if (@_) {
17 14         35 for my $subclass (@_) {
18 15         43 my $package = _table_class_name($subclass);
19 15 50       90 $package->require or croak $@;
20             {
21 22     22   2197 no strict 'refs';
  22         46  
  22         14932  
  15         171  
22 15         75 while (my($k, $v) = each %{"$package\::TEL_TABLE"}) {
  461         1244  
23 446 100       631 if ($TEL_TABLE{$k}) {
24             $TEL_TABLE{$k} =
25 1         4 '(?:' . $TEL_TABLE{$k} . '|' . $v . ')';
26             }
27             else {
28 445         666 $TEL_TABLE{$k} = $v;
29             }
30             }
31             }
32             }
33             }
34             else {
35 75         3889 require Number::Phone::JP::Table;
36 75         266 import Number::Phone::JP::Table;
37             }
38 89         3436 return $self;
39             }
40              
41             sub new {
42 82     82 1 17358 my $class = shift;
43 82         188 my $self = bless {}, $class;
44 82 100       380 $self->set_number(@_) if @_;
45 82         434 return $self;
46             }
47              
48             sub set_number {
49 66219     66219 1 378426 my $self = shift;
50 66219         99969 my $number = shift;
51 66219 50       436522 if (ref($number) eq 'ARRAY') {
    50          
    100          
    50          
52 0         0 $self->_prefix = shift @$number;
53 0         0 (my $num = join('', @$number)) =~ s/\D+//g;
54 0         0 $self->_number = $num;
55             }
56             elsif (defined $_[0]) {
57 0         0 $self->_prefix = $number;
58 0         0 (my $num = join('', @_)) =~ s/\D+//g;
59 0         0 $self->_number = $num;
60             }
61             elsif ($number =~ /^\D*(0\d+)\D(.+)$/) {
62 66152         139801 my $pref = $1;
63 66152         106138 my $num = $2;
64 66152         129187 $pref =~ s/\D+//g;
65 66152         96435 $num =~ s/\D+//g;
66 66152         134270 $self->_prefix = $pref;
67 66152         110644 $self->_number = $num;
68             }
69             elsif ($number =~ s/^\+81//) {
70 67         163 $self->_prefix = ();
71 67         133 $self->_number = ();
72 67         171 for (my $i = 1; $i < length $number; $i++) {
73 597         894 my $pref = substr $number, 0, $i;
74 597 100       1381 if ($TEL_TABLE{$pref}) {
75 79         161 $self->_prefix = "0$pref";
76 79         167 $self->_number = substr $number, $i;
77             }
78             }
79             }
80             else {
81 0         0 carp "The number is invalid telephone number.";
82 0         0 $self->_prefix = ();
83 0         0 $self->_number = ();
84             }
85 66219         239740 return $self;
86             }
87              
88             sub is_valid_number {
89 66163     66163 1 100546 my $self = shift;
90 66163 50 33     96720 unless ($self->_prefix || $self->_number) {
91 0         0 carp "Any number was not set";
92 0         0 return;
93             }
94 66163         106343 my $pref = $self->_prefix;
95 66163 50       230033 return unless $pref =~ s/^0//;
96 66163         139527 my $re = $TEL_TABLE{$pref};
97 66163 100       111098 return unless defined $re;
98 65944         112475 return $self->_number =~ /^$re$/;
99             }
100              
101 198749     198749   360288 sub _prefix : lvalue { shift->{_prefix} }
102 132255     132255   723048 sub _number : lvalue { shift->{_number} }
103              
104             {
105 22     22   217 no warnings 'once';
  22         61  
  22         3490  
106             *is_valid = \&is_valid_number;
107             }
108              
109             sub _table_class_name {
110 127     127   205 my $subclass = shift;
111 127         722 return sprintf('%s::Table::%s', __PACKAGE__, ucfirst(lc($subclass)));
112             }
113              
114             sub _is_this_type {
115 110     110   223 my($self, $type) = @_;
116 110         208 my $package = _table_class_name($type);
117 110         495 $package->require;
118 110         3591 my $pref = $self->_prefix;
119 110         329 $pref =~ s/^0//;
120 22     22   159 no strict 'refs';
  22         60  
  22         3403  
121 110         198 return exists ${"$package\::TEL_TABLE"}{$pref};
  110         710  
122             }
123              
124             sub is_mobile {
125 22     22 1 39 my $self = shift;
126 22         45 my $result = $self->_is_this_type('mobile');
127 22 100       112 return $result unless $result;
128 4         10 my $pref = $self->_prefix;
129 4         12 $pref =~ s/^0//;
130 4 100       19 return $result if $pref ne '70';
131 2         5 my $package = _table_class_name('mobile');
132 22     22   187 no strict 'refs';
  22         47  
  22         9843  
133 2         5 my $re = ${"$package\::TEL_TABLE"}{$pref};
  2         8  
134 2         5 return $self->_number =~ /^$re$/;
135             }
136              
137 22     22 1 55 sub is_pager { return shift->_is_this_type('pager') }
138 22     22 1 57 sub is_ipphone { return shift->_is_this_type('ipphone') }
139 22     22 1 52 sub is_tollfree { return shift->_is_this_type('freedial') }
140 22     22 1 55 sub is_specialrate { return shift->_is_this_type('q2') }
141              
142 1     1 1 10 sub is_allocated { undef }
143 1     1 1 373 sub is_in_use { undef }
144 1     1 1 347 sub is_geographic { undef }
145 1     1 1 341 sub is_fixed_line { undef }
146 1     1 1 361 sub is_isdn { undef }
147 1     1 1 341 sub is_adult { undef }
148 1     1 1 340 sub is_personal { undef }
149 1     1 1 338 sub is_corporate { undef }
150 1     1 1 339 sub is_government { undef }
151 1     1 1 339 sub is_international { undef }
152 1     1 1 336 sub is_network_service { undef }
153              
154 22     22 1 76 sub country_code { return 81 }
155              
156 1     1 1 336 sub regulator { undef }
157 1     1 1 336 sub areacode { undef }
158 1     1 1 351 sub areaname { undef }
159 1     1 1 336 sub location { undef }
160 1     1 1 333 sub subscriber { undef }
161 1     1 1 367 sub operator { undef }
162 1     1 1 339 sub type { undef }
163              
164             sub format {
165 11     11 1 22 my $self = shift;
166 11         25 my $pref = $self->_prefix;
167 11         48 $pref =~ s/^0//;
168 11         24 return sprintf '+%s %s %s', $self->country_code, $pref, $self->_number;
169             }
170              
171 1     1 1 336 sub country { undef }
172 1     1 1 335 sub translates_to { undef }
173              
174             1;
175             __END__