view release on metacpan or  search on metacpan

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

    {
        my $stat = $self->shmstat();
        # number of processes attached to the associated shared memory segment.
        if( defined( $stat ) && ( $stat->nattch() == 0 ) )
        {
            $self->remove;
        }
    }
};

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 };
        }
    }
    # CORE::delete( @hash{ qw( addr id locked owner removed removed_semaphore semid ) } );
    # 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 { 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 $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: 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 );
#         $s->detach;
#         $s->remove;
#     }
#     $shem_repo->unlock;
#     $shem_repo->remove;
# };

# NOTE: Module::Generic::SharedStat class
{
    package
        Module::Generic::SharedStat;
    use IPC::SysV;
    require IPC::SharedMem;
    our $VERSION = 'v0.1.0';

    use constant UID    => 0;
    use constant GID    => 1;
    use constant CUID   => 2;
    use constant CGID   => 3;
    use constant MODE   => 4;
    use constant SEGSZ  => 5;
    use constant LPID   => 6;
    use constant CPID   => 7;
    use constant NATTCH => 8;
    use constant ATIME  => 9;
    use constant DTIME  => 10;
    use constant CTIME  => 11;

    sub new
    {
        my $this = shift( @_ );
        my @vals = @_;
        return( bless( [ @vals ] => ref( $this ) || $this ) );
    }

    sub unpack
    {
        my $self = shift( @_ );
        my $data = shift( @_ );
        # XS method
        my $d = IPC::SharedMem::stat->new->unpack( $data );
        # my @unpacked = unpack( "i*", $data );
        return( $self->new( @$d ) );
    }

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

    # time the last detach was completed on the associated shared memory segment.
    sub dtime { return( shift->[DTIME] ); }

    sub gid { return( shift->[GID] ); }

    # process ID of the last process to attach or detach the shared memory segment.
    sub lpid { return( shift->[LPID] ); }

    sub mode { return( shift->[MODE] ); }

    # number of processes attached to the associated shared memory segment.
    sub nattch { return( shift->[NATTCH] ); }

    # size of the associated shared memory segment in bytes.
    sub segsz { return( shift->[SEGSZ] ); }

    sub uid { return( shift->[UID] ); }

    sub FREEZE
    {
        my $self = CORE::shift( @_ );
        my $serialiser = CORE::shift( @_ ) // '';
        my $class = CORE::ref( $self );
        my @array = @$self;
        # Return an array reference rather than a list so this works with Sereal
        # 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, \@array] );
            }
        }
        # But CBOR and Storable want a list with the first element being the serialised element
        CORE::return( $class, \@array );
    }

    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 $array = CORE::ref( $ref ) eq 'ARRAY' ? $ref : [];
        # Storable pattern requires to modify the object it created rather than returning a new one
        if( CORE::ref( $self ) )
        {
            @$self = @$array;
            CORE::return( $self );
        }
        else
        {
            my $new = bless( $array => $class );
            CORE::return( $new );
        }
    }

    sub TO_JSON { CORE::return( [ @{$_[0]} ] ); }
}

# NOTE: Module::Generic::SemStat class
{
    package
        Module::Generic::SemStat;
    use IPC::SysV;
    require IPC::Semaphore;
    our $VERSION = 'v0.1.0';

    use constant UID => 0;
    use constant GID => 1;
    use constant CUID => 2;
    use constant CGID => 3;
    use constant MODE => 4;
    use constant CTIME => 5;
    use constant OTIME => 6;
    use constant NSEMS => 7;

    sub new
    {
        my $this = shift( @_ );
        my @vals = @_;
        return( bless( [ @vals ] => ref( $this ) || $this ) );
    }

    sub unpack
    {
        my $self = shift( @_ );
        my $data = shift( @_ );
        # my @unpacked = unpack( "i*", $data );
        # XS method
        my $d = IPC::Semaphore::stat->new->unpack( $data );
        return( $self->new( @$d ) );
    }

    sub cgid { return( shift->[CGID] ); }

    sub ctime { return( shift->[CTIME] ); }

    sub cuid { return( shift->[CUID] ); }

    sub gid { return( shift->[GID] ); }

    sub mode { return( shift->[MODE] ); }

    # number of semaphores in the set associated with the semaphore entry.
    sub nsems { return( shift->[NSEMS] ); }

    # time the last semaphore operation was completed on the set associated with the semaphore entry.
    sub otime { return( shift->[OTIME] ); }

    sub uid { return( shift->[UID] ); }

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

    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 $array = CORE::ref( $ref ) eq 'ARRAY' ? $ref : [];
        # Storable pattern requires to modify the object it created rather than returning a new one
        if( CORE::ref( $self ) )
        {
            @$self = @$array;
            CORE::return( $self );
        }
        else
        {
            my $new = bless( $array => $class );
            CORE::return( $new );
        }
    }

    sub TO_JSON { CORE::return( [ @{$_[0]} ] ); }
}

1;

__END__