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)
#define next_symbol S_next_symbol
#define find_count S_find_count
#define group_end S_group_end
+#define measure_struct S_measure_struct
#endif
#if defined(PERL_IN_PP_CTL_C) || defined(PERL_DECL_PROT)
#define docatch S_docatch
#define next_symbol(a,b) S_next_symbol(aTHX_ a,b)
#define find_count(a,b,c) S_find_count(aTHX_ a,b,c)
#define group_end(a,b,c) S_group_end(aTHX_ a,b,c)
+#define measure_struct(a,b) S_measure_struct(aTHX_ a,b)
#endif
#if defined(PERL_IN_PP_CTL_C) || defined(PERL_DECL_PROT)
#define docatch(a) S_docatch(aTHX_ a)
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
x A null byte.
X Back up a byte.
@ Null fill to absolute position.
- ( Beginning of a ()-group.
+ ( Start of a ()-group.
The following rules apply:
Each letter may optionally be followed by a number giving a repeat
count. With all types except C<a>, C<A>, C<Z>, C<b>, C<B>, C<h>,
-C<H>, and C<P> the pack function will gobble up that many values from
-the LIST. A C<*> for the repeat count means to use however many items are
-left, except for C<@>, C<x>, C<X>, where it is equivalent
-to C<0>, and C<u>, where it is equivalent to 1 (or 45, what is the
-same). A numeric repeat count may optionally be enclosed in brackets, as in
-C<pack 'C[80]', @arr>.
+C<H>, C<@>, C<x>, C<X> and C<P> the pack function will gobble up that
+many values from the LIST. A C<*> for the repeat count means to use
+however many items are left, except for C<@>, C<x>, C<X>, where it is
+equivalent to C<0>, and C<u>, where it is equivalent to 1 (or 45, what
+is the same). A numeric repeat count may optionally be enclosed in
+brackets, as in C<pack 'C[80]', @arr>.
+
+One can replace the numeric repeat count by a template enclosed in brackets;
+then the packed length of this template in bytes is used as a count.
+For example, C<x[L]> skips a long (it skips the number of bytes in a long).
When used with C<Z>, C<*> results in the addition of a trailing null
byte (so the packed result will be one longer than the byte C<length>
continue;
} else if (c == '(')
pat = group_end(pat, patend, ')') + 1;
+ else if (c == '[')
+ pat = group_end(pat, patend, ']') + 1;
}
croak("No group ending character `%c' found", ender);
}
+/* Returns the sizeof() struct described by pat */
+I32
+S_measure_struct(pTHX_ char *pat, register char *patend)
+{
+ I32 datumtype;
+ register I32 len;
+ 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];
+ 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 = "sSiIlL";
+
+ if (strchr(natstr, datumtype)) {
+#ifdef PERL_NATINT_PACK
+ natint = 1;
+#endif
+ pat++;
+ }
+ else
+ croak("'!' allowed only after types %s", natstr);
+ }
+ len = find_count(&pat, patend, &star);
+ if (star > 0) /* */
+ croak("%s not allowed in length fields", "count *");
+ else if (star < 0) /* No explicit len */
+ len = datumtype != '@';
+
+ switch(datumtype) {
+ default:
+ croak("Invalid type in unpack: '%c'", (int)datumtype);
+ case '@':
+ case '/':
+ case 'U': /* XXXX Is it correct? */
+ case 'w':
+ case 'u':
+ buf[0] = datumtype;
+ buf[1] = 0;
+ croak("%s not allowed in length fields", buf);
+ case ',': /* grandfather in commas but with a warning */
+ if (commas++ == 0 && ckWARN(WARN_UNPACK))
+ Perl_warner(aTHX_ WARN_UNPACK,
+ "Invalid type in unpack: '%c'", (int)datumtype);
+ /* FALL THROUGH */
+ case '%':
+ size = 0;
+ break;
+ case '(':
+ {
+ char *beg = pat, *end;
+
+ if (star >= 0)
+ croak("()-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 */
+ croak("%s not allowed in length fields", "count *");
+ size = measure_struct(beg, end);
+ break;
+ }
+ case 'X':
+ size = -1;
+ if (total < len)
+ croak("X outside of string");
+ break;
+ case 'x':
+ case 'A':
+ case 'Z':
+ case 'a':
+ case 'c':
+ case 'C':
+ size = 1;
+ break;
+ case 'B':
+ case 'b':
+ len = (len + 7)/8;
+ size = 1;
+ break;
+ case 'H':
+ case 'h':
+ len = (len + 1)/2;
+ size = 1;
+ break;
+ case 's':
+#if SHORTSIZE == SIZE16
+ size = SIZE16;
+#else
+ size = (natint ? sizeof(short) : SIZE16);
+#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':
+ size = sizeof(int);
+ break;
+ case 'I':
+ size = sizeof(unsigned int);
+ break;
+ case 'l':
+#if LONGSIZE == SIZE32
+ size = SIZE32;
+#else
+ size = (natint ? sizeof(long) : SIZE32);
+#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;
+ /* FALL THROUGH */
+ case 'p':
+ size = sizeof(char*);
+ break;
+#ifdef HAS_QUAD
+ case 'q':
+ size = sizeof(Quad_t);
+ break;
+ case 'Q':
+ size = sizeof(Uquad_t);
+ break;
+#endif
+ case 'f':
+ case 'F':
+ size = sizeof(float);
+ break;
+ case 'd':
+ case 'D':
+ size = sizeof(double);
+ break;
+ }
+ total += len * size;
+ }
+ return total;
+}
+
/* Returns -1 on no count or on star */
STATIC I32
S_find_count(pTHX_ char **ppat, register char *patend, int *star)
else if (isDIGIT(*pat) || *pat == '[') {
bool brackets = *pat == '[';
- if (brackets)
+ if (brackets) {
++pat, len = 0;
+ if (!isDIGIT(*pat)) {
+ char *end = group_end(pat, patend, ']');
+
+ *ppat = end + 1;
+ return measure_struct(pat, end);
+ }
+ }
else
len = *pat++ - '0';
while (isDIGIT(*pat)) {
return pat;
}
-
/*
=for apidoc unpack_str
#ifdef PERL_NATINT_PACK
natint = 0;
#endif
+ /* 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)
+ && (SP - PL_stack_base == start_sp_offset + 1)
+ && (datumtype != '/') )
+ break;
if (*pat == '!') {
- char *natstr = "sSiIlL";
+ static const char natstr[] = "sSiIlL";
if (strchr(natstr, datumtype)) {
#ifdef PERL_NATINT_PACK
if (star > 0)
len = strend - strbeg; /* long enough */
else if (star < 0) /* No explicit len */
- len = datumtype != '@';
+ len = datumtype != '@';
redo_switch:
switch(datumtype) {
}
break;
case 'Q':
- along = (strend - s) / sizeof(Quad_t);
+ along = (strend - s) / sizeof(Uquad_t);
if (len > along)
len = along;
if (checksum) {
XPUSHs(sv_2mortal(sv));
checksum = 0;
}
- if ((flags & UNPACK_ONLY_ONE)
- && SP - PL_stack_base == start_sp_offset + 1) {
- /* do first one only unless in list context
- / is implmented by unpacking the count, then poping it from the
- stack, so must check that we're not in the middle of a / */
- if ((pat >= patend) || *pat != '/')
- break;
- }
}
if (new_s)
*new_s = s;
natint = 0;
#endif
if (*pat == '!') {
- char *natstr = "sSiIlL";
+ static const char natstr[] = "sSiIlL";
if (strchr(natstr, datumtype)) {
#ifdef PERL_NATINT_PACK
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)
require './test.pl';
}
-plan tests => 1493;
+plan tests => 3943;
use strict;
use warnings;
@a = unpack '(SL)3 SL', pack '(SL)*', 67..74;
is("@a", "@b");
}
+
+{ # 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 D
+ s! S! i! I! l! L! );
+ if (eval { pack 'q', 1 } ) {
+ push @codes, qw(q Q);
+ } else {
+ push @codes, qw(c C); # Keep the count the same
+ }
+
+ my %val;
+ @val{@codes} = map { / [Xx] (?{ undef })
+ | [AZa] (?{ 'something' })
+ | C (?{ 214 })
+ | c (?{ 114 })
+ | [Bb] (?{ '101' })
+ | [Hh] (?{ 'b8' })
+ | [svnSiIlVNLqQ] (?{ 10111 })
+ | [FfDd] (?{ 1.36514538e67 })
+ | [pP] (?{ "try this buffer" })
+ /x; $^R } @codes;
+ my @end = (0x12345678, 0x23456781, 0x35465768, 0x15263748);
+ my $end = "N4";
+
+ for my $type (@codes) {
+ my @list = $val{$type};
+ @list = () unless defined $list[0];
+ for my $count ('', '3', '[11]') {
+ my $c = 1;
+ $c = $1 if $count =~ /(\d+)/;
+ my @list1 = @list;
+ @list1 = (@list1) x $c unless $type =~ /[XxAaZBbHhP]/;
+ for my $groupend ('', ')2', ')[8]') {
+ my $groupbegin = ($groupend ? '(' : '');
+ $c = 1;
+ $c = $1 if $groupend =~ /(\d+)/;
+ my @list2 = (@list1) x $c;
+
+ my $junk1 = "$groupbegin $type$count $groupend";
+ # print "# junk1=$junk1\n";
+ my $p = pack $junk1, @list2;
+ my $half = int( (length $p)/2 );
+ for my $move ('', "X$half", 'x1', "x$half") {
+ my $junk = "$junk1 $move";
+ # print "# junk=$junk list=(@list2)\n";
+ $p = pack "$junk $end", @list2, @end;
+ my @l = unpack "x[$junk] $end", $p;
+ is(scalar @l, scalar @end);
+ is("@l", "@end", "skipping x[$junk]");
+ }
+ }
+ }
+ }
+}
+
+# / is recognized after spaces in scalar context
+# XXXX no spaces are allowed in pack... In pack only before the slash...
+is(scalar unpack('A /A Z20', pack 'A/A* Z20', 'bcde', 'xxxxx'), 'bcde');
+is(scalar unpack('A /A /A Z20', '3004bcde'), 'bcde');
projects / p5sagit/p5-mst-13.2.git / commitdiff