view release on metacpan or  search on metacpan

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

        next unless( index( $UNRESERVED, $chr ) < 0 );
        my $enc = sprintf( '%%%.2X', $ord );
        push @tests, [ $chr, $enc, sprintf( "ordinal %d", $ord ) ];
    }

    my $cnt = 0;
    foreach my $test ( @tests )
    {
        my( $expected, $encoded, $name ) = @$test;
        my $rv = $api->decode_url( $encoded ) eq $expected ? 1 : 0;
        $r->log_error( "$[class}: decode_url(): $name -> ", ( $rv ? 'ok' : 'not ok' ) ) if( $debug );
        $cnt++ if( $rv );
    }

    foreach my $test ( @tests )
    {
        my( $octets, $expected, $name ) = @$test;
        my $rv = $api->encode_url( $octets ) eq $expected ? 1 : 0;
        $r->log_error( "$[class}: encode_url(): $name -> ", ( $rv ? 'ok' : 'not ok' ) ) if( $debug );
        $cnt++ if( $rv );
    }
    return( $self->ok( $cnt == scalar( @tests ) ) );
}

my $jwt = q{eyJleHAiOjE2MzYwNzEwMzksImFsZyI6IkhTMjU2In0.eyJqdGkiOiJkMDg2Zjk0OS1mYWJmLTRiMzgtOTE1ZC1hMDJkNzM0Y2ZmNzAiLCJmaXJzdF9uYW1lIjoiSm9obiIsImlhdCI6MTYzNTk4NDYzOSwiYXpwIjoiNGQ0YWFiYWQtYmJiMy00ODgwLThlM2ItNTA0OWMwZTczNjBlIiwiaXNzIjoiaHR0cHM6Ly9hcG...
# Need to set the Authorization header in the test unit
# $r->authorization( "Bearer ${jwt}" );
sub auth { return( shift->_test({ method => 'get_auth_bearer', expect => $jwt }) ); }

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

{
    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} || do
    {
        $r->log_error( "$[class}: no method provided to test." );
        return( Apache2::Const::HTTP_INTERNAL_SERVER_ERROR );
    };
    # expect may be undef
    exists( $opts->{expect} ) || do
    {
        $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 || do
    {
        $r->log_error( "$[class}: Cannot get a target object." );
        return( Apache2::Const::HTTP_INTERNAL_SERVER_ERROR );
    };
    my $code = $obj->can( $meth ) || do
    {
        $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 );

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

        {
            $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__

=encoding utf8

=head1 NAME