B::Deparse gets rid of the bit shifts, but it breaks the code by omitting the parentheses after
not below. After reinstating the parentheses and running the code through
Perl::Tidy it's still not very readable. I've inserted some comments inside and outside the code to keep track of what's going on. Comments generally refer to the statements preceding them.
$_ = [
[
[ [ {}, [] ], { 73, '01110111', 1000, '11100101' }, [ [] ] ],
{
1,
'01111110',
72,
'00011010',
64,
'011001000011111001111010',
8,
'00000100',
9,
'010101010001000000011111101000101010000000001010001100000100010010101
+0100',
65,
'011100001001010100000001'
},
[ [] ]
]
];
(%_) = %{ ${ ${ $_; }[0]; }[1]; };
Most of the structure of
$_ is obfuscation. Let's start over with
%_ since
$_ is never used again except for the localized
$_ in the for loop.
undef $_;
%_ = (
1 => '01111110', # '~'
72 => '00011010', # 'X'
64 => '011001000011111001111010', # '&|^'
# 012345678901234567890123
8 => '00000100', # ' '
9 =>
'010101010001000000011111101000101010000000001010001100000100010010101
+0100',
#012345678901234567890123456789012345678901234567890123456789012345678
+9012
# 1 2 3 4 5 6
+ 7
65 => '011100001001010100000001'
# 012345678901234567890123
);
Some of these (little-endian) bitstrings are really bytestrings and I've commented them as such. I've also added column numbers below some of the strings.
$s = eval {
do {
$O = 0, $C = 0, $t = 'This is my 100th PM post';
# 012345678901234567890123
sub {
$O++, $C = @_ ? $C : eval
# { do { my $k =
pack( 'b*',
vec( pack( 'b*', $_{64} ), $O - 1, 1 ) ? $_{1} : $_{8}
+ )
. $C
. pack( 'c', vec( pack( 'b*', $_{64} ), ( $O - 1 ) % 3,
+8 ) )
. pack( 'b*',
vec( pack( 'b*', $_{64} ), $O - 1, 1 ) ? $_{8} : $_{1}
+ )
. vec( $t, $O - 1, 8 );
# print " $k"; eval $k; } }
}
}
};
This subroutine is essentially pure obfuscation. It does some fairly random calculations using the characters of
$t and a fudge factor is added at the end to produce the desired output.
$o = pack( 'b*', $_{9} );
foreach $_ ( 0 .. unpack( '%b*', $o ) - 2 ) {
# 16 bit checksum = 25, - 2 = 23
Now we come to the heart of it. It's rather convenient that a 16-bit checksum of
$o comes out so close to the length.
$c = $_ - ( ( $_ - $_ % 4 ) / 4 + ( $_ % 4 ? 1 : 0 ) );
# print $c;
# 0 0 1 2 3 3 4 5 6 6 7 8 9 9 10 11 12 12 13 14 15 15 16 17
$i =
vec( $o, $c, 4 ) + ( vec( $o, $c + 1, 4 ) << 4 ) >> 4 - $_ % 4 -
+ 4 *
( $_ % 4 ? 0 : 1 );
# >> 0 3 2 1 0 3 2 1 0 3 2 1 0 3 2 1 0 3 2 1 0 3 2 1
# print $i;
# 170 21 34 4 128 16 62 47 69 8 21 2 0 0 20 98 12 1 8 17 82 10 21 2
# print $i % 16; # == vec( pack( 'C', $i ), 0, 4 )
# 10 5 2 4 0 0 14 15 5 8 5 2 0 0 4 2 12 1 8 1 2 10 5
+ 2
# 0101 0100 0000 0111 1010 1010 0000 0010 0011 0001 0100 10
+10
# 1010 0010 0000 1111 0001 0100 0000 0100 1000 1000 0101
+ 0100
# J u r t n o u h e r P d r l a h a b j e
+ r
# * * * * * * *
Heavy comments here. These two statements extract the low nybbles of the JAPH phrase from
$o. The trick is that the nybbles are offset by only 3 bits so the 8's bit of each character is the 1's bit of the next character. Naturally, not all the 1's bits are correct, but surprisingly many are. Also, some of the higher-order bits in
$i are set, but they get stripped off later.
$i += $i % 2 ? -1 : 1 # $i ^= 1
if ( $_ + 1 ) % 12 and not(( $_ + 1 ) % 3)
or $_ + 1 == 22;
# print $i;
# 170 21 35 4 128 17 62 47 68 8 21 2 0 0 21 98 12 0 8 17 83 11 21 2
# print $i % 16;
# 10 5 3 4 0 1 14 15 4 8 5 2 0 0 5 2 12 0 8 1 3 11 5 2
# J u s t a n o t h e r P e r l h a c k e r
Here we fix up the erroneous 1's bits.
$T =
vec( pack( 'C', $i ), 0, 4 ) + vec( pack( 'b*', $_{65} ), $_, 1
+) * 16 +
32;
# print $T;
# 42 53 51 52 32 33 46 47 52 40 37 50 32 48 37 50 44 32 40 33 35 43 37
+ 50
# 0 1 1 1 0 0 0 0 1 0 0 1 0 1 0 1 0 0 0 0 0 0 0
+ 1
# J u s t a n o t h e r P e r l h a c k e
+ r
# * 1 2 3 4 5 6 7 8 9 10 11 12 * 1 2 3 4 5 6 7 8 9
+ 10
Now we extract the low nybbles from
$i and the 16's bits from
$_{65}, and set the 32's bits unconditionally.
print pack( 'c', ( $T += $T == 32 ? 0 : 64 ) -= $_ % 13 == 0 ? 32
+: 0 );
Now we set the 64's bit unless the character is a space and reset the 32's bit for the two capital letters and print the result.
# &$s; # independent of rest of loop, unrolled
}
# print ' ',
&$s for 0..23;
# 00 14294967295 2105 38 44294967263 573 68 74294967263 87
+7
# 94 104294967291 1153 120 134294967295 14116 1520 164294967263 17
+112
# 1813 194294967282 20125 2116 224294967295 23116
As I mentioned above the calls to
&$s are essentially pure obfuscation. In the last statement below a fudge factor
$_{72} is
xored with the final result to get a comma.
print pack( 'c', &$s(1) ^ unpack( 'c', pack( 'b*', $_{72} ) ) );
