/* pp_pack.c
*
- * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, by Larry Wall and others
+ * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
+ * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
* wooden spoon, a short two-pronged fork and some skewers were stowed; and
* hidden at the bottom of the pack in a flat wooden box a dwindling treasure,
* some salt.
+ *
+ * [p.653 of _The Lord of the Rings_, IV/iv: "Of Herbs and Stewed Rabbit"]
*/
/* This file contains pp ("push/pop") functions that
# define DO_BO_UNPACK_PC(var) DO_BO_UNPACK_PTR(var, i, int, char)
# define DO_BO_PACK_PC(var) DO_BO_PACK_PTR(var, i, int, char)
# elif PTRSIZE == LONGSIZE
-# define DO_BO_UNPACK_P(var) DO_BO_UNPACK_PTR(var, l, long, void)
-# define DO_BO_PACK_P(var) DO_BO_PACK_PTR(var, l, long, void)
-# define DO_BO_UNPACK_PC(var) DO_BO_UNPACK_PTR(var, l, long, char)
-# define DO_BO_PACK_PC(var) DO_BO_PACK_PTR(var, l, long, char)
+# if LONGSIZE < IVSIZE && IVSIZE == 8
+# define DO_BO_UNPACK_P(var) DO_BO_UNPACK_PTR(var, 64, IV, void)
+# define DO_BO_PACK_P(var) DO_BO_PACK_PTR(var, 64, IV, void)
+# define DO_BO_UNPACK_PC(var) DO_BO_UNPACK_PTR(var, 64, IV, char)
+# define DO_BO_PACK_PC(var) DO_BO_PACK_PTR(var, 64, IV, char)
+# else
+# define DO_BO_UNPACK_P(var) DO_BO_UNPACK_PTR(var, l, IV, void)
+# define DO_BO_PACK_P(var) DO_BO_PACK_PTR(var, l, IV, void)
+# define DO_BO_UNPACK_PC(var) DO_BO_UNPACK_PTR(var, l, IV, char)
+# define DO_BO_PACK_PC(var) DO_BO_PACK_PTR(var, l, IV, char)
+# endif
# elif PTRSIZE == IVSIZE
# define DO_BO_UNPACK_P(var) DO_BO_UNPACK_PTR(var, l, IV, void)
# define DO_BO_PACK_P(var) DO_BO_PACK_PTR(var, l, IV, void)
Perl_croak(aTHX_ "Malformed UTF-8 string in '%c' format in unpack",
(int) TYPE_NO_MODIFIERS(datumtype));
if (val >= 0x100) {
- if (ckWARN(WARN_UNPACK))
- Perl_warner(aTHX_ packWARN(WARN_UNPACK),
- "Character in '%c' format wrapped in unpack",
- (int) TYPE_NO_MODIFIERS(datumtype));
+ Perl_ck_warner(aTHX_ packWARN(WARN_UNPACK),
+ "Character in '%c' format wrapped in unpack",
+ (int) TYPE_NO_MODIFIERS(datumtype));
val &= 0xff;
}
*s += retlen;
}
if (from > end) from = end;
}
- if ((bad & 2) && ckWARN(WARN_UNPACK))
- Perl_warner(aTHX_ packWARN(datumtype & TYPE_IS_PACK ?
+ if ((bad & 2))
+ Perl_ck_warner(aTHX_ packWARN(datumtype & TYPE_IS_PACK ?
WARN_PACK : WARN_UNPACK),
- "Character(s) in '%c' format wrapped in %s",
- (int) TYPE_NO_MODIFIERS(datumtype),
- datumtype & TYPE_IS_PACK ? "pack" : "unpack");
+ "Character(s) in '%c' format wrapped in %s",
+ (int) TYPE_NO_MODIFIERS(datumtype),
+ datumtype & TYPE_IS_PACK ? "pack" : "unpack");
}
*s = from;
return TRUE;
Perl_croak(aTHX_ "Can't use '%c' in a group with different byte-order in %s",
*patptr, _action( symptr ) );
- if ((code & modifier) && ckWARN(WARN_UNPACK)) {
- Perl_warner(aTHX_ packWARN(WARN_UNPACK),
- "Duplicate modifier '%c' after '%c' in %s",
- *patptr, (int) TYPE_NO_MODIFIERS(code),
- _action( symptr ) );
+ if ((code & modifier)) {
+ Perl_ck_warner(aTHX_ packWARN(WARN_UNPACK),
+ "Duplicate modifier '%c' after '%c' in %s",
+ *patptr, (int) TYPE_NO_MODIFIERS(code),
+ _action( symptr ) );
}
code |= modifier;
if (howlen == e_star || len > (strend - s) * 8)
len = (strend - s) * 8;
if (checksum) {
- if (!PL_bitcount) {
- int bits;
- Newxz(PL_bitcount, 256, char);
- for (bits = 1; bits < 256; bits++) {
- if (bits & 1) PL_bitcount[bits]++;
- if (bits & 2) PL_bitcount[bits]++;
- if (bits & 4) PL_bitcount[bits]++;
- if (bits & 8) PL_bitcount[bits]++;
- if (bits & 16) PL_bitcount[bits]++;
- if (bits & 32) PL_bitcount[bits]++;
- if (bits & 64) PL_bitcount[bits]++;
- if (bits & 128) PL_bitcount[bits]++;
- }
- }
if (utf8)
while (len >= 8 && s < strend) {
cuv += PL_bitcount[uni_to_byte(aTHX_ &s, strend, datumtype)];
if (m != marks + sym_ptr->level+1) {
Safefree(marks);
Safefree(to_start);
- Perl_croak(aTHX_ "Assertion: marks beyond string end");
+ Perl_croak(aTHX_ "panic: marks beyond string end");
}
for (group=sym_ptr; group; group = group->previous)
group->strbeg = marks[group->level] - to_start;
GROWING(0, cat, start, cur, len);
if (!uni_to_bytes(aTHX_ &aptr, end, cur, fromlen,
datumtype | TYPE_IS_PACK))
- Perl_croak(aTHX_ "Perl bug: predicted utf8 length not available");
+ Perl_croak(aTHX_ "panic: predicted utf8 length not available");
cur += fromlen;
len -= fromlen;
} else if (utf8) {
}
memset(cur, datumtype == 'A' ? ' ' : '\0', len);
cur += len;
+ SvTAINT(cat);
break;
}
case 'B':
IV aiv;
fromstr = NEXTFROM;
aiv = SvIV(fromstr);
- if ((-128 > aiv || aiv > 127) &&
- ckWARN(WARN_PACK))
- Perl_warner(aTHX_ packWARN(WARN_PACK),
- "Character in 'c' format wrapped in pack");
+ if ((-128 > aiv || aiv > 127))
+ Perl_ck_warner(aTHX_ packWARN(WARN_PACK),
+ "Character in 'c' format wrapped in pack");
PUSH_BYTE(utf8, cur, (U8)(aiv & 0xff));
}
break;
IV aiv;
fromstr = NEXTFROM;
aiv = SvIV(fromstr);
- if ((0 > aiv || aiv > 0xff) &&
- ckWARN(WARN_PACK))
- Perl_warner(aTHX_ packWARN(WARN_PACK),
- "Character in 'C' format wrapped in pack");
+ if ((0 > aiv || aiv > 0xff))
+ Perl_ck_warner(aTHX_ packWARN(WARN_PACK),
+ "Character in 'C' format wrapped in pack");
PUSH_BYTE(utf8, cur, (U8)(aiv & 0xff));
}
break;
end = start+SvLEN(cat)-UTF8_MAXLEN;
goto W_utf8;
}
- if (ckWARN(WARN_PACK))
- Perl_warner(aTHX_ packWARN(WARN_PACK),
- "Character in 'W' format wrapped in pack");
+ Perl_ck_warner(aTHX_ packWARN(WARN_PACK),
+ "Character in 'W' format wrapped in pack");
auv &= 0xff;
}
if (cur >= end) {
* gone.
*/
if ((SvTEMP(fromstr) || (SvPADTMP(fromstr) &&
- !SvREADONLY(fromstr))) && ckWARN(WARN_PACK)) {
- Perl_warner(aTHX_ packWARN(WARN_PACK),
- "Attempt to pack pointer to temporary value");
+ !SvREADONLY(fromstr)))) {
+ Perl_ck_warner(aTHX_ packWARN(WARN_PACK),
+ "Attempt to pack pointer to temporary value");
}
if (SvPOK(fromstr) || SvNIOK(fromstr))
aptr = SvPV_nomg_const_nolen(fromstr);
if (len <= 2) len = 45;
else len = len / 3 * 3;
if (len >= 64) {
- if (ckWARN(WARN_PACK))
- Perl_warner(aTHX_ packWARN(WARN_PACK),
- "Field too wide in 'u' format in pack");
+ Perl_ck_warner(aTHX_ packWARN(WARN_PACK),
+ "Field too wide in 'u' format in pack");
len = 63;
}
aptr = SvPV_const(fromstr, fromlen);
'u' | TYPE_IS_PACK)) {
*cur = '\0';
SvCUR_set(cat, cur - start);
- Perl_croak(aTHX_ "Assertion: string is shorter than advertised");
+ Perl_croak(aTHX_ "panic: string is shorter than advertised");
}
end = doencodes(hunk, buffer, todo);
} else {
register const char *patend = pat + fromlen;
MARK++;
- sv_setpvn(cat, "", 0);
+ sv_setpvs(cat, "");
SvUTF8_off(cat);
packlist(cat, pat, patend, MARK, SP + 1);
projects / p5sagit/p5-mst-13.2.git / blobdiff