* "It all comes from here, the stench and the peril." --Frodo
*/
-/* toke.c
- *
- * This file is the tokenizer for Perl. It's closely linked to the
+/*
+ * This file is the lexer for Perl. It's closely linked to the
* parser, perly.y.
*
* The main routine is yylex(), which returns the next token.
/*
* Convenience functions to return different tokens and prime the
- * tokenizer for the next token. They all take an argument.
+ * lexer for the next token. They all take an argument.
*
* TOKEN : generic token (used for '(', DOLSHARP, etc)
* OPERATOR : generic operator
* BAop : bitwise and
* SHop : shift operator
* PWop : power operator
- * PMop : matching operator
+ * PMop : pattern-matching operator
* Aop : addition-level operator
* Mop : multiplication-level operator
* Eop : equality-testing operator
/*
* Perl_deprecate
- * Warns that something is deprecated. Duh.
*/
void
/*
* depcom
- * Deprecate a comma-less variable list. Called from three places
- * in the tokenizer.
+ * Deprecate a comma-less variable list.
*/
STATIC void
}
/*
- * text filters for win32 carriage-returns, utf16-to-utf8 and
- * utf16-to-utf8-reversed, whatever that is.
+ * experimental text filters for win32 carriage-returns, utf16-to-utf8 and
+ * utf16-to-utf8-reversed.
*/
#ifdef WIN32
/*
* Perl_lex_start
- * Initialize variables. Called by perl.c. It uses the Perl stack
- * to save its state (for recursive calls to the parser).
+ * Initialize variables. Uses the Perl save_stack to save its state (for
+ * recursive calls to the parser).
*/
void
/*
* Perl_lex_end
- * Tidy up. Called from pp_ctl.c in the sv_compile_2op(), doeval(),
- * and pp_leaveeval() subroutines.
+ * Finalizer for lexing operations. Must be called when the parser is
+ * done with the lexer.
*/
void
* or pinball tables. Its name is short for "increment line". It
* increments the current line number in PL_curcop->cop_line and checks
* to see whether the line starts with a comment of the form
- * # line 500
- * If so, it sets the current line number to the number in the comment.
+ * # line 500 "foo.pm"
+ * If so, it sets the current line number and file to the values in the comment.
*/
STATIC void
return s;
/* try to recharge the buffer */
- if ((s = filter_gets(PL_linestr, PL_rsfp, (prevlen = SvCUR(PL_linestr)))) == Nullch) {
- /* end of file. Add on the -p or -n magic */
+ if ((s = filter_gets(PL_linestr, PL_rsfp,
+ (prevlen = SvCUR(PL_linestr)))) == Nullch)
+ {
+ /* end of file. Add on the -p or -n magic */
if (PL_minus_n || PL_minus_p) {
sv_setpv(PL_linestr,PL_minus_p ?
";}continue{print or die qq(-p destination: $!\\n)" :
sv_setpv(PL_linestr,";");
/* reset variables for next time we lex */
- PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
+ PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart
+ = SvPVX(PL_linestr);
PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
/* Close the filehandle. Could be from -P preprocessor,
/*
* S_force_next
- * When the tokenizer realizes it knows the next token (for instance,
+ * When the lexer realizes it knows the next token (for instance,
* it is reordering tokens for the parser) then it can call S_force_next
- * to make the current token be the next one. It will also set
- * PL_nextval, and possibly PL_expect to ensure the lexer handles the
- * token correctly.
+ * to know what token to return the next time the lexer is called. Caller
+ * will need to set PL_nextval[], and possibly PL_expect to ensure the lexer
+ * handles the token correctly.
*/
STATIC void
* a keyword (do this if the word is a label, e.g. goto FOO)
* int allow_pack : if true, : characters will also be allowed (require,
* use, etc. do this)
- * int allow_initial_tick : used by the "sub" tokenizer only.
+ * int allow_initial_tick : used by the "sub" lexer only.
*/
STATIC char *
/*
* S_force_ident
- * Called when the tokenizer wants $foo *foo &foo etc, but the program
+ * Called when the lexer wants $foo *foo &foo etc, but the program
* text only contains the "foo" portion. The first argument is a pointer
* to the "foo", and the second argument is the type symbol to prefix.
* Forces the next token to be a "WORD".
- * Creates the symbol if it didn't already exist (through the gv_fetchpv
- * call).
+ * Creates the symbol if it didn't already exist (via gv_fetchpv()).
*/
STATIC void
PL_linestr = PL_lex_stuff;
PL_lex_stuff = Nullsv;
- PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
+ PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
+ = SvPVX(PL_linestr);
PL_bufend += SvCUR(PL_linestr);
SAVEFREESV(PL_linestr);
? (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))
+ ? (PL_sublex_info.sub_op->op_private & (PL_lex_repl ?
+ OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF))
: UTF;
- /* leaveit is the set of acceptably-backslashed characters */
- char *leaveit =
+ char *leaveit = /* set of acceptably-backslashed characters */
PL_lex_inpat
- ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxcz0123456789[{]} \t\n\r\f\v#"
+ ? "\\.^$@AGZdDwWsSbBpPXO+*?|()-nrtfeaxcz0123456789[{]} \t\n\r\f\v#"
: "";
while (s < send || dorange) {
I32 max; /* last character in range */
i = d - SvPVX(sv); /* remember current offset */
- SvGROW(sv, SvLEN(sv) + 256); /* expand the sv -- there'll never be more'n 256 chars in a range for it to grow by */
- d = SvPVX(sv) + i; /* restore d after the grow potentially has changed the ptr */
+ SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */
+ d = SvPVX(sv) + i; /* refresh d after realloc */
d -= 2; /* eat the first char and the - */
min = (U8)*d; /* first char in range */
}
continue;
+ /* \C{latin small letter a} is a named character */
+ case 'C':
+ ++s;
+ if (*s == '{') {
+ char* e = strchr(s, '}');
+ HV *hv;
+ SV **svp;
+ SV *res, *cv;
+ STRLEN len;
+ char *str;
+ char *why = Nullch;
+
+ if (!e) {
+ yyerror("Missing right brace on \\C{}");
+ e = s - 1;
+ goto cont_scan;
+ }
+ res = newSVpvn(s + 1, e - s - 1);
+ res = new_constant( Nullch, 0, "charnames",
+ res, Nullsv, "\\C{...}" );
+ str = SvPV(res,len);
+ if (len > e - s + 4) {
+ char *odest = SvPVX(sv);
+
+ SvGROW(sv, (SvCUR(sv) + len - (e - s + 4)));
+ d = SvPVX(sv) + (d - odest);
+ }
+ Copy(str, d, len, char);
+ d += len;
+ SvREFCNT_dec(res);
+ cont_scan:
+ s = e + 1;
+ }
+ else
+ yyerror("Missing braces on \\C{}");
+ continue;
+
/* \c is a control character */
case 'c':
s++;
/* S_intuit_more
* Returns TRUE if there's more to the expression (e.g., a subscript),
* FALSE otherwise.
- * This is the one truly awful dwimmer necessary to conflate C and sed.
*
* It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
*
* anything else returns TRUE
*/
+/* This is the one truly awful dwimmer necessary to conflate C and sed. */
+
STATIC int
S_intuit_more(pTHX_ register char *s)
{
TERM(THING);
case KEY___LINE__:
- yylval.opval = (OP*)newSVOP(OP_CONST, 0,
- Perl_newSVpvf(aTHX_ "%ld", (long)PL_curcop->cop_line));
+#ifdef IV_IS_QUAD
+ yylval.opval = (OP*)newSVOP(OP_CONST, 0,
+ Perl_newSVpvf(aTHX_ "%" PERL_PRId64, (IV)PL_curcop->cop_line));
+#else
+ yylval.opval = (OP*)newSVOP(OP_CONST, 0,
+ Perl_newSVpvf(aTHX_ "%ld", (long)PL_curcop->cop_line));
+#endif
TERM(THING);
case KEY___PACKAGE__:
}
}
+/* Either returns sv, or mortalizes sv and returns a new SV*.
+ Best used as sv=new_constant(..., sv, ...).
+ If s, pv are NULL, calls subroutine with one argument,
+ and type is used with error messages only. */
+
STATIC SV *
S_new_constant(pTHX_ char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type)
{
dSP;
HV *table = GvHV(PL_hintgv); /* ^H */
- BINOP myop;
SV *res;
- bool oldcatch = CATCH_GET;
SV **cvp;
SV *cv, *typesv;
-
+ char *why, *why1, *why2;
+
+ if (!(PL_hints & HINT_LOCALIZE_HH)) {
+ SV *msg;
+
+ why = "%^H is not localized";
+ report_short:
+ why1 = why2 = "";
+ report:
+ msg = Perl_newSVpvf(aTHX_ "constant(%s): %s%s%s",
+ (type ? type: "undef"), why1, why2, why);
+ yyerror(SvPVX(msg));
+ SvREFCNT_dec(msg);
+ return sv;
+ }
if (!table) {
- yyerror("%^H is not defined");
- return sv;
+ why = "%^H is not defined";
+ goto report_short;
}
cvp = hv_fetch(table, key, strlen(key), FALSE);
if (!cvp || !SvOK(*cvp)) {
- char buf[128];
- sprintf(buf,"$^H{%s} is not defined", key);
- yyerror(buf);
- return sv;
+ why = "} is not defined";
+ why1 = "$^H{";
+ why2 = key;
+ goto report;
}
sv_2mortal(sv); /* Parent created it permanently */
cv = *cvp;
- if (!pv)
- pv = sv_2mortal(newSVpvn(s, len));
- if (type)
- typesv = sv_2mortal(newSVpv(type, 0));
+ if (!pv && s)
+ pv = sv_2mortal(newSVpvn(s, len));
+ if (type && pv)
+ typesv = sv_2mortal(newSVpv(type, 0));
else
- typesv = &PL_sv_undef;
- CATCH_SET(TRUE);
- Zero(&myop, 1, BINOP);
- myop.op_last = (OP *) &myop;
- myop.op_next = Nullop;
- myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
-
+ typesv = &PL_sv_undef;
+
PUSHSTACKi(PERLSI_OVERLOAD);
- ENTER;
- SAVEOP();
- PL_op = (OP *) &myop;
- if (PERLDB_SUB && PL_curstash != PL_debstash)
- PL_op->op_private |= OPpENTERSUB_DB;
- PUTBACK;
- Perl_pp_pushmark(aTHX);
-
+ ENTER ;
+ SAVETMPS;
+
+ PUSHMARK(SP) ;
EXTEND(sp, 4);
- PUSHs(pv);
+ if (pv)
+ PUSHs(pv);
PUSHs(sv);
- PUSHs(typesv);
+ if (pv)
+ PUSHs(typesv);
PUSHs(cv);
PUTBACK;
-
- if (PL_op = Perl_pp_entersub(aTHX))
- CALLRUNOPS(aTHX);
- LEAVE;
- SPAGAIN;
-
- res = POPs;
- PUTBACK;
- CATCH_SET(oldcatch);
+ 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;
+ sv_catpv(ERRSV, "Propagated");
+ yyerror(SvPV(ERRSV, n_a)); /* Duplicates the message inside eval */
+ POPs ;
+ res = SvREFCNT_inc(sv);
+ }
+ else {
+ res = POPs;
+ SvREFCNT_inc(res);
+ }
+
+ PUTBACK ;
+ FREETMPS ;
+ LEAVE ;
POPSTACK;
-
+
if (!SvOK(res)) {
- char buf[128];
- sprintf(buf,"Call to &{$^H{%s}} did not return a defined value", key);
- yyerror(buf);
- }
- return SvREFCNT_inc(res);
+ why = "}} did not return a defined value";
+ why1 = "Call to &{$^H{";
+ why2 = key;
+ sv = res;
+ goto report;
+ }
+
+ return res;
}
-
+
STATIC char *
S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
{
register char *s = start; /* current position in buffer */
register char *d; /* destination in temp buffer */
register char *e; /* end of temp buffer */
- I32 tryiv; /* used to see if it can be an int */
+ IV tryiv; /* used to see if it can be an IV */
NV value; /* number read, as a double */
SV *sv; /* place to put the converted number */
- I32 floatit; /* boolean: int or float? */
+ bool floatit; /* boolean: int or float? */
char *lastub = 0; /* position of last underbar */
static char number_too_long[] = "Number too long";
static char *maxima[5] = { "",
"0b11111111111111111111111111111111",
"",
- "0b37777777777",
+ "037777777777",
"0xffffffff" };
char *base, *Base, *max;
/* read the rest of the number */
for (;;) {
/* x is used in the overflow test,
- b is the digit we're adding on */
+ b is the digit we're adding on. */
UV x, b;
switch (*s) {
sv = NEWSV(92,0);
if (overflowed) {
dTHR;
- if (ckWARN(WARN_UNSAFE) && (double) n > 4294967295.0)
+ if (ckWARN(WARN_UNSAFE) && n > 4294967295.0)
Perl_warner(aTHX_ WARN_UNSAFE,
"%s number > %s non-portable",
Base, max);
sv_setnv(sv, n);
}
else {
+#if UV_SIZEOF > 4
dTHR;
- if (ckWARN(WARN_UNSAFE) && u > 4294967295)
+ if (ckWARN(WARN_UNSAFE) && u > 0xffffffff)
Perl_warner(aTHX_ WARN_UNSAFE,
"%s number > %s non-portable",
Base, max);
+#endif
sv_setuv(sv, u);
}
- if ( PL_hints & HINT_NEW_BINARY)
+ if (PL_hints & HINT_NEW_BINARY)
sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
}
break;
sv_setiv(sv, tryiv);
else
sv_setnv(sv, value);
- if ( floatit ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) )
+ if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
+ (PL_hints & HINT_NEW_INTEGER) )
sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
- (floatit ? "float" : "integer"), sv, Nullsv, NULL);
+ (floatit ? "float" : "integer"),
+ sv, Nullsv, NULL);
break;
}
where = SvPVX(where_sv);
}
msg = sv_2mortal(newSVpv(s, 0));
+#ifdef IV_IS_QUAD
+ Perl_sv_catpvf(aTHX_ msg, " at %_ line %" PERL_PRId64 ", ",
+ GvSV(PL_curcop->cop_filegv), (IV)PL_curcop->cop_line);
+#else
Perl_sv_catpvf(aTHX_ msg, " at %_ line %ld, ",
- GvSV(PL_curcop->cop_filegv), (long)PL_curcop->cop_line);
+ GvSV(PL_curcop->cop_filegv), (long)PL_curcop->cop_line);
+#endif
if (context)
Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
else
Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
if (PL_multi_start < PL_multi_end && (U32)(PL_curcop->cop_line - PL_multi_end) <= 1) {
- Perl_sv_catpvf(aTHX_ msg,
- " (Might be a runaway multi-line %c%c string starting on line %ld)\n",
- (int)PL_multi_open,(int)PL_multi_close,(long)PL_multi_start);
+#ifdef IV_IS_QUAD
+ Perl_sv_catpvf(aTHX_ msg,
+ " (Might be a runaway multi-line %c%c string starting on line %" PERL_\
+PRId64 ")\n",
+ (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
+#else
+ Perl_sv_catpvf(aTHX_ msg,
+ " (Might be a runaway multi-line %c%c string starting on line %ld)\n",
+ (int)PL_multi_open,(int)PL_multi_close,(long)PL_multi_start);
+#endif
PL_multi_end = 0;
}
if (PL_in_eval & EVAL_WARNONLY)
projects / p5sagit/p5-mst-13.2.git / blobdiff