X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=toke.c;h=98210a010f518b7d00ca2f002a55e548367b45cb;hb=188ff3c1f17467ccacb0b31f3e13fd49b5b438a7;hp=fc51d910e17391af650c38397a40c18720ac32c7;hpb=ce58e4c2a04da0fdbc16746698a37cdef4d70f56;p=p5sagit%2Fp5-mst-13.2.git diff --git a/toke.c b/toke.c index fc51d91..98210a0 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,8 +2480,8 @@ Perl_yylex(pTHX) goto retry; } do { - bool bof; - bof = PL_rsfp && (PerlIO_tell(PL_rsfp)==0); /* *Before* read! */ + bool bof; + bof = PL_rsfp && (PerlIO_tell(PL_rsfp) == 0); /* *Before* read! */ if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) { fake_eof: if (PL_rsfp) { @@ -2528,8 +2518,8 @@ Perl_yylex(pTHX) PL_doextract = FALSE; } } - if (bof) - s = swallow_bom(s); + if (bof) + s = swallow_bom((U8*)s); incline(s); } while (PL_doextract); PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s; @@ -3158,7 +3148,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) { @@ -6157,8 +6147,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 +7152,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,57 +7380,59 @@ Perl_yyerror(pTHX_ char *s) return 0; } - STATIC char* -S_swallow_bom(pTHX_ char *s) { +S_swallow_bom(pTHX_ U8 *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; + case 0xFF: + if (s[1] == 0xFE) { + /* UTF-16 little-endian */ +#ifndef PERL_NO_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; + if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */ + Perl_croak(aTHX_ "Unsupported script encoding"); +#ifndef PERL_NO_UTF16_FILTER + s += 2; + filter_add(utf16rev_textfilter, NULL); + New(898, news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8); + PL_bufend = (char*)utf16_to_utf8((U16*)s, news, + PL_bufend - (char*)s); + s = news; #else - Perl_croak(aTHX_ "Unsupported script encoding"); + Perl_croak(aTHX_ "Unsupported script encoding"); #endif - } - 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; + } + break; + case 0xFE: + if (s[1] == 0xFF) { /* UTF-16 big-endian */ +#ifndef PERL_NO_UTF16_FILTER + U8 *news; + filter_add(utf16_textfilter, NULL); + New(898, news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8); + PL_bufend = (char*)utf16_to_utf8((U16*)s, news, + PL_bufend - (char*)s); + s = news; #else - Perl_croak(aTHX_ "Unsupported script encoding"); + 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; + } + break; + case 0xEF: + if (slen > 2 && s[1] == 0xBB && s[2] == 0xBF) { + 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 @@ -7463,3 +7455,33 @@ restore_rsfp(pTHXo_ void *f) PerlIO_close(PL_rsfp); PL_rsfp = fp; } + +#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; + 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 +utf16rev_textfilter(pTHXo_ 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