This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
-Wall nit.
[perl5.git] / op.c
CommitLineData
a0d0e21e 1/* op.c
79072805 2 *
bc89e66f 3 * Copyright (c) 1991-2001, Larry Wall
79072805
LW
4 *
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
7 *
a0d0e21e
LW
8 */
9
10/*
11 * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
12 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
13 * youngest of the Old Took's daughters); and Mr. Drogo was his second
14 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
15 * either way, as the saying is, if you follow me." --the Gaffer
79072805
LW
16 */
17
18#include "EXTERN.h"
864dbfa3 19#define PERL_IN_OP_C
79072805 20#include "perl.h"
77ca0c92 21#include "keywords.h"
79072805 22
a07e034d 23#define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
a2efc822 24
b7dc083c 25/* #define PL_OP_SLAB_ALLOC */
7934575e 26
1c846c1f 27#ifdef PL_OP_SLAB_ALLOC
b7dc083c
NIS
28#define SLAB_SIZE 8192
29static char *PL_OpPtr = NULL;
30static int PL_OpSpace = 0;
31#define NewOp(m,var,c,type) do { if ((PL_OpSpace -= c*sizeof(type)) >= 0) \
32 var = (type *)(PL_OpPtr -= c*sizeof(type)); \
33 else \
34 var = (type *) Slab_Alloc(m,c*sizeof(type)); \
35 } while (0)
36
1c846c1f 37STATIC void *
cea2e8a9 38S_Slab_Alloc(pTHX_ int m, size_t sz)
1c846c1f 39{
b7dc083c
NIS
40 Newz(m,PL_OpPtr,SLAB_SIZE,char);
41 PL_OpSpace = SLAB_SIZE - sz;
42 return PL_OpPtr += PL_OpSpace;
43}
76e3520e 44
1c846c1f 45#else
b7dc083c
NIS
46#define NewOp(m, var, c, type) Newz(m, var, c, type)
47#endif
e50aee73 48/*
5dc0d613 49 * In the following definition, the ", Nullop" is just to make the compiler
a5f75d66 50 * think the expression is of the right type: croak actually does a Siglongjmp.
e50aee73 51 */
11343788 52#define CHECKOP(type,o) \
3280af22 53 ((PL_op_mask && PL_op_mask[type]) \
5dc0d613 54 ? ( op_free((OP*)o), \
cea2e8a9 55 Perl_croak(aTHX_ "%s trapped by operation mask", PL_op_desc[type]), \
28757baa 56 Nullop ) \
fc0dc3b3 57 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
e50aee73 58
c53d7c7d 59#define PAD_MAX 999999999
e6438c1a 60#define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
c53d7c7d 61
76e3520e 62STATIC char*
cea2e8a9 63S_gv_ename(pTHX_ GV *gv)
4633a7c4 64{
2d8e6c8d 65 STRLEN n_a;
4633a7c4 66 SV* tmpsv = sv_newmortal();
46fc3d4c 67 gv_efullname3(tmpsv, gv, Nullch);
2d8e6c8d 68 return SvPV(tmpsv,n_a);
4633a7c4
LW
69}
70
76e3520e 71STATIC OP *
cea2e8a9 72S_no_fh_allowed(pTHX_ OP *o)
79072805 73{
cea2e8a9 74 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
53e06cf0 75 OP_DESC(o)));
11343788 76 return o;
79072805
LW
77}
78
76e3520e 79STATIC OP *
cea2e8a9 80S_too_few_arguments(pTHX_ OP *o, char *name)
79072805 81{
cea2e8a9 82 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
11343788 83 return o;
79072805
LW
84}
85
76e3520e 86STATIC OP *
cea2e8a9 87S_too_many_arguments(pTHX_ OP *o, char *name)
79072805 88{
cea2e8a9 89 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
11343788 90 return o;
79072805
LW
91}
92
76e3520e 93STATIC void
cea2e8a9 94S_bad_type(pTHX_ I32 n, char *t, char *name, OP *kid)
8990e307 95{
cea2e8a9 96 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
53e06cf0 97 (int)n, name, t, OP_DESC(kid)));
8990e307
LW
98}
99
7a52d87a 100STATIC void
cea2e8a9 101S_no_bareword_allowed(pTHX_ OP *o)
7a52d87a 102{
5a844595
GS
103 qerror(Perl_mess(aTHX_
104 "Bareword \"%s\" not allowed while \"strict subs\" in use",
7766f137 105 SvPV_nolen(cSVOPo_sv)));
7a52d87a
GS
106}
107
79072805
LW
108/* "register" allocation */
109
110PADOFFSET
864dbfa3 111Perl_pad_allocmy(pTHX_ char *name)
93a17b20 112{
a0d0e21e
LW
113 PADOFFSET off;
114 SV *sv;
115
155aba94
GS
116 if (!(PL_in_my == KEY_our ||
117 isALPHA(name[1]) ||
39e02b42 118 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
155aba94 119 (name[1] == '_' && (int)strlen(name) > 2)))
834a4ddd 120 {
c4d0567e 121 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
2b92dfce
GS
122 /* 1999-02-27 mjd@plover.com */
123 char *p;
124 p = strchr(name, '\0');
125 /* The next block assumes the buffer is at least 205 chars
126 long. At present, it's always at least 256 chars. */
127 if (p-name > 200) {
128 strcpy(name+200, "...");
129 p = name+199;
130 }
131 else {
132 p[1] = '\0';
133 }
134 /* Move everything else down one character */
135 for (; p-name > 2; p--)
136 *p = *(p-1);
46fc3d4c
PP
137 name[2] = toCTRL(name[1]);
138 name[1] = '^';
139 }
cea2e8a9 140 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
a0d0e21e 141 }
e476b1b5 142 if (ckWARN(WARN_MISC) && AvFILLp(PL_comppad_name) >= 0) {
3280af22 143 SV **svp = AvARRAY(PL_comppad_name);
33633739
GS
144 HV *ourstash = (PL_curstash ? PL_curstash : PL_defstash);
145 PADOFFSET top = AvFILLp(PL_comppad_name);
146 for (off = top; off > PL_comppad_name_floor; off--) {
b1cb66bf 147 if ((sv = svp[off])
3280af22 148 && sv != &PL_sv_undef
c53d7c7d 149 && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
33633739
GS
150 && (PL_in_my != KEY_our
151 || ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash))
b1cb66bf
PP
152 && strEQ(name, SvPVX(sv)))
153 {
e476b1b5 154 Perl_warner(aTHX_ WARN_MISC,
1c846c1f 155 "\"%s\" variable %s masks earlier declaration in same %s",
33633739
GS
156 (PL_in_my == KEY_our ? "our" : "my"),
157 name,
158 (SvIVX(sv) == PAD_MAX ? "scope" : "statement"));
159 --off;
160 break;
161 }
162 }
163 if (PL_in_my == KEY_our) {
635bab04 164 do {
33633739
GS
165 if ((sv = svp[off])
166 && sv != &PL_sv_undef
5ce0178e 167 && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
33633739
GS
168 && ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash)
169 && strEQ(name, SvPVX(sv)))
f472eb5c 170 {
e476b1b5 171 Perl_warner(aTHX_ WARN_MISC,
33633739 172 "\"our\" variable %s redeclared", name);
e476b1b5 173 Perl_warner(aTHX_ WARN_MISC,
cc507455 174 "\t(Did you mean \"local\" instead of \"our\"?)\n");
33633739 175 break;
f472eb5c 176 }
635bab04 177 } while ( off-- > 0 );
b1cb66bf
PP
178 }
179 }
a0d0e21e
LW
180 off = pad_alloc(OP_PADSV, SVs_PADMY);
181 sv = NEWSV(1102,0);
93a17b20
LW
182 sv_upgrade(sv, SVt_PVNV);
183 sv_setpv(sv, name);
3280af22 184 if (PL_in_my_stash) {
c750a3ec 185 if (*name != '$')
eb64745e
GS
186 yyerror(Perl_form(aTHX_ "Can't declare class for non-scalar %s in \"%s\"",
187 name, PL_in_my == KEY_our ? "our" : "my"));
524189f1 188 SvFLAGS(sv) |= SVpad_TYPED;
c750a3ec 189 (void)SvUPGRADE(sv, SVt_PVMG);
3280af22 190 SvSTASH(sv) = (HV*)SvREFCNT_inc(PL_in_my_stash);
c750a3ec 191 }
f472eb5c
GS
192 if (PL_in_my == KEY_our) {
193 (void)SvUPGRADE(sv, SVt_PVGV);
ef75a179 194 GvSTASH(sv) = (HV*)SvREFCNT_inc(PL_curstash ? (SV*)PL_curstash : (SV*)PL_defstash);
77ca0c92 195 SvFLAGS(sv) |= SVpad_OUR;
f472eb5c 196 }
3280af22 197 av_store(PL_comppad_name, off, sv);
65202027 198 SvNVX(sv) = (NV)PAD_MAX;
8990e307 199 SvIVX(sv) = 0; /* Not yet introduced--see newSTATEOP */
3280af22
NIS
200 if (!PL_min_intro_pending)
201 PL_min_intro_pending = off;
202 PL_max_intro_pending = off;
93a17b20 203 if (*name == '@')
3280af22 204 av_store(PL_comppad, off, (SV*)newAV());
93a17b20 205 else if (*name == '%')
3280af22
NIS
206 av_store(PL_comppad, off, (SV*)newHV());
207 SvPADMY_on(PL_curpad[off]);
93a17b20
LW
208 return off;
209}
210
94f23f41
GS
211STATIC PADOFFSET
212S_pad_addlex(pTHX_ SV *proto_namesv)
213{
214 SV *namesv = NEWSV(1103,0);
215 PADOFFSET newoff = pad_alloc(OP_PADSV, SVs_PADMY);
216 sv_upgrade(namesv, SVt_PVNV);
217 sv_setpv(namesv, SvPVX(proto_namesv));
218 av_store(PL_comppad_name, newoff, namesv);
219 SvNVX(namesv) = (NV)PL_curcop->cop_seq;
220 SvIVX(namesv) = PAD_MAX; /* A ref, intro immediately */
221 SvFAKE_on(namesv); /* A ref, not a real var */
222 if (SvFLAGS(proto_namesv) & SVpad_OUR) { /* An "our" variable */
223 SvFLAGS(namesv) |= SVpad_OUR;
224 (void)SvUPGRADE(namesv, SVt_PVGV);
225 GvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)GvSTASH(proto_namesv));
226 }
524189f1
JH
227 if (SvFLAGS(proto_namesv) & SVpad_TYPED) { /* A typed lexical */
228 SvFLAGS(namesv) |= SVpad_TYPED;
94f23f41
GS
229 (void)SvUPGRADE(namesv, SVt_PVMG);
230 SvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)SvSTASH(proto_namesv));
94f23f41
GS
231 }
232 return newoff;
233}
234
2680586e
GS
235#define FINDLEX_NOSEARCH 1 /* don't search outer contexts */
236
76e3520e 237STATIC PADOFFSET
cea2e8a9 238S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv,
864dbfa3 239 I32 cx_ix, I32 saweval, U32 flags)
93a17b20 240{
748a9306 241 CV *cv;
93a17b20
LW
242 I32 off;
243 SV *sv;
93a17b20 244 register I32 i;
c09156bb 245 register PERL_CONTEXT *cx;
93a17b20 246
748a9306 247 for (cv = startcv; cv; cv = CvOUTSIDE(cv)) {
4fdae800
PP
248 AV *curlist = CvPADLIST(cv);
249 SV **svp = av_fetch(curlist, 0, FALSE);
748a9306 250 AV *curname;
4fdae800 251
3280af22 252 if (!svp || *svp == &PL_sv_undef)
4633a7c4 253 continue;
748a9306
LW
254 curname = (AV*)*svp;
255 svp = AvARRAY(curname);
93965878 256 for (off = AvFILLp(curname); off > 0; off--) {
748a9306 257 if ((sv = svp[off]) &&
3280af22 258 sv != &PL_sv_undef &&
748a9306 259 seq <= SvIVX(sv) &&
13826f2c 260 seq > I_32(SvNVX(sv)) &&
748a9306
LW
261 strEQ(SvPVX(sv), name))
262 {
5f05dabc
PP
263 I32 depth;
264 AV *oldpad;
265 SV *oldsv;
266
267 depth = CvDEPTH(cv);
268 if (!depth) {
9607fc9c
PP
269 if (newoff) {
270 if (SvFAKE(sv))
271 continue;
4fdae800 272 return 0; /* don't clone from inactive stack frame */
9607fc9c 273 }
5f05dabc
PP
274 depth = 1;
275 }
94f23f41 276 oldpad = (AV*)AvARRAY(curlist)[depth];
5f05dabc 277 oldsv = *av_fetch(oldpad, off, TRUE);
748a9306 278 if (!newoff) { /* Not a mere clone operation. */
94f23f41 279 newoff = pad_addlex(sv);
3280af22 280 if (CvANON(PL_compcv) || SvTYPE(PL_compcv) == SVt_PVFM) {
28757baa 281 /* "It's closures all the way down." */
3280af22 282 CvCLONE_on(PL_compcv);
54310121 283 if (cv == startcv) {
3280af22 284 if (CvANON(PL_compcv))
54310121
PP
285 oldsv = Nullsv; /* no need to keep ref */
286 }
287 else {
28757baa
PP
288 CV *bcv;
289 for (bcv = startcv;
290 bcv && bcv != cv && !CvCLONE(bcv);
6b35e009
GS
291 bcv = CvOUTSIDE(bcv))
292 {
94f23f41
GS
293 if (CvANON(bcv)) {
294 /* install the missing pad entry in intervening
295 * nested subs and mark them cloneable.
296 * XXX fix pad_foo() to not use globals */
297 AV *ocomppad_name = PL_comppad_name;
298 AV *ocomppad = PL_comppad;
299 SV **ocurpad = PL_curpad;
300 AV *padlist = CvPADLIST(bcv);
301 PL_comppad_name = (AV*)AvARRAY(padlist)[0];
302 PL_comppad = (AV*)AvARRAY(padlist)[1];
303 PL_curpad = AvARRAY(PL_comppad);
304 pad_addlex(sv);
305 PL_comppad_name = ocomppad_name;
306 PL_comppad = ocomppad;
307 PL_curpad = ocurpad;
28757baa 308 CvCLONE_on(bcv);
94f23f41 309 }
28757baa 310 else {
6b35e009
GS
311 if (ckWARN(WARN_CLOSURE)
312 && !CvUNIQUE(bcv) && !CvUNIQUE(cv))
313 {
cea2e8a9 314 Perl_warner(aTHX_ WARN_CLOSURE,
44a8e56a 315 "Variable \"%s\" may be unavailable",
28757baa 316 name);
6b35e009 317 }
28757baa
PP
318 break;
319 }
320 }
321 }
322 }
3280af22 323 else if (!CvUNIQUE(PL_compcv)) {
741b6338
GS
324 if (ckWARN(WARN_CLOSURE) && !SvFAKE(sv) && !CvUNIQUE(cv)
325 && !(SvFLAGS(sv) & SVpad_OUR))
326 {
cea2e8a9 327 Perl_warner(aTHX_ WARN_CLOSURE,
599cee73 328 "Variable \"%s\" will not stay shared", name);
741b6338 329 }
5f05dabc 330 }
748a9306 331 }
3280af22 332 av_store(PL_comppad, newoff, SvREFCNT_inc(oldsv));
748a9306
LW
333 return newoff;
334 }
93a17b20
LW
335 }
336 }
337
2680586e
GS
338 if (flags & FINDLEX_NOSEARCH)
339 return 0;
340
93a17b20
LW
341 /* Nothing in current lexical context--try eval's context, if any.
342 * This is necessary to let the perldb get at lexically scoped variables.
343 * XXX This will also probably interact badly with eval tree caching.
344 */
345
748a9306 346 for (i = cx_ix; i >= 0; i--) {
93a17b20 347 cx = &cxstack[i];
6b35e009 348 switch (CxTYPE(cx)) {
93a17b20 349 default:
748a9306 350 if (i == 0 && saweval) {
2680586e 351 return pad_findlex(name, newoff, seq, PL_main_cv, -1, saweval, 0);
748a9306 352 }
93a17b20
LW
353 break;
354 case CXt_EVAL:
44a8e56a
PP
355 switch (cx->blk_eval.old_op_type) {
356 case OP_ENTEREVAL:
2090ab20
JH
357 if (CxREALEVAL(cx)) {
358 PADOFFSET off;
6b35e009 359 saweval = i;
2090ab20
JH
360 seq = cxstack[i].blk_oldcop->cop_seq;
361 startcv = cxstack[i].blk_eval.cv;
c975facc
JH
362 if (startcv && CvOUTSIDE(startcv)) {
363 off = pad_findlex(name, newoff, seq, CvOUTSIDE(startcv),
364 i-1, saweval, 0);
365 if (off) /* continue looking if not found here */
366 return off;
367 }
2090ab20 368 }
44a8e56a 369 break;
faa7e5bb 370 case OP_DOFILE:
44a8e56a 371 case OP_REQUIRE:
faa7e5bb 372 /* require/do must have their own scope */
44a8e56a
PP
373 return 0;
374 }
93a17b20 375 break;
7766f137 376 case CXt_FORMAT:
93a17b20
LW
377 case CXt_SUB:
378 if (!saweval)
379 return 0;
380 cv = cx->blk_sub.cv;
3280af22 381 if (PL_debstash && CvSTASH(cv) == PL_debstash) { /* ignore DB'* scope */
748a9306 382 saweval = i; /* so we know where we were called from */
708c0d06 383 seq = cxstack[i].blk_oldcop->cop_seq;
93a17b20 384 continue;
93a17b20 385 }
2680586e 386 return pad_findlex(name, newoff, seq, cv, i-1, saweval,FINDLEX_NOSEARCH);
93a17b20
LW
387 }
388 }
389
748a9306
LW
390 return 0;
391}
a0d0e21e 392
748a9306 393PADOFFSET
864dbfa3 394Perl_pad_findmy(pTHX_ char *name)
748a9306
LW
395{
396 I32 off;
54310121 397 I32 pendoff = 0;
748a9306 398 SV *sv;
3280af22
NIS
399 SV **svp = AvARRAY(PL_comppad_name);
400 U32 seq = PL_cop_seqmax;
6b35e009 401 PERL_CONTEXT *cx;
33b8ce05 402 CV *outside;
748a9306 403
4d1ff10f 404#ifdef USE_5005THREADS
11343788
MB
405 /*
406 * Special case to get lexical (and hence per-thread) @_.
407 * XXX I need to find out how to tell at parse-time whether use
408 * of @_ should refer to a lexical (from a sub) or defgv (global
409 * scope and maybe weird sub-ish things like formats). See
410 * startsub in perly.y. It's possible that @_ could be lexical
411 * (at least from subs) even in non-threaded perl.
412 */
413 if (strEQ(name, "@_"))
414 return 0; /* success. (NOT_IN_PAD indicates failure) */
4d1ff10f 415#endif /* USE_5005THREADS */
11343788 416
748a9306 417 /* The one we're looking for is probably just before comppad_name_fill. */
3280af22 418 for (off = AvFILLp(PL_comppad_name); off > 0; off--) {
a0d0e21e 419 if ((sv = svp[off]) &&
3280af22 420 sv != &PL_sv_undef &&
54310121
PP
421 (!SvIVX(sv) ||
422 (seq <= SvIVX(sv) &&
423 seq > I_32(SvNVX(sv)))) &&
a0d0e21e
LW
424 strEQ(SvPVX(sv), name))
425 {
77ca0c92 426 if (SvIVX(sv) || SvFLAGS(sv) & SVpad_OUR)
54310121
PP
427 return (PADOFFSET)off;
428 pendoff = off; /* this pending def. will override import */
a0d0e21e
LW
429 }
430 }
748a9306 431
33b8ce05
GS
432 outside = CvOUTSIDE(PL_compcv);
433
434 /* Check if if we're compiling an eval'', and adjust seq to be the
435 * eval's seq number. This depends on eval'' having a non-null
436 * CvOUTSIDE() while it is being compiled. The eval'' itself is
1aff0e91
GS
437 * identified by CvEVAL being true and CvGV being null. */
438 if (outside && CvEVAL(PL_compcv) && !CvGV(PL_compcv) && cxstack_ix >= 0) {
6b35e009
GS
439 cx = &cxstack[cxstack_ix];
440 if (CxREALEVAL(cx))
441 seq = cx->blk_oldcop->cop_seq;
442 }
443
748a9306 444 /* See if it's in a nested scope */
2680586e 445 off = pad_findlex(name, 0, seq, outside, cxstack_ix, 0, 0);
54310121
PP
446 if (off) {
447 /* If there is a pending local definition, this new alias must die */
448 if (pendoff)
3280af22 449 SvIVX(AvARRAY(PL_comppad_name)[off]) = seq;
11343788 450 return off; /* pad_findlex returns 0 for failure...*/
54310121 451 }
11343788 452 return NOT_IN_PAD; /* ...but we return NOT_IN_PAD for failure */
93a17b20
LW
453}
454
455void
864dbfa3 456Perl_pad_leavemy(pTHX_ I32 fill)
93a17b20
LW
457{
458 I32 off;
3280af22 459 SV **svp = AvARRAY(PL_comppad_name);
93a17b20 460 SV *sv;
3280af22
NIS
461 if (PL_min_intro_pending && fill < PL_min_intro_pending) {
462 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
0453d815
PM
463 if ((sv = svp[off]) && sv != &PL_sv_undef && ckWARN_d(WARN_INTERNAL))
464 Perl_warner(aTHX_ WARN_INTERNAL, "%s never introduced", SvPVX(sv));
8990e307
LW
465 }
466 }
467 /* "Deintroduce" my variables that are leaving with this scope. */
3280af22 468 for (off = AvFILLp(PL_comppad_name); off > fill; off--) {
c53d7c7d 469 if ((sv = svp[off]) && sv != &PL_sv_undef && SvIVX(sv) == PAD_MAX)
3280af22 470 SvIVX(sv) = PL_cop_seqmax;
93a17b20
LW
471 }
472}
473
474PADOFFSET
864dbfa3 475Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
79072805
LW
476{
477 SV *sv;
478 I32 retval;
479
3280af22 480 if (AvARRAY(PL_comppad) != PL_curpad)
cea2e8a9 481 Perl_croak(aTHX_ "panic: pad_alloc");
3280af22 482 if (PL_pad_reset_pending)
a0d0e21e 483 pad_reset();
ed6116ce 484 if (tmptype & SVs_PADMY) {
79072805 485 do {
3280af22 486 sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
ed6116ce 487 } while (SvPADBUSY(sv)); /* need a fresh one */
3280af22 488 retval = AvFILLp(PL_comppad);
79072805
LW
489 }
490 else {
3280af22
NIS
491 SV **names = AvARRAY(PL_comppad_name);
492 SSize_t names_fill = AvFILLp(PL_comppad_name);
bbce6d69
PP
493 for (;;) {
494 /*
495 * "foreach" index vars temporarily become aliases to non-"my"
496 * values. Thus we must skip, not just pad values that are
497 * marked as current pad values, but also those with names.
498 */
3280af22
NIS
499 if (++PL_padix <= names_fill &&
500 (sv = names[PL_padix]) && sv != &PL_sv_undef)
bbce6d69 501 continue;
3280af22 502 sv = *av_fetch(PL_comppad, PL_padix, TRUE);
3049cdab
SB
503 if (!(SvFLAGS(sv) & (SVs_PADTMP|SVs_PADMY)) &&
504 !IS_PADGV(sv) && !IS_PADCONST(sv))
bbce6d69
PP
505 break;
506 }
3280af22 507 retval = PL_padix;
79072805 508 }
8990e307 509 SvFLAGS(sv) |= tmptype;
3280af22 510 PL_curpad = AvARRAY(PL_comppad);
4d1ff10f 511#ifdef USE_5005THREADS
b900a521
JH
512 DEBUG_X(PerlIO_printf(Perl_debug_log,
513 "0x%"UVxf" Pad 0x%"UVxf" alloc %ld for %s\n",
514 PTR2UV(thr), PTR2UV(PL_curpad),
22c35a8c 515 (long) retval, PL_op_name[optype]));
11343788 516#else
b900a521
JH
517 DEBUG_X(PerlIO_printf(Perl_debug_log,
518 "Pad 0x%"UVxf" alloc %ld for %s\n",
519 PTR2UV(PL_curpad),
22c35a8c 520 (long) retval, PL_op_name[optype]));
4d1ff10f 521#endif /* USE_5005THREADS */
79072805
LW
522 return (PADOFFSET)retval;
523}
524
525SV *
864dbfa3 526Perl_pad_sv(pTHX_ PADOFFSET po)
79072805 527{
4d1ff10f 528#ifdef USE_5005THREADS
b900a521 529 DEBUG_X(PerlIO_printf(Perl_debug_log,
f1dbda3d
JH
530 "0x%"UVxf" Pad 0x%"UVxf" sv %"IVdf"\n",
531 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
11343788 532#else
79072805 533 if (!po)
cea2e8a9 534 Perl_croak(aTHX_ "panic: pad_sv po");
97835f67
JH
535 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" sv %"IVdf"\n",
536 PTR2UV(PL_curpad), (IV)po));
4d1ff10f 537#endif /* USE_5005THREADS */
3280af22 538 return PL_curpad[po]; /* eventually we'll turn this into a macro */
79072805
LW
539}
540
541void
864dbfa3 542Perl_pad_free(pTHX_ PADOFFSET po)
79072805 543{
3280af22 544 if (!PL_curpad)
a0d0e21e 545 return;
3280af22 546 if (AvARRAY(PL_comppad) != PL_curpad)
cea2e8a9 547 Perl_croak(aTHX_ "panic: pad_free curpad");
79072805 548 if (!po)
cea2e8a9 549 Perl_croak(aTHX_ "panic: pad_free po");
4d1ff10f 550#ifdef USE_5005THREADS
b900a521 551 DEBUG_X(PerlIO_printf(Perl_debug_log,
7766f137 552 "0x%"UVxf" Pad 0x%"UVxf" free %"IVdf"\n",
f1dbda3d 553 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
11343788 554#else
97835f67
JH
555 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" free %"IVdf"\n",
556 PTR2UV(PL_curpad), (IV)po));
4d1ff10f 557#endif /* USE_5005THREADS */
2aa1bedc 558 if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
3280af22 559 SvPADTMP_off(PL_curpad[po]);
2aa1bedc
GS
560#ifdef USE_ITHREADS
561 SvREADONLY_off(PL_curpad[po]); /* could be a freed constant */
562#endif
563 }
3280af22
NIS
564 if ((I32)po < PL_padix)
565 PL_padix = po - 1;
79072805
LW
566}
567
568void
864dbfa3 569Perl_pad_swipe(pTHX_ PADOFFSET po)
79072805 570{
3280af22 571 if (AvARRAY(PL_comppad) != PL_curpad)
cea2e8a9 572 Perl_croak(aTHX_ "panic: pad_swipe curpad");
79072805 573 if (!po)
cea2e8a9 574 Perl_croak(aTHX_ "panic: pad_swipe po");
4d1ff10f 575#ifdef USE_5005THREADS
b900a521 576 DEBUG_X(PerlIO_printf(Perl_debug_log,
f1dbda3d
JH
577 "0x%"UVxf" Pad 0x%"UVxf" swipe %"IVdf"\n",
578 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
11343788 579#else
97835f67
JH
580 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" swipe %"IVdf"\n",
581 PTR2UV(PL_curpad), (IV)po));
4d1ff10f 582#endif /* USE_5005THREADS */
3280af22
NIS
583 SvPADTMP_off(PL_curpad[po]);
584 PL_curpad[po] = NEWSV(1107,0);
585 SvPADTMP_on(PL_curpad[po]);
586 if ((I32)po < PL_padix)
587 PL_padix = po - 1;
79072805
LW
588}
589
d9bb4600
GS
590/* XXX pad_reset() is currently disabled because it results in serious bugs.
591 * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
592 * on the stack by OPs that use them, there are several ways to get an alias
593 * to a shared TARG. Such an alias will change randomly and unpredictably.
594 * We avoid doing this until we can think of a Better Way.
595 * GSAR 97-10-29 */
79072805 596void
864dbfa3 597Perl_pad_reset(pTHX)
79072805 598{
d9bb4600 599#ifdef USE_BROKEN_PAD_RESET
79072805
LW
600 register I32 po;
601
6b88bc9c 602 if (AvARRAY(PL_comppad) != PL_curpad)
cea2e8a9 603 Perl_croak(aTHX_ "panic: pad_reset curpad");
4d1ff10f 604#ifdef USE_5005THREADS
b900a521
JH
605 DEBUG_X(PerlIO_printf(Perl_debug_log,
606 "0x%"UVxf" Pad 0x%"UVxf" reset\n",
607 PTR2UV(thr), PTR2UV(PL_curpad)));
11343788 608#else
b900a521
JH
609 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" reset\n",
610 PTR2UV(PL_curpad)));
4d1ff10f 611#endif /* USE_5005THREADS */
6b88bc9c
GS
612 if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
613 for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
614 if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
615 SvPADTMP_off(PL_curpad[po]);
748a9306 616 }
6b88bc9c 617 PL_padix = PL_padix_floor;
79072805 618 }
d9bb4600 619#endif
3280af22 620 PL_pad_reset_pending = FALSE;
79072805
LW
621}
622
4d1ff10f 623#ifdef USE_5005THREADS
54b9620d 624/* find_threadsv is not reentrant */
a863c7d1 625PADOFFSET
864dbfa3 626Perl_find_threadsv(pTHX_ const char *name)
a863c7d1 627{
a863c7d1
MB
628 char *p;
629 PADOFFSET key;
554b3eca 630 SV **svp;
54b9620d 631 /* We currently only handle names of a single character */
533c011a 632 p = strchr(PL_threadsv_names, *name);
a863c7d1
MB
633 if (!p)
634 return NOT_IN_PAD;
533c011a 635 key = p - PL_threadsv_names;
2d8e6c8d 636 MUTEX_LOCK(&thr->mutex);
54b9620d 637 svp = av_fetch(thr->threadsv, key, FALSE);
2d8e6c8d
GS
638 if (svp)
639 MUTEX_UNLOCK(&thr->mutex);
640 else {
554b3eca 641 SV *sv = NEWSV(0, 0);
54b9620d 642 av_store(thr->threadsv, key, sv);
940cb80d 643 thr->threadsvp = AvARRAY(thr->threadsv);
2d8e6c8d 644 MUTEX_UNLOCK(&thr->mutex);
554b3eca
MB
645 /*
646 * Some magic variables used to be automagically initialised
647 * in gv_fetchpv. Those which are now per-thread magicals get
648 * initialised here instead.
649 */
650 switch (*name) {
54b9620d
MB
651 case '_':
652 break;
554b3eca
MB
653 case ';':
654 sv_setpv(sv, "\034");
14befaf4 655 sv_magic(sv, 0, PERL_MAGIC_sv, name, 1);
554b3eca 656 break;
c277df42
IZ
657 case '&':
658 case '`':
659 case '\'':
533c011a 660 PL_sawampersand = TRUE;
a3f914c5
GS
661 /* FALL THROUGH */
662 case '1':
663 case '2':
664 case '3':
665 case '4':
666 case '5':
667 case '6':
668 case '7':
669 case '8':
670 case '9':
c277df42 671 SvREADONLY_on(sv);
d8b5173a 672 /* FALL THROUGH */
067391ea
GS
673
674 /* XXX %! tied to Errno.pm needs to be added here.
675 * See gv_fetchpv(). */
676 /* case '!': */
677
54b9620d 678 default:
14befaf4 679 sv_magic(sv, 0, PERL_MAGIC_sv, name, 1);
554b3eca 680 }
bf49b057 681 DEBUG_S(PerlIO_printf(Perl_error_log,
54b9620d 682 "find_threadsv: new SV %p for $%s%c\n",
554b3eca
MB
683 sv, (*name < 32) ? "^" : "",
684 (*name < 32) ? toCTRL(*name) : *name));
a863c7d1
MB
685 }
686 return key;
687}
4d1ff10f 688#endif /* USE_5005THREADS */
a863c7d1 689
79072805
LW
690/* Destructor */
691
692void
864dbfa3 693Perl_op_free(pTHX_ OP *o)
79072805 694{
85e6fe83 695 register OP *kid, *nextkid;
acb36ea4 696 OPCODE type;
79072805 697
5dc0d613 698 if (!o || o->op_seq == (U16)-1)
79072805
LW
699 return;
700
7934575e
GS
701 if (o->op_private & OPpREFCOUNTED) {
702 switch (o->op_type) {
703 case OP_LEAVESUB:
704 case OP_LEAVESUBLV:
705 case OP_LEAVEEVAL:
706 case OP_LEAVE:
707 case OP_SCOPE:
708 case OP_LEAVEWRITE:
709 OP_REFCNT_LOCK;
710 if (OpREFCNT_dec(o)) {
711 OP_REFCNT_UNLOCK;
712 return;
713 }
714 OP_REFCNT_UNLOCK;
715 break;
716 default:
717 break;
718 }
719 }
720
11343788
MB
721 if (o->op_flags & OPf_KIDS) {
722 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
85e6fe83 723 nextkid = kid->op_sibling; /* Get before next freeing kid */
79072805 724 op_free(kid);
85e6fe83 725 }
79072805 726 }
acb36ea4
GS
727 type = o->op_type;
728 if (type == OP_NULL)
729 type = o->op_targ;
730
731 /* COP* is not cleared by op_clear() so that we may track line
732 * numbers etc even after null() */
733 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
734 cop_free((COP*)o);
735
736 op_clear(o);
737
738#ifdef PL_OP_SLAB_ALLOC
739 if ((char *) o == PL_OpPtr)
740 {
741 }
742#else
743 Safefree(o);
744#endif
745}
79072805 746
93c66552
DM
747void
748Perl_op_clear(pTHX_ OP *o)
acb36ea4 749{
13137afc 750
11343788 751 switch (o->op_type) {
acb36ea4
GS
752 case OP_NULL: /* Was holding old type, if any. */
753 case OP_ENTEREVAL: /* Was holding hints. */
4d1ff10f 754#ifdef USE_5005THREADS
acb36ea4
GS
755 case OP_THREADSV: /* Was holding index into thr->threadsv AV. */
756#endif
757 o->op_targ = 0;
a0d0e21e 758 break;
4d1ff10f 759#ifdef USE_5005THREADS
8dd3ba40
SM
760 case OP_ENTERITER:
761 if (!(o->op_flags & OPf_SPECIAL))
762 break;
763 /* FALL THROUGH */
4d1ff10f 764#endif /* USE_5005THREADS */
a6006777 765 default:
ac4c12e7 766 if (!(o->op_flags & OPf_REF)
0b94c7bb 767 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
a6006777
PP
768 break;
769 /* FALL THROUGH */
463ee0b2 770 case OP_GVSV:
79072805 771 case OP_GV:
a6006777 772 case OP_AELEMFAST:
350de78d 773#ifdef USE_ITHREADS
971a9dd3
GS
774 if (cPADOPo->op_padix > 0) {
775 if (PL_curpad) {
638eceb6 776 GV *gv = cGVOPo_gv;
971a9dd3
GS
777 pad_swipe(cPADOPo->op_padix);
778 /* No GvIN_PAD_off(gv) here, because other references may still
779 * exist on the pad */
780 SvREFCNT_dec(gv);
781 }
782 cPADOPo->op_padix = 0;
783 }
350de78d 784#else
971a9dd3 785 SvREFCNT_dec(cSVOPo->op_sv);
7934575e 786 cSVOPo->op_sv = Nullsv;
350de78d 787#endif
79072805 788 break;
a1ae71d2 789 case OP_METHOD_NAMED:
79072805 790 case OP_CONST:
11343788 791 SvREFCNT_dec(cSVOPo->op_sv);
acb36ea4 792 cSVOPo->op_sv = Nullsv;
79072805 793 break;
748a9306
LW
794 case OP_GOTO:
795 case OP_NEXT:
796 case OP_LAST:
797 case OP_REDO:
11343788 798 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
748a9306
LW
799 break;
800 /* FALL THROUGH */
a0d0e21e 801 case OP_TRANS:
acb36ea4 802 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
a0ed51b3 803 SvREFCNT_dec(cSVOPo->op_sv);
acb36ea4
GS
804 cSVOPo->op_sv = Nullsv;
805 }
806 else {
a0ed51b3 807 Safefree(cPVOPo->op_pv);
acb36ea4
GS
808 cPVOPo->op_pv = Nullch;
809 }
a0d0e21e
LW
810 break;
811 case OP_SUBST:
11343788 812 op_free(cPMOPo->op_pmreplroot);
971a9dd3 813 goto clear_pmop;
748a9306 814 case OP_PUSHRE:
971a9dd3
GS
815#ifdef USE_ITHREADS
816 if ((PADOFFSET)cPMOPo->op_pmreplroot) {
817 if (PL_curpad) {
818 GV *gv = (GV*)PL_curpad[(PADOFFSET)cPMOPo->op_pmreplroot];
819 pad_swipe((PADOFFSET)cPMOPo->op_pmreplroot);
820 /* No GvIN_PAD_off(gv) here, because other references may still
821 * exist on the pad */
822 SvREFCNT_dec(gv);
823 }
824 }
825#else
826 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
827#endif
828 /* FALL THROUGH */
a0d0e21e 829 case OP_MATCH:
8782bef2 830 case OP_QR:
971a9dd3 831clear_pmop:
cb55de95
JH
832 {
833 HV *pmstash = PmopSTASH(cPMOPo);
834 if (pmstash && SvREFCNT(pmstash)) {
835 PMOP *pmop = HvPMROOT(pmstash);
836 PMOP *lastpmop = NULL;
837 while (pmop) {
838 if (cPMOPo == pmop) {
839 if (lastpmop)
840 lastpmop->op_pmnext = pmop->op_pmnext;
841 else
842 HvPMROOT(pmstash) = pmop->op_pmnext;
843 break;
844 }
845 lastpmop = pmop;
846 pmop = pmop->op_pmnext;
847 }
83da49e6 848 }
cb55de95 849#ifdef USE_ITHREADS
83da49e6 850 Safefree(PmopSTASHPV(cPMOPo));
cb55de95 851#else
83da49e6 852 /* NOTE: PMOP.op_pmstash is not refcounted */
cb55de95 853#endif
cb55de95 854 }
971a9dd3 855 cPMOPo->op_pmreplroot = Nullop;
5f8cb046
DM
856 /* we use the "SAFE" version of the PM_ macros here
857 * since sv_clean_all might release some PMOPs
858 * after PL_regex_padav has been cleared
859 * and the clearing of PL_regex_padav needs to
860 * happen before sv_clean_all
861 */
862 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
863 PM_SETRE_SAFE(cPMOPo, (REGEXP*)NULL);
13137afc
AB
864#ifdef USE_ITHREADS
865 if(PL_regex_pad) { /* We could be in destruction */
866 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
1cc8b4c5 867 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
13137afc
AB
868 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
869 }
870#endif
871
a0d0e21e 872 break;
79072805
LW
873 }
874
743e66e6 875 if (o->op_targ > 0) {
11343788 876 pad_free(o->op_targ);
743e66e6
GS
877 o->op_targ = 0;
878 }
79072805
LW
879}
880
76e3520e 881STATIC void
3eb57f73
HS
882S_cop_free(pTHX_ COP* cop)
883{
884 Safefree(cop->cop_label);
57843af0 885#ifdef USE_ITHREADS
f4dd75d9
GS
886 Safefree(CopFILE(cop)); /* XXX share in a pvtable? */
887 Safefree(CopSTASHPV(cop)); /* XXX share in a pvtable? */
57843af0 888#else
11faa288 889 /* NOTE: COP.cop_stash is not refcounted */
cc49e20b 890 SvREFCNT_dec(CopFILEGV(cop));
57843af0 891#endif
0453d815 892 if (! specialWARN(cop->cop_warnings))
3eb57f73 893 SvREFCNT_dec(cop->cop_warnings);
ac27b0f5
NIS
894 if (! specialCopIO(cop->cop_io))
895 SvREFCNT_dec(cop->cop_io);
3eb57f73
HS
896}
897
93c66552
DM
898void
899Perl_op_null(pTHX_ OP *o)
8990e307 900{
acb36ea4
GS
901 if (o->op_type == OP_NULL)
902 return;
903 op_clear(o);
11343788
MB
904 o->op_targ = o->op_type;
905 o->op_type = OP_NULL;
22c35a8c 906 o->op_ppaddr = PL_ppaddr[OP_NULL];
8990e307
LW
907}
908
79072805
LW
909/* Contextualizers */
910
463ee0b2 911#define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
79072805
LW
912
913OP *
864dbfa3 914Perl_linklist(pTHX_ OP *o)
79072805
LW
915{
916 register OP *kid;
917
11343788
MB
918 if (o->op_next)
919 return o->op_next;
79072805
LW
920
921 /* establish postfix order */
11343788
MB
922 if (cUNOPo->op_first) {
923 o->op_next = LINKLIST(cUNOPo->op_first);
924 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
79072805
LW
925 if (kid->op_sibling)
926 kid->op_next = LINKLIST(kid->op_sibling);
927 else
11343788 928 kid->op_next = o;
79072805
LW
929 }
930 }
931 else
11343788 932 o->op_next = o;
79072805 933
11343788 934 return o->op_next;
79072805
LW
935}
936
937OP *
864dbfa3 938Perl_scalarkids(pTHX_ OP *o)
79072805
LW
939{
940 OP *kid;
11343788
MB
941 if (o && o->op_flags & OPf_KIDS) {
942 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW
943 scalar(kid);
944 }
11343788 945 return o;
79072805
LW
946}
947
76e3520e 948STATIC OP *
cea2e8a9 949S_scalarboolean(pTHX_ OP *o)
8990e307 950{
d008e5eb 951 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
d008e5eb 952 if (ckWARN(WARN_SYNTAX)) {
57843af0 953 line_t oldline = CopLINE(PL_curcop);
a0d0e21e 954
d008e5eb 955 if (PL_copline != NOLINE)
57843af0 956 CopLINE_set(PL_curcop, PL_copline);
cea2e8a9 957 Perl_warner(aTHX_ WARN_SYNTAX, "Found = in conditional, should be ==");
57843af0 958 CopLINE_set(PL_curcop, oldline);
d008e5eb 959 }
a0d0e21e 960 }
11343788 961 return scalar(o);
8990e307
LW
962}
963
964OP *
864dbfa3 965Perl_scalar(pTHX_ OP *o)
79072805
LW
966{
967 OP *kid;
968
a0d0e21e 969 /* assumes no premature commitment */
3280af22 970 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
5dc0d613 971 || o->op_type == OP_RETURN)
7e363e51 972 {
11343788 973 return o;
7e363e51 974 }
79072805 975
5dc0d613 976 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
79072805 977
11343788 978 switch (o->op_type) {
79072805 979 case OP_REPEAT:
11343788 980 scalar(cBINOPo->op_first);
8990e307 981 break;
79072805
LW
982 case OP_OR:
983 case OP_AND:
984 case OP_COND_EXPR:
11343788 985 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
8990e307 986 scalar(kid);
79072805 987 break;
a0d0e21e 988 case OP_SPLIT:
11343788 989 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
a0d0e21e
LW
990 if (!kPMOP->op_pmreplroot)
991 deprecate("implicit split to @_");
992 }
993 /* FALL THROUGH */
79072805 994 case OP_MATCH:
8782bef2 995 case OP_QR:
79072805
LW
996 case OP_SUBST:
997 case OP_NULL:
8990e307 998 default:
11343788
MB
999 if (o->op_flags & OPf_KIDS) {
1000 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
8990e307
LW
1001 scalar(kid);
1002 }
79072805
LW
1003 break;
1004 case OP_LEAVE:
1005 case OP_LEAVETRY:
5dc0d613 1006 kid = cLISTOPo->op_first;
54310121 1007 scalar(kid);
155aba94 1008 while ((kid = kid->op_sibling)) {
54310121
PP
1009 if (kid->op_sibling)
1010 scalarvoid(kid);
1011 else
1012 scalar(kid);
1013 }
3280af22 1014 WITH_THR(PL_curcop = &PL_compiling);
54310121 1015 break;
748a9306 1016 case OP_SCOPE:
79072805 1017 case OP_LINESEQ:
8990e307 1018 case OP_LIST:
11343788 1019 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
79072805
LW
1020 if (kid->op_sibling)
1021 scalarvoid(kid);
1022 else
1023 scalar(kid);
1024 }
3280af22 1025 WITH_THR(PL_curcop = &PL_compiling);
79072805
LW
1026 break;
1027 }
11343788 1028 return o;
79072805
LW
1029}
1030
1031OP *
864dbfa3 1032Perl_scalarvoid(pTHX_ OP *o)
79072805
LW
1033{
1034 OP *kid;
8990e307
LW
1035 char* useless = 0;
1036 SV* sv;
2ebea0a1
GS
1037 U8 want;
1038
acb36ea4
GS
1039 if (o->op_type == OP_NEXTSTATE
1040 || o->op_type == OP_SETSTATE
1041 || o->op_type == OP_DBSTATE
1042 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1043 || o->op_targ == OP_SETSTATE
1044 || o->op_targ == OP_DBSTATE)))
2ebea0a1 1045 PL_curcop = (COP*)o; /* for warning below */
79072805 1046
54310121 1047 /* assumes no premature commitment */
2ebea0a1
GS
1048 want = o->op_flags & OPf_WANT;
1049 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
5dc0d613 1050 || o->op_type == OP_RETURN)
7e363e51 1051 {
11343788 1052 return o;
7e363e51 1053 }
79072805 1054
b162f9ea 1055 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS
1056 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1057 {
b162f9ea 1058 return scalar(o); /* As if inside SASSIGN */
7e363e51 1059 }
1c846c1f 1060
5dc0d613 1061 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
79072805 1062
11343788 1063 switch (o->op_type) {
79072805 1064 default:
22c35a8c 1065 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
8990e307 1066 break;
36477c24
PP
1067 /* FALL THROUGH */
1068 case OP_REPEAT:
11343788 1069 if (o->op_flags & OPf_STACKED)
8990e307 1070 break;
5d82c453
GA
1071 goto func_ops;
1072 case OP_SUBSTR:
1073 if (o->op_private == 4)
1074 break;
8990e307
LW
1075 /* FALL THROUGH */
1076 case OP_GVSV:
1077 case OP_WANTARRAY:
1078 case OP_GV:
1079 case OP_PADSV:
1080 case OP_PADAV:
1081 case OP_PADHV:
1082 case OP_PADANY:
1083 case OP_AV2ARYLEN:
8990e307 1084 case OP_REF:
a0d0e21e
LW
1085 case OP_REFGEN:
1086 case OP_SREFGEN:
8990e307
LW
1087 case OP_DEFINED:
1088 case OP_HEX:
1089 case OP_OCT:
1090 case OP_LENGTH:
8990e307
LW
1091 case OP_VEC:
1092 case OP_INDEX:
1093 case OP_RINDEX:
1094 case OP_SPRINTF:
1095 case OP_AELEM:
1096 case OP_AELEMFAST:
1097 case OP_ASLICE:
8990e307
LW
1098 case OP_HELEM:
1099 case OP_HSLICE:
1100 case OP_UNPACK:
1101 case OP_PACK:
8990e307
LW
1102 case OP_JOIN:
1103 case OP_LSLICE:
1104 case OP_ANONLIST:
1105 case OP_ANONHASH:
1106 case OP_SORT:
1107 case OP_REVERSE:
1108 case OP_RANGE:
1109 case OP_FLIP:
1110 case OP_FLOP:
1111 case OP_CALLER:
1112 case OP_FILENO:
1113 case OP_EOF:
1114 case OP_TELL:
1115 case OP_GETSOCKNAME:
1116 case OP_GETPEERNAME:
1117 case OP_READLINK:
1118 case OP_TELLDIR:
1119 case OP_GETPPID:
1120 case OP_GETPGRP:
1121 case OP_GETPRIORITY:
1122 case OP_TIME:
1123 case OP_TMS:
1124 case OP_LOCALTIME:
1125 case OP_GMTIME:
1126 case OP_GHBYNAME:
1127 case OP_GHBYADDR:
1128 case OP_GHOSTENT:
1129 case OP_GNBYNAME:
1130 case OP_GNBYADDR:
1131 case OP_GNETENT:
1132 case OP_GPBYNAME:
1133 case OP_GPBYNUMBER:
1134 case OP_GPROTOENT:
1135 case OP_GSBYNAME:
1136 case OP_GSBYPORT:
1137 case OP_GSERVENT:
1138 case OP_GPWNAM:
1139 case OP_GPWUID:
1140 case OP_GGRNAM:
1141 case OP_GGRGID:
1142 case OP_GETLOGIN:
5d82c453 1143 func_ops:
64aac5a9 1144 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
53e06cf0 1145 useless = OP_DESC(o);
8990e307
LW
1146 break;
1147
1148 case OP_RV2GV:
1149 case OP_RV2SV:
1150 case OP_RV2AV:
1151 case OP_RV2HV:
192587c2 1152 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
11343788 1153 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
8990e307
LW
1154 useless = "a variable";
1155 break;
79072805
LW
1156
1157 case OP_CONST:
7766f137 1158 sv = cSVOPo_sv;
7a52d87a
GS
1159 if (cSVOPo->op_private & OPpCONST_STRICT)
1160 no_bareword_allowed(o);
1161 else {
d008e5eb
GS
1162 if (ckWARN(WARN_VOID)) {
1163 useless = "a constant";
960b4253
MG
1164 /* the constants 0 and 1 are permitted as they are
1165 conventionally used as dummies in constructs like
1166 1 while some_condition_with_side_effects; */
d008e5eb
GS
1167 if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1168 useless = 0;
1169 else if (SvPOK(sv)) {
a52fe3ac
A
1170 /* perl4's way of mixing documentation and code
1171 (before the invention of POD) was based on a
1172 trick to mix nroff and perl code. The trick was
1173 built upon these three nroff macros being used in
1174 void context. The pink camel has the details in
1175 the script wrapman near page 319. */
d008e5eb
GS
1176 if (strnEQ(SvPVX(sv), "di", 2) ||
1177 strnEQ(SvPVX(sv), "ds", 2) ||
1178 strnEQ(SvPVX(sv), "ig", 2))
1179 useless = 0;
1180 }
8990e307
LW
1181 }
1182 }
93c66552 1183 op_null(o); /* don't execute or even remember it */
79072805
LW
1184 break;
1185
1186 case OP_POSTINC:
11343788 1187 o->op_type = OP_PREINC; /* pre-increment is faster */
22c35a8c 1188 o->op_ppaddr = PL_ppaddr[OP_PREINC];
79072805
LW
1189 break;
1190
1191 case OP_POSTDEC:
11343788 1192 o->op_type = OP_PREDEC; /* pre-decrement is faster */
22c35a8c 1193 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
79072805
LW
1194 break;
1195
79072805
LW
1196 case OP_OR:
1197 case OP_AND:
1198 case OP_COND_EXPR:
11343788 1199 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
79072805
LW
1200 scalarvoid(kid);
1201 break;
5aabfad6 1202
a0d0e21e 1203 case OP_NULL:
11343788 1204 if (o->op_flags & OPf_STACKED)
a0d0e21e 1205 break;
5aabfad6 1206 /* FALL THROUGH */
2ebea0a1
GS
1207 case OP_NEXTSTATE:
1208 case OP_DBSTATE:
79072805
LW
1209 case OP_ENTERTRY:
1210 case OP_ENTER:
11343788 1211 if (!(o->op_flags & OPf_KIDS))
79072805 1212 break;
54310121 1213 /* FALL THROUGH */
463ee0b2 1214 case OP_SCOPE:
79072805
LW
1215 case OP_LEAVE:
1216 case OP_LEAVETRY:
a0d0e21e 1217 case OP_LEAVELOOP:
79072805 1218 case OP_LINESEQ:
79072805 1219 case OP_LIST:
11343788 1220 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW
1221 scalarvoid(kid);
1222 break;
c90c0ff4 1223 case OP_ENTEREVAL:
5196be3e 1224 scalarkids(o);
c90c0ff4 1225 break;
5aabfad6 1226 case OP_REQUIRE:
c90c0ff4 1227 /* all requires must return a boolean value */
5196be3e 1228 o->op_flags &= ~OPf_WANT;
d6483035
GS
1229 /* FALL THROUGH */
1230 case OP_SCALAR:
5196be3e 1231 return scalar(o);
a0d0e21e 1232 case OP_SPLIT:
11343788 1233 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
a0d0e21e
LW
1234 if (!kPMOP->op_pmreplroot)
1235 deprecate("implicit split to @_");
1236 }
1237 break;
79072805 1238 }
411caa50
JH
1239 if (useless && ckWARN(WARN_VOID))
1240 Perl_warner(aTHX_ WARN_VOID, "Useless use of %s in void context", useless);
11343788 1241 return o;
79072805
LW
1242}
1243
1244OP *
864dbfa3 1245Perl_listkids(pTHX_ OP *o)
79072805
LW
1246{
1247 OP *kid;
11343788
MB
1248 if (o && o->op_flags & OPf_KIDS) {
1249 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW
1250 list(kid);
1251 }
11343788 1252 return o;
79072805
LW
1253}
1254
1255OP *
864dbfa3 1256Perl_list(pTHX_ OP *o)
79072805
LW
1257{
1258 OP *kid;
1259
a0d0e21e 1260 /* assumes no premature commitment */
3280af22 1261 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
5dc0d613 1262 || o->op_type == OP_RETURN)
7e363e51 1263 {
11343788 1264 return o;
7e363e51 1265 }
79072805 1266
b162f9ea 1267 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS
1268 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1269 {
b162f9ea 1270 return o; /* As if inside SASSIGN */
7e363e51 1271 }
1c846c1f 1272
5dc0d613 1273 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
79072805 1274
11343788 1275 switch (o->op_type) {
79072805
LW
1276 case OP_FLOP:
1277 case OP_REPEAT:
11343788 1278 list(cBINOPo->op_first);
79072805
LW
1279 break;
1280 case OP_OR:
1281 case OP_AND:
1282 case OP_COND_EXPR:
11343788 1283 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
79072805
LW
1284 list(kid);
1285 break;
1286 default:
1287 case OP_MATCH:
8782bef2 1288 case OP_QR:
79072805
LW
1289 case OP_SUBST:
1290 case OP_NULL:
11343788 1291 if (!(o->op_flags & OPf_KIDS))
79072805 1292 break;
11343788
MB
1293 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1294 list(cBINOPo->op_first);
1295 return gen_constant_list(o);
79072805
LW
1296 }
1297 case OP_LIST:
11343788 1298 listkids(o);
79072805
LW
1299 break;
1300 case OP_LEAVE:
1301 case OP_LEAVETRY:
5dc0d613 1302 kid = cLISTOPo->op_first;
54310121 1303 list(kid);
155aba94 1304 while ((kid = kid->op_sibling)) {
54310121
PP
1305 if (kid->op_sibling)
1306 scalarvoid(kid);
1307 else
1308 list(kid);
1309 }
3280af22 1310 WITH_THR(PL_curcop = &PL_compiling);
54310121 1311 break;
748a9306 1312 case OP_SCOPE:
79072805 1313 case OP_LINESEQ:
11343788 1314 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
79072805
LW
1315 if (kid->op_sibling)
1316 scalarvoid(kid);
1317 else
1318 list(kid);
1319 }
3280af22 1320 WITH_THR(PL_curcop = &PL_compiling);
79072805 1321 break;
c90c0ff4
PP
1322 case OP_REQUIRE:
1323 /* all requires must return a boolean value */
5196be3e
MB
1324 o->op_flags &= ~OPf_WANT;
1325 return scalar(o);
79072805 1326 }
11343788 1327 return o;
79072805
LW
1328}
1329
1330OP *
864dbfa3 1331Perl_scalarseq(pTHX_ OP *o)
79072805
LW
1332{
1333 OP *kid;
1334
11343788
MB
1335 if (o) {
1336 if (o->op_type == OP_LINESEQ ||
1337 o->op_type == OP_SCOPE ||
1338 o->op_type == OP_LEAVE ||
1339 o->op_type == OP_LEAVETRY)
463ee0b2 1340 {
11343788 1341 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
ed6116ce 1342 if (kid->op_sibling) {
463ee0b2 1343 scalarvoid(kid);
ed6116ce 1344 }
463ee0b2 1345 }
3280af22 1346 PL_curcop = &PL_compiling;
79072805 1347 }
11343788 1348 o->op_flags &= ~OPf_PARENS;
3280af22 1349 if (PL_hints & HINT_BLOCK_SCOPE)
11343788 1350 o->op_flags |= OPf_PARENS;
79072805 1351 }
8990e307 1352 else
11343788
MB
1353 o = newOP(OP_STUB, 0);
1354 return o;
79072805
LW
1355}
1356
76e3520e 1357STATIC OP *
cea2e8a9 1358S_modkids(pTHX_ OP *o, I32 type)
79072805
LW
1359{
1360 OP *kid;
11343788
MB
1361 if (o && o->op_flags & OPf_KIDS) {
1362 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
463ee0b2 1363 mod(kid, type);
79072805 1364 }
11343788 1365 return o;
79072805
LW
1366}
1367
79072805 1368OP *
864dbfa3 1369Perl_mod(pTHX_ OP *o, I32 type)
79072805
LW
1370{
1371 OP *kid;
2d8e6c8d 1372 STRLEN n_a;
79072805 1373
3280af22 1374 if (!o || PL_error_count)
11343788 1375 return o;
79072805 1376
b162f9ea 1377 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS
1378 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1379 {
b162f9ea 1380 return o;
7e363e51 1381 }
1c846c1f 1382
11343788 1383 switch (o->op_type) {
68dc0745 1384 case OP_UNDEF:
3280af22 1385 PL_modcount++;
5dc0d613 1386 return o;
a0d0e21e 1387 case OP_CONST:
11343788 1388 if (!(o->op_private & (OPpCONST_ARYBASE)))
a0d0e21e 1389 goto nomod;
3280af22 1390 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
7766f137 1391 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
3280af22 1392 PL_eval_start = 0;
a0d0e21e
LW
1393 }
1394 else if (!type) {
3280af22
NIS
1395 SAVEI32(PL_compiling.cop_arybase);
1396 PL_compiling.cop_arybase = 0;
a0d0e21e
LW
1397 }
1398 else if (type == OP_REFGEN)
1399 goto nomod;
1400 else
cea2e8a9 1401 Perl_croak(aTHX_ "That use of $[ is unsupported");
a0d0e21e 1402 break;
5f05dabc 1403 case OP_STUB:
5196be3e 1404 if (o->op_flags & OPf_PARENS)
5f05dabc
PP
1405 break;
1406 goto nomod;
a0d0e21e
LW
1407 case OP_ENTERSUB:
1408 if ((type == OP_UNDEF || type == OP_REFGEN) &&
11343788
MB
1409 !(o->op_flags & OPf_STACKED)) {
1410 o->op_type = OP_RV2CV; /* entersub => rv2cv */
22c35a8c 1411 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
11343788 1412 assert(cUNOPo->op_first->op_type == OP_NULL);
93c66552 1413 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
79072805
LW
1414 break;
1415 }
cd06dffe
GS
1416 else { /* lvalue subroutine call */
1417 o->op_private |= OPpLVAL_INTRO;
e6438c1a 1418 PL_modcount = RETURN_UNLIMITED_NUMBER;
4978d6d9 1419 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
cd06dffe
GS
1420 /* Backward compatibility mode: */
1421 o->op_private |= OPpENTERSUB_INARGS;
1422 break;
1423 }
1424 else { /* Compile-time error message: */
1425 OP *kid = cUNOPo->op_first;
1426 CV *cv;
1427 OP *okid;
1428
1429 if (kid->op_type == OP_PUSHMARK)
1430 goto skip_kids;
1431 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1432 Perl_croak(aTHX_
1433 "panic: unexpected lvalue entersub "
1434 "args: type/targ %ld:%ld",
1435 (long)kid->op_type,kid->op_targ);
1436 kid = kLISTOP->op_first;
1437 skip_kids:
1438 while (kid->op_sibling)
1439 kid = kid->op_sibling;
1440 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1441 /* Indirect call */
1442 if (kid->op_type == OP_METHOD_NAMED
1443 || kid->op_type == OP_METHOD)
1444 {
87d7fd28 1445 UNOP *newop;
cd06dffe
GS
1446
1447 if (kid->op_sibling || kid->op_next != kid) {
1448 yyerror("panic: unexpected optree near method call");
1449 break;
1450 }
1451
87d7fd28 1452 NewOp(1101, newop, 1, UNOP);
349fd7b7
GS
1453 newop->op_type = OP_RV2CV;
1454 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
87d7fd28
GS
1455 newop->op_first = Nullop;
1456 newop->op_next = (OP*)newop;
1457 kid->op_sibling = (OP*)newop;
349fd7b7 1458 newop->op_private |= OPpLVAL_INTRO;
cd06dffe
GS
1459 break;
1460 }
1c846c1f 1461
cd06dffe
GS
1462 if (kid->op_type != OP_RV2CV)
1463 Perl_croak(aTHX_
1464 "panic: unexpected lvalue entersub "
1465 "entry via type/targ %ld:%ld",
1466 (long)kid->op_type,kid->op_targ);
1467 kid->op_private |= OPpLVAL_INTRO;
1468 break; /* Postpone until runtime */
1469 }
1470
1471 okid = kid;
1472 kid = kUNOP->op_first;
1473 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1474 kid = kUNOP->op_first;
1475 if (kid->op_type == OP_NULL)
1476 Perl_croak(aTHX_
1477 "Unexpected constant lvalue entersub "
1478 "entry via type/targ %ld:%ld",
1479 (long)kid->op_type,kid->op_targ);
1480 if (kid->op_type != OP_GV) {
1481 /* Restore RV2CV to check lvalueness */
1482 restore_2cv:
1483 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1484 okid->op_next = kid->op_next;
1485 kid->op_next = okid;
1486 }
1487 else
1488 okid->op_next = Nullop;
1489 okid->op_type = OP_RV2CV;
1490 okid->op_targ = 0;
1491 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1492 okid->op_private |= OPpLVAL_INTRO;
1493 break;
1494 }
1495
638eceb6 1496 cv = GvCV(kGVOP_gv);
1c846c1f 1497 if (!cv)
cd06dffe
GS
1498 goto restore_2cv;
1499 if (CvLVALUE(cv))
1500 break;
1501 }
1502 }
79072805
LW
1503 /* FALL THROUGH */
1504 default:
a0d0e21e
LW
1505 nomod:
1506 /* grep, foreach, subcalls, refgen */
1507 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1508 break;
cea2e8a9 1509 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
638bc118 1510 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
cd06dffe
GS
1511 ? "do block"
1512 : (o->op_type == OP_ENTERSUB
1513 ? "non-lvalue subroutine call"
53e06cf0 1514 : OP_DESC(o))),
22c35a8c 1515 type ? PL_op_desc[type] : "local"));
11343788 1516 return o;
79072805 1517
a0d0e21e
LW
1518 case OP_PREINC:
1519 case OP_PREDEC:
1520 case OP_POW:
1521 case OP_MULTIPLY:
1522 case OP_DIVIDE:
1523 case OP_MODULO:
1524 case OP_REPEAT:
1525 case OP_ADD:
1526 case OP_SUBTRACT:
1527 case OP_CONCAT:
1528 case OP_LEFT_SHIFT:
1529 case OP_RIGHT_SHIFT:
1530 case OP_BIT_AND:
1531 case OP_BIT_XOR:
1532 case OP_BIT_OR:
1533 case OP_I_MULTIPLY:
1534 case OP_I_DIVIDE:
1535 case OP_I_MODULO:
1536 case OP_I_ADD:
1537 case OP_I_SUBTRACT:
11343788 1538 if (!(o->op_flags & OPf_STACKED))
a0d0e21e 1539 goto nomod;
3280af22 1540 PL_modcount++;
a0d0e21e
LW
1541 break;
1542
79072805 1543 case OP_COND_EXPR:
11343788 1544 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
463ee0b2 1545 mod(kid, type);
79072805
LW
1546 break;
1547
1548 case OP_RV2AV:
1549 case OP_RV2HV:
93af7a87 1550 if (!type && cUNOPo->op_first->op_type != OP_GV)
cea2e8a9 1551 Perl_croak(aTHX_ "Can't localize through a reference");
11343788 1552 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
e6438c1a 1553 PL_modcount = RETURN_UNLIMITED_NUMBER;
11343788 1554 return o; /* Treat \(@foo) like ordinary list. */
748a9306
LW
1555 }
1556 /* FALL THROUGH */
79072805 1557 case OP_RV2GV:
5dc0d613 1558 if (scalar_mod_type(o, type))
3fe9a6f1 1559 goto nomod;
11343788 1560 ref(cUNOPo->op_first, o->op_type);
79072805 1561 /* FALL THROUGH */
79072805
LW
1562 case OP_ASLICE:
1563 case OP_HSLICE:
78f9721b
SM
1564 if (type == OP_LEAVESUBLV)
1565 o->op_private |= OPpMAYBE_LVSUB;
1566 /* FALL THROUGH */
1567 case OP_AASSIGN:
93a17b20
LW
1568 case OP_NEXTSTATE:
1569 case OP_DBSTATE:
a0d0e21e 1570 case OP_CHOMP:
e6438c1a 1571 PL_modcount = RETURN_UNLIMITED_NUMBER;
79072805 1572 break;
463ee0b2 1573 case OP_RV2SV:
11343788 1574 if (!type && cUNOPo->op_first->op_type != OP_GV)
cea2e8a9 1575 Perl_croak(aTHX_ "Can't localize through a reference");
aeea060c 1576 ref(cUNOPo->op_first, o->op_type);
463ee0b2 1577 /* FALL THROUGH */
79072805 1578 case OP_GV:
463ee0b2 1579 case OP_AV2ARYLEN:
3280af22 1580 PL_hints |= HINT_BLOCK_SCOPE;
463ee0b2 1581 case OP_SASSIGN:
bf4b1e52
GS
1582 case OP_ANDASSIGN:
1583 case OP_ORASSIGN:
8990e307 1584 case OP_AELEMFAST:
3280af22 1585 PL_modcount++;
8990e307
LW
1586 break;
1587
748a9306
LW
1588 case OP_PADAV:
1589 case OP_PADHV:
e6438c1a 1590 PL_modcount = RETURN_UNLIMITED_NUMBER;
5196be3e
MB
1591 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1592 return o; /* Treat \(@foo) like ordinary list. */
1593 if (scalar_mod_type(o, type))
3fe9a6f1 1594 goto nomod;
78f9721b
SM
1595 if (type == OP_LEAVESUBLV)
1596 o->op_private |= OPpMAYBE_LVSUB;
748a9306
LW
1597 /* FALL THROUGH */
1598 case OP_PADSV:
3280af22 1599 PL_modcount++;
748a9306 1600 if (!type)
cea2e8a9 1601 Perl_croak(aTHX_ "Can't localize lexical variable %s",
2d8e6c8d 1602 SvPV(*av_fetch(PL_comppad_name, o->op_targ, 4), n_a));
463ee0b2
LW
1603 break;
1604
4d1ff10f 1605#ifdef USE_5005THREADS
2faa37cc 1606 case OP_THREADSV:
533c011a 1607 PL_modcount++; /* XXX ??? */
554b3eca 1608 break;
4d1ff10f 1609#endif /* USE_5005THREADS */
554b3eca 1610
748a9306
LW
1611 case OP_PUSHMARK:
1612 break;
a0d0e21e 1613
69969c6f
SB
1614 case OP_KEYS:
1615 if (type != OP_SASSIGN)
1616 goto nomod;
5d82c453
GA
1617 goto lvalue_func;
1618 case OP_SUBSTR:
1619 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1620 goto nomod;
5f05dabc 1621 /* FALL THROUGH */
a0d0e21e 1622 case OP_POS:
463ee0b2 1623 case OP_VEC:
78f9721b
SM
1624 if (type == OP_LEAVESUBLV)
1625 o->op_private |= OPpMAYBE_LVSUB;
5d82c453 1626 lvalue_func:
11343788
MB
1627 pad_free(o->op_targ);
1628 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
5dc0d613 1629 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
11343788
MB
1630 if (o->op_flags & OPf_KIDS)
1631 mod(cBINOPo->op_first->op_sibling, type);
463ee0b2 1632 break;
a0d0e21e 1633
463ee0b2
LW
1634 case OP_AELEM:
1635 case OP_HELEM:
11343788 1636 ref(cBINOPo->op_first, o->op_type);
68dc0745 1637 if (type == OP_ENTERSUB &&
5dc0d613
MB
1638 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1639 o->op_private |= OPpLVAL_DEFER;
78f9721b
SM
1640 if (type == OP_LEAVESUBLV)
1641 o->op_private |= OPpMAYBE_LVSUB;
3280af22 1642 PL_modcount++;
463ee0b2
LW
1643 break;
1644
1645 case OP_SCOPE:
1646 case OP_LEAVE:
1647 case OP_ENTER:
78f9721b 1648 case OP_LINESEQ:
11343788
MB
1649 if (o->op_flags & OPf_KIDS)
1650 mod(cLISTOPo->op_last, type);
a0d0e21e
LW
1651 break;
1652
1653 case OP_NULL:
638bc118
GS
1654 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1655 goto nomod;
1656 else if (!(o->op_flags & OPf_KIDS))
463ee0b2 1657 break;
11343788
MB
1658 if (o->op_targ != OP_LIST) {
1659 mod(cBINOPo->op_first, type);
a0d0e21e
LW
1660 break;
1661 }
1662 /* FALL THROUGH */
463ee0b2 1663 case OP_LIST:
11343788 1664 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
463ee0b2
LW
1665 mod(kid, type);
1666 break;
78f9721b
SM
1667
1668 case OP_RETURN:
1669 if (type != OP_LEAVESUBLV)
1670 goto nomod;
1671 break; /* mod()ing was handled by ck_return() */
463ee0b2 1672 }
78f9721b
SM
1673 if (type != OP_LEAVESUBLV)
1674 o->op_flags |= OPf_MOD;
a0d0e21e
LW
1675
1676 if (type == OP_AASSIGN || type == OP_SASSIGN)
11343788 1677 o->op_flags |= OPf_SPECIAL|OPf_REF;
a0d0e21e 1678 else if (!type) {
11343788
MB
1679 o->op_private |= OPpLVAL_INTRO;
1680 o->op_flags &= ~OPf_SPECIAL;
3280af22 1681 PL_hints |= HINT_BLOCK_SCOPE;
463ee0b2 1682 }
78f9721b
SM
1683 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1684 && type != OP_LEAVESUBLV)
11343788
MB
1685 o->op_flags |= OPf_REF;
1686 return o;
463ee0b2
LW
1687}
1688
864dbfa3 1689STATIC bool
cea2e8a9 1690S_scalar_mod_type(pTHX_ OP *o, I32 type)
3fe9a6f1
PP
1691{
1692 switch (type) {
1693 case OP_SASSIGN:
5196be3e 1694 if (o->op_type == OP_RV2GV)
3fe9a6f1
PP
1695 return FALSE;
1696 /* FALL THROUGH */
1697 case OP_PREINC:
1698 case OP_PREDEC:
1699 case OP_POSTINC:
1700 case OP_POSTDEC:
1701 case OP_I_PREINC:
1702 case OP_I_PREDEC:
1703 case OP_I_POSTINC:
1704 case OP_I_POSTDEC:
1705 case OP_POW:
1706 case OP_MULTIPLY:
1707 case OP_DIVIDE:
1708 case OP_MODULO:
1709 case OP_REPEAT:
1710 case OP_ADD:
1711 case OP_SUBTRACT:
1712 case OP_I_MULTIPLY:
1713 case OP_I_DIVIDE:
1714 case OP_I_MODULO:
1715 case OP_I_ADD:
1716 case OP_I_SUBTRACT:
1717 case OP_LEFT_SHIFT:
1718 case OP_RIGHT_SHIFT:
1719 case OP_BIT_AND:
1720 case OP_BIT_XOR:
1721 case OP_BIT_OR:
1722 case OP_CONCAT:
1723 case OP_SUBST:
1724 case OP_TRANS:
49e9fbe6
GS
1725 case OP_READ:
1726 case OP_SYSREAD:
1727 case OP_RECV:
bf4b1e52
GS
1728 case OP_ANDASSIGN:
1729 case OP_ORASSIGN:
3fe9a6f1
PP
1730 return TRUE;
1731 default:
1732 return FALSE;
1733 }
1734}
1735
35cd451c 1736STATIC bool
cea2e8a9 1737S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
35cd451c
GS
1738{
1739 switch (o->op_type) {
1740 case OP_PIPE_OP:
1741 case OP_SOCKPAIR:
1742 if (argnum == 2)
1743 return TRUE;
1744 /* FALL THROUGH */
1745 case OP_SYSOPEN:
1746 case OP_OPEN:
ded8aa31 1747 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
35cd451c
GS
1748 case OP_SOCKET:
1749 case OP_OPEN_DIR:
1750 case OP_ACCEPT:
1751 if (argnum == 1)
1752 return TRUE;
1753 /* FALL THROUGH */
1754 default:
1755 return FALSE;
1756 }
1757}
1758
463ee0b2 1759OP *
864dbfa3 1760Perl_refkids(pTHX_ OP *o, I32 type)
463ee0b2
LW
1761{
1762 OP *kid;
11343788
MB
1763 if (o && o->op_flags & OPf_KIDS) {
1764 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
463ee0b2
LW
1765 ref(kid, type);
1766 }
11343788 1767 return o;
463ee0b2
LW
1768}
1769
1770OP *
864dbfa3 1771Perl_ref(pTHX_ OP *o, I32 type)
463ee0b2
LW
1772{
1773 OP *kid;
463ee0b2 1774
3280af22 1775 if (!o || PL_error_count)
11343788 1776 return o;
463ee0b2 1777
11343788 1778 switch (o->op_type) {
a0d0e21e 1779 case OP_ENTERSUB:
afebc493 1780 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
11343788
MB
1781 !(o->op_flags & OPf_STACKED)) {
1782 o->op_type = OP_RV2CV; /* entersub => rv2cv */
22c35a8c 1783 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
11343788 1784 assert(cUNOPo->op_first->op_type == OP_NULL);
93c66552 1785 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
11343788 1786 o->op_flags |= OPf_SPECIAL;
8990e307
LW
1787 }
1788 break;
aeea060c 1789
463ee0b2 1790 case OP_COND_EXPR:
11343788 1791 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
463ee0b2
LW
1792 ref(kid, type);
1793 break;
8990e307 1794 case OP_RV2SV:
35cd451c
GS
1795 if (type == OP_DEFINED)
1796 o->op_flags |= OPf_SPECIAL; /* don't create GV */
11343788 1797 ref(cUNOPo->op_first, o->op_type);
4633a7c4
LW
1798 /* FALL THROUGH */
1799 case OP_PADSV:
5f05dabc 1800 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5dc0d613
MB
1801 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1802 : type == OP_RV2HV ? OPpDEREF_HV
1803 : OPpDEREF_SV);
11343788 1804 o->op_flags |= OPf_MOD;
a0d0e21e 1805 }
8990e307 1806 break;
1c846c1f 1807
2faa37cc 1808 case OP_THREADSV:
a863c7d1
MB
1809 o->op_flags |= OPf_MOD; /* XXX ??? */
1810 break;
1811
463ee0b2
LW
1812 case OP_RV2AV:
1813 case OP_RV2HV:
aeea060c 1814 o->op_flags |= OPf_REF;
8990e307 1815 /* FALL THROUGH */
463ee0b2 1816 case OP_RV2GV:
35cd451c
GS
1817 if (type == OP_DEFINED)
1818 o->op_flags |= OPf_SPECIAL; /* don't create GV */
11343788 1819 ref(cUNOPo->op_first, o->op_type);
463ee0b2 1820 break;
8990e307 1821
463ee0b2
LW
1822 case OP_PADAV:
1823 case OP_PADHV:
aeea060c 1824 o->op_flags |= OPf_REF;
79072805 1825 break;
aeea060c 1826
8990e307 1827 case OP_SCALAR:
79072805 1828 case OP_NULL:
11343788 1829 if (!(o->op_flags & OPf_KIDS))
463ee0b2 1830 break;
11343788 1831 ref(cBINOPo->op_first, type);
79072805
LW
1832 break;
1833 case OP_AELEM:
1834 case OP_HELEM:
11343788 1835 ref(cBINOPo->op_first, o->op_type);
5f05dabc 1836 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5dc0d613
MB
1837 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1838 : type == OP_RV2HV ? OPpDEREF_HV
1839 : OPpDEREF_SV);
11343788 1840 o->op_flags |= OPf_MOD;
8990e307 1841 }
79072805
LW
1842 break;
1843
463ee0b2 1844 case OP_SCOPE:
79072805
LW
1845 case OP_LEAVE:
1846 case OP_ENTER:
8990e307 1847 case OP_LIST:
11343788 1848 if (!(o->op_flags & OPf_KIDS))
79072805 1849 break;
11343788 1850 ref(cLISTOPo->op_last, type);
79072805 1851 break;
a0d0e21e
LW
1852 default:
1853 break;
79072805 1854 }
11343788 1855 return scalar(o);
8990e307 1856
79072805
LW
1857}
1858
09bef843
SB
1859STATIC OP *
1860S_dup_attrlist(pTHX_ OP *o)
1861{
1862 OP *rop = Nullop;
1863
1864 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1865 * where the first kid is OP_PUSHMARK and the remaining ones
1866 * are OP_CONST. We need to push the OP_CONST values.
1867 */
1868 if (o->op_type == OP_CONST)
1869 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1870 else {
1871 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1872 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1873 if (o->op_type == OP_CONST)
1874 rop = append_elem(OP_LIST, rop,
1875 newSVOP(OP_CONST, o->op_flags,
1876 SvREFCNT_inc(cSVOPo->op_sv)));
1877 }
1878 }
1879 return rop;
1880}
1881
1882STATIC void
1883S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
1884{
09bef843
SB
1885 SV *stashsv;
1886
1887 /* fake up C<use attributes $pkg,$rv,@attrs> */
1888 ENTER; /* need to protect against side-effects of 'use' */
1889 SAVEINT(PL_expect);
a9164de8 1890 if (stash)
09bef843
SB
1891 stashsv = newSVpv(HvNAME(stash), 0);
1892 else
1893 stashsv = &PL_sv_no;
e4783991 1894
09bef843 1895#define ATTRSMODULE "attributes"
e4783991
GS
1896
1897 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1898 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1899 Nullsv,
1900 prepend_elem(OP_LIST,
1901 newSVOP(OP_CONST, 0, stashsv),
1902 prepend_elem(OP_LIST,
1903 newSVOP(OP_CONST, 0,
1904 newRV(target)),
1905 dup_attrlist(attrs))));
09bef843
SB
1906 LEAVE;
1907}
1908
be3174d2
GS
1909void
1910Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
1911 char *attrstr, STRLEN len)
1912{
1913 OP *attrs = Nullop;
1914
1915 if (!len) {
1916 len = strlen(attrstr);
1917 }
1918
1919 while (len) {
1920 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1921 if (len) {
1922 char *sstr = attrstr;
1923 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1924 attrs = append_elem(OP_LIST, attrs,
1925 newSVOP(OP_CONST, 0,
1926 newSVpvn(sstr, attrstr-sstr)));
1927 }
1928 }
1929
1930 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1931 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1932 Nullsv, prepend_elem(OP_LIST,
1933 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1934 prepend_elem(OP_LIST,
1935 newSVOP(OP_CONST, 0,
1936 newRV((SV*)cv)),
1937 attrs)));
1938}
1939
09bef843
SB
1940STATIC OP *
1941S_my_kid(pTHX_ OP *o, OP *attrs)
93a17b20
LW
1942{
1943 OP *kid;
93a17b20
LW
1944 I32 type;
1945
3280af22 1946 if (!o || PL_error_count)
11343788 1947 return o;
93a17b20 1948
11343788 1949 type = o->op_type;
93a17b20 1950 if (type == OP_LIST) {
11343788 1951 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
09bef843 1952 my_kid(kid, attrs);
dab48698 1953 } else if (type == OP_UNDEF) {
7766148a 1954 return o;
77ca0c92
LW
1955 } else if (type == OP_RV2SV || /* "our" declaration */
1956 type == OP_RV2AV ||
1957 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
0256094b
DM
1958 if (attrs) {
1959 GV *gv = cGVOPx_gv(cUNOPo->op_first);
1960 PL_in_my = FALSE;
1961 PL_in_my_stash = Nullhv;
1962 apply_attrs(GvSTASH(gv),
1963 (type == OP_RV2SV ? GvSV(gv) :
1964 type == OP_RV2AV ? (SV*)GvAV(gv) :
1965 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1966 attrs);
1967 }
192587c2 1968 o->op_private |= OPpOUR_INTRO;
77ca0c92 1969 return o;
dab48698 1970 } else if (type != OP_PADSV &&
93a17b20
LW
1971 type != OP_PADAV &&
1972 type != OP_PADHV &&
1973 type != OP_PUSHMARK)
1974 {
eb64745e 1975 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
53e06cf0 1976 OP_DESC(o),
eb64745e 1977 PL_in_my == KEY_our ? "our" : "my"));
11343788 1978 return o;
93a17b20 1979 }
09bef843
SB
1980 else if (attrs && type != OP_PUSHMARK) {
1981 HV *stash;
1982 SV *padsv;
1983 SV **namesvp;
1984
eb64745e
GS
1985 PL_in_my = FALSE;
1986 PL_in_my_stash = Nullhv;
1987
09bef843
SB
1988 /* check for C<my Dog $spot> when deciding package */
1989 namesvp = av_fetch(PL_comppad_name, o->op_targ, FALSE);
a9164de8 1990 if (namesvp && *namesvp && (SvFLAGS(*namesvp) & SVpad_TYPED))
09bef843
SB
1991 stash = SvSTASH(*namesvp);
1992 else
1993 stash = PL_curstash;
1994 padsv = PAD_SV(o->op_targ);
1995 apply_attrs(stash, padsv, attrs);
1996 }
11343788
MB
1997 o->op_flags |= OPf_MOD;
1998 o->op_private |= OPpLVAL_INTRO;
1999 return o;
93a17b20
LW
2000}
2001
2002OP *
09bef843
SB
2003Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2004{
2005 if (o->op_flags & OPf_PARENS)
2006 list(o);
09bef843
SB
2007 if (attrs)
2008 SAVEFREEOP(attrs);
eb64745e
GS
2009 o = my_kid(o, attrs);
2010 PL_in_my = FALSE;
2011 PL_in_my_stash = Nullhv;
2012 return o;
09bef843
SB
2013}
2014
2015OP *
2016Perl_my(pTHX_ OP *o)
2017{
2018 return my_kid(o, Nullop);
2019}
2020
2021OP *
864dbfa3 2022Perl_sawparens(pTHX_ OP *o)
79072805
LW
2023{
2024 if (o)
2025 o->op_flags |= OPf_PARENS;
2026 return o;
2027}
2028
2029OP *
864dbfa3 2030Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
79072805 2031{
11343788 2032 OP *o;
79072805 2033
e476b1b5 2034 if (ckWARN(WARN_MISC) &&
599cee73
PM
2035 (left->op_type == OP_RV2AV ||
2036 left->op_type == OP_RV2HV ||
2037 left->op_type == OP_PADAV ||
2038 left->op_type == OP_PADHV)) {
22c35a8c 2039 char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
599cee73
PM
2040 right->op_type == OP_TRANS)
2041 ? right->op_type : OP_MATCH];
dff6d3cd
GS
2042 const char *sample = ((left->op_type == OP_RV2AV ||
2043 left->op_type == OP_PADAV)
2044 ? "@array" : "%hash");
e476b1b5 2045 Perl_warner(aTHX_ WARN_MISC,
1c846c1f 2046 "Applying %s to %s will act on scalar(%s)",
599cee73 2047 desc, sample, sample);
2ae324a7
PP
2048 }
2049
de4bf5b3
G
2050 if (!(right->op_flags & OPf_STACKED) &&
2051 (right->op_type == OP_MATCH ||
79072805 2052 right->op_type == OP_SUBST ||
de4bf5b3 2053 right->op_type == OP_TRANS)) {
79072805 2054 right->op_flags |= OPf_STACKED;
55d27857
RG
2055 if ((right->op_type != OP_MATCH &&
2056 ! (right->op_type == OP_TRANS &&
2057 right->op_private & OPpTRANS_IDENTICAL)) ||
2058 /* if SV has magic, then match on original SV, not on its copy.
2059 see note in pp_helem() */
2060 (right->op_type == OP_MATCH &&
2061 (left->op_type == OP_AELEM ||
2062 left->op_type == OP_HELEM ||
2063 left->op_type == OP_AELEMFAST)))
463ee0b2 2064 left = mod(left, right->op_type);
79072805 2065 if (right->op_type == OP_TRANS)
11343788 2066 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
79072805 2067 else
11343788 2068 o = prepend_elem(right->op_type, scalar(left), right);
79072805 2069 if (type == OP_NOT)
11343788
MB
2070 return newUNOP(OP_NOT, 0, scalar(o));
2071 return o;
79072805
LW
2072 }
2073 else
2074 return bind_match(type, left,
2075 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
2076}
2077
2078OP *
864dbfa3 2079Perl_invert(pTHX_ OP *o)
79072805 2080{
11343788
MB
2081 if (!o)
2082 return o;
79072805 2083 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
11343788 2084 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
79072805
LW
2085}
2086
2087OP *
864dbfa3 2088Perl_scope(pTHX_ OP *o)
79072805
LW
2089{
2090 if (o) {
3280af22 2091 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
463ee0b2
LW
2092 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2093 o->op_type = OP_LEAVE;
22c35a8c 2094 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
463ee0b2
LW
2095 }
2096 else {
2097 if (o->op_type == OP_LINESEQ) {
2098 OP *kid;
2099 o->op_type = OP_SCOPE;
22c35a8c 2100 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
c3ed7a6a
GS
2101 kid = ((LISTOP*)o)->op_first;
2102 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
93c66552 2103 op_null(kid);
463ee0b2
LW
2104 }
2105 else
748a9306 2106 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
463ee0b2 2107 }
79072805
LW
2108 }
2109 return o;
2110}
2111
b3ac6de7 2112void
864dbfa3 2113Perl_save_hints(pTHX)
b3ac6de7 2114{
3280af22
NIS
2115 SAVEI32(PL_hints);
2116 SAVESPTR(GvHV(PL_hintgv));
2117 GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
2118 SAVEFREESV(GvHV(PL_hintgv));
b3ac6de7
IZ
2119}
2120
a0d0e21e 2121int
864dbfa3 2122Perl_block_start(pTHX_ int full)
79072805 2123{
3280af22 2124 int retval = PL_savestack_ix;
b3ac6de7 2125
3280af22 2126 SAVEI32(PL_comppad_name_floor);
43d4d5c6
GS
2127 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
2128 if (full)
2129 PL_comppad_name_fill = PL_comppad_name_floor;
2130 if (PL_comppad_name_floor < 0)
2131 PL_comppad_name_floor = 0;
3280af22
NIS
2132 SAVEI32(PL_min_intro_pending);
2133 SAVEI32(PL_max_intro_pending);
2134 PL_min_intro_pending = 0;
2135 SAVEI32(PL_comppad_name_fill);
2136 SAVEI32(PL_padix_floor);
2137 PL_padix_floor = PL_padix;
2138 PL_pad_reset_pending = FALSE;
b3ac6de7 2139 SAVEHINTS();
3280af22 2140 PL_hints &= ~HINT_BLOCK_SCOPE;
1c846c1f 2141 SAVESPTR(PL_compiling.cop_warnings);
0453d815 2142 if (! specialWARN(PL_compiling.cop_warnings)) {
599cee73
PM
2143 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2144 SAVEFREESV(PL_compiling.cop_warnings) ;
2145 }
ac27b0f5
NIS
2146 SAVESPTR(PL_compiling.cop_io);
2147 if (! specialCopIO(PL_compiling.cop_io)) {
2148 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
2149 SAVEFREESV(PL_compiling.cop_io) ;
2150 }
a0d0e21e
LW
2151 return retval;
2152}
2153
2154OP*
864dbfa3 2155Perl_block_end(pTHX_ I32 floor, OP *seq)
a0d0e21e 2156{
3280af22 2157 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
d8a34499
IK
2158 line_t copline = PL_copline;
2159 /* there should be a nextstate in every block */
2160 OP* retval = seq ? scalarseq(seq) : newSTATEOP(0, Nullch, seq);
2161 PL_copline = copline; /* XXX newSTATEOP may reset PL_copline */
e9818f4e 2162 LEAVE_SCOPE(floor);
3280af22 2163 PL_pad_reset_pending = FALSE;
e24b16f9 2164 PL_compiling.op_private = PL_hints;
a0d0e21e 2165 if (needblockscope)
3280af22
NIS
2166 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2167 pad_leavemy(PL_comppad_name_fill);
2168 PL_cop_seqmax++;
a0d0e21e
LW
2169 return retval;
2170}
2171
76e3520e 2172STATIC OP *
cea2e8a9 2173S_newDEFSVOP(pTHX)
54b9620d 2174{
4d1ff10f 2175#ifdef USE_5005THREADS
54b9620d
MB
2176 OP *o = newOP(OP_THREADSV, 0);
2177 o->op_targ = find_threadsv("_");
2178 return o;
2179#else
3280af22 2180 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
4d1ff10f 2181#endif /* USE_5005THREADS */
54b9620d
MB
2182}
2183
a0d0e21e 2184void
864dbfa3 2185Perl_newPROG(pTHX_ OP *o)
a0d0e21e 2186{
3280af22 2187 if (PL_in_eval) {
b295d113
TH
2188 if (PL_eval_root)
2189 return;
faef0170
HS
2190 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2191 ((PL_in_eval & EVAL_KEEPERR)
2192 ? OPf_SPECIAL : 0), o);
3280af22 2193 PL_eval_start = linklist(PL_eval_root);
7934575e
GS
2194 PL_eval_root->op_private |= OPpREFCOUNTED;
2195 OpREFCNT_set(PL_eval_root, 1);
3280af22 2196 PL_eval_root->op_next = 0;
a2efc822 2197 CALL_PEEP(PL_eval_start);
a0d0e21e
LW
2198 }
2199 else {
5dc0d613 2200 if (!o)
a0d0e21e 2201 return;
3280af22
NIS
2202 PL_main_root = scope(sawparens(scalarvoid(o)));
2203 PL_curcop = &PL_compiling;
2204 PL_main_start = LINKLIST(PL_main_root);
7934575e
GS
2205 PL_main_root->op_private |= OPpREFCOUNTED;
2206 OpREFCNT_set(PL_main_root, 1);
3280af22 2207 PL_main_root->op_next = 0;
a2efc822 2208 CALL_PEEP(PL_main_start);
3280af22 2209 PL_compcv = 0;
3841441e 2210
4fdae800 2211 /* Register with debugger */
84902520 2212 if (PERLDB_INTER) {
864dbfa3 2213 CV *cv = get_cv("DB::postponed", FALSE);
3841441e
CS
2214 if (cv) {
2215 dSP;
924508f0 2216 PUSHMARK(SP);
cc49e20b 2217 XPUSHs((SV*)CopFILEGV(&PL_compiling));
3841441e 2218 PUTBACK;
864dbfa3 2219 call_sv((SV*)cv, G_DISCARD);
3841441e
CS
2220 }
2221 }
79072805 2222 }
79072805
LW
2223}
2224
2225OP *
864dbfa3 2226Perl_localize(pTHX_ OP *o, I32 lex)
79072805
LW
2227{
2228 if (o->op_flags & OPf_PARENS)
2229 list(o);
8990e307 2230 else {
64420d0d
JH
2231 if (ckWARN(WARN_PARENTHESIS)
2232 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
2233 {
2234 char *s = PL_bufptr;
2235
2236 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ", *s)))
2237 s++;
2238
a0d0e21e 2239 if (*s == ';' || *s == '=')
eb64745e
GS
2240 Perl_warner(aTHX_ WARN_PARENTHESIS,
2241 "Parentheses missing around \"%s\" list",
2242 lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
8990e307
LW
2243 }
2244 }
93a17b20 2245 if (lex)
eb64745e 2246 o = my(o);
93a17b20 2247 else
eb64745e
GS
2248 o = mod(o, OP_NULL); /* a bit kludgey */
2249 PL_in_my = FALSE;
2250 PL_in_my_stash = Nullhv;
2251 return o;
79072805
LW
2252}
2253
2254OP *
864dbfa3 2255Perl_jmaybe(pTHX_ OP *o)
79072805
LW
2256{
2257 if (o->op_type == OP_LIST) {
554b3eca 2258 OP *o2;
4d1ff10f 2259#ifdef USE_5005THREADS
2faa37cc 2260 o2 = newOP(OP_THREADSV, 0);
54b9620d 2261 o2->op_targ = find_threadsv(";");
554b3eca
MB
2262#else
2263 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
4d1ff10f 2264#endif /* USE_5005THREADS */
554b3eca 2265 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
79072805
LW
2266 }
2267 return o;
2268}
2269
2270OP *
864dbfa3 2271Perl_fold_constants(pTHX_ register OP *o)
79072805
LW
2272{
2273 register OP *curop;
2274 I32 type = o->op_type;
748a9306 2275 SV *sv;
79072805 2276
22c35a8c 2277 if (PL_opargs[type] & OA_RETSCALAR)
79072805 2278 scalar(o);
b162f9ea 2279 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
ed6116ce 2280 o->op_targ = pad_alloc(type, SVs_PADTMP);
79072805 2281
eac055e9
GS
2282 /* integerize op, unless it happens to be C<-foo>.
2283 * XXX should pp_i_negate() do magic string negation instead? */
2284 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2285 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2286 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2287 {
22c35a8c 2288 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
eac055e9 2289 }
85e6fe83 2290
22c35a8c 2291 if (!(PL_opargs[type] & OA_FOLDCONST))
79072805
LW
2292 goto nope;
2293
de939608 2294 switch (type) {
7a52d87a
GS
2295 case OP_NEGATE:
2296 /* XXX might want a ck_negate() for this */
2297 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2298 break;
de939608
CS
2299 case OP_SPRINTF:
2300 case OP_UCFIRST:
2301 case OP_LCFIRST:
2302 case OP_UC:
2303 case OP_LC:
69dcf70c
MB
2304 case OP_SLT:
2305 case OP_SGT:
2306 case OP_SLE:
2307 case OP_SGE:
2308 case OP_SCMP:
2de3dbcc
JH
2309 /* XXX what about the numeric ops? */
2310 if (PL_hints & HINT_LOCALE)
de939608
CS
2311 goto nope;
2312 }
2313
3280af22 2314 if (PL_error_count)
a0d0e21e
LW
2315 goto nope; /* Don't try to run w/ errors */
2316
79072805 2317 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
11fa937b
GS
2318 if ((curop->op_type != OP_CONST ||
2319 (curop->op_private & OPpCONST_BARE)) &&
7a52d87a
GS
2320 curop->op_type != OP_LIST &&
2321 curop->op_type != OP_SCALAR &&
2322 curop->op_type != OP_NULL &&
2323 curop->op_type != OP_PUSHMARK)
2324 {
79072805
LW
2325 goto nope;
2326 }
2327 }
2328
2329 curop = LINKLIST(o);
2330 o->op_next = 0;
533c011a 2331 PL_op = curop;
cea2e8a9 2332 CALLRUNOPS(aTHX);
3280af22 2333 sv = *(PL_stack_sp--);
748a9306 2334 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
79072805 2335 pad_swipe(o->op_targ);
748a9306
LW
2336 else if (SvTEMP(sv)) { /* grab mortal temp? */
2337 (void)SvREFCNT_inc(sv);
2338 SvTEMP_off(sv);
85e6fe83 2339 }
79072805
LW
2340 op_free(o);
2341 if (type == OP_RV2GV)
b1cb66bf 2342 return newGVOP(OP_GV, 0, (GV*)sv);
748a9306 2343 else {
ee580363
GS
2344 /* try to smush double to int, but don't smush -2.0 to -2 */
2345 if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
2346 type != OP_NEGATE)
2347 {
28e5dec8
JH
2348#ifdef PERL_PRESERVE_IVUV
2349 /* Only bother to attempt to fold to IV if
2350 most operators will benefit */
2351 SvIV_please(sv);
2352#endif
748a9306 2353 }
a86a20aa 2354 return newSVOP(OP_CONST, 0, sv);
748a9306 2355 }
aeea060c 2356
79072805 2357 nope:
22c35a8c 2358 if (!(PL_opargs[type] & OA_OTHERINT))
79072805 2359 return o;
79072805 2360
3280af22 2361 if (!(PL_hints & HINT_INTEGER)) {
4bb9f687
GS
2362 if (type == OP_MODULO
2363 || type == OP_DIVIDE
2364 || !(o->op_flags & OPf_KIDS))
2365 {
85e6fe83 2366 return o;
4bb9f687 2367 }
85e6fe83
LW
2368
2369 for (curop = ((UNOP*)o)->op_first; curop; curop = curop->op_sibling) {
2370 if (curop->op_type == OP_CONST) {
b1cb66bf 2371 if (SvIOK(((SVOP*)curop)->op_sv))
85e6fe83
LW
2372 continue;
2373 return o;
2374 }
22c35a8c 2375 if (PL_opargs[curop->op_type] & OA_RETINTEGER)
79072805
LW
2376 continue;
2377 return o;
2378 }
22c35a8c 2379 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
79072805
LW
2380 }
2381
79072805
LW
2382 return o;
2383}
2384
2385OP *
864dbfa3 2386Perl_gen_constant_list(pTHX_ register OP *o)
79072805
LW
2387{
2388 register OP *curop;
3280af22 2389 I32 oldtmps_floor = PL_tmps_floor;
79072805 2390
a0d0e21e 2391 list(o);
3280af22 2392 if (PL_error_count)
a0d0e21e
LW
2393 return o; /* Don't attempt to run with errors */
2394
533c011a 2395 PL_op = curop = LINKLIST(o);
a0d0e21e 2396 o->op_next = 0;
a2efc822 2397 CALL_PEEP(curop);
cea2e8a9
GS
2398 pp_pushmark();
2399 CALLRUNOPS(aTHX);
533c011a 2400 PL_op = curop;
cea2e8a9 2401 pp_anonlist();
3280af22 2402 PL_tmps_floor = oldtmps_floor;
79072805
LW
2403
2404 o->op_type = OP_RV2AV;
22c35a8c 2405 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
79072805 2406 curop = ((UNOP*)o)->op_first;
3280af22 2407 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
79072805 2408 op_free(curop);
79072805
LW
2409 linklist(o);
2410 return list(o);
2411}
2412
2413OP *
864dbfa3 2414Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
79072805 2415{
11343788
MB
2416 if (!o || o->op_type != OP_LIST)
2417 o = newLISTOP(OP_LIST, 0, o, Nullop);
748a9306 2418 else
5dc0d613 2419 o->op_flags &= ~OPf_WANT;
79072805 2420
22c35a8c 2421 if (!(PL_opargs[type] & OA_MARK))
93c66552 2422 op_null(cLISTOPo->op_first);
8990e307 2423
11343788 2424 o->op_type = type;
22c35a8c 2425 o->op_ppaddr = PL_ppaddr[type];
11343788 2426 o->op_flags |= flags;
79072805 2427
11343788
MB
2428 o = CHECKOP(type, o);
2429 if (o->op_type != type)
2430 return o;
79072805 2431
11343788 2432 return fold_constants(o);
79072805
LW
2433}
2434
2435/* List constructors */
2436
2437OP *
864dbfa3 2438Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW
2439{
2440 if (!first)
2441 return last;
8990e307
LW
2442
2443 if (!last)
79072805 2444 return first;
8990e307 2445
155aba94
GS
2446 if (first->op_type != type
2447 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2448 {
2449 return newLISTOP(type, 0, first, last);
2450 }
79072805 2451
a0d0e21e
LW
2452 if (first->op_flags & OPf_KIDS)
2453 ((LISTOP*)first)->op_last->op_sibling = last;
2454 else {
2455 first->op_flags |= OPf_KIDS;
2456 ((LISTOP*)first)->op_first = last;
2457 }
2458 ((LISTOP*)first)->op_last = last;
a0d0e21e 2459 return first;
79072805
LW
2460}
2461
2462OP *
864dbfa3 2463Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
79072805
LW
2464{
2465 if (!first)
2466 return (OP*)last;
8990e307
LW
2467
2468 if (!last)
79072805 2469 return (OP*)first;
8990e307
LW
2470
2471 if (first->op_type != type)
79072805 2472 return prepend_elem(type, (OP*)first, (OP*)last);
8990e307
LW
2473
2474 if (last->op_type != type)
79072805
LW
2475 return append_elem(type, (OP*)first, (OP*)last);
2476
2477 first->op_last->op_sibling = last->op_first;
2478 first->op_last = last->op_last;
117dada2 2479 first->op_flags |= (last->op_flags & OPf_KIDS);
1c846c1f 2480
b7dc083c
NIS
2481#ifdef PL_OP_SLAB_ALLOC
2482#else
1c846c1f 2483 Safefree(last);
b7dc083c 2484#endif
79072805
LW
2485 return (OP*)first;
2486}
2487
2488OP *
864dbfa3 2489Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW
2490{
2491 if (!first)
2492 return last;
8990e307
LW
2493
2494 if (!last)
79072805 2495 return first;
8990e307
LW
2496
2497 if (last->op_type == type) {
2498 if (type == OP_LIST) { /* already a PUSHMARK there */
2499 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2500 ((LISTOP*)last)->op_first->op_sibling = first;
36a5d4ba
DC
2501 if (!(first->op_flags & OPf_PARENS))
2502 last->op_flags &= ~OPf_PARENS;
8990e307
LW
2503 }
2504 else {
2505 if (!(last->op_flags & OPf_KIDS)) {
2506 ((LISTOP*)last)->op_last = first;
2507 last->op_flags |= OPf_KIDS;
2508 }
2509 first->op_sibling = ((LISTOP*)last)->op_first;
2510 ((LISTOP*)last)->op_first = first;
79072805 2511 }
117dada2 2512 last->op_flags |= OPf_KIDS;
79072805
LW
2513 return last;
2514 }
2515
2516 return newLISTOP(type, 0, first, last);
2517}
2518
2519/* Constructors */
2520
2521OP *
864dbfa3 2522Perl_newNULLLIST(pTHX)
79072805 2523{
8990e307
LW
2524 return newOP(OP_STUB, 0);
2525}
2526
2527OP *
864dbfa3 2528Perl_force_list(pTHX_ OP *o)
8990e307 2529{
11343788
MB
2530 if (!o || o->op_type != OP_LIST)
2531 o = newLISTOP(OP_LIST, 0, o, Nullop);
93c66552 2532 op_null(o);
11343788 2533 return o;
79072805
LW
2534}
2535
2536OP *
864dbfa3 2537Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
79072805
LW
2538{
2539 LISTOP *listop;
2540
b7dc083c 2541 NewOp(1101, listop, 1, LISTOP);
79072805
LW
2542
2543 listop->op_type = type;
22c35a8c 2544 listop->op_ppaddr = PL_ppaddr[type];
117dada2
SM
2545 if (first || last)
2546 flags |= OPf_KIDS;
79072805 2547 listop->op_flags = flags;
79072805
LW
2548
2549 if (!last && first)
2550 last = first;
2551 else if (!first && last)
2552 first = last;
8990e307
LW
2553 else if (first)
2554 first->op_sibling = last;
79072805
LW
2555 listop->op_first = first;
2556 listop->op_last = last;
8990e307
LW
2557 if (type == OP_LIST) {
2558 OP* pushop;
2559 pushop = newOP(OP_PUSHMARK, 0);
2560 pushop->op_sibling = first;
2561 listop->op_first = pushop;
2562 listop->op_flags |= OPf_KIDS;
2563 if (!last)
2564 listop->op_last = pushop;
2565 }
79072805
LW
2566
2567 return (OP*)listop;
2568}
2569
2570OP *
864dbfa3 2571Perl_newOP(pTHX_ I32 type, I32 flags)
79072805 2572{
11343788 2573 OP *o;
b7dc083c 2574 NewOp(1101, o, 1, OP);
11343788 2575 o->op_type = type;
22c35a8c 2576 o->op_ppaddr = PL_ppaddr[type];
11343788 2577 o->op_flags = flags;
79072805 2578
11343788
MB
2579 o->op_next = o;
2580 o->op_private = 0 + (flags >> 8);
22c35a8c 2581 if (PL_opargs[type] & OA_RETSCALAR)
11343788 2582 scalar(o);
22c35a8c 2583 if (PL_opargs[type] & OA_TARGET)
11343788
MB
2584 o->op_targ = pad_alloc(type, SVs_PADTMP);
2585 return CHECKOP(type, o);
79072805
LW
2586}
2587
2588OP *
864dbfa3 2589Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
79072805
LW
2590{
2591 UNOP *unop;
2592
93a17b20 2593 if (!first)
aeea060c 2594 first = newOP(OP_STUB, 0);
22c35a8c 2595 if (PL_opargs[type] & OA_MARK)
8990e307 2596 first = force_list(first);
93a17b20 2597
b7dc083c 2598 NewOp(1101, unop, 1, UNOP);
79072805 2599 unop->op_type = type;
22c35a8c 2600 unop->op_ppaddr = PL_ppaddr[type];
79072805
LW
2601 unop->op_first = first;
2602 unop->op_flags = flags | OPf_KIDS;
c07a80fd 2603 unop->op_private = 1 | (flags >> 8);
e50aee73 2604 unop = (UNOP*) CHECKOP(type, unop);
79072805
LW
2605 if (unop->op_next)
2606 return (OP*)unop;
2607
a0d0e21e 2608 return fold_constants((OP *) unop);
79072805
LW
2609}
2610
2611OP *
864dbfa3 2612Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
79072805
LW
2613{
2614 BINOP *binop;
b7dc083c 2615 NewOp(1101, binop, 1, BINOP);
79072805
LW
2616
2617 if (!first)
2618 first = newOP(OP_NULL, 0);
2619
2620 binop->op_type = type;
22c35a8c 2621 binop->op_ppaddr = PL_ppaddr[type];
79072805
LW
2622 binop->op_first = first;
2623 binop->op_flags = flags | OPf_KIDS;
2624 if (!last) {
2625 last = first;
c07a80fd 2626 binop->op_private = 1 | (flags >> 8);
79072805
LW
2627 }
2628 else {
c07a80fd 2629 binop->op_private = 2 | (flags >> 8);
79072805
LW
2630 first->op_sibling = last;
2631 }
2632
e50aee73 2633 binop = (BINOP*)CHECKOP(type, binop);
b162f9ea 2634 if (binop->op_next || binop->op_type != type)
79072805
LW
2635 return (OP*)binop;
2636
7284ab6f 2637 binop->op_last = binop->op_first->op_sibling;
79072805 2638
a0d0e21e 2639 return fold_constants((OP *)binop);
79072805
LW
2640}
2641
a0ed51b3 2642static int
2b9d42f0
NIS
2643uvcompare(const void *a, const void *b)
2644{
2645 if (*((UV *)a) < (*(UV *)b))
2646 return -1;
2647 if (*((UV *)a) > (*(UV *)b))
2648 return 1;
2649 if (*((UV *)a+1) < (*(UV *)b+1))
2650 return -1;
2651 if (*((UV *)a+1) > (*(UV *)b+1))
2652 return 1;
a0ed51b3
LW
2653 return 0;
2654}
2655
79072805 2656OP *
864dbfa3 2657Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
79072805 2658{
79072805
LW
2659 SV *tstr = ((SVOP*)expr)->op_sv;
2660 SV *rstr = ((SVOP*)repl)->op_sv;
463ee0b2
LW
2661 STRLEN tlen;
2662 STRLEN rlen;
9b877dbb
IH
2663 U8 *t = (U8*)SvPV(tstr, tlen);
2664 U8 *r = (U8*)SvPV(rstr, rlen);
79072805
LW
2665 register I32 i;
2666 register I32 j;
a0ed51b3 2667 I32 del;
79072805 2668 I32 complement;
5d06d08e 2669 I32 squash;
9b877dbb 2670 I32 grows = 0;
79072805
LW
2671 register short *tbl;
2672
800b4dc4 2673 PL_hints |= HINT_BLOCK_SCOPE;
11343788 2674 complement = o->op_private & OPpTRANS_COMPLEMENT;
a0ed51b3 2675 del = o->op_private & OPpTRANS_DELETE;
5d06d08e 2676 squash = o->op_private & OPpTRANS_SQUASH;
1c846c1f 2677
036b4402
GS
2678 if (SvUTF8(tstr))
2679 o->op_private |= OPpTRANS_FROM_UTF;
1c846c1f
NIS
2680
2681 if (SvUTF8(rstr))
036b4402 2682 o->op_private |= OPpTRANS_TO_UTF;
79072805 2683
a0ed51b3 2684 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
79cb57f6 2685 SV* listsv = newSVpvn("# comment\n",10);
a0ed51b3
LW
2686 SV* transv = 0;
2687 U8* tend = t + tlen;
2688 U8* rend = r + rlen;
ba210ebe 2689 STRLEN ulen;
a0ed51b3
LW
2690 U32 tfirst = 1;
2691 U32 tlast = 0;
2692 I32 tdiff;
2693 U32 rfirst = 1;
2694 U32 rlast = 0;
2695 I32 rdiff;
2696 I32 diff;
2697 I32 none = 0;
2698 U32 max = 0;
2699 I32 bits;
a0ed51b3 2700 I32 havefinal = 0;
9c5ffd7c 2701 U32 final = 0;
a0ed51b3
LW
2702 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2703 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
bf4a1e57
JH
2704 U8* tsave = NULL;
2705 U8* rsave = NULL;
2706
2707 if (!from_utf) {
2708 STRLEN len = tlen;
2709 tsave = t = bytes_to_utf8(t, &len);
2710 tend = t + len;
2711 }
2712 if (!to_utf && rlen) {
2713 STRLEN len = rlen;
2714 rsave = r = bytes_to_utf8(r, &len);
2715 rend = r + len;
2716 }
a0ed51b3 2717
2b9d42f0
NIS
2718/* There are several snags with this code on EBCDIC:
2719 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2720 2. scan_const() in toke.c has encoded chars in native encoding which makes
2721 ranges at least in EBCDIC 0..255 range the bottom odd.
2722*/
2723
a0ed51b3 2724 if (complement) {
ad391ad9 2725 U8 tmpbuf[UTF8_MAXLEN+1];
2b9d42f0 2726 UV *cp;
a0ed51b3 2727 UV nextmin = 0;
2b9d42f0 2728 New(1109, cp, 2*tlen, UV);
a0ed51b3 2729 i = 0;
79cb57f6 2730 transv = newSVpvn("",0);
a0ed51b3 2731 while (t < tend) {
2b9d42f0
NIS
2732 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2733 t += ulen;
2734 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
a0ed51b3 2735 t++;
2b9d42f0
NIS
2736 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2737 t += ulen;
a0ed51b3 2738 }
2b9d42f0
NIS
2739 else {
2740 cp[2*i+1] = cp[2*i];
2741 }
2742 i++;
a0ed51b3 2743 }
2b9d42f0 2744 qsort(cp, i, 2*sizeof(UV), uvcompare);
a0ed51b3 2745 for (j = 0; j < i; j++) {
2b9d42f0 2746 UV val = cp[2*j];
a0ed51b3
LW
2747 diff = val - nextmin;
2748 if (diff > 0) {
9041c2e3 2749 t = uvuni_to_utf8(tmpbuf,nextmin);
dfe13c55 2750 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
a0ed51b3 2751 if (diff > 1) {
2b9d42f0 2752 U8 range_mark = UTF_TO_NATIVE(0xff);
9041c2e3 2753 t = uvuni_to_utf8(tmpbuf, val - 1);
2b9d42f0 2754 sv_catpvn(transv, (char *)&range_mark, 1);
dfe13c55 2755 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
a0ed51b3
LW
2756 }
2757 }
2b9d42f0 2758 val = cp[2*j+1];
a0ed51b3
LW
2759 if (val >= nextmin)
2760 nextmin = val + 1;
2761 }
9041c2e3 2762 t = uvuni_to_utf8(tmpbuf,nextmin);
dfe13c55 2763 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2b9d42f0
NIS
2764 {
2765 U8 range_mark = UTF_TO_NATIVE(0xff);
2766 sv_catpvn(transv, (char *)&range_mark, 1);
2767 }
9041c2e3 2768 t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
dfe13c55
GS
2769 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2770 t = (U8*)SvPVX(transv);
a0ed51b3
LW
2771 tlen = SvCUR(transv);
2772 tend = t + tlen;
455d824a 2773 Safefree(cp);
a0ed51b3
LW
2774 }
2775 else if (!rlen && !del) {
2776 r = t; rlen = tlen; rend = tend;
4757a243
LW
2777 }
2778 if (!squash) {
05d340b8 2779 if ((!rlen && !del) || t == r ||
12ae5dfc 2780 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
01ec43d0 2781 {
4757a243 2782 o->op_private |= OPpTRANS_IDENTICAL;
01ec43d0 2783 }
a0ed51b3
LW
2784 }
2785
2786 while (t < tend || tfirst <= tlast) {
2787 /* see if we need more "t" chars */
2788 if (tfirst > tlast) {
9041c2e3 2789 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
a0ed51b3 2790 t += ulen;
2b9d42f0 2791 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
ba210ebe 2792 t++;
9041c2e3 2793 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
a0ed51b3
LW
2794 t += ulen;
2795 }
2796 else
2797 tlast = tfirst;
2798 }
2799
2800 /* now see if we need more "r" chars */
2801 if (rfirst > rlast) {
2802 if (r < rend) {
9041c2e3 2803 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
a0ed51b3 2804 r += ulen;
2b9d42f0 2805 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
ba210ebe 2806 r++;
9041c2e3 2807 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
a0ed51b3
LW
2808 r += ulen;
2809 }
2810 else
2811 rlast = rfirst;
2812 }
2813 else {
2814 if (!havefinal++)
2815 final = rlast;
2816 rfirst = rlast = 0xffffffff;
2817 }
2818 }
2819
2820 /* now see which range will peter our first, if either. */
2821 tdiff = tlast - tfirst;
2822 rdiff = rlast - rfirst;
2823
2824 if (tdiff <= rdiff)
2825 diff = tdiff;
2826 else
2827 diff = rdiff;
2828
2829 if (rfirst == 0xffffffff) {
2830 diff = tdiff; /* oops, pretend rdiff is infinite */
2831 if (diff > 0)
894356b3
GS
2832 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2833 (long)tfirst, (long)tlast);
a0ed51b3 2834 else
894356b3 2835 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
a0ed51b3
LW
2836 }
2837 else {
2838 if (diff > 0)
894356b3
GS
2839 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2840 (long)tfirst, (long)(tfirst + diff),
2841 (long)rfirst);
a0ed51b3 2842 else
894356b3
GS
2843 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2844 (long)tfirst, (long)rfirst);
a0ed51b3
LW
2845
2846 if (rfirst + diff > max)
2847 max = rfirst + diff;
9b877dbb 2848 if (!grows)
45005bfb
JH
2849 grows = (tfirst < rfirst &&
2850 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2851 rfirst += diff + 1;
a0ed51b3
LW
2852 }
2853 tfirst += diff + 1;
2854 }
2855
2856 none = ++max;
2857 if (del)
2858 del = ++max;
2859
2860 if (max > 0xffff)
2861 bits = 32;
2862 else if (max > 0xff)
2863 bits = 16;
2864 else
2865 bits = 8;
2866
455d824a 2867 Safefree(cPVOPo->op_pv);
a0ed51b3
LW
2868 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2869 SvREFCNT_dec(listsv);
2870 if (transv)
2871 SvREFCNT_dec(transv);
2872
45005bfb 2873 if (!del && havefinal && rlen)
b448e4fe
JH
2874 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2875 newSVuv((UV)final), 0);
a0ed51b3 2876
9b877dbb 2877 if (grows)
a0ed51b3
LW
2878 o->op_private |= OPpTRANS_GROWS;
2879
9b877dbb
IH
2880 if (tsave)
2881 Safefree(tsave);
2882 if (rsave)
2883 Safefree(rsave);
2884
a0ed51b3
LW
2885 op_free(expr);
2886 op_free(repl);
2887 return o;
2888 }
2889
2890 tbl = (short*)cPVOPo->op_pv;
79072805
LW
2891 if (complement) {
2892 Zero(tbl, 256, short);
2893 for (i = 0; i < tlen; i++)
ec49126f 2894 tbl[t[i]] = -1;
79072805
LW
2895 for (i = 0, j = 0; i < 256; i++) {
2896 if (!tbl[i]) {
2897 if (j >= rlen) {
a0ed51b3 2898 if (del)
79072805
LW
2899 tbl[i] = -2;
2900 else if (rlen)
ec49126f 2901 tbl[i] = r[j-1];
79072805
LW
2902 else
2903 tbl[i] = i;
2904 }
9b877dbb
IH
2905 else {
2906 if (i < 128 && r[j] >= 128)
2907 grows = 1;
ec49126f 2908 tbl[i] = r[j++];
9b877dbb 2909 }
79072805
LW
2910 }
2911 }
05d340b8
JH
2912 if (!del) {
2913 if (!rlen) {
2914 j = rlen;
2915 if (!squash)
2916 o->op_private |= OPpTRANS_IDENTICAL;
2917 }
2918 else if (j >= rlen)
2919 j = rlen - 1;
2920 else
2921 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
8973db79
JH
2922 tbl[0x100] = rlen - j;
2923 for (i=0; i < rlen - j; i++)
2924 tbl[0x101+i] = r[j+i];
2925 }
79072805
LW
2926 }
2927 else {
a0ed51b3 2928 if (!rlen && !del) {
79072805 2929 r = t; rlen = tlen;
5d06d08e 2930 if (!squash)
4757a243 2931 o->op_private |= OPpTRANS_IDENTICAL;
79072805
LW
2932 }
2933 for (i = 0; i < 256; i++)
2934 tbl[i] = -1;
2935 for (i = 0, j = 0; i < tlen; i++,j++) {
2936 if (j >= rlen) {
a0ed51b3 2937 if (del) {
ec49126f
PP
2938 if (tbl[t[i]] == -1)
2939 tbl[t[i]] = -2;
79072805
LW
2940 continue;
2941 }
2942 --j;
2943 }
9b877dbb
IH
2944 if (tbl[t[i]] == -1) {
2945 if (t[i] < 128 && r[j] >= 128)
2946 grows = 1;
ec49126f 2947 tbl[t[i]] = r[j];
9b877dbb 2948 }
79072805
LW
2949 }
2950 }
9b877dbb
IH
2951 if (grows)
2952 o->op_private |= OPpTRANS_GROWS;
79072805
LW
2953 op_free(expr);
2954 op_free(repl);
2955
11343788 2956 return o;
79072805
LW
2957}
2958
2959OP *
864dbfa3 2960Perl_newPMOP(pTHX_ I32 type, I32 flags)
79072805
LW
2961{
2962 PMOP *pmop;
2963
b7dc083c 2964 NewOp(1101, pmop, 1, PMOP);
79072805 2965 pmop->op_type = type;
22c35a8c 2966 pmop->op_ppaddr = PL_ppaddr[type];
79072805 2967 pmop->op_flags = flags;
c07a80fd 2968 pmop->op_private = 0 | (flags >> 8);
79072805 2969
3280af22 2970 if (PL_hints & HINT_RE_TAINT)
b3eb6a9b 2971 pmop->op_pmpermflags |= PMf_RETAINT;
3280af22 2972 if (PL_hints & HINT_LOCALE)
b3eb6a9b
GS
2973 pmop->op_pmpermflags |= PMf_LOCALE;
2974 pmop->op_pmflags = pmop->op_pmpermflags;
36477c24 2975
debc9467 2976#ifdef USE_ITHREADS
13137afc
AB
2977 {
2978 SV* repointer;
2979 if(av_len((AV*) PL_regex_pad[0]) > -1) {
2980 repointer = av_pop((AV*)PL_regex_pad[0]);
2981 pmop->op_pmoffset = SvIV(repointer);
1cc8b4c5 2982 SvREPADTMP_off(repointer);
13137afc
AB
2983 sv_setiv(repointer,0);
2984 } else {
2985 repointer = newSViv(0);
2986 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2987 pmop->op_pmoffset = av_len(PL_regex_padav);
2988 PL_regex_pad = AvARRAY(PL_regex_padav);
1fcf4c12 2989 }
13137afc 2990 }
debc9467 2991#endif
1fcf4c12
AB
2992
2993 /* link into pm list */
3280af22
NIS
2994 if (type != OP_TRANS && PL_curstash) {
2995 pmop->op_pmnext = HvPMROOT(PL_curstash);
2996 HvPMROOT(PL_curstash) = pmop;
cb55de95 2997 PmopSTASH_set(pmop,PL_curstash);
79072805
LW
2998 }
2999
3000 return (OP*)pmop;
3001}
3002
3003OP *
864dbfa3 3004Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
79072805
LW
3005{
3006 PMOP *pm;
3007 LOGOP *rcop;
ce862d02 3008 I32 repl_has_vars = 0;
79072805 3009
11343788
MB
3010 if (o->op_type == OP_TRANS)
3011 return pmtrans(o, expr, repl);
79072805 3012
3280af22 3013 PL_hints |= HINT_BLOCK_SCOPE;
11343788 3014 pm = (PMOP*)o;
79072805
LW
3015
3016 if (expr->op_type == OP_CONST) {
463ee0b2 3017 STRLEN plen;
79072805 3018 SV *pat = ((SVOP*)expr)->op_sv;
463ee0b2 3019 char *p = SvPV(pat, plen);
11343788 3020 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
93a17b20 3021 sv_setpvn(pat, "\\s+", 3);
463ee0b2 3022 p = SvPV(pat, plen);
79072805
LW
3023 pm->op_pmflags |= PMf_SKIPWHITE;
3024 }
aaa362c4
RS
3025 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
3026 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
85e6fe83 3027 pm->op_pmflags |= PMf_WHITE;
79072805
LW
3028 op_free(expr);
3029 }
3030 else {
3280af22 3031 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
1c846c1f 3032 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2cd61cdb
IZ
3033 ? OP_REGCRESET
3034 : OP_REGCMAYBE),0,expr);
463ee0b2 3035
b7dc083c 3036 NewOp(1101, rcop, 1, LOGOP);
79072805 3037 rcop->op_type = OP_REGCOMP;
22c35a8c 3038 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
79072805 3039 rcop->op_first = scalar(expr);
1c846c1f 3040 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
2cd61cdb
IZ
3041 ? (OPf_SPECIAL | OPf_KIDS)
3042 : OPf_KIDS);
79072805 3043 rcop->op_private = 1;
11343788 3044 rcop->op_other = o;
79072805
LW
3045
3046 /* establish postfix order */
3280af22 3047 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
463ee0b2
LW
3048 LINKLIST(expr);
3049 rcop->op_next = expr;
3050 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3051 }
3052 else {
3053 rcop->op_next = LINKLIST(expr);
3054 expr->op_next = (OP*)rcop;
3055 }
79072805 3056
11343788 3057 prepend_elem(o->op_type, scalar((OP*)rcop), o);
79072805
LW
3058 }
3059
3060 if (repl) {
748a9306 3061 OP *curop;
0244c3a4 3062 if (pm->op_pmflags & PMf_EVAL) {
748a9306 3063 curop = 0;
57843af0
GS
3064 if (CopLINE(PL_curcop) < PL_multi_end)
3065 CopLINE_set(PL_curcop, PL_multi_end);
0244c3a4 3066 }
4d1ff10f 3067#ifdef USE_5005THREADS
2faa37cc 3068 else if (repl->op_type == OP_THREADSV
554b3eca 3069 && strchr("&`'123456789+",
533c011a 3070 PL_threadsv_names[repl->op_targ]))
554b3eca
MB
3071 {
3072 curop = 0;
3073 }
4d1ff10f 3074#endif /* USE_5005THREADS */
748a9306
LW
3075 else if (repl->op_type == OP_CONST)
3076 curop = repl;
79072805 3077 else {
79072805
LW
3078 OP *lastop = 0;
3079 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
22c35a8c 3080 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4d1ff10f 3081#ifdef USE_5005THREADS
ce862d02
IZ
3082 if (curop->op_type == OP_THREADSV) {
3083 repl_has_vars = 1;
be949f6f 3084 if (strchr("&`'123456789+", curop->op_private))
ce862d02 3085 break;
554b3eca
MB
3086 }
3087#else
79072805 3088 if (curop->op_type == OP_GV) {
638eceb6 3089 GV *gv = cGVOPx_gv(curop);
ce862d02 3090 repl_has_vars = 1;
93a17b20 3091 if (strchr("&`'123456789+", *GvENAME(gv)))
79072805
LW
3092 break;
3093 }
4d1ff10f 3094#endif /* USE_5005THREADS */
79072805
LW
3095 else if (curop->op_type == OP_RV2CV)
3096 break;
3097 else if (curop->op_type == OP_RV2SV ||
3098 curop->op_type == OP_RV2AV ||
3099 curop->op_type == OP_RV2HV ||
3100 curop->op_type == OP_RV2GV) {
3101 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3102 break;
3103 }
748a9306
LW
3104 else if (curop->op_type == OP_PADSV ||
3105 curop->op_type == OP_PADAV ||
3106 curop->op_type == OP_PADHV ||
554b3eca 3107 curop->op_type == OP_PADANY) {
ce862d02 3108 repl_has_vars = 1;
748a9306 3109 }
1167e5da
SM
3110 else if (curop->op_type == OP_PUSHRE)
3111 ; /* Okay here, dangerous in newASSIGNOP */
79072805
LW
3112 else
3113 break;
3114 }
3115 lastop = curop;
3116 }
748a9306 3117 }
ce862d02 3118 if (curop == repl
1c846c1f 3119 && !(repl_has_vars
aaa362c4
RS
3120 && (!PM_GETRE(pm)
3121 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
748a9306 3122 pm->op_pmflags |= PMf_CONST; /* const for long enough */
4633a7c4 3123 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
11343788 3124 prepend_elem(o->op_type, scalar(repl), o);
748a9306
LW
3125 }
3126 else {
aaa362c4 3127 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
ce862d02
IZ
3128 pm->op_pmflags |= PMf_MAYBE_CONST;
3129 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3130 }
b7dc083c 3131 NewOp(1101, rcop, 1, LOGOP);
748a9306 3132 rcop->op_type = OP_SUBSTCONT;
22c35a8c 3133 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
748a9306
LW
3134 rcop->op_first = scalar(repl);
3135 rcop->op_flags |= OPf_KIDS;
3136 rcop->op_private = 1;
11343788 3137 rcop->op_other = o;
748a9306
LW
3138
3139 /* establish postfix order */
3140 rcop->op_next = LINKLIST(repl);
3141 repl->op_next = (OP*)rcop;
3142
3143 pm->op_pmreplroot = scalar((OP*)rcop);
3144 pm->op_pmreplstart = LINKLIST(rcop);
3145 rcop->op_next = 0;
79072805
LW
3146 }
3147 }
3148
3149 return (OP*)pm;
3150}
3151
3152OP *
864dbfa3 3153Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
79072805
LW
3154{
3155 SVOP *svop;
b7dc083c 3156 NewOp(1101, svop, 1, SVOP);
79072805 3157 svop->op_type = type;
22c35a8c 3158 svop->op_ppaddr = PL_ppaddr[type];
79072805
LW
3159 svop->op_sv = sv;
3160 svop->op_next = (OP*)svop;
3161 svop->op_flags = flags;
22c35a8c 3162 if (PL_opargs[type] & OA_RETSCALAR)
463ee0b2 3163 scalar((OP*)svop);
22c35a8c 3164 if (PL_opargs[type] & OA_TARGET)
ed6116ce 3165 svop->op_targ = pad_alloc(type, SVs_PADTMP);
e50aee73 3166 return CHECKOP(type, svop);
79072805
LW
3167}
3168
3169OP *
350de78d
GS
3170Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3171{
3172 PADOP *padop;
3173 NewOp(1101, padop, 1, PADOP);
3174 padop->op_type = type;
3175 padop->op_ppaddr = PL_ppaddr[type];
3176 padop->op_padix = pad_alloc(type, SVs_PADTMP);
7766f137 3177 SvREFCNT_dec(PL_curpad[padop->op_padix]);
350de78d 3178 PL_curpad[padop->op_padix] = sv;
7766f137 3179 SvPADTMP_on(sv);
350de78d
GS
3180 padop->op_next = (OP*)padop;
3181 padop->op_flags = flags;
3182 if (PL_opargs[type] & OA_RETSCALAR)
3183 scalar((OP*)padop);
3184 if (PL_opargs[type] & OA_TARGET)
3185 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3186 return CHECKOP(type, padop);
3187}
3188
3189OP *
864dbfa3 3190Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
79072805 3191{
350de78d 3192#ifdef USE_ITHREADS
743e66e6 3193 GvIN_PAD_on(gv);
350de78d
GS
3194 return newPADOP(type, flags, SvREFCNT_inc(gv));
3195#else
7934575e 3196 return newSVOP(type, flags, SvREFCNT_inc(gv));
350de78d 3197#endif
79072805
LW
3198}
3199
3200OP *
864dbfa3 3201Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
79072805
LW
3202{
3203 PVOP *pvop;
b7dc083c 3204 NewOp(1101, pvop, 1, PVOP);
79072805 3205 pvop->op_type = type;
22c35a8c 3206 pvop->op_ppaddr = PL_ppaddr[type];
79072805
LW
3207 pvop->op_pv = pv;
3208 pvop->op_next = (OP*)pvop;
3209 pvop->op_flags = flags;
22c35a8c 3210 if (PL_opargs[type] & OA_RETSCALAR)
463ee0b2 3211 scalar((OP*)pvop);
22c35a8c 3212 if (PL_opargs[type] & OA_TARGET)
ed6116ce 3213 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
e50aee73 3214 return CHECKOP(type, pvop);
79072805
LW
3215}
3216
79072805 3217void
864dbfa3 3218Perl_package(pTHX_ OP *o)
79072805 3219{
93a17b20 3220 SV *sv;
79072805 3221
3280af22
NIS
3222 save_hptr(&PL_curstash);
3223 save_item(PL_curstname);
11343788 3224 if (o) {
463ee0b2
LW
3225 STRLEN len;
3226 char *name;
11343788 3227 sv = cSVOPo->op_sv;
463ee0b2 3228 name = SvPV(sv, len);
3280af22
NIS
3229 PL_curstash = gv_stashpvn(name,len,TRUE);
3230 sv_setpvn(PL_curstname, name, len);
11343788 3231 op_free(o);
93a17b20
LW
3232 }
3233 else {
f2c0fa37 3234 deprecate("\"package\" with no arguments");
3280af22
NIS
3235 sv_setpv(PL_curstname,"<none>");
3236 PL_curstash = Nullhv;
93a17b20 3237 }
7ad382f4 3238 PL_hints |= HINT_BLOCK_SCOPE;
3280af22
NIS
3239 PL_copline = NOLINE;
3240 PL_expect = XSTATE;
79072805
LW
3241}
3242
85e6fe83 3243void
864dbfa3 3244Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
85e6fe83 3245{
a0d0e21e 3246 OP *pack;
a0d0e21e 3247 OP *imop;
b1cb66bf 3248 OP *veop;
18fc9488 3249 char *packname = Nullch;
c4e33207 3250 STRLEN packlen = 0;
18fc9488 3251 SV *packsv;
85e6fe83 3252
a0d0e21e 3253 if (id->op_type != OP_CONST)
cea2e8a9 3254 Perl_croak(aTHX_ "Module name must be constant");
85e6fe83 3255
b1cb66bf
PP
3256 veop = Nullop;
3257
0f79a09d 3258 if (version != Nullop) {
b1cb66bf
PP
3259 SV *vesv = ((SVOP*)version)->op_sv;
3260
44dcb63b 3261 if (arg == Nullop && !SvNIOKp(vesv)) {
b1cb66bf
PP
3262 arg = version;
3263 }
3264 else {
3265 OP *pack;
0f79a09d 3266 SV *meth;
b1cb66bf 3267
44dcb63b 3268 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
cea2e8a9 3269 Perl_croak(aTHX_ "Version number must be constant number");
b1cb66bf
PP
3270
3271 /* Make copy of id so we don't free it twice */
3272 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3273
3274 /* Fake up a method call to VERSION */
0f79a09d
GS
3275 meth = newSVpvn("VERSION",7);
3276 sv_upgrade(meth, SVt_PVIV);
155aba94 3277 (void)SvIOK_on(meth);
0f79a09d 3278 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
b1cb66bf
PP
3279 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3280 append_elem(OP_LIST,
0f79a09d
GS
3281 prepend_elem(OP_LIST, pack, list(version)),
3282 newSVOP(OP_METHOD_NAMED, 0, meth)));
b1cb66bf
PP
3283 }
3284 }
aeea060c 3285
a0d0e21e 3286 /* Fake up an import/unimport */
4633a7c4
LW
3287 if (arg && arg->op_type == OP_STUB)
3288 imop = arg; /* no import on explicit () */
44dcb63b 3289 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
b1cb66bf
PP
3290 imop = Nullop; /* use 5.0; */
3291 }
4633a7c4 3292 else {
0f79a09d
GS
3293 SV *meth;
3294
4633a7c4
LW
3295 /* Make copy of id so we don't free it twice */
3296 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
0f79a09d
GS
3297
3298 /* Fake up a method call to import/unimport */
3299 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
3300 sv_upgrade(meth, SVt_PVIV);
155aba94 3301 (void)SvIOK_on(meth);
0f79a09d 3302 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
4633a7c4 3303 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
0f79a09d
GS
3304 append_elem(OP_LIST,
3305 prepend_elem(OP_LIST, pack, list(arg)),
3306 newSVOP(OP_METHOD_NAMED, 0, meth)));
4633a7c4
LW
3307 }
3308
d04f2e46
DM
3309 if (ckWARN(WARN_MISC) &&
3310 imop && (imop != arg) && /* no warning on use 5.0; or explicit () */
3311 SvPOK(packsv = ((SVOP*)id)->op_sv))
3312 {
18fc9488
DM
3313 /* BEGIN will free the ops, so we need to make a copy */
3314 packlen = SvCUR(packsv);
3315 packname = savepvn(SvPVX(packsv), packlen);
3316 }
3317
a0d0e21e 3318 /* Fake up the BEGIN {}, which does its thing immediately. */
09bef843 3319 newATTRSUB(floor,
79cb57f6 3320 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
4633a7c4 3321 Nullop,
09bef843 3322 Nullop,
a0d0e21e 3323 append_elem(OP_LINESEQ,
b1cb66bf 3324 append_elem(OP_LINESEQ,
ec4ab249 3325 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, id)),
b1cb66bf 3326 newSTATEOP(0, Nullch, veop)),
a0d0e21e 3327 newSTATEOP(0, Nullch, imop) ));
85e6fe83 3328
18fc9488
DM
3329 if (packname) {
3330 if (ckWARN(WARN_MISC) && !gv_stashpvn(packname, packlen, FALSE)) {
3331 Perl_warner(aTHX_ WARN_MISC,
3332 "Package `%s' not found "
3333 "(did you use the incorrect case?)", packname);
3334 }
3335 safefree(packname);
3336 }
3337
c305c6a0 3338 PL_hints |= HINT_BLOCK_SCOPE;
3280af22
NIS
3339 PL_copline = NOLINE;
3340 PL_expect = XSTATE;
85e6fe83
LW
3341}
3342
7d3fb230
BS
3343/*
3344=for apidoc load_module
3345
3346Loads the module whose name is pointed to by the string part of name.
3347Note that the actual module name, not its filename, should be given.
3348Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3349PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3350(or 0 for no flags). ver, if specified, provides version semantics
3351similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3352arguments can be used to specify arguments to the module's import()
3353method, similar to C<use Foo::Bar VERSION LIST>.
3354
3355=cut */
3356
e4783991
GS
3357void
3358Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3359{
3360 va_list args;
3361 va_start(args, ver);
3362 vload_module(flags, name, ver, &args);
3363 va_end(args);
3364}
3365
3366#ifdef PERL_IMPLICIT_CONTEXT
3367void
3368Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3369{
3370 dTHX;
3371 va_list args;
3372 va_start(args, ver);
3373 vload_module(flags, name, ver, &args);
3374 va_end(args);
3375}
3376#endif
3377
3378void
3379Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3380{
3381 OP *modname, *veop, *imop;
3382
3383 modname = newSVOP(OP_CONST, 0, name);
3384 modname->op_private |= OPpCONST_BARE;
3385 if (ver) {
3386 veop = newSVOP(OP_CONST, 0, ver);
3387 }
3388 else
3389 veop = Nullop;
3390 if (flags & PERL_LOADMOD_NOIMPORT) {
3391 imop = sawparens(newNULLLIST());
3392 }
3393 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3394 imop = va_arg(*args, OP*);
3395 }
3396 else {
3397 SV *sv;
3398 imop = Nullop;
3399 sv = va_arg(*args, SV*);
3400 while (sv) {
3401 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3402 sv = va_arg(*args, SV*);
3403 }
3404 }
81885997
GS
3405 {
3406 line_t ocopline = PL_copline;
3407 int oexpect = PL_expect;
3408
3409 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3410 veop, modname, imop);
3411 PL_expect = oexpect;
3412 PL_copline = ocopline;
3413 }
e4783991
GS
3414}
3415
79072805 3416OP *
864dbfa3 3417Perl_dofile(pTHX_ OP *term)
78ca652e
GS
3418{
3419 OP *doop;
3420 GV *gv;
3421
3422 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3423 if (!(gv && GvIMPORTED_CV(gv)))
3424 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3425
3426 if (gv && GvIMPORTED_CV(gv)) {
3427 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3428 append_elem(OP_LIST, term,
3429 scalar(newUNOP(OP_RV2CV, 0,
3430 newGVOP(OP_GV, 0,
3431 gv))))));
3432 }
3433 else {
3434 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3435 }
3436 return doop;
3437}
3438
3439OP *
864dbfa3 3440Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
79072805
LW
3441{
3442 return newBINOP(OP_LSLICE, flags,
8990e307
LW
3443 list(force_list(subscript)),
3444 list(force_list(listval)) );
79072805
LW
3445}
3446
76e3520e 3447STATIC I32
cea2e8a9 3448S_list_assignment(pTHX_ register OP *o)
79072805 3449{
11343788 3450 if (!o)
79072805
LW
3451 return TRUE;
3452
11343788
MB
3453 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3454 o = cUNOPo->op_first;
79072805 3455
11343788 3456 if (o->op_type == OP_COND_EXPR) {
1a67a97c
SM
3457 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3458 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
79072805
LW
3459
3460 if (t && f)
3461 return TRUE;
3462 if (t || f)
3463 yyerror("Assignment to both a list and a scalar");
3464 return FALSE;
3465 }
3466
11343788
MB
3467 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3468 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3469 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
79072805
LW
3470 return TRUE;
3471
11343788 3472 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
93a17b20
LW
3473 return TRUE;
3474
11343788 3475 if (o->op_type == OP_RV2SV)
79072805
LW
3476 return FALSE;
3477
3478 return FALSE;
3479}
3480
3481OP *
864dbfa3 3482Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
79072805 3483{
11343788 3484 OP *o;
79072805 3485
a0d0e21e
LW
3486 if (optype) {
3487 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3488 return newLOGOP(optype, 0,
3489 mod(scalar(left), optype),
3490 newUNOP(OP_SASSIGN, 0, scalar(right)));
3491 }
3492 else {
3493 return newBINOP(optype, OPf_STACKED,
3494 mod(scalar(left), optype), scalar(right));
3495 }
3496 }
3497
79072805 3498 if (list_assignment(left)) {
10c8fecd
GS
3499 OP *curop;
3500
3280af22
NIS
3501 PL_modcount = 0;
3502 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
463ee0b2 3503 left = mod(left, OP_AASSIGN);
3280af22
NIS
3504 if (PL_eval_start)
3505 PL_eval_start = 0;
748a9306 3506 else {
a0d0e21e
LW
3507 op_free(left);
3508 op_free(right);
3509 return Nullop;
3510 }
10c8fecd
GS
3511 curop = list(force_list(left));
3512 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
11343788 3513 o->op_private = 0 | (flags >> 8);
10c8fecd
GS
3514 for (curop = ((LISTOP*)curop)->op_first;
3515 curop; curop = curop->op_sibling)
3516 {
3517 if (curop->op_type == OP_RV2HV &&
3518 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3519 o->op_private |= OPpASSIGN_HASH;
3520 break;
3521 }
3522 }
a0d0e21e 3523 if (!(left->op_private & OPpLVAL_INTRO)) {
11343788 3524 OP *lastop = o;
3280af22 3525 PL_generation++;
11343788 3526 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(c