view release on metacpan or  search on metacpan

lib/Module/Generic/File/Cache.pm  view on Meta::CPAN

    }
};

sub FREEZE
{
    my $self = CORE::shift( @_ );
    my $serialiser = CORE::shift( @_ ) // '';
    my $class = CORE::ref( $self );
    my @props = qw(
        binmode base64 create destroy exclusive id key locked mode owner removed serial size
        _packing_method _cache_dir _cache_file
    );
    my $hash  = {};
    foreach my $prop ( @props )
    {
        if( exists( $self->{ $prop } ) )
        {
            $hash->{ $prop } = $self->{ $prop };
        }
    }
    # 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
    if( $serialiser eq 'Sereal' )
    {
        require Sereal::Encoder;
        require version;
    
        if( version->parse( Sereal::Encoder->VERSION ) <= version->parse( '4.023' ) )
        {
            CORE::return( [$class, $hash] );
        }
    }
    # 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 ) : {};
    # Storable pattern requires to modify the object it created rather than returning a new one
    my $new;
    if( CORE::ref( $self ) )
    {
        foreach( CORE::keys( %$hash ) )
        {
            $self->{ $_ } = CORE::delete( $hash->{ $_ } );
        }
        $new = $self;
    }
    else
    {
        $new = CORE::bless( $hash => $class );
    }
    CORE::return( $new );
}

# NOTE: END
END
{
    my $repo = Module::Generic::Global->new( 'cache' => __PACKAGE__, key => __PACKAGE__ );
    my $repo_data;
    if( $repo )
    {
        $repo_data = $repo->get;
        return unless( defined( $repo_data ) && ref( $repo_data ) eq 'ARRAY' );
    }
    else
    {
        warn( "Error instantiating a new Module::Generic::Global object for 'cache': ", Module::Generic::Global->error );
        return;
    }
    my $file2obj_repo = Module::Generic::Global->new( 'file2object_repo' => __PACKAGE__, key => __PACKAGE__ );
    my $f2o_data;
    if( $file2obj_repo )
    {
        $f2o_data = $file2obj_repo->get;
    }
    else
    {
        warn( "Error instantiating a new Module::Generic::Global object for 'file2object_repo': ", Module::Generic::Global->error );
        return;
    }

    my $prefix = __PACKAGE__ . '::END';
    printf( STDERR "${prefix}: %d objects in repo to check.\n", scalar( @$repo_data ) ) if( $DEBUG >= 4 );

    foreach my $cache ( @$repo_data )
    {
        # Only allow the parent process to clean up
        my $pid = $cache->owner // '';
        next if( $pid ne $$ );

        if( !Scalar::Util::blessed( $cache // '' ) || 
            ref( $cache // '' ) ne 'Module::Generic::File::Cache' )
        {
            warn( "${prefix}: Object found in object repo is not a Module::Generic::File::Cache object." );
            next;
        }
        elsif( !defined( $cache ) ||
            !ref( $cache ) ||
            ( Scalar::Util::blessed( $cache ) && !$cache->can( 'remove' ) ) )
        {
            next;
        }
        elsif( !Scalar::Util::blessed( $cache->{_cache_file} ) ||
               (
                   Scalar::Util::blessed( $cache->{_cache_file} ) &&
                   !$cache->{_cache_file}->isa( 'Module::Generic::File' )
               ) )
        {
            warn( "${prefix}: File object found in _cache_file (", overload::StrVal( $cache->{_cache_file} ), ") is actually not a Module::Generic::File, which is weird." );
            next;