File Coverage

blib/lib/Bencode.pm

Criterion	Covered	Total	%
statement	71	71	100.0
branch	68	80	85.0
condition	16	18	88.8
subroutine	10	10	100.0
pod	2	3	66.6
total	167	182	91.7

use 5.006;
use strict;
use warnings;

package Bencode;
our $VERSION = '1.502';

use Exporter::Tidy all => [qw( bencode bdecode )];

our ( $DEBUG, $do_lenient_decode, $max_depth, $undef_encoding );

sub croak {
	my ( @c, $i );
	1 while ( @c = caller $i++ ) and $c[0] eq __PACKAGE__;
	@c or @c = caller;
	die @_, " at $c[1] line $c[2].\n";
}

sub _bdecode_string {

	if ( m/ \G ( 0 | [1-9] \d* ) : /xgc ) {
		my $len = $1;

		croak 'unexpected end of string data starting at ', 0+pos
			if $len > length() - pos();

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

		warn "STRING (length $len)", $len < 200 ? " [$str]" : () if $DEBUG;

		return $str;
	}
	else {
		my $pos = pos();
		if ( m/ \G -? 0? \d+ : /xgc ) {
			pos() = $pos;
			croak 'malformed string length at ', 0+pos;
		}
	}

	return;
}

sub _bdecode_chunk {
	warn 'decoding at ', 0+pos if $DEBUG;

	local $max_depth = $max_depth - 1 if defined $max_depth;

	if ( defined( my $str = _bdecode_string() ) ) {
		return $str;
	}
	elsif ( m/ \G i /xgc ) {
		croak 'unexpected end of data at ', 0+pos if m/ \G \z /xgc;

		m/ \G ( 0 | -? [1-9] \d* ) e /xgc
			or croak 'malformed integer data at ', 0+pos;

		warn "INTEGER $1" if $DEBUG;
		return $1;
	}
	elsif ( m/ \G l /xgc ) {
		warn 'LIST' if $DEBUG;

		croak 'nesting depth exceeded at ', 0+pos
			if defined $max_depth and $max_depth < 0;

		my @list;
		until ( m/ \G e /xgc ) {
			warn 'list not terminated at ',0+pos,', looking for another element' if $DEBUG;
			push @list, _bdecode_chunk();
		}
		return \@list;
	}
	elsif ( m/ \G d /xgc ) {
		warn 'DICT' if $DEBUG;

		croak 'nesting depth exceeded at ', 0+pos
			if defined $max_depth and $max_depth < 0;

		my $last_key;
		my %hash;
		until ( m/ \G e /xgc ) {
			warn 'dict not terminated at ',0+pos,', looking for another pair' if $DEBUG;

			croak 'unexpected end of data at ', 0+pos
				if m/ \G \z /xgc;

			my $key = _bdecode_string();
			defined $key or croak 'dict key is not a string at ', 0+pos;

			croak 'duplicate dict key at ', 0+pos
				if exists $hash{ $key };

			croak 'dict key not in sort order at ', 0+pos
				if not( $do_lenient_decode ) and defined $last_key and $key lt $last_key;

			croak 'dict key is missing value at ', 0+pos
				if m/ \G e /xgc;

			$last_key = $key;
			$hash{ $key } = _bdecode_chunk();
		}
		return \%hash;
	}
	else {
		croak m/ \G \z /xgc ? 'unexpected end of data' : 'garbage', ' at ', 0+pos;
	}
}

sub bdecode {
	local $_ = shift;
	local $do_lenient_decode = shift;
	local $max_depth = shift;
	my $deserialised_data = _bdecode_chunk();
	croak 'trailing garbage at ', 0+pos if $_ !~ m/ \G \z /xgc;
	return $deserialised_data;
}

sub _bencode;
sub _bencode {
	map
	+( ( not defined     ) ? ( $undef_encoding or croak 'unhandled data type' )
	:  ( not ref         ) ? ( m/\A (?: 0 | -? [1-9] \d* ) \z/x ? 'i' . $_ . 'e' : length . ':' . $_ )
	:  ( 'SCALAR' eq ref ) ? ( length $$_ ) . ':' . $$_ # escape hatch -- use this to avoid num/str heuristics
	:  (  'ARRAY' eq ref ) ? 'l' . ( join '', _bencode @$_ ) . 'e'
	:  (   'HASH' eq ref ) ? 'd' . do { my @k = sort keys %$_; join '', map +( length $k[0] ) . ':' . ( shift @k ) . $_, _bencode @$_{ @k } } . 'e'
	:  croak 'unhandled data type'
	), @_
}

sub bencode {
	my $undef_mode = @_ == 2 ? pop : 'str';
	$undef_mode = 'str' unless defined $undef_mode;
	local $undef_encoding
		= 'str' eq $undef_mode ? '0:'
		: 'num' eq $undef_mode ? 'i0e'
		: 'die' eq $undef_mode ? undef
		: croak qq'undef_mode argument must be "str", "num", "die" or undefined, not "$undef_mode"';
	croak 'need exactly one or two arguments' if @_ != 1;
	( &_bencode )[0];
}

bdecode( 'i1e' );

__END__