develooper Front page | perl.perl5.porters | Postings from March 2003

pack changes and related fixes

From:
LAUN Wolfgang
Date:
March 17, 2003 04:55
Subject:
pack changes and related fixes
Message ID:
75A46BF1A9D8D311863A00508B6259A405F17EB8@ATTMSX4

=head1 Summary

This describes a set of changes concerning C<pack> and C<unpack>, against
Perl, v5.9.0, perl@18376. Starting point was the change to code C<@>, but
other things came up during testing. The examples below illustrate the
behavior prior to the changes given in the patch. Tests added to 
F<t/op/pack.t> demonstrate the new situation.

In addition to the pack and unpack functions in the Perl core, also the
library package diagnostics.pm had to be changed.

Contrary to previous versions of this patch, the Perl API was not changed.
It should be noted, however, that this interface must have changed between
5.8.x and 5.9.0 for the engined implementing pack and unpack due to adding
the parameters required for handling the recursion now necessary to the
new ()-groups. I do not think that these parameters should be included in
the API.

The arbitrary limitation of ()-group nesting is still in there. According
to Hugo, this should be handled in a way similar to the regexp engine
recursions. Note that the limit (100) is far, far beyond any reasonable
nesting depth, sice it is difficult to find applications for more than
even three levels.  

The patch is after the __END__ below.

=head1 Partial Redesign of pp_pack.c

The intention was to concentrate template parsing for pack, unpack and the
new function determining a template's length into a single function
(next_symbol). The function now parses code, modifier, repeat count and
the '/'. Since this implies more than one return value, a parser control
block (type tempsym_t) was introduced (in perl.h). Input values describing
the template, and some static and dynamic flags are also kept in this block.

The modifier '!' is now treated in a uniform way. All switch statements
have their own branch for dealing with the ! version of a code.

Wording of error messages was streamlined and made to include a reference
to pack or unpack in almost all cases. perldiag.pod was updated accordingly.

=head1 Functional Change: Code C<@> 

Template code C<@n> in a ()-group is now relative to the position where
(un)pack was when the last C<(> was encountered. 

=head1 Bug Fixes and Improvements 

Below are examples for odds and ends, some of them bugs, some of them just
improved diagnostics etc., and how they were fixed.

=over 4

=item UTF8-ness lost if set in ()-group

Code U0 is used to indicate UTF8-ness. This is lost if the U0 happens to
occur in a ()-group.

{
    # does pack U0C create Unicode?
    $buf = pack('(U0)C*', 100, 195, 136);
    # $buf eq "d\303\210", but should be "d\310" (cf pack.t l.644)
}


=item White space handling

White space tolerance was not consistent. Now, white space may be used
to separate pack codes including any modifier and repeat count from each
other. Spaces may also surround C</> and C<()>.

 use strict;
 { 
   my @Env = ( a => 'AAA', b => 'BBB' );
   my $env = pack( 'S ( S /A*  S /A* )*', @Env/2, @Env );
   # warn: Argument "a" isn't numeric in pack at ./oldpack.pl line 6.
   # die: Invalid type in pack: '/' at ./oldpack.pl line 6.
   # but unpack( 'S /(S /A* S /A*)',... ); is OK
 }
 {
   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 );
   # die: Invalid type in unpack: ' ' at ./oldpack.pl line 16.
 }

=item Unpack data exhausted while in count/code

This may happen under varying circumstances (c/(...), (...)n, cc...c),
with insufficient data in the string-to-unpack. With count/code, it may
even happen after count and before code. Warnings and abort messages
were not clear, and the unpack result list might not be OK. This has been
changed so that unpack aborts whenever a non-existent count would be used
on (also non-existent) data.

 {
   my @Env = ( a => 'AAA', b => 'BBB' );
   my $env = pack( 'S(S/A*  S/A*)*', @Env/2, @Env );

   # count/code goes beyond end of string
   # \0002 \0001 a \0003 AAA \0001 b \0003 BBB
   #     2     4 5     7  10    1213
   my @pup = unpack( 'S/(S/A* S/A*)', substr( $env, 0, 13 ) );
   # warn: Argument "b" isn't numeric in unpack at ./oldpack.pl line 29.
   #  @pup equals ( 'a', 'AAA', '' ) - where has 'b' gone to?
 }
 {
   # postfix repeat count
   my @Env = ( a => 'AAA', b => 'BBB' );
   my $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 3     5   8    10 11    13  16
   my @pup = unpack( '(S/A* S/A*)' . @Env/2, substr( $env, 0, 11 ) );
   # warn: Argument "b" isn't numeric in unpack at ./oldpack.pl line 51
   # @pup equals ( 'a', 'AAA', '' )
 }

