File Coverage

blib/lib/Apache2/SSI/Notes.pm

Criterion	Covered	Total	%
statement	115	134	85.8
branch	27	58	46.5
condition	10	24	41.6
subroutine	21	24	87.5
pod	11	14	78.5
total	184	254	72.4

##----------------------------------------------------------------------------
## Apache2 Server Side Include Parser's Notes - ~/lib/Apache2/SSI/Notes.pm
## Version v0.1.0
## Copyright(c) 2021 DEGUEST Pte. Ltd.
## Author: Jacques Deguest <[e-mail]>
## Created 2021/01/18
## Modified 2021/01/19
## All rights reserved
##
## This program is free software; you can redistribute  it  and/or  modify  it
## under the same terms as Perl itself.
##----------------------------------------------------------------------------
package Apache2::SSI::Notes;
BEGIN
{
    use strict;
    use warnings;
    use warnings::register;
    use parent qw( Module::Generic );
    ## 512Kb
    use constant MAX_SIZE => 524288;
    use Apache2::SSI::SharedMem ':all';
    use Nice::Try;
    our $VERSION = 'v0.1.0';
};

sub init
{
    my $self = shift( @_ );
    $self->{key}  = 'ap2_ssi_notes';
    $self->{size} = MAX_SIZE;
    $self->{_init_strict_use_sub} = 1;
    $self->SUPER::init( @_ );
    return( $self->error( "Notes under this system $^O are unsupported." ) ) if( !Apache2::SSI::SharedMem->supported );
    my $mem = Apache2::SSI::SharedMem->new(
        key => ( length( $self->{key} ) ? $self->{key} : 'ap2_ssi_notes' ),
        ## 512 Kb max
        size => $self->{size},
        ## Create if necessary
        create => 1,
        debug => $self->debug,
    ) || return( $self->pass_error( Apache2::SSI::SharedMem->error ) );
    my $shem = $mem->open || return( $self->pass_error( $mem->error ) );
    $self->shem( $shem );
    return( $self );
};

sub add { return( shift->set( @_ ) ); }

sub clear
{
    my $self = shift( @_ );
    my $data = {};
    $self->write_mem( $data ) || return;
    return( $self );
}

sub do
{
    my $self = shift( @_ );
    my $code = shift( @_ );
    my @keys = @_;
    return( $self->error( "Code provided ($code) is not actually a code reference." ) ) if( ref( $code ) ne 'CODE' );
    my $data = $self->read_mem || return;
    @keys = sort( keys( %$data ) ) unless( scalar( @keys ) );
    foreach my $k ( @keys )
    {
        my $k_orig = $k;
        my $v = $data->{ $k };
        try
        {
            ## Code can modify values in-place like:
            ## sub
            ## {
            ##     $_[1] = 'new value' if( $_[0] eq 'some_key_name' );
            ## }
            $code->( $k, $v );
            ## Store possibly updated value
            $data->{ $k_orig } = $v;
        }
        catch( $e )
        {
            return( $self->error( "Callback died with error: $e" ) );
        }
    }
    ## No need to bother if there was no keys in the first place
    if( scalar( @keys ) )
    {
        $self->write_mem( $data ) || return;
    }
    return( $self );
}

sub get
{
    my $self = shift( @_ );
    my $key;
    if( @_ )
    {
        $key = shift( @_ );
        return( $self->error( "Key provided to retrieve is empty." ) ) if( !length( $key ) );
    }
    my $data = $self->read_mem || return;
    ## As it is the case for the first time, before any write
    $data = {} if( !ref( $data ) );
    return( $data ) if( !defined( $key ) );
    return( $data->{ $key } );
}

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

sub read_mem
{
    my $self = shift( @_ );
    my $shem = $self->shem ||
        return( $self->error( "Oh no, the shared memory object is gone! That should not happen." ) );
    my $data;
    my $len = $shem->read( $data );
    return( $self->pass_error( $shem->error ) ) if( !defined( $len ) );
    ## $self->message( 3, "Data read is: ", sub{ $self->dump( $data ) } );
    $data = {} unless( ref( $data ) eq 'HASH' );
    return( $data );
}

