/* toke.c
*
- * Copyright (c) 1991-2000, Larry Wall
+ * Copyright (c) 1991-2001, Larry Wall
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
/*
* This file is the lexer for Perl. It's closely linked to the
- * parser, perly.y.
+ * parser, perly.y.
*
* The main routine is yylex(), which returns the next token.
*/
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
-/*#define UTF (SvUTF8(PL_linestr) && !(PL_hints & HINT_BYTE))*/
-#define UTF (PL_hints & HINT_UTF8)
+#ifdef EBCDIC
+/* For now 'use utf8' does not affect tokenizer on EBCDIC */
+#define UTF (PL_linestr && DO_UTF8(PL_linestr))
+#else
+#define UTF ((PL_linestr && DO_UTF8(PL_linestr)) || (PL_hints & HINT_UTF8))
+#endif
-/* In variables name $^X, these are the legal values for X.
+/* In variables name $^X, these are the legal values for X.
* 1999-02-27 mjd-perl-patch@plover.com */
#define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
+/* On MacOS, respect nonbreaking spaces */
+#ifdef MACOS_TRADITIONAL
+#define SPACE_OR_TAB(c) ((c)==' '||(c)=='\312'||(c)=='\t')
+#else
+#define SPACE_OR_TAB(c) ((c)==' '||(c)=='\t')
+#endif
+
/* LEX_* are values for PL_lex_state, the state of the lexer.
* They are arranged oddly so that the guard on the switch statement
* can get by with a single comparison (if the compiler is smart enough).
#define LEX_FORMLINE 1
#define LEX_KNOWNEXT 0
-/* XXX If this causes problems, set i_unistd=undef in the hint file. */
-#ifdef I_UNISTD
-# include <unistd.h> /* Needed for execv() */
-#endif
-
-
#ifdef ff_next
#undef ff_next
#endif
#ifdef USE_PURE_BISON
-YYSTYPE* yylval_pointer = NULL;
-int* yychar_pointer = NULL;
+# ifndef YYMAXLEVEL
+# define YYMAXLEVEL 100
+# endif
+YYSTYPE* yylval_pointer[YYMAXLEVEL];
+int* yychar_pointer[YYMAXLEVEL];
+int yyactlevel = -1;
# undef yylval
# undef yychar
-# define yylval (*yylval_pointer)
-# define yychar (*yychar_pointer)
-# define PERL_YYLEX_PARAM yylval_pointer,yychar_pointer
+# define yylval (*yylval_pointer[yyactlevel])
+# define yychar (*yychar_pointer[yyactlevel])
+# define PERL_YYLEX_PARAM yylval_pointer[yyactlevel],yychar_pointer[yyactlevel]
# undef yylex
-# define yylex() Perl_yylex(aTHX_ yylval_pointer, yychar_pointer)
+# define yylex() Perl_yylex_r(aTHX_ yylval_pointer[yyactlevel],yychar_pointer[yyactlevel])
#endif
#include "keywords.h"
* Aop : addition-level operator
* Mop : multiplication-level operator
* Eop : equality-testing operator
- * Rop : relational operator <= != gt
+ * Rop : relational operator <= != gt
*
* Also see LOP and lop() below.
*/
-#define TOKEN(retval) return (PL_bufptr = s,(int)retval)
-#define OPERATOR(retval) return (PL_expect = XTERM,PL_bufptr = s,(int)retval)
-#define AOPERATOR(retval) return ao((PL_expect = XTERM,PL_bufptr = s,(int)retval))
-#define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s,(int)retval)
-#define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s,(int)retval)
-#define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s,(int)retval)
-#define TERM(retval) return (CLINE, PL_expect = XOPERATOR,PL_bufptr = s,(int)retval)
-#define LOOPX(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LOOPEX)
-#define FTST(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)UNIOP)
-#define FUN0(f) return(yylval.ival = f,PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC0)
-#define FUN1(f) return(yylval.ival = f,PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC1)
-#define BOop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)BITOROP))
-#define BAop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)BITANDOP))
-#define SHop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)SHIFTOP))
-#define PWop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)POWOP))
-#define PMop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)MATCHOP)
-#define Aop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)ADDOP))
-#define Mop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)MULOP))
-#define Eop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)EQOP)
-#define Rop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)RELOP)
+/* Note that REPORT() and REPORT2() will be expressions that supply
+ * their own trailing comma, not suitable for statements as such. */
+#ifdef DEBUGGING /* Serve -DT. */
+# define REPORT(x,retval) tokereport(x,s,(int)retval),
+# define REPORT2(x,retval) tokereport(x,s, yylval.ival),
+#else
+# define REPORT(x,retval)
+# define REPORT2(x,retval)
+#endif
+
+#define TOKEN(retval) return (REPORT2("token",retval) PL_bufptr = s,(int)retval)
+#define OPERATOR(retval) return (REPORT2("operator",retval) PL_expect = XTERM, PL_bufptr = s,(int)retval)
+#define AOPERATOR(retval) return ao((REPORT2("aop",retval) PL_expect = XTERM, PL_bufptr = s,(int)retval))
+#define PREBLOCK(retval) return (REPORT2("preblock",retval) PL_expect = XBLOCK,PL_bufptr = s,(int)retval)
+#define PRETERMBLOCK(retval) return (REPORT2("pretermblock",retval) PL_expect = XTERMBLOCK,PL_bufptr = s,(int)retval)
+#define PREREF(retval) return (REPORT2("preref",retval) PL_expect = XREF,PL_bufptr = s,(int)retval)
+#define TERM(retval) return (CLINE, REPORT2("term",retval) PL_expect = XOPERATOR, PL_bufptr = s,(int)retval)
+#define LOOPX(f) return(yylval.ival=f, REPORT("loopx",f) PL_expect = XTERM,PL_bufptr = s,(int)LOOPEX)
+#define FTST(f) return(yylval.ival=f, REPORT("ftst",f) PL_expect = XTERM,PL_bufptr = s,(int)UNIOP)
+#define FUN0(f) return(yylval.ival = f, REPORT("fun0",f) PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC0)
+#define FUN1(f) return(yylval.ival = f, REPORT("fun1",f) PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC1)
+#define BOop(f) return ao((yylval.ival=f, REPORT("bitorop",f) PL_expect = XTERM,PL_bufptr = s,(int)BITOROP))
+#define BAop(f) return ao((yylval.ival=f, REPORT("bitandop",f) PL_expect = XTERM,PL_bufptr = s,(int)BITANDOP))
+#define SHop(f) return ao((yylval.ival=f, REPORT("shiftop",f) PL_expect = XTERM,PL_bufptr = s,(int)SHIFTOP))
+#define PWop(f) return ao((yylval.ival=f, REPORT("powop",f) PL_expect = XTERM,PL_bufptr = s,(int)POWOP))
+#define PMop(f) return(yylval.ival=f, REPORT("matchop",f) PL_expect = XTERM,PL_bufptr = s,(int)MATCHOP)
+#define Aop(f) return ao((yylval.ival=f, REPORT("add",f) PL_expect = XTERM,PL_bufptr = s,(int)ADDOP))
+#define Mop(f) return ao((yylval.ival=f, REPORT("mul",f) PL_expect = XTERM,PL_bufptr = s,(int)MULOP))
+#define Eop(f) return(yylval.ival=f, REPORT("eq",f) PL_expect = XTERM,PL_bufptr = s,(int)EQOP)
+#define Rop(f) return(yylval.ival=f, REPORT("rel",f) PL_expect = XTERM,PL_bufptr = s,(int)RELOP)
/* This bit of chicanery makes a unary function followed by
* a parenthesis into a function with one argument, highest precedence.
*/
#define UNI(f) return(yylval.ival = f, \
+ REPORT("uni",f) \
PL_expect = XTERM, \
PL_bufptr = s, \
PL_last_uni = PL_oldbufptr, \
(*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
#define UNIBRACK(f) return(yylval.ival = f, \
+ REPORT("uni",f) \
PL_bufptr = s, \
PL_last_uni = PL_oldbufptr, \
(*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
/* grandfather return to old style */
#define OLDLOP(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP)
+STATIC void
+S_tokereport(pTHX_ char *thing, char* s, I32 rv)
+{
+ SV *report;
+ DEBUG_T({
+ report = newSVpv(thing, 0);
+ Perl_sv_catpvf(aTHX_ report, ":line %d:%"IVdf":", CopLINE(PL_curcop),
+ (IV)rv);
+
+ if (s - PL_bufptr > 0)
+ sv_catpvn(report, PL_bufptr, s - PL_bufptr);
+ else {
+ if (PL_oldbufptr && *PL_oldbufptr)
+ sv_catpv(report, PL_tokenbuf);
+ }
+ PerlIO_printf(Perl_debug_log, "### %s\n", SvPV_nolen(report));
+ })
+}
+
/*
* S_ao
*
if (!s)
s = oldbp;
- else {
- assert(s >= oldbp);
+ else
PL_bufptr = s;
- }
yywarn(Perl_form(aTHX_ "%s found where operator expected", what));
if (is_first)
Perl_warn(aTHX_ "\t(Missing semicolon on previous line?)\n");
Perl_warn(aTHX_ "\t(Do you need to predeclare %.*s?)\n",
t - PL_oldoldbufptr, PL_oldoldbufptr);
}
- else
+ else {
+ assert(s >= oldbp);
Perl_warn(aTHX_ "\t(Missing operator before %.*s?)\n", s - oldbp, oldbp);
+ }
PL_bufptr = oldbp;
}
void
Perl_deprecate(pTHX_ char *s)
{
- dTHR;
if (ckWARN(WARN_DEPRECATED))
Perl_warner(aTHX_ WARN_DEPRECATED, "Use of %s is deprecated", s);
}
}
#endif
-#if 0
-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
void
Perl_lex_start(pTHX_ SV *line)
{
- dTHR;
char *s;
STRLEN len;
SAVEVPTR(PL_nextval[toke]);
}
SAVEI32(PL_nexttoke);
- PL_nexttoke = 0;
}
SAVECOPLINE(PL_curcop);
SAVEPPTR(PL_bufptr);
SAVEPPTR(PL_bufend);
SAVEPPTR(PL_oldbufptr);
SAVEPPTR(PL_oldoldbufptr);
+ SAVEPPTR(PL_last_lop);
+ SAVEPPTR(PL_last_uni);
SAVEPPTR(PL_linestart);
SAVESPTR(PL_linestr);
SAVEPPTR(PL_lex_brackstack);
PL_lex_stuff = Nullsv;
PL_lex_repl = Nullsv;
PL_lex_inpat = 0;
+ PL_nexttoke = 0;
PL_lex_inwhat = 0;
PL_sublex_info.sub_inwhat = 0;
PL_linestr = line;
SvTEMP_off(PL_linestr);
PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
PL_bufend = PL_bufptr + SvCUR(PL_linestr);
+ PL_last_lop = PL_last_uni = Nullch;
SvREFCNT_dec(PL_rs);
PL_rs = newSVpvn("\n", 1);
PL_rsfp = 0;
STATIC void
S_incline(pTHX_ char *s)
{
- dTHR;
char *t;
char *n;
char *e;
CopLINE_inc(PL_curcop);
if (*s++ != '#')
return;
- while (*s == ' ' || *s == '\t') s++;
+ while (SPACE_OR_TAB(*s)) s++;
if (strnEQ(s, "line", 4))
s += 4;
else
return;
- if (*s == ' ' || *s == '\t')
+ if (SPACE_OR_TAB(*s))
s++;
- else
+ else
return;
- while (*s == ' ' || *s == '\t') s++;
+ while (SPACE_OR_TAB(*s)) s++;
if (!isDIGIT(*s))
return;
n = s;
while (isDIGIT(*s))
s++;
- while (*s == ' ' || *s == '\t')
+ while (SPACE_OR_TAB(*s))
s++;
if (*s == '"' && (t = strchr(s+1, '"'))) {
s++;
for (t = s; !isSPACE(*t); t++) ;
e = t;
}
- while (*e == ' ' || *e == '\t' || *e == '\r' || *e == '\f')
+ while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
e++;
if (*e != '\n' && *e != '\0')
return; /* false alarm */
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);
}
STATIC char *
S_skipspace(pTHX_ register char *s)
{
- dTHR;
if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
- while (s < PL_bufend && (*s == ' ' || *s == '\t'))
+ while (s < PL_bufend && SPACE_OR_TAB(*s))
s++;
return s;
}
PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart
= SvPVX(PL_linestr);
PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
+ PL_last_lop = PL_last_uni = Nullch;
/* Close the filehandle. Could be from -P preprocessor,
* STDIN, or a regular file. If we were reading code from
{
char *s;
char *t;
- dTHR;
if (PL_oldoldbufptr != PL_last_uni)
return;
if (ckWARN_d(WARN_AMBIGUOUS)){
char ch = *s;
*s = '\0';
- Perl_warner(aTHX_ WARN_AMBIGUOUS,
- "Warning: Use of \"%s\" without parens is ambiguous",
+ Perl_warner(aTHX_ WARN_AMBIGUOUS,
+ "Warning: Use of \"%s\" without parens is ambiguous",
PL_last_uni);
*s = ch;
}
STATIC I32
S_lop(pTHX_ I32 f, int x, char *s)
{
- dTHR;
yylval.ival = f;
CLINE;
+ REPORT("lop", f)
PL_expect = x;
PL_bufptr = s;
PL_last_lop = PL_oldbufptr;
* handles the token correctly.
*/
-STATIC void
+STATIC void
S_force_next(pTHX_ I32 type)
{
PL_nexttype[PL_nexttoke] = type;
{
register char *s;
STRLEN len;
-
+
start = skipspace(start);
s = start;
if (isIDFIRST_lazy_if(s,UTF) ||
PL_nextval[PL_nexttoke].opval = o;
force_next(WORD);
if (kind) {
- dTHR; /* just for in_eval */
o->op_private = OPpCONST_ENTERED;
/* XXX see note in pp_entereval() for why we forgo typo
warnings if the symbol must be introduced in an eval.
NV nshift = 1.0;
STRLEN len;
char *start = SvPVx(sv,len);
- bool utf = SvUTF8(sv);
+ bool utf = SvUTF8(sv) ? TRUE : FALSE;
char *end = start + len;
while (start < end) {
- I32 skip;
+ STRLEN skip;
UV n;
if (utf)
- n = utf8_to_uv((U8*)start, &skip);
+ n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
else {
n = *(U8*)start;
skip = 1;
return retval;
}
-/*
+/*
* S_force_version
* Forces the next token to be a version number.
*/
for (; isDIGIT(*d) || *d == '_' || *d == '.'; d++);
if (*d == ';' || isSPACE(*d) || *d == '}' || !*d) {
SV *ver;
- s = scan_num(s);
+ s = scan_num(s, &yylval);
version = yylval.opval;
ver = cSVOPx(version)->op_sv;
if (SvPOK(ver) && !SvNIOK(ver)) {
/* NOTE: The parser sees the package name and the VERSION swapped */
PL_nextval[PL_nexttoke].opval = version;
- force_next(WORD);
+ force_next(WORD);
return (s);
}
goto finish;
s = SvPV_force(sv, len);
- if (SvIVX(sv) == -1)
+ if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1)
goto finish;
send = s + len;
while (s < send && *s != '\\')
if (s == send)
goto finish;
d = s;
- if ( PL_hints & HINT_NEW_STRING )
+ if ( PL_hints & HINT_NEW_STRING ) {
pv = sv_2mortal(newSVpvn(SvPVX(pv), len));
+ if (SvUTF8(sv))
+ SvUTF8_on(pv);
+ }
while (s < send) {
if (*s == '\\') {
if (s + 1 < send && (s[1] == '\\'))
p = SvPV(sv, len);
nsv = newSVpvn(p, len);
+ if (SvUTF8(sv))
+ SvUTF8_on(nsv);
SvREFCNT_dec(sv);
sv = nsv;
- }
+ }
yylval.opval = (OP*)newSVOP(op_type, 0, sv);
PL_lex_stuff = Nullsv;
return THING;
STATIC I32
S_sublex_push(pTHX)
{
- dTHR;
ENTER;
PL_lex_state = PL_sublex_info.super_state;
SAVEPPTR(PL_bufptr);
SAVEPPTR(PL_oldbufptr);
SAVEPPTR(PL_oldoldbufptr);
+ SAVEPPTR(PL_last_lop);
+ SAVEPPTR(PL_last_uni);
SAVEPPTR(PL_linestart);
SAVESPTR(PL_linestr);
SAVEPPTR(PL_lex_brackstack);
PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
= SvPVX(PL_linestr);
PL_bufend += SvCUR(PL_linestr);
+ PL_last_lop = PL_last_uni = Nullch;
SAVEFREESV(PL_linestr);
PL_lex_dojoin = FALSE;
S_sublex_done(pTHX)
{
if (!PL_lex_starts++) {
+ SV *sv = newSVpvn("",0);
+ if (SvUTF8(PL_linestr))
+ SvUTF8_on(sv);
PL_expect = XOPERATOR;
- yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpvn("",0));
+ yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
return THING;
}
PL_lex_inpat = 0;
PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
PL_bufend += SvCUR(PL_linestr);
+ PL_last_lop = PL_last_uni = Nullch;
SAVEFREESV(PL_linestr);
PL_lex_dojoin = FALSE;
PL_lex_brackets = 0;
} (end switch)
} (end if backslash)
} (end while character to read)
-
+
*/
STATIC char *
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 has_utf = FALSE; /* embedded \x{} */
- I32 len; /* ? */
+ bool didrange = FALSE; /* did we just finish a range? */
+ I32 has_utf8 = FALSE; /* Output constant is UTF8 */
+ I32 this_utf8 = UTF; /* The source string is assumed to be UTF8 */
UV uv;
- I32 utf = (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op)
- ? (PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
- : UTF;
- I32 thisutf = (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op)
- ? (PL_sublex_info.sub_op->op_private & (PL_lex_repl ?
- OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF))
- : UTF;
const char *leaveit = /* set of acceptably-backslashed characters */
PL_lex_inpat
? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxcz0123456789[{]} \t\n\r\f\v#"
: "";
+ if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
+ /* If we are doing a trans and we know we want UTF8 set expectation */
+ has_utf8 = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
+ this_utf8 = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
+ }
+
+
while (s < send || dorange) {
/* get transliterations out of the way (they're most literal) */
if (PL_lex_inwhat == OP_TRANS) {
I32 min; /* first character in range */
I32 max; /* last character in range */
+ if (has_utf8) {
+ char *c = (char*)utf8_hop((U8*)d, -1);
+ char *e = d++;
+ while (e-- > c)
+ *(e + 1) = *e;
+ *c = UTF_TO_NATIVE(0xff);
+ /* mark the range as done, and continue */
+ dorange = FALSE;
+ didrange = TRUE;
+ continue;
+ }
+
i = d - SvPVX(sv); /* remember current offset */
SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */
d = SvPVX(sv) + i; /* refresh d after realloc */
min = (U8)*d; /* first char in range */
max = (U8)d[1]; /* last char in range */
-#ifndef ASCIIish
+ if (min > max) {
+ Perl_croak(aTHX_
+ "Invalid [] range \"%c-%c\" in transliteration operator",
+ (char)min, (char)max);
+ }
+
+#ifdef EBCDIC
if ((isLOWER(min) && isLOWER(max)) ||
(isUPPER(min) && isUPPER(max))) {
if (isLOWER(min)) {
for (i = min; i <= max; i++)
if (isLOWER(i))
- *d++ = i;
+ *d++ = NATIVE_TO_NEED(has_utf8,i);
} else {
for (i = min; i <= max; i++)
if (isUPPER(i))
- *d++ = i;
+ *d++ = NATIVE_TO_NEED(has_utf8,i);
}
}
else
/* 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 (utf) {
- *d++ = (char)0xff; /* use illegal utf8 byte--see pmtrans */
+ if (didrange) {
+ Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
+ }
+ if (has_utf8) {
+ *d++ = UTF_TO_NATIVE(0xff); /* use illegal utf8 byte--see pmtrans */
s++;
continue;
}
dorange = TRUE;
s++;
}
+ else {
+ didrange = FALSE;
+ }
}
/* if we get here, we're not doing a transliteration */
else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
if (s[2] == '#') {
while (s < send && *s != ')')
- *d++ = *s++;
+ *d++ = NATIVE_TO_NEED(has_utf8,*s++);
}
else if (s[2] == '{' /* This should match regcomp.c */
|| ((s[2] == 'p' || s[2] == '?') && s[3] == '{'))
while (count && (c = *regparse)) {
if (c == '\\' && regparse[1])
regparse++;
- else if (c == '{')
+ else if (c == '{')
count++;
- else if (c == '}')
+ else if (c == '}')
count--;
regparse++;
}
yyerror("Sequence (?{...}) not terminated or not {}-balanced");
}
while (s < regparse)
- *d++ = *s++;
+ *d++ = NATIVE_TO_NEED(has_utf8,*s++);
}
}
else if (*s == '#' && PL_lex_inpat &&
((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
while (s+1 < send && *s != '\n')
- *d++ = *s++;
+ *d++ = NATIVE_TO_NEED(has_utf8,*s++);
}
- /* check for embedded arrays (@foo, @:foo, @'foo, @{foo}, @$foo) */
+ /* check for embedded arrays
+ (@foo, @:foo, @'foo, @{foo}, @$foo, @+, @-)
+ */
else if (*s == '@' && s[1]
- && (isALNUM_lazy_if(s+1,UTF) || strchr(":'{$", s[1])))
+ && (isALNUM_lazy_if(s+1,UTF) || strchr(":'{$+-", s[1])))
break;
/* check for embedded scalars. only stop if we're sure it's a
break; /* in regexp, $ might be tail anchor */
}
- /* (now in tr/// code again) */
-
- if (*s & 0x80 && thisutf) {
- (void)utf8_to_uv((U8*)s, &len);
- if (len == 1) {
- /* illegal UTF8, make it valid */
- char *old_pvx = SvPVX(sv);
- /* need space for one extra char (NOTE: SvCUR() not set here) */
- d = SvGROW(sv, SvLEN(sv) + 1) + (d - old_pvx);
- d = (char*)uv_to_utf8((U8*)d, (U8)*s++);
- }
- else {
- while (len--)
- *d++ = *s++;
- }
- has_utf = TRUE;
- continue;
- }
+ /* End of else if chain - OP_TRANS rejoin rest */
/* backslashes */
if (*s == '\\' && s+1 < send) {
/* some backslashes we leave behind */
if (*leaveit && *s && strchr(leaveit, *s)) {
- *d++ = '\\';
- *d++ = *s++;
+ *d++ = NATIVE_TO_NEED(has_utf8,'\\');
+ *d++ = NATIVE_TO_NEED(has_utf8,*s++);
continue;
}
if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
{
- dTHR; /* only for ckWARN */
if (ckWARN(WARN_SYNTAX))
Perl_warner(aTHX_ WARN_SYNTAX, "\\%c better written as $%c", *s, *s);
*--s = '$';
/* FALL THROUGH */
default:
{
- dTHR;
- if (ckWARN(WARN_MISC) && isALPHA(*s))
- Perl_warner(aTHX_ WARN_MISC,
+ if (ckWARN(WARN_MISC) && isALNUM(*s))
+ Perl_warner(aTHX_ WARN_MISC,
"Unrecognized escape \\%c passed through",
*s);
/* default action is to copy the quoted character */
- *d++ = *s++;
- continue;
+ goto default_action;
}
/* \132 indicates an octal constant */
case '0': case '1': case '2': case '3':
case '4': case '5': case '6': case '7':
- uv = (UV)scan_oct(s, 3, &len);
- s += len;
+ {
+ STRLEN len = 0; /* disallow underscores */
+ uv = (UV)scan_oct(s, 3, &len);
+ s += len;
+ }
goto NUM_ESCAPE_INSERT;
/* \x24 indicates a hex constant */
yyerror("Missing right brace on \\x{}");
e = s;
}
- uv = (UV)scan_hex(s + 1, e - s - 1, &len);
- s = e + 1;
+ else {
+ STRLEN len = 1; /* allow underscores */
+ uv = (UV)scan_hex(s + 1, e - s - 1, &len);
+ }
+ s = e + 1;
}
else {
- uv = (UV)scan_hex(s, 2, &len);
- s += len;
+ {
+ STRLEN len = 0; /* disallow underscores */
+ uv = (UV)scan_hex(s, 2, &len);
+ s += len;
+ }
}
NUM_ESCAPE_INSERT:
/* Insert oct or hex escaped character.
- * There will always enough room in sv since such escapes will
- * be longer than any utf8 sequence they can end up as
- */
- if (uv > 127) {
- if (!thisutf && !has_utf && uv > 255) {
- /* might need to recode whatever we have accumulated so far
- * if it contains any hibit chars
+ * There will always enough room in sv since such
+ * escapes will be longer than any UTF-8 sequence
+ * they can end up as. */
+
+ /* We need to map to chars to ASCII before doing the tests
+ to cover EBCDIC
+ */
+ if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(uv))) {
+ if (!has_utf8 && uv > 255) {
+ /* Might need to recode whatever we have
+ * accumulated so far if it contains any
+ * hibit chars.
+ *
+ * (Can't we keep track of that and avoid
+ * this rescan? --jhi)
*/
- int hicount = 0;
- char *c;
- for (c = SvPVX(sv); c < d; c++) {
- if (*c & 0x80)
+ int hicount = 0;
+ U8 *c;
+ for (c = (U8 *) SvPVX(sv); c < (U8 *)d; c++) {
+ if (!NATIVE_IS_INVARIANT(*c)) {
hicount++;
+ }
}
if (hicount) {
- char *old_pvx = SvPVX(sv);
- char *src, *dst;
- d = SvGROW(sv, SvCUR(sv) + hicount + 1) + (d - old_pvx);
-
- src = d - 1;
- d += hicount;
- dst = d - 1;
-
- while (src < dst) {
- if (*src & 0x80) {
- dst--;
- uv_to_utf8((U8*)dst, (U8)*src--);
- dst--;
+ STRLEN offset = d - SvPVX(sv);
+ U8 *src, *dst;
+ d = SvGROW(sv, SvLEN(sv) + hicount + 1) + offset;
+ src = (U8 *)d - 1;
+ dst = src+hicount;
+ d += hicount;
+ while (src >= (U8 *)SvPVX(sv)) {
+ if (!NATIVE_IS_INVARIANT(*src)) {
+ U8 ch = NATIVE_TO_ASCII(*src);
+ *dst-- = UTF8_EIGHT_BIT_LO(ch);
+ *dst-- = UTF8_EIGHT_BIT_HI(ch);
}
else {
- *dst-- = *src--;
+ *dst-- = *src;
}
+ src--;
}
}
}
- if (thisutf || uv > 255) {
- d = (char*)uv_to_utf8((U8*)d, uv);
- has_utf = TRUE;
+ if (has_utf8 || uv > 255) {
+ d = (char*)uvchr_to_utf8((U8*)d, uv);
+ has_utf8 = TRUE;
+ if (PL_lex_inwhat == OP_TRANS &&
+ PL_sublex_info.sub_op) {
+ PL_sublex_info.sub_op->op_private |=
+ (PL_lex_repl ? OPpTRANS_FROM_UTF
+ : OPpTRANS_TO_UTF);
+ }
}
else {
*d++ = (char)uv;
}
}
else {
- *d++ = (char)uv;
+ *d++ = (char) uv;
}
continue;
SV *res;
STRLEN len;
char *str;
-
+
if (!e) {
yyerror("Missing right brace on \\N{}");
e = s - 1;
goto cont_scan;
}
res = newSVpvn(s + 1, e - s - 1);
- res = new_constant( Nullch, 0, "charnames",
+ res = new_constant( Nullch, 0, "charnames",
res, Nullsv, "\\N{...}" );
+ if (has_utf8)
+ sv_utf8_upgrade(res);
str = SvPV(res,len);
- if (len > 1)
- has_utf = TRUE;
+ if (!has_utf8 && SvUTF8(res)) {
+ char *ostart = SvPVX(sv);
+ SvCUR_set(sv, d - ostart);
+ SvPOK_on(sv);
+ *d = '\0';
+ sv_utf8_upgrade(sv);
+ /* this just broke our allocation above... */
+ SvGROW(sv, send - start);
+ d = SvPVX(sv) + SvCUR(sv);
+ has_utf8 = TRUE;
+ }
if (len > e - s + 4) {
char *odest = SvPVX(sv);
- SvGROW(sv, (SvCUR(sv) + len - (e - s + 4)));
+ SvGROW(sv, (SvLEN(sv) + len - (e - s + 4)));
d = SvPVX(sv) + (d - odest);
}
Copy(str, d, len, char);
/* \c is a control character */
case 'c':
s++;
+ {
+ U8 c = *s++;
#ifdef EBCDIC
- *d = *s++;
- if (isLOWER(*d))
- *d = toUPPER(*d);
- *d++ = toCTRL(*d);
-#else
- len = *s++;
- *d++ = toCTRL(len);
+ if (isLOWER(c))
+ c = toUPPER(c);
#endif
+ *d++ = NATIVE_TO_NEED(has_utf8,toCTRL(c));
+ }
continue;
/* printf-style backslashes, formfeeds, newlines, etc */
case 'b':
- *d++ = '\b';
+ *d++ = NATIVE_TO_NEED(has_utf8,'\b');
break;
case 'n':
- *d++ = '\n';
+ *d++ = NATIVE_TO_NEED(has_utf8,'\n');
break;
case 'r':
- *d++ = '\r';
+ *d++ = NATIVE_TO_NEED(has_utf8,'\r');
break;
case 'f':
- *d++ = '\f';
+ *d++ = NATIVE_TO_NEED(has_utf8,'\f');
break;
case 't':
- *d++ = '\t';
+ *d++ = NATIVE_TO_NEED(has_utf8,'\t');
break;
-#ifdef EBCDIC
case 'e':
- *d++ = '\047'; /* CP 1047 */
+ *d++ = ASCII_TO_NEED(has_utf8,'\033');
break;
case 'a':
- *d++ = '\057'; /* CP 1047 */
+ *d++ = ASCII_TO_NEED(has_utf8,'\007');
break;
-#else
- case 'e':
- *d++ = '\033';
- break;
- case 'a':
- *d++ = '\007';
- break;
-#endif
} /* end switch */
s++;
continue;
} /* end if (backslash) */
- *d++ = *s++;
+ default_action:
+ /* If we started with encoded form, or already know we want it
+ and then encode the next character */
+ if ((has_utf8 || this_utf8) && !NATIVE_IS_INVARIANT((U8)(*s))) {
+ STRLEN len = 1;
+ UV uv = (this_utf8) ? utf8n_to_uvchr((U8*)s, send - s, &len, 0) : (UV) ((U8) *s);
+ STRLEN need = UNISKIP(NATIVE_TO_UNI(uv));
+ s += len;
+ if (need > len) {
+ /* encoded value larger than old, need extra space (NOTE: SvCUR() not set here) */
+ STRLEN off = d - SvPVX(sv);
+ d = SvGROW(sv, SvLEN(sv) + (need-len)) + off;
+ }
+ d = (char*)uvchr_to_utf8((U8*)d, uv);
+ has_utf8 = TRUE;
+ }
+ else {
+ *d++ = NATIVE_TO_NEED(has_utf8,*s++);
+ }
} /* while loop to process each character */
/* terminate the string and set up the sv */
*d = '\0';
SvCUR_set(sv, d - SvPVX(sv));
+ if (SvCUR(sv) >= SvLEN(sv))
+ Perl_croak(aTHX_ "panic:constant overflowed allocated space");
+
SvPOK_on(sv);
- if (has_utf)
+ if (has_utf8) {
SvUTF8_on(sv);
+ if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
+ PL_sublex_info.sub_op->op_private |=
+ (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
+ }
+ }
/* shrink the sv if we allocated more than we used */
if (SvCUR(sv) + 5 < SvLEN(sv)) {
/* return the substring (via yylval) only if we parsed anything */
if (s > PL_bufptr) {
if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
- sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
+ sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
sv, Nullsv,
- ( PL_lex_inwhat == OP_TRANS
+ ( PL_lex_inwhat == OP_TRANS
? "tr"
: ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
? "s"
/* Encoded script support. filter_add() effectively inserts a
- * 'pre-processing' function into the current source input stream.
+ * 'pre-processing' function into the current source input stream.
* Note that the filter function only applies to the current source file
* (e.g., it will not affect files 'require'd or 'use'd by this one).
*
* 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)));
av_store(PL_rsfp_filters, 0, datasv) ;
return(datasv);
}
-
+
/* Delete most recently added instance of this filter function. */
void
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;
/* Invoke the n'th filter function for the current rsfp. */
I32
Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
-
-
+
+
/* 0 = read one text line */
{
filter_t funcp;
/* Note that we append to the line. This is handy. */
DEBUG_P(PerlIO_printf(Perl_debug_log,
"filter_read %d: from rsfp\n", idx));
- if (maxlen) {
+ if (maxlen) {
/* Want a block */
int len ;
int old_len = SvCUR(buf_sv) ;
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)
+{
+ GV *gv;
+
+ 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:: */
+ }
+
+ /* 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[] =
if we already built the token before, use it.
*/
-int
#ifdef USE_PURE_BISON
-Perl_yylex(pTHX_ YYSTYPE *lvalp, int *lcharp)
-#else
-Perl_yylex(pTHX)
+int
+Perl_yylex_r(pTHX_ YYSTYPE *lvalp, int *lcharp)
+{
+ int r;
+
+ yyactlevel++;
+ yylval_pointer[yyactlevel] = lvalp;
+ yychar_pointer[yyactlevel] = lcharp;
+ if (yyactlevel >= YYMAXLEVEL)
+ Perl_croak(aTHX_ "panic: YYMAXLEVEL");
+
+ r = Perl_yylex(aTHX);
+
+ if (yyactlevel > 0)
+ yyactlevel--;
+
+ return r;
+}
#endif
+
+#ifdef __SC__
+#pragma segment Perl_yylex
+#endif
+int
+Perl_yylex(pTHX)
{
- dTHR;
register char *s;
register char *d;
register I32 tmp;
STRLEN len;
GV *gv = Nullgv;
GV **gvp = 0;
-
-#ifdef USE_PURE_BISON
- yylval_pointer = lvalp;
- yychar_pointer = lcharp;
-#endif
+ bool bof = FALSE;
/* check if there's an identifier for us to look at */
if (PL_pending_ident) {
char pit = PL_pending_ident;
PL_pending_ident = 0;
+ DEBUG_T({ PerlIO_printf(Perl_debug_log,
+ "### Tokener saw identifier '%s'\n", PL_tokenbuf); })
+
/* if we're in a my(), we can't allow dynamics here.
$foo'bar has already been turned into $foo::bar, so
just check for colons.
}
}
- /*
+ /*
build the ops for accesses to a my() variable.
Deny my($a) or my($b) in a sort block, *if* $a or $b is
*/
if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
- if (!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
- yyerror(Perl_form(aTHX_ "In string, %s now must be written as \\%s",
- PL_tokenbuf, PL_tokenbuf));
+ if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
+ && ckWARN(WARN_AMBIGUOUS))
+ {
+ /* Downgraded from fatal to warning 20000522 mjd */
+ Perl_warner(aTHX_ WARN_AMBIGUOUS,
+ "Possible unintended interpolation of %s in string",
+ PL_tokenbuf);
+ }
}
/* build ops for a bareword */
PL_expect = PL_lex_expect;
PL_lex_defer = LEX_NORMAL;
}
+ DEBUG_T({ PerlIO_printf(Perl_debug_log,
+ "### Next token after '%s' was known, type %"IVdf"\n", PL_bufptr,
+ (IV)PL_nexttype[PL_nexttoke]); })
+
return(PL_nexttype[PL_nexttoke]);
/* interpolated case modifiers like \L \U, including \Q and \E.
return yylex();
}
else {
+ DEBUG_T({ PerlIO_printf(Perl_debug_log,
+ "### Saw case modifier at '%s'\n", PL_bufptr); })
s = PL_bufptr + 1;
if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
tmp = *s, *s = s[2], s[2] = tmp; /* misordered... */
case LEX_INTERPSTART:
if (PL_bufptr == PL_bufend)
return sublex_done();
+ DEBUG_T({ PerlIO_printf(Perl_debug_log,
+ "### Interpolated variable at '%s'\n", PL_bufptr); })
PL_expect = XTERM;
PL_lex_dojoin = (*PL_bufptr == '@');
PL_lex_state = LEX_INTERPNORMAL;
s = PL_bufptr;
PL_oldoldbufptr = PL_oldbufptr;
PL_oldbufptr = s;
- DEBUG_p( {
+ DEBUG_T( {
PerlIO_printf(Perl_debug_log, "### Tokener expecting %s at %s\n",
exp_name[PL_expect], s);
} )
PL_last_lop = 0;
if (PL_lex_brackets)
yyerror("Missing right curly or square bracket");
+ DEBUG_T( { PerlIO_printf(Perl_debug_log,
+ "### Tokener got EOF\n");
+ } )
TOKEN(0);
}
if (s++ < PL_bufend)
sv_catpv(PL_linestr, "\n");
PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
+ PL_last_lop = PL_last_uni = Nullch;
if (PERLDB_LINE && PL_curstash != PL_debstash) {
SV *sv = NEWSV(85,0);
goto retry;
}
do {
+ bof = PL_rsfp ? TRUE : FALSE;
if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
fake_eof:
if (PL_rsfp) {
sv_catpv(PL_linestr,";}");
PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
+ PL_last_lop = PL_last_uni = Nullch;
PL_minus_n = PL_minus_p = 0;
goto retry;
}
PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
+ PL_last_lop = PL_last_uni = Nullch;
sv_setpv(PL_linestr,"");
TOKEN(';'); /* not infinite loop because rsfp is NULL now */
}
+ /* if it looks like the start of a BOM, check if it in fact is */
+ else if (bof && (!*s || *(U8*)s == 0xEF || *(U8*)s >= 0xFE)) {
+#ifdef PERLIO_IS_STDIO
+# ifdef __GNU_LIBRARY__
+# if __GNU_LIBRARY__ == 1 /* Linux glibc5 */
+# define FTELL_FOR_PIPE_IS_BROKEN
+# endif
+# else
+# ifdef __GLIBC__
+# if __GLIBC__ == 1 /* maybe some glibc5 release had it like this? */
+# define FTELL_FOR_PIPE_IS_BROKEN
+# endif
+# endif
+# endif
+#endif
+#ifdef FTELL_FOR_PIPE_IS_BROKEN
+ /* This loses the possibility to detect the bof
+ * situation on perl -P when the libc5 is being used.
+ * Workaround? Maybe attach some extra state to PL_rsfp?
+ */
+ if (!PL_preprocess)
+ bof = PerlIO_tell(PL_rsfp) == SvCUR(PL_linestr);
+#else
+ bof = PerlIO_tell(PL_rsfp) == SvCUR(PL_linestr);
+#endif
+ 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;
sv_setpv(PL_linestr, "");
PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
+ PL_last_lop = PL_last_uni = Nullch;
PL_doextract = FALSE;
}
}
av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
}
PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
+ PL_last_lop = PL_last_uni = Nullch;
if (CopLINE(PL_curcop) == 1) {
while (s < PL_bufend && isSPACE(*s))
s++;
*s = '#'; /* Don't try to parse shebang line */
}
#endif /* ALTERNATE_SHEBANG */
+#ifndef MACOS_TRADITIONAL
if (!d &&
*s == '#' &&
ipathend > ipath &&
else
newargv = PL_origargv;
newargv[0] = ipath;
- PerlProc_execv(ipath, newargv);
+ PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
Perl_croak(aTHX_ "Can't exec %s", ipath);
}
+#endif
if (d) {
U32 oldpdb = PL_perldb;
bool oldn = PL_minus_n;
bool oldp = PL_minus_p;
while (*d && !isSPACE(*d)) d++;
- while (*d == ' ' || *d == '\t') d++;
+ while (SPACE_OR_TAB(*d)) d++;
if (*d++ == '-') {
do {
sv_setpv(PL_linestr, "");
PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
+ PL_last_lop = PL_last_uni = Nullch;
PL_preambled = FALSE;
if (PERLDB_LINE)
(void)gv_fetchfile(PL_origfilename);
case '\r':
#ifdef PERL_STRICT_CR
Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
- Perl_croak(aTHX_
- "(Maybe you didn't strip carriage returns after a network transfer?)\n");
+ Perl_croak(aTHX_
+ "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
#endif
case ' ': case '\t': case '\f': case 013:
+#ifdef MACOS_TRADITIONAL
+ case '\312':
+#endif
s++;
goto retry;
case '#':
case '\n':
if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
+ if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) {
+ /* handle eval qq[#line 1 "foo"\n ...] */
+ CopLINE_dec(PL_curcop);
+ incline(s);
+ }
d = PL_bufend;
while (s < d && *s != '\n')
s++;
goto retry;
case '-':
if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
+ I32 ftst = 0;
+
s++;
PL_bufptr = s;
tmp = *s++;
- while (s < PL_bufend && (*s == ' ' || *s == '\t'))
+ while (s < PL_bufend && SPACE_OR_TAB(*s))
s++;
if (strnEQ(s,"=>",2)) {
s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
+ DEBUG_T( { PerlIO_printf(Perl_debug_log,
+ "### Saw unary minus before =>, forcing word '%s'\n", s);
+ } )
OPERATOR('-'); /* unary minus */
}
PL_last_uni = PL_oldbufptr;
- PL_last_lop_op = OP_FTEREAD; /* good enough */
switch (tmp) {
- case 'r': FTST(OP_FTEREAD);
- case 'w': FTST(OP_FTEWRITE);
- case 'x': FTST(OP_FTEEXEC);
- case 'o': FTST(OP_FTEOWNED);
- case 'R': FTST(OP_FTRREAD);
- case 'W': FTST(OP_FTRWRITE);
- case 'X': FTST(OP_FTREXEC);
- case 'O': FTST(OP_FTROWNED);
- case 'e': FTST(OP_FTIS);
- case 'z': FTST(OP_FTZERO);
- case 's': FTST(OP_FTSIZE);
- case 'f': FTST(OP_FTFILE);
- case 'd': FTST(OP_FTDIR);
- case 'l': FTST(OP_FTLINK);
- case 'p': FTST(OP_FTPIPE);
- case 'S': FTST(OP_FTSOCK);
- case 'u': FTST(OP_FTSUID);
- case 'g': FTST(OP_FTSGID);
- case 'k': FTST(OP_FTSVTX);
- case 'b': FTST(OP_FTBLK);
- case 'c': FTST(OP_FTCHR);
- case 't': FTST(OP_FTTTY);
- case 'T': FTST(OP_FTTEXT);
- case 'B': FTST(OP_FTBINARY);
- case 'M': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTMTIME);
- case 'A': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTATIME);
- case 'C': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTCTIME);
+ case 'r': ftst = OP_FTEREAD; break;
+ case 'w': ftst = OP_FTEWRITE; break;
+ case 'x': ftst = OP_FTEEXEC; break;
+ case 'o': ftst = OP_FTEOWNED; break;
+ case 'R': ftst = OP_FTRREAD; break;
+ case 'W': ftst = OP_FTRWRITE; break;
+ case 'X': ftst = OP_FTREXEC; break;
+ case 'O': ftst = OP_FTROWNED; break;
+ case 'e': ftst = OP_FTIS; break;
+ case 'z': ftst = OP_FTZERO; break;
+ case 's': ftst = OP_FTSIZE; break;
+ case 'f': ftst = OP_FTFILE; break;
+ case 'd': ftst = OP_FTDIR; break;
+ case 'l': ftst = OP_FTLINK; break;
+ case 'p': ftst = OP_FTPIPE; break;
+ case 'S': ftst = OP_FTSOCK; break;
+ case 'u': ftst = OP_FTSUID; break;
+ case 'g': ftst = OP_FTSGID; break;
+ case 'k': ftst = OP_FTSVTX; break;
+ case 'b': ftst = OP_FTBLK; break;
+ case 'c': ftst = OP_FTCHR; break;
+ case 't': ftst = OP_FTTTY; break;
+ case 'T': ftst = OP_FTTEXT; break;
+ case 'B': ftst = OP_FTBINARY; break;
+ case 'M': case 'A': case 'C':
+ gv_fetchpv("\024",TRUE, SVt_PV);
+ switch (tmp) {
+ case 'M': ftst = OP_FTMTIME; break;
+ case 'A': ftst = OP_FTATIME; break;
+ case 'C': ftst = OP_FTCTIME; break;
+ default: break;
+ }
+ break;
default:
- Perl_croak(aTHX_ "Unrecognized file test: -%c", (int)tmp);
break;
}
+ if (ftst) {
+ PL_last_lop_op = ftst;
+ DEBUG_T( { PerlIO_printf(Perl_debug_log,
+ "### Saw file test %c\n", (int)ftst);
+ } )
+ FTST(ftst);
+ }
+ else {
+ /* Assume it was a minus followed by a one-letter named
+ * subroutine call (or a -bareword), then. */
+ DEBUG_T( { PerlIO_printf(Perl_debug_log,
+ "### %c looked like a file test but was not\n",
+ (int)ftst);
+ } )
+ s -= 2;
+ }
}
tmp = *s++;
if (*s == tmp) {
if (*d == '(') {
d = scan_str(d,TRUE,TRUE);
if (!d) {
- if (PL_lex_stuff) {
- SvREFCNT_dec(PL_lex_stuff);
- PL_lex_stuff = Nullsv;
- }
/* MUST advance bufptr here to avoid bogus
"at end of line" context messages from yyerror().
*/
PL_lex_stuff = Nullsv;
}
else {
- attrs = append_elem(OP_LIST, attrs,
- newSVOP(OP_CONST, 0,
- newSVpvn(s, len)));
+ if (!PL_in_my && len == 6 && strnEQ(s, "lvalue", len))
+ CvLVALUE_on(PL_compcv);
+ else if (!PL_in_my && len == 6 && strnEQ(s, "locked", len))
+ CvLOCKED_on(PL_compcv);
+ else if (!PL_in_my && len == 6 && strnEQ(s, "method", len))
+ CvMETHOD_on(PL_compcv);
+#ifdef USE_ITHREADS
+ else if (PL_in_my == KEY_our && len == 6 && strnEQ(s, "shared", len))
+ GvSHARED_on(cGVOPx_gv(yylval.opval));
+#endif
+ /* After we've set the flags, it could be argued that
+ we don't need to do the attributes.pm-based setting
+ process, and shouldn't bother appending recognized
+ flags. To experiment with that, uncomment the
+ following "else": */
+ else
+ attrs = append_elem(OP_LIST, attrs,
+ newSVOP(OP_CONST, 0,
+ newSVpvn(s, len)));
}
s = skipspace(d);
if (*s == ':' && s[1] != ':')
PL_expect = XTERM;
TOKEN('(');
case ';':
- if (CopLINE(PL_curcop) < PL_copline)
- PL_copline = CopLINE(PL_curcop);
+ CLINE;
tmp = *s++;
OPERATOR(tmp);
case ')':
PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
OPERATOR(HASHBRACK);
case XOPERATOR:
- while (s < PL_bufend && (*s == ' ' || *s == '\t'))
+ while (s < PL_bufend && SPACE_OR_TAB(*s))
s++;
d = s;
PL_tokenbuf[0] = '\0';
if (d < PL_bufend && *d == '-') {
PL_tokenbuf[0] = '-';
d++;
- while (d < PL_bufend && (*d == ' ' || *d == '\t'))
+ while (d < PL_bufend && SPACE_OR_TAB(*d))
d++;
}
if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
FALSE, &len);
- while (d < PL_bufend && (*d == ' ' || *d == '\t'))
+ while (d < PL_bufend && SPACE_OR_TAB(*d))
d++;
if (*d == '}') {
char minus = (PL_tokenbuf[0] == '-');
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) {
if (PL_lex_brackets < PL_lex_formbrack) {
char *t;
#ifdef PERL_STRICT_CR
- for (t = s; *t == ' ' || *t == '\t'; t++) ;
+ for (t = s; SPACE_OR_TAB(*t); t++) ;
#else
- for (t = s; *t == ' ' || *t == '\t' || *t == '\r'; t++) ;
+ for (t = s; SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
#endif
if (*t == '\n' || *t == '#') {
s--;
case '?': /* may either be conditional or pattern */
if (PL_expect != XOPERATOR) {
/* Disable warning on "study /blah/" */
- if (PL_oldoldbufptr == PL_last_uni
- && (*PL_last_uni != 's' || s - PL_last_uni < 5
+ if (PL_oldoldbufptr == PL_last_uni
+ && (*PL_last_uni != 's' || s - PL_last_uni < 5
|| memNE(PL_last_uni, "study", 5)
|| isALNUM_lazy_if(PL_last_uni+5,UTF)))
check_uni();
/* FALL THROUGH */
case '0': case '1': case '2': case '3': case '4':
case '5': case '6': case '7': case '8': case '9':
- s = scan_num(s);
+ s = scan_num(s, &yylval);
+ DEBUG_T( { PerlIO_printf(Perl_debug_log,
+ "### Saw number in '%s'\n", s);
+ } )
if (PL_expect == XOPERATOR)
no_op("Number",s);
TERM(THING);
case '\'':
s = scan_str(s,FALSE,FALSE);
+ DEBUG_T( { PerlIO_printf(Perl_debug_log,
+ "### Saw string before '%s'\n", s);
+ } )
if (PL_expect == XOPERATOR) {
if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
PL_expect = XTERM;
case '"':
s = scan_str(s,FALSE,FALSE);
+ DEBUG_T( { PerlIO_printf(Perl_debug_log,
+ "### Saw string before '%s'\n", s);
+ } )
if (PL_expect == XOPERATOR) {
if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
PL_expect = XTERM;
missingterm((char*)0);
yylval.ival = OP_CONST;
for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
- if (*d == '$' || *d == '@' || *d == '\\' || *d & 0x80) {
+ if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
yylval.ival = OP_STRINGIFY;
break;
}
case '`':
s = scan_str(s,FALSE,FALSE);
+ DEBUG_T( { PerlIO_printf(Perl_debug_log,
+ "### Saw backtick string before '%s'\n", s);
+ } )
if (PL_expect == XOPERATOR)
no_op("Backticks",s);
if (!s)
while (isDIGIT(*start) || *start == '_')
start++;
if (*start == '.' && isDIGIT(start[1])) {
- s = scan_num(s);
+ s = scan_num(s, &yylval);
TERM(THING);
}
/* avoid v123abc() or $h{v1}, allow C<print v10;> */
gv = gv_fetchpv(s, FALSE, SVt_PVCV);
*start = c;
if (!gv) {
- s = scan_num(s);
+ s = scan_num(s, &yylval);
TERM(THING);
}
}
tmp = keyword(PL_tokenbuf, len);
/* Is this a word before a => operator? */
- if (strnEQ(d,"=>",2)) {
+ if (*d == '=' && d[1] == '>') {
CLINE;
yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
yylval.opval->op_private = OPpCONST_BARE;
+ if (UTF && !IN_BYTE && is_utf8_string((U8*)PL_tokenbuf, len))
+ SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
TERM(WORD);
}
PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
{
if (ckWARN(WARN_BAREWORD) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
- Perl_warner(aTHX_ WARN_BAREWORD,
+ Perl_warner(aTHX_ WARN_BAREWORD,
"Bareword \"%s\" refers to nonexistent package",
PL_tokenbuf);
len -= 2;
/* If not a declared subroutine, it's an indirect object. */
/* (But it's an indir obj regardless for sort.) */
- if ((PL_last_lop_op == OP_SORT ||
- (!immediate_paren && (!gv || !GvCVu(gv)))) &&
+ if ( !immediate_paren && (PL_last_lop_op == OP_SORT ||
+ ((!gv || !GvCVu(gv)) &&
(PL_last_lop_op != OP_MAPSTART &&
- PL_last_lop_op != OP_GREPSTART))
+ PL_last_lop_op != OP_GREPSTART))))
{
PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
goto bareword;
}
}
- /* If followed by a paren, it's certainly a subroutine. */
PL_expect = XOPERATOR;
s = skipspace(s);
+
+ /* Is this a word before a => operator? */
+ if (*s == '=' && s[1] == '>') {
+ CLINE;
+ sv_setpv(((SVOP*)yylval.opval)->op_sv, PL_tokenbuf);
+ if (UTF && !IN_BYTE && is_utf8_string((U8*)PL_tokenbuf, len))
+ SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
+ TERM(WORD);
+ }
+
+ /* If followed by a paren, it's certainly a subroutine. */
if (*s == '(') {
CLINE;
if (gv && GvCVu(gv)) {
- for (d = s + 1; *d == ' ' || *d == '\t'; d++) ;
+ for (d = s + 1; SPACE_OR_TAB(*d); d++) ;
if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
s = d + 1;
goto its_constant;
/* 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);
}
if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
-#if defined(__BORLANDC__)
+#ifdef PERLIO_IS_STDIO /* really? */
+# if defined(__BORLANDC__)
/* XXX see note in do_binmode() */
- ((FILE*)PL_rsfp)->flags |= _F_BIN;
+ ((FILE*)PL_rsfp)->flags &= ~_F_BIN;
+# endif
#endif
if (loc > 0)
PerlIO_seek(PL_rsfp, loc, 0);
}
}
#endif
+#ifdef PERLIO_LAYERS
+ if (UTF && !IN_BYTE)
+ PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
+#endif
PL_rsfp = Nullfp;
}
goto fake_eof;
case KEY_exists:
UNI(OP_EXISTS);
-
+
case KEY_exit:
UNI(OP_EXIT);
case KEY_last:
s = force_word(s,WORD,TRUE,FALSE,FALSE);
LOOPX(OP_LAST);
-
+
case KEY_lc:
UNI(OP_LC);
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;
case KEY_pos:
UNI(OP_POS);
-
+
case KEY_pack:
LOP(OP_PACK,XTERM);
int warned = 0;
d = SvPV_force(PL_lex_stuff, len);
while (len) {
+ SV *sv;
for (; isSPACE(*d) && len; --len, ++d) ;
if (len) {
char *b = d;
else {
for (; !isSPACE(*d) && len; --len, ++d) ;
}
+ sv = newSVpvn(b, d-b);
+ if (DO_UTF8(PL_lex_stuff))
+ SvUTF8_on(sv);
words = append_elem(OP_LIST, words,
- newSVOP(OP_CONST, 0, newSVpvn(b, d-b)));
+ newSVOP(OP_CONST, 0, tokeq(sv)));
}
}
if (words) {
force_next(THING);
}
}
- if (PL_lex_stuff)
+ if (PL_lex_stuff) {
SvREFCNT_dec(PL_lex_stuff);
- PL_lex_stuff = Nullsv;
+ PL_lex_stuff = Nullsv;
+ }
PL_expect = XTERM;
TOKEN('(');
case KEY_chomp:
UNI(OP_CHOMP);
-
+
case KEY_scalar:
UNI(OP_SCALAR);
char *p;
s = scan_str(s,FALSE,FALSE);
- if (!s) {
- if (PL_lex_stuff)
- SvREFCNT_dec(PL_lex_stuff);
- PL_lex_stuff = Nullsv;
+ if (!s)
Perl_croak(aTHX_ "Prototype not terminated");
- }
/* strip spaces */
d = SvPVX(PL_lex_stuff);
tmp = 0;
case KEY_umask:
if (ckWARN(WARN_UMASK)) {
for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
- if (*d != '0' && isDIGIT(*d))
+ if (*d != '0' && isDIGIT(*d))
Perl_warner(aTHX_ WARN_UMASK,
"umask: argument is missing initial 0");
}
{
static char ctl_l[2];
- if (ctl_l[0] == '\0')
+ if (ctl_l[0] == '\0')
ctl_l[0] = toCTRL('L');
gv_fetchpv(ctl_l,TRUE, SVt_PV);
}
}
}}
}
+#ifdef __SC__
+#pragma segment Main
+#endif
I32
Perl_keyword(pTHX_ register char *d, I32 len)
if (strEQ(d,"cos")) return -KEY_cos;
break;
case 4:
- if (strEQ(d,"chop")) return KEY_chop;
+ if (strEQ(d,"chop")) return -KEY_chop;
break;
case 5:
if (strEQ(d,"close")) return -KEY_close;
if (strEQ(d,"chdir")) return -KEY_chdir;
- if (strEQ(d,"chomp")) return KEY_chomp;
+ if (strEQ(d,"chomp")) return -KEY_chomp;
if (strEQ(d,"chmod")) return -KEY_chmod;
if (strEQ(d,"chown")) return -KEY_chown;
if (strEQ(d,"crypt")) return -KEY_crypt;
}
break;
case 'E':
- if (strEQ(d,"EQ")) { deprecate(d); return -KEY_eq;}
if (strEQ(d,"END")) return KEY_END;
break;
case 'e':
if (strEQ(d,"exit")) return -KEY_exit;
if (strEQ(d,"eval")) return KEY_eval;
if (strEQ(d,"exec")) return -KEY_exec;
- if (strEQ(d,"each")) return KEY_each;
+ if (strEQ(d,"each")) return -KEY_each;
break;
case 5:
if (strEQ(d,"elsif")) return KEY_elsif;
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;
break;
case 'k':
if (len == 4) {
- if (strEQ(d,"keys")) return KEY_keys;
+ if (strEQ(d,"keys")) return -KEY_keys;
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;
case 'p':
switch (len) {
case 3:
- if (strEQ(d,"pop")) return KEY_pop;
+ if (strEQ(d,"pop")) return -KEY_pop;
if (strEQ(d,"pos")) return KEY_pos;
break;
case 4:
- if (strEQ(d,"push")) return KEY_push;
+ if (strEQ(d,"push")) return -KEY_push;
if (strEQ(d,"pack")) return -KEY_pack;
if (strEQ(d,"pipe")) return -KEY_pipe;
break;
case 'h':
switch (len) {
case 5:
- if (strEQ(d,"shift")) return KEY_shift;
+ if (strEQ(d,"shift")) return -KEY_shift;
break;
case 6:
if (strEQ(d,"shmctl")) return -KEY_shmctl;
case 'p':
if (strEQ(d,"split")) return KEY_split;
if (strEQ(d,"sprintf")) return -KEY_sprintf;
- if (strEQ(d,"splice")) return KEY_splice;
+ if (strEQ(d,"splice")) return -KEY_splice;
break;
case 'q':
if (strEQ(d,"sqrt")) return -KEY_sqrt;
if (strEQ(d,"unlink")) return -KEY_unlink;
break;
case 7:
- if (strEQ(d,"unshift")) return KEY_unshift;
+ if (strEQ(d,"unshift")) return -KEY_unshift;
if (strEQ(d,"ucfirst")) return -KEY_ucfirst;
break;
}
char *w;
if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
- dTHR; /* only for ckWARN */
if (ckWARN(WARN_SYNTAX)) {
int level = 1;
for (w = s+2; *w && level; w++) {
SV *res;
SV **cvp;
SV *cv, *typesv;
- const char *why, *why1, *why2;
-
- if (!(PL_hints & HINT_LOCALIZE_HH)) {
+ const char *why1, *why2, *why3;
+
+ if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
SV *msg;
- why = "%^H is not localized";
- report_short:
- why1 = why2 = "";
+ why2 = strEQ(key,"charnames")
+ ? "(possibly a missing \"use charnames ...\")"
+ : "";
+ msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s",
+ (type ? type: "undef"), why2);
+
+ /* This is convoluted and evil ("goto considered harmful")
+ * but I do not understand the intricacies of all the different
+ * failure modes of %^H in here. The goal here is to make
+ * the most probable error message user-friendly. --jhi */
+
+ goto msgdone;
+
report:
- msg = Perl_newSVpvf(aTHX_ "constant(%s): %s%s%s",
- (type ? type: "undef"), why1, why2, why);
+ msg = Perl_newSVpvf(aTHX_ "Constant(%s): %s%s%s",
+ (type ? type: "undef"), why1, why2, why3);
+ msgdone:
yyerror(SvPVX(msg));
SvREFCNT_dec(msg);
return sv;
}
- if (!table) {
- why = "%^H is not defined";
- goto report_short;
- }
cvp = hv_fetch(table, key, strlen(key), FALSE);
if (!cvp || !SvOK(*cvp)) {
- why = "} is not defined";
why1 = "$^H{";
why2 = key;
+ why3 = "} is not defined";
goto report;
}
sv_2mortal(sv); /* Parent created it permanently */
typesv = sv_2mortal(newSVpv(type, 0));
else
typesv = &PL_sv_undef;
-
+
PUSHSTACKi(PERLSI_OVERLOAD);
ENTER ;
SAVETMPS;
-
+
PUSHMARK(SP) ;
- EXTEND(sp, 4);
+ EXTEND(sp, 3);
if (pv)
PUSHs(pv);
PUSHs(sv);
if (pv)
PUSHs(typesv);
- PUSHs(cv);
PUTBACK;
call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
-
+
SPAGAIN ;
-
+
/* Check the eval first */
if (!PL_in_eval && SvTRUE(ERRSV)) {
STRLEN n_a;
res = POPs;
(void)SvREFCNT_inc(res);
}
-
+
PUTBACK ;
FREETMPS ;
LEAVE ;
POPSTACK;
-
+
if (!SvOK(res)) {
- why = "}} did not return a defined value";
why1 = "Call to &{$^H{";
why2 = key;
+ why3 = "}} did not return a defined value";
sv = res;
goto report;
}
return res;
}
-
+
STATIC char *
S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
{
*d++ = *s++;
*d++ = *s++;
}
- else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
+ else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
char *t = s + UTF8SKIP(s);
- while (*t & 0x80 && is_utf8_mark((U8*)t))
+ while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
t += UTF8SKIP(t);
if (d + (t - s) > e)
Perl_croak(aTHX_ ident_too_long);
*d++ = *s++;
*d++ = *s++;
}
- else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
+ else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
char *t = s + UTF8SKIP(s);
- while (*t & 0x80 && is_utf8_mark((U8*)t))
+ while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
t += UTF8SKIP(t);
if (d + (t - s) > e)
Perl_croak(aTHX_ ident_too_long);
if (isSPACE(s[-1])) {
while (s < send) {
char ch = *s++;
- if (ch != ' ' && ch != '\t') {
+ if (!SPACE_OR_TAB(ch)) {
*d = ch;
break;
}
e = s;
while ((e < send && isALNUM_lazy_if(e,UTF)) || *e == ':') {
e += UTF8SKIP(e);
- while (e < send && *e & 0x80 && is_utf8_mark((U8*)e))
+ while (e < send && UTF8_IS_CONTINUED(*e) && is_utf8_mark((U8*)e))
e += UTF8SKIP(e);
}
Copy(s, d, e - s, char);
Perl_croak(aTHX_ ident_too_long);
}
*d = '\0';
- while (s < send && (*s == ' ' || *s == '\t')) s++;
+ while (s < send && SPACE_OR_TAB(*s)) s++;
if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
- dTHR; /* only for ckWARN */
if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
const char *brack = *s == '[' ? "[...]" : "{...}";
Perl_warner(aTHX_ WARN_AMBIGUOUS,
PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
return s;
}
- }
- /* Handle extended ${^Foo} variables
+ }
+ /* Handle extended ${^Foo} variables
* 1999-02-27 mjd-perl-patch@plover.com */
else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
&& isALNUM(*s))
if (funny == '#')
funny = '@';
if (PL_lex_state == LEX_NORMAL) {
- dTHR; /* only for ckWARN */
if (ckWARN(WARN_AMBIGUOUS) &&
(keyword(dest, d - dest) || get_cv(dest, FALSE)))
{
char *s;
s = scan_str(start,FALSE,FALSE);
- if (!s) {
- if (PL_lex_stuff)
- SvREFCNT_dec(PL_lex_stuff);
- PL_lex_stuff = Nullsv;
+ if (!s)
Perl_croak(aTHX_ "Search pattern not terminated");
- }
pm = (PMOP*)newPMOP(type, 0);
if (PL_multi_open == '?')
s = scan_str(start,FALSE,FALSE);
- if (!s) {
- if (PL_lex_stuff)
- SvREFCNT_dec(PL_lex_stuff);
- PL_lex_stuff = Nullsv;
+ if (!s)
Perl_croak(aTHX_ "Substitution pattern not terminated");
- }
if (s[-1] == PL_multi_open)
s--;
first_start = PL_multi_start;
s = scan_str(s,FALSE,FALSE);
if (!s) {
- if (PL_lex_stuff)
+ if (PL_lex_stuff) {
SvREFCNT_dec(PL_lex_stuff);
- PL_lex_stuff = Nullsv;
- if (PL_lex_repl)
- SvREFCNT_dec(PL_lex_repl);
- PL_lex_repl = Nullsv;
+ PL_lex_stuff = Nullsv;
+ }
Perl_croak(aTHX_ "Substitution replacement not terminated");
}
PL_multi_start = first_start; /* so whole substitution is taken together */
I32 squash;
I32 del;
I32 complement;
- I32 utf8;
- I32 count = 0;
yylval.ival = OP_NULL;
s = scan_str(start,FALSE,FALSE);
- if (!s) {
- if (PL_lex_stuff)
- SvREFCNT_dec(PL_lex_stuff);
- PL_lex_stuff = Nullsv;
+ if (!s)
Perl_croak(aTHX_ "Transliteration pattern not terminated");
- }
if (s[-1] == PL_multi_open)
s--;
s = scan_str(s,FALSE,FALSE);
if (!s) {
- if (PL_lex_stuff)
+ if (PL_lex_stuff) {
SvREFCNT_dec(PL_lex_stuff);
- PL_lex_stuff = Nullsv;
- if (PL_lex_repl)
- SvREFCNT_dec(PL_lex_repl);
- PL_lex_repl = Nullsv;
+ PL_lex_stuff = Nullsv;
+ }
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;
+
+ New(803, tbl, complement&&!del?258:256, short);
+ o = newPVOP(OP_TRANS, 0, (char*)tbl);
+ o->op_private = del|squash|complement|
+ (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
+ (DO_UTF8(PL_lex_repl) ? OPpTRANS_TO_UTF : 0);
PL_lex_op = o;
yylval.ival = OP_TRANS;
STATIC char *
S_scan_heredoc(pTHX_ register char *s)
{
- dTHR;
SV *herewas;
I32 op_type = OP_SCALAR;
I32 len;
e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
if (!outer)
*d++ = '\n';
- for (peek = s; *peek == ' ' || *peek == '\t'; peek++) ;
+ for (peek = s; SPACE_OR_TAB(*peek); peek++) ;
if (*peek && strchr("`'\"",*peek)) {
s = peek;
term = *s++;
sv_setsv(PL_linestr,herewas);
PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
+ PL_last_lop = PL_last_uni = Nullch;
}
else
sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
}
CopLINE_inc(PL_curcop);
PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
+ PL_last_lop = PL_last_uni = Nullch;
#ifndef PERL_STRICT_CR
if (PL_bufend - PL_linestart >= 2) {
if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
}
SvREFCNT_dec(herewas);
+ if (UTF && !IN_BYTE && is_utf8_string((U8*)SvPVX(tmpstr), SvCUR(tmpstr)))
+ SvUTF8_on(tmpstr);
PL_lex_stuff = tmpstr;
yylval.ival = op_type;
return s;
calls scan_str(). s/// makes yylex() call scan_subst() which calls
scan_str(). tr/// and y/// make yylex() call scan_trans() which
calls scan_str().
-
+
It skips whitespace before the string starts, and treats the first
character as the delimiter. If the delimiter is one of ([{< then
the corresponding "close" character )]}> is used as the closing
delimiter. It allows quoting of delimiters, and if the string has
balanced delimiters ([{<>}]) it allows nesting.
- The lexer always reads these strings into lex_stuff, except in the
- case of the operators which take *two* arguments (s/// and tr///)
- when it checks to see if lex_stuff is full (presumably with the 1st
- arg to s or tr) and if so puts the string into lex_repl.
-
+ On success, the SV with the resulting string is put into lex_stuff or,
+ if that is already non-NULL, into lex_repl. The second case occurs only
+ when parsing the RHS of the special constructs s/// and tr/// (y///).
+ For convenience, the terminating delimiter character is stuffed into
+ SvIVX of the SV.
*/
STATIC char *
S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
{
- dTHR;
SV *sv; /* scalar value: string */
char *tmps; /* temp string, used for delimiter matching */
register char *s = start; /* current position in the buffer */
register char term; /* terminating character */
register char *to; /* current position in the sv's data */
I32 brackets = 1; /* bracket nesting level */
- bool has_utf = FALSE; /* is there any utf8 content? */
+ bool has_utf8 = FALSE; /* is there any utf8 content? */
/* skip space before the delimiter */
if (isSPACE(*s))
/* after skipping whitespace, the next character is the terminator */
term = *s;
- if ((term & 0x80) && UTF)
- has_utf = TRUE;
+ if (!UTF8_IS_INVARIANT((U8)term) && UTF)
+ has_utf8 = TRUE;
/* mark where we are */
PL_multi_start = CopLINE(PL_curcop);
have found the terminator */
else if (*s == term)
break;
- else if (!has_utf && (*s & 0x80) && UTF)
- has_utf = TRUE;
+ else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
+ has_utf8 = TRUE;
*to = *s;
}
}
break;
else if (*s == PL_multi_open)
brackets++;
- else if (!has_utf && (*s & 0x80) && UTF)
- has_utf = TRUE;
+ else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
+ has_utf8 = TRUE;
*to = *s;
}
}
/* having changed the buffer, we must update PL_bufend */
PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
+ PL_last_lop = PL_last_uni = Nullch;
}
-
+
/* at this point, we have successfully read the delimited string */
if (keep_delims)
sv_catpvn(sv, s, 1);
- if (has_utf)
+ if (has_utf8)
SvUTF8_on(sv);
PL_multi_end = CopLINE(PL_curcop);
s++;
/* decide whether this is the first or second quoted string we've read
for this op
*/
-
+
if (PL_lex_stuff)
PL_lex_repl = sv;
else
try converting the number to an integer and see if it can do so
without loss of precision.
*/
-
+
char *
-Perl_scan_num(pTHX_ char *start)
+Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp)
{
register char *s = start; /* current position in buffer */
register char *d; /* destination in temp buffer */
register char *e; /* end of temp buffer */
- NV value; /* number read, as a double */
+ NV nv; /* number read, as a double */
SV *sv = Nullsv; /* place to put the converted number */
bool floatit; /* boolean: int or float? */
char *lastub = 0; /* position of last underbar */
switch (*s) {
default:
Perl_croak(aTHX_ "panic: scan_num");
-
+
/* if it starts with a 0, it could be an octal number, a decimal in
0.13 disguise, or a hexadecimal number, or a binary number. */
case '0':
we in octal/hex/binary?" indicator to disallow hex characters
when in octal mode.
*/
- dTHR;
NV n = 0.0;
UV u = 0;
I32 shift;
if ((x >> shift) != u
&& !(PL_hints & HINT_NEW_BINARY)) {
- dTHR;
overflowed = TRUE;
n = (NV) u;
if (ckWARN_d(WARN_OVERFLOW))
out:
sv = NEWSV(92,0);
if (overflowed) {
- dTHR;
if (ckWARN(WARN_PORTABLE) && n > 4294967295.0)
Perl_warner(aTHX_ WARN_PORTABLE,
"%s number > %s non-portable",
}
else {
#if UVSIZE > 4
- dTHR;
if (ckWARN(WARN_PORTABLE) && u > 0xffffffff)
Perl_warner(aTHX_ WARN_PORTABLE,
"%s number > %s non-portable",
/* read next group of digits and _ and copy into d */
while (isDIGIT(*s) || *s == '_') {
- /* skip underscores, checking for misplaced ones
+ /* skip underscores, checking for misplaced ones
if -w is on
*/
if (*s == '_') {
- dTHR; /* only for ckWARN */
if (ckWARN(WARN_SYNTAX) && lastub && s - lastub != 3)
Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
lastub = ++s;
/* final misplaced underbar check */
if (lastub && s - lastub != 3) {
- dTHR;
if (ckWARN(WARN_SYNTAX))
Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
}
/* make an sv from the string */
sv = NEWSV(92,0);
- /* unfortunately this monster needs to be on one line or
- makedepend will be confused. */
-#if (defined(USE_64_BIT_INT) && (!defined(HAS_STRTOLL)|| !defined(HAS_STRTOULL))) || (!defined(USE_64_BIT_INT) && (!defined(HAS_STRTOL) || !defined(HAS_STRTOUL)))
+#if defined(Strtol) && defined(Strtoul)
/*
- No working strto[u]l[l]. Since atoi() doesn't do range checks,
- we need to do this the hard way.
- */
-
- value = Atof(PL_tokenbuf);
-
- /*
- See if we can make do with an integer value without loss of
- precision. We use I_V to cast to an int, because some
- compilers have issues. Then we try casting it back and see
- if it was the same. We only do this if we know we
- specifically read an integer.
-
- Note: if floatit is true, then we don't need to do the
- conversion at all.
- */
- {
- UV tryuv = U_V(value);
- if (!floatit && (NV)tryuv == value) {
- if (tryuv <= IV_MAX)
- sv_setiv(sv, (IV)tryuv);
- else
- sv_setuv(sv, tryuv);
- }
- else
- sv_setnv(sv, value);
- }
-#else
- /*
strtol/strtoll sets errno to ERANGE if the number is too big
for an integer. We try to do an integer conversion first
if no characters indicating "float" have been found.
else
uv = Strtoul(PL_tokenbuf, (char**)NULL, 10);
if (errno)
- floatit = TRUE; /* probably just too large */
+ floatit = TRUE; /* Probably just too large. */
else if (*PL_tokenbuf == '-')
sv_setiv(sv, iv);
+ else if (uv <= IV_MAX)
+ sv_setiv(sv, uv); /* Prefer IVs over UVs. */
else
sv_setuv(sv, uv);
}
if (floatit) {
- value = Atof(PL_tokenbuf);
- sv_setnv(sv, value);
+ nv = Atof(PL_tokenbuf);
+ sv_setnv(sv, nv);
+ }
+#else
+ /*
+ No working strtou?ll?.
+
+ Unfortunately atol() doesn't do range checks (returning
+ LONG_MIN/LONG_MAX, and setting errno to ERANGE on overflows)
+ everywhere [1], so we cannot use use atol() (or atoll()).
+ If we could, they would be used, as Atol(), very much like
+ Strtol() and Strtoul() are used above.
+
+ [1] XXX Configure test needed to check for atol()
+ (and atoll()) overflow behaviour XXX
+
+ --jhi
+
+ We need to do this the hard way. */
+
+ nv = Atof(PL_tokenbuf);
+
+ /* See if we can make do with an integer value without loss of
+ precision. We use U_V to cast to a UV, because some
+ compilers have issues. Then we try casting it back and see
+ if it was the same [1]. We only do this if we know we
+ specifically read an integer. If floatit is true, then we
+ don't need to do the conversion at all.
+
+ [1] Note that this is lossy if our NVs cannot preserve our
+ UVs. There are metaconfig defines NV_PRESERVES_UV (a boolean)
+ and NV_PRESERVES_UV_BITS (a number), but in general we really
+ do hope all such potentially lossy platforms have strtou?ll?
+ to do a lossless IV/UV conversion.
+
+ Maybe could do some tricks with DBL_DIG, LDBL_DIG and
+ DBL_MANT_DIG and LDBL_MANT_DIG (these are already available
+ as NV_DIG and NV_MANT_DIG)?
+
+ --jhi
+ */
+ {
+ UV uv = U_V(nv);
+ if (!floatit && (NV)uv == nv) {
+ if (uv <= IV_MAX)
+ sv_setiv(sv, uv); /* Prefer IVs over UVs. */
+ else
+ sv_setuv(sv, uv);
+ }
+ else
+ sv_setnv(sv, nv);
}
#endif
if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
(PL_hints & HINT_NEW_INTEGER) )
- sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
+ sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
(floatit ? "float" : "integer"),
sv, Nullsv, NULL);
break;
pos++;
if (!isALPHA(*pos)) {
UV rev;
- U8 tmpbuf[UTF8_MAXLEN];
+ U8 tmpbuf[UTF8_MAXLEN+1];
U8 *tmpend;
- bool utf8 = FALSE;
s++; /* get past 'v' */
sv = NEWSV(92,5);
"Integer overflow in decimal number");
}
}
- tmpend = uv_to_utf8(tmpbuf, rev);
- utf8 = utf8 || rev > 127;
+ /* Append native character for the rev point */
+ tmpend = uvchr_to_utf8(tmpbuf, rev);
sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
+ if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev)))
+ SvUTF8_on(sv);
if (*pos == '.' && isDIGIT(pos[1]))
s = ++pos;
else {
while (isDIGIT(*pos) || *pos == '_')
pos++;
}
-
SvPOK_on(sv);
SvREADONLY_on(sv);
- if (utf8) {
- SvUTF8_on(sv);
- sv_utf8_downgrade(sv, TRUE);
- }
}
}
break;
/* make the op for the constant and return */
if (sv)
- yylval.opval = newSVOP(OP_CONST, 0, sv);
+ lvalp->opval = newSVOP(OP_CONST, 0, sv);
else
- yylval.opval = Nullop;
+ lvalp->opval = Nullop;
return s;
}
STATIC char *
S_scan_formline(pTHX_ register char *s)
{
- dTHR;
register char *eol;
register char *t;
SV *stuff = newSVpvn("",0);
bool needargs = FALSE;
while (!needargs) {
- if (*s == '.' || *s == '}') {
+ if (*s == '.' || *s == /*{*/'}') {
/*SUPPRESS 530*/
#ifdef PERL_STRICT_CR
- for (t = s+1;*t == ' ' || *t == '\t'; t++) ;
+ for (t = s+1;SPACE_OR_TAB(*t); t++) ;
#else
- for (t = s+1;*t == ' ' || *t == '\t' || *t == '\r'; t++) ;
+ for (t = s+1;SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
#endif
if (*t == '\n' || t == PL_bufend)
break;
s = filter_gets(PL_linestr, PL_rsfp, 0);
PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
PL_bufend = PL_bufptr + SvCUR(PL_linestr);
+ PL_last_lop = PL_last_uni = Nullch;
if (!s) {
s = PL_bufptr;
yyerror("Format not terminated");
I32
Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
{
- dTHR;
I32 oldsavestack_ix = PL_savestack_ix;
CV* outsidecv = PL_compcv;
AV* comppadlist;
return oldsavestack_ix;
}
+#ifdef __SC__
+#pragma segment Perl_yylex
+#endif
int
Perl_yywarn(pTHX_ char *s)
{
- dTHR;
PL_in_eval |= EVAL_WARNONLY;
yyerror(s);
PL_in_eval &= ~EVAL_WARNONLY;
int
Perl_yyerror(pTHX_ char *s)
{
- dTHR;
char *where = NULL;
char *context = NULL;
int contlen = -1;
qerror(msg);
if (PL_error_count >= 10) {
if (PL_in_eval && SvCUR(ERRSV))
- Perl_croak(aTHX_ "%_%s has too many errors.\n",
+ Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
ERRSV, CopFILE(PL_curcop));
else
Perl_croak(aTHX_ "%s has too many errors.\n",
PL_in_my_stash = Nullhv;
return 0;
}
+#ifdef __SC__
+#pragma segment Main
+#endif
+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"
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;
+ 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);
+ }
+ 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