/*
* 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.
*/
/*#define UTF (SvUTF8(PL_linestr) && !(PL_hints & HINT_BYTE))*/
#define UTF (PL_hints & HINT_UTF8)
-/* 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)))
# define yylval (*yylval_pointer[yyactlevel])
# define yychar (*yychar_pointer[yyactlevel])
# define PERL_YYLEX_PARAM yylval_pointer[yyactlevel],yychar_pointer[yyactlevel]
-# undef yylex
+# undef yylex
# define yylex() Perl_yylex_r(aTHX_ yylval_pointer[yyactlevel],yychar_pointer[yyactlevel])
#endif
return;
if (*s == ' ' || *s == '\t')
s++;
- else
+ else
return;
while (SPACE_OR_TAB(*s)) s++;
if (!isDIGIT(*s))
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;
}
* 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) ||
return retval;
}
-/*
+/*
* S_force_version
* Forces the next token to be a version number.
*/
/* 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);
}
SvUTF8_on(nsv);
SvREFCNT_dec(sv);
sv = nsv;
- }
+ }
yylval.opval = (OP*)newSVOP(op_type, 0, sv);
PL_lex_stuff = Nullsv;
return THING;
} (end switch)
} (end if backslash)
} (end while character to read)
-
+
*/
STATIC char *
dorange = FALSE;
didrange = TRUE;
continue;
- }
+ }
/* range begins (ignore - as first or last char) */
else if (*s == '-' && s+1 < send && s != start) {
- if (didrange) {
+ if (didrange) {
Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
}
if (utf) {
while (count && (c = *regparse)) {
if (c == '\\' && regparse[1])
regparse++;
- else if (c == '{')
+ else if (c == '{')
count++;
- else if (c == '}')
+ else if (c == '}')
count--;
regparse++;
}
default:
{
if (ckWARN(WARN_MISC) && isALNUM(*s))
- Perl_warner(aTHX_ WARN_MISC,
+ Perl_warner(aTHX_ WARN_MISC,
"Unrecognized escape \\%c passed through",
*s);
/* default action is to copy the quoted character */
if (has_utf8 || uv > 255) {
d = (char*)uv_to_utf8((U8*)d, uv);
- this_utf8 = TRUE;
+ has_utf8 = TRUE;
}
else {
*d++ = (char)uv;
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{...}" );
str = SvPV(res,len);
if (!has_utf8 && SvUTF8(res)) {
*d = *s++;
if (isLOWER(*d))
*d = toUPPER(*d);
- *d = toCTRL(*d);
+ *d = toCTRL(*d);
d++;
#else
{
/* 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).
*
av_store(PL_rsfp_filters, 0, datasv) ;
return(datasv);
}
-
+
/* Delete most recently added instance of this filter function. */
void
/* 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) ;
}
}
- /*
+ /*
build the ops for accesses to a my() variable.
Deny my($a) or my($b) in a sort block, *if* $a or $b is
PL_last_lop = 0;
if (PL_lex_brackets)
yyerror("Missing right curly or square bracket");
- DEBUG_T( { PerlIO_printf(Perl_debug_log,
+ DEBUG_T( { PerlIO_printf(Perl_debug_log,
"### Tokener got EOF\n");
} )
TOKEN(0);
PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
PL_doextract = FALSE;
}
- }
+ }
incline(s);
} while (PL_doextract);
PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
case '\r':
#ifdef PERL_STRICT_CR
Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
- Perl_croak(aTHX_
+ Perl_croak(aTHX_
"\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
#endif
case ' ': case '\t': case '\f': case 013:
if (strnEQ(s,"=>",2)) {
s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
- DEBUG_T( { PerlIO_printf(Perl_debug_log,
+ DEBUG_T( { PerlIO_printf(Perl_debug_log,
"### Saw unary minus before =>, forcing word '%s'\n", s);
} )
OPERATOR('-'); /* unary minus */
}
if (ftst) {
PL_last_lop_op = ftst;
- DEBUG_T( { PerlIO_printf(Perl_debug_log,
+ DEBUG_T( { PerlIO_printf(Perl_debug_log,
"### Saw file test %c\n", ftst);
} )
if (*s == '(' && ckWARN(WARN_AMBIGUOUS))
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();
case '0': case '1': case '2': case '3': case '4':
case '5': case '6': case '7': case '8': case '9':
s = scan_num(s, &yylval);
- DEBUG_T( { PerlIO_printf(Perl_debug_log,
+ DEBUG_T( { PerlIO_printf(Perl_debug_log,
"### Saw number in '%s'\n", s);
} )
if (PL_expect == XOPERATOR)
case '\'':
s = scan_str(s,FALSE,FALSE);
- DEBUG_T( { PerlIO_printf(Perl_debug_log,
+ DEBUG_T( { PerlIO_printf(Perl_debug_log,
"### Saw string in '%s'\n", s);
} )
if (PL_expect == XOPERATOR) {
case '"':
s = scan_str(s,FALSE,FALSE);
- DEBUG_T( { PerlIO_printf(Perl_debug_log,
+ DEBUG_T( { PerlIO_printf(Perl_debug_log,
"### Saw string in '%s'\n", s);
} )
if (PL_expect == XOPERATOR) {
case '`':
s = scan_str(s,FALSE,FALSE);
- DEBUG_T( { PerlIO_printf(Perl_debug_log,
+ DEBUG_T( { PerlIO_printf(Perl_debug_log,
"### Saw backtick string in '%s'\n", s);
} )
if (PL_expect == XOPERATOR)
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;
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);
case KEY_pos:
UNI(OP_POS);
-
+
case KEY_pack:
LOP(OP_PACK,XTERM);
case KEY_chomp:
UNI(OP_CHOMP);
-
+
case KEY_scalar:
UNI(OP_SCALAR);
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);
}
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:
SV **cvp;
SV *cv, *typesv;
const char *why1, *why2, *why3;
-
+
if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
SV *msg;
why2 = strEQ(key,"charnames")
? "(possibly a missing \"use charnames ...\")"
: "";
- msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s",
+ msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s",
(type ? type: "undef"), why2);
/* This is convoluted and evil ("goto considered harmful")
goto msgdone;
report:
- msg = Perl_newSVpvf(aTHX_ "Constant(%s): %s%s%s",
+ msg = Perl_newSVpvf(aTHX_ "Constant(%s): %s%s%s",
(type ? type: "undef"), why1, why2, why3);
msgdone:
yyerror(SvPVX(msg));
typesv = sv_2mortal(newSVpv(type, 0));
else
typesv = &PL_sv_undef;
-
+
PUSHSTACKi(PERLSI_OVERLOAD);
ENTER ;
SAVETMPS;
-
+
PUSHMARK(SP) ;
EXTEND(sp, 3);
if (pv)
PUSHs(typesv);
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)) {
why1 = "Call to &{$^H{";
why2 = key;
return res;
}
-
+
STATIC char *
S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
{
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))
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
/* having changed the buffer, we must update PL_bufend */
PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
}
-
+
/* at this point, we have successfully read the delimited string */
if (keep_delims)
/* 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, YYSTYPE* lvalp)
{
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':
/* 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 == '_') {
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.
+ 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)
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
*/
{
#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;
STRLEN slen;
slen = SvCUR(PL_linestr);
switch (*s) {
- case 0xFF:
- if (s[1] == 0xFE) {
+ 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");
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);
}
projects / p5sagit/p5-mst-13.2.git / commitdiff