view release on metacpan or  search on metacpan

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

    $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 );
    }
    my $code = $obj->can( $meth );
    if( !$code )
    {
        $r->log_error( "${class}: Method '$meth' is not supported in ", ref( $obj ), "." );
        return( Apache2::Const::HTTP_INTERNAL_SERVER_ERROR );
    }
    my $base_path;
    unless( $base_path = $class2log->{ ref( $obj ) } )
    {
        my @parts = split( /::/, ref( $obj ) );
        my $parent_path = $config->{vars}->{t_logs} || die( "No 't_logs' variable in Apache::TestConfig->thaw->httpd_config" );
        $parent_path = file( $parent_path );
        $base_path = $parent_path->child( join( '/', map( lc( $_ ), split( /::/, ref( $obj ) ) ) ) );
        $base_path->mkpath if( !$base_path->exists );
        $class2log->{ ref( $obj ) } = $base_path;
    }
    my $log_file = $base_path->child( "${meth}.log" );
    my $io = $log_file->open( '>', { autoflush => 1, binmode => 'utf8' } ) || 
        die( "Unable to open test log file \"$log_file\" in write mode: $!" );
    
    my $val = $args ? $code->( $obj, @$args ) : $code->( $obj );
    my $rv;
    if( ref( $expect ) eq 'CODE' )
    {
        $rv = $expect->( $val, { object => $self, log => sub{ $io->print( @_, "\n" ) } } );
    }
    elsif( $opts->{type} eq 'boolean' )
    {
        $rv = ( int( $val // '' ) == $expect );
        if( !$rv )
        {
            $io->print( "Boolean value expected (", ( $expect // 'undef' ), "), but got '", int( $val // '' ), "'\n" );
        }
    }
    elsif( $opts->{type} eq 'isa' )
    {
        $rv = ( Scalar::Util::blessed( $val ) && $val->isa( $expect ) );
        if( !$rv )
        {
            $io->print( "Object of class '", ( $expect // 'undef' ), "', but instead got '", ( $val // 'undef' ), "'\n" );
        }
    }
    else
    {
        if( !defined( $val ) )
        {
            $rv = !defined( $expect );
            if( !$rv )
            {
                $io->print( "Expected a defined value (", ( $expect // 'undef' ), "), but instead got an undefined one.\n" );
            }
        }
        elsif( !defined( $expect ) )
        {
            $rv = 0;
            if( !$rv )
            {
                $io->print( "Expected an undefined value, but instead got a defined one (", ( $val // 'undef' ), ").\n" );
            }
        }
        else
        {
            $rv = ( $val eq $expect );
            if( !$rv )
            {
                $io->print( "Expected the value to be '", ( $expect // 'undef' ), "', but instead got '", ( $val // 'undef' ), "'\n" );
            }
        }
    }
    $io->close;
    $log_file->remove if( $log_file->is_empty );
    $r->log_error( "${class}: ${meth}() -> ", ( $rv ? 'ok' : 'not ok' ) ) if( $debug );
    return( $self->ok( $rv ) );
}

1;
# NOTE: POD
__END__