File Coverage

blib/lib/Bifcode/V2.pm

Criterion	Covered	Total	%
statement	232	330	70.3
branch	96	98	97.9
condition	52	65	80.0
subroutine	55	55	100.0
pod	4	4	100.0
total	439	552	79.5

package Bifcode::V2;
use 5.010;
use strict;
use warnings;
use boolean ();
use Carp (qw/croak shortmess/);
use Exporter::Tidy all => [
    qw( encode_bifcode
      decode_bifcode
      force_bifcode
      diff_bifcode)
];

# ABSTRACT: Serialisation similar to Bencode + undef/UTF8

our $VERSION = '2.000_1';
our $max_depth;
our @CARP_NOT = (__PACKAGE__);

sub _croak {
    my $type     = shift // croak 'usage: _error($TYPE, [$msg])';
    my %messages = (
        Decode             => 'garbage at',
        DecodeBytes        => 'malformed BYTES length at',
        DecodeBytesTrunc   => 'unexpected BYTES end of data at',
        DecodeBytesTerm    => 'missing BYTES termination at',
        DecodeDepth        => 'nesting depth exceeded at',
        DecodeTrunc        => 'unexpected end of data at',
        DecodeReal         => 'malformed REAL data at',
        DecodeRealTrunc    => 'unexpected REAL end of data at',
        DecodeInteger      => 'malformed INTEGER data at',
        DecodeIntegerTrunc => 'unexpected INTEGER end of data at',
        DecodeTrailing     => 'trailing garbage at',
        DecodeUTF8         => 'malformed UTF8 string length at',
        DecodeUTF8Trunc    => 'unexpected UTF8 end of data at',
        DecodeUTF8Term     => 'missing UTF8 termination at',
        DecodeUsage        => undef,
        DiffUsage          => 'usage: diff_bifcode($b1, $b2, [$diff_args])',
        EncodeBytesUndef   => 'Bifcode::V2::BYTES ref is undefined',
        EncodeReal         => undef,
        EncodeRealUndef    => 'Bifcode::V2::REAL ref is undefined',
        EncodeInteger      => undef,
        EncodeIntegerUndef => 'Bifcode::V2::INTEGER ref is undefined',
        DecodeKeyType      => 'dict key is not BYTES or UTF8 at',
        DecodeKeyDuplicate => 'duplicate dict key at',
        DecodeKeyOrder     => 'dict key not in sort order at',
        DecodeKeyValue     => 'dict key is missing value at',
        EncodeUTF8Undef    => 'Bifcode::V2::UTF8 ref is undefined',
        EncodeUnhandled    => undef,
        EncodeUsage        => 'usage: encode_bifcode($arg)',
        ForceUsage         => 'ref and type must be defined',
    );

    my $err   = 'Bifcode::V2::Error::' . $type;
    my $msg   = shift // $messages{$type} // '(no message)';
    my $short = shortmess('');

    $msg =~ s! at$!' at input byte '. ( pos() // 0 )!e;

    eval 'package ' . $err . qq[;
        use overload
          bool => sub { 1 },
          '""' => sub { \${ \$_[0] } . ' (' . ( ref \$_[0] ) . ')$short' },
          fallback => 1;
        1; ];

    die bless \$msg, $err;
}

my $match = qr/ \G (?|
      (~,)
    | (f,)
    | (t,)
    | (b|u) (?: ( 0 | [1-9] [0-9]* ) \. )?
    | (i)   (?: ( 0 | -? [1-9] [0-9]* ) , )?
    | (r)   (?: ( 0 | -? [1-9] [0-9]* ) \. ( 0 | [0-9]* [1-9] ) e
                ( (?: 0 | -? [1-9] ) [0-9]* ) , )?
    | (\[)
    | (\{)
) /x;

sub _decode_bifcode_chunk {
    local $max_depth = $max_depth - 1 if defined $max_depth;

    unless (m/$match/gc) {
        _croak m/ \G \z /xgc ? 'DecodeTrunc' : 'Decode';
    }

    if ( $1 eq '~,' ) {
        return undef;
    }
    elsif ( $1 eq 'f,' ) {
        return boolean::false;
    }
    elsif ( $1 eq 't,' ) {
        return boolean::true;
    }
    elsif ( $1 eq 'b' ) {
        my $len = $2 // _croak 'DecodeBytes';
        _croak 'DecodeBytesTrunc' if $len > length() - pos();

        my $data = substr $_, pos(), $len;
        pos() = pos() + $len;

        _croak 'DecodeBytesTerm' unless m/ \G , /xgc;
        return $data;
    }
    elsif ( $1 eq 'u' ) {
        my $len = $2 // _croak 'DecodeUTF8';
        _croak 'DecodeUTF8Trunc' if $len > length() - pos();

        utf8::decode( my $str = substr $_, pos(), $len );
        pos() = pos() + $len;

        _croak 'DecodeUTF8Term' unless m/ \G , /xgc;
        return $str;
    }
    elsif ( $1 eq 'i' ) {
        return $2 if defined $2;
        _croak 'DecodeIntegerTrunc' if m/ \G \z /xgc;
        _croak 'DecodeInteger';
    }
    elsif ( $1 eq 'r' ) {
        if ( !defined $2 ) {
            _croak 'DecodeRealTrunc' if m/ \G \z /xgc;
            _croak 'DecodeReal';
        }
        _croak 'DecodeReal'
          if $2 eq '0'      # mantissa 0.
          and $3 eq '0'     # mantissa 0.0
          and $4 ne '0';    # sign or exponent 0.0e0

        return $2 . '.' . $3 . 'e' . $4;
    }
    elsif ( $1 eq '[' ) {
        _croak 'DecodeDepth' if defined $max_depth and $max_depth < 0;

        my @list;
        until (m/ \G \] /xgc) {
            push @list, _decode_bifcode_chunk();
        }
        return \@list;
    }
    elsif ( $1 eq '{' ) {
        _croak 'DecodeDepth' if defined $max_depth and $max_depth < 0;

        my $last_key;
        my %hash;
        until (m/ \G \} /xgc) {
            _croak 'DecodeTrunc' if m/ \G \z /xgc;
            _croak 'DecodeKeyType' unless m/ \G (b|u) /xgc;

            pos() = pos() - 1;
            my $key = _decode_bifcode_chunk();

            _croak 'DecodeKeyDuplicate' if exists $hash{$key};
            _croak 'DecodeKeyOrder'
              if defined $last_key and $key lt $last_key;
            _croak 'DecodeKeyValue' if m/ \G \} /xgc;

            $last_key = $key;
            $hash{$key} = _decode_bifcode_chunk();
        }
        return \%hash;
    }
}

