File Coverage

blib/lib/URI/tel.pm

Criterion	Covered	Total	%
statement	270	396	68.1
branch	127	206	61.6
condition	39	77	50.6
subroutine	29	44	65.9
pod	18	30	60.0
total	483	753	64.1

##----------------------------------------------------------------------------
## URI::tel - ~/lib/URI/tel.pm
## Version v0.801.1
## Copyright(c) 2021 DEGUEST Pte. Ltd.
## Author: Jacques Deguest
## Created 2016/02/12
## Modified 2021/08/18
## All rights reserved
##
## This program is free software; you can redistribute  it  and/or  modify  it
## under the same terms as Perl itself.
##----------------------------------------------------------------------------
package URI::tel;
BEGIN
{
    use strict;
    use parent 'URI';
    our( $VERSION, $VERBOSE, $DEBUG, $ERROR );
    our( $RESERVED, $MARK, $UNRESERVED, $PCT_ENCODED, $URIC, $ALPHA, $DIGIT, $ALPHANUM, $HEXDIG );
    our( $PARAM_UNRESERVED, $VISUAL_SEPARATOR, $PHONEDIGIT, $GLOBAL_NUMBER_DIGITS, $PARAMCHAR, $DOMAINLABEL, $TOPLABEL, $DOMAINNAME, $DESCRIPTOR, $PNAME, $PVALUE, $PARAMETER, $EXTENSION, $ISDN_SUBADDRESS, $CONTEXT, $PAR, $PHONEDIGIT_HEX, $GLOBAL_NUMBER, $LOCAL_NUMBER, $OTHER, $TEL_SUBSCRIBER, $TEL_URI, $VANITY, $VANITY_LOCAL );
    our( $COUNTRIES, $IDD_RE );
    $VERSION     = 'v0.801.1';
    use overload ('""'     => 'as_string',
                  '=='     => sub { _obj_eq(@_) },
                  '!='     => sub { !_obj_eq(@_) },
                  fallback => 1,
                 );
};

