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