#!/usr/bin/perl
use strict;
use warnings;
use Benchmark qw(:all);

my $fault=0;

# Reference implementation

my $BrowserUk = sub {
    my $arg = shift;
    my @bytes;
    push @bytes, ord( pack 'b6', $_ ) for unpack '(a6)*', unpack 'b*',
+ $arg;
    return (@bytes);
};

my $orig= "This is not a hat.";
my $reference = hexdump(&{$BrowserUk}($orig));
print "REF: $reference\n";

# Jethro's setup

my (@table0u, @table1l, @table1u, @table2l, @table2u);
for (0 .. 255) {
    $table0u[$_] = $_>>6;
    $table1l[$_] = ($_ & 0x0f)<<2;
    $table1u[$_] = $_>>4;
    $table2l[$_] = ($_ & 0x03)<<4;
    $table2u[$_] = $_>>2;
}

my $jethro = sub {
    my @arg = map { ord($_) } split //,shift;
    my @number;
    while (@arg) {
        my @byte = (splice @arg, 0, 3);
        push @number, $byte[0]&63;
        push @number, $table0u[$byte[0]] + $table1l[$byte[1]];
        push @number, $table1u[$byte[1]] + $table2l[$byte[2]];
        push @number, $table2u[$byte[2]];
    }
    return (@number);
};

test("jethro", $jethro, $orig);


# Use pack (or unpack) after mangling header

=h1 Doesn't work!

my $robo_1 = sub {
    my $orig = shift;
    $orig = "8 " . $orig;
    my (undef, @bytes) = map { ord($_) } split //, pack "u", $orig;
    return (@bytes);
};

test("robo_1", $robo_1, $orig);

=cut

# Roboticus' second attempt

my $robo_2 = sub {
    my @orig = unpack "S*", shift;
    my $bits=0;
    my $buf=0;
    my @bytes;
    while (@orig) {
        $buf |= (shift @orig)<<$bits;
        $bits += 16;
        while ($bits>6) {
            push @bytes, $buf & 0x3f;
            $buf>>=6;
            $bits-=6;
        }
    }
    push @bytes, $buf if $bits;
    return (@bytes);
};

test("robo_2", $robo_2, $orig);

# Benchmark them

die unless $fault==0;
my $t1 = "x" x 24;
cmpthese( 100000,
    {
        BrowserUk => sub { &$BrowserUk($t1) },
        jethro      => sub { &$jethro($t1) },
#        robo_1    => sub { &$robo_1($t1) },
        robo_2    => sub { &$robo_2($t1) },
    }
);

sub hexdump {
    join("", map { sprintf "%02x ", $_ } @_);
}

sub test {
    my ($name, $fr, $arg) = (@_);
    my @bytes = &$fr($arg);
    my $out = join("", map { sprintf "%02x ", $_ } @bytes);
    if ($out eq $reference) {
        print "$name: matches\n";
    }
    else {
        ++$fault;
        print "$name: FAULT!\nout: $out\n";
    }
}
[download]