view release on metacpan or  search on metacpan

t/lib/TestUtils.pm  view on Meta::CPAN

use 5.010001;
use strict;
use warnings;
use Test::More 0.96;

# Hijack the JSON::PP::USE_B constant to enable svtype detection
BEGIN {
    no warnings 'redefine';

    require constant;
    my $orig = constant->can('import');
    local *constant::import = sub {
        if ($_[1] eq 'USE_B') {
            pop(@_);
            push(@_, 1)
        }
        goto &$orig;
    };

    require JSON::PP;
    die "TOO LATE"
        unless JSON::PP::USE_B();
}

use B;
use Carp qw/croak/;
use Config;
use JSON::PP ();

use base 'Exporter';
our @EXPORT = qw/
    sv_type packed_is bytes_are to_extjson to_myjson try_or_fail
    normalize_json
    INT64 INT32 FLOAT
/;

use constant {
    INT64 => 'q<',
    INT32 => 'l<',
    FLOAT => 'd<',
};

my $json_codec = JSON::PP
    ->new
    ->ascii
    ->allow_bignum
    ->allow_blessed
    ->convert_blessed;

sub normalize_json {
    my $decoded = $json_codec->decode(shift);
    return $json_codec->encode($decoded);
}

sub to_extjson {
    my $data = BSON->perl_to_extjson($_[0], { relaxed => $_[1] });
    return $json_codec->encode($data);
}

sub to_myjson {
    local $ENV{BSON_EXTJSON} = 0;
    return $json_codec->encode( shift );
}

sub sv_type {
    my $v     = shift;
    my $b_obj = B::svref_2object( \$v );
    my $type  = ref($b_obj);
    $type =~ s/^B:://;
    return $type;
}

sub packed_is {
    croak("Not enough args for packed_is()") unless @_ >= 3;
    my ( $template, $got, $exp, $label ) = @_;
    $label = '' unless defined $label;

    local $Test::Builder::Level = $Test::Builder::Level + 1;

    my $ok;
    if ( $template eq INT64 && ! $Config{use64bitint} ) {
        if ( !ref($got) && !ref($exp) ) {
            # regular scalar will fit in 32 bits, so downgrade the template
            $template = INT32;
        }
        else {
            # something is a reference, so must be BigInt or equivalent
            $ok = ok( $got eq $exp, $label );
            diag "Got: $got, Expected: $exp" unless $ok;
            return $ok;
        }
    }

    $ok = ok( pack( $template, $got ) eq pack( $template, $exp ), $label );
    diag "Got: $got, Expected: $exp" unless $ok;

    return $ok;
}

sub bytes_are {
    croak("Not enough args for bytes_are()") unless @_ >= 2;
    my ( $got, $exp, $label ) = @_;
    $label = '' unless defined $label;

    local $Test::Builder::Level = $Test::Builder::Level + 1;

    my $ok = ok( $got eq $exp, $label );
    diag "Got:\n", unpack( "H*", $got ), "\nExpected:\n", unpack( "H*", $exp )
      unless $ok;

    return $ok;
}