This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[patch] plug PL_origargv leak
[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",
22c35a8c 75 PL_op_desc[o->op_type]));
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)",
22c35a8c 97 (int)n, name, t, PL_op_desc[kid->op_type]));
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]) ||
fd400ab9 118 (PL_hints & HINT_UTF8 && 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 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 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 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 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 263 I32 depth;
264 AV *oldpad;
265 SV *oldsv;
266
267 depth = CvDEPTH(cv);
268 if (!depth) {
9607fc9c 269 if (newoff) {
270 if (SvFAKE(sv))
271 continue;
4fdae800 272 return 0; /* don't clone from inactive stack frame */
9607fc9c 273 }
5f05dabc 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 285 oldsv = Nullsv; /* no need to keep ref */
286 }
287 else {
28757baa 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 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 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 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
11343788
MB
404#ifdef USE_THREADS
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) */
415#endif /* USE_THREADS */
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 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 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 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 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 505 break;
506 }
3280af22 507 retval = PL_padix;
79072805 508 }
8990e307 509 SvFLAGS(sv) |= tmptype;
3280af22 510 PL_curpad = AvARRAY(PL_comppad);
11343788 511#ifdef USE_THREADS
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]));
11343788 521#endif /* USE_THREADS */
79072805
LW
522 return (PADOFFSET)retval;
523}
524
525SV *
864dbfa3 526Perl_pad_sv(pTHX_ PADOFFSET po)
79072805 527{
11343788 528#ifdef USE_THREADS
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));
11343788 537#endif /* USE_THREADS */
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");
11343788 550#ifdef USE_THREADS
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));
11343788 557#endif /* USE_THREADS */
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");
11343788 575#ifdef USE_THREADS
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));
11343788 582#endif /* USE_THREADS */
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");
11343788 604#ifdef USE_THREADS
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)));
11343788 611#endif /* USE_THREADS */
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
a863c7d1 623#ifdef USE_THREADS
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}
688#endif /* USE_THREADS */
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{
11343788 750 switch (o->op_type) {
acb36ea4
GS
751 case OP_NULL: /* Was holding old type, if any. */
752 case OP_ENTEREVAL: /* Was holding hints. */
753#ifdef USE_THREADS
754 case OP_THREADSV: /* Was holding index into thr->threadsv AV. */
755#endif
756 o->op_targ = 0;
a0d0e21e 757 break;
554b3eca 758#ifdef USE_THREADS
8dd3ba40
SM
759 case OP_ENTERITER:
760 if (!(o->op_flags & OPf_SPECIAL))
761 break;
762 /* FALL THROUGH */
554b3eca 763#endif /* USE_THREADS */
a6006777 764 default:
ac4c12e7 765 if (!(o->op_flags & OPf_REF)
0b94c7bb 766 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
a6006777 767 break;
768 /* FALL THROUGH */
463ee0b2 769 case OP_GVSV:
79072805 770 case OP_GV:
a6006777 771 case OP_AELEMFAST:
350de78d 772#ifdef USE_ITHREADS
971a9dd3
GS
773 if (cPADOPo->op_padix > 0) {
774 if (PL_curpad) {
638eceb6 775 GV *gv = cGVOPo_gv;
971a9dd3
GS
776 pad_swipe(cPADOPo->op_padix);
777 /* No GvIN_PAD_off(gv) here, because other references may still
778 * exist on the pad */
779 SvREFCNT_dec(gv);
780 }
781 cPADOPo->op_padix = 0;
782 }
350de78d 783#else
971a9dd3 784 SvREFCNT_dec(cSVOPo->op_sv);
7934575e 785 cSVOPo->op_sv = Nullsv;
350de78d 786#endif
79072805 787 break;
a1ae71d2 788 case OP_METHOD_NAMED:
79072805 789 case OP_CONST:
11343788 790 SvREFCNT_dec(cSVOPo->op_sv);
acb36ea4 791 cSVOPo->op_sv = Nullsv;
79072805 792 break;
748a9306
LW
793 case OP_GOTO:
794 case OP_NEXT:
795 case OP_LAST:
796 case OP_REDO:
11343788 797 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
748a9306
LW
798 break;
799 /* FALL THROUGH */
a0d0e21e 800 case OP_TRANS:
acb36ea4 801 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
a0ed51b3 802 SvREFCNT_dec(cSVOPo->op_sv);
acb36ea4
GS
803 cSVOPo->op_sv = Nullsv;
804 }
805 else {
a0ed51b3 806 Safefree(cPVOPo->op_pv);
acb36ea4
GS
807 cPVOPo->op_pv = Nullch;
808 }
a0d0e21e
LW
809 break;
810 case OP_SUBST:
11343788 811 op_free(cPMOPo->op_pmreplroot);
971a9dd3 812 goto clear_pmop;
748a9306 813 case OP_PUSHRE:
971a9dd3
GS
814#ifdef USE_ITHREADS
815 if ((PADOFFSET)cPMOPo->op_pmreplroot) {
816 if (PL_curpad) {
817 GV *gv = (GV*)PL_curpad[(PADOFFSET)cPMOPo->op_pmreplroot];
818 pad_swipe((PADOFFSET)cPMOPo->op_pmreplroot);
819 /* No GvIN_PAD_off(gv) here, because other references may still
820 * exist on the pad */
821 SvREFCNT_dec(gv);
822 }
823 }
824#else
825 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
826#endif
827 /* FALL THROUGH */
a0d0e21e 828 case OP_MATCH:
8782bef2 829 case OP_QR:
971a9dd3 830clear_pmop:
cb55de95
JH
831 {
832 HV *pmstash = PmopSTASH(cPMOPo);
833 if (pmstash && SvREFCNT(pmstash)) {
834 PMOP *pmop = HvPMROOT(pmstash);
835 PMOP *lastpmop = NULL;
836 while (pmop) {
837 if (cPMOPo == pmop) {
838 if (lastpmop)
839 lastpmop->op_pmnext = pmop->op_pmnext;
840 else
841 HvPMROOT(pmstash) = pmop->op_pmnext;
842 break;
843 }
844 lastpmop = pmop;
845 pmop = pmop->op_pmnext;
846 }
83da49e6 847 }
cb55de95 848#ifdef USE_ITHREADS
83da49e6 849 Safefree(PmopSTASHPV(cPMOPo));
cb55de95 850#else
83da49e6 851 /* NOTE: PMOP.op_pmstash is not refcounted */
cb55de95 852#endif
cb55de95 853 }
971a9dd3 854 cPMOPo->op_pmreplroot = Nullop;
aaa362c4
RS
855 ReREFCNT_dec(PM_GETRE(cPMOPo));
856 PM_SETRE(cPMOPo, (REGEXP*)NULL);
a0d0e21e 857 break;
79072805
LW
858 }
859
743e66e6 860 if (o->op_targ > 0) {
11343788 861 pad_free(o->op_targ);
743e66e6
GS
862 o->op_targ = 0;
863 }
79072805
LW
864}
865
76e3520e 866STATIC void
3eb57f73
HS
867S_cop_free(pTHX_ COP* cop)
868{
869 Safefree(cop->cop_label);
57843af0 870#ifdef USE_ITHREADS
f4dd75d9
GS
871 Safefree(CopFILE(cop)); /* XXX share in a pvtable? */
872 Safefree(CopSTASHPV(cop)); /* XXX share in a pvtable? */
57843af0 873#else
11faa288 874 /* NOTE: COP.cop_stash is not refcounted */
cc49e20b 875 SvREFCNT_dec(CopFILEGV(cop));
57843af0 876#endif
0453d815 877 if (! specialWARN(cop->cop_warnings))
3eb57f73 878 SvREFCNT_dec(cop->cop_warnings);
ac27b0f5
NIS
879 if (! specialCopIO(cop->cop_io))
880 SvREFCNT_dec(cop->cop_io);
3eb57f73
HS
881}
882
93c66552
DM
883void
884Perl_op_null(pTHX_ OP *o)
8990e307 885{
acb36ea4
GS
886 if (o->op_type == OP_NULL)
887 return;
888 op_clear(o);
11343788
MB
889 o->op_targ = o->op_type;
890 o->op_type = OP_NULL;
22c35a8c 891 o->op_ppaddr = PL_ppaddr[OP_NULL];
8990e307
LW
892}
893
79072805
LW
894/* Contextualizers */
895
463ee0b2 896#define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
79072805
LW
897
898OP *
864dbfa3 899Perl_linklist(pTHX_ OP *o)
79072805
LW
900{
901 register OP *kid;
902
11343788
MB
903 if (o->op_next)
904 return o->op_next;
79072805
LW
905
906 /* establish postfix order */
11343788
MB
907 if (cUNOPo->op_first) {
908 o->op_next = LINKLIST(cUNOPo->op_first);
909 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
79072805
LW
910 if (kid->op_sibling)
911 kid->op_next = LINKLIST(kid->op_sibling);
912 else
11343788 913 kid->op_next = o;
79072805
LW
914 }
915 }
916 else
11343788 917 o->op_next = o;
79072805 918
11343788 919 return o->op_next;
79072805
LW
920}
921
922OP *
864dbfa3 923Perl_scalarkids(pTHX_ OP *o)
79072805
LW
924{
925 OP *kid;
11343788
MB
926 if (o && o->op_flags & OPf_KIDS) {
927 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW
928 scalar(kid);
929 }
11343788 930 return o;
79072805
LW
931}
932
76e3520e 933STATIC OP *
cea2e8a9 934S_scalarboolean(pTHX_ OP *o)
8990e307 935{
d008e5eb 936 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
d008e5eb 937 if (ckWARN(WARN_SYNTAX)) {
57843af0 938 line_t oldline = CopLINE(PL_curcop);
a0d0e21e 939
d008e5eb 940 if (PL_copline != NOLINE)
57843af0 941 CopLINE_set(PL_curcop, PL_copline);
cea2e8a9 942 Perl_warner(aTHX_ WARN_SYNTAX, "Found = in conditional, should be ==");
57843af0 943 CopLINE_set(PL_curcop, oldline);
d008e5eb 944 }
a0d0e21e 945 }
11343788 946 return scalar(o);
8990e307
LW
947}
948
949OP *
864dbfa3 950Perl_scalar(pTHX_ OP *o)
79072805
LW
951{
952 OP *kid;
953
a0d0e21e 954 /* assumes no premature commitment */
3280af22 955 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
5dc0d613 956 || o->op_type == OP_RETURN)
7e363e51 957 {
11343788 958 return o;
7e363e51 959 }
79072805 960
5dc0d613 961 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
79072805 962
11343788 963 switch (o->op_type) {
79072805 964 case OP_REPEAT:
11343788 965 scalar(cBINOPo->op_first);
8990e307 966 break;
79072805
LW
967 case OP_OR:
968 case OP_AND:
969 case OP_COND_EXPR:
11343788 970 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
8990e307 971 scalar(kid);
79072805 972 break;
a0d0e21e 973 case OP_SPLIT:
11343788 974 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
a0d0e21e
LW
975 if (!kPMOP->op_pmreplroot)
976 deprecate("implicit split to @_");
977 }
978 /* FALL THROUGH */
79072805 979 case OP_MATCH:
8782bef2 980 case OP_QR:
79072805
LW
981 case OP_SUBST:
982 case OP_NULL:
8990e307 983 default:
11343788
MB
984 if (o->op_flags & OPf_KIDS) {
985 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
8990e307
LW
986 scalar(kid);
987 }
79072805
LW
988 break;
989 case OP_LEAVE:
990 case OP_LEAVETRY:
5dc0d613 991 kid = cLISTOPo->op_first;
54310121 992 scalar(kid);
155aba94 993 while ((kid = kid->op_sibling)) {
54310121 994 if (kid->op_sibling)
995 scalarvoid(kid);
996 else
997 scalar(kid);
998 }
3280af22 999 WITH_THR(PL_curcop = &PL_compiling);
54310121 1000 break;
748a9306 1001 case OP_SCOPE:
79072805 1002 case OP_LINESEQ:
8990e307 1003 case OP_LIST:
11343788 1004 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
79072805
LW
1005 if (kid->op_sibling)
1006 scalarvoid(kid);
1007 else
1008 scalar(kid);
1009 }
3280af22 1010 WITH_THR(PL_curcop = &PL_compiling);
79072805
LW
1011 break;
1012 }
11343788 1013 return o;
79072805
LW
1014}
1015
1016OP *
864dbfa3 1017Perl_scalarvoid(pTHX_ OP *o)
79072805
LW
1018{
1019 OP *kid;
8990e307
LW
1020 char* useless = 0;
1021 SV* sv;
2ebea0a1
GS
1022 U8 want;
1023
acb36ea4
GS
1024 if (o->op_type == OP_NEXTSTATE
1025 || o->op_type == OP_SETSTATE
1026 || o->op_type == OP_DBSTATE
1027 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1028 || o->op_targ == OP_SETSTATE
1029 || o->op_targ == OP_DBSTATE)))
2ebea0a1 1030 PL_curcop = (COP*)o; /* for warning below */
79072805 1031
54310121 1032 /* assumes no premature commitment */
2ebea0a1
GS
1033 want = o->op_flags & OPf_WANT;
1034 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
5dc0d613 1035 || o->op_type == OP_RETURN)
7e363e51 1036 {
11343788 1037 return o;
7e363e51 1038 }
79072805 1039
b162f9ea 1040 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS
1041 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1042 {
b162f9ea 1043 return scalar(o); /* As if inside SASSIGN */
7e363e51 1044 }
1c846c1f 1045
5dc0d613 1046 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
79072805 1047
11343788 1048 switch (o->op_type) {
79072805 1049 default:
22c35a8c 1050 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
8990e307 1051 break;
36477c24 1052 /* FALL THROUGH */
1053 case OP_REPEAT:
11343788 1054 if (o->op_flags & OPf_STACKED)
8990e307 1055 break;
5d82c453
GA
1056 goto func_ops;
1057 case OP_SUBSTR:
1058 if (o->op_private == 4)
1059 break;
8990e307
LW
1060 /* FALL THROUGH */
1061 case OP_GVSV:
1062 case OP_WANTARRAY:
1063 case OP_GV:
1064 case OP_PADSV:
1065 case OP_PADAV:
1066 case OP_PADHV:
1067 case OP_PADANY:
1068 case OP_AV2ARYLEN:
8990e307 1069 case OP_REF:
a0d0e21e
LW
1070 case OP_REFGEN:
1071 case OP_SREFGEN:
8990e307
LW
1072 case OP_DEFINED:
1073 case OP_HEX:
1074 case OP_OCT:
1075 case OP_LENGTH:
8990e307
LW
1076 case OP_VEC:
1077 case OP_INDEX:
1078 case OP_RINDEX:
1079 case OP_SPRINTF:
1080 case OP_AELEM:
1081 case OP_AELEMFAST:
1082 case OP_ASLICE:
8990e307
LW
1083 case OP_HELEM:
1084 case OP_HSLICE:
1085 case OP_UNPACK:
1086 case OP_PACK:
8990e307
LW
1087 case OP_JOIN:
1088 case OP_LSLICE:
1089 case OP_ANONLIST:
1090 case OP_ANONHASH:
1091 case OP_SORT:
1092 case OP_REVERSE:
1093 case OP_RANGE:
1094 case OP_FLIP:
1095 case OP_FLOP:
1096 case OP_CALLER:
1097 case OP_FILENO:
1098 case OP_EOF:
1099 case OP_TELL:
1100 case OP_GETSOCKNAME:
1101 case OP_GETPEERNAME:
1102 case OP_READLINK:
1103 case OP_TELLDIR:
1104 case OP_GETPPID:
1105 case OP_GETPGRP:
1106 case OP_GETPRIORITY:
1107 case OP_TIME:
1108 case OP_TMS:
1109 case OP_LOCALTIME:
1110 case OP_GMTIME:
1111 case OP_GHBYNAME:
1112 case OP_GHBYADDR:
1113 case OP_GHOSTENT:
1114 case OP_GNBYNAME:
1115 case OP_GNBYADDR:
1116 case OP_GNETENT:
1117 case OP_GPBYNAME:
1118 case OP_GPBYNUMBER:
1119 case OP_GPROTOENT:
1120 case OP_GSBYNAME:
1121 case OP_GSBYPORT:
1122 case OP_GSERVENT:
1123 case OP_GPWNAM:
1124 case OP_GPWUID:
1125 case OP_GGRNAM:
1126 case OP_GGRGID:
1127 case OP_GETLOGIN:
5d82c453 1128 func_ops:
64aac5a9 1129 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
22c35a8c 1130 useless = PL_op_desc[o->op_type];
8990e307
LW
1131 break;
1132
1133 case OP_RV2GV:
1134 case OP_RV2SV:
1135 case OP_RV2AV:
1136 case OP_RV2HV:
192587c2 1137 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
11343788 1138 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
8990e307
LW
1139 useless = "a variable";
1140 break;
79072805
LW
1141
1142 case OP_CONST:
7766f137 1143 sv = cSVOPo_sv;
7a52d87a
GS
1144 if (cSVOPo->op_private & OPpCONST_STRICT)
1145 no_bareword_allowed(o);
1146 else {
d008e5eb
GS
1147 if (ckWARN(WARN_VOID)) {
1148 useless = "a constant";
960b4253
MG
1149 /* the constants 0 and 1 are permitted as they are
1150 conventionally used as dummies in constructs like
1151 1 while some_condition_with_side_effects; */
d008e5eb
GS
1152 if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1153 useless = 0;
1154 else if (SvPOK(sv)) {
a52fe3ac
A
1155 /* perl4's way of mixing documentation and code
1156 (before the invention of POD) was based on a
1157 trick to mix nroff and perl code. The trick was
1158 built upon these three nroff macros being used in
1159 void context. The pink camel has the details in
1160 the script wrapman near page 319. */
d008e5eb
GS
1161 if (strnEQ(SvPVX(sv), "di", 2) ||
1162 strnEQ(SvPVX(sv), "ds", 2) ||
1163 strnEQ(SvPVX(sv), "ig", 2))
1164 useless = 0;
1165 }
8990e307
LW
1166 }
1167 }
93c66552 1168 op_null(o); /* don't execute or even remember it */
79072805
LW
1169 break;
1170
1171 case OP_POSTINC:
11343788 1172 o->op_type = OP_PREINC; /* pre-increment is faster */
22c35a8c 1173 o->op_ppaddr = PL_ppaddr[OP_PREINC];
79072805
LW
1174 break;
1175
1176 case OP_POSTDEC:
11343788 1177 o->op_type = OP_PREDEC; /* pre-decrement is faster */
22c35a8c 1178 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
79072805
LW
1179 break;
1180
79072805
LW
1181 case OP_OR:
1182 case OP_AND:
1183 case OP_COND_EXPR:
11343788 1184 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
79072805
LW
1185 scalarvoid(kid);
1186 break;
5aabfad6 1187
a0d0e21e 1188 case OP_NULL:
11343788 1189 if (o->op_flags & OPf_STACKED)
a0d0e21e 1190 break;
5aabfad6 1191 /* FALL THROUGH */
2ebea0a1
GS
1192 case OP_NEXTSTATE:
1193 case OP_DBSTATE:
79072805
LW
1194 case OP_ENTERTRY:
1195 case OP_ENTER:
11343788 1196 if (!(o->op_flags & OPf_KIDS))
79072805 1197 break;
54310121 1198 /* FALL THROUGH */
463ee0b2 1199 case OP_SCOPE:
79072805
LW
1200 case OP_LEAVE:
1201 case OP_LEAVETRY:
a0d0e21e 1202 case OP_LEAVELOOP:
79072805 1203 case OP_LINESEQ:
79072805 1204 case OP_LIST:
11343788 1205 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW
1206 scalarvoid(kid);
1207 break;
c90c0ff4 1208 case OP_ENTEREVAL:
5196be3e 1209 scalarkids(o);
c90c0ff4 1210 break;
5aabfad6 1211 case OP_REQUIRE:
c90c0ff4 1212 /* all requires must return a boolean value */
5196be3e 1213 o->op_flags &= ~OPf_WANT;
d6483035
GS
1214 /* FALL THROUGH */
1215 case OP_SCALAR:
5196be3e 1216 return scalar(o);
a0d0e21e 1217 case OP_SPLIT:
11343788 1218 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
a0d0e21e
LW
1219 if (!kPMOP->op_pmreplroot)
1220 deprecate("implicit split to @_");
1221 }
1222 break;
79072805 1223 }
411caa50
JH
1224 if (useless && ckWARN(WARN_VOID))
1225 Perl_warner(aTHX_ WARN_VOID, "Useless use of %s in void context", useless);
11343788 1226 return o;
79072805
LW
1227}
1228
1229OP *
864dbfa3 1230Perl_listkids(pTHX_ OP *o)
79072805
LW
1231{
1232 OP *kid;
11343788
MB
1233 if (o && o->op_flags & OPf_KIDS) {
1234 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW
1235 list(kid);
1236 }
11343788 1237 return o;
79072805
LW
1238}
1239
1240OP *
864dbfa3 1241Perl_list(pTHX_ OP *o)
79072805
LW
1242{
1243 OP *kid;
1244
a0d0e21e 1245 /* assumes no premature commitment */
3280af22 1246 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
5dc0d613 1247 || o->op_type == OP_RETURN)
7e363e51 1248 {
11343788 1249 return o;
7e363e51 1250 }
79072805 1251
b162f9ea 1252 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS
1253 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1254 {
b162f9ea 1255 return o; /* As if inside SASSIGN */
7e363e51 1256 }
1c846c1f 1257
5dc0d613 1258 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
79072805 1259
11343788 1260 switch (o->op_type) {
79072805
LW
1261 case OP_FLOP:
1262 case OP_REPEAT:
11343788 1263 list(cBINOPo->op_first);
79072805
LW
1264 break;
1265 case OP_OR:
1266 case OP_AND:
1267 case OP_COND_EXPR:
11343788 1268 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
79072805
LW
1269 list(kid);
1270 break;
1271 default:
1272 case OP_MATCH:
8782bef2 1273 case OP_QR:
79072805
LW
1274 case OP_SUBST:
1275 case OP_NULL:
11343788 1276 if (!(o->op_flags & OPf_KIDS))
79072805 1277 break;
11343788
MB
1278 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1279 list(cBINOPo->op_first);
1280 return gen_constant_list(o);
79072805
LW
1281 }
1282 case OP_LIST:
11343788 1283 listkids(o);
79072805
LW
1284 break;
1285 case OP_LEAVE:
1286 case OP_LEAVETRY:
5dc0d613 1287 kid = cLISTOPo->op_first;
54310121 1288 list(kid);
155aba94 1289 while ((kid = kid->op_sibling)) {
54310121 1290 if (kid->op_sibling)
1291 scalarvoid(kid);
1292 else
1293 list(kid);
1294 }
3280af22 1295 WITH_THR(PL_curcop = &PL_compiling);
54310121 1296 break;
748a9306 1297 case OP_SCOPE:
79072805 1298 case OP_LINESEQ:
11343788 1299 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
79072805
LW
1300 if (kid->op_sibling)
1301 scalarvoid(kid);
1302 else
1303 list(kid);
1304 }
3280af22 1305 WITH_THR(PL_curcop = &PL_compiling);
79072805 1306 break;
c90c0ff4 1307 case OP_REQUIRE:
1308 /* all requires must return a boolean value */
5196be3e
MB
1309 o->op_flags &= ~OPf_WANT;
1310 return scalar(o);
79072805 1311 }
11343788 1312 return o;
79072805
LW
1313}
1314
1315OP *
864dbfa3 1316Perl_scalarseq(pTHX_ OP *o)
79072805
LW
1317{
1318 OP *kid;
1319
11343788
MB
1320 if (o) {
1321 if (o->op_type == OP_LINESEQ ||
1322 o->op_type == OP_SCOPE ||
1323 o->op_type == OP_LEAVE ||
1324 o->op_type == OP_LEAVETRY)
463ee0b2 1325 {
11343788 1326 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
ed6116ce 1327 if (kid->op_sibling) {
463ee0b2 1328 scalarvoid(kid);
ed6116ce 1329 }
463ee0b2 1330 }
3280af22 1331 PL_curcop = &PL_compiling;
79072805 1332 }
11343788 1333 o->op_flags &= ~OPf_PARENS;
3280af22 1334 if (PL_hints & HINT_BLOCK_SCOPE)
11343788 1335 o->op_flags |= OPf_PARENS;
79072805 1336 }
8990e307 1337 else
11343788
MB
1338 o = newOP(OP_STUB, 0);
1339 return o;
79072805
LW
1340}
1341
76e3520e 1342STATIC OP *
cea2e8a9 1343S_modkids(pTHX_ OP *o, I32 type)
79072805
LW
1344{
1345 OP *kid;
11343788
MB
1346 if (o && o->op_flags & OPf_KIDS) {
1347 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
463ee0b2 1348 mod(kid, type);
79072805 1349 }
11343788 1350 return o;
79072805
LW
1351}
1352
79072805 1353OP *
864dbfa3 1354Perl_mod(pTHX_ OP *o, I32 type)
79072805
LW
1355{
1356 OP *kid;
2d8e6c8d 1357 STRLEN n_a;
79072805 1358
3280af22 1359 if (!o || PL_error_count)
11343788 1360 return o;
79072805 1361
b162f9ea 1362 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS
1363 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1364 {
b162f9ea 1365 return o;
7e363e51 1366 }
1c846c1f 1367
11343788 1368 switch (o->op_type) {
68dc0745 1369 case OP_UNDEF:
3280af22 1370 PL_modcount++;
5dc0d613 1371 return o;
a0d0e21e 1372 case OP_CONST:
11343788 1373 if (!(o->op_private & (OPpCONST_ARYBASE)))
a0d0e21e 1374 goto nomod;
3280af22 1375 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
7766f137 1376 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
3280af22 1377 PL_eval_start = 0;
a0d0e21e
LW
1378 }
1379 else if (!type) {
3280af22
NIS
1380 SAVEI32(PL_compiling.cop_arybase);
1381 PL_compiling.cop_arybase = 0;
a0d0e21e
LW
1382 }
1383 else if (type == OP_REFGEN)
1384 goto nomod;
1385 else
cea2e8a9 1386 Perl_croak(aTHX_ "That use of $[ is unsupported");
a0d0e21e 1387 break;
5f05dabc 1388 case OP_STUB:
5196be3e 1389 if (o->op_flags & OPf_PARENS)
5f05dabc 1390 break;
1391 goto nomod;
a0d0e21e
LW
1392 case OP_ENTERSUB:
1393 if ((type == OP_UNDEF || type == OP_REFGEN) &&
11343788
MB
1394 !(o->op_flags & OPf_STACKED)) {
1395 o->op_type = OP_RV2CV; /* entersub => rv2cv */
22c35a8c 1396 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
11343788 1397 assert(cUNOPo->op_first->op_type == OP_NULL);
93c66552 1398 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
79072805
LW
1399 break;
1400 }
cd06dffe
GS
1401 else { /* lvalue subroutine call */
1402 o->op_private |= OPpLVAL_INTRO;
e6438c1a 1403 PL_modcount = RETURN_UNLIMITED_NUMBER;
4978d6d9 1404 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
cd06dffe
GS
1405 /* Backward compatibility mode: */
1406 o->op_private |= OPpENTERSUB_INARGS;
1407 break;
1408 }
1409 else { /* Compile-time error message: */
1410 OP *kid = cUNOPo->op_first;
1411 CV *cv;
1412 OP *okid;
1413
1414 if (kid->op_type == OP_PUSHMARK)
1415 goto skip_kids;
1416 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1417 Perl_croak(aTHX_
1418 "panic: unexpected lvalue entersub "
1419 "args: type/targ %ld:%ld",
1420 (long)kid->op_type,kid->op_targ);
1421 kid = kLISTOP->op_first;
1422 skip_kids:
1423 while (kid->op_sibling)
1424 kid = kid->op_sibling;
1425 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1426 /* Indirect call */
1427 if (kid->op_type == OP_METHOD_NAMED
1428 || kid->op_type == OP_METHOD)
1429 {
87d7fd28 1430 UNOP *newop;
cd06dffe
GS
1431
1432 if (kid->op_sibling || kid->op_next != kid) {
1433 yyerror("panic: unexpected optree near method call");
1434 break;
1435 }
1436
87d7fd28 1437 NewOp(1101, newop, 1, UNOP);
349fd7b7
GS
1438 newop->op_type = OP_RV2CV;
1439 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
87d7fd28
GS
1440 newop->op_first = Nullop;
1441 newop->op_next = (OP*)newop;
1442 kid->op_sibling = (OP*)newop;
349fd7b7 1443 newop->op_private |= OPpLVAL_INTRO;
cd06dffe
GS
1444 break;
1445 }
1c846c1f 1446
cd06dffe
GS
1447 if (kid->op_type != OP_RV2CV)
1448 Perl_croak(aTHX_
1449 "panic: unexpected lvalue entersub "
1450 "entry via type/targ %ld:%ld",
1451 (long)kid->op_type,kid->op_targ);
1452 kid->op_private |= OPpLVAL_INTRO;
1453 break; /* Postpone until runtime */
1454 }
1455
1456 okid = kid;
1457 kid = kUNOP->op_first;
1458 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1459 kid = kUNOP->op_first;
1460 if (kid->op_type == OP_NULL)
1461 Perl_croak(aTHX_
1462 "Unexpected constant lvalue entersub "
1463 "entry via type/targ %ld:%ld",
1464 (long)kid->op_type,kid->op_targ);
1465 if (kid->op_type != OP_GV) {
1466 /* Restore RV2CV to check lvalueness */
1467 restore_2cv:
1468 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1469 okid->op_next = kid->op_next;
1470 kid->op_next = okid;
1471 }
1472 else
1473 okid->op_next = Nullop;
1474 okid->op_type = OP_RV2CV;
1475 okid->op_targ = 0;
1476 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1477 okid->op_private |= OPpLVAL_INTRO;
1478 break;
1479 }
1480
638eceb6 1481 cv = GvCV(kGVOP_gv);
1c846c1f 1482 if (!cv)
cd06dffe
GS
1483 goto restore_2cv;
1484 if (CvLVALUE(cv))
1485 break;
1486 }
1487 }
79072805
LW
1488 /* FALL THROUGH */
1489 default:
a0d0e21e
LW
1490 nomod:
1491 /* grep, foreach, subcalls, refgen */
1492 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1493 break;
cea2e8a9 1494 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
638bc118 1495 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
cd06dffe
GS
1496 ? "do block"
1497 : (o->op_type == OP_ENTERSUB
1498 ? "non-lvalue subroutine call"
1499 : PL_op_desc[o->op_type])),
22c35a8c 1500 type ? PL_op_desc[type] : "local"));
11343788 1501 return o;
79072805 1502
a0d0e21e
LW
1503 case OP_PREINC:
1504 case OP_PREDEC:
1505 case OP_POW:
1506 case OP_MULTIPLY:
1507 case OP_DIVIDE:
1508 case OP_MODULO:
1509 case OP_REPEAT:
1510 case OP_ADD:
1511 case OP_SUBTRACT:
1512 case OP_CONCAT:
1513 case OP_LEFT_SHIFT:
1514 case OP_RIGHT_SHIFT:
1515 case OP_BIT_AND:
1516 case OP_BIT_XOR:
1517 case OP_BIT_OR:
1518 case OP_I_MULTIPLY:
1519 case OP_I_DIVIDE:
1520 case OP_I_MODULO:
1521 case OP_I_ADD:
1522 case OP_I_SUBTRACT:
11343788 1523 if (!(o->op_flags & OPf_STACKED))
a0d0e21e 1524 goto nomod;
3280af22 1525 PL_modcount++;
a0d0e21e
LW
1526 break;
1527
79072805 1528 case OP_COND_EXPR:
11343788 1529 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
463ee0b2 1530 mod(kid, type);
79072805
LW
1531 break;
1532
1533 case OP_RV2AV:
1534 case OP_RV2HV:
93af7a87 1535 if (!type && cUNOPo->op_first->op_type != OP_GV)
cea2e8a9 1536 Perl_croak(aTHX_ "Can't localize through a reference");
11343788 1537 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
e6438c1a 1538 PL_modcount = RETURN_UNLIMITED_NUMBER;
11343788 1539 return o; /* Treat \(@foo) like ordinary list. */
748a9306
LW
1540 }
1541 /* FALL THROUGH */
79072805 1542 case OP_RV2GV:
5dc0d613 1543 if (scalar_mod_type(o, type))
3fe9a6f1 1544 goto nomod;
11343788 1545 ref(cUNOPo->op_first, o->op_type);
79072805 1546 /* FALL THROUGH */
79072805
LW
1547 case OP_ASLICE:
1548 case OP_HSLICE:
78f9721b
SM
1549 if (type == OP_LEAVESUBLV)
1550 o->op_private |= OPpMAYBE_LVSUB;
1551 /* FALL THROUGH */
1552 case OP_AASSIGN:
93a17b20
LW
1553 case OP_NEXTSTATE:
1554 case OP_DBSTATE:
a0d0e21e 1555 case OP_CHOMP:
e6438c1a 1556 PL_modcount = RETURN_UNLIMITED_NUMBER;
79072805 1557 break;
463ee0b2 1558 case OP_RV2SV:
11343788 1559 if (!type && cUNOPo->op_first->op_type != OP_GV)
cea2e8a9 1560 Perl_croak(aTHX_ "Can't localize through a reference");
aeea060c 1561 ref(cUNOPo->op_first, o->op_type);
463ee0b2 1562 /* FALL THROUGH */
79072805 1563 case OP_GV:
463ee0b2 1564 case OP_AV2ARYLEN:
3280af22 1565 PL_hints |= HINT_BLOCK_SCOPE;
463ee0b2 1566 case OP_SASSIGN:
bf4b1e52
GS
1567 case OP_ANDASSIGN:
1568 case OP_ORASSIGN:
8990e307 1569 case OP_AELEMFAST:
3280af22 1570 PL_modcount++;
8990e307
LW
1571 break;
1572
748a9306
LW
1573 case OP_PADAV:
1574 case OP_PADHV:
e6438c1a 1575 PL_modcount = RETURN_UNLIMITED_NUMBER;
5196be3e
MB
1576 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1577 return o; /* Treat \(@foo) like ordinary list. */
1578 if (scalar_mod_type(o, type))
3fe9a6f1 1579 goto nomod;
78f9721b
SM
1580 if (type == OP_LEAVESUBLV)
1581 o->op_private |= OPpMAYBE_LVSUB;
748a9306
LW
1582 /* FALL THROUGH */
1583 case OP_PADSV:
3280af22 1584 PL_modcount++;
748a9306 1585 if (!type)
cea2e8a9 1586 Perl_croak(aTHX_ "Can't localize lexical variable %s",
2d8e6c8d 1587 SvPV(*av_fetch(PL_comppad_name, o->op_targ, 4), n_a));
463ee0b2
LW
1588 break;
1589
554b3eca 1590#ifdef USE_THREADS
2faa37cc 1591 case OP_THREADSV:
533c011a 1592 PL_modcount++; /* XXX ??? */
554b3eca
MB
1593 break;
1594#endif /* USE_THREADS */
1595
748a9306
LW
1596 case OP_PUSHMARK:
1597 break;
a0d0e21e 1598
69969c6f
SB
1599 case OP_KEYS:
1600 if (type != OP_SASSIGN)
1601 goto nomod;
5d82c453
GA
1602 goto lvalue_func;
1603 case OP_SUBSTR:
1604 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1605 goto nomod;
5f05dabc 1606 /* FALL THROUGH */
a0d0e21e 1607 case OP_POS:
463ee0b2 1608 case OP_VEC:
78f9721b
SM
1609 if (type == OP_LEAVESUBLV)
1610 o->op_private |= OPpMAYBE_LVSUB;
5d82c453 1611 lvalue_func:
11343788
MB
1612 pad_free(o->op_targ);
1613 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
5dc0d613 1614 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
11343788
MB
1615 if (o->op_flags & OPf_KIDS)
1616 mod(cBINOPo->op_first->op_sibling, type);
463ee0b2 1617 break;
a0d0e21e 1618
463ee0b2
LW
1619 case OP_AELEM:
1620 case OP_HELEM:
11343788 1621 ref(cBINOPo->op_first, o->op_type);
68dc0745 1622 if (type == OP_ENTERSUB &&
5dc0d613
MB
1623 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1624 o->op_private |= OPpLVAL_DEFER;
78f9721b
SM
1625 if (type == OP_LEAVESUBLV)
1626 o->op_private |= OPpMAYBE_LVSUB;
3280af22 1627 PL_modcount++;
463ee0b2
LW
1628 break;
1629
1630 case OP_SCOPE:
1631 case OP_LEAVE:
1632 case OP_ENTER:
78f9721b 1633 case OP_LINESEQ:
11343788
MB
1634 if (o->op_flags & OPf_KIDS)
1635 mod(cLISTOPo->op_last, type);
a0d0e21e
LW
1636 break;
1637
1638 case OP_NULL:
638bc118
GS
1639 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1640 goto nomod;
1641 else if (!(o->op_flags & OPf_KIDS))
463ee0b2 1642 break;
11343788
MB
1643 if (o->op_targ != OP_LIST) {
1644 mod(cBINOPo->op_first, type);
a0d0e21e
LW
1645 break;
1646 }
1647 /* FALL THROUGH */
463ee0b2 1648 case OP_LIST:
11343788 1649 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
463ee0b2
LW
1650 mod(kid, type);
1651 break;
78f9721b
SM
1652
1653 case OP_RETURN:
1654 if (type != OP_LEAVESUBLV)
1655 goto nomod;
1656 break; /* mod()ing was handled by ck_return() */
463ee0b2 1657 }
78f9721b
SM
1658 if (type != OP_LEAVESUBLV)
1659 o->op_flags |= OPf_MOD;
a0d0e21e
LW
1660
1661 if (type == OP_AASSIGN || type == OP_SASSIGN)
11343788 1662 o->op_flags |= OPf_SPECIAL|OPf_REF;
a0d0e21e 1663 else if (!type) {
11343788
MB
1664 o->op_private |= OPpLVAL_INTRO;
1665 o->op_flags &= ~OPf_SPECIAL;
3280af22 1666 PL_hints |= HINT_BLOCK_SCOPE;
463ee0b2 1667 }
78f9721b
SM
1668 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1669 && type != OP_LEAVESUBLV)
11343788
MB
1670 o->op_flags |= OPf_REF;
1671 return o;
463ee0b2
LW
1672}
1673
864dbfa3 1674STATIC bool
cea2e8a9 1675S_scalar_mod_type(pTHX_ OP *o, I32 type)
3fe9a6f1 1676{
1677 switch (type) {
1678 case OP_SASSIGN:
5196be3e 1679 if (o->op_type == OP_RV2GV)
3fe9a6f1 1680 return FALSE;
1681 /* FALL THROUGH */
1682 case OP_PREINC:
1683 case OP_PREDEC:
1684 case OP_POSTINC:
1685 case OP_POSTDEC:
1686 case OP_I_PREINC:
1687 case OP_I_PREDEC:
1688 case OP_I_POSTINC:
1689 case OP_I_POSTDEC:
1690 case OP_POW:
1691 case OP_MULTIPLY:
1692 case OP_DIVIDE:
1693 case OP_MODULO:
1694 case OP_REPEAT:
1695 case OP_ADD:
1696 case OP_SUBTRACT:
1697 case OP_I_MULTIPLY:
1698 case OP_I_DIVIDE:
1699 case OP_I_MODULO:
1700 case OP_I_ADD:
1701 case OP_I_SUBTRACT:
1702 case OP_LEFT_SHIFT:
1703 case OP_RIGHT_SHIFT:
1704 case OP_BIT_AND:
1705 case OP_BIT_XOR:
1706 case OP_BIT_OR:
1707 case OP_CONCAT:
1708 case OP_SUBST:
1709 case OP_TRANS:
49e9fbe6
GS
1710 case OP_READ:
1711 case OP_SYSREAD:
1712 case OP_RECV:
bf4b1e52
GS
1713 case OP_ANDASSIGN:
1714 case OP_ORASSIGN:
3fe9a6f1 1715 return TRUE;
1716 default:
1717 return FALSE;
1718 }
1719}
1720
35cd451c 1721STATIC bool
cea2e8a9 1722S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
35cd451c
GS
1723{
1724 switch (o->op_type) {
1725 case OP_PIPE_OP:
1726 case OP_SOCKPAIR:
1727 if (argnum == 2)
1728 return TRUE;
1729 /* FALL THROUGH */
1730 case OP_SYSOPEN:
1731 case OP_OPEN:
ded8aa31 1732 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
35cd451c
GS
1733 case OP_SOCKET:
1734 case OP_OPEN_DIR:
1735 case OP_ACCEPT:
1736 if (argnum == 1)
1737 return TRUE;
1738 /* FALL THROUGH */
1739 default:
1740 return FALSE;
1741 }
1742}
1743
463ee0b2 1744OP *
864dbfa3 1745Perl_refkids(pTHX_ OP *o, I32 type)
463ee0b2
LW
1746{
1747 OP *kid;
11343788
MB
1748 if (o && o->op_flags & OPf_KIDS) {
1749 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
463ee0b2
LW
1750 ref(kid, type);
1751 }
11343788 1752 return o;
463ee0b2
LW
1753}
1754
1755OP *
864dbfa3 1756Perl_ref(pTHX_ OP *o, I32 type)
463ee0b2
LW
1757{
1758 OP *kid;
463ee0b2 1759
3280af22 1760 if (!o || PL_error_count)
11343788 1761 return o;
463ee0b2 1762
11343788 1763 switch (o->op_type) {
a0d0e21e 1764 case OP_ENTERSUB:
afebc493 1765 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
11343788
MB
1766 !(o->op_flags & OPf_STACKED)) {
1767 o->op_type = OP_RV2CV; /* entersub => rv2cv */
22c35a8c 1768 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
11343788 1769 assert(cUNOPo->op_first->op_type == OP_NULL);
93c66552 1770 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
11343788 1771 o->op_flags |= OPf_SPECIAL;
8990e307
LW
1772 }
1773 break;
aeea060c 1774
463ee0b2 1775 case OP_COND_EXPR:
11343788 1776 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
463ee0b2
LW
1777 ref(kid, type);
1778 break;
8990e307 1779 case OP_RV2SV:
35cd451c
GS
1780 if (type == OP_DEFINED)
1781 o->op_flags |= OPf_SPECIAL; /* don't create GV */
11343788 1782 ref(cUNOPo->op_first, o->op_type);
4633a7c4
LW
1783 /* FALL THROUGH */
1784 case OP_PADSV:
5f05dabc 1785 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5dc0d613
MB
1786 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1787 : type == OP_RV2HV ? OPpDEREF_HV
1788 : OPpDEREF_SV);
11343788 1789 o->op_flags |= OPf_MOD;
a0d0e21e 1790 }
8990e307 1791 break;
1c846c1f 1792
2faa37cc 1793 case OP_THREADSV:
a863c7d1
MB
1794 o->op_flags |= OPf_MOD; /* XXX ??? */
1795 break;
1796
463ee0b2
LW
1797 case OP_RV2AV:
1798 case OP_RV2HV:
aeea060c 1799 o->op_flags |= OPf_REF;
8990e307 1800 /* FALL THROUGH */
463ee0b2 1801 case OP_RV2GV:
35cd451c
GS
1802 if (type == OP_DEFINED)
1803 o->op_flags |= OPf_SPECIAL; /* don't create GV */
11343788 1804 ref(cUNOPo->op_first, o->op_type);
463ee0b2 1805 break;
8990e307 1806
463ee0b2
LW
1807 case OP_PADAV:
1808 case OP_PADHV:
aeea060c 1809 o->op_flags |= OPf_REF;
79072805 1810 break;
aeea060c 1811
8990e307 1812 case OP_SCALAR:
79072805 1813 case OP_NULL:
11343788 1814 if (!(o->op_flags & OPf_KIDS))
463ee0b2 1815 break;
11343788 1816 ref(cBINOPo->op_first, type);
79072805
LW
1817 break;
1818 case OP_AELEM:
1819 case OP_HELEM:
11343788 1820 ref(cBINOPo->op_first, o->op_type);
5f05dabc 1821 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5dc0d613
MB
1822 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1823 : type == OP_RV2HV ? OPpDEREF_HV
1824 : OPpDEREF_SV);
11343788 1825 o->op_flags |= OPf_MOD;
8990e307 1826 }
79072805
LW
1827 break;
1828
463ee0b2 1829 case OP_SCOPE:
79072805
LW
1830 case OP_LEAVE:
1831 case OP_ENTER:
8990e307 1832 case OP_LIST:
11343788 1833 if (!(o->op_flags & OPf_KIDS))
79072805 1834 break;
11343788 1835 ref(cLISTOPo->op_last, type);
79072805 1836 break;
a0d0e21e
LW
1837 default:
1838 break;
79072805 1839 }
11343788 1840 return scalar(o);
8990e307 1841
79072805
LW
1842}
1843
09bef843
SB
1844STATIC OP *
1845S_dup_attrlist(pTHX_ OP *o)
1846{
1847 OP *rop = Nullop;
1848
1849 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1850 * where the first kid is OP_PUSHMARK and the remaining ones
1851 * are OP_CONST. We need to push the OP_CONST values.
1852 */
1853 if (o->op_type == OP_CONST)
1854 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1855 else {
1856 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1857 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1858 if (o->op_type == OP_CONST)
1859 rop = append_elem(OP_LIST, rop,
1860 newSVOP(OP_CONST, o->op_flags,
1861 SvREFCNT_inc(cSVOPo->op_sv)));
1862 }
1863 }
1864 return rop;
1865}
1866
1867STATIC void
1868S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
1869{
09bef843
SB
1870 SV *stashsv;
1871
1872 /* fake up C<use attributes $pkg,$rv,@attrs> */
1873 ENTER; /* need to protect against side-effects of 'use' */
1874 SAVEINT(PL_expect);
a9164de8 1875 if (stash)
09bef843
SB
1876 stashsv = newSVpv(HvNAME(stash), 0);
1877 else
1878 stashsv = &PL_sv_no;
e4783991 1879
09bef843 1880#define ATTRSMODULE "attributes"
e4783991
GS
1881
1882 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1883 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1884 Nullsv,
1885 prepend_elem(OP_LIST,
1886 newSVOP(OP_CONST, 0, stashsv),
1887 prepend_elem(OP_LIST,
1888 newSVOP(OP_CONST, 0,
1889 newRV(target)),
1890 dup_attrlist(attrs))));
09bef843
SB
1891 LEAVE;
1892}
1893
be3174d2
GS
1894void
1895Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
1896 char *attrstr, STRLEN len)
1897{
1898 OP *attrs = Nullop;
1899
1900 if (!len) {
1901 len = strlen(attrstr);
1902 }
1903
1904 while (len) {
1905 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1906 if (len) {
1907 char *sstr = attrstr;
1908 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1909 attrs = append_elem(OP_LIST, attrs,
1910 newSVOP(OP_CONST, 0,
1911 newSVpvn(sstr, attrstr-sstr)));
1912 }
1913 }
1914
1915 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1916 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1917 Nullsv, prepend_elem(OP_LIST,
1918 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1919 prepend_elem(OP_LIST,
1920 newSVOP(OP_CONST, 0,
1921 newRV((SV*)cv)),
1922 attrs)));
1923}
1924
09bef843
SB
1925STATIC OP *
1926S_my_kid(pTHX_ OP *o, OP *attrs)
93a17b20
LW
1927{
1928 OP *kid;
93a17b20
LW
1929 I32 type;
1930
3280af22 1931 if (!o || PL_error_count)
11343788 1932 return o;
93a17b20 1933
11343788 1934 type = o->op_type;
93a17b20 1935 if (type == OP_LIST) {
11343788 1936 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
09bef843 1937 my_kid(kid, attrs);
dab48698 1938 } else if (type == OP_UNDEF) {
7766148a 1939 return o;
77ca0c92
LW
1940 } else if (type == OP_RV2SV || /* "our" declaration */
1941 type == OP_RV2AV ||
1942 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
0256094b
DM
1943 if (attrs) {
1944 GV *gv = cGVOPx_gv(cUNOPo->op_first);
1945 PL_in_my = FALSE;
1946 PL_in_my_stash = Nullhv;
1947 apply_attrs(GvSTASH(gv),
1948 (type == OP_RV2SV ? GvSV(gv) :
1949 type == OP_RV2AV ? (SV*)GvAV(gv) :
1950 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1951 attrs);
1952 }
192587c2 1953 o->op_private |= OPpOUR_INTRO;
77ca0c92 1954 return o;
dab48698 1955 } else if (type != OP_PADSV &&
93a17b20
LW
1956 type != OP_PADAV &&
1957 type != OP_PADHV &&
1958 type != OP_PUSHMARK)
1959 {
eb64745e
GS
1960 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1961 PL_op_desc[o->op_type],
1962 PL_in_my == KEY_our ? "our" : "my"));
11343788 1963 return o;
93a17b20 1964 }
09bef843
SB
1965 else if (attrs && type != OP_PUSHMARK) {
1966 HV *stash;
1967 SV *padsv;
1968 SV **namesvp;
1969
eb64745e
GS
1970 PL_in_my = FALSE;
1971 PL_in_my_stash = Nullhv;
1972
09bef843
SB
1973 /* check for C<my Dog $spot> when deciding package */
1974 namesvp = av_fetch(PL_comppad_name, o->op_targ, FALSE);
a9164de8 1975 if (namesvp && *namesvp && (SvFLAGS(*namesvp) & SVpad_TYPED))
09bef843
SB
1976 stash = SvSTASH(*namesvp);
1977 else
1978 stash = PL_curstash;
1979 padsv = PAD_SV(o->op_targ);
1980 apply_attrs(stash, padsv, attrs);
1981 }
11343788
MB
1982 o->op_flags |= OPf_MOD;
1983 o->op_private |= OPpLVAL_INTRO;
1984 return o;
93a17b20
LW
1985}
1986
1987OP *
09bef843
SB
1988Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1989{
1990 if (o->op_flags & OPf_PARENS)
1991 list(o);
09bef843
SB
1992 if (attrs)
1993 SAVEFREEOP(attrs);
eb64745e
GS
1994 o = my_kid(o, attrs);
1995 PL_in_my = FALSE;
1996 PL_in_my_stash = Nullhv;
1997 return o;
09bef843
SB
1998}
1999
2000OP *
2001Perl_my(pTHX_ OP *o)
2002{
2003 return my_kid(o, Nullop);
2004}
2005
2006OP *
864dbfa3 2007Perl_sawparens(pTHX_ OP *o)
79072805
LW
2008{
2009 if (o)
2010 o->op_flags |= OPf_PARENS;
2011 return o;
2012}
2013
2014OP *
864dbfa3 2015Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
79072805 2016{
11343788 2017 OP *o;
79072805 2018
e476b1b5 2019 if (ckWARN(WARN_MISC) &&
599cee73
PM
2020 (left->op_type == OP_RV2AV ||
2021 left->op_type == OP_RV2HV ||
2022 left->op_type == OP_PADAV ||
2023 left->op_type == OP_PADHV)) {
22c35a8c 2024 char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
599cee73
PM
2025 right->op_type == OP_TRANS)
2026 ? right->op_type : OP_MATCH];
dff6d3cd
GS
2027 const char *sample = ((left->op_type == OP_RV2AV ||
2028 left->op_type == OP_PADAV)
2029 ? "@array" : "%hash");
e476b1b5 2030 Perl_warner(aTHX_ WARN_MISC,
1c846c1f 2031 "Applying %s to %s will act on scalar(%s)",
599cee73 2032 desc, sample, sample);
2ae324a7 2033 }
2034
de4bf5b3
MG
2035 if (!(right->op_flags & OPf_STACKED) &&
2036 (right->op_type == OP_MATCH ||
79072805 2037 right->op_type == OP_SUBST ||
de4bf5b3 2038 right->op_type == OP_TRANS)) {
79072805 2039 right->op_flags |= OPf_STACKED;
55d27857
RG
2040 if ((right->op_type != OP_MATCH &&
2041 ! (right->op_type == OP_TRANS &&
2042 right->op_private & OPpTRANS_IDENTICAL)) ||
2043 /* if SV has magic, then match on original SV, not on its copy.
2044 see note in pp_helem() */
2045 (right->op_type == OP_MATCH &&
2046 (left->op_type == OP_AELEM ||
2047 left->op_type == OP_HELEM ||
2048 left->op_type == OP_AELEMFAST)))
463ee0b2 2049 left = mod(left, right->op_type);
79072805 2050 if (right->op_type == OP_TRANS)
11343788 2051 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
79072805 2052 else
11343788 2053 o = prepend_elem(right->op_type, scalar(left), right);
79072805 2054 if (type == OP_NOT)
11343788
MB
2055 return newUNOP(OP_NOT, 0, scalar(o));
2056 return o;
79072805
LW
2057 }
2058 else
2059 return bind_match(type, left,
2060 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
2061}
2062
2063OP *
864dbfa3 2064Perl_invert(pTHX_ OP *o)
79072805 2065{
11343788
MB
2066 if (!o)
2067 return o;
79072805 2068 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
11343788 2069 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
79072805
LW
2070}
2071
2072OP *
864dbfa3 2073Perl_scope(pTHX_ OP *o)
79072805
LW
2074{
2075 if (o) {
3280af22 2076 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
463ee0b2
LW
2077 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2078 o->op_type = OP_LEAVE;
22c35a8c 2079 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
463ee0b2
LW
2080 }
2081 else {
2082 if (o->op_type == OP_LINESEQ) {
2083 OP *kid;
2084 o->op_type = OP_SCOPE;
22c35a8c 2085 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
c3ed7a6a
GS
2086 kid = ((LISTOP*)o)->op_first;
2087 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
93c66552 2088 op_null(kid);
463ee0b2
LW
2089 }
2090 else
748a9306 2091 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
463ee0b2 2092 }
79072805
LW
2093 }
2094 return o;
2095}
2096
b3ac6de7 2097void
864dbfa3 2098Perl_save_hints(pTHX)
b3ac6de7 2099{
3280af22
NIS
2100 SAVEI32(PL_hints);
2101 SAVESPTR(GvHV(PL_hintgv));
2102 GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
2103 SAVEFREESV(GvHV(PL_hintgv));
b3ac6de7
IZ
2104}
2105
a0d0e21e 2106int
864dbfa3 2107Perl_block_start(pTHX_ int full)
79072805 2108{
3280af22 2109 int retval = PL_savestack_ix;
b3ac6de7 2110
3280af22 2111 SAVEI32(PL_comppad_name_floor);
43d4d5c6
GS
2112 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
2113 if (full)
2114 PL_comppad_name_fill = PL_comppad_name_floor;
2115 if (PL_comppad_name_floor < 0)
2116 PL_comppad_name_floor = 0;
3280af22
NIS
2117 SAVEI32(PL_min_intro_pending);
2118 SAVEI32(PL_max_intro_pending);
2119 PL_min_intro_pending = 0;
2120 SAVEI32(PL_comppad_name_fill);
2121 SAVEI32(PL_padix_floor);
2122 PL_padix_floor = PL_padix;
2123 PL_pad_reset_pending = FALSE;
b3ac6de7 2124 SAVEHINTS();
3280af22 2125 PL_hints &= ~HINT_BLOCK_SCOPE;
1c846c1f 2126 SAVESPTR(PL_compiling.cop_warnings);
0453d815 2127 if (! specialWARN(PL_compiling.cop_warnings)) {
599cee73
PM
2128 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2129 SAVEFREESV(PL_compiling.cop_warnings) ;
2130 }
ac27b0f5
NIS
2131 SAVESPTR(PL_compiling.cop_io);
2132 if (! specialCopIO(PL_compiling.cop_io)) {
2133 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
2134 SAVEFREESV(PL_compiling.cop_io) ;
2135 }
a0d0e21e
LW
2136 return retval;
2137}
2138
2139OP*
864dbfa3 2140Perl_block_end(pTHX_ I32 floor, OP *seq)
a0d0e21e 2141{
3280af22 2142 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
a0d0e21e 2143 OP* retval = scalarseq(seq);
a0d0e21e 2144 LEAVE_SCOPE(floor);
3280af22 2145 PL_pad_reset_pending = FALSE;
e24b16f9 2146 PL_compiling.op_private = PL_hints;
a0d0e21e 2147 if (needblockscope)
3280af22
NIS
2148 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2149 pad_leavemy(PL_comppad_name_fill);
2150 PL_cop_seqmax++;
a0d0e21e
LW
2151 return retval;
2152}
2153
76e3520e 2154STATIC OP *
cea2e8a9 2155S_newDEFSVOP(pTHX)
54b9620d
MB
2156{
2157#ifdef USE_THREADS
2158 OP *o = newOP(OP_THREADSV, 0);
2159 o->op_targ = find_threadsv("_");
2160 return o;
2161#else
3280af22 2162 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
54b9620d
MB
2163#endif /* USE_THREADS */
2164}
2165
a0d0e21e 2166void
864dbfa3 2167Perl_newPROG(pTHX_ OP *o)
a0d0e21e 2168{
3280af22 2169 if (PL_in_eval) {
b295d113
TH
2170 if (PL_eval_root)
2171 return;
faef0170
HS
2172 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2173 ((PL_in_eval & EVAL_KEEPERR)
2174 ? OPf_SPECIAL : 0), o);
3280af22 2175 PL_eval_start = linklist(PL_eval_root);
7934575e
GS
2176 PL_eval_root->op_private |= OPpREFCOUNTED;
2177 OpREFCNT_set(PL_eval_root, 1);
3280af22 2178 PL_eval_root->op_next = 0;
a2efc822 2179 CALL_PEEP(PL_eval_start);
a0d0e21e
LW
2180 }
2181 else {
5dc0d613 2182 if (!o)
a0d0e21e 2183 return;
3280af22
NIS
2184 PL_main_root = scope(sawparens(scalarvoid(o)));
2185 PL_curcop = &PL_compiling;
2186 PL_main_start = LINKLIST(PL_main_root);
7934575e
GS
2187 PL_main_root->op_private |= OPpREFCOUNTED;
2188 OpREFCNT_set(PL_main_root, 1);
3280af22 2189 PL_main_root->op_next = 0;
a2efc822 2190 CALL_PEEP(PL_main_start);
3280af22 2191 PL_compcv = 0;
3841441e 2192
4fdae800 2193 /* Register with debugger */
84902520 2194 if (PERLDB_INTER) {
864dbfa3 2195 CV *cv = get_cv("DB::postponed", FALSE);
3841441e
CS
2196 if (cv) {
2197 dSP;
924508f0 2198 PUSHMARK(SP);
cc49e20b 2199 XPUSHs((SV*)CopFILEGV(&PL_compiling));
3841441e 2200 PUTBACK;
864dbfa3 2201 call_sv((SV*)cv, G_DISCARD);
3841441e
CS
2202 }
2203 }
79072805 2204 }
79072805
LW
2205}
2206
2207OP *
864dbfa3 2208Perl_localize(pTHX_ OP *o, I32 lex)
79072805
LW
2209{
2210 if (o->op_flags & OPf_PARENS)
2211 list(o);
8990e307 2212 else {
64420d0d
JH
2213 if (ckWARN(WARN_PARENTHESIS)
2214 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
2215 {
2216 char *s = PL_bufptr;
2217
2218 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ", *s)))
2219 s++;
2220
a0d0e21e 2221 if (*s == ';' || *s == '=')
eb64745e
GS
2222 Perl_warner(aTHX_ WARN_PARENTHESIS,
2223 "Parentheses missing around \"%s\" list",
2224 lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
8990e307
LW
2225 }
2226 }
93a17b20 2227 if (lex)
eb64745e 2228 o = my(o);
93a17b20 2229 else
eb64745e
GS
2230 o = mod(o, OP_NULL); /* a bit kludgey */
2231 PL_in_my = FALSE;
2232 PL_in_my_stash = Nullhv;
2233 return o;
79072805
LW
2234}
2235
2236OP *
864dbfa3 2237Perl_jmaybe(pTHX_ OP *o)
79072805
LW
2238{
2239 if (o->op_type == OP_LIST) {
554b3eca
MB
2240 OP *o2;
2241#ifdef USE_THREADS
2faa37cc 2242 o2 = newOP(OP_THREADSV, 0);
54b9620d 2243 o2->op_targ = find_threadsv(";");
554b3eca
MB
2244#else
2245 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2246#endif /* USE_THREADS */
2247 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
79072805
LW
2248 }
2249 return o;
2250}
2251
2252OP *
864dbfa3 2253Perl_fold_constants(pTHX_ register OP *o)
79072805
LW
2254{
2255 register OP *curop;
2256 I32 type = o->op_type;
748a9306 2257 SV *sv;
79072805 2258
22c35a8c 2259 if (PL_opargs[type] & OA_RETSCALAR)
79072805 2260 scalar(o);
b162f9ea 2261 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
ed6116ce 2262 o->op_targ = pad_alloc(type, SVs_PADTMP);
79072805 2263
eac055e9
GS
2264 /* integerize op, unless it happens to be C<-foo>.
2265 * XXX should pp_i_negate() do magic string negation instead? */
2266 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2267 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2268 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2269 {
22c35a8c 2270 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
eac055e9 2271 }
85e6fe83 2272
22c35a8c 2273 if (!(PL_opargs[type] & OA_FOLDCONST))
79072805
LW
2274 goto nope;
2275
de939608 2276 switch (type) {
7a52d87a
GS
2277 case OP_NEGATE:
2278 /* XXX might want a ck_negate() for this */
2279 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2280 break;
de939608
CS
2281 case OP_SPRINTF:
2282 case OP_UCFIRST:
2283 case OP_LCFIRST:
2284 case OP_UC:
2285 case OP_LC:
69dcf70c
MB
2286 case OP_SLT:
2287 case OP_SGT:
2288 case OP_SLE:
2289 case OP_SGE:
2290 case OP_SCMP:
2de3dbcc
JH
2291 /* XXX what about the numeric ops? */
2292 if (PL_hints & HINT_LOCALE)
de939608
CS
2293 goto nope;
2294 }
2295
3280af22 2296 if (PL_error_count)
a0d0e21e
LW
2297 goto nope; /* Don't try to run w/ errors */
2298
79072805 2299 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
11fa937b
GS
2300 if ((curop->op_type != OP_CONST ||
2301 (curop->op_private & OPpCONST_BARE)) &&
7a52d87a
GS
2302 curop->op_type != OP_LIST &&
2303 curop->op_type != OP_SCALAR &&
2304 curop->op_type != OP_NULL &&
2305 curop->op_type != OP_PUSHMARK)
2306 {
79072805
LW
2307 goto nope;
2308 }
2309 }
2310
2311 curop = LINKLIST(o);
2312 o->op_next = 0;
533c011a 2313 PL_op = curop;
cea2e8a9 2314 CALLRUNOPS(aTHX);
3280af22 2315 sv = *(PL_stack_sp--);
748a9306 2316 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
79072805 2317 pad_swipe(o->op_targ);
748a9306
LW
2318 else if (SvTEMP(sv)) { /* grab mortal temp? */
2319 (void)SvREFCNT_inc(sv);
2320 SvTEMP_off(sv);
85e6fe83 2321 }
79072805
LW
2322 op_free(o);
2323 if (type == OP_RV2GV)
b1cb66bf 2324 return newGVOP(OP_GV, 0, (GV*)sv);
748a9306 2325 else {
ee580363
GS
2326 /* try to smush double to int, but don't smush -2.0 to -2 */
2327 if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
2328 type != OP_NEGATE)
2329 {
28e5dec8
JH
2330#ifdef PERL_PRESERVE_IVUV
2331 /* Only bother to attempt to fold to IV if
2332 most operators will benefit */
2333 SvIV_please(sv);
2334#endif
748a9306 2335 }
a86a20aa 2336 return newSVOP(OP_CONST, 0, sv);
748a9306 2337 }
aeea060c 2338
79072805 2339 nope:
22c35a8c 2340 if (!(PL_opargs[type] & OA_OTHERINT))
79072805 2341 return o;
79072805 2342
3280af22 2343 if (!(PL_hints & HINT_INTEGER)) {
4bb9f687
GS
2344 if (type == OP_MODULO
2345 || type == OP_DIVIDE
2346 || !(o->op_flags & OPf_KIDS))
2347 {
85e6fe83 2348 return o;
4bb9f687 2349 }
85e6fe83
LW
2350
2351 for (curop = ((UNOP*)o)->op_first; curop; curop = curop->op_sibling) {
2352 if (curop->op_type == OP_CONST) {
b1cb66bf 2353 if (SvIOK(((SVOP*)curop)->op_sv))
85e6fe83
LW
2354 continue;
2355 return o;
2356 }
22c35a8c 2357 if (PL_opargs[curop->op_type] & OA_RETINTEGER)
79072805
LW
2358 continue;
2359 return o;
2360 }
22c35a8c 2361 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
79072805
LW
2362 }
2363
79072805
LW
2364 return o;
2365}
2366
2367OP *
864dbfa3 2368Perl_gen_constant_list(pTHX_ register OP *o)
79072805
LW
2369{
2370 register OP *curop;
3280af22 2371 I32 oldtmps_floor = PL_tmps_floor;
79072805 2372
a0d0e21e 2373 list(o);
3280af22 2374 if (PL_error_count)
a0d0e21e
LW
2375 return o; /* Don't attempt to run with errors */
2376
533c011a 2377 PL_op = curop = LINKLIST(o);
a0d0e21e 2378 o->op_next = 0;
a2efc822 2379 CALL_PEEP(curop);
cea2e8a9
GS
2380 pp_pushmark();
2381 CALLRUNOPS(aTHX);
533c011a 2382 PL_op = curop;
cea2e8a9 2383 pp_anonlist();
3280af22 2384 PL_tmps_floor = oldtmps_floor;
79072805
LW
2385
2386 o->op_type = OP_RV2AV;
22c35a8c 2387 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
79072805 2388 curop = ((UNOP*)o)->op_first;
3280af22 2389 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
79072805 2390 op_free(curop);
79072805
LW
2391 linklist(o);
2392 return list(o);
2393}
2394
2395OP *
864dbfa3 2396Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
79072805 2397{
11343788
MB
2398 if (!o || o->op_type != OP_LIST)
2399 o = newLISTOP(OP_LIST, 0, o, Nullop);
748a9306 2400 else
5dc0d613 2401 o->op_flags &= ~OPf_WANT;
79072805 2402
22c35a8c 2403 if (!(PL_opargs[type] & OA_MARK))
93c66552 2404 op_null(cLISTOPo->op_first);
8990e307 2405
11343788 2406 o->op_type = type;
22c35a8c 2407 o->op_ppaddr = PL_ppaddr[type];
11343788 2408 o->op_flags |= flags;
79072805 2409
11343788
MB
2410 o = CHECKOP(type, o);
2411 if (o->op_type != type)
2412 return o;
79072805 2413
11343788 2414 return fold_constants(o);
79072805
LW
2415}
2416
2417/* List constructors */
2418
2419OP *
864dbfa3 2420Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW
2421{
2422 if (!first)
2423 return last;
8990e307
LW
2424
2425 if (!last)
79072805 2426 return first;
8990e307 2427
155aba94
GS
2428 if (first->op_type != type
2429 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2430 {
2431 return newLISTOP(type, 0, first, last);
2432 }
79072805 2433
a0d0e21e
LW
2434 if (first->op_flags & OPf_KIDS)
2435 ((LISTOP*)first)->op_last->op_sibling = last;
2436 else {
2437 first->op_flags |= OPf_KIDS;
2438 ((LISTOP*)first)->op_first = last;
2439 }
2440 ((LISTOP*)first)->op_last = last;
a0d0e21e 2441 return first;
79072805
LW
2442}
2443
2444OP *
864dbfa3 2445Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
79072805
LW
2446{
2447 if (!first)
2448 return (OP*)last;
8990e307
LW
2449
2450 if (!last)
79072805 2451 return (OP*)first;
8990e307
LW
2452
2453 if (first->op_type != type)
79072805 2454 return prepend_elem(type, (OP*)first, (OP*)last);
8990e307
LW
2455
2456 if (last->op_type != type)
79072805
LW
2457 return append_elem(type, (OP*)first, (OP*)last);
2458
2459 first->op_last->op_sibling = last->op_first;
2460 first->op_last = last->op_last;
117dada2 2461 first->op_flags |= (last->op_flags & OPf_KIDS);
1c846c1f 2462
b7dc083c
NIS
2463#ifdef PL_OP_SLAB_ALLOC
2464#else
1c846c1f 2465 Safefree(last);
b7dc083c 2466#endif
79072805
LW
2467 return (OP*)first;
2468}
2469
2470OP *
864dbfa3 2471Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW
2472{
2473 if (!first)
2474 return last;
8990e307
LW
2475
2476 if (!last)
79072805 2477 return first;
8990e307
LW
2478
2479 if (last->op_type == type) {
2480 if (type == OP_LIST) { /* already a PUSHMARK there */
2481 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2482 ((LISTOP*)last)->op_first->op_sibling = first;
36a5d4ba
DC
2483 if (!(first->op_flags & OPf_PARENS))
2484 last->op_flags &= ~OPf_PARENS;
8990e307
LW
2485 }
2486 else {
2487 if (!(last->op_flags & OPf_KIDS)) {
2488 ((LISTOP*)last)->op_last = first;
2489 last->op_flags |= OPf_KIDS;
2490 }
2491 first->op_sibling = ((LISTOP*)last)->op_first;
2492 ((LISTOP*)last)->op_first = first;
79072805 2493 }
117dada2 2494 last->op_flags |= OPf_KIDS;
79072805
LW
2495 return last;
2496 }
2497
2498 return newLISTOP(type, 0, first, last);
2499}
2500
2501/* Constructors */
2502
2503OP *
864dbfa3 2504Perl_newNULLLIST(pTHX)
79072805 2505{
8990e307
LW
2506 return newOP(OP_STUB, 0);
2507}
2508
2509OP *
864dbfa3 2510Perl_force_list(pTHX_ OP *o)
8990e307 2511{
11343788
MB
2512 if (!o || o->op_type != OP_LIST)
2513 o = newLISTOP(OP_LIST, 0, o, Nullop);
93c66552 2514 op_null(o);
11343788 2515 return o;
79072805
LW
2516}
2517
2518OP *
864dbfa3 2519Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
79072805
LW
2520{
2521 LISTOP *listop;
2522
b7dc083c 2523 NewOp(1101, listop, 1, LISTOP);
79072805
LW
2524
2525 listop->op_type = type;
22c35a8c 2526 listop->op_ppaddr = PL_ppaddr[type];
117dada2
SM
2527 if (first || last)
2528 flags |= OPf_KIDS;
79072805 2529 listop->op_flags = flags;
79072805
LW
2530
2531 if (!last && first)
2532 last = first;
2533 else if (!first && last)
2534 first = last;
8990e307
LW
2535 else if (first)
2536 first->op_sibling = last;
79072805
LW
2537 listop->op_first = first;
2538 listop->op_last = last;
8990e307
LW
2539 if (type == OP_LIST) {
2540 OP* pushop;
2541 pushop = newOP(OP_PUSHMARK, 0);
2542 pushop->op_sibling = first;
2543 listop->op_first = pushop;
2544 listop->op_flags |= OPf_KIDS;
2545 if (!last)
2546 listop->op_last = pushop;
2547 }
79072805
LW
2548
2549 return (OP*)listop;
2550}
2551
2552OP *
864dbfa3 2553Perl_newOP(pTHX_ I32 type, I32 flags)
79072805 2554{
11343788 2555 OP *o;
b7dc083c 2556 NewOp(1101, o, 1, OP);
11343788 2557 o->op_type = type;
22c35a8c 2558 o->op_ppaddr = PL_ppaddr[type];
11343788 2559 o->op_flags = flags;
79072805 2560
11343788
MB
2561 o->op_next = o;
2562 o->op_private = 0 + (flags >> 8);
22c35a8c 2563 if (PL_opargs[type] & OA_RETSCALAR)
11343788 2564 scalar(o);
22c35a8c 2565 if (PL_opargs[type] & OA_TARGET)
11343788
MB
2566 o->op_targ = pad_alloc(type, SVs_PADTMP);
2567 return CHECKOP(type, o);
79072805
LW
2568}
2569
2570OP *
864dbfa3 2571Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
79072805
LW
2572{
2573 UNOP *unop;
2574
93a17b20 2575 if (!first)
aeea060c 2576 first = newOP(OP_STUB, 0);
22c35a8c 2577 if (PL_opargs[type] & OA_MARK)
8990e307 2578 first = force_list(first);
93a17b20 2579
b7dc083c 2580 NewOp(1101, unop, 1, UNOP);
79072805 2581 unop->op_type = type;
22c35a8c 2582 unop->op_ppaddr = PL_ppaddr[type];
79072805
LW
2583 unop->op_first = first;
2584 unop->op_flags = flags | OPf_KIDS;
c07a80fd 2585 unop->op_private = 1 | (flags >> 8);
e50aee73 2586 unop = (UNOP*) CHECKOP(type, unop);
79072805
LW
2587 if (unop->op_next)
2588 return (OP*)unop;
2589
a0d0e21e 2590 return fold_constants((OP *) unop);
79072805
LW
2591}
2592
2593OP *
864dbfa3 2594Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
79072805
LW
2595{
2596 BINOP *binop;
b7dc083c 2597 NewOp(1101, binop, 1, BINOP);
79072805
LW
2598
2599 if (!first)
2600 first = newOP(OP_NULL, 0);
2601
2602 binop->op_type = type;
22c35a8c 2603 binop->op_ppaddr = PL_ppaddr[type];
79072805
LW
2604 binop->op_first = first;
2605 binop->op_flags = flags | OPf_KIDS;
2606 if (!last) {
2607 last = first;
c07a80fd 2608 binop->op_private = 1 | (flags >> 8);
79072805
LW
2609 }
2610 else {
c07a80fd 2611 binop->op_private = 2 | (flags >> 8);
79072805
LW
2612 first->op_sibling = last;
2613 }
2614
e50aee73 2615 binop = (BINOP*)CHECKOP(type, binop);
b162f9ea 2616 if (binop->op_next || binop->op_type != type)
79072805
LW
2617 return (OP*)binop;
2618
7284ab6f 2619 binop->op_last = binop->op_first->op_sibling;
79072805 2620
a0d0e21e 2621 return fold_constants((OP *)binop);
79072805
LW
2622}
2623
a0ed51b3 2624static int
2b9d42f0
NIS
2625uvcompare(const void *a, const void *b)
2626{
2627 if (*((UV *)a) < (*(UV *)b))
2628 return -1;
2629 if (*((UV *)a) > (*(UV *)b))
2630 return 1;
2631 if (*((UV *)a+1) < (*(UV *)b+1))
2632 return -1;
2633 if (*((UV *)a+1) > (*(UV *)b+1))
2634 return 1;
a0ed51b3
LW
2635 return 0;
2636}
2637
79072805 2638OP *
864dbfa3 2639Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
79072805 2640{
79072805
LW
2641 SV *tstr = ((SVOP*)expr)->op_sv;
2642 SV *rstr = ((SVOP*)repl)->op_sv;
463ee0b2
LW
2643 STRLEN tlen;
2644 STRLEN rlen;
9b877dbb
IH
2645 U8 *t = (U8*)SvPV(tstr, tlen);
2646 U8 *r = (U8*)SvPV(rstr, rlen);
79072805
LW
2647 register I32 i;
2648 register I32 j;
a0ed51b3 2649 I32 del;
79072805 2650 I32 complement;
5d06d08e 2651 I32 squash;
9b877dbb 2652 I32 grows = 0;
79072805
LW
2653 register short *tbl;
2654
800b4dc4 2655 PL_hints |= HINT_BLOCK_SCOPE;
11343788 2656 complement = o->op_private & OPpTRANS_COMPLEMENT;
a0ed51b3 2657 del = o->op_private & OPpTRANS_DELETE;
5d06d08e 2658 squash = o->op_private & OPpTRANS_SQUASH;
1c846c1f 2659
036b4402
GS
2660 if (SvUTF8(tstr))
2661 o->op_private |= OPpTRANS_FROM_UTF;
1c846c1f
NIS
2662
2663 if (SvUTF8(rstr))
036b4402 2664 o->op_private |= OPpTRANS_TO_UTF;
79072805 2665
a0ed51b3 2666 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
79cb57f6 2667 SV* listsv = newSVpvn("# comment\n",10);
a0ed51b3
LW
2668 SV* transv = 0;
2669 U8* tend = t + tlen;
2670 U8* rend = r + rlen;
ba210ebe 2671 STRLEN ulen;
a0ed51b3
LW
2672 U32 tfirst = 1;
2673 U32 tlast = 0;
2674 I32 tdiff;
2675 U32 rfirst = 1;
2676 U32 rlast = 0;
2677 I32 rdiff;
2678 I32 diff;
2679 I32 none = 0;
2680 U32 max = 0;
2681 I32 bits;
a0ed51b3 2682 I32 havefinal = 0;
9c5ffd7c 2683 U32 final = 0;
a0ed51b3
LW
2684 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2685 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
bf4a1e57
JH
2686 U8* tsave = NULL;
2687 U8* rsave = NULL;
2688
2689 if (!from_utf) {
2690 STRLEN len = tlen;
2691 tsave = t = bytes_to_utf8(t, &len);
2692 tend = t + len;
2693 }
2694 if (!to_utf && rlen) {
2695 STRLEN len = rlen;
2696 rsave = r = bytes_to_utf8(r, &len);
2697 rend = r + len;
2698 }
a0ed51b3 2699
2b9d42f0
NIS
2700/* There are several snags with this code on EBCDIC:
2701 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2702 2. scan_const() in toke.c has encoded chars in native encoding which makes
2703 ranges at least in EBCDIC 0..255 range the bottom odd.
2704*/
2705
a0ed51b3 2706 if (complement) {
ad391ad9 2707 U8 tmpbuf[UTF8_MAXLEN+1];
2b9d42f0 2708 UV *cp;
a0ed51b3 2709 UV nextmin = 0;
2b9d42f0 2710 New(1109, cp, 2*tlen, UV);
a0ed51b3 2711 i = 0;
79cb57f6 2712 transv = newSVpvn("",0);
a0ed51b3 2713 while (t < tend) {
2b9d42f0
NIS
2714 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2715 t += ulen;
2716 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
a0ed51b3 2717 t++;
2b9d42f0
NIS
2718 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2719 t += ulen;
a0ed51b3 2720 }
2b9d42f0
NIS
2721 else {
2722 cp[2*i+1] = cp[2*i];
2723 }
2724 i++;
a0ed51b3 2725 }
2b9d42f0 2726 qsort(cp, i, 2*sizeof(UV), uvcompare);
a0ed51b3 2727 for (j = 0; j < i; j++) {
2b9d42f0 2728 UV val = cp[2*j];
a0ed51b3
LW
2729 diff = val - nextmin;
2730 if (diff > 0) {
9041c2e3 2731 t = uvuni_to_utf8(tmpbuf,nextmin);
dfe13c55 2732 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
a0ed51b3 2733 if (diff > 1) {
2b9d42f0 2734 U8 range_mark = UTF_TO_NATIVE(0xff);
9041c2e3 2735 t = uvuni_to_utf8(tmpbuf, val - 1);
2b9d42f0 2736 sv_catpvn(transv, (char *)&range_mark, 1);
dfe13c55 2737 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
a0ed51b3
LW
2738 }
2739 }
2b9d42f0 2740 val = cp[2*j+1];
a0ed51b3
LW
2741 if (val >= nextmin)
2742 nextmin = val + 1;
2743 }
9041c2e3 2744 t = uvuni_to_utf8(tmpbuf,nextmin);
dfe13c55 2745 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2b9d42f0
NIS
2746 {
2747 U8 range_mark = UTF_TO_NATIVE(0xff);
2748 sv_catpvn(transv, (char *)&range_mark, 1);
2749 }
9041c2e3 2750 t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
dfe13c55
GS
2751 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2752 t = (U8*)SvPVX(transv);
a0ed51b3
LW
2753 tlen = SvCUR(transv);
2754 tend = t + tlen;
455d824a 2755 Safefree(cp);
a0ed51b3
LW
2756 }
2757 else if (!rlen && !del) {
2758 r = t; rlen = tlen; rend = tend;
4757a243
LW
2759 }
2760 if (!squash) {
05d340b8 2761 if ((!rlen && !del) || t == r ||
12ae5dfc 2762 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
01ec43d0 2763 {
4757a243 2764 o->op_private |= OPpTRANS_IDENTICAL;
01ec43d0 2765 }
a0ed51b3
LW
2766 }
2767
2768 while (t < tend || tfirst <= tlast) {
2769 /* see if we need more "t" chars */
2770 if (tfirst > tlast) {
9041c2e3 2771 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
a0ed51b3 2772 t += ulen;
2b9d42f0 2773 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
ba210ebe 2774 t++;
9041c2e3 2775 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
a0ed51b3
LW
2776 t += ulen;
2777 }
2778 else
2779 tlast = tfirst;
2780 }
2781
2782 /* now see if we need more "r" chars */
2783 if (rfirst > rlast) {
2784 if (r < rend) {
9041c2e3 2785 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
a0ed51b3 2786 r += ulen;
2b9d42f0 2787 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
ba210ebe 2788 r++;
9041c2e3 2789 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
a0ed51b3
LW
2790 r += ulen;
2791 }
2792 else
2793 rlast = rfirst;
2794 }
2795 else {
2796 if (!havefinal++)
2797 final = rlast;
2798 rfirst = rlast = 0xffffffff;
2799 }
2800 }
2801
2802 /* now see which range will peter our first, if either. */
2803 tdiff = tlast - tfirst;
2804 rdiff = rlast - rfirst;
2805
2806 if (tdiff <= rdiff)
2807 diff = tdiff;
2808 else
2809 diff = rdiff;
2810
2811 if (rfirst == 0xffffffff) {
2812 diff = tdiff; /* oops, pretend rdiff is infinite */
2813 if (diff > 0)
894356b3
GS
2814 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2815 (long)tfirst, (long)tlast);
a0ed51b3 2816 else
894356b3 2817 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
a0ed51b3
LW
2818 }
2819 else {
2820 if (diff > 0)
894356b3
GS
2821 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2822 (long)tfirst, (long)(tfirst + diff),
2823 (long)rfirst);
a0ed51b3 2824 else
894356b3
GS
2825 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2826 (long)tfirst, (long)rfirst);
a0ed51b3
LW
2827
2828 if (rfirst + diff > max)
2829 max = rfirst + diff;
9b877dbb 2830 if (!grows)
45005bfb
JH
2831 grows = (tfirst < rfirst &&
2832 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2833 rfirst += diff + 1;
a0ed51b3
LW
2834 }
2835 tfirst += diff + 1;
2836 }
2837
2838 none = ++max;
2839 if (del)
2840 del = ++max;
2841
2842 if (max > 0xffff)
2843 bits = 32;
2844 else if (max > 0xff)
2845 bits = 16;
2846 else
2847 bits = 8;
2848
455d824a 2849 Safefree(cPVOPo->op_pv);
a0ed51b3
LW
2850 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2851 SvREFCNT_dec(listsv);
2852 if (transv)
2853 SvREFCNT_dec(transv);
2854
45005bfb 2855 if (!del && havefinal && rlen)
b448e4fe
JH
2856 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2857 newSVuv((UV)final), 0);
a0ed51b3 2858
9b877dbb 2859 if (grows)
a0ed51b3
LW
2860 o->op_private |= OPpTRANS_GROWS;
2861
9b877dbb
IH
2862 if (tsave)
2863 Safefree(tsave);
2864 if (rsave)
2865 Safefree(rsave);
2866
a0ed51b3
LW
2867 op_free(expr);
2868 op_free(repl);
2869 return o;
2870 }
2871
2872 tbl = (short*)cPVOPo->op_pv;
79072805
LW
2873 if (complement) {
2874 Zero(tbl, 256, short);
2875 for (i = 0; i < tlen; i++)
ec49126f 2876 tbl[t[i]] = -1;
79072805
LW
2877 for (i = 0, j = 0; i < 256; i++) {
2878 if (!tbl[i]) {
2879 if (j >= rlen) {
a0ed51b3 2880 if (del)
79072805
LW
2881 tbl[i] = -2;
2882 else if (rlen)
ec49126f 2883 tbl[i] = r[j-1];
79072805
LW
2884 else
2885 tbl[i] = i;
2886 }
9b877dbb
IH
2887 else {
2888 if (i < 128 && r[j] >= 128)
2889 grows = 1;
ec49126f 2890 tbl[i] = r[j++];
9b877dbb 2891 }
79072805
LW
2892 }
2893 }
05d340b8
JH
2894 if (!del) {
2895 if (!rlen) {
2896 j = rlen;
2897 if (!squash)
2898 o->op_private |= OPpTRANS_IDENTICAL;
2899 }
2900 else if (j >= rlen)
2901 j = rlen - 1;
2902 else
2903 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
8973db79
JH
2904 tbl[0x100] = rlen - j;
2905 for (i=0; i < rlen - j; i++)
2906 tbl[0x101+i] = r[j+i];
2907 }
79072805
LW
2908 }
2909 else {
a0ed51b3 2910 if (!rlen && !del) {
79072805 2911 r = t; rlen = tlen;
5d06d08e 2912 if (!squash)
4757a243 2913 o->op_private |= OPpTRANS_IDENTICAL;
79072805
LW
2914 }
2915 for (i = 0; i < 256; i++)
2916 tbl[i] = -1;
2917 for (i = 0, j = 0; i < tlen; i++,j++) {
2918 if (j >= rlen) {
a0ed51b3 2919 if (del) {
ec49126f 2920 if (tbl[t[i]] == -1)
2921 tbl[t[i]] = -2;
79072805
LW
2922 continue;
2923 }
2924 --j;
2925 }
9b877dbb
IH
2926 if (tbl[t[i]] == -1) {
2927 if (t[i] < 128 && r[j] >= 128)
2928 grows = 1;
ec49126f 2929 tbl[t[i]] = r[j];
9b877dbb 2930 }
79072805
LW
2931 }
2932 }
9b877dbb
IH
2933 if (grows)
2934 o->op_private |= OPpTRANS_GROWS;
79072805
LW
2935 op_free(expr);
2936 op_free(repl);
2937
11343788 2938 return o;
79072805
LW
2939}
2940
2941OP *
864dbfa3 2942Perl_newPMOP(pTHX_ I32 type, I32 flags)
79072805
LW
2943{
2944 PMOP *pmop;
2945
b7dc083c 2946 NewOp(1101, pmop, 1, PMOP);
79072805 2947 pmop->op_type = type;
22c35a8c 2948 pmop->op_ppaddr = PL_ppaddr[type];
79072805 2949 pmop->op_flags = flags;
c07a80fd 2950 pmop->op_private = 0 | (flags >> 8);
79072805 2951
3280af22 2952 if (PL_hints & HINT_RE_TAINT)
b3eb6a9b 2953 pmop->op_pmpermflags |= PMf_RETAINT;
3280af22 2954 if (PL_hints & HINT_LOCALE)
b3eb6a9b
GS
2955 pmop->op_pmpermflags |= PMf_LOCALE;
2956 pmop->op_pmflags = pmop->op_pmpermflags;
36477c24 2957
1fcf4c12
AB
2958 #ifdef USE_ITHREADS
2959 {
2960 SV* repointer = newSViv(0);
c5f51345 2961 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
1fcf4c12
AB
2962 pmop->op_pmoffset = av_len(PL_regex_padav);
2963 PL_regex_pad = AvARRAY(PL_regex_padav);
2964 }
2965 #endif
2966
2967 /* link into pm list */
3280af22
NIS
2968 if (type != OP_TRANS && PL_curstash) {
2969 pmop->op_pmnext = HvPMROOT(PL_curstash);
2970 HvPMROOT(PL_curstash) = pmop;
cb55de95 2971 PmopSTASH_set(pmop,PL_curstash);
79072805
LW
2972 }
2973
2974 return (OP*)pmop;
2975}
2976
2977OP *
864dbfa3 2978Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
79072805
LW
2979{
2980 PMOP *pm;
2981 LOGOP *rcop;
ce862d02 2982 I32 repl_has_vars = 0;
79072805 2983
11343788
MB
2984 if (o->op_type == OP_TRANS)
2985 return pmtrans(o, expr, repl);
79072805 2986
3280af22 2987 PL_hints |= HINT_BLOCK_SCOPE;
11343788 2988 pm = (PMOP*)o;
79072805
LW
2989
2990 if (expr->op_type == OP_CONST) {
463ee0b2 2991 STRLEN plen;
79072805 2992 SV *pat = ((SVOP*)expr)->op_sv;
463ee0b2 2993 char *p = SvPV(pat, plen);
11343788 2994 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
93a17b20 2995 sv_setpvn(pat, "\\s+", 3);
463ee0b2 2996 p = SvPV(pat, plen);
79072805
LW
2997 pm->op_pmflags |= PMf_SKIPWHITE;
2998 }
1fd7b382 2999 if ((PL_hints & HINT_UTF8) || DO_UTF8(pat))
7e2040f0 3000 pm->op_pmdynflags |= PMdf_UTF8;
aaa362c4
RS
3001 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
3002 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
85e6fe83 3003 pm->op_pmflags |= PMf_WHITE;
79072805
LW
3004 op_free(expr);
3005 }
3006 else {
393fec97
GS
3007 if (PL_hints & HINT_UTF8)
3008 pm->op_pmdynflags |= PMdf_UTF8;
3280af22 3009 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
1c846c1f 3010 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2cd61cdb
IZ
3011 ? OP_REGCRESET
3012 : OP_REGCMAYBE),0,expr);
463ee0b2 3013
b7dc083c 3014 NewOp(1101, rcop, 1, LOGOP);
79072805 3015 rcop->op_type = OP_REGCOMP;
22c35a8c 3016 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
79072805 3017 rcop->op_first = scalar(expr);
1c846c1f 3018 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
2cd61cdb
IZ
3019 ? (OPf_SPECIAL | OPf_KIDS)
3020 : OPf_KIDS);
79072805 3021 rcop->op_private = 1;
11343788 3022 rcop->op_other = o;
79072805
LW
3023
3024 /* establish postfix order */
3280af22 3025 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
463ee0b2
LW
3026 LINKLIST(expr);
3027 rcop->op_next = expr;
3028 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3029 }
3030 else {
3031 rcop->op_next = LINKLIST(expr);
3032 expr->op_next = (OP*)rcop;
3033 }
79072805 3034
11343788 3035 prepend_elem(o->op_type, scalar((OP*)rcop), o);
79072805
LW
3036 }
3037
3038 if (repl) {
748a9306 3039 OP *curop;
0244c3a4 3040 if (pm->op_pmflags & PMf_EVAL) {
748a9306 3041 curop = 0;
57843af0
GS
3042 if (CopLINE(PL_curcop) < PL_multi_end)
3043 CopLINE_set(PL_curcop, PL_multi_end);
0244c3a4 3044 }
554b3eca 3045#ifdef USE_THREADS
2faa37cc 3046 else if (repl->op_type == OP_THREADSV
554b3eca 3047 && strchr("&`'123456789+",
533c011a 3048 PL_threadsv_names[repl->op_targ]))
554b3eca
MB
3049 {
3050 curop = 0;
3051 }
3052#endif /* USE_THREADS */
748a9306
LW
3053 else if (repl->op_type == OP_CONST)
3054 curop = repl;
79072805 3055 else {
79072805
LW
3056 OP *lastop = 0;
3057 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
22c35a8c 3058 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
554b3eca 3059#ifdef USE_THREADS
ce862d02
IZ
3060 if (curop->op_type == OP_THREADSV) {
3061 repl_has_vars = 1;
be949f6f 3062 if (strchr("&`'123456789+", curop->op_private))
ce862d02 3063 break;
554b3eca
MB
3064 }
3065#else
79072805 3066 if (curop->op_type == OP_GV) {
638eceb6 3067 GV *gv = cGVOPx_gv(curop);
ce862d02 3068 repl_has_vars = 1;
93a17b20 3069 if (strchr("&`'123456789+", *GvENAME(gv)))
79072805
LW
3070 break;
3071 }
554b3eca 3072#endif /* USE_THREADS */
79072805
LW
3073 else if (curop->op_type == OP_RV2CV)
3074 break;
3075 else if (curop->op_type == OP_RV2SV ||
3076 curop->op_type == OP_RV2AV ||
3077 curop->op_type == OP_RV2HV ||
3078 curop->op_type == OP_RV2GV) {
3079 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3080 break;
3081 }
748a9306
LW
3082 else if (curop->op_type == OP_PADSV ||
3083 curop->op_type == OP_PADAV ||
3084 curop->op_type == OP_PADHV ||
554b3eca 3085 curop->op_type == OP_PADANY) {
ce862d02 3086 repl_has_vars = 1;
748a9306 3087 }
1167e5da
SM
3088 else if (curop->op_type == OP_PUSHRE)
3089 ; /* Okay here, dangerous in newASSIGNOP */
79072805
LW
3090 else
3091 break;
3092 }
3093 lastop = curop;
3094 }
748a9306 3095 }
ce862d02 3096 if (curop == repl
1c846c1f 3097 && !(repl_has_vars
aaa362c4
RS
3098 && (!PM_GETRE(pm)
3099 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
748a9306 3100 pm->op_pmflags |= PMf_CONST; /* const for long enough */
4633a7c4 3101 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
11343788 3102 prepend_elem(o->op_type, scalar(repl), o);
748a9306
LW
3103 }
3104 else {
aaa362c4 3105 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
ce862d02
IZ
3106 pm->op_pmflags |= PMf_MAYBE_CONST;
3107 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3108 }
b7dc083c 3109 NewOp(1101, rcop, 1, LOGOP);
748a9306 3110 rcop->op_type = OP_SUBSTCONT;
22c35a8c 3111 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
748a9306
LW
3112 rcop->op_first = scalar(repl);
3113 rcop->op_flags |= OPf_KIDS;
3114 rcop->op_private = 1;
11343788 3115 rcop->op_other = o;
748a9306
LW
3116
3117 /* establish postfix order */
3118 rcop->op_next = LINKLIST(repl);
3119 repl->op_next = (OP*)rcop;
3120
3121 pm->op_pmreplroot = scalar((OP*)rcop);
3122 pm->op_pmreplstart = LINKLIST(rcop);
3123 rcop->op_next = 0;
79072805
LW
3124 }
3125 }
3126
3127 return (OP*)pm;
3128}
3129
3130OP *
864dbfa3 3131Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
79072805
LW
3132{
3133 SVOP *svop;
b7dc083c 3134 NewOp(1101, svop, 1, SVOP);
79072805 3135 svop->op_type = type;
22c35a8c 3136 svop->op_ppaddr = PL_ppaddr[type];
79072805
LW
3137 svop->op_sv = sv;
3138 svop->op_next = (OP*)svop;
3139 svop->op_flags = flags;
22c35a8c 3140 if (PL_opargs[type] & OA_RETSCALAR)
463ee0b2 3141 scalar((OP*)svop);
22c35a8c 3142 if (PL_opargs[type] & OA_TARGET)
ed6116ce 3143 svop->op_targ = pad_alloc(type, SVs_PADTMP);
e50aee73 3144 return CHECKOP(type, svop);
79072805
LW
3145}
3146
3147OP *
350de78d
GS
3148Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3149{
3150 PADOP *padop;
3151 NewOp(1101, padop, 1, PADOP);
3152 padop->op_type = type;
3153 padop->op_ppaddr = PL_ppaddr[type];
3154 padop->op_padix = pad_alloc(type, SVs_PADTMP);
7766f137 3155 SvREFCNT_dec(PL_curpad[padop->op_padix]);
350de78d 3156 PL_curpad[padop->op_padix] = sv;
7766f137 3157 SvPADTMP_on(sv);
350de78d
GS
3158 padop->op_next = (OP*)padop;
3159 padop->op_flags = flags;
3160 if (PL_opargs[type] & OA_RETSCALAR)
3161 scalar((OP*)padop);
3162 if (PL_opargs[type] & OA_TARGET)
3163 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3164 return CHECKOP(type, padop);
3165}
3166
3167OP *
864dbfa3 3168Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
79072805 3169{
350de78d 3170#ifdef USE_ITHREADS
743e66e6 3171 GvIN_PAD_on(gv);
350de78d
GS
3172 return newPADOP(type, flags, SvREFCNT_inc(gv));
3173#else
7934575e 3174 return newSVOP(type, flags, SvREFCNT_inc(gv));
350de78d 3175#endif
79072805
LW
3176}
3177
3178OP *
864dbfa3 3179Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
79072805
LW
3180{
3181 PVOP *pvop;
b7dc083c 3182 NewOp(1101, pvop, 1, PVOP);
79072805 3183 pvop->op_type = type;
22c35a8c 3184 pvop->op_ppaddr = PL_ppaddr[type];
79072805
LW
3185 pvop->op_pv = pv;
3186 pvop->op_next = (OP*)pvop;
3187 pvop->op_flags = flags;
22c35a8c 3188 if (PL_opargs[type] & OA_RETSCALAR)
463ee0b2 3189 scalar((OP*)pvop);
22c35a8c 3190 if (PL_opargs[type] & OA_TARGET)
ed6116ce 3191 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
e50aee73 3192 return CHECKOP(type, pvop);
79072805
LW
3193}
3194
79072805 3195void
864dbfa3 3196Perl_package(pTHX_ OP *o)
79072805 3197{
93a17b20 3198 SV *sv;
79072805 3199
3280af22
NIS
3200 save_hptr(&PL_curstash);
3201 save_item(PL_curstname);
11343788 3202 if (o) {
463ee0b2
LW
3203 STRLEN len;
3204 char *name;
11343788 3205 sv = cSVOPo->op_sv;
463ee0b2 3206 name = SvPV(sv, len);
3280af22
NIS
3207 PL_curstash = gv_stashpvn(name,len,TRUE);
3208 sv_setpvn(PL_curstname, name, len);
11343788 3209 op_free(o);
93a17b20
LW
3210 }
3211 else {
f2c0fa37 3212 deprecate("\"package\" with no arguments");
3280af22
NIS
3213 sv_setpv(PL_curstname,"<none>");
3214 PL_curstash = Nullhv;
93a17b20 3215 }
7ad382f4 3216 PL_hints |= HINT_BLOCK_SCOPE;
3280af22
NIS
3217 PL_copline = NOLINE;
3218 PL_expect = XSTATE;
79072805
LW
3219}
3220
85e6fe83 3221void
864dbfa3 3222Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
85e6fe83 3223{
a0d0e21e 3224 OP *pack;
a0d0e21e 3225 OP *imop;
b1cb66bf 3226 OP *veop;
18fc9488 3227 char *packname = Nullch;
c4e33207 3228 STRLEN packlen = 0;
18fc9488 3229 SV *packsv;
85e6fe83 3230
a0d0e21e 3231 if (id->op_type != OP_CONST)
cea2e8a9 3232 Perl_croak(aTHX_ "Module name must be constant");
85e6fe83 3233
b1cb66bf 3234 veop = Nullop;
3235
0f79a09d 3236 if (version != Nullop) {
b1cb66bf 3237 SV *vesv = ((SVOP*)version)->op_sv;
3238
44dcb63b 3239 if (arg == Nullop && !SvNIOKp(vesv)) {
b1cb66bf 3240 arg = version;
3241 }
3242 else {
3243 OP *pack;
0f79a09d 3244 SV *meth;
b1cb66bf 3245
44dcb63b 3246 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
cea2e8a9 3247 Perl_croak(aTHX_ "Version number must be constant number");
b1cb66bf 3248
3249 /* Make copy of id so we don't free it twice */
3250 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3251
3252 /* Fake up a method call to VERSION */
0f79a09d
GS
3253 meth = newSVpvn("VERSION",7);
3254 sv_upgrade(meth, SVt_PVIV);
155aba94 3255 (void)SvIOK_on(meth);
0f79a09d 3256 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
b1cb66bf 3257 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3258 append_elem(OP_LIST,
0f79a09d
GS
3259 prepend_elem(OP_LIST, pack, list(version)),
3260 newSVOP(OP_METHOD_NAMED, 0, meth)));
b1cb66bf 3261 }
3262 }
aeea060c 3263
a0d0e21e 3264 /* Fake up an import/unimport */
4633a7c4
LW
3265 if (arg && arg->op_type == OP_STUB)
3266 imop = arg; /* no import on explicit () */
44dcb63b 3267 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
b1cb66bf 3268 imop = Nullop; /* use 5.0; */
3269 }
4633a7c4 3270 else {
0f79a09d
GS
3271 SV *meth;
3272
4633a7c4
LW
3273 /* Make copy of id so we don't free it twice */
3274 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
0f79a09d
GS
3275
3276 /* Fake up a method call to import/unimport */
3277 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
3278 sv_upgrade(meth, SVt_PVIV);
155aba94 3279 (void)SvIOK_on(meth);
0f79a09d 3280 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
4633a7c4 3281 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
0f79a09d
GS
3282 append_elem(OP_LIST,
3283 prepend_elem(OP_LIST, pack, list(arg)),
3284 newSVOP(OP_METHOD_NAMED, 0, meth)));
4633a7c4
LW
3285 }
3286
d04f2e46
DM
3287 if (ckWARN(WARN_MISC) &&
3288 imop && (imop != arg) && /* no warning on use 5.0; or explicit () */
3289 SvPOK(packsv = ((SVOP*)id)->op_sv))
3290 {
18fc9488
DM
3291 /* BEGIN will free the ops, so we need to make a copy */
3292 packlen = SvCUR(packsv);
3293 packname = savepvn(SvPVX(packsv), packlen);
3294 }
3295
a0d0e21e 3296 /* Fake up the BEGIN {}, which does its thing immediately. */
09bef843 3297 newATTRSUB(floor,
79cb57f6 3298 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
4633a7c4 3299 Nullop,
09bef843 3300 Nullop,
a0d0e21e 3301 append_elem(OP_LINESEQ,
b1cb66bf 3302 append_elem(OP_LINESEQ,
ec4ab249 3303 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, id)),
b1cb66bf 3304 newSTATEOP(0, Nullch, veop)),
a0d0e21e 3305 newSTATEOP(0, Nullch, imop) ));
85e6fe83 3306
18fc9488
DM
3307 if (packname) {
3308 if (ckWARN(WARN_MISC) && !gv_stashpvn(packname, packlen, FALSE)) {
3309 Perl_warner(aTHX_ WARN_MISC,
3310 "Package `%s' not found "
3311 "(did you use the incorrect case?)", packname);
3312 }
3313 safefree(packname);
3314 }
3315
c305c6a0 3316 PL_hints |= HINT_BLOCK_SCOPE;
3280af22
NIS
3317 PL_copline = NOLINE;
3318 PL_expect = XSTATE;
85e6fe83
LW
3319}
3320
7d3fb230
BS
3321/*
3322=for apidoc load_module
3323
3324Loads the module whose name is pointed to by the string part of name.
3325Note that the actual module name, not its filename, should be given.
3326Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3327PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3328(or 0 for no flags). ver, if specified, provides version semantics
3329similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3330arguments can be used to specify arguments to the module's import()
3331method, similar to C<use Foo::Bar VERSION LIST>.
3332
3333=cut */
3334
e4783991
GS
3335void
3336Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3337{
3338 va_list args;
3339 va_start(args, ver);
3340 vload_module(flags, name, ver, &args);
3341 va_end(args);
3342}
3343
3344#ifdef PERL_IMPLICIT_CONTEXT
3345void
3346Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3347{
3348 dTHX;
3349 va_list args;
3350 va_start(args, ver);
3351 vload_module(flags, name, ver, &args);
3352 va_end(args);
3353}
3354#endif
3355
3356void
3357Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3358{
3359 OP *modname, *veop, *imop;
3360
3361 modname = newSVOP(OP_CONST, 0, name);
3362 modname->op_private |= OPpCONST_BARE;
3363 if (ver) {
3364 veop = newSVOP(OP_CONST, 0, ver);
3365 }
3366 else
3367 veop = Nullop;
3368 if (flags & PERL_LOADMOD_NOIMPORT) {
3369 imop = sawparens(newNULLLIST());
3370 }
3371 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3372 imop = va_arg(*args, OP*);
3373 }
3374 else {
3375 SV *sv;
3376 imop = Nullop;
3377 sv = va_arg(*args, SV*);
3378 while (sv) {
3379 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3380 sv = va_arg(*args, SV*);
3381 }
3382 }
81885997
GS
3383 {
3384 line_t ocopline = PL_copline;
3385 int oexpect = PL_expect;
3386
3387 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3388 veop, modname, imop);
3389 PL_expect = oexpect;
3390 PL_copline = ocopline;
3391 }
e4783991
GS
3392}
3393
79072805 3394OP *
864dbfa3 3395Perl_dofile(pTHX_ OP *term)
78ca652e
GS
3396{
3397 OP *doop;
3398 GV *gv;
3399
3400 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3401 if (!(gv && GvIMPORTED_CV(gv)))
3402 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3403
3404 if (gv && GvIMPORTED_CV(gv)) {
3405 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3406 append_elem(OP_LIST, term,
3407 scalar(newUNOP(OP_RV2CV, 0,
3408 newGVOP(OP_GV, 0,
3409 gv))))));
3410 }
3411 else {
3412 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3413 }
3414 return doop;
3415}
3416
3417OP *
864dbfa3 3418Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
79072805
LW
3419{
3420 return newBINOP(OP_LSLICE, flags,
8990e307
LW
3421 list(force_list(subscript)),
3422 list(force_list(listval)) );
79072805
LW
3423}
3424
76e3520e 3425STATIC I32
cea2e8a9 3426S_list_assignment(pTHX_ register OP *o)
79072805 3427{
11343788 3428 if (!o)
79072805
LW
3429 return TRUE;
3430
11343788
MB
3431 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3432 o = cUNOPo->op_first;
79072805 3433
11343788 3434 if (o->op_type == OP_COND_EXPR) {
1a67a97c
SM
3435 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3436 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
79072805
LW
3437
3438 if (t && f)
3439 return TRUE;
3440 if (t || f)
3441 yyerror("Assignment to both a list and a scalar");
3442 return FALSE;
3443 }
3444
11343788
MB
3445 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3446 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3447 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
79072805
LW
3448 return TRUE;
3449
11343788 3450 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
93a17b20
LW
3451 return TRUE;
3452
11343788 3453 if (o->op_type == OP_RV2SV)
79072805
LW
3454 return FALSE;
3455
3456 return FALSE;
3457}
3458
3459OP *
864dbfa3 3460Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
79072805 3461{
11343788 3462 OP *o;
79072805 3463
a0d0e21e
LW
3464 if (optype) {
3465 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3466 return newLOGOP(optype, 0,
3467 mod(scalar(left), optype),
3468 newUNOP(OP_SASSIGN, 0, scalar(right)));
3469 }
3470 else {
3471 return newBINOP(optype, OPf_STACKED,
3472 mod(scalar(left), optype), scalar(right));
3473 }
3474 }
3475
79072805 3476 if (list_assignment(left)) {
10c8fecd
GS
3477 OP *curop;
3478
3280af22
NIS
3479 PL_modcount = 0;
3480 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
463ee0b2 3481 left = mod(left, OP_AASSIGN);
3280af22
NIS
3482 if (PL_eval_start)
3483 PL_eval_start = 0;
748a9306 3484 else {
a0d0e21e
LW
3485 op_free(left);
3486 op_free(right);
3487 return Nullop;
3488 }
10c8fecd
GS
3489 curop = list(force_list(left));
3490 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
11343788 3491 o->op_private = 0 | (flags >> 8);
10c8fecd
GS
3492 for (curop = ((LISTOP*)curop)->op_first;
3493 curop; curop = curop->op_sibling)
3494 {
3495 if (curop->op_type == OP_RV2HV &&
3496 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3497 o->op_private |= OPpASSIGN_HASH;
3498 break;
3499 }
3500 }
a0d0e21e 3501 if (!(left->op_private & OPpLVAL_INTRO)) {
11343788 3502 OP *lastop = o;
3280af22 3503 PL_generation++;
11343788 3504 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
22c35a8c 3505 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
79072805 3506 if (curop->op_type == OP_GV) {
638eceb6 3507 GV *gv = cGVOPx_gv(curop);
3280af22 3508 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
79072805 3509 break;
3280af22 3510 SvCUR(gv) = PL_generation;
79072805 3511 }
748a9306
LW
3512 else if (curop->op_type == OP_PADSV ||
3513 curop->op_type == OP_PADAV ||
3514 curop->op_type == OP_PADHV ||
3515 curop->op_type == OP_PADANY) {
3280af22 3516 SV **svp = AvARRAY(PL_comppad_name);
8e07c86e 3517 SV *sv = svp[curop->op_targ];
3280af22 3518 if (SvCUR(sv) == PL_generation)
748a9306 3519 break;
3280af22 3520 SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
748a9306 3521 }
79072805
LW
3522 else if (curop->op_type == OP_RV2CV)
3523 break;
3524 else if (curop->op_type == OP_RV2SV ||
3525 curop->op_type == OP_RV2AV ||
3526 curop->op_type == OP_RV2HV ||
3527 curop->op_type == OP_RV2GV) {
3528 if (lastop->op_type != OP_GV) /* funny deref? */
3529 break;
3530 }
1167e5da
SM
3531 else if (curop->op_type == OP_PUSHRE) {
3532 if (((PMOP*)curop)->op_pmreplroot) {
b3f5893f
GS
3533#ifdef USE_ITHREADS
3534 GV *gv = (GV*)PL_curpad[(PADOFFSET)((PMOP*)curop)->op_pmreplroot];
3535#else