=item No unpack code after C</>

This produced the fatal error with the message "Invalid type in unpack: ''".
Now the message is "No unpack code after '/'".


=item Deep nesting of ()-groups
 
Deep nesting (~5000 on my Linux system) of ()-groups resulted
in a stackoverflow/segmentation fault. Fixed by limiting
()-group nesting to 100 which should be sufficient for most cases ;-).

 {
   $_ = pack( ('(' x 5000) . 'A' . (')' x 5000) );
   # Segmentation fault
 }


=item Malformed numeric [count]  

Trailing garbage after a numeric bracketed length (e.g. C<[123x]>)
was silently accepted. Now dies with "Malformed integer in []".

 {
   my $s = pack( 'Ax![4OO]A', 1..5 );
   print "s=$s, length of s is ", length( $s ), "\n";
   # s=12, length of s is 5
 }

=item Repeat count overflow

Repeat count conversion is now safe against overflow. 

=item count/code with count < 0 

unpack( 's/A', "\xFF\xFF..." ) dies with  "panic: sv_setpvn called with
negative strlen at..." which doesn't provide much help to find the error.
Changed to die with "Negative count for '/'".

 {
   my @inf = unpack( 's/a', "\xFF\xFF" );
   # panic: sv_setpvn called with negative strlen at ./oldpack.pl line 66
 }

