view release on metacpan or  search on metacpan

lib/Getopt/Class.pm  view on Meta::CPAN

    {
        my $uri_class = exists( $def->{package} ) ? $def->{package} : 'URI';
        return( $self->_set_get_uri( { field => $f, class => $uri_class }, @_ ) );
    }
    elsif( $def->{type} eq 'uri-array' )
    {
        my $uri_class = exists( $def->{package} ) ? $def->{package} : 'URI';
        if( @_ )
        {
            my $arr = Module::Generic::Array->new;
            foreach( @_ )
            {
                push( @$arr, $uri_class->new( $_ ) );
            }
            $self->{ $f } = $arr;
        }
        return( $self->_set_get_uri( { field => $f, class => $uri_class } ) );
    }
    elsif( $def->{type} eq 'uri' )
    {
        return( $self->_set_get_uri( $f, @_ ) );
    }
    elsif( $def->{type} eq 'uri-array' )
    {
        if( @_ )
        {
            my $arr = Module::Generic::Array->new;
            foreach( @_ )
            {
                push( @$arr, file( $_ ) );
            }
            $self->{ $f } = $arr;
        }
        return( $self->_set_get_array_as_object( $f ) );
    }
    else
    {
        CORE::warn( "I do not know what to do with this property \"$f\" type \"$def->{type}\". Using scalar.\n" ) if( $self->{warnings} );
        return( $self->_set_get_scalar( $f, @_ ) );
    }
};

# NOTE: Getopt::Class::Repository package
package Getopt::Class::Repository;
BEGIN
{
    use strict;
    use warnings;
    use Scalar::Util;
    use constant VALUES_CLASS => 'Getopt::Class::Value';
};

# tie( %self, 'Getopt::Class::Repository' );
# Used by Getopt::Class::Values to ensure that whether the data are accessed as methods or as hash keys,
# in either way it returns the option data
# Actually option data are stored in the Getopt::Class::Values object data property
sub TIEHASH
{
    my $self  = shift( @_ );
    my $class = ref( $self ) || $self;
    return( bless( { data => {} } => $class ) );
}

sub CLEAR
{
    my $self = shift( @_ );
    my $data = $self->{data};
    my $caller = caller;
    %$data = ();
}

sub DELETE
{
    my $self = shift( @_ );
    my $data = $self->{data};
    my $key  = shift( @_ );
    if( caller eq VALUES_CLASS || !$self->{enable} )
    {
        CORE::delete( $self->{ $key } );
    }
    else
    {
        CORE::delete( $data->{ $key } );
    }
}

sub EXISTS
{
    my $self = shift( @_ );
    my $data = $self->{data};
    my $key  = shift( @_ );
    if( caller eq VALUES_CLASS || !$self->{enable} )
    {
        CORE::exists( $self->{ $key } );
    }
    else
    {
        CORE::exists( $data->{ $key } );
    }
}

sub FETCH
{
    my $self = shift( @_ );
    my $data = $self->{data};
    my $key  = shift( @_ );
    my $caller = caller;
    # print( STDERR "FETCH($caller)[enable=$self->{enable}] <- '$key''\n" );
    if( caller eq VALUES_CLASS || !$self->{enable} )
    {
        # print( STDERR "FETCH($caller)[enable=$self->{enable}] <- '$key' <- '$self->{$key}'\n" );
        return( $self->{ $key } )
    }
    else
    {
        # print( STDERR "FETCH($caller)[enable=$self->{enable}] <- '$key' <- '$self->{$key}'\n" );
        return( $data->{ $key } );
    }
}

sub FIRSTKEY

