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
Re: [PATCH] MAD prototype checking
[perl5.git] / op.c
CommitLineData
a0d0e21e 1/* op.c
79072805 2 *
4bb101f2 3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
bc641c27 4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, by Larry Wall and others
79072805
LW		 5 *
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
8 *
a0d0e21e
LW		 9 */
10
11/*
12 * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
13 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
14 * youngest of the Old Took's daughters); and Mr. Drogo was his second
15 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
16 * either way, as the saying is, if you follow me." --the Gaffer
79072805
LW		 17 */
18
166f8a29
DM		 19/* This file contains the functions that create, manipulate and optimize
20 * the OP structures that hold a compiled perl program.
21 *
22 * A Perl program is compiled into a tree of OPs. Each op contains
23 * structural pointers (eg to its siblings and the next op in the
24 * execution sequence), a pointer to the function that would execute the
25 * op, plus any data specific to that op. For example, an OP_CONST op
26 * points to the pp_const() function and to an SV containing the constant
27 * value. When pp_const() is executed, its job is to push that SV onto the
28 * stack.
29 *
30 * OPs are mainly created by the newFOO() functions, which are mainly
31 * called from the parser (in perly.y) as the code is parsed. For example
32 * the Perl code $a + $b * $c would cause the equivalent of the following
33 * to be called (oversimplifying a bit):
34 *
35 * newBINOP(OP_ADD, flags,
36 * newSVREF($a),
37 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
38 * )
39 *
40 * Note that during the build of miniperl, a temporary copy of this file
41 * is made, called opmini.c.
42 */
ccfc67b7 43
61b743bb
DM		 44/*
45Perl's compiler is essentially a 3-pass compiler with interleaved phases:
46
47 A bottom-up pass
48 A top-down pass
49 An execution-order pass
50
51The bottom-up pass is represented by all the "newOP" routines and
52the ck_ routines. The bottom-upness is actually driven by yacc.
53So at the point that a ck_ routine fires, we have no idea what the
54context is, either upward in the syntax tree, or either forward or
55backward in the execution order. (The bottom-up parser builds that
56part of the execution order it knows about, but if you follow the "next"
57links around, you'll find it's actually a closed loop through the
58top level node.
59
60Whenever the bottom-up parser gets to a node that supplies context to
61its components, it invokes that portion of the top-down pass that applies
62to that part of the subtree (and marks the top node as processed, so
63if a node further up supplies context, it doesn't have to take the
64plunge again). As a particular subcase of this, as the new node is
65built, it takes all the closed execution loops of its subcomponents
66and links them into a new closed loop for the higher level node. But
67it's still not the real execution order.
68
69The actual execution order is not known till we get a grammar reduction
70to a top-level unit like a subroutine or file that will be called by
71"name" rather than via a "next" pointer. At that point, we can call
72into peep() to do that code's portion of the 3rd pass. It has to be
73recursive, but it's recursive on basic blocks, not on tree nodes.
74*/
75
06e0342d 76/* To implement user lexical pragmas, there needs to be a way at run time to
b3ca2e83
NC		 77 get the compile time state of %^H for that block. Storing %^H in every
78 block (or even COP) would be very expensive, so a different approach is
79 taken. The (running) state of %^H is serialised into a tree of HE-like
80 structs. Stores into %^H are chained onto the current leaf as a struct
81 refcounted_he * with the key and the value. Deletes from %^H are saved
82 with a value of PL_sv_placeholder. The state of %^H at any point can be
83 turned back into a regular HV by walking back up the tree from that point's
06e0342d 84 leaf, ignoring any key you've already seen (placeholder or not), storing
b3ca2e83
NC		 85 the rest into the HV structure, then removing the placeholders. Hence
86 memory is only used to store the %^H deltas from the enclosing COP, rather
87 than the entire %^H on each COP.
88
89 To cause actions on %^H to write out the serialisation records, it has
90 magic type 'H'. This magic (itself) does nothing, but its presence causes
91 the values to gain magic type 'h', which has entries for set and clear.
c28fe1ec 92 C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
b3ca2e83 93 record, with deletes written by C<Perl_magic_clearhint>. C<SAVE_HINTS>
c28fe1ec
NC		 94 saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
95 it will be correctly restored when any inner compiling scope is exited.
b3ca2e83
NC		 96*/
97
79072805 98#include "EXTERN.h"
864dbfa3 99#define PERL_IN_OP_C
79072805 100#include "perl.h"
77ca0c92 101#include "keywords.h"
79072805 102
a07e034d 103#define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
a2efc822 104
238a4c30
NIS		 105#if defined(PL_OP_SLAB_ALLOC)
106
f1fac472
NC		 107#ifdef PERL_DEBUG_READONLY_OPS
108# define PERL_SLAB_SIZE 4096
109# include <sys/mman.h>
110#endif
111
238a4c30
NIS		 112#ifndef PERL_SLAB_SIZE
113#define PERL_SLAB_SIZE 2048
114#endif
115
c7e45529 116void *
e91d68d5 117Perl_Slab_Alloc(pTHX_ size_t sz)
1c846c1f 118{
5a8e194f
NIS		 119 /*
120 * To make incrementing use count easy PL_OpSlab is an I32 *
121 * To make inserting the link to slab PL_OpPtr is I32 **
122 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
123 * Add an overhead for pointer to slab and round up as a number of pointers
124 */
125 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
238a4c30 126 if ((PL_OpSpace -= sz) < 0) {
f1fac472
NC		 127#ifdef PERL_DEBUG_READONLY_OPS
128 /* We need to allocate chunk by chunk so that we can control the VM
129 mapping */
130 PL_OpPtr = mmap(0, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE,
131 MAP_ANON|MAP_PRIVATE, -1, 0);
132
133 DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
134 (unsigned long) PERL_SLAB_SIZE*sizeof(I32*),
135 PL_OpPtr));
136 if(PL_OpPtr == MAP_FAILED) {
137 perror("mmap failed");
138 abort();
139 }
140#else
277e868c
NC		 141
142 PL_OpPtr = (I32 **) PerlMemShared_calloc(PERL_SLAB_SIZE,sizeof(I32*));
f1fac472 143#endif
083fcd59 144 if (!PL_OpPtr) {
238a4c30
NIS		 145 return NULL;
146 }
5a8e194f
NIS		 147 /* We reserve the 0'th I32 sized chunk as a use count */
148 PL_OpSlab = (I32 *) PL_OpPtr;
149 /* Reduce size by the use count word, and by the size we need.
150 * Latter is to mimic the '-=' in the if() above
151 */
152 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
238a4c30
NIS		 153 /* Allocation pointer starts at the top.
154 Theory: because we build leaves before trunk allocating at end
155 means that at run time access is cache friendly upward
156 */
5a8e194f 157 PL_OpPtr += PERL_SLAB_SIZE;
f1fac472
NC		 158
159#ifdef PERL_DEBUG_READONLY_OPS
160 /* We remember this slab. */
161 /* This implementation isn't efficient, but it is simple. */
162 PL_slabs = realloc(PL_slabs, sizeof(I32**) * (PL_slab_count + 1));
163 PL_slabs[PL_slab_count++] = PL_OpSlab;
164 DEBUG_m(PerlIO_printf(Perl_debug_log, "Allocate %p\n", PL_OpSlab));
165#endif
238a4c30
NIS		 166 }
167 assert( PL_OpSpace >= 0 );
168 /* Move the allocation pointer down */
169 PL_OpPtr -= sz;
5a8e194f 170 assert( PL_OpPtr > (I32 **) PL_OpSlab );
238a4c30
NIS		 171 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
172 (*PL_OpSlab)++; /* Increment use count of slab */
5a8e194f 173 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
238a4c30
NIS		 174 assert( *PL_OpSlab > 0 );
175 return (void *)(PL_OpPtr + 1);
176}
177
f1fac472
NC		 178#ifdef PERL_DEBUG_READONLY_OPS
179void
180Perl_pending_Slabs_to_ro(pTHX) {
181 /* Turn all the allocated op slabs read only. */
182 U32 count = PL_slab_count;
183 I32 **const slabs = PL_slabs;
184
185 /* Reset the array of pending OP slabs, as we're about to turn this lot
186 read only. Also, do it ahead of the loop in case the warn triggers,
187 and a warn handler has an eval */
188
189 free(PL_slabs);
190 PL_slabs = NULL;
191 PL_slab_count = 0;
192
193 /* Force a new slab for any further allocation. */
194 PL_OpSpace = 0;
195
196 while (count--) {
197 const void *start = slabs[count];
198 const size_t size = PERL_SLAB_SIZE* sizeof(I32*);
199 if(mprotect(start, size, PROT_READ)) {
200 Perl_warn(aTHX_ "mprotect for %p %lu failed with %d",
201 start, (unsigned long) size, errno);
202 }
203 }
204}
205
206STATIC void
207S_Slab_to_rw(pTHX_ void *op)
208{
209 I32 * const * const ptr = (I32 **) op;
210 I32 * const slab = ptr[-1];
211 assert( ptr-1 > (I32 **) slab );
212 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
213 assert( *slab > 0 );
214 if(mprotect(slab, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE)) {
215 Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d",
216 slab, (unsigned long) PERL_SLAB_SIZE*sizeof(I32*), errno);
217 }
218}
219#else
220# define Slab_to_rw(op)
221#endif
222
c7e45529
AE		 223void
224Perl_Slab_Free(pTHX_ void *op)
238a4c30 225{
551405c4 226 I32 * const * const ptr = (I32 **) op;
aec46f14 227 I32 * const slab = ptr[-1];
5a8e194f
NIS		 228 assert( ptr-1 > (I32 **) slab );
229 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
238a4c30 230 assert( *slab > 0 );
f1fac472 231 Slab_to_rw(op);
238a4c30 232 if (--(*slab) == 0) {
7e4e8c89
NC		 233# ifdef NETWARE
234# define PerlMemShared PerlMem
235# endif
083fcd59 236
f1fac472 237#ifdef PERL_DEBUG_READONLY_OPS
782a40f1 238 U32 count = PL_slab_count;
f1fac472 239 /* Need to remove this slab from our list of slabs */
782a40f1 240 if (count) {
f1fac472
NC		 241 while (count--) {
242 if (PL_slabs[count] == slab) {
243 /* Found it. Move the entry at the end to overwrite it. */
244 DEBUG_m(PerlIO_printf(Perl_debug_log,
245 "Deallocate %p by moving %p from %lu to %lu\n",
246 PL_OpSlab,
247 PL_slabs[PL_slab_count - 1],
248 PL_slab_count, count));
249 PL_slabs[count] = PL_slabs[--PL_slab_count];
250 /* Could realloc smaller at this point, but probably not
251 worth it. */
252 goto gotcha;
253 }
254
255 }
256 Perl_croak(aTHX_
257 "panic: Couldn't find slab at %p (%lu allocated)",
258 slab, (unsigned long) PL_slabs);
259 gotcha:
260 if(munmap(slab, PERL_SLAB_SIZE*sizeof(I32*))) {
261 perror("munmap failed");
262 abort();
263 }
264 }
265#else
083fcd59 266 PerlMemShared_free(slab);
f1fac472 267#endif
238a4c30
NIS		 268 if (slab == PL_OpSlab) {
269 PL_OpSpace = 0;
270 }
271 }
b7dc083c 272}
b7dc083c 273#endif
e50aee73 274/*
ce6f1cbc 275 * In the following definition, the ", (OP*)0" is just to make the compiler
a5f75d66 276 * think the expression is of the right type: croak actually does a Siglongjmp.
e50aee73 277 */
11343788 278#define CHECKOP(type,o) \
ce6f1cbc 279 ((PL_op_mask && PL_op_mask[type]) \
5dc0d613 280 ? ( op_free((OP*)o), \
cb77fdf0 281 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
ce6f1cbc 282 (OP*)0 ) \
fc0dc3b3 283 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
e50aee73 284
e6438c1a 285#define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
c53d7c7d 286
8b6b16e7 287STATIC const char*
cea2e8a9 288S_gv_ename(pTHX_ GV *gv)
4633a7c4 289{
46c461b5 290 SV* const tmpsv = sv_newmortal();
bd61b366 291 gv_efullname3(tmpsv, gv, NULL);
8b6b16e7 292 return SvPV_nolen_const(tmpsv);
4633a7c4
LW		 293}
294
76e3520e 295STATIC OP *
cea2e8a9 296S_no_fh_allowed(pTHX_ OP *o)
79072805 297{
cea2e8a9 298 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
53e06cf0 299 OP_DESC(o)));
11343788 300 return o;
79072805
LW		 301}
302
76e3520e 303STATIC OP *
bfed75c6 304S_too_few_arguments(pTHX_ OP *o, const char *name)
79072805 305{
cea2e8a9 306 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
11343788 307 return o;
79072805
LW		 308}
309
76e3520e 310STATIC OP *
bfed75c6 311S_too_many_arguments(pTHX_ OP *o, const char *name)
79072805 312{
cea2e8a9 313 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
11343788 314 return o;
79072805
LW		 315}
316
76e3520e 317STATIC void
6867be6d 318S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
8990e307 319{
cea2e8a9 320 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
53e06cf0 321 (int)n, name, t, OP_DESC(kid)));
8990e307
LW		 322}
323
7a52d87a 324STATIC void
6867be6d 325S_no_bareword_allowed(pTHX_ const OP *o)
7a52d87a 326{
eb8433b7
NC		 327 if (PL_madskills)
328 return; /* various ok barewords are hidden in extra OP_NULL */
5a844595 329 qerror(Perl_mess(aTHX_
35c1215d 330 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
be2597df 331 SVfARG(cSVOPo_sv)));
7a52d87a
GS		 332}
333
79072805
LW		 334/* "register" allocation */
335
336PADOFFSET
262cbcdb 337Perl_allocmy(pTHX_ const char *const name)
93a17b20 338{
97aff369 339 dVAR;
a0d0e21e 340 PADOFFSET off;
3edf23ff 341 const bool is_our = (PL_in_my == KEY_our);
a0d0e21e 342
59f00321 343 /* complain about "my $<special_var>" etc etc */
6b58708b 344 if (*name &&
3edf23ff 345 !(is_our ||
155aba94 346 isALPHA(name[1]) ||
39e02b42 347 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
6b58708b 348 (name[1] == '_' && (*name == '$' || name[2]))))
834a4ddd 349 {
6b58708b 350 /* name[2] is true if strlen(name) > 2 */
c4d0567e 351 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
d1544d85
NC		 352 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%s in \"my\"",
353 name[0], toCTRL(name[1]), name + 2));
354 } else {
355 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
46fc3d4c 356 }
a0d0e21e 357 }
748a9306 358
dd2155a4 359 /* check for duplicate declaration */
3edf23ff 360 pad_check_dup(name, is_our, (PL_curstash ? PL_curstash : PL_defstash));
33b8ce05 361
dd2155a4
DM		 362 if (PL_in_my_stash && *name != '$') {
363 yyerror(Perl_form(aTHX_
364 "Can't declare class for non-scalar %s in \"%s\"",
952306ac
RGS		 365 name,
366 is_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
6b35e009
GS		 367 }
368
dd2155a4 369 /* allocate a spare slot and store the name in that slot */
93a17b20 370
dd2155a4
DM		 371 off = pad_add_name(name,
372 PL_in_my_stash,
3edf23ff 373 (is_our
133706a6
RGS		 374 /* $_ is always in main::, even with our */
375 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
5c284bb0 376 : NULL
dd2155a4 377 ),
952306ac
RGS		 378 0, /* not fake */
379 PL_in_my == KEY_state
dd2155a4
DM		 380 );
381 return off;
79072805
LW		 382}
383
d2c837a0
DM		 384/* free the body of an op without examining its contents.
385 * Always use this rather than FreeOp directly */
386
387void
388S_op_destroy(pTHX_ OP *o)
389{
390 if (o->op_latefree) {
391 o->op_latefreed = 1;
392 return;
393 }
394 FreeOp(o);
395}
396
397
79072805
LW		 398/* Destructor */
399
400void
864dbfa3 401Perl_op_free(pTHX_ OP *o)
79072805 402{
27da23d5 403 dVAR;
acb36ea4 404 OPCODE type;
79072805 405
2814eb74 406 if (!o || o->op_static)
79072805 407 return;
670f3923
DM		 408 if (o->op_latefreed) {
409 if (o->op_latefree)
410 return;
411 goto do_free;
412 }
79072805 413
67566ccd 414 type = o->op_type;
7934575e 415 if (o->op_private & OPpREFCOUNTED) {
67566ccd 416 switch (type) {
7934575e
GS		 417 case OP_LEAVESUB:
418 case OP_LEAVESUBLV:
419 case OP_LEAVEEVAL:
420 case OP_LEAVE:
421 case OP_SCOPE:
422 case OP_LEAVEWRITE:
67566ccd
AL		 423 {
424 PADOFFSET refcnt;
f1fac472
NC		 425#ifdef PERL_DEBUG_READONLY_OPS
426 Slab_to_rw(o);
427#endif
7934575e 428 OP_REFCNT_LOCK;
4026c95a 429 refcnt = OpREFCNT_dec(o);
7934575e 430 OP_REFCNT_UNLOCK;
4026c95a
SH		 431 if (refcnt)
432 return;
67566ccd 433 }
7934575e
GS		 434 break;
435 default:
436 break;
437 }
438 }
439
11343788 440 if (o->op_flags & OPf_KIDS) {
6867be6d 441 register OP *kid, *nextkid;
11343788 442 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
85e6fe83 443 nextkid = kid->op_sibling; /* Get before next freeing kid */
79072805 444 op_free(kid);
85e6fe83 445 }
79072805 446 }
acb36ea4 447 if (type == OP_NULL)
eb160463 448 type = (OPCODE)o->op_targ;
acb36ea4
GS		 449
450 /* COP* is not cleared by op_clear() so that we may track line
451 * numbers etc even after null() */
452 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
453 cop_free((COP*)o);
454
455 op_clear(o);
670f3923
DM		 456 if (o->op_latefree) {
457 o->op_latefreed = 1;
458 return;
459 }
460 do_free:
238a4c30 461 FreeOp(o);
4d494880
DM		 462#ifdef DEBUG_LEAKING_SCALARS
463 if (PL_op == o)
5f66b61c 464 PL_op = NULL;
4d494880 465#endif
acb36ea4 466}
79072805 467
93c66552
DM		 468void
469Perl_op_clear(pTHX_ OP *o)
acb36ea4 470{
13137afc 471
27da23d5 472 dVAR;
eb8433b7
NC		 473#ifdef PERL_MAD
474 /* if (o->op_madprop && o->op_madprop->mad_next)
475 abort(); */
3cc8d589
NC		 476 /* FIXME for MAD - if I uncomment these two lines t/op/pack.t fails with
477 "modification of a read only value" for a reason I can't fathom why.
478 It's the "" stringification of $_, where $_ was set to '' in a foreach
04a4d38e
NC		 479 loop, but it defies simplification into a small test case.
480 However, commenting them out has caused ext/List/Util/t/weak.t to fail
481 the last test. */
3cc8d589
NC		 482 /*
483 mad_free(o->op_madprop);
484 o->op_madprop = 0;
485 */
eb8433b7
NC		 486#endif
487
488 retry:
11343788 489 switch (o->op_type) {
acb36ea4 490 case OP_NULL: /* Was holding old type, if any. */
eb8433b7
NC		 491 if (PL_madskills && o->op_targ != OP_NULL) {
492 o->op_type = o->op_targ;
493 o->op_targ = 0;
494 goto retry;
495 }
acb36ea4 496 case OP_ENTEREVAL: /* Was holding hints. */
acb36ea4 497 o->op_targ = 0;
a0d0e21e 498 break;
a6006777 499 default:
ac4c12e7 500 if (!(o->op_flags & OPf_REF)
0b94c7bb 501 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
a6006777 502 break;
503 /* FALL THROUGH */
463ee0b2 504 case OP_GVSV:
79072805 505 case OP_GV:
a6006777 506 case OP_AELEMFAST:
6a077020
DM		 507 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
508 /* not an OP_PADAV replacement */
350de78d 509#ifdef USE_ITHREADS
6a077020
DM		 510 if (cPADOPo->op_padix > 0) {
511 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
512 * may still exist on the pad */
513 pad_swipe(cPADOPo->op_padix, TRUE);
514 cPADOPo->op_padix = 0;
515 }
350de78d 516#else
6a077020 517 SvREFCNT_dec(cSVOPo->op_sv);
a0714e2c 518 cSVOPo->op_sv = NULL;
350de78d 519#endif
6a077020 520 }
79072805 521 break;
a1ae71d2 522 case OP_METHOD_NAMED:
79072805 523 case OP_CONST:
11343788 524 SvREFCNT_dec(cSVOPo->op_sv);
a0714e2c 525 cSVOPo->op_sv = NULL;
3b1c21fa
AB		 526#ifdef USE_ITHREADS
527 /** Bug #15654
528 Even if op_clear does a pad_free for the target of the op,
6a077020 529 pad_free doesn't actually remove the sv that exists in the pad;
3b1c21fa
AB		 530 instead it lives on. This results in that it could be reused as
531 a target later on when the pad was reallocated.
532 **/
533 if(o->op_targ) {
534 pad_swipe(o->op_targ,1);
535 o->op_targ = 0;
536 }
537#endif
79072805 538 break;
748a9306
LW		 539 case OP_GOTO:
540 case OP_NEXT:
541 case OP_LAST:
542 case OP_REDO:
11343788 543 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
748a9306
LW		 544 break;
545 /* FALL THROUGH */
a0d0e21e 546 case OP_TRANS:
acb36ea4 547 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
043e41b8
DM		 548#ifdef USE_ITHREADS
549 if (cPADOPo->op_padix > 0) {
550 pad_swipe(cPADOPo->op_padix, TRUE);
551 cPADOPo->op_padix = 0;
552 }
553#else
a0ed51b3 554 SvREFCNT_dec(cSVOPo->op_sv);
a0714e2c 555 cSVOPo->op_sv = NULL;
043e41b8 556#endif
acb36ea4
GS		 557 }
558 else {
ea71c68d 559 PerlMemShared_free(cPVOPo->op_pv);
bd61b366 560 cPVOPo->op_pv = NULL;
acb36ea4 561 }
a0d0e21e
LW		 562 break;
563 case OP_SUBST:
11343788 564 op_free(cPMOPo->op_pmreplroot);
971a9dd3 565 goto clear_pmop;
748a9306 566 case OP_PUSHRE:
971a9dd3 567#ifdef USE_ITHREADS
ba89bb6e 568 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
dd2155a4
DM		 569 /* No GvIN_PAD_off here, because other references may still
570 * exist on the pad */
571 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
971a9dd3
GS		 572 }
573#else
574 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
575#endif
576 /* FALL THROUGH */
a0d0e21e 577 case OP_MATCH:
8782bef2 578 case OP_QR:
971a9dd3 579clear_pmop:
cb55de95 580 {
551405c4 581 HV * const pmstash = PmopSTASH(cPMOPo);
0565a181 582 if (pmstash && !SvIS_FREED(pmstash)) {
551405c4 583 MAGIC * const mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab);
8d2f4536
NC		 584 if (mg) {
585 PMOP *pmop = (PMOP*) mg->mg_obj;
586 PMOP *lastpmop = NULL;
587 while (pmop) {
588 if (cPMOPo == pmop) {
589 if (lastpmop)
590 lastpmop->op_pmnext = pmop->op_pmnext;
591 else
592 mg->mg_obj = (SV*) pmop->op_pmnext;
593 break;
594 }
595 lastpmop = pmop;
596 pmop = pmop->op_pmnext;
cb55de95 597 }
cb55de95 598 }
83da49e6 599 }
05ec9bb3 600 PmopSTASH_free(cPMOPo);
cb55de95 601 }
5f66b61c 602 cPMOPo->op_pmreplroot = NULL;
5f8cb046
DM		 603 /* we use the "SAFE" version of the PM_ macros here
604 * since sv_clean_all might release some PMOPs
605 * after PL_regex_padav has been cleared
606 * and the clearing of PL_regex_padav needs to
607 * happen before sv_clean_all
608 */
609 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
5f66b61c 610 PM_SETRE_SAFE(cPMOPo, NULL);
13137afc
AB		 611#ifdef USE_ITHREADS
612 if(PL_regex_pad) { /* We could be in destruction */
613 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
1cc8b4c5 614 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
13137afc
AB		 615 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
616 }
1eb1540c 617#endif
13137afc 618
a0d0e21e 619 break;
79072805
LW		 620 }
621
743e66e6 622 if (o->op_targ > 0) {
11343788 623 pad_free(o->op_targ);
743e66e6
GS		 624 o->op_targ = 0;
625 }
79072805
LW		 626}
627
76e3520e 628STATIC void
3eb57f73
HS		 629S_cop_free(pTHX_ COP* cop)
630{
6a3d5e3d 631 CopLABEL_free(cop);
05ec9bb3
NIS		 632 CopFILE_free(cop);
633 CopSTASH_free(cop);
0453d815 634 if (! specialWARN(cop->cop_warnings))
72dc9ed5 635 PerlMemShared_free(cop->cop_warnings);
c28fe1ec 636 Perl_refcounted_he_free(aTHX_ cop->cop_hints_hash);
3eb57f73
HS		 637}
638
93c66552
DM		 639void
640Perl_op_null(pTHX_ OP *o)
8990e307 641{
27da23d5 642 dVAR;
acb36ea4
GS		 643 if (o->op_type == OP_NULL)
644 return;
eb8433b7
NC		 645 if (!PL_madskills)
646 op_clear(o);
11343788
MB		 647 o->op_targ = o->op_type;
648 o->op_type = OP_NULL;
22c35a8c 649 o->op_ppaddr = PL_ppaddr[OP_NULL];
8990e307
LW		 650}
651
4026c95a
SH		 652void
653Perl_op_refcnt_lock(pTHX)
654{
27da23d5 655 dVAR;
96a5add6 656 PERL_UNUSED_CONTEXT;
4026c95a
SH		 657 OP_REFCNT_LOCK;
658}
659
660void
661Perl_op_refcnt_unlock(pTHX)
662{
27da23d5 663 dVAR;
96a5add6 664 PERL_UNUSED_CONTEXT;
4026c95a
SH		 665 OP_REFCNT_UNLOCK;
666}
667
79072805
LW		 668/* Contextualizers */
669
463ee0b2 670#define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
79072805
LW		 671
672OP *
864dbfa3 673Perl_linklist(pTHX_ OP *o)
79072805 674{
3edf23ff 675 OP *first;
79072805 676
11343788
MB		 677 if (o->op_next)
678 return o->op_next;
79072805
LW		 679
680 /* establish postfix order */
3edf23ff
AL		 681 first = cUNOPo->op_first;
682 if (first) {
6867be6d 683 register OP *kid;
3edf23ff
AL		 684 o->op_next = LINKLIST(first);
685 kid = first;
686 for (;;) {
687 if (kid->op_sibling) {
79072805 688 kid->op_next = LINKLIST(kid->op_sibling);
3edf23ff
AL		 689 kid = kid->op_sibling;
690 } else {
11343788 691 kid->op_next = o;
3edf23ff
AL		 692 break;
693 }
79072805
LW		 694 }
695 }
696 else
11343788 697 o->op_next = o;
79072805 698
11343788 699 return o->op_next;
79072805
LW		 700}
701
702OP *
864dbfa3 703Perl_scalarkids(pTHX_ OP *o)
79072805 704{
11343788 705 if (o && o->op_flags & OPf_KIDS) {
bfed75c6 706 OP *kid;
11343788 707 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW		 708 scalar(kid);
709 }
11343788 710 return o;
79072805
LW		 711}
712
76e3520e 713STATIC OP *
cea2e8a9 714S_scalarboolean(pTHX_ OP *o)
8990e307 715{
97aff369 716 dVAR;
d008e5eb 717 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
d008e5eb 718 if (ckWARN(WARN_SYNTAX)) {
6867be6d 719 const line_t oldline = CopLINE(PL_curcop);
a0d0e21e 720
d008e5eb 721 if (PL_copline != NOLINE)
57843af0 722 CopLINE_set(PL_curcop, PL_copline);
9014280d 723 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
57843af0 724 CopLINE_set(PL_curcop, oldline);
d008e5eb 725 }
a0d0e21e 726 }
11343788 727 return scalar(o);
8990e307
LW		 728}
729
730OP *
864dbfa3 731Perl_scalar(pTHX_ OP *o)
79072805 732{
27da23d5 733 dVAR;
79072805
LW		 734 OP *kid;
735
a0d0e21e 736 /* assumes no premature commitment */
551405c4 737 if (!o || PL_error_count || (o->op_flags & OPf_WANT)
5dc0d613 738 || o->op_type == OP_RETURN)
7e363e51 739 {
11343788 740 return o;
7e363e51 741 }
79072805 742
5dc0d613 743 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
79072805 744
11343788 745 switch (o->op_type) {
79072805 746 case OP_REPEAT:
11343788 747 scalar(cBINOPo->op_first);
8990e307 748 break;
79072805
LW		 749 case OP_OR:
750 case OP_AND:
751 case OP_COND_EXPR:
11343788 752 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
8990e307 753 scalar(kid);
79072805 754 break;
a0d0e21e 755 case OP_SPLIT:
11343788 756 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
a0d0e21e 757 if (!kPMOP->op_pmreplroot)
12bcd1a6 758 deprecate_old("implicit split to @_");
a0d0e21e
LW		 759 }
760 /* FALL THROUGH */
79072805 761 case OP_MATCH:
8782bef2 762 case OP_QR:
79072805
LW		 763 case OP_SUBST:
764 case OP_NULL:
8990e307 765 default:
11343788
MB		 766 if (o->op_flags & OPf_KIDS) {
767 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
8990e307
LW		 768 scalar(kid);
769 }
79072805
LW		 770 break;
771 case OP_LEAVE:
772 case OP_LEAVETRY:
5dc0d613 773 kid = cLISTOPo->op_first;
54310121 774 scalar(kid);
155aba94 775 while ((kid = kid->op_sibling)) {
54310121 776 if (kid->op_sibling)
777 scalarvoid(kid);
778 else
779 scalar(kid);
780 }
11206fdd 781 PL_curcop = &PL_compiling;
54310121 782 break;
748a9306 783 case OP_SCOPE:
79072805 784 case OP_LINESEQ:
8990e307 785 case OP_LIST:
11343788 786 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
79072805
LW		 787 if (kid->op_sibling)
788 scalarvoid(kid);
789 else
790 scalar(kid);
791 }
11206fdd 792 PL_curcop = &PL_compiling;
79072805 793 break;
a801c63c
RGS		 794 case OP_SORT:
795 if (ckWARN(WARN_VOID))
9014280d 796 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
79072805 797 }
11343788 798 return o;
79072805
LW		 799}
800
801OP *
864dbfa3 802Perl_scalarvoid(pTHX_ OP *o)
79072805 803{
27da23d5 804 dVAR;
79072805 805 OP *kid;
c445ea15 806 const char* useless = NULL;
8990e307 807 SV* sv;
2ebea0a1
GS		 808 U8 want;
809
eb8433b7
NC		 810 /* trailing mad null ops don't count as "there" for void processing */
811 if (PL_madskills &&
812 o->op_type != OP_NULL &&
813 o->op_sibling &&
814 o->op_sibling->op_type == OP_NULL)
815 {
816 OP *sib;
817 for (sib = o->op_sibling;
818 sib && sib->op_type == OP_NULL;
819 sib = sib->op_sibling) ;
820
821 if (!sib)
822 return o;
823 }
824
acb36ea4
GS		 825 if (o->op_type == OP_NEXTSTATE
826 || o->op_type == OP_SETSTATE
827 || o->op_type == OP_DBSTATE
828 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
829 || o->op_targ == OP_SETSTATE
830 || o->op_targ == OP_DBSTATE)))
2ebea0a1 831 PL_curcop = (COP*)o; /* for warning below */
79072805 832
54310121 833 /* assumes no premature commitment */
2ebea0a1
GS		 834 want = o->op_flags & OPf_WANT;
835 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
5dc0d613 836 || o->op_type == OP_RETURN)
7e363e51 837 {
11343788 838 return o;
7e363e51 839 }
79072805 840
b162f9ea 841 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS		 842 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
843 {
b162f9ea 844 return scalar(o); /* As if inside SASSIGN */
7e363e51 845 }
1c846c1f 846
5dc0d613 847 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
79072805 848
11343788 849 switch (o->op_type) {
79072805 850 default:
22c35a8c 851 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
8990e307 852 break;
36477c24 853 /* FALL THROUGH */
854 case OP_REPEAT:
11343788 855 if (o->op_flags & OPf_STACKED)
8990e307 856 break;
5d82c453
GA		 857 goto func_ops;
858 case OP_SUBSTR:
859 if (o->op_private == 4)
860 break;
8990e307
LW		 861 /* FALL THROUGH */
862 case OP_GVSV:
863 case OP_WANTARRAY:
864 case OP_GV:
865 case OP_PADSV:
866 case OP_PADAV:
867 case OP_PADHV:
868 case OP_PADANY:
869 case OP_AV2ARYLEN:
8990e307 870 case OP_REF:
a0d0e21e
LW		 871 case OP_REFGEN:
872 case OP_SREFGEN:
8990e307
LW		 873 case OP_DEFINED:
874 case OP_HEX:
875 case OP_OCT:
876 case OP_LENGTH:
8990e307
LW		 877 case OP_VEC:
878 case OP_INDEX:
879 case OP_RINDEX:
880 case OP_SPRINTF:
881 case OP_AELEM:
882 case OP_AELEMFAST:
883 case OP_ASLICE:
8990e307
LW		 884 case OP_HELEM:
885 case OP_HSLICE:
886 case OP_UNPACK:
887 case OP_PACK:
8990e307
LW		 888 case OP_JOIN:
889 case OP_LSLICE:
890 case OP_ANONLIST:
891 case OP_ANONHASH:
892 case OP_SORT:
893 case OP_REVERSE:
894 case OP_RANGE:
895 case OP_FLIP:
896 case OP_FLOP:
897 case OP_CALLER:
898 case OP_FILENO:
899 case OP_EOF:
900 case OP_TELL:
901 case OP_GETSOCKNAME:
902 case OP_GETPEERNAME:
903 case OP_READLINK:
904 case OP_TELLDIR:
905 case OP_GETPPID:
906 case OP_GETPGRP:
907 case OP_GETPRIORITY:
908 case OP_TIME:
909 case OP_TMS:
910 case OP_LOCALTIME:
911 case OP_GMTIME:
912 case OP_GHBYNAME:
913 case OP_GHBYADDR:
914 case OP_GHOSTENT:
915 case OP_GNBYNAME:
916 case OP_GNBYADDR:
917 case OP_GNETENT:
918 case OP_GPBYNAME:
919 case OP_GPBYNUMBER:
920 case OP_GPROTOENT:
921 case OP_GSBYNAME:
922 case OP_GSBYPORT:
923 case OP_GSERVENT:
924 case OP_GPWNAM:
925 case OP_GPWUID:
926 case OP_GGRNAM:
927 case OP_GGRGID:
928 case OP_GETLOGIN:
78e1b766 929 case OP_PROTOTYPE:
5d82c453 930 func_ops:
64aac5a9 931 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
53e06cf0 932 useless = OP_DESC(o);
8990e307
LW		 933 break;
934
9f82cd5f
YST		 935 case OP_NOT:
936 kid = cUNOPo->op_first;
937 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
938 kid->op_type != OP_TRANS) {
939 goto func_ops;
940 }
941 useless = "negative pattern binding (!~)";
942 break;
943
8990e307
LW		 944 case OP_RV2GV:
945 case OP_RV2SV:
946 case OP_RV2AV:
947 case OP_RV2HV:
192587c2 948 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
11343788 949 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
8990e307
LW		 950 useless = "a variable";
951 break;
79072805
LW		 952
953 case OP_CONST:
7766f137 954 sv = cSVOPo_sv;
7a52d87a
GS		 955 if (cSVOPo->op_private & OPpCONST_STRICT)
956 no_bareword_allowed(o);
957 else {
d008e5eb
GS		 958 if (ckWARN(WARN_VOID)) {
959 useless = "a constant";
2e0ae2d3 960 if (o->op_private & OPpCONST_ARYBASE)
d4c19fe8 961 useless = NULL;
e7fec78e 962 /* don't warn on optimised away booleans, eg
b5a930ec 963 * use constant Foo, 5; Foo || print; */
e7fec78e 964 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
d4c19fe8 965 useless = NULL;
960b4253
MG		 966 /* the constants 0 and 1 are permitted as they are
967 conventionally used as dummies in constructs like
968 1 while some_condition_with_side_effects; */
e7fec78e 969 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
d4c19fe8 970 useless = NULL;
d008e5eb 971 else if (SvPOK(sv)) {
a52fe3ac
A		 972 /* perl4's way of mixing documentation and code
973 (before the invention of POD) was based on a
974 trick to mix nroff and perl code. The trick was
975 built upon these three nroff macros being used in
976 void context. The pink camel has the details in
977 the script wrapman near page 319. */
6136c704
AL		 978 const char * const maybe_macro = SvPVX_const(sv);
979 if (strnEQ(maybe_macro, "di", 2) ||
980 strnEQ(maybe_macro, "ds", 2) ||
981 strnEQ(maybe_macro, "ig", 2))
d4c19fe8 982 useless = NULL;
d008e5eb 983 }
8990e307
LW		 984 }
985 }
93c66552 986 op_null(o); /* don't execute or even remember it */
79072805
LW		 987 break;
988
989 case OP_POSTINC:
11343788 990 o->op_type = OP_PREINC; /* pre-increment is faster */
22c35a8c 991 o->op_ppaddr = PL_ppaddr[OP_PREINC];
79072805
LW		 992 break;
993
994 case OP_POSTDEC:
11343788 995 o->op_type = OP_PREDEC; /* pre-decrement is faster */
22c35a8c 996 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
79072805
LW		 997 break;
998
679d6c4e
HS		 999 case OP_I_POSTINC:
1000 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1001 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1002 break;
1003
1004 case OP_I_POSTDEC:
1005 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1006 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1007 break;
1008
79072805
LW		 1009 case OP_OR:
1010 case OP_AND:
c963b151 1011 case OP_DOR:
79072805 1012 case OP_COND_EXPR:
0d863452
RH		 1013 case OP_ENTERGIVEN:
1014 case OP_ENTERWHEN:
11343788 1015 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
79072805
LW		 1016 scalarvoid(kid);
1017 break;
5aabfad6 1018
a0d0e21e 1019 case OP_NULL:
11343788 1020 if (o->op_flags & OPf_STACKED)
a0d0e21e 1021 break;
5aabfad6 1022 /* FALL THROUGH */
2ebea0a1
GS		 1023 case OP_NEXTSTATE:
1024 case OP_DBSTATE:
79072805
LW		 1025 case OP_ENTERTRY:
1026 case OP_ENTER:
11343788 1027 if (!(o->op_flags & OPf_KIDS))
79072805 1028 break;
54310121 1029 /* FALL THROUGH */
463ee0b2 1030 case OP_SCOPE:
79072805
LW		 1031 case OP_LEAVE:
1032 case OP_LEAVETRY:
a0d0e21e 1033 case OP_LEAVELOOP:
79072805 1034 case OP_LINESEQ:
79072805 1035 case OP_LIST:
0d863452
RH		 1036 case OP_LEAVEGIVEN:
1037 case OP_LEAVEWHEN:
11343788 1038 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW		 1039 scalarvoid(kid);
1040 break;
c90c0ff4 1041 case OP_ENTEREVAL:
5196be3e 1042 scalarkids(o);
c90c0ff4 1043 break;
5aabfad6 1044 case OP_REQUIRE:
c90c0ff4 1045 /* all requires must return a boolean value */
5196be3e 1046 o->op_flags &= ~OPf_WANT;
d6483035
GS		 1047 /* FALL THROUGH */
1048 case OP_SCALAR:
5196be3e 1049 return scalar(o);
a0d0e21e 1050 case OP_SPLIT:
11343788 1051 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
a0d0e21e 1052 if (!kPMOP->op_pmreplroot)
12bcd1a6 1053 deprecate_old("implicit split to @_");
a0d0e21e
LW		 1054 }
1055 break;
79072805 1056 }
411caa50 1057 if (useless && ckWARN(WARN_VOID))
9014280d 1058 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
11343788 1059 return o;
79072805
LW		 1060}
1061
1062OP *
864dbfa3 1063Perl_listkids(pTHX_ OP *o)
79072805 1064{
11343788 1065 if (o && o->op_flags & OPf_KIDS) {
6867be6d 1066 OP *kid;
11343788 1067 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW		 1068 list(kid);
1069 }
11343788 1070 return o;
79072805
LW		 1071}
1072
1073OP *
864dbfa3 1074Perl_list(pTHX_ OP *o)
79072805 1075{
27da23d5 1076 dVAR;
79072805
LW		 1077 OP *kid;
1078
a0d0e21e 1079 /* assumes no premature commitment */
3280af22 1080 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
5dc0d613 1081 || o->op_type == OP_RETURN)
7e363e51 1082 {
11343788 1083 return o;
7e363e51 1084 }
79072805 1085
b162f9ea 1086 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS		 1087 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1088 {
b162f9ea 1089 return o; /* As if inside SASSIGN */
7e363e51 1090 }
1c846c1f 1091
5dc0d613 1092 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
79072805 1093
11343788 1094 switch (o->op_type) {
79072805
LW		 1095 case OP_FLOP:
1096 case OP_REPEAT:
11343788 1097 list(cBINOPo->op_first);
79072805
LW		 1098 break;
1099 case OP_OR:
1100 case OP_AND:
1101 case OP_COND_EXPR:
11343788 1102 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
79072805
LW		 1103 list(kid);
1104 break;
1105 default:
1106 case OP_MATCH:
8782bef2 1107 case OP_QR:
79072805
LW		 1108 case OP_SUBST:
1109 case OP_NULL:
11343788 1110 if (!(o->op_flags & OPf_KIDS))
79072805 1111 break;
11343788
MB		 1112 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1113 list(cBINOPo->op_first);
1114 return gen_constant_list(o);
79072805
LW		 1115 }
1116 case OP_LIST:
11343788 1117 listkids(o);
79072805
LW		 1118 break;
1119 case OP_LEAVE:
1120 case OP_LEAVETRY:
5dc0d613 1121 kid = cLISTOPo->op_first;
54310121 1122 list(kid);
155aba94 1123 while ((kid = kid->op_sibling)) {
54310121 1124 if (kid->op_sibling)
1125 scalarvoid(kid);
1126 else
1127 list(kid);
1128 }
11206fdd 1129 PL_curcop = &PL_compiling;
54310121 1130 break;
748a9306 1131 case OP_SCOPE:
79072805 1132 case OP_LINESEQ:
11343788 1133 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
79072805
LW		 1134 if (kid->op_sibling)
1135 scalarvoid(kid);
1136 else
1137 list(kid);
1138 }
11206fdd 1139 PL_curcop = &PL_compiling;
79072805 1140 break;
c90c0ff4 1141 case OP_REQUIRE:
1142 /* all requires must return a boolean value */
5196be3e
MB		 1143 o->op_flags &= ~OPf_WANT;
1144 return scalar(o);
79072805 1145 }
11343788 1146 return o;
79072805
LW		 1147}
1148
1149OP *
864dbfa3 1150Perl_scalarseq(pTHX_ OP *o)
79072805 1151{
97aff369 1152 dVAR;
11343788 1153 if (o) {
1496a290
AL		 1154 const OPCODE type = o->op_type;
1155
1156 if (type == OP_LINESEQ || type == OP_SCOPE ||
1157 type == OP_LEAVE || type == OP_LEAVETRY)
463ee0b2 1158 {
6867be6d 1159 OP *kid;
11343788 1160 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
ed6116ce 1161 if (kid->op_sibling) {
463ee0b2 1162 scalarvoid(kid);
ed6116ce 1163 }
463ee0b2 1164 }
3280af22 1165 PL_curcop = &PL_compiling;
79072805 1166 }
11343788 1167 o->op_flags &= ~OPf_PARENS;
3280af22 1168 if (PL_hints & HINT_BLOCK_SCOPE)
11343788 1169 o->op_flags |= OPf_PARENS;
79072805 1170 }
8990e307 1171 else
11343788
MB		 1172 o = newOP(OP_STUB, 0);
1173 return o;
79072805
LW		 1174}
1175
76e3520e 1176STATIC OP *
cea2e8a9 1177S_modkids(pTHX_ OP *o, I32 type)
79072805 1178{
11343788 1179 if (o && o->op_flags & OPf_KIDS) {
6867be6d 1180 OP *kid;
11343788 1181 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
463ee0b2 1182 mod(kid, type);
79072805 1183 }
11343788 1184 return o;
79072805
LW		 1185}
1186
ff7298cb 1187/* Propagate lvalue ("modifiable") context to an op and its children.
ddeae0f1
DM		 1188 * 'type' represents the context type, roughly based on the type of op that
1189 * would do the modifying, although local() is represented by OP_NULL.
1190 * It's responsible for detecting things that can't be modified, flag
1191 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1192 * might have to vivify a reference in $x), and so on.
1193 *
1194 * For example, "$a+1 = 2" would cause mod() to be called with o being
1195 * OP_ADD and type being OP_SASSIGN, and would output an error.
1196 */
1197
79072805 1198OP *
864dbfa3 1199Perl_mod(pTHX_ OP *o, I32 type)
79072805 1200{
27da23d5 1201 dVAR;
79072805 1202 OP *kid;
ddeae0f1
DM		 1203 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1204 int localize = -1;
79072805 1205
3280af22 1206 if (!o || PL_error_count)
11343788 1207 return o;
79072805 1208
b162f9ea 1209 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS		 1210 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1211 {
b162f9ea 1212 return o;
7e363e51 1213 }
1c846c1f 1214
11343788 1215 switch (o->op_type) {
68dc0745 1216 case OP_UNDEF:
ddeae0f1 1217 localize = 0;
3280af22 1218 PL_modcount++;
5dc0d613 1219 return o;
a0d0e21e 1220 case OP_CONST:
2e0ae2d3 1221 if (!(o->op_private & OPpCONST_ARYBASE))
a0d0e21e 1222 goto nomod;
54dc0f91 1223 localize = 0;
3280af22 1224 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
fc15ae8f
NC		 1225 CopARYBASE_set(&PL_compiling,
1226 (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
3280af22 1227 PL_eval_start = 0;
a0d0e21e
LW		 1228 }
1229 else if (!type) {
fc15ae8f
NC		 1230 SAVECOPARYBASE(&PL_compiling);
1231 CopARYBASE_set(&PL_compiling, 0);
a0d0e21e
LW		 1232 }
1233 else if (type == OP_REFGEN)
1234 goto nomod;
1235 else
cea2e8a9 1236 Perl_croak(aTHX_ "That use of $[ is unsupported");
a0d0e21e 1237 break;
5f05dabc 1238 case OP_STUB:
eb8433b7 1239 if (o->op_flags & OPf_PARENS || PL_madskills)
5f05dabc 1240 break;
1241 goto nomod;
a0d0e21e
LW		 1242 case OP_ENTERSUB:
1243 if ((type == OP_UNDEF || type == OP_REFGEN) &&
11343788
MB		 1244 !(o->op_flags & OPf_STACKED)) {
1245 o->op_type = OP_RV2CV; /* entersub => rv2cv */
e26df76a
NC		 1246 /* The default is to set op_private to the number of children,
1247 which for a UNOP such as RV2CV is always 1. And w're using
1248 the bit for a flag in RV2CV, so we need it clear. */
1249 o->op_private &= ~1;
22c35a8c 1250 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
11343788 1251 assert(cUNOPo->op_first->op_type == OP_NULL);
93c66552 1252 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
79072805
LW		 1253 break;
1254 }
95f0a2f1
SB		 1255 else if (o->op_private & OPpENTERSUB_NOMOD)
1256 return o;
cd06dffe
GS		 1257 else { /* lvalue subroutine call */
1258 o->op_private |= OPpLVAL_INTRO;
e6438c1a 1259 PL_modcount = RETURN_UNLIMITED_NUMBER;
4978d6d9 1260 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
cd06dffe
GS		 1261 /* Backward compatibility mode: */
1262 o->op_private |= OPpENTERSUB_INARGS;
1263 break;
1264 }
1265 else { /* Compile-time error message: */
1266 OP *kid = cUNOPo->op_first;
1267 CV *cv;
1268 OP *okid;
1269
3ea285d1
AL		 1270 if (kid->op_type != OP_PUSHMARK) {
1271 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1272 Perl_croak(aTHX_
1273 "panic: unexpected lvalue entersub "
1274 "args: type/targ %ld:%"UVuf,
1275 (long)kid->op_type, (UV)kid->op_targ);
1276 kid = kLISTOP->op_first;
1277 }
cd06dffe
GS		 1278 while (kid->op_sibling)
1279 kid = kid->op_sibling;
1280 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1281 /* Indirect call */
1282 if (kid->op_type == OP_METHOD_NAMED
1283 || kid->op_type == OP_METHOD)
1284 {
87d7fd28 1285 UNOP *newop;
b2ffa427 1286
87d7fd28 1287 NewOp(1101, newop, 1, UNOP);
349fd7b7
GS		 1288 newop->op_type = OP_RV2CV;
1289 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
5f66b61c 1290 newop->op_first = NULL;
87d7fd28
GS		 1291 newop->op_next = (OP*)newop;
1292 kid->op_sibling = (OP*)newop;
349fd7b7 1293 newop->op_private |= OPpLVAL_INTRO;
e26df76a 1294 newop->op_private &= ~1;
cd06dffe
GS		 1295 break;
1296 }
b2ffa427 1297
cd06dffe
GS		 1298 if (kid->op_type != OP_RV2CV)
1299 Perl_croak(aTHX_
1300 "panic: unexpected lvalue entersub "
55140b79 1301 "entry via type/targ %ld:%"UVuf,
3d811634 1302 (long)kid->op_type, (UV)kid->op_targ);
cd06dffe
GS		 1303 kid->op_private |= OPpLVAL_INTRO;
1304 break; /* Postpone until runtime */
1305 }
b2ffa427
NIS		 1306
1307 okid = kid;
cd06dffe
GS		 1308 kid = kUNOP->op_first;
1309 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1310 kid = kUNOP->op_first;
b2ffa427 1311 if (kid->op_type == OP_NULL)
cd06dffe
GS		 1312 Perl_croak(aTHX_
1313 "Unexpected constant lvalue entersub "
55140b79 1314 "entry via type/targ %ld:%"UVuf,
3d811634 1315 (long)kid->op_type, (UV)kid->op_targ);
cd06dffe
GS		 1316 if (kid->op_type != OP_GV) {
1317 /* Restore RV2CV to check lvalueness */
1318 restore_2cv:
1319 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1320 okid->op_next = kid->op_next;
1321 kid->op_next = okid;
1322 }
1323 else
5f66b61c 1324 okid->op_next = NULL;
cd06dffe
GS		 1325 okid->op_type = OP_RV2CV;
1326 okid->op_targ = 0;
1327 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1328 okid->op_private |= OPpLVAL_INTRO;
e26df76a 1329 okid->op_private &= ~1;
cd06dffe
GS		 1330 break;
1331 }
b2ffa427 1332
638eceb6 1333 cv = GvCV(kGVOP_gv);
1c846c1f 1334 if (!cv)
cd06dffe
GS		 1335 goto restore_2cv;
1336 if (CvLVALUE(cv))
1337 break;
1338 }
1339 }
79072805
LW		 1340 /* FALL THROUGH */
1341 default:
a0d0e21e 1342 nomod:
6fbb66d6
NC		 1343 /* grep, foreach, subcalls, refgen */
1344 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
a0d0e21e 1345 break;
cea2e8a9 1346 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
638bc118 1347 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
cd06dffe
GS		 1348 ? "do block"
1349 : (o->op_type == OP_ENTERSUB
1350 ? "non-lvalue subroutine call"
53e06cf0 1351 : OP_DESC(o))),
22c35a8c 1352 type ? PL_op_desc[type] : "local"));
11343788 1353 return o;
79072805 1354
a0d0e21e
LW		 1355 case OP_PREINC:
1356 case OP_PREDEC:
1357 case OP_POW:
1358 case OP_MULTIPLY:
1359 case OP_DIVIDE:
1360 case OP_MODULO:
1361 case OP_REPEAT:
1362 case OP_ADD:
1363 case OP_SUBTRACT:
1364 case OP_CONCAT:
1365 case OP_LEFT_SHIFT:
1366 case OP_RIGHT_SHIFT:
1367 case OP_BIT_AND:
1368 case OP_BIT_XOR:
1369 case OP_BIT_OR:
1370 case OP_I_MULTIPLY:
1371 case OP_I_DIVIDE:
1372 case OP_I_MODULO:
1373 case OP_I_ADD:
1374 case OP_I_SUBTRACT:
11343788 1375 if (!(o->op_flags & OPf_STACKED))
a0d0e21e 1376 goto nomod;
3280af22 1377 PL_modcount++;
a0d0e21e 1378 break;
b2ffa427 1379
79072805 1380 case OP_COND_EXPR:
ddeae0f1 1381 localize = 1;
11343788 1382 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
463ee0b2 1383 mod(kid, type);
79072805
LW		 1384 break;
1385
1386 case OP_RV2AV:
1387 case OP_RV2HV:
11343788 1388 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
e6438c1a 1389 PL_modcount = RETURN_UNLIMITED_NUMBER;
11343788 1390 return o; /* Treat \(@foo) like ordinary list. */
748a9306
LW		 1391 }
1392 /* FALL THROUGH */
79072805 1393 case OP_RV2GV:
5dc0d613 1394 if (scalar_mod_type(o, type))
3fe9a6f1 1395 goto nomod;
11343788 1396 ref(cUNOPo->op_first, o->op_type);
79072805 1397 /* FALL THROUGH */
79072805
LW		 1398 case OP_ASLICE:
1399 case OP_HSLICE:
78f9721b
SM		 1400 if (type == OP_LEAVESUBLV)
1401 o->op_private |= OPpMAYBE_LVSUB;
ddeae0f1 1402 localize = 1;
78f9721b
SM		 1403 /* FALL THROUGH */
1404 case OP_AASSIGN:
93a17b20
LW		 1405 case OP_NEXTSTATE:
1406 case OP_DBSTATE:
e6438c1a 1407 PL_modcount = RETURN_UNLIMITED_NUMBER;
79072805 1408 break;
463ee0b2 1409 case OP_RV2SV:
aeea060c 1410 ref(cUNOPo->op_first, o->op_type);
ddeae0f1 1411 localize = 1;
463ee0b2 1412 /* FALL THROUGH */
79072805 1413 case OP_GV:
463ee0b2 1414 case OP_AV2ARYLEN:
3280af22 1415 PL_hints |= HINT_BLOCK_SCOPE;
463ee0b2 1416 case OP_SASSIGN:
bf4b1e52
GS		 1417 case OP_ANDASSIGN:
1418 case OP_ORASSIGN:
c963b151 1419 case OP_DORASSIGN:
ddeae0f1
DM		 1420 PL_modcount++;
1421 break;
1422
8990e307 1423 case OP_AELEMFAST:
6a077020 1424 localize = -1;
3280af22 1425 PL_modcount++;
8990e307
LW		 1426 break;
1427
748a9306
LW		 1428 case OP_PADAV:
1429 case OP_PADHV:
e6438c1a 1430 PL_modcount = RETURN_UNLIMITED_NUMBER;
5196be3e
MB		 1431 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1432 return o; /* Treat \(@foo) like ordinary list. */
1433 if (scalar_mod_type(o, type))
3fe9a6f1 1434 goto nomod;
78f9721b
SM		 1435 if (type == OP_LEAVESUBLV)
1436 o->op_private |= OPpMAYBE_LVSUB;
748a9306
LW		 1437 /* FALL THROUGH */
1438 case OP_PADSV:
3280af22 1439 PL_modcount++;
ddeae0f1 1440 if (!type) /* local() */
cea2e8a9 1441 Perl_croak(aTHX_ "Can't localize lexical variable %s",
dd2155a4 1442 PAD_COMPNAME_PV(o->op_targ));
463ee0b2
LW		 1443 break;
1444
748a9306 1445 case OP_PUSHMARK:
ddeae0f1 1446 localize = 0;
748a9306 1447 break;
b2ffa427 1448
69969c6f
SB		 1449 case OP_KEYS:
1450 if (type != OP_SASSIGN)
1451 goto nomod;
5d82c453
GA		 1452 goto lvalue_func;
1453 case OP_SUBSTR:
1454 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1455 goto nomod;
5f05dabc 1456 /* FALL THROUGH */
a0d0e21e 1457 case OP_POS:
463ee0b2 1458 case OP_VEC:
78f9721b
SM		 1459 if (type == OP_LEAVESUBLV)
1460 o->op_private |= OPpMAYBE_LVSUB;
5d82c453 1461 lvalue_func:
11343788
MB		 1462 pad_free(o->op_targ);
1463 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
5dc0d613 1464 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
11343788
MB		 1465 if (o->op_flags & OPf_KIDS)
1466 mod(cBINOPo->op_first->op_sibling, type);
463ee0b2 1467 break;
a0d0e21e 1468
463ee0b2
LW		 1469 case OP_AELEM:
1470 case OP_HELEM:
11343788 1471 ref(cBINOPo->op_first, o->op_type);
68dc0745 1472 if (type == OP_ENTERSUB &&
5dc0d613
MB		 1473 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1474 o->op_private |= OPpLVAL_DEFER;
78f9721b
SM		 1475 if (type == OP_LEAVESUBLV)
1476 o->op_private |= OPpMAYBE_LVSUB;
ddeae0f1 1477 localize = 1;
3280af22 1478 PL_modcount++;
463ee0b2
LW		 1479 break;
1480
1481 case OP_SCOPE:
1482 case OP_LEAVE:
1483 case OP_ENTER:
78f9721b 1484 case OP_LINESEQ:
ddeae0f1 1485 localize = 0;
11343788
MB		 1486 if (o->op_flags & OPf_KIDS)
1487 mod(cLISTOPo->op_last, type);
a0d0e21e
LW		 1488 break;
1489
1490 case OP_NULL:
ddeae0f1 1491 localize = 0;
638bc118
GS		 1492 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1493 goto nomod;
1494 else if (!(o->op_flags & OPf_KIDS))
463ee0b2 1495 break;
11343788
MB		 1496 if (o->op_targ != OP_LIST) {
1497 mod(cBINOPo->op_first, type);
a0d0e21e
LW		 1498 break;
1499 }
1500 /* FALL THROUGH */
463ee0b2 1501 case OP_LIST:
ddeae0f1 1502 localize = 0;
11343788 1503 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
463ee0b2
LW		 1504 mod(kid, type);
1505 break;
78f9721b
SM		 1506
1507 case OP_RETURN:
1508 if (type != OP_LEAVESUBLV)
1509 goto nomod;
1510 break; /* mod()ing was handled by ck_return() */
463ee0b2 1511 }
58d95175 1512
8be1be90
AMS		 1513 /* [20011101.069] File test operators interpret OPf_REF to mean that
1514 their argument is a filehandle; thus \stat(".") should not set
1515 it. AMS 20011102 */
1516 if (type == OP_REFGEN &&
1517 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1518 return o;
1519
1520 if (type != OP_LEAVESUBLV)
1521 o->op_flags |= OPf_MOD;
1522
1523 if (type == OP_AASSIGN || type == OP_SASSIGN)
1524 o->op_flags |= OPf_SPECIAL|OPf_REF;
ddeae0f1
DM		 1525 else if (!type) { /* local() */
1526 switch (localize) {
1527 case 1:
1528 o->op_private |= OPpLVAL_INTRO;
1529 o->op_flags &= ~OPf_SPECIAL;
1530 PL_hints |= HINT_BLOCK_SCOPE;
1531 break;
1532 case 0:
1533 break;
1534 case -1:
1535 if (ckWARN(WARN_SYNTAX)) {
1536 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1537 "Useless localization of %s", OP_DESC(o));
1538 }
1539 }
463ee0b2 1540 }
8be1be90
AMS		 1541 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1542 && type != OP_LEAVESUBLV)
1543 o->op_flags |= OPf_REF;
11343788 1544 return o;
463ee0b2
LW		 1545}
1546
864dbfa3 1547STATIC bool
5f66b61c 1548S_scalar_mod_type(const OP *o, I32 type)
3fe9a6f1 1549{
1550 switch (type) {
1551 case OP_SASSIGN:
5196be3e 1552 if (o->op_type == OP_RV2GV)
3fe9a6f1 1553 return FALSE;
1554 /* FALL THROUGH */
1555 case OP_PREINC:
1556 case OP_PREDEC:
1557 case OP_POSTINC:
1558 case OP_POSTDEC:
1559 case OP_I_PREINC:
1560 case OP_I_PREDEC:
1561 case OP_I_POSTINC:
1562 case OP_I_POSTDEC:
1563 case OP_POW:
1564 case OP_MULTIPLY:
1565 case OP_DIVIDE:
1566 case OP_MODULO:
1567 case OP_REPEAT:
1568 case OP_ADD:
1569 case OP_SUBTRACT:
1570 case OP_I_MULTIPLY:
1571 case OP_I_DIVIDE:
1572 case OP_I_MODULO:
1573 case OP_I_ADD:
1574 case OP_I_SUBTRACT:
1575 case OP_LEFT_SHIFT:
1576 case OP_RIGHT_SHIFT:
1577 case OP_BIT_AND:
1578 case OP_BIT_XOR:
1579 case OP_BIT_OR:
1580 case OP_CONCAT:
1581 case OP_SUBST:
1582 case OP_TRANS:
49e9fbe6
GS		 1583 case OP_READ:
1584 case OP_SYSREAD:
1585 case OP_RECV:
bf4b1e52
GS		 1586 case OP_ANDASSIGN:
1587 case OP_ORASSIGN:
3fe9a6f1 1588 return TRUE;
1589 default:
1590 return FALSE;
1591 }
1592}
1593
35cd451c 1594STATIC bool
5f66b61c 1595S_is_handle_constructor(const OP *o, I32 numargs)
35cd451c
GS		 1596{
1597 switch (o->op_type) {
1598 case OP_PIPE_OP:
1599 case OP_SOCKPAIR:
504618e9 1600 if (numargs == 2)
35cd451c
GS		 1601 return TRUE;
1602 /* FALL THROUGH */
1603 case OP_SYSOPEN:
1604 case OP_OPEN:
ded8aa31 1605 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
35cd451c
GS		 1606 case OP_SOCKET:
1607 case OP_OPEN_DIR:
1608 case OP_ACCEPT:
504618e9 1609 if (numargs == 1)
35cd451c 1610 return TRUE;
5f66b61c 1611 /* FALLTHROUGH */
35cd451c
GS		 1612 default:
1613 return FALSE;
1614 }
1615}
1616
463ee0b2 1617OP *
864dbfa3 1618Perl_refkids(pTHX_ OP *o, I32 type)
463ee0b2 1619{
11343788 1620 if (o && o->op_flags & OPf_KIDS) {
6867be6d 1621 OP *kid;
11343788 1622 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
463ee0b2
LW		 1623 ref(kid, type);
1624 }
11343788 1625 return o;
463ee0b2
LW		 1626}
1627
1628OP *
e4c5ccf3 1629Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
463ee0b2 1630{
27da23d5 1631 dVAR;
463ee0b2 1632 OP *kid;
463ee0b2 1633
3280af22 1634 if (!o || PL_error_count)
11343788 1635 return o;
463ee0b2 1636
11343788 1637 switch (o->op_type) {
a0d0e21e 1638 case OP_ENTERSUB:
afebc493 1639 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
11343788
MB		 1640 !(o->op_flags & OPf_STACKED)) {
1641 o->op_type = OP_RV2CV; /* entersub => rv2cv */
22c35a8c 1642 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
11343788 1643 assert(cUNOPo->op_first->op_type == OP_NULL);
93c66552 1644 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
11343788 1645 o->op_flags |= OPf_SPECIAL;
e26df76a 1646 o->op_private &= ~1;
8990e307
LW		 1647 }
1648 break;
aeea060c 1649
463ee0b2 1650 case OP_COND_EXPR:
11343788 1651 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
e4c5ccf3 1652 doref(kid, type, set_op_ref);
463ee0b2 1653 break;
8990e307 1654 case OP_RV2SV:
35cd451c
GS		 1655 if (type == OP_DEFINED)
1656 o->op_flags |= OPf_SPECIAL; /* don't create GV */
e4c5ccf3 1657 doref(cUNOPo->op_first, o->op_type, set_op_ref);
4633a7c4
LW		 1658 /* FALL THROUGH */
1659 case OP_PADSV:
5f05dabc 1660 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5dc0d613
MB		 1661 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1662 : type == OP_RV2HV ? OPpDEREF_HV
1663 : OPpDEREF_SV);
11343788 1664 o->op_flags |= OPf_MOD;
a0d0e21e 1665 }
8990e307 1666 break;
1c846c1f 1667
463ee0b2
LW		 1668 case OP_RV2AV:
1669 case OP_RV2HV:
e4c5ccf3
RH		 1670 if (set_op_ref)
1671 o->op_flags |= OPf_REF;
8990e307 1672 /* FALL THROUGH */
463ee0b2 1673 case OP_RV2GV:
35cd451c
GS		 1674 if (type == OP_DEFINED)
1675 o->op_flags |= OPf_SPECIAL; /* don't create GV */
e4c5ccf3 1676 doref(cUNOPo->op_first, o->op_type, set_op_ref);
463ee0b2 1677 break;
8990e307 1678
463ee0b2
LW		 1679 case OP_PADAV:
1680 case OP_PADHV:
e4c5ccf3
RH		 1681 if (set_op_ref)
1682 o->op_flags |= OPf_REF;
79072805 1683 break;
aeea060c 1684
8990e307 1685 case OP_SCALAR:
79072805 1686 case OP_NULL:
11343788 1687 if (!(o->op_flags & OPf_KIDS))
463ee0b2 1688 break;
e4c5ccf3 1689 doref(cBINOPo->op_first, type, set_op_ref);
79072805
LW		 1690 break;
1691 case OP_AELEM:
1692 case OP_HELEM:
e4c5ccf3 1693 doref(cBINOPo->op_first, o->op_type, set_op_ref);
5f05dabc 1694 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5dc0d613
MB		 1695 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1696 : type == OP_RV2HV ? OPpDEREF_HV
1697 : OPpDEREF_SV);
11343788 1698 o->op_flags |= OPf_MOD;
8990e307 1699 }
79072805
LW		 1700 break;
1701
463ee0b2 1702 case OP_SCOPE:
79072805 1703 case OP_LEAVE:
e4c5ccf3
RH		 1704 set_op_ref = FALSE;
1705 /* FALL THROUGH */
79072805 1706 case OP_ENTER:
8990e307 1707 case OP_LIST:
11343788 1708 if (!(o->op_flags & OPf_KIDS))
79072805 1709 break;
e4c5ccf3 1710 doref(cLISTOPo->op_last, type, set_op_ref);
79072805 1711 break;
a0d0e21e
LW		 1712 default:
1713 break;
79072805 1714 }
11343788 1715 return scalar(o);
8990e307 1716
79072805
LW		 1717}
1718
09bef843
SB		 1719STATIC OP *
1720S_dup_attrlist(pTHX_ OP *o)
1721{
97aff369 1722 dVAR;
0bd48802 1723 OP *rop;
09bef843
SB		 1724
1725 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1726 * where the first kid is OP_PUSHMARK and the remaining ones
1727 * are OP_CONST. We need to push the OP_CONST values.
1728 */
1729 if (o->op_type == OP_CONST)
b37c2d43 1730 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
eb8433b7
NC		 1731#ifdef PERL_MAD
1732 else if (o->op_type == OP_NULL)
1d866c12 1733 rop = NULL;
eb8433b7 1734#endif
09bef843
SB		 1735 else {
1736 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
5f66b61c 1737 rop = NULL;
09bef843
SB		 1738 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1739 if (o->op_type == OP_CONST)
1740 rop = append_elem(OP_LIST, rop,
1741 newSVOP(OP_CONST, o->op_flags,
b37c2d43 1742 SvREFCNT_inc_NN(cSVOPo->op_sv)));
09bef843
SB		 1743 }
1744 }
1745 return rop;
1746}
1747
1748STATIC void
95f0a2f1 1749S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
09bef843 1750{
27da23d5 1751 dVAR;
09bef843
SB		 1752 SV *stashsv;
1753
1754 /* fake up C<use attributes $pkg,$rv,@attrs> */
1755 ENTER; /* need to protect against side-effects of 'use' */
1756 SAVEINT(PL_expect);
5aaec2b4 1757 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
e4783991 1758
09bef843 1759#define ATTRSMODULE "attributes"
95f0a2f1
SB		 1760#define ATTRSMODULE_PM "attributes.pm"
1761
1762 if (for_my) {
95f0a2f1 1763 /* Don't force the C<use> if we don't need it. */
a4fc7abc 1764 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
95f0a2f1 1765 if (svp && *svp != &PL_sv_undef)
6f207bd3 1766 NOOP; /* already in %INC */
95f0a2f1
SB		 1767 else
1768 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6136c704 1769 newSVpvs(ATTRSMODULE), NULL);
95f0a2f1
SB		 1770 }
1771 else {
1772 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
6136c704
AL		 1773 newSVpvs(ATTRSMODULE),
1774 NULL,
95f0a2f1
SB		 1775 prepend_elem(OP_LIST,
1776 newSVOP(OP_CONST, 0, stashsv),
1777 prepend_elem(OP_LIST,
1778 newSVOP(OP_CONST, 0,
1779 newRV(target)),
1780 dup_attrlist(attrs))));
1781 }
09bef843
SB		 1782 LEAVE;
1783}
1784
95f0a2f1
SB		 1785STATIC void
1786S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1787{
97aff369 1788 dVAR;
95f0a2f1
SB		 1789 OP *pack, *imop, *arg;
1790 SV *meth, *stashsv;
1791
1792 if (!attrs)
1793 return;
1794
1795 assert(target->op_type == OP_PADSV ||
1796 target->op_type == OP_PADHV ||
1797 target->op_type == OP_PADAV);
1798
1799 /* Ensure that attributes.pm is loaded. */
dd2155a4 1800 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
95f0a2f1
SB		 1801
1802 /* Need package name for method call. */
6136c704 1803 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
95f0a2f1
SB		 1804
1805 /* Build up the real arg-list. */
5aaec2b4
NC		 1806 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1807
95f0a2f1
SB		 1808 arg = newOP(OP_PADSV, 0);
1809 arg->op_targ = target->op_targ;
1810 arg = prepend_elem(OP_LIST,
1811 newSVOP(OP_CONST, 0, stashsv),
1812 prepend_elem(OP_LIST,
1813 newUNOP(OP_REFGEN, 0,
1814 mod(arg, OP_REFGEN)),
1815 dup_attrlist(attrs)));
1816
1817 /* Fake up a method call to import */
18916d0d 1818 meth = newSVpvs_share("import");
95f0a2f1
SB		 1819 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1820 append_elem(OP_LIST,
1821 prepend_elem(OP_LIST, pack, list(arg)),
1822 newSVOP(OP_METHOD_NAMED, 0, meth)));
1823 imop->op_private |= OPpENTERSUB_NOMOD;
1824
1825 /* Combine the ops. */
1826 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1827}
1828
1829/*
1830=notfor apidoc apply_attrs_string
1831
1832Attempts to apply a list of attributes specified by the C<attrstr> and
1833C<len> arguments to the subroutine identified by the C<cv> argument which
1834is expected to be associated with the package identified by the C<stashpv>
1835argument (see L<attributes>). It gets this wrong, though, in that it
1836does not correctly identify the boundaries of the individual attribute
1837specifications within C<attrstr>. This is not really intended for the
1838public API, but has to be listed here for systems such as AIX which
1839need an explicit export list for symbols. (It's called from XS code
1840in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1841to respect attribute syntax properly would be welcome.
1842
1843=cut
1844*/
1845
be3174d2 1846void
6867be6d
AL		 1847Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1848 const char *attrstr, STRLEN len)
be3174d2 1849{
5f66b61c 1850 OP *attrs = NULL;
be3174d2
GS		 1851
1852 if (!len) {
1853 len = strlen(attrstr);
1854 }
1855
1856 while (len) {
1857 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1858 if (len) {
890ce7af 1859 const char * const sstr = attrstr;
be3174d2
GS		 1860 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1861 attrs = append_elem(OP_LIST, attrs,
1862 newSVOP(OP_CONST, 0,
1863 newSVpvn(sstr, attrstr-sstr)));
1864 }
1865 }
1866
1867 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
6136c704 1868 newSVpvs(ATTRSMODULE),
a0714e2c 1869 NULL, prepend_elem(OP_LIST,
be3174d2
GS		 1870 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1871 prepend_elem(OP_LIST,
1872 newSVOP(OP_CONST, 0,
1873 newRV((SV*)cv)),
1874 attrs)));
1875}
1876
09bef843 1877STATIC OP *
95f0a2f1 1878S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
93a17b20 1879{
97aff369 1880 dVAR;
93a17b20
LW		 1881 I32 type;
1882
3280af22 1883 if (!o || PL_error_count)
11343788 1884 return o;
93a17b20 1885
bc61e325 1886 type = o->op_type;
eb8433b7
NC		 1887 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
1888 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
1889 return o;
1890 }
1891
93a17b20 1892 if (type == OP_LIST) {
6867be6d 1893 OP *kid;
11343788 1894 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
95f0a2f1 1895 my_kid(kid, attrs, imopsp);
eb8433b7
NC		 1896 } else if (type == OP_UNDEF
1897#ifdef PERL_MAD
1898 || type == OP_STUB
1899#endif
1900 ) {
7766148a 1901 return o;
77ca0c92
LW		 1902 } else if (type == OP_RV2SV || /* "our" declaration */
1903 type == OP_RV2AV ||
1904 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1ce0b88c 1905 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
fab01b8e 1906 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
952306ac
RGS		 1907 OP_DESC(o),
1908 PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
1ce0b88c 1909 } else if (attrs) {
551405c4 1910 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
1ce0b88c 1911 PL_in_my = FALSE;
5c284bb0 1912 PL_in_my_stash = NULL;
1ce0b88c
RGS		 1913 apply_attrs(GvSTASH(gv),
1914 (type == OP_RV2SV ? GvSV(gv) :
1915 type == OP_RV2AV ? (SV*)GvAV(gv) :
1916 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1917 attrs, FALSE);
1918 }
192587c2 1919 o->op_private |= OPpOUR_INTRO;
77ca0c92 1920 return o;
95f0a2f1
SB		 1921 }
1922 else if (type != OP_PADSV &&
93a17b20
LW		 1923 type != OP_PADAV &&
1924 type != OP_PADHV &&
1925 type != OP_PUSHMARK)
1926 {
eb64745e 1927 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
53e06cf0 1928 OP_DESC(o),
952306ac 1929 PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
11343788 1930 return o;
93a17b20 1931 }
09bef843
SB		 1932 else if (attrs && type != OP_PUSHMARK) {
1933 HV *stash;
09bef843 1934
eb64745e 1935 PL_in_my = FALSE;
5c284bb0 1936 PL_in_my_stash = NULL;
eb64745e 1937
09bef843 1938 /* check for C<my Dog $spot> when deciding package */
dd2155a4
DM		 1939 stash = PAD_COMPNAME_TYPE(o->op_targ);
1940 if (!stash)
09bef843 1941 stash = PL_curstash;
95f0a2f1 1942 apply_attrs_my(stash, o, attrs, imopsp);
09bef843 1943 }
11343788
MB		 1944 o->op_flags |= OPf_MOD;
1945 o->op_private |= OPpLVAL_INTRO;
952306ac
RGS		 1946 if (PL_in_my == KEY_state)
1947 o->op_private |= OPpPAD_STATE;
11343788 1948 return o;
93a17b20
LW		 1949}
1950
1951OP *
09bef843
SB		 1952Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1953{
97aff369 1954 dVAR;
0bd48802 1955 OP *rops;
95f0a2f1
SB		 1956 int maybe_scalar = 0;
1957
d2be0de5 1958/* [perl #17376]: this appears to be premature, and results in code such as
c754c3d7 1959 C< our(%x); > executing in list mode rather than void mode */
d2be0de5 1960#if 0
09bef843
SB		 1961 if (o->op_flags & OPf_PARENS)
1962 list(o);
95f0a2f1
SB		 1963 else
1964 maybe_scalar = 1;
d2be0de5
YST		 1965#else
1966 maybe_scalar = 1;
1967#endif
09bef843
SB		 1968 if (attrs)
1969 SAVEFREEOP(attrs);
5f66b61c 1970 rops = NULL;
95f0a2f1
SB		 1971 o = my_kid(o, attrs, &rops);
1972 if (rops) {
1973 if (maybe_scalar && o->op_type == OP_PADSV) {
1974 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1975 o->op_private |= OPpLVAL_INTRO;
1976 }
1977 else
1978 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1979 }
eb64745e 1980 PL_in_my = FALSE;
5c284bb0 1981 PL_in_my_stash = NULL;
eb64745e 1982 return o;
09bef843
SB		 1983}
1984
1985OP *
1986Perl_my(pTHX_ OP *o)
1987{
5f66b61c 1988 return my_attrs(o, NULL);
09bef843
SB		 1989}
1990
1991OP *
864dbfa3 1992Perl_sawparens(pTHX_ OP *o)
79072805 1993{
96a5add6 1994 PERL_UNUSED_CONTEXT;
79072805
LW		 1995 if (o)
1996 o->op_flags |= OPf_PARENS;
1997 return o;
1998}
1999
2000OP *
864dbfa3 2001Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
79072805 2002{
11343788 2003 OP *o;
59f00321 2004 bool ismatchop = 0;
1496a290
AL		 2005 const OPCODE ltype = left->op_type;
2006 const OPCODE rtype = right->op_type;
79072805 2007
1496a290
AL		 2008 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2009 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
041457d9 2010 {
1496a290 2011 const char * const desc
666ea192
JH		 2012 = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
2013 ? (int)rtype : OP_MATCH];
2014 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
2015 ? "@array" : "%hash");
9014280d 2016 Perl_warner(aTHX_ packWARN(WARN_MISC),
1c846c1f 2017 "Applying %s to %s will act on scalar(%s)",
599cee73 2018 desc, sample, sample);
2ae324a7 2019 }
2020
1496a290 2021 if (rtype == OP_CONST &&
5cc9e5c9
RH		 2022 cSVOPx(right)->op_private & OPpCONST_BARE &&
2023 cSVOPx(right)->op_private & OPpCONST_STRICT)
2024 {
2025 no_bareword_allowed(right);
2026 }
2027
1496a290
AL		 2028 ismatchop = rtype == OP_MATCH ||
2029 rtype == OP_SUBST ||
2030 rtype == OP_TRANS;
59f00321
RGS		 2031 if (ismatchop && right->op_private & OPpTARGET_MY) {
2032 right->op_targ = 0;
2033 right->op_private &= ~OPpTARGET_MY;
2034 }
2035 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1496a290
AL		 2036 OP *newleft;
2037
79072805 2038 right->op_flags |= OPf_STACKED;
1496a290
AL		 2039 if (rtype != OP_MATCH &&
2040 ! (rtype == OP_TRANS &&
6fbb66d6 2041 right->op_private & OPpTRANS_IDENTICAL))
1496a290
AL		 2042 newleft = mod(left, rtype);
2043 else
2044 newleft = left;
79072805 2045 if (right->op_type == OP_TRANS)
1496a290 2046 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
79072805 2047 else
1496a290 2048 o = prepend_elem(rtype, scalar(newleft), right);
79072805 2049 if (type == OP_NOT)
11343788
MB		 2050 return newUNOP(OP_NOT, 0, scalar(o));
2051 return o;
79072805
LW		 2052 }
2053 else
2054 return bind_match(type, left,
131b3ad0 2055 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
79072805
LW		 2056}
2057
2058OP *
864dbfa3 2059Perl_invert(pTHX_ OP *o)
79072805 2060{
11343788 2061 if (!o)
1d866c12 2062 return NULL;
11343788 2063 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
79072805
LW		 2064}
2065
2066OP *
864dbfa3 2067Perl_scope(pTHX_ OP *o)
79072805 2068{
27da23d5 2069 dVAR;
79072805 2070 if (o) {
3280af22 2071 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
463ee0b2
LW		 2072 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2073 o->op_type = OP_LEAVE;
22c35a8c 2074 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
463ee0b2 2075 }
fdb22418
HS		 2076 else if (o->op_type == OP_LINESEQ) {
2077 OP *kid;
2078 o->op_type = OP_SCOPE;
2079 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2080 kid = ((LISTOP*)o)->op_first;
59110972 2081 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
fdb22418 2082 op_null(kid);
59110972
RH		 2083
2084 /* The following deals with things like 'do {1 for 1}' */
2085 kid = kid->op_sibling;
2086 if (kid &&
2087 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2088 op_null(kid);
2089 }
463ee0b2 2090 }
fdb22418 2091 else
5f66b61c 2092 o = newLISTOP(OP_SCOPE, 0, o, NULL);
79072805
LW		 2093 }
2094 return o;
2095}
72dc9ed5 2096
a0d0e21e 2097int
864dbfa3 2098Perl_block_start(pTHX_ int full)
79072805 2099{
97aff369 2100 dVAR;
73d840c0 2101 const int retval = PL_savestack_ix;
dd2155a4 2102 pad_block_start(full);
b3ac6de7 2103 SAVEHINTS();
3280af22 2104 PL_hints &= ~HINT_BLOCK_SCOPE;
68da3b2f 2105 SAVECOMPILEWARNINGS();
72dc9ed5 2106 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
a0d0e21e
LW		 2107 return retval;
2108}
2109
2110OP*
864dbfa3 2111Perl_block_end(pTHX_ I32 floor, OP *seq)
a0d0e21e 2112{
97aff369 2113 dVAR;
6867be6d 2114 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
551405c4 2115 OP* const retval = scalarseq(seq);
e9818f4e 2116 LEAVE_SCOPE(floor);
623e6609 2117 CopHINTS_set(&PL_compiling, PL_hints);
a0d0e21e 2118 if (needblockscope)
3280af22 2119 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
dd2155a4 2120 pad_leavemy();
a0d0e21e
LW		 2121 return retval;
2122}
2123
76e3520e 2124STATIC OP *
cea2e8a9 2125S_newDEFSVOP(pTHX)
54b9620d 2126{
97aff369 2127 dVAR;
9f7d9405 2128 const PADOFFSET offset = pad_findmy("$_");
00b1698f 2129 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
59f00321
RGS		 2130 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2131 }
2132 else {
551405c4 2133 OP * const o = newOP(OP_PADSV, 0);
59f00321
RGS		 2134 o->op_targ = offset;
2135 return o;
2136 }
54b9620d
MB		 2137}
2138
a0d0e21e 2139void
864dbfa3 2140Perl_newPROG(pTHX_ OP *o)
a0d0e21e 2141{
97aff369 2142 dVAR;
3280af22 2143 if (PL_in_eval) {
b295d113
TH		 2144 if (PL_eval_root)
2145 return;
faef0170
HS		 2146 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2147 ((PL_in_eval & EVAL_KEEPERR)
2148 ? OPf_SPECIAL : 0), o);
3280af22 2149 PL_eval_start = linklist(PL_eval_root);
7934575e
GS		 2150 PL_eval_root->op_private |= OPpREFCOUNTED;
2151 OpREFCNT_set(PL_eval_root, 1);
3280af22 2152 PL_eval_root->op_next = 0;
a2efc822 2153 CALL_PEEP(PL_eval_start);
a0d0e21e
LW		 2154 }
2155 else {
6be89cf9
AE		 2156 if (o->op_type == OP_STUB) {
2157 PL_comppad_name = 0;
2158 PL_compcv = 0;
d2c837a0 2159 S_op_destroy(aTHX_ o);
a0d0e21e 2160 return;
6be89cf9 2161 }
3280af22
NIS		 2162 PL_main_root = scope(sawparens(scalarvoid(o)));
2163 PL_curcop = &PL_compiling;
2164 PL_main_start = LINKLIST(PL_main_root);
7934575e
GS		 2165 PL_main_root->op_private |= OPpREFCOUNTED;
2166 OpREFCNT_set(PL_main_root, 1);
3280af22 2167 PL_main_root->op_next = 0;
a2efc822 2168 CALL_PEEP(PL_main_start);
3280af22 2169 PL_compcv = 0;
3841441e 2170
4fdae800 2171 /* Register with debugger */
84902520 2172 if (PERLDB_INTER) {
780a5241
NC		 2173 CV * const cv
2174 = Perl_get_cvn_flags(aTHX_ STR_WITH_LEN("DB::postponed"), 0);
3841441e
CS		 2175 if (cv) {
2176 dSP;
924508f0 2177 PUSHMARK(SP);
cc49e20b 2178 XPUSHs((SV*)CopFILEGV(&PL_compiling));
3841441e 2179 PUTBACK;
864dbfa3 2180 call_sv((SV*)cv, G_DISCARD);
3841441e
CS		 2181 }
2182 }
79072805 2183 }
79072805
LW		 2184}
2185
2186OP *
864dbfa3 2187Perl_localize(pTHX_ OP *o, I32 lex)
79072805 2188{
97aff369 2189 dVAR;
79072805 2190 if (o->op_flags & OPf_PARENS)
d2be0de5
YST		 2191/* [perl #17376]: this appears to be premature, and results in code such as
2192 C< our(%x); > executing in list mode rather than void mode */
2193#if 0
79072805 2194 list(o);
d2be0de5 2195#else
6f207bd3 2196 NOOP;
d2be0de5 2197#endif
8990e307 2198 else {
041457d9
DM		 2199 if ( PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ','
2200 && ckWARN(WARN_PARENTHESIS))
64420d0d
JH		 2201 {
2202 char *s = PL_bufptr;
bac662ee 2203 bool sigil = FALSE;
64420d0d 2204
8473848f 2205 /* some heuristics to detect a potential error */
bac662ee 2206 while (*s && (strchr(", \t\n", *s)))
64420d0d 2207 s++;
8473848f 2208
bac662ee
TS		 2209 while (1) {
2210 if (*s && strchr("@$%*", *s) && *++s
2211 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2212 s++;
2213 sigil = TRUE;
2214 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2215 s++;
2216 while (*s && (strchr(", \t\n", *s)))
2217 s++;
2218 }
2219 else
2220 break;
2221 }
2222 if (sigil && (*s == ';' || *s == '=')) {
2223 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
8473848f 2224 "Parentheses missing around \"%s\" list",
952306ac 2225 lex ? (PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my")
8473848f
RGS		 2226 : "local");
2227 }
8990e307
LW		 2228 }
2229 }
93a17b20 2230 if (lex)
eb64745e 2231 o = my(o);
93a17b20 2232 else
eb64745e
GS		 2233 o = mod(o, OP_NULL); /* a bit kludgey */
2234 PL_in_my = FALSE;
5c284bb0 2235 PL_in_my_stash = NULL;
eb64745e 2236 return o;
79072805
LW		 2237}
2238
2239OP *
864dbfa3 2240Perl_jmaybe(pTHX_ OP *o)
79072805
LW		 2241{
2242 if (o->op_type == OP_LIST) {
fafc274c 2243 OP * const o2
d4c19fe8 2244 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
554b3eca 2245 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
79072805
LW		 2246 }
2247 return o;
2248}
2249
2250OP *
864dbfa3 2251Perl_fold_constants(pTHX_ register OP *o)
79072805 2252{
27da23d5 2253 dVAR;
79072805 2254 register OP *curop;
eb8433b7 2255 OP *newop;
8ea43dc8 2256 VOL I32 type = o->op_type;
e3cbe32f 2257 SV * VOL sv = NULL;
b7f7fd0b
NC		 2258 int ret = 0;
2259 I32 oldscope;
2260 OP *old_next;
5f2d9966
DM		 2261 SV * const oldwarnhook = PL_warnhook;
2262 SV * const olddiehook = PL_diehook;
b7f7fd0b 2263 dJMPENV;
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_UCFIRST:
2288 case OP_LCFIRST:
2289 case OP_UC:
2290 case OP_LC:
69dcf70c
MB		 2291 case OP_SLT:
2292 case OP_SGT:
2293 case OP_SLE:
2294 case OP_SGE:
2295 case OP_SCMP:
2de3dbcc
JH		 2296 /* XXX what about the numeric ops? */
2297 if (PL_hints & HINT_LOCALE)
de939608
CS		 2298 goto nope;
2299 }
2300
3280af22 2301 if (PL_error_count)
a0d0e21e
LW		 2302 goto nope; /* Don't try to run w/ errors */
2303
79072805 2304 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
1496a290
AL		 2305 const OPCODE type = curop->op_type;
2306 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2307 type != OP_LIST &&
2308 type != OP_SCALAR &&
2309 type != OP_NULL &&
2310 type != OP_PUSHMARK)
7a52d87a 2311 {
79072805
LW		 2312 goto nope;
2313 }
2314 }
2315
2316 curop = LINKLIST(o);
b7f7fd0b 2317 old_next = o->op_next;
79072805 2318 o->op_next = 0;
533c011a 2319 PL_op = curop;
b7f7fd0b
NC		 2320
2321 oldscope = PL_scopestack_ix;
edb2152a 2322 create_eval_scope(G_FAKINGEVAL);
b7f7fd0b 2323
5f2d9966
DM		 2324 PL_warnhook = PERL_WARNHOOK_FATAL;
2325 PL_diehook = NULL;
b7f7fd0b
NC		 2326 JMPENV_PUSH(ret);
2327
2328 switch (ret) {
2329 case 0:
2330 CALLRUNOPS(aTHX);
2331 sv = *(PL_stack_sp--);
2332 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2333 pad_swipe(o->op_targ, FALSE);
2334 else if (SvTEMP(sv)) { /* grab mortal temp? */
2335 SvREFCNT_inc_simple_void(sv);
2336 SvTEMP_off(sv);
2337 }
2338 break;
2339 case 3:
2340 /* Something tried to die. Abandon constant folding. */
2341 /* Pretend the error never happened. */
2342 sv_setpvn(ERRSV,"",0);
2343 o->op_next = old_next;
2344 break;
2345 default:
2346 JMPENV_POP;
5f2d9966
DM		 2347 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2348 PL_warnhook = oldwarnhook;
2349 PL_diehook = olddiehook;
2350 /* XXX note that this croak may fail as we've already blown away
2351 * the stack - eg any nested evals */
b7f7fd0b
NC		 2352 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2353 }
b7f7fd0b 2354 JMPENV_POP;
5f2d9966
DM		 2355 PL_warnhook = oldwarnhook;
2356 PL_diehook = olddiehook;
edb2152a
NC		 2357
2358 if (PL_scopestack_ix > oldscope)
2359 delete_eval_scope();
eb8433b7 2360
b7f7fd0b
NC		 2361 if (ret)
2362 goto nope;
2363
eb8433b7 2364#ifndef PERL_MAD
79072805 2365 op_free(o);
eb8433b7 2366#endif
de5e01c2 2367 assert(sv);
79072805 2368 if (type == OP_RV2GV)
eb8433b7
NC		 2369 newop = newGVOP(OP_GV, 0, (GV*)sv);
2370 else
670f1322 2371 newop = newSVOP(OP_CONST, 0, (SV*)sv);
eb8433b7
NC		 2372 op_getmad(o,newop,'f');
2373 return newop;
aeea060c 2374
b7f7fd0b 2375 nope:
79072805
LW		 2376 return o;
2377}
2378
2379OP *
864dbfa3 2380Perl_gen_constant_list(pTHX_ register OP *o)
79072805 2381{
27da23d5 2382 dVAR;
79072805 2383 register OP *curop;
6867be6d 2384 const I32 oldtmps_floor = PL_tmps_floor;
79072805 2385
a0d0e21e 2386 list(o);
3280af22 2387 if (PL_error_count)
a0d0e21e
LW		 2388 return o; /* Don't attempt to run with errors */
2389
533c011a 2390 PL_op = curop = LINKLIST(o);
a0d0e21e 2391 o->op_next = 0;
a2efc822 2392 CALL_PEEP(curop);
cea2e8a9
GS		 2393 pp_pushmark();
2394 CALLRUNOPS(aTHX);
533c011a 2395 PL_op = curop;
78c72037
NC		 2396 assert (!(curop->op_flags & OPf_SPECIAL));
2397 assert(curop->op_type == OP_RANGE);
cea2e8a9 2398 pp_anonlist();
3280af22 2399 PL_tmps_floor = oldtmps_floor;
79072805
LW		 2400
2401 o->op_type = OP_RV2AV;
22c35a8c 2402 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
fb53bbb2
SG		 2403 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2404 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2814eb74 2405 o->op_opt = 0; /* needs to be revisited in peep() */
79072805 2406 curop = ((UNOP*)o)->op_first;
b37c2d43 2407 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
eb8433b7
NC		 2408#ifdef PERL_MAD
2409 op_getmad(curop,o,'O');
2410#else
79072805 2411 op_free(curop);
eb8433b7 2412#endif
79072805
LW		 2413 linklist(o);
2414 return list(o);
2415}
2416
2417OP *
864dbfa3 2418Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
79072805 2419{
27da23d5 2420 dVAR;
11343788 2421 if (!o || o->op_type != OP_LIST)
5f66b61c 2422 o = newLISTOP(OP_LIST, 0, o, NULL);
748a9306 2423 else
5dc0d613 2424 o->op_flags &= ~OPf_WANT;
79072805 2425
22c35a8c 2426 if (!(PL_opargs[type] & OA_MARK))
93c66552 2427 op_null(cLISTOPo->op_first);
8990e307 2428
eb160463 2429 o->op_type = (OPCODE)type;
22c35a8c 2430 o->op_ppaddr = PL_ppaddr[type];
11343788 2431 o->op_flags |= flags;
79072805 2432
11343788 2433 o = CHECKOP(type, o);
fe2774ed 2434 if (o->op_type != (unsigned)type)
11343788 2435 return o;
79072805 2436
11343788 2437 return fold_constants(o);
79072805
LW		 2438}
2439
2440/* List constructors */
2441
2442OP *
864dbfa3 2443Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW		 2444{
2445 if (!first)
2446 return last;
8990e307
LW		 2447
2448 if (!last)
79072805 2449 return first;
8990e307 2450
fe2774ed 2451 if (first->op_type != (unsigned)type
155aba94
GS		 2452 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2453 {
2454 return newLISTOP(type, 0, first, last);
2455 }
79072805 2456
a0d0e21e
LW		 2457 if (first->op_flags & OPf_KIDS)
2458 ((LISTOP*)first)->op_last->op_sibling = last;
2459 else {
2460 first->op_flags |= OPf_KIDS;
2461 ((LISTOP*)first)->op_first = last;
2462 }
2463 ((LISTOP*)first)->op_last = last;
a0d0e21e 2464 return first;
79072805
LW		 2465}
2466
2467OP *
864dbfa3 2468Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
79072805
LW		 2469{
2470 if (!first)
2471 return (OP*)last;
8990e307
LW		 2472
2473 if (!last)
79072805 2474 return (OP*)first;
8990e307 2475
fe2774ed 2476 if (first->op_type != (unsigned)type)
79072805 2477 return prepend_elem(type, (OP*)first, (OP*)last);
8990e307 2478
fe2774ed 2479 if (last->op_type != (unsigned)type)
79072805
LW		 2480 return append_elem(type, (OP*)first, (OP*)last);
2481
2482 first->op_last->op_sibling = last->op_first;
2483 first->op_last = last->op_last;
117dada2 2484 first->op_flags |= (last->op_flags & OPf_KIDS);
1c846c1f 2485
eb8433b7
NC		 2486#ifdef PERL_MAD
2487 if (last->op_first && first->op_madprop) {
2488 MADPROP *mp = last->op_first->op_madprop;
2489 if (mp) {
2490 while (mp->mad_next)
2491 mp = mp->mad_next;
2492 mp->mad_next = first->op_madprop;
2493 }
2494 else {
2495 last->op_first->op_madprop = first->op_madprop;
2496 }
2497 }
2498 first->op_madprop = last->op_madprop;
2499 last->op_madprop = 0;
2500#endif
2501
d2c837a0 2502 S_op_destroy(aTHX_ (OP*)last);
238a4c30 2503
79072805
LW		 2504 return (OP*)first;
2505}
2506
2507OP *
864dbfa3 2508Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW		 2509{
2510 if (!first)
2511 return last;
8990e307
LW		 2512
2513 if (!last)
79072805 2514 return first;
8990e307 2515
fe2774ed 2516 if (last->op_type == (unsigned)type) {
8990e307
LW		 2517 if (type == OP_LIST) { /* already a PUSHMARK there */
2518 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2519 ((LISTOP*)last)->op_first->op_sibling = first;
36a5d4ba
DC		 2520 if (!(first->op_flags & OPf_PARENS))
2521 last->op_flags &= ~OPf_PARENS;
8990e307
LW		 2522 }
2523 else {
2524 if (!(last->op_flags & OPf_KIDS)) {
2525 ((LISTOP*)last)->op_last = first;
2526 last->op_flags |= OPf_KIDS;
2527 }
2528 first->op_sibling = ((LISTOP*)last)->op_first;
2529 ((LISTOP*)last)->op_first = first;
79072805 2530 }
117dada2 2531 last->op_flags |= OPf_KIDS;
79072805
LW		 2532 return last;
2533 }
2534
2535 return newLISTOP(type, 0, first, last);
2536}
2537
2538/* Constructors */
2539
eb8433b7
NC		 2540#ifdef PERL_MAD
2541
2542TOKEN *
2543Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2544{
2545 TOKEN *tk;
99129197 2546 Newxz(tk, 1, TOKEN);
eb8433b7
NC		 2547 tk->tk_type = (OPCODE)optype;
2548 tk->tk_type = 12345;
2549 tk->tk_lval = lval;
2550 tk->tk_mad = madprop;
2551 return tk;
2552}
2553
2554void
2555Perl_token_free(pTHX_ TOKEN* tk)
2556{
2557 if (tk->tk_type != 12345)
2558 return;
2559 mad_free(tk->tk_mad);
2560 Safefree(tk);
2561}
2562
2563void
2564Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2565{
2566 MADPROP* mp;
2567 MADPROP* tm;
2568 if (tk->tk_type != 12345) {
2569 Perl_warner(aTHX_ packWARN(WARN_MISC),
2570 "Invalid TOKEN object ignored");
2571 return;
2572 }
2573 tm = tk->tk_mad;
2574 if (!tm)
2575 return;
2576
2577 /* faked up qw list? */
2578 if (slot == '(' &&
2579 tm->mad_type == MAD_SV &&
2580 SvPVX((SV*)tm->mad_val)[0] == 'q')
2581 slot = 'x';
2582
2583 if (o) {
2584 mp = o->op_madprop;
2585 if (mp) {
2586 for (;;) {
2587 /* pretend constant fold didn't happen? */
2588 if (mp->mad_key == 'f' &&
2589 (o->op_type == OP_CONST ||
2590 o->op_type == OP_GV) )
2591 {
2592 token_getmad(tk,(OP*)mp->mad_val,slot);
2593 return;
2594 }
2595 if (!mp->mad_next)
2596 break;
2597 mp = mp->mad_next;
2598 }
2599 mp->mad_next = tm;
2600 mp = mp->mad_next;
2601 }
2602 else {
2603 o->op_madprop = tm;
2604 mp = o->op_madprop;
2605 }
2606 if (mp->mad_key == 'X')
2607 mp->mad_key = slot; /* just change the first one */
2608
2609 tk->tk_mad = 0;
2610 }
2611 else
2612 mad_free(tm);
2613 Safefree(tk);
2614}
2615
2616void
2617Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2618{
2619 MADPROP* mp;
2620 if (!from)
2621 return;
2622 if (o) {
2623 mp = o->op_madprop;
2624 if (mp) {
2625 for (;;) {
2626 /* pretend constant fold didn't happen? */
2627 if (mp->mad_key == 'f' &&
2628 (o->op_type == OP_CONST ||
2629 o->op_type == OP_GV) )
2630 {
2631 op_getmad(from,(OP*)mp->mad_val,slot);
2632 return;
2633 }
2634 if (!mp->mad_next)
2635 break;
2636 mp = mp->mad_next;
2637 }
2638 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2639 }
2640 else {
2641 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2642 }
2643 }
2644}
2645
2646void
2647Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2648{
2649 MADPROP* mp;
2650 if (!from)
2651 return;
2652 if (o) {
2653 mp = o->op_madprop;
2654 if (mp) {
2655 for (;;) {
2656 /* pretend constant fold didn't happen? */
2657 if (mp->mad_key == 'f' &&
2658 (o->op_type == OP_CONST ||
2659 o->op_type == OP_GV) )
2660 {
2661 op_getmad(from,(OP*)mp->mad_val,slot);
2662 return;
2663 }
2664 if (!mp->mad_next)
2665 break;
2666 mp = mp->mad_next;
2667 }
2668 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2669 }
2670 else {
2671 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2672 }
2673 }
2674 else {
99129197
NC		 2675 PerlIO_printf(PerlIO_stderr(),
2676 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
eb8433b7
NC		 2677 op_free(from);
2678 }
2679}
2680
2681void
2682Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2683{
2684 MADPROP* tm;
2685 if (!mp || !o)
2686 return;
2687 if (slot)
2688 mp->mad_key = slot;
2689 tm = o->op_madprop;
2690 o->op_madprop = mp;
2691 for (;;) {
2692 if (!mp->mad_next)
2693 break;
2694 mp = mp->mad_next;
2695 }
2696 mp->mad_next = tm;
2697}
2698
2699void
2700Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2701{
2702 if (!o)
2703 return;
2704 addmad(tm, &(o->op_madprop), slot);
2705}
2706
2707void
2708Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2709{
2710 MADPROP* mp;
2711 if (!tm || !root)
2712 return;
2713 if (slot)
2714 tm->mad_key = slot;
2715 mp = *root;
2716 if (!mp) {
2717 *root = tm;
2718 return;
2719 }
2720 for (;;) {
2721 if (!mp->mad_next)
2722 break;
2723 mp = mp->mad_next;
2724 }
2725 mp->mad_next = tm;
2726}
2727
2728MADPROP *
2729Perl_newMADsv(pTHX_ char key, SV* sv)
2730{
2731 return newMADPROP(key, MAD_SV, sv, 0);
2732}
2733
2734MADPROP *
2735Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
2736{
2737 MADPROP *mp;
99129197 2738 Newxz(mp, 1, MADPROP);
eb8433b7
NC		 2739 mp->mad_next = 0;
2740 mp->mad_key = key;
2741 mp->mad_vlen = vlen;
2742 mp->mad_type = type;
2743 mp->mad_val = val;
2744/* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
2745 return mp;
2746}
2747
2748void
2749Perl_mad_free(pTHX_ MADPROP* mp)
2750{
2751/* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2752 if (!mp)
2753 return;
2754 if (mp->mad_next)
2755 mad_free(mp->mad_next);
2756/* if (PL_lex_state != LEX_NOTPARSING && mp->mad_vlen)
2757 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2758 switch (mp->mad_type) {
2759 case MAD_NULL:
2760 break;
2761 case MAD_PV:
2762 Safefree((char*)mp->mad_val);
2763 break;
2764 case MAD_OP:
2765 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
2766 op_free((OP*)mp->mad_val);
2767 break;
2768 case MAD_SV:
2769 sv_free((SV*)mp->mad_val);
2770 break;
2771 default:
2772 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
2773 break;
2774 }
2775 Safefree(mp);
2776}
2777
2778#endif
2779
79072805 2780OP *
864dbfa3 2781Perl_newNULLLIST(pTHX)
79072805 2782{
8990e307
LW		 2783 return newOP(OP_STUB, 0);
2784}
2785
2786OP *
864dbfa3 2787Perl_force_list(pTHX_ OP *o)
8990e307 2788{
11343788 2789 if (!o || o->op_type != OP_LIST)
5f66b61c 2790 o = newLISTOP(OP_LIST, 0, o, NULL);
93c66552 2791 op_null(o);
11343788 2792 return o;
79072805
LW		 2793}
2794
2795OP *
864dbfa3 2796Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
79072805 2797{
27da23d5 2798 dVAR;
79072805
LW		 2799 LISTOP *listop;
2800
b7dc083c 2801 NewOp(1101, listop, 1, LISTOP);
79072805 2802
eb160463 2803 listop->op_type = (OPCODE)type;
22c35a8c 2804 listop->op_ppaddr = PL_ppaddr[type];
117dada2
SM		 2805 if (first || last)
2806 flags |= OPf_KIDS;
eb160463 2807 listop->op_flags = (U8)flags;
79072805
LW		 2808
2809 if (!last && first)
2810 last = first;
2811 else if (!first && last)
2812 first = last;
8990e307
LW		 2813 else if (first)
2814 first->op_sibling = last;
79072805
LW		 2815 listop->op_first = first;
2816 listop->op_last = last;
8990e307 2817 if (type == OP_LIST) {
551405c4 2818 OP* const pushop = newOP(OP_PUSHMARK, 0);
8990e307
LW		 2819 pushop->op_sibling = first;
2820 listop->op_first = pushop;
2821 listop->op_flags |= OPf_KIDS;
2822 if (!last)
2823 listop->op_last = pushop;
2824 }
79072805 2825
463d09e6 2826 return CHECKOP(type, listop);
79072805
LW		 2827}
2828
2829OP *
864dbfa3 2830Perl_newOP(pTHX_ I32 type, I32 flags)
79072805 2831{
27da23d5 2832 dVAR;
11343788 2833 OP *o;
b7dc083c 2834 NewOp(1101, o, 1, OP);
eb160463 2835 o->op_type = (OPCODE)type;
22c35a8c 2836 o->op_ppaddr = PL_ppaddr[type];
eb160463 2837 o->op_flags = (U8)flags;
670f3923
DM		 2838 o->op_latefree = 0;
2839 o->op_latefreed = 0;
7e5d8ed2 2840 o->op_attached = 0;
79072805 2841
11343788 2842 o->op_next = o;
eb160463 2843 o->op_private = (U8)(0 | (flags >> 8));
22c35a8c 2844 if (PL_opargs[type] & OA_RETSCALAR)
11343788 2845 scalar(o);
22c35a8c 2846 if (PL_opargs[type] & OA_TARGET)
11343788
MB		 2847 o->op_targ = pad_alloc(type, SVs_PADTMP);
2848 return CHECKOP(type, o);
79072805
LW		 2849}
2850
2851OP *
864dbfa3 2852Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
79072805 2853{
27da23d5 2854 dVAR;
79072805
LW		 2855 UNOP *unop;
2856
93a17b20 2857 if (!first)
aeea060c 2858 first = newOP(OP_STUB, 0);
22c35a8c 2859 if (PL_opargs[type] & OA_MARK)
8990e307 2860 first = force_list(first);
93a17b20 2861
b7dc083c 2862 NewOp(1101, unop, 1, UNOP);
eb160463 2863 unop->op_type = (OPCODE)type;
22c35a8c 2864 unop->op_ppaddr = PL_ppaddr[type];
79072805 2865 unop->op_first = first;
585ec06d 2866 unop->op_flags = (U8)(flags | OPf_KIDS);
eb160463 2867 unop->op_private = (U8)(1 | (flags >> 8));
e50aee73 2868 unop = (UNOP*) CHECKOP(type, unop);
79072805
LW		 2869 if (unop->op_next)
2870 return (OP*)unop;
2871
a0d0e21e 2872 return fold_constants((OP *) unop);
79072805
LW		 2873}
2874
2875OP *
864dbfa3 2876Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
79072805 2877{
27da23d5 2878 dVAR;
79072805 2879 BINOP *binop;
b7dc083c 2880 NewOp(1101, binop, 1, BINOP);
79072805
LW		 2881
2882 if (!first)
2883 first = newOP(OP_NULL, 0);
2884
eb160463 2885 binop->op_type = (OPCODE)type;
22c35a8c 2886 binop->op_ppaddr = PL_ppaddr[type];
79072805 2887 binop->op_first = first;
585ec06d 2888 binop->op_flags = (U8)(flags | OPf_KIDS);
79072805
LW		 2889 if (!last) {
2890 last = first;
eb160463 2891 binop->op_private = (U8)(1 | (flags >> 8));
79072805
LW		 2892 }
2893 else {
eb160463 2894 binop->op_private = (U8)(2 | (flags >> 8));
79072805
LW		 2895 first->op_sibling = last;
2896 }
2897
e50aee73 2898 binop = (BINOP*)CHECKOP(type, binop);
eb160463 2899 if (binop->op_next || binop->op_type != (OPCODE)type)
79072805
LW		 2900 return (OP*)binop;
2901
7284ab6f 2902 binop->op_last = binop->op_first->op_sibling;
79072805 2903
a0d0e21e 2904 return fold_constants((OP *)binop);
79072805
LW		 2905}
2906
5f66b61c
AL		 2907static int uvcompare(const void *a, const void *b)
2908 __attribute__nonnull__(1)
2909 __attribute__nonnull__(2)
2910 __attribute__pure__;
abb2c242 2911static int uvcompare(const void *a, const void *b)
2b9d42f0 2912{
e1ec3a88 2913 if (*((const UV *)a) < (*(const UV *)b))
2b9d42f0 2914 return -1;
e1ec3a88 2915 if (*((const UV *)a) > (*(const UV *)b))
2b9d42f0 2916 return 1;
e1ec3a88 2917 if (*((const UV *)a+1) < (*(const UV *)b+1))
2b9d42f0 2918 return -1;
e1ec3a88 2919 if (*((const UV *)a+1) > (*(const UV *)b+1))
2b9d42f0 2920 return 1;
a0ed51b3
LW		 2921 return 0;
2922}
2923
79072805 2924OP *
864dbfa3 2925Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
79072805 2926{
97aff369 2927 dVAR;
2d03de9c 2928 SV * const tstr = ((SVOP*)expr)->op_sv;
fbbb0949
DM		 2929 SV * const rstr =
2930#ifdef PERL_MAD
2931 (repl->op_type == OP_NULL)
2932 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
2933#endif
2934 ((SVOP*)repl)->op_sv;
463ee0b2
LW		 2935 STRLEN tlen;
2936 STRLEN rlen;
5c144d81
NC		 2937 const U8 *t = (U8*)SvPV_const(tstr, tlen);
2938 const U8 *r = (U8*)SvPV_const(rstr, rlen);
79072805
LW		 2939 register I32 i;
2940 register I32 j;
9b877dbb 2941 I32 grows = 0;
79072805
LW		 2942 register short *tbl;
2943
551405c4
AL		 2944 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
2945 const I32 squash = o->op_private & OPpTRANS_SQUASH;
2946 I32 del = o->op_private & OPpTRANS_DELETE;
043e41b8 2947 SV* swash;
800b4dc4 2948 PL_hints |= HINT_BLOCK_SCOPE;
1c846c1f 2949
036b4402
GS		 2950 if (SvUTF8(tstr))
2951 o->op_private |= OPpTRANS_FROM_UTF;
1c846c1f
NIS		 2952
2953 if (SvUTF8(rstr))
036b4402 2954 o->op_private |= OPpTRANS_TO_UTF;
79072805 2955
a0ed51b3 2956 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
396482e1 2957 SV* const listsv = newSVpvs("# comment\n");
c445ea15 2958 SV* transv = NULL;
5c144d81
NC		 2959 const U8* tend = t + tlen;
2960 const U8* rend = r + rlen;
ba210ebe 2961 STRLEN ulen;
84c133a0
RB		 2962 UV tfirst = 1;
2963 UV tlast = 0;
2964 IV tdiff;
2965 UV rfirst = 1;
2966 UV rlast = 0;
2967 IV rdiff;
2968 IV diff;
a0ed51b3
LW		 2969 I32 none = 0;
2970 U32 max = 0;
2971 I32 bits;
a0ed51b3 2972 I32 havefinal = 0;
9c5ffd7c 2973 U32 final = 0;
551405c4
AL		 2974 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2975 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
bf4a1e57
JH		 2976 U8* tsave = NULL;
2977 U8* rsave = NULL;
9f7f3913 2978 const U32 flags = UTF8_ALLOW_DEFAULT;
bf4a1e57
JH		 2979
2980 if (!from_utf) {
2981 STRLEN len = tlen;
5c144d81 2982 t = tsave = bytes_to_utf8(t, &len);
bf4a1e57
JH		 2983 tend = t + len;
2984 }
2985 if (!to_utf && rlen) {
2986 STRLEN len = rlen;
5c144d81 2987 r = rsave = bytes_to_utf8(r, &len);
bf4a1e57
JH		 2988 rend = r + len;
2989 }
a0ed51b3 2990
2b9d42f0
NIS		 2991/* There are several snags with this code on EBCDIC:
2992 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2993 2. scan_const() in toke.c has encoded chars in native encoding which makes
2994 ranges at least in EBCDIC 0..255 range the bottom odd.
2995*/
2996
a0ed51b3 2997 if (complement) {
89ebb4a3 2998 U8 tmpbuf[UTF8_MAXBYTES+1];
2b9d42f0 2999 UV *cp;
a0ed51b3 3000 UV nextmin = 0;
a02a5408 3001 Newx(cp, 2*tlen, UV);
a0ed51b3 3002 i = 0;
396482e1 3003 transv = newSVpvs("");
a0ed51b3 3004 while (t < tend) {
9f7f3913 3005 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
2b9d42f0
NIS		 3006 t += ulen;
3007 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
a0ed51b3 3008 t++;
9f7f3913 3009 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
2b9d42f0 3010 t += ulen;
a0ed51b3 3011 }
2b9d42f0
NIS		 3012 else {
3013 cp[2*i+1] = cp[2*i];
3014 }
3015 i++;
a0ed51b3 3016 }
2b9d42f0 3017 qsort(cp, i, 2*sizeof(UV), uvcompare);
a0ed51b3 3018 for (j = 0; j < i; j++) {
2b9d42f0 3019 UV val = cp[2*j];
a0ed51b3
LW		 3020 diff = val - nextmin;
3021 if (diff > 0) {
9041c2e3 3022 t = uvuni_to_utf8(tmpbuf,nextmin);
dfe13c55 3023 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
a0ed51b3 3024 if (diff > 1) {
2b9d42f0 3025 U8 range_mark = UTF_TO_NATIVE(0xff);
9041c2e3 3026 t = uvuni_to_utf8(tmpbuf, val - 1);
2b9d42f0 3027 sv_catpvn(transv, (char *)&range_mark, 1);
dfe13c55 3028 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
a0ed51b3
LW		 3029 }
3030 }
2b9d42f0 3031 val = cp[2*j+1];
a0ed51b3
LW		 3032 if (val >= nextmin)
3033 nextmin = val + 1;
3034 }
9041c2e3 3035 t = uvuni_to_utf8(tmpbuf,nextmin);
dfe13c55 3036 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2b9d42f0
NIS		 3037 {
3038 U8 range_mark = UTF_TO_NATIVE(0xff);
3039 sv_catpvn(transv, (char *)&range_mark, 1);
3040 }
b851fbc1
JH		 3041 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
3042 UNICODE_ALLOW_SUPER);
dfe13c55 3043 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
93524f2b 3044 t = (const U8*)SvPVX_const(transv);
a0ed51b3
LW		 3045 tlen = SvCUR(transv);
3046 tend = t + tlen;
455d824a 3047 Safefree(cp);
a0ed51b3
LW		 3048 }
3049 else if (!rlen && !del) {
3050 r = t; rlen = tlen; rend = tend;
4757a243
LW		 3051 }
3052 if (!squash) {
05d340b8 3053 if ((!rlen && !del) || t == r ||
12ae5dfc 3054 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
01ec43d0 3055 {
4757a243 3056 o->op_private |= OPpTRANS_IDENTICAL;
01ec43d0 3057 }
a0ed51b3
LW		 3058 }
3059
3060 while (t < tend || tfirst <= tlast) {
3061 /* see if we need more "t" chars */
3062 if (tfirst > tlast) {
9f7f3913 3063 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
a0ed51b3 3064 t += ulen;
2b9d42f0 3065 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
ba210ebe 3066 t++;
9f7f3913 3067 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
a0ed51b3
LW		 3068 t += ulen;
3069 }
3070 else
3071 tlast = tfirst;
3072 }
3073
3074 /* now see if we need more "r" chars */
3075 if (rfirst > rlast) {
3076 if (r < rend) {
9f7f3913 3077 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
a0ed51b3 3078 r += ulen;
2b9d42f0 3079 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
ba210ebe 3080 r++;
9f7f3913 3081 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
a0ed51b3
LW		 3082 r += ulen;
3083 }
3084 else
3085 rlast = rfirst;
3086 }
3087 else {
3088 if (!havefinal++)
3089 final = rlast;
3090 rfirst = rlast = 0xffffffff;
3091 }
3092 }
3093
3094 /* now see which range will peter our first, if either. */
3095 tdiff = tlast - tfirst;
3096 rdiff = rlast - rfirst;
3097
3098 if (tdiff <= rdiff)
3099 diff = tdiff;
3100 else
3101 diff = rdiff;
3102
3103 if (rfirst == 0xffffffff) {
3104 diff = tdiff; /* oops, pretend rdiff is infinite */
3105 if (diff > 0)
894356b3
GS		 3106 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3107 (long)tfirst, (long)tlast);
a0ed51b3 3108 else
894356b3 3109 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
a0ed51b3
LW		 3110 }
3111 else {
3112 if (diff > 0)
894356b3
GS		 3113 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3114 (long)tfirst, (long)(tfirst + diff),
3115 (long)rfirst);
a0ed51b3 3116 else
894356b3
GS		 3117 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3118 (long)tfirst, (long)rfirst);
a0ed51b3
LW		 3119
3120 if (rfirst + diff > max)
3121 max = rfirst + diff;
9b877dbb 3122 if (!grows)
45005bfb
JH		 3123 grows = (tfirst < rfirst &&
3124 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3125 rfirst += diff + 1;
a0ed51b3
LW		 3126 }
3127 tfirst += diff + 1;
3128 }
3129
3130 none = ++max;
3131 if (del)
3132 del = ++max;
3133
3134 if (max > 0xffff)
3135 bits = 32;
3136 else if (max > 0xff)
3137 bits = 16;
3138 else
3139 bits = 8;
3140
ea71c68d 3141 PerlMemShared_free(cPVOPo->op_pv);
b3123a61 3142 cPVOPo->op_pv = NULL;
043e41b8
DM		 3143
3144 swash = (SV*)swash_init("utf8", "", listsv, bits, none);
3145#ifdef USE_ITHREADS
3146 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3147 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3148 PAD_SETSV(cPADOPo->op_padix, swash);
3149 SvPADTMP_on(swash);
3150#else
3151 cSVOPo->op_sv = swash;
3152#endif
a0ed51b3 3153 SvREFCNT_dec(listsv);
b37c2d43 3154 SvREFCNT_dec(transv);
a0ed51b3 3155
45005bfb 3156 if (!del && havefinal && rlen)
043e41b8 3157 (void)hv_store((HV*)SvRV(swash), "FINAL", 5,
b448e4fe 3158 newSVuv((UV)final), 0);
a0ed51b3 3159
9b877dbb 3160 if (grows)
a0ed51b3
LW		 3161 o->op_private |= OPpTRANS_GROWS;
3162
b37c2d43
AL		 3163 Safefree(tsave);
3164 Safefree(rsave);
9b877dbb 3165
eb8433b7
NC		 3166#ifdef PERL_MAD
3167 op_getmad(expr,o,'e');
3168 op_getmad(repl,o,'r');
3169#else
a0ed51b3
LW		 3170 op_free(expr);
3171 op_free(repl);
eb8433b7 3172#endif
a0ed51b3
LW		 3173 return o;
3174 }
3175
3176 tbl = (short*)cPVOPo->op_pv;
79072805
LW		 3177 if (complement) {
3178 Zero(tbl, 256, short);
eb160463 3179 for (i = 0; i < (I32)tlen; i++)
ec49126f 3180 tbl[t[i]] = -1;
79072805
LW		 3181 for (i = 0, j = 0; i < 256; i++) {
3182 if (!tbl[i]) {
eb160463 3183 if (j >= (I32)rlen) {
a0ed51b3 3184 if (del)
79072805
LW		 3185 tbl[i] = -2;
3186 else if (rlen)
ec49126f 3187 tbl[i] = r[j-1];
79072805 3188 else
eb160463 3189 tbl[i] = (short)i;
79072805 3190 }
9b877dbb
IH		 3191 else {
3192 if (i < 128 && r[j] >= 128)
3193 grows = 1;
ec49126f 3194 tbl[i] = r[j++];
9b877dbb 3195 }
79072805
LW		 3196 }
3197 }
05d340b8
JH		 3198 if (!del) {
3199 if (!rlen) {
3200 j = rlen;
3201 if (!squash)
3202 o->op_private |= OPpTRANS_IDENTICAL;
3203 }
eb160463 3204 else if (j >= (I32)rlen)
05d340b8 3205 j = rlen - 1;
10db182f 3206 else {
aa1f7c5b
JH		 3207 tbl =
3208 (short *)
3209 PerlMemShared_realloc(tbl,
3210 (0x101+rlen-j) * sizeof(short));
10db182f
YO		 3211 cPVOPo->op_pv = (char*)tbl;
3212 }
585ec06d 3213 tbl[0x100] = (short)(rlen - j);
eb160463 3214 for (i=0; i < (I32)rlen - j; i++)
8973db79
JH		 3215 tbl[0x101+i] = r[j+i];
3216 }
79072805
LW		 3217 }
3218 else {
a0ed51b3 3219 if (!rlen && !del) {
79072805 3220 r = t; rlen = tlen;
5d06d08e 3221 if (!squash)
4757a243 3222 o->op_private |= OPpTRANS_IDENTICAL;
79072805 3223 }
94bfe852
RGS		 3224 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3225 o->op_private |= OPpTRANS_IDENTICAL;
3226 }
79072805
LW		 3227 for (i = 0; i < 256; i++)
3228 tbl[i] = -1;
eb160463
GS		 3229 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3230 if (j >= (I32)rlen) {
a0ed51b3 3231 if (del) {
ec49126f 3232 if (tbl[t[i]] == -1)
3233 tbl[t[i]] = -2;
79072805
LW		 3234 continue;
3235 }
3236 --j;
3237 }
9b877dbb
IH		 3238 if (tbl[t[i]] == -1) {
3239 if (t[i] < 128 && r[j] >= 128)
3240 grows = 1;
ec49126f 3241 tbl[t[i]] = r[j];
9b877dbb 3242 }
79072805
LW		 3243 }
3244 }
9b877dbb
IH		 3245 if (grows)
3246 o->op_private |= OPpTRANS_GROWS;
eb8433b7
NC		 3247#ifdef PERL_MAD
3248 op_getmad(expr,o,'e');
3249 op_getmad(repl,o,'r');
3250#else
79072805
LW		 3251 op_free(expr);
3252 op_free(repl);
eb8433b7 3253#endif
79072805 3254
11343788 3255 return o;
79072805
LW		 3256}
3257
3258OP *
864dbfa3 3259Perl_newPMOP(pTHX_ I32 type, I32 flags)
79072805 3260{
27da23d5 3261 dVAR;
79072805
LW		 3262 PMOP *pmop;
3263
b7dc083c 3264 NewOp(1101, pmop, 1, PMOP);
eb160463 3265 pmop->op_type = (OPCODE)type;
22c35a8c 3266 pmop->op_ppaddr = PL_ppaddr[type];
eb160463
GS		 3267 pmop->op_flags = (U8)flags;
3268 pmop->op_private = (U8)(0 | (flags >> 8));
79072805 3269
3280af22 3270 if (PL_hints & HINT_RE_TAINT)
b3eb6a9b 3271 pmop->op_pmpermflags |= PMf_RETAINT;
3280af22 3272 if (PL_hints & HINT_LOCALE)
b3eb6a9b
GS		 3273 pmop->op_pmpermflags |= PMf_LOCALE;
3274 pmop->op_pmflags = pmop->op_pmpermflags;
36477c24 3275
debc9467 3276#ifdef USE_ITHREADS
551405c4
AL		 3277 if (av_len((AV*) PL_regex_pad[0]) > -1) {
3278 SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
3279 pmop->op_pmoffset = SvIV(repointer);
3280 SvREPADTMP_off(repointer);
3281 sv_setiv(repointer,0);
3282 } else {
3283 SV * const repointer = newSViv(0);
b37c2d43 3284 av_push(PL_regex_padav, SvREFCNT_inc_simple_NN(repointer));
551405c4
AL		 3285 pmop->op_pmoffset = av_len(PL_regex_padav);
3286 PL_regex_pad = AvARRAY(PL_regex_padav);
13137afc 3287 }
debc9467 3288#endif
1eb1540c 3289
1fcf4c12 3290 /* link into pm list */
3280af22 3291 if (type != OP_TRANS && PL_curstash) {
8d2f4536
NC		 3292 MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab);
3293
3294 if (!mg) {
3295 mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0);
3296 }
3297 pmop->op_pmnext = (PMOP*)mg->mg_obj;
3298 mg->mg_obj = (SV*)pmop;
cb55de95 3299 PmopSTASH_set(pmop,PL_curstash);
79072805
LW		 3300 }
3301
463d09e6 3302 return CHECKOP(type, pmop);
79072805
LW		 3303}
3304
131b3ad0
DM		 3305/* Given some sort of match op o, and an expression expr containing a
3306 * pattern, either compile expr into a regex and attach it to o (if it's
3307 * constant), or convert expr into a runtime regcomp op sequence (if it's
3308 * not)
3309 *
3310 * isreg indicates that the pattern is part of a regex construct, eg
3311 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3312 * split "pattern", which aren't. In the former case, expr will be a list
3313 * if the pattern contains more than one term (eg /a$b/) or if it contains
3314 * a replacement, ie s/// or tr///.
3315 */
3316
79072805 3317OP *
131b3ad0 3318Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
79072805 3319{
27da23d5 3320 dVAR;
79072805
LW		 3321 PMOP *pm;
3322 LOGOP *rcop;
ce862d02 3323 I32 repl_has_vars = 0;
5f66b61c 3324 OP* repl = NULL;
131b3ad0
DM		 3325 bool reglist;
3326
3327 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3328 /* last element in list is the replacement; pop it */
3329 OP* kid;
3330 repl = cLISTOPx(expr)->op_last;
3331 kid = cLISTOPx(expr)->op_first;
3332 while (kid->op_sibling != repl)
3333 kid = kid->op_sibling;
5f66b61c 3334 kid->op_sibling = NULL;
131b3ad0
DM		 3335 cLISTOPx(expr)->op_last = kid;
3336 }
79072805 3337
131b3ad0
DM		 3338 if (isreg && expr->op_type == OP_LIST &&
3339 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3340 {
3341 /* convert single element list to element */
0bd48802 3342 OP* const oe = expr;
131b3ad0 3343 expr = cLISTOPx(oe)->op_first->op_sibling;
5f66b61c
AL		 3344 cLISTOPx(oe)->op_first->op_sibling = NULL;
3345 cLISTOPx(oe)->op_last = NULL;
131b3ad0
DM		 3346 op_free(oe);
3347 }
3348
3349 if (o->op_type == OP_TRANS) {
11343788 3350 return pmtrans(o, expr, repl);
131b3ad0
DM		 3351 }
3352
3353 reglist = isreg && expr->op_type == OP_LIST;
3354 if (reglist)
3355 op_null(expr);
79072805 3356
3280af22 3357 PL_hints |= HINT_BLOCK_SCOPE;
11343788 3358 pm = (PMOP*)o;
79072805
LW		 3359
3360 if (expr->op_type == OP_CONST) {
463ee0b2 3361 STRLEN plen;
6136c704 3362 SV * const pat = ((SVOP*)expr)->op_sv;
5c144d81 3363 const char *p = SvPV_const(pat, plen);
ede8ac17 3364 if ((o->op_flags & OPf_SPECIAL) && (plen == 1 && *p == ' ')) {
5c144d81
NC		 3365 U32 was_readonly = SvREADONLY(pat);
3366
3367 if (was_readonly) {
3368 if (SvFAKE(pat)) {
3369 sv_force_normal_flags(pat, 0);
3370 assert(!SvREADONLY(pat));
3371 was_readonly = 0;
3372 } else {
3373 SvREADONLY_off(pat);
3374 }
3375 }
3376
93a17b20 3377 sv_setpvn(pat, "\\s+", 3);
5c144d81
NC		 3378
3379 SvFLAGS(pat) |= was_readonly;
3380
3381 p = SvPV_const(pat, plen);
79072805
LW		 3382 pm->op_pmflags |= PMf_SKIPWHITE;
3383 }
5b71a6a7 3384 if (DO_UTF8(pat))
a5961de5 3385 pm->op_pmdynflags |= PMdf_UTF8;
5c144d81 3386 /* FIXME - can we make this function take const char * args? */
f9f4320a 3387 PM_SETRE(pm, CALLREGCOMP((char*)p, (char*)p + plen, pm));
e357fc67 3388 if (PM_GETRE(pm)->extflags & RXf_WHITE)
85e6fe83 3389 pm->op_pmflags |= PMf_WHITE;
e357fc67
YO		 3390 else
3391 pm->op_pmflags &= ~PMf_WHITE;
eb8433b7
NC		 3392#ifdef PERL_MAD
3393 op_getmad(expr,(OP*)pm,'e');
3394#else
79072805 3395 op_free(expr);
eb8433b7 3396#endif
79072805
LW		 3397 }
3398 else {
3280af22 3399 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
1c846c1f 3400 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2cd61cdb
IZ		 3401 ? OP_REGCRESET
3402 : OP_REGCMAYBE),0,expr);
463ee0b2 3403
b7dc083c 3404 NewOp(1101, rcop, 1, LOGOP);
79072805 3405 rcop->op_type = OP_REGCOMP;
22c35a8c 3406 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
79072805 3407 rcop->op_first = scalar(expr);
131b3ad0
DM		 3408 rcop->op_flags |= OPf_KIDS
3409 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3410 | (reglist ? OPf_STACKED : 0);
79072805 3411 rcop->op_private = 1;
11343788 3412 rcop->op_other = o;
131b3ad0
DM		 3413 if (reglist)
3414 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3415
b5c19bd7
DM		 3416 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3417 PL_cv_has_eval = 1;
79072805
LW		 3418
3419 /* establish postfix order */
3280af22 3420 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
463ee0b2
LW		 3421 LINKLIST(expr);
3422 rcop->op_next = expr;
3423 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3424 }
3425 else {
3426 rcop->op_next = LINKLIST(expr);
3427 expr->op_next = (OP*)rcop;
3428 }
79072805 3429
11343788 3430 prepend_elem(o->op_type, scalar((OP*)rcop), o);
79072805
LW		 3431 }
3432
3433 if (repl) {
748a9306 3434 OP *curop;
0244c3a4 3435 if (pm->op_pmflags & PMf_EVAL) {
6136c704 3436 curop = NULL;
8bafa735 3437 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
eb160463 3438 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
0244c3a4 3439 }
748a9306
LW		 3440 else if (repl->op_type == OP_CONST)
3441 curop = repl;
79072805 3442 else {
c445ea15 3443 OP *lastop = NULL;
79072805 3444 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
e80b829c 3445 if (curop->op_type == OP_SCOPE
10250113 3446 || curop->op_type == OP_LEAVE
e80b829c 3447 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
79072805 3448 if (curop->op_type == OP_GV) {
6136c704 3449 GV * const gv = cGVOPx_gv(curop);
ce862d02 3450 repl_has_vars = 1;
f702bf4a 3451 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
79072805
LW		 3452 break;
3453 }
3454 else if (curop->op_type == OP_RV2CV)
3455 break;
3456 else if (curop->op_type == OP_RV2SV ||
3457 curop->op_type == OP_RV2AV ||
3458 curop->op_type == OP_RV2HV ||
3459 curop->op_type == OP_RV2GV) {
3460 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3461 break;
3462 }
748a9306
LW		 3463 else if (curop->op_type == OP_PADSV ||
3464 curop->op_type == OP_PADAV ||
3465 curop->op_type == OP_PADHV ||
e80b829c
RGS		 3466 curop->op_type == OP_PADANY)
3467 {
ce862d02 3468 repl_has_vars = 1;
748a9306 3469 }
1167e5da 3470 else if (curop->op_type == OP_PUSHRE)
6f207bd3 3471 NOOP; /* Okay here, dangerous in newASSIGNOP */
79072805
LW		 3472 else
3473 break;
3474 }
3475 lastop = curop;
3476 }
748a9306 3477 }
ce862d02 3478 if (curop == repl
e80b829c
RGS		 3479 && !(repl_has_vars
3480 && (!PM_GETRE(pm)
3481 || PM_GETRE(pm)->extflags & RXf_EVAL_SEEN)))
3be69782 3482 {
748a9306 3483 pm->op_pmflags |= PMf_CONST; /* const for long enough */
4633a7c4 3484 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
11343788 3485 prepend_elem(o->op_type, scalar(repl), o);
748a9306
LW		 3486 }
3487 else {
aaa362c4 3488 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
ce862d02
IZ		 3489 pm->op_pmflags |= PMf_MAYBE_CONST;
3490 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3491 }
b7dc083c 3492 NewOp(1101, rcop, 1, LOGOP);
748a9306 3493 rcop->op_type = OP_SUBSTCONT;
22c35a8c 3494 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
748a9306
LW		 3495 rcop->op_first = scalar(repl);
3496 rcop->op_flags |= OPf_KIDS;
3497 rcop->op_private = 1;
11343788 3498 rcop->op_other = o;
748a9306
LW		 3499
3500 /* establish postfix order */
3501 rcop->op_next = LINKLIST(repl);
3502 repl->op_next = (OP*)rcop;
3503
3504 pm->op_pmreplroot = scalar((OP*)rcop);
3505 pm->op_pmreplstart = LINKLIST(rcop);
3506 rcop->op_next = 0;
79072805
LW		 3507 }
3508 }
3509
3510 return (OP*)pm;
3511}
3512
3513OP *
864dbfa3 3514Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
79072805 3515{
27da23d5 3516 dVAR;
79072805 3517 SVOP *svop;
b7dc083c 3518 NewOp(1101, svop, 1, SVOP);
eb160463 3519 svop->op_type = (OPCODE)type;
22c35a8c 3520 svop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 3521 svop->op_sv = sv;
3522 svop->op_next = (OP*)svop;
eb160463 3523 svop->op_flags = (U8)flags;
22c35a8c 3524 if (PL_opargs[type] & OA_RETSCALAR)
463ee0b2 3525 scalar((OP*)svop);
22c35a8c 3526 if (PL_opargs[type] & OA_TARGET)
ed6116ce 3527 svop->op_targ = pad_alloc(type, SVs_PADTMP);
e50aee73 3528 return CHECKOP(type, svop);
79072805
LW		 3529}
3530
392d04bb 3531#ifdef USE_ITHREADS
79072805 3532OP *
350de78d
GS		 3533Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3534{
27da23d5 3535 dVAR;
350de78d
GS		 3536 PADOP *padop;
3537 NewOp(1101, padop, 1, PADOP);
eb160463 3538 padop->op_type = (OPCODE)type;
350de78d
GS		 3539 padop->op_ppaddr = PL_ppaddr[type];
3540 padop->op_padix = pad_alloc(type, SVs_PADTMP);
dd2155a4
DM		 3541 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3542 PAD_SETSV(padop->op_padix, sv);
58182927
NC		 3543 assert(sv);
3544 SvPADTMP_on(sv);
350de78d 3545 padop->op_next = (OP*)padop;
eb160463 3546 padop->op_flags = (U8)flags;
350de78d
GS		 3547 if (PL_opargs[type] & OA_RETSCALAR)
3548 scalar((OP*)padop);
3549 if (PL_opargs[type] & OA_TARGET)
3550 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3551 return CHECKOP(type, padop);
3552}
392d04bb 3553#endif
350de78d
GS		 3554
3555OP *
864dbfa3 3556Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
79072805 3557{
27da23d5 3558 dVAR;
58182927 3559 assert(gv);
350de78d 3560#ifdef USE_ITHREADS
58182927 3561 GvIN_PAD_on(gv);
ff8997d7 3562 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
350de78d 3563#else
ff8997d7 3564 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
350de78d 3565#endif