view release on metacpan or  search on metacpan

t/lib/Test/Apache2/Common.pm  view on Meta::CPAN

    }
    $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 api { return( shift->{api} ); }

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

sub debug
{
    my $self = shift( @_ );
    $self->{debug} = shift( @_ ) if( @_ );
    return( $self->{debug} );
}

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 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 ) ) );
    return( $self );
}

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

sub reply
{
    my $self = shift( @_ );
    my $code = shift( @_ );
    my $r = $self->request;
    $r->content_type( 'text/plain' );
    $r->status( $code );
    $r->rflush;
    $r->print( @_ );
    return( $code );
}

sub success { return( shift->reply( Apache2::Const::HTTP_OK => 'ok' ) ); }

sub _request { return( shift->{request} ); }

sub _target { die( "This method needs to be superseeded in the inheriting package." ) }

sub _test
{
    my $self = shift( @_ );
    my $opts = shift( @_ );
    die( "Argument provided is not an hash reference." ) if( ref( $opts ) ne 'HASH' );
    my $class = ref( $self );
    my $api = $self->api;
    my $r = $self->request;
    my $debug = $self->debug;
    my $meth = $opts->{method};
    if( !$meth )
    {
        $r->log_error( "${class}: no method provided to test." );
        return( Apache2::Const::HTTP_INTERNAL_SERVER_ERROR );
    }
    # expect may be undef
    if( !exists( $opts->{expect} ) )
    {
        $r->log_error( "${class}: no expected value provided to test method '$meth'." );
        return( Apache2::Const::HTTP_INTERNAL_SERVER_ERROR );
    }
    my $expect = $opts->{expect};
    my $args = exists( $opts->{args} ) ? $opts->{args} : undef;
    $opts->{type} //= '';
    my $obj = $self->_target;
    if( !$obj )
    {
        $r->log_error( "${class}: Cannot get a target object." );
        return( Apache2::Const::HTTP_INTERNAL_SERVER_ERROR );
    }