perl: check data strictly; which is slow, but required

perl/lib/Data/MessagePack/PP.pm

@@ -138,6 +138,7 @@ sub _unexpected {
     Carp::confess("Unexpected " . sprintf(shift, @_) . " found");
 }
 
+
 #
 # PACK
 #
@@ -257,6 +258,10 @@ sub _pack {
 our $_utf8 = 0;
 my $p; # position variables for speed.
 
+sub _insufficient {
+    Carp::confess("Insufficient bytes (pos=$p, type=@_)");
+}
+
 sub unpack :method {
     $p = 0; # init
     my $data = _unpack( $_[1] );
@@ -302,10 +307,26 @@ foreach my $pair(
     $byte2value[ $pair->[0] ]  = $pair->[1];
 }
 
+sub _fetch_size {
+    my($value_ref, $byte, $x16, $x32, $x_fixbits) = @_;
+    if ( $byte == $x16 ) {
+        $p += 2;
+        $p <= length(${$value_ref}) or _insufficient('x/16');
+        return unpack 'n', substr( ${$value_ref}, $p - 2, 2 );
+    }
+    elsif ( $byte == $x32 ) {
+        $p += 4;
+        $p <= length(${$value_ref}) or _insufficient('x/32');
+        return unpack 'N', substr( ${$value_ref}, $p - 4, 4 );
+    }
+    else { # fix raw
+        return $byte & ~$x_fixbits;
+    }
+}
+
 sub _unpack {
     my ( $value ) = @_;
-    $p < length($value)
+    $p < length($value) or _insufficient('header byte');
-        or Carp::confess("Data::MessagePack->unpack: insufficient bytes");
     # get a header byte
     my $byte = ord( substr $value, $p, 1 );
     $p++;
@@ -314,55 +335,23 @@ sub _unpack {
     return $byte2value[$byte] if $typemap[$byte] & $T_DIRECT;
 
     if ( $typemap[$byte] & $T_RAW ) {
-        my $num;
+        my $size = _fetch_size(\$value, $byte, 0xda, 0xdb, 0xa0);
-        if ( $byte == 0xda ) {
+        my $s    = substr( $value, $p, $size );
-            $num = CORE::unpack 'n', substr( $value, $p, 2 );
+        length($s) == $size or _insufficient('raw');
-            $p += 2 + $num;
+        $p      += $size;
-        }
-        elsif ( $byte == 0xdb ) {
-            $num = CORE::unpack 'N', substr( $value, $p, 4 );
-            $p += 4 + $num;
-        }
-        else { # fix raw
-            $num = $byte & ~0xa0;
-            $p += $num;
-        }
-        my $s = substr( $value, $p - $num, $num );
         utf8::decode($s) if $_utf8;
         return $s;
     }
     elsif ( $typemap[$byte] & $T_ARRAY ) {
-        my $num;
+        my $size = _fetch_size(\$value, $byte, 0xdc, 0xdd, 0x90);
-        if ( $byte == 0xdc ) { # array 16
-            $num = CORE::unpack 'n', substr( $value, $p, 2 );
-            $p += 2;
-        }
-        elsif ( $byte == 0xdd ) { # array 32
-            $num = CORE::unpack 'N', substr( $value, $p, 4 );
-            $p += 4;
-        }
-        else { # fix array
-            $num = $byte & ~0x90;
-        }
         my @array;
-        push @array, _unpack( $value ) while --$num >= 0;
+        push @array, _unpack( $value ) while --$size >= 0;
         return \@array;
     }
     elsif ( $typemap[$byte] & $T_MAP ) {
-        my $num;
+        my $size = _fetch_size(\$value, $byte, 0xde, 0xdf, 0x80);
-        if ( $byte == 0xde ) { # map 16
-            $num = CORE::unpack 'n', substr( $value, $p, 2 );
-            $p += 2;
-        }
-        elsif ( $byte == 0xdf ) { # map 32
-            $num = CORE::unpack 'N', substr( $value, $p, 4 );
-            $p += 4;
-        }
-        else { # fix map
-            $num = $byte & ~0x80;
-        }
         my %map;
-        while ( --$num >= 0 ) {
+        while(--$size >= 0) {
             no warnings; # for undef key case
             my $key = _unpack( $value );
             my $val = _unpack( $value );
@@ -372,41 +361,53 @@ sub _unpack {
     }
 
     elsif ( $byte == 0xcc ) { # uint8
-        return CORE::unpack( 'C', substr( $value, $p++, 1 ) );
+        $p++;
+        $p <= length($value) or _insufficient('uint8');
+        return CORE::unpack( 'C', substr( $value, $p - 1, 1 ) );
     }
     elsif ( $byte == 0xcd ) { # uint16
         $p += 2;
+        $p <= length($value) or _insufficient('uint16');
         return unpack_uint16( $value, $p - 2 );
     }
     elsif ( $byte == 0xce ) { # unit32
         $p += 4;
+        $p <= length($value) or _insufficient('uint32');
         return unpack_uint32( $value, $p - 4 );
     }
     elsif ( $byte == 0xcf ) { # unit64
         $p += 8;
+        $p <= length($value) or _insufficient('uint64');
         return unpack_uint64( $value, $p - 8 );
     }
     elsif ( $byte == 0xd3 ) { # int64
         $p += 8;
+        $p <= length($value) or _insufficient('int64');
         return unpack_int64( $value, $p - 8 );
     }
     elsif ( $byte == 0xd2 ) { # int32
         $p += 4;
+        $p <= length($value) or _insufficient('int32');
         return unpack_int32( $value, $p - 4 );
     }
     elsif ( $byte == 0xd1 ) { # int16
         $p += 2;
+        $p <= length($value) or _insufficient('int16');
         return unpack_int16( $value, $p - 2 );
     }
     elsif ( $byte == 0xd0 ) { # int8
-        return CORE::unpack 'c',  substr( $value, $p++, 1 ); # c / C
+        $p++;
+        $p <= length($value) or _insufficient('int8');
+        return CORE::unpack 'c',  substr( $value, $p - 1, 1 );
     }
     elsif ( $byte == 0xcb ) { # double
         $p += 8;
+        $p <= length($value) or _insufficient('double');
         return unpack_double( $value, $p - 8 );
     }
     elsif ( $byte == 0xca ) { # float
         $p += 4;
+        $p <= length($value) or _insufficient('float');
         return unpack_float( $value, $p - 4 );
     }
     else {

perl/t/02_unpack.t

@@ -12,7 +12,10 @@ sub unpackit {
 
 sub pis ($$) {
     is_deeply unpackit($_[0]), $_[1], 'dump ' . $_[0]
-        or diag( explain(unpackit($_[0])) );
+        or do {
+            diag( 'got:', explain(unpackit($_[0])) );
+            diag( 'expected:', explain($_[1]) );
+        };
 }
 
 my @dat = do 't/data.pl' or die $@;