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

package Number::Phone::JP;

use strict;
use warnings;
use 5.008_001;
use parent qw(Number::Phone);
use Carp;
use UNIVERSAL::require;

our $VERSION = '0.20190521';
our %TEL_TABLE = ();

sub import {
    my $self = shift;
    %TEL_TABLE = ();
    if (@_) {
        for my $subclass (@_) {
            my $package = _table_class_name($subclass);
            $package->require or croak $@;
            {
                no strict 'refs';
                while (my($k, $v) = each %{"$package\::TEL_TABLE"}) {
                    if ($TEL_TABLE{$k}) {
                        $TEL_TABLE{$k} =
                            '(?:' . $TEL_TABLE{$k} . '|' . $v . ')';
                    }
                    else {
                        $TEL_TABLE{$k} = $v;
                    }
                }
            }
        }
    }
    else {
        require Number::Phone::JP::Table;
        import  Number::Phone::JP::Table;
    }
    return $self;
}

sub new {
    my $class = shift;
    my $self = bless {}, $class;
    $self->set_number(@_) if @_;
    return $self;
}

sub set_number {
    my $self   = shift;
    my $number = shift;
    if (ref($number) eq 'ARRAY') {
        $self->_prefix = shift @$number;
        (my $num = join('', @$number)) =~ s/\D+//g;
        $self->_number = $num;
    }
    elsif (defined $_[0]) {
        $self->_prefix = $number;
        (my $num = join('', @_)) =~ s/\D+//g;
        $self->_number = $num;
    }
    elsif ($number =~ /^\D*(0\d+)\D(.+)$/) {
        my $pref = $1;
        my $num  =  $2;
        $pref =~ s/\D+//g;
        $num  =~ s/\D+//g;
        $self->_prefix = $pref;
        $self->_number = $num;
    }
    elsif ($number =~ s/^\+81//) {
        $self->_prefix = ();
        $self->_number = ();
        for (my $i = 1; $i < length $number; $i++) {
            my $pref = substr $number, 0, $i;
            if ($TEL_TABLE{$pref}) {
                $self->_prefix = "0$pref";
                $self->_number = substr $number, $i;
            }
        }
    }
    else {
        carp "The number is invalid telephone number.";
        $self->_prefix = ();
        $self->_number = ();
    }
    return $self;
}

sub is_valid_number {
    my $self = shift;
    unless ($self->_prefix || $self->_number) {
        carp "Any number was not set";
        return;
    }
    my $pref = $self->_prefix;
    return unless $pref =~ s/^0//;
    my $re = $TEL_TABLE{$pref};
    return unless defined $re;
    return $self->_number =~ /^$re$/;
}

sub _prefix : lvalue { shift->{_prefix} }
sub _number : lvalue { shift->{_number} }

{
    no warnings 'once';
    *is_valid = \&is_valid_number;
}

sub _table_class_name {
    my $subclass = shift;
    return sprintf('%s::Table::%s', __PACKAGE__, ucfirst(lc($subclass)));
}

sub _is_this_type {
    my($self, $type) = @_;
    my $package = _table_class_name($type);
    $package->require;
    my $pref = $self->_prefix;
    $pref =~ s/^0//;
    no strict 'refs';
    return exists ${"$package\::TEL_TABLE"}{$pref};
}

sub is_mobile {
    my $self = shift;
    my $result = $self->_is_this_type('mobile');
    return $result unless $result;
    my $pref = $self->_prefix;
    $pref =~ s/^0//;
    return $result if $pref ne '70';
    my $package = _table_class_name('mobile');
    no strict 'refs';
    my $re = ${"$package\::TEL_TABLE"}{$pref};
    return $self->_number =~ /^$re$/;
}

sub is_pager       { return shift->_is_this_type('pager')    }
sub is_ipphone     { return shift->_is_this_type('ipphone')  }
sub is_tollfree    { return shift->_is_this_type('freedial') }
sub is_specialrate { return shift->_is_this_type('q2')       }

sub is_allocated       { undef }
sub is_in_use          { undef }
sub is_geographic      { undef }
sub is_fixed_line      { undef }
sub is_isdn            { undef }
sub is_adult           { undef }
sub is_personal        { undef }
sub is_corporate       { undef }
sub is_government      { undef }
sub is_international   { undef }
sub is_network_service { undef }

sub country_code { return 81 }

sub regulator  { undef }
sub areacode   { undef }
sub areaname   { undef }
sub location   { undef }
sub subscriber { undef }
sub operator   { undef }
sub type       { undef }

sub format {
    my $self = shift;
    my $pref = $self->_prefix;
    $pref =~ s/^0//;
    return sprintf '+%s %s %s', $self->country_code, $pref, $self->_number;
}

sub country       { undef }
sub translates_to { undef }

1;
__END__