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