Apache2-API
5 results

 view release on metacpan or  search on metacpan

lib/Apache2/API.pm  view on Meta::CPAN 

            return( $self->pass_error( Apache2::API::Response->error ) );
        $self->response( $resp );
    }
    return( $self );
}

sub apache_request { return( shift->_set_get_object_without_init( 'apache_request', 'Apache2::RequestRec', @_ ) ); }

sub apr1_md5
{
    my( $passwd, $salt ) = @_;
    my $ht = Apache2::API::Password->new( $passwd, create => 1, algo => 'md5', ( defined( $salt ) ? ( salt => $salt ) : () ) ) ||
        die( Apache2::API::Password->error );
    return( $ht->hash );
}

sub bailout
{
    my $self = shift( @_ );
    my $msg;
    if( scalar( @_ ) == 1 && ref( $_[0] ) eq 'HASH' )
    {
        $msg = shift( @_ );
    }
    elsif( scalar( @_ ) == 1 && $self->_is_a( $_[0] => 'Module::Generic::Exception' ) )
    {
        my $ex = shift( @_ );
        $msg = {};
        if( my $code = $ex->code )
        {
            $msg->{code} = $code;
        }
        else
        {
            $msg->{code} = Apache2::Const::HTTP_INTERNAL_SERVER_ERROR;
        }
        $msg->{message} = $ex->message;
        my $lang;
        if( $ex->can( 'type' ) && ( my $type = $ex->type ) )
        {
            $msg->{type} = $type;
        }
        if( !$msg->{lang} && $ex->can( 'lang' ) && ( $lang = $ex->lang ) )
        {
            $msg->{lang} = $lang;
        }
        elsif( !$msg->{lang} && $ex->can( 'locale' ) && ( $lang = $ex->locale ) )
        {
            $msg->{lang} = $lang;
        }
        warn( $msg->{message} ) if( $msg->{message} );
    }
    else
    {
        $msg = { code => Apache2::Const::HTTP_INTERNAL_SERVER_ERROR };
        $msg->{message} = join( '', @_ ) if( @_ );
    }
    # We send the error to our error method
    $msg->{code} ||= Apache2::Const::HTTP_INTERNAL_SERVER_ERROR;
    $self->error( $msg ) if( $msg->{message} );
    CORE::delete( $msg->{skip_frames} );
    # So it gets logged or displayed on terminal
    my( $pack, $file, $line ) = caller;
    my $sub_str = ( caller(1) )[3];
    my $sub = CORE::index( $sub_str, '::' ) != -1 ? substr( $sub_str, rindex( $sub_str, '::' ) + 2 ) : $sub_str;
    # Now we tweak the hash to send it to the client
    $msg->{message} = CORE::delete( $msg->{public_message} ) || 'An unexpected server error has occurred';
    # Give it a chance to be localised
    $msg->{message} = $self->gettext( $msg->{message} );
    # For example, if the message is a Text::PO::Gettext::String object
    if( !$msg->{lang} && $self->_can( $msg->{message} => 'lang' ) )
    {
        $msg->{lang} = $msg->{message}->lang;
    }
    elsif( !$msg->{lang} && $self->_can( $msg->{message} => 'locale' ) )
    {
        $msg->{lang} = $msg->{message}->locale;
    }
    my $ctype = $self->response->content_type;
    if( $ctype eq 'application/json' )
    {
        return( $self->reply( $msg->{code}, { error => $msg->{message} } ) );
    }
    else
    {
        # try-catch
        local $@;
        my $rv = eval
        {
            my $r = $self->apache_request;
            $r->status( $msg->{code} );
            $r->rflush;
            $r->print( $msg->{message} );
            return( $msg->{code} );
        };
        if( $@ )
        {
            return( Apache2::Const::HTTP_INTERNAL_SERVER_ERROR );
        }
        return( $rv );
    }
}

sub compression_threshold { return( shift->_set_get_number( 'compression_threshold', @_ ) ); }

# <https://perl.apache.org/docs/2.0/api/APR/Base64.html#toc_C_decode_>
sub decode_base64
{
    my $self = shift( @_ );
    my $data = shift( @_ );
    # try-catch
    local $@;
    my $rv = eval
    {
        return( APR::Base64::decode( $data ) );
    };
    if( $@ )
    {
        return( $self->error( "An error occurred while trying to base64 decode data: $@" ) );
    }
    return( $rv );

lib/Apache2/API.pm  view on Meta::CPAN 

    if( Apache2::API::Status->is_error( $code ) )
    {
        my $req = $self->request;
        $req->request->pool->cleanup_register(sub
        {
            $req->close;
        });
    }
    return( $code );
}

sub request { return( shift->_set_get_object( 'request', 'Apache2::API::Request', @_ ) ); }

