File Coverage

blib/lib/URI/tel.pm

Criterion	Covered	Total	%
statement	262	367	71.3
branch	124	194	63.9
condition	37	71	52.1
subroutine	28	40	70.0
pod	17	26	65.3
total	468	698	67.0

##----------------------------------------------------------------------------
## URI::tel - ~/lib/URI/tel.pm
## Version v0.800.1
## Copyright(c) 2019 DEGUEST Pte. Ltd.
## Author: Jacques Deguest <@sitael.tokyo.deguest.jp>
## Created 2016/02/12
## Modified 2019/08/30
##
##----------------------------------------------------------------------------
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 );
    our( $COUNTRIES, $IDD_RE );
    $VERSION     = 'v0.800.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					= qr{(\+?[$PHONEDIGIT]*[A-Z0-9\Q$VISUAL_SEPARATOR\E]+[$PHONEDIGIT]*)};
	$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;
    #my $self = bless \$str, $class;
    #$self;
    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 );
	}
	## e.g. +1-800-LAWYR-UP
	elsif( @matches = $str =~ /^((?:tel\:)?$VANITY)$/ )
	{
		$temp->{ 'type' } = 'vanity';
		@names = qw( all subscriber );
	}
	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' } );
}

*letters2digits = \&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 );
}

*extension = \&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( undef() );
		}
		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' } );
}

*isdn_subaddress = \&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 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( '' );
	#print( STDERR "Trying to find international code from '$str'\n" );
	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;
		#print( STDERR "\tIDD is '$idd'\n" );
		if( CORE::exists( $COUNTRIES->{ $idd } ) )
		{
			my $idds = $COUNTRIES->{ $idd }->[0]->{ 'idd' };
			#print( STDERR "\tFound entry.\n" );
			foreach my $thisIdd ( @$idds )
			{
				my $check = $thisIdd;
				$check =~ s/\D//g;
				if( $check eq $idd )
				{
					#$temp->{ 'context' } = '+' . $thisIdd;
					$code = $thisIdd;
					last;
				}
			}
		}
	}
	#print( STDERR "\tReturning '$code'\n" );
	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( substr( $subscriber, $j, 1 ) !~ /^\d$/ );
	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__