build-data.stubs

#!/usr/bin/env perl

# THIS SCRIPT IS NOT INTENDED FOR END USERS OR FOR PEOPLE INSTALLING
# THE MODULES, BUT FOR THE AUTHOR'S USE WHEN UPDATING THE DATA FROM OFCOM'S
# PUBLISHED DATA.

use strict;
use warnings;
use Data::Dumper;
use File::Find::Rule;

$Data::Dumper::Indent = 2;
$Data::Dumper::Sortkeys = 1;

use lib 'lib';
use Number::Phone::Country;
use Number::Phone::NANP::Data;

use lib 'buildtools';
use Number::Phone::BuildHelpers;

$| = 1;

use XML::XPath;
my $xml = XML::XPath->new(filename => 'libphonenumber/resources/PhoneNumberMetadata.xml');
my @territories = $xml->find('/phoneNumberMetadata/territories/territory')->get_nodelist();

my %prefix_to_timezones;
open(my $timezones_fh, "<:encoding(utf8)", 'libphonenumber/resources/timezones/map_data.txt')
  or die "Opening 'map_data.txt': $!\n";
while (my $line = <$timezones_fh>)  {
  $line =~ s/^\s+|\s+$//g;

  # Skip empty or comment lines
  if (!$line || $line =~ /^#/) {
     next;
  }

  # Assert pipe deliminated
  if ($line !~ /\|/) {
    die "malformatted data, expected '|''\n";
  }

  my ($prefix, $tz_string) = split(/\|/, $line, 2);
  unless ($tz_string) {
    die "missing time zones\n";
  }

  if ($prefix_to_timezones{$prefix}) {
    die "duplicated prefix $prefix\n";
  }

  $prefix_to_timezones{$prefix} = $tz_string;
}
close($timezones_fh);

open(my $manifest_fh, 'MANIFEST') || die("Can't read MANIFEST\n");
my @manifest_files = grep { /./ } <$manifest_fh>;
close($manifest_fh);
open($manifest_fh, '>', 'MANIFEST') || die("Can't write MANIFEST\n");
print $manifest_fh "$_" foreach( grep { $_ !~ m{^lib/Number/Phone/StubCountry/\w+\.pm} } @manifest_files);

mkdir('lib/Number/Phone/StubCountry');
mkdir('t/lib');
mkdir('t/lib/Number');
mkdir('t/lib/Number/Phone');
my $dir = 'lib/Number/Phone/StubCountry';

my @us_formats = formats_for($xml->find(
    '/phoneNumberMetadata/territories/territory[@id="US"]')->get_node(1)
);

my @gb_formats = formats_for($xml->find(
    '/phoneNumberMetadata/territories/territory[@id="GB"]')->get_node(1)
);

unlink(glob('lib/Number/Phone/StubCountry/*pm'));