sub remove
{
    my $self = shift( @_ );
    my $shem = $self->shem ||
        return( $self->error( "Oh no, the shared memory object is gone! That should not happen." ) );
    my $rv;
    if( !defined( $rv = $shem->remove ) )
    {
        return( $self->pass_error( $shem->error ) );
    }
    return( $rv );
}

sub set
{
    my $self = shift( @_ );
    my $data = $self->read_mem || return;
    my @callinfo = caller;
    ## $self->message( 3, "Called from file $callinfo[1] at line $callinfo[2]" );
    my( $key, $value ) = @_;
    ## $self->message( 3, "Set key '$key' with value '$value'" );
    return( $self->error( "Key provided to set value is empty." ) ) if( !length( $key ) );
    $data->{ $key } = $value;
    $self->write_mem( $data ) || return;
    return( $self );
}

sub shem { return( shift->_set_get_object_without_init( 'shem', 'Apache2::SSI::SharedMem', @_ ) ); }

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

sub supported { return( Apache2::SSI::SharedMem->supported ); }

sub unset
{
    my $self = shift( @_ );
    my $key  = shift( @_ );
    return( $self->error( "Key provided to unset value is empty." ) ) if( !length( $key ) );
    my $data = $self->read_mem || return;
    delete( $data->{ $key } );
    $self->write_mem( $data ) || return;
    return( $self );
}

sub write_mem
{
    my $self = shift( @_ );
    my $shem = $self->shem ||
        return( $self->error( "Oh no, the shared memory object is gone! That should not happen." ) );
    my $data = shift( @_ );
    return( $self->error( "I was expecting an hash reference and got instead '$data'" ) ) if( ref( $data ) ne 'HASH' );
    if( !defined( $shem->lock( ( LOCK_EX | LOCK_NB ) ) ) )
    {
        ## $self->message( 3, "Error setting a non-blocking lock on the semaphore" );
        return( $self->pass_error( $shem->error ) );
    }
    my $rc = $shem->write( $data );
    $shem->unlock;
    return( $self->pass_error( $shem->error ) ) if( !defined( $rc ) );
    return( $self );
}

1;

__END__

=encoding utf-8

=head1 NAME

Apache2::SSI::Notes - Apache2 Server Side Include Notes

=head1 SYNOPSIS

    my $notes = Apache2::SSI::Notes->new(
        # 100K
        size => 102400,
        debug => 3,
    ) || die( Apache2::SSI::Notes->error );

    $notes->add( key => $val );

    $notes->clear;

    $notes->do(sub
    {
        # $_[0] = key
        # $_[1] = value
        $_[1] = Encode::decode( 'utf8', $_[1] );
    });

    # Or specify the keys to check
    $notes->do(sub
    {
        # $_[0] = key
        # $_[1] = value
        $_[1] = Encode::decode( 'utf8', $_[1] );
    }, qw( first_name last_name location ) );

    my $val = $notes-get( 'name' );

    # Get all as an hash reference
    my $hashref = $notes->get;

    $notes->set( name => 'John Doe' );

    # remove entry. This is different from $notes->set( name => undef() );
    # equivalent to delete( $hash->{name} );
    $notes->unset( 'name' );

=head1 VERSION

    v0.1.0

=head1 DESCRIPTION

L<Apache2::SSI::Notes> provides a mean to share notes in and out of Apache/mod_perl2 environment.

The interface is loosely mimicking L<APR::Table> on some, but not all, methods.

So you could have in your script, outside of Apache:

    $notes->set( API_ID => 1234567 );

And then, under mod_perl, in your file:

    <!--#if expr="note('API_ID')" -->

