This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
pack changes and related fixes
authorLAUN Wolfgang <wolfgang.laun@alcatel.at>
Mon, 17 Mar 2003 13:55:37 +0000 (14:55 +0100)
committerJarkko Hietaniemi <jhi@iki.fi>
Mon, 17 Mar 2003 17:16:44 +0000 (17:16 +0000)
Message-ID: <75A46BF1A9D8D311863A00508B6259A405F17EB8@ATTMSX4>

p4raw-id: //depot/perl@19010

embed.fnc
embed.h
lib/diagnostics.pm
perl.h
pod/perldiag.pod
pod/perlfunc.pod
pod/perlpacktut.pod
pp_pack.c
proto.h
t/lib/warnings/pp_pack
t/op/pack.t

index d4e1f35..c288f72 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -1060,14 +1060,16 @@ s       |U32    |seed
 #endif
 
 #if defined(PERL_IN_PP_PACK_C) || defined(PERL_DECL_PROT)
-s      |void   |doencodes      |SV* sv|char* s|I32 len
+s       |I32    |unpack_rec     |tempsym_t* symptr|char *s|char *strbeg|char *strend|char **new_s
+s       |SV **  |pack_rec       |SV *cat|tempsym_t* symptr|SV **beglist|SV **endlist
 s      |SV*    |mul128         |SV *sv|U8 m
+s      |I32    |measure_struct |tempsym_t* symptr
+s      |char * |group_end      |char *pat|char *patend|char ender
+s       |char * |get_num        |char *ppat|I32 *
+s      |bool   |next_symbol    |tempsym_t* symptr
+s      |void   |doencodes      |SV* sv|char* s|I32 len
 s      |SV*    |is_an_int      |char *s|STRLEN l
 s      |int    |div128         |SV *pnum|bool *done
-s      |char * |next_symbol    |char *pat|char *patend
-s      |I32    |find_count     |char **ppat|char *patend|int *star
-s      |char * |group_end      |char *pat|char *patend|char ender
-s      |I32    |measure_struct |char *pat|char *patend
 #endif
 
 #if defined(PERL_IN_PP_CTL_C) || defined(PERL_DECL_PROT)
diff --git a/embed.h b/embed.h
index b03d9de..8793f64 100644 (file)
--- a/embed.h
+++ b/embed.h
 #endif
 #if defined(PERL_IN_PP_PACK_C) || defined(PERL_DECL_PROT)
 #ifdef PERL_CORE
-#define doencodes              S_doencodes
+#define unpack_rec             S_unpack_rec
+#endif
+#ifdef PERL_CORE
+#define pack_rec               S_pack_rec
 #endif
 #ifdef PERL_CORE
 #define mul128                 S_mul128
 #endif
 #ifdef PERL_CORE
-#define is_an_int              S_is_an_int
+#define measure_struct         S_measure_struct
 #endif
 #ifdef PERL_CORE
-#define div128                 S_div128
+#define group_end              S_group_end
+#endif
+#ifdef PERL_CORE
+#define get_num                        S_get_num
 #endif
 #ifdef PERL_CORE
 #define next_symbol            S_next_symbol
 #endif
 #ifdef PERL_CORE
-#define find_count             S_find_count
+#define doencodes              S_doencodes
 #endif
 #ifdef PERL_CORE
-#define group_end              S_group_end
+#define is_an_int              S_is_an_int
 #endif
 #ifdef PERL_CORE
-#define measure_struct         S_measure_struct
+#define div128                 S_div128
 #endif
 #endif
 #if defined(PERL_IN_PP_CTL_C) || defined(PERL_DECL_PROT)
 #endif
 #if defined(PERL_IN_PP_PACK_C) || defined(PERL_DECL_PROT)
 #ifdef PERL_CORE
-#define doencodes(a,b,c)       S_doencodes(aTHX_ a,b,c)
+#define unpack_rec(a,b,c,d,e)  S_unpack_rec(aTHX_ a,b,c,d,e)
+#endif
+#ifdef PERL_CORE
+#define pack_rec(a,b,c,d)      S_pack_rec(aTHX_ a,b,c,d)
 #endif
 #ifdef PERL_CORE
 #define mul128(a,b)            S_mul128(aTHX_ a,b)
 #endif
 #ifdef PERL_CORE
-#define is_an_int(a,b)         S_is_an_int(aTHX_ a,b)
+#define measure_struct(a)      S_measure_struct(aTHX_ a)
 #endif
 #ifdef PERL_CORE
-#define div128(a,b)            S_div128(aTHX_ a,b)
+#define group_end(a,b,c)       S_group_end(aTHX_ a,b,c)
 #endif
 #ifdef PERL_CORE
-#define next_symbol(a,b)       S_next_symbol(aTHX_ a,b)
+#define get_num(a,b)           S_get_num(aTHX_ a,b)
 #endif
 #ifdef PERL_CORE
-#define find_count(a,b,c)      S_find_count(aTHX_ a,b,c)
+#define next_symbol(a)         S_next_symbol(aTHX_ a)
 #endif
 #ifdef PERL_CORE
-#define group_end(a,b,c)       S_group_end(aTHX_ a,b,c)
+#define doencodes(a,b,c)       S_doencodes(aTHX_ a,b,c)
+#endif
+#ifdef PERL_CORE
+#define is_an_int(a,b)         S_is_an_int(aTHX_ a,b)
 #endif
 #ifdef PERL_CORE
-#define measure_struct(a,b)    S_measure_struct(aTHX_ a,b)
+#define div128(a,b)            S_div128(aTHX_ a,b)
 #endif
 #endif
 #if defined(PERL_IN_PP_CTL_C) || defined(PERL_DECL_PROT)
index 1ba70c5..466b9e9 100755 (executable)
@@ -53,7 +53,7 @@ escape sequences for pagers.
 
 Warnings dispatched from perl itself (or more accurately, those that match
 descriptions found in L<perldiag>) are only displayed once (no duplicate
-descriptions).  User code generated warnings ala warn() are unaffected,
+descriptions).  User code generated warnings a la warn() are unaffected,
 allowing duplicate user messages to be displayed.
 
 =head2 The I<splain> Program
@@ -296,6 +296,7 @@ our %HTML_Escapes;
 
 *THITHER = $standalone ? *STDOUT : *STDERR;
 
+my %transfmt = (); 
 my $transmo = <<EOFUNC;
 sub transmo {
     #local \$^W = 0;  # recursive warnings we do NOT need!
@@ -330,7 +331,7 @@ my %msg;
                    ) )
                {
                    next;
-               } 
+               }
                s/^/    /gm;
                $msg{$header} .= $_;
                undef $for_item;        
@@ -358,25 +359,38 @@ my %msg;
            }
        }
 
-       # strip formatting directives in =item line
+       # strip formatting directives from =item line
        $header =~ s/[A-Z]<(.*?)>/$1/g;
 
