sub packwithsubst {
    my $string = shift;
    my $bits = unpack 'b*', $string;
    $bits =~ s/(.{7})./$1/g;
    return pack 'Cb*', length($string), $bits;
}

sub unpackwithsubst {
    my ($length, $chars) = unpack 'Cb*', shift;
    $chars =~ s/(.{7})/${1}0/g;
    substr $chars, $length * 8, 8, '';
    return pack 'b*', $chars;
}

##</code><code>##

               Rate GSM::SMS
GSM::SMS      324/s       --
Device::Gsm   342/s       6%
My_code       514/s      59%

##</code><code>##

my (%b2c, %c2b);
$b2c{unpack 'b8', $_} = $_ for map chr, 0..255;
$c2b{$_} = unpack 'b7', $_ for map chr, 0..127;
    
sub packdevicegsm2 { # Device::Gsm::Pdu:encode_text7, not going via hex
    my @char = split //, shift;
    my($result, $bits);
    map { $bits .= $c2b{$_} } @char; 
    if (my $len = length($bits) % 8) { $bits .= '0' x (8 - $len) }
    $result .= $b2c{ substr $bits, 0, 8, '' } while length $bits;
    return chr(scalar @char) . $result;
}

sub unpackdevicegsm2 { # Device::Gsm::Pdu:decode_text7, not going via hex
    my $text7 = shift;
    my $len = ord substr( $text7, 0, 1, '' );
    my $bits = '';
    $bits .= unpack 'b8', substr $text7, 0, 1, '' while length $text7;
    my $decoded = '';
    $decoded .= pack 'b7', substr $bits, 0, 7, '' while length $bits >= 7;
    return substr $decoded, 0, $len;
}

##</code><code>##

               Rate GSM::SMS
GSM::SMS      322/s       --
Device::Gsm   345/s       7%
My_code       519/s      61%
Dev::Gsm_opt  519/s      61%

##</code><code>##

sub packwitharray {
    my $string = shift;
    return pack 'Cb*', length($string), join('', unpack '(b7)*', $string);
}

sub unpackwitharray {
    my ($length, $bits) = unpack 'Cb*', shift;
    my @chars = $bits =~ /.{7}/g;
    $#chars = $length - 1;
    return pack '(b7)*', @chars;
}

##</code><code>##

               Rate GSM::SMS
GSM::SMS      321/s       --
Device::Gsm   342/s       7%
Dev::Gsm_opt  500/s      56%
Subst/Subst   519/s      62%   # This was called My_code above
Subst/Array   527/s      64%   # i.e. packwithsubst / unpackwitharray
Array/Subst   777/s     142%
Array/Array   808/s     152%

##</code><code>##

           Rate My_code    C
My_code   792/s      -- -99%
C       77422/s   9670%   --

##</code><code>##

#! /usr/bin/perl

use strict;
use warnings;
use Benchmark 'cmpthese';
use 5.010;

use Inline 'C';

my $sample = <<'END_STRING';
To be or not to be: that is the question:
Whether 'tis nobler in the mind to suffer
The slings and arrows of outrageous fortune
Or to take arms against a sea of troubles
And by opposing, end them?
                           To die: to sleep
No more ...
END_STRING

my %packs = (
    C     => \&c_pack,
    subst => \&packwithsubst,
    array => \&packwitharray,
    gsp   => \&packgsmsms,
    dgp   => \&packdevicegsm,
    dgp2  => \&packdevicegsm2,
);

my %unpacks = (
    C     => \&c_unpack,
    subst => \&unpackwithsubst,
    array => \&unpackwitharray,
    gsp   => \&unpackgsmsms,
    dgp   => \&unpackdevicegsm,
    dgp2  => \&unpackdevicegsm2,
);

my @pairs = (
    ['gsp',   'gsp'  ],
    ['dgp',   'dgp'  ],
    ['dgp2',  'dgp2' ],
    ['subst', 'subst'],
    ['subst', 'array'],
    ['array', 'subst'],
    ['array', 'array'],
    ['C',     'C'    ],
);

# Check that all implementations work and are equivalent.
for my $impl (keys %packs) {
    next if $unpacks{array}->($packs{$impl}->($sample)) eq $sample;
    say "$impl packer is broken";
    say "Expected: ", packwithsubst("foo bar baz quux");
    say "Got:      ", $packs{$impl}->("foo bar baz quux");
    exit 1;
}
for my $impl (keys %unpacks) {
    next if $unpacks{$impl}->($packs{array}->($sample)) eq $sample;
    say "$impl unpacker is broken";
    say "Expected: foo bar baz quux";
    say "Got:      ", $unpacks{$impl}->(packwitharray("foo bar baz quux"));
    exit 1;
}

# Do the benchmark.
cmpthese(-1, {
    map {
        my $p = $packs{$$_[0]};
        my $u = $unpacks{$$_[1]};
        "$$_[0]/$$_[1]" => sub { $u->($p->($sample)) };
    } @pairs
});

sub packwithsubst {
    my $string = shift;
    my $bits = unpack 'b*', $string;
    $bits =~ s/(.{7})./$1/g;
    return pack 'Cb*', length($string), $bits;
}

sub packwitharray {
    my $string = shift;
    return pack 'Cb*', length($string), join('', unpack '(b7)*', $string);
}

sub unpackwitharray {
    my ($length, $bits) = unpack 'Cb*', shift;
    my @chars = $bits =~ /.{7}/g;
    $#chars = $length - 1;
    return pack '(b7)*', @chars;
}

sub unpackwithsubst {
    my ($length, $chars) = unpack 'Cb*', shift;
    $chars =~ s/(.{7})/${1}0/g;
    substr $chars, $length * 8, 8, '';
    return pack 'b*', $chars;
}

