File Coverage

blib/lib/URI/tel.pm

Criterion	Covered	Total	%
statement	213	306	69.6
branch	111	166	66.8
condition	18	42	42.8
subroutine	22	32	68.7
pod	16	21	76.1
total	380	567	67.0

##----------------------------------------------------------------------------
## tel.pm
## Version 0.6
## Copyright(c) 2016-2019 Jacques Deguest
## Author: Jacques Deguest
## Created 2016/02/12
## Modified 2019/08/26
## 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 );
    our( $COUNTRIES, $IDD_RE );
    $VERSION     = '0.6';
	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 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] ) );
	}
	elsif( @matches = $str =~ /^((?:tel\:)?$OTHER)$/ )
	{
		$temp->{ 'type' } = 'other';
		@names = qw( all subscriber params ignore4 last_param );
	}
	elsif( @matches = $str =~ /^((?:tel\:)?$VANITY)$/ )
	{
		$temp->{ 'type' } = 'vanity';
		@names = qw( all subscriber );
	}
	else
	{
		$ERROR = "Unknown telephone number '$str'.";
		warn( $ERROR );
	}

	if( $str =~ /^(?:tel\:)?\+/ )
	{
		## Extract the global idd
		$this->_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;
						last;
					}
				}
			}
		}
	}

	## 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;

	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' },
	};
	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;
	$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' } ) );
		}
		elsif( $self->{ 'subscriber' } !~ /^\+\d+/ && $self->{ 'context' } !~ /[a-zA-Z]+/ )
		{
			@uri = ( 'tel:' . $self->{ 'context' } . '.' . $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->{_has_context_param} = $self->{_has_context_param};
	$uri->{_prepend_context} = $self->{_prepend_context};
	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;
	}
	return( $self->{ 'context' } );
}

sub country
{
	my $self = shift( @_ );
	$self->_load_countries;
	my $hash = $COUNTRIES;
	my $idd = substr( $self->{ 'subscriber' }, 0, 1 ) eq '+' ? $self->{ 'subscriber' } : substr( $self->{ 'context' }, 0, 1 ) eq '+' ? $self->{ 'context' } : '';
	## Something like [phone] or [phone]
	## Make sure we got a phone number without any visual separator
	my $uri = $self->canonical;
	$idd = substr( $uri->{ 'subscriber' }, 0, 1 ) eq '+' ? $uri->{ 'subscriber' } : substr( $uri->{ 'context' }, 0, 1 ) eq '+' ? $uri->{ 'context' } : '';
	## Remove the '+'
	$idd = substr( $idd, 1 );
	foreach my $k ( %$hash )
	{
		next if( length( $k ) > length( $idd ) );
		## We found a match
		## We return all the countries that match the international prefix
		if( substr( $idd, 0, length( $k ) ) eq $k )
		{
			my $ref = $hash->{ $k };
			return( wantarray() ? @$ref : \@$ref );
		}
	}
	## We got here, nothing found
	return( wantarray() ? () : [] );
}

sub error
{
    my $self  = shift( @_ );
    my $level = 0;
    my $caller = caller;
    my $err   = join( '', @_ );
    my $hash  = $self->_obj2h;
    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;
        $hash->{ 'error' } = ${ $class . '::ERROR' } = $err;
        return( undef() );
    }
    return( $hash->{ '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 is_global
{
	return( shift->{ 'is_global' } );
}

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

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' } );
}

# 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)};
	}
}

sub _obj2h
{
    my $self = shift( @_ );
    if( UNIVERSAL::isa( $self, 'HASH' ) )
    {
        return( $self );
    }
    elsif( UNIVERSAL::isa( $self, 'GLOB' ) )
    {
        return( \%{*$self} );
    }
    ## Because object may be accessed as My::Package->method or My::Package::method
    ## there is not always an object available, so we need to fake it to avoid error
    ## This is primarly itended for generic methods error(), errstr() to work under any conditions.
    else
    {
        return( {} );
    }
}

1;

__DATA__