static char ident_too_long[] = "Identifier too long";
static void restore_rsfp(pTHXo_ void *f);
+#ifndef PERL_NO_UTF16_FILTER
+static I32 utf16_textfilter(pTHXo_ int idx, SV *sv, int maxlen);
+static I32 utf16rev_textfilter(pTHXo_ int idx, SV *sv, int maxlen);
+#endif
#define XFAKEBRACK 128
#define XENUMMASK 127
}
#endif
-#ifdef PERL_UTF16_FILTER
-STATIC I32
-S_utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
-{
- I32 count = FILTER_READ(idx+1, sv, maxlen);
- if (count) {
- U8* tmps;
- U8* tend;
- New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
- tend = utf16_to_utf8((U16*)SvPVX(sv), tmps, SvCUR(sv));
- sv_usepvn(sv, (char*)tmps, tend - tmps);
- }
- return count;
-}
-
-STATIC I32
-S_utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen)
-{
- I32 count = FILTER_READ(idx+1, sv, maxlen);
- if (count) {
- U8* tmps;
- U8* tend;
- New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
- tend = utf16_to_utf8_reversed((U16*)SvPVX(sv), tmps, SvCUR(sv));
- sv_usepvn(sv, (char*)tmps, tend - tmps);
- }
- return count;
-}
-#endif
-
/*
* Perl_lex_start
* Initialize variables. Uses the Perl save_stack to save its state (for
p = SvPV(sv, len);
nsv = newSVpvn(p, len);
- if (SvUTF8(sv))
- SvUTF8_on(nsv);
+ if (SvUTF8(sv))
+ SvUTF8_on(nsv);
SvREFCNT_dec(sv);
sv = nsv;
}
register char *s = start; /* start of the constant */
register char *d = SvPVX(sv); /* destination for copies */
bool dorange = FALSE; /* are we in a translit range? */
+ bool didrange = FALSE; /* did we just finish a range? */
bool has_utf = FALSE; /* embedded \x{} */
I32 len; /* ? */
UV uv;
min = (U8)*d; /* first char in range */
max = (U8)d[1]; /* last char in range */
+ if (min > max) {
+ Perl_croak(aTHX_
+ "Invalid [] range \"%c-%c\" in transliteration operator",
+ min, max);
+ }
+
#ifndef ASCIIish
if ((isLOWER(min) && isLOWER(max)) ||
(isUPPER(min) && isUPPER(max))) {
/* mark the range as done, and continue */
dorange = FALSE;
+ didrange = TRUE;
continue;
- }
+ }
/* range begins (ignore - as first or last char) */
else if (*s == '-' && s+1 < send && s != start) {
+ if (didrange) {
+ Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
+ }
if (utf) {
*d++ = (char)0xff; /* use illegal utf8 byte--see pmtrans */
s++;
dorange = TRUE;
s++;
}
+ else {
+ didrange = FALSE;
+ }
}
/* if we get here, we're not doing a transliteration */
default:
{
dTHR;
- if (ckWARN(WARN_MISC) && isALNUM(*s) && *s != '_')
+ if (ckWARN(WARN_MISC) && isALNUM(*s))
Perl_warner(aTHX_ WARN_MISC,
"Unrecognized escape \\%c passed through",
*s);
* store private buffers and state information.
*
* The supplied datasv parameter is upgraded to a PVIO type
- * and the IoDIRP field is used to store the function pointer,
+ * and the IoDIRP/IoANY field is used to store the function pointer,
* and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
* Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
* private use must be set using malloc'd pointers.
datasv = NEWSV(255,0);
if (!SvUPGRADE(datasv, SVt_PVIO))
Perl_die(aTHX_ "Can't upgrade filter_add data to SVt_PVIO");
- IoDIRP(datasv) = (DIR*)funcp; /* stash funcp into spare field */
+ IoANY(datasv) = (void *)funcp; /* stash funcp into spare field */
IoFLAGS(datasv) |= IOf_FAKE_DIRP;
DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
funcp, SvPV_nolen(datasv)));
return;
/* if filter is on top of stack (usual case) just pop it off */
datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
- if (IoDIRP(datasv) == (DIR*)funcp) {
+ if (IoANY(datasv) == (void *)funcp) {
IoFLAGS(datasv) &= ~IOf_FAKE_DIRP;
- IoDIRP(datasv) = (DIR*)NULL;
+ IoANY(datasv) = (void *)NULL;
sv_free(av_pop(PL_rsfp_filters));
return;
return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
}
/* Get function pointer hidden within datasv */
- funcp = (filter_t)IoDIRP(datasv);
+ funcp = (filter_t)IoANY(datasv);
DEBUG_P(PerlIO_printf(Perl_debug_log,
"filter_read %d: via function %p (%s)\n",
idx, funcp, SvPV_nolen(datasv)));
return (sv_gets(sv, fp, append));
}
-STATIC HV *S_find_in_my_stash(pTHX_ char *pkgname, I32 len)
+STATIC HV *
+S_find_in_my_stash(pTHX_ char *pkgname, I32 len)
{
GV *gv;
- if (*pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
+ if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
return PL_curstash;
if (len > 2 &&
(pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
- (gv = gv_fetchpv(pkgname, FALSE, SVt_PVHV))) {
- return GvHV(gv); /* Foo:: */
+ (gv = gv_fetchpv(pkgname, FALSE, SVt_PVHV)))
+ {
+ return GvHV(gv); /* Foo:: */
}
/* use constant CLASS => 'MyClass' */
goto retry;
}
do {
- bool bof;
- bof = PL_rsfp && (PerlIO_tell(PL_rsfp)==0); /* *Before* read! */
- if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
+ bool bof;
+ bof = PL_rsfp && (PerlIO_tell(PL_rsfp) == 0); /* *Before* read! */
+ s = filter_gets(PL_linestr, PL_rsfp, 0);
+ if (s == Nullch) {
fake_eof:
if (PL_rsfp) {
if (PL_preprocess && !PL_in_eval)
PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
sv_setpv(PL_linestr,"");
TOKEN(';'); /* not infinite loop because rsfp is NULL now */
+ } else if (bof) {
+ PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
+ s = swallow_bom((U8*)s);
}
if (PL_doextract) {
if (*s == '#' && s[1] == '!' && instr(s,"perl"))
PL_doextract = FALSE;
}
}
- if (bof)
- s = swallow_bom(s);
incline(s);
} while (PL_doextract);
PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
yyerror("Unmatched right curly bracket");
else
PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
- if (PL_lex_brackets < PL_lex_formbrack)
+ if (PL_lex_brackets < PL_lex_formbrack && PL_lex_state != LEX_INTERPNORMAL)
PL_lex_formbrack = 0;
if (PL_lex_state == LEX_INTERPNORMAL) {
if (PL_lex_brackets == 0) {
/* Mark this internal pseudo-handle as clean */
IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
if (PL_preprocess)
- IoTYPE(GvIOp(gv)) = '|';
+ IoTYPE(GvIOp(gv)) = IoTYPE_PIPE;
else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
- IoTYPE(GvIOp(gv)) = '-';
+ IoTYPE(GvIOp(gv)) = IoTYPE_STD;
else
- IoTYPE(GvIOp(gv)) = '<';
+ IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
#if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
/* if the script was opened in binmode, we need to revert
* it to text mode for compatibility; but only iff it has CRs
&& PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
{
Off_t loc = 0;
- if (IoTYPE(GvIOp(gv)) == '<') {
+ if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
loc = PerlIO_tell(PL_rsfp);
(void)PerlIO_seek(PL_rsfp, 0L, 0);
}
}
break;
case 'E':
- if (strEQ(d,"EQ")) { deprecate(d); return -KEY_eq;}
if (strEQ(d,"END")) return KEY_END;
break;
case 'e':
break;
}
break;
- case 'G':
- if (len == 2) {
- if (strEQ(d,"GT")) { deprecate(d); return -KEY_gt;}
- if (strEQ(d,"GE")) { deprecate(d); return -KEY_ge;}
- }
- break;
case 'g':
if (strnEQ(d,"get",3)) {
d += 3;
if (strEQ(d,"kill")) return -KEY_kill;
}
break;
- case 'L':
- if (len == 2) {
- if (strEQ(d,"LT")) { deprecate(d); return -KEY_lt;}
- if (strEQ(d,"LE")) { deprecate(d); return -KEY_le;}
- }
- break;
case 'l':
switch (len) {
case 2:
break;
}
break;
- case 'N':
- if (strEQ(d,"NE")) { deprecate(d); return -KEY_ne;}
- break;
case 'n':
if (strEQ(d,"next")) return KEY_next;
if (strEQ(d,"ne")) return -KEY_ne;
Perl_croak(aTHX_ "Transliteration replacement not terminated");
}
- New(803,tbl,256,short);
- o = newPVOP(OP_TRANS, 0, (char*)tbl);
+ New(803,tbl,256,short);
+ o = newPVOP(OP_TRANS, 0, (char*)tbl);
complement = del = squash = 0;
while (strchr("cds", *s)) {
bool needargs = FALSE;
while (!needargs) {
- if (*s == '.' || *s == '}') {
+ if (*s == '.' || *s == /*{*/'}') {
/*SUPPRESS 530*/
#ifdef PERL_STRICT_CR
for (t = s+1;SPACE_OR_TAB(*t); t++) ;
return 0;
}
+STATIC char*
+S_swallow_bom(pTHX_ U8 *s)
+{
+ STRLEN slen;
+ slen = SvCUR(PL_linestr);
+ switch (*s) {
+ case 0xFF:
+ if (s[1] == 0xFE) {
+ /* UTF-16 little-endian */
+ if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */
+ Perl_croak(aTHX_ "Unsupported script encoding");
+#ifndef PERL_NO_UTF16_FILTER
+ DEBUG_p(PerlIO_printf(Perl_debug_log, "UTF-LE script encoding\n"));
+ s += 2;
+ if (PL_bufend > (char*)s) {
+ U8 *news;
+ I32 newlen;
+
+ filter_add(utf16rev_textfilter, NULL);
+ New(898, news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
+ PL_bufend = (char*)utf16_to_utf8_reversed(s, news,
+ PL_bufend - (char*)s - 1,
+ &newlen);
+ Copy(news, s, newlen, U8);
+ SvCUR_set(PL_linestr, newlen);
+ PL_bufend = SvPVX(PL_linestr) + newlen;
+ news[newlen++] = '\0';
+ Safefree(news);
+ }
+#else
+ Perl_croak(aTHX_ "Unsupported script encoding");
+#endif
+ }
+ break;
+ case 0xFE:
+ if (s[1] == 0xFF) { /* UTF-16 big-endian */
+#ifndef PERL_NO_UTF16_FILTER
+ DEBUG_p(PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding\n"));
+ s += 2;
+ if (PL_bufend > (char *)s) {
+ U8 *news;
+ I32 newlen;
+
+ filter_add(utf16_textfilter, NULL);
+ New(898, news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
+ PL_bufend = (char*)utf16_to_utf8(s, news,
+ PL_bufend - (char*)s,
+ &newlen);
+ Copy(news, s, newlen, U8);
+ SvCUR_set(PL_linestr, newlen);
+ PL_bufend = SvPVX(PL_linestr) + newlen;
+ news[newlen++] = '\0';
+ Safefree(news);
+ }
+#else
+ Perl_croak(aTHX_ "Unsupported script encoding");
+#endif
+ }
+ break;
+ case 0xEF:
+ if (slen > 2 && s[1] == 0xBB && s[2] == 0xBF) {
+ DEBUG_p(PerlIO_printf(Perl_debug_log, "UTF-8 script encoding\n"));
+ s += 3; /* UTF-8 */
+ }
+ break;
+ case 0:
+ if (slen > 3 && s[1] == 0 && /* UTF-32 big-endian */
+ s[2] == 0xFE && s[3] == 0xFF)
+ {
+ Perl_croak(aTHX_ "Unsupported script encoding");
+ }
+ }
+ return (char*)s;
+}
#ifdef PERL_OBJECT
#include "XSUB.h"
PL_rsfp = fp;
}
-STATIC char*
-S_swallow_bom(pTHX_ char *s) {
- STRLEN slen;
- slen = SvCUR(PL_linestr);
- switch (*s) {
- case -1:
- if ((s[1] & 255) == 254) {
- /* UTF-16 little-endian */
-#ifdef PERL_UTF16_FILTER
- U8 *news;
-#endif
- s+=2;
- if (*s == 0 && s[1] == 0) /* UTF-32 little-endian */
- Perl_croak(aTHX_ "Unsupported script encoding");
-#ifdef PERL_UTF16_FILTER
- filter_add(S_utf16rev_textfilter, NULL);
- New(898, news, (PL_bufend - s) * 3 / 2 + 1, U8);
- PL_bufend = utf16_to_utf8((U16*)s, news, PL_bufend - s);
- s = news;
-#else
- Perl_croak(aTHX_ "Unsupported script encoding");
-#endif
+#ifndef PERL_NO_UTF16_FILTER
+static I32
+utf16_textfilter(pTHXo_ int idx, SV *sv, int maxlen)
+{
+ I32 count = FILTER_READ(idx+1, sv, maxlen);
+ if (count) {
+ U8* tmps;
+ U8* tend;
+ I32 newlen;
+ New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
+ if (!*SvPV_nolen(sv))
+ /* Game over, but don't feed an odd-length string to utf16_to_utf8 */
+ return count;
+
+ tend = utf16_to_utf8((U8*)SvPVX(sv), tmps, SvCUR(sv), &newlen);
+ sv_usepvn(sv, (char*)tmps, tend - tmps);
}
- break;
-
- case -2:
- if ((s[1] & 255) == 255) { /* UTF-16 big-endian */
-#ifdef PERL_UTF16_FILTER
- U8 *news;
- filter_add(S_utf16_textfilter, NULL);
- New(898, news, (PL_bufend - s) * 3 / 2 + 1, U8);
- PL_bufend = utf16_to_utf8((U16*)s, news, PL_bufend - s);
- s = news;
-#else
- Perl_croak(aTHX_ "Unsupported script encoding");
-#endif
- }
- break;
-
- case -17:
- if ( slen>2 && (s[1] & 255) == 187 && (s[2] & 255) == 191) {
- s+=3; /* UTF-8 */
- }
- break;
- case 0:
- if (slen > 3 && s[1] == 0 && /* UTF-32 big-endian */
- s[2] & 255 == 254 && s[3] & 255 == 255)
- Perl_croak(aTHX_ "Unsupported script encoding");
-}
-return s;
+ return count;
+}
+
+static I32
+utf16rev_textfilter(pTHXo_ int idx, SV *sv, int maxlen)
+{
+ I32 count = FILTER_READ(idx+1, sv, maxlen);
+ if (count) {
+ U8* tmps;
+ U8* tend;
+ I32 newlen;
+ if (!*SvPV_nolen(sv))
+ /* Game over, but don't feed an odd-length string to utf16_to_utf8 */
+ return count;
+
+ New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
+ tend = utf16_to_utf8_reversed((U8*)SvPVX(sv), tmps, SvCUR(sv), &newlen);
+ sv_usepvn(sv, (char*)tmps, tend - tmps);
+ }
+ return count;
}
+#endif