view release on metacpan or  search on metacpan

t/SSITest.pm  view on Meta::CPAN

package SSITest;
BEGIN
{
    use strict;
    use warnings;
    use lib './lib';
    use parent qw( Apache2::SSI );
    use Apache2::SSI::URI;
    use Apache2::SSI::File;
    use Apache2::Const -compile => qw( :common :http DECLINED );
    use APR::URI ();
    use URI::file;
    # use Devel::Confess;
    use constant BASE_URI => '/ssi';
    use constant TEST_URI_1 => './ssi/include.cgi';
    use constant TEST_URI_2 => './not-existing.txt';
};

sub handler : method
{
    my( $class, $r ) = @_;
    $r->log_error( "${class}: Received request for uri \"", $r->uri, "\" matching file \"", $r->filename, "\"." );
    my $uri = APR::URI->parse( $r->pool, $r->uri );
    my $path = [split( '/', $uri->path )]->[-1];
    my $self = bless( { apache_request => $r, debug => int( $r->dir_config( 'Apache2_SSI_DEBUG' ) ) } => $class );
    my $code = $self->can( $path );
    if( !defined( $code ) )
    {
        $r->log_error( "No method \"$path\" for SSI testing." );
        return( Apache2::Const::DECLINED );
    }
    my $res = $code->( $self );
    return( Apache2::Const::OK );
}

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

sub error
{
    my $self = shift( @_ );
    my $r = $self->apache_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( "failed\nI was expecting \"$expect\", but got \"$what\"." ) );
}

sub message
{
    my $self = shift( @_ );
    return unless( $self->{debug} );
    my $class = ref( $self );
    my $r = $self->apache_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 ) ) );
    return( $self );
}

sub ok
{
    my $self = shift( @_ );
    my $cond = shift( @_ );
    return( $cond ? $self->success : $self->failure );
}

sub reply
{
    my $self = shift( @_ );