sub decode_bifcode {
    local $_         = shift;
    local $max_depth = shift;

    _croak 'DecodeUsage', 'decode_bifcode: too many arguments' if @_;
    _croak 'DecodeUsage', 'decode_bifcode: input undefined'
      unless defined $_;
    _croak 'DecodeUsage', 'decode_bifcode: only accepts bytes'
      if utf8::is_utf8($_);

    my $deserialised_data = _decode_bifcode_chunk();
    _croak 'DecodeTrailing' if $_ !~ m/ \G \z /xgc;
    return $deserialised_data;
}

my $number_qr = qr/\A ( 0 | -? [1-9] [0-9]* )
                    ( \. ( [0-9]+? ) 0* )?
                    ( e ( -? [0-9]+ ) )? \z/xi;

sub _encode_bifcode {
    map {
        if ( !defined $_ ) {
            '~,';
        }
        elsif ( ( my $ref = ref $_ ) eq '' ) {
            if ( $_ =~ $number_qr ) {
                if ( defined $3 or defined $5 ) {

                    # normalize to BIFCODE_REAL standards
                    my $x = 'r' . ( 0 + $1 )    # remove leading zeros
                      . '.' . ( $3 // 0 ) . 'e' . ( 0 + ( $5 // 0 ) ) . ',';
                    $x =~ s/ ([1-9]) (0+ e)/.${1}e/x;    # remove trailing zeros
                    $x;
                }
                else {
                    'i' . $_ . ',';
                }
            }
            else {
                utf8::encode( my $str = $_ );
                'u' . length($str) . '.' . $str . ',';
            }
        }
        elsif ( $ref eq 'ARRAY' ) {
            '[' . join( '', map _encode_bifcode($_), @$_ ) . ']';
        }
        elsif ( $ref eq 'HASH' ) {
            '{' . join(
                '',
                do {
                    my @k = sort keys %$_;
                    map {
                        my $k = shift @k;

                        # if ( is valid utf8($k) ) {
                        utf8::encode($k);
                        ( 'u' . length($k) . '.' . $k . ',', $_ );

                        # }
                        # else {
                        #     ('b' . length($k) . '.' . $k .',', $_);
                        # }
                    } _encode_bifcode( @$_{@k} );
                  }
            ) . '}';
        }
        elsif ( $ref eq 'SCALAR' or $ref eq 'Bifcode::V2::BYTES' ) {
            $$_ // _croak 'EncodeBytesUndef';
            'b' . length($$_) . '.' . $$_ . ',';
        }
        elsif ( boolean::isBoolean($_) ) {
            $_ ? 't,' : 'f,';
        }
        elsif ( $ref eq 'Bifcode::V2::INTEGER' ) {
            $$_ // _croak 'EncodeIntegerUndef';
            _croak 'EncodeInteger', 'invalid integer: ' . $$_
              unless $$_ =~ m/\A (?: 0 | -? [1-9] [0-9]* ) \z/x;
            sprintf 'i%s,', $$_;
        }
        elsif ( $ref eq 'Bifcode::V2::REAL' ) {
            $$_ // _croak 'EncodeRealUndef';
            _croak 'EncodeReal', 'invalid real: ' . $$_
              unless $$_ =~ $number_qr;

            my $x = 'r' . ( 0 + $1 )    # remove leading zeros
              . '.' . ( $3 // 0 ) . 'e' . ( 0 + ( $5 // 0 ) ) . ',';
            $x =~ s/ ([1-9]) (0+ e)/.${1}e/x;    # remove trailing zeros
            $x;
        }
        elsif ( $ref eq 'Bifcode::V2::UTF8' ) {
            my $str = $$_ // _croak 'EncodeUTF8Undef';
            utf8::encode($str);  #, sub { croak 'invalid Bifcode::V2::UTF8' } );
            'u' . length($str) . '.' . $str . ',';
        }
        else {
            _croak 'EncodeUnhandled', 'unhandled data type: ' . $ref;
        }
    } @_;
}

sub encode_bifcode {
    _croak 'EncodeUsage' if @_ != 1;
    (&_encode_bifcode)[0];
}

sub force_bifcode {
    my $ref  = shift;
    my $type = shift;

    _croak 'ForceUsage' unless defined $ref and defined $type;
    bless \$ref, 'Bifcode::V2::' . uc($type);
}

sub _expand_bifcode {
    my $bifcode = shift;
    $bifcode =~ s/ (
            [\[\]\{\}]
            | ~,
            | (u|b) [0-9]+ \.
            | r -? [0-9]+ \. [0-9]+ e -? [0-9]+ ,
            | i [0-9]+ ,
        ) /\n$1/gmx;
    $bifcode =~ s/ \A \n //mx;
    $bifcode . "\n";
}

sub diff_bifcode {
    _croak 'DiffUsage' unless @_ >= 2 and @_ <= 3;
    my $b1        = shift;
    my $b2        = shift;
    my $diff_args = shift || { STYLE => 'Unified' };

    require Text::Diff;

    $b1 = _expand_bifcode($b1);
    $b2 = _expand_bifcode($b2);
    return Text::Diff::diff( \$b1, \$b2, $diff_args );
}

1;

__END__