sub unpackdevicegsm2 { # Device::Gsm::Pdu:decode_text7, not going via hex
    my $text7 = shift;
    my $len = ord substr( $text7, 0, 1, '' );
    my $bits = '';
    while( length $text7 ) {
        $bits .= unpack 'b8', substr $text7, 0, 1, '';
    }
    my $decoded = '';
    while( length $bits >= 7 ) {
        $decoded .= pack 'b7', substr($bits, 0, 7, '');
    }
    return substr $decoded, 0, $len;
}

BEGIN {
    
my (%b2c, %c2b);
$b2c{unpack 'b8', $_} = $_ for map chr, 0..255;
$c2b{$_} = unpack 'b7', $_ for map chr, 0..127;
    
sub packdevicegsm2 { # Device::Gsm::Pdu:encode_text7, not going via hex
    my @char = split //, shift;
    my($result, $bits);
    map { $bits .= $c2b{$_} } @char; 
    if( my $len = length($bits) % 8 ) {
        $bits .= '0' x ( 8 - $len );
    }
    while( length $bits ) {
        $result .= $b2c{ substr $bits, 0, 8, '' };
    }
    return chr(scalar @char) . $result;
}
}

sub unpackdevicegsm { # Device::Gsm::Pdu:decode_text7, cosmetic changes only
    my $text7 = unpack 'H*', shift;
    my $len = hex substr( $text7, 0, 2 );
    $text7  = substr $text7, 2;
    my $bits = '';
    while( $text7 ) {
        $bits .= unpack 'b8', pack 'H2', substr $text7, 0, 2;
        if( length($text7) > 2 ) {
            $text7 = substr($text7, 2);
        } else {
            $text7 = '';
        }
    }
    my $decoded;
    while( length $bits >= 7 ) {
        $decoded .= pack 'b7', substr($bits, 0, 7);
        $bits = substr $bits, 7;
    }
    return substr $decoded, 0, $len;
}

BEGIN {
    
my (%b2h, %h2b);
$b2h{unpack 'b8', $_} = unpack 'H2', $_ for map chr, 0..255;
$h2b{$_} = unpack 'b7', $_ for map chr, 0..127;
    
sub packdevicegsm { # Device::Gsm::Pdu:encode_text7, cosmetic changes only
    my($result, $bits);
    my @char = split //, $_[0];
    map { $bits .= $h2b{$_} } @char; 
    if( my $len = length($bits) % 8 ) {
        $bits .= '0' x ( 8 - $len );
    }
    while( length $bits ) {
        $result .= $b2h{ substr $bits, 0, 8 };
        $bits = substr $bits, 8;
    }
    return chr(scalar @char) . pack 'H*', $result;
}
}

sub unpackgsmsms { # Based on GSM::SMS::PDU::decode_7bit
    my ($ud) = @_;
    my ($msg,$bits);
    my $cnt = 0;
    my $len = ord substr $ud, 0, 1, '';
    $msg = "";
    my $byte = unpack('b8', substr($ud, 0, 1));
    while (($cnt<length($ud)) && (length($msg)<$len)) {
        $msg .= pack('b7', $byte);
        $byte = substr($byte, 7, length($byte) - 7);
        if ( (length( $byte ) < 7) ) {
            ++$cnt; 
            $byte = $byte.unpack('b8', substr($ud, $cnt, 1));
        }
    }
    return $msg;
}

sub packgsmsms { # Based on GSM::SMS::PDU::encode_7bit
    my ($msg) = @_;
    my ($bits, $ud, $octet);
    foreach (split(//,$msg)) {
        $bits .= unpack('b7', $_);
    }
    while (defined($bits) && (length($bits)>0)) {
        $octet = substr($bits,0,8);
        $ud .= pack("b8", substr($octet."0" x 7, 0, 8));
        $bits = (length($bits) > 8) ? substr($bits, 8) : "";
    }
    return chr(length $msg) . $ud;
}

__DATA__
__C__

#include <stdlib.h>
typedef unsigned char uchr;

SV* c_pack(SV* input)
{
    SV*   rv;
    int   len, ipos;
    uchr *bytes  = (uchr*) SvPV(input, len);
    int   newlen = ceil((len / 8.) * 7) + 1;
    uchr *packed = (uchr*) calloc(newlen, 1);
    int   opos = 1, oset = 0;
    packed[0] = len;
    for (ipos = 0; ipos < len; ++ipos) {
        uchr c1 = bytes[ipos];
        uchr c2 = bytes[ipos + 1];
        if (c1 & 0x80) croak("Data must be 7-bit");
        packed[opos++] = c1 >> oset | c2 << 7 - oset;
        if (++oset == 7) { oset = 0; ++ipos; }
    }
    rv = newSVpv((char*) packed, newlen);
    free(packed);
    return rv;
}

SV* c_unpack(SV* input)
{
    SV*   rv;
    int   len;
    uchr *bytes    = (uchr*) SvPV(input, len);
    int   newlen   = bytes[0];
    uchr *unpacked = (uchr*) calloc(newlen, 1);
    int   ipos, opos = 0, oset = 0;
    uchr  carry = 0;
    for (ipos = 1; ipos < len; ++ipos) {
        uchr ch = bytes[ipos];
        unpacked[opos++] = carry | (ch & (0xff >> oset + 1)) << oset;
        if (oset == 6) {
            unpacked[opos++] = ch >> 1;
            carry = oset = 0;
        }
        else {
            carry = ch >> 7 - oset++;
        }            
    }
    rv = newSVpv((char*) unpacked, newlen);
    free(unpacked);
    return rv;
}