=item unpack: /length or /* silently accepted

Now dies with the message "'/'cannot take a count or '*'" 

 {
   my $buf = pack( '(c/a*)', 'AAA', 'BB' );
   my @inf = unpack( 'c/1a c/1a', "\x03AAA\x02BB" );
   print "@inf\n";
 }

=back

=head1 Pod Changes

Update of perlfunc.pod, explaining C<@> in C<()>, adding cautionary
remarks concerning unpack() going beyond the end of the buffer string,
and explaining about white space.

perlpacktut.pod now says a few words about C<()> and C<x![]>. (The
omission of codes C<jJFD> is deliberate.)

All error messages pertaining to pack/unpack in perldiag.pod were
reviewed. New messages were added, obsolete messages deleted, etc.
Some of the new messages led to problems when "use diagnostics" was
tried. This led to...


=head1 Changes in diagnostics.pm

First, diagnostics.pm was not able to handle a message wit C<[]> in it.
Testing the fix for this with all messages from perldiag.pod revealed
additional problems:

   - embedded format codes %x, %lx, %.2c were not handled properly
   - messages containing " at foo" were not recognized
   - messages equal to the initial substring of another message were
     eclipsing the longer one
   - messages with additional constant text next to %s were being
     eclipsed by the shorter ones

The solution adopted to solve the latter two problems was to match messages
in the order of decreasing length of fixed parts.

The entire setup is shaky and liable to get broken by the addition of
messages with peculiar contents, or new format codes. Output also depends
on the contents of perldiag.pod, e.g. a reference to some other error
message ("see blech") is not useful in this context. 



=head1 Changed Files

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


=cut

__END__

--- /extra/perl/perl.h	2002-12-17 02:10:24.000000000 +0100
+++ /extra/pack/perl.h	2003-01-26 15:30:06.000000000 +0100
@@ -3342,6 +3342,25 @@
 #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"
 
--- /extra/perl/embed.fnc	2002-12-17 02:13:01.000000000 +0100
+++ /extra/pack/embed.fnc	2003-03-16 20:10:40.000000000 +0100
@@ -1047,14 +1047,16 @@
 #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)
--- /extra/perl/pp_pack.c	2002-10-12 16:20:35.000000000 +0200
+++ /extra/pack/pp_pack.c	2003-03-16 20:11:08.000000000 +0100
@@ -83,6 +83,16 @@
 #  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 @@
 #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 @@
 	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 @@
 	    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 @@
 	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 @@
     return total;
 }
 
-/* Returns -1 on no count or on star */
-STATIC I32
-S_find_count(pTHX_ char **ppat, register char *patend, int *star)
-{
-    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, ']');
+/* 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)
+{
+    while (patptr < patend) {
+	char c = *patptr++;
 
-	len = 0;
-	*ppat = end + 1;
-	if (isDIGIT(*pat))
-	    return find_count(&pat, end, star);
-	return measure_struct(pat, end);
+	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 )
 {
-    while (pat < patend) {
-	if (isSPACE(*pat))
-	    pat++;
-	else if (*pat == '#') {
-	    pat++;
-	    while (pat < patend && *pat != '\n')
-		pat++;
-	    if (pat < patend)
-		pat++;
+  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 )
+{
+  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 @@
 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 @@
     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 @@
 	    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 @@
  	    /* 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 @@
  	    /* 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 @@
 		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 @@
 	    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 @@
 	    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 @@
 		}
 	    }
 	    else {
-                if (len && (flags & UNPACK_ONLY_ONE))
+                if (len && unpack_only_one)
                     len = 1;
 		EXTEND(SP, len);
 		EXTEND_MORTAL(len);
@@ -737,7 +796,7 @@
 	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 @@
 		}
 	    }
 	    else {
-                if (len && (flags & UNPACK_ONLY_ONE))
+                if (len && unpack_only_one)
                     len = 1;
 		EXTEND(SP, len);
 		EXTEND_MORTAL(len);
@@ -764,10 +823,10 @@
 	    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 @@
 		}
 	    }
 	    else {
-                if (len && (flags & UNPACK_ONLY_ONE))
+                if (len && unpack_only_one)
                     len = 1;
 		EXTEND(SP, len);
 		EXTEND_MORTAL(len);
@@ -799,161 +858,160 @@
 		}
 	    }
 	    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 @@
 		}
 	    }
 	    else {
-                if (len && (flags & UNPACK_ONLY_ONE))
+                if (len && unpack_only_one)
                     len = 1;
 		EXTEND(SP, len);
 		EXTEND_MORTAL(len);
@@ -1007,6 +1065,7 @@
 	    }
 	    break;
 	case 'I':
+	case 'I' | TYPE_IS_SHRIEKING:
 	    along = (strend - s) / sizeof(unsigned int);
 	    if (len > along)
 		len = along;
@@ -1021,7 +1080,7 @@
 		}
 	    }
 	    else {
-                if (len && (flags & UNPACK_ONLY_ONE))
+                if (len && unpack_only_one)
                     len = 1;
 		EXTEND(SP, len);
 		EXTEND_MORTAL(len);
@@ -1056,7 +1115,7 @@
 		}
 	    }
 	    else {
-                if (len && (flags & UNPACK_ONLY_ONE))
+                if (len && unpack_only_one)
                     len = 1;
 		EXTEND(SP, len);
 		EXTEND_MORTAL(len);
@@ -1084,7 +1143,7 @@
 		}
 	    }
 	    else {
-                if (len && (flags & UNPACK_ONLY_ONE))
+                if (len && unpack_only_one)
                     len = 1;
 		EXTEND(SP, len);
 		EXTEND_MORTAL(len);
@@ -1097,160 +1156,157 @@
 		}
 	    }
 	    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 @@
 	    }
 	    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 @@
 		    }
 		}
 		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 @@
 		}
 	    }
             else {
-                if (len && (flags & UNPACK_ONLY_ONE))
+                if (len && unpack_only_one)
                     len = 1;
                 EXTEND(SP, len);
                 EXTEND_MORTAL(len);
@@ -1384,7 +1440,7 @@
 		}
 	    }
             else {
-                if (len && (flags & UNPACK_ONLY_ONE))
+                if (len && unpack_only_one)
                     len = 1;
                 EXTEND(SP, len);
                 EXTEND_MORTAL(len);
@@ -1418,7 +1474,7 @@
 		}
 	    }
 	    else {
-                if (len && (flags & UNPACK_ONLY_ONE))
+                if (len && unpack_only_one)
                     len = 1;
 		EXTEND(SP, len);
 		EXTEND_MORTAL(len);
@@ -1443,7 +1499,7 @@
 		}
 	    }
 	    else {
-                if (len && (flags & UNPACK_ONLY_ONE))
+                if (len && unpack_only_one)
                     len = 1;
 		EXTEND(SP, len);
 		EXTEND_MORTAL(len);
@@ -1468,7 +1524,7 @@
 		}
 	    }
 	    else {
-                if (len && (flags & UNPACK_ONLY_ONE))
+                if (len && unpack_only_one)
                     len = 1;
 		EXTEND(SP, len);
 		EXTEND_MORTAL(len);
@@ -1494,7 +1550,7 @@
 		}
 	    }
 	    else {
-                if (len && (flags & UNPACK_ONLY_ONE))
+                if (len && unpack_only_one)
                     len = 1;
 		EXTEND(SP, len);
 		EXTEND_MORTAL(len);
@@ -1568,11 +1624,12 @@
 	    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 @@
 	    else {
 		if (checksum < bits_in_uv) {
 		    UV mask = ((UV)1 << checksum) - 1;
-
 		    cuv &= mask;
 		}
 		sv_setuv(sv, cuv);
@@ -1596,7 +1652,30 @@
 	    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;
@@ -1625,8 +1704,9 @@
 
     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);
@@ -1737,7 +1817,7 @@
   return (m);
 }
 
-#define PACK_CHILD	0x1
+
 
 /*
 =for apidoc pack_cat
@@ -1746,18 +1826,31 @@
 
 =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;
@@ -1779,65 +1872,58 @@
     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;
@@ -1846,27 +1932,17 @@
 	    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:
@@ -1877,7 +1953,7 @@
 	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;
@@ -1890,6 +1966,7 @@
 	    else
 		len = 0;
 	    /* FALL THROUGH */
