view release on metacpan or  search on metacpan

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

sub FREEZE
{
    my $self       = CORE::shift( @_ );
    my $serialiser = CORE::shift( @_ ) // '';
    my $class      = CORE::ref( $self );
    # We skip 'owner' on purpose, since it represents the process ID
    my @props      = qw(
        base64 create destroy destroy_semaphore exclusive key mode
        serial size _packing_method
    );
    my $hash  = {};
    foreach my $prop ( @props )
    {
        if( exists( $self->{ $prop } ) )
        {
            $hash->{ $prop } = $self->{ $prop };
        }
    }
    $hash->{_was_opened} = $self->{_ipc_shared} ? 1 : 0;
    # 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 { CORE::return( CORE::shift->FREEZE( @_ ) ); }

sub STORABLE_thaw { CORE::return( CORE::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 $was_opened = CORE::delete( $hash->{_was_opened} );
    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 );
    }
    if( $was_opened )
    {
        my $size = ( defined( $new->{size} ) && length( $new->{size} ) ) ? $new->{size} : SHM_BUFSIZ;
        my $flags = ( defined( $new->{flags} ) && length( $new->{flags} ) ) ? $new->{flags} : &IPC::SysV::S_IRWXU;
        $flags |= &IPC::SysV::IPC_CREAT if( defined( $new->{create} ) && $new->{create} );
        my $key = $new->{key};
        # try-catch
        local $@;
        eval
        {
            my $shm;
            if( defined( $key ) && length( $key ) )
            {
                $key = $self->_str2key( $key );
                $shm = IPC::SharedMem->new( $key, $size, $flags );
            }
            else
            {
                $shm = IPC::SharedMem->new( &IPC::SysV::IPC_PRIVATE, $size, $flags );
            }
            $new->{_ipc_shared} = $shm;
        };
        if( $@ )
        {
            return( $self->error( "Error creating a new IPC::SharedMem object: $@" ) );
        }

        my $sem;
        # try-catch
        local $@;
        eval
        {
            $sem = IPC::Semaphore->new( $key, 3, $flags );
        };
        if( $@ )
        {
            return( $self->error( "Error creating a new IPC::Semaphore object: $@" ) );
        }

        if( !defined( $sem ) )
        {
            return( $self->error( "Unable to create semaphore with key \"", ( $key // '' ), "\" and flags \"$flags\": $!" ) );
        }
        $new->{_sem} = $sem;
    }
    CORE::return( $new );
}

# NOTE: END
# END
# {
#     my $shem_repo = Module::Generic::Global->new( 'shem_repo' => __PACKAGE__, key => __PACKAGE__ );
#     $shem_repo->lock;
#     my $all_shem = $shem_repo->get // [];
#     foreach my $id ( @$all_shem )
#     {
#         my $id2obj_repo = Module::Generic::Global->new( 'id2obj' => __PACKAGE__, key => $id );
#         my $s = $id2obj_repo->get || next;
#         next if( $s->removed || !$s->id || !$s->destroy );