#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)
#endif
#if defined(PERL_IN_PP_PACK_C) || defined(PERL_DECL_PROT)
#ifdef PERL_CORE
-#define doencodes S_doencodes
+#define unpack_rec S_unpack_rec
+#endif
+#ifdef PERL_CORE
+#define pack_rec S_pack_rec
#endif
#ifdef PERL_CORE
#define mul128 S_mul128
#endif
#ifdef PERL_CORE
-#define is_an_int S_is_an_int
+#define measure_struct S_measure_struct
#endif
#ifdef PERL_CORE
-#define div128 S_div128
+#define group_end S_group_end
+#endif
+#ifdef PERL_CORE
+#define get_num S_get_num
#endif
#ifdef PERL_CORE
#define next_symbol S_next_symbol
#endif
#ifdef PERL_CORE
-#define find_count S_find_count
+#define doencodes S_doencodes
#endif
#ifdef PERL_CORE
-#define group_end S_group_end
+#define is_an_int S_is_an_int
#endif
#ifdef PERL_CORE
-#define measure_struct S_measure_struct
+#define div128 S_div128
#endif
#endif
#if defined(PERL_IN_PP_CTL_C) || defined(PERL_DECL_PROT)
#endif
#if defined(PERL_IN_PP_PACK_C) || defined(PERL_DECL_PROT)
#ifdef PERL_CORE
-#define doencodes(a,b,c) S_doencodes(aTHX_ a,b,c)
+#define unpack_rec(a,b,c,d,e) S_unpack_rec(aTHX_ a,b,c,d,e)
+#endif
+#ifdef PERL_CORE
+#define pack_rec(a,b,c,d) S_pack_rec(aTHX_ a,b,c,d)
#endif
#ifdef PERL_CORE
#define mul128(a,b) S_mul128(aTHX_ a,b)
#endif
#ifdef PERL_CORE
-#define is_an_int(a,b) S_is_an_int(aTHX_ a,b)
+#define measure_struct(a) S_measure_struct(aTHX_ a)
#endif
#ifdef PERL_CORE
-#define div128(a,b) S_div128(aTHX_ a,b)
+#define group_end(a,b,c) S_group_end(aTHX_ a,b,c)
#endif
#ifdef PERL_CORE
-#define next_symbol(a,b) S_next_symbol(aTHX_ a,b)
+#define get_num(a,b) S_get_num(aTHX_ a,b)
#endif
#ifdef PERL_CORE
-#define find_count(a,b,c) S_find_count(aTHX_ a,b,c)
+#define next_symbol(a) S_next_symbol(aTHX_ a)
#endif
#ifdef PERL_CORE
-#define group_end(a,b,c) S_group_end(aTHX_ a,b,c)
+#define doencodes(a,b,c) S_doencodes(aTHX_ a,b,c)
+#endif
+#ifdef PERL_CORE
+#define is_an_int(a,b) S_is_an_int(aTHX_ a,b)
#endif
#ifdef PERL_CORE
-#define measure_struct(a,b) S_measure_struct(aTHX_ a,b)
+#define div128(a,b) S_div128(aTHX_ a,b)
#endif
#endif
#if defined(PERL_IN_PP_CTL_C) || defined(PERL_DECL_PROT)
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
*THITHER = $standalone ? *STDOUT : *STDERR;
+my %transfmt = ();
my $transmo = <<EOFUNC;
sub transmo {
#local \$^W = 0; # recursive warnings we do NOT need!
) )
{
next;
- }
+ }
s/^/ /gm;
$msg{$header} .= $_;
undef $for_item;
}
}
- # 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"
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;
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();
#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"
=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 &
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"
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
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
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.
(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>
(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.
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
(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
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)
(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
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
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
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.
(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
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
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
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
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
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:
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.
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
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.
(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
(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
(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
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
(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
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
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.
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
=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.
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
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
(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:
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:
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
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
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>.
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:
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')
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 *
=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 *
=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 *
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.
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
$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
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 ) );
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
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.)
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
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
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" : '';
# 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)
{
#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:
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 */
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;
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;
return total;
}
-/* Returns -1 on no count or on star */
-STATIC I32
-S_find_count(pTHX_ char **ppat, register char *patend, int *star)
+
+/* locate matching closing parenthesis or bracket
+ * returns char pointer to char after match, or NULL
+ */
+STATIC char *
+S_group_end(pTHX_ register char *patptr, register char *patend, char ender)
{
- char *pat = *ppat;
- I32 len;
-
- *star = 0;
- if (pat >= patend)
- len = 1;
- else if (*pat == '*') {
- pat++;
- *star = 1;
- len = -1;
- }
- else if (isDIGIT(*pat)) {
- len = *pat++ - '0';
- while (isDIGIT(*pat)) {
- len = (len * 10) + (*pat++ - '0');
- if (len < 0) /* 50% chance of catching... */
- Perl_croak(aTHX_ "Repeat count in pack/unpack overflows");
- }
- }
- else if (*pat == '[') {
- char *end = group_end(++pat, patend, ']');
-
- len = 0;
- *ppat = end + 1;
- if (isDIGIT(*pat))
- return find_count(&pat, end, star);
- return measure_struct(pat, end);
+ while (patptr < patend) {
+ char c = *patptr++;
+
+ if (isSPACE(c))
+ continue;
+ else if (c == ender)
+ return patptr-1;
+ else if (c == '#') {
+ while (patptr < patend && *patptr != '\n')
+ patptr++;
+ continue;
+ } else if (c == '(')
+ patptr = group_end(patptr, patend, ')') + 1;
+ else if (c == '[')
+ patptr = group_end(patptr, patend, ']') + 1;
}
- else
- len = *star = -1;
- *ppat = pat;
- return len;
+ Perl_croak(aTHX_ "No group ending character '%c' found in template",
+ ender);
+ return 0;
}
+
+/* Convert unsigned decimal number to binary.
+ * Expects a pointer to the first digit and address of length variable
+ * Advances char pointer to 1st non-digit char and returns number
+ */
STATIC char *
-S_next_symbol(pTHX_ register char *pat, register char *patend)
+S_get_num(pTHX_ register char *patptr, I32 *lenptr )
+{
+ I32 len = *patptr++ - '0';
+ while (isDIGIT(*patptr)) {
+ if (len >= 0x7FFFFFFF/10)
+ Perl_croak(aTHX_ "pack/unpack repeat count overflow");
+ len = (len * 10) + (*patptr++ - '0');
+ }
+ *lenptr = len;
+ return patptr;
+}
+
+/* The marvellous template parsing routine: Using state stored in *symptr,
+ * locates next template code and count
+ */
+STATIC bool
+S_next_symbol(pTHX_ register tempsym_t* symptr )
{
- while (pat < patend) {
- if (isSPACE(*pat))
- pat++;
- else if (*pat == '#') {
- pat++;
- while (pat < patend && *pat != '\n')
- pat++;
- if (pat < patend)
- pat++;
+ register char* patptr = symptr->patptr;
+ register char* patend = symptr->patend;
+
+ symptr->flags &= ~FLAG_SLASH;
+
+ while (patptr < patend) {
+ if (isSPACE(*patptr))
+ patptr++;
+ else if (*patptr == '#') {
+ patptr++;
+ while (patptr < patend && *patptr != '\n')
+ patptr++;
+ if (patptr < patend)
+ patptr++;
+ } else {
+ /* We should have found a template code */
+ I32 code = *patptr++ & 0xFF;
+
+ if (code == ','){ /* grandfather in commas but with a warning */
+ if (((symptr->flags & FLAG_COMMA) == 0) && ckWARN(WARN_UNPACK)){
+ symptr->flags |= FLAG_COMMA;
+ Perl_warner(aTHX_ packWARN(WARN_UNPACK),
+ "Invalid type ',' in %s",
+ symptr->flags & FLAG_PACK ? "pack" : "unpack" );
+ }
+ continue;
+ }
+
+ /* for '(', skip to ')' */
+ if (code == '(') {
+ if( isDIGIT(*patptr) || *patptr == '*' || *patptr == '[' )
+ Perl_croak(aTHX_ "()-group starts with a count in %s",
+ symptr->flags & FLAG_PACK ? "pack" : "unpack" );
+ symptr->grpbeg = patptr;
+ patptr = 1 + ( symptr->grpend = group_end(patptr, patend, ')') );
+ if( symptr->level >= MAX_SUB_TEMPLATE_LEVEL )
+ Perl_croak(aTHX_ "Too deeply nested ()-groups in %s",
+ symptr->flags & FLAG_PACK ? "pack" : "unpack" );
+ }
+
+ /* test for '!' modifier */
+ if (patptr < patend && *patptr == '!') {
+ static const char natstr[] = "sSiIlLxX";
+ patptr++;
+ if (strchr(natstr, code))
+ code |= TYPE_IS_SHRIEKING;
+ else
+ Perl_croak(aTHX_ "'!' allowed only after types %s in pack/unpack",
+ natstr, symptr->flags & FLAG_PACK ? "pack" : "unpack" );
+ }
+
+ /* look for count and/or / */
+ if (patptr < patend) {
+ if (isDIGIT(*patptr)) {
+ patptr = get_num( patptr, &symptr->length );
+ symptr->howlen = e_number;
+
+ } else if (*patptr == '*') {
+ patptr++;
+ symptr->howlen = e_star;
+
+ } else if (*patptr == '[') {
+ char* lenptr = ++patptr;
+ symptr->howlen = e_number;
+ patptr = group_end( patptr, patend, ']' ) + 1;
+ /* what kind of [] is it? */
+ if (isDIGIT(*lenptr)) {
+ lenptr = get_num( lenptr, &symptr->length );
+ if( *lenptr != ']' )
+ Perl_croak(aTHX_ "Malformed integer in [] in %s",
+ symptr->flags & FLAG_PACK ? "pack" : "unpack");
+ } else {
+ tempsym_t savsym = *symptr;
+ symptr->patend = patptr-1;
+ symptr->patptr = lenptr;
+ savsym.length = measure_struct(symptr);
+ *symptr = savsym;
+ }
+ } else {
+ symptr->howlen = e_no_len;
+ symptr->length = 1;
+ }
+
+ /* try to find / */
+ while (patptr < patend) {
+ if (isSPACE(*patptr))
+ patptr++;
+ else if (*patptr == '#') {
+ patptr++;
+ while (patptr < patend && *patptr != '\n')
+ patptr++;
+ if (patptr < patend)
+ patptr++;
+ } else {
+ if( *patptr == '/' ){
+ symptr->flags |= FLAG_SLASH;
+ patptr++;
+ if( patptr < patend &&
+ (isDIGIT(*patptr) || *patptr == '*' || *patptr == '[') )
+ Perl_croak(aTHX_ "'/' does not take a repeat count in %s",
+ symptr->flags & FLAG_PACK ? "pack" : "unpack" );
+ }
+ break;
+ }
}
- else
- return pat;
+ } else {
+ /* at end - no count, no / */
+ symptr->howlen = e_no_len;
+ symptr->length = 1;
+ }
+
+ symptr->code = code;
+ symptr->patptr = patptr;
+ return TRUE;
}
- return pat;
+ }
+ symptr->patptr = patptr;
+ return FALSE;
}
/*
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;
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;
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 */
/* 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:
/* 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':
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 */
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) {
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);
}
}
else {
- if (len && (flags & UNPACK_ONLY_ONE))
+ if (len && unpack_only_one)
len = 1;
EXTEND(SP, len);
EXTEND_MORTAL(len);
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)
}
}
else {
- if (len && (flags & UNPACK_ONLY_ONE))
+ if (len && unpack_only_one)
len = 1;
EXTEND(SP, len);
EXTEND_MORTAL(len);
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;
}
}
else {
- if (len && (flags & UNPACK_ONLY_ONE))
+ if (len && unpack_only_one)
len = 1;
EXTEND(SP, len);
EXTEND_MORTAL(len);
}
}
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;
}
}
else {
- if (len && (flags & UNPACK_ONLY_ONE))
+ if (len && unpack_only_one)
len = 1;
EXTEND(SP, len);
EXTEND_MORTAL(len);
}
break;
case 'I':
+ case 'I' | TYPE_IS_SHRIEKING:
along = (strend - s) / sizeof(unsigned int);
if (len > along)
len = along;
}
}
else {
- if (len && (flags & UNPACK_ONLY_ONE))
+ if (len && unpack_only_one)
len = 1;
EXTEND(SP, len);
EXTEND_MORTAL(len);
}
}
else {
- if (len && (flags & UNPACK_ONLY_ONE))
+ if (len && unpack_only_one)
len = 1;
EXTEND(SP, len);
EXTEND_MORTAL(len);
}
}
else {
- if (len && (flags & UNPACK_ONLY_ONE))
+ if (len && unpack_only_one)
len = 1;
EXTEND(SP, len);
EXTEND_MORTAL(len);
}
}
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;
}
break;
case 'w':
- if (len && (flags & UNPACK_ONLY_ONE))
+ if (len && unpack_only_one)
len = 1;
EXTEND(SP, len);
EXTEND_MORTAL(len);
}
}
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;
}
}
else {
- if (len && (flags & UNPACK_ONLY_ONE))
+ if (len && unpack_only_one)
len = 1;
EXTEND(SP, len);
EXTEND_MORTAL(len);
}
}
else {
- if (len && (flags & UNPACK_ONLY_ONE))
+ if (len && unpack_only_one)
len = 1;
EXTEND(SP, len);
EXTEND_MORTAL(len);
}
}
else {
- if (len && (flags & UNPACK_ONLY_ONE))
+ if (len && unpack_only_one)
len = 1;
EXTEND(SP, len);
EXTEND_MORTAL(len);
}
}
else {
- if (len && (flags & UNPACK_ONLY_ONE))
+ if (len && unpack_only_one)
len = 1;
EXTEND(SP, len);
EXTEND_MORTAL(len);
}
}
else {
- if (len && (flags & UNPACK_ONLY_ONE))
+ if (len && unpack_only_one)
len = 1;
EXTEND(SP, len);
EXTEND_MORTAL(len);
}
}
else {
- if (len && (flags & UNPACK_ONLY_ONE))
+ if (len && unpack_only_one)
len = 1;
EXTEND(SP, len);
EXTEND_MORTAL(len);
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));
else {
if (checksum < bits_in_uv) {
UV mask = ((UV)1 << checksum) - 1;
-
cuv &= mask;
}
sv_setuv(sv, cuv);
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;
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);
return (m);
}
-#define PACK_CHILD 0x1
+
/*
=for apidoc pack_cat
=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;
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;
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:
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;
else
len = 0;
/* FALL THROUGH */
+
case 'x':
grow:
while (len >= 10) {
case 'a':
fromstr = NEXTFROM;
aptr = SvPV(fromstr, fromlen);
- if (star > 0) { /* -2 after '/' */
+ if (howlen == e_star) {
len = fromlen;
if (datumtype == 'Z')
++len;
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;
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;
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;
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;
CAT16(cat, &ashort);
}
break;
- case 'S':
+ case 'S' | TYPE_IS_SHRIEKING:
#if SHORTSIZE != SIZE16
- if (natint) {
+ {
unsigned short aushort;
while (len-- > 0) {
aushort = SvUV(fromstr);
sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
}
- }
- else
+ }
+ break;
+#else
+ /* Fall through! */
#endif
+ case 'S':
{
U16 aushort;
}
break;
- case 's':
+ case 's' | TYPE_IS_SHRIEKING:
#if SHORTSIZE != SIZE16
- if (natint) {
+ {
short ashort;
while (len-- > 0) {
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);
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
/* 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;
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);
/* 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;
}
break;
case 'i':
+ case 'i' | TYPE_IS_SHRIEKING:
while (len-- > 0) {
fromstr = NEXTFROM;
aint = SvIV(fromstr);
CAT32(cat, &aulong);
}
break;
- case 'L':
+ case 'L' | TYPE_IS_SHRIEKING:
#if LONGSIZE != SIZE32
- if (natint) {
+ {
unsigned long aulong;
while (len-- > 0) {
sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
}
}
- else
+ break;
+#else
+ /* Fall though! */
#endif
+ case 'L':
{
while (len-- > 0) {
fromstr = NEXTFROM;
}
}
break;
- case 'l':
+ case 'l' | TYPE_IS_SHRIEKING:
#if LONGSIZE != SIZE32
- if (natint) {
+ {
long along;
while (len-- > 0) {
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
#endif
case 'P':
len = 1; /* assume SV is correct length */
- /* FALL THROUGH */
+ /* Fall through! */
case 'p':
while (len-- > 0) {
fromstr = NEXTFROM;
}
break;
}
+ *symptr = lookahead;
}
- if (next_in_list)
- *next_in_list = beglist;
+ return beglist;
}
#undef NEXTFROM
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;
#endif
#if defined(PERL_IN_PP_PACK_C) || defined(PERL_DECL_PROT)
-STATIC void S_doencodes(pTHX_ SV* sv, char* s, I32 len);
+STATIC I32 S_unpack_rec(pTHX_ tempsym_t* symptr, char *s, char *strbeg, char *strend, char **new_s);
+STATIC SV ** S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist);
STATIC SV* S_mul128(pTHX_ SV *sv, U8 m);
+STATIC I32 S_measure_struct(pTHX_ tempsym_t* symptr);
+STATIC char * S_group_end(pTHX_ char *pat, char *patend, char ender);
+STATIC char * S_get_num(pTHX_ char *ppat, I32 *);
+STATIC bool S_next_symbol(pTHX_ tempsym_t* symptr);
+STATIC void S_doencodes(pTHX_ SV* sv, char* s, I32 len);
STATIC SV* S_is_an_int(pTHX_ char *s, STRLEN l);
STATIC int S_div128(pTHX_ SV *pnum, bool *done);
-STATIC char * S_next_symbol(pTHX_ char *pat, char *patend);
-STATIC I32 S_find_count(pTHX_ char **ppat, char *patend, int *star);
-STATIC char * S_group_end(pTHX_ char *pat, char *patend, char ender);
-STATIC I32 S_measure_struct(pTHX_ char *pat, char *patend);
#endif
#if defined(PERL_IN_PP_CTL_C) || defined(PERL_DECL_PROT)
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' ;
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
require './test.pl';
}
-plan tests => 5827;
+plan tests => 5849;
use strict;
use warnings;
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);
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, $_);
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);
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" };
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";
# 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
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);
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);
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);
}
projects / p5sagit/p5-mst-13.2.git / commitdiff