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   281188 use strict;
  22         50  
  22         8542  
4 22     22   105 use warnings;
  22         61  
  22         667  
5 22     22   417 use 5.008_001;
  22         69  
6 22     22   24784 use parent qw(Number::Phone);
  22         6374  
  22         100  
7 22     22   615655 use Carp;
  22         45  
  22         1315  
8 22     22   8711 use UNIVERSAL::require;
  22         31030  
  22         190  
9              
10             our $VERSION = '0.20190401';
11             our %TEL_TABLE = ();
12              
13             sub import {
14 89     89   35584 my $self = shift;
15 89         2382 %TEL_TABLE = ();
16 89 100       540 if (@_) {
17 14         34 for my $subclass (@_) {
18 15         39 my $package = _table_class_name($subclass);
19 15 50       100 $package->require or croak $@;
20             {
21 22     22   1959 no strict 'refs';
  22         46  
  22         13790  
  15         181  
22 15         29 while (my($k, $v) = each %{"$package\::TEL_TABLE"}) {
  461         1185  
23 446 100       615 if ($TEL_TABLE{$k}) {
24             $TEL_TABLE{$k} =
25 1         3 '(?:' . $TEL_TABLE{$k} . '|' . $v . ')';
26             }
27             else {
28 445         716 $TEL_TABLE{$k} = $v;
29             }
30             }
31             }
32             }
33             }
34             else {
35 75         3584 require Number::Phone::JP::Table;
36 75         253 import Number::Phone::JP::Table;
37             }
38 89         3618 return $self;
39             }
40              
41             sub new {
42 82     82 1 16537 my $class = shift;
43 82         172 my $self = bless {}, $class;
44 82 100       395 $self->set_number(@_) if @_;
45 82         364 return $self;
46             }
47              
48             sub set_number {
49 66219     66219 1 380275 my $self = shift;
50 66219         98428 my $number = shift;
51 66219 50       446186 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         163891 my $pref = $1;
63 66152         133229 my $num = $2;
64 66152         137609 $pref =~ s/\D+//g;
65 66152         88453 $num =~ s/\D+//g;
66 66152         152519 $self->_prefix = $pref;
67 66152         118501 $self->_number = $num;
68             }
69             elsif ($number =~ s/^\+81//) {
70 67         139 $self->_prefix = ();
71 67         120 $self->_number = ();
72 67         158 for (my $i = 1; $i < length $number; $i++) {
73 597         782 my $pref = substr $number, 0, $i;
74 597 100       1617 if ($TEL_TABLE{$pref}) {
75 79         144 $self->_prefix = "0$pref";
76 79         137 $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         242610 return $self;
86             }
87              
88             sub is_valid_number {
89 66163     66163 1 97976 my $self = shift;
90 66163 50 33     101699 unless ($self->_prefix || $self->_number) {
91 0         0 carp "Any number was not set";
92 0         0 return;
93             }
94 66163         101653 my $pref = $self->_prefix;
95 66163 50       249914 return unless $pref =~ s/^0//;
96 66163         151205 my $re = $TEL_TABLE{$pref};
97 66163 100       125981 return unless defined $re;
98 65944         127111 return $self->_number =~ /^$re$/;
99             }
100              
101 198749     198749   406722 sub _prefix : lvalue { shift->{_prefix} }
102 132255     132255   784862 sub _number : lvalue { shift->{_number} }
103              
104             {
105 22     22   188 no warnings 'once';
  22         50  
  22         3002  
106             *is_valid = \&is_valid_number;
107             }
108              
109             sub _table_class_name {
110 127     127   184 my $subclass = shift;
111 127         666 return sprintf('%s::Table::%s', __PACKAGE__, ucfirst(lc($subclass)));
112             }
113              
114             sub _is_this_type {
115 110     110   168 my($self, $type) = @_;
116 110         457 my $package = _table_class_name($type);
117 110         429 $package->require;
118 110         3126 my $pref = $self->_prefix;
119 110         284 $pref =~ s/^0//;
120 22     22   141 no strict 'refs';
  22         62  
  22         3070  
121 110         155 return exists ${"$package\::TEL_TABLE"}{$pref};
  110         581  
122             }
123              
124             sub is_mobile {
125 22     22 1 32 my $self = shift;
126 22         48 my $result = $self->_is_this_type('mobile');
127 22 100       95 return $result unless $result;
128 4         9 my $pref = $self->_prefix;
129 4         12 $pref =~ s/^0//;
130 4 100       16 return $result if $pref ne '70';
131 2         6 my $package = _table_class_name('mobile');
132 22     22   151 no strict 'refs';
  22         51  
  22         10944  
133 2         4 my $re = ${"$package\::TEL_TABLE"}{$pref};
  2         9  
134 2         5 return $self->_number =~ /^$re$/;
135             }
136              
137 22     22 1 53 sub is_pager { return shift->_is_this_type('pager') }
138 22     22 1 48 sub is_ipphone { return shift->_is_this_type('ipphone') }
139 22     22 1 46 sub is_tollfree { return shift->_is_this_type('freedial') }
140 22     22 1 53 sub is_specialrate { return shift->_is_this_type('q2') }
141              
142 1     1 1 11 sub is_allocated { undef }
143 1     1 1 283 sub is_in_use { undef }
144 1     1 1 264 sub is_geographic { undef }
145 1     1 1 260 sub is_fixed_line { undef }
146 1     1 1 257 sub is_isdn { undef }
147 1     1 1 257 sub is_adult { undef }
148 1     1 1 260 sub is_personal { undef }
149 1     1 1 256 sub is_corporate { undef }
150 1     1 1 257 sub is_government { undef }
151 1     1 1 277 sub is_international { undef }
152 1     1 1 258 sub is_network_service { undef }
153              
154 22     22 1 62 sub country_code { return 81 }
155              
156 1     1 1 256 sub regulator { undef }
157 1     1 1 256 sub areacode { undef }
158 1     1 1 256 sub areaname { undef }
159 1     1 1 258 sub location { undef }
160 1     1 1 294 sub subscriber { undef }
161 1     1 1 258 sub operator { undef }
162 1     1 1 256 sub type { undef }
163              
164             sub format {
165 11     11 1 18 my $self = shift;
166 11         23 my $pref = $self->_prefix;
167 11         45 $pref =~ s/^0//;
168 11         29 return sprintf '+%s %s %s', $self->country_code, $pref, $self->_number;
169             }
170              
171 1     1 1 258 sub country { undef }
172 1     1 1 256 sub translates_to { undef }
173              
174             1;
175             __END__