File Coverage

blib/lib/Bifcode.pm

Criterion	Covered	Total	%
statement	246	342	71.9
branch	112	140	80.0
condition	55	78	70.5
subroutine	57	57	100.0
pod	4	6	66.6
total	474	623	76.0

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

# ABSTRACT: Serialisation similar to Bencode + undef/UTF8

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

sub _croak {
    require Carp;
    my $type     = shift // Carp::croak('usage: _croak($TYPE, [$msg])');
    my %messages = (
        Decode             => 'garbage at',
        DecodeBifcodeTerm  => 'missing BIFCODE terminator 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::BYTES ref is undefined',
        EncodeReal         => undef,
        EncodeRealUndef    => 'Bifcode::REAL 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}
      // Carp::croak("Bifcode::_croak($type) has no message ");
    my $short = Carp::shortmess('');

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

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

    die $@ if $@;
    die bless \$msg, $err;
}

my $chunk = qr/ \G (?|
      (~,)
    | (f,)
    | (t,)
    | (B|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_key {

    unless (m/ \G (b|u) (?: ( 0 | [1-9] [0-9]* ) \. )? /gcx) {
        _croak m/ \G \z /xgc ? 'DecodeTrunc' : 'DecodeKeyType';
    }

    if ( $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;
    }
}

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

    unless (m/$chunk/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 0 + $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 0.0 + ( $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;

            my $key = _decode_bifcode_key();

            _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;
    }
    elsif ( $1 eq 'B' ) {
        my $len = $2 // _croak 'DecodeBifcode';
        _croak 'DecodeBifcodeTrunc' if $len > length() - pos();

        my $res = _decode_bifcode_chunk();
        _croak 'DecodeBifcodeTerm' unless m/ \G , /xgc;

        return $res;
    }
}

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', " For: $_" 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' . $_ . ',';
                }
            }
            elsif ( utf8::is_utf8($_) ) {
                utf8::encode( my $str = $_ );
                'u' . length($str) . '.' . $str . ',';
            }
            elsif ( $_ =~ m/^[\x{20}-\x{7E}]*$/ ) {
                'u' . length($_) . '.' . $_ . ',';
            }
            else {
                'b' . length($_) . '.' . $_ . ',';
            }
        }
        elsif ( $ref eq 'ARRAY' ) {
            '[' . join( '', map _encode_bifcode($_), @$_ ) . ']';
        }
        elsif ( $ref eq 'HASH' ) {
            '{' . join(
                '',
                do {
                    my $k;
                    my @k = sort keys %$_;

                    map {
                        $k = shift @k;

                        if ( $k =~ m/^[\x{20}-\x{7E}]*$/ ) {
                            ( 'u' . length($k) . '.' . $k . ':', $_ );
                        }
                        elsif ( utf8::is_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($_) ) {
            ( $_ ? 't' : 'f' ) . ',';
        }
        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::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::UTF8' ) {
            my $str = $$_ // _croak 'EncodeUTF8Undef';
            utf8::encode($str);
            'u' . length($str) . '.' . $str . ',';
        }
        else {
            _croak 'EncodeUnhandled', 'unhandled data type: ' . $ref;
        }
    } @_;
}

sub encode_bifcode {
    if ( ( @_ == 2 ) && pop ) {
        my $b = (&_encode_bifcode)[0];
        'B' . length($b) . '.' . $b . ',';
    }
    elsif ( @_ == 1 ) {
        (&_encode_bifcode)[0];
    }
    else {
        _croak 'EncodeUsage';
    }
}

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/ (
            [\[\]\{\}]
            | ~,
            | (B|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 );
}

# Looking for something like "B48." that may be truncated at any point
my $qr_bcbc = qr/
    ^
    (                                   # 1
        B
        (?:
            \Z | (?:
                ( 0 | [1-9][0-9]* )     # 2
                ( \Z | (\.) )           # 3
            )
        )
    )
/x;

sub anyevent_read_type {
    my ( $self, $cb, $maxdepth ) = @_;

    sub {
        return unless defined $_[0]->{rbuf};

        $_[0]->{rbuf} =~ s/^[\r\n]*//;
        return unless length $_[0]->{rbuf};

        $_[0]->{rbuf} =~ $qr_bcbc;

        if ( length $3 ) {
            $_[0]->unshift_read(
                chunk => length($1) + $2 + 1,
                sub {
                    my $data = eval { decode_bifcode( $_[1], $maxdepth ) };
                    if ($@) {
                        $_[0]->_error( Errno::EBADMSG(), undef, $@ );
                    }
                    else {
                        $cb->( $_[0], $data );
                    }
                    1;
                }
            );
            return 1;
        }
        elsif ( not length $1 ) {
            $_[0]->_error( Errno::EBADMSG() );
            return;
        }
        else {
            return;    # not enough data yet
        }
    };
}

sub anyevent_write_type {
    encode_bifcode( $_[1], 1 ) . "\n";
}

1;

__END__