view release on metacpan or  search on metacpan

t/CookieTest.pm  view on Meta::CPAN

package CookieTest;
BEGIN
{
    use strict;
    use warnings;
    use lib './lib';
    use Apache2::Connection ();
    use Apache2::Const -compile => qw( :common :http OK DECLINED );
    use Apache2::RequestIO ();
    use Apache2::RequestRec ();
    # so we can get the request as a string
    use Apache2::RequestUtil ();
    use APR::URI ();
    use Cookie::Jar;
    # 2021-11-1T167:12:10+0900
    use Test::Time time => 1635754330;
    eval( "use Crypt::Cipher::AES" );
    use constant HAS_CRYPT => ( $@ ? 0 : 1 );
    eval( "use Bytes::Random::Secure" );
    use constant HAS_RAND_BYTES => ( $@ ? 0 : 1 );
    use constant HAS_SSL => ( $ENV{HTTPS} || ( defined( $ENV{SCRIPT_URI} ) && substr( lc( $ENV{SCRIPT_URI} ), 0, 5 ) eq 'https' ) ) ? 1 : 0;
    # For AES encryption, the requirements are key of minimum 32 bytes and IV of 16 bytes
    our $CRYPT_KEY = '501213571d199667011fc6b37a9651bf';
    our $CRYPT_IV  = 'ee60150eca7743a9';
};

sub handler : method
{
    my( $class, $r ) = @_;
    my $debug = $r->dir_config( 'COOKIES_DEBUG' );
    $r->log_error( "${class}: Received request for uri \"", $r->uri, "\" matching file \"", $r->filename, "\": ", $r->as_string );
    my $uri = APR::URI->parse( $r->pool, $r->uri );
    my $path = [split( '/', $uri->path )]->[-1];
    my $jar = Cookie::Jar->new( $r, debug => $debug ) || do
    {
        $r->log_error( "$class: Error instantiating Cookie::Jar object: ", Cookie::Jar->error );
        return( Apache2::Const::HTTP_INTERNAL_SERVER_ERROR );
    };
    $jar->fetch || do
    {
        $r->log_error( "$class: Error fetching cookies from http request: ", $jar->error );
        return( Apache2::Const::HTTP_INTERNAL_SERVER_ERROR );
    };
    my $self = bless( { request => $r, jar => $jar, debug => int( $r->dir_config( 'COOKIES_DEBUG' ) ) } => $class );
    my $code = $self->can( $path );
    if( !defined( $code ) )
    {
        $r->log_error( "No method \"$path\" for testing." );
        return( Apache2::Const::DECLINED );
    }
    $r->err_headers_out->set( 'Test-No' => $path );
    my $rc = $code->( $self );
    $r->log_error( "$class: Returning http code '$rc' for method '$path'" );
    if( $rc == Apache2::Const::HTTP_OK )
    {
        # https://perl.apache.org/docs/2.0/user/handlers/intro.html#item_RUN_FIRST
        # return( Apache2::Const::DONE );
        return( Apache2::Const::OK );
    }
    else
    {
        return( $rc );
    }
    # $r->connection->client_socket->close();
    exit(0);
}

sub error
{
    my $self = shift( @_ );
    my $r = $self->request;
    $r->status( Apache2::Const::HTTP_INTERNAL_SERVER_ERROR );
    my $ref = [@_];
    my $error = join( '', map( ( ref( $_ ) eq 'CODE' ) ? $_->() : ( $_ // '' ), @$ref ) );
    warn( $error );
    $r->log_error( $error );
    $r->print( $error );
    $r->rflush;
    return;
}

sub failure { return( shift->reply( Apache2::Const::HTTP_EXPECTATION_FAILED => 'failed' ) ); }

sub is
{
    my $self = shift( @_ );
    my( $what, $expect ) = @_;
    return( $self->success ) if( $what eq $expect );
    return( $self->reply( Apache2::Const::HTTP_EXPECTATION_FAILED => "failed\nI was expecting \"$expect\", but got \"$what\"." ) );
}

sub jar { return( shift->{jar} ); }

sub message
{
    my $self = shift( @_ );
    return unless( $self->{debug} );
    my $class = ref( $self );
    my $r = $self->request || return( $self->error( "No Apache2::RequestRec object set!" ) );
    my $ref = [@_];
    my $sub = (caller(1))[3] // '';
    my $line = (caller())[2] // '';
    $sub = substr( $sub, rindex( $sub, ':' ) + 1 );
    $r->log_error( "${class} -> $sub [$line]: ", join( '', map( ( ref( $_ ) eq 'CODE' ) ? $_->() : ( $_ // '' ), @$ref ) ) );