-       if ($header =~ /%[csd]/) {
-           my $rhs = my $lhs = $header;
-           if ($lhs =~ s/(.*?)%d(?!%d)(.*)/\Q$1\E-?\\d+\Q$2\E/g)  {
-               $lhs =~ s/\\%s/.*?/g;
-           } else {
-               # if i had lookbehind negations,
-               # i wouldn't have to do this \377 noise
-               $lhs =~ s/(.*?)%s/\Q$1\E.*?\377/g;
-               $lhs =~ s/\377([^\377]*)$/\Q$1\E/;
-               $lhs =~ s/\377//g;
-               $lhs =~ s/\.\*\?$/.*/; # Allow %s at the end to eat it all
-           } 
-           $lhs =~ s/\\%c/./g;
-           $transmo .= "    s{^$lhs}\n     {\Q$rhs\E}s\n\t&& return 1;\n";
+        my @toks = split( /(%l?[dx]|%c|%(?:\.\d+)?s)/, $header );
+       if (@toks > 1) {
+            my $conlen = 0;
+            for my $i (0..$#toks){
+                if( $i % 2 ){
+                    if(      $toks[$i] eq '%c' ){
+                        $toks[$i] = '.';
+                    } elsif( $toks[$i] eq '%d' ){
+                        $toks[$i] = '\d+';
+                    } elsif( $toks[$i] eq '%s' ){
+                        $toks[$i] = $i == $#toks ? '.*' : '.*?';
+                    } elsif( $toks[$i] =~ '%.(\d+)s' ){
+                        $toks[$i] = ".{$1}";
+                     } elsif( $toks[$i] =~ '^%l*x$' ){
+                        $toks[$i] = '[\da-f]+';
+                   }
+                } elsif( length( $toks[$i] ) ){
+                    $toks[$i] =~ s/^.*$/\Q$&\E/;
+                    $conlen += length( $toks[$i] );
+                }
+            }  
+            my $lhs = join( '', @toks );
+           $transfmt{$header}{pat} =
+              "    s{^$lhs}\n     {\Q$header\E}s\n\t&& return 1;\n";
+            $transfmt{$header}{len} = $conlen;
        } else {
-           $transmo .= "    m{^\Q$header\E} && return 1;\n";
+            $transfmt{$header}{pat} =
+             "    m{^\Q$header\E} && return 1;\n";
+            $transfmt{$header}{len} = length( $header );
        } 
 
        print STDERR "$WHOAMI: Duplicate entry: \"$header\"\n"
@@ -390,6 +404,12 @@ my %msg;
 
     die "No diagnostics?" unless %msg;
 
+    # Apply patterns in order of decreasing sum of lengths of fixed parts
+    # Seems the best way of hitting the right one.
+    for my $hdr ( sort { $transfmt{$b}{len} <=> $transfmt{$a}{len} }
+                  keys %transfmt ){
+        $transmo .= $transfmt{$hdr}{pat};
+    }
     $transmo .= "    return 0;\n}\n";
     print STDERR $transmo if $DEBUG;
     eval $transmo;
@@ -505,15 +525,33 @@ sub splainthis {
     s/\.?\n+$//;
     my $orig = $_;
     # return unless defined;
+
+    # get rid of the where-are-we-in-input part
     s/, <.*?> (?:line|chunk).*$//;
-    my $real = s/(.*?) at .*? (?:line|chunk) \d+.*/$1/;
+
+    # Discard 1st " at <file> line <no>" and all text beyond
+    # but be aware of messsages containing " at this-or-that"
+    my $real = 0;
+    my @secs = split( / at / );
+    $_ = $secs[0];
+    for my $i ( 1..$#secs ){
+        if( $secs[$i] =~ /.+? (?:line|chunk) \d+/ ){
+            $real = 1;
+            last;
+        } else {
+            $_ .= ' at ' . $secs[$i];
+       }
+    }
+    
+    # remove parenthesis occurring at the end of some messages 
     s/^\((.*)\)$/$1/;
+
     if ($exact_duplicate{$orig}++) {
        return &transmo;
-    }
-    else {
+    } else {
        return 0 unless &transmo;
     }
+
     $orig = shorten($orig);
     if ($old_diag{$_}) {
        autodescribe();
diff --git a/perl.h b/perl.h
index 547165a..89d1494 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -3355,6 +3355,25 @@ typedef void *Thread;
 #undef PERLVARI
 #undef PERLVARIC
 
+/* Types used by pack/unpack */ 
+typedef enum {
+  e_no_len,     /* no length  */
+  e_number,     /* number, [] */
+  e_star        /* asterisk   */
+} howlen_t;
+
+typedef struct {
+  char*    patptr;   /* current template char */
+  char*    patend;   /* one after last char   */
+  char*    grpbeg;   /* 1st char of ()-group  */
+  char*    grpend;   /* end of ()-group       */
+  I32      code;     /* template code (!)     */
+  I32      length;   /* length/repeat count   */
+  howlen_t howlen;   /* how length is given   */ 
+  int      level;    /* () nesting level      */
+  U32      flags;    /* /=4, comma=2, pack=1  */
+} tempsym_t;
+
 #include "thread.h"
 #include "pp.h"
 
index daa0837..af771f1 100644 (file)
@@ -64,7 +64,7 @@ L<perlfunc/accept>.
 
 =item '!' allowed only after types %s
 
-(F) The '!' is allowed in pack() and unpack() only after certain types.
+(F) The '!' is allowed in pack() or unpack(9 only after certain types.
 See L<perlfunc/pack>.
 
 =item Ambiguous call resolved as CORE::%s(), qualify as such or use &
@@ -466,30 +466,24 @@ checking.  Alternatively, if you are certain that you're calling the
 function correctly, you may put an ampersand before the name to avoid
 the warning.  See L<perlsub>.
 
-=item Can only compress unsigned integers
+=item Can only compress unsigned integers in pack
 
 (F) An argument to pack("w",...) was not an integer.  The BER compressed
 integer format can only be used with positive integers, and you attempted
 to compress something else.  See L<perlfunc/pack>.
 
-=item Cannot compress integer
+=item Cannot compress integer in pack
 
 (F) An argument to pack("w",...) was too large to compress.  The BER
 compressed integer format can only be used with positive integers, and you
 attempted to compress Infinity or a very large number (> 1e308).
 See L<perlfunc/pack>.
 
-=item Cannot compress negative numbers
+=item Cannot compress negative numbers in pack
 
 (F) An argument to pack("w",...) was negative.  The BER compressed integer
 format can only be used with positive integers.  See L<perlfunc/pack>.
 
-=item / cannot take a count
-
-(F) You had an unpack template indicating a counted-length string, but
-you have also specified an explicit size for the string.  See
-L<perlfunc/pack>.
-
 =item Can't bless non-reference value
 
 (F) Only hard references may be blessed.  This is how Perl "enforces"
@@ -1127,7 +1121,7 @@ references can be weakened.
 with an assignment operator, which implies modifying the value itself.
 Perhaps you need to copy the value to a temporary, and repeat that.
 
-=item Character in "C" format wrapped
+=item Character in "C" format wrapped in pack
 
 (W pack) You said
 
@@ -1142,7 +1136,7 @@ and so on) and not for Unicode characters, so Perl behaved as if you meant
 If you actually want to pack Unicode codepoints, use the C<"U"> format
 instead.
 
-=item Character in "c" format wrapped
+=item Character in "c" format wrapped in pack
 
 (W pack) You said
 
@@ -1157,6 +1151,11 @@ and so on) and not for Unicode characters, so Perl behaved as if you meant
 If you actually want to pack Unicode codepoints, use the C<"U"> format
 instead.
 
+=item Code missing after '/'
+
+(F) You had a (sub-)template that ends with a '/'. There must be another
+template code following the slash. See L<perlfunc/pack>.
+
 =item close() on unopened filehandle %s
 
 (W unopened) You tried to close a filehandle that was never opened.
@@ -1264,6 +1263,12 @@ valid magic number.
 
 (P) The malloc package that comes with Perl had an internal failure.
 
+=item Count after length/code in unpack
+
+(F) You had an unpack template indicating a counted-length string, but
+you have also specified an explicit size for the string.  See
+L<perlfunc/pack>.
+
 =item C<-p> destination: %s
 
 (F) An error occurred during the implicit output invoked by the C<-p>
@@ -1347,6 +1352,11 @@ See Server error.
 (F) You said something like "use Module 42" but the Module did not
 define a C<$VERSION.>
 
+=item '/' does not take a repeat count
+
+(F) You cannot put a repeat count of any kind right after the '/' code.
+See L<perlfunc/pack>.
+
 =item Don't know how to handle magic of type '%s'
 
 (P) The internal handling of magical variables has been cursed.
@@ -1550,9 +1560,7 @@ some time before now.  Check your control flow.  flock() operates on
 filehandles.  Are you attempting to call flock() on a dirhandle by the
 same name?
 
-=item Quantifier follows nothing in regex;
-
-marked by <-- HERE in m/%s/
+=item Quantifier follows nothing in regex; marked by <-- HERE in m/%s/
 
 (F) You started a regular expression with a quantifier. Backslash it if you
 meant it literally. The <-- HERE shows in the regular expression about
@@ -1655,10 +1663,11 @@ version of Perl, and this should not happen anyway.
 (F) Unlike with "next" or "last", you're not allowed to goto an
 unspecified destination.  See L<perlfunc/goto>.
 
-=item %s-group starts with a count
+=item ()-group starts with a count
 
-(F) In pack/unpack a ()-group started with a count.  A count is
+(F) A ()-group started with a count.  A count is
 supposed to follow something: a template character or a ()-group.
+ See L<perlfunc/pack>.
 
 =item %s had compilation errors
 
@@ -1900,17 +1909,11 @@ elements of an attribute list.  If the previous attribute had a
 parenthesised parameter list, perhaps that list was terminated too soon.
 See L<attributes>.
 
-=item Invalid type in pack: '%s'
-
-(F) The given character is not a valid pack type.  See L<perlfunc/pack>.
-(W pack) The given character is not a valid pack type but used to be
-silently ignored.
+=item Invalid type '%s' in %s
 
-=item Invalid type in unpack: '%s'
-
-(F) The given character is not a valid unpack type.  See
-L<perlfunc/unpack>.
-(W unpack) The given character is not a valid unpack type but used to be
+(F) The given character is not a valid pack or unpack type.
+See L<perlfunc/pack>.
+(W) The given character is not a valid pack or unpack type but used to be
 silently ignored.
 
 =item Invalid version format (multiple underscores)
@@ -1977,6 +1980,12 @@ L<perlfunc/last>.
 (F) While under the C<use filetest> pragma, switching the real and
 effective uids or gids failed.
 
+=item length/code after end of string in unpack
+
+(F) While unpacking, the string buffer was alread used up when an unpack
+length/code combination tried to obtain more data. This results in
+an undefined value for the length. See L<perlfunc/pack>.
+
 =item listen() on closed socket %s
 
 (W closed) You tried to do a listen on a closed socket.  Did you forget
@@ -1995,14 +2004,22 @@ instead on the filehandle.)
 values cannot be returned in subroutines used in lvalue context.  See
 L<perlsub/"Lvalue subroutines">.
 
-=item Lookbehind longer than %d not implemented in regex;
-
-marked by <-- HERE in m/%s/
+=item Lookbehind longer than %d not implemented in regex; marked by <-- HERE in m/%s/
 
 (F) There is currently a limit on the length of string which lookbehind can
 handle. This restriction may be eased in a future release. The <-- HERE
 shows in the regular expression about where the problem was discovered.
 
+=item Malformed integer in [] in  pack
+
+(F) Between the  brackets enclosing a numeric repeat count only digits
+are permitted.  See L<perlfunc/pack>.
+
+=item Malformed integer in [] in unpack
+
+(F) Between the  brackets enclosing a numeric repeat count only digits
+are permitted.  See L<perlfunc/pack>.
+
 =item Malformed PERLLIB_PREFIX
 
 (F) An error peculiar to OS/2.  PERLLIB_PREFIX should be of the form
@@ -2037,9 +2054,7 @@ possibility is careless use of utf8::upgrade().
 Perl thought it was reading UTF-16 encoded character data but while
 doing it Perl met a malformed Unicode surrogate.
 
-=item %s matches null string many times in regex;
-
-marked by <-- HERE in m/%s/
+=item %s matches null string many times in regex; marked by <-- HERE in m/%s/
 
 (W regexp) The pattern you've specified would be an infinite loop if the
 regular expression engine didn't specifically check for that.  The <-- HERE
@@ -2052,7 +2067,7 @@ See L<perlre>.
 interpreter, especially if the word that is being warned about is
 "use" or "my".
 
-=item % may only be used in unpack
+=item % may not be used in pack
 
 (F) You can't pack a string by supplying a checksum, because the
 checksumming process loses information, and you can't go the other way.
@@ -2187,22 +2202,17 @@ See L<perlfunc/open> for details.
 (W syntax) Multidimensional arrays aren't written like C<$foo[1,2,3]>.
 They're written like C<$foo[1][2][3]>, as in C.
 
-=item / must be followed by a*, A* or Z*
+=item '/' must be followed by 'a*', 'A*' or 'Z*'
 
 (F) You had a pack template indicating a counted-length string,
 Currently the only things that can have their length counted are a*, A*
 or Z*.  See L<perlfunc/pack>.
 
-=item / must be followed by a, A or Z
-
-(F) You had an unpack template indicating a counted-length string, which
-must be followed by one of the letters a, A or Z to indicate what sort
-of string is to be unpacked.  See L<perlfunc/pack>.
-
-=item / must follow a numeric type
+=item '/' must follow a numeric type in unpack
 
-(F) You had an unpack template that contained a '#', but this did not
-follow some numeric unpack specification.  See L<perlfunc/pack>.
+(F) You had an unpack template that contained a '/', but this did not
+follow some unpack specification producing a numeric value.
+See L<perlfunc/pack>.
 
 =item "my sub" not yet implemented
 
@@ -2222,6 +2232,11 @@ If you had a good reason for having a unique name, then just mention it
 again somehow to suppress the message.  The C<our> declaration is
 provided for this purpose.
 
+=item Negative '/' count in unpack
+
+(F) The length count obtained from a length/code unpack operation was
+negative.  See L<perlfunc/pack>.
+
 =item Negative length
 
 (F) You tried to do a read/write/send/recv operation with a buffer
@@ -2307,6 +2322,11 @@ ordinary subroutine call.
 redirection, and found a '2>' or a '2>>' on the command line, but can't
 find the name of the file to which to write data destined for stderr.
 
+=item No group ending character '%c' found in template
+
+(F) A pack or unpack template has an opening '(' or '[' without its
+matching counterpart. See L<perlfunc/pack>.
+
 =item No input file after < on command line
 
 (F) An error peculiar to VMS.  Perl handles its own command line
@@ -2453,12 +2473,6 @@ supplied.  See L<perlform>.
 of Perl.  Check the #! line, or manually feed your script into Perl
 yourself.
 
-=item %s not allowed in length fields
-
-(F) The count in the (un)pack template may be replaced by C<[TEMPLATE]> only if
-C<TEMPLATE> always matches the same amount of packed bytes.  Redesign
-the template.
-
 =item no UTC offset information; assuming local time is UTC
 
 (S) A warning peculiar to VMS.  Perl was unable to find the local
@@ -2622,9 +2636,9 @@ C<$arr[time]> instead of C<$arr[$time]>.
 parsing, but realloc() wouldn't give it more memory, virtual or
 otherwise.
 
-=item @ outside of string
+=item '@' outside of string in unpack
 
-(F) You had a pack template that specified an absolute position outside
+(F) You had a template that specified an absolute position outside
 the string being unpacked.  See L<perlfunc/pack>.
 
 =item %s package attribute may clash with future reserved word: %s
@@ -2890,13 +2904,11 @@ value of the environment variable PERLIO.
 process which isn't a subprocess of the current process.  While this is
 fine from VMS' perspective, it's probably not what you intended.
 
-=item P must have an explicit size
+=item 'P' must have an explicit size in unpack
 
 (F) The unpack format P must have an explicit size, not "*".
 
-=item POSIX syntax [%s] belongs inside character classes in regex;
-
-marked by <-- HERE in m/%s/
+=item POSIX syntax [%s] belongs inside character classes in regex; marked by <-- HERE in m/%s/
 
 (W regexp) The character class constructs [: :], [= =], and [. .]  go
 I<inside> character classes, the [] are part of the construct, for example:
@@ -2905,9 +2917,7 @@ implemented; they are simply placeholders for future extensions and will
 cause fatal errors.  The <-- HERE shows in the regular expression about
 where the problem was discovered.  See L<perlre>.
 
-=item POSIX syntax [. .] is reserved for future extensions in regex;
-
-marked by <-- HERE in m/%s/
+=item POSIX syntax [. .] is reserved for future extensions in regex; marked by <-- HERE in m/%s/
 
 (F regexp) Within regular expression character classes ([]) the syntax
 beginning with "[." and ending with ".]" is reserved for future extensions.
@@ -2916,9 +2926,7 @@ expression character class, just quote the square brackets with the
 backslash: "\[." and ".\]".  The <-- HERE shows in the regular expression
 about where the problem was discovered.  See L<perlre>.
 
-=item POSIX syntax [= =] is reserved for future extensions in regex;
-
-marked by <-- HERE in m/%s/
+=item POSIX syntax [= =] is reserved for future extensions in regex; marked by <-- HERE in m/%s/
 
 (F) Within regular expression character classes ([]) the syntax beginning
 with "[=" and ending with "=]" is reserved for future extensions.  If you
@@ -2927,9 +2935,7 @@ character class, just quote the square brackets with the backslash: "\[="
 and "=\]".  The <-- HERE shows in the regular expression about where the
 problem was discovered.  See L<perlre>.
 
-=item POSIX class [:%s:] unknown in regex;
-
-marked by <-- HERE in m/%s/
+=item POSIX class [:%s:] unknown in regex; marked by <-- HERE in m/%s/
 
 (F) The class in the character class [: :] syntax is unknown.  The <-- HERE
 shows in the regular expression about where the problem was discovered.
@@ -3083,17 +3089,13 @@ declared or defined with a different function prototype.
 (F) You've omitted the closing parenthesis in a function prototype
 definition.
 
-=item Quantifier in {,} bigger than %d in regex;
-
-marked by <-- HERE in m/%s/
+=item Quantifier in {,} bigger than %d in regex; marked by <-- HERE in m/%s/
 
 (F) There is currently a limit to the size of the min and max values of the
 {min,max} construct. The <-- HERE shows in the regular expression about where
 the problem was discovered. See L<perlre>.
 
-=item Quantifier unexpected on zero-length expression;
-
-marked by <-- HERE in m/%s/
+=item Quantifier unexpected on zero-length expression; marked by <-- HERE in m/%s/
 
 (W regexp) You applied a regular expression quantifier in a place where
 it makes no sense, such as on a zero-width assertion.  Try putting the
@@ -3172,9 +3174,7 @@ Doing so has no effect.
 (W internal) The internal sv_replace() function was handed a new SV with
 a reference count of other than 1.
 
-=item Reference to nonexistent group in regex;
-
-marked by <-- HERE in m/%s/
+=item Reference to nonexistent group in regex; marked by <-- HERE in m/%s/
 
 (F) You used something like C<\7> in your regular expression, but there are
 not at least seven sets of capturing parentheses in the expression. If you
@@ -3194,16 +3194,11 @@ expression compiler gave it.
 (P) A "can't happen" error, because safemalloc() should have caught it
 earlier.
 
-=item Repeat count in pack overflows
+=item pack/unpack repeat count overflow
 
 (F) You can't specify a repeat count so large that it overflows your
 signed integers.  See L<perlfunc/pack>.
 
-=item Repeat count in unpack overflows
-
-(F) You can't specify a repeat count so large that it overflows your
-signed integers.  See L<perlfunc/unpack>.
-
 =item Reversed %s= operator
 
 (W syntax) You wrote your assignment operator backwards.  The = must
@@ -3309,34 +3304,26 @@ before now.  Check your control flow.
 shows in the regular expression about where the problem was discovered. See
 L<perlre>.
 
-=item Sequence (?{...}) not terminated or not {}-balanced in regex;
-
-marked by <-- HERE in m/%s/
+=item Sequence (?{...}) not terminated or not {}-balanced in regex; marked by <-- HERE in m/%s/
 
 (F) If the contents of a (?{...}) clause contains braces, they must balance
 for Perl to properly detect the end of the clause. The <-- HERE shows in
 the regular expression about where the problem was discovered. See
 L<perlre>.
 
-=item Sequence (?%s...) not implemented in regex;
-
-marked by <-- HERE in m/%s/
+=item Sequence (?%s...) not implemented in regex; marked by <-- HERE in m/%s/
 
 (F) A proposed regular expression extension has the character reserved but
 has not yet been written. The <-- HERE shows in the regular expression about
 where the problem was discovered. See L<perlre>.
 
-=item Sequence (?%s...) not recognized in regex;
-
-marked by <-- HERE in m/%s/
+=item Sequence (?%s...) not recognized in regex; marked by <-- HERE in m/%s/
 
 (F) You used a regular expression extension that doesn't make sense.  The
 <-- HERE shows in the regular expression about where the problem was
 discovered.  See L<perlre>.
 
-=item Sequence (?#... not terminated in regex;
-
-marked by <-- HERE in m/%s/
+=item Sequence (?#... not terminated in regex; marked by <-- HERE in m/%s/
 
 (F) A regular expression comment must be terminated by a closing
 parenthesis.  Embedded parentheses aren't allowed.  The <-- HERE shows in
@@ -3532,9 +3519,7 @@ assignment or as a subroutine argument for example).
 (F) Your Perl was compiled with B<-D>SETUID_SCRIPTS_ARE_SECURE_NOW, but
 a version of the setuid emulator somehow got run anyway.
 
-=item Switch (?(condition)... contains too many branches in regex;
-
-marked by <-- HERE in m/%s/
+=item Switch (?(condition)... contains too many branches in regex; marked by <-- HERE in m/%s/
 
 (F) A (?(condition)if-clause|else-clause) construct can have at most two
 branches (the if-clause and the else-clause). If you want one or both to
@@ -3546,9 +3531,7 @@ clustering parentheses:
 The <-- HERE shows in the regular expression about where the problem was
 discovered. See L<perlre>.
 
-=item Switch condition not recognized in regex;
-
-marked by <-- HERE in m/%s/
+=item Switch condition not recognized in regex; marked by <-- HERE in m/%s/
 
 (F) If the argument to the (?(...)if-clause|else-clause) construct is a
 number, it can be only a number. The <-- HERE shows in the regular expression
@@ -3593,7 +3576,7 @@ yourself.
 a perl4 interpreter, especially if the next 2 tokens are "use strict"
 or "my $var" or "our $var".
 
-=item %s syntax OK
+=item %s syntax
 
 (F) The final summary message when a C<perl -c> succeeds.
 
@@ -3696,6 +3679,10 @@ uc(), or ucfirst() (or their string-inlined versions), but you
 specified an illegal mapping.
 See L<perlunicode/"User-Defined Character Properties">.
 
+=item Too deeply nested ()-groups
+
+(F) Your template contains ()-groups with a ridiculously deep nesting level. 
+
 =item Too few args to syscall
 
 (F) There has to be at least one argument to syscall() to specify the
@@ -3741,6 +3728,9 @@ BEGIN block.
 
 =item Too many )'s
 
+(A) You've accidentally run your script through B<csh> instead of Perl.
+Check the #! line, or manually feed your script into Perl yourself.
+
 =item Too many ('s
 
 (A) You've accidentally run your script through B<csh> instead of Perl.
@@ -3864,9 +3854,7 @@ order.
 
 You tried to use an unknown subpragma of the "re" pragma.
 
-=item Unknown switch condition (?(%.2s in regex;
-
-marked by <-- HERE in m/%s/
+=item Unknown switch condition (?(%.2s in regex; marked by <-- HERE in m/%s/
 
 (F) The condition part of a (?(condition)if-clause|else-clause) construct
 is not known. The condition may be lookahead or lookbehind (the condition
@@ -3950,9 +3938,7 @@ script, a binary program, or a directory as a Perl program.
 recognized by Perl inside character classes.  The character was
 understood literally.
 
-=item Unrecognized escape \\%c passed through in regex;
-
-marked by <-- HERE in m/%s/
+=item Unrecognized escape \\%c passed through in regex; marked by <-- HERE in m/%s/
 
 (W regexp) You used a backslash-character combination which is not
 recognized by Perl. This combination appears in an interpolated variable or
@@ -4042,9 +4028,7 @@ earlier in the line, and you really meant a "less than".
 (W untie) A copy of the object returned from C<tie> (or C<tied>) was
 still valid when C<untie> was called.
 
-=item Useless (?%s) - use /%s modifier in regex;
-
-marked by <-- HERE in m/%s/
+=item Useless (?%s) - use /%s modifier in regex; marked by <-- HERE in m/%s/
 
 (W regexp) You have used an internal modifier such as (?o) that has no
 meaning unless applied to the entire regexp:
@@ -4058,9 +4042,7 @@ must be written as
 The <-- HERE shows in the regular expression about
 where the problem was discovered. See L<perlre>.
 
-=item Useless (?-%s) - don't use /%s modifier in regex;
-
-marked by <-- HERE in m/%s/
+=item Useless (?-%s) - don't use /%s modifier in regex; marked by <-- HERE in m/%s/
 
 (W regexp) You have used an internal modifier such as (?-o) that has no
 meaning unless removed from the entire regexp:
@@ -4232,17 +4214,17 @@ matching, both for you and for any luckless subroutine that you happen
 to call.  You should use the new C<//m> and C<//s> modifiers now to do
 that without the dangerous action-at-a-distance effects of C<$*>.
 
+=item Use of $# is deprecated
+
+(D deprecated) This was an ill-advised attempt to emulate a poorly
+defined B<awk> feature.  Use an explicit printf() or sprintf() instead.
+
 =item Use of %s is deprecated
 
 (D deprecated) The construct indicated is no longer recommended for use,
 generally because there's a better way to do it, and also because the
 old way has bad side effects.
 
-=item Use of $# is deprecated
-
-(D deprecated) This was an ill-advised attempt to emulate a poorly
-defined B<awk> feature.  Use an explicit printf() or sprintf() instead.
-
 =item Use of reference "%s" as array index
 
 (W misc) You tried to use a reference as an array index; this probably
@@ -4388,9 +4370,7 @@ anonymous, using the C<sub {}> syntax.  When inner anonymous subs that
 reference variables in outer subroutines are called or referenced, they
 are automatically rebound to the current values of such variables.
 
-=item Variable length lookbehind not implemented in regex;
-
-marked by <-- HERE in m/%s/
+=item Variable length lookbehind not implemented in regex; marked by <-- HERE in m/%s/
 
 (F) Lookbehind is allowed only for subexpressions whose length is fixed and
 known at compile time. The <-- HERE shows in the regular expression about
@@ -4449,17 +4429,24 @@ one.  This warning is by default on for I/O (like print) but can be
 turned off by C<no warnings 'utf8';>.  You are supposed to explicitly
 mark the filehandle with an encoding, see L<open> and L<perlfunc/binmode>.
 
+=item Within []-length '%c' not allowed
+
+(F) The count in the (un)pack template may be replaced by C<[TEMPLATE]> only if
+C<TEMPLATE> always matches the same amount of packed bytes that can be
+determined from the template alone. This is not possible if it contains an
+of the codes @, /, U, u, w or a *-length. Redesign the template.
+
 =item write() on closed filehandle %s
 
 (W closed) The filehandle you're writing to got itself closed sometime
 before now.  Check your control flow.
 
-=item X outside of string
+=item 'X' outside of string
 
-(F) You had a pack template that specified a relative position before
-the beginning of the string being unpacked.  See L<perlfunc/pack>.
+(F) You had a (un)pack template that specified a relative position before
+the beginning of the string being (un)packed.  See L<perlfunc/pack>.
 
-=item x outside of string
+=item 'x' outside of string in unpack
 
 (F) You had a pack template that specified a relative position after
 the end of the string being unpacked.  See L<perlfunc/pack>.
index d1b4d29..353e4e6 100644 (file)
@@ -3259,7 +3259,8 @@ of values, as follows:
 
     x  A null byte.
     X  Back up a byte.
-    @  Null fill to absolute position.
+    @  Null fill to absolute position, counted from the start of
+        the innermost ()-group.
     (  Start of a ()-group.
 
 The following rules apply:
@@ -3377,9 +3378,11 @@ how the length value is packed.  The ones likely to be of most use are
 integer-packing ones like C<n> (for Java strings), C<w> (for ASN.1 or
 SNMP) and C<N> (for Sun XDR).
 
-The I<string-item> must, at present, be C<"A*">, C<"a*"> or C<"Z*">.
-For C<unpack> the length of the string is obtained from the I<length-item>,
-but if you put in the '*' it will be ignored.
+For C<pack>, the I<string-item> must, at present, be C<"A*">, C<"a*"> or
+C<"Z*">. For C<unpack> the length of the string is obtained from the
+I<length-item>, but if you put in the '*' it will be ignored. For all other
+codes, C<unpack> applies the length value to the next item, which must not
+have a repeat count.
 
     unpack 'C/a', "\04Gurusamy";        gives 'Guru'
     unpack 'a3/A* A*', '007 Bond  J ';  gives (' Bond','J')
@@ -3417,7 +3420,7 @@ L<Config>:
        print $Config{longsize},     "\n";
        print $Config{longlongsize}, "\n";
 
-(The C<$Config{longlongsize}> will be undefine if your system does
+(The C<$Config{longlongsize}> will be undefined if your system does
 not support long longs.)
 
 =item *
@@ -3500,8 +3503,14 @@ sequences of bytes.
 =item *
 
 A ()-group is a sub-TEMPLATE enclosed in parentheses.  A group may
-take a repeat count, both as postfix, and via the C</> template
-character.
+take a repeat count, both as postfix, and for unpack() also via the C</>
+template character. Within each repetition of a group, positioning with
+C<@> starts again at 0. Therefore, the result of
+
+    pack( '@1A((@2A)@3A)', 'a', 'b', 'c' )
+
+is the string "\0a\0\0bc".
+
 
 =item *
 
@@ -3518,6 +3527,8 @@ both result in no-ops.
 =item *
 
 A comment in a TEMPLATE starts with C<#> and goes to the end of line.
+White space may be used to separate pack codes from each other, but
+a C<!> modifier and a repeat count must follow immediately.
 
 =item *
 
@@ -5994,9 +6005,12 @@ has no way of checking whether the value passed to C<unpack()>
 corresponds to a valid memory location, passing a pointer value that's
 not known to be valid is likely to have disastrous consequences.
 
-If the repeat count of a field is larger than what the remainder of
-the input string allows, repeat count is decreased.  If the input string
-is longer than one described by the TEMPLATE, the rest is ignored.
+If there are more pack codes or if the repeat count of a field or a group
+is larger than what the remainder of the input string allows, the result
+is not well defined: in some cases, the repeat count is decreased, or
+C<unpack()> will produce null strings or zeroes, or terminate with an
+error. If the input string is longer than one described by the TEMPLATE,
+the rest is ignored.
 
 See L</pack> for more examples and notes.
 
index ac7a01a..80c784b 100644 (file)
@@ -177,7 +177,7 @@ template doesn't match the incoming data, Perl will scream and die.
 
 Hence, putting it all together:
 
-    my($date,$description,$income,$expend) = unpack("A10xA27xA7A*", $_);
+    my($date,$description,$income,$expend) = unpack("A10xA27xA7xA*", $_);
 
 Now, that's our data parsed. I suppose what we might want to do now is
 total up our income and expenditure, and add another line to the end of
@@ -423,6 +423,8 @@ together, we may now write:
        $si, $di, $bp, $ds, $es ) =
    unpack( 'v2' . ('vXXCC' x 5) . 'v5', $frame );
 
+(The clumsy construction of the template can be avoided - just read on!)  
+
 We've taken some pains to construct the template so that it matches
 the contents of our frame buffer. Otherwise we'd either get undefined values,
 or C<unpack> could not unpack all. If C<pack> runs out of items, it will
@@ -520,7 +522,7 @@ into individual characters. Bit values from the "reserved" positions are
 simply assigned to C<undef>, a convenient notation for "I don't care where
 this goes".
 
-   ($carry, undef, $parity, undef, $auxcarry, undef, $sign,
+   ($carry, undef, $parity, undef, $auxcarry, undef, $zero, $sign,
     $trace, $interrupt, $direction, $overflow) =
       split( //, unpack( 'b16', $status ) );
 
@@ -636,6 +638,54 @@ shows 01 8100 8101 81807F. Since the last byte is always less than
 128, C<unpack> knows where to stop.
 
 
+=head1 Template Grouping
+
+Prior to Perl 5.8, repetitions of templates had to be made by
+C<x>-multiplication of template strings. Now there is a better way as
+we may use the pack codes C<(> and C<)> combined with a repeat count.
+The C<unpack> template from the Stack Frame example can simply
+be written like this:
+
+   unpack( 'v2 (vXXCC)5 v5', $frame )
+
+Let's explore this feature a little more. We'll begin with the equivalent of
+
+   join( '', map( substr( $_, 0, 1 ), @str ) )
+
+which returns a string consisting of the first character from each string.
+Using pack, we can write
+
+   pack( '(A)'.@str, @str )
+
+or, because a repeat count C<*> means "repeat as often as required",
+simply
+
+   pack( '(A)*', @str )
+
+(Note that the template C<A*> would only have packed C<$str[0]> in full
+length.)
+To pack dates stored as triplets ( day, month, year ) in an array C<@dates>
+into a sequence of byte, byte, short integer we can write
+
+   $pd = pack( '(CCS)*', map( @$_, @dates ) );
+
+To swap pairs of characters in a string (with even length) one could use
+several techniques. First, let's use C<x> and C<X> to skip forward and back:
+
+   $s = pack( '(A)*', unpack( '(xAXXAx)*', $s ) );
+
+We can also use C<@> to jump to an offset, with 0 being the position where
+we were when the last C<(> was encountered:
+
+   $s = pack( '(A)*', unpack( '(@1A @0A @2)*', $s ) );
+
+Finally, there is also an entirely different approach by unpacking big
+endian shorts and packing them in the reverse byte order:
+
+   $s = pack( '(v)*', unpack( '(n)*', $s );
+
+
 =head1 Lengths and Widths
 
 =head2 String Lengths
@@ -713,20 +763,20 @@ string for the template. So maybe we should introduce...
 
 So far, we've seen literals used as templates. If the list of pack
 items doesn't have fixed length, an expression constructing the
-template has to be used. Here's an example:
-To store named string values in a way that can be conveniently parsed
-by a C program, we create a sequence of names and null terminated ASCII
-strings, with C<=> between the name and the value, followed by an
-additional delimiting null byte. Here's how:
+template is required (whenever, for some reason, C<()*> cannot be used).
+Here's an example: To store named string values in a way that can be
+conveniently parsed by a C program, we create a sequence of names and
+null terminated ASCII strings, with C<=> between the name and the value,
+followed by an additional delimiting null byte. Here's how:
 
-   my $env = pack( 'A*A*Z*' x keys( %Env ) . 'C',
+   my $env = pack( '(A*A*Z*)' . keys( %Env ) . 'C',
                    map( { ( $_, '=', $Env{$_} ) } keys( %Env ) ), 0 );
 
 Let's examine the cogs of this byte mill, one by one. There's the C<map>
 call, creating the items we intend to stuff into the C<$env> buffer:
 to each key (in C<$_>) it adds the C<=> separator and the hash entry value.
 Each triplet is packed with the template code sequence C<A*A*Z*> that
-is multiplied with the number of keys. (Yes, that's what the C<keys>
+is repeated according to the number of keys. (Yes, that's what the C<keys>
 function returns in scalar context.) To get the very last null byte,
 we add a C<0> at the end of the C<pack> list, to be packed with C<C>.
 (Attentive readers may have noticed that we could have omitted the 0.)
@@ -735,12 +785,31 @@ For the reverse operation, we'll have to determine the number of items
 in the buffer before we can let C<unpack> rip it apart:
 
    my $n = $env =~ tr/\0// - 1;
-   my %env = map( split( /=/, $_ ), unpack( 'Z*' x $n, $env ) );
+   my %env = map( split( /=/, $_ ), unpack( "(Z*)$n", $env ) );
 
 The C<tr> counts the null bytes. The C<unpack> call returns a list of
 name-value pairs each of which is taken apart in the C<map> block. 
 
 
+=head2 Counting Repetitions
+
+Rather than storing a sentinel at the end of a data item (or a list of items),
+we could precede the data with a count. Again, we pack keys and values of
+a hash, preceding each with an unsigned short length count, and up front
+we store the number of pairs:
+
+   my $env = pack( 'S(S/A* S/A*)*', scalar keys( %Env ), %Env );
+
+This simplifies the reverse operation as the number of repetitions can be
+unpacked with the C</> code:
+
+   my %env = unpack( 'S/(S/A* S/A*)', $env );
+
+Note that this is one of the rare cases where you cannot use the same
+template for C<pack> and C<unpack> because C<pack> can't determine
+a repeat count for a C<()>-group.
+
+
 =head1 Packing and Unpacking C Structures
 
 In previous sections we have seen how to pack numbers and character
@@ -855,6 +924,22 @@ the C<offsetof> macro (defined in C<E<lt>stddef.hE<gt>>) returns when
 given a C<struct> type and one of its field names ("member-designator" in 
 C standardese).
 
+Neither using offsets nor adding C<x>'s to bridge the gaps is satisfactory.
+(Just imagine what happens if the structure changes.) What we really need
+is a way of saying "skip as many bytes as required to the next multiple of N".
+In fluent Templatese, you say this with C<x!N> where N is replaced by the
+appropriate value. Here's the next version of our struct packaging:
+
+  my $gappy = pack( 'c x!2 s c x!4 l!', $c1, $s, $c2, $l );
+
+That's certainly better, but we still have to know how long all the
+integers are, and portability is far away. Rather than C<2>,
+for instance, we want to say "however long a short is". But this can be
+done by enclosing the appropriate pack code in brackets: C<[s]>. So, here's
+the very best we can do:
+
+  my $gappy = pack( 'c x![s] s c x![l!] l!', $c1, $s, $c2, $l );
+
 
 =head2 Alignment, Take 2
 
@@ -1038,8 +1123,8 @@ many pairs of hex digits, and use C<map> to handle the traditional
 spacing - 16 bytes to a line:
 
     my $i;
-    print map { ++$i % 16 ? "$_ " : "$_\n" }
-          unpack( 'H2' x length( $mem ), $mem ),
+    print map( ++$i % 16 ? "$_ " : "$_\n",
+               unpack( 'H2' x length( $mem ), $mem ) ),
           length( $mem ) % 16 ? "\n" : '';
 
 
index ee036c6..69341db 100644 (file)
--- a/pp_pack.c
+++ b/pp_pack.c
@@ -83,6 +83,16 @@ static double UV_MAX_cxux = ((double)UV_MAX);
 #  define CAT32(sv,p)  sv_catpvn(sv, (char*)(p), SIZE32)
 #endif
 
+/* Avoid stack overflow due to pathological templates. 100 should be plenty. */
+#define MAX_SUB_TEMPLATE_LEVEL 100
+
+/* flags */
+#define FLAG_UNPACK_ONLY_ONE  0x10
+#define FLAG_UNPACK_DO_UTF8   0x08
+#define FLAG_SLASH            0x04
+#define FLAG_COMMA            0x02
+#define FLAG_PACK             0x01
+
 STATIC SV *
 S_mul128(pTHX_ SV *sv, U8 m)
 {
@@ -123,114 +133,58 @@ S_mul128(pTHX_ SV *sv, U8 m)
 #define ISUUCHAR(ch)    (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
 #endif
 
-#define UNPACK_ONLY_ONE        0x1
-#define UNPACK_DO_UTF8 0x2
-
-STATIC char *
-S_group_end(pTHX_ register char *pat, register char *patend, char ender)
-{
-    while (pat < patend) {
-       char c = *pat++;
-
-       if (isSPACE(c))
-           continue;
-       else if (c == ender)
-           return --pat;
-       else if (c == '#') {
-           while (pat < patend && *pat != '\n')
-               pat++;
-           continue;
-       } else if (c == '(')
-           pat = group_end(pat, patend, ')') + 1;
-       else if (c == '[')
-           pat = group_end(pat, patend, ']') + 1;
-    }
-    Perl_croak(aTHX_ "No group ending character `%c' found", ender);
-    return 0;
-}
-
 #define TYPE_IS_SHRIEKING      0x100
 
 /* Returns the sizeof() struct described by pat */
 STATIC I32
-S_measure_struct(pTHX_ char *pat, register char *patend)
+S_measure_struct(pTHX_ register tempsym_t* symptr)
 {
-    I32 datumtype;
-    register I32 len;
+    register I32 len = 0;
     register I32 total = 0;
-    int commas = 0;
-    int star;          /* 1 if count is *, -1 if no count given, -2 for / */
-#ifdef PERL_NATINT_PACK
-    int natint;                /* native integer */
-    int unatint;       /* unsigned native integer */
-#endif
-    char buf[2];
+    int star;
+
     register int size;
 
-    while ((pat = next_symbol(pat, patend)) < patend) {
-       datumtype = *pat++ & 0xFF;
-#ifdef PERL_NATINT_PACK
-       natint = 0;
-#endif
-       if (*pat == '!') {
-           static const char *natstr = "sSiIlLxX";
-
-           if (strchr(natstr, datumtype)) {
-               if (datumtype == 'x' || datumtype == 'X') {
-                   datumtype |= TYPE_IS_SHRIEKING;
-               } else {                /* XXXX Should be redone similarly! */
-#ifdef PERL_NATINT_PACK
-                   natint = 1;
-#endif
-               }
-               pat++;
-           }
-           else
-               Perl_croak(aTHX_ "'!' allowed only after types %s", natstr);
-       }
-       len = find_count(&pat, patend, &star);
-       if (star > 0)                   /*  */
-               Perl_croak(aTHX_ "%s not allowed in length fields", "count *");
-       else if (star < 0)              /* No explicit len */
-               len = datumtype != '@';
+    while (next_symbol(symptr)) {
 
-       switch(datumtype) {
+        switch( symptr->howlen ){
+        case e_no_len:
+       case e_number:
+           len = symptr->length;
+           break;
+        case e_star:
+           Perl_croak(aTHX_ "Within []-length '*' not allowed in %s",
+                       symptr->flags & FLAG_PACK ? "pack" : "unpack" );
+            break;
+        }
+
+       switch(symptr->code) {
        default:
-           Perl_croak(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
+    Perl_croak(aTHX_ "Invalid type '%c' in %s",
+                       (int)symptr->code,
+                       symptr->flags & FLAG_PACK ? "pack" : "unpack" );
        case '@':
        case '/':
        case 'U':                       /* XXXX Is it correct? */
        case 'w':
        case 'u':
-           buf[0] = (char)datumtype;
-           buf[1] = 0;
-           Perl_croak(aTHX_ "%s not allowed in length fields", buf);
-       case ',': /* grandfather in commas but with a warning */
-           if (commas++ == 0 && ckWARN(WARN_UNPACK))
-               Perl_warner(aTHX_ packWARN(WARN_UNPACK),
-                           "Invalid type in unpack: '%c'", (int)datumtype);
-           /* FALL THROUGH */
+           Perl_croak(aTHX_ "Within []-length '%c' not allowed in %s",
+                       (int)symptr->code,
+                       symptr->flags & FLAG_PACK ? "pack" : "unpack" );
        case '%':
            size = 0;
            break;
        case '(':
        {
-           char *beg = pat, *end;
-
-           if (star >= 0)
-               Perl_croak(aTHX_ "()-group starts with a count");
-           end = group_end(beg, patend, ')');
-           pat = end + 1;
-           len = find_count(&pat, patend, &star);
-           if (star < 0)               /* No count */
-               len = 1;
-           else if (star > 0)  /* Star */
-               Perl_croak(aTHX_ "%s not allowed in length fields", "count *");
+            tempsym_t savsym = *symptr;
+           symptr->patptr = savsym.grpbeg;
+            symptr->patend = savsym.grpend;
            /* XXXX Theoretically, we need to measure many times at different
               positions, since the subexpression may contain
               alignment commands, but be not of aligned length.
               Need to detect this and croak().  */
-           size = measure_struct(beg, end);
+           size = measure_struct(symptr);
+            *symptr = savsym;
            break;
        }
        case 'X' | TYPE_IS_SHRIEKING:
@@ -242,7 +196,8 @@ S_measure_struct(pTHX_ char *pat, register char *patend)
        case 'X':
            size = -1;
            if (total < len)
-               Perl_croak(aTHX_ "X outside of string");
+               Perl_croak(aTHX_ "'X' outside of string in %s",
+                          symptr->flags & FLAG_PACK ? "pack" : "unpack" );
            break;
        case 'x' | TYPE_IS_SHRIEKING:
            if (!len)                   /* Avoid division by 0 */
@@ -271,26 +226,33 @@ S_measure_struct(pTHX_ char *pat, register char *patend)
            len = (len + 1)/2;
            size = 1;
            break;
+       case 's' | TYPE_IS_SHRIEKING:
+#if SHORTSIZE != SIZE16
+           size = sizeof(short);
+           break;
+#else
+            /* FALL THROUGH */
+#endif
        case 's':
-#if SHORTSIZE == SIZE16
            size = SIZE16;
+           break;
+       case 'S' | TYPE_IS_SHRIEKING:
+#if SHORTSIZE != SIZE16
+           size = sizeof(unsigned short);
+           break;
 #else
-           size = (natint ? sizeof(short) : SIZE16);
+            /* FALL THROUGH */
 #endif
-           break;
        case 'v':
        case 'n':
        case 'S':
-#if SHORTSIZE == SIZE16
            size = SIZE16;
-#else
-           unatint = natint && datumtype == 'S';
-           size = (unatint ? sizeof(unsigned short) : SIZE16);
-#endif
            break;
+       case 'i' | TYPE_IS_SHRIEKING:
        case 'i':
            size = sizeof(int);
            break;
+       case 'I' | TYPE_IS_SHRIEKING:
        case 'I':
            size = sizeof(unsigned int);
            break;
@@ -300,22 +262,27 @@ S_measure_struct(pTHX_ char *pat, register char *patend)
        case 'J':
            size = UVSIZE;
            break;
+       case 'l' | TYPE_IS_SHRIEKING:
+#if LONGSIZE != SIZE32
+           size = sizeof(long);
+            break;
+#else
+            /* FALL THROUGH */
+#endif
        case 'l':
-#if LONGSIZE == SIZE32
            size = SIZE32;
+           break;
+       case 'L' | TYPE_IS_SHRIEKING:
+#if LONGSIZE != SIZE32
+           size = sizeof(unsigned long);
+           break;
 #else
-           size = (natint ? sizeof(long) : SIZE32);
+            /* FALL THROUGH */
 #endif
-           break;
        case 'V':
        case 'N':
        case 'L':
-#if LONGSIZE == SIZE32
            size = SIZE32;
-#else
-           unatint = natint && datumtype == 'L';
-           size = (unatint ? sizeof(unsigned long) : SIZE32);
-#endif
            break;
        case 'P':
            len = 1;
@@ -351,61 +318,176 @@ S_measure_struct(pTHX_ char *pat, register char *patend)
     return total;
 }
 
-/* Returns -1 on no count or on star */
-STATIC I32
-S_find_count(pTHX_ char **ppat, register char *patend, int *star)
+
+/* locate matching closing parenthesis or bracket
+ * returns char pointer to char after match, or NULL
+ */
+STATIC char *
+S_group_end(pTHX_ register char *patptr, register char *patend, char ender)
 {
-    char *pat = *ppat;
-    I32 len;
-
-    *star = 0;
-    if (pat >= patend)
-       len = 1;
-    else if (*pat == '*') {
-       pat++;
-       *star = 1;
-       len = -1;
-    }
-    else if (isDIGIT(*pat)) {
-       len = *pat++ - '0';
-       while (isDIGIT(*pat)) {
-           len = (len * 10) + (*pat++ - '0');
-           if (len < 0)                /* 50% chance of catching... */
-               Perl_croak(aTHX_ "Repeat count in pack/unpack overflows");
-       }
-    }
-    else if (*pat == '[') {
-       char *end = group_end(++pat, patend, ']');
-
-       len = 0;
-       *ppat = end + 1;
-       if (isDIGIT(*pat))
-           return find_count(&pat, end, star);
-       return measure_struct(pat, end);
+    while (patptr < patend) {
+       char c = *patptr++;
+
+       if (isSPACE(c))
+           continue;
+       else if (c == ender)
+           return patptr-1;
+       else if (c == '#') {
+           while (patptr < patend && *patptr != '\n')
+               patptr++;
+           continue;
+       } else if (c == '(')
+           patptr = group_end(patptr, patend, ')') + 1;
+       else if (c == '[')
+           patptr = group_end(patptr, patend, ']') + 1;
     }
-    else
-       len = *star = -1;
-    *ppat = pat;
-    return len;
+    Perl_croak(aTHX_ "No group ending character '%c' found in template",
+               ender);
+    return 0;
 }
 
+
+/* Convert unsigned decimal number to binary.
+ * Expects a pointer to the first digit and address of length variable
+ * Advances char pointer to 1st non-digit char and returns number
+ */ 
 STATIC char *
-S_next_symbol(pTHX_ register char *pat, register char *patend)
+S_get_num(pTHX_ register char *patptr, I32 *lenptr )
+{
+  I32 len = *patptr++ - '0';
+  while (isDIGIT(*patptr)) {
+    if (len >= 0x7FFFFFFF/10)
+      Perl_croak(aTHX_ "pack/unpack repeat count overflow");
+    len = (len * 10) + (*patptr++ - '0');
+  }
+  *lenptr = len;
+  return patptr;
+}
+
+/* The marvellous template parsing routine: Using state stored in *symptr,
+ * locates next template code and count
+ */
+STATIC bool
+S_next_symbol(pTHX_ register tempsym_t* symptr )
 {
-    while (pat < patend) {
-       if (isSPACE(*pat))
-           pat++;
-       else if (*pat == '#') {
-           pat++;
-           while (pat < patend && *pat != '\n')
-               pat++;
-           if (pat < patend)
-               pat++;
+  register char* patptr = symptr->patptr; 
+  register char* patend = symptr->patend; 
+
+  symptr->flags &= ~FLAG_SLASH;
+
+  while (patptr < patend) {
+    if (isSPACE(*patptr))
+      patptr++;
+    else if (*patptr == '#') {
+      patptr++;
+      while (patptr < patend && *patptr != '\n')
+       patptr++;
+      if (patptr < patend)
+       patptr++;
+    } else {
+      /* We should have found a template code */ 
+      I32 code = *patptr++ & 0xFF;
+
+      if (code == ','){ /* grandfather in commas but with a warning */
+       if (((symptr->flags & FLAG_COMMA) == 0) && ckWARN(WARN_UNPACK)){
+          symptr->flags |= FLAG_COMMA;
+         Perl_warner(aTHX_ packWARN(WARN_UNPACK),
+                     "Invalid type ',' in %s",
+                      symptr->flags & FLAG_PACK ? "pack" : "unpack" );
+        }
+       continue;
+      }
+      
+      /* for '(', skip to ')' */
+      if (code == '(') {  
+        if( isDIGIT(*patptr) || *patptr == '*' || *patptr == '[' )
+          Perl_croak(aTHX_ "()-group starts with a count in %s",
+                     symptr->flags & FLAG_PACK ? "pack" : "unpack" );
+        symptr->grpbeg = patptr;
+        patptr = 1 + ( symptr->grpend = group_end(patptr, patend, ')') );
+        if( symptr->level >= MAX_SUB_TEMPLATE_LEVEL )
+         Perl_croak(aTHX_ "Too deeply nested ()-groups in %s",
+                     symptr->flags & FLAG_PACK ? "pack" : "unpack" );
+      }
+
+      /* test for '!' modifier */
+      if (patptr < patend && *patptr == '!') {
+       static const char natstr[] = "sSiIlLxX";
+        patptr++;              
+        if (strchr(natstr, code))
+         code |= TYPE_IS_SHRIEKING;
+        else
+         Perl_croak(aTHX_ "'!' allowed only after types %s in pack/unpack",
+                     natstr, symptr->flags & FLAG_PACK ? "pack" : "unpack" );
+      }
+
+      /* look for count and/or / */ 
+      if (patptr < patend) {
+       if (isDIGIT(*patptr)) {
+         patptr = get_num( patptr, &symptr->length );
+          symptr->howlen = e_number;
+
+        } else if (*patptr == '*') {
+          patptr++;
+          symptr->howlen = e_star;
+
+        } else if (*patptr == '[') {
+          char* lenptr = ++patptr;            
+          symptr->howlen = e_number;
+          patptr = group_end( patptr, patend, ']' ) + 1;
+          /* what kind of [] is it? */
+          if (isDIGIT(*lenptr)) {
+            lenptr = get_num( lenptr, &symptr->length );
+            if( *lenptr != ']' )
+              Perl_croak(aTHX_ "Malformed integer in [] in %s",
+                         symptr->flags & FLAG_PACK ? "pack" : "unpack");
+          } else {
+            tempsym_t savsym = *symptr;
+            symptr->patend = patptr-1;
+            symptr->patptr = lenptr;
+            savsym.length = measure_struct(symptr);
+            *symptr = savsym;
+          }
+        } else {
+          symptr->howlen = e_no_len;
+          symptr->length = 1;
+        }
+
+        /* try to find / */
+        while (patptr < patend) {
+          if (isSPACE(*patptr))
+            patptr++;
+          else if (*patptr == '#') {
+            patptr++;
+            while (patptr < patend && *patptr != '\n')
+             patptr++;
+            if (patptr < patend)
+             patptr++;
+          } else {
+            if( *patptr == '/' ){ 
+              symptr->flags |= FLAG_SLASH;
+              patptr++;
+              if( patptr < patend &&
+                  (isDIGIT(*patptr) || *patptr == '*' || *patptr == '[') )
+                Perl_croak(aTHX_ "'/' does not take a repeat count in %s",
+                           symptr->flags & FLAG_PACK ? "pack" : "unpack" );
+            }
+            break;
+         }
        }
-       else
-           return pat;
+      } else {
+        /* at end - no count, no / */
+        symptr->howlen = e_no_len;
+        symptr->length = 1;
+      }
+
+      symptr->code = code;
+      symptr->patptr = patptr; 
+      return TRUE;
     }
-    return pat;
+  }
+  symptr->patptr = patptr; 
+  return FALSE;
 }
 
 /*
@@ -418,13 +500,26 @@ The engine implementing unpack() Perl function.
 I32
 Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *strbeg, char *strend, char **new_s, I32 ocnt, U32 flags)
 {
+    tempsym_t sym = { 0 };
+    sym.patptr = pat;
+    sym.patend = patend;
+    sym.flags  = flags;
+
+    return unpack_rec(&sym, s, s, strend, NULL );
+}
+
+STATIC
+I32
+S_unpack_rec(pTHX_ register tempsym_t* symptr, register char *s, char *strbeg, char *strend, char **new_s )
+{
     dSP;
     I32 datumtype;
-    register I32 len;
+    register I32 len = 0;
     register I32 bits = 0;
     register char *str;
     SV *sv;
     I32 start_sp_offset = SP - PL_stack_base;
+    howlen_t howlen;
 
     /* These must not be in registers: */
     short ashort;
@@ -446,65 +541,45 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *
     UV cuv = 0;
     NV cdouble = 0.0;
     const int bits_in_uv = 8 * sizeof(cuv);
-    int commas = 0;
-    int star;          /* 1 if count is *, -1 if no count given, -2 for / */
-#ifdef PERL_NATINT_PACK
-    int natint;                /* native integer */
-    int unatint;       /* unsigned native integer */
-#endif
+    char* strrelbeg = s;
+    bool beyond = FALSE;
+    bool unpack_only_one = (symptr->flags & FLAG_UNPACK_ONLY_ONE) != 0;
+
     IV aiv;
     UV auv;
     NV anv;
 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
     long double aldouble;
 #endif
-    bool do_utf8 = (flags & UNPACK_DO_UTF8) != 0;
 
-    while ((pat = next_symbol(pat, patend)) < patend) {
-       datumtype = *pat++ & 0xFF;
-#ifdef PERL_NATINT_PACK
-       natint = 0;
-#endif
+    while (next_symbol(symptr)) {
+        datumtype = symptr->code;
        /* do first one only unless in list context
           / is implemented by unpacking the count, then poping it from the
           stack, so must check that we're not in the middle of a /  */
-        if ( (flags & UNPACK_ONLY_ONE)
+        if ( unpack_only_one
             && (SP - PL_stack_base == start_sp_offset + 1)
-            && (datumtype != '/') )
+            && (datumtype != '/') )   /* XXX can this be omitted */
             break;
-       if (*pat == '!') {
-           static const char natstr[] = "sSiIlLxX";
-
-           if (strchr(natstr, datumtype)) {
-               if (datumtype == 'x' || datumtype == 'X') {
-                   datumtype |= TYPE_IS_SHRIEKING;
-               } else {                /* XXXX Should be redone similarly! */
-#ifdef PERL_NATINT_PACK
-                   natint = 1;
-#endif
-               }
-               pat++;
-           }
-           else
-               Perl_croak(aTHX_ "'!' allowed only after types %s", natstr);
-       }
-       len = find_count(&pat, patend, &star);
-       if (star > 0)
-               len = strend - strbeg;  /* long enough */
-       else if (star < 0)              /* No explicit len */
-               len = datumtype != '@';
+
+        switch( howlen = symptr->howlen ){
+        case e_no_len:
+       case e_number:
+           len = symptr->length;
+           break;
+        case e_star:
+           len = strend - strbeg;      /* long enough */          
+           break;
+        }
 
       redo_switch:
+        beyond = s >= strend;
        switch(datumtype) {
        default:
-           Perl_croak(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
-       case ',': /* grandfather in commas but with a warning */
-           if (commas++ == 0 && ckWARN(WARN_UNPACK))
-               Perl_warner(aTHX_ packWARN(WARN_UNPACK),
-                           "Invalid type in unpack: '%c'", (int)datumtype);
-           break;
+           Perl_croak(aTHX_ "Invalid type '%c' in unpack", (int)datumtype );
+
        case '%':
-           if (len == 1 && pat[-1] != '1' && pat[-1] != ']')
+           if (howlen == e_no_len)
                len = 16;               /* len is not specified */
            checksum = len;
            cuv = 0;
@@ -513,35 +588,27 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *
            break;
        case '(':
        {
-           char *beg = pat;
            char *ss = s;               /* Move from register */
-
-           if (star >= 0)
-               Perl_croak(aTHX_ "()-group starts with a count");
-           aptr = group_end(beg, patend, ')');
-           pat = aptr + 1;
-           if (star != -2) {
-               len = find_count(&pat, patend, &star);
-               if (star < 0)           /* No count */
-                   len = 1;
-               else if (star > 0)      /* Star */
-                   len = strend - strbeg; /* long enough? */
-           }
+            tempsym_t savsym = *symptr;
+            symptr->patend = savsym.grpend;
+            symptr->level++;
            PUTBACK;
            while (len--) {
-               unpack_str(beg, aptr, ss, strbeg, strend, &ss,
-                          ocnt + SP - PL_stack_base - start_sp_offset, flags);
-               if (star > 0 && ss == strend)
-                   break;              /* No way to continue */
+               symptr->patptr = savsym.grpbeg;
+               unpack_rec(symptr, ss, strbeg, strend, &ss );
+                if (ss == strend && savsym.howlen == e_star)
+                   break; /* No way to continue */
            }
            SPAGAIN;
            s = ss;
+            savsym.flags = symptr->flags;
+            *symptr = savsym;
            break;
        }
        case '@':
-           if (len > strend - strbeg)
-               Perl_croak(aTHX_ "@ outside of string");
-           s = strbeg + len;
+           if (len > strend - strrelbeg)
+               Perl_croak(aTHX_ "'@' outside of string in unpack");
+           s = strrelbeg + len;
            break;
        case 'X' | TYPE_IS_SHRIEKING:
            if (!len)                   /* Avoid division by 0 */
@@ -550,7 +617,7 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *
            /* FALL THROUGH */
        case 'X':
            if (len > s - strbeg)
-               Perl_croak(aTHX_ "X outside of string");
+               Perl_croak(aTHX_ "'X' outside of string in unpack" );
            s -= len;
            break;
        case 'x' | TYPE_IS_SHRIEKING:
@@ -564,20 +631,12 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *
            /* FALL THROUGH */
        case 'x':
            if (len > strend - s)
-               Perl_croak(aTHX_ "x outside of string");
+               Perl_croak(aTHX_ "'x' outside of string in unpack");
            s += len;
            break;
        case '/':
-           if (ocnt + SP - PL_stack_base - start_sp_offset <= 0)
-               Perl_croak(aTHX_ "/ must follow a numeric type");
-           datumtype = *pat++;
-           if (*pat == '*')
-               pat++;          /* ignore '*' for compatibility with pack */
-           if (isDIGIT(*pat))
-               Perl_croak(aTHX_ "/ cannot take a count" );
-           len = POPi;
-           star = -2;
-           goto redo_switch;
+           Perl_croak(aTHX_ "'/' must follow a numeric type in unpack");
+            break;
        case 'A':
        case 'Z':
        case 'a':
@@ -587,13 +646,13 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *
                goto uchar_checksum;
            sv = NEWSV(35, len);
            sv_setpvn(sv, s, len);
-           if (datumtype == 'A' || datumtype == 'Z') {
+           if (len > 0 && (datumtype == 'A' || datumtype == 'Z')) {
                aptr = s;       /* borrow register */
                if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
                    s = SvPVX(sv);
                    while (*s)
                        s++;
-                   if (star > 0) /* exact for 'Z*' */
+                   if (howlen == e_star) /* exact for 'Z*' */
                        len = s - SvPVX(sv) + 1;
                }
                else {          /* 'A' strips both nulls and spaces */
@@ -610,7 +669,7 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *
            break;
        case 'B':
        case 'b':
-           if (star > 0 || len > (strend - s) * 8)
+           if (howlen == e_star || len > (strend - s) * 8)
                len = (strend - s) * 8;
            if (checksum) {
                if (!PL_bitcount) {
@@ -676,7 +735,7 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *
            break;
        case 'H':
        case 'h':
-           if (star > 0 || len > (strend - s) * 2)
+           if (howlen == e_star || len > (strend - s) * 2)
                len = (strend - s) * 2;
            sv = NEWSV(35, len + 1);
            SvCUR_set(sv, len);
@@ -720,7 +779,7 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *
                }
            }
            else {
-                if (len && (flags & UNPACK_ONLY_ONE))
+                if (len && unpack_only_one)
                     len = 1;
                EXTEND(SP, len);
                EXTEND_MORTAL(len);
@@ -737,7 +796,7 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *
        case 'C':
        unpack_C: /* unpack U will jump here if not UTF-8 */
             if (len == 0) {
-               do_utf8 = FALSE;
+                symptr->flags &= ~FLAG_UNPACK_DO_UTF8;
                break;
            }
            if (len > strend - s)
@@ -750,7 +809,7 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *
                }
            }
            else {
-                if (len && (flags & UNPACK_ONLY_ONE))
+                if (len && unpack_only_one)
                     len = 1;
                EXTEND(SP, len);
                EXTEND_MORTAL(len);
@@ -764,10 +823,10 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *
            break;
        case 'U':
            if (len == 0) {
-               do_utf8 = TRUE;
+                symptr->flags |= FLAG_UNPACK_DO_UTF8;
                break;
            }
-           if (!do_utf8)
+           if ((symptr->flags & FLAG_UNPACK_DO_UTF8) == 0)
                 goto unpack_C;
            if (len > strend - s)
                len = strend - s;
@@ -784,7 +843,7 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *
                }
            }
            else {
-                if (len && (flags & UNPACK_ONLY_ONE))
+                if (len && unpack_only_one)
                     len = 1;
                EXTEND(SP, len);
                EXTEND_MORTAL(len);
@@ -799,161 +858,160 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *
                }
            }
            break;
-       case 's':
-#if SHORTSIZE == SIZE16
-           along = (strend - s) / SIZE16;
-#else
-           along = (strend - s) / (natint ? sizeof(short) : SIZE16);
-#endif
+       case 's' | TYPE_IS_SHRIEKING:
+#if SHORTSIZE != SIZE16
+           along = (strend - s) / sizeof(short);
            if (len > along)
                len = along;
            if (checksum) {
-#if SHORTSIZE != SIZE16
-               if (natint) {
-                   short ashort;
-                   while (len-- > 0) {
-                       COPYNN(s, &ashort, sizeof(short));
-                       s += sizeof(short);
-                       if (checksum > bits_in_uv)
-                           cdouble += (NV)ashort;
-                       else
-                           cuv += ashort;
+               short ashort;
+               while (len-- > 0) {
+                    COPYNN(s, &ashort, sizeof(short));
+                     s += sizeof(short);
+                     if (checksum > bits_in_uv)
+                         cdouble += (NV)ashort;
+                     else
+                         cuv += ashort;
 
-                   }
                }
-               else
+           }
+           else {
+                if (len && unpack_only_one)
+                    len = 1;
+               EXTEND(SP, len);
+               EXTEND_MORTAL(len);
+               short ashort;
+               while (len-- > 0) {
+                   COPYNN(s, &ashort, sizeof(short));
+                   s += sizeof(short);
+                   sv = NEWSV(38, 0);
+                   sv_setiv(sv, (IV)ashort);
+                   PUSHs(sv_2mortal(sv));
+               }
+           }
+           break;
+#else
+           /* Fallthrough! */
 #endif
-                {
-                   while (len-- > 0) {
-                       COPY16(s, &ashort);
+       case 's':
+           along = (strend - s) / SIZE16;
+           if (len > along)
+               len = along;
+           if (checksum) {
+               while (len-- > 0) {
+                   COPY16(s, &ashort);
 #if SHORTSIZE > SIZE16
-                       if (ashort > 32767)
-                         ashort -= 65536;
+                   if (ashort > 32767)
+                       ashort -= 65536;
 #endif
-                       s += SIZE16;
-                       if (checksum > bits_in_uv)
-                           cdouble += (NV)ashort;
-                       else
-                           cuv += ashort;
-                   }
+                   s += SIZE16;
+                   if (checksum > bits_in_uv)
+                       cdouble += (NV)ashort;
+                   else
+                       cuv += ashort;
                }
            }
            else {
-                if (len && (flags & UNPACK_ONLY_ONE))
+                if (len && unpack_only_one)
                     len = 1;
                EXTEND(SP, len);
                EXTEND_MORTAL(len);
-#if SHORTSIZE != SIZE16
-               if (natint) {
-                   short ashort;
-                   while (len-- > 0) {
-                       COPYNN(s, &ashort, sizeof(short));
-                       s += sizeof(short);
-                       sv = NEWSV(38, 0);
-                       sv_setiv(sv, (IV)ashort);
-                       PUSHs(sv_2mortal(sv));
-                   }
-               }
-               else
-#endif
-                {
-                   while (len-- > 0) {
-                       COPY16(s, &ashort);
+
+               while (len-- > 0) {
+                   COPY16(s, &ashort);
 #if SHORTSIZE > SIZE16
-                       if (ashort > 32767)
-                         ashort -= 65536;
+                   if (ashort > 32767)
+                       ashort -= 65536;
 #endif
-                       s += SIZE16;
-                       sv = NEWSV(38, 0);
-                       sv_setiv(sv, (IV)ashort);
-                       PUSHs(sv_2mortal(sv));
-                   }
+                   s += SIZE16;
+                   sv = NEWSV(38, 0);
+                   sv_setiv(sv, (IV)ashort);
+                   PUSHs(sv_2mortal(sv));
                }
            }
            break;
+       case 'S' | TYPE_IS_SHRIEKING:
+#if SHORTSIZE != SIZE16
+           along = (strend - s) / SIZE16;
+           if (len > along)
+               len = along;
+           if (checksum) {
+               unsigned short aushort;
+               while (len-- > 0) {
+                   COPYNN(s, &aushort, sizeof(unsigned short));
+                   s += sizeof(unsigned short);
+                   if (checksum > bits_in_uv)
+                       cdouble += (NV)aushort;
+                   else
+                       cuv += aushort;
+               }
+           }
+           else {
+                if (len && unpack_only_one)
+                    len = 1;
+               EXTEND(SP, len);
+               EXTEND_MORTAL(len);
+               while (len-- > 0) {
+                   unsigned short aushort;
+                   COPYNN(s, &aushort, sizeof(unsigned short));
+                   s += sizeof(unsigned short);
+                   sv = NEWSV(39, 0);
+                   sv_setiv(sv, (UV)aushort);
+                   PUSHs(sv_2mortal(sv));
+               }
+           }
+           break;
+#else
+            /* Fallhrough! */
+#endif
        case 'v':
        case 'n':
        case 'S':
-#if SHORTSIZE == SIZE16
            along = (strend - s) / SIZE16;
-#else
-           unatint = natint && datumtype == 'S';
-           along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
-#endif
            if (len > along)
                len = along;
            if (checksum) {
-#if SHORTSIZE != SIZE16
-               if (unatint) {
-                   unsigned short aushort;
-                   while (len-- > 0) {
-                       COPYNN(s, &aushort, sizeof(unsigned short));
-                       s += sizeof(unsigned short);
-                       if (checksum > bits_in_uv)
-                           cdouble += (NV)aushort;
-                       else
-                           cuv += aushort;
-                   }
-               }
-               else
-#endif
-                {
-                   while (len-- > 0) {
-                       COPY16(s, &aushort);
-                       s += SIZE16;
+               while (len-- > 0) {
+                   COPY16(s, &aushort);
+                   s += SIZE16;
 #ifdef HAS_NTOHS
-                       if (datumtype == 'n')
-                           aushort = PerlSock_ntohs(aushort);
+                   if (datumtype == 'n')
+                       aushort = PerlSock_ntohs(aushort);
 #endif
 #ifdef HAS_VTOHS
-                       if (datumtype == 'v')
-                           aushort = vtohs(aushort);
+                   if (datumtype == 'v')
+                       aushort = vtohs(aushort);
 #endif
-                       if (checksum > bits_in_uv)
-                           cdouble += (NV)aushort;
-                       else
-                           cuv += aushort;
-                   }
+                   if (checksum > bits_in_uv)
+                       cdouble += (NV)aushort;
+                   else
+                       cuv += aushort;
                }
            }
            else {
-                if (len && (flags & UNPACK_ONLY_ONE))
+                if (len && unpack_only_one)
                     len = 1;
                EXTEND(SP, len);
                EXTEND_MORTAL(len);
-#if SHORTSIZE != SIZE16
-               if (unatint) {
-                   unsigned short aushort;
-                   while (len-- > 0) {
-                       COPYNN(s, &aushort, sizeof(unsigned short));
-                       s += sizeof(unsigned short);
-                       sv = NEWSV(39, 0);
-                       sv_setiv(sv, (UV)aushort);
-                       PUSHs(sv_2mortal(sv));
-                   }
-               }
-               else
-#endif
-                {
-                   while (len-- > 0) {
-                       COPY16(s, &aushort);
-                       s += SIZE16;
-                       sv = NEWSV(39, 0);
+               while (len-- > 0) {
+                   COPY16(s, &aushort);
+                   s += SIZE16;
+                   sv = NEWSV(39, 0);
 #ifdef HAS_NTOHS
-                       if (datumtype == 'n')
-                           aushort = PerlSock_ntohs(aushort);
+                   if (datumtype == 'n')
+                       aushort = PerlSock_ntohs(aushort);
 #endif
 #ifdef HAS_VTOHS
-                       if (datumtype == 'v')
-                           aushort = vtohs(aushort);
+                   if (datumtype == 'v')
+                       aushort = vtohs(aushort);
 #endif
-                       sv_setiv(sv, (UV)aushort);
-                       PUSHs(sv_2mortal(sv));
-                   }
+                   sv_setiv(sv, (UV)aushort);
+                   PUSHs(sv_2mortal(sv));
                }
            }
            break;
        case 'i':
+       case 'i' | TYPE_IS_SHRIEKING:
            along = (strend - s) / sizeof(int);
            if (len > along)
                len = along;
@@ -968,7 +1026,7 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *
                }
            }
            else {
-                if (len && (flags & UNPACK_ONLY_ONE))
+                if (len && unpack_only_one)
                     len = 1;
                EXTEND(SP, len);
                EXTEND_MORTAL(len);
@@ -1007,6 +1065,7 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *
            }
            break;
        case 'I':
+       case 'I' | TYPE_IS_SHRIEKING:
            along = (strend - s) / sizeof(unsigned int);
            if (len > along)
                len = along;
@@ -1021,7 +1080,7 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *
                }
            }
            else {
-                if (len && (flags & UNPACK_ONLY_ONE))
+                if (len && unpack_only_one)
                     len = 1;
                EXTEND(SP, len);
                EXTEND_MORTAL(len);
@@ -1056,7 +1115,7 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *
                }
            }
            else {
-                if (len && (flags & UNPACK_ONLY_ONE))
+                if (len && unpack_only_one)
                     len = 1;
                EXTEND(SP, len);
                EXTEND_MORTAL(len);
@@ -1084,7 +1143,7 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *
                }
            }
            else {
-                if (len && (flags & UNPACK_ONLY_ONE))
+                if (len && unpack_only_one)
                     len = 1;
                EXTEND(SP, len);
                EXTEND_MORTAL(len);
@@ -1097,160 +1156,157 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *
                }
            }
            break;
-       case 'l':
-#if LONGSIZE == SIZE32
-           along = (strend - s) / SIZE32;
-#else
-           along = (strend - s) / (natint ? sizeof(long) : SIZE32);
-#endif
+       case 'l' | TYPE_IS_SHRIEKING:
+#if LONGSIZE != SIZE32
+           along = (strend - s) / sizeof(long);
            if (len > along)
                len = along;
            if (checksum) {
-#if LONGSIZE != SIZE32
-               if (natint) {
-                   while (len-- > 0) {
-                       COPYNN(s, &along, sizeof(long));
-                       s += sizeof(long);
-                       if (checksum > bits_in_uv)
-                           cdouble += (NV)along;
-                       else
-                           cuv += along;
-                   }
+               while (len-- > 0) {
+                   COPYNN(s, &along, sizeof(long));
+                   s += sizeof(long);
+                   if (checksum > bits_in_uv)
+                       cdouble += (NV)along;
+                   else
+                       cuv += along;
                }
-               else
+           }
+           else {
+                if (len && unpack_only_one)
+                    len = 1;
+               EXTEND(SP, len);
+               EXTEND_MORTAL(len);
+               while (len-- > 0) {
+                   COPYNN(s, &along, sizeof(long));
+                   s += sizeof(long);
+                   sv = NEWSV(42, 0);
+                   sv_setiv(sv, (IV)along);
+                   PUSHs(sv_2mortal(sv));
+               }
+           }
+           break;
+#else
+           /* Fallthrough! */
 #endif
-                {
-                   while (len-- > 0) {
+       case 'l':
+           along = (strend - s) / SIZE32;
+           if (len > along)
+               len = along;
+           if (checksum) {
+               while (len-- > 0) {
 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
-                       I32 along;
+                   I32 along;
 #endif
-                       COPY32(s, &along);
+                   COPY32(s, &along);
 #if LONGSIZE > SIZE32
-                       if (along > 2147483647)
-                         along -= 4294967296;
+                   if (along > 2147483647)
+                       along -= 4294967296;
 #endif
-                       s += SIZE32;
-                       if (checksum > bits_in_uv)
-                           cdouble += (NV)along;
-                       else
-                           cuv += along;
-                   }
+                   s += SIZE32;
+                   if (checksum > bits_in_uv)
+                       cdouble += (NV)along;
+                   else
+                       cuv += along;
                }
            }
            else {
-                if (len && (flags & UNPACK_ONLY_ONE))
+                if (len && unpack_only_one)
                     len = 1;
                EXTEND(SP, len);
                EXTEND_MORTAL(len);
-#if LONGSIZE != SIZE32
-               if (natint) {
-                   while (len-- > 0) {
-                       COPYNN(s, &along, sizeof(long));
-                       s += sizeof(long);
-                       sv = NEWSV(42, 0);
-                       sv_setiv(sv, (IV)along);
-                       PUSHs(sv_2mortal(sv));
-                   }
-               }
-               else
-#endif
-                {
-                   while (len-- > 0) {
+               while (len-- > 0) {
 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
-                       I32 along;
+                   I32 along;
 #endif
-                       COPY32(s, &along);
+                   COPY32(s, &along);
 #if LONGSIZE > SIZE32
-                       if (along > 2147483647)
-                         along -= 4294967296;
+                   if (along > 2147483647)
+                       along -= 4294967296;
 #endif
-                       s += SIZE32;
-                       sv = NEWSV(42, 0);
-                       sv_setiv(sv, (IV)along);
-                       PUSHs(sv_2mortal(sv));
-                   }
+                   s += SIZE32;
+                   sv = NEWSV(42, 0);
+                   sv_setiv(sv, (IV)along);
+                   PUSHs(sv_2mortal(sv));
                }
            }
            break;
+       case 'L' | TYPE_IS_SHRIEKING:
+#if LONGSIZE != SIZE32
+           along = (strend - s) / sizeof(unsigned long);
+           if (len > along)
+               len = along;
+           if (checksum) {
+               while (len-- > 0) {
+                   unsigned long aulong;
+                   COPYNN(s, &aulong, sizeof(unsigned long));
+                   s += sizeof(unsigned long);
+                   if (checksum > bits_in_uv)
+                       cdouble += (NV)aulong;
+                   else
+                       cuv += aulong;
+               }
+           }
+           else {
+                if (len && unpack_only_one)
+                    len = 1;
+               EXTEND(SP, len);
+               EXTEND_MORTAL(len);
+               while (len-- > 0) {
+                   unsigned long aulong;
+                   COPYNN(s, &aulong, sizeof(unsigned long));
+                   s += sizeof(unsigned long);
+                   sv = NEWSV(43, 0);
+                   sv_setuv(sv, (UV)aulong);
+                   PUSHs(sv_2mortal(sv));
+               }
+           }
+           break;
+#else
+            /* Fall through! */
+#endif
        case 'V':
        case 'N':
        case 'L':
-#if LONGSIZE == SIZE32
            along = (strend - s) / SIZE32;
-#else
-           unatint = natint && datumtype == 'L';
-           along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
-#endif
            if (len > along)
                len = along;
            if (checksum) {
-#if LONGSIZE != SIZE32
-               if (unatint) {
-                   unsigned long aulong;
-                   while (len-- > 0) {
-                       COPYNN(s, &aulong, sizeof(unsigned long));
-                       s += sizeof(unsigned long);
-                       if (checksum > bits_in_uv)
-                           cdouble += (NV)aulong;
-                       else
-                           cuv += aulong;
-                   }
-               }
-               else
-#endif
-                {
-                   while (len-- > 0) {
-                       COPY32(s, &aulong);
-                       s += SIZE32;
+               while (len-- > 0) {
+                   COPY32(s, &aulong);
+                   s += SIZE32;
 #ifdef HAS_NTOHL
-                       if (datumtype == 'N')
-                           aulong = PerlSock_ntohl(aulong);
+                   if (datumtype == 'N')
+                       aulong = PerlSock_ntohl(aulong);
 #endif
 #ifdef HAS_VTOHL
-                       if (datumtype == 'V')
-                           aulong = vtohl(aulong);
+                   if (datumtype == 'V')
+                       aulong = vtohl(aulong);
 #endif
-                       if (checksum > bits_in_uv)
-                           cdouble += (NV)aulong;
-                       else
-                           cuv += aulong;
-                   }
+                   if (checksum > bits_in_uv)
+                       cdouble += (NV)aulong;
+                   else
+                       cuv += aulong;
                }
            }
            else {
-                if (len && (flags & UNPACK_ONLY_ONE))
+                if (len && unpack_only_one)
                     len = 1;
                EXTEND(SP, len);
                EXTEND_MORTAL(len);
-#if LONGSIZE != SIZE32
-               if (unatint) {
-                   unsigned long aulong;
-                   while (len-- > 0) {
-                       COPYNN(s, &aulong, sizeof(unsigned long));
-                       s += sizeof(unsigned long);
-                       sv = NEWSV(43, 0);
-                       sv_setuv(sv, (UV)aulong);
-                       PUSHs(sv_2mortal(sv));
-                   }
-               }
-               else
-#endif
-                {
-                   while (len-- > 0) {
-                       COPY32(s, &aulong);
-                       s += SIZE32;
+               while (len-- > 0) {
+                   COPY32(s, &aulong);
+                   s += SIZE32;
 #ifdef HAS_NTOHL
-                       if (datumtype == 'N')
-                           aulong = PerlSock_ntohl(aulong);
+                   if (datumtype == 'N')
+                       aulong = PerlSock_ntohl(aulong);
 #endif
 #ifdef HAS_VTOHL
-                       if (datumtype == 'V')
-                           aulong = vtohl(aulong);
+                   if (datumtype == 'V')
+                       aulong = vtohl(aulong);
 #endif
-                       sv = NEWSV(43, 0);
-                       sv_setuv(sv, (UV)aulong);
-                       PUSHs(sv_2mortal(sv));
-                   }
+                   sv = NEWSV(43, 0);
+                   sv_setuv(sv, (UV)aulong);
+                   PUSHs(sv_2mortal(sv));
                }
            }
            break;
@@ -1274,7 +1330,7 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *
            }
            break;
        case 'w':
-            if (len && (flags & UNPACK_ONLY_ONE))
+            if (len && unpack_only_one)
                 len = 1;
            EXTEND(SP, len);
            EXTEND_MORTAL(len);
@@ -1315,12 +1371,12 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *
                    }
                }
                if ((s >= strend) && bytes)
-                   Perl_croak(aTHX_ "Unterminated compressed integer");
+                   Perl_croak(aTHX_ "Unterminated compressed integer in unpack");
            }
            break;
        case 'P':
-           if (star > 0)
-               Perl_croak(aTHX_ "P must have an explicit size");
+           if (symptr->howlen == e_star)
+               Perl_croak(aTHX_ "'P' must have an explicit size in unpack");
            EXTEND(SP, 1);
            if (sizeof(char*) > strend - s)
                break;
@@ -1349,7 +1405,7 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *
                }
            }
             else {
-                if (len && (flags & UNPACK_ONLY_ONE))
+                if (len && unpack_only_one)
                     len = 1;
                 EXTEND(SP, len);
                 EXTEND_MORTAL(len);
@@ -1384,7 +1440,7 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *
                }
            }
             else {
-                if (len && (flags & UNPACK_ONLY_ONE))
+                if (len && unpack_only_one)
                     len = 1;
                 EXTEND(SP, len);
                 EXTEND_MORTAL(len);
@@ -1418,7 +1474,7 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *
                }
            }
            else {
-                if (len && (flags & UNPACK_ONLY_ONE))
+                if (len && unpack_only_one)
                     len = 1;
                EXTEND(SP, len);
                EXTEND_MORTAL(len);
@@ -1443,7 +1499,7 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *
                }
            }
            else {
-                if (len && (flags & UNPACK_ONLY_ONE))
+                if (len && unpack_only_one)
                     len = 1;
                EXTEND(SP, len);
                EXTEND_MORTAL(len);
@@ -1468,7 +1524,7 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *
                }
            }
            else {
-                if (len && (flags & UNPACK_ONLY_ONE))
+                if (len && unpack_only_one)
                     len = 1;
                EXTEND(SP, len);
                EXTEND_MORTAL(len);
@@ -1494,7 +1550,7 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *
                }
            }
            else {
-                if (len && (flags & UNPACK_ONLY_ONE))
+                if (len && unpack_only_one)
                     len = 1;
                EXTEND(SP, len);
                EXTEND_MORTAL(len);
@@ -1568,11 +1624,12 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *
            XPUSHs(sv_2mortal(sv));
            break;
        }
+
        if (checksum) {
            sv = NEWSV(42, 0);
            if (strchr("fFdD", datumtype) ||
              (checksum > bits_in_uv &&
-              strchr("csSiIlLnNUvVqQjJ", datumtype)) ) {
+              strchr("csSiIlLnNUvVqQjJ", datumtype&0xFF)) ) {
                NV trouble;
 
                 adouble = (NV) (1 << (checksum & 15));
@@ -1588,7 +1645,6 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *
            else {
                if (checksum < bits_in_uv) {
                    UV mask = ((UV)1 << checksum) - 1;
-
                    cuv &= mask;
                }
                sv_setuv(sv, cuv);
@@ -1596,7 +1652,30 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *
            XPUSHs(sv_2mortal(sv));
            checksum = 0;
        }
+    
+        if (symptr->flags & FLAG_SLASH){
+            if (SP - PL_stack_base - start_sp_offset <= 0)
+                Perl_croak(aTHX_ "'/' must follow a numeric type in unpack");
+            if( next_symbol(symptr) ){
+              if( symptr->howlen == e_number )
+               Perl_croak(aTHX_ "Count after length/code in unpack" );
+              if( beyond ){
+               /* ...end of char buffer then no decent length available */
+               Perl_croak(aTHX_ "length/code after end of string in unpack" );
+              } else {
+               /* take top of stack (hope it's numeric) */
+                len = POPi;
+                if( len < 0 )
+                    Perl_croak(aTHX_ "Negative '/' count in unpack" );
+              }
+            } else {
+               Perl_croak(aTHX_ "Code missing after '/' in unpack" );
+            }
+            datumtype = symptr->code;
+           goto redo_switch;
+        }
     }
+
     if (new_s)
        *new_s = s;
     PUTBACK;
@@ -1626,8 +1705,9 @@ PP(pp_unpack)
 
     PUTBACK;
     cnt = unpack_str(pat, patend, s, s, strend, NULL, 0,
-                    ((gimme == G_SCALAR) ? UNPACK_ONLY_ONE : 0)
-                    | (DO_UTF8(right) ? UNPACK_DO_UTF8 : 0));
+                    ((gimme == G_SCALAR) ? FLAG_UNPACK_ONLY_ONE : 0)
+                    | (DO_UTF8(right) ? FLAG_UNPACK_DO_UTF8 : 0));
+
     SPAGAIN;
     if ( !cnt && gimme == G_SCALAR )
        PUSHs(&PL_sv_undef);
@@ -1738,7 +1818,7 @@ S_div128(pTHX_ SV *pnum, bool *done)
   return (m);
 }
 
-#define PACK_CHILD     0x1
+
 
 /*
 =for apidoc pack_cat
@@ -1747,18 +1827,31 @@ The engine implementing pack() Perl function.
 
 =cut */
 
+
 void
 Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beglist, SV **endlist, SV ***next_in_list, U32 flags)
 {
+    tempsym_t sym = { 0 };
+    sym.patptr = pat;
+    sym.patend = patend;
+    sym.flags  = flags;
+
+    (void)pack_rec( cat, &sym, beglist, endlist );
+}
+
+
+STATIC
+SV **
+S_pack_rec(pTHX_ SV *cat, register tempsym_t* symptr, register SV **beglist, SV **endlist )
+{
     register I32 items;
     STRLEN fromlen;
-    register I32 len;
-    I32 datumtype;
+    register I32 len = 0;
     SV *fromstr;
     /*SUPPRESS 442*/
     static char null10[] = {0,0,0,0,0,0,0,0,0,0};
     static char *space10 = "          ";
-    int star;
+    bool found;
 
     /* These must not be in registers: */
     char achar;
@@ -1780,65 +1873,58 @@ Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beg
     char *aptr;
     float afloat;
     double adouble;
-    int commas = 0;
-#ifdef PERL_NATINT_PACK
-    int natint;                /* native integer */
-#endif
+    int strrelbeg = SvCUR(cat);
+    tempsym_t lookahead;
 
     items = endlist - beglist;
+    found = next_symbol( symptr );
+
 #ifndef PACKED_IS_OCTETS
-    pat = next_symbol(pat, patend);
-    if (pat < patend && *pat == 'U' && !flags)
+    if (symptr->level == 0 && found && symptr->code == 'U' ){
        SvUTF8_on(cat);
+    }
 #endif
-    while ((pat = next_symbol(pat, patend)) < patend) {
+
+    while (found) {
        SV *lengthcode = Nullsv;
 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *beglist++ : &PL_sv_no)
-       datumtype = *pat++ & 0xFF;
-#ifdef PERL_NATINT_PACK
-       natint = 0;
-#endif
-        if (*pat == '!') {
-           static const char natstr[] = "sSiIlLxX";
-
-           if (strchr(natstr, datumtype)) {
-               if (datumtype == 'x' || datumtype == 'X') {
-                   datumtype |= TYPE_IS_SHRIEKING;
-               } else {                /* XXXX Should be redone similarly! */
-#ifdef PERL_NATINT_PACK
-                   natint = 1;
-#endif
-               }
-               pat++;
-           }
-           else
-               Perl_croak(aTHX_ "'!' allowed only after types %s", natstr);
-       }
-       len = find_count(&pat, patend, &star);
-       if (star > 0)                   /* Count is '*' */
-           len = strchr("@Xxu", datumtype) ? 0 : items;
-       else if (star < 0)              /* Default len */
-           len = 1;
-       if (*pat == '/') {              /* doing lookahead how... */
-           ++pat;
-           if ((*pat != 'a' && *pat != 'A' && *pat != 'Z') || pat[1] != '*')
-               Perl_croak(aTHX_ "/ must be followed by a*, A* or Z*");
-           lengthcode = sv_2mortal(newSViv(sv_len(items > 0
+
+        I32 datumtype = symptr->code;
+        howlen_t howlen;
+
+        switch( howlen = symptr->howlen ){
+        case e_no_len:
+       case e_number:
+           len = symptr->length;
+           break;
+        case e_star:
+           len = strchr("@Xxu", datumtype) ? 0 : items; 
+           break;
+        }
+
+        /* Look ahead for next symbol. Do we have code/code? */
+        lookahead = *symptr;
+        found = next_symbol(&lookahead);
+       if ( symptr->flags & FLAG_SLASH ) {
+           if (found){
+               if ( 0 == strchr( "aAZ", lookahead.code ) ||
+                     e_star != lookahead.howlen )
+                   Perl_croak(aTHX_ "'/' must be followed by 'a*', 'A*' or 'Z*' in pack");
+               lengthcode = sv_2mortal(newSViv(sv_len(items > 0
                                                   ? *beglist : &PL_sv_no)
-                                            + (*pat == 'Z' ? 1 : 0)));
+                                           + (lookahead.code == 'Z' ? 1 : 0)));
+           } else {
+               Perl_croak(aTHX_ "Code missing after '/' in pack");
+            }
        }
+
        switch(datumtype) {
        default:
-           Perl_croak(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
-       case ',': /* grandfather in commas but with a warning */
-           if (commas++ == 0 && ckWARN(WARN_PACK))
-               Perl_warner(aTHX_ packWARN(WARN_PACK),
-                           "Invalid type in pack: '%c'", (int)datumtype);
-           break;
+           Perl_croak(aTHX_ "Invalid type '%c' in pack", (int)datumtype);
        case '%':
-           Perl_croak(aTHX_ "%% may only be used in unpack");
+           Perl_croak(aTHX_ "'%%' may not be used in pack");
        case '@':
-           len -= SvCUR(cat);
+           len += strrelbeg - SvCUR(cat);
            if (len > 0)
                goto grow;
            len = -len;
@@ -1847,27 +1933,17 @@ Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beg
            break;
        case '(':
        {
-           char *beg = pat;
-           SV **savebeglist = beglist; /* beglist de-register-ed */
-
-           if (star >= 0)
-               Perl_croak(aTHX_ "()-group starts with a count");
-           aptr = group_end(beg, patend, ')');
-           pat = aptr + 1;
-           if (star != -2) {
-               len = find_count(&pat, patend, &star);
-               if (star < 0)           /* No count */
-                   len = 1;
-               else if (star > 0)      /* Star */
-                   len = items;        /* long enough? */
-           }
+            tempsym_t savsym = *symptr;
+            symptr->patend = savsym.grpend;
+            symptr->level++;
            while (len--) {
-               pack_cat(cat, beg, aptr, savebeglist, endlist,
-                        &savebeglist, PACK_CHILD);
-               if (star > 0 && savebeglist == endlist)
+               symptr->patptr = savsym.grpbeg;
+               beglist = pack_rec(cat, symptr, beglist, endlist );
+               if (savsym.howlen == e_star && beglist == endlist)
                    break;              /* No way to continue */
            }
-           beglist = savebeglist;
+            lookahead.flags = symptr->flags;
+            *symptr = savsym;
            break;
        }
        case 'X' | TYPE_IS_SHRIEKING:
@@ -1878,7 +1954,7 @@ Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beg
        case 'X':
          shrink:
            if ((I32)SvCUR(cat) < len)
-               Perl_croak(aTHX_ "X outside of string");
+               Perl_croak(aTHX_ "'X' outside of string in pack");
            SvCUR(cat) -= len;
            *SvEND(cat) = '\0';
            break;
@@ -1891,6 +1967,7 @@ Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beg
            else
                len = 0;
            /* FALL THROUGH */
+
        case 'x':
          grow:
            while (len >= 10) {
@@ -1904,7 +1981,7 @@ Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beg
        case 'a':
            fromstr = NEXTFROM;
            aptr = SvPV(fromstr, fromlen);
-           if (star > 0) { /* -2 after '/' */  
+           if (howlen == e_star) {   
                len = fromlen;
                if (datumtype == 'Z')
                    ++len;
@@ -1942,7 +2019,7 @@ Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beg
                fromstr = NEXTFROM;
                saveitems = items;
                str = SvPV(fromstr, fromlen);
-               if (star > 0)
+               if (howlen == e_star)
                    len = fromlen;
                aint = SvCUR(cat);
                SvCUR(cat) += (len+7)/8;
@@ -1998,7 +2075,7 @@ Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beg
                fromstr = NEXTFROM;
                saveitems = items;
                str = SvPV(fromstr, fromlen);
-               if (star > 0)
+               if (howlen == e_star)
                    len = fromlen;
                aint = SvCUR(cat);
                SvCUR(cat) += (len+1)/2;
@@ -2055,7 +2132,7 @@ Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beg
                    if ((aint < 0 || aint > 255) &&
                        ckWARN(WARN_PACK))
                        Perl_warner(aTHX_ packWARN(WARN_PACK),
-                                   "Character in \"C\" format wrapped");
+                                   "Character in 'C' format wrapped in pack");
                    achar = aint & 255;
                    sv_catpvn(cat, &achar, sizeof(char));
                    break;
@@ -2064,7 +2141,7 @@ Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beg
                    if ((aint < -128 || aint > 127) &&
                        ckWARN(WARN_PACK))
                        Perl_warner(aTHX_ packWARN(WARN_PACK),
-                                   "Character in \"c\" format wrapped");
+                                   "Character in 'c' format wrapped in pack" );
                    achar = aint & 255;
                    sv_catpvn(cat, &achar, sizeof(char));
                    break;
@@ -2186,9 +2263,9 @@ Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beg
                CAT16(cat, &ashort);
            }
            break;
-       case 'S':
+        case 'S' | TYPE_IS_SHRIEKING:
 #if SHORTSIZE != SIZE16
-           if (natint) {
+           {
                unsigned short aushort;
 
                while (len-- > 0) {
@@ -2196,9 +2273,12 @@ Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beg
                    aushort = SvUV(fromstr);
                    sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
                }
-           }
-           else
+            }
+            break;
+#else
+            /* Fall through! */
 #endif
+       case 'S':
             {
                U16 aushort;
 
@@ -2210,9 +2290,9 @@ Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beg
 
            }
            break;
-       case 's':
+       case 's' | TYPE_IS_SHRIEKING:
 #if SHORTSIZE != SIZE16
-           if (natint) {
+           {
                short ashort;
 
                while (len-- > 0) {
@@ -2221,17 +2301,19 @@ Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beg
                    sv_catpvn(cat, (char *)&ashort, sizeof(short));
                }
            }
-           else
+            break;
+#else
+            /* Fall through! */
 #endif
-            {
-               while (len-- > 0) {
-                   fromstr = NEXTFROM;
-                   ashort = (I16)SvIV(fromstr);
-                   CAT16(cat, &ashort);
-               }
+       case 's':
+           while (len-- > 0) {
+               fromstr = NEXTFROM;
+               ashort = (I16)SvIV(fromstr);
+               CAT16(cat, &ashort);
            }
            break;
        case 'I':
+       case 'I' | TYPE_IS_SHRIEKING:
            while (len-- > 0) {
                fromstr = NEXTFROM;
                auint = SvUV(fromstr);
@@ -2258,7 +2340,7 @@ Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beg
                anv = SvNV(fromstr);
 
                if (anv < 0)
-                   Perl_croak(aTHX_ "Cannot compress negative numbers");
+                   Perl_croak(aTHX_ "Cannot compress negative numbers in pack");
 
                 /* 0xFFFFFFFFFFFFFFFF may cast to 18446744073709551616.0,
                    which is == UV_MAX_P1. IOK is fine (instead of UV_only), as
@@ -2287,7 +2369,7 @@ Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beg
                    /* Copy string and check for compliance */
                    from = SvPV(fromstr, len);
                    if ((norm = is_an_int(from, len)) == NULL)
-                       Perl_croak(aTHX_ "Can only compress unsigned integers");
+                       Perl_croak(aTHX_ "Can only compress unsigned integers in pack");
 
                    New('w', result, len, char);
                    in = result + len;
@@ -2317,7 +2399,7 @@ Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beg
                    do {
                        NV next = Perl_floor(anv / 128);
                        if (in <= buf)  /* this cannot happen ;-) */
-                           Perl_croak(aTHX_ "Cannot compress integer");
+                           Perl_croak(aTHX_ "Cannot compress integer in pack");
                        *--in = (unsigned char)(anv - (next * 128)) | 0x80;
                        anv = next;
                    } while (anv > 0);
@@ -2333,7 +2415,7 @@ Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beg
                    /* Copy string and check for compliance */
                    from = SvPV(fromstr, len);
                    if ((norm = is_an_int(from, len)) == NULL)
-                       Perl_croak(aTHX_ "Can only compress unsigned integers");
+                       Perl_croak(aTHX_ "Can only compress unsigned integers in pack");
 
                    New('w', result, len, char);
                    in = result + len;
@@ -2348,6 +2430,7 @@ Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beg
            }
             break;
        case 'i':
+       case 'i' | TYPE_IS_SHRIEKING:
            while (len-- > 0) {
                fromstr = NEXTFROM;
                aint = SvIV(fromstr);
@@ -2374,9 +2457,9 @@ Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beg
                CAT32(cat, &aulong);
            }
            break;
-       case 'L':
+       case 'L' | TYPE_IS_SHRIEKING:
 #if LONGSIZE != SIZE32
-           if (natint) {
+           {
                unsigned long aulong;
 
                while (len-- > 0) {
@@ -2385,8 +2468,11 @@ Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beg
                    sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
                }
            }
-           else
+           break;
+#else
+            /* Fall though! */
 #endif
+       case 'L':
             {
                while (len-- > 0) {
                    fromstr = NEXTFROM;
@@ -2395,9 +2481,9 @@ Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beg
                }
            }
            break;
-       case 'l':
+       case 'l' | TYPE_IS_SHRIEKING:
 #if LONGSIZE != SIZE32
-           if (natint) {
+           {
                long along;
 
                while (len-- > 0) {
@@ -2406,14 +2492,15 @@ Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beg
                    sv_catpvn(cat, (char *)&along, sizeof(long));
                }
            }
-           else
+           break;
+#else
+            /* Fall though! */
 #endif
-            {
-               while (len-- > 0) {
-                   fromstr = NEXTFROM;
-                   along = SvIV(fromstr);
-                   CAT32(cat, &along);
-               }
+       case 'l':
+            while (len-- > 0) {
+               fromstr = NEXTFROM;
+               along = SvIV(fromstr);
+               CAT32(cat, &along);
            }
            break;
 #ifdef HAS_QUAD
@@ -2434,7 +2521,7 @@ Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beg
 #endif
        case 'P':
            len = 1;            /* assume SV is correct length */
-           /* FALL THROUGH */
+           /* Fall through! */
        case 'p':
            while (len-- > 0) {
                fromstr = NEXTFROM;
@@ -2483,9 +2570,9 @@ Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beg
            }
            break;
        }
+       *symptr = lookahead;
     }
-    if (next_in_list)
-       *next_in_list = beglist;
+    return beglist;
 }
 #undef NEXTFROM
 
@@ -2501,7 +2588,7 @@ PP(pp_pack)
     MARK++;
     sv_setpvn(cat, "", 0);
 
-    pack_cat(cat, pat, patend, MARK, SP + 1, NULL, 0);
+    pack_cat(cat, pat, patend, MARK, SP + 1, NULL, FLAG_PACK);
 
     SvSETMAGIC(cat);
     SP = ORIGMARK;
diff --git a/proto.h b/proto.h
index e013aaf..5a5e0bd 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -1096,14 +1096,16 @@ STATIC U32      S_seed(pTHX);
 #endif
 
 #if defined(PERL_IN_PP_PACK_C) || defined(PERL_DECL_PROT)
-STATIC void    S_doencodes(pTHX_ SV* sv, char* s, I32 len);
+STATIC I32     S_unpack_rec(pTHX_ tempsym_t* symptr, char *s, char *strbeg, char *strend, char **new_s);
+STATIC SV **   S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist);
 STATIC SV*     S_mul128(pTHX_ SV *sv, U8 m);
+STATIC I32     S_measure_struct(pTHX_ tempsym_t* symptr);
+STATIC char *  S_group_end(pTHX_ char *pat, char *patend, char ender);
+STATIC char *  S_get_num(pTHX_ char *ppat, I32 *);
+STATIC bool    S_next_symbol(pTHX_ tempsym_t* symptr);
+STATIC void    S_doencodes(pTHX_ SV* sv, char* s, I32 len);
 STATIC SV*     S_is_an_int(pTHX_ char *s, STRLEN l);
 STATIC int     S_div128(pTHX_ SV *pnum, bool *done);
-STATIC char *  S_next_symbol(pTHX_ char *pat, char *patend);
-STATIC I32     S_find_count(pTHX_ char **ppat, char *patend, int *star);
-STATIC char *  S_group_end(pTHX_ char *pat, char *patend, char ender);
-STATIC I32     S_measure_struct(pTHX_ char *pat, char *patend);
 #endif
 
 #if defined(PERL_IN_PP_CTL_C) || defined(PERL_DECL_PROT)
index 62fa6ec..0f447c7 100644 (file)
@@ -18,8 +18,8 @@ no warnings 'unpack' ;
 my @b = unpack ("A,A", "22") ;
 my $b = pack ("A,A", 1,2) ;
 EXPECT
-Invalid type in unpack: ',' at - line 4.
-Invalid type in pack: ',' at - line 5.
+Invalid type ',' in unpack at - line 4.
+Invalid type ',' in pack at - line 5.
 ########
 # pp.c
 use warnings 'uninitialized' ;
@@ -73,10 +73,10 @@ print unpack("c", pack("c", -128)), "\n";
 print unpack("c", pack("c",  127)), "\n";
 print unpack("c", pack("c",  128)), "\n";
 EXPECT
-Character in "C" format wrapped at - line 3.
-Character in "C" format wrapped at - line 3.
-Character in "c" format wrapped at - line 3.
-Character in "c" format wrapped at - line 3.
+Character in 'C' format wrapped in pack at - line 3.
+Character in 'C' format wrapped in pack at - line 3.
+Character in 'c' format wrapped in pack at - line 3.
+Character in 'c' format wrapped in pack at - line 3.
 255
 0
 255
index 9ac5d38..af54fdc 100755 (executable)
@@ -6,7 +6,7 @@ BEGIN {
     require './test.pl';
 }
 
-plan tests => 5827;
+plan tests => 5849;
 
 use strict;
 use warnings;
@@ -263,7 +263,7 @@ foreach my $t (@templates) {
         my @t = eval { unpack("$t*", pack("$t*", 12, 34)) };
 
         # quads not supported everywhere
-        skip "Quads not supported", 4 if $@ =~ /Invalid type in pack/;
+        skip "Quads not supported", 4 if $@ =~ /Invalid type/;
         is( $@, '' );
 
         is(scalar @t, 2);
@@ -378,7 +378,7 @@ sub numbers_with_total {
     SKIP: {
         my $out = eval {unpack($format, pack($format, $_))};
         skip "cannot pack '$format' on this perl", 2 if
-          $@ =~ /Invalid type in pack: '$format'/;
+          $@ =~ /Invalid type '$format'/;
 
         is($@, '');
         is($out, $_);
@@ -398,7 +398,7 @@ sub numbers_with_total {
     SKIP: {
       my $sum = eval {unpack "%$_$format*", pack "$format*", @_};
       skip "cannot pack '$format' on this perl", 3
-        if $@ =~ /Invalid type in pack: '$format'/;
+        if $@ =~ /Invalid type '$format'/;
 
       is($@, '');
       ok(defined $sum);
@@ -519,10 +519,10 @@ is(pack("V", 0xdeadbeef), "\xef\xbe\xad\xde");
 
   my ($x, $y, $z);
   eval { ($x) = unpack '/a*','hello' };
-  like($@, qr!/ must follow a numeric type!);
+  like($@, qr!'/' must follow a numeric type!);
   undef $x;
   eval { $x = unpack '/a*','hello' };
-  like($@, qr!/ must follow a numeric type!);
+  like($@, qr!'/' must follow a numeric type!);
 
   undef $x;
   eval { ($z,$x,$y) = unpack 'a3/A C/a* C/Z', "003ok \003yes\004z\000abc" };
@@ -538,10 +538,10 @@ is(pack("V", 0xdeadbeef), "\xef\xbe\xad\xde");
 
   undef $x;
   eval { ($x) = pack '/a*','hello' };
-  like($@,  qr!Invalid type in pack: '/'!);
+  like($@,  qr!Invalid type '/'!);
   undef $x;
   eval { $x = pack '/a*','hello' };
-  like($@,  qr!Invalid type in pack: '/'!);
+  like($@,  qr!Invalid type '/'!);
 
   $z = pack 'n/a* N/Z* w/A*','string','hi there ','etc';
   my $expect = "\000\006string\0\0\0\012hi there \000\003etc";
@@ -781,7 +781,7 @@ foreach (
     # from Wolfgang Laun: fix in change #13288
 
     eval { my $t=unpack("P*", "abc") };
-    like($@, qr/P must have an explicit size/);
+    like($@, qr/'P' must have an explicit size/);
 }
 
 {   # Grouping constructs
@@ -822,6 +822,105 @@ foreach (
     is("@a", "@b");
 }
 
+{  # more on grouping (W.Laun)
+  use warnings;
+  my $warning;
+  local $SIG{__WARN__} = sub {
+      $warning = $_[0];
+  };
+  # @ absolute within ()-group
+  my $badc = pack( '(a)*', unpack( '(@1a @0a @2)*', 'abcd' ) );
+  is( $badc, 'badc' );
+  my @b = ( 1, 2, 3 );
+  my $buf = pack( '(@1c)((@2C)@3c)', @b );
+  is( $buf, "\0\1\0\0\2\3" );
+  my @a = unpack( '(@1c)((@2c)@3c)', $buf );
+  is( "@a", "@b" );
+
+  # various unpack count/code scenarios 
+  my @Env = ( a => 'AAA', b => 'BBB' );
+  my $env = pack( 'S(S/A*S/A*)*', @Env/2, @Env );
+
+  # unpack full length - ok
+  my @pup = unpack( 'S/(S/A* S/A*)', $env );
+  is( "@pup", "@Env" );
+
+  # warn when count/code goes beyond end of string
+  # \0002 \0001 a \0003 AAA \0001 b \0003 BBB
+  #     2     4 5     7  10    1213
+  eval { @pup = unpack( 'S/(S/A* S/A*)', substr( $env, 0, 13 ) ) };
+  like( $@, qr{length/code after end of string} );
+  
+  # postfix repeat count
+  $env = pack( '(S/A* S/A*)' . @Env/2, @Env );
+
+  # warn when count/code goes beyond end of string
+  # \0001 a \0003 AAA \0001  b \0003 BBB
+  #     2 3c    5   8    10 11    13  16
+  eval { @pup = unpack( '(S/A* S/A*)' . @Env/2, substr( $env, 0, 11 ) ) };
+  like( $@, qr{length/code after end of string} );
+
+  # catch stack overflow/segfault
+  eval { $_ = pack( ('(' x 105) . 'A' . (')' x 105) ); };
+  like( $@, qr{Too deeply nested \(\)-groups} );
+}
+
+{ # syntax checks (W.Laun)
+  use warnings;
+  my @warning;
+  local $SIG{__WARN__} = sub {
+      push( @warning, $_[0] );
+  };
+  eval { my $s = pack( 'Ax![4c]A', 1..5 ); };
+  like( $@, qr{Malformed integer in \[\]} );
+
+  eval { my $buf = pack( '(c/*a*)', 'AAA', 'BB' ); };
+  like( $@, qr{'/' does not take a repeat count} );
+
+  eval { my @inf = unpack( 'c/1a', "\x03AAA\x02BB" ); };
+  like( $@, qr{'/' does not take a repeat count} );
+
+  eval { my @inf = unpack( 'c/*a', "\x03AAA\x02BB" ); };
+  like( $@, qr{'/' does not take a repeat count} );
+
+  # white space where possible 
+  my @Env = ( a => 'AAA', b => 'BBB' );
+  my $env = pack( ' S ( S / A*   S / A* )* ', @Env/2, @Env );
+  my @pup = unpack( ' S / ( S / A*   S / A* ) ', $env );
+  is( "@pup", "@Env" );
+
+  # white space in 4 wrong places
+  for my $temp (  'A ![4]', 'A [4]', 'A *', 'A 4' ){
+      eval { my $s = pack( $temp, 'B' ); };
+      like( $@, qr{Invalid type } );
+  }
+
+  # warning for commas
+  @warning = ();
+  my $x = pack( 'I,A', 4, 'X' );
+  like( $warning[0], qr{Invalid type ','} );
+
+  # comma warning only once
+  @warning = ();
+  $x = pack( 'C(C,C)C,C', 65..71  );
+  like( scalar @warning, 1 );
+
+  # forbidden code in []
+  eval { my $x = pack( 'A[@4]', 'XXXX' ); };
+  like( $@, qr{Within \[\]-length '\@' not allowed} );
+
+  # @ repeat default 1
+  my $s = pack( 'AA@A', 'A', 'B', 'C' );
+  my @c = unpack( 'AA@A', $s );
+  is( $s, 'AC' ); 
+  is( "@c", "A C C" ); 
+
+  # no unpack code after /
+  eval { my @a = unpack( "C/", "\3" ); };
+  like( $@, qr{Code missing after '/'} );
+
+}
+
 {  # Repeat count [SUBEXPR]
    my @codes = qw( x A Z a c C B b H h s v n S i I l V N L p P f F d
                   s! S! i! I! l! L! j J);
@@ -939,7 +1038,7 @@ numbers ('F', -(2**34), -1, 0, 1, 2**34);
 SKIP: {
     my $t = eval { unpack("D*", pack("D", 12.34)) };
 
-    skip "Long doubles not in use", 56 if $@ =~ /Invalid type in pack/;
+    skip "Long doubles not in use", 56 if $@ =~ /Invalid type/;
 
     is(length(pack("D", 0)), $Config{longdblsize});
     numbers ('D', -(2**34), -1, 0, 1, 2**34);
@@ -953,7 +1052,7 @@ foreach my $template (qw(A Z c C s S i I l L n N v V q Q j J f d F D u U w)) {
   SKIP: {
     my $packed = eval {pack "${template}4", 1, 4, 9, 16};
     if ($@) {
-      die unless $@ =~ /Invalid type in pack: '$template'/;
+      die unless $@ =~ /Invalid type '$template'/;
       skip ("$template not supported on this perl",
             $cant_checksum{$template} ? 4 : 8);
     }