Bencode - BitTorrent serialisation format

 use Bencode qw( bencode bdecode );

 my $bencoded = bencode { 'age' => 25, 'eyes' => 'blue' };
 print $bencoded, "\n";
 my $decoded = bdecode $bencoded;

  Aristotle Pagaltzis <pagaltzis@gmx.de>

package Bencode;
BEGIN {
  $Bencode::VERSION = '1.4';
}
use strict;
use Carp;
use Exporter;

# ABSTRACT: BitTorrent serialisation format

use vars qw( $VERSION @ISA @EXPORT_OK $DEBUG $do_lenient_decode $max_depth );

@ISA = qw( Exporter );
@EXPORT_OK = qw( bencode bdecode );

sub _msg { sprintf "@_", pos() || 0 }

sub _bdecode_string {

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

		croak _msg 'unexpected end of string data starting at %s'
			if $len > length() - pos();

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

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

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

	return;
}

sub _bdecode_chunk {
	warn _msg 'decoding at %s' 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 _msg 'unexpected end of data at %s' if m/ \G \z /xgc;

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

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

		croak _msg 'nesting depth exceeded at %s'
			if defined $max_depth and $max_depth < 0;

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

		croak _msg 'nesting depth exceeded at %s'
			if defined $max_depth and $max_depth < 0;

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

			croak _msg 'unexpected end of data at %s'
				if m/ \G \z /xgc;

			my $key = _bdecode_string();
			defined $key or croak _msg 'dict key is not a string at %s';

			croak _msg 'duplicate dict key at %s'
				if exists $hash{ $key };

			croak _msg 'dict key not in sort order at %s'
				if not( $do_lenient_decode ) and defined $last_key and $key lt $last_key;

			croak _msg 'dict key is missing value at %s'
				if m/ \G e /xgc;

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

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

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

sub bencode {
	croak 'need exactly one argument' if @_ != 1;
	goto &_bencode;
}

bdecode( 'i1e' );

__END__