bless.*=> [$]class results from the CPAN

Locale-Unicode-Data

view release on metacpan or search on metacpan

lib/Locale/Unicode/Data.pm view on Meta::CPAN

    table       => 'number_systems',
    has_array   => [qw( digits )],
}, @_ ) ); }

sub number_system_l10n { return( shift->_fetch_one({
    id          => 'getnumber_system_l10n',
    field       => 'number_system',
    table       => 'number_systems_l10n',
    requires    => [qw( locale alt )],
    default     => { alt => undef },
}, @_ ) ); }

sub number_systems_l10n { return( shift->_fetch_all({
    id          => 'number_systems_l10n',
    table       => 'number_systems_l10n',
    by          => [qw( locale number_system alt )],
}, @_ ) ); }

sub pass_error
{
    my $self = shift( @_ );
    my $pack = ref( $self ) || $self;
    my $opts = {};
    my( $err, $class, $code );
    no strict 'refs';
    if( scalar( @_ ) )
    {
        # Either an hash defining a new error and this will be passed along to error(); or
        # an hash with a single property: { class => 'Some::ExceptionClass' }
        if( scalar( @_ ) == 1 && ref( $_[0] ) eq 'HASH' )
        {
            $opts = $_[0];
        }
        else
        {
            if( scalar( @_ ) > 1 && ref( $_[-1] ) eq 'HASH' )
            {
                $opts = pop( @_ );
            }
            $err = $_[0];
        }
    }
    $err = $opts->{error} if( !defined( $err ) && CORE::exists( $opts->{error} ) && defined( $opts->{error} ) && CORE::length( $opts->{error} ) );
    # We set $class only if the hash provided is a one-element hash and not an error-defining hash
    $class = $opts->{class} if( CORE::exists( $opts->{class} ) && defined( $opts->{class} ) && CORE::length( $opts->{class} ) );
    $code  = $opts->{code} if( CORE::exists( $opts->{code} ) && defined( $opts->{code} ) && CORE::length( $opts->{code} ) );
    
    # called with no argument, most likely from the same class to pass on an error 
    # set up earlier by another method; or
    # with an hash containing just one argument class => 'Some::ExceptionClass'
    if( !defined( $err ) && ( !scalar( @_ ) || defined( $class ) ) )
    {
        # $error is a previous erro robject
        my $error = ref( $self ) ? $self->{error} : length( ${ $pack . '::ERROR' } ) ? ${ $pack . '::ERROR' } : undef;
        if( !defined( $error ) )
        {
            warn( "No error object provided and no previous error set either! It seems the previous method call returned a simple undef" );
        }
        else
        {
            $err = ( defined( $class ) ? bless( $error => $class ) : $error );
            $err->code( $code ) if( defined( $code ) );
        }
    }
    elsif( defined( $err ) && 
           Scalar::Util::blessed( $err ) && 
           ( scalar( @_ ) == 1 || 
             ( scalar( @_ ) == 2 && defined( $class ) ) 
           ) )
    {
        $self->{error} = ${ $pack . '::ERROR' } = ( defined( $class ) ? bless( $err => $class ) : $err );
        $self->{error}->code( $code ) if( defined( $code ) && $self->{error}->can( 'code' ) );
        
        if( $self->{fatal} || ( defined( ${"${class}\::FATAL_EXCEPTIONS"} ) && ${"${class}\::FATAL_EXCEPTIONS"} ) )
        {
            die( $self->{error} );
        }
    }
    # If the error provided is not an object, we call error to create one
    else
    {
        return( $self->error( @_ ) );
    }
    
    if( want( 'OBJECT' ) )
    {
        rreturn( Locale::Unicode::Data::NullObject->new );
    }
    return;
}

sub person_name_default { return( shift->_fetch_one({
    id      => 'get_person_name_default',
    field   => 'locale',
    table   => 'person_name_defaults',
}, @_ ) ); }

sub person_name_defaults { return( shift->_fetch_all({
    id          => 'person_name_defaults',
    table       => 'person_name_defaults',
}, @_ ) ); }

# These methods implement key steps of the CLDR person name formatting algorithm
# described in UTS #35 Part 8. Insert them alongside PART 1 (in alphabetical order
# within the person_name_* group).