+
 	case 'x':
 	  grow:
 	    while (len >= 10) {
@@ -1903,7 +1980,7 @@
 	case 'a':
 	    fromstr = NEXTFROM;
 	    aptr = SvPV(fromstr, fromlen);
-	    if (star > 0) { /* -2 after '/' */  
+	    if (howlen == e_star) {   
 		len = fromlen;
 		if (datumtype == 'Z')
 		    ++len;
@@ -1941,7 +2018,7 @@
 		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;
@@ -1997,7 +2074,7 @@
 		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;
@@ -2054,7 +2131,7 @@
 		    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;
@@ -2063,7 +2140,7 @@
 		    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;
@@ -2185,9 +2262,9 @@
 		CAT16(cat, &ashort);
 	    }
 	    break;
-	case 'S':
+        case 'S' | TYPE_IS_SHRIEKING:
 #if SHORTSIZE != SIZE16
-	    if (natint) {
+	    {
 		unsigned short aushort;
 
 		while (len-- > 0) {
@@ -2195,9 +2272,12 @@
 		    aushort = SvUV(fromstr);
 		    sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
 		}
-	    }
-	    else
+            }
+            break;
+#else
+            /* Fall through! */
 #endif
+	case 'S':
             {
 		U16 aushort;
 
@@ -2209,9 +2289,9 @@
 
 	    }
 	    break;
-	case 's':
+	case 's' | TYPE_IS_SHRIEKING:
 #if SHORTSIZE != SIZE16
-	    if (natint) {
+	    {
 		short ashort;
 
 		while (len-- > 0) {
@@ -2220,17 +2300,19 @@
 		    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);
@@ -2257,7 +2339,7 @@
 		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
@@ -2286,7 +2368,7 @@
 		    /* 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;
@@ -2316,7 +2398,7 @@
 		    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);
@@ -2332,7 +2414,7 @@
 		    /* 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;
@@ -2347,6 +2429,7 @@
 	    }
             break;
 	case 'i':
+	case 'i' | TYPE_IS_SHRIEKING:
 	    while (len-- > 0) {
 		fromstr = NEXTFROM;
 		aint = SvIV(fromstr);
@@ -2373,9 +2456,9 @@
 		CAT32(cat, &aulong);
 	    }
 	    break;
-	case 'L':
+	case 'L' | TYPE_IS_SHRIEKING:
 #if LONGSIZE != SIZE32
-	    if (natint) {
+	    {
 		unsigned long aulong;
 
 		while (len-- > 0) {
@@ -2384,8 +2467,11 @@
 		    sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
 		}
 	    }
-	    else
+	    break;
+#else
+            /* Fall though! */
 #endif
+	case 'L':
             {
 		while (len-- > 0) {
 		    fromstr = NEXTFROM;
@@ -2394,9 +2480,9 @@
 		}
 	    }
 	    break;
-	case 'l':
+	case 'l' | TYPE_IS_SHRIEKING:
 #if LONGSIZE != SIZE32
-	    if (natint) {
+	    {
 		long along;
 
 		while (len-- > 0) {
@@ -2405,14 +2491,15 @@
 		    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
@@ -2433,7 +2520,7 @@
 #endif
 	case 'P':
 	    len = 1;		/* assume SV is correct length */
-	    /* FALL THROUGH */
+	    /* Fall through! */
 	case 'p':
 	    while (len-- > 0) {
 		fromstr = NEXTFROM;
@@ -2482,9 +2569,9 @@
 	    }
 	    break;
 	}
+	*symptr = lookahead;
     }
-    if (next_in_list)
-	*next_in_list = beglist;
+    return beglist;
 }
 #undef NEXTFROM
 
@@ -2500,7 +2587,7 @@
     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;
--- /extra/perl/lib/diagnostics.pm	2002-08-23 01:00:24.000000000 +0200
+++ /extra/pack/lib/diagnostics.pm	2003-03-17 09:42:49.000000000 +0100
@@ -16,7 +16,7 @@
     enable  diagnostics;
     disable diagnostics;
 
-Aa a program:
+As a program:
 
     perl program 2>diag.out
     splain [-v] [-p] diag.out
@@ -53,7 +53,7 @@
 
 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 @@
 
 *THITHER = $standalone ? *STDOUT : *STDERR;
 
+my %transfmt = (); 
 my $transmo = <<EOFUNC;
 sub transmo {
     #local \$^W = 0;  # recursive warnings we do NOT need!
@@ -330,7 +331,7 @@
 		    ) )
 		{
 		    next;
-		} 
+		}
 		s/^/    /gm;
 		$msg{$header} .= $_;
 	 	undef $for_item;	
@@ -358,25 +359,38 @@
 	    }
 	}
 
