}
#endif
-#if 0
+#ifdef PERL_UTF16_FILTER
STATIC I32
S_utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
{
ch = *t;
*t = '\0';
- if (t - s > 0)
+ if (t - s > 0) {
+#ifdef USE_ITHREADS
+ Safefree(CopFILE(PL_curcop));
+#else
+ SvREFCNT_dec(CopFILEGV(PL_curcop));
+#endif
CopFILE_set(PL_curcop, s);
+ }
*t = ch;
CopLINE_set(PL_curcop, atoi(n)-1);
}
p = SvPV(sv, len);
nsv = newSVpvn(p, len);
+ if (SvUTF8(sv))
+ SvUTF8_on(nsv);
SvREFCNT_dec(sv);
sv = nsv;
}
default:
{
dTHR;
- if (ckWARN(WARN_MISC) && isALNUM(*s))
+ if (ckWARN(WARN_MISC) && isALNUM(*s) && *s != '_')
Perl_warner(aTHX_ WARN_MISC,
"Unrecognized escape \\%c passed through",
*s);
return (sv_gets(sv, fp, append));
}
+STATIC HV *S_find_in_my_stash(pTHX_ char *pkgname, I32 len)
+{
+ GV *gv;
+
+ if (*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:: */
+ }
+
+ /* use constant CLASS => 'MyClass' */
+ if ((gv = gv_fetchpv(pkgname, FALSE, SVt_PVCV))) {
+ SV *sv;
+ if (GvCV(gv) && (sv = cv_const_sv(GvCV(gv)))) {
+ pkgname = SvPV_nolen(sv);
+ }
+ }
+
+ return gv_stashpv(pkgname, FALSE);
+}
#ifdef DEBUGGING
static char* exp_name[] =
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) {
fake_eof:
if (PL_rsfp) {
PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
PL_doextract = FALSE;
}
- }
+ }
+ if (bof)
+ s = swallow_bom(s);
incline(s);
} while (PL_doextract);
PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
PL_expect = XTERM;
TOKEN('(');
case ';':
- if (CopLINE(PL_curcop) < PL_copline)
- PL_copline = CopLINE(PL_curcop);
+ CLINE;
tmp = *s++;
OPERATOR(tmp);
case ')':
s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
goto really_sub;
- PL_in_my_stash = gv_stashpv(PL_tokenbuf, FALSE);
+ PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
if (!PL_in_my_stash) {
char tmpbuf[1024];
PL_bufptr = s;
Perl_croak(aTHX_ "Transliteration replacement not terminated");
}
- if (UTF) {
- o = newSVOP(OP_TRANS, 0, 0);
- utf8 = OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF;
- }
- else {
New(803,tbl,256,short);
o = newPVOP(OP_TRANS, 0, (char*)tbl);
- utf8 = 0;
- }
complement = del = squash = 0;
- while (strchr("cdsCU", *s)) {
+ while (strchr("cds", *s)) {
if (*s == 'c')
complement = OPpTRANS_COMPLEMENT;
else if (*s == 'd')
del = OPpTRANS_DELETE;
else if (*s == 's')
squash = OPpTRANS_SQUASH;
- else {
- switch (count++) {
- case 0:
- if (*s == 'C')
- utf8 &= ~OPpTRANS_FROM_UTF;
- else
- utf8 |= OPpTRANS_FROM_UTF;
- break;
- case 1:
- if (*s == 'C')
- utf8 &= ~OPpTRANS_TO_UTF;
- else
- utf8 |= OPpTRANS_TO_UTF;
- break;
- default:
- Perl_croak(aTHX_ "Too many /C and /U options");
- }
- }
s++;
}
- o->op_private = del|squash|complement|utf8;
+ o->op_private = del|squash|complement;
PL_lex_op = o;
yylval.ival = OP_TRANS;
PerlIO_close(PL_rsfp);
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
+ }
+ 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;
+}