Normally, the C<note> function would work only for values set and retrieved inside the Apache/mod_perl2 framework, but with L<Apache2::SSI::Notes>, you can set a note, say, in a command line script and share it with your Server-Side Includes files.

To achieve this sharing of notes, L<Apache2::SSI::Notes> uses shared memory (see L<perlipc>) with L<Apache2::SSI::SharedMem> that does the heavy work.

However, this only works when L<Apache2::SSI> is in charge of parsing SSI files. Apache mod_includes module will not recognise notes stored outside of Apache/mod_perl framework.

=head1 METHODS

=head2 new

This instantiates a notes object. It takes the following parameters:

=over 4

=item I<debug>

A debug value will enable debugging output (equal or above 3 actually)

=item I<size>

The fixed size of the memory allocation. It defaults to 524,288 bytes which is 512 Kb, which should be ample enough.

=back

An object will be returned if it successfully initiated, or undef() upon error, which can then be retrieved with C<Apache2::SSI::Notes->error>. You should always check the return value of the methods used here for their definedness.

    my $notes = Apache2::SSI::Notes->new ||
        die( Apache2::SSI::Notes->error );

=head2 add

This is an alias for set.

=head2 clear

Empty all the notes. Beware that this will empty the notes for all the processes, since the notes are stored in a shared memory.

=head2 do

Provided with a callback as a code reference, and optionally an array of keys, and this will loop through all keys or the given keys if any, and call the callback passing it the key and its value.

For example:

    $notes->do(sub
    {
        my( $n, $v ) = @_;
        if( $n =~ /name/ )
        {
            $_[1] = Encode::decode( 'utf8', $_[1] );
        }
    });

=head2 get

Provided with a key and this retrieve its corresponding value, whatever that may be.

    my $val = $notes->get( 'name' );

If no key is provided, it returns all the notes as an hash reference.

    my $all = $notes->get;
    print( "API id is $all->{api}\n" );

Or maybe

    print( "API id is ", $notes->get->{api}, "\n" );

=head2 read_mem

Access the shared memory and return the hash reference stored.

If an error occurred, C<undef()> is returned and an L<Module::Generic/error> is set, which can be retrieved like:

    die( $notes->error );

Be careful however, that L</get> may return C<undef()> not because an error would have occurred, but because this is the value you would have previously set.

=head2 set

Provided with a key and value pair, and this will set its entry into the notes hash accordingly.

    $notes->set( name => 'John Doe' );

It returns the notes object to enable chaining.

=head2 shem

Returns the current value of the L<Apache2::SSI::SharedMem> object.

You can also set an alternative value, but this is not advised unless you know what you are doing.

=head2 size

Sets or gets the shared memory block size.

This should really not be changed. If you do want to change it, you first need to remove the shared memory.

    $notes->shem->remove;

And then create a new L<Apache2::SSI::Notes> object with a different size parameter value.

=head2 unset

Remove the notes entry for the given key.

    # No more name key:
    $notes->unset( 'name' );

It returns the notes object to enable chaining.

=head2 write_mem

Provided with data, and this will write the data to the shared memory.

=head1 AUTHOR

Jacques Deguest E<lt>F<[e-mail]>E<gt>

CPAN ID: jdeguest

L<https://git.deguest.jp/jack/Apache2-SSI>

=head1 SEE ALSO

mod_include, mod_perl(3), L<APR::Finfo>, L<perlfunc/stat>
L<https://httpd.apache.org/docs/current/en/mod/mod_include.html>,
L<https://httpd.apache.org/docs/current/en/howto/ssi.html>,
L<https://httpd.apache.org/docs/current/en/expr.html>
L<https://perl.apache.org/docs/2.0/user/handlers/filters.html#C_PerlOutputFilterHandler_>

=head1 COPYRIGHT & LICENSE

Copyright (c) 2020-2021 DEGUEST Pte. Ltd.

You can use, copy, modify and redistribute this package and associated
files under the same terms as Perl itself.

=cut