view release on metacpan or  search on metacpan

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

    $new->size( $opts->{size} );
    $new->flags( $flags );
    if( $there == SHM_EXISTS )
    {
    }
    else
    {
        # We initialise the semaphore with value of 1
        $new->stat( SEM_MARKER, SHM_EXISTS ) ||
            return( $self->error( "Unable to set semaphore during object creation: $!" ) );
        $SHEM_REPO->{ $id } = $new;
    }
    $new->op( @{$SEMOP_ARGS->{(LOCK_SH | LOCK_UN)}} );
    return( $new );
}

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

sub pid
{
    my $self = shift( @_ );
    my $sem  = shift( @_ );
    my $semid = $self->semid ||
        return( $self->error( "No semaphore set yet. You must open the shared memory first to remove semaphore." ) );
    my $v = semctl( $semid, $sem, &IPC::SysV::GETPID, 0 );
    return( $v ? 0 + $v : undef() );
}

sub rand
{
    my $self = shift( @_ );
    my $size = $self->size || 1024;
    my $key  = shmget( &IPC::SysV::IPC_PRIVATE, $size, &IPC::SysV::S_IRWXU|&IPC::SysV::S_IRWXG|&IPC::SysV::S_IRWXO ) ||
        return( $self->error( "Unable to generate a share memory key: $!" ) );
    return( $key );
}

# $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 ) );

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

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 ) );
    if( @_ )
    {
        if( @_ == 1 )
        {
            my $sem = shift( @_ );
            my $v = semctl( $id, $sem, &IPC::SysV::GETVAL, 0 );
            return( $v ? 0 + $v : undef() );
        }
        else
        {
            my( $sem, $val ) = @_;
            return( semctl( $id, $sem, &IPC::SysV::SETVAL, $val ) );
        }
    }
    else
    {
        my $data = '';
        if( wantarray() )
        {
            semctl( $id, 0, &IPC::SysV::GETALL, $data ) || return( () );
            return( ( unpack( "s*", $data ) ) );
        }
        else
        {
            semctl( $id, 0, &IPC::SysV::IPC_STAT, $data ) ||
                return( $self->error( "Unable to stat semaphore with id '$id': $!" ) );
            return( Apache2::SSI::SemStat->new->unpack( $data ) );
        }
    }
}

sub supported { return( $SYSV_SUPPORTED ); }

sub unlock
{
    my $self = shift( @_ );
    return( 1 ) if( !$self->locked );
    my $semid = $self->semid;
    return( $self->error( "No semaphore set yet. You must open the shared memory first to unlock semaphore." ) ) if( !length( $semid ) );
    my $type = $self->locked | LOCK_UN;
    $type ^= LOCK_NB if( $type & LOCK_NB );
    if( defined( $self->op( @{$SEMOP_ARGS->{ $type }} ) ) )
    {
        $self->locked( 0 );
    }
    return( $self );
}

sub write
{
    my $self = shift( @_ );
    my $data = ( @_ == 1 ) ? shift( @_ ) : join( '', @_ );
    my $id   = $self->id();
    my $size = int( $self->size() ) || SHM_BUFSIZ;
    my @callinfo = caller;
    my $j = JSON->new->utf8->relaxed->allow_nonref->convert_blessed;
    my $encoded;
    local $@;
    # try-catch
    eval
    {
        $encoded = $j->encode( $data );
    };
    if( $@ )
    {
        return( $self->error( "An error occured json encoding data provided: $@" ) );
    }
    
    if( length( $encoded ) > $size )
    {
        return( $self->error( "Data to write are ", length( $encoded ), " bytes long and exceed the maximum you have set of '$size'." ) );
    }
    # $size = length( $encoded );
    my $addr = $self->addr;
    if( $addr )
    {
        memwrite( $addr, $encoded, 0, $size ) ||
            return( $self->error( "Unable to write to shared memory address '$addr' using memwrite: $!" ) );
    }
    else
    {
        shmwrite( $id, $encoded, 0, $size ) ||
            return( $self->error( "Unable to write to shared memory id '$id': $!" ) );
    }
    return( $self );
}

sub _str2key
{
    my $self = shift( @_ );
    my $key  = shift( @_ );
    if( !defined( $key ) || $key eq '' )
    {
        return( &IPC::SysV::IPC_PRIVATE );
    }
    elsif( $key =~ /^\d+$/ )
    {
        return( IPC::SysV::ftok( __FILE__, $key ) );
    }
    else
    {
        my $id = 0;
        $id += $_ for( unpack( "C*", $key ) );
        # We use the root as a reliable and stable path.
        # I initially though about using __FILE__, but during testing this would be in ./blib/lib and beside one user might use a version of this module somewhere while the one used under Apache/mod_perl2 could be somewhere else and this would render...
        my $val = IPC::SysV::ftok( '/', $id );
        return( $val );
    }
}

END
{
    foreach my $id ( keys( %$SHEM_REPO ) )
    {
        my $s = $SHEM_REPO->{ $id };
        $s->unlock;