view release on metacpan or  search on metacpan

lib/Apache2/SSI/SharedMem.pm  view on Meta::CPAN

}

# $self->read( $buffer, $size );
sub read
{
    my $self   = shift( @_ );
    my $id     = $self->id;
    # Optional length parameter for non-reference data only
    my $size   = int( $_[1] || $self->size || SHM_BUFSIZ );
    return( $self->error( "No shared memory id! Have you opened it first?" ) ) if( !length( $id ) );
    my $buffer = '';
    my $addr = $self->addr;
    if( $addr )
    {
        memread( $addr, $buffer, 0, $size ) ||
            return( $self->error( "Unable to read data from shared memory address \"$addr\" using memread: $!" ) );
    }
    else
    {
        shmread( $id, $buffer, 0, $size ) ||
            return( $self->error( "Unable to read data from shared memory id \"$id\": $!" ) );
    }
    # Get rid of nulls end padded
    $buffer = unpack( "A*", $buffer );
    my $first_char = substr( $buffer, 0, 1 );
    my $j = JSON->new->utf8->relaxed->allow_nonref;
    my $data;
    local $@;
    # try-catch
    eval
    {
        # Does the value have any typical json format? " for a string, { for an hash and [ for an array
        if( $first_char eq '"' || $first_char eq '{' || $first_char eq '[' )
        {
            $data = $j->decode( $buffer );
        }
        else
        {
            $data = $buffer;
        }
    };
    if( $@ )
    {
        $self->error( "An error occured while json decoding data: $@", ( length( $buffer ) <= 1024 ? "\nData is: '$buffer'" : '' ) );
        # Maybe it's a string that starts with '{' or " or [ and triggered an error because it was not actually json data?
        # So we return the data stored as it is
        if( @_ )
        {
            $_[0] = $buffer;
            return( length( $buffer ) || "0E0" );
        }
        else
        {
            return( $buffer );
        }
    }
    
    if( @_ )
    {
        my $len = length( $_[0] );
        # If the decoded data is not a reference of any sort, and the length parameter was provided
        if( !ref( $data ) )
        {
            $_[0] = $size > 0 ? substr( $data, 0, $size ) : $data;
            return( length( $_[0] ) || "0E0" );
        }
        else
        {
            $_[0] = $data;
            return( $len || "0E0" );
        }
    }
    else
    {
        return( $data );
    }
}

sub remove
{
    my $self = shift( @_ );
    return( 1 ) if( $self->removed );
    my $id   = $self->id();
    return( $self->error( "No shared memory id! Have you opened it first?" ) ) if( !length( $id ) );
    my $semid = $self->semid;
    return( $self->error( "No semaphore set yet. You must open the shared memory first to remove semaphore." ) ) if( !length( $semid ) );
    $self->unlock();
    # Remove share memory segment
    if( !defined( shmctl( $id, &IPC::SysV::IPC_RMID, 0 ) ) )
    {
        return( $self->error( "Unable to remove share memory segement id '$id' (IPC_RMID is '", &IPC::SysV::IPC_RMID, "'): $!" ) );
    }
    # Remove semaphore
    my $rv;
    if( !defined( $rv = semctl( $semid, 0, &IPC::SysV::IPC_RMID, 0 ) ) )
    {
        $self->error( "Warning only: could not remove the semaphore id \"$semid\": $!" );
    }
    $self->removed( $rv ? 1 : 0 );
    if( $rv )
    {
        delete( $SHEM_REPO->{ $id } );
        $self->id( undef() );
        $self->semid( undef() );
    }
    return( $rv ? 1 : 0 );
}

sub removed { return( shift->_set_get_boolean( 'removed', @_ ) ); }

sub semid { return( shift->_set_get_scalar( 'semid', @_ ) ); }

sub serial { return( shift->_set_get_scalar( 'serial', @_ ) ); }

sub size { return( shift->_set_get_scalar( 'size', @_ ) ); }

sub stat
{
    my $self = shift( @_ );
    my $id   = $self->semid;
    return( $self->error( "No semaphore set yet. You must open the shared memory first to set the semaphore." ) ) if( !length( $id ) );