view release on metacpan or  search on metacpan

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

package Test::Apache2::API;
BEGIN
{
    use strict;
    use warnings;
    use lib './lib';
    use parent qw( Test::Apache2::Common );
    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 Apache2::API;
    use Scalar::Util;
    # 2021-11-1T17:12:10+0900
    use Test::Time time => 1635754330;
    use constant HAS_SSL => ( $ENV{HTTPS} || ( defined( $ENV{SCRIPT_URI} ) && substr( lc( $ENV{SCRIPT_URI} ), 0, 5 ) eq 'https' ) ) ? 1 : 0;
};

use strict;
use warnings;

sub compression_threshold { return( shift->_test({ method => 'compression_threshold', expect => 102400 }) ); }

my $json = <<EOT;
{
    "debug": "true",
    "client_id": "d7024a37-f8d8-4d37-bbc4-5bd19429df8c",
    "total": 10.20,
}
EOT

sub decode_json { return( shift->_test({ method => 'compression_threshold', expect => sub
{
    my $ref = shift( @_ );
    return(0) if( ref( $ref ) ne 'HASH' );
    return( $ref->{debug} && $ref->{client_id} eq 'd7024a37-f8d8-4d37-bbc4-5bd19429df8c' && $ref->{total} == 10.20 );
}, args => [$json] }) ); }

sub encode_decode_url
{
    my $self = shift( @_ );
    my $class = ref( $self );
    my $api = $self->api;
    my $r = $self->request;
    my $debug = $self->debug;
    # Borrowed from URL::Encode
    my $UNRESERVED = "0123456789"
    . "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
    . "abcdefghijklmnopqrstuvwxyz"
    . "_.~-";
    
    my @tests = (
        [ "",         "",     "empty string" ],
        [ "\x{00E5}", "%E5",  "U+00E5 in native encoding" ],
        [ $UNRESERVED, $UNRESERVED, "unreserved characters" ],
        [ " ", "+", "U+0020 SPACE" ]
    );
    
    for my $ord ( 0x00..0x1F, 0x21..0xFF )
    {
        my $chr = pack( 'C', $ord );
        next unless( index( $UNRESERVED, $chr ) < 0 );
        my $enc = sprintf( '%%%.2X', $ord );