# person_name_derive_order( formatting_locale => 'ja', name_locale => 'ko' )
# -> returns 'givenFirst' or 'surnameFirst', by consulting person_name_order_locales
#    for the formatting locale, matching against the name locale's base language
#    and the 'und' catch-all.
#
# This implements step 3 of the CLDR "Derive the name order" algorithm, full lookup
# (base language + 'und') with the full parent-locale chain traversal, which requires
# the parentLocales supplemental data. For the full algorithm see UTS #35 Part 8 section
# "Derive the name order".
# The default when no match is found is 'givenFirst', as specified by CLDR.
#
# NOTE: The caller should pass a preferredOrder from the PersonName object when
# available (step 2 of the algorithm), as that takes precedence over this method.
sub person_name_derive_order
{
    my $self = shift( @_ );
    my %args = @_;
    my $fmt_locale = $args{formatting_locale} ||
        return( $self->error( "Missing required argument 'formatting_locale'" ) );
    my $name_locale = $args{name_locale} ||
        return( $self->error( "Missing required argument 'name_locale'" ) );
    my $fmt_tree = $self->make_inheritance_tree( $fmt_locale ) ||
        return( $self->pass_error );
    my $name_tree = $self->make_inheritance_tree( $name_locale ) ||
        return( $self->pass_error );

lib/Locale/Unicode/Data.pm view on Meta::CPAN


    if( defined( $DBH ) && ref( $DBH ) eq 'HASH' )
    {
        foreach my $tid ( keys( %$DBH ) )
        {
            next unless( ref( $DBH->{ $tid } ) eq 'HASH' );
            foreach my $db ( keys( %{ $DBH->{ $tid } } ) )
            {
                my $dbh = delete( $DBH->{ $tid }->{ $db } );
                if( defined( $dbh ) &&
                    Scalar::Util::blessed( $dbh ) &&
                    $dbh->isa( 'DBI::db' ) )
                {
                    $dbh->disconnect;
                }
                undef( $dbh );
            }
        }
    }
};

sub FREEZE
{
    my $self = CORE::shift( @_ );
    my $serialiser = CORE::shift( @_ ) // '';
    my $class = CORE::ref( $self );
    my @keys = qw( datafile decode_sql_arrays fatal );
    my %hash = ();
    @hash{ @keys } = @$self{ @keys };
    # Return an array reference rather than a list so this works with Sereal and CBOR
    # On or before Sereal version 4.023, Sereal did not support multiple values returned
    CORE::return( [$class, %hash] ) if( $serialiser eq 'Sereal' && Sereal::Encoder->VERSION <= version->parse( '4.023' ) );
    # But Storable want a list with the first element being the serialised element
    CORE::return( $class, \%hash );
}

sub STORABLE_freeze { return( shift->FREEZE( @_ ) ); }

sub STORABLE_thaw { return( shift->THAW( @_ ) ); }

# NOTE: CBOR will call the THAW method with the stored classname as first argument, the constant string CBOR as second argument, and all values returned by FREEZE as remaining arguments.
# NOTE: Storable calls it with a blessed object it created followed with $cloning and any other arguments initially provided by STORABLE_freeze
sub THAW
{
    my( $self, undef, @args ) = @_;
    my $ref = ( CORE::scalar( @args ) == 1 && CORE::ref( $args[0] ) eq 'ARRAY' ) ? CORE::shift( @args ) : \@args;
    my $class = ( CORE::defined( $ref ) && CORE::ref( $ref ) eq 'ARRAY' && CORE::scalar( @$ref ) > 1 ) ? CORE::shift( @$ref ) : ( CORE::ref( $self ) || $self );
    my $hash = CORE::ref( $ref ) eq 'ARRAY' ? CORE::shift( @$ref ) : {};
    my $new;
    # Storable pattern requires to modify the object it created rather than returning a new one
    if( CORE::ref( $self ) )
    {
        foreach( CORE::keys( %$hash ) )
        {
            $self->{ $_ } = CORE::delete( $hash->{ $_ } );
        }
        $new = $self;
    }
    else
    {
        $new = CORE::bless( $hash => $class );
    }
    CORE::return( $new );
}

sub TO_JSON
{
    my $self = CORE::shift( @_ );
    my @keys = qw( datafile decode_sql_arrays );
    my $hash = {};
    @$hash{ @keys } = @$self{ @keys };
    return( $hash );
}

# NOTE: Locale::Unicode::Data::Boolean class
package Locale::Unicode::Data::Boolean;
BEGIN
{
    use strict;
    use warnings;
    use vars qw( $VERSION $true $false );
    use overload
      "0+"     => sub{ ${$_[0]} },
      "++"     => sub{ $_[0] = ${$_[0]} + 1 },
      "--"     => sub{ $_[0] = ${$_[0]} - 1 },
      fallback => 1;
    $true  = do{ bless( \( my $dummy = 1 ) => 'Locale::Unicode::Data::Boolean' ) };
    $false = do{ bless( \( my $dummy = 0 ) => 'Locale::Unicode::Data::Boolean' ) };
    our $VERSION = 'v0.1.0';
};
use strict;
use warnings;

sub new
{
    my $this = shift( @_ );
    my $self = bless( \( my $dummy = ( $_[0] ? 1 : 0 ) ) => ( ref( $this ) || $this ) );
}