sub response { return( shift->_set_get_object( 'response', 'Apache2::API::Response', @_ ) ); }

sub server
{
    my $self = shift( @_ );
    # try-catch
    local $@;
    my $rv = eval
    {
        my $r = $self->apache_request;
        return( $r->server ) if( $r );
        return( Apache2::ServerUtil->server );
    };
    if( $@ )
    {
        return( $self->error( "An error occurred while trying to get the Apache server object: $@" ) );
    }
    return( $rv );
}

# sub server_version { return( version->parse( Apache2::ServerUtil::get_server_version ) ); }
# Or maybe the environment variable SERVER_SOFTWARE, e.g. Apache/2.4.18
# sub server_version { return( version->parse( Apache2::ServerUtil::get_server_version ) ); }
sub server_version 
{
    my $self = shift( @_ );
    my $v = $self->request->server_version || return( $self->pass_error( $self->request->error ) );
    return( version->parse( $v ) );
}

# $ok = $s->set_handlers($hook_name => \&handler);
# $ok = $s->set_handlers($hook_name => [\&handler, \&handler2]);
# $ok = $s->set_handlers($hook_name => []);
# $ok = $s->set_handlers($hook_name => undef);
# https://perl.apache.org/docs/2.0/api/Apache2/ServerUtil.html#C_set_handlers_
sub set_handlers { return( shift->_try( 'server', 'set_handlers', @_ ) ); }

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

sub warn
{
    my $self = shift( @_ );
    my $txt = join( '', map( ref( $_ ) eq 'CODE' ? $_->() : $_, @_ ) );
    my( $pkg, $file, $line, @otherInfo ) = caller;
    my $sub = ( caller( 1 ) )[3];
    my $sub2 = substr( $sub, rindex( $sub, '::' ) + 2 );
    my $trace = $self->_get_stack_trace();
    my $frame = $trace->next_frame;
    my $frame2 = $trace->next_frame;
    my $r = $self->apache_request;
    $txt = sprintf( "$txt called from %s in package %s in file %s at line %d\n%s\n",  $frame2->subroutine, $frame->package, $frame->filename, $frame->line, $trace->as_string );
    return( $r->warn( $txt ) ) if( $r );
    return( CORE::warn( $txt ) );
}

sub _try
{
    my $self = shift( @_ );
    my $pack = shift( @_ ) || return( $self->error( "No Apache package name was provided to call method" ) );
    my $meth = shift( @_ ) || return( $self->error( "No method name was provided to try!" ) );
    my $r = Apache2::RequestUtil->request;
    # $r->log_error( "Apache2::API::_try to call method \"$meth\" in package \"$pack\"." );
    # try-catch
    local $@;
    my $rv = eval
    {
        return( $self->$pack->$meth ) if( !scalar( @_ ) );
        return( $self->$pack->$meth( @_ ) );
    };
    if( $@ )
    {
        return( $self->error( "An error occurred while trying to call Apache ", ucfirst( $pack ), " method \"$meth\": $@" ) );
    }
    return( $rv );
}

# NOTE: sub FREEZE is inherited

sub STORABLE_freeze { CORE::return( CORE::shift->FREEZE( @_ ) ); }

sub STORABLE_thaw { CORE::return( CORE::shift->THAW( @_ ) ); }

# NOTE: sub THAW is inherited

# NOTE: Apache2::API::Password
package Apache2::API::Password;
use parent qw( Module::Generic );
use strict;
use warnings;
use vars qw( $VERSION $APR1_RE $BCRYPT_RE $SHA_RE );
# Compile the regular expression once
our $APR1_RE   = qr/\$apr1\$(?<salt>[.\/0-9A-Za-z]{1,8})\$[.\/0-9A-Za-z]{22}/;
our $BCRYPT_RE = qr/\$2[aby]\$(?<bcrypt_cost>\d{2})\$(?<salt>[A-Za-z0-9.\/]{22})[A-Za-z0-9.\/]{31}/;
our $SHA_RE    = qr/\$(?<sha_size>[56])\$(?:rounds=(?<rounds>\d+)\$)?(?<salt>[A-Za-z0-9.\/]{1,16})\$[A-Za-z0-9.\/]+/;
our $VERSION   = 'v0.1.1';

