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