#define PL_pending_ident (PL_parser->pending_ident)
#define PL_preambled (PL_parser->preambled)
#define PL_sublex_info (PL_parser->sublex_info)
+#define PL_linestr (PL_parser->linestr)
+#define PL_expect (PL_parser->expect)
+#define PL_copline (PL_parser->copline)
+#define PL_bufptr (PL_parser->bufptr)
+#define PL_oldbufptr (PL_parser->oldbufptr)
+#define PL_oldoldbufptr (PL_parser->oldoldbufptr)
+#define PL_linestart (PL_parser->linestart)
+#define PL_bufend (PL_parser->bufend)
+#define PL_last_uni (PL_parser->last_uni)
+#define PL_last_lop (PL_parser->last_lop)
+#define PL_last_lop_op (PL_parser->last_lop_op)
+#define PL_lex_state (PL_parser->lex_state)
+#define PL_rsfp (PL_parser->rsfp)
+#define PL_rsfp_filters (PL_parser->rsfp_filters)
+#define PL_in_my (PL_parser->in_my)
+#define PL_in_my_stash (PL_parser->in_my_stash)
+#define PL_tokenbuf (PL_parser->tokenbuf)
+#define PL_multi_end (PL_parser->multi_end)
+#define PL_error_count (PL_parser->error_count)
#ifdef PERL_MAD
# define PL_endwhite (PL_parser->endwhite)
# define PL_thisstuff (PL_parser->thisstuff)
# define PL_thistoken (PL_parser->thistoken)
# define PL_thiswhite (PL_parser->thiswhite)
+# define PL_thiswhite (PL_parser->thiswhite)
+# define PL_nexttoke (PL_parser->nexttoke)
+# define PL_curforce (PL_parser->curforce)
+#else
+# define PL_nexttoke (PL_parser->nexttoke)
+# define PL_nexttype (PL_parser->nexttype)
+# define PL_nextval (PL_parser->nextval)
#endif
static int
static const char ident_too_long[] = "Identifier too long";
static const char commaless_variable_list[] = "comma-less variable list";
-static void restore_rsfp(pTHX_ void *f);
#ifndef PERL_NO_UTF16_FILTER
static I32 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen);
static I32 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen);
/*
* Perl_lex_start
- * Initialize variables. Uses the Perl save_stack to save its state (for
- * recursive calls to the parser).
+ *
+ * Create a parser object and initialise its parser and lexer fields
+ *
+ * rsfp is the opened file handle to read from (if any),
+ *
+ * line holds any initial content already read from the file (or in
+ * the case of no file, such as an eval, the whole contents);
+ *
+ * new_filter indicates that this is a new file and it shouldn't inherit
+ * the filters from the current parser (ie require).
*/
void
-Perl_lex_start(pTHX_ SV *line)
+Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, bool new_filter)
{
dVAR;
const char *s = NULL;
STRLEN len;
- yy_parser *parser;
+ yy_parser *parser, *oparser;
/* create and initialise a parser */
Newxz(parser, 1, yy_parser);
- parser->old_parser = PL_parser;
+ parser->old_parser = oparser = PL_parser;
PL_parser = parser;
Newx(parser->stack, YYINITDEPTH, yy_stack_frame);
parser->yyerrstatus = 0;
parser->yychar = YYEMPTY; /* Cause a token to be read. */
+ /* on scope exit, free this parser and restore any outer one */
+ SAVEPARSER(parser);
+ parser->saved_curcop = PL_curcop;
+
/* initialise lexer state */
- SAVEI32(PL_lex_state);
#ifdef PERL_MAD
- if (PL_lex_state == LEX_KNOWNEXT) {
- I32 toke = parser->old_parser->lasttoke;
- while (--toke >= 0) {
- SAVEI32(PL_nexttoke[toke].next_type);
- SAVEVPTR(PL_nexttoke[toke].next_val);
- if (PL_madskills)
- SAVEVPTR(PL_nexttoke[toke].next_mad);
- }
- }
- SAVEI32(PL_curforce);
+ parser->curforce = -1;
#else
- if (PL_lex_state == LEX_KNOWNEXT) {
- I32 toke = PL_nexttoke;
- while (--toke >= 0) {
- SAVEI32(PL_nexttype[toke]);
- SAVEVPTR(PL_nextval[toke]);
- }
- SAVEI32(PL_nexttoke);
- }
+ parser->nexttoke = 0;
#endif
- 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);
- SAVEDESTRUCTOR_X(restore_rsfp, PL_rsfp);
- SAVEINT(PL_expect);
+ parser->copline = NOLINE;
+ parser->lex_state = LEX_NORMAL;
+ parser->expect = XSTATE;
+ parser->rsfp = rsfp;
+ parser->rsfp_filters = (new_filter || !oparser) ? newAV()
+ : (AV*)SvREFCNT_inc(oparser->rsfp_filters);
- PL_lex_state = LEX_NORMAL;
- PL_expect = XSTATE;
Newx(parser->lex_brackstack, 120, char);
Newx(parser->lex_casestack, 12, char);
*parser->lex_casestack = '\0';
-#ifndef PERL_MAD
- PL_nexttoke = 0;
-#endif
if (line) {
s = SvPV_const(line, len);
} else {
len = 0;
}
+
if (!len) {
- PL_linestr = newSVpvs("\n;");
+ parser->linestr = newSVpvs("\n;");
} else if (SvREADONLY(line) || s[len-1] != ';') {
- PL_linestr = newSVsv(line);
+ parser->linestr = newSVsv(line);
if (s[len-1] != ';')
- sv_catpvs(PL_linestr, "\n;");
+ sv_catpvs(parser->linestr, "\n;");
} else {
SvTEMP_off(line);
SvREFCNT_inc_simple_void_NN(line);
- PL_linestr = line;
- }
- /* PL_linestr needs to survive until end of scope, not just the next
- FREETMPS. See changes 17505 and 17546 which fixed the symptoms only. */
- SAVEFREESV(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 = NULL;
- PL_rsfp = 0;
+ parser->linestr = line;
+ }
+ parser->oldoldbufptr =
+ parser->oldbufptr =
+ parser->bufptr =
+ parser->linestart = SvPVX(parser->linestr);
+ parser->bufend = parser->bufptr + SvCUR(parser->linestr);
+ parser->last_lop = parser->last_uni = NULL;
+}
+
+
+/* delete a parser object */
+
+void
+Perl_parser_free(pTHX_ const yy_parser *parser)
+{
+ PL_curcop = parser->saved_curcop;
+ SvREFCNT_dec(parser->linestr);
+
+ if (parser->rsfp == PerlIO_stdin())
+ PerlIO_clearerr(parser->rsfp);
+ else if (parser->rsfp && parser->old_parser
+ && parser->rsfp != parser->old_parser->rsfp)
+ PerlIO_close(parser->rsfp);
+ SvREFCNT_dec(parser->rsfp_filters);
+
+ Safefree(parser->stack);
+ Safefree(parser->lex_brackstack);
+ Safefree(parser->lex_casestack);
+ PL_parser = parser->old_parser;
+ Safefree(parser);
}
+
/*
* Perl_lex_end
* Finalizer for lexing operations. Must be called when the parser is
*/
STATIC void
-S_incline(pTHX_ char *s)
+S_incline(pTHX_ const char *s)
{
dVAR;
- char *t;
- char *n;
- char *e;
- char ch;
+ const char *t;
+ const char *n;
+ const char *e;
CopLINE_inc(PL_curcop);
if (*s++ != '#')
if (*e != '\n' && *e != '\0')
return; /* false alarm */
- ch = *t;
- *t = '\0';
if (t - s > 0) {
+ const STRLEN len = t - s;
#ifndef USE_ITHREADS
const char * const cf = CopFILE(PL_curcop);
STRLEN tmplen = cf ? strlen(cf) : 0;
if (tmplen > 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 tmplen2 = strlen(s);
- if (tmplen + 3 < sizeof smallbuf)
+ /* However, the long form of evals is only turned on by the
+ debugger - usually they're "(eval %lu)" */
+ char smallbuf[128];
+ char *tmpbuf;
+ GV **gvp;
+ STRLEN tmplen2 = len;
+ if (tmplen + 2 <= 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;
+ Newx(tmpbuf, tmplen + 2, char);
+ tmpbuf[0] = '_';
+ tmpbuf[1] = '<';
+ memcpy(tmpbuf + 2, cf, tmplen);
+ tmplen += 2;
gvp = (GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, FALSE);
if (gvp) {
+ char *tmpbuf2;
+ GV *gv2;
+
+ if (tmplen2 + 2 <= sizeof smallbuf)
+ tmpbuf2 = smallbuf;
+ else
+ Newx(tmpbuf2, tmplen2 + 2, char);
+
+ if (tmpbuf2 != smallbuf || tmpbuf != smallbuf) {
+ /* Either they malloc'd it, or we malloc'd it,
+ so no prefix is present in ours. */
+ tmpbuf2[0] = '_';
+ tmpbuf2[1] = '<';
+ }
+
+ memcpy(tmpbuf2 + 2, s, tmplen2);
+ tmplen2 += 2;
+
gv2 = *(GV**)hv_fetch(PL_defstash, tmpbuf2, tmplen2, TRUE);
if (!isGV(gv2)) {
gv_init(gv2, PL_defstash, tmpbuf2, tmplen2, FALSE);
GvHV(gv2) = (HV*)SvREFCNT_inc(GvHV(*gvp));
GvAV(gv2) = (AV*)SvREFCNT_inc(GvAV(*gvp));
}
+
+ if (tmpbuf2 != smallbuf) Safefree(tmpbuf2);
}
if (tmpbuf != smallbuf) Safefree(tmpbuf);
- if (tmpbuf2 != smallbuf2) Safefree(tmpbuf2);
}
#endif
CopFILE_free(PL_curcop);
- CopFILE_set(PL_curcop, s);
+ CopFILE_setn(PL_curcop, s, len);
}
- *t = ch;
CopLINE_set(PL_curcop, atoi(n)-1);
}
{
AV *av = CopFILEAVx(PL_curcop);
if (av) {
- SV * const sv = newSV(0);
- sv_upgrade(sv, SVt_PVMG);
+ SV * const sv = newSV_type(SVt_PVMG);
if (orig_sv)
sv_setsv(sv, orig_sv);
else
/* XXX these shouldn't really be added here, can't set PL_faketokens */
if (PL_minus_p) {
#ifdef PERL_MAD
- sv_catpv(PL_linestr,
+ sv_catpvs(PL_linestr,
";}continue{print or die qq(-p destination: $!\\n);}");
#else
- sv_setpv(PL_linestr,
+ sv_setpvs(PL_linestr,
";}continue{print or die qq(-p destination: $!\\n);}");
#endif
PL_minus_n = PL_minus_p = 0;
/* keep a slot open for the head of the list? */
if (slot != '_' && *where && (*where)->mad_key == '^') {
(*where)->mad_key = slot;
- sv_free((*where)->mad_val);
+ sv_free((SV*)((*where)->mad_val));
(*where)->mad_val = (void*)sv;
}
else
PL_expect = XOPERATOR;
}
}
+ if (PL_madskills)
+ curmad('g', newSVpvs( "forced" ));
NEXTVAL_NEXTTOKE.opval
= (OP*)newSVOP(OP_CONST,0,
S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
}
PL_sublex_info.super_state = PL_lex_state;
- PL_sublex_info.sub_inwhat = op_type;
+ PL_sublex_info.sub_inwhat = (U16)op_type;
PL_sublex_info.sub_op = PL_lex_op;
PL_lex_state = LEX_INTERPPUSH;
ENTER;
PL_lex_state = PL_sublex_info.super_state;
- SAVEI32(PL_lex_dojoin);
+ SAVEBOOL(PL_lex_dojoin);
SAVEI32(PL_lex_brackets);
SAVEI32(PL_lex_casemods);
SAVEI32(PL_lex_starts);
- SAVEI32(PL_lex_state);
+ SAVEI8(PL_lex_state);
SAVEVPTR(PL_lex_inpat);
- SAVEI32(PL_lex_inwhat);
+ SAVEI16(PL_lex_inwhat);
SAVECOPLINE(PL_curcop);
SAVEPPTR(PL_bufptr);
SAVEPPTR(PL_bufend);
*d++ = NATIVE_TO_NEED(has_utf8,*s++);
}
else if (s[2] == '{' /* This should match regcomp.c */
- || ((s[2] == 'p' || s[2] == '?') && s[3] == '{'))
+ || (s[2] == '?' && s[3] == '{'))
{
I32 count = 1;
char *regparse = s + (s[2] == '{' ? 3 : 4);
*/
if (*start == '$') {
- if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
+ if (gv || PL_last_lop_op == OP_PRINT || PL_last_lop_op == OP_SAY ||
+ isUPPER(*PL_tokenbuf))
return 0;
#ifdef PERL_MAD
len = start - SvPVX(PL_linestr);
if (indirgv && GvCVu(indirgv))
return 0;
/* filehandle or package name makes it a method */
- if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
+ if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, 0)) {
#ifdef PERL_MAD
soff = s - SvPVX(PL_linestr);
#endif
if (!funcp)
return NULL;
+ if (!PL_parser)
+ return NULL;
+
if (!PL_rsfp_filters)
PL_rsfp_filters = newAV();
if (!datasv)
DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p",
FPTR2DPTR(void*, funcp)));
#endif
- if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
+ if (!PL_parser || !PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
return;
/* if filter is on top of stack (usual case) just pop it off */
datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
#endif
: maxlen;
- if (!PL_rsfp_filters)
+ if (!PL_parser || !PL_rsfp_filters)
return -1;
if (idx > AvFILLp(PL_rsfp_filters)) { /* Any more filters? */
/* Provide a default input filter to make life easy. */
pkgname = SvPV_nolen_const(sv);
}
- return gv_stashpv(pkgname, FALSE);
+ return gv_stashpv(pkgname, 0);
}
/*
&& GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe))
||
((gvp = (GV**)hv_fetchs(PL_globalstash, "readpipe", FALSE))
- && (gv_readpipe = *gvp) != (GV*)&PL_sv_undef
+ && (gv_readpipe = *gvp) && isGV_with_GP(gv_readpipe)
&& GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe)))
{
PL_lex_op = (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
#endif
#ifdef PERL_MAD
PL_realtokenstart = -1;
- s = SKIPSPACE0(s);
-#else
- s++;
+ if (!PL_thiswhite)
+ PL_thiswhite = newSVpvs("");
+ sv_catpvn(PL_thiswhite, s, 1);
#endif
+ s++;
goto retry;
case '#':
case '\n':
Mop(OP_MODULO);
}
PL_tokenbuf[0] = '%';
- s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
+ s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
+ sizeof PL_tokenbuf - 1, FALSE);
if (!PL_tokenbuf[1]) {
PREREF('%');
}
/* FALL THROUGH */
case '~':
if (s[1] == '~'
- && (PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR)
- && FEATURE_IS_ENABLED("~~"))
+ && (PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR))
{
s += 2;
Eop(OP_SMARTMATCH);
sv_free(sv);
CvMETHOD_on(PL_compcv);
}
- else if (!PL_in_my && len == 9 && strnEQ(SvPVX(sv), "assertion", len)) {
- sv_free(sv);
- CvASSERTION_on(PL_compcv);
- }
/* 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
--PL_lex_brackets;
if (PL_lex_state == LEX_INTERPNORMAL) {
if (PL_lex_brackets == 0) {
- if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
+ if (*s == '-' && s[1] == '>')
+ PL_lex_state = LEX_INTERPENDMAYBE;
+ else if (*s != '[' && *s != '{')
PL_lex_state = LEX_INTERPEND;
}
}
t++;
} while (isSPACE(*t));
if (isIDFIRST_lazy_if(t,UTF)) {
- STRLEN dummylen;
+ STRLEN len;
t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE,
- &dummylen);
+ &len);
while (isSPACE(*t))
t++;
- if (*t == ';' && get_cv(tmpbuf, FALSE))
+ if (*t == ';' && get_cvn_flags(tmpbuf, len, 0))
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
"You need to quote \"%s\"",
tmpbuf);
}
if (!ogv &&
(gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
- (gv = *gvp) != (GV*)&PL_sv_undef &&
+ (gv = *gvp) && isGV_with_GP(gv) &&
GvCVu(gv) && GvIMPORTED_CV(gv))
{
ogv = gv;
}
else if (gv && !gvp
&& -tmp==KEY_lock /* XXX generalizable kludge */
- && GvCVu(gv)
- && !hv_fetchs(GvHVn(PL_incgv), "Thread.pm", FALSE))
+ && GvCVu(gv))
{
tmp = 0; /* any sub overrides "weak" keyword */
}
PL_nextwhite = 0;
}
}
+ else
#endif
- goto its_constant;
+ goto its_constant;
}
}
#ifdef PERL_MAD
"Ambiguous use of -%s resolved as -&%s()",
PL_tokenbuf, PL_tokenbuf);
/* Check for a constant sub */
- if ((sv = gv_const_sv(gv))) {
+ if ((sv = gv_const_sv(gv)) && !PL_madskills) {
its_constant:
SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc_simple(sv);
}
}
if (probable_sub) {
- gv = gv_fetchpv(PL_tokenbuf, TRUE, SVt_PVCV);
+ gv = gv_fetchpv(PL_tokenbuf, GV_ADD, SVt_PVCV);
op_free(yylval.opval);
yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
d = PL_tokenbuf;
while (isLOWER(*d))
d++;
- if (!*d && !gv_stashpv(PL_tokenbuf,FALSE))
+ if (!*d && !gv_stashpv(PL_tokenbuf, 0))
Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
PL_tokenbuf);
}
case KEY_our:
case KEY_my:
case KEY_state:
- PL_in_my = tmp;
+ PL_in_my = (U16)tmp;
s = SKIPSPACE1(s);
if (isIDFIRST_lazy_if(s,UTF)) {
#ifdef PERL_MAD
*PL_tokenbuf = '\0';
s = force_word(s,WORD,TRUE,TRUE,FALSE);
if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
- gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
+ gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), GV_ADD);
else if (*s == '<')
yyerror("<> should be quotes");
}
case KEY_readpipe:
set_csh();
- UNI(OP_BACKTICK);
+ UNIDOR(OP_BACKTICK);
case KEY_rewinddir:
UNI(OP_REWINDDIR);
if (PL_madskills)
nametoke = newSVpvn(s, d - s);
#endif
- if (strchr(tmpbuf, ':'))
- sv_setpv(PL_subname, tmpbuf);
+ if (memchr(tmpbuf, ':', len))
+ sv_setpvn(PL_subname, tmpbuf, len);
else {
sv_setsv(PL_subname,PL_curstname);
sv_catpvs(PL_subname,"::");
if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
GV *gv = gv_fetchpv(PL_tokenbuf+1, 0, SVt_PVAV);
if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
- && ckWARN(WARN_AMBIGUOUS))
+ && ckWARN(WARN_AMBIGUOUS)
+ /* DO NOT warn for @- and @+ */
+ && !( PL_tokenbuf[2] == '\0' &&
+ ( PL_tokenbuf[1] == '-' || PL_tokenbuf[1] == '+' ))
+ )
{
/* Downgraded from fatal to warning 20000522 mjd */
Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
}
while (isSPACE(*w))
++w;
- if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
+ /* the list of chars below is for end of statements or
+ * block / parens, boolean operators (&&, ||, //) and branch
+ * constructs (or, and, if, until, unless, while, err, for).
+ * Not a very solid hack... */
+ if (!*w || !strchr(";&/|})]oaiuwef!=", *w))
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
"%s (...) interpreted as function",name);
}
}
if (PL_lex_state == LEX_NORMAL) {
if (ckWARN(WARN_AMBIGUOUS) &&
- (keyword(dest, d - dest, 0) || get_cv(dest, FALSE)))
+ (keyword(dest, d - dest, 0)
+ || get_cvn_flags(dest, d - dest, 0)))
{
if (funny == '#')
funny = '@';
Perl_pmflag(pTHX_ U32* pmfl, int ch)
{
PERL_UNUSED_CONTEXT;
- if (ch == 'i')
- *pmfl |= PMf_FOLD;
- else if (ch == 'g')
- *pmfl |= PMf_GLOBAL;
- else if (ch == 'c')
- *pmfl |= PMf_CONTINUE;
- else if (ch == 'o')
- *pmfl |= PMf_KEEP;
- else if (ch == 'm')
- *pmfl |= PMf_MULTILINE;
- else if (ch == 's')
- *pmfl |= PMf_SINGLELINE;
- else if (ch == 'x')
- *pmfl |= PMf_EXTENDED;
+ if (ch<256) {
+ char c = (char)ch;
+ switch (c) {
+ CASE_STD_PMMOD_FLAGS_PARSE_SET(pmfl);
+ case GLOBAL_PAT_MOD: *pmfl |= PMf_GLOBAL; break;
+ case CONTINUE_PAT_MOD: *pmfl |= PMf_CONTINUE; break;
+ case ONCE_PAT_MOD: *pmfl |= PMf_KEEP; break;
+ case KEEPCOPY_PAT_MOD: *pmfl |= PMf_KEEPCOPY; break;
+ }
+ }
}
STATIC char *
PMOP *pm;
char *s = scan_str(start,!!PL_madskills,FALSE);
const char * const valid_flags =
- (const char *)((type == OP_QR) ? "iomsx" : "iogcmsx");
+ (const char *)((type == OP_QR) ? QR_PAT_MODS : M_PAT_MODS);
#ifdef PERL_MAD
char *modstart;
#endif
}
pm = (PMOP*)newPMOP(type, 0);
- if (PL_multi_open == '?')
+ if (PL_multi_open == '?') {
+ /* This is the only point in the code that sets PMf_ONCE: */
pm->op_pmflags |= PMf_ONCE;
+
+ /* Hence it's safe to do this bit of PMOP book-keeping here, which
+ allows us to restrict the list needed by reset to just the ??
+ matches. */
+ assert(type != OP_TRANS);
+ if (PL_curstash) {
+ MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab);
+ U32 elements;
+ if (!mg) {
+ mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0,
+ 0);
+ }
+ elements = mg->mg_len / sizeof(PMOP**);
+ Renewc(mg->mg_ptr, elements + 1, PMOP*, char);
+ ((PMOP**)mg->mg_ptr) [elements++] = pm;
+ mg->mg_len = elements * sizeof(PMOP**);
+ PmopSTASH_set(pm,PL_curstash);
+ }
+ }
#ifdef PERL_MAD
modstart = s;
#endif
if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL)
&& ckWARN(WARN_REGEXP))
{
- Perl_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless without /g" );
+ Perl_warner(aTHX_ packWARN(WARN_REGEXP),
+ "Use of /c modifier is meaningless without /g" );
}
- pm->op_pmpermflags = pm->op_pmflags;
-
PL_lex_op = (OP*)pm;
yylval.ival = OP_MATCH;
return s;
#endif
while (*s) {
- if (*s == 'e') {
+ if (*s == EXEC_PAT_MOD) {
s++;
es++;
}
- else if (strchr("iogcmsx", *s))
+ else if (strchr(S_PAT_MODS, *s))
pmflag(&pm->op_pmflags,*s++);
else
break;
PL_lex_repl = repl;
}
- pm->op_pmpermflags = pm->op_pmflags;
PL_lex_op = (OP*)pm;
yylval.ival = OP_SUBST;
return s;
}
no_more:
- tbl = PerlMemShared_calloc(complement&&!del?258:256, sizeof(short));
+ tbl = (short *)PerlMemShared_calloc(complement&&!del?258:256, sizeof(short));
o = newPVOP(OP_TRANS, 0, (char*)tbl);
o->op_private &= ~OPpTRANS_ALL;
o->op_private |= del|squash|complement|
s--;
#endif
- tmpstr = newSV(79);
- sv_upgrade(tmpstr, SVt_PVIV);
+ tmpstr = newSV_type(SVt_PVIV);
+ SvGROW(tmpstr, 80);
if (term == '\'') {
op_type = OP_CONST;
SvIV_set(tmpstr, -1);
&& GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline))
||
((gvp = (GV**)hv_fetchs(PL_globalstash, "readline", FALSE))
- && (gv_readline = *gvp) != (GV*)&PL_sv_undef
+ && (gv_readline = *gvp) && isGV_with_GP(gv_readline)
&& GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline)))
readline_overriden = TRUE;
/* create a new SV to hold the contents. 79 is the SV's initial length.
What a random number. */
- sv = newSV(79);
- sv_upgrade(sv, SVt_PVIV);
+ sv = newSV_type(SVt_PVIV);
+ SvGROW(sv, 80);
SvIV_set(sv, termcode);
(void)SvPOK_only(sv); /* validate pointer */
case 'v':
vstring:
sv = newSV(5); /* preallocate storage space */
- s = scan_vstring(s,sv);
+ s = scan_vstring(s, PL_bufend, sv);
break;
}
save_item(PL_subname);
SAVESPTR(PL_compcv);
- PL_compcv = (CV*)newSV(0);
- sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
+ PL_compcv = (CV*)newSV_type(is_format ? SVt_PVFM : SVt_PVCV);
CvFLAGS(PL_compcv) |= flags;
PL_subline = CopLINE(PL_curcop);
return (char*)s;
}
-/*
- * restore_rsfp
- * Restore a source filter.
- */
-
-static void
-restore_rsfp(pTHX_ void *f)
-{
- dVAR;
- PerlIO * const fp = (PerlIO*)f;
-
- if (PL_rsfp == PerlIO_stdin())
- PerlIO_clearerr(PL_rsfp);
- else if (PL_rsfp && (PL_rsfp != fp))
- PerlIO_close(PL_rsfp);
- PL_rsfp = fp;
-}
#ifndef PERL_NO_UTF16_FILTER
static I32
Function must be called like
sv = newSV(5);
- s = scan_vstring(s,sv);
+ s = scan_vstring(s,e,sv);
+where s and e are the start and end of the string.
The sv should already be large enough to store the vstring
passed in, for performance reasons.
*/
char *
-Perl_scan_vstring(pTHX_ const char *s, SV *sv)
+Perl_scan_vstring(pTHX_ const char *s, const char *e, SV *sv)
{
dVAR;
const char *pos = s;
const char *start = s;
if (*pos == 'v') pos++; /* get past 'v' */
- while (pos < PL_bufend && (isDIGIT(*pos) || *pos == '_'))
+ while (pos < e && (isDIGIT(*pos) || *pos == '_'))
pos++;
if ( *pos != '.') {
/* this may not be a v-string if followed by => */
const char *next = pos;
- while (next < PL_bufend && isSPACE(*next))
+ while (next < e && isSPACE(*next))
++next;
- if ((PL_bufend - next) >= 2 && *next == '=' && next[1] == '>' ) {
+ if ((e - next) >= 2 && *next == '=' && next[1] == '>' ) {
/* return string not v-string */
sv_setpvn(sv,(char *)s,pos-s);
return (char *)pos;
sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev)))
SvUTF8_on(sv);
- if (pos + 1 < PL_bufend && *pos == '.' && isDIGIT(pos[1]))
+ if (pos + 1 < e && *pos == '.' && isDIGIT(pos[1]))
s = ++pos;
else {
s = pos;
break;
}
- while (pos < PL_bufend && (isDIGIT(*pos) || *pos == '_'))
+ while (pos < e && (isDIGIT(*pos) || *pos == '_'))
pos++;
}
SvPOK_on(sv);
https://perl5.git.perl.org / perl5.git / blobdiff