-	# 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 @@
 
     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 @@
     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();
--- /extra/perl/pod/perlfunc.pod	2002-12-30 04:22:45.000000000 +0100
+++ /extra/pack/pod/perlfunc.pod	2003-01-25 16:50:33.000000000 +0100
@@ -3259,7 +3259,8 @@
 
     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 @@
 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 @@
        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 @@
 =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 @@
 =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 *
 
@@ -5988,9 +5999,12 @@
 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.
 
--- /extra/perl/pod/perlpacktut.pod	2002-08-23 01:00:53.000000000 +0200
+++ /extra/pack/pod/perlpacktut.pod	2003-03-17 09:37:11.000000000 +0100
@@ -177,7 +177,7 @@
 
 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 @@
        $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 @@
 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 @@
 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 @@
 
 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 @@
 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 @@
 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 @@
 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" : '';
 
 
--- /extra/perl/pod/perldiag.pod	2002-12-11 10:57:05.000000000 +0100
+++ /extra/pack/pod/perldiag.pod	2003-03-16 17:54:35.000000000 +0100
@@ -64,7 +64,7 @@
 
 =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 @@
 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 @@
 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 @@
 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 @@
 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 @@
 
 (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 @@
 (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 @@
 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 @@
 (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
 
@@ -1895,17 +1904,11 @@
 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)
@@ -1972,6 +1975,12 @@
 (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
@@ -1990,14 +1999,22 @@
 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
@@ -2032,9 +2049,7 @@
 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
@@ -2047,7 +2062,7 @@
 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.
@@ -2182,22 +2197,17 @@
 (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
 
@@ -2217,6 +2227,11 @@
 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
@@ -2302,6 +2317,11 @@
 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
@@ -2448,12 +2468,6 @@
 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
@@ -2611,9 +2625,9 @@
 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
@@ -2879,13 +2893,11 @@
 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:
@@ -2894,9 +2906,7 @@
 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.
@@ -2905,9 +2915,7 @@
 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
@@ -2916,9 +2924,7 @@
 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.
@@ -3072,17 +3078,13 @@
 (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
@@ -3161,9 +3163,7 @@
 (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
@@ -3183,16 +3183,11 @@
 (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
@@ -3298,34 +3293,26 @@
 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
@@ -3517,9 +3504,7 @@
 (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
@@ -3531,9 +3516,7 @@
 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
@@ -3578,7 +3561,7 @@
 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.
 
@@ -3675,6 +3658,10 @@
 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
@@ -3720,6 +3707,9 @@
 
 =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.
@@ -3843,9 +3833,7 @@
 
 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
@@ -3919,9 +3907,7 @@
 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
@@ -4011,9 +3997,7 @@
 (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:
@@ -4027,9 +4011,7 @@
 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:
@@ -4201,17 +4183,17 @@
 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
@@ -4357,9 +4339,7 @@
 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
@@ -4418,17 +4398,24 @@
 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>.
--- /extra/perl/t/op/pack.t	2002-12-11 11:05:19.000000000 +0100
+++ /extra/pack/t/op/pack.t	2003-01-28 10:23:56.000000000 +0100
@@ -6,7 +6,7 @@
     require './test.pl';
 }
 
-plan tests => 5826;
+plan tests => 5848;
 
 use strict;
 use warnings;
@@ -263,7 +263,7 @@
         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 @@
     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 @@
     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 @@
 
   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 @@
 
   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 @@
     # 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 @@
     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 @@
 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 @@
   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);
     }
--- /extra/perl/t/lib/warnings/pp_pack	2002-08-23 01:01:04.000000000 +0200
+++ /extra/pack/t/lib/warnings/pp_pack	2003-02-02 20:55:07.000000000 +0100
@@ -18,8 +18,8 @@
 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",  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



nntp.perl.org: Perl Programming lists via nntp and http.
Comments to Ask Bjørn Hansen at ask@perl.org | Group listing | About