sub clone
{
    my $self = shift( @_ );
    unless( ref( $self ) )
    {
        die( "clone() must be called with an object." );
    }
    my $copy = $$self;
    my $new = bless( \$copy => ref( $self ) );
    return( $new );
}

sub false() { $false }

sub is_bool($) { UNIVERSAL::isa( $_[0], 'Locale::Unicode::Data::Boolean' ) }

sub is_true($) { $_[0] && UNIVERSAL::isa( $_[0], 'Locale::Unicode::Data::Boolean' ) }

sub is_false($) { !$_[0] && UNIVERSAL::isa( $_[0], 'Locale::Unicode::Data::Boolean' ) }

sub true() { $true  }

lib/Locale/Unicode/Data.pm view on Meta::CPAN

        my $msg  = shift( @_ );
        $e = $self->new({
            skip_frames => 1,
            message => $msg,
        });
    }
    else
    {
        $e = $self;
    }
    die( $e );
}

sub type { return( shift->reset(@_)->_set_get_prop( 'type', @_ ) ); }

sub _set_get_prop
{
    my $self = shift( @_ );
    my $prop = shift( @_ ) || die( "No object property was provided." );
    $self->{ $prop } = shift( @_ ) if( @_ );
    return( $self->{ $prop } );
}

sub FREEZE
{
    my $self = CORE::shift( @_ );
    my $serialiser = CORE::shift( @_ ) // '';
    my $class = CORE::ref( $self );
    my %hash  = %$self;
    # Return an array reference rather than a list so this works with Sereal and CBOR
    # On or before Sereal version 4.023, Sereal did not support multiple values returned
    CORE::return( [$class, \%hash] ) if( $serialiser eq 'Sereal' && Sereal::Encoder->VERSION <= version->parse( '4.023' ) );
    # But Storable want a list with the first element being the serialised element
    CORE::return( $class, \%hash );
}

sub STORABLE_freeze { return( shift->FREEZE( @_ ) ); }

sub STORABLE_thaw { return( shift->THAW( @_ ) ); }

# NOTE: CBOR will call the THAW method with the stored classname as first argument, the constant string CBOR as second argument, and all values returned by FREEZE as remaining arguments.
# NOTE: Storable calls it with a blessed object it created followed with $cloning and any other arguments initially provided by STORABLE_freeze
sub THAW
{
    my( $self, undef, @args ) = @_;
    my $ref = ( CORE::scalar( @args ) == 1 && CORE::ref( $args[0] ) eq 'ARRAY' ) ? CORE::shift( @args ) : \@args;
    my $class = ( CORE::defined( $ref ) && CORE::ref( $ref ) eq 'ARRAY' && CORE::scalar( @$ref ) > 1 ) ? CORE::shift( @$ref ) : ( CORE::ref( $self ) || $self );
    my $hash = CORE::ref( $ref ) eq 'ARRAY' ? CORE::shift( @$ref ) : {};
    my $new;
    # Storable pattern requires to modify the object it created rather than returning a new one
    if( CORE::ref( $self ) )
    {
        foreach( CORE::keys( %$hash ) )
        {
            $self->{ $_ } = CORE::delete( $hash->{ $_ } );
        }
        $new = $self;
    }
    else
    {
        $new = CORE::bless( $hash => $class );
    }
    CORE::return( $new );
}

sub TO_JSON { return( shift->as_string ); }

{
    # NOTE: Locale::Unicode::Data::NullObject class
    package
        Locale::Unicode::Data::NullObject;
    BEGIN
    {
        use strict;
        use warnings;
        use overload (
            '""'    => sub{ '' },
            fallback => 1,
        );
        use Wanted;
    };
    use strict;
    use warnings;

    sub new
    {
        my $this = shift( @_ );
        my $ref = @_ ? { @_ } : {};
        return( bless( $ref => ( ref( $this ) || $this ) ) );
    }

    sub AUTOLOAD
    {
        my( $method ) = our $AUTOLOAD =~ /([^:]+)$/;
        my $self = shift( @_ );
        if( want( 'OBJECT' ) )
        {
            rreturn( $self );
        }
        # Otherwise, we return undef; Empty return returns undef in scalar context and empty list in list context
        return;
    };
}

1;
# NOTE: POD
__END__

=encoding utf-8

=head1 NAME

Locale::Unicode::Data - Unicode CLDR SQL Data

=head1 SYNOPSIS

    use Locale::Unicode::Data;
    my $cldr = Locale::Unicode::Data->new;
    # Do not decode SQL arrays into perl arrays. Defaults to true
    # This uses JSON::XS
    my $cldr = Locale::Unicode::Data->new( decode_sql_arrays => 0 );

( run in 0.484 second using v1.01-cache-2.11-cpan-a9496e3eb41 )