ch = *t;
*t = '\0';
if (t - s > 0) {
+#ifndef USE_ITHREADS
+ const char *cf = CopFILE(PL_curcop);
+ if (cf && strlen(cf) > 7 && strnEQ(cf, "(eval ", 6)) {
+ /* must copy *{"::_<(eval N)[oldfilename:L]"}
+ * to *{"::_<newfilename"} */
+ char smallbuf[256], smallbuf2[256];
+ char *tmpbuf, *tmpbuf2;
+ GV **gvp, *gv2;
+ STRLEN tmplen = strlen(cf);
+ STRLEN tmplen2 = strlen(s);
+ if (tmplen + 3 < sizeof smallbuf)
+ tmpbuf = smallbuf;
+ else
+ Newx(tmpbuf, tmplen + 3, char);
+ if (tmplen2 + 3 < sizeof smallbuf2)
+ tmpbuf2 = smallbuf2;
+ else
+ Newx(tmpbuf2, tmplen2 + 3, char);
+ tmpbuf[0] = tmpbuf2[0] = '_';
+ tmpbuf[1] = tmpbuf2[1] = '<';
+ memcpy(tmpbuf + 2, cf, ++tmplen);
+ memcpy(tmpbuf2 + 2, s, ++tmplen2);
+ ++tmplen; ++tmplen2;
+ gvp = (GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, FALSE);
+ if (gvp) {
+ gv2 = *(GV**)hv_fetch(PL_defstash, tmpbuf2, tmplen2, TRUE);
+ if (!isGV(gv2))
+ gv_init(gv2, PL_defstash, tmpbuf2, tmplen2, FALSE);
+ /* adjust ${"::_<newfilename"} to store the new file name */
+ GvSV(gv2) = newSVpvn(tmpbuf2 + 2, tmplen2 - 2);
+ GvHV(gv2) = (HV*)SvREFCNT_inc(GvHV(*gvp));
+ GvAV(gv2) = (AV*)SvREFCNT_inc(GvAV(*gvp));
+ }
+ if (tmpbuf != smallbuf) Safefree(tmpbuf);
+ if (tmpbuf2 != smallbuf2) Safefree(tmpbuf2);
+ }
+#endif
CopFILE_free(PL_curcop);
CopFILE_set(PL_curcop, s);
}
I32 has_utf8 = FALSE; /* Output constant is UTF8 */
I32 this_utf8 = UTF; /* The source string is assumed to be UTF8 */
UV uv;
+#ifdef EBCDIC
+ UV literal_endpoint = 0;
+#endif
const char *leaveit = /* set of acceptably-backslashed characters */
PL_lex_inpat
}
#ifdef EBCDIC
- if ((isLOWER(min) && isLOWER(max)) ||
- (isUPPER(min) && isUPPER(max))) {
+ if (literal_endpoint == 2 &&
+ ((isLOWER(min) && isLOWER(max)) ||
+ (isUPPER(min) && isUPPER(max)))) {
if (isLOWER(min)) {
for (i = min; i <= max; i++)
if (isLOWER(i))
/* mark the range as done, and continue */
dorange = FALSE;
didrange = TRUE;
+#ifdef EBCDIC
+ literal_endpoint = 0;
+#endif
continue;
}
}
else {
didrange = FALSE;
+#ifdef EBCDIC
+ literal_endpoint = 0;
+#endif
}
}
/* FALL THROUGH */
default:
{
- if (ckWARN(WARN_MISC) &&
- isALNUM(*s) &&
- *s != '_')
+ if (isALNUM(*s) &&
+ *s != '_' &&
+ ckWARN(WARN_MISC))
Perl_warner(aTHX_ packWARN(WARN_MISC),
"Unrecognized escape \\%c passed through",
*s);
s++;
continue;
} /* end if (backslash) */
+#ifdef EBCDIC
+ else
+ literal_endpoint++;
+#endif
default_action:
/* If we started with encoded form, or already know we want it
return gv_stashpv(pkgname, FALSE);
}
+STATIC char *
+S_tokenize_use(pTHX_ int is_use, char *s) {
+ if (PL_expect != XSTATE)
+ yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression",
+ is_use ? "use" : "no"));
+ s = skipspace(s);
+ if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
+ s = force_version(s, TRUE);
+ if (*s == ';' || (s = skipspace(s), *s == ';')) {
+ PL_nextval[PL_nexttoke].opval = Nullop;
+ force_next(WORD);
+ }
+ else if (*s == 'v') {
+ s = force_word(s,WORD,FALSE,TRUE,FALSE);
+ s = force_version(s, FALSE);
+ }
+ }
+ else {
+ s = force_word(s,WORD,FALSE,TRUE,FALSE);
+ s = force_version(s, FALSE);
+ }
+ yylval.ival = is_use;
+ return s;
+}
#ifdef DEBUGGING
static const char* const exp_name[] =
{ "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
AOPERATOR(ANDAND);
s--;
if (PL_expect == XOPERATOR) {
- if (ckWARN(WARN_SEMICOLON)
- && isIDFIRST_lazy_if(s,UTF) && PL_bufptr == PL_linestart)
+ if (PL_bufptr == PL_linestart && ckWARN(WARN_SEMICOLON)
+ && isIDFIRST_lazy_if(s,UTF))
{
CopLINE_dec(PL_curcop);
Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
OPERATOR(',');
if (tmp == '~')
PMop(OP_MATCH);
- if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
+ if (tmp && isSPACE(*s) && ckWARN(WARN_SYNTAX) && strchr("+-*/%.^&|<",tmp))
Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Reversed %c= operator",(int)tmp);
s--;
if (PL_expect == XSTATE && isALPHA(tmp) &&
else if (*s == '{') {
char *t;
PL_tokenbuf[0] = '%';
- if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
- (t = strchr(s, '}')) && (t = strchr(t, '=')))
+ if (strEQ(PL_tokenbuf+1, "SIG") && ckWARN(WARN_SYNTAX)
+ && (t = strchr(s, '}')) && (t = strchr(t, '=')))
{
char tmpbuf[sizeof PL_tokenbuf];
for (t++; isSPACE(*t); t++) ;
PL_tokenbuf[0] = '%';
/* Warn about @ where they meant $. */
- if (ckWARN(WARN_SYNTAX)) {
- if (*s == '[' || *s == '{') {
+ if (*s == '[' || *s == '{') {
+ if (ckWARN(WARN_SYNTAX)) {
const char *t = s + 1;
while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
t++;
case '\\':
s++;
- if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
+ if (PL_lex_inwhat && isDIGIT(*s) && ckWARN(WARN_SYNTAX))
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
*s, *s);
if (PL_expect == XOPERATOR)
}
gv = Nullgv;
gvp = 0;
- if (ckWARN(WARN_AMBIGUOUS) && hgv
- && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
+ if (hgv && tmp != KEY_x && tmp != KEY_CORE
+ && ckWARN(WARN_AMBIGUOUS)) /* never ambiguous */
Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
"Ambiguous call resolved as CORE::%s(), %s",
GvENAME(hgv), "qualify as such or use &");
yylval.opval->op_private |= OPpCONST_STRICT;
else {
bareword:
- if (ckWARN(WARN_RESERVED)) {
- if (lastchar != '-') {
+ if (lastchar != '-') {
+ if (ckWARN(WARN_RESERVED)) {
for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
if (!*d && !gv_stashpv(PL_tokenbuf,FALSE))
Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf);
if (tmp < 0)
tmp = -tmp;
+ else if (tmp == KEY_require)
+ /* that's a way to remember we saw "CORE::" */
+ orig_keyword = KEY_require;
goto reserved_word;
}
goto just_a_word;
Eop(OP_SNE);
case KEY_no:
- if (PL_expect != XSTATE)
- yyerror("\"no\" not allowed in expression");
- s = force_word(s,WORD,FALSE,TRUE,FALSE);
- s = force_version(s, FALSE);
- yylval.ival = 0;
+ s = tokenize_use(0, s);
OPERATOR(USE);
case KEY_not:
else if (*s == '<')
yyerror("<> should be quotes");
}
- UNI(OP_REQUIRE);
+ if (orig_keyword == KEY_require) {
+ orig_keyword = 0;
+ yylval.ival = 1;
+ }
+ else
+ yylval.ival = 0;
+ PL_expect = XTERM;
+ PL_bufptr = s;
+ PL_last_uni = PL_oldbufptr;
+ PL_last_lop_op = OP_REQUIRE;
+ s = skipspace(s);
+ return REPORT( (int)REQUIRE );
case KEY_reset:
UNI(OP_RESET);
LOP(OP_UNSHIFT,XTERM);
case KEY_use:
- if (PL_expect != XSTATE)
- yyerror("\"use\" not allowed in expression");
- s = skipspace(s);
- if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
- s = force_version(s, TRUE);
- if (*s == ';' || (s = skipspace(s), *s == ';')) {
- PL_nextval[PL_nexttoke].opval = Nullop;
- force_next(WORD);
- }
- else if (*s == 'v') {
- s = force_word(s,WORD,FALSE,TRUE,FALSE);
- s = force_version(s, FALSE);
- }
- }
- else {
- s = force_word(s,WORD,FALSE,TRUE,FALSE);
- s = force_version(s, FALSE);
- }
- yylval.ival = 1;
+ s = tokenize_use(1, s);
OPERATOR(USE);
case KEY_values:
const char *type)
{
dVAR; dSP;
- HV *table = GvHV(PL_hintgv); /* ^H */
+ HV * const table = GvHV(PL_hintgv); /* ^H */
SV *res;
SV **cvp;
SV *cv, *typesv;
S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
{
register char *d = dest;
- register char *e = d + destlen - 3; /* two-character token, ending NUL */
+ register char * const e = d + destlen - 3; /* two-character token, ending NUL */
for (;;) {
if (d >= e)
Perl_croak(aTHX_ ident_too_long);
{
register char *d;
register char *e;
- char *bracket = 0;
+ char *bracket = Nullch;
char funny = *s++;
if (isSPACE(*s))
char *s = scan_str(start,FALSE,FALSE);
if (!s) {
- char *delimiter = skipspace(start);
+ char * const delimiter = skipspace(start);
Perl_croak(aTHX_ *delimiter == '?'
? "Search pattern not terminated or ternary operator parsed as search pattern"
: "Search pattern not terminated" );
pmflag(&pm->op_pmflags,*s++);
}
/* issue a warning if /c is specified,but /g is not */
- if (ckWARN(WARN_REGEXP) &&
- (pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL))
+ if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL)
+ && ckWARN(WARN_REGEXP))
{
Perl_warner(aTHX_ packWARN(WARN_REGEXP), c_without_g);
}
}
/* /c is not meaningful with s/// */
- if (ckWARN(WARN_REGEXP) && (pm->op_pmflags & PMf_CONTINUE))
+ if ((pm->op_pmflags & PMf_CONTINUE) && ckWARN(WARN_REGEXP))
{
Perl_warner(aTHX_ packWARN(WARN_REGEXP), c_in_subst);
}
/* _ are ignored -- but warned about if consecutive */
case '_':
- if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1)
+ if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
"Misplaced _ in number");
lastub = s++;
sv = NEWSV(92,0);
if (overflowed) {
- if (ckWARN(WARN_PORTABLE) && n > 4294967295.0)
+ if (n > 4294967295.0 && ckWARN(WARN_PORTABLE))
Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
"%s number > %s non-portable",
Base, max);
}
else {
#if UVSIZE > 4
- if (ckWARN(WARN_PORTABLE) && u > 0xffffffff)
+ if (u > 0xffffffff && ckWARN(WARN_PORTABLE))
Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
"%s number > %s non-portable",
Base, max);
if -w is on
*/
if (*s == '_') {
- if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1)
+ if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
"Misplaced _ in number");
lastub = s++;
if (d >= e)
Perl_croak(aTHX_ number_too_long);
if (*s == '_') {
- if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1)
+ if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
"Misplaced _ in number");
lastub = s;
*d++ = *s++;
}
else {
- if (ckWARN(WARN_SYNTAX) &&
- ((lastub && s == lastub + 1) ||
- (!isDIGIT(s[1]) && s[1] != '_')))
+ if (((lastub && s == lastub + 1) ||
+ (!isDIGIT(s[1]) && s[1] != '_'))
+ && ckWARN(WARN_SYNTAX))
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
"Misplaced _ in number");
lastub = s++;
projects / p5sagit/p5-mst-13.2.git / blobdiff