File Coverage

blib/lib/Bifcode/V1.pm

Criterion	Covered	Total	%
statement	232	330	70.3
branch	94	96	97.9
condition	52	65	80.0
subroutine	55	55	100.0
pod	4	4	100.0
total	437	550	79.4

package Bifcode::V1;
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 = '1.003_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',
        DecodeFloat        => 'malformed FLOAT data at',
        DecodeFloatTrunc   => 'unexpected FLOAT 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::BYTES ref is undefined',
        EncodeFloat        => undef,
        EncodeFloatUndef   => 'Bifcode::FLOAT ref is undefined',
        EncodeInteger      => undef,
        EncodeIntegerUndef => 'Bifcode::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::UTF8 ref is undefined',
        EncodeUnhandled    => undef,
        EncodeUsage        => 'usage: encode_bifcode($arg)',
        ForceUsage         => 'ref and type must be defined',
    );

    my $err   = 'Bifcode::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 (?|
      (~)
    | (0)
    | (1)
    | (B|U) (?: ( 0 | [1-9] [0-9]* ) : )?
    | (I)   (?: ( 0 | -? [1-9] [0-9]* ) , )?
    | (F)   (?: ( 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 '0' ) {
        return boolean::false;
    }
    elsif ( $1 eq '1' ) {
        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 'F' ) {
        if ( !defined $2 ) {
            _croak 'DecodeFloatTrunc' if m/ \G \z /xgc;
            _croak 'DecodeFloat';
        }
        _croak 'DecodeFloat'
          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_FLOAT standards
                    my $x = 'F' . ( 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::BYTES' ) {
            $$_ // _croak 'EncodeBytesUndef';
            'B' . length($$_) . ':' . $$_ . ',';
        }
        elsif ( boolean::isBoolean($_) ) {
            $_;
        }
        elsif ( $ref eq 'Bifcode::INTEGER' ) {
            $$_ // _croak 'EncodeIntegerUndef';
            _croak 'EncodeInteger', 'invalid integer: ' . $$_
              unless $$_ =~ m/\A (?: 0 | -? [1-9] [0-9]* ) \z/x;
            sprintf 'I%s,', $$_;
        }
        elsif ( $ref eq 'Bifcode::FLOAT' ) {
            $$_ // _croak 'EncodeFloatUndef';
            _croak 'EncodeFloat', 'invalid float: ' . $$_
              unless $$_ =~ $number_qr;

            my $x = 'F' . ( 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::UTF8' ) {
            my $str = $$_ // _croak 'EncodeUTF8Undef';
            utf8::encode($str);    #, sub { croak 'invalid Bifcode::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::' . uc($type);
}

sub _expand_bifcode {
    my $bifcode = shift;
    $bifcode =~ s/ (
            [~\[\]\{\}]
            | (U|B) [0-9]+ :
            | F -? [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 );
}

decode_bifcode('I1,');

__END__