view release on metacpan or  search on metacpan

lib/Module/Generic/Scalar.pm  view on Meta::CPAN

        $self->{capture}    = [];
        $self->{name}       = {};
        $self->{result}     = 0;
        $self->{_init_strict_use_sub} = 1;
        return( $self->SUPER::init( @_ ) );
    }

    sub capture { return( shift->_set_get_array_as_object( 'capture', @_ ) ); }

    sub matched
    {
        my $res = shift->result;
        # There may be one entry of empty value when there is no match, so we check for length
        return( $res->length->scalar ) if( $res->length && length( $res->get(0) ) );
        return(0);
    }

    sub name { return( shift->_set_get_hash_as_object( 'name', @_ ) ); }

    sub result { return( shift->_set_get_array_as_object( 'result', @_ ) ); }

    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
    {
        # STORABLE_thaw would issue $cloning as the 2nd argument, while CBOR would issue
        # 'CBOR' as the second value.
        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 );
    }
}

{
    # NOTE: Module::Generic::Scalar::Tie class
    package
        Module::Generic::Scalar::Tie;
    BEGIN
    {
        use strict;
        use warnings;
        use vars qw( $LOCK );
        use Config;
        use Scalar::Util ();
        use constant HAS_THREADS => $Config{useithreads};
        use constant IN_THREAD => ( $Config{useithreads} && threads->tid != 0 );
        if( HAS_THREADS )
        {
            require threads;
            require threads::shared;
            threads->import();
            threads::shared->import();
            my $lock :shared;
            $LOCK = \$lock;
        }
    };

    our $dummy_callback = sub{1};

    sub TIESCALAR
    {
        my( $class, $opts ) = @_;
        $opts //= {};
        if( ( Scalar::Util::reftype( $opts ) // '' ) ne 'HASH' )
        {
            warn( "Options provided (", overload::StrVal( $opts ), ") is not an hash reference\n" );
            $opts = {};
        }
        $opts->{data} //= '';
        $opts->{debug} //= 0;
        if( CORE::length( $opts->{add} ) && ref( $opts->{add} ) ne 'CODE' )
        {
            warnings::warn( "Code provided for the scalar add callback is not a code reference.\n" ) if( warnings::enabled( 'Module::Generic::Scalar' ) || $opts->{debug} );
            return;
        }
        if( CORE::length( $opts->{remove} ) && ref( $opts->{remove} ) ne 'CODE' )
        {
            warnings::warn( "Code provided for the scalar remove callback is not a code reference.\n" ) if( warnings::enabled( 'Module::Generic::Scalar' ) || $opts->{debug} );
            return;
        }

        my $data = ( ( Scalar::Util::reftype( $opts->{data} ) // '' ) eq 'SCALAR' ? \"${$opts->{data}}" : \undef );
        if( HAS_THREADS )
        {
            threads::shared::share( $data );
        }
        my $ref =
        {