1#!perl
2use strict;
3use warnings;
4use Data::Dumper;
5
6use Getopt::Long qw(GetOptions);
7use Encode qw(encode_utf8 decode_utf8);
8our @constants;
9no warnings 'recursion';
10
11BEGIN {
12    my $add_use_blib= "";
13    my $use= "";
14    my @check;
15    for my $type ( "Decoder", "Encoder" ) {
16        if ( -e "blib/lib/Sereal/$type/Constants.pm" ) {
17            $add_use_blib= "use blib;";
18            @check= ($type);
19            last;
20        }
21        push @check, $type;
22    }
23
24    my @err;
25    foreach my $check (@check) {
26        if (
27            eval(
28                my $code= sprintf '
29                %s
30                use Sereal::%s::Constants qw(:all);
31                @constants= @Sereal::%s::Constants::EXPORT_OK;
32                print "Loaded constants from $INC{q(Sereal/%s/Constants.pm)}\n";
33                1;
34            ', $add_use_blib, ($check) x 3
35            ) )
36        {
37            @err= ();
38            last;
39        }
40        else {
41            push @err, "Error:", $@ || "Zombie Error", "\nCode:\n$code";
42        }
43    }
44    die @err if @err;
45}
46
47my $done;
48my $data;
49my $hlen= -1;
50my $indent= "";
51
52sub _chop_data_prefix {
53    my ($len)= @_;
54    die "Unexpected end of packet" unless length($data) >= $len;
55    return substr( $data, 0, $len, '' );
56}
57
58sub parse_header {
59    $data =~ s/^(=[s\xF3]rl)(.)// or die "invalid header: $data";
60    $done .= $1 . $2;
61    my $flags= $2;
62    my $len= varint();
63    my $hdr= _chop_data_prefix($len);
64
65    my $proto_version= ord($flags) & SRL_PROTOCOL_VERSION_MASK;
66    print "Sereal protocol version: $proto_version\n";
67    if ( length($hdr) ) {
68        print "Header($len): " . join( " ", map ord, split //, $hdr ) . "\n";
69        if ( $proto_version >= 2 && ( ord( substr( $hdr, 0, 1 ) ) & 1 ) ) { # if first bit set => user header data
70            print "Found user data in header:\n";
71            my $tmp_data= $data; # dance necessary because $data is treated as a global :( hobo, hobo, hobo!
72            $data= substr( $hdr, 1 );
73            parse_sv("  ");
74            $data= $tmp_data;
75            print "End of user data in header. Body:\n";
76        }
77    }
78    else {
79        print "Empty Header.\n";
80    }
81
82    my $encoding= ord($flags) & SRL_PROTOCOL_ENCODING_MASK;
83
84    printf "%i %i %i\n", $encoding, ord(SRL_PROTOCOL_ENCODING_MASK), ord($flags);
85    if ( $encoding == SRL_PROTOCOL_ENCODING_RAW ) {
86        print "Header says: Document body is uncompressed.\n";
87    }
88    elsif ( $encoding == SRL_PROTOCOL_ENCODING_SNAPPY ) {
89        print "Header says: Document body is Snappy-compressed.\n";
90        require Compress::Snappy;
91        my $out= Compress::Snappy::decompress($data);
92        $data= $out;
93    }
94    elsif ( $encoding == SRL_PROTOCOL_ENCODING_SNAPPY_INCREMENTAL ) {
95        print "Header says: Document body is Snappy-compressed (incremental).\n";
96        my $compressed_len= varint();
97        require Compress::Snappy;
98        my $out= Compress::Snappy::decompress($data);
99        $data= $out;
100    }
101    elsif ( $encoding == SRL_PROTOCOL_ENCODING_ZLIB ) {
102        print "Header says: Document body is ZLIB-compressed.\n";
103        my $uncompressed_len= varint();
104        my $compressed_len= varint();
105        require Compress::Zlib;
106        my $out= Compress::Zlib::uncompress($data);
107        $data= $out;
108    }
109    else {
110        die "Invalid encoding '" . ( $encoding >> SRL_PROTOCOL_VERSION_BITS ) . "'";
111    }
112    $hlen= length($done);
113}
114
115my ( $len_f, $len_d, $len_D );
116
117sub parse_float {
118    $len_f ||= length( pack( "f", 0 ) );
119    my $v= _chop_data_prefix($len_f);
120    $done .= $v;
121    return unpack( "f", $v );
122}
123
124sub parse_double {
125    $len_d ||= length( pack( "d", 0 ) );
126    my $v= _chop_data_prefix($len_d);
127    $done .= $v;
128    return unpack( "d", $v );
129}
130
131sub parse_long_double {
132    $len_D ||= eval { length( pack( "D", 0.0 ) ) };
133    die "Long double not supported" unless $len_D;
134    my $v= _chop_data_prefix($len_D);
135    $done .= $v;
136    return unpack( "D", $v );
137}
138
139my $fmt1= "%06d/%06d: %02x%1s %03s %s";
140my $fmt2= "%-6s %-6s  %-2s%1s %-3s %s";
141my $lead_items= 5;    # 1 less than the fmt2
142
143sub parse_sv {
144    my ($ind)= @_;
145
146    my $p= length($done);
147    my $t= _chop_data_prefix(1);
148    $done .= $t;
149    my $o= ord($t);
150    my $bv= $o;
151    my $high= $o >= 128;
152    $o -= 128 if $high;
153    printf $fmt1, $p, $p - $hlen + 1, $o, $high ? '*' : ' ', $bv, $ind;
154
155    if ( $o == SRL_HDR_VARINT ) {
156        printf "VARINT: %u\n", varint();
157    }
158    elsif ( $o == SRL_HDR_ZIGZAG ) {
159        printf "ZIGZAG: %d\n", zigzag();
160    }
161    elsif ( SRL_HDR_POS_LOW <= $o && $o <= SRL_HDR_POS_HIGH ) {
162        printf "POS: %u\n", $o;
163    }
164    elsif ( SRL_HDR_NEG_LOW <= $o && $o <= SRL_HDR_NEG_HIGH ) {
165        $o= $o - 32;
166        printf "NEG: %i\n", $o;
167    }
168    elsif ( $o >= SRL_HDR_SHORT_BINARY_LOW ) {
169        $o -= SRL_HDR_SHORT_BINARY_LOW;
170        my $len= $o;
171        my $str= _chop_data_prefix($len);
172        $done .= $str;
173        printf "SHORT_BINARY(%u): '%s' (%s)\n", $len, encode_utf8($str), unpack( "H*", $str );
174    }
175    elsif ( $o == SRL_HDR_BINARY || $o == SRL_HDR_STR_UTF8 ) {
176        my $l= varint();
177        my $str= _chop_data_prefix($l);    # fixme UTF8
178        $done .= $str;
179        $str= decode_utf8($str) if $o == SRL_HDR_STR_UTF8;
180        printf(
181            ( $o == SRL_HDR_STR_UTF8 ? "STR_UTF8" : "BINARY" ) . "(%u): '%s' (%s)\n", $l,
182            encode_utf8($str), unpack( "H*", encode_utf8($str) ) );
183    }
184    elsif ( $o == SRL_HDR_FLOAT ) {
185        printf "FLOAT(%f)\n", parse_float();
186    }
187    elsif ( $o == SRL_HDR_DOUBLE ) {
188        printf "DOUBLE(%f)\n", parse_double();
189    }
190    elsif ( $o == SRL_HDR_LONG_DOUBLE ) {
191        printf "LONG_DOUBLE(%f)\n", parse_long_double();
192    }
193    elsif ( $o == SRL_HDR_REFN ) {
194        printf "REFN\n";
195        parse_sv( $ind . "  " );
196    }
197    elsif ( $o == SRL_HDR_REFP ) {
198        my $len= varint();
199        printf "REFP(%u)\n", $len;
200    }
201    elsif ( $o == SRL_HDR_COPY ) {
202        my $len= varint();
203        printf "COPY(%u)\n", $len;
204    }
205    elsif ( SRL_HDR_ARRAYREF_LOW <= $o && $o <= SRL_HDR_ARRAYREF_HIGH ) {
206        printf "ARRAYREF";
207        parse_av( $ind, $o );
208    }
209    elsif ( $o == SRL_HDR_ARRAY ) {
210        printf "ARRAY";
211        parse_av($ind);
212    }
213    elsif ( SRL_HDR_HASHREF_LOW <= $o && $o <= SRL_HDR_HASHREF_HIGH ) {
214        printf "HASHREF";
215        parse_hv( $ind, $o );
216    }
217    elsif ( $o == SRL_HDR_HASH ) {
218        printf "HASH";
219        parse_hv($ind);
220    }
221    elsif ( $o == SRL_HDR_CANONICAL_UNDEF ) {
222        printf "CANONICAL_UNDEF\n";
223    }
224    elsif ( $o == SRL_HDR_UNDEF ) {
225        printf "UNDEF\n";
226    }
227    elsif ( $o == SRL_HDR_WEAKEN ) {
228        printf "WEAKEN\n";
229        parse_sv($ind);
230    }
231    elsif ( $o == SRL_HDR_PAD ) {
232        printf "[PAD]\n";
233        parse_sv($ind);
234    }
235    elsif ( $o == SRL_HDR_ALIAS ) {
236        my $ofs= varint();
237        printf "ALIAS(%u)\n", $ofs;
238    }
239    elsif ( $o == SRL_HDR_OBJECTV ) {
240        my $ofs= varint();
241        printf "OBJECTV(%d)\n", $ofs;
242        printf "$fmt2  Value:\n", ("") x $lead_items, $ind;
243        parse_sv( $ind . "    " );
244    }
245    elsif ( $o == SRL_HDR_OBJECTV_FREEZE ) {
246        my $ofs= varint();
247        printf "OBJECTV_FREEZE(%d)\n", $ofs;
248        printf "$fmt2  Value:\n", ("") x $lead_items, $ind;
249        parse_sv( $ind . "    " );
250    }
251    elsif ( $o == SRL_HDR_OBJECT ) {
252        printf "OBJECT\n";
253        printf "$fmt2  Class:\n", ("") x $lead_items, $ind;
254        parse_sv( $ind . "    " );
255        printf "$fmt2  Value:\n", ("") x $lead_items, $ind;
256        parse_sv( $ind . "    " );
257    }
258    elsif ( $o == SRL_HDR_OBJECT_FREEZE ) {
259        printf "OBJECT_FREEZE\n";
260        printf "$fmt2  Class:\n", ("") x $lead_items, $ind;
261        parse_sv( $ind . "    " );
262        printf "$fmt2  Value:\n", ("") x $lead_items, $ind;
263        parse_sv( $ind . "    " );
264    }
265    elsif ( $o == SRL_HDR_REGEXP ) {
266        printf "REGEXP\n";
267        parse_sv( $ind . "  " );
268        parse_sv( $ind . "  " );
269    }
270    elsif ( $o == SRL_HDR_FALSE ) {
271        printf "FALSE\n";
272    }
273    elsif ( $o == SRL_HDR_TRUE ) {
274        printf "TRUE\n";
275
276    }
277    else {
278        printf "<UNKNOWN>\n";
279        die sprintf "unsupported type: 0x%02x (%d) %s: %s", $o, $o,
280            Data::Dumper::qquote($t),
281            Data::Dumper->new( [ $TAG_INFO_ARRAY[$o] ] )->Terse(1)->Dump();
282    }
283    return 0;
284}
285
286sub parse_av {
287    my ( $ind, $o )= @_;
288    my $len= defined $o ? $o & 15 : varint();
289    printf "(%u)\n", $len;
290    $ind .= "  ";
291    while ( $len-- ) {
292        parse_sv( $ind, \$len );
293    }
294}
295
296sub parse_hv {
297    my ( $ind, $o )= @_;
298    my $len= ( defined $o ? $o & 15 : varint() );
299    printf "(%u)\n", $len;
300    $ind .= "  ";
301    while ( $len-- ) {
302        printf "$fmt2%s:\n", ("") x $lead_items, $ind, "KEY";
303        parse_sv( $ind . "  " );
304        printf "$fmt2%s:\n", ("") x $lead_items, $ind, "VALUE";
305        parse_sv( $ind . "  " );
306    }
307}
308
309# super inefficient
310sub varint {
311    my $x= 0;
312    my $lshift= 0;
313    while ( length($data) && ord( substr( $data, 0, 1 ) ) & 0x80 ) {
314        my $c= ord( _chop_data_prefix(1) );
315        $done .= chr($c);
316        $x      += ( $c & 0x7F ) << $lshift;
317        $lshift += 7;
318    }
319    if ( length($data) ) {
320        my $c= ord( _chop_data_prefix(1) );
321        $done .= chr($c);
322        $x += $c << $lshift;
323    }
324    else {
325        die "premature end of varint";
326    }
327    return $x;
328}
329
330sub _zigzag {
331    my $n= $_[0];
332    return $n & 1 ? -( ( $n >> 1 ) + 1 ) : ( $n >> 1 );
333}
334
335sub zigzag {
336    return _zigzag( varint() );
337}
338
339GetOptions(
340    my $opt= {},
341    'e|stderr',
342);
343
344$|= 1;
345if ( $opt->{e} ) {
346    select(STDERR);
347}
348
349local $/= undef;
350$data= <STDIN>;
351
352open my $fh, "| od -tu1c" or die $!;
353print $fh $data;
354close $fh;
355
356print "\n\nTotal length: " . length($data) . "\n\n";
357
358while ( length $data ) {
359    parse_header();
360    print "--- End header\n";
361    $done= parse_sv("");
362    print "--- End Document\n";
363}
364