Front page | perl.perl5.porters |
Postings from October 1999
[PATCH 5.005_62] First round of unpack
Thread Next
From:
Ilya Zakharevich
Date:
October 27, 1999 00:06
Subject:
[PATCH 5.005_62] First round of unpack
Message ID:
199910270706.DAA26862@monk.mps.ohio-state.edu
This patch is *not* for inclusion into the core, but just to make you
discuss the new unpack specifiers 't' and 'T'.
What do they do? They are very similar, the only difference is how
they interpret a "count". They take part of the argument strings to
be an "embedded TEMPLATE".
"t6" takes 6 chars off the STRING, and extracts from the rest of the
string using this 6-char-long string as a TEMPLATE. "T" is equivalent
to "t1", so that "T6" is equivalent to "t1 t1 t1 t1 t1 t1".
To facilitate complicated data extraction, the following extensions
are allowed inside embedded templates:
*) Template of '/' is equivalent to 't/t'. [This makes it possible
to extract more or less arbitrary data with a TEMPLATE of 't'.]
Example of usage: you want the receiving end to obtain
qw(a bc def ghij)
but the receiving end does not know what data is there: you
want the receiver look like
@out = unpack 't', $string;
This data may be unpacked as
unpack 'A1 A2 A3 A4', 'abcdefghij'; # Now do transformations:
unpack 't11', 'A1 A2 A3 A4abcdefghij';
unpack 't2/t', 'A211A1 A2 A3 A4abcdefghij';
unpack 't4', 't2/tA211A1 A2 A3 A4abcdefghij';
unpack 't/t', 'A4t2/tA211A1 A2 A3 A4abcdefghij';
unpack 't', '/A4t2/tA211A1 A2 A3 A4abcdefghij';
It is not simple for manual coding, but as you can see, this
simple extension allows us to achieve our target.
*) If an embedded template starts with a digit, it is extracted as
if it were a6, not t6. This allows significant savings in the
above example:
unpack 'A1 A2 A3 A4', 'abcdefghij'; # Now do transformations:
unpack 't11', 'A1 A2 A3 A4abcdefghij';
unpack 't2/t', '11A1 A2 A3 A4abcdefghij';
unpack 't/t/t','211A1 A2 A3 A4abcdefghij';
unpack 't/t', '/211A1 A2 A3 A4abcdefghij';
unpack 't', '//211A1 A2 A3 A4abcdefghij';
*) One can put '\\', ']', '}' at the beginning of an embedded
template. This would substitute what is extracted using this
template by a scalar reference, array reference, hash reference
(as if \, [], {} were used).
*) Similarly, one can put '-' or ')' at the start of the template.
'-' expects that the rest of the template extracts two scalars,
and blesses the second one in the package given by the first one.
*) ')' takes the last element extracted by the embedded template,
interpretes it as a subroutine name, and makes a subroutine call.
[For safety this may be prohibited by using 't!6' or 'T!2'.]
These 5 extensions make it possible to extract almost-arbitrary data
from strings. The patch below has a completely finished unpack(),
pack() may follow if wanted.
[Note a possible security hazard: if people use a user-supplied
TEMPLATE for unpack, then the above !-protection may be not enough.
Some other mechanism (use pack 'eval'?) may be needed too.]
Enjoy,
Ilya
P.S. The bulk of the patch is a fix for an apparent bug: unpack was
storing the initial value of SP, then comparing SP to this
stored value. I do not understand how this might have worked,
given possible stack relocations.
--- ./pp.c-pre Tue Oct 12 00:16:26 1999
+++ ./pp.c Wed Oct 27 03:02:08 1999
@@ -3226,23 +3226,21 @@ S_mul128(pTHX_ SV *sv, U8 m)
#define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
#endif
-PP(pp_unpack)
+#define PACKf_SUBOK 1
+
+I32
+Perl_unpack(pTHX_ register char *pat, STRLEN patlen, register char *s, STRLEN slen, char **end, U32 flags)
{
djSP;
- dPOPPOPssrl;
- SV **oldsp = SP;
- I32 gimme = GIMME_V;
- SV *sv;
- STRLEN llen;
- STRLEN rlen;
- register char *pat = SvPV(left, llen);
- register char *s = SvPV(right, rlen);
- char *strend = s + rlen;
char *strbeg = s;
- register char *patend = pat + llen;
+ register char *patend = pat + patlen;
+ register char *strend = s + slen;
I32 datumtype;
register I32 len;
register I32 bits;
+ SV *sv;
+ register I32 cnt = 0;
+ STRLEN n_a;
/* These must not be in registers: */
I16 ashort;
@@ -3269,24 +3267,15 @@ PP(pp_unpack)
int natint; /* native integer */
int unatint; /* unsigned native integer */
#endif
+ int subok;
- if (gimme != G_ARRAY) { /* arrange to do first one only */
- /*SUPPRESS 530*/
- for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
- if (strchr("aAZbBhHP", *patend) || *pat == '%') {
- patend++;
- while (isDIGIT(*patend) || *patend == '*')
- patend++;
- }
- else
- patend++;
- }
while (pat < patend) {
reparse:
datumtype = *pat++ & 0xFF;
#ifdef PERL_NATINT_PACK
natint = 0;
#endif
+ subok = 1;
if (isSPACE(datumtype))
continue;
if (datumtype == '#') {
@@ -3297,14 +3286,16 @@ PP(pp_unpack)
if (*pat == '!') {
char *natstr = "sSiIlL";
+ pat++;
if (strchr(natstr, datumtype)) {
#ifdef PERL_NATINT_PACK
natint = 1;
#endif
- pat++;
}
+ else if (datumtype == 't' || datumtype == 'T')
+ subok = 0;
else
- DIE(aTHX_ "'!' allowed only after types %s", natstr);
+ Perl_croak(aTHX_ "'!' allowed only after types %s", natstr);
}
star = 0;
if (pat >= patend)
@@ -3316,10 +3307,10 @@ PP(pp_unpack)
}
else if (isDIGIT(*pat)) {
len = *pat++ - '0';
- while (isDIGIT(*pat)) {
+ while (pat < patend && isDIGIT(*pat)) {
len = (len * 10) + (*pat++ - '0');
if (len < 0)
- DIE(aTHX_ "Repeat count in unpack overflows");
+ Perl_croak(aTHX_ "Repeat count in unpack overflows");
}
}
else
@@ -3327,7 +3318,7 @@ PP(pp_unpack)
redo_switch:
switch(datumtype) {
default:
- DIE(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
+ Perl_croak(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
case ',': /* grandfather in commas but with a warning */
if (commas++ == 0 && ckWARN(WARN_UNSAFE))
Perl_warner(aTHX_ WARN_UNSAFE,
@@ -3344,30 +3335,186 @@ PP(pp_unpack)
break;
case '@':
if (len > strend - strbeg)
- DIE(aTHX_ "@ outside of string");
+ Perl_croak(aTHX_ "@ outside of string");
s = strbeg + len;
break;
case 'X':
if (len > s - strbeg)
- DIE(aTHX_ "X outside of string");
+ Perl_croak(aTHX_ "X outside of string");
s -= len;
break;
case 'x':
if (len > strend - s)
- DIE(aTHX_ "x outside of string");
+ Perl_croak(aTHX_ "x outside of string");
s += len;
break;
case '/':
- if (oldsp >= SP)
- DIE(aTHX_ "/ must follow a numeric type");
+ if (!cnt)
+ Perl_croak(aTHX_ "/ must follow a numeric type");
datumtype = *pat++;
if (*pat == '*')
pat++; /* ignore '*' for compatibility with pack */
if (isDIGIT(*pat))
- DIE(aTHX_ "/ cannot take a count" );
+ Perl_croak(aTHX_ "/ cannot take a count" );
len = POPi;
+ cnt--;
star = 0;
goto redo_switch;
+ case 'T':
+ bits = len;
+ len = 1;
+ goto do_t;
+ case 't':
+ bits = 1;
+ do_t:
+ while (bits--) {
+ I32 other_round = 0;
+ I32 c;
+
+ redo_t:
+ if (len > strend - s)
+ Perl_croak(aTHX_ "String too short for %c%ld",
+ datumtype, (long)len);
+ if (len == 1)
+ while (*s == '/') { /* Pretend we are t/t */
+ s++;
+ other_round++;
+ }
+ if (!len); /* Nothing: be causious */
+ else if (*s <= '9' && *s >= '0') { /* Shortcut it */
+ sv = NEWSV(35, len);
+ sv_setpvn(sv, s, len);
+ put_on_stack:
+ XPUSHs(sv_2mortal(sv));
+ cnt++;
+ s += len;
+ c = 1;
+ }
+ else if (*s == '.') { /* Undef */
+ sv = NEWSV(35, len);
+ goto put_on_stack;
+ }
+ else { /* Use the template */
+ char *mod_s = s;
+ char *mod_e = s;
+ I32 items;
+
+ c = 0;
+ /* Check for modifiers */
+ PUTBACK;
+ check_mod:
+ if (*s == '.') { /* Undef */
+ XPUSHs(&PL_sv_undef);
+ cnt++;
+ s++;
+ len--;
+ c++;
+ if (len)
+ goto check_mod;
+ }
+ else if (strchr("\\-]})", *s)) {
+ if (mod_e != s)
+ Perl_croak(aTHX_ "interrupted modifier flow");
+ if (*s == ')')
+ pp_pushmark();
+ s++;
+ len--;
+ mod_e = s;
+ if (len)
+ goto check_mod;
+ }
+ if (len) {
+ PUTBACK;
+ c += Perl_unpack(aTHX_ s, len,
+ s + len, strend - s - len, end,
+ (subok ? (flags & PACKf_SUBOK) : 0));
+ s = *end; /* Avoid deregisterization */
+ SPAGAIN;
+ }
+ while (mod_e-- >= mod_s) {
+ char *pack;
+ HV *hv;
+ AV *av;
+
+ switch (*mod_e) {
+ case '\\': /* Scalar ref */
+ if (c != 1)
+ Perl_croak(aTHX_ "Too many values for \\ modifier");
+ /* Claim the elts on the stack,
+ make a reference and unclaim it. */
+ sv = POPs;
+ SvREFCNT_inc(sv);
+ sv = Perl_newRV(aTHX_ sv);
+ PUSHs(Perl_sv_2mortal(aTHX_ sv));
+ break;
+ case '-': /* Blessed */
+ if (c != 2)
+ Perl_croak(aTHX_ "Too many values for - modifier");
+ sv = POPs;
+ pack = POPpx;
+ hv = Perl_gv_stashpv(aTHX_ pack, TRUE);
+ sv = Perl_sv_bless(aTHX_ sv, hv);
+ PUSHs(aTHX_ sv);
+ c--;
+ break;
+ case ']': /* Array ref */
+ /* Claim all the elts on the stack,
+ make a reference and unclaim it. */
+ along = c;
+ while (along--)
+ SvREFCNT_inc(*(SP--));
+ av = Perl_av_make(pTHX_ c, SP + 1);
+ sv = Perl_newRV_noinc(aTHX_ (SV*)av);
+ XPUSHs(Perl_sv_2mortal(aTHX_ sv));
+ c = 1;
+ break;
+ case '}': /* Hash ref */
+ if (c % 2)
+ Perl_croak(aTHX_ "Odd number of values for } modifier");
+ along = c;
+ hv = newHV();
+ /* Claim all the even elts on the stack,
+ make a reference and unclaim it. */
+ while (along > 0) {
+ sv = *(SP--);
+ if (Perl_hv_store_ent(aTHX_ hv, *(SP--), sv, 0))
+ SvREFCNT_inc(sv);
+ along -= 2;
+ }
+ sv = Perl_newRV_noinc(aTHX_ (SV*)hv);
+ XPUSHs(Perl_sv_2mortal(aTHX_ sv));
+ c = 1;
+ break;
+ case ')': /* Subroutine call */
+ if (!c)
+ Perl_croak(aTHX_ "No subroutine name for ) modifier");
+ if (!(subok && (flags & PACKf_SUBOK)))
+ Perl_croak(aTHX_ "modifier ) prohibited");
+ sv = POPs; /* Stupid to pop, when call_sv
+ will push it back again... */
+ PUTBACK;
+ ENTER;
+ /* */
+ c = Perl_call_sv(pTHX_ sv, G_ARRAY);
+ LEAVE;
+ SPAGAIN;
+ break;
+ }
+ }
+ cnt += c;
+ }
+ if (other_round--) {
+ if (c != 1)
+ Perl_croak(aTHX_ "t with #-data extracted %ld items",
+ (long)c);
+ len = POPi;
+ cnt--;
+ star = 0;
+ goto redo_t;
+ }
+ len = 1;
+ }
+ break;
case 'A':
case 'Z':
case 'a':
@@ -3395,6 +3542,7 @@ PP(pp_unpack)
s = aptr; /* unborrow register */
}
XPUSHs(sv_2mortal(sv));
+ cnt++;
break;
case 'B':
case 'b':
@@ -3463,6 +3611,7 @@ PP(pp_unpack)
*pat = '\0';
pat = aptr; /* unborrow register */
XPUSHs(sv_2mortal(sv));
+ cnt++;
break;
case 'H':
case 'h':
@@ -3496,6 +3645,7 @@ PP(pp_unpack)
*pat = '\0';
pat = aptr; /* unborrow register */
XPUSHs(sv_2mortal(sv));
+ cnt++;
break;
case 'c':
if (len > strend - s)
@@ -3511,6 +3661,7 @@ PP(pp_unpack)
else {
EXTEND(SP, len);
EXTEND_MORTAL(len);
+ cnt += len;
while (len-- > 0) {
aint = *s++;
if (aint >= 128) /* fake up signed chars */
@@ -3534,6 +3685,7 @@ PP(pp_unpack)
else {
EXTEND(SP, len);
EXTEND_MORTAL(len);
+ cnt += len;
while (len-- > 0) {
auint = *s++ & 255;
sv = NEWSV(37, 0);
@@ -3558,6 +3710,7 @@ PP(pp_unpack)
else {
EXTEND(SP, len);
EXTEND_MORTAL(len);
+ cnt += len;
while (len-- > 0 && s < strend) {
auint = utf8_to_uv((U8*)s, &along);
s += along;
@@ -3603,6 +3756,7 @@ PP(pp_unpack)
else {
EXTEND(SP, len);
EXTEND_MORTAL(len);
+ cnt += len;
#if SHORTSIZE != SIZE16
if (natint) {
short ashort;
@@ -3673,6 +3827,7 @@ PP(pp_unpack)
else {
EXTEND(SP, len);
EXTEND_MORTAL(len);
+ cnt += len;
#if SHORTSIZE != SIZE16
if (unatint) {
unsigned short aushort;
@@ -3722,6 +3877,7 @@ PP(pp_unpack)
else {
EXTEND(SP, len);
EXTEND_MORTAL(len);
+ cnt += len;
while (len-- > 0) {
Copy(s, &aint, 1, int);
s += sizeof(int);
@@ -3773,6 +3929,7 @@ PP(pp_unpack)
else {
EXTEND(SP, len);
EXTEND_MORTAL(len);
+ cnt += len;
while (len-- > 0) {
Copy(s, &auint, 1, unsigned int);
s += sizeof(unsigned int);
@@ -3830,6 +3987,7 @@ PP(pp_unpack)
else {
EXTEND(SP, len);
EXTEND_MORTAL(len);
+ cnt += len;
#if LONGSIZE != SIZE32
if (natint) {
long along;
@@ -3906,6 +4064,7 @@ PP(pp_unpack)
else {
EXTEND(SP, len);
EXTEND_MORTAL(len);
+ cnt += len;
#if LONGSIZE != SIZE32
if (unatint) {
unsigned long aulong;
@@ -3944,6 +4103,7 @@ PP(pp_unpack)
len = along;
EXTEND(SP, len);
EXTEND_MORTAL(len);
+ cnt += len;
while (len-- > 0) {
if (sizeof(char*) > strend - s)
break;
@@ -3960,6 +4120,7 @@ PP(pp_unpack)
case 'w':
EXTEND(SP, len);
EXTEND_MORTAL(len);
+ cnt += len;
{
UV auv = 0;
U32 bytes = 0;
@@ -3996,7 +4157,7 @@ PP(pp_unpack)
}
}
if ((s >= strend) && bytes)
- DIE(aTHX_ "Unterminated compressed integer");
+ Perl_croak(aTHX_ "Unterminated compressed integer");
}
break;
case 'P':
@@ -4011,6 +4172,7 @@ PP(pp_unpack)
if (aptr)
sv_setpvn(sv, aptr, len);
PUSHs(sv_2mortal(sv));
+ cnt++;
break;
#ifdef HAS_QUAD
case 'q':
@@ -4019,6 +4181,7 @@ PP(pp_unpack)
len = along;
EXTEND(SP, len);
EXTEND_MORTAL(len);
+ cnt += len;
while (len-- > 0) {
if (s + sizeof(Quad_t) > strend)
aquad = 0;
@@ -4040,6 +4203,7 @@ PP(pp_unpack)
len = along;
EXTEND(SP, len);
EXTEND_MORTAL(len);
+ cnt += len;
while (len-- > 0) {
if (s + sizeof(Uquad_t) > strend)
auquad = 0;
@@ -4072,6 +4236,7 @@ PP(pp_unpack)
else {
EXTEND(SP, len);
EXTEND_MORTAL(len);
+ cnt += len;
while (len-- > 0) {
Copy(s, &afloat, 1, float);
s += sizeof(float);
@@ -4096,6 +4261,7 @@ PP(pp_unpack)
else {
EXTEND(SP, len);
EXTEND_MORTAL(len);
+ cnt += len;
while (len-- > 0) {
Copy(s, &adouble, 1, double);
s += sizeof(double);
@@ -4162,6 +4328,7 @@ PP(pp_unpack)
s += 2;
}
XPUSHs(sv_2mortal(sv));
+ cnt++;
break;
}
if (checksum) {
@@ -4195,10 +4362,44 @@ PP(pp_unpack)
sv_setuv(sv, (UV)culong);
}
XPUSHs(sv_2mortal(sv));
+ cnt++;
checksum = 0;
}
}
- if (SP == oldsp && gimme == G_SCALAR)
+ *end = s;
+ PUTBACK;
+ return cnt;
+}
+
+PP(pp_unpack)
+{
+ djSP;
+ dPOPPOPssrl;
+ I32 gimme = GIMME_V;
+ STRLEN llen;
+ STRLEN rlen;
+ register char *pat = SvPV(left, llen);
+ register char *s = SvPV(right, rlen);
+ char *dummy;
+ I32 cnt;
+
+ if (gimme != G_ARRAY) { /* arrange to do first one only */
+ register char *patend;
+ /*SUPPRESS 530*/
+ for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
+ if (strchr("aAZbBhHP", *patend) || *pat == '%') {
+ patend++;
+ while (isDIGIT(*patend) || *patend == '*')
+ patend++;
+ }
+ else
+ patend++;
+ llen = patend - pat;
+ }
+ PUTBACK;
+ cnt = Perl_unpack(aTHX_ pat, llen, s, rlen, &dummy, PACKf_SUBOK);
+ SPAGAIN;
+ if ( !cnt && gimme == G_SCALAR )
PUSHs(&PL_sv_undef);
RETURN;
}
--- ./t/op/pack.t-pre Tue Oct 12 00:19:04 1999
+++ ./t/op/pack.t Wed Oct 27 02:56:30 1999
@@ -6,7 +6,7 @@ BEGIN {
require Config; import Config;
}
-print "1..156\n";
+print "1..275\n";
$format = "c2 x5 C C x s d i l a6";
# Need the expression in here to force ary[5] to be numeric. This avoids
@@ -400,3 +400,223 @@ $z = pack <<EOP,'string','etc';
w/A* # Count a BER integer
EOP
print 'not ' unless $z eq "\000\006string\003etc"; print "ok $test\n"; $test++;
+
+(@z) = unpack 't3C*', 'A12ab3456789012erg';
+print 'not ' unless @z == 4; print "ok $test\n"; $test++;
+print 'not ' unless "@z" eq "ab3456789012 101 114 103";
+print "ok $test\n"; $test++;
+
+(@z) = unpack 'tC*', '/6A10 A2ab3456789012erg';
+print 'not ' unless @z == 5; print "ok $test\n"; $test++;
+print 'not ' unless "@z" eq "ab34567890 12 101 114 103";
+print "ok $test\n"; $test++;
+
+(@z) = unpack 't/tC*', '6A10 A2ab3456789012erg';
+print 'not ' unless @z == 5; print "ok $test\n"; $test++;
+print 'not ' unless "@z" eq "ab34567890 12 101 114 103";
+print "ok $test\n"; $test++;
+
+(@z) = unpack 't/tC*', 'A6A10 A2ab3456789012erg';
+print "# $#z\nnot " unless @z == 5; print "ok $test\n"; $test++;
+print "# '@z'\nnot " unless "@z" eq "ab34567890 12 101 114 103";
+print "ok $test\n"; $test++;
+
+(@z) = unpack 'TC*', '/6A10 A2ab3456789012erg';
+print 'not ' unless @z == 5; print "ok $test\n"; $test++;
+print 'not ' unless "@z" eq "ab34567890 12 101 114 103";
+print "ok $test\n"; $test++;
+
+(@z) = unpack 'T2C2A*', '/6A10 A2ab3456789012Cerg';
+print 'not ' unless @z == 6; print "ok $test\n"; $test++;
+print 'not ' unless "@z" eq "ab34567890 12 101 114 103 ";
+print "ok $test\n"; $test++;
+
+(@z) = unpack 't/TC2A*', 'A2/6A10 A2ab3456789012Cerg';
+print "# $#z\nnot " unless @z == 6; print "ok $test\n"; $test++;
+print "# '@z'\nnot " unless "@z" eq "ab34567890 12 101 114 103 ";
+print "ok $test\n"; $test++;
+
+(@z) = unpack 't', '.';
+print "# $#z\nnot " unless @z == 1; print "ok $test\n"; $test++;
+print "# '@z'\nnot " if defined $z[0]; print "ok $test\n"; $test++;
+
+(@z) = unpack 't2', '\\.';
+print "# $#z\nnot " unless @z == 1; print "ok $test\n"; $test++;
+print "# '@z'\nnot " if ref $z[0] ne 'SCALAR'; print "ok $test\n"; $test++;
+print "# '@z'\nnot " if defined ${$z[0]}; print "ok $test\n"; $test++;
+
+(@z) = unpack 't3', '\\A2ab';
+print "# $#z\nnot " unless @z == 1; print "ok $test\n"; $test++;
+print "# '@z'\nnot " unless ref $z[0] eq 'SCALAR'; print "ok $test\n"; $test++;
+print "# '@z'\nnot " unless ${$z[0]} eq "ab";
+print "ok $test\n"; $test++;
+
+(@z) = unpack 't4', '\\\\A2ab';
+print "# $#z\nnot " unless @z == 1; print "ok $test\n"; $test++;
+print "# '@z'\nnot " unless ref $z[0] eq 'REF'; print "ok $test\n"; $test++;
+print "# '@z'\nnot " unless ref ${$z[0]} eq 'SCALAR'; print "ok $test\n"; $test++;
+print "# '@z'\nnot " unless $${$z[0]} eq "ab";
+print "ok $test\n"; $test++;
+
+(@z) = unpack 't1', ']';
+print "# $#z\nnot " unless @z == 1; print "ok $test\n"; $test++;
+print "# '@z'\nnot " if ref $z[0] ne 'ARRAY'; print "ok $test\n"; $test++;
+print "# $#z\nnot " unless @{$z[0]} == 0; print "ok $test\n"; $test++;
+
+(@z) = unpack 't2', '].';
+print "# $#z\nnot " unless @z == 1; print "ok $test\n"; $test++;
+print "# '@z'\nnot " if ref $z[0] ne 'ARRAY'; print "ok $test\n"; $test++;
+print "# $#z\nnot " unless @{$z[0]} == 1; print "ok $test\n"; $test++;
+print "# '@z'\nnot " if defined $z[0]->[0]; print "ok $test\n"; $test++;
+
+(@z) = unpack 't3', ']A2ab';
+print "# $#z\nnot " unless @z == 1; print "ok $test\n"; $test++;
+print "# '@z'\nnot " unless ref $z[0] eq 'ARRAY'; print "ok $test\n"; $test++;
+print "# $#z\nnot " unless @{$z[0]} == 1; print "ok $test\n"; $test++;
+print "not " unless defined $z[0]->[0]; print "ok $test\n"; $test++;
+print "# '$z[0]->[0]'\nnot " unless $z[0]->[0] eq "ab";
+print "ok $test\n"; $test++; # 194
+
+(@z) = unpack 't4', ']]A2ab';
+print "# $#z\nnot " unless @z == 1; print "ok $test\n"; $test++;
+print "# '@z'\nnot " unless ref $z[0] eq 'ARRAY'; print "ok $test\n"; $test++;
+print "not " unless @{$z[0]} == 1; print "ok $test\n"; $test++;
+print "not " unless ref $z[0][0] eq 'ARRAY'; print "ok $test\n"; $test++;
+print "not " unless @{$z[0][0]} == 1; print "ok $test\n"; $test++;
+print "not " unless $z[0]->[0]->[0] eq "ab";
+print "ok $test\n"; $test++;
+
+(@z) = unpack 't4', '\\]A2ab';
+print "# $#z\nnot " unless @z == 1; print "ok $test\n"; $test++;
+print "# '@z'\nnot " unless ref $z[0] eq 'REF'; print "ok $test\n"; $test++;
+print "not " unless ref ${$z[0]} eq 'ARRAY'; print "ok $test\n"; $test++;
+print "not " unless @${$z[0]} == 1; print "ok $test\n"; $test++;
+print "not " unless ${$z[0]}->[0] eq "ab"; print "ok $test\n"; $test++;
+
+(@z) = unpack 't4', ']\\A2ab';
+print "# $#z\nnot " unless @z == 1; print "ok $test\n"; $test++;
+print "# '@z'\nnot " unless ref $z[0] eq 'ARRAY'; print "ok $test\n"; $test++;
+print "not " unless @{$z[0]} == 1; print "ok $test\n"; $test++;
+print "not " unless ref $z[0][0] eq 'SCALAR'; print "ok $test\n"; $test++;
+print "not " unless ${$z[0]->[0]} eq "ab"; print "ok $test\n"; $test++;
+
+(@z) = unpack 't', '}';
+print "# $#z\nnot " unless @z == 1; print "ok $test\n"; $test++;
+print "# '@z'\nnot " if ref $z[0] ne 'HASH'; print "ok $test\n"; $test++;
+print "not " unless (keys %{$z[0]}) == 0; print "ok $test\n"; $test++;
+
+(@z) = unpack 't7', '}AA2AA2xXXzZZ';
+print "# $#z\nnot " unless @z == 1; print "ok $test\n"; $test++;
+print "# '@z'\nnot " if ref $z[0] ne 'HASH'; print "ok $test\n"; $test++;
+@k = sort keys %{$z[0]};
+print "# '@k'\nnot " unless @k == 2; print "ok $test\n"; $test++;
+print "# '@k'\nnot " unless "@k" eq "x z"; print "ok $test\n"; $test++;
+print "# '@{$z[0]}{@k}'\nnot " unless "@{$z[0]}{@k}" eq "XX ZZ"; print "ok $test\n"; $test++;
+
+(@z) = unpack 't8', '\\}AA2AA2xXXzZZ';
+print "# $#z\nnot " unless @z == 1; print "ok $test\n"; $test++;
+print "# '@z'\nnot " if ref $z[0] ne 'REF'; print "ok $test\n"; $test++;
+@z = ${$z[0]};
+# 221
+print "# '@z'\nnot " if ref $z[0] ne 'HASH'; print "ok $test\n"; $test++;
+@k = sort keys %{$z[0]};
+print "# '@k'\nnot " unless @k == 2; print "ok $test\n"; $test++;
+print "# '@k'\nnot " unless "@k" eq "x z"; print "ok $test\n"; $test++;
+print "# '@{$z[0]}{@k}'\nnot " unless "@{$z[0]}{@k}" eq "XX ZZ"; print "ok $test\n"; $test++;
+
+(@z) = unpack 't6', '\\}A2t3xy]A2ab';
+print "# $#z\nnot " unless @z == 1; print "ok $test\n"; $test++;
+print "# '@z'\nnot " if ref $z[0] ne 'REF'; print "ok $test\n"; $test++;
+@z = ${$z[0]};
+# 221
+print "# '@z'\nnot " if ref $z[0] ne 'HASH'; print "ok $test\n"; $test++;
+@k = sort keys %{$z[0]};
+print "# '@k'\nnot " unless @k == 1; print "ok $test\n"; $test++;
+print "# '@k'\nnot " unless "@k" eq "xy"; print "ok $test\n"; $test++;
+@z = @{$z[0]}{@k};
+print "# $#z\nnot " unless @z == 1; print "ok $test\n"; $test++;
+print "# '@z'\nnot " unless ref $z[0] eq 'ARRAY'; print "ok $test\n"; $test++;
+print "# $#z\nnot " unless @{$z[0]} == 1; print "ok $test\n"; $test++;
+print "not " unless defined $z[0]->[0]; print "ok $test\n"; $test++;
+print "# '$z[0]->[0]'\nnot " unless $z[0]->[0] eq "ab";
+print "ok $test\n"; $test++;
+
+(@z) = unpack 't5', '-A3t6abc\\}A2t3xy]A2ab';
+print "# $#z\nnot " unless @z == 1; print "ok $test\n"; $test++;
+print "# '@z'\nnot " if ref $z[0] ne 'abc'; print "ok $test\n"; $test++;
+print "# '@z'\nnot " if "$z[0]" !~ /^abc=SCALAR\(/; print "ok $test\n"; $test++;
+@z = ${$z[0]};
+# 221
+print "# '@z'\nnot " if ref $z[0] ne 'HASH'; print "ok $test\n"; $test++;
+@k = sort keys %{$z[0]};
+print "# '@k'\nnot " unless @k == 1; print "ok $test\n"; $test++;
+print "# '@k'\nnot " unless "@k" eq "xy"; print "ok $test\n"; $test++;
+@z = @{$z[0]}{@k};
+print "# $#z\nnot " unless @z == 1; print "ok $test\n"; $test++;
+print "# '@z'\nnot " unless ref $z[0] eq 'ARRAY'; print "ok $test\n"; $test++;
+print "# $#z\nnot " unless @{$z[0]} == 1; print "ok $test\n"; $test++;
+print "not " unless defined $z[0]->[0]; print "ok $test\n"; $test++;
+print "# '$z[0]->[0]'\nnot " unless $z[0]->[0] eq "ab";
+print "ok $test\n"; $test++;
+
+(@z) = unpack 't5', '-A3t6abc\\}A2t5xy-A2t3FG]A2ab';
+print "# $#z\nnot " unless @z == 1; print "ok $test\n"; $test++;
+print "# '@z'\nnot " if ref $z[0] ne 'abc'; print "ok $test\n"; $test++;
+print "# '@z'\nnot " if "$z[0]" !~ /^abc=SCALAR\(/; print "ok $test\n"; $test++;
+@z = ${$z[0]};
+# 221
+print "# '@z'\nnot " if ref $z[0] ne 'HASH'; print "ok $test\n"; $test++;
+@k = sort keys %{$z[0]};
+print "# '@k'\nnot " unless @k == 1; print "ok $test\n"; $test++;
+print "# '@k'\nnot " unless "@k" eq "xy"; print "ok $test\n"; $test++;
+@z = @{$z[0]}{@k};
+print "# $#z\nnot " unless @z == 1; print "ok $test\n"; $test++;
+print "# '@z'\nnot " unless ref $z[0] eq 'FG'; print "ok $test\n"; $test++;
+print "# '@z'\nnot " unless "$z[0]" =~ /FG=ARRAY\(/; print "ok $test\n"; $test++;
+print "# $#z\nnot " unless @{$z[0]} == 1; print "ok $test\n"; $test++;
+print "not " unless defined $z[0]->[0]; print "ok $test\n"; $test++;
+print "# '$z[0]->[0]'\nnot " unless $z[0]->[0] eq "ab";
+print "ok $test\n"; $test++;
+
+sub sp {
+ my $c = @_;
+ print "# $c args\nnot " if $c != 3; print "ok $test\n"; $test++;
+ my ($x, $y, $z) = (shift, shift, shift);
+ ($x + $y*$z, $x*$y + $z);
+}
+
+(@z) = unpack 'At7', 'x)AAA2A26712sp';
+print 'not ' unless @z == 3; print "ok $test\n"; $test++;
+print 'not ' unless "@z" eq "x 90 54";
+print "ok $test\n"; $test++;
+
+(@z) = unpack 'AAA2A2', '6712spyz';
+print 'not ' unless @z == 4; print "ok $test\n"; $test++;
+print "# '@z'\nnot " unless "@z" eq "6 7 12 sp"; print "ok $test\n"; $test++;
+
+(@z) = unpack 'At6A2', 'xAAA2A26712spyz';
+print 'not ' unless @z == 6; print "ok $test\n"; $test++;
+print "# '@z'\nnot " unless "@z" eq "x 6 7 12 sp yz";
+print "ok $test\n"; $test++;
+
+(@z) = unpack 'At7A2', 'x]AAA2A26712spyz';
+print 'not ' unless @z == 3; print "ok $test\n"; $test++;
+print "# '@z'\nnot " unless "$z[0] $z[2]" eq "x yz"; print "ok $test\n"; $test++;
+print 'not ' unless ref $z[1] eq "ARRAY"; print "ok $test\n"; $test++;
+print "# '@{$z[1]}'\nnot " unless "@{$z[1]}" eq "6 7 12 sp";
+print "ok $test\n"; $test++;
+
+(@z) = unpack 'At7A2', 'x)AAA2A26712spyz';
+print 'not ' unless @z == 4; print "ok $test\n"; $test++;
+print 'not ' unless "@z" eq "x 90 54 yz";
+print "ok $test\n"; $test++;
+
+@z = eval { unpack 'At!7A2', 'x)AAA2A26712spyz' };
+print "# z='@z', \$\@='$@'\nnot " unless @z == 0 and $@ =~ /modifier \) prohibited/; print "ok $test\n"; $test++;
+
+@z = eval { unpack 'At!2A2', 'xt7)AAA2A26712spyz' };
+print "# z='@z', \$\@='$@'\nnot " unless @z == 0 and $@ =~ /modifier \) prohibited/; print "ok $test\n"; $test++;
+
+@z = unpack 't', '//211A1 A2 A3 A4abcdefghij';
+print 'not ' unless @z == 4; print "ok $test\n"; $test++;
+print 'not ' unless "@z" eq "a bc def ghij"; print "ok $test\n"; $test++;
Thread Next
-
[PATCH 5.005_62] First round of unpack
by Ilya Zakharevich