/usr/share/perl5/Number/Phone/UK.pm is in libnumber-phone-perl 3.0014-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 | package Number::Phone::UK;
use strict;
use Scalar::Util 'blessed';
use Number::Phone::UK::Data;
use base 'Number::Phone';
our $VERSION = 1.65;
my $cache = {};
=head1 NAME
Number::Phone::UK - UK-specific methods for Number::Phone
=head1 SYNOPSIS
use Number::Phone;
$daves_phone = Number::Phone->new('+44 1234 567890');
=cut
sub new {
my $class = shift;
my $number = shift;
die("No number given to ".__PACKAGE__."->new()\n") unless($number);
$number = '+44'._clean_number($number);
if(is_valid($number)) {
$number =~ s/^0/+44/;
return bless(\$number, $class->_get_class(_clean_number($number)));
} else { return undef; }
}
=head1 METHODS
The following methods from Number::Phone are overridden:
=over 4
=item is_valid
The number is valid within the national numbering scheme. It may or may
not yet be allocated, or it may be reserved. Any number which returns
true for any of the following methods will also be valid.
=cut
sub _get_class {
my $class = shift;
my $number = shift;
foreach my $prefix (_prefixes($number)) {
if(exists($Number::Phone::UK::Data::db->{subclass}->{$prefix})) {
my $subclass = join('::', $class, $Number::Phone::UK::Data::db->{subclass}->{$prefix});
eval "use $subclass";
die($@) if($@);
return $subclass;
}
}
return $class;
}
sub _clean_number {
my $clean = shift;
$clean =~ s/[^0-9+]//g; # strip non-digits/plusses
$clean =~ s/^\+44//; # remove leading +44
$clean =~ s/^0//; # kill leading zero
return $clean;
}
sub _prefixes {
my $number = shift;
map { substr($number, 0, $_) } reverse(1..length($number));
}
sub is_valid {
my $number = shift;
# If called as an object method, it *must* be valid otherwise the
# object would never have been instantiated.
# If called as a subroutine, that's the constructor doing its thang.
return 1 if(blessed($number) && $number->isa(__PACKAGE__));
# otherwise we have to validate
# if we've seen this number before, use cached result
return 1 if($cache->{$number}->{is_valid});
# assume it's OK unless proven otherwise
$cache->{$number}->{is_valid} = 1;
my $cleaned_number = _clean_number($number);
my @prefixes = _prefixes($cleaned_number);
# quickly check length
return $cache->{$number}->{is_valid} = 0 if(length($cleaned_number) < 7 || length($cleaned_number) > 10);
# slightly more rigourous length check for some unallocated geographic numbers
# 07, 02x and 011x are always ten digits
return $cache->{$number}->{is_valid} = 0 if($cleaned_number =~ /^([27]|11)/ && length($cleaned_number) != 10);
$cache->{$number}->{is_allocated} =
grep { $Number::Phone::UK::Data::db->{telco_and_length}->{$_} } @prefixes;
if($cache->{$number}->{is_allocated}) {
my($telco_and_length) = map { $Number::Phone::UK::Data::db->{telco_and_length}->{$_} } grep { $Number::Phone::UK::Data::db->{telco_and_length}->{$_} } @prefixes;
$cache->{$number}->{operator} = $Number::Phone::UK::Data::db->{telco_format}->{$telco_and_length}->{telco};
$cache->{$number}->{format} = $Number::Phone::UK::Data::db->{telco_format}->{$telco_and_length}->{format};
if(defined($cache->{$number}->{format}) && $cache->{$number}->{format} =~ /\+/) {
my($arealength, $subscriberlength) = split(/\+/, $cache->{$number}->{format});
# for hateful mixed thing
my @subscriberlengths = ($subscriberlength =~ m{/}) ? split(/\//, $subscriberlength) : ($subscriberlength);
$subscriberlength =~ s/^(\d+).*/$1/; # for hateful mixed thing
$cache->{$number}->{areacode} = substr($cleaned_number, 0, $arealength);
$cache->{$number}->{subscriber} = substr($cleaned_number, $arealength);
$cache->{$number}->{areaname} = (
map {
$Number::Phone::UK::Data::db->{areanames}->{$_}
} grep { $Number::Phone::UK::Data::db->{areanames}->{$_} } @prefixes
)[0];
if(!grep { length($cache->{$number}->{subscriber}) == $_ } @subscriberlengths) {
# number wrong length!
$cache->{$number} = { is_valid => 0 };
return 0;
}
}
}
return $cache->{$number}->{is_valid};
}
# now define the is_* methods that we over-ride
sub is_fixed_line {
return 0 if(is_mobile(@_));
return undef;
}
foreach my $is (qw(
geographic network_service tollfree corporate
personal pager mobile specialrate adult allocated ipphone
)) {
no strict 'refs';
*{__PACKAGE__."::is_$is"} = sub {
my $self = shift;
if(!exists($cache->{${$self}}->{"is_$is"})) {
$cache->{${$self}}->{"is_$is"} =
grep {
$Number::Phone::UK::Data::db->{
{ geographic => 'geo_prefices',
network_service => 'network_svc_prefices',
tollfree => 'free_prefices',
corporate => 'corporate_prefices',
personal => 'personal_prefices',
pager => 'pager_prefices',
mobile => 'mobile_prefices',
specialrate => 'special_prefices',
adult => 'adult_prefices',
ipphone => 'ip_prefices'
}->{$is}
}->{$_}
} _prefixes(_clean_number(${$self}));
}
$cache->{${$self}}->{"is_$is"};
}
}
# define the other methods
foreach my $method (qw(operator areacode areaname subscriber)) {
no strict 'refs';
*{__PACKAGE__."::$method"} = sub {
my $self = shift;
return $cache->{${$self}}->{$method};
}
}
=item is_allocated
The number has been allocated to a telco for use. It may or may not yet
be in use or may be reserved.
=item is_geographic
The number refers to a geographic area.
=item is_fixed_line
The number, when in use, can only refer to a fixed line.
(we can't tell whether a number is a fixed line, but we can tell that
some are *not*).
=item is_mobile
The number, when in use, can only refer to a mobile phone.
=item is_pager
The number, when in use, can only refer to a pager.
=item is_tollfree
Callers will not be charged for calls to this number under normal circumstances.
=item is_specialrate
The number, when in use, attracts special rates. For instance, national
dialling at local rates, or premium rates for services.
=item is_adult
The number, when in use, goes to a service of an adult nature, such as porn.
=item is_personal
The number, when in use, goes to an individual person.
=item is_corporate
The number, when in use, goes to a business.
=item is_ipphone
The number, when in use, is terminated using VoIP.
=item is_network_service
The number is some kind of network service such as a human operator, directory
enquiries, emergency services etc
=item country_code
Returns 44.
=cut
sub country_code { 44; }
=item regulator
Returns informational text.
=cut
sub regulator { 'OFCOM, http://www.ofcom.org.uk/'; }
=item areacode
Return the area code - if applicable - for the number. If not applicable,
returns undef.
=item areaname
Return the area name - if applicable - for the number, or undef.
=item location
For geographic numbers, this returns the location of the exchange to which
that number is assigned, if available. Otherwise returns undef.
=cut
sub location {
my $self = shift;
return undef unless($self->is_geographic());
my $cleaned_number = _clean_number(${$self});
my @prefixes = _prefixes($cleaned_number);
eval "require Number::Phone::UK::DetailedLocations" unless($ENV{TESTINGKILLTHEWABBIT});
require Number::Phone::UK::Exchanges if(!$Number::Phone::UK::Exchanges::db);
foreach(@prefixes) {
if(exists($Number::Phone::UK::Exchanges::db->{exchg_prefices}->{$_})) {
return [
$Number::Phone::UK::Exchanges::db->{exchg_positions}->{$Number::Phone::UK::Exchanges::db->{exchg_prefices}->{$_}}->{lat},
$Number::Phone::UK::Exchanges::db->{exchg_positions}->{$Number::Phone::UK::Exchanges::db->{exchg_prefices}->{$_}}->{long}
];
}
}
return undef;
}
=item subscriber
Return the subscriber part of the number
=item operator
Return the name of the telco operating this number, in an appropriate
character set and with optional details such as their web site or phone
number.
=item format
Return a sanely formatted version of the number, complete with IDD code, eg
for the UK number (0208) 771-2924 it would return +44 20 87712924.
=cut
sub format {
my $self = shift;
return (
# if there's an areacode ...
$self->areacode() ? ('+'.country_code().' '.$self->areacode().' '.(
length($self->subscriber()) == 7 ? substr($self->subscriber(), 0, 3).' '.substr($self->subscriber(), 3) :
length($self->subscriber()) == 8 ? substr($self->subscriber(), 0, 4).' '.substr($self->subscriber(), 4) :
$self->subscriber() )) :
# if not allocated ...
!$self->is_allocated() ? '+'.country_code().' '.( ${$self} =~ /^\+44/ ? substr(${$self}, 3) : substr(${$self}, 1)) :
# if there's a subscriber ...
$self->subscriber() ? '+'.country_code().' '.$self->subscriber :
# otherwise ...
${$self}
);
}
=item intra_country_dial_to
Within the UK numbering plan you can *always* dial 0xxxx xxxxxx
for intra-country calls. In most places the leading 0$areacode is
optional but in some it is required (see
L<http://consumers.ofcom.org.uk/dial-the-code/>) and over time this
will apply to more areas.
=cut
sub intra_country_dial_to {
my $from = shift;
my $to = shift;
return '0'.($to->areacode() ? $to->areacode() : '').$to->subscriber();
}
=item country
If the number is_international, return the two-letter ISO country code.
NYI
=back
=head1 LIMITATIONS/BUGS/FEEDBACK
The results are only as up-to-date as the data included from OFCOM's
official documentation of number range allocations.
No attempt is made to deal with number portability.
Please report bugs at L<https://github.com/DrHyde/perl-modules-Number-Phone/issues>, including, if possible, a test case.
I welcome feedback from users.
=head1 LICENCE
You may use, modify and distribute this software under the same terms as
perl itself.
=head1 AUTHOR
David Cantrell E<lt>david@cantrell.org.ukE<gt>
Copyright 2012
=cut
1;
|