X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=toke.c;h=a4f95a7e98ada25a17a696f6de90554fba4b4201;hb=e5c81feb3d32a96869ed78abc5cecef7e294da38;hp=d6bb6d9291f3962bef1faad21cfb0011b5f9797a;hpb=27d76ecff97d0a9449f569d789504cc8b69a6d01;p=p5sagit%2Fp5-mst-13.2.git diff --git a/toke.c b/toke.c index d6bb6d9..a4f95a7 100644 --- a/toke.c +++ b/toke.c @@ -28,6 +28,10 @@ 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 @@ -326,36 +330,6 @@ S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen) } #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 @@ -987,8 +961,8 @@ S_sublex_start(pTHX) 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; } @@ -1208,6 +1182,7 @@ S_scan_const(pTHX_ char *start) 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; @@ -1241,6 +1216,12 @@ S_scan_const(pTHX_ char *start) 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))) { @@ -1261,11 +1242,15 @@ S_scan_const(pTHX_ char *start) /* 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++; @@ -1274,6 +1259,9 @@ S_scan_const(pTHX_ char *start) dorange = TRUE; s++; } + else { + didrange = FALSE; + } } /* if we get here, we're not doing a transliteration */ @@ -1392,7 +1380,7 @@ S_scan_const(pTHX_ char *start) 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); @@ -1875,7 +1863,7 @@ S_incl_perldb(pTHX) * 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. @@ -1893,7 +1881,7 @@ Perl_filter_add(pTHX_ filter_t funcp, SV *datasv) 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))); @@ -1913,9 +1901,9 @@ Perl_filter_del(pTHX_ filter_t funcp) 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; @@ -1975,7 +1963,7 @@ Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen) 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))); @@ -2006,17 +1994,19 @@ S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append) 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' */ @@ -2490,9 +2480,10 @@ Perl_yylex(pTHX) 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) @@ -2515,6 +2506,9 @@ Perl_yylex(pTHX) 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")) @@ -2528,8 +2522,6 @@ Perl_yylex(pTHX) PL_doextract = FALSE; } } - if (bof) - s = swallow_bom(s); incline(s); } while (PL_doextract); PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s; @@ -3158,7 +3150,7 @@ Perl_yylex(pTHX) 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) { @@ -3988,11 +3980,11 @@ Perl_yylex(pTHX) /* 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 @@ -4001,7 +3993,7 @@ Perl_yylex(pTHX) && 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); } @@ -5150,7 +5142,6 @@ Perl_keyword(pTHX_ register char *d, I32 len) } break; case 'E': - if (strEQ(d,"EQ")) { deprecate(d); return -KEY_eq;} if (strEQ(d,"END")) return KEY_END; break; case 'e': @@ -5216,12 +5207,6 @@ Perl_keyword(pTHX_ register char *d, I32 len) 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; @@ -5321,12 +5306,6 @@ Perl_keyword(pTHX_ register char *d, I32 len) 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: @@ -5378,9 +5357,6 @@ Perl_keyword(pTHX_ register char *d, I32 len) 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; @@ -6157,8 +6133,8 @@ S_scan_trans(pTHX_ char *start) 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)) { @@ -7162,7 +7138,7 @@ S_scan_formline(pTHX_ register char *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++) ; @@ -7390,6 +7366,80 @@ Perl_yyerror(pTHX_ char *s) 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" @@ -7412,54 +7462,42 @@ restore_rsfp(pTHXo_ void *f) 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