{
    #$RESERVED              = qr{[\[\;\/\?\:\@\&\=\+\$\,\[\]]+};
    $RESERVED               = q{[;/?:@&=+$,[]+};
    $MARK                   = q{-_.!~*'()};                                    #'; emacs
    $UNRESERVED             = qq{A-Za-z0-9\Q$MARK\E};
    ## "%" HEXDIG HEXDIG
    $PCT_ENCODED            = qr{\%[0-9A-Fa-f]{2}};
    #$URIC       = quotemeta( $RESERVED ) . $UNRESERVED . "%";
    $URIC                   = qr{(?:[\Q$RESERVED\E]+|[$UNRESERVED]+|(?:$PCT_ENCODED)+)};
#   $ALPHA                  = qr{A-Za-z};
#   $DIGIT                  = qr{\d};
    $ALPHA                  = qr{A-Za-z};
    $DIGIT                  = qq{0-9};
#   $ALPHANUM               = qr{A-Za-z\d};
    $ALPHANUM               = qq{A-Za-z0-9};
#   $HEXDIG                 = qr{\dA-F};
    $HEXDIG                 = qr{\dA-F};
#   $PARAM_UNRESERVED       = qr{[\[\]\/\:\&\+\$]+};
    $PARAM_UNRESERVED       = q{[]/:&+$};
    $VISUAL_SEPARATOR       = q(-.());
    ## DIGIT / [ visual-separator ]
#   $PHONEDIGIT             = qr{$DIGIT\Q$VISUAL_SEPARATOR\E};
    $PHONEDIGIT             = qq{$DIGIT\Q$VISUAL_SEPARATOR\E};
    ## "+" *phonedigit DIGIT *phonedigit
    $GLOBAL_NUMBER_DIGITS   = qr{\+[$PHONEDIGIT]*[$DIGIT]+[$PHONEDIGIT]*};
    ## param-unreserved / unreserved / pct-encoded
    $PARAMCHAR              = qr{(?:[\Q$PARAM_UNRESERVED\E]+|[$UNRESERVED]+|(?:$PCT_ENCODED)+)};
    ## alphanum / alphanum *( alphanum / "-" ) alphanum
    $DOMAINLABEL            = qr{(?:[$ALPHANUM]+|[$ALPHANUM]+(?:[$ALPHANUM\-]+)*[$ALPHANUM]+)};
    ## ALPHA / ALPHA *( alphanum / "-" ) alphanum
    $TOPLABEL               = qr{(?:[$ALPHA]+|[$ALPHA]+[$ALPHANUM\-]*[$ALPHANUM]+)};
    ## *( domainlabel "." ) toplabel [ "." ]
    $DOMAINNAME             = qr{(?:$DOMAINLABEL\.)*(?:$TOPLABEL\.?)+};
    ## domainname / global-number-digits
    $DESCRIPTOR             = qr{(?:$DOMAINNAME|$GLOBAL_NUMBER_DIGITS)};
    ## 1*( alphanum / "-" )
    $PNAME                  = qr{[$ALPHANUM\-]+};
    ## 1*paramchar
    $PVALUE                 = qr{(?:$PARAMCHAR)};
    ## ";" pname ["=" pvalue ]
    $PARAMETER              = qr{\;$PNAME=$PVALUE};
    ## ";ext=" 1*phonedigit
    ##$EXTENSION                = qr{\;ext=[$PHONEDIGIT]+}msxi;
    ## Tweaking the rfc regular expression to add often used extension format
    ## See: https://discussions.apple.com/thread/1635858?start=0&tstart=0
    ## or
    ## http://stackoverflow.com/questions/2403767/string-format-phone-numbers-with-extension
    $EXTENSION              = qr{(?:[\;\,]?ext[\=\.]?|x)[$PHONEDIGIT]+}msxi;
    ## ";isub=" 1*uric
    $ISDN_SUBADDRESS        = qr{\;isub=$URIC}msxi;
    ## ";phone-context=" descriptor
    $CONTEXT                = qr{\;phone-context=$DESCRIPTOR}msxi;
    ## parameter / extension / isdn-subaddress
    $PAR                    = qr{(?:(?:($PARAMETER)|($EXTENSION)|($ISDN_SUBADDRESS)))+};
    ## HEXDIG / "*" / "#" / [ visual-separator ]
    $PHONEDIGIT_HEX         = qr{[$HEXDIG\*\#$VISUAL_SEPARATOR]+};
    ## *phonedigit-hex (HEXDIG / "*" / "#")*phonedigit-hex
    $LOCAL_NUMBER_DIGITS    = qr{(?:$PHONEDIGIT_HEX)?[$HEXDIG\*\#]+(?:$PHONEDIGIT_HEX)?};
    ## global-number-digits *par => "+" *phonedigit DIGIT *phonedigit
    $GLOBAL_NUMBER          = qr{($GLOBAL_NUMBER_DIGITS)($PAR)*};
    ## local-number-digits *par context *par
    $LOCAL_NUMBER           = qr{($LOCAL_NUMBER_DIGITS)($PAR)*($CONTEXT)($PAR)*};
    ## This is a non-rfc standard requirement, but a necessity to catch local number with no context
    ## such as 03-1234-5678 plain and simple
    $OTHER                  = qr{(\+?[$PHONEDIGIT]*[$DIGIT]+[$PHONEDIGIT]*)($PAR)*};
    ## Like +1-800-LAWYR-UP => [phone]
    $VANITY_LOCAL           = qr{[A-Z0-9\Q$VISUAL_SEPARATOR\E]+[$PHONEDIGIT]*};
    $VANITY                 = qr{(\+?[$PHONEDIGIT]*$VANITY_LOCAL)};
    $TEL_SUBSCRIBER         = qr{(?:$VANITY|$GLOBAL_NUMBER|$LOCAL_NUMBER|$OTHER)}xs;
    ##$TEL_SUBSCRIBER     = qr{(?:$GLOBAL_NUMBER)};
    $TEL_URI                = qr{(?:tel\:)?$TEL_SUBSCRIBER};
    # https://tools.ietf.org/search/rfc3966#section-3

    $COUNTRIES = {};
}

sub _init
{
    my $class = shift( @_ );
    my( $str, $scheme ) = @_;
    # find all funny characters and encode the bytes.
    $str = $class->_uric_escape( $str );
    $str = "$scheme:$str" unless $str =~ /^[a-zA-Z][a-zA-Z0-9.+\-]*:/o ||
                                 $class->_no_scheme_ok;
    return( $class->new( $str ) );
}

sub new
{
    my $this = shift( @_ );
    my $str  = shift( @_ );
    my $class = ref( $this ) || $this;
    my $orig  = $str;
    $str      =~ s/[[:blank:]]+//gs;
    my $temp  = {};
    my @matches = ();
    my @names = ();
    if( @matches = $str =~ /^((?:tel\:)?$GLOBAL_NUMBER)$/ )
    {
        @names = qw( all subscriber params last_param );
        $temp->{type} = 'global';
    }
    elsif( @matches = $str =~ /^((?:tel\:)?$LOCAL_NUMBER)$/ )
    {
        $temp->{type} = 'local';
        @names = qw( all subscriber params1 last_param1 ignore5 ignore6 context params2 last_param2 ignore10 ignore11 );
        $temp->{_has_context_param} = 1 if( length( $matches[6] ) );
        $temp->{local_number} = $str;
        $temp->{local_number} =~ s/^tel\://;
    }
    ## e.g. 911, 110 or just ordinary local phones like 03-1234-5678
    elsif( @matches = $str =~ /^((?:tel\:)?$OTHER)$/ )
    {
        $temp->{type} = 'other';
        @names = qw( all subscriber params ignore4 last_param );
        $temp->{local_number} = $matches[1];
    }
    ## e.g. +1-800-LAWYR-UP
    elsif( @matches = $str =~ /^((?:tel\:)?$VANITY)$/ )
    {
        $temp->{type} = 'vanity';
        @names = qw( all subscriber );
        my $prefix = $this->_extract_intl_code( $matches[0] );
        if( $prefix )
        {
            $temp->{local_number} = $this->_extract_local_number( "\+$prefix", $matches[1] );
        }
        else
        {
            $temp->{local_number} = $matches[1];
        }
    }
    else
    {
        $ERROR = "Unknown telephone number '$str'.";
        warn( $ERROR );
    }

    ## The component name for each match
    @$temp{ @names } = @matches;

    $temp->{params} = $temp->{params1} ? $temp->{params1} : $temp->{params2} if( !length( $temp->{params} ) );
    $temp->{context} =~ s/;[^=]+=(.*?)$/$1/gs;

    if( $str =~ /^(?:tel\:)?\+/ )
    {
        $temp->{intl_code} = $this->_extract_intl_code( $str );
    }
    elsif( $temp->{context} &&
        $temp->{context} !~ /^[a-zA-Z]/ &&
        substr( $temp->{context}, 0, 1 ) eq '+' )
    {
        $temp->{intl_code} = $this->_extract_intl_code( $temp->{context} );
        ## We flag it as extracted from context, because we do not want to prepend the subscriber number with it.
        ## It's just too dangerous as we cannot tell the subscriber number is actually a proper number that can be dialed from outside e.g. 911 or 110 are emergency number who may heva a context with international code
        ## However, if the international code was provided by the user then that's his responsibility
        ## If the user wants to just provide some context, then better to use context() instead.
        ## Knowing the international code helps getting some other useful information, but it should not necessarily affect the format of the number
        $temp->{_intl_code_from_context} = 1;
    }
    $temp->{context} = '+' . $temp->{intl_code} if( !length( $temp->{context} ) && length( $temp->{intl_code} ) );

    if( $temp->{type} eq 'global' && $temp->{intl_code} )
    {
        $temp->{local_number} = $this->_extract_local_number( $temp->{intl_code}, $temp->{subscriber} );
    }

    my $hash  = {
    'original'      => ( $orig ne $str ) ? $orig : $temp->{all},
    'is_global'     => $temp->{type} eq 'global' ? 1 : 0,
    'is_local'      => ( $temp->{type} eq 'local' or $temp->{type} eq 'other' ) ? 1 : 0,
    'is_other'      => $temp->{type} eq 'other' ? 1 : 0,
    'is_vanity'     => $temp->{type} eq 'vanity' ? 1 : 0,
    'subscriber'    => $temp->{subscriber},
    'params'        => $temp->{params},
    'last_param'    => $temp->{last_param} ? $temp->{last_param} : $temp->{last_param1} ? $temp->{last_param1} : $temp->{last_param2},
    'context'       => $temp->{context},
    'intl_code'     => $temp->{intl_code},
    '_intl_code_from_context' => $temp->{_intl_code_from_context},
    'local_number'  => $temp->{local_number},
    };
    my $self  = bless( $hash, $class );
    my $prams = [];
    if( length( $temp->{params} ) )
    {
        my $pram_str = $temp->{params};
        $pram_str    =~ s/^[\.\,\#\;]//;
        $prams    = [ $self->split_str( $pram_str ) ];
    }
    ## Private parameters
    my $priv  = {};
    foreach my $this ( @$prams )
    {
        $this =~ s/^(x|ext)\.?(\d+)$/ext=$2/i;
        my( $p, $v ) = split( /=/, $this, 2 );
        $p =~ s/\-/\_/gs;
        if( lc( $p ) =~ /^(ext|isdn_subaddress)$/ )
        {
            $hash->{ lc( $p ) } = $v;
        }
        elsif( lc( $p ) eq 'phone_context' )
        {
            $hash->{context} = $v;
            $temp->{_has_context_param} = 1;
        }
        else
        {
            $priv->{ lc( $p ) } = $v;
        }
    }
    $self->{private} = $priv;
    $self->{ext} = $temp->{ext} if( !length( $hash->{ext} ) && !$self->{is_vanity} );
    $self->{ext} =~ s/\D//gs;
    ## Because a context may be +81 or it could be a domain name example.com
    ## if we had it as a parameter at instantiation, we remember it and honour it when we stringify
    $self->{_prepend_context} = $temp->{_has_context_param} ? 0 : 1;
    return( $self );
}

sub as_string
{
    my $self = shift( @_ );
    return( $self->{cache} ) if( length( $self->{cache} ) );
    my @uri = ( 'tel:' . $self->{subscriber} ) if( length( $self->{subscriber} ) );
    my @params = ();
    push( @params, sprintf( "ext=%s", $self->{ext} ) ) if( length( $self->{ext} ) );
    push( @params, sprintf( "isub=%s", $self->{isdn_subaddress} ) ) if( length( $self->{isdn_subaddress} ) );
    if( length( $self->{context} ) )
    {
        if( !$self->{_prepend_context} )
        {
            push( @params, sprintf( "phone-context=%s", $self->{context} ) );
        }
        ## Context is not some domain name
        elsif( $self->{subscriber} !~ /^\+\d+/ && $self->{context} !~ /[a-zA-Z]+/ )
        {
            @uri = ( 'tel:' . $self->{context} . '-' . $self->{subscriber} );
        }
    }
    if( length( $self->{intl_code} ) && !$self->{_intl_code_from_context} )
    {
        if( $self->{subscriber} !~ /^\+\d+/ && $uri[0] !~ /^tel\:\+/ )
        {
            @uri = ( 'tel:' . '+' . $self->{intl_code} . '-' . $self->{subscriber} );
        }
    }
    my $priv = $self->{private};
    foreach my $k ( sort( keys( %$priv ) ) )
    {
        push( @params, sprintf( "$k=%s", $priv->{ $k } ) ) if( length( $priv->{ $k } ) );
    }
    push( @uri, join( ';', @params ) ) if( scalar( @params ) );
    $self->{cache} = join( ';', @uri );
    return( $self->{cache} );
}

sub letters2digits { return( shift->aton( @_ ) ); }

sub aton
{
    my $self = shift( @_ );
    my $str  = shift( @_ ) || $self->{subscriber};
    my $letters = 'abcdefghijklmnopqrstuvwxyz';
    my $digits  = '22233344455566677778889999';
    return( $str ) if( $str !~ /[a-zA-Z]+/ || !$self->is_vanity );
    $str = lc( $str );
    my $res = '';
    for( my $i = 0; $i < length( $str ); $i++ )
    {
        my $c = substr( $str, $i, 1 );
        my $p = index( $letters, $c );
        $res .= $p != -1 ? substr( $digits, $p, 1 ) : $c;
    }
    return( $res );
}

sub canonical
{
    my $self = shift( @_ );
    my $tel  = $self->aton;
    $tel     =~ s/[\Q$VISUAL_SEPARATOR\E]+//gs;
    my $uri  = $self->new( "tel:$tel" );
    $uri->ext( $self->{ext} ) if( length( $self->{ext} ) );
    $uri->isub( $self->{isdn_subaddress} ) if( length( $self->{isdn_subaddress} ) );
    $uri->context( $self->{context} ) if( length( $self->{context} ) );
    $uri->international_code( $self->{intl_code} ) if( length( $self->{intl_code} ) );
    $uri->{_has_context_param} = $self->{_has_context_param};
    $uri->{_prepend_context} = $self->{_prepend_context};
    $uri->{_intl_code_from_context} = $self->{_intl_code_from_context};
    $uri->{local_number} = $self->{local_number};
    my $priv = $self->{private};
    %{$uri->{private}} = %$priv;
    return( $uri );
}

sub cc2context
{
    my $self = shift( @_ );
    my $cc   = uc( shift( @_ ) );
    return( $self->error( "No country code provided." ) ) if( !length( $cc ) );
    $self->_load_countries;
    my $hash = $COUNTRIES;
    foreach my $k ( sort( keys( %$hash ) ) )
    {
        ## array ref
        my $ref = $hash->{ $k };
        foreach my $this ( @$ref )
        {
            if( $this->{cc} eq $cc )
            {
                return( '+' . $k );
            }
        }
    }
    ## Nothing found
    return( '' );
}

sub clone
{
    my $self  = shift( @_ );
    my $class = ref( $self );
    my $hash  = {};
    my @keys  = keys( %$self );
    @$hash{ @keys } = @$self{ @keys };
    delete( $hash->{cache} );
    return( bless( $hash, $class ) );
}

sub context
{
    my $self = shift( @_ );
    if( @_ )
    {
        my $str  = shift( @_ );
        if( $str !~ /^$DESCRIPTOR$/ )
        {
            warn( "'$str' is not a valid context\n" );
            return( undef() );
        }
        delete( $self->{cache} );
        $self->{_has_context_param} = 1;
        $self->{_prepend_context} = 0;
        $self->{context} = $str;
        ## We found an international country code in the prefix provided, so let's set it
        if( !length( $self->{intl_code} ) && ( my $code = $self->_extract_intl_code( $str ) ) )
        {
            $self->{_intl_code_from_context} = 1;
            $self->{intl_code} = $code;
        }
    }
    return( $self->{context} );
}

sub country
{
    my $self = shift( @_ );
    no overloading;
    $self->_load_countries;
    my $hash = $COUNTRIES;
    my $code = $self->international_code;
    return( wantarray() ? () : [] ) if( !length( $code ) );
    $code =~ s/[\Q$VISUAL_SEPARATOR\E]+//g;
    if( $code =~ /^\+($IDD_RE)/ )
    {
        $code = $1;
    }
    return( wantarray() ? () : [] ) if( !exists( $hash->{ $code } ) );
    my $ref = $hash->{ $code };
    return( wantarray() ? @$ref : \@$ref );
}

sub country_code
{
    my $self = shift( @_ );
    my $ref  = $self->country_codes;
    return( '' ) if( ref( $ref ) ne 'ARRAY' );
    return( $ref->[0] );
}

sub country_codes
{
    my $self = shift( @_ );
    my $ref  = $self->country;
    return( '' ) if( ref( $ref ) ne 'ARRAY' );
    my @codes = map( $_->{cc}, @$ref );
    return( wantarray() ? @codes : \@codes );
}

sub country_name
{
    my $self = shift( @_ );
    my $ref  = $self->country_names;
    return( '' ) if( ref( $ref ) ne 'ARRAY' );
    return( $ref->[0] );
}

sub country_names
{
    my $self = shift( @_ );
    my $ref  = $self->country;
    return( '' ) if( ref( $ref ) ne 'ARRAY' );
    my @names = map( $_->{name}, @$ref );
    return( wantarray() ? @names : \@names );
}

sub error
{
    my $self  = shift( @_ );
    my $level = 0;
    my $caller = caller;
    my $err   = join( '', @_ );
    my $class = ref( $self ) || $self;
    if( $err && length( $err ) )
    {
        my( $frame, $caller ) = ( $level, '' );
        while( $caller = ( caller( $frame ) )[ 0 ] )
        {
            last if( $caller ne 'URI::tel' );
            $frame++;
        }
        my( $pack, $file, $line ) = caller( $frame );
        $err =~ s/\n$//gs;
        $self->{error} = ${ $class . '::ERROR' } = $err;
        return( undef() );
    }
    return( $self->{error} || $ERROR );
}

sub extension { return( shift->ext( @_ ) ); }

sub ext
{
    my $self = shift( @_ );
    if( @_ )
    {
        my $val = shift( @_ );
        if( length( $val ) && $val !~ /^[$PHONEDIGIT]+$/ )
        {
            warn( "'$val' is not a valid extension ([$PHONEDIGIT]+)\n" );
            return( undef() );
        }
        delete( $self->{cache} );
        $self->{ext} = $val;
    }
    return( $self->{ext} );
}

sub international_code
{
    my $self = shift( @_ );
    if( @_ )
    {
        my $val = shift( @_ );
        if( length( $val ) && $val !~ /^[$PHONEDIGIT]+$/ )
        {
            warn( "'$val' is not a valid international code.\n" );
            return;
        }
        delete( $self->{cache} );
        ## The international code was provided by the user as opposed to using the context() method,
        ## so we flag it properly so it can be used in stringification of the phone number
        $self->{_intl_code_from_context} = 0;
        $self->{is_global} = 1;
        $self->{intl_code} = $val;
    }
    return( $self->{intl_code} );
}

sub is_global
{
    return( shift->{is_global} );
}

sub is_local
{
    return( shift->{is_local} );
}

sub is_other
{
    return( shift->{is_other} );
}

sub is_vanity
{
    return( shift->{is_vanity} );
}

sub isdn_subaddress { return( shift->isub( @_ ) ); }

sub isub
{
    my $self = shift( @_ );
    if( @_ )
    {
        my $val  = shift( @_ );
        if( length( $val ) && $val !~ /^$URIC$/ )
        {
            warn( "'$val' is not a isdn subaddress\n" );
            return( undef() );
        }
        delete( $self->{cache} );
        $self->{isub} = $val;
    }
    return( $self->{isub} );
}

sub local_number
{
    my $self = shift( @_ );
    if( @_ )
    {
        my $val = shift( @_ );
        $self->{local_number} = $val;
        if( length( $val ) )
        {
            my @matches = ();
            if( @matches = $val !~ /^((?:tel\:)?$LOCAL_NUMBER)$/ )
            {
                $val =~ s/^tel\://;
                @names = qw( all subscriber params1 last_param1 ignore5 ignore6 context params2 last_param2 ignore10 ignore11 );
                my $ref = {};
                @$ref{ @names } = @matches;
                if( length( $ref->{context} ) )
                {
                    $ref->{context} =~ s/;[^=]+=(.*?)$/$1/gs;
                    $self->{context} = $ref->{context};
                    $self->{_has_context_param} = 1;

                    if( $ref->{context} !~ /^[a-zA-Z]/ &&
                        substr( $ref->{context}, 0, 1 ) eq '+' )
                    {
                        $self->{intl_code} = $self->_extract_intl_code( $ref->{context} );
                        ## We flag it as extracted from context, because we do not want to prepend the subscriber number with it.
                        ## It's just too dangerous as we cannot tell the subscriber number is actually a proper number that can be dialed from outside e.g. 911 or 110 are emergency number who may heva a context with international code
                        ## However, if the international code was provided by the user then that's his responsibility
                        ## If the user wants to just provide some context, then better to use context() instead.
                        ## Knowing the international code helps getting some other useful information, but it should not necessarily affect the format of the number
                        $self->{_intl_code_from_context} = 1;
                    }
                }
            }
            else
            {
                warn( "'$val' is not a valid local number.\n" );
                return;
            }
        }
    }
    return( $self->{local_number} );
}

sub original
{
    return( shift->{original} );
}

sub prepend_context
{
    my $self = shift( @_ );
    if( @_ )
    {
        $self->{_prepend_context} = shift( @_ );
        delete( $self->{cache} );
    }
    return( $self->{_prepend_context} );
}

sub private
{
    my $self = shift( @_ );
    my( $name, $val ) = @_;
    if( length( $name ) )
    {
        ## The value could be blank and if so, we would remove the parameter
        if( defined( $val ) )
        {
            if( $name !~ /^$PNAME$/ )
            {
                warn( "'$name' is not a valid parameter name.\n" );
                return( undef() );
            }
            if( length( $val ) )
            {
                if( $val !~ /^$PVALUE$/ )
                {
                    warn( "'$val' is not a valid parameter value.\n" );
                    return( undef() );
                }
                delete( $self->{cache} );
                $self->{private}->{ $name } = $val;
                return( $self->{private}->{ $name } );
            }
            else
            {
                return( delete( $self->{private}->{ $name } ) );
            }
        }
        else
        {
            return( wantarray() ? %${$self->{private}->{ $name }} : \%${$self->{private}->{ $name }} );
        }
    }
    return( wantarray() ? %{$self->{private}} : \%{$self->{private}} );
}

sub subscriber
{
    my $self = shift( @_ );
    if( @_ )
    {
        my $val = shift( @_ );
        if( length( $val ) && $val !~ /^$TEL_SUBSCRIBER$/ )
        {
            warn( "'$val' is not a valid subscriber value.\n" );
            return( undef() );
        }
        delete( $self->{cache} );
        $self->{subscriber} = $val;
    }
    return( $self->{subscriber} );
}

sub type
{
    return( shift->{type} );
}

sub _extract_intl_code
{
    my $self = shift( @_ );
    my $str  = shift( @_ ) || return( '' );
    my $code;
    ## Extract the global idd
    $self->_load_countries;
    ( my $str2 = $str ) =~ s/[\Q$VISUAL_SEPARATOR\E]+//g;
    $str2 =~ s/^tel\://;
    if( $str2 =~ /^\+($IDD_RE)/ )
    {
        my $idd = $1;
        if( CORE::exists( $COUNTRIES->{ $idd } ) )
        {
            my $idds = $COUNTRIES->{ $idd }->[0]->{idd};
            foreach my $thisIdd ( @$idds )
            {
                my $check = $thisIdd;
                $check =~ s/\D//g;
                if( $check eq $idd )
                {
                    #$temp->{context} = '+' . $thisIdd;
                    $code = $thisIdd;
                    last;
                }
            }
        }
    }
    return( $code );
}

sub _extract_local_number
{
    my $self = shift( @_ );
    my( $intl_code, $subscriber ) = @_;
    my $j = 0;
    for( my $i = 0; $i < length( $intl_code ); $i++ )
    {
        # Skip until we are on a number
        next if( substr( $intl_code, $i, 1 ) !~ /^\d$/ );
        # and here too so we can compare number to number
        while( substr( $subscriber, $j, 1 ) !~ /^\d$/ )
        {
            $j++;
        }
        # Our international code does not seem to match the prefix of our subscriber! This should not happen.
        if( substr( $subscriber, $j, 1 ) ne substr( $intl_code, $i, 1 ) )
        {
            # printf( STDERR "Mismatch... %s at position %d vs %s at position %d\n", substr( $intl_code, $i, 1 ), $i, substr( $subscriber, $j, 1 ), $j );
            #last;
            return( '' );
        }
        $j++;
    }
    $j++ while( $j <= length( $subscriber ) && substr( $subscriber, $j ) !~ /^[()]?\d+($LOCAL_NUMBER|$OTHER|$VANITY_LOCAL)$/ );
    return( substr( $subscriber, $j ) );
}

# Check if two objects are the same object
# https://tools.ietf.org/search/rfc3966#section-4
sub _obj_eq
{
    ##return overload::StrVal( $_[0] ) eq overload::StrVal( $_[1] );
    no overloading;
    my $self = shift( @_ );
    my $other = shift( @_ );
    return( 0 ) if( !ref( $other ) || !$other->isa( 'URI::tel' ) );
    my $sub = $self->canonical->subscriber;
    my $sub2 = $other->canonical->subscriber;
    $sub =~ s/^\+//;
    $sub2 =~ s/^\+//;
    return( 0 ) if( $sub ne $sub2 );
    my $context = $self->context;
    my $context2 = $other->context;
    return( 0 ) if( $context ne $context2 );
    my $ext = $self->ext;
    my $ext2 = $other->ext;
    return( 0 ) if( $ext ne $ext2 );
    my $priv = $self->private;
    my $priv2 = $other->private;
    foreach my $k ( keys( %$priv ) )
    {
        return( 0 ) if( !exists( $priv2->{ $k } ) );
        return( 0 ) if( $priv->{ $k } ne $priv2->{ $k } );
    }
    foreach my $k ( keys( %$priv2 ) )
    {
        return( 0 ) if( !exists( $priv->{ $k } ) );
        return( 0 ) if( $priv2->{ $k } ne $priv->{ $k } );
    }
    use overloading;
    return( 1 );
}

## Taken from http://www.perlmonks.org/bare/?node_id=319761
## This will do a split on a semi-colon, but being mindful if before it there is an escaped backslash
## For example, this would not be skipped: something\;here
## But this would be split: something\\;here resulting in something\ and here after unescaping
sub split_str
{
    my $self = shift( @_ );
    my $s    = shift( @_ );
    my $sep  = @_ ? shift( @_ ) : ';';
    my @parts = ();
    my $i = 0;
    foreach( split( /(\\.)|$sep/, $s ) )
    {
        defined( $_ ) ? do{ $parts[$i] .= $_ } : do{ $i++ };
    }
    return( @parts );
}

sub _load_countries
{
    my $self = shift( @_ );
    if( !%$COUNTRIES )
    {
        my $in = 0;
        my $hash = {};
        my @data = ;
        foreach ( @data )
        {
            chomp;
            next unless( $in || /^\#{2} BEGIN DATA/ );
            last if( /^\#{2} END DATA/ );
            $in++;
            next if( /^\#{2} BEGIN DATA/ );
            my( $cc, $cc3, $name, $idd ) = split( /[[:blank:]]*\;[[:blank:]]*/, $_ );
            my $keys = index( $idd, ',' ) != -1 ? [ split( /[[:blank:]]*\,[[:blank:]]*/, $idd ) ] : [ $idd ];
            my $info =
            {
            'cc' => $cc,
            'cc3' => $cc3,
            'name' => $name,
            'idd' => $idd,
            };
            $info->{idd} = $keys;
            foreach my $k ( @$keys )
            {
                my $k2 = $k;
                $k2 =~ s/-//gs;
                $hash->{ $k2 } = [] if( !exists( $hash->{ $k2 } ) );
                push( @{$hash->{ $k2 }}, $info );
            }
        }
        $COUNTRIES = $hash;
        my @list = sort{ $b <=> $a } keys( %$hash );
        my $re_list = join( '|', @list );
        $IDD_RE = qr{(?:$re_list)};
    }
}

1;

__DATA__