sub init
{
    my $self = shift( @_ );
    my $pwd  = shift( @_ );
    return( $self->error( "No password was provided." ) ) if( !defined( $pwd ) );
    $self->{create}        = 0     if( !exists( $self->{create} ) );
    # md5 | bcrypt | sha256 | sha512
    $self->{algo}          = 'md5' if( !exists( $self->{algo} ) );
    # 04..31
    $self->{bcrypt_cost}   = 12    if( !exists( $self->{bcrypt_cost} ) );
    # undef => default (5000)
    $self->{sha_rounds}    = undef if( !exists( $self->{sha_rounds} ) );
    # By default, like Apache does, we use Apache md5 algorithm
    # Other possibilities are bcrypt (Blowfish)
    $self->SUPER::init( @_ ) ||

lib/Apache2/API.pm  view on Meta::CPAN 

    # or
    return( $api->bailout( @some_reasons ) );

    # 100kb
    $api->compression_threshold(102400);
    my $decoded = $api->decode_base64( $b64_string );
    my $ref = $api->decode_json( $json_data );
    my $decoded = $api->decode_url;
    my $perl_utf8 = $api->decode_utf8( $data );
    my $b64_string = $api->encode_base64( $data );
    my $json_data = $api->encode_json( $ref );
    my $encoded = $api->encode_url( $uri );
    my $utf8 = $api->encode_utf8( $data );
    my $uuid = $api->generate_uuid;
    my $auth = $api->get_auth_bearer;
    my $handlers = $api->get_handlers;
    my $dt = $api->header_datetime( $http_datetime );
    my $bool = $api->is_perl_option_enabled;
    # JSON object
    my $json = $api->json( pretty => 1, sorted => 1, relaxed => 1 );
    my $lang = $api->lang( 'en_GB' );
    # en_GB
    my $lang = $api->lang_unix;
    # en-GB
    my $lang = $api->lang_web;
    $api->log_error( "Oops" );
    $api->print( @some_data );
    $api->push_handlers( $name => $code_reference );
    return( $api->reply( Apache2::Const::HTTP_OK => {
        message => "All good!",
        # arbitrary property
        client_id => "efe4bcf3-730c-4cb2-99df-25d4027ec404",
        # special property
        cleanup => sub
        {
            # Some code here to be executed after the reply is sent out to the client.
        }
    }) );
    # Apache2::API::Request
    my $req = $api->request;
    # Apache2::API::Response
    my $req = $api->response;
    my $server = $api->server;
    my $version = $api->server_version;
    $api->set_handlers( $name => $code_reference );
    $api->warn( @some_warnings );

    my $hash = apr1_md5( $clear_password );
    my $hash = apr1_md5( $clear_password, $salt );
    my $ht = $api->htpasswd( $clear_password );
    my $ht = $api->htpasswd( $clear_password, salt => $salt );
    my $hash = $ht->hash;
    say "Does our password match ? ", $ht->matches( $user_clear_password ) ? "yes" : "not";

=head1 VERSION

    v0.5.4

=head1 DESCRIPTION

This module provides a comprehensive, powerful, yet simple framework to access L<Apache mod_perl's API|https://perl.apache.org/docs/2.0/api/> and documented appropriately.

Apache mod_perl is an awesome framework, but quite complexe with a steep learning curve and methods all over the place. So much so that L<they have developed a module dedicated to find appropriate methods|https://perl.apache.org/docs/2.0/user/coding/...

=head1 METHODS

=head2 new

    my $api = Apache2::API->new( $r, $hash_ref_of_options );
    # or
    my $api = Apache2::API->new( apache_request => $r, compression_threshold => 102400 );

This initiates the package and takes an L<Apache2::RequestRec> object and an hash or hash reference of parameters, or only an hash or hash reference of parameters:

=over 4

=item * C<apache_request>

See L</apache_request>

=item * C<compression_threshold>

See L</compression_threshold>

=item * C<debug>

Optional. If set with a positive integer, this will activate debugging message

=back

=head2 apache_request

Returns the L<Apache2::RequestRec> object that was provided upon object instantiation.

=head2 bailout

    $api->bailout( $error_string );
    $api->bailout( { code => 400, message => $internal_message } );
    $api->bailout( { code => 400, message => $internal_message, public_message => "Sorry!" } );

Given an error message, this will prepare the HTTP header and response accordingly.

It will call L</gettext> to get the localised version of the error message, so this method is expected to be overriden by inheriting package.

If the outgoing content type set is C<application/json> then this will return a properly formatted standard json error, such as:

    { "error": { "code": 401, "message": "Something went wrong" } }

Otherwise, it will send to the client the message as is.

=head2 compression_threshold( $integer )

The number of bytes threshold beyond which, the L</reply> method will gzip compress the data returned to the client.

=head2 decode_base64( $data )

Given some data, this will decode it using base64 algorithm. It uses L<APR::Base64/decode> in the background.

=head2 decode_json( $data )

This decode from utf8 some data into a perl structure using L<JSON>

If an error occurs, it will return undef and set an exception that can be accessed with the L<error|Module::Generic/error> method.



( run in 1.176 second using v1.01-cache-2.11-cpan-e1769b4cff6 )