lib/Getopt/Class.pm  view on Meta::CPAN

    # debug
    my $opts  = {};
    $opts = shift( @_ ) if( @_ );
    # print( STDERR __PACKAGE__ . "::TIEHASH() called with following arguments: '", join( ', ', @_ ), "'.\n" );
    my $call_offset = 0;
    while( my @call_data = caller( $call_offset ) )
    {
        # printf( STDERR "[$call_offset] In file $call_data[1] at line $call_data[2] from subroutine %s has bitmask $call_data[9]\n", (caller($call_offset+1))[3] );
        unless( $call_offset > 0 && $call_data[0] ne $class && (caller($call_offset-1))[0] eq $class )
        {
            # print( STDERR "Skipping package $call_data[0]\n" );
            $call_offset++;
            next;
        }
        last if( $call_data[9] || ( $call_offset > 0 && (caller($call_offset-1))[0] ne $class ) );
        $call_offset++;
    }
    # print( STDERR "Using offset $call_offset with bitmask ", ( caller( $call_offset ) )[9], "\n" );
    my $bitmask = ( caller( $call_offset - 1 ) )[9];
    my $offset = $warnings::Offsets{uninitialized};
    # print( STDERR "Caller (2)'s bitmask is '$bitmask', warnings offset is '$offset' and vector is '", vec( $bitmask, $offset, 1 ), "'.\n" );
    my $should_display_warning = vec( ( $bitmask // 0 ), $offset, 1 );
    
    my $dict = $opts->{dict} || return( __PACKAGE__->error( "No dictionary was provided to Getopt::Class:Alias" ) );
    if( Scalar::Util::reftype( $dict ) ne 'HASH' )
    {
        #warn( "Dictionary provided is not an hash reference.\n" ) if( $should_display_warning );
        #return;
        return( __PACKAGE__->error({ message => "Dictionary provided is not an hash reference.", no_return_null_object => 1 }) );
    }
    elsif( !scalar( keys( %$dict ) ) )
    {
        #warn( "The dictionary hash reference provided is empty.\n" ) if( $should_display_warning );
        #return;
        return( __PACKAGE__->error( "The dictionary hash reference provided is empty." ) );
    }
    
    my $aliases = $opts->{aliases} || do
    {
        #warn( "No aliases map was provided to Getopt::Class:Alias\n" ) if( $should_display_warning );
        #return;
        return( __PACKAGE__->error( "No aliases map was provided to Getopt::Class:Alias" ) );
    };
    if( Scalar::Util::reftype( $aliases ) ne 'HASH' )
    {
        #warn( "Aliases map provided is not an hash reference.\n" ) if( $should_display_warning );
        #return;
        return( __PACKAGE__->error( "Aliases map provided is not an hash reference." ) );
    }
    my $hash = 
    {
    data => {},
    dict => $dict,
    aliases => $aliases,
    warnings => $should_display_warning,
    debug => ( $opts->{debug} || 0 ),
    # _data_repo => 'data',
    colour_open => '<',
    colour_close => '>',
    };
    return( bless( $hash => $class ) );
}

sub FETCH
{
    my $self = shift( @_ );
    my $data = $self->{data};
    # my $dict = $self->{dict};
    my $key  = shift( @_ );
    # my $def = $dict->{ $key };
    return( $data->{ $key } );
}

sub STORE
{
    my $self  = shift( @_ );
    my $class = ref( $self );
    my $data = $self->{data};
    # Aliases contains both the original dictionary key and all its aliases
    my $aliases = $self->{aliases};
    my( $pack, $file, $line ) = caller;
    my( $key, $val ) = @_;
    my $dict = $self->{dict};
    my $enabled = $self->{enable};
    my $fallback = sub
    {
        my( $k, $v ) = @_;
        $data->{ $k } = $v;
    };
    if( $enabled && CORE::exists( $aliases->{ $key } ) )
    {
        my $def = $aliases->{ $key } || do
        {
            CORE::warn( "No dictionary definition found for \"$key\".\n" ) if( $self->{warnings} );
            return( $fallback->( $key, $val ) );
        };
        if( !$self->_is_array( $def->{alias} ) )
        {
            CORE::warn( "I was expecting an array reference for this alias, but instead got '$def->{alias}'.\n" ) if( $self->{warnings} );
            return( $fallback->( $key, $val ) );
        }
        my $alias = $def->{alias} || do
        {
            CORE::warn( "No alias property found. This should not happen.\n" ) if( $self->{warnings} );
            return( $fallback->( $key, $val ) );
        };
        # $self->messagef_colour( 3, 'Found alias "{green}' . $alias . '{/}" with %d elements: {green}"%s"{/}', scalar( @$alias ), $alias->join( "', '" ) );
        $self->messagef_colour( 3, "Found alias '<green>$alias</>' with %d elements: <green>'%s'</>", scalar( @$alias ), $alias->join( "', '" ) );
        if( Scalar::Util::reftype( $alias ) ne 'ARRAY' )
        {
            CORE::warn( "Alias property is not an array reference. This should not happen.\n" ) if( $self->{warnings} );
            return( $fallback->( $key, $val ) );
        }
        $data->{ $key } = $val;
        foreach my $a ( @$alias )
        {
            next if( $a eq $key );
            # We do not set the value, if for some reason, the user would have removed this key
            # $data->{ $a } = $val if( CORE::exists( $data->{ $a } ) );
            $data->{ $a } = $val;
        }