TERRITORY: foreach my $territory (@territories) {
  my $IDD_country_code = ''.$territory->find('@countryCode');
  my $national_code = ''.$territory->find('@nationalPrefixForParsing') || ''.$territory->find('@nationalPrefix');
  my $national_prefix_transform_rule = ''.$territory->find('@nationalPrefixTransformRule');

  # see https://github.com/DrHyde/perl-modules-Number-Phone/issues/101
  $national_prefix_transform_rule = '' if($IDD_country_code == 44);

  my $ISO_country_code = ''.$territory->find('@id');
  if(is_dodgy_unknown_country($ISO_country_code, $IDD_country_code)) {
      warn("skipping 'country' $ISO_country_code (+$IDD_country_code)\n");
      next TERRITORY;
  }

  my $final_class_part = get_final_class_part($ISO_country_code, $IDD_country_code);
  my $filename = "$dir/$final_class_part.pm";

  open(my $module_fh, '>:encoding(UTF-8)', $filename)
    || die("Can't write $filename: $!\n");
  print $manifest_fh "$filename\n";
  print $module_fh preamble($final_class_part);

  my @formatters = formats_for($territory, $ISO_country_code);
  print $module_fh 'my '.Data::Dumper->new([\@formatters], [qw(formatters)])->Dump()."\n";
  my $validators = {
      specialrate => join('|', grep { $_ ne '()' } map {
          '('.$territory->find("$_/nationalNumberPattern")->string_value().')'
      } qw(sharedCost premiumRate uan)),
      map {
          (my $xpath = $_) =~ s/_(\w)/uc($1)/eg;
          ($_ => $territory->find("$xpath/nationalNumberPattern")->string_value());
      } qw(fixed_line mobile pager voip toll_free personal_number)
  };

  $validators->{geographic} = $validators->{fixed_line};
  if($IDD_country_code == 1) {
      # see if build-nanp detected dodgy data
      if(!exists($Number::Phone::NANP::Data::fixed_line_regexes{$ISO_country_code})) {
          $validators->{geographic} = '('.$validators->{fixed_line}.'|'.$validators->{mobile}.')';
          delete $validators->{fixed_line};
          delete $validators->{mobile};
      }
  }
  # Similarly to +1, don't pass is_mobile or is_fixed_line if could be either
  if ($validators->{fixed_line} && $validators->{fixed_line} eq $validators->{mobile}) {
      delete $validators->{fixed_line};
      delete $validators->{mobile};
  }
  print $module_fh 'my '.Data::Dumper->new([$validators], [qw(validators)])->Dump();

  my $got_area_names = 0;
  my %areanames = ();
  CODEFILE: foreach my $codesfile (File::Find::Rule->file()->name("$IDD_country_code.txt")->in("libphonenumber/resources/geocoding")) {
    $codesfile =~ /\/(..)\/$IDD_country_code.txt$/;
    my $language = $1 || next CODEFILE;

    if($IDD_country_code == 1) {
      print $module_fh "use Number::Phone::NANP::Data;\nsub areaname {\n";
      if($ISO_country_code !~ /^(US|CA|JM)$/) {
          # we have explicit tests for US and CA areaname, and use JM to
          # check it DTRT when there's no data
          print $module_fh "# uncoverable subroutine - no data for most NANP countries
                            # uncoverable statement\n";
      }
      print $module_fh "Number::Phone::NANP::Data::_areaname('1'.shift()->{number}); }\n";
    } elsif(-e $codesfile) {
      open(my $geocoding, '<:encoding(UTF-8)', $codesfile) || die("Can't read $codesfile\n");
      print $module_fh "my %areanames = ();\n" unless($got_area_names);
      $got_area_names = 1;
      my @lines = <$geocoding>;
      foreach my $line (@lines) {
        chomp($line);
        next if($line =~ /^(#.*|\s+)?$/);
        my($prefix, $area) = split(/\|/, $line);
        $areanames{$language}->{$prefix} = $area;
      }
    }
  }
  # now de-dupe. We always fall back to English if no data is available, so
  # if eg $areanames{fr}->{33105} is the same as $areanames{en}->{33105}
  # delete it from the fr data
  foreach my $language (grep { $_ ne 'en' } keys %areanames) {
      foreach my $prefix (keys %{$areanames{'en'}}) {
          if(exists($areanames{$language}->{$prefix}) && $areanames{$language}->{$prefix} eq $areanames{en}->{$prefix}) {
              delete $areanames{$language}->{$prefix};
          }
      }
  }

  foreach my $language (keys %areanames) {
      print $module_fh "\$areanames{$language} = {";
      print $module_fh join("\n", map { "\"$_\", \"".quotemeta($areanames{$language}->{$_})."\"," } keys %{$areanames{$language}});
      print $module_fh "};\n";
  }

  my %timezones;

  while (my ($prefix, $tz_string) = each %prefix_to_timezones) {
    if ($prefix !~ /^$IDD_country_code/) {
      next;
    }

    my $national_prefix = $prefix =~ s/^$IDD_country_code//r;

    # For NANP phone numbers, we only need to include timezone mappings if the prefix
    # might apply to the country. E.g. Jamiaca which also use the +1 country code do
    # not need to include timezone mappings for Texas area codes.
    if ($IDD_country_code eq "1") {
      my ($area) = $national_prefix =~ /^1(\d{3})/; # take the next 3 digits (if they exit)
      if ($area && $area !~ /^($Number::Phone::Country::NANP_areas{$ISO_country_code})$/x) {
        next;
      }
    }

    $timezones{$national_prefix} = [split(/&/, $tz_string)];
  }

  print $module_fh 'my '.Data::Dumper->new([\%timezones], [qw(timezones)])->Dump();

  print $module_fh "
    sub new {
      my \$class = shift;
      my \$number = shift;
      \$number =~ s/(^\\+$IDD_country_code|\\D)//g;
      my \$self = bless({ country_code => '$IDD_country_code', number => \$number, formatters => \$formatters, validators => \$validators, timezones => \$timezones, ".
      (($IDD_country_code != 1 && $got_area_names) ? 'areanames => \\%areanames' : '')
      ."}, \$class);
  ";

  if ($national_code ne '' && $IDD_country_code ne '1') {
    $national_code =~ s/\s+//g;
    # Suppressing the warning below is for if the national code optionally
    # matches part of the number that would then be in the transform rule
    my @code = "return \$self if (\$self->is_valid());";

    if ($national_prefix_transform_rule eq '') {
      # There is no national prefix transform rule, so just delete the national
      # prefix, if present.
      push @code, "  \$number =~ s/^(?:$national_code)//;";
    }
    else {
      # There is a national prefix transform rule.
      push @code,
        "  my \$prefix = qr/^(?:$national_code)/;",
        "  my \@matches = \$number =~ /\$prefix/;",
        "  if (defined \$matches[-1]) {",
        # We have a match in the last capturing group.  Assume that the
        # transform rule can be applied.
        "    no warnings 'uninitialized';",
        "    \$number =~ s/\$prefix/$national_prefix_transform_rule/;",
        "  }",
        "  else {",
        # We don't have a match in the last capturing group.  Assume that the
        # transform rule cannot be applied, and instead, just delete the
        # national prefix, if present.
        "    \$number =~ s/\$prefix//;",
        "  }";
    }

    push @code,
      "  \$self = bless({ country_code => '$IDD_country_code', number => \$number, formatters => \$formatters, validators => \$validators, ".
      (($IDD_country_code != 1 && $got_area_names) ? 'areanames => \\%areanames' : '')
      ."}, \$class);";

    print $module_fh join "\n", map {"    $_"} @code;
    print $module_fh "\n";
  }

  print $module_fh "      return \$self->is_valid() ? \$self : undef;\n";
  print $module_fh "    }\n1;";
}

sub preamble {
  my $final_class_part = shift;
  "# automatically generated file, don't edit\n\n".
  q{

# Copyright 2024 David Cantrell, derived from data from libphonenumber
# http://code.google.com/p/libphonenumber/
#
# Licensed under the Apache License, Version 2.0 (the "License");
# you may not use this file except in compliance with the License.
# You may obtain a copy of the License at
#
#     http://www.apache.org/licenses/LICENSE-2.0
#
# Unless required by applicable law or agreed to in writing, software
# distributed under the License is distributed on an "AS IS" BASIS,
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
# See the License for the specific language governing permissions and
# limitations under the License.
package Number::Phone::StubCountry::}.$final_class_part.q{;
use base qw(Number::Phone::StubCountry);

use strict;
use warnings;
use utf8;
}.
  "our \$VERSION = 1.".join("", (gmtime())[5] + 1900, sprintf('%02d', (gmtime())[4] + 1), map { sprintf('%02d', $_) } (gmtime())[3, 2, 1, 0]).";\n\n";
}

sub formats_for {
  my ($territory, $ccode) = @_;

  return @us_formats if(
    $ccode && $ccode ne 'US' && ''.$territory->find('@countryCode') eq '1'
  );

  return @gb_formats if(
    $ccode && $ccode =~ /^(IM|JE|GG)$/
  );

  my $national_code = ''.$territory->find('@nationalPrefix');
  my $territory_national_rule = ''.$territory->find('@nationalPrefixFormattingRule');

  my @number_formats = $territory->find('availableFormats/numberFormat')->get_nodelist();

  my @formatters = ();
  foreach my $number_format (@number_formats) {
    my $number_format_pattern = ''.$number_format->find('@pattern');
    # only interested in the last one,
    # see https://github.com/DrHyde/perl-modules-Number-Phone/issues/7
    my $leading_digit_pattern = ($number_format->find('leadingDigits')->get_nodelist())[-1];
    my $formatter = ''.$number_format->find('format');
    my $formatter_intl = ''.$number_format->find('intlFormat');

    my $national_rule = ''.$number_format->find('@nationalPrefixFormattingRule') || $territory_national_rule;
    $national_rule =~ s/\$NP/$national_code/;
    $national_rule =~ s/\$FG/\$1/;

    if($leading_digit_pattern) {
      ($leading_digit_pattern = $leading_digit_pattern->string_value()); # =~ s/\s//g;
    }
    push @formatters, {
      $leading_digit_pattern ? (leading_digits => $leading_digit_pattern) : (),
      $national_rule ? (national_rule => $national_rule) : (),
      format => $formatter,
      $formatter_intl ? (intl_format => $formatter_intl) : (),
      pattern => $number_format_pattern
    };
  }
  return @formatters;

}