view release on metacpan or  search on metacpan

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

##----------------------------------------------------------------------------
## Apache2 API Framework - ~/lib/m
## Version v0.5.3
## Copyright(c) 2026 DEGUEST Pte. Ltd.
## Author: Jacques Deguest <jack@deguest.jp>
## Created 2023/05/30
## Modified 2026/04/15
## 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::API;
BEGIN
{
    use strict;
    use warnings;
    use warnings::register;
    use parent qw( Module::Generic );
    use vars qw( $VERSION $DEBUG @EXPORT $USE_RFC_ERROR );
    use version;
    use Encode ();
    # use Apache2::Const qw( :common :http );
    use Apache2::Const -compile => qw( :cmd_how :common :config :conn_keepalive :context :filter_type :http :input_mode :log :methods :mpmq :options :override :platform :remotehost :satisfy :types :proxy );
    use APR::Const -compile => qw( :common :error :fopen :filepath :fprot :filetype :finfo :flock :hook :limit :lockmech :poll :read_type :shutdown_how :socket :status :table :uri );
    use Apache2::RequestRec ();
    use Apache2::RequestIO ();
    use Apache2::ServerUtil ();
    use Apache2::RequestUtil ();
    use Apache2::Response ();
    use Apache2::Log ();
    use Apache2::API::Request;
    use Apache2::API::Response;
    use Apache2::API::Status;
    use APR::Base64 ();
    use APR::Request ();
    use APR::UUID ();
    use Exporter ();
    use JSON ();
    use Scalar::Util ();
    our @EXPORT = qw( apr1_md5 );
    $DEBUG   = 0;
    $VERSION = 'v0.5.3';
};

use strict;
use warnings;

sub import
{
    my( $this, @arguments ) = @_ ;
    my $class = CORE::caller();
    # my $code = qq{package ${class}; use Apache2::Const -compile => qw( @arguments );};
    # print( "Evaluating -> $code\n" );
    # eval( $code );
    # print( "\$@ -> $@\n" );

    # local $Exporter::ExportLevel = 1;
    # Apache2::Const->import( '-compile' => @arguments );
    # my @argv = grep( !/^\:http/, @arguments );
    # Apache2::Const->compile( '-compile' => @argv );
    # Apache2::Const->compile( $class => qw( AUTH_REQUIRED ) );

    Apache2::Const->compile( $class => @arguments );
    Exporter::export_to_level( $this, 1, @EXPORT );
}

sub init
{
    my $self = shift( @_ );
    my $r;
    $r = shift( @_ ) if( @_ % 2 );
    # my $r = shift( @_ ) || Apache2::RequestUtil->request;
    $self->{request}                = undef unless( $self->{request} );
    $self->{response}               = undef unless( $self->{response} );
    $self->{apache_request}         = $r unless( $self->{apache_request} );
    # 200Kb
    $self->{compression_threshold}  = 204800 unless( length( $self->{compression_threshold} ) );
    $self->{use_rfc_error}          = $USE_RFC_ERROR unless( length( $self->{use_rfc_error} ) );
    $self->SUPER::init( @_ ) || return( $self->pass_error );
    unless( $r = $self->apache_request )
    {
        $r ||= Apache2::RequestUtil->request;
        return( $self->error( "No Apache2::RequestRec object was provided." ) ) if( !$r );
        $self->apache_request( $r ) || return( $self->pass_error );
    }
    my( $req, $resp );
    unless( $req = $self->request )
    {
        $req = Apache2::API::Request->new( $r, debug => $self->debug ) ||
            return( $self->pass_error( Apache2::API::Request->error ) );
        $self->request( $req );
    }
    unless( $resp = $self->response )
    {
        $resp = Apache2::API::Response->new( request => $req, debug => $self->debug ) ||
            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 );
}

sub decode_json

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

    my $self = shift( @_ );
    my $code = $self->reply( @_ );
    $code //= 500;
    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