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
version-0.73 (was Re: Change 31920: Don't use ~0 as a version
[perl5.git] / op.c
CommitLineData
a0d0e21e 1/* op.c
79072805 2 *
4bb101f2 3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
bc641c27 4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, by Larry Wall and others
79072805
LW		 5 *
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
8 *
a0d0e21e
LW		 9 */
10
11/*
12 * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
13 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
14 * youngest of the Old Took's daughters); and Mr. Drogo was his second
15 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
16 * either way, as the saying is, if you follow me." --the Gaffer
79072805
LW		 17 */
18
166f8a29
DM		 19/* This file contains the functions that create, manipulate and optimize
20 * the OP structures that hold a compiled perl program.
21 *
22 * A Perl program is compiled into a tree of OPs. Each op contains
23 * structural pointers (eg to its siblings and the next op in the
24 * execution sequence), a pointer to the function that would execute the
25 * op, plus any data specific to that op. For example, an OP_CONST op
26 * points to the pp_const() function and to an SV containing the constant
27 * value. When pp_const() is executed, its job is to push that SV onto the
28 * stack.
29 *
30 * OPs are mainly created by the newFOO() functions, which are mainly
31 * called from the parser (in perly.y) as the code is parsed. For example
32 * the Perl code $a + $b * $c would cause the equivalent of the following
33 * to be called (oversimplifying a bit):
34 *
35 * newBINOP(OP_ADD, flags,
36 * newSVREF($a),
37 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
38 * )
39 *
40 * Note that during the build of miniperl, a temporary copy of this file
41 * is made, called opmini.c.
42 */
ccfc67b7 43
61b743bb
DM		 44/*
45Perl's compiler is essentially a 3-pass compiler with interleaved phases:
46
47 A bottom-up pass
48 A top-down pass
49 An execution-order pass
50
51The bottom-up pass is represented by all the "newOP" routines and
52the ck_ routines. The bottom-upness is actually driven by yacc.
53So at the point that a ck_ routine fires, we have no idea what the
54context is, either upward in the syntax tree, or either forward or
55backward in the execution order. (The bottom-up parser builds that
56part of the execution order it knows about, but if you follow the "next"
57links around, you'll find it's actually a closed loop through the
58top level node.
59
60Whenever the bottom-up parser gets to a node that supplies context to
61its components, it invokes that portion of the top-down pass that applies
62to that part of the subtree (and marks the top node as processed, so
63if a node further up supplies context, it doesn't have to take the
64plunge again). As a particular subcase of this, as the new node is
65built, it takes all the closed execution loops of its subcomponents
66and links them into a new closed loop for the higher level node. But
67it's still not the real execution order.
68
69The actual execution order is not known till we get a grammar reduction
70to a top-level unit like a subroutine or file that will be called by
71"name" rather than via a "next" pointer. At that point, we can call
72into peep() to do that code's portion of the 3rd pass. It has to be
73recursive, but it's recursive on basic blocks, not on tree nodes.
74*/
75
06e0342d 76/* To implement user lexical pragmas, there needs to be a way at run time to
b3ca2e83
NC		 77 get the compile time state of %^H for that block. Storing %^H in every
78 block (or even COP) would be very expensive, so a different approach is
79 taken. The (running) state of %^H is serialised into a tree of HE-like
80 structs. Stores into %^H are chained onto the current leaf as a struct
81 refcounted_he * with the key and the value. Deletes from %^H are saved
82 with a value of PL_sv_placeholder. The state of %^H at any point can be
83 turned back into a regular HV by walking back up the tree from that point's
06e0342d 84 leaf, ignoring any key you've already seen (placeholder or not), storing
b3ca2e83
NC		 85 the rest into the HV structure, then removing the placeholders. Hence
86 memory is only used to store the %^H deltas from the enclosing COP, rather
87 than the entire %^H on each COP.
88
89 To cause actions on %^H to write out the serialisation records, it has
90 magic type 'H'. This magic (itself) does nothing, but its presence causes
91 the values to gain magic type 'h', which has entries for set and clear.
c28fe1ec 92 C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
b3ca2e83 93 record, with deletes written by C<Perl_magic_clearhint>. C<SAVE_HINTS>
c28fe1ec
NC		 94 saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
95 it will be correctly restored when any inner compiling scope is exited.
b3ca2e83
NC		 96*/
97
79072805 98#include "EXTERN.h"
864dbfa3 99#define PERL_IN_OP_C
79072805 100#include "perl.h"
77ca0c92 101#include "keywords.h"
79072805 102
a07e034d 103#define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
a2efc822 104
238a4c30
NIS		 105#if defined(PL_OP_SLAB_ALLOC)
106
f1fac472
NC		 107#ifdef PERL_DEBUG_READONLY_OPS
108# define PERL_SLAB_SIZE 4096
109# include <sys/mman.h>
110#endif
111
238a4c30
NIS		 112#ifndef PERL_SLAB_SIZE
113#define PERL_SLAB_SIZE 2048
114#endif
115
c7e45529 116void *
e91d68d5 117Perl_Slab_Alloc(pTHX_ size_t sz)
1c846c1f 118{
5a8e194f
NIS		 119 /*
120 * To make incrementing use count easy PL_OpSlab is an I32 *
121 * To make inserting the link to slab PL_OpPtr is I32 **
122 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
123 * Add an overhead for pointer to slab and round up as a number of pointers
124 */
125 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
238a4c30 126 if ((PL_OpSpace -= sz) < 0) {
f1fac472
NC		 127#ifdef PERL_DEBUG_READONLY_OPS
128 /* We need to allocate chunk by chunk so that we can control the VM
129 mapping */
130 PL_OpPtr = mmap(0, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE,
131 MAP_ANON|MAP_PRIVATE, -1, 0);
132
133 DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
134 (unsigned long) PERL_SLAB_SIZE*sizeof(I32*),
135 PL_OpPtr));
136 if(PL_OpPtr == MAP_FAILED) {
137 perror("mmap failed");
138 abort();
139 }
140#else
277e868c
NC		 141
142 PL_OpPtr = (I32 **) PerlMemShared_calloc(PERL_SLAB_SIZE,sizeof(I32*));
f1fac472 143#endif
083fcd59 144 if (!PL_OpPtr) {
238a4c30
NIS		 145 return NULL;
146 }
5a8e194f
NIS		 147 /* We reserve the 0'th I32 sized chunk as a use count */
148 PL_OpSlab = (I32 *) PL_OpPtr;
149 /* Reduce size by the use count word, and by the size we need.
150 * Latter is to mimic the '-=' in the if() above
151 */
152 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
238a4c30
NIS		 153 /* Allocation pointer starts at the top.
154 Theory: because we build leaves before trunk allocating at end
155 means that at run time access is cache friendly upward
156 */
5a8e194f 157 PL_OpPtr += PERL_SLAB_SIZE;
f1fac472
NC		 158
159#ifdef PERL_DEBUG_READONLY_OPS
160 /* We remember this slab. */
161 /* This implementation isn't efficient, but it is simple. */
162 PL_slabs = realloc(PL_slabs, sizeof(I32**) * (PL_slab_count + 1));
163 PL_slabs[PL_slab_count++] = PL_OpSlab;
164 DEBUG_m(PerlIO_printf(Perl_debug_log, "Allocate %p\n", PL_OpSlab));
165#endif
238a4c30
NIS		 166 }
167 assert( PL_OpSpace >= 0 );
168 /* Move the allocation pointer down */
169 PL_OpPtr -= sz;
5a8e194f 170 assert( PL_OpPtr > (I32 **) PL_OpSlab );
238a4c30
NIS		 171 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
172 (*PL_OpSlab)++; /* Increment use count of slab */
5a8e194f 173 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
238a4c30
NIS		 174 assert( *PL_OpSlab > 0 );
175 return (void *)(PL_OpPtr + 1);
176}
177
f1fac472
NC		 178#ifdef PERL_DEBUG_READONLY_OPS
179void
180Perl_pending_Slabs_to_ro(pTHX) {
181 /* Turn all the allocated op slabs read only. */
182 U32 count = PL_slab_count;
183 I32 **const slabs = PL_slabs;
184
185 /* Reset the array of pending OP slabs, as we're about to turn this lot
186 read only. Also, do it ahead of the loop in case the warn triggers,
187 and a warn handler has an eval */
188
f1fac472
NC		 189 PL_slabs = NULL;
190 PL_slab_count = 0;
191
192 /* Force a new slab for any further allocation. */
193 PL_OpSpace = 0;
194
195 while (count--) {
5892a4d4 196 void *const start = slabs[count];
f1fac472
NC		 197 const size_t size = PERL_SLAB_SIZE* sizeof(I32*);
198 if(mprotect(start, size, PROT_READ)) {
199 Perl_warn(aTHX_ "mprotect for %p %lu failed with %d",
200 start, (unsigned long) size, errno);
201 }
202 }
5892a4d4
NC		 203
204 free(slabs);
f1fac472
NC		 205}
206
207STATIC void
208S_Slab_to_rw(pTHX_ void *op)
209{
210 I32 * const * const ptr = (I32 **) op;
211 I32 * const slab = ptr[-1];
212 assert( ptr-1 > (I32 **) slab );
213 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
214 assert( *slab > 0 );
215 if(mprotect(slab, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE)) {
216 Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d",
217 slab, (unsigned long) PERL_SLAB_SIZE*sizeof(I32*), errno);
218 }
219}
fc97af9c
NC		 220
221OP *
222Perl_op_refcnt_inc(pTHX_ OP *o)
223{
224 if(o) {
225 Slab_to_rw(o);
226 ++o->op_targ;
227 }
228 return o;
229
230}
231
232PADOFFSET
233Perl_op_refcnt_dec(pTHX_ OP *o)
234{
235 Slab_to_rw(o);
236 return --o->op_targ;
237}
f1fac472
NC		 238#else
239# define Slab_to_rw(op)
240#endif
241
c7e45529
AE		 242void
243Perl_Slab_Free(pTHX_ void *op)
238a4c30 244{
551405c4 245 I32 * const * const ptr = (I32 **) op;
aec46f14 246 I32 * const slab = ptr[-1];
5a8e194f
NIS		 247 assert( ptr-1 > (I32 **) slab );
248 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
238a4c30 249 assert( *slab > 0 );
f1fac472 250 Slab_to_rw(op);
238a4c30 251 if (--(*slab) == 0) {
7e4e8c89
NC		 252# ifdef NETWARE
253# define PerlMemShared PerlMem
254# endif
083fcd59 255
f1fac472 256#ifdef PERL_DEBUG_READONLY_OPS
782a40f1 257 U32 count = PL_slab_count;
f1fac472 258 /* Need to remove this slab from our list of slabs */
782a40f1 259 if (count) {
f1fac472
NC		 260 while (count--) {
261 if (PL_slabs[count] == slab) {
262 /* Found it. Move the entry at the end to overwrite it. */
263 DEBUG_m(PerlIO_printf(Perl_debug_log,
264 "Deallocate %p by moving %p from %lu to %lu\n",
265 PL_OpSlab,
266 PL_slabs[PL_slab_count - 1],
267 PL_slab_count, count));
268 PL_slabs[count] = PL_slabs[--PL_slab_count];
269 /* Could realloc smaller at this point, but probably not
270 worth it. */
fc97af9c
NC		 271 if(munmap(slab, PERL_SLAB_SIZE*sizeof(I32*))) {
272 perror("munmap failed");
273 abort();
274 }
275 break;
f1fac472 276 }
f1fac472
NC		 277 }
278 }
279#else
083fcd59 280 PerlMemShared_free(slab);
f1fac472 281#endif
238a4c30
NIS		 282 if (slab == PL_OpSlab) {
283 PL_OpSpace = 0;
284 }
285 }
b7dc083c 286}
b7dc083c 287#endif
e50aee73 288/*
ce6f1cbc 289 * In the following definition, the ", (OP*)0" is just to make the compiler
a5f75d66 290 * think the expression is of the right type: croak actually does a Siglongjmp.
e50aee73 291 */
11343788 292#define CHECKOP(type,o) \
ce6f1cbc 293 ((PL_op_mask && PL_op_mask[type]) \
5dc0d613 294 ? ( op_free((OP*)o), \
cb77fdf0 295 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
ce6f1cbc 296 (OP*)0 ) \
fc0dc3b3 297 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
e50aee73 298
e6438c1a 299#define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
c53d7c7d 300
8b6b16e7 301STATIC const char*
cea2e8a9 302S_gv_ename(pTHX_ GV *gv)
4633a7c4 303{
46c461b5 304 SV* const tmpsv = sv_newmortal();
bd61b366 305 gv_efullname3(tmpsv, gv, NULL);
8b6b16e7 306 return SvPV_nolen_const(tmpsv);
4633a7c4
LW		 307}
308
76e3520e 309STATIC OP *
cea2e8a9 310S_no_fh_allowed(pTHX_ OP *o)
79072805 311{
cea2e8a9 312 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
53e06cf0 313 OP_DESC(o)));
11343788 314 return o;
79072805
LW		 315}
316
76e3520e 317STATIC OP *
bfed75c6 318S_too_few_arguments(pTHX_ OP *o, const char *name)
79072805 319{
cea2e8a9 320 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
11343788 321 return o;
79072805
LW		 322}
323
76e3520e 324STATIC OP *
bfed75c6 325S_too_many_arguments(pTHX_ OP *o, const char *name)
79072805 326{
cea2e8a9 327 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
11343788 328 return o;
79072805
LW		 329}
330
76e3520e 331STATIC void
6867be6d 332S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
8990e307 333{
cea2e8a9 334 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
53e06cf0 335 (int)n, name, t, OP_DESC(kid)));
8990e307
LW		 336}
337
7a52d87a 338STATIC void
6867be6d 339S_no_bareword_allowed(pTHX_ const OP *o)
7a52d87a 340{
eb8433b7
NC		 341 if (PL_madskills)
342 return; /* various ok barewords are hidden in extra OP_NULL */
5a844595 343 qerror(Perl_mess(aTHX_
35c1215d 344 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
be2597df 345 SVfARG(cSVOPo_sv)));
7a52d87a
GS		 346}
347
79072805
LW		 348/* "register" allocation */
349
350PADOFFSET
262cbcdb 351Perl_allocmy(pTHX_ const char *const name)
93a17b20 352{
97aff369 353 dVAR;
a0d0e21e 354 PADOFFSET off;
12bd6ede 355 const bool is_our = (PL_parser->in_my == KEY_our);
a0d0e21e 356
59f00321 357 /* complain about "my $<special_var>" etc etc */
6b58708b 358 if (*name &&
3edf23ff 359 !(is_our ||
155aba94 360 isALPHA(name[1]) ||
39e02b42 361 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
6b58708b 362 (name[1] == '_' && (*name == '$' || name[2]))))
834a4ddd 363 {
6b58708b 364 /* name[2] is true if strlen(name) > 2 */
c4d0567e 365 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
aab6a793
NC		 366 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%s in \"%s\"",
367 name[0], toCTRL(name[1]), name + 2,
368 PL_parser->in_my == KEY_state ? "state" : "my"));
d1544d85 369 } else {
aab6a793
NC		 370 yyerror(Perl_form(aTHX_ "Can't use global %s in \"%s\"",name,
371 PL_parser->in_my == KEY_state ? "state" : "my"));
46fc3d4c 372 }
a0d0e21e 373 }
748a9306 374
dd2155a4 375 /* check for duplicate declaration */
3edf23ff 376 pad_check_dup(name, is_our, (PL_curstash ? PL_curstash : PL_defstash));
33b8ce05 377
12bd6ede 378 if (PL_parser->in_my_stash && *name != '$') {
dd2155a4
DM		 379 yyerror(Perl_form(aTHX_
380 "Can't declare class for non-scalar %s in \"%s\"",
952306ac 381 name,
12bd6ede
DM		 382 is_our ? "our"
383 : PL_parser->in_my == KEY_state ? "state" : "my"));
6b35e009
GS		 384 }
385
dd2155a4 386 /* allocate a spare slot and store the name in that slot */
93a17b20 387
dd2155a4 388 off = pad_add_name(name,
12bd6ede 389 PL_parser->in_my_stash,
3edf23ff 390 (is_our
133706a6
RGS		 391 /* $_ is always in main::, even with our */
392 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
5c284bb0 393 : NULL
dd2155a4 394 ),
952306ac 395 0, /* not fake */
12bd6ede 396 PL_parser->in_my == KEY_state
dd2155a4 397 );
a74073ad
DM		 398 /* anon sub prototypes contains state vars should always be cloned,
399 * otherwise the state var would be shared between anon subs */
400
401 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
402 CvCLONE_on(PL_compcv);
403
dd2155a4 404 return off;
79072805
LW		 405}
406
d2c837a0
DM		 407/* free the body of an op without examining its contents.
408 * Always use this rather than FreeOp directly */
409
4136a0f7 410static void
d2c837a0
DM		 411S_op_destroy(pTHX_ OP *o)
412{
413 if (o->op_latefree) {
414 o->op_latefreed = 1;
415 return;
416 }
417 FreeOp(o);
418}
419
c4bd3ae5
NC		 420#ifdef USE_ITHREADS
421# define forget_pmop(a,b) S_forget_pmop(aTHX_ a,b)
422#else
423# define forget_pmop(a,b) S_forget_pmop(aTHX_ a)
424#endif
d2c837a0 425
79072805
LW		 426/* Destructor */
427
428void
864dbfa3 429Perl_op_free(pTHX_ OP *o)
79072805 430{
27da23d5 431 dVAR;
acb36ea4 432 OPCODE type;
79072805 433
85594c31 434 if (!o)
79072805 435 return;
670f3923
DM		 436 if (o->op_latefreed) {
437 if (o->op_latefree)
438 return;
439 goto do_free;
440 }
79072805 441
67566ccd 442 type = o->op_type;
7934575e 443 if (o->op_private & OPpREFCOUNTED) {
67566ccd 444 switch (type) {
7934575e
GS		 445 case OP_LEAVESUB:
446 case OP_LEAVESUBLV:
447 case OP_LEAVEEVAL:
448 case OP_LEAVE:
449 case OP_SCOPE:
450 case OP_LEAVEWRITE:
67566ccd
AL		 451 {
452 PADOFFSET refcnt;
7934575e 453 OP_REFCNT_LOCK;
4026c95a 454 refcnt = OpREFCNT_dec(o);
7934575e 455 OP_REFCNT_UNLOCK;
bfd0ff22
NC		 456 if (refcnt) {
457 /* Need to find and remove any pattern match ops from the list
458 we maintain for reset(). */
459 find_and_forget_pmops(o);
4026c95a 460 return;
67566ccd 461 }
bfd0ff22 462 }
7934575e
GS		 463 break;
464 default:
465 break;
466 }
467 }
468
11343788 469 if (o->op_flags & OPf_KIDS) {
6867be6d 470 register OP *kid, *nextkid;
11343788 471 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
85e6fe83 472 nextkid = kid->op_sibling; /* Get before next freeing kid */
79072805 473 op_free(kid);
85e6fe83 474 }
79072805 475 }
acb36ea4 476 if (type == OP_NULL)
eb160463 477 type = (OPCODE)o->op_targ;
acb36ea4 478
fc97af9c
NC		 479#ifdef PERL_DEBUG_READONLY_OPS
480 Slab_to_rw(o);
481#endif
482
acb36ea4
GS		 483 /* COP* is not cleared by op_clear() so that we may track line
484 * numbers etc even after null() */
3235b7a3 485 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE) {
acb36ea4 486 cop_free((COP*)o);
3235b7a3 487 }
acb36ea4
GS		 488
489 op_clear(o);
670f3923
DM		 490 if (o->op_latefree) {
491 o->op_latefreed = 1;
492 return;
493 }
494 do_free:
238a4c30 495 FreeOp(o);
4d494880
DM		 496#ifdef DEBUG_LEAKING_SCALARS
497 if (PL_op == o)
5f66b61c 498 PL_op = NULL;
4d494880 499#endif
acb36ea4 500}
79072805 501
93c66552
DM		 502void
503Perl_op_clear(pTHX_ OP *o)
acb36ea4 504{
13137afc 505
27da23d5 506 dVAR;
eb8433b7
NC		 507#ifdef PERL_MAD
508 /* if (o->op_madprop && o->op_madprop->mad_next)
509 abort(); */
3cc8d589
NC		 510 /* FIXME for MAD - if I uncomment these two lines t/op/pack.t fails with
511 "modification of a read only value" for a reason I can't fathom why.
512 It's the "" stringification of $_, where $_ was set to '' in a foreach
04a4d38e
NC		 513 loop, but it defies simplification into a small test case.
514 However, commenting them out has caused ext/List/Util/t/weak.t to fail
515 the last test. */
3cc8d589
NC		 516 /*
517 mad_free(o->op_madprop);
518 o->op_madprop = 0;
519 */
eb8433b7
NC		 520#endif
521
522 retry:
11343788 523 switch (o->op_type) {
acb36ea4 524 case OP_NULL: /* Was holding old type, if any. */
eb8433b7
NC		 525 if (PL_madskills && o->op_targ != OP_NULL) {
526 o->op_type = o->op_targ;
527 o->op_targ = 0;
528 goto retry;
529 }
acb36ea4 530 case OP_ENTEREVAL: /* Was holding hints. */
acb36ea4 531 o->op_targ = 0;
a0d0e21e 532 break;
a6006777 533 default:
ac4c12e7 534 if (!(o->op_flags & OPf_REF)
0b94c7bb 535 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
a6006777 536 break;
537 /* FALL THROUGH */
463ee0b2 538 case OP_GVSV:
79072805 539 case OP_GV:
a6006777 540 case OP_AELEMFAST:
6a077020
DM		 541 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
542 /* not an OP_PADAV replacement */
350de78d 543#ifdef USE_ITHREADS
6a077020
DM		 544 if (cPADOPo->op_padix > 0) {
545 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
546 * may still exist on the pad */
547 pad_swipe(cPADOPo->op_padix, TRUE);
548 cPADOPo->op_padix = 0;
549 }
350de78d 550#else
6a077020 551 SvREFCNT_dec(cSVOPo->op_sv);
a0714e2c 552 cSVOPo->op_sv = NULL;
350de78d 553#endif
6a077020 554 }
79072805 555 break;
a1ae71d2 556 case OP_METHOD_NAMED:
79072805 557 case OP_CONST:
11343788 558 SvREFCNT_dec(cSVOPo->op_sv);
a0714e2c 559 cSVOPo->op_sv = NULL;
3b1c21fa
AB		 560#ifdef USE_ITHREADS
561 /** Bug #15654
562 Even if op_clear does a pad_free for the target of the op,
6a077020 563 pad_free doesn't actually remove the sv that exists in the pad;
3b1c21fa
AB		 564 instead it lives on. This results in that it could be reused as
565 a target later on when the pad was reallocated.
566 **/
567 if(o->op_targ) {
568 pad_swipe(o->op_targ,1);
569 o->op_targ = 0;
570 }
571#endif
79072805 572 break;
748a9306
LW		 573 case OP_GOTO:
574 case OP_NEXT:
575 case OP_LAST:
576 case OP_REDO:
11343788 577 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
748a9306
LW		 578 break;
579 /* FALL THROUGH */
a0d0e21e 580 case OP_TRANS:
acb36ea4 581 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
043e41b8
DM		 582#ifdef USE_ITHREADS
583 if (cPADOPo->op_padix > 0) {
584 pad_swipe(cPADOPo->op_padix, TRUE);
585 cPADOPo->op_padix = 0;
586 }
587#else
a0ed51b3 588 SvREFCNT_dec(cSVOPo->op_sv);
a0714e2c 589 cSVOPo->op_sv = NULL;
043e41b8 590#endif
acb36ea4
GS		 591 }
592 else {
ea71c68d 593 PerlMemShared_free(cPVOPo->op_pv);
bd61b366 594 cPVOPo->op_pv = NULL;
acb36ea4 595 }
a0d0e21e
LW		 596 break;
597 case OP_SUBST:
20e98b0f 598 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
971a9dd3 599 goto clear_pmop;
748a9306 600 case OP_PUSHRE:
971a9dd3 601#ifdef USE_ITHREADS
20e98b0f 602 if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
dd2155a4
DM		 603 /* No GvIN_PAD_off here, because other references may still
604 * exist on the pad */
20e98b0f 605 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
971a9dd3
GS		 606 }
607#else
20e98b0f 608 SvREFCNT_dec((SV*)cPMOPo->op_pmreplrootu.op_pmtargetgv);
971a9dd3
GS		 609#endif
610 /* FALL THROUGH */
a0d0e21e 611 case OP_MATCH:
8782bef2 612 case OP_QR:
971a9dd3 613clear_pmop:
c2b1997a 614 forget_pmop(cPMOPo, 1);
20e98b0f 615 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
5f8cb046
DM		 616 /* we use the "SAFE" version of the PM_ macros here
617 * since sv_clean_all might release some PMOPs
618 * after PL_regex_padav has been cleared
619 * and the clearing of PL_regex_padav needs to
620 * happen before sv_clean_all
621 */
622 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
5f66b61c 623 PM_SETRE_SAFE(cPMOPo, NULL);
13137afc
AB		 624#ifdef USE_ITHREADS
625 if(PL_regex_pad) { /* We could be in destruction */
626 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
c737faaf 627 SvREADONLY_off(PL_regex_pad[(cPMOPo)->op_pmoffset]);
1cc8b4c5 628 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
13137afc
AB		 629 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
630 }
1eb1540c 631#endif
13137afc 632
a0d0e21e 633 break;
79072805
LW		 634 }
635
743e66e6 636 if (o->op_targ > 0) {
11343788 637 pad_free(o->op_targ);
743e66e6
GS		 638 o->op_targ = 0;
639 }
79072805
LW		 640}
641
76e3520e 642STATIC void
3eb57f73
HS		 643S_cop_free(pTHX_ COP* cop)
644{
6a3d5e3d 645 CopLABEL_free(cop);
05ec9bb3
NIS		 646 CopFILE_free(cop);
647 CopSTASH_free(cop);
0453d815 648 if (! specialWARN(cop->cop_warnings))
72dc9ed5 649 PerlMemShared_free(cop->cop_warnings);
c28fe1ec 650 Perl_refcounted_he_free(aTHX_ cop->cop_hints_hash);
3eb57f73
HS		 651}
652
c2b1997a 653STATIC void
c4bd3ae5
NC		 654S_forget_pmop(pTHX_ PMOP *const o
655#ifdef USE_ITHREADS
656 , U32 flags
657#endif
658 )
c2b1997a
NC		 659{
660 HV * const pmstash = PmopSTASH(o);
661 if (pmstash && !SvIS_FREED(pmstash)) {
662 MAGIC * const mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab);
663 if (mg) {
664 PMOP **const array = (PMOP**) mg->mg_ptr;
665 U32 count = mg->mg_len / sizeof(PMOP**);
666 U32 i = count;
667
668 while (i--) {
669 if (array[i] == o) {
670 /* Found it. Move the entry at the end to overwrite it. */
671 array[i] = array[--count];
672 mg->mg_len = count * sizeof(PMOP**);
673 /* Could realloc smaller at this point always, but probably
674 not worth it. Probably worth free()ing if we're the
675 last. */
676 if(!count) {
677 Safefree(mg->mg_ptr);
678 mg->mg_ptr = NULL;
679 }
680 break;
681 }
682 }
683 }
684 }
1cdf7faf
NC		 685 if (PL_curpm == o)
686 PL_curpm = NULL;
c4bd3ae5 687#ifdef USE_ITHREADS
c2b1997a
NC		 688 if (flags)
689 PmopSTASH_free(o);
c4bd3ae5 690#endif
c2b1997a
NC		 691}
692
bfd0ff22
NC		 693STATIC void
694S_find_and_forget_pmops(pTHX_ OP *o)
695{
696 if (o->op_flags & OPf_KIDS) {
697 OP *kid = cUNOPo->op_first;
698 while (kid) {
699 switch (kid->op_type) {
700 case OP_SUBST:
701 case OP_PUSHRE:
702 case OP_MATCH:
703 case OP_QR:
704 forget_pmop((PMOP*)kid, 0);
705 }
706 find_and_forget_pmops(kid);
707 kid = kid->op_sibling;
708 }
709 }
710}
711
93c66552
DM		 712void
713Perl_op_null(pTHX_ OP *o)
8990e307 714{
27da23d5 715 dVAR;
acb36ea4
GS		 716 if (o->op_type == OP_NULL)
717 return;
eb8433b7
NC		 718 if (!PL_madskills)
719 op_clear(o);
11343788
MB		 720 o->op_targ = o->op_type;
721 o->op_type = OP_NULL;
22c35a8c 722 o->op_ppaddr = PL_ppaddr[OP_NULL];
8990e307
LW		 723}
724
4026c95a
SH		 725void
726Perl_op_refcnt_lock(pTHX)
727{
27da23d5 728 dVAR;
96a5add6 729 PERL_UNUSED_CONTEXT;
4026c95a
SH		 730 OP_REFCNT_LOCK;
731}
732
733void
734Perl_op_refcnt_unlock(pTHX)
735{
27da23d5 736 dVAR;
96a5add6 737 PERL_UNUSED_CONTEXT;
4026c95a
SH		 738 OP_REFCNT_UNLOCK;
739}
740
79072805
LW		 741/* Contextualizers */
742
463ee0b2 743#define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
79072805
LW		 744
745OP *
864dbfa3 746Perl_linklist(pTHX_ OP *o)
79072805 747{
3edf23ff 748 OP *first;
79072805 749
11343788
MB		 750 if (o->op_next)
751 return o->op_next;
79072805
LW		 752
753 /* establish postfix order */
3edf23ff
AL		 754 first = cUNOPo->op_first;
755 if (first) {
6867be6d 756 register OP *kid;
3edf23ff
AL		 757 o->op_next = LINKLIST(first);
758 kid = first;
759 for (;;) {
760 if (kid->op_sibling) {
79072805 761 kid->op_next = LINKLIST(kid->op_sibling);
3edf23ff
AL		 762 kid = kid->op_sibling;
763 } else {
11343788 764 kid->op_next = o;
3edf23ff
AL		 765 break;
766 }
79072805
LW		 767 }
768 }
769 else
11343788 770 o->op_next = o;
79072805 771
11343788 772 return o->op_next;
79072805
LW		 773}
774
775OP *
864dbfa3 776Perl_scalarkids(pTHX_ OP *o)
79072805 777{
11343788 778 if (o && o->op_flags & OPf_KIDS) {
bfed75c6 779 OP *kid;
11343788 780 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW		 781 scalar(kid);
782 }
11343788 783 return o;
79072805
LW		 784}
785
76e3520e 786STATIC OP *
cea2e8a9 787S_scalarboolean(pTHX_ OP *o)
8990e307 788{
97aff369 789 dVAR;
d008e5eb 790 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
d008e5eb 791 if (ckWARN(WARN_SYNTAX)) {
6867be6d 792 const line_t oldline = CopLINE(PL_curcop);
a0d0e21e 793
53a7735b
DM		 794 if (PL_parser && PL_parser->copline != NOLINE)
795 CopLINE_set(PL_curcop, PL_parser->copline);
9014280d 796 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
57843af0 797 CopLINE_set(PL_curcop, oldline);
d008e5eb 798 }
a0d0e21e 799 }
11343788 800 return scalar(o);
8990e307
LW		 801}
802
803OP *
864dbfa3 804Perl_scalar(pTHX_ OP *o)
79072805 805{
27da23d5 806 dVAR;
79072805
LW		 807 OP *kid;
808
a0d0e21e 809 /* assumes no premature commitment */
13765c85
DM		 810 if (!o || (PL_parser && PL_parser->error_count)
811 || (o->op_flags & OPf_WANT)
5dc0d613 812 || o->op_type == OP_RETURN)
7e363e51 813 {
11343788 814 return o;
7e363e51 815 }
79072805 816
5dc0d613 817 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
79072805 818
11343788 819 switch (o->op_type) {
79072805 820 case OP_REPEAT:
11343788 821 scalar(cBINOPo->op_first);
8990e307 822 break;
79072805
LW		 823 case OP_OR:
824 case OP_AND:
825 case OP_COND_EXPR:
11343788 826 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
8990e307 827 scalar(kid);
79072805 828 break;
a0d0e21e 829 case OP_SPLIT:
11343788 830 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
20e98b0f 831 if (!kPMOP->op_pmreplrootu.op_pmreplroot)
12bcd1a6 832 deprecate_old("implicit split to @_");
a0d0e21e
LW		 833 }
834 /* FALL THROUGH */
79072805 835 case OP_MATCH:
8782bef2 836 case OP_QR:
79072805
LW		 837 case OP_SUBST:
838 case OP_NULL:
8990e307 839 default:
11343788
MB		 840 if (o->op_flags & OPf_KIDS) {
841 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
8990e307
LW		 842 scalar(kid);
843 }
79072805
LW		 844 break;
845 case OP_LEAVE:
846 case OP_LEAVETRY:
5dc0d613 847 kid = cLISTOPo->op_first;
54310121 848 scalar(kid);
155aba94 849 while ((kid = kid->op_sibling)) {
54310121 850 if (kid->op_sibling)
851 scalarvoid(kid);
852 else
853 scalar(kid);
854 }
11206fdd 855 PL_curcop = &PL_compiling;
54310121 856 break;
748a9306 857 case OP_SCOPE:
79072805 858 case OP_LINESEQ:
8990e307 859 case OP_LIST:
11343788 860 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
79072805
LW		 861 if (kid->op_sibling)
862 scalarvoid(kid);
863 else
864 scalar(kid);
865 }
11206fdd 866 PL_curcop = &PL_compiling;
79072805 867 break;
a801c63c
RGS		 868 case OP_SORT:
869 if (ckWARN(WARN_VOID))
9014280d 870 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
79072805 871 }
11343788 872 return o;
79072805
LW		 873}
874
875OP *
864dbfa3 876Perl_scalarvoid(pTHX_ OP *o)
79072805 877{
27da23d5 878 dVAR;
79072805 879 OP *kid;
c445ea15 880 const char* useless = NULL;
8990e307 881 SV* sv;
2ebea0a1
GS		 882 U8 want;
883
eb8433b7
NC		 884 /* trailing mad null ops don't count as "there" for void processing */
885 if (PL_madskills &&
886 o->op_type != OP_NULL &&
887 o->op_sibling &&
888 o->op_sibling->op_type == OP_NULL)
889 {
890 OP *sib;
891 for (sib = o->op_sibling;
892 sib && sib->op_type == OP_NULL;
893 sib = sib->op_sibling) ;
894
895 if (!sib)
896 return o;
897 }
898
acb36ea4
GS		 899 if (o->op_type == OP_NEXTSTATE
900 || o->op_type == OP_SETSTATE
901 || o->op_type == OP_DBSTATE
902 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
903 || o->op_targ == OP_SETSTATE
904 || o->op_targ == OP_DBSTATE)))
2ebea0a1 905 PL_curcop = (COP*)o; /* for warning below */
79072805 906
54310121 907 /* assumes no premature commitment */
2ebea0a1 908 want = o->op_flags & OPf_WANT;
13765c85
DM		 909 if ((want && want != OPf_WANT_SCALAR)
910 || (PL_parser && PL_parser->error_count)
5dc0d613 911 || o->op_type == OP_RETURN)
7e363e51 912 {
11343788 913 return o;
7e363e51 914 }
79072805 915
b162f9ea 916 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS		 917 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
918 {
b162f9ea 919 return scalar(o); /* As if inside SASSIGN */
7e363e51 920 }
1c846c1f 921
5dc0d613 922 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
79072805 923
11343788 924 switch (o->op_type) {
79072805 925 default:
22c35a8c 926 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
8990e307 927 break;
36477c24 928 /* FALL THROUGH */
929 case OP_REPEAT:
11343788 930 if (o->op_flags & OPf_STACKED)
8990e307 931 break;
5d82c453
GA		 932 goto func_ops;
933 case OP_SUBSTR:
934 if (o->op_private == 4)
935 break;
8990e307
LW		 936 /* FALL THROUGH */
937 case OP_GVSV:
938 case OP_WANTARRAY:
939 case OP_GV:
940 case OP_PADSV:
941 case OP_PADAV:
942 case OP_PADHV:
943 case OP_PADANY:
944 case OP_AV2ARYLEN:
8990e307 945 case OP_REF:
a0d0e21e
LW		 946 case OP_REFGEN:
947 case OP_SREFGEN:
8990e307
LW		 948 case OP_DEFINED:
949 case OP_HEX:
950 case OP_OCT:
951 case OP_LENGTH:
8990e307
LW		 952 case OP_VEC:
953 case OP_INDEX:
954 case OP_RINDEX:
955 case OP_SPRINTF:
956 case OP_AELEM:
957 case OP_AELEMFAST:
958 case OP_ASLICE:
8990e307
LW		 959 case OP_HELEM:
960 case OP_HSLICE:
961 case OP_UNPACK:
962 case OP_PACK:
8990e307
LW		 963 case OP_JOIN:
964 case OP_LSLICE:
965 case OP_ANONLIST:
966 case OP_ANONHASH:
967 case OP_SORT:
968 case OP_REVERSE:
969 case OP_RANGE:
970 case OP_FLIP:
971 case OP_FLOP:
972 case OP_CALLER:
973 case OP_FILENO:
974 case OP_EOF:
975 case OP_TELL:
976 case OP_GETSOCKNAME:
977 case OP_GETPEERNAME:
978 case OP_READLINK:
979 case OP_TELLDIR:
980 case OP_GETPPID:
981 case OP_GETPGRP:
982 case OP_GETPRIORITY:
983 case OP_TIME:
984 case OP_TMS:
985 case OP_LOCALTIME:
986 case OP_GMTIME:
987 case OP_GHBYNAME:
988 case OP_GHBYADDR:
989 case OP_GHOSTENT:
990 case OP_GNBYNAME:
991 case OP_GNBYADDR:
992 case OP_GNETENT:
993 case OP_GPBYNAME:
994 case OP_GPBYNUMBER:
995 case OP_GPROTOENT:
996 case OP_GSBYNAME:
997 case OP_GSBYPORT:
998 case OP_GSERVENT:
999 case OP_GPWNAM:
1000 case OP_GPWUID:
1001 case OP_GGRNAM:
1002 case OP_GGRGID:
1003 case OP_GETLOGIN:
78e1b766 1004 case OP_PROTOTYPE:
5d82c453 1005 func_ops:
64aac5a9 1006 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
53e06cf0 1007 useless = OP_DESC(o);
8990e307
LW		 1008 break;
1009
9f82cd5f
YST		 1010 case OP_NOT:
1011 kid = cUNOPo->op_first;
1012 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1013 kid->op_type != OP_TRANS) {
1014 goto func_ops;
1015 }
1016 useless = "negative pattern binding (!~)";
1017 break;
1018
8990e307
LW		 1019 case OP_RV2GV:
1020 case OP_RV2SV:
1021 case OP_RV2AV:
1022 case OP_RV2HV:
192587c2 1023 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
11343788 1024 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
8990e307
LW		 1025 useless = "a variable";
1026 break;
79072805
LW		 1027
1028 case OP_CONST:
7766f137 1029 sv = cSVOPo_sv;
7a52d87a
GS		 1030 if (cSVOPo->op_private & OPpCONST_STRICT)
1031 no_bareword_allowed(o);
1032 else {
d008e5eb
GS		 1033 if (ckWARN(WARN_VOID)) {
1034 useless = "a constant";
2e0ae2d3 1035 if (o->op_private & OPpCONST_ARYBASE)
d4c19fe8 1036 useless = NULL;
e7fec78e 1037 /* don't warn on optimised away booleans, eg
b5a930ec 1038 * use constant Foo, 5; Foo || print; */
e7fec78e 1039 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
d4c19fe8 1040 useless = NULL;
960b4253
MG		 1041 /* the constants 0 and 1 are permitted as they are
1042 conventionally used as dummies in constructs like
1043 1 while some_condition_with_side_effects; */
e7fec78e 1044 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
d4c19fe8 1045 useless = NULL;
d008e5eb 1046 else if (SvPOK(sv)) {
a52fe3ac
A		 1047 /* perl4's way of mixing documentation and code
1048 (before the invention of POD) was based on a
1049 trick to mix nroff and perl code. The trick was
1050 built upon these three nroff macros being used in
1051 void context. The pink camel has the details in
1052 the script wrapman near page 319. */
6136c704
AL		 1053 const char * const maybe_macro = SvPVX_const(sv);
1054 if (strnEQ(maybe_macro, "di", 2) ||
1055 strnEQ(maybe_macro, "ds", 2) ||
1056 strnEQ(maybe_macro, "ig", 2))
d4c19fe8 1057 useless = NULL;
d008e5eb 1058 }
8990e307
LW		 1059 }
1060 }
93c66552 1061 op_null(o); /* don't execute or even remember it */
79072805
LW		 1062 break;
1063
1064 case OP_POSTINC:
11343788 1065 o->op_type = OP_PREINC; /* pre-increment is faster */
22c35a8c 1066 o->op_ppaddr = PL_ppaddr[OP_PREINC];
79072805
LW		 1067 break;
1068
1069 case OP_POSTDEC:
11343788 1070 o->op_type = OP_PREDEC; /* pre-decrement is faster */
22c35a8c 1071 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
79072805
LW		 1072 break;
1073
679d6c4e
HS		 1074 case OP_I_POSTINC:
1075 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1076 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1077 break;
1078
1079 case OP_I_POSTDEC:
1080 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1081 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1082 break;
1083
79072805
LW		 1084 case OP_OR:
1085 case OP_AND:
c963b151 1086 case OP_DOR:
79072805 1087 case OP_COND_EXPR:
0d863452
RH		 1088 case OP_ENTERGIVEN:
1089 case OP_ENTERWHEN:
11343788 1090 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
79072805
LW		 1091 scalarvoid(kid);
1092 break;
5aabfad6 1093
a0d0e21e 1094 case OP_NULL:
11343788 1095 if (o->op_flags & OPf_STACKED)
a0d0e21e 1096 break;
5aabfad6 1097 /* FALL THROUGH */
2ebea0a1
GS		 1098 case OP_NEXTSTATE:
1099 case OP_DBSTATE:
79072805
LW		 1100 case OP_ENTERTRY:
1101 case OP_ENTER:
11343788 1102 if (!(o->op_flags & OPf_KIDS))
79072805 1103 break;
54310121 1104 /* FALL THROUGH */
463ee0b2 1105 case OP_SCOPE:
79072805
LW		 1106 case OP_LEAVE:
1107 case OP_LEAVETRY:
a0d0e21e 1108 case OP_LEAVELOOP:
79072805 1109 case OP_LINESEQ:
79072805 1110 case OP_LIST:
0d863452
RH		 1111 case OP_LEAVEGIVEN:
1112 case OP_LEAVEWHEN:
11343788 1113 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW		 1114 scalarvoid(kid);
1115 break;
c90c0ff4 1116 case OP_ENTEREVAL:
5196be3e 1117 scalarkids(o);
c90c0ff4 1118 break;
5aabfad6 1119 case OP_REQUIRE:
c90c0ff4 1120 /* all requires must return a boolean value */
5196be3e 1121 o->op_flags &= ~OPf_WANT;
d6483035
GS		 1122 /* FALL THROUGH */
1123 case OP_SCALAR:
5196be3e 1124 return scalar(o);
a0d0e21e 1125 case OP_SPLIT:
11343788 1126 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
20e98b0f 1127 if (!kPMOP->op_pmreplrootu.op_pmreplroot)
12bcd1a6 1128 deprecate_old("implicit split to @_");
a0d0e21e
LW		 1129 }
1130 break;
79072805 1131 }
411caa50 1132 if (useless && ckWARN(WARN_VOID))
9014280d 1133 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
11343788 1134 return o;
79072805
LW		 1135}
1136
1137OP *
864dbfa3 1138Perl_listkids(pTHX_ OP *o)
79072805 1139{
11343788 1140 if (o && o->op_flags & OPf_KIDS) {
6867be6d 1141 OP *kid;
11343788 1142 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW		 1143 list(kid);
1144 }
11343788 1145 return o;
79072805
LW		 1146}
1147
1148OP *
864dbfa3 1149Perl_list(pTHX_ OP *o)
79072805 1150{
27da23d5 1151 dVAR;
79072805
LW		 1152 OP *kid;
1153
a0d0e21e 1154 /* assumes no premature commitment */
13765c85
DM		 1155 if (!o || (o->op_flags & OPf_WANT)
1156 || (PL_parser && PL_parser->error_count)
5dc0d613 1157 || o->op_type == OP_RETURN)
7e363e51 1158 {
11343788 1159 return o;
7e363e51 1160 }
79072805 1161
b162f9ea 1162 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS		 1163 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1164 {
b162f9ea 1165 return o; /* As if inside SASSIGN */
7e363e51 1166 }
1c846c1f 1167
5dc0d613 1168 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
79072805 1169
11343788 1170 switch (o->op_type) {
79072805
LW		 1171 case OP_FLOP:
1172 case OP_REPEAT:
11343788 1173 list(cBINOPo->op_first);
79072805
LW		 1174 break;
1175 case OP_OR:
1176 case OP_AND:
1177 case OP_COND_EXPR:
11343788 1178 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
79072805
LW		 1179 list(kid);
1180 break;
1181 default:
1182 case OP_MATCH:
8782bef2 1183 case OP_QR:
79072805
LW		 1184 case OP_SUBST:
1185 case OP_NULL:
11343788 1186 if (!(o->op_flags & OPf_KIDS))
79072805 1187 break;
11343788
MB		 1188 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1189 list(cBINOPo->op_first);
1190 return gen_constant_list(o);
79072805
LW		 1191 }
1192 case OP_LIST:
11343788 1193 listkids(o);
79072805
LW		 1194 break;
1195 case OP_LEAVE:
1196 case OP_LEAVETRY:
5dc0d613 1197 kid = cLISTOPo->op_first;
54310121 1198 list(kid);
155aba94 1199 while ((kid = kid->op_sibling)) {
54310121 1200 if (kid->op_sibling)
1201 scalarvoid(kid);
1202 else
1203 list(kid);
1204 }
11206fdd 1205 PL_curcop = &PL_compiling;
54310121 1206 break;
748a9306 1207 case OP_SCOPE:
79072805 1208 case OP_LINESEQ:
11343788 1209 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
79072805
LW		 1210 if (kid->op_sibling)
1211 scalarvoid(kid);
1212 else
1213 list(kid);
1214 }
11206fdd 1215 PL_curcop = &PL_compiling;
79072805 1216 break;
c90c0ff4 1217 case OP_REQUIRE:
1218 /* all requires must return a boolean value */
5196be3e
MB		 1219 o->op_flags &= ~OPf_WANT;
1220 return scalar(o);
79072805 1221 }
11343788 1222 return o;
79072805
LW		 1223}
1224
1225OP *
864dbfa3 1226Perl_scalarseq(pTHX_ OP *o)
79072805 1227{
97aff369 1228 dVAR;
11343788 1229 if (o) {
1496a290
AL		 1230 const OPCODE type = o->op_type;
1231
1232 if (type == OP_LINESEQ || type == OP_SCOPE ||
1233 type == OP_LEAVE || type == OP_LEAVETRY)
463ee0b2 1234 {
6867be6d 1235 OP *kid;
11343788 1236 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
ed6116ce 1237 if (kid->op_sibling) {
463ee0b2 1238 scalarvoid(kid);
ed6116ce 1239 }
463ee0b2 1240 }
3280af22 1241 PL_curcop = &PL_compiling;
79072805 1242 }
11343788 1243 o->op_flags &= ~OPf_PARENS;
3280af22 1244 if (PL_hints & HINT_BLOCK_SCOPE)
11343788 1245 o->op_flags |= OPf_PARENS;
79072805 1246 }
8990e307 1247 else
11343788
MB		 1248 o = newOP(OP_STUB, 0);
1249 return o;
79072805
LW		 1250}
1251
76e3520e 1252STATIC OP *
cea2e8a9 1253S_modkids(pTHX_ OP *o, I32 type)
79072805 1254{
11343788 1255 if (o && o->op_flags & OPf_KIDS) {
6867be6d 1256 OP *kid;
11343788 1257 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
463ee0b2 1258 mod(kid, type);
79072805 1259 }
11343788 1260 return o;
79072805
LW		 1261}
1262
ff7298cb 1263/* Propagate lvalue ("modifiable") context to an op and its children.
ddeae0f1
DM		 1264 * 'type' represents the context type, roughly based on the type of op that
1265 * would do the modifying, although local() is represented by OP_NULL.
1266 * It's responsible for detecting things that can't be modified, flag
1267 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1268 * might have to vivify a reference in $x), and so on.
1269 *
1270 * For example, "$a+1 = 2" would cause mod() to be called with o being
1271 * OP_ADD and type being OP_SASSIGN, and would output an error.
1272 */
1273
79072805 1274OP *
864dbfa3 1275Perl_mod(pTHX_ OP *o, I32 type)
79072805 1276{
27da23d5 1277 dVAR;
79072805 1278 OP *kid;
ddeae0f1
DM		 1279 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1280 int localize = -1;
79072805 1281
13765c85 1282 if (!o || (PL_parser && PL_parser->error_count))
11343788 1283 return o;
79072805 1284
b162f9ea 1285 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS		 1286 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1287 {
b162f9ea 1288 return o;
7e363e51 1289 }
1c846c1f 1290
11343788 1291 switch (o->op_type) {
68dc0745 1292 case OP_UNDEF:
ddeae0f1 1293 localize = 0;
3280af22 1294 PL_modcount++;
5dc0d613 1295 return o;
a0d0e21e 1296 case OP_CONST:
2e0ae2d3 1297 if (!(o->op_private & OPpCONST_ARYBASE))
a0d0e21e 1298 goto nomod;
54dc0f91 1299 localize = 0;
3280af22 1300 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
fc15ae8f
NC		 1301 CopARYBASE_set(&PL_compiling,
1302 (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
3280af22 1303 PL_eval_start = 0;
a0d0e21e
LW		 1304 }
1305 else if (!type) {
fc15ae8f
NC		 1306 SAVECOPARYBASE(&PL_compiling);
1307 CopARYBASE_set(&PL_compiling, 0);
a0d0e21e
LW		 1308 }
1309 else if (type == OP_REFGEN)
1310 goto nomod;
1311 else
cea2e8a9 1312 Perl_croak(aTHX_ "That use of $[ is unsupported");
a0d0e21e 1313 break;
5f05dabc 1314 case OP_STUB:
58bde88d 1315 if ((o->op_flags & OPf_PARENS) || PL_madskills)
5f05dabc 1316 break;
1317 goto nomod;
a0d0e21e
LW		 1318 case OP_ENTERSUB:
1319 if ((type == OP_UNDEF || type == OP_REFGEN) &&
11343788
MB		 1320 !(o->op_flags & OPf_STACKED)) {
1321 o->op_type = OP_RV2CV; /* entersub => rv2cv */
e26df76a
NC		 1322 /* The default is to set op_private to the number of children,
1323 which for a UNOP such as RV2CV is always 1. And w're using
1324 the bit for a flag in RV2CV, so we need it clear. */
1325 o->op_private &= ~1;
22c35a8c 1326 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
11343788 1327 assert(cUNOPo->op_first->op_type == OP_NULL);
93c66552 1328 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
79072805
LW		 1329 break;
1330 }
95f0a2f1
SB		 1331 else if (o->op_private & OPpENTERSUB_NOMOD)
1332 return o;
cd06dffe
GS		 1333 else { /* lvalue subroutine call */
1334 o->op_private |= OPpLVAL_INTRO;
e6438c1a 1335 PL_modcount = RETURN_UNLIMITED_NUMBER;
4978d6d9 1336 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
cd06dffe
GS		 1337 /* Backward compatibility mode: */
1338 o->op_private |= OPpENTERSUB_INARGS;
1339 break;
1340 }
1341 else { /* Compile-time error message: */
1342 OP *kid = cUNOPo->op_first;
1343 CV *cv;
1344 OP *okid;
1345
3ea285d1
AL		 1346 if (kid->op_type != OP_PUSHMARK) {
1347 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1348 Perl_croak(aTHX_
1349 "panic: unexpected lvalue entersub "
1350 "args: type/targ %ld:%"UVuf,
1351 (long)kid->op_type, (UV)kid->op_targ);
1352 kid = kLISTOP->op_first;
1353 }
cd06dffe
GS		 1354 while (kid->op_sibling)
1355 kid = kid->op_sibling;
1356 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1357 /* Indirect call */
1358 if (kid->op_type == OP_METHOD_NAMED
1359 || kid->op_type == OP_METHOD)
1360 {
87d7fd28 1361 UNOP *newop;
b2ffa427 1362
87d7fd28 1363 NewOp(1101, newop, 1, UNOP);
349fd7b7
GS		 1364 newop->op_type = OP_RV2CV;
1365 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
5f66b61c 1366 newop->op_first = NULL;
87d7fd28
GS		 1367 newop->op_next = (OP*)newop;
1368 kid->op_sibling = (OP*)newop;
349fd7b7 1369 newop->op_private |= OPpLVAL_INTRO;
e26df76a 1370 newop->op_private &= ~1;
cd06dffe
GS		 1371 break;
1372 }
b2ffa427 1373
cd06dffe
GS		 1374 if (kid->op_type != OP_RV2CV)
1375 Perl_croak(aTHX_
1376 "panic: unexpected lvalue entersub "
55140b79 1377 "entry via type/targ %ld:%"UVuf,
3d811634 1378 (long)kid->op_type, (UV)kid->op_targ);
cd06dffe
GS		 1379 kid->op_private |= OPpLVAL_INTRO;
1380 break; /* Postpone until runtime */
1381 }
b2ffa427
NIS		 1382
1383 okid = kid;
cd06dffe
GS		 1384 kid = kUNOP->op_first;
1385 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1386 kid = kUNOP->op_first;
b2ffa427 1387 if (kid->op_type == OP_NULL)
cd06dffe
GS		 1388 Perl_croak(aTHX_
1389 "Unexpected constant lvalue entersub "
55140b79 1390 "entry via type/targ %ld:%"UVuf,
3d811634 1391 (long)kid->op_type, (UV)kid->op_targ);
cd06dffe
GS		 1392 if (kid->op_type != OP_GV) {
1393 /* Restore RV2CV to check lvalueness */
1394 restore_2cv:
1395 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1396 okid->op_next = kid->op_next;
1397 kid->op_next = okid;
1398 }
1399 else
5f66b61c 1400 okid->op_next = NULL;
cd06dffe
GS		 1401 okid->op_type = OP_RV2CV;
1402 okid->op_targ = 0;
1403 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1404 okid->op_private |= OPpLVAL_INTRO;
e26df76a 1405 okid->op_private &= ~1;
cd06dffe
GS		 1406 break;
1407 }
b2ffa427 1408
638eceb6 1409 cv = GvCV(kGVOP_gv);
1c846c1f 1410 if (!cv)
cd06dffe
GS		 1411 goto restore_2cv;
1412 if (CvLVALUE(cv))
1413 break;
1414 }
1415 }
79072805
LW		 1416 /* FALL THROUGH */
1417 default:
a0d0e21e 1418 nomod:
6fbb66d6
NC		 1419 /* grep, foreach, subcalls, refgen */
1420 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
a0d0e21e 1421 break;
cea2e8a9 1422 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
638bc118 1423 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
cd06dffe
GS		 1424 ? "do block"
1425 : (o->op_type == OP_ENTERSUB
1426 ? "non-lvalue subroutine call"
53e06cf0 1427 : OP_DESC(o))),
22c35a8c 1428 type ? PL_op_desc[type] : "local"));
11343788 1429 return o;
79072805 1430
a0d0e21e
LW		 1431 case OP_PREINC:
1432 case OP_PREDEC:
1433 case OP_POW:
1434 case OP_MULTIPLY:
1435 case OP_DIVIDE:
1436 case OP_MODULO:
1437 case OP_REPEAT:
1438 case OP_ADD:
1439 case OP_SUBTRACT:
1440 case OP_CONCAT:
1441 case OP_LEFT_SHIFT:
1442 case OP_RIGHT_SHIFT:
1443 case OP_BIT_AND:
1444 case OP_BIT_XOR:
1445 case OP_BIT_OR:
1446 case OP_I_MULTIPLY:
1447 case OP_I_DIVIDE:
1448 case OP_I_MODULO:
1449 case OP_I_ADD:
1450 case OP_I_SUBTRACT:
11343788 1451 if (!(o->op_flags & OPf_STACKED))
a0d0e21e 1452 goto nomod;
3280af22 1453 PL_modcount++;
a0d0e21e 1454 break;
b2ffa427 1455
79072805 1456 case OP_COND_EXPR:
ddeae0f1 1457 localize = 1;
11343788 1458 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
463ee0b2 1459 mod(kid, type);
79072805
LW		 1460 break;
1461
1462 case OP_RV2AV:
1463 case OP_RV2HV:
11343788 1464 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
e6438c1a 1465 PL_modcount = RETURN_UNLIMITED_NUMBER;
11343788 1466 return o; /* Treat \(@foo) like ordinary list. */
748a9306
LW		 1467 }
1468 /* FALL THROUGH */
79072805 1469 case OP_RV2GV:
5dc0d613 1470 if (scalar_mod_type(o, type))
3fe9a6f1 1471 goto nomod;
11343788 1472 ref(cUNOPo->op_first, o->op_type);
79072805 1473 /* FALL THROUGH */
79072805
LW		 1474 case OP_ASLICE:
1475 case OP_HSLICE:
78f9721b
SM		 1476 if (type == OP_LEAVESUBLV)
1477 o->op_private |= OPpMAYBE_LVSUB;
ddeae0f1 1478 localize = 1;
78f9721b
SM		 1479 /* FALL THROUGH */
1480 case OP_AASSIGN:
93a17b20
LW		 1481 case OP_NEXTSTATE:
1482 case OP_DBSTATE:
e6438c1a 1483 PL_modcount = RETURN_UNLIMITED_NUMBER;
79072805 1484 break;
463ee0b2 1485 case OP_RV2SV:
aeea060c 1486 ref(cUNOPo->op_first, o->op_type);
ddeae0f1 1487 localize = 1;
463ee0b2 1488 /* FALL THROUGH */
79072805 1489 case OP_GV:
463ee0b2 1490 case OP_AV2ARYLEN:
3280af22 1491 PL_hints |= HINT_BLOCK_SCOPE;
463ee0b2 1492 case OP_SASSIGN:
bf4b1e52
GS		 1493 case OP_ANDASSIGN:
1494 case OP_ORASSIGN:
c963b151 1495 case OP_DORASSIGN:
ddeae0f1
DM		 1496 PL_modcount++;
1497 break;
1498
8990e307 1499 case OP_AELEMFAST:
6a077020 1500 localize = -1;
3280af22 1501 PL_modcount++;
8990e307
LW		 1502 break;
1503
748a9306
LW		 1504 case OP_PADAV:
1505 case OP_PADHV:
e6438c1a 1506 PL_modcount = RETURN_UNLIMITED_NUMBER;
5196be3e
MB		 1507 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1508 return o; /* Treat \(@foo) like ordinary list. */
1509 if (scalar_mod_type(o, type))
3fe9a6f1 1510 goto nomod;
78f9721b
SM		 1511 if (type == OP_LEAVESUBLV)
1512 o->op_private |= OPpMAYBE_LVSUB;
748a9306
LW		 1513 /* FALL THROUGH */
1514 case OP_PADSV:
3280af22 1515 PL_modcount++;
ddeae0f1 1516 if (!type) /* local() */
cea2e8a9 1517 Perl_croak(aTHX_ "Can't localize lexical variable %s",
dd2155a4 1518 PAD_COMPNAME_PV(o->op_targ));
463ee0b2
LW		 1519 break;
1520
748a9306 1521 case OP_PUSHMARK:
ddeae0f1 1522 localize = 0;
748a9306 1523 break;
b2ffa427 1524
69969c6f
SB		 1525 case OP_KEYS:
1526 if (type != OP_SASSIGN)
1527 goto nomod;
5d82c453
GA		 1528 goto lvalue_func;
1529 case OP_SUBSTR:
1530 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1531 goto nomod;
5f05dabc 1532 /* FALL THROUGH */
a0d0e21e 1533 case OP_POS:
463ee0b2 1534 case OP_VEC:
78f9721b
SM		 1535 if (type == OP_LEAVESUBLV)
1536 o->op_private |= OPpMAYBE_LVSUB;
5d82c453 1537 lvalue_func:
11343788
MB		 1538 pad_free(o->op_targ);
1539 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
5dc0d613 1540 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
11343788
MB		 1541 if (o->op_flags & OPf_KIDS)
1542 mod(cBINOPo->op_first->op_sibling, type);
463ee0b2 1543 break;
a0d0e21e 1544
463ee0b2
LW		 1545 case OP_AELEM:
1546 case OP_HELEM:
11343788 1547 ref(cBINOPo->op_first, o->op_type);
68dc0745 1548 if (type == OP_ENTERSUB &&
5dc0d613
MB		 1549 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1550 o->op_private |= OPpLVAL_DEFER;
78f9721b
SM		 1551 if (type == OP_LEAVESUBLV)
1552 o->op_private |= OPpMAYBE_LVSUB;
ddeae0f1 1553 localize = 1;
3280af22 1554 PL_modcount++;
463ee0b2
LW		 1555 break;
1556
1557 case OP_SCOPE:
1558 case OP_LEAVE:
1559 case OP_ENTER:
78f9721b 1560 case OP_LINESEQ:
ddeae0f1 1561 localize = 0;
11343788
MB		 1562 if (o->op_flags & OPf_KIDS)
1563 mod(cLISTOPo->op_last, type);
a0d0e21e
LW		 1564 break;
1565
1566 case OP_NULL:
ddeae0f1 1567 localize = 0;
638bc118
GS		 1568 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1569 goto nomod;
1570 else if (!(o->op_flags & OPf_KIDS))
463ee0b2 1571 break;
11343788
MB		 1572 if (o->op_targ != OP_LIST) {
1573 mod(cBINOPo->op_first, type);
a0d0e21e
LW		 1574 break;
1575 }
1576 /* FALL THROUGH */
463ee0b2 1577 case OP_LIST:
ddeae0f1 1578 localize = 0;
11343788 1579 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
463ee0b2
LW		 1580 mod(kid, type);
1581 break;
78f9721b
SM		 1582
1583 case OP_RETURN:
1584 if (type != OP_LEAVESUBLV)
1585 goto nomod;
1586 break; /* mod()ing was handled by ck_return() */
463ee0b2 1587 }
58d95175 1588
8be1be90
AMS		 1589 /* [20011101.069] File test operators interpret OPf_REF to mean that
1590 their argument is a filehandle; thus \stat(".") should not set
1591 it. AMS 20011102 */
1592 if (type == OP_REFGEN &&
1593 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1594 return o;
1595
1596 if (type != OP_LEAVESUBLV)
1597 o->op_flags |= OPf_MOD;
1598
1599 if (type == OP_AASSIGN || type == OP_SASSIGN)
1600 o->op_flags |= OPf_SPECIAL|OPf_REF;
ddeae0f1
DM		 1601 else if (!type) { /* local() */
1602 switch (localize) {
1603 case 1:
1604 o->op_private |= OPpLVAL_INTRO;
1605 o->op_flags &= ~OPf_SPECIAL;
1606 PL_hints |= HINT_BLOCK_SCOPE;
1607 break;
1608 case 0:
1609 break;
1610 case -1:
1611 if (ckWARN(WARN_SYNTAX)) {
1612 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1613 "Useless localization of %s", OP_DESC(o));
1614 }
1615 }
463ee0b2 1616 }
8be1be90
AMS		 1617 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1618 && type != OP_LEAVESUBLV)
1619 o->op_flags |= OPf_REF;
11343788 1620 return o;
463ee0b2
LW		 1621}
1622
864dbfa3 1623STATIC bool
5f66b61c 1624S_scalar_mod_type(const OP *o, I32 type)
3fe9a6f1 1625{
1626 switch (type) {
1627 case OP_SASSIGN:
5196be3e 1628 if (o->op_type == OP_RV2GV)
3fe9a6f1 1629 return FALSE;
1630 /* FALL THROUGH */
1631 case OP_PREINC:
1632 case OP_PREDEC:
1633 case OP_POSTINC:
1634 case OP_POSTDEC:
1635 case OP_I_PREINC:
1636 case OP_I_PREDEC:
1637 case OP_I_POSTINC:
1638 case OP_I_POSTDEC:
1639 case OP_POW:
1640 case OP_MULTIPLY:
1641 case OP_DIVIDE:
1642 case OP_MODULO:
1643 case OP_REPEAT:
1644 case OP_ADD:
1645 case OP_SUBTRACT:
1646 case OP_I_MULTIPLY:
1647 case OP_I_DIVIDE:
1648 case OP_I_MODULO:
1649 case OP_I_ADD:
1650 case OP_I_SUBTRACT:
1651 case OP_LEFT_SHIFT:
1652 case OP_RIGHT_SHIFT:
1653 case OP_BIT_AND:
1654 case OP_BIT_XOR:
1655 case OP_BIT_OR:
1656 case OP_CONCAT:
1657 case OP_SUBST:
1658 case OP_TRANS:
49e9fbe6
GS		 1659 case OP_READ:
1660 case OP_SYSREAD:
1661 case OP_RECV:
bf4b1e52
GS		 1662 case OP_ANDASSIGN:
1663 case OP_ORASSIGN:
410d09fe 1664 case OP_DORASSIGN:
3fe9a6f1 1665 return TRUE;
1666 default:
1667 return FALSE;
1668 }
1669}
1670
35cd451c 1671STATIC bool
5f66b61c 1672S_is_handle_constructor(const OP *o, I32 numargs)
35cd451c
GS		 1673{
1674 switch (o->op_type) {
1675 case OP_PIPE_OP:
1676 case OP_SOCKPAIR:
504618e9 1677 if (numargs == 2)
35cd451c
GS		 1678 return TRUE;
1679 /* FALL THROUGH */
1680 case OP_SYSOPEN:
1681 case OP_OPEN:
ded8aa31 1682 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
35cd451c
GS		 1683 case OP_SOCKET:
1684 case OP_OPEN_DIR:
1685 case OP_ACCEPT:
504618e9 1686 if (numargs == 1)
35cd451c 1687 return TRUE;
5f66b61c 1688 /* FALLTHROUGH */
35cd451c
GS		 1689 default:
1690 return FALSE;
1691 }
1692}
1693
463ee0b2 1694OP *
864dbfa3 1695Perl_refkids(pTHX_ OP *o, I32 type)
463ee0b2 1696{
11343788 1697 if (o && o->op_flags & OPf_KIDS) {
6867be6d 1698 OP *kid;
11343788 1699 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
463ee0b2
LW		 1700 ref(kid, type);
1701 }
11343788 1702 return o;
463ee0b2
LW		 1703}
1704
1705OP *
e4c5ccf3 1706Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
463ee0b2 1707{
27da23d5 1708 dVAR;
463ee0b2 1709 OP *kid;
463ee0b2 1710
13765c85 1711 if (!o || (PL_parser && PL_parser->error_count))
11343788 1712 return o;
463ee0b2 1713
11343788 1714 switch (o->op_type) {
a0d0e21e 1715 case OP_ENTERSUB:
afebc493 1716 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
11343788
MB		 1717 !(o->op_flags & OPf_STACKED)) {
1718 o->op_type = OP_RV2CV; /* entersub => rv2cv */
22c35a8c 1719 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
11343788 1720 assert(cUNOPo->op_first->op_type == OP_NULL);
93c66552 1721 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
11343788 1722 o->op_flags |= OPf_SPECIAL;
e26df76a 1723 o->op_private &= ~1;
8990e307
LW		 1724 }
1725 break;
aeea060c 1726
463ee0b2 1727 case OP_COND_EXPR:
11343788 1728 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
e4c5ccf3 1729 doref(kid, type, set_op_ref);
463ee0b2 1730 break;
8990e307 1731 case OP_RV2SV:
35cd451c
GS		 1732 if (type == OP_DEFINED)
1733 o->op_flags |= OPf_SPECIAL; /* don't create GV */
e4c5ccf3 1734 doref(cUNOPo->op_first, o->op_type, set_op_ref);
4633a7c4
LW		 1735 /* FALL THROUGH */
1736 case OP_PADSV:
5f05dabc 1737 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5dc0d613
MB		 1738 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1739 : type == OP_RV2HV ? OPpDEREF_HV
1740 : OPpDEREF_SV);
11343788 1741 o->op_flags |= OPf_MOD;
a0d0e21e 1742 }
8990e307 1743 break;
1c846c1f 1744
463ee0b2
LW		 1745 case OP_RV2AV:
1746 case OP_RV2HV:
e4c5ccf3
RH		 1747 if (set_op_ref)
1748 o->op_flags |= OPf_REF;
8990e307 1749 /* FALL THROUGH */
463ee0b2 1750 case OP_RV2GV:
35cd451c
GS		 1751 if (type == OP_DEFINED)
1752 o->op_flags |= OPf_SPECIAL; /* don't create GV */
e4c5ccf3 1753 doref(cUNOPo->op_first, o->op_type, set_op_ref);
463ee0b2 1754 break;
8990e307 1755
463ee0b2
LW		 1756 case OP_PADAV:
1757 case OP_PADHV:
e4c5ccf3
RH		 1758 if (set_op_ref)
1759 o->op_flags |= OPf_REF;
79072805 1760 break;
aeea060c 1761
8990e307 1762 case OP_SCALAR:
79072805 1763 case OP_NULL:
11343788 1764 if (!(o->op_flags & OPf_KIDS))
463ee0b2 1765 break;
e4c5ccf3 1766 doref(cBINOPo->op_first, type, set_op_ref);
79072805
LW		 1767 break;
1768 case OP_AELEM:
1769 case OP_HELEM:
e4c5ccf3 1770 doref(cBINOPo->op_first, o->op_type, set_op_ref);
5f05dabc 1771 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5dc0d613
MB		 1772 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1773 : type == OP_RV2HV ? OPpDEREF_HV
1774 : OPpDEREF_SV);
11343788 1775 o->op_flags |= OPf_MOD;
8990e307 1776 }
79072805
LW		 1777 break;
1778
463ee0b2 1779 case OP_SCOPE:
79072805 1780 case OP_LEAVE:
e4c5ccf3
RH		 1781 set_op_ref = FALSE;
1782 /* FALL THROUGH */
79072805 1783 case OP_ENTER:
8990e307 1784 case OP_LIST:
11343788 1785 if (!(o->op_flags & OPf_KIDS))
79072805 1786 break;
e4c5ccf3 1787 doref(cLISTOPo->op_last, type, set_op_ref);
79072805 1788 break;
a0d0e21e
LW		 1789 default:
1790 break;
79072805 1791 }
11343788 1792 return scalar(o);
8990e307 1793
79072805
LW		 1794}
1795
09bef843
SB		 1796STATIC OP *
1797S_dup_attrlist(pTHX_ OP *o)
1798{
97aff369 1799 dVAR;
0bd48802 1800 OP *rop;
09bef843
SB		 1801
1802 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1803 * where the first kid is OP_PUSHMARK and the remaining ones
1804 * are OP_CONST. We need to push the OP_CONST values.
1805 */
1806 if (o->op_type == OP_CONST)
b37c2d43 1807 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
eb8433b7
NC		 1808#ifdef PERL_MAD
1809 else if (o->op_type == OP_NULL)
1d866c12 1810 rop = NULL;
eb8433b7 1811#endif
09bef843
SB		 1812 else {
1813 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
5f66b61c 1814 rop = NULL;
09bef843
SB		 1815 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1816 if (o->op_type == OP_CONST)
1817 rop = append_elem(OP_LIST, rop,
1818 newSVOP(OP_CONST, o->op_flags,
b37c2d43 1819 SvREFCNT_inc_NN(cSVOPo->op_sv)));
09bef843
SB		 1820 }
1821 }
1822 return rop;
1823}
1824
1825STATIC void
95f0a2f1 1826S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
09bef843 1827{
27da23d5 1828 dVAR;
09bef843
SB		 1829 SV *stashsv;
1830
1831 /* fake up C<use attributes $pkg,$rv,@attrs> */
1832 ENTER; /* need to protect against side-effects of 'use' */
5aaec2b4 1833 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
e4783991 1834
09bef843 1835#define ATTRSMODULE "attributes"
95f0a2f1
SB		 1836#define ATTRSMODULE_PM "attributes.pm"
1837
1838 if (for_my) {
95f0a2f1 1839 /* Don't force the C<use> if we don't need it. */
a4fc7abc 1840 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
95f0a2f1 1841 if (svp && *svp != &PL_sv_undef)
6f207bd3 1842 NOOP; /* already in %INC */
95f0a2f1
SB		 1843 else
1844 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6136c704 1845 newSVpvs(ATTRSMODULE), NULL);
95f0a2f1
SB		 1846 }
1847 else {
1848 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
6136c704
AL		 1849 newSVpvs(ATTRSMODULE),
1850 NULL,
95f0a2f1
SB		 1851 prepend_elem(OP_LIST,
1852 newSVOP(OP_CONST, 0, stashsv),
1853 prepend_elem(OP_LIST,
1854 newSVOP(OP_CONST, 0,
1855 newRV(target)),
1856 dup_attrlist(attrs))));
1857 }
09bef843
SB		 1858 LEAVE;
1859}
1860
95f0a2f1
SB		 1861STATIC void
1862S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1863{
97aff369 1864 dVAR;
95f0a2f1
SB		 1865 OP *pack, *imop, *arg;
1866 SV *meth, *stashsv;
1867
1868 if (!attrs)
1869 return;
1870
1871 assert(target->op_type == OP_PADSV ||
1872 target->op_type == OP_PADHV ||
1873 target->op_type == OP_PADAV);
1874
1875 /* Ensure that attributes.pm is loaded. */
dd2155a4 1876 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
95f0a2f1
SB		 1877
1878 /* Need package name for method call. */
6136c704 1879 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
95f0a2f1
SB		 1880
1881 /* Build up the real arg-list. */
5aaec2b4
NC		 1882 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1883
95f0a2f1
SB		 1884 arg = newOP(OP_PADSV, 0);
1885 arg->op_targ = target->op_targ;
1886 arg = prepend_elem(OP_LIST,
1887 newSVOP(OP_CONST, 0, stashsv),
1888 prepend_elem(OP_LIST,
1889 newUNOP(OP_REFGEN, 0,
1890 mod(arg, OP_REFGEN)),
1891 dup_attrlist(attrs)));
1892
1893 /* Fake up a method call to import */
18916d0d 1894 meth = newSVpvs_share("import");
95f0a2f1
SB		 1895 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1896 append_elem(OP_LIST,
1897 prepend_elem(OP_LIST, pack, list(arg)),
1898 newSVOP(OP_METHOD_NAMED, 0, meth)));
1899 imop->op_private |= OPpENTERSUB_NOMOD;
1900
1901 /* Combine the ops. */
1902 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1903}
1904
1905/*
1906=notfor apidoc apply_attrs_string
1907
1908Attempts to apply a list of attributes specified by the C<attrstr> and
1909C<len> arguments to the subroutine identified by the C<cv> argument which
1910is expected to be associated with the package identified by the C<stashpv>
1911argument (see L<attributes>). It gets this wrong, though, in that it
1912does not correctly identify the boundaries of the individual attribute
1913specifications within C<attrstr>. This is not really intended for the
1914public API, but has to be listed here for systems such as AIX which
1915need an explicit export list for symbols. (It's called from XS code
1916in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1917to respect attribute syntax properly would be welcome.
1918
1919=cut
1920*/
1921
be3174d2 1922void
6867be6d
AL		 1923Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1924 const char *attrstr, STRLEN len)
be3174d2 1925{
5f66b61c 1926 OP *attrs = NULL;
be3174d2
GS		 1927
1928 if (!len) {
1929 len = strlen(attrstr);
1930 }
1931
1932 while (len) {
1933 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1934 if (len) {
890ce7af 1935 const char * const sstr = attrstr;
be3174d2
GS		 1936 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1937 attrs = append_elem(OP_LIST, attrs,
1938 newSVOP(OP_CONST, 0,
1939 newSVpvn(sstr, attrstr-sstr)));
1940 }
1941 }
1942
1943 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
6136c704 1944 newSVpvs(ATTRSMODULE),
a0714e2c 1945 NULL, prepend_elem(OP_LIST,
be3174d2
GS		 1946 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1947 prepend_elem(OP_LIST,
1948 newSVOP(OP_CONST, 0,
1949 newRV((SV*)cv)),
1950 attrs)));
1951}
1952
09bef843 1953STATIC OP *
95f0a2f1 1954S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
93a17b20 1955{
97aff369 1956 dVAR;
93a17b20
LW		 1957 I32 type;
1958
13765c85 1959 if (!o || (PL_parser && PL_parser->error_count))
11343788 1960 return o;
93a17b20 1961
bc61e325 1962 type = o->op_type;
eb8433b7
NC		 1963 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
1964 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
1965 return o;
1966 }
1967
93a17b20 1968 if (type == OP_LIST) {
6867be6d 1969 OP *kid;
11343788 1970 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
95f0a2f1 1971 my_kid(kid, attrs, imopsp);
eb8433b7
NC		 1972 } else if (type == OP_UNDEF
1973#ifdef PERL_MAD
1974 || type == OP_STUB
1975#endif
1976 ) {
7766148a 1977 return o;
77ca0c92
LW		 1978 } else if (type == OP_RV2SV || /* "our" declaration */
1979 type == OP_RV2AV ||
1980 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1ce0b88c 1981 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
fab01b8e 1982 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
952306ac 1983 OP_DESC(o),
12bd6ede
DM		 1984 PL_parser->in_my == KEY_our
1985 ? "our"
1986 : PL_parser->in_my == KEY_state ? "state" : "my"));
1ce0b88c 1987 } else if (attrs) {
551405c4 1988 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
12bd6ede
DM		 1989 PL_parser->in_my = FALSE;
1990 PL_parser->in_my_stash = NULL;
1ce0b88c
RGS		 1991 apply_attrs(GvSTASH(gv),
1992 (type == OP_RV2SV ? GvSV(gv) :
1993 type == OP_RV2AV ? (SV*)GvAV(gv) :
1994 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1995 attrs, FALSE);
1996 }
192587c2 1997 o->op_private |= OPpOUR_INTRO;
77ca0c92 1998 return o;
95f0a2f1
SB		 1999 }
2000 else if (type != OP_PADSV &&
93a17b20
LW		 2001 type != OP_PADAV &&
2002 type != OP_PADHV &&
2003 type != OP_PUSHMARK)
2004 {
eb64745e 2005 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
53e06cf0 2006 OP_DESC(o),
12bd6ede
DM		 2007 PL_parser->in_my == KEY_our
2008 ? "our"
2009 : PL_parser->in_my == KEY_state ? "state" : "my"));
11343788 2010 return o;
93a17b20 2011 }
09bef843
SB		 2012 else if (attrs && type != OP_PUSHMARK) {
2013 HV *stash;
09bef843 2014
12bd6ede
DM		 2015 PL_parser->in_my = FALSE;
2016 PL_parser->in_my_stash = NULL;
eb64745e 2017
09bef843 2018 /* check for C<my Dog $spot> when deciding package */
dd2155a4
DM		 2019 stash = PAD_COMPNAME_TYPE(o->op_targ);
2020 if (!stash)
09bef843 2021 stash = PL_curstash;
95f0a2f1 2022 apply_attrs_my(stash, o, attrs, imopsp);
09bef843 2023 }
11343788
MB		 2024 o->op_flags |= OPf_MOD;
2025 o->op_private |= OPpLVAL_INTRO;
12bd6ede 2026 if (PL_parser->in_my == KEY_state)
952306ac 2027 o->op_private |= OPpPAD_STATE;
11343788 2028 return o;
93a17b20
LW		 2029}
2030
2031OP *
09bef843
SB		 2032Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2033{
97aff369 2034 dVAR;
0bd48802 2035 OP *rops;
95f0a2f1
SB		 2036 int maybe_scalar = 0;
2037
d2be0de5 2038/* [perl #17376]: this appears to be premature, and results in code such as
c754c3d7 2039 C< our(%x); > executing in list mode rather than void mode */
d2be0de5 2040#if 0
09bef843
SB		 2041 if (o->op_flags & OPf_PARENS)
2042 list(o);
95f0a2f1
SB		 2043 else
2044 maybe_scalar = 1;
d2be0de5
YST		 2045#else
2046 maybe_scalar = 1;
2047#endif
09bef843
SB		 2048 if (attrs)
2049 SAVEFREEOP(attrs);
5f66b61c 2050 rops = NULL;
95f0a2f1
SB		 2051 o = my_kid(o, attrs, &rops);
2052 if (rops) {
2053 if (maybe_scalar && o->op_type == OP_PADSV) {
2054 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
2055 o->op_private |= OPpLVAL_INTRO;
2056 }
2057 else
2058 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
2059 }
12bd6ede
DM		 2060 PL_parser->in_my = FALSE;
2061 PL_parser->in_my_stash = NULL;
eb64745e 2062 return o;
09bef843
SB		 2063}
2064
2065OP *
2066Perl_my(pTHX_ OP *o)
2067{
5f66b61c 2068 return my_attrs(o, NULL);
09bef843
SB		 2069}
2070
2071OP *
864dbfa3 2072Perl_sawparens(pTHX_ OP *o)
79072805 2073{
96a5add6 2074 PERL_UNUSED_CONTEXT;
79072805
LW		 2075 if (o)
2076 o->op_flags |= OPf_PARENS;
2077 return o;
2078}
2079
2080OP *
864dbfa3 2081Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
79072805 2082{
11343788 2083 OP *o;
59f00321 2084 bool ismatchop = 0;
1496a290
AL		 2085 const OPCODE ltype = left->op_type;
2086 const OPCODE rtype = right->op_type;
79072805 2087
1496a290
AL		 2088 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2089 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
041457d9 2090 {
1496a290 2091 const char * const desc
666ea192
JH		 2092 = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
2093 ? (int)rtype : OP_MATCH];
2094 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
2095 ? "@array" : "%hash");
9014280d 2096 Perl_warner(aTHX_ packWARN(WARN_MISC),
1c846c1f 2097 "Applying %s to %s will act on scalar(%s)",
599cee73 2098 desc, sample, sample);
2ae324a7 2099 }
2100
1496a290 2101 if (rtype == OP_CONST &&
5cc9e5c9
RH		 2102 cSVOPx(right)->op_private & OPpCONST_BARE &&
2103 cSVOPx(right)->op_private & OPpCONST_STRICT)
2104 {
2105 no_bareword_allowed(right);
2106 }
2107
1496a290
AL		 2108 ismatchop = rtype == OP_MATCH ||
2109 rtype == OP_SUBST ||
2110 rtype == OP_TRANS;
59f00321
RGS		 2111 if (ismatchop && right->op_private & OPpTARGET_MY) {
2112 right->op_targ = 0;
2113 right->op_private &= ~OPpTARGET_MY;
2114 }
2115 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1496a290
AL		 2116 OP *newleft;
2117
79072805 2118 right->op_flags |= OPf_STACKED;
1496a290
AL		 2119 if (rtype != OP_MATCH &&
2120 ! (rtype == OP_TRANS &&
6fbb66d6 2121 right->op_private & OPpTRANS_IDENTICAL))
1496a290
AL		 2122 newleft = mod(left, rtype);
2123 else
2124 newleft = left;
79072805 2125 if (right->op_type == OP_TRANS)
1496a290 2126 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
79072805 2127 else
1496a290 2128 o = prepend_elem(rtype, scalar(newleft), right);
79072805 2129 if (type == OP_NOT)
11343788
MB		 2130 return newUNOP(OP_NOT, 0, scalar(o));
2131 return o;
79072805
LW		 2132 }
2133 else
2134 return bind_match(type, left,
131b3ad0 2135 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
79072805
LW		 2136}
2137
2138OP *
864dbfa3 2139Perl_invert(pTHX_ OP *o)
79072805 2140{
11343788 2141 if (!o)
1d866c12 2142 return NULL;
11343788 2143 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
79072805
LW		 2144}
2145
2146OP *
864dbfa3 2147Perl_scope(pTHX_ OP *o)
79072805 2148{
27da23d5 2149 dVAR;
79072805 2150 if (o) {
3280af22 2151 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
463ee0b2
LW		 2152 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2153 o->op_type = OP_LEAVE;
22c35a8c 2154 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
463ee0b2 2155 }
fdb22418
HS		 2156 else if (o->op_type == OP_LINESEQ) {
2157 OP *kid;
2158 o->op_type = OP_SCOPE;
2159 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2160 kid = ((LISTOP*)o)->op_first;
59110972 2161 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
fdb22418 2162 op_null(kid);
59110972
RH		 2163
2164 /* The following deals with things like 'do {1 for 1}' */
2165 kid = kid->op_sibling;
2166 if (kid &&
2167 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2168 op_null(kid);
2169 }
463ee0b2 2170 }
fdb22418 2171 else
5f66b61c 2172 o = newLISTOP(OP_SCOPE, 0, o, NULL);
79072805
LW		 2173 }
2174 return o;
2175}
72dc9ed5 2176
a0d0e21e 2177int
864dbfa3 2178Perl_block_start(pTHX_ int full)
79072805 2179{
97aff369 2180 dVAR;
73d840c0 2181 const int retval = PL_savestack_ix;
dd2155a4 2182 pad_block_start(full);
b3ac6de7 2183 SAVEHINTS();
3280af22 2184 PL_hints &= ~HINT_BLOCK_SCOPE;
68da3b2f 2185 SAVECOMPILEWARNINGS();
72dc9ed5 2186 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
a0d0e21e
LW		 2187 return retval;
2188}
2189
2190OP*
864dbfa3 2191Perl_block_end(pTHX_ I32 floor, OP *seq)
a0d0e21e 2192{
97aff369 2193 dVAR;
6867be6d 2194 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
551405c4 2195 OP* const retval = scalarseq(seq);
e9818f4e 2196 LEAVE_SCOPE(floor);
623e6609 2197 CopHINTS_set(&PL_compiling, PL_hints);
a0d0e21e 2198 if (needblockscope)
3280af22 2199 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
dd2155a4 2200 pad_leavemy();
a0d0e21e
LW		 2201 return retval;
2202}
2203
76e3520e 2204STATIC OP *
cea2e8a9 2205S_newDEFSVOP(pTHX)
54b9620d 2206{
97aff369 2207 dVAR;
9f7d9405 2208 const PADOFFSET offset = pad_findmy("$_");
00b1698f 2209 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
59f00321
RGS		 2210 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2211 }
2212 else {
551405c4 2213 OP * const o = newOP(OP_PADSV, 0);
59f00321
RGS		 2214 o->op_targ = offset;
2215 return o;
2216 }
54b9620d
MB		 2217}
2218
a0d0e21e 2219void
864dbfa3 2220Perl_newPROG(pTHX_ OP *o)
a0d0e21e 2221{
97aff369 2222 dVAR;
3280af22 2223 if (PL_in_eval) {
b295d113
TH		 2224 if (PL_eval_root)
2225 return;
faef0170
HS		 2226 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2227 ((PL_in_eval & EVAL_KEEPERR)
2228 ? OPf_SPECIAL : 0), o);
3280af22 2229 PL_eval_start = linklist(PL_eval_root);
7934575e
GS		 2230 PL_eval_root->op_private |= OPpREFCOUNTED;
2231 OpREFCNT_set(PL_eval_root, 1);
3280af22 2232 PL_eval_root->op_next = 0;
a2efc822 2233 CALL_PEEP(PL_eval_start);
a0d0e21e
LW		 2234 }
2235 else {
6be89cf9
AE		 2236 if (o->op_type == OP_STUB) {
2237 PL_comppad_name = 0;
2238 PL_compcv = 0;
d2c837a0 2239 S_op_destroy(aTHX_ o);
a0d0e21e 2240 return;
6be89cf9 2241 }
3280af22
NIS		 2242 PL_main_root = scope(sawparens(scalarvoid(o)));
2243 PL_curcop = &PL_compiling;
2244 PL_main_start = LINKLIST(PL_main_root);
7934575e
GS		 2245 PL_main_root->op_private |= OPpREFCOUNTED;
2246 OpREFCNT_set(PL_main_root, 1);
3280af22 2247 PL_main_root->op_next = 0;
a2efc822 2248 CALL_PEEP(PL_main_start);
3280af22 2249 PL_compcv = 0;
3841441e 2250
4fdae800 2251 /* Register with debugger */
84902520 2252 if (PERLDB_INTER) {
780a5241
NC		 2253 CV * const cv
2254 = Perl_get_cvn_flags(aTHX_ STR_WITH_LEN("DB::postponed"), 0);
3841441e
CS		 2255 if (cv) {
2256 dSP;
924508f0 2257 PUSHMARK(SP);
cc49e20b 2258 XPUSHs((SV*)CopFILEGV(&PL_compiling));
3841441e 2259 PUTBACK;
864dbfa3 2260 call_sv((SV*)cv, G_DISCARD);
3841441e
CS		 2261 }
2262 }
79072805 2263 }
79072805
LW		 2264}
2265
2266OP *
864dbfa3 2267Perl_localize(pTHX_ OP *o, I32 lex)
79072805 2268{
97aff369 2269 dVAR;
79072805 2270 if (o->op_flags & OPf_PARENS)
d2be0de5
YST		 2271/* [perl #17376]: this appears to be premature, and results in code such as
2272 C< our(%x); > executing in list mode rather than void mode */
2273#if 0
79072805 2274 list(o);
d2be0de5 2275#else
6f207bd3 2276 NOOP;
d2be0de5 2277#endif
8990e307 2278 else {
f06b5848
DM		 2279 if ( PL_parser->bufptr > PL_parser->oldbufptr
2280 && PL_parser->bufptr[-1] == ','
041457d9 2281 && ckWARN(WARN_PARENTHESIS))
64420d0d 2282 {
f06b5848 2283 char *s = PL_parser->bufptr;
bac662ee 2284 bool sigil = FALSE;
64420d0d 2285
8473848f 2286 /* some heuristics to detect a potential error */
bac662ee 2287 while (*s && (strchr(", \t\n", *s)))
64420d0d 2288 s++;
8473848f 2289
bac662ee
TS		 2290 while (1) {
2291 if (*s && strchr("@$%*", *s) && *++s
2292 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2293 s++;
2294 sigil = TRUE;
2295 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2296 s++;
2297 while (*s && (strchr(", \t\n", *s)))
2298 s++;
2299 }
2300 else
2301 break;
2302 }
2303 if (sigil && (*s == ';' || *s == '=')) {
2304 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
8473848f 2305 "Parentheses missing around \"%s\" list",
12bd6ede
DM		 2306 lex
2307 ? (PL_parser->in_my == KEY_our
2308 ? "our"
2309 : PL_parser->in_my == KEY_state
2310 ? "state"
2311 : "my")
2312 : "local");
8473848f 2313 }
8990e307
LW		 2314 }
2315 }
93a17b20 2316 if (lex)
eb64745e 2317 o = my(o);
93a17b20 2318 else
eb64745e 2319 o = mod(o, OP_NULL); /* a bit kludgey */
12bd6ede
DM		 2320 PL_parser->in_my = FALSE;
2321 PL_parser->in_my_stash = NULL;
eb64745e 2322 return o;
79072805
LW		 2323}
2324
2325OP *
864dbfa3 2326Perl_jmaybe(pTHX_ OP *o)
79072805
LW		 2327{
2328 if (o->op_type == OP_LIST) {
fafc274c 2329 OP * const o2
d4c19fe8 2330 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
554b3eca 2331 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
79072805
LW		 2332 }
2333 return o;
2334}
2335
2336OP *
864dbfa3 2337Perl_fold_constants(pTHX_ register OP *o)
79072805 2338{
27da23d5 2339 dVAR;
79072805 2340 register OP *curop;
eb8433b7 2341 OP *newop;
8ea43dc8 2342 VOL I32 type = o->op_type;
e3cbe32f 2343 SV * VOL sv = NULL;
b7f7fd0b
NC		 2344 int ret = 0;
2345 I32 oldscope;
2346 OP *old_next;
5f2d9966
DM		 2347 SV * const oldwarnhook = PL_warnhook;
2348 SV * const olddiehook = PL_diehook;
b7f7fd0b 2349 dJMPENV;
79072805 2350
22c35a8c 2351 if (PL_opargs[type] & OA_RETSCALAR)
79072805 2352 scalar(o);
b162f9ea 2353 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
ed6116ce 2354 o->op_targ = pad_alloc(type, SVs_PADTMP);
79072805 2355
eac055e9
GS		 2356 /* integerize op, unless it happens to be C<-foo>.
2357 * XXX should pp_i_negate() do magic string negation instead? */
2358 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2359 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2360 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2361 {
22c35a8c 2362 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
eac055e9 2363 }
85e6fe83 2364
22c35a8c 2365 if (!(PL_opargs[type] & OA_FOLDCONST))
79072805
LW		 2366 goto nope;
2367
de939608 2368 switch (type) {
7a52d87a
GS		 2369 case OP_NEGATE:
2370 /* XXX might want a ck_negate() for this */
2371 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2372 break;
de939608
CS		 2373 case OP_UCFIRST:
2374 case OP_LCFIRST:
2375 case OP_UC:
2376 case OP_LC:
69dcf70c
MB		 2377 case OP_SLT:
2378 case OP_SGT:
2379 case OP_SLE:
2380 case OP_SGE:
2381 case OP_SCMP:
2de3dbcc
JH		 2382 /* XXX what about the numeric ops? */
2383 if (PL_hints & HINT_LOCALE)
de939608
CS		 2384 goto nope;
2385 }
2386
13765c85 2387 if (PL_parser && PL_parser->error_count)
a0d0e21e
LW		 2388 goto nope; /* Don't try to run w/ errors */
2389
79072805 2390 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
1496a290
AL		 2391 const OPCODE type = curop->op_type;
2392 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2393 type != OP_LIST &&
2394 type != OP_SCALAR &&
2395 type != OP_NULL &&
2396 type != OP_PUSHMARK)
7a52d87a 2397 {
79072805
LW		 2398 goto nope;
2399 }
2400 }
2401
2402 curop = LINKLIST(o);
b7f7fd0b 2403 old_next = o->op_next;
79072805 2404 o->op_next = 0;
533c011a 2405 PL_op = curop;
b7f7fd0b
NC		 2406
2407 oldscope = PL_scopestack_ix;
edb2152a 2408 create_eval_scope(G_FAKINGEVAL);
b7f7fd0b 2409
5f2d9966
DM		 2410 PL_warnhook = PERL_WARNHOOK_FATAL;
2411 PL_diehook = NULL;
b7f7fd0b
NC		 2412 JMPENV_PUSH(ret);
2413
2414 switch (ret) {
2415 case 0:
2416 CALLRUNOPS(aTHX);
2417 sv = *(PL_stack_sp--);
2418 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2419 pad_swipe(o->op_targ, FALSE);
2420 else if (SvTEMP(sv)) { /* grab mortal temp? */
2421 SvREFCNT_inc_simple_void(sv);
2422 SvTEMP_off(sv);
2423 }
2424 break;
2425 case 3:
2426 /* Something tried to die. Abandon constant folding. */
2427 /* Pretend the error never happened. */
2428 sv_setpvn(ERRSV,"",0);
2429 o->op_next = old_next;
2430 break;
2431 default:
2432 JMPENV_POP;
5f2d9966
DM		 2433 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2434 PL_warnhook = oldwarnhook;
2435 PL_diehook = olddiehook;
2436 /* XXX note that this croak may fail as we've already blown away
2437 * the stack - eg any nested evals */
b7f7fd0b
NC		 2438 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2439 }
b7f7fd0b 2440 JMPENV_POP;
5f2d9966
DM		 2441 PL_warnhook = oldwarnhook;
2442 PL_diehook = olddiehook;
edb2152a
NC		 2443
2444 if (PL_scopestack_ix > oldscope)
2445 delete_eval_scope();
eb8433b7 2446
b7f7fd0b
NC		 2447 if (ret)
2448 goto nope;
2449
eb8433b7 2450#ifndef PERL_MAD
79072805 2451 op_free(o);
eb8433b7 2452#endif
de5e01c2 2453 assert(sv);
79072805 2454 if (type == OP_RV2GV)
eb8433b7
NC		 2455 newop = newGVOP(OP_GV, 0, (GV*)sv);
2456 else
670f1322 2457 newop = newSVOP(OP_CONST, 0, (SV*)sv);
eb8433b7
NC		 2458 op_getmad(o,newop,'f');
2459 return newop;
aeea060c 2460
b7f7fd0b 2461 nope:
79072805
LW		 2462 return o;
2463}
2464
2465OP *
864dbfa3 2466Perl_gen_constant_list(pTHX_ register OP *o)
79072805 2467{
27da23d5 2468 dVAR;
79072805 2469 register OP *curop;
6867be6d 2470 const I32 oldtmps_floor = PL_tmps_floor;
79072805 2471
a0d0e21e 2472 list(o);
13765c85 2473 if (PL_parser && PL_parser->error_count)
a0d0e21e
LW		 2474 return o; /* Don't attempt to run with errors */
2475
533c011a 2476 PL_op = curop = LINKLIST(o);
a0d0e21e 2477 o->op_next = 0;
a2efc822 2478 CALL_PEEP(curop);
cea2e8a9
GS		 2479 pp_pushmark();
2480 CALLRUNOPS(aTHX);
533c011a 2481 PL_op = curop;
78c72037
NC		 2482 assert (!(curop->op_flags & OPf_SPECIAL));
2483 assert(curop->op_type == OP_RANGE);
cea2e8a9 2484 pp_anonlist();
3280af22 2485 PL_tmps_floor = oldtmps_floor;
79072805
LW		 2486
2487 o->op_type = OP_RV2AV;
22c35a8c 2488 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
fb53bbb2
SG		 2489 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2490 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2814eb74 2491 o->op_opt = 0; /* needs to be revisited in peep() */
79072805 2492 curop = ((UNOP*)o)->op_first;
b37c2d43 2493 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
eb8433b7
NC		 2494#ifdef PERL_MAD
2495 op_getmad(curop,o,'O');
2496#else
79072805 2497 op_free(curop);
eb8433b7 2498#endif
79072805
LW		 2499 linklist(o);
2500 return list(o);
2501}
2502
2503OP *
864dbfa3 2504Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
79072805 2505{
27da23d5 2506 dVAR;
11343788 2507 if (!o || o->op_type != OP_LIST)
5f66b61c 2508 o = newLISTOP(OP_LIST, 0, o, NULL);
748a9306 2509 else
5dc0d613 2510 o->op_flags &= ~OPf_WANT;
79072805 2511
22c35a8c 2512 if (!(PL_opargs[type] & OA_MARK))
93c66552 2513 op_null(cLISTOPo->op_first);
8990e307 2514
eb160463 2515 o->op_type = (OPCODE)type;
22c35a8c 2516 o->op_ppaddr = PL_ppaddr[type];
11343788 2517 o->op_flags |= flags;
79072805 2518
11343788 2519 o = CHECKOP(type, o);
fe2774ed 2520 if (o->op_type != (unsigned)type)
11343788 2521 return o;
79072805 2522
11343788 2523 return fold_constants(o);
79072805
LW		 2524}
2525
2526/* List constructors */
2527
2528OP *
864dbfa3 2529Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW		 2530{
2531 if (!first)
2532 return last;
8990e307
LW		 2533
2534 if (!last)
79072805 2535 return first;
8990e307 2536
fe2774ed 2537 if (first->op_type != (unsigned)type
155aba94
GS		 2538 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2539 {
2540 return newLISTOP(type, 0, first, last);
2541 }
79072805 2542
a0d0e21e
LW		 2543 if (first->op_flags & OPf_KIDS)
2544 ((LISTOP*)first)->op_last->op_sibling = last;
2545 else {
2546 first->op_flags |= OPf_KIDS;
2547 ((LISTOP*)first)->op_first = last;
2548 }
2549 ((LISTOP*)first)->op_last = last;
a0d0e21e 2550 return first;
79072805
LW		 2551}
2552
2553OP *
864dbfa3 2554Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
79072805
LW		 2555{
2556 if (!first)
2557 return (OP*)last;
8990e307
LW		 2558
2559 if (!last)
79072805 2560 return (OP*)first;
8990e307 2561
fe2774ed 2562 if (first->op_type != (unsigned)type)
79072805 2563 return prepend_elem(type, (OP*)first, (OP*)last);
8990e307 2564
fe2774ed 2565 if (last->op_type != (unsigned)type)
79072805
LW		 2566 return append_elem(type, (OP*)first, (OP*)last);
2567
2568 first->op_last->op_sibling = last->op_first;
2569 first->op_last = last->op_last;
117dada2 2570 first->op_flags |= (last->op_flags & OPf_KIDS);
1c846c1f 2571
eb8433b7
NC		 2572#ifdef PERL_MAD
2573 if (last->op_first && first->op_madprop) {
2574 MADPROP *mp = last->op_first->op_madprop;
2575 if (mp) {
2576 while (mp->mad_next)
2577 mp = mp->mad_next;
2578 mp->mad_next = first->op_madprop;
2579 }
2580 else {
2581 last->op_first->op_madprop = first->op_madprop;
2582 }
2583 }
2584 first->op_madprop = last->op_madprop;
2585 last->op_madprop = 0;
2586#endif
2587
d2c837a0 2588 S_op_destroy(aTHX_ (OP*)last);
238a4c30 2589
79072805
LW		 2590 return (OP*)first;
2591}
2592
2593OP *
864dbfa3 2594Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW		 2595{
2596 if (!first)
2597 return last;
8990e307
LW		 2598
2599 if (!last)
79072805 2600 return first;
8990e307 2601
fe2774ed 2602 if (last->op_type == (unsigned)type) {
8990e307
LW		 2603 if (type == OP_LIST) { /* already a PUSHMARK there */
2604 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2605 ((LISTOP*)last)->op_first->op_sibling = first;
36a5d4ba
DC		 2606 if (!(first->op_flags & OPf_PARENS))
2607 last->op_flags &= ~OPf_PARENS;
8990e307
LW		 2608 }
2609 else {
2610 if (!(last->op_flags & OPf_KIDS)) {
2611 ((LISTOP*)last)->op_last = first;
2612 last->op_flags |= OPf_KIDS;
2613 }
2614 first->op_sibling = ((LISTOP*)last)->op_first;
2615 ((LISTOP*)last)->op_first = first;
79072805 2616 }
117dada2 2617 last->op_flags |= OPf_KIDS;
79072805
LW		 2618 return last;
2619 }
2620
2621 return newLISTOP(type, 0, first, last);
2622}
2623
2624/* Constructors */
2625
eb8433b7
NC		 2626#ifdef PERL_MAD
2627
2628TOKEN *
2629Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2630{
2631 TOKEN *tk;
99129197 2632 Newxz(tk, 1, TOKEN);
eb8433b7
NC		 2633 tk->tk_type = (OPCODE)optype;
2634 tk->tk_type = 12345;
2635 tk->tk_lval = lval;
2636 tk->tk_mad = madprop;
2637 return tk;
2638}
2639
2640void
2641Perl_token_free(pTHX_ TOKEN* tk)
2642{
2643 if (tk->tk_type != 12345)
2644 return;
2645 mad_free(tk->tk_mad);
2646 Safefree(tk);
2647}
2648
2649void
2650Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2651{
2652 MADPROP* mp;
2653 MADPROP* tm;
2654 if (tk->tk_type != 12345) {
2655 Perl_warner(aTHX_ packWARN(WARN_MISC),
2656 "Invalid TOKEN object ignored");
2657 return;
2658 }
2659 tm = tk->tk_mad;
2660 if (!tm)
2661 return;
2662
2663 /* faked up qw list? */
2664 if (slot == '(' &&
2665 tm->mad_type == MAD_SV &&
2666 SvPVX((SV*)tm->mad_val)[0] == 'q')
2667 slot = 'x';
2668
2669 if (o) {
2670 mp = o->op_madprop;
2671 if (mp) {
2672 for (;;) {
2673 /* pretend constant fold didn't happen? */
2674 if (mp->mad_key == 'f' &&
2675 (o->op_type == OP_CONST ||
2676 o->op_type == OP_GV) )
2677 {
2678 token_getmad(tk,(OP*)mp->mad_val,slot);
2679 return;
2680 }
2681 if (!mp->mad_next)
2682 break;
2683 mp = mp->mad_next;
2684 }
2685 mp->mad_next = tm;
2686 mp = mp->mad_next;
2687 }
2688 else {
2689 o->op_madprop = tm;
2690 mp = o->op_madprop;
2691 }
2692 if (mp->mad_key == 'X')
2693 mp->mad_key = slot; /* just change the first one */
2694
2695 tk->tk_mad = 0;
2696 }
2697 else
2698 mad_free(tm);
2699 Safefree(tk);
2700}
2701
2702void
2703Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2704{
2705 MADPROP* mp;
2706 if (!from)
2707 return;
2708 if (o) {
2709 mp = o->op_madprop;
2710 if (mp) {
2711 for (;;) {
2712 /* pretend constant fold didn't happen? */
2713 if (mp->mad_key == 'f' &&
2714 (o->op_type == OP_CONST ||
2715 o->op_type == OP_GV) )
2716 {
2717 op_getmad(from,(OP*)mp->mad_val,slot);
2718 return;
2719 }
2720 if (!mp->mad_next)
2721 break;
2722 mp = mp->mad_next;
2723 }
2724 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2725 }
2726 else {
2727 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2728 }
2729 }
2730}
2731
2732void
2733Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2734{
2735 MADPROP* mp;
2736 if (!from)
2737 return;
2738 if (o) {
2739 mp = o->op_madprop;
2740 if (mp) {
2741 for (;;) {
2742 /* pretend constant fold didn't happen? */
2743 if (mp->mad_key == 'f' &&
2744 (o->op_type == OP_CONST ||
2745 o->op_type == OP_GV) )
2746 {
2747 op_getmad(from,(OP*)mp->mad_val,slot);
2748 return;
2749 }
2750 if (!mp->mad_next)
2751 break;
2752 mp = mp->mad_next;
2753 }
2754 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2755 }
2756 else {
2757 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2758 }
2759 }
2760 else {
99129197
NC		 2761 PerlIO_printf(PerlIO_stderr(),
2762 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
eb8433b7
NC		 2763 op_free(from);
2764 }
2765}
2766
2767void
2768Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2769{
2770 MADPROP* tm;
2771 if (!mp || !o)
2772 return;
2773 if (slot)
2774 mp->mad_key = slot;
2775 tm = o->op_madprop;
2776 o->op_madprop = mp;
2777 for (;;) {
2778 if (!mp->mad_next)
2779 break;
2780 mp = mp->mad_next;
2781 }
2782 mp->mad_next = tm;
2783}
2784
2785void
2786Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2787{
2788 if (!o)
2789 return;
2790 addmad(tm, &(o->op_madprop), slot);
2791}
2792
2793void
2794Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2795{
2796 MADPROP* mp;
2797 if (!tm || !root)
2798 return;
2799 if (slot)
2800 tm->mad_key = slot;
2801 mp = *root;
2802 if (!mp) {
2803 *root = tm;
2804 return;
2805 }
2806 for (;;) {
2807 if (!mp->mad_next)
2808 break;
2809 mp = mp->mad_next;
2810 }
2811 mp->mad_next = tm;
2812}
2813
2814MADPROP *
2815Perl_newMADsv(pTHX_ char key, SV* sv)
2816{
2817 return newMADPROP(key, MAD_SV, sv, 0);
2818}
2819
2820MADPROP *
594c10dc 2821Perl_newMADPROP(pTHX_ char key, char type, const void* val, I32 vlen)
eb8433b7
NC		 2822{
2823 MADPROP *mp;
99129197 2824 Newxz(mp, 1, MADPROP);
eb8433b7
NC		 2825 mp->mad_next = 0;
2826 mp->mad_key = key;
2827 mp->mad_vlen = vlen;
2828 mp->mad_type = type;
2829 mp->mad_val = val;
2830/* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
2831 return mp;
2832}
2833
2834void
2835Perl_mad_free(pTHX_ MADPROP* mp)
2836{
2837/* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2838 if (!mp)
2839 return;
2840 if (mp->mad_next)
2841 mad_free(mp->mad_next);
bc177e6b 2842/* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
eb8433b7
NC		 2843 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2844 switch (mp->mad_type) {
2845 case MAD_NULL:
2846 break;
2847 case MAD_PV:
2848 Safefree((char*)mp->mad_val);
2849 break;
2850 case MAD_OP:
2851 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
2852 op_free((OP*)mp->mad_val);
2853 break;
2854 case MAD_SV:
2855 sv_free((SV*)mp->mad_val);
2856 break;
2857 default:
2858 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
2859 break;
2860 }
2861 Safefree(mp);
2862}
2863
2864#endif
2865
79072805 2866OP *
864dbfa3 2867Perl_newNULLLIST(pTHX)
79072805 2868{
8990e307
LW		 2869 return newOP(OP_STUB, 0);
2870}
2871
2872OP *
864dbfa3 2873Perl_force_list(pTHX_ OP *o)
8990e307 2874{
11343788 2875 if (!o || o->op_type != OP_LIST)
5f66b61c 2876 o = newLISTOP(OP_LIST, 0, o, NULL);
93c66552 2877 op_null(o);
11343788 2878 return o;
79072805
LW		 2879}
2880
2881OP *
864dbfa3 2882Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
79072805 2883{
27da23d5 2884 dVAR;
79072805
LW		 2885 LISTOP *listop;
2886
b7dc083c 2887 NewOp(1101, listop, 1, LISTOP);
79072805 2888
eb160463 2889 listop->op_type = (OPCODE)type;
22c35a8c 2890 listop->op_ppaddr = PL_ppaddr[type];
117dada2
SM		 2891 if (first || last)
2892 flags |= OPf_KIDS;
eb160463 2893 listop->op_flags = (U8)flags;
79072805
LW		 2894
2895 if (!last && first)
2896 last = first;
2897 else if (!first && last)
2898 first = last;
8990e307
LW		 2899 else if (first)
2900 first->op_sibling = last;
79072805
LW		 2901 listop->op_first = first;
2902 listop->op_last = last;
8990e307 2903 if (type == OP_LIST) {
551405c4 2904 OP* const pushop = newOP(OP_PUSHMARK, 0);
8990e307
LW		 2905 pushop->op_sibling = first;
2906 listop->op_first = pushop;
2907 listop->op_flags |= OPf_KIDS;
2908 if (!last)
2909 listop->op_last = pushop;
2910 }
79072805 2911
463d09e6 2912 return CHECKOP(type, listop);
79072805
LW		 2913}
2914
2915OP *
864dbfa3 2916Perl_newOP(pTHX_ I32 type, I32 flags)
79072805 2917{
27da23d5 2918 dVAR;
11343788 2919 OP *o;
b7dc083c 2920 NewOp(1101, o, 1, OP);
eb160463 2921 o->op_type = (OPCODE)type;
22c35a8c 2922 o->op_ppaddr = PL_ppaddr[type];
eb160463 2923 o->op_flags = (U8)flags;
670f3923
DM		 2924 o->op_latefree = 0;
2925 o->op_latefreed = 0;
7e5d8ed2 2926 o->op_attached = 0;
79072805 2927
11343788 2928 o->op_next = o;
eb160463 2929 o->op_private = (U8)(0 | (flags >> 8));
22c35a8c 2930 if (PL_opargs[type] & OA_RETSCALAR)
11343788 2931 scalar(o);
22c35a8c 2932 if (PL_opargs[type] & OA_TARGET)
11343788
MB		 2933 o->op_targ = pad_alloc(type, SVs_PADTMP);
2934 return CHECKOP(type, o);
79072805
LW		 2935}
2936
2937OP *
864dbfa3 2938Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
79072805 2939{
27da23d5 2940 dVAR;
79072805
LW		 2941 UNOP *unop;
2942
93a17b20 2943 if (!first)
aeea060c 2944 first = newOP(OP_STUB, 0);
22c35a8c 2945 if (PL_opargs[type] & OA_MARK)
8990e307 2946 first = force_list(first);
93a17b20 2947
b7dc083c 2948 NewOp(1101, unop, 1, UNOP);
eb160463 2949 unop->op_type = (OPCODE)type;
22c35a8c 2950 unop->op_ppaddr = PL_ppaddr[type];
79072805 2951 unop->op_first = first;
585ec06d 2952 unop->op_flags = (U8)(flags | OPf_KIDS);
eb160463 2953 unop->op_private = (U8)(1 | (flags >> 8));
e50aee73 2954 unop = (UNOP*) CHECKOP(type, unop);
79072805
LW		 2955 if (unop->op_next)
2956 return (OP*)unop;
2957
a0d0e21e 2958 return fold_constants((OP *) unop);
79072805
LW		 2959}
2960
2961OP *
864dbfa3 2962Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
79072805 2963{
27da23d5 2964 dVAR;
79072805 2965 BINOP *binop;
b7dc083c 2966 NewOp(1101, binop, 1, BINOP);
79072805
LW		 2967
2968 if (!first)
2969 first = newOP(OP_NULL, 0);
2970
eb160463 2971 binop->op_type = (OPCODE)type;
22c35a8c 2972 binop->op_ppaddr = PL_ppaddr[type];
79072805 2973 binop->op_first = first;
585ec06d 2974 binop->op_flags = (U8)(flags | OPf_KIDS);
79072805
LW		 2975 if (!last) {
2976 last = first;
eb160463 2977 binop->op_private = (U8)(1 | (flags >> 8));
79072805
LW		 2978 }
2979 else {
eb160463 2980 binop->op_private = (U8)(2 | (flags >> 8));
79072805
LW		 2981 first->op_sibling = last;
2982 }
2983
e50aee73 2984 binop = (BINOP*)CHECKOP(type, binop);
eb160463 2985 if (binop->op_next || binop->op_type != (OPCODE)type)
79072805
LW		 2986 return (OP*)binop;
2987
7284ab6f 2988 binop->op_last = binop->op_first->op_sibling;
79072805 2989
a0d0e21e 2990 return fold_constants((OP *)binop);
79072805
LW		 2991}
2992
5f66b61c
AL		 2993static int uvcompare(const void *a, const void *b)
2994 __attribute__nonnull__(1)
2995 __attribute__nonnull__(2)
2996 __attribute__pure__;
abb2c242 2997static int uvcompare(const void *a, const void *b)
2b9d42f0 2998{
e1ec3a88 2999 if (*((const UV *)a) < (*(const UV *)b))
2b9d42f0 3000 return -1;
e1ec3a88 3001 if (*((const UV *)a) > (*(const UV *)b))
2b9d42f0 3002 return 1;
e1ec3a88 3003 if (*((const UV *)a+1) < (*(const UV *)b+1))
2b9d42f0 3004 return -1;
e1ec3a88 3005 if (*((const UV *)a+1) > (*(const UV *)b+1))
2b9d42f0 3006 return 1;
a0ed51b3
LW		 3007 return 0;
3008}
3009
79072805 3010OP *
864dbfa3 3011Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
79072805 3012{
97aff369 3013 dVAR;
2d03de9c 3014 SV * const tstr = ((SVOP*)expr)->op_sv;
fbbb0949
DM		 3015 SV * const rstr =
3016#ifdef PERL_MAD
3017 (repl->op_type == OP_NULL)
3018 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3019#endif
3020 ((SVOP*)repl)->op_sv;
463ee0b2
LW		 3021 STRLEN tlen;
3022 STRLEN rlen;
5c144d81
NC		 3023 const U8 *t = (U8*)SvPV_const(tstr, tlen);
3024 const U8 *r = (U8*)SvPV_const(rstr, rlen);
79072805
LW		 3025 register I32 i;
3026 register I32 j;
9b877dbb 3027 I32 grows = 0;
79072805
LW		 3028 register short *tbl;
3029
551405c4
AL		 3030 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3031 const I32 squash = o->op_private & OPpTRANS_SQUASH;
3032 I32 del = o->op_private & OPpTRANS_DELETE;
043e41b8 3033 SV* swash;
800b4dc4 3034 PL_hints |= HINT_BLOCK_SCOPE;
1c846c1f 3035
036b4402
GS		 3036 if (SvUTF8(tstr))
3037 o->op_private |= OPpTRANS_FROM_UTF;
1c846c1f
NIS		 3038
3039 if (SvUTF8(rstr))
036b4402 3040 o->op_private |= OPpTRANS_TO_UTF;
79072805 3041
a0ed51b3 3042 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
396482e1 3043 SV* const listsv = newSVpvs("# comment\n");
c445ea15 3044 SV* transv = NULL;
5c144d81
NC		 3045 const U8* tend = t + tlen;
3046 const U8* rend = r + rlen;
ba210ebe 3047 STRLEN ulen;
84c133a0
RB		 3048 UV tfirst = 1;
3049 UV tlast = 0;
3050 IV tdiff;
3051 UV rfirst = 1;
3052 UV rlast = 0;
3053 IV rdiff;
3054 IV diff;
a0ed51b3
LW		 3055 I32 none = 0;
3056 U32 max = 0;
3057 I32 bits;
a0ed51b3 3058 I32 havefinal = 0;
9c5ffd7c 3059 U32 final = 0;
551405c4
AL		 3060 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
3061 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
bf4a1e57
JH		 3062 U8* tsave = NULL;
3063 U8* rsave = NULL;
9f7f3913 3064 const U32 flags = UTF8_ALLOW_DEFAULT;
bf4a1e57
JH		 3065
3066 if (!from_utf) {
3067 STRLEN len = tlen;
5c144d81 3068 t = tsave = bytes_to_utf8(t, &len);
bf4a1e57
JH		 3069 tend = t + len;
3070 }
3071 if (!to_utf && rlen) {
3072 STRLEN len = rlen;
5c144d81 3073 r = rsave = bytes_to_utf8(r, &len);
bf4a1e57
JH		 3074 rend = r + len;
3075 }
a0ed51b3 3076
2b9d42f0
NIS		 3077/* There are several snags with this code on EBCDIC:
3078 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3079 2. scan_const() in toke.c has encoded chars in native encoding which makes
3080 ranges at least in EBCDIC 0..255 range the bottom odd.
3081*/
3082
a0ed51b3 3083 if (complement) {
89ebb4a3 3084 U8 tmpbuf[UTF8_MAXBYTES+1];
2b9d42f0 3085 UV *cp;
a0ed51b3 3086 UV nextmin = 0;
a02a5408 3087 Newx(cp, 2*tlen, UV);
a0ed51b3 3088 i = 0;
396482e1 3089 transv = newSVpvs("");
a0ed51b3 3090 while (t < tend) {
9f7f3913 3091 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
2b9d42f0
NIS		 3092 t += ulen;
3093 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
a0ed51b3 3094 t++;
9f7f3913 3095 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
2b9d42f0 3096 t += ulen;
a0ed51b3 3097 }
2b9d42f0
NIS		 3098 else {
3099 cp[2*i+1] = cp[2*i];
3100 }
3101 i++;
a0ed51b3 3102 }
2b9d42f0 3103 qsort(cp, i, 2*sizeof(UV), uvcompare);
a0ed51b3 3104 for (j = 0; j < i; j++) {
2b9d42f0 3105 UV val = cp[2*j];
a0ed51b3
LW		 3106 diff = val - nextmin;
3107 if (diff > 0) {
9041c2e3 3108 t = uvuni_to_utf8(tmpbuf,nextmin);
dfe13c55 3109 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
a0ed51b3 3110 if (diff > 1) {
2b9d42f0 3111 U8 range_mark = UTF_TO_NATIVE(0xff);
9041c2e3 3112 t = uvuni_to_utf8(tmpbuf, val - 1);
2b9d42f0 3113 sv_catpvn(transv, (char *)&range_mark, 1);
dfe13c55 3114 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
a0ed51b3
LW		 3115 }
3116 }
2b9d42f0 3117 val = cp[2*j+1];
a0ed51b3
LW		 3118 if (val >= nextmin)
3119 nextmin = val + 1;
3120 }
9041c2e3 3121 t = uvuni_to_utf8(tmpbuf,nextmin);
dfe13c55 3122 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2b9d42f0
NIS		 3123 {
3124 U8 range_mark = UTF_TO_NATIVE(0xff);
3125 sv_catpvn(transv, (char *)&range_mark, 1);
3126 }
b851fbc1
JH		 3127 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
3128 UNICODE_ALLOW_SUPER);
dfe13c55 3129 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
93524f2b 3130 t = (const U8*)SvPVX_const(transv);
a0ed51b3
LW		 3131 tlen = SvCUR(transv);
3132 tend = t + tlen;
455d824a 3133 Safefree(cp);
a0ed51b3
LW		 3134 }
3135 else if (!rlen && !del) {
3136 r = t; rlen = tlen; rend = tend;
4757a243
LW		 3137 }
3138 if (!squash) {
05d340b8 3139 if ((!rlen && !del) || t == r ||
12ae5dfc 3140 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
01ec43d0 3141 {
4757a243 3142 o->op_private |= OPpTRANS_IDENTICAL;
01ec43d0 3143 }
a0ed51b3
LW		 3144 }
3145
3146 while (t < tend || tfirst <= tlast) {
3147 /* see if we need more "t" chars */
3148 if (tfirst > tlast) {
9f7f3913 3149 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
a0ed51b3 3150 t += ulen;
2b9d42f0 3151 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
ba210ebe 3152 t++;
9f7f3913 3153 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
a0ed51b3
LW		 3154 t += ulen;
3155 }
3156 else
3157 tlast = tfirst;
3158 }
3159
3160 /* now see if we need more "r" chars */
3161 if (rfirst > rlast) {
3162 if (r < rend) {
9f7f3913 3163 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
a0ed51b3 3164 r += ulen;
2b9d42f0 3165 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
ba210ebe 3166 r++;
9f7f3913 3167 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
a0ed51b3
LW		 3168 r += ulen;
3169 }
3170 else
3171 rlast = rfirst;
3172 }
3173 else {
3174 if (!havefinal++)
3175 final = rlast;
3176 rfirst = rlast = 0xffffffff;
3177 }
3178 }
3179
3180 /* now see which range will peter our first, if either. */
3181 tdiff = tlast - tfirst;
3182 rdiff = rlast - rfirst;
3183
3184 if (tdiff <= rdiff)
3185 diff = tdiff;
3186 else
3187 diff = rdiff;
3188
3189 if (rfirst == 0xffffffff) {
3190 diff = tdiff; /* oops, pretend rdiff is infinite */
3191 if (diff > 0)
894356b3
GS		 3192 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3193 (long)tfirst, (long)tlast);
a0ed51b3 3194 else
894356b3 3195 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
a0ed51b3
LW		 3196 }
3197 else {
3198 if (diff > 0)
894356b3
GS		 3199 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3200 (long)tfirst, (long)(tfirst + diff),
3201 (long)rfirst);
a0ed51b3 3202 else
894356b3
GS		 3203 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3204 (long)tfirst, (long)rfirst);
a0ed51b3
LW		 3205
3206 if (rfirst + diff > max)
3207 max = rfirst + diff;
9b877dbb 3208 if (!grows)
45005bfb
JH		 3209 grows = (tfirst < rfirst &&
3210 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3211 rfirst += diff + 1;
a0ed51b3
LW		 3212 }
3213 tfirst += diff + 1;
3214 }
3215
3216 none = ++max;
3217 if (del)
3218 del = ++max;
3219
3220 if (max > 0xffff)
3221 bits = 32;
3222 else if (max > 0xff)
3223 bits = 16;
3224 else
3225 bits = 8;
3226
ea71c68d 3227 PerlMemShared_free(cPVOPo->op_pv);
b3123a61 3228 cPVOPo->op_pv = NULL;
043e41b8
DM		 3229
3230 swash = (SV*)swash_init("utf8", "", listsv, bits, none);
3231#ifdef USE_ITHREADS
3232 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3233 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3234 PAD_SETSV(cPADOPo->op_padix, swash);
3235 SvPADTMP_on(swash);
3236#else
3237 cSVOPo->op_sv = swash;
3238#endif
a0ed51b3 3239 SvREFCNT_dec(listsv);
b37c2d43 3240 SvREFCNT_dec(transv);
a0ed51b3 3241
45005bfb 3242 if (!del && havefinal && rlen)
043e41b8 3243 (void)hv_store((HV*)SvRV(swash), "FINAL", 5,
b448e4fe 3244 newSVuv((UV)final), 0);
a0ed51b3 3245
9b877dbb 3246 if (grows)
a0ed51b3
LW		 3247 o->op_private |= OPpTRANS_GROWS;
3248
b37c2d43
AL		 3249 Safefree(tsave);
3250 Safefree(rsave);
9b877dbb 3251
eb8433b7
NC		 3252#ifdef PERL_MAD
3253 op_getmad(expr,o,'e');
3254 op_getmad(repl,o,'r');
3255#else
a0ed51b3
LW		 3256 op_free(expr);
3257 op_free(repl);
eb8433b7 3258#endif
a0ed51b3
LW		 3259 return o;
3260 }
3261
3262 tbl = (short*)cPVOPo->op_pv;
79072805
LW		 3263 if (complement) {
3264 Zero(tbl, 256, short);
eb160463 3265 for (i = 0; i < (I32)tlen; i++)
ec49126f 3266 tbl[t[i]] = -1;
79072805
LW		 3267 for (i = 0, j = 0; i < 256; i++) {
3268 if (!tbl[i]) {
eb160463 3269 if (j >= (I32)rlen) {
a0ed51b3 3270 if (del)
79072805
LW		 3271 tbl[i] = -2;
3272 else if (rlen)
ec49126f 3273 tbl[i] = r[j-1];
79072805 3274 else
eb160463 3275 tbl[i] = (short)i;
79072805 3276 }
9b877dbb
IH		 3277 else {
3278 if (i < 128 && r[j] >= 128)
3279 grows = 1;
ec49126f 3280 tbl[i] = r[j++];
9b877dbb 3281 }
79072805
LW		 3282 }
3283 }
05d340b8
JH		 3284 if (!del) {
3285 if (!rlen) {
3286 j = rlen;
3287 if (!squash)
3288 o->op_private |= OPpTRANS_IDENTICAL;
3289 }
eb160463 3290 else if (j >= (I32)rlen)
05d340b8 3291 j = rlen - 1;
10db182f 3292 else {
aa1f7c5b
JH		 3293 tbl =
3294 (short *)
3295 PerlMemShared_realloc(tbl,
3296 (0x101+rlen-j) * sizeof(short));
10db182f
YO		 3297 cPVOPo->op_pv = (char*)tbl;
3298 }
585ec06d 3299 tbl[0x100] = (short)(rlen - j);
eb160463 3300 for (i=0; i < (I32)rlen - j; i++)
8973db79
JH		 3301 tbl[0x101+i] = r[j+i];
3302 }
79072805
LW		 3303 }
3304 else {
a0ed51b3 3305 if (!rlen && !del) {
79072805 3306 r = t; rlen = tlen;
5d06d08e 3307 if (!squash)
4757a243 3308 o->op_private |= OPpTRANS_IDENTICAL;
79072805 3309 }
94bfe852
RGS		 3310 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3311 o->op_private |= OPpTRANS_IDENTICAL;
3312 }
79072805
LW		 3313 for (i = 0; i < 256; i++)
3314 tbl[i] = -1;
eb160463
GS		 3315 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3316 if (j >= (I32)rlen) {
a0ed51b3 3317 if (del) {
ec49126f 3318 if (tbl[t[i]] == -1)
3319 tbl[t[i]] = -2;
79072805
LW		 3320 continue;
3321 }
3322 --j;
3323 }
9b877dbb
IH		 3324 if (tbl[t[i]] == -1) {
3325 if (t[i] < 128 && r[j] >= 128)
3326 grows = 1;
ec49126f 3327 tbl[t[i]] = r[j];
9b877dbb 3328 }
79072805
LW		 3329 }
3330 }
9b877dbb
IH		 3331 if (grows)
3332 o->op_private |= OPpTRANS_GROWS;
eb8433b7
NC		 3333#ifdef PERL_MAD
3334 op_getmad(expr,o,'e');
3335 op_getmad(repl,o,'r');
3336#else
79072805
LW		 3337 op_free(expr);
3338 op_free(repl);
eb8433b7 3339#endif
79072805 3340
11343788 3341 return o;
79072805
LW		 3342}
3343
3344OP *
864dbfa3 3345Perl_newPMOP(pTHX_ I32 type, I32 flags)
79072805 3346{
27da23d5 3347 dVAR;
79072805
LW		 3348 PMOP *pmop;
3349
b7dc083c 3350 NewOp(1101, pmop, 1, PMOP);
eb160463 3351 pmop->op_type = (OPCODE)type;
22c35a8c 3352 pmop->op_ppaddr = PL_ppaddr[type];
eb160463
GS		 3353 pmop->op_flags = (U8)flags;
3354 pmop->op_private = (U8)(0 | (flags >> 8));
79072805 3355
3280af22 3356 if (PL_hints & HINT_RE_TAINT)
c737faaf 3357 pmop->op_pmflags |= PMf_RETAINT;
3280af22 3358 if (PL_hints & HINT_LOCALE)
c737faaf
YO		 3359 pmop->op_pmflags |= PMf_LOCALE;
3360
36477c24 3361
debc9467 3362#ifdef USE_ITHREADS
551405c4
AL		 3363 if (av_len((AV*) PL_regex_pad[0]) > -1) {
3364 SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
3365 pmop->op_pmoffset = SvIV(repointer);
3366 SvREPADTMP_off(repointer);
3367 sv_setiv(repointer,0);
3368 } else {
3369 SV * const repointer = newSViv(0);
b37c2d43 3370 av_push(PL_regex_padav, SvREFCNT_inc_simple_NN(repointer));
551405c4
AL		 3371 pmop->op_pmoffset = av_len(PL_regex_padav);
3372 PL_regex_pad = AvARRAY(PL_regex_padav);
13137afc 3373 }
debc9467 3374#endif
1eb1540c 3375
463d09e6 3376 return CHECKOP(type, pmop);
79072805
LW		 3377}
3378
131b3ad0
DM		 3379/* Given some sort of match op o, and an expression expr containing a
3380 * pattern, either compile expr into a regex and attach it to o (if it's
3381 * constant), or convert expr into a runtime regcomp op sequence (if it's
3382 * not)
3383 *
3384 * isreg indicates that the pattern is part of a regex construct, eg
3385 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3386 * split "pattern", which aren't. In the former case, expr will be a list
3387 * if the pattern contains more than one term (eg /a$b/) or if it contains
3388 * a replacement, ie s/// or tr///.
3389 */
3390
79072805 3391OP *
131b3ad0 3392Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
79072805 3393{
27da23d5 3394 dVAR;
79072805
LW		 3395 PMOP *pm;
3396 LOGOP *rcop;
ce862d02 3397 I32 repl_has_vars = 0;
5f66b61c 3398 OP* repl = NULL;
131b3ad0
DM		 3399 bool reglist;
3400
3401 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3402 /* last element in list is the replacement; pop it */
3403 OP* kid;
3404 repl = cLISTOPx(expr)->op_last;
3405 kid = cLISTOPx(expr)->op_first;
3406 while (kid->op_sibling != repl)
3407 kid = kid->op_sibling;
5f66b61c 3408 kid->op_sibling = NULL;
131b3ad0
DM		 3409 cLISTOPx(expr)->op_last = kid;
3410 }
79072805 3411
131b3ad0
DM		 3412 if (isreg && expr->op_type == OP_LIST &&
3413 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3414 {
3415 /* convert single element list to element */
0bd48802 3416 OP* const oe = expr;
131b3ad0 3417 expr = cLISTOPx(oe)->op_first->op_sibling;
5f66b61c
AL		 3418 cLISTOPx(oe)->op_first->op_sibling = NULL;
3419 cLISTOPx(oe)->op_last = NULL;
131b3ad0
DM		 3420 op_free(oe);
3421 }
3422
3423 if (o->op_type == OP_TRANS) {
11343788 3424 return pmtrans(o, expr, repl);
131b3ad0
DM		 3425 }
3426
3427 reglist = isreg && expr->op_type == OP_LIST;
3428 if (reglist)
3429 op_null(expr);
79072805 3430
3280af22 3431 PL_hints |= HINT_BLOCK_SCOPE;
11343788 3432 pm = (PMOP*)o;
79072805
LW		 3433
3434 if (expr->op_type == OP_CONST) {
6136c704 3435 SV * const pat = ((SVOP*)expr)->op_sv;
c737faaf 3436 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
5c144d81 3437
0ac6acae
AB		 3438 if (o->op_flags & OPf_SPECIAL)
3439 pm_flags |= RXf_SPLIT;
5c144d81 3440
0ac6acae 3441 if (DO_UTF8(pat))
c737faaf 3442 pm_flags |= RXf_UTF8;
0ac6acae 3443
3ab4a224 3444 PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
c737faaf 3445
eb8433b7
NC		 3446#ifdef PERL_MAD
3447 op_getmad(expr,(OP*)pm,'e');
3448#else
79072805 3449 op_free(expr);
eb8433b7 3450#endif
79072805
LW		 3451 }
3452 else {
3280af22 3453 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
1c846c1f 3454 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2cd61cdb
IZ		 3455 ? OP_REGCRESET
3456 : OP_REGCMAYBE),0,expr);
463ee0b2 3457
b7dc083c 3458 NewOp(1101, rcop, 1, LOGOP);
79072805 3459 rcop->op_type = OP_REGCOMP;
22c35a8c 3460 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
79072805 3461 rcop->op_first = scalar(expr);
131b3ad0
DM		 3462 rcop->op_flags |= OPf_KIDS
3463 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3464 | (reglist ? OPf_STACKED : 0);
79072805 3465 rcop->op_private = 1;
11343788 3466 rcop->op_other = o;
131b3ad0
DM		 3467 if (reglist)
3468 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3469
b5c19bd7
DM		 3470 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3471 PL_cv_has_eval = 1;
79072805
LW		 3472
3473 /* establish postfix order */
3280af22 3474 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
463ee0b2
LW		 3475 LINKLIST(expr);
3476 rcop->op_next = expr;
3477 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3478 }
3479 else {
3480 rcop->op_next = LINKLIST(expr);
3481 expr->op_next = (OP*)rcop;
3482 }
79072805 3483
11343788 3484 prepend_elem(o->op_type, scalar((OP*)rcop), o);
79072805
LW		 3485 }
3486
3487 if (repl) {
748a9306 3488 OP *curop;
0244c3a4 3489 if (pm->op_pmflags & PMf_EVAL) {
6136c704 3490 curop = NULL;
670a9cb2
DM		 3491 if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
3492 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
0244c3a4 3493 }
748a9306
LW		 3494 else if (repl->op_type == OP_CONST)
3495 curop = repl;
79072805 3496 else {
c445ea15 3497 OP *lastop = NULL;
79072805 3498 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
e80b829c 3499 if (curop->op_type == OP_SCOPE
10250113 3500 || curop->op_type == OP_LEAVE
e80b829c 3501 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
79072805 3502 if (curop->op_type == OP_GV) {
6136c704 3503 GV * const gv = cGVOPx_gv(curop);
ce862d02 3504 repl_has_vars = 1;
f702bf4a 3505 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
79072805
LW		 3506 break;
3507 }
3508 else if (curop->op_type == OP_RV2CV)
3509 break;
3510 else if (curop->op_type == OP_RV2SV ||
3511 curop->op_type == OP_RV2AV ||
3512 curop->op_type == OP_RV2HV ||
3513 curop->op_type == OP_RV2GV) {
3514 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3515 break;
3516 }
748a9306
LW		 3517 else if (curop->op_type == OP_PADSV ||
3518 curop->op_type == OP_PADAV ||
3519 curop->op_type == OP_PADHV ||
e80b829c
RGS		 3520 curop->op_type == OP_PADANY)
3521 {
ce862d02 3522 repl_has_vars = 1;
748a9306 3523 }
1167e5da 3524 else if (curop->op_type == OP_PUSHRE)
6f207bd3 3525 NOOP; /* Okay here, dangerous in newASSIGNOP */
79072805
LW		 3526 else
3527 break;
3528 }
3529 lastop = curop;
3530 }
748a9306 3531 }
ce862d02 3532 if (curop == repl
e80b829c
RGS		 3533 && !(repl_has_vars
3534 && (!PM_GETRE(pm)
3535 || PM_GETRE(pm)->extflags & RXf_EVAL_SEEN)))
3be69782 3536 {
748a9306 3537 pm->op_pmflags |= PMf_CONST; /* const for long enough */
11343788 3538 prepend_elem(o->op_type, scalar(repl), o);
748a9306
LW		 3539 }
3540 else {
aaa362c4 3541 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
ce862d02 3542 pm->op_pmflags |= PMf_MAYBE_CONST;
ce862d02 3543 }
b7dc083c 3544 NewOp(1101, rcop, 1, LOGOP);
748a9306 3545 rcop->op_type = OP_SUBSTCONT;
22c35a8c 3546 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
748a9306
LW		 3547 rcop->op_first = scalar(repl);
3548 rcop->op_flags |= OPf_KIDS;
3549 rcop->op_private = 1;
11343788 3550 rcop->op_other = o;
748a9306
LW		 3551
3552 /* establish postfix order */
3553 rcop->op_next = LINKLIST(repl);
3554 repl->op_next = (OP*)rcop;
3555
20e98b0f 3556 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
29f2e912
NC		 3557 assert(!(pm->op_pmflags & PMf_ONCE));
3558 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
748a9306 3559 rcop->op_next = 0;
79072805
LW		 3560 }
3561 }
3562
3563 return (OP*)pm;
3564}
3565
3566OP *
864dbfa3 3567Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
79072805 3568{
27da23d5 3569 dVAR;
79072805 3570 SVOP *svop;
b7dc083c 3571 NewOp(1101, svop, 1, SVOP);
eb160463 3572 svop->op_type = (OPCODE)type;
22c35a8c 3573 svop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 3574 svop->op_sv = sv;
3575 svop->op_next = (OP*)svop;
eb160463 3576 svop->op_flags = (U8)flags;
22c35a8c 3577 if (PL_opargs[type] & OA_RETSCALAR)
463ee0b2 3578 scalar((OP*)svop);
22c35a8c 3579 if (PL_opargs[type] & OA_TARGET)
ed6116ce 3580 svop->op_targ = pad_alloc(type, SVs_PADTMP);
e50aee73 3581 return CHECKOP(type, svop);
79072805
LW		 3582}
3583
392d04bb 3584#ifdef USE_ITHREADS
79072805 3585OP *
350de78d
GS		 3586Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3587{
27da23d5 3588 dVAR;
350de78d
GS		 3589 PADOP *padop;
3590 NewOp(1101, padop, 1, PADOP);
eb160463 3591 padop->op_type = (OPCODE)type;
350de78d
GS		 3592 padop->op_ppaddr = PL_ppaddr[type];
3593 padop->op_padix = pad_alloc(type, SVs_PADTMP);
dd2155a4
DM		 3594 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3595 PAD_SETSV(padop->op_padix, sv);
58182927
NC		 3596 assert(sv);
3597 SvPADTMP_on(sv);
350de78d 3598 padop->op_next = (OP*)padop;
eb160463 3599 padop->op_flags = (U8)flags;
350de78d
GS		 3600 if (PL_opargs[type] & OA_RETSCALAR)
3601 scalar((OP*)padop);
3602 if (PL_opargs[type] & OA_TARGET)
3603 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3604 return CHECKOP(type, padop);
3605}
392d04bb 3606#endif
350de78d
GS		 3607
3608OP *
864dbfa3 3609Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
79072805 3610{
27da23d5 3611 dVAR;
58182927 3612 assert(gv);
350de78d 3613#ifdef USE_ITHREADS
58182927 3614 GvIN_PAD_on(gv);
ff8997d7 3615 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
350de78d 3616#else
ff8997d7 3617 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
350de78d 3618#endif
79072805
LW		 3619}
3620
3621OP *
864dbfa3 3622Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
79072805 3623{
27da23d5 3624 dVAR;
79072805 3625 PVOP *pvop;
b7dc083c 3626 NewOp(1101, pvop, 1, PVOP);
eb160463 3627 pvop->op_type = (OPCODE)type;
22c35a8c 3628 pvop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 3629 pvop->op_pv = pv;
3630 pvop->op_next = (OP*)pvop;
eb160463 3631 pvop->op_flags = (U8)flags;
22c35a8c 3632 if (PL_opargs[type] & OA_RETSCALAR)
463ee0b2 3633 scalar((OP*)pvop);
22c35a8c 3634 if (PL_opargs[type] & OA_TARGET)
ed6116ce 3635 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
e50aee73 3636 return CHECKOP(type, pvop);
79072805
LW		 3637}
3638
eb8433b7
NC		 3639#ifdef PERL_MAD
3640OP*
3641#else
79072805 3642void
eb8433b7 3643#endif
864dbfa3 3644Perl_package(pTHX_ OP *o)
79072805 3645{
97aff369 3646 dVAR;
bf070237 3647 SV *const sv = cSVOPo->op_sv;
eb8433b7
NC		 3648#ifdef PERL_MAD
3649 OP *pegop;
3650#endif
79072805 3651
3280af22
NIS		 3652 save_hptr(&PL_curstash);
3653 save_item(PL_curstname);
de11ba31 3654
bf070237 3655 PL_curstash = gv_stashsv(sv, GV_ADD);
e1a479c5 3656
bf070237 3657 sv_setsv(PL_curstname, sv);
de11ba31 3658
7ad382f4 3659 PL_hints |= HINT_BLOCK_SCOPE;
53a7735b
DM		 3660 PL_parser->copline = NOLINE;
3661 PL_parser->expect = XSTATE;
eb8433b7
NC		 3662
3663#ifndef PERL_MAD
3664 op_free(o);
3665#else
3666 if (!PL_madskills) {
3667 op_free(o);
1d866c12 3668 return NULL;
eb8433b7
NC		 3669 }
3670
3671 pegop = newOP(OP_NULL,0);
3672 op_getmad(o,pegop,'P');
3673 return pegop;
3674#endif
79072805
LW		 3675}
3676
eb8433b7
NC		 3677#ifdef PERL_MAD
3678OP*
3679#else
85e6fe83 3680void
eb8433b7 3681#endif
88d95a4d 3682Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
85e6fe83 3683{
97aff369 3684 dVAR;
a0d0e21e 3685 OP *pack;
a0d0e21e 3686 OP *imop;
b1cb66bf 3687 OP *veop;
eb8433b7
NC		 3688#ifdef PERL_MAD
3689 OP *pegop = newOP(OP_NULL,0);
3690#endif
85e6fe83 3691
88d95a4d 3692 if (idop->op_type != OP_CONST)
cea2e8a9 3693 Perl_croak(aTHX_ "Module name must be constant");
85e6fe83 3694
eb8433b7
NC		 3695 if (PL_madskills)
3696 op_getmad(idop,pegop,'U');
3697
5f66b61c 3698 veop = NULL;
b1cb66bf 3699
aec46f14 3700 if (version) {
551405c4 3701 SV * const vesv = ((SVOP*)version)->op_sv;
b1cb66bf 3702
eb8433b7
NC		 3703 if (PL_madskills)
3704 op_getmad(version,pegop,'V');
aec46f14 3705 if (!arg && !SvNIOKp(vesv)) {
b1cb66bf 3706 arg = version;
3707 }
3708 else {
3709 OP *pack;
0f79a09d 3710 SV *meth;
b1cb66bf 3711
44dcb63b 3712 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
cea2e8a9 3713 Perl_croak(aTHX_ "Version number must be constant number");
b1cb66bf 3714
88d95a4d
JH		 3715 /* Make copy of idop so we don't free it twice */
3716 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
b1cb66bf 3717
3718 /* Fake up a method call to VERSION */
18916d0d 3719 meth = newSVpvs_share("VERSION");
b1cb66bf 3720 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3721 append_elem(OP_LIST,
0f79a09d
GS		 3722 prepend_elem(OP_LIST, pack, list(version)),
3723 newSVOP(OP_METHOD_NAMED, 0, meth)));
b1cb66bf 3724 }
3725 }
aeea060c 3726
a0d0e21e 3727 /* Fake up an import/unimport */
eb8433b7
NC		 3728 if (arg && arg->op_type == OP_STUB) {
3729 if (PL_madskills)
3730 op_getmad(arg,pegop,'S');
4633a7c4 3731 imop = arg; /* no import on explicit () */
eb8433b7 3732 }
88d95a4d 3733 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
5f66b61c 3734 imop = NULL; /* use 5.0; */
468aa647
RGS		 3735 if (!aver)
3736 idop->op_private |= OPpCONST_NOVER;
b1cb66bf 3737 }
4633a7c4 3738 else {
0f79a09d
GS		 3739 SV *meth;
3740
eb8433b7
NC		 3741 if (PL_madskills)
3742 op_getmad(arg,pegop,'A');
3743
88d95a4d
JH		 3744 /* Make copy of idop so we don't free it twice */
3745 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
0f79a09d
GS		 3746
3747 /* Fake up a method call to import/unimport */
427d62a4 3748 meth = aver
18916d0d 3749 ? newSVpvs_share("import") : newSVpvs_share("unimport");
4633a7c4 3750 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
0f79a09d
GS		 3751 append_elem(OP_LIST,
3752 prepend_elem(OP_LIST, pack, list(arg)),
3753 newSVOP(OP_METHOD_NAMED, 0, meth)));
4633a7c4
LW		 3754 }
3755
a0d0e21e 3756 /* Fake up the BEGIN {}, which does its thing immediately. */
09bef843 3757 newATTRSUB(floor,
18916d0d 3758 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
5f66b61c
AL		 3759 NULL,
3760 NULL,
a0d0e21e 3761 append_elem(OP_LINESEQ,
b1cb66bf 3762 append_elem(OP_LINESEQ,
bd61b366
SS		 3763 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3764 newSTATEOP(0, NULL, veop)),
3765 newSTATEOP(0, NULL, imop) ));
85e6fe83 3766
70f5e4ed
JH		 3767 /* The "did you use incorrect case?" warning used to be here.
3768 * The problem is that on case-insensitive filesystems one
3769 * might get false positives for "use" (and "require"):
3770 * "use Strict" or "require CARP" will work. This causes
3771 * portability problems for the script: in case-strict
3772 * filesystems the script will stop working.
3773 *
3774 * The "incorrect case" warning checked whether "use Foo"
3775 * imported "Foo" to your namespace, but that is wrong, too:
3776 * there is no requirement nor promise in the language that
3777 * a Foo.pm should or would contain anything in package "Foo".
3778 *
3779 * There is very little Configure-wise that can be done, either:
3780 * the case-sensitivity of the build filesystem of Perl does not
3781 * help in guessing the case-sensitivity of the runtime environment.
3782 */
18fc9488 3783
c305c6a0 3784 PL_hints |= HINT_BLOCK_SCOPE;
53a7735b
DM		 3785 PL_parser->copline = NOLINE;
3786 PL_parser->expect = XSTATE;
8ec8fbef 3787 PL_cop_seqmax++; /* Purely for B::*'s benefit */
eb8433b7
NC		 3788
3789#ifdef PERL_MAD
3790 if (!PL_madskills) {
3791 /* FIXME - don't allocate pegop if !PL_madskills */
3792 op_free(pegop);
1d866c12 3793 return NULL;
eb8433b7
NC		 3794 }
3795 return pegop;
3796#endif
85e6fe83
LW		 3797}
3798
7d3fb230 3799/*
ccfc67b7
JH		 3800=head1 Embedding Functions
3801
7d3fb230
BS		 3802=for apidoc load_module
3803
3804Loads the module whose name is pointed to by the string part of name.
3805Note that the actual module name, not its filename, should be given.
3806Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3807PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3808(or 0 for no flags). ver, if specified, provides version semantics
3809similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3810arguments can be used to specify arguments to the module's import()
3811method, similar to C<use Foo::Bar VERSION LIST>.
3812
3813=cut */
3814
e4783991
GS		 3815void
3816Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3817{
3818 va_list args;
3819 va_start(args, ver);
3820 vload_module(flags, name, ver, &args);
3821 va_end(args);
3822}
3823
3824#ifdef PERL_IMPLICIT_CONTEXT
3825void
3826Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3827{
3828 dTHX;
3829 va_list args;
3830 va_start(args, ver);
3831 vload_module(flags, name, ver, &args);
3832 va_end(args);
3833}
3834#endif
3835
3836void
3837Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3838{
97aff369 3839 dVAR;
551405c4 3840 OP *veop, *imop;
e4783991 3841
551405c4 3842 OP * const modname = newSVOP(OP_CONST, 0, name);
e4783991
GS		 3843 modname->op_private |= OPpCONST_BARE;
3844 if (ver) {
3845 veop = newSVOP(OP_CONST, 0, ver);
3846 }
3847 else
5f66b61c 3848 veop = NULL;
e4783991
GS		 3849 if (flags & PERL_LOADMOD_NOIMPORT) {
3850 imop = sawparens(newNULLLIST());
3851 }
3852 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3853 imop = va_arg(*args, OP*);
3854 }
3855 else {
3856 SV *sv;
5f66b61c 3857 imop = NULL;
e4783991
GS		 3858 sv = va_arg(*args, SV*);
3859 while (sv) {
3860 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3861 sv = va_arg(*args, SV*);
3862 }
3863 }
81885997 3864
53a7735b
DM		 3865 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
3866 * that it has a PL_parser to play with while doing that, and also
3867 * that it doesn't mess with any existing parser, by creating a tmp
3868 * new parser with lex_start(). This won't actually be used for much,
3869 * since pp_require() will create another parser for the real work. */
3870
3871 ENTER;
3872 SAVEVPTR(PL_curcop);
5486870f 3873 lex_start(NULL, NULL, FALSE);
53a7735b
DM		 3874 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3875 veop, modname, imop);
3876 LEAVE;
e4783991
GS		 3877}
3878
79072805 3879OP *
850e8516 3880Perl_dofile(pTHX_ OP *term, I32 force_builtin)
78ca652e 3881{
97aff369 3882 dVAR;
78ca652e 3883 OP *doop;
a0714e2c 3884 GV *gv = NULL;
78ca652e 3885
850e8516 3886 if (!force_builtin) {
fafc274c 3887 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
850e8516 3888 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
a4fc7abc 3889 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
a0714e2c 3890 gv = gvp ? *gvp : NULL;
850e8516
RGS		 3891 }
3892 }
78ca652e 3893
b9f751c0 3894 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
78ca652e
GS		 3895 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3896 append_elem(OP_LIST, term,
3897 scalar(newUNOP(OP_RV2CV, 0,
d4c19fe8 3898 newGVOP(OP_GV, 0, gv))))));
78ca652e
GS		 3899 }
3900 else {
3901 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3902 }
3903 return doop;
3904}
3905
3906OP *
864dbfa3 3907Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
79072805
LW		 3908{
3909 return newBINOP(OP_LSLICE, flags,
8990e307
LW		 3910 list(force_list(subscript)),
3911 list(force_list(listval)) );
79072805
LW		 3912}
3913
76e3520e 3914STATIC I32
504618e9 3915S_is_list_assignment(pTHX_ register const OP *o)
79072805 3916{
1496a290
AL		 3917 unsigned type;
3918 U8 flags;
3919
11343788 3920 if (!o)
79072805
LW		 3921 return TRUE;
3922
1496a290 3923 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
11343788 3924 o = cUNOPo->op_first;
79072805 3925
1496a290
AL		 3926 flags = o->op_flags;
3927 type = o->op_type;
3928 if (type == OP_COND_EXPR) {
504618e9
AL		 3929 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3930 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
79072805
LW		 3931
3932 if (t && f)
3933 return TRUE;
3934 if (t || f)
3935 yyerror("Assignment to both a list and a scalar");
3936 return FALSE;
3937 }
3938
1496a290
AL		 3939 if (type == OP_LIST &&
3940 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
95f0a2f1
SB		 3941 o->op_private & OPpLVAL_INTRO)
3942 return FALSE;
3943
1496a290
AL		 3944 if (type == OP_LIST || flags & OPf_PARENS ||
3945 type == OP_RV2AV || type == OP_RV2HV ||
3946 type == OP_ASLICE || type == OP_HSLICE)
79072805
LW		 3947 return TRUE;
3948
1496a290 3949 if (type == OP_PADAV || type == OP_PADHV)
93a17b20
LW		 3950 return TRUE;
3951
1496a290 3952 if (type == OP_RV2SV)
79072805
LW		 3953 return FALSE;
3954
3955 return FALSE;
3956}
3957
3958OP *
864dbfa3 3959Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
79072805 3960{
97aff369 3961 dVAR;
11343788 3962 OP *o;
79072805 3963
a0d0e21e 3964 if (optype) {
c963b151 3965 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
a0d0e21e
LW		 3966 return newLOGOP(optype, 0,
3967 mod(scalar(left), optype),
3968 newUNOP(OP_SASSIGN, 0, scalar(right)));
3969 }
3970 else {
3971 return newBINOP(optype, OPf_STACKED,
3972 mod(scalar(left), optype), scalar(right));
3973 }
3974 }
3975
504618e9 3976 if (is_list_assignment(left)) {
6dbe9451
NC		 3977 static const char no_list_state[] = "Initialization of state variables"
3978 " in list context currently forbidden";
10c8fecd
GS		 3979 OP *curop;
3980
3280af22 3981 PL_modcount = 0;
dbfe47cf
RD		 3982 /* Grandfathering $[ assignment here. Bletch.*/
3983 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
fe5bfecd 3984 PL_eval_start = (left->op_type == OP_CONST) ? right : NULL;
463ee0b2 3985 left = mod(left, OP_AASSIGN);
3280af22
NIS		 3986 if (PL_eval_start)
3987 PL_eval_start = 0;
dbfe47cf 3988 else if (left->op_type == OP_CONST) {
eb8433b7 3989 /* FIXME for MAD */
dbfe47cf
RD		 3990 /* Result of assignment is always 1 (or we'd be dead already) */
3991 return newSVOP(OP_CONST, 0, newSViv(1));
a0d0e21e 3992 }
10c8fecd
GS		 3993 curop = list(force_list(left));
3994 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
eb160463 3995 o->op_private = (U8)(0 | (flags >> 8));
dd2155a4
DM		 3996
3997 /* PL_generation sorcery:
3998 * an assignment like ($a,$b) = ($c,$d) is easier than
3999 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
4000 * To detect whether there are common vars, the global var
4001 * PL_generation is incremented for each assign op we compile.
4002 * Then, while compiling the assign op, we run through all the
4003 * variables on both sides of the assignment, setting a spare slot
4004 * in each of them to PL_generation. If any of them already have
4005 * that value, we know we've got commonality. We could use a
4006 * single bit marker, but then we'd have to make 2 passes, first
4007 * to clear the flag, then to test and set it. To find somewhere
931b58fb 4008 * to store these values, evil chicanery is done with SvUVX().
dd2155a4
DM		 4009 */
4010
461824dc 4011 {
11343788 4012 OP *lastop = o;
3280af22 4013 PL_generation++;
11343788 4014 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
22c35a8c 4015 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
79072805 4016 if (curop->op_type == OP_GV) {
638eceb6 4017 GV *gv = cGVOPx_gv(curop);
169d2d72
NC		 4018 if (gv == PL_defgv
4019 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
79072805 4020 break;
169d2d72 4021 GvASSIGN_GENERATION_set(gv, PL_generation);
79072805 4022 }
748a9306
LW		 4023 else if (curop->op_type == OP_PADSV ||
4024 curop->op_type == OP_PADAV ||
4025 curop->op_type == OP_PADHV ||
dd2155a4
DM		 4026 curop->op_type == OP_PADANY)
4027 {
4028 if (PAD_COMPNAME_GEN(curop->op_targ)
92251a1e 4029 == (STRLEN)PL_generation)
748a9306 4030 break;
b162af07 4031 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
dd2155a4 4032
748a9306 4033 }
79072805
LW		 4034 else if (curop->op_type == OP_RV2CV)
4035 break;
4036 else if (curop->op_type == OP_RV2SV ||
4037 curop->op_type == OP_RV2AV ||
4038 curop->op_type == OP_RV2HV ||
4039 curop->op_type == OP_RV2GV) {
4040 if (lastop->op_type != OP_GV) /* funny deref? */
4041 break;
4042 }
1167e5da 4043 else if (curop->op_type == OP_PUSHRE) {
b3f5893f 4044#ifdef USE_ITHREADS
20e98b0f
NC		 4045 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4046 GV *const gv = (GV*)PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff);
169d2d72
NC		 4047 if (gv == PL_defgv
4048 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
1167e5da 4049 break;
169d2d72 4050 GvASSIGN_GENERATION_set(gv, PL_generation);
20e98b0f
NC		 4051 }
4052#else
4053 GV *const gv
4054 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4055 if (gv) {
4056 if (gv == PL_defgv
4057 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4058 break;
169d2d72 4059 GvASSIGN_GENERATION_set(gv, PL_generation);
b2ffa427 4060 }
20e98b0f 4061#endif
1167e5da 4062 }
79072805
LW		 4063 else
4064 break;
4065 }
4066 lastop = curop;
4067 }
11343788 4068 if (curop != o)
10c8fecd 4069 o->op_private |= OPpASSIGN_COMMON;
461824dc 4070 }
9fdc7570 4071
6dbe9451
NC		 4072 if ((left->op_type == OP_LIST
4073 || (left->op_type == OP_NULL && left->op_targ == OP_LIST))) {
4074 OP* lop = ((LISTOP*)left)->op_first;
4075 while (lop) {
4076 if (lop->op_type == OP_PADSV ||
4077 lop->op_type == OP_PADAV ||
4078 lop->op_type == OP_PADHV ||
4079 lop->op_type == OP_PADANY) {
4080 if (lop->op_private & OPpPAD_STATE) {
4081 if (left->op_private & OPpLVAL_INTRO) {
4082 /* Each variable in state($a, $b, $c) = ... */
4083 }
4084 else {
4085 /* Each state variable in
4086 (state $a, my $b, our $c, $d, undef) = ... */
4087 }
4088 yyerror(no_list_state);
4089 } else {
4090 /* Each my variable in
4091 (state $a, my $b, our $c, $d, undef) = ... */
4092 }
4093 } else {
4094 /* Other ops in the list. undef may be interesting in
4095 (state $a, undef, state $c) */
4096 }
4097 lop = lop->op_sibling;
4098 }
4099 }
4100 else if (((left->op_private & (OPpLVAL_INTRO | OPpPAD_STATE))
4101 == (OPpLVAL_INTRO | OPpPAD_STATE))
4102 && ( left->op_type == OP_PADSV
4103 || left->op_type == OP_PADAV
4104 || left->op_type == OP_PADHV
4105 || left->op_type == OP_PADANY))
4106 {
4107 /* All single variable list context state assignments, hence
4108 state ($a) = ...
4109 (state $a) = ...
4110 state @a = ...
4111 state (@a) = ...
4112 (state @a) = ...
4113 state %a = ...
4114 state (%a) = ...
4115 (state %a) = ...
4116 */
4117 yyerror(no_list_state);
4118 }
4119
e9cc17ba 4120 if (right && right->op_type == OP_SPLIT && !PL_madskills) {
1496a290
AL		 4121 OP* tmpop = ((LISTOP*)right)->op_first;
4122 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
551405c4 4123 PMOP * const pm = (PMOP*)tmpop;
c07a80fd 4124 if (left->op_type == OP_RV2AV &&
4125 !(left->op_private & OPpLVAL_INTRO) &&
11343788 4126 !(o->op_private & OPpASSIGN_COMMON) )
c07a80fd 4127 {
4128 tmpop = ((UNOP*)left)->op_first;
20e98b0f
NC		 4129 if (tmpop->op_type == OP_GV
4130#ifdef USE_ITHREADS
4131 && !pm->op_pmreplrootu.op_pmtargetoff
4132#else
4133 && !pm->op_pmreplrootu.op_pmtargetgv
4134#endif
4135 ) {
971a9dd3 4136#ifdef USE_ITHREADS
20e98b0f
NC		 4137 pm->op_pmreplrootu.op_pmtargetoff
4138 = cPADOPx(tmpop)->op_padix;
971a9dd3
GS		 4139 cPADOPx(tmpop)->op_padix = 0; /* steal it */
4140#else
20e98b0f
NC		 4141 pm->op_pmreplrootu.op_pmtargetgv
4142 = (GV*)cSVOPx(tmpop)->op_sv;
a0714e2c 4143 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
971a9dd3 4144#endif
c07a80fd 4145 pm->op_pmflags |= PMf_ONCE;
11343788 4146 tmpop = cUNOPo->op_first; /* to list (nulled) */
c07a80fd 4147 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
5f66b61c 4148 tmpop->op_sibling = NULL; /* don't free split */
c07a80fd 4149 right->op_next = tmpop->op_next; /* fix starting loc */
11343788 4150 op_free(o); /* blow off assign */
54310121 4151 right->op_flags &= ~OPf_WANT;
a5f75d66 4152 /* "I don't know and I don't care." */
c07a80fd 4153 return right;
4154 }
4155 }
4156 else {
e6438c1a 4157 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
c07a80fd 4158 ((LISTOP*)right)->op_last->op_type == OP_CONST)
4159 {
4160 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
4161 if (SvIVX(sv) == 0)
3280af22 4162 sv_setiv(sv, PL_modcount+1);
c07a80fd 4163 }
4164 }
4165 }
4166 }
11343788 4167 return o;
79072805
LW		 4168 }
4169 if (!right)
4170 right = newOP(OP_UNDEF, 0);
4171 if (right->op_type == OP_READLINE) {
4172 right->op_flags |= OPf_STACKED;
463ee0b2 4173 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
79072805 4174 }
a0d0e21e 4175 else {
3280af22 4176 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
11343788 4177 o = newBINOP(OP_SASSIGN, flags,
463ee0b2 4178 scalar(right), mod(scalar(left), OP_SASSIGN) );
3280af22
NIS		 4179 if (PL_eval_start)
4180 PL_eval_start = 0;
748a9306 4181 else {
eb8433b7 4182 /* FIXME for MAD */
3b6547f5 4183 op_free(o);
fc15ae8f 4184 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
2e0ae2d3 4185 o->op_private |= OPpCONST_ARYBASE;
a0d0e21e
LW		 4186 }
4187 }
11343788 4188 return o;
79072805
LW		 4189}
4190
4191OP *
864dbfa3 4192Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
79072805 4193{
27da23d5 4194 dVAR;
e1ec3a88 4195 const U32 seq = intro_my();
79072805
LW		 4196 register COP *cop;
4197
b7dc083c 4198 NewOp(1101, cop, 1, COP);
57843af0 4199 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
8990e307 4200 cop->op_type = OP_DBSTATE;
22c35a8c 4201 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
8990e307
LW		 4202 }
4203 else {
4204 cop->op_type = OP_NEXTSTATE;
22c35a8c 4205 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
8990e307 4206 }
eb160463 4207 cop->op_flags = (U8)flags;
623e6609 4208 CopHINTS_set(cop, PL_hints);
ff0cee69 4209#ifdef NATIVE_HINTS
4210 cop->op_private |= NATIVE_HINTS;
4211#endif
623e6609 4212 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
79072805
LW		 4213 cop->op_next = (OP*)cop;
4214
463ee0b2 4215 if (label) {
6a3d5e3d 4216 CopLABEL_set(cop, label);
3280af22 4217 PL_hints |= HINT_BLOCK_SCOPE;
463ee0b2 4218 }
bbce6d69 4219 cop->cop_seq = seq;
7b0bddfa 4220 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
c28fe1ec
NC		 4221 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4222 */
72dc9ed5 4223 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
c28fe1ec
NC		 4224 cop->cop_hints_hash = PL_curcop->cop_hints_hash;
4225 if (cop->cop_hints_hash) {
cbb1fbea 4226 HINTS_REFCNT_LOCK;
c28fe1ec 4227 cop->cop_hints_hash->refcounted_he_refcnt++;
cbb1fbea 4228 HINTS_REFCNT_UNLOCK;
b3ca2e83 4229 }
79072805 4230
53a7735b 4231 if (PL_parser && PL_parser->copline == NOLINE)
57843af0 4232 CopLINE_set(cop, CopLINE(PL_curcop));
79072805 4233 else {
53a7735b
DM		 4234 CopLINE_set(cop, PL_parser->copline);
4235 if (PL_parser)
4236 PL_parser->copline = NOLINE;
79072805 4237 }
57843af0 4238#ifdef USE_ITHREADS
f4dd75d9 4239 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
57843af0 4240#else
f4dd75d9 4241 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
57843af0 4242#endif
11faa288 4243 CopSTASH_set(cop, PL_curstash);
79072805 4244
3280af22 4245 if (PERLDB_LINE && PL_curstash != PL_debstash) {
80a702cd
RGS		 4246 AV *av = CopFILEAVx(PL_curcop);
4247 if (av) {
4248 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4249 if (svp && *svp != &PL_sv_undef ) {
4250 (void)SvIOK_on(*svp);
4251 SvIV_set(*svp, PTR2IV(cop));
4252 }
1eb1540c 4253 }
93a17b20
LW		 4254 }
4255
722969e2 4256 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
79072805
LW		 4257}
4258
bbce6d69 4259
79072805 4260OP *
864dbfa3 4261Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
79072805 4262{
27da23d5 4263 dVAR;
883ffac3
CS		 4264 return new_logop(type, flags, &first, &other);
4265}
4266
3bd495df 4267STATIC OP *
cea2e8a9 4268S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
883ffac3 4269{
27da23d5 4270 dVAR;
79072805 4271 LOGOP *logop;
11343788 4272 OP *o;
883ffac3 4273 OP *first = *firstp;
b22e6366 4274 OP * const other = *otherp;
79072805 4275
a0d0e21e
LW		 4276 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4277 return newBINOP(type, flags, scalar(first), scalar(other));
4278
8990e307 4279 scalarboolean(first);
79072805 4280 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
68726e16
NC		 4281 if (first->op_type == OP_NOT
4282 && (first->op_flags & OPf_SPECIAL)
b6214b80
GG		 4283 && (first->op_flags & OPf_KIDS)
4284 && !PL_madskills) {
79072805
LW		 4285 if (type == OP_AND || type == OP_OR) {
4286 if (type == OP_AND)
4287 type = OP_OR;
4288 else
4289 type = OP_AND;
11343788 4290 o = first;
883ffac3 4291 first = *firstp = cUNOPo->op_first;
11343788
MB		 4292 if (o->op_next)
4293 first->op_next = o->op_next;
5f66b61c 4294 cUNOPo->op_first = NULL;
11343788 4295 op_free(o);
79072805
LW		 4296 }
4297 }
4298 if (first->op_type == OP_CONST) {
39a440a3
DM		 4299 if (first->op_private & OPpCONST_STRICT)
4300 no_bareword_allowed(first);
041457d9 4301 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
989dfb19 4302 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
75cc09e4
MHM		 4303 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
4304 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
4305 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
5f66b61c 4306 *firstp = NULL;
d6fee5c7
DM		 4307 if (other->op_type == OP_CONST)
4308 other->op_private |= OPpCONST_SHORTCIRCUIT;
eb8433b7
NC		 4309 if (PL_madskills) {
4310 OP *newop = newUNOP(OP_NULL, 0, other);
4311 op_getmad(first, newop, '1');
4312 newop->op_targ = type; /* set "was" field */
4313 return newop;
4314 }
4315 op_free(first);
79072805
LW		 4316 return other;
4317 }
4318 else {
7921d0f2 4319 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
6867be6d 4320 const OP *o2 = other;
7921d0f2
DM		 4321 if ( ! (o2->op_type == OP_LIST
4322 && (( o2 = cUNOPx(o2)->op_first))
4323 && o2->op_type == OP_PUSHMARK
4324 && (( o2 = o2->op_sibling)) )
4325 )
4326 o2 = other;
4327 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4328 || o2->op_type == OP_PADHV)
4329 && o2->op_private & OPpLVAL_INTRO
52351015 4330 && !(o2->op_private & OPpPAD_STATE)
7921d0f2
DM		 4331 && ckWARN(WARN_DEPRECATED))
4332 {
4333 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4334 "Deprecated use of my() in false conditional");
4335 }
4336
5f66b61c 4337 *otherp = NULL;
d6fee5c7
DM		 4338 if (first->op_type == OP_CONST)
4339 first->op_private |= OPpCONST_SHORTCIRCUIT;
eb8433b7
NC		 4340 if (PL_madskills) {
4341 first = newUNOP(OP_NULL, 0, first);
4342 op_getmad(other, first, '2');
4343 first->op_targ = type; /* set "was" field */
4344 }
4345 else
4346 op_free(other);
79072805
LW		 4347 return first;
4348 }
4349 }
041457d9
DM		 4350 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4351 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
59e10468 4352 {
b22e6366
AL		 4353 const OP * const k1 = ((UNOP*)first)->op_first;
4354 const OP * const k2 = k1->op_sibling;
a6006777 4355 OPCODE warnop = 0;
4356 switch (first->op_type)
4357 {
4358 case OP_NULL:
4359 if (k2 && k2->op_type == OP_READLINE
4360 && (k2->op_flags & OPf_STACKED)
1c846c1f 4361 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
72b16652 4362 {
a6006777 4363 warnop = k2->op_type;
72b16652 4364 }
a6006777 4365 break;
4366
4367 case OP_SASSIGN:
68dc0745 4368 if (k1->op_type == OP_READDIR
4369 || k1->op_type == OP_GLOB
72b16652 4370 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
68dc0745 4371 || k1->op_type == OP_EACH)
72b16652
GS		 4372 {
4373 warnop = ((k1->op_type == OP_NULL)
eb160463 4374 ? (OPCODE)k1->op_targ : k1->op_type);
72b16652 4375 }
a6006777 4376 break;
4377 }
8ebc5c01 4378 if (warnop) {
6867be6d 4379 const line_t oldline = CopLINE(PL_curcop);
53a7735b 4380 CopLINE_set(PL_curcop, PL_parser->copline);
9014280d 4381 Perl_warner(aTHX_ packWARN(WARN_MISC),
599cee73 4382 "Value of %s%s can be \"0\"; test with defined()",
22c35a8c 4383 PL_op_desc[warnop],
68dc0745 4384 ((warnop == OP_READLINE || warnop == OP_GLOB)
4385 ? " construct" : "() operator"));
57843af0 4386 CopLINE_set(PL_curcop, oldline);
8ebc5c01 4387 }
a6006777 4388 }
79072805
LW		 4389
4390 if (!other)
4391 return first;
4392
c963b151 4393 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
a0d0e21e
LW		 4394 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4395
b7dc083c 4396 NewOp(1101, logop, 1, LOGOP);
79072805 4397
eb160463 4398 logop->op_type = (OPCODE)type;
22c35a8c 4399 logop->op_ppaddr = PL_ppaddr[type];
79072805 4400 logop->op_first = first;
585ec06d 4401 logop->op_flags = (U8)(flags | OPf_KIDS);
79072805 4402 logop->op_other = LINKLIST(other);
eb160463 4403 logop->op_private = (U8)(1 | (flags >> 8));
79072805
LW		 4404
4405 /* establish postfix order */
4406 logop->op_next = LINKLIST(first);
4407 first->op_next = (OP*)logop;
4408 first->op_sibling = other;
4409
463d09e6
RGS		 4410 CHECKOP(type,logop);
4411
11343788
MB		 4412 o = newUNOP(OP_NULL, 0, (OP*)logop);
4413 other->op_next = o;
79072805 4414
11343788 4415 return o;
79072805
LW		 4416}
4417
4418OP *
864dbfa3 4419Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
79072805 4420{
27da23d5 4421 dVAR;
1a67a97c
SM		 4422 LOGOP *logop;
4423 OP *start;
11343788 4424 OP *o;
79072805 4425
b1cb66bf 4426 if (!falseop)
4427 return newLOGOP(OP_AND, 0, first, trueop);
4428 if (!trueop)
4429 return newLOGOP(OP_OR, 0, first, falseop);
79072805 4430
8990e307 4431 scalarboolean(first);
79072805 4432 if (first->op_type == OP_CONST) {
5b6782b2
NC		 4433 /* Left or right arm of the conditional? */
4434 const bool left = SvTRUE(((SVOP*)first)->op_sv);
4435 OP *live = left ? trueop : falseop;
4436 OP *const dead = left ? falseop : trueop;
2bc6235c 4437 if (first->op_private & OPpCONST_BARE &&
b22e6366
AL		 4438 first->op_private & OPpCONST_STRICT) {
4439 no_bareword_allowed(first);
4440 }
5b6782b2
NC		 4441 if (PL_madskills) {
4442 /* This is all dead code when PERL_MAD is not defined. */
4443 live = newUNOP(OP_NULL, 0, live);
4444 op_getmad(first, live, 'C');
4445 op_getmad(dead, live, left ? 'e' : 't');
4446 } else {
4447 op_free(first);
4448 op_free(dead);
79072805 4449 }
5b6782b2 4450 return live;
79072805 4451 }
1a67a97c
SM		 4452 NewOp(1101, logop, 1, LOGOP);
4453 logop->op_type = OP_COND_EXPR;
4454 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4455 logop->op_first = first;
585ec06d 4456 logop->op_flags = (U8)(flags | OPf_KIDS);
eb160463 4457 logop->op_private = (U8)(1 | (flags >> 8));
1a67a97c
SM		 4458 logop->op_other = LINKLIST(trueop);
4459 logop->op_next = LINKLIST(falseop);
79072805 4460
463d09e6
RGS		 4461 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4462 logop);
79072805
LW		 4463
4464 /* establish postfix order */
1a67a97c
SM		 4465 start = LINKLIST(first);
4466 first->op_next = (OP*)logop;
79072805 4467
b1cb66bf 4468 first->op_sibling = trueop;
4469 trueop->op_sibling = falseop;
1a67a97c 4470 o = newUNOP(OP_NULL, 0, (OP*)logop);
79072805 4471
1a67a97c 4472 trueop->op_next = falseop->op_next = o;
79072805 4473
1a67a97c 4474 o->op_next = start;
11343788 4475 return o;
79072805
LW		 4476}
4477
4478OP *
864dbfa3 4479Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
79072805 4480{
27da23d5 4481 dVAR;
1a67a97c 4482 LOGOP *range;
79072805
LW		 4483 OP *flip;
4484 OP *flop;
1a67a97c 4485 OP *leftstart;
11343788 4486 OP *o;
79072805 4487
1a67a97c 4488 NewOp(1101, range, 1, LOGOP);
79072805 4489
1a67a97c
SM		 4490 range->op_type = OP_RANGE;
4491 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4492 range->op_first = left;
4493 range->op_flags = OPf_KIDS;
4494 leftstart = LINKLIST(left);
4495 range->op_other = LINKLIST(right);
eb160463 4496 range->op_private = (U8)(1 | (flags >> 8));
79072805
LW		 4497
4498 left->op_sibling = right;
4499
1a67a97c
SM		 4500 range->op_next = (OP*)range;
4501 flip = newUNOP(OP_FLIP, flags, (OP*)range);
79072805 4502 flop = newUNOP(OP_FLOP, 0, flip);
11343788 4503 o = newUNOP(OP_NULL, 0, flop);
79072805 4504 linklist(flop);
1a67a97c 4505 range->op_next = leftstart;
79072805
LW		 4506
4507 left->op_next = flip;
4508 right->op_next = flop;
4509
1a67a97c
SM		 4510 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4511 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
ed6116ce 4512 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
79072805
LW		 4513 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4514
4515 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4516 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4517
11343788 4518 flip->op_next = o;
79072805 4519 if (!flip->op_private || !flop->op_private)
11343788 4520 linklist(o); /* blow off optimizer unless constant */
79072805 4521
11343788 4522 return o;
79072805
LW		 4523}
4524
4525OP *
864dbfa3 4526Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
79072805 4527{
97aff369 4528 dVAR;
463ee0b2 4529 OP* listop;
11343788 4530 OP* o;
73d840c0 4531 const bool once = block && block->op_flags & OPf_SPECIAL &&
a0d0e21e 4532 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
46c461b5
AL		 4533
4534 PERL_UNUSED_ARG(debuggable);
93a17b20 4535
463ee0b2
LW		 4536 if (expr) {
4537 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4538 return block; /* do {} while 0 does once */
fb73857a 4539 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4540 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
774d564b 4541 expr = newUNOP(OP_DEFINED, 0,
54b9620d 4542 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
55d729e4 4543 } else if (expr->op_flags & OPf_KIDS) {
46c461b5
AL		 4544 const OP * const k1 = ((UNOP*)expr)->op_first;
4545 const OP * const k2 = k1 ? k1->op_sibling : NULL;
55d729e4 4546 switch (expr->op_type) {
1c846c1f 4547 case OP_NULL:
55d729e4
GS		 4548 if (k2 && k2->op_type == OP_READLINE
4549 && (k2->op_flags & OPf_STACKED)
1c846c1f 4550 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
55d729e4 4551 expr = newUNOP(OP_DEFINED, 0, expr);
1c846c1f 4552 break;
55d729e4
GS		 4553
4554 case OP_SASSIGN:
06dc7ac6 4555 if (k1 && (k1->op_type == OP_READDIR
55d729e4 4556 || k1->op_type == OP_GLOB
6531c3e6 4557 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
06dc7ac6 4558 || k1->op_type == OP_EACH))
55d729e4
GS		 4559 expr = newUNOP(OP_DEFINED, 0, expr);
4560 break;
4561 }
774d564b 4562 }
463ee0b2 4563 }
93a17b20 4564
e1548254
RGS		 4565 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4566 * op, in listop. This is wrong. [perl #27024] */
4567 if (!block)
4568 block = newOP(OP_NULL, 0);
8990e307 4569 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
883ffac3 4570 o = new_logop(OP_AND, 0, &expr, &listop);
463ee0b2 4571
883ffac3
CS		 4572 if (listop)
4573 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
79072805 4574
11343788
MB		 4575 if (once && o != listop)
4576 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
79072805 4577
11343788
MB		 4578 if (o == listop)
4579 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
748a9306 4580
11343788
MB		 4581 o->op_flags |= flags;
4582 o = scope(o);
4583 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4584 return o;
79072805
LW		 4585}
4586
4587OP *
a034e688
DM		 4588Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4589whileline, OP *expr, OP *block, OP *cont, I32 has_my)
79072805 4590{
27da23d5 4591 dVAR;
79072805 4592 OP *redo;
c445ea15 4593 OP *next = NULL;
79072805 4594 OP *listop;
11343788 4595 OP *o;
1ba6ee2b 4596 U8 loopflags = 0;
46c461b5
AL		 4597
4598 PERL_UNUSED_ARG(debuggable);
79072805 4599
2d03de9c
AL		 4600 if (expr) {
4601 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4602 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4603 expr = newUNOP(OP_DEFINED, 0,
4604 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4605 } else if (expr->op_flags & OPf_KIDS) {
4606 const OP * const k1 = ((UNOP*)expr)->op_first;
4607 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4608 switch (expr->op_type) {
4609 case OP_NULL:
4610 if (k2 && k2->op_type == OP_READLINE
4611 && (k2->op_flags & OPf_STACKED)
4612 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4613 expr = newUNOP(OP_DEFINED, 0, expr);
4614 break;
55d729e4 4615
2d03de9c 4616 case OP_SASSIGN:
72c8de1a 4617 if (k1 && (k1->op_type == OP_READDIR
2d03de9c
AL		 4618 || k1->op_type == OP_GLOB
4619 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
72c8de1a 4620 || k1->op_type == OP_EACH))
2d03de9c
AL		 4621 expr = newUNOP(OP_DEFINED, 0, expr);
4622 break;
4623 }
55d729e4 4624 }
748a9306 4625 }
79072805
LW		 4626
4627 if (!block)
4628 block = newOP(OP_NULL, 0);
a034e688 4629 else if (cont || has_my) {
87246558
GS		 4630 block = scope(block);
4631 }
79072805 4632
1ba6ee2b 4633 if (cont) {
79072805 4634 next = LINKLIST(cont);
1ba6ee2b 4635 }
fb73857a 4636 if (expr) {
551405c4 4637 OP * const unstack = newOP(OP_UNSTACK, 0);
85538317
GS		 4638 if (!next)
4639 next = unstack;
4640 cont = append_elem(OP_LINESEQ, cont, unstack);
fb73857a 4641 }
79072805 4642
ce3e5c45 4643 assert(block);
463ee0b2 4644 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
ce3e5c45 4645 assert(listop);
79072805
LW		 4646 redo = LINKLIST(listop);
4647
4648 if (expr) {
53a7735b 4649 PL_parser->copline = (line_t)whileline;
883ffac3
CS		 4650 scalar(listop);
4651 o = new_logop(OP_AND, 0, &expr, &listop);
11343788 4652 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
85e6fe83 4653 op_free(expr); /* oops, it's a while (0) */
463ee0b2 4654 op_free((OP*)loop);
5f66b61c 4655 return NULL; /* listop already freed by new_logop */
463ee0b2 4656 }
883ffac3 4657 if (listop)
497b47a8 4658 ((LISTOP*)listop)->op_last->op_next =
883ffac3 4659 (o == listop ? redo : LINKLIST(o));
79072805
LW		 4660 }
4661 else
11343788 4662 o = listop;
79072805
LW		 4663
4664 if (!loop) {
b7dc083c 4665 NewOp(1101,loop,1,LOOP);
79072805 4666 loop->op_type = OP_ENTERLOOP;
22c35a8c 4667 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
79072805
LW		 4668 loop->op_private = 0;
4669 loop->op_next = (OP*)loop;
4670 }
4671
11343788 4672 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
79072805
LW		 4673
4674 loop->op_redoop = redo;
11343788 4675 loop->op_lastop = o;
1ba6ee2b 4676 o->op_private |= loopflags;
79072805
LW		 4677
4678 if (next)
4679 loop->op_nextop = next;
4680 else
11343788 4681 loop->op_nextop = o;
79072805 4682
11343788
MB		 4683 o->op_flags |= flags;
4684 o->op_private |= (flags >> 8);
4685 return o;
79072805
LW		 4686}
4687
4688OP *
66a1b24b 4689Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
79072805 4690{
27da23d5 4691 dVAR;
79072805 4692 LOOP *loop;
fb73857a 4693 OP *wop;
4bbc6d12 4694 PADOFFSET padoff = 0;
4633a7c4 4695 I32 iterflags = 0;
241416b8 4696 I32 iterpflags = 0;
d4c19fe8 4697 OP *madsv = NULL;
79072805 4698
79072805 4699 if (sv) {
85e6fe83 4700 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
241416b8 4701 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
748a9306 4702 sv->op_type = OP_RV2GV;
22c35a8c 4703 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
0be9a6bb
RH		 4704
4705 /* The op_type check is needed to prevent a possible segfault
4706 * if the loop variable is undeclared and 'strict vars' is in
4707 * effect. This is illegal but is nonetheless parsed, so we
4708 * may reach this point with an OP_CONST where we're expecting
4709 * an OP_GV.
4710 */
4711 if (cUNOPx(sv)->op_first->op_type == OP_GV
4712 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
0d863452 4713 iterpflags |= OPpITER_DEF;
79072805 4714 }
85e6fe83 4715 else if (sv->op_type == OP_PADSV) { /* private variable */
241416b8 4716 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
85e6fe83 4717 padoff = sv->op_targ;
eb8433b7
NC		 4718 if (PL_madskills)
4719 madsv = sv;
4720 else {
4721 sv->op_targ = 0;
4722 op_free(sv);
4723 }
5f66b61c 4724 sv = NULL;
85e6fe83 4725 }
79072805 4726 else
cea2e8a9 4727 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
f8503592
NC		 4728 if (padoff) {
4729 SV *const namesv = PAD_COMPNAME_SV(padoff);
4730 STRLEN len;
4731 const char *const name = SvPV_const(namesv, len);
4732
4733 if (len == 2 && name[0] == '$' && name[1] == '_')
4734 iterpflags |= OPpITER_DEF;
4735 }
79072805
LW		 4736 }
4737 else {
9f7d9405 4738 const PADOFFSET offset = pad_findmy("$_");
00b1698f 4739 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
aabe9514
RGS		 4740 sv = newGVOP(OP_GV, 0, PL_defgv);
4741 }
4742 else {
4743 padoff = offset;
aabe9514 4744 }
0d863452 4745 iterpflags |= OPpITER_DEF;
79072805 4746 }
5f05dabc 4747 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
89ea2908 4748 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4633a7c4
LW		 4749 iterflags |= OPf_STACKED;
4750 }
89ea2908
GA		 4751 else if (expr->op_type == OP_NULL &&
4752 (expr->op_flags & OPf_KIDS) &&
4753 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4754 {
4755 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4756 * set the STACKED flag to indicate that these values are to be
4757 * treated as min/max values by 'pp_iterinit'.
4758 */
d4c19fe8 4759 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
551405c4 4760 LOGOP* const range = (LOGOP*) flip->op_first;
66a1b24b
AL		 4761 OP* const left = range->op_first;
4762 OP* const right = left->op_sibling;
5152d7c7 4763 LISTOP* listop;
89ea2908
GA		 4764
4765 range->op_flags &= ~OPf_KIDS;
5f66b61c 4766 range->op_first = NULL;
89ea2908 4767
5152d7c7 4768 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
1a67a97c
SM		 4769 listop->op_first->op_next = range->op_next;
4770 left->op_next = range->op_other;
5152d7c7
GS		 4771 right->op_next = (OP*)listop;
4772 listop->op_next = listop->op_first;
89ea2908 4773
eb8433b7
NC		 4774#ifdef PERL_MAD
4775 op_getmad(expr,(OP*)listop,'O');
4776#else
89ea2908 4777 op_free(expr);
eb8433b7 4778#endif
5152d7c7 4779 expr = (OP*)(listop);
93c66552 4780 op_null(expr);
89ea2908
GA		 4781 iterflags |= OPf_STACKED;
4782 }
4783 else {
4784 expr = mod(force_list(expr), OP_GREPSTART);
4785 }
4786
4633a7c4 4787 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
89ea2908 4788 append_elem(OP_LIST, expr, scalar(sv))));
85e6fe83 4789 assert(!loop->op_next);
241416b8 4790 /* for my $x () sets OPpLVAL_INTRO;
14f338dc 4791 * for our $x () sets OPpOUR_INTRO */
c5661c80 4792 loop->op_private = (U8)iterpflags;
b7dc083c 4793#ifdef PL_OP_SLAB_ALLOC
155aba94
GS		 4794 {
4795 LOOP *tmp;
4796 NewOp(1234,tmp,1,LOOP);
bd5f3bc4 4797 Copy(loop,tmp,1,LISTOP);
bfafaa29 4798 S_op_destroy(aTHX_ (OP*)loop);
155aba94
GS		 4799 loop = tmp;
4800 }
b7dc083c 4801#else
10edeb5d 4802 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
1c846c1f 4803#endif
85e6fe83 4804 loop->op_targ = padoff;
a034e688 4805 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
eb8433b7
NC		 4806 if (madsv)
4807 op_getmad(madsv, (OP*)loop, 'v');
53a7735b 4808 PL_parser->copline = forline;
fb73857a 4809 return newSTATEOP(0, label, wop);
79072805
LW		 4810}
4811
8990e307 4812OP*
864dbfa3 4813Perl_newLOOPEX(pTHX_ I32 type, OP *label)
8990e307 4814{
97aff369 4815 dVAR;
11343788 4816 OP *o;
2d8e6c8d 4817
8990e307 4818 if (type != OP_GOTO || label->op_type == OP_CONST) {
cdaebead
MB		 4819 /* "last()" means "last" */
4820 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4821 o = newOP(type, OPf_SPECIAL);
4822 else {
ea71c68d 4823 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
4ea561bc 4824 ? SvPV_nolen_const(((SVOP*)label)->op_sv)
666ea192 4825 : ""));
cdaebead 4826 }
eb8433b7
NC		 4827#ifdef PERL_MAD
4828 op_getmad(label,o,'L');
4829#else
8990e307 4830 op_free(label);
eb8433b7 4831#endif
8990e307
LW		 4832 }
4833 else {
e3aba57a
RGS		 4834 /* Check whether it's going to be a goto &function */
4835 if (label->op_type == OP_ENTERSUB
4836 && !(label->op_flags & OPf_STACKED))
a0d0e21e 4837 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
11343788 4838 o = newUNOP(type, OPf_STACKED, label);
8990e307 4839 }
3280af22 4840 PL_hints |= HINT_BLOCK_SCOPE;
11343788 4841 return o;
8990e307
LW		 4842}
4843
0d863452
RH		 4844/* if the condition is a literal array or hash
4845 (or @{ ... } etc), make a reference to it.
4846 */
4847STATIC OP *
4848S_ref_array_or_hash(pTHX_ OP *cond)
4849{
4850 if (cond
4851 && (cond->op_type == OP_RV2AV
4852 || cond->op_type == OP_PADAV
4853 || cond->op_type == OP_RV2HV
4854 || cond->op_type == OP_PADHV))
4855
4856 return newUNOP(OP_REFGEN,
4857 0, mod(cond, OP_REFGEN));
4858
4859 else
4860 return cond;
4861}
4862
4863/* These construct the optree fragments representing given()
4864 and when() blocks.
4865
4866 entergiven and enterwhen are LOGOPs; the op_other pointer
4867 points up to the associated leave op. We need this so we
4868 can put it in the context and make break/continue work.
4869 (Also, of course, pp_enterwhen will jump straight to
4870 op_other if the match fails.)
4871 */
4872
4136a0f7 4873STATIC OP *
0d863452
RH		 4874S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
4875 I32 enter_opcode, I32 leave_opcode,
4876 PADOFFSET entertarg)
4877{
97aff369 4878 dVAR;
0d863452
RH		 4879 LOGOP *enterop;
4880 OP *o;
4881
4882 NewOp(1101, enterop, 1, LOGOP);
4883 enterop->op_type = enter_opcode;
4884 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
4885 enterop->op_flags = (U8) OPf_KIDS;
4886 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
4887 enterop->op_private = 0;
4888
4889 o = newUNOP(leave_opcode, 0, (OP *) enterop);
4890
4891 if (cond) {
4892 enterop->op_first = scalar(cond);
4893 cond->op_sibling = block;
4894
4895 o->op_next = LINKLIST(cond);
4896 cond->op_next = (OP *) enterop;
4897 }
4898 else {
4899 /* This is a default {} block */
4900 enterop->op_first = block;
4901 enterop->op_flags |= OPf_SPECIAL;
4902
4903 o->op_next = (OP *) enterop;
4904 }
4905
4906 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
4907 entergiven and enterwhen both
4908 use ck_null() */
4909
4910 enterop->op_next = LINKLIST(block);
4911 block->op_next = enterop->op_other = o;
4912
4913 return o;
4914}
4915
4916/* Does this look like a boolean operation? For these purposes
4917 a boolean operation is:
4918 - a subroutine call [*]
4919 - a logical connective
4920 - a comparison operator
4921 - a filetest operator, with the exception of -s -M -A -C
4922 - defined(), exists() or eof()
4923 - /$re/ or $foo =~ /$re/
4924
4925 [*] possibly surprising
4926 */
4136a0f7 4927STATIC bool
ef519e13 4928S_looks_like_bool(pTHX_ const OP *o)
0d863452 4929{
97aff369 4930 dVAR;
0d863452
RH		 4931 switch(o->op_type) {
4932 case OP_OR:
4933 return looks_like_bool(cLOGOPo->op_first);
4934
4935 case OP_AND:
4936 return (
4937 looks_like_bool(cLOGOPo->op_first)
4938 && looks_like_bool(cLOGOPo->op_first->op_sibling));
4939
4940 case OP_ENTERSUB:
4941
4942 case OP_NOT: case OP_XOR:
4943 /* Note that OP_DOR is not here */
4944
4945 case OP_EQ: case OP_NE: case OP_LT:
4946 case OP_GT: case OP_LE: case OP_GE:
4947
4948 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
4949 case OP_I_GT: case OP_I_LE: case OP_I_GE:
4950
4951 case OP_SEQ: case OP_SNE: case OP_SLT:
4952 case OP_SGT: case OP_SLE: case OP_SGE:
4953
4954 case OP_SMARTMATCH:
4955
4956 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
4957 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
4958 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
4959 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
4960 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
4961 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
4962 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
4963 case OP_FTTEXT: case OP_FTBINARY:
4964
4965 case OP_DEFINED: case OP_EXISTS:
4966 case OP_MATCH: case OP_EOF:
4967
4968 return TRUE;
4969
4970 case OP_CONST:
4971 /* Detect comparisons that have been optimized away */
4972 if (cSVOPo->op_sv == &PL_sv_yes
4973 || cSVOPo->op_sv == &PL_sv_no)
4974
4975 return TRUE;
4976
4977 /* FALL THROUGH */
4978 default:
4979 return FALSE;
4980 }
4981}
4982
4983OP *
4984Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
4985{
97aff369 4986 dVAR;
0d863452
RH		 4987 assert( cond );
4988 return newGIVWHENOP(
4989 ref_array_or_hash(cond),
4990 block,
4991 OP_ENTERGIVEN, OP_LEAVEGIVEN,
4992 defsv_off);
4993}
4994
4995/* If cond is null, this is a default {} block */
4996OP *
4997Perl_newWHENOP(pTHX_ OP *cond, OP *block)
4998{
ef519e13 4999 const bool cond_llb = (!cond || looks_like_bool(cond));
0d863452
RH		 5000 OP *cond_op;
5001
5002 if (cond_llb)
5003 cond_op = cond;
5004 else {
5005 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
5006 newDEFSVOP(),
5007 scalar(ref_array_or_hash(cond)));
5008 }
5009
5010 return newGIVWHENOP(
5011 cond_op,
5012 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
5013 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
5014}
5015
7dafbf52
DM		 5016/*
5017=for apidoc cv_undef
5018
5019Clear out all the active components of a CV. This can happen either
5020by an explicit C<undef &foo>, or by the reference count going to zero.
5021In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
5022children can still follow the full lexical scope chain.
5023
5024=cut
5025*/
5026
79072805 5027void
864dbfa3 5028Perl_cv_undef(pTHX_ CV *cv)
79072805 5029{
27da23d5 5030 dVAR;
503de470
DM		 5031
5032 DEBUG_X(PerlIO_printf(Perl_debug_log,
5033 "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
5034 PTR2UV(cv), PTR2UV(PL_comppad))
5035 );
5036
a636914a 5037#ifdef USE_ITHREADS
aed2304a 5038 if (CvFILE(cv) && !CvISXSUB(cv)) {
35f1c1c7 5039 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
a636914a 5040 Safefree(CvFILE(cv));
a636914a 5041 }
b3123a61 5042 CvFILE(cv) = NULL;
a636914a
RH		 5043#endif
5044
aed2304a 5045 if (!CvISXSUB(cv) && CvROOT(cv)) {
bb172083 5046 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
cea2e8a9 5047 Perl_croak(aTHX_ "Can't undef active subroutine");
8990e307 5048 ENTER;
a0d0e21e 5049
f3548bdc 5050 PAD_SAVE_SETNULLPAD();
a0d0e21e 5051
282f25c9 5052 op_free(CvROOT(cv));
5f66b61c
AL		 5053 CvROOT(cv) = NULL;
5054 CvSTART(cv) = NULL;
8990e307 5055 LEAVE;
79072805 5056 }
1d5db326 5057 SvPOK_off((SV*)cv); /* forget prototype */
a0714e2c 5058 CvGV(cv) = NULL;
a3985cdc
DM		 5059
5060 pad_undef(cv);
5061
7dafbf52
DM		 5062 /* remove CvOUTSIDE unless this is an undef rather than a free */
5063 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
5064 if (!CvWEAKOUTSIDE(cv))
5065 SvREFCNT_dec(CvOUTSIDE(cv));
601f1833 5066 CvOUTSIDE(cv) = NULL;
7dafbf52 5067 }
beab0874
JT		 5068 if (CvCONST(cv)) {
5069 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
5070 CvCONST_off(cv);
5071 }
d04ba589 5072 if (CvISXSUB(cv) && CvXSUB(cv)) {
96a5add6 5073 CvXSUB(cv) = NULL;
50762d59 5074 }
7dafbf52
DM		 5075 /* delete all flags except WEAKOUTSIDE */
5076 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
79072805
LW		 5077}
5078
3fe9a6f1 5079void
cbf82dd0
NC		 5080Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5081 const STRLEN len)
5082{
5083 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5084 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
5085 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
5086 || (p && (len != SvCUR(cv) /* Not the same length. */
5087 || memNE(p, SvPVX_const(cv), len))))
5088 && ckWARN_d(WARN_PROTOTYPE)) {
2d03de9c 5089 SV* const msg = sv_newmortal();
a0714e2c 5090 SV* name = NULL;
3fe9a6f1 5091
5092 if (gv)
bd61b366 5093 gv_efullname3(name = sv_newmortal(), gv, NULL);
6502358f 5094 sv_setpvs(msg, "Prototype mismatch:");
46fc3d4c 5095 if (name)
be2597df 5096 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
3fe9a6f1 5097 if (SvPOK(cv))
be2597df 5098 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
ebe643b9 5099 else
396482e1
GA		 5100 sv_catpvs(msg, ": none");
5101 sv_catpvs(msg, " vs ");
46fc3d4c 5102 if (p)
cbf82dd0 5103 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
46fc3d4c 5104 else
396482e1 5105 sv_catpvs(msg, "none");
be2597df 5106 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
3fe9a6f1 5107 }
5108}
5109
35f1c1c7
SB		 5110static void const_sv_xsub(pTHX_ CV* cv);
5111
beab0874 5112/*
ccfc67b7
JH		 5113
5114=head1 Optree Manipulation Functions
5115
beab0874
JT		 5116=for apidoc cv_const_sv
5117
5118If C<cv> is a constant sub eligible for inlining. returns the constant
5119value returned by the sub. Otherwise, returns NULL.
5120
5121Constant subs can be created with C<newCONSTSUB> or as described in
5122L<perlsub/"Constant Functions">.
5123
5124=cut
5125*/
760ac839 5126SV *
864dbfa3 5127Perl_cv_const_sv(pTHX_ CV *cv)
760ac839 5128{
96a5add6 5129 PERL_UNUSED_CONTEXT;
5069cc75
NC		 5130 if (!cv)
5131 return NULL;
5132 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5133 return NULL;
5134 return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
fe5e78ed 5135}
760ac839 5136
b5c19bd7
DM		 5137/* op_const_sv: examine an optree to determine whether it's in-lineable.
5138 * Can be called in 3 ways:
5139 *
5140 * !cv
5141 * look for a single OP_CONST with attached value: return the value
5142 *
5143 * cv && CvCLONE(cv) && !CvCONST(cv)
5144 *
5145 * examine the clone prototype, and if contains only a single
5146 * OP_CONST referencing a pad const, or a single PADSV referencing
5147 * an outer lexical, return a non-zero value to indicate the CV is
5148 * a candidate for "constizing" at clone time
5149 *
5150 * cv && CvCONST(cv)
5151 *
5152 * We have just cloned an anon prototype that was marked as a const
5153 * candidiate. Try to grab the current value, and in the case of
5154 * PADSV, ignore it if it has multiple references. Return the value.
5155 */
5156
fe5e78ed 5157SV *
6867be6d 5158Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
fe5e78ed 5159{
97aff369 5160 dVAR;
a0714e2c 5161 SV *sv = NULL;
fe5e78ed 5162
c631f32b
GG		 5163 if (PL_madskills)
5164 return NULL;
5165
0f79a09d 5166 if (!o)
a0714e2c 5167 return NULL;
1c846c1f
NIS		 5168
5169 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
fe5e78ed
GS		 5170 o = cLISTOPo->op_first->op_sibling;
5171
5172 for (; o; o = o->op_next) {
890ce7af 5173 const OPCODE type = o->op_type;
fe5e78ed 5174
1c846c1f 5175 if (sv && o->op_next == o)
fe5e78ed 5176 return sv;
e576b457
JT		 5177 if (o->op_next != o) {
5178 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
5179 continue;
5180 if (type == OP_DBSTATE)
5181 continue;
5182 }
54310121 5183 if (type == OP_LEAVESUB || type == OP_RETURN)
5184 break;
5185 if (sv)
a0714e2c 5186 return NULL;
7766f137 5187 if (type == OP_CONST && cSVOPo->op_sv)
5dc0d613 5188 sv = cSVOPo->op_sv;
b5c19bd7 5189 else if (cv && type == OP_CONST) {
dd2155a4 5190 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
beab0874 5191 if (!sv)
a0714e2c 5192 return NULL;
b5c19bd7
DM		 5193 }
5194 else if (cv && type == OP_PADSV) {
5195 if (CvCONST(cv)) { /* newly cloned anon */
5196 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5197 /* the candidate should have 1 ref from this pad and 1 ref
5198 * from the parent */
5199 if (!sv || SvREFCNT(sv) != 2)
a0714e2c 5200 return NULL;
beab0874 5201 sv = newSVsv(sv);
b5c19bd7
DM		 5202 SvREADONLY_on(sv);
5203 return sv;
5204 }
5205 else {
5206 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
5207 sv = &PL_sv_undef; /* an arbitrary non-null value */
beab0874 5208 }
760ac839 5209 }
b5c19bd7 5210 else {
a0714e2c 5211 return NULL;
b5c19bd7 5212 }
760ac839
LW		 5213 }
5214 return sv;
5215}
5216
eb8433b7
NC		 5217#ifdef PERL_MAD
5218OP *
5219#else
09bef843 5220void
eb8433b7 5221#endif
09bef843
SB		 5222Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5223{
99129197
NC		 5224#if 0
5225 /* This would be the return value, but the return cannot be reached. */
eb8433b7
NC		 5226 OP* pegop = newOP(OP_NULL, 0);
5227#endif
5228
46c461b5
AL		 5229 PERL_UNUSED_ARG(floor);
5230
09bef843
SB		 5231 if (o)
5232 SAVEFREEOP(o);
5233 if (proto)
5234 SAVEFREEOP(proto);
5235 if (attrs)
5236 SAVEFREEOP(attrs);
5237 if (block)
5238 SAVEFREEOP(block);
5239 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
eb8433b7 5240#ifdef PERL_MAD
99129197 5241 NORETURN_FUNCTION_END;
eb8433b7 5242#endif
09bef843
SB		 5243}
5244
748a9306 5245CV *
864dbfa3 5246Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
79072805 5247{
5f66b61c 5248 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
09bef843
SB		 5249}
5250
5251CV *
5252Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5253{
27da23d5 5254 dVAR;
6867be6d 5255 const char *aname;
83ee9e09 5256 GV *gv;
5c144d81 5257 const char *ps;
ea6e9374 5258 STRLEN ps_len;
c445ea15 5259 register CV *cv = NULL;
beab0874 5260 SV *const_sv;
b48b272a
NC		 5261 /* If the subroutine has no body, no attributes, and no builtin attributes
5262 then it's just a sub declaration, and we may be able to get away with
5263 storing with a placeholder scalar in the symbol table, rather than a
5264 full GV and CV. If anything is present then it will take a full CV to
5265 store it. */
5266 const I32 gv_fetch_flags
eb8433b7
NC		 5267 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5268 || PL_madskills)
b48b272a 5269 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
4ea561bc 5270 const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
8e742a20
MHM		 5271
5272 if (proto) {
5273 assert(proto->op_type == OP_CONST);
4ea561bc 5274 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
8e742a20
MHM		 5275 }
5276 else
bd61b366 5277 ps = NULL;
8e742a20 5278
83ee9e09 5279 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
aec46f14 5280 SV * const sv = sv_newmortal();
c99da370
JH		 5281 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5282 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
83ee9e09 5283 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
b15aece3 5284 aname = SvPVX_const(sv);
83ee9e09
GS		 5285 }
5286 else
bd61b366 5287 aname = NULL;
61dbb99a 5288
61dbb99a 5289 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
666ea192
JH		 5290 : gv_fetchpv(aname ? aname
5291 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
61dbb99a 5292 gv_fetch_flags, SVt_PVCV);
83ee9e09 5293
eb8433b7
NC		 5294 if (!PL_madskills) {
5295 if (o)
5296 SAVEFREEOP(o);
5297 if (proto)
5298 SAVEFREEOP(proto);
5299 if (attrs)
5300 SAVEFREEOP(attrs);
5301 }
3fe9a6f1 5302
09bef843 5303 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
55d729e4
GS		 5304 maximum a prototype before. */
5305 if (SvTYPE(gv) > SVt_NULL) {
0453d815 5306 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
e476b1b5 5307 && ckWARN_d(WARN_PROTOTYPE))
f248d071 5308 {
9014280d 5309 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
f248d071 5310 }
cbf82dd0 5311 cv_ckproto_len((CV*)gv, NULL, ps, ps_len);
55d729e4
GS		 5312 }
5313 if (ps)
ea6e9374 5314 sv_setpvn((SV*)gv, ps, ps_len);
55d729e4
GS		 5315 else
5316 sv_setiv((SV*)gv, -1);
e1a479c5 5317
3280af22
NIS		 5318 SvREFCNT_dec(PL_compcv);
5319 cv = PL_compcv = NULL;
beab0874 5320 goto done;
55d729e4
GS		 5321 }
5322
601f1833 5323 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
beab0874 5324
7fb37951
AMS		 5325#ifdef GV_UNIQUE_CHECK
5326 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
5327 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
5bd07a3d
DM		 5328 }
5329#endif
5330
eb8433b7
NC		 5331 if (!block || !ps || *ps || attrs
5332 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5333#ifdef PERL_MAD
5334 || block->op_type == OP_NULL
5335#endif
5336 )
a0714e2c 5337 const_sv = NULL;
beab0874 5338 else
601f1833 5339 const_sv = op_const_sv(block, NULL);
beab0874
JT		 5340
5341 if (cv) {
6867be6d 5342 const bool exists = CvROOT(cv) || CvXSUB(cv);
5bd07a3d 5343
7fb37951
AMS		 5344#ifdef GV_UNIQUE_CHECK
5345 if (exists && GvUNIQUE(gv)) {
5346 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5bd07a3d
DM		 5347 }
5348#endif
5349
60ed1d8c
GS		 5350 /* if the subroutine doesn't exist and wasn't pre-declared
5351 * with a prototype, assume it will be AUTOLOADed,
5352 * skipping the prototype check
5353 */
5354 if (exists || SvPOK(cv))
cbf82dd0 5355 cv_ckproto_len(cv, gv, ps, ps_len);
68dc0745 5356 /* already defined (or promised)? */
60ed1d8c 5357 if (exists || GvASSUMECV(gv)) {
eb8433b7
NC		 5358 if ((!block
5359#ifdef PERL_MAD
5360 || block->op_type == OP_NULL
5361#endif
5362 )&& !attrs) {
d3cea301
SB		 5363 if (CvFLAGS(PL_compcv)) {
5364 /* might have had built-in attrs applied */
5365 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5366 }
aa689395 5367 /* just a "sub foo;" when &foo is already defined */
3280af22 5368 SAVEFREESV(PL_compcv);
aa689395 5369 goto done;
5370 }
eb8433b7
NC		 5371 if (block
5372#ifdef PERL_MAD
5373 && block->op_type != OP_NULL
5374#endif
5375 ) {
beab0874
JT		 5376 if (ckWARN(WARN_REDEFINE)
5377 || (CvCONST(cv)
5378 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5379 {
6867be6d 5380 const line_t oldline = CopLINE(PL_curcop);
53a7735b
DM		 5381 if (PL_parser && PL_parser->copline != NOLINE)
5382 CopLINE_set(PL_curcop, PL_parser->copline);
9014280d 5383 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
666ea192
JH		 5384 CvCONST(cv) ? "Constant subroutine %s redefined"
5385 : "Subroutine %s redefined", name);
beab0874
JT		 5386 CopLINE_set(PL_curcop, oldline);
5387 }
eb8433b7
NC		 5388#ifdef PERL_MAD
5389 if (!PL_minus_c) /* keep old one around for madskills */
5390#endif
5391 {
5392 /* (PL_madskills unset in used file.) */
5393 SvREFCNT_dec(cv);
5394 }
601f1833 5395 cv = NULL;
79072805 5396 }
79072805
LW		 5397 }
5398 }
beab0874 5399 if (const_sv) {
f84c484e 5400 SvREFCNT_inc_simple_void_NN(const_sv);
beab0874 5401 if (cv) {
0768512c 5402 assert(!CvROOT(cv) && !CvCONST(cv));
c69006e4 5403 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
beab0874
JT		 5404 CvXSUBANY(cv).any_ptr = const_sv;
5405 CvXSUB(cv) = const_sv_xsub;
5406 CvCONST_on(cv);
d04ba589 5407 CvISXSUB_on(cv);
beab0874
JT		 5408 }
5409 else {
601f1833 5410 GvCV(gv) = NULL;
beab0874
JT		 5411 cv = newCONSTSUB(NULL, name, const_sv);
5412 }
e1a479c5
BB		 5413 mro_method_changed_in( /* sub Foo::Bar () { 123 } */
5414 (CvGV(cv) && GvSTASH(CvGV(cv)))
5415 ? GvSTASH(CvGV(cv))
5416 : CvSTASH(cv)
5417 ? CvSTASH(cv)
5418 : PL_curstash
5419 );
eb8433b7
NC		 5420 if (PL_madskills)
5421 goto install_block;
beab0874
JT		 5422 op_free(block);
5423 SvREFCNT_dec(PL_compcv);
5424 PL_compcv = NULL;
beab0874
JT		 5425 goto done;
5426 }
09bef843
SB		 5427 if (attrs) {
5428 HV *stash;
5429 SV *rcv;
5430
5431 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
5432 * before we clobber PL_compcv.
5433 */
99129197 5434 if (cv && (!block
eb8433b7
NC		 5435#ifdef PERL_MAD
5436 || block->op_type == OP_NULL
5437#endif
5438 )) {
09bef843 5439 rcv = (SV*)cv;
020f0e03
SB		 5440 /* Might have had built-in attributes applied -- propagate them. */
5441 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
a9164de8 5442 if (CvGV(cv) && GvSTASH(CvGV(cv)))
09bef843 5443 stash = GvSTASH(CvGV(cv));
a9164de8 5444 else if (CvSTASH(cv))
09bef843
SB		 5445 stash = CvSTASH(cv);
5446 else
5447 stash = PL_curstash;
5448 }
5449 else {
5450 /* possibly about to re-define existing subr -- ignore old cv */
5451 rcv = (SV*)PL_compcv;
a9164de8 5452 if (name && GvSTASH(gv))
09bef843
SB		 5453 stash = GvSTASH(gv);
5454 else
5455 stash = PL_curstash;
5456 }
95f0a2f1 5457 apply_attrs(stash, rcv, attrs, FALSE);
09bef843 5458 }
a0d0e21e 5459 if (cv) { /* must reuse cv if autoloaded */
eb8433b7
NC		 5460 if (
5461#ifdef PERL_MAD
5462 (
5463#endif
5464 !block
5465#ifdef PERL_MAD
5466 || block->op_type == OP_NULL) && !PL_madskills
5467#endif
5468 ) {
09bef843
SB		 5469 /* got here with just attrs -- work done, so bug out */
5470 SAVEFREESV(PL_compcv);
5471 goto done;
5472 }
a3985cdc 5473 /* transfer PL_compcv to cv */
4633a7c4 5474 cv_undef(cv);
3280af22 5475 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5c41a5fa
DM		 5476 if (!CvWEAKOUTSIDE(cv))
5477 SvREFCNT_dec(CvOUTSIDE(cv));
3280af22 5478 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
a3985cdc 5479 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
3280af22
NIS		 5480 CvOUTSIDE(PL_compcv) = 0;
5481 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5482 CvPADLIST(PL_compcv) = 0;
282f25c9 5483 /* inner references to PL_compcv must be fixed up ... */
dd2155a4 5484 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
282f25c9 5485 /* ... before we throw it away */
3280af22 5486 SvREFCNT_dec(PL_compcv);
b5c19bd7 5487 PL_compcv = cv;
a933f601
IZ		 5488 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5489 ++PL_sub_generation;
a0d0e21e
LW		 5490 }
5491 else {
3280af22 5492 cv = PL_compcv;
44a8e56a 5493 if (name) {
5494 GvCV(gv) = cv;
eb8433b7
NC		 5495 if (PL_madskills) {
5496 if (strEQ(name, "import")) {
5497 PL_formfeed = (SV*)cv;
5498 Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5499 }
5500 }
44a8e56a 5501 GvCVGEN(gv) = 0;
e1a479c5 5502 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
44a8e56a 5503 }
a0d0e21e 5504 }
65c50114 5505 CvGV(cv) = gv;
a636914a 5506 CvFILE_set_from_cop(cv, PL_curcop);
3280af22 5507 CvSTASH(cv) = PL_curstash;
8990e307 5508
3fe9a6f1 5509 if (ps)
ea6e9374 5510 sv_setpvn((SV*)cv, ps, ps_len);
4633a7c4 5511
13765c85 5512 if (PL_parser && PL_parser->error_count) {
c07a80fd 5513 op_free(block);
5f66b61c 5514 block = NULL;
68dc0745 5515 if (name) {
6867be6d 5516 const char *s = strrchr(name, ':');
68dc0745 5517 s = s ? s+1 : name;
6d4c2119 5518 if (strEQ(s, "BEGIN")) {
e1ec3a88 5519 const char not_safe[] =
6d4c2119 5520 "BEGIN not safe after errors--compilation aborted";
faef0170 5521 if (PL_in_eval & EVAL_KEEPERR)
cea2e8a9 5522 Perl_croak(aTHX_ not_safe);
6d4c2119
CS		 5523 else {
5524 /* force display of errors found but not reported */
38a03e6e 5525 sv_catpv(ERRSV, not_safe);
be2597df 5526 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
6d4c2119
CS		 5527 }
5528 }
68dc0745 5529 }
c07a80fd 5530 }
eb8433b7 5531 install_block:
beab0874
JT		 5532 if (!block)
5533 goto done;
a0d0e21e 5534
7766f137 5535 if (CvLVALUE(cv)) {
78f9721b
SM		 5536 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5537 mod(scalarseq(block), OP_LEAVESUBLV));
7e5d8ed2 5538 block->op_attached = 1;
7766f137
GS		 5539 }
5540 else {
09c2fd24
AE		 5541 /* This makes sub {}; work as expected. */
5542 if (block->op_type == OP_STUB) {
1496a290 5543 OP* const newblock = newSTATEOP(0, NULL, 0);
eb8433b7
NC		 5544#ifdef PERL_MAD
5545 op_getmad(block,newblock,'B');
5546#else
09c2fd24 5547 op_free(block);
eb8433b7
NC		 5548#endif
5549 block = newblock;
09c2fd24 5550 }
7e5d8ed2
DM		 5551 else
5552 block->op_attached = 1;
7766f137
GS		 5553 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5554 }
5555 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5556 OpREFCNT_set(CvROOT(cv), 1);
5557 CvSTART(cv) = LINKLIST(CvROOT(cv));
5558 CvROOT(cv)->op_next = 0;
a2efc822 5559 CALL_PEEP(CvSTART(cv));
7766f137
GS		 5560
5561 /* now that optimizer has done its work, adjust pad values */
54310121 5562
dd2155a4
DM		 5563 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5564
5565 if (CvCLONE(cv)) {
beab0874
JT		 5566 assert(!CvCONST(cv));
5567 if (ps && !*ps && op_const_sv(block, cv))
5568 CvCONST_on(cv);
a0d0e21e 5569 }
79072805 5570
83ee9e09 5571 if (name || aname) {
3280af22 5572 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
561b68a9 5573 SV * const sv = newSV(0);
c4420975 5574 SV * const tmpstr = sv_newmortal();
5c1737d1
NC		 5575 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5576 GV_ADDMULTI, SVt_PVHV);
44a8e56a 5577 HV *hv;
5578
ed094faf
GS		 5579 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5580 CopFILE(PL_curcop),
cc49e20b 5581 (long)PL_subline, (long)CopLINE(PL_curcop));
bd61b366 5582 gv_efullname3(tmpstr, gv, NULL);
b15aece3 5583 hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
44a8e56a 5584 hv = GvHVn(db_postponed);
551405c4
AL		 5585 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5586 CV * const pcv = GvCV(db_postponed);
5587 if (pcv) {
5588 dSP;
5589 PUSHMARK(SP);
5590 XPUSHs(tmpstr);
5591 PUTBACK;
5592 call_sv((SV*)pcv, G_DISCARD);
5593 }
44a8e56a 5594 }
5595 }
79072805 5596
13765c85 5597 if (name && ! (PL_parser && PL_parser->error_count))
0cd10f52 5598 process_special_blocks(name, gv, cv);
33fb7a6e 5599 }
ed094faf 5600
33fb7a6e 5601 done:
53a7735b
DM		 5602 if (PL_parser)
5603 PL_parser->copline = NOLINE;
33fb7a6e
NC		 5604 LEAVE_SCOPE(floor);
5605 return cv;
5606}
ed094faf 5607
33fb7a6e
NC		 5608STATIC void
5609S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
5610 CV *const cv)
5611{
5612 const char *const colon = strrchr(fullname,':');
5613 const char *const name = colon ? colon + 1 : fullname;
5614
5615 if (*name == 'B') {
6952d67e 5616 if (strEQ(name, "BEGIN")) {
6867be6d 5617 const I32 oldscope = PL_scopestack_ix;
28757baa 5618 ENTER;
57843af0
GS		 5619 SAVECOPFILE(&PL_compiling);
5620 SAVECOPLINE(&PL_compiling);
28757baa 5621
28757baa 5622 DEBUG_x( dump_sub(gv) );
29a861e7 5623 Perl_av_create_and_push(aTHX_ &PL_beginav, (SV*)cv);
ea2f84a3 5624 GvCV(gv) = 0; /* cv has been hijacked */
3280af22 5625 call_list(oldscope, PL_beginav);
a6006777 5626
3280af22 5627 PL_curcop = &PL_compiling;
623e6609 5628 CopHINTS_set(&PL_compiling, PL_hints);
28757baa 5629 LEAVE;
5630 }
33fb7a6e
NC		 5631 else
5632 return;
5633 } else {
5634 if (*name == 'E') {
5635 if strEQ(name, "END") {
5636 DEBUG_x( dump_sub(gv) );
5637 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, (SV*)cv);
5638 } else
5639 return;
5640 } else if (*name == 'U') {
5641 if (strEQ(name, "UNITCHECK")) {
5642 /* It's never too late to run a unitcheck block */
5643 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, (SV*)cv);
5644 }
5645 else
5646 return;
5647 } else if (*name == 'C') {
5648 if (strEQ(name, "CHECK")) {
5649 if (PL_main_start && ckWARN(WARN_VOID))
5650 Perl_warner(aTHX_ packWARN(WARN_VOID),
5651 "Too late to run CHECK block");
5652 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, (SV*)cv);
5653 }
5654 else
5655 return;
5656 } else if (*name == 'I') {
5657 if (strEQ(name, "INIT")) {
5658 if (PL_main_start && ckWARN(WARN_VOID))
5659 Perl_warner(aTHX_ packWARN(WARN_VOID),
5660 "Too late to run INIT block");
5661 Perl_av_create_and_push(aTHX_ &PL_initav, (SV*)cv);
5662 }
5663 else
5664 return;
5665 } else
5666 return;
5667 DEBUG_x( dump_sub(gv) );
5668 GvCV(gv) = 0; /* cv has been hijacked */
79072805 5669 }
79072805
LW		 5670}
5671
954c1994
GS		 5672/*
5673=for apidoc newCONSTSUB
5674
5675Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5676eligible for inlining at compile-time.
5677
5678=cut
5679*/
5680
beab0874 5681CV *
e1ec3a88 5682Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5476c433 5683{
27da23d5 5684 dVAR;
beab0874 5685 CV* cv;
cbf82dd0
NC		 5686#ifdef USE_ITHREADS
5687 const char *const temp_p = CopFILE(PL_curcop);
07fcac01 5688 const STRLEN len = temp_p ? strlen(temp_p) : 0;
cbf82dd0
NC		 5689#else
5690 SV *const temp_sv = CopFILESV(PL_curcop);
5691 STRLEN len;
5692 const char *const temp_p = temp_sv ? SvPV_const(temp_sv, len) : NULL;
5693#endif
07fcac01 5694 char *const file = savepvn(temp_p, temp_p ? len : 0);
5476c433 5695
11faa288 5696 ENTER;
11faa288 5697
f4dd75d9 5698 SAVECOPLINE(PL_curcop);
53a7735b 5699 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
f4dd75d9
GS		 5700
5701 SAVEHINTS();
3280af22 5702 PL_hints &= ~HINT_BLOCK_SCOPE;
11faa288
GS		 5703
5704 if (stash) {
5705 SAVESPTR(PL_curstash);
5706 SAVECOPSTASH(PL_curcop);
5707 PL_curstash = stash;
05ec9bb3 5708 CopSTASH_set(PL_curcop,stash);
11faa288 5709 }
5476c433 5710
cbf82dd0
NC		 5711 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
5712 and so doesn't get free()d. (It's expected to be from the C pre-
5713 processor __FILE__ directive). But we need a dynamically allocated one,
77004dee
NC		 5714 and we need it to get freed. */
5715 cv = newXS_flags(name, const_sv_xsub, file, "", XS_DYNAMIC_FILENAME);
beab0874
JT		 5716 CvXSUBANY(cv).any_ptr = sv;
5717 CvCONST_on(cv);
c3db7d92 5718 Safefree(file);
5476c433 5719
65e66c80 5720#ifdef USE_ITHREADS
02f28d44
MHM		 5721 if (stash)
5722 CopSTASH_free(PL_curcop);
65e66c80 5723#endif
11faa288 5724 LEAVE;
beab0874
JT		 5725
5726 return cv;
5476c433
JD		 5727}
5728
77004dee
NC		 5729CV *
5730Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
5731 const char *const filename, const char *const proto,
5732 U32 flags)
5733{
5734 CV *cv = newXS(name, subaddr, filename);
5735
5736 if (flags & XS_DYNAMIC_FILENAME) {
5737 /* We need to "make arrangements" (ie cheat) to ensure that the
5738 filename lasts as long as the PVCV we just created, but also doesn't
5739 leak */
5740 STRLEN filename_len = strlen(filename);
5741 STRLEN proto_and_file_len = filename_len;
5742 char *proto_and_file;
5743 STRLEN proto_len;
5744
5745 if (proto) {
5746 proto_len = strlen(proto);
5747 proto_and_file_len += proto_len;
5748
5749 Newx(proto_and_file, proto_and_file_len + 1, char);
5750 Copy(proto, proto_and_file, proto_len, char);
5751 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
5752 } else {
5753 proto_len = 0;
5754 proto_and_file = savepvn(filename, filename_len);
5755 }
5756
5757 /* This gets free()d. :-) */
5758 sv_usepvn_flags((SV*)cv, proto_and_file, proto_and_file_len,
5759 SV_HAS_TRAILING_NUL);
5760 if (proto) {
5761 /* This gives us the correct prototype, rather than one with the
5762 file name appended. */
5763 SvCUR_set(cv, proto_len);
5764 } else {
5765 SvPOK_off(cv);
5766 }
81a2b3b6 5767 CvFILE(cv) = proto_and_file + proto_len;
77004dee
NC		 5768 } else {
5769 sv_setpv((SV *)cv, proto);
5770 }
5771 return cv;
5772}
5773
954c1994
GS		 5774/*
5775=for apidoc U||newXS
5776
77004dee
NC		 5777Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
5778static storage, as it is used directly as CvFILE(), without a copy being made.
954c1994
GS		 5779
5780=cut
5781*/
5782
57d3b86d 5783CV *
bfed75c6 5784Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
a0d0e21e 5785{
97aff369 5786 dVAR;
666ea192
JH		 5787 GV * const gv = gv_fetchpv(name ? name :
5788 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5789 GV_ADDMULTI, SVt_PVCV);
79072805 5790 register CV *cv;
44a8e56a 5791
1ecdd9a8
HS		 5792 if (!subaddr)
5793 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
5794
601f1833 5795 if ((cv = (name ? GvCV(gv) : NULL))) {
44a8e56a 5796 if (GvCVGEN(gv)) {
5797 /* just a cached method */
5798 SvREFCNT_dec(cv);
601f1833 5799 cv = NULL;
44a8e56a 5800 }
5801 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5802 /* already defined (or promised) */
1df70142 5803 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
66a1b24b
AL		 5804 if (ckWARN(WARN_REDEFINE)) {
5805 GV * const gvcv = CvGV(cv);
5806 if (gvcv) {
5807 HV * const stash = GvSTASH(gvcv);
5808 if (stash) {
8b38226b
AL		 5809 const char *redefined_name = HvNAME_get(stash);
5810 if ( strEQ(redefined_name,"autouse") ) {
66a1b24b 5811 const line_t oldline = CopLINE(PL_curcop);
53a7735b
DM		 5812 if (PL_parser && PL_parser->copline != NOLINE)
5813 CopLINE_set(PL_curcop, PL_parser->copline);
66a1b24b 5814 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
666ea192
JH		 5815 CvCONST(cv) ? "Constant subroutine %s redefined"
5816 : "Subroutine %s redefined"
5817 ,name);
66a1b24b
AL		 5818 CopLINE_set(PL_curcop, oldline);
5819 }
5820 }
5821 }
a0d0e21e
LW		 5822 }
5823 SvREFCNT_dec(cv);
601f1833 5824 cv = NULL;
79072805 5825 }
79072805 5826 }
44a8e56a 5827
5828 if (cv) /* must reuse cv if autoloaded */
5829 cv_undef(cv);
a0d0e21e 5830 else {
b9f83d2f 5831 cv = (CV*)newSV_type(SVt_PVCV);
44a8e56a 5832 if (name) {
5833 GvCV(gv) = cv;
5834 GvCVGEN(gv) = 0;
e1a479c5 5835 mro_method_changed_in(GvSTASH(gv)); /* newXS */
44a8e56a 5836 }
a0d0e21e 5837 }
65c50114 5838 CvGV(cv) = gv;
b195d487 5839 (void)gv_fetchfile(filename);
dd374669 5840 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
57843af0 5841 an external constant string */
d04ba589 5842 CvISXSUB_on(cv);
a0d0e21e 5843 CvXSUB(cv) = subaddr;
44a8e56a 5844
33fb7a6e
NC		 5845 if (name)
5846 process_special_blocks(name, gv, cv);
8990e307 5847 else
a5f75d66 5848 CvANON_on(cv);
44a8e56a 5849
a0d0e21e 5850 return cv;
79072805
LW		 5851}
5852
eb8433b7
NC		 5853#ifdef PERL_MAD
5854OP *
5855#else
79072805 5856void
eb8433b7 5857#endif
864dbfa3 5858Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
79072805 5859{
97aff369 5860 dVAR;
79072805 5861 register CV *cv;
eb8433b7
NC		 5862#ifdef PERL_MAD
5863 OP* pegop = newOP(OP_NULL, 0);
5864#endif
79072805 5865
0bd48802 5866 GV * const gv = o
f776e3cd 5867 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
fafc274c 5868 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
0bd48802 5869
7fb37951
AMS		 5870#ifdef GV_UNIQUE_CHECK
5871 if (GvUNIQUE(gv)) {
666ea192 5872 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5bd07a3d
DM		 5873 }
5874#endif
a5f75d66 5875 GvMULTI_on(gv);
155aba94 5876 if ((cv = GvFORM(gv))) {
599cee73 5877 if (ckWARN(WARN_REDEFINE)) {
6867be6d 5878 const line_t oldline = CopLINE(PL_curcop);
53a7735b
DM		 5879 if (PL_parser && PL_parser->copline != NOLINE)
5880 CopLINE_set(PL_curcop, PL_parser->copline);
7a5fd60d 5881 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
666ea192 5882 o ? "Format %"SVf" redefined"
be2597df 5883 : "Format STDOUT redefined", SVfARG(cSVOPo->op_sv));
57843af0 5884 CopLINE_set(PL_curcop, oldline);
79072805 5885 }
8990e307 5886 SvREFCNT_dec(cv);
79072805 5887 }
3280af22 5888 cv = PL_compcv;
79072805 5889 GvFORM(gv) = cv;
65c50114 5890 CvGV(cv) = gv;
a636914a 5891 CvFILE_set_from_cop(cv, PL_curcop);
79072805 5892
a0d0e21e 5893
dd2155a4 5894 pad_tidy(padtidy_FORMAT);
79072805 5895 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
7934575e
GS		 5896 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5897 OpREFCNT_set(CvROOT(cv), 1);
79072805
LW		 5898 CvSTART(cv) = LINKLIST(CvROOT(cv));
5899 CvROOT(cv)->op_next = 0;
a2efc822 5900 CALL_PEEP(CvSTART(cv));
eb8433b7
NC		 5901#ifdef PERL_MAD
5902 op_getmad(o,pegop,'n');
5903 op_getmad_weak(block, pegop, 'b');
5904#else
11343788 5905 op_free(o);
eb8433b7 5906#endif
53a7735b
DM		 5907 if (PL_parser)
5908 PL_parser->copline = NOLINE;
8990e307 5909 LEAVE_SCOPE(floor);
eb8433b7
NC		 5910#ifdef PERL_MAD
5911 return pegop;
5912#endif
79072805
LW		 5913}
5914
5915OP *
864dbfa3 5916Perl_newANONLIST(pTHX_ OP *o)
79072805 5917{
78c72037 5918 return convert(OP_ANONLIST, OPf_SPECIAL, o);
79072805
LW		 5919}
5920
5921OP *
864dbfa3 5922Perl_newANONHASH(pTHX_ OP *o)
79072805 5923{
78c72037 5924 return convert(OP_ANONHASH, OPf_SPECIAL, o);
a0d0e21e
LW		 5925}
5926
5927OP *
864dbfa3 5928Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
a0d0e21e 5929{
5f66b61c 5930 return newANONATTRSUB(floor, proto, NULL, block);
09bef843
SB		 5931}
5932
5933OP *
5934Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5935{
a0d0e21e 5936 return newUNOP(OP_REFGEN, 0,
09bef843
SB		 5937 newSVOP(OP_ANONCODE, 0,
5938 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
79072805
LW		 5939}
5940
5941OP *
864dbfa3 5942Perl_oopsAV(pTHX_ OP *o)
79072805 5943{
27da23d5 5944 dVAR;
ed6116ce
LW		 5945 switch (o->op_type) {
5946 case OP_PADSV:
5947 o->op_type = OP_PADAV;
22c35a8c 5948 o->op_ppaddr = PL_ppaddr[OP_PADAV];
51e247a3 5949 return ref(o, OP_RV2AV);
b2ffa427 5950
ed6116ce 5951 case OP_RV2SV:
79072805 5952 o->op_type = OP_RV2AV;
22c35a8c 5953 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
79072805 5954 ref(o, OP_RV2AV);
ed6116ce
LW		 5955 break;
5956
5957 default:
0453d815 5958 if (ckWARN_d(WARN_INTERNAL))
9014280d 5959 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
ed6116ce
LW		 5960 break;
5961 }
79072805
LW		 5962 return o;
5963}
5964
5965OP *
864dbfa3 5966Perl_oopsHV(pTHX_ OP *o)
79072805 5967{
27da23d5 5968 dVAR;
ed6116ce
LW		 5969 switch (o->op_type) {
5970 case OP_PADSV:
5971 case OP_PADAV:
5972 o->op_type = OP_PADHV;
22c35a8c 5973 o->op_ppaddr = PL_ppaddr[OP_PADHV];
51e247a3 5974 return ref(o, OP_RV2HV);
ed6116ce
LW		 5975
5976 case OP_RV2SV:
5977 case OP_RV2AV:
79072805 5978 o->op_type = OP_RV2HV;
22c35a8c 5979 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
79072805 5980 ref(o, OP_RV2HV);
ed6116ce
LW		 5981 break;
5982
5983 default:
0453d815 5984 if (ckWARN_d(WARN_INTERNAL))
9014280d 5985 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
ed6116ce
LW		 5986 break;
5987 }
79072805
LW		 5988 return o;
5989}
5990
5991OP *
864dbfa3 5992Perl_newAVREF(pTHX_ OP *o)
79072805 5993{
27da23d5 5994 dVAR;
ed6116ce
LW		 5995 if (o->op_type == OP_PADANY) {
5996 o->op_type = OP_PADAV;
22c35a8c 5997 o->op_ppaddr = PL_ppaddr[OP_PADAV];
93a17b20 5998 return o;
ed6116ce 5999 }
a1063b2d 6000 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
9014280d
PM		 6001 && ckWARN(WARN_DEPRECATED)) {
6002 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
a1063b2d
RH		 6003 "Using an array as a reference is deprecated");
6004 }
79072805
LW		 6005 return newUNOP(OP_RV2AV, 0, scalar(o));
6006}
6007
6008OP *
864dbfa3 6009Perl_newGVREF(pTHX_ I32 type, OP *o)
79072805 6010{
82092f1d 6011 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
a0d0e21e 6012 return newUNOP(OP_NULL, 0, o);
748a9306 6013 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
79072805
LW		 6014}
6015
6016OP *
864dbfa3 6017Perl_newHVREF(pTHX_ OP *o)
79072805 6018{
27da23d5 6019 dVAR;
ed6116ce
LW		 6020 if (o->op_type == OP_PADANY) {
6021 o->op_type = OP_PADHV;
22c35a8c 6022 o->op_ppaddr = PL_ppaddr[OP_PADHV];
93a17b20 6023 return o;
ed6116ce 6024 }
a1063b2d 6025 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
9014280d
PM		 6026 && ckWARN(WARN_DEPRECATED)) {
6027 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
a1063b2d
RH		 6028 "Using a hash as a reference is deprecated");
6029 }
79072805
LW		 6030 return newUNOP(OP_RV2HV, 0, scalar(o));
6031}
6032
6033OP *
864dbfa3 6034Perl_newCVREF(pTHX_ I32 flags, OP *o)
79072805 6035{
c07a80fd 6036 return newUNOP(OP_RV2CV, flags, scalar(o));
79072805
LW		 6037}
6038
6039OP *
864dbfa3 6040Perl_newSVREF(pTHX_ OP *o)
79072805 6041{
27da23d5 6042 dVAR;
ed6116ce
LW		 6043 if (o->op_type == OP_PADANY) {
6044 o->op_type = OP_PADSV;
22c35a8c 6045 o->op_ppaddr = PL_ppaddr[OP_PADSV];
93a17b20 6046 return o;
ed6116ce 6047 }
79072805
LW		 6048 return newUNOP(OP_RV2SV, 0, scalar(o));
6049}
6050
61b743bb
DM		 6051/* Check routines. See the comments at the top of this file for details
6052 * on when these are called */
79072805
LW		 6053
6054OP *
cea2e8a9 6055Perl_ck_anoncode(pTHX_ OP *o)
5f05dabc 6056{
dd2155a4 6057 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
eb8433b7 6058 if (!PL_madskills)
1d866c12 6059 cSVOPo->op_sv = NULL;
5dc0d613 6060 return o;
5f05dabc 6061}
6062
6063OP *
cea2e8a9 6064Perl_ck_bitop(pTHX_ OP *o)
55497cff 6065{
97aff369 6066 dVAR;
276b2a0c
RGS		 6067#define OP_IS_NUMCOMPARE(op) \
6068 ((op) == OP_LT || (op) == OP_I_LT || \
6069 (op) == OP_GT || (op) == OP_I_GT || \
6070 (op) == OP_LE || (op) == OP_I_LE || \
6071 (op) == OP_GE || (op) == OP_I_GE || \
6072 (op) == OP_EQ || (op) == OP_I_EQ || \
6073 (op) == OP_NE || (op) == OP_I_NE || \
6074 (op) == OP_NCMP || (op) == OP_I_NCMP)
d5ec2987 6075 o->op_private = (U8)(PL_hints & HINT_INTEGER);
2b84528b
RGS		 6076 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6077 && (o->op_type == OP_BIT_OR
6078 || o->op_type == OP_BIT_AND
6079 || o->op_type == OP_BIT_XOR))
276b2a0c 6080 {
1df70142
AL		 6081 const OP * const left = cBINOPo->op_first;
6082 const OP * const right = left->op_sibling;
96a925ab
YST		 6083 if ((OP_IS_NUMCOMPARE(left->op_type) &&
6084 (left->op_flags & OPf_PARENS) == 0) ||
6085 (OP_IS_NUMCOMPARE(right->op_type) &&
6086 (right->op_flags & OPf_PARENS) == 0))
276b2a0c
RGS		 6087 if (ckWARN(WARN_PRECEDENCE))
6088 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6089 "Possible precedence problem on bitwise %c operator",
6090 o->op_type == OP_BIT_OR ? '|'
6091 : o->op_type == OP_BIT_AND ? '&' : '^'
6092 );
6093 }
5dc0d613 6094 return o;
55497cff 6095}
6096
6097OP *
cea2e8a9 6098Perl_ck_concat(pTHX_ OP *o)
79072805 6099{
0bd48802 6100 const OP * const kid = cUNOPo->op_first;
96a5add6 6101 PERL_UNUSED_CONTEXT;
df91b2c5
AE		 6102 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6103 !(kUNOP->op_first->op_flags & OPf_MOD))
0165acc7 6104 o->op_flags |= OPf_STACKED;
11343788 6105 return o;
79072805
LW		 6106}
6107
6108OP *
cea2e8a9 6109Perl_ck_spair(pTHX_ OP *o)
79072805 6110{
27da23d5 6111 dVAR;
11343788 6112 if (o->op_flags & OPf_KIDS) {
79072805 6113 OP* newop;
a0d0e21e 6114 OP* kid;
6867be6d 6115 const OPCODE type = o->op_type;
5dc0d613 6116 o = modkids(ck_fun(o), type);
11343788 6117 kid = cUNOPo->op_first;
a0d0e21e 6118 newop = kUNOP->op_first->op_sibling;
1496a290
AL		 6119 if (newop) {
6120 const OPCODE type = newop->op_type;
6121 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6122 type == OP_PADAV || type == OP_PADHV ||
6123 type == OP_RV2AV || type == OP_RV2HV)
6124 return o;
a0d0e21e 6125 }
eb8433b7
NC		 6126#ifdef PERL_MAD
6127 op_getmad(kUNOP->op_first,newop,'K');
6128#else
a0d0e21e 6129 op_free(kUNOP->op_first);
eb8433b7 6130#endif
a0d0e21e
LW		 6131 kUNOP->op_first = newop;
6132 }
22c35a8c 6133 o->op_ppaddr = PL_ppaddr[++o->op_type];
11343788 6134 return ck_fun(o);
a0d0e21e
LW		 6135}
6136
6137OP *
cea2e8a9 6138Perl_ck_delete(pTHX_ OP *o)
a0d0e21e 6139{
11343788 6140 o = ck_fun(o);
5dc0d613 6141 o->op_private = 0;
11343788 6142 if (o->op_flags & OPf_KIDS) {
551405c4 6143 OP * const kid = cUNOPo->op_first;
01020589
GS		 6144 switch (kid->op_type) {
6145 case OP_ASLICE:
6146 o->op_flags |= OPf_SPECIAL;
6147 /* FALL THROUGH */
6148 case OP_HSLICE:
5dc0d613 6149 o->op_private |= OPpSLICE;
01020589
GS		 6150 break;
6151 case OP_AELEM:
6152 o->op_flags |= OPf_SPECIAL;
6153 /* FALL THROUGH */
6154 case OP_HELEM:
6155 break;
6156 default:
6157 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
53e06cf0 6158 OP_DESC(o));
01020589 6159 }
93c66552 6160 op_null(kid);
79072805 6161 }
11343788 6162 return o;
79072805
LW		 6163}
6164
6165OP *
96e176bf
CL		 6166Perl_ck_die(pTHX_ OP *o)
6167{
6168#ifdef VMS
6169 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6170#endif
6171 return ck_fun(o);
6172}
6173
6174OP *
cea2e8a9 6175Perl_ck_eof(pTHX_ OP *o)
79072805 6176{
97aff369 6177 dVAR;
79072805 6178
11343788
MB		 6179 if (o->op_flags & OPf_KIDS) {
6180 if (cLISTOPo->op_first->op_type == OP_STUB) {
1d866c12
AL		 6181 OP * const newop
6182 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
eb8433b7
NC		 6183#ifdef PERL_MAD
6184 op_getmad(o,newop,'O');
6185#else
11343788 6186 op_free(o);
eb8433b7
NC		 6187#endif
6188 o = newop;
8990e307 6189 }
11343788 6190 return ck_fun(o);
79072805 6191 }
11343788 6192 return o;
79072805
LW		 6193}
6194
6195OP *
cea2e8a9 6196Perl_ck_eval(pTHX_ OP *o)
79072805 6197{
27da23d5 6198 dVAR;
3280af22 6199 PL_hints |= HINT_BLOCK_SCOPE;
11343788 6200 if (o->op_flags & OPf_KIDS) {
46c461b5 6201 SVOP * const kid = (SVOP*)cUNOPo->op_first;
79072805 6202
93a17b20 6203 if (!kid) {
11343788 6204 o->op_flags &= ~OPf_KIDS;
93c66552 6205 op_null(o);
79072805 6206 }
b14574b4 6207 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
79072805 6208 LOGOP *enter;
eb8433b7 6209#ifdef PERL_MAD
1d866c12 6210 OP* const oldo = o;
eb8433b7 6211#endif
79072805 6212
11343788 6213 cUNOPo->op_first = 0;
eb8433b7 6214#ifndef PERL_MAD
11343788 6215 op_free(o);
eb8433b7 6216#endif
79072805 6217
b7dc083c 6218 NewOp(1101, enter, 1, LOGOP);
79072805 6219 enter->op_type = OP_ENTERTRY;
22c35a8c 6220 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
79072805
LW		 6221 enter->op_private = 0;
6222
6223 /* establish postfix order */
6224 enter->op_next = (OP*)enter;
6225
11343788
MB		 6226 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6227 o->op_type = OP_LEAVETRY;
22c35a8c 6228 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
11343788 6229 enter->op_other = o;
eb8433b7 6230 op_getmad(oldo,o,'O');
11343788 6231 return o;
79072805 6232 }
b5c19bd7 6233 else {
473986ff 6234 scalar((OP*)kid);
b5c19bd7
DM		 6235 PL_cv_has_eval = 1;
6236 }
79072805
LW		 6237 }
6238 else {
eb8433b7 6239#ifdef PERL_MAD
1d866c12 6240 OP* const oldo = o;
eb8433b7 6241#else
11343788 6242 op_free(o);
eb8433b7 6243#endif
54b9620d 6244 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
eb8433b7 6245 op_getmad(oldo,o,'O');
79072805 6246 }
3280af22 6247 o->op_targ = (PADOFFSET)PL_hints;
7168684c 6248 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
0282be92
RGS		 6249 /* Store a copy of %^H that pp_entereval can pick up.
6250 OPf_SPECIAL flags the opcode as being for this purpose,
6251 so that it in turn will return a copy at every
6252 eval.*/
6253 OP *hhop = newSVOP(OP_CONST, OPf_SPECIAL,
5b9c0671 6254 (SV*)Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)));
0d863452
RH		 6255 cUNOPo->op_first->op_sibling = hhop;
6256 o->op_private |= OPpEVAL_HAS_HH;
6257 }
11343788 6258 return o;
79072805
LW		 6259}
6260
6261OP *
d98f61e7
GS		 6262Perl_ck_exit(pTHX_ OP *o)
6263{
6264#ifdef VMS
551405c4 6265 HV * const table = GvHV(PL_hintgv);
d98f61e7 6266 if (table) {
a4fc7abc 6267 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
d98f61e7
GS		 6268 if (svp && *svp && SvTRUE(*svp))
6269 o->op_private |= OPpEXIT_VMSISH;
6270 }
96e176bf 6271 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
d98f61e7
GS		 6272#endif
6273 return ck_fun(o);
6274}
6275
6276OP *
cea2e8a9 6277Perl_ck_exec(pTHX_ OP *o)
79072805 6278{
11343788 6279 if (o->op_flags & OPf_STACKED) {
6867be6d 6280 OP *kid;
11343788
MB		 6281 o = ck_fun(o);
6282 kid = cUNOPo->op_first->op_sibling;
8990e307 6283 if (kid->op_type == OP_RV2GV)
93c66552 6284 op_null(kid);
79072805 6285 }
463ee0b2 6286 else
11343788
MB		 6287 o = listkids(o);
6288 return o;
79072805
LW		 6289}
6290
6291OP *
cea2e8a9 6292Perl_ck_exists(pTHX_ OP *o)
5f05dabc 6293{
97aff369 6294 dVAR;
5196be3e
MB		 6295 o = ck_fun(o);
6296 if (o->op_flags & OPf_KIDS) {
46c461b5 6297 OP * const kid = cUNOPo->op_first;
afebc493
GS		 6298 if (kid->op_type == OP_ENTERSUB) {
6299 (void) ref(kid, o->op_type);
13765c85
DM		 6300 if (kid->op_type != OP_RV2CV
6301 && !(PL_parser && PL_parser->error_count))
afebc493 6302 Perl_croak(aTHX_ "%s argument is not a subroutine name",
53e06cf0 6303 OP_DESC(o));
afebc493
GS		 6304 o->op_private |= OPpEXISTS_SUB;
6305 }
6306 else if (kid->op_type == OP_AELEM)
01020589
GS		 6307 o->op_flags |= OPf_SPECIAL;
6308 else if (kid->op_type != OP_HELEM)
6309 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
53e06cf0 6310 OP_DESC(o));
93c66552 6311 op_null(kid);
5f05dabc 6312 }
5196be3e 6313 return o;
5f05dabc 6314}
6315
79072805 6316OP *
cea2e8a9 6317Perl_ck_rvconst(pTHX_ register OP *o)
79072805 6318{
27da23d5 6319 dVAR;
0bd48802 6320 SVOP * const kid = (SVOP*)cUNOPo->op_first;
85e6fe83 6321
3280af22 6322 o->op_private |= (PL_hints & HINT_STRICT_REFS);
e26df76a
NC		 6323 if (o->op_type == OP_RV2CV)
6324 o->op_private &= ~1;
6325
79072805 6326 if (kid->op_type == OP_CONST) {
44a8e56a 6327 int iscv;
6328 GV *gv;
504618e9 6329 SV * const kidsv = kid->op_sv;
44a8e56a 6330
779c5bc9
GS		 6331 /* Is it a constant from cv_const_sv()? */
6332 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
0bd48802 6333 SV * const rsv = SvRV(kidsv);
42d0e0b7 6334 const svtype type = SvTYPE(rsv);
bd61b366 6335 const char *badtype = NULL;
779c5bc9
GS		 6336
6337 switch (o->op_type) {
6338 case OP_RV2SV:
42d0e0b7 6339 if (type > SVt_PVMG)
779c5bc9
GS		 6340 badtype = "a SCALAR";
6341 break;
6342 case OP_RV2AV:
42d0e0b7 6343 if (type != SVt_PVAV)
779c5bc9
GS		 6344 badtype = "an ARRAY";
6345 break;
6346 case OP_RV2HV:
42d0e0b7 6347 if (type != SVt_PVHV)
779c5bc9 6348 badtype = "a HASH";
779c5bc9
GS		 6349 break;
6350 case OP_RV2CV:
42d0e0b7 6351 if (type != SVt_PVCV)
779c5bc9
GS		 6352 badtype = "a CODE";
6353 break;
6354 }
6355 if (badtype)
cea2e8a9 6356 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
779c5bc9
GS		 6357 return o;
6358 }
ce10b5d1
RGS		 6359 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6360 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6361 /* If this is an access to a stash, disable "strict refs", because
6362 * stashes aren't auto-vivified at compile-time (unless we store
6363 * symbols in them), and we don't want to produce a run-time
6364 * stricture error when auto-vivifying the stash. */
6365 const char *s = SvPV_nolen(kidsv);
6366 const STRLEN l = SvCUR(kidsv);
6367 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6368 o->op_private &= ~HINT_STRICT_REFS;
6369 }
6370 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5f66b61c 6371 const char *badthing;
5dc0d613 6372 switch (o->op_type) {
44a8e56a 6373 case OP_RV2SV:
6374 badthing = "a SCALAR";
6375 break;
6376 case OP_RV2AV:
6377 badthing = "an ARRAY";
6378 break;
6379 case OP_RV2HV:
6380 badthing = "a HASH";
6381 break;
5f66b61c
AL		 6382 default:
6383 badthing = NULL;
6384 break;
44a8e56a 6385 }
6386 if (badthing)
1c846c1f 6387 Perl_croak(aTHX_
95b63a38 6388 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
be2597df 6389 SVfARG(kidsv), badthing);
44a8e56a 6390 }
93233ece
CS		 6391 /*
6392 * This is a little tricky. We only want to add the symbol if we
6393 * didn't add it in the lexer. Otherwise we get duplicate strict
6394 * warnings. But if we didn't add it in the lexer, we must at
6395 * least pretend like we wanted to add it even if it existed before,
6396 * or we get possible typo warnings. OPpCONST_ENTERED says
6397 * whether the lexer already added THIS instance of this symbol.
6398 */
5196be3e 6399 iscv = (o->op_type == OP_RV2CV) * 2;
93233ece 6400 do {
7a5fd60d 6401 gv = gv_fetchsv(kidsv,
748a9306 6402 iscv | !(kid->op_private & OPpCONST_ENTERED),
a0d0e21e
LW		 6403 iscv
6404 ? SVt_PVCV
11343788 6405 : o->op_type == OP_RV2SV
a0d0e21e 6406 ? SVt_PV
11343788 6407 : o->op_type == OP_RV2AV
a0d0e21e 6408 ? SVt_PVAV
11343788 6409 : o->op_type == OP_RV2HV
a0d0e21e
LW		 6410 ? SVt_PVHV
6411 : SVt_PVGV);
93233ece
CS		 6412 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6413 if (gv) {
6414 kid->op_type = OP_GV;
6415 SvREFCNT_dec(kid->op_sv);
350de78d 6416#ifdef USE_ITHREADS
638eceb6 6417 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
350de78d 6418 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
dd2155a4 6419 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
743e66e6 6420 GvIN_PAD_on(gv);
b37c2d43 6421 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv));
350de78d 6422#else
b37c2d43 6423 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
350de78d 6424#endif
23f1ca44 6425 kid->op_private = 0;
76cd736e 6426 kid->op_ppaddr = PL_ppaddr[OP_GV];
a0d0e21e 6427 }
79072805 6428 }
11343788 6429 return o;
79072805
LW		 6430}
6431
6432OP *
cea2e8a9 6433Perl_ck_ftst(pTHX_ OP *o)
79072805 6434{
27da23d5 6435 dVAR;
6867be6d 6436 const I32 type = o->op_type;
79072805 6437
d0dca557 6438 if (o->op_flags & OPf_REF) {
6f207bd3 6439 NOOP;
d0dca557
JD		 6440 }
6441 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
551405c4 6442 SVOP * const kid = (SVOP*)cUNOPo->op_first;
1496a290 6443 const OPCODE kidtype = kid->op_type;
79072805 6444
1496a290 6445 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
551405c4 6446 OP * const newop = newGVOP(type, OPf_REF,
f776e3cd 6447 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
eb8433b7
NC		 6448#ifdef PERL_MAD
6449 op_getmad(o,newop,'O');
6450#else
11343788 6451 op_free(o);
eb8433b7 6452#endif
1d866c12 6453 return newop;
79072805 6454 }
1d866c12 6455 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o))
1af34c76 6456 o->op_private |= OPpFT_ACCESS;
1496a290
AL		 6457 if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6458 && kidtype != OP_STAT && kidtype != OP_LSTAT)
fbb0b3b3 6459 o->op_private |= OPpFT_STACKED;
79072805
LW		 6460 }
6461 else {
eb8433b7 6462#ifdef PERL_MAD
1d866c12 6463 OP* const oldo = o;
eb8433b7 6464#else
11343788 6465 op_free(o);
eb8433b7 6466#endif
79072805 6467 if (type == OP_FTTTY)
8fde6460 6468 o = newGVOP(type, OPf_REF, PL_stdingv);
79072805 6469 else
d0dca557 6470 o = newUNOP(type, 0, newDEFSVOP());
eb8433b7 6471 op_getmad(oldo,o,'O');
79072805 6472 }
11343788 6473 return o;
79072805
LW		 6474}
6475
6476OP *
cea2e8a9 6477Perl_ck_fun(pTHX_ OP *o)
79072805 6478{
97aff369 6479 dVAR;
6867be6d 6480 const int type = o->op_type;
22c35a8c 6481 register I32 oa = PL_opargs[type] >> OASHIFT;
aeea060c 6482
11343788 6483 if (o->op_flags & OPf_STACKED) {
79072805
LW		 6484 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6485 oa &= ~OA_OPTIONAL;
6486 else
11343788 6487 return no_fh_allowed(o);
79072805
LW		 6488 }
6489
11343788 6490 if (o->op_flags & OPf_KIDS) {
6867be6d
AL		 6491 OP **tokid = &cLISTOPo->op_first;
6492 register OP *kid = cLISTOPo->op_first;
6493 OP *sibl;
6494 I32 numargs = 0;
6495
8990e307 6496 if (kid->op_type == OP_PUSHMARK ||
155aba94 6497 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
8990e307 6498 {
79072805
LW		 6499 tokid = &kid->op_sibling;
6500 kid = kid->op_sibling;
6501 }
22c35a8c 6502 if (!kid && PL_opargs[type] & OA_DEFGV)
54b9620d 6503 *tokid = kid = newDEFSVOP();
79072805
LW		 6504
6505 while (oa && kid) {
6506 numargs++;
6507 sibl = kid->op_sibling;
eb8433b7
NC		 6508#ifdef PERL_MAD
6509 if (!sibl && kid->op_type == OP_STUB) {
6510 numargs--;
6511 break;
6512 }
6513#endif
79072805
LW		 6514 switch (oa & 7) {
6515 case OA_SCALAR:
62c18ce2
GS		 6516 /* list seen where single (scalar) arg expected? */
6517 if (numargs == 1 && !(oa >> 4)
6518 && kid->op_type == OP_LIST && type != OP_SCALAR)
6519 {
6520 return too_many_arguments(o,PL_op_desc[type]);
6521 }
79072805
LW		 6522 scalar(kid);
6523 break;
6524 case OA_LIST:
6525 if (oa < 16) {
6526 kid = 0;
6527 continue;
6528 }
6529 else
6530 list(kid);
6531 break;
6532 case OA_AVREF:
936edb8b 6533 if ((type == OP_PUSH || type == OP_UNSHIFT)
f87c3213 6534 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
9014280d 6535 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
de4864e4 6536 "Useless use of %s with no values",
936edb8b 6537 PL_op_desc[type]);
b2ffa427 6538
79072805 6539 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 6540 (kid->op_private & OPpCONST_BARE))
6541 {
551405c4 6542 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
f776e3cd 6543 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
12bcd1a6
PM		 6544 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6545 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7a5fd60d 6546 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
be2597df 6547 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
eb8433b7
NC		 6548#ifdef PERL_MAD
6549 op_getmad(kid,newop,'K');
6550#else
79072805 6551 op_free(kid);
eb8433b7 6552#endif
79072805
LW		 6553 kid = newop;
6554 kid->op_sibling = sibl;
6555 *tokid = kid;
6556 }
8990e307 6557 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
35cd451c 6558 bad_type(numargs, "array", PL_op_desc[type], kid);
a0d0e21e 6559 mod(kid, type);
79072805
LW		 6560 break;
6561 case OA_HVREF:
6562 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 6563 (kid->op_private & OPpCONST_BARE))
6564 {
551405c4 6565 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
f776e3cd 6566 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
12bcd1a6
PM		 6567 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6568 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7a5fd60d 6569 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
be2597df 6570 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
eb8433b7
NC		 6571#ifdef PERL_MAD
6572 op_getmad(kid,newop,'K');
6573#else
79072805 6574 op_free(kid);
eb8433b7 6575#endif
79072805
LW		 6576 kid = newop;
6577 kid->op_sibling = sibl;
6578 *tokid = kid;
6579 }
8990e307 6580 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
35cd451c 6581 bad_type(numargs, "hash", PL_op_desc[type], kid);
a0d0e21e 6582 mod(kid, type);
79072805
LW		 6583 break;
6584 case OA_CVREF:
6585 {
551405c4 6586 OP * const newop = newUNOP(OP_NULL, 0, kid);
79072805
LW		 6587 kid->op_sibling = 0;
6588 linklist(kid);
6589 newop->op_next = newop;
6590 kid = newop;
6591 kid->op_sibling = sibl;
6592 *tokid = kid;
6593 }
6594 break;
6595 case OA_FILEREF:
c340be78 6596 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
79072805 6597 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 6598 (kid->op_private & OPpCONST_BARE))
6599 {
0bd48802 6600 OP * const newop = newGVOP(OP_GV, 0,
f776e3cd 6601 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
afbdacea 6602 if (!(o->op_private & 1) && /* if not unop */
8a996ce8 6603 kid == cLISTOPo->op_last)
364daeac 6604 cLISTOPo->op_last = newop;
eb8433b7
NC		 6605#ifdef PERL_MAD
6606 op_getmad(kid,newop,'K');
6607#else
79072805 6608 op_free(kid);
eb8433b7 6609#endif
79072805
LW		 6610 kid = newop;
6611 }
1ea32a52
GS		 6612 else if (kid->op_type == OP_READLINE) {
6613 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
53e06cf0 6614 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
1ea32a52 6615 }
79072805 6616 else {
35cd451c 6617 I32 flags = OPf_SPECIAL;
a6c40364 6618 I32 priv = 0;
2c8ac474
GS		 6619 PADOFFSET targ = 0;
6620
35cd451c 6621 /* is this op a FH constructor? */
853846ea 6622 if (is_handle_constructor(o,numargs)) {
bd61b366 6623 const char *name = NULL;
dd2155a4 6624 STRLEN len = 0;
2c8ac474
GS		 6625
6626 flags = 0;
6627 /* Set a flag to tell rv2gv to vivify
853846ea
NIS		 6628 * need to "prove" flag does not mean something
6629 * else already - NI-S 1999/05/07
2c8ac474
GS		 6630 */
6631 priv = OPpDEREF;
6632 if (kid->op_type == OP_PADSV) {
f8503592
NC		 6633 SV *const namesv
6634 = PAD_COMPNAME_SV(kid->op_targ);
6635 name = SvPV_const(namesv, len);
2c8ac474
GS		 6636 }
6637 else if (kid->op_type == OP_RV2SV
6638 && kUNOP->op_first->op_type == OP_GV)
6639 {
0bd48802 6640 GV * const gv = cGVOPx_gv(kUNOP->op_first);
2c8ac474
GS		 6641 name = GvNAME(gv);
6642 len = GvNAMELEN(gv);
6643 }
afd1915d
GS		 6644 else if (kid->op_type == OP_AELEM
6645 || kid->op_type == OP_HELEM)
6646 {
735fec84 6647 OP *firstop;
551405c4 6648 OP *op = ((BINOP*)kid)->op_first;
a4fc7abc 6649 name = NULL;
551405c4 6650 if (op) {
a0714e2c 6651 SV *tmpstr = NULL;
551405c4 6652 const char * const a =
666ea192
JH		 6653 kid->op_type == OP_AELEM ?
6654 "[]" : "{}";
0c4b0a3f
JH		 6655 if (((op->op_type == OP_RV2AV) ||
6656 (op->op_type == OP_RV2HV)) &&
735fec84
RGS		 6657 (firstop = ((UNOP*)op)->op_first) &&
6658 (firstop->op_type == OP_GV)) {
0c4b0a3f 6659 /* packagevar $a[] or $h{} */
735fec84 6660 GV * const gv = cGVOPx_gv(firstop);
0c4b0a3f
JH		 6661 if (gv)
6662 tmpstr =
6663 Perl_newSVpvf(aTHX_
6664 "%s%c...%c",
6665 GvNAME(gv),
6666 a[0], a[1]);
6667 }
6668 else if (op->op_type == OP_PADAV
6669 || op->op_type == OP_PADHV) {
6670 /* lexicalvar $a[] or $h{} */
551405c4 6671 const char * const padname =
0c4b0a3f
JH		 6672 PAD_COMPNAME_PV(op->op_targ);
6673 if (padname)
6674 tmpstr =
6675 Perl_newSVpvf(aTHX_
6676 "%s%c...%c",
6677 padname + 1,
6678 a[0], a[1]);
0c4b0a3f
JH		 6679 }
6680 if (tmpstr) {
93524f2b 6681 name = SvPV_const(tmpstr, len);
0c4b0a3f
JH		 6682 sv_2mortal(tmpstr);
6683 }
6684 }
6685 if (!name) {
6686 name = "__ANONIO__";
6687 len = 10;
6688 }
6689 mod(kid, type);
afd1915d 6690 }
2c8ac474
GS		 6691 if (name) {
6692 SV *namesv;
6693 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
dd2155a4 6694 namesv = PAD_SVl(targ);
862a34c6 6695 SvUPGRADE(namesv, SVt_PV);
2c8ac474
GS		 6696 if (*name != '$')
6697 sv_setpvn(namesv, "$", 1);
6698 sv_catpvn(namesv, name, len);
6699 }
853846ea 6700 }
79072805 6701 kid->op_sibling = 0;
35cd451c 6702 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
2c8ac474
GS		 6703 kid->op_targ = targ;
6704 kid->op_private |= priv;
79072805
LW		 6705 }
6706 kid->op_sibling = sibl;
6707 *tokid = kid;
6708 }
6709 scalar(kid);
6710 break;
6711 case OA_SCALARREF:
a0d0e21e 6712 mod(scalar(kid), type);
79072805
LW		 6713 break;
6714 }
6715 oa >>= 4;
6716 tokid = &kid->op_sibling;
6717 kid = kid->op_sibling;
6718 }
eb8433b7
NC		 6719#ifdef PERL_MAD
6720 if (kid && kid->op_type != OP_STUB)
6721 return too_many_arguments(o,OP_DESC(o));
6722 o->op_private |= numargs;
6723#else
6724 /* FIXME - should the numargs move as for the PERL_MAD case? */
11343788 6725 o->op_private |= numargs;
79072805 6726 if (kid)
53e06cf0 6727 return too_many_arguments(o,OP_DESC(o));
eb8433b7 6728#endif
11343788 6729 listkids(o);
79072805 6730 }
22c35a8c 6731 else if (PL_opargs[type] & OA_DEFGV) {
c56915e3 6732#ifdef PERL_MAD
c7fe699d 6733 OP *newop = newUNOP(type, 0, newDEFSVOP());
c56915e3 6734 op_getmad(o,newop,'O');
c7fe699d 6735 return newop;
c56915e3 6736#else
c7fe699d 6737 /* Ordering of these two is important to keep f_map.t passing. */
11343788 6738 op_free(o);
c7fe699d 6739 return newUNOP(type, 0, newDEFSVOP());
c56915e3 6740#endif
a0d0e21e
LW		 6741 }
6742
79072805
LW		 6743 if (oa) {
6744 while (oa & OA_OPTIONAL)
6745 oa >>= 4;
6746 if (oa && oa != OA_LIST)
53e06cf0 6747 return too_few_arguments(o,OP_DESC(o));
79072805 6748 }
11343788 6749 return o;
79072805
LW		 6750}
6751
6752OP *
cea2e8a9 6753Perl_ck_glob(pTHX_ OP *o)
79072805 6754{
27da23d5 6755 dVAR;
fb73857a 6756 GV *gv;
6757
649da076 6758 o = ck_fun(o);
1f2bfc8a 6759 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
54b9620d 6760 append_elem(OP_GLOB, o, newDEFSVOP());
fb73857a 6761
fafc274c 6762 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
b9f751c0
GS		 6763 && GvCVu(gv) && GvIMPORTED_CV(gv)))
6764 {
5c1737d1 6765 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
b9f751c0 6766 }
b1cb66bf 6767
52bb0670 6768#if !defined(PERL_EXTERNAL_GLOB)
72b16652 6769 /* XXX this can be tightened up and made more failsafe. */
f444d496 6770 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7d3fb230 6771 GV *glob_gv;
72b16652 6772 ENTER;
00ca71c1 6773 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
a0714e2c 6774 newSVpvs("File::Glob"), NULL, NULL, NULL);
5c1737d1
NC		 6775 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6776 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
7d3fb230 6777 GvCV(gv) = GvCV(glob_gv);
b37c2d43 6778 SvREFCNT_inc_void((SV*)GvCV(gv));
7d3fb230 6779 GvIMPORTED_CV_on(gv);
72b16652
GS		 6780 LEAVE;
6781 }
52bb0670 6782#endif /* PERL_EXTERNAL_GLOB */
72b16652 6783
b9f751c0 6784 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5196be3e 6785 append_elem(OP_GLOB, o,
80252599 6786 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
1f2bfc8a 6787 o->op_type = OP_LIST;
22c35a8c 6788 o->op_ppaddr = PL_ppaddr[OP_LIST];
1f2bfc8a 6789 cLISTOPo->op_first->op_type = OP_PUSHMARK;
22c35a8c 6790 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
ad33f57d 6791 cLISTOPo->op_first->op_targ = 0;
1f2bfc8a 6792 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
aeea060c 6793 append_elem(OP_LIST, o,
1f2bfc8a
MB		 6794 scalar(newUNOP(OP_RV2CV, 0,
6795 newGVOP(OP_GV, 0, gv)))));
d58bf5aa
MB		 6796 o = newUNOP(OP_NULL, 0, ck_subr(o));
6797 o->op_targ = OP_GLOB; /* hint at what it used to be */
6798 return o;
b1cb66bf 6799 }
6800 gv = newGVgen("main");
a0d0e21e 6801 gv_IOadd(gv);
11343788
MB		 6802 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6803 scalarkids(o);
649da076 6804 return o;
79072805
LW		 6805}
6806
6807OP *
cea2e8a9 6808Perl_ck_grep(pTHX_ OP *o)
79072805 6809{
27da23d5 6810 dVAR;
03ca120d 6811 LOGOP *gwop = NULL;
79072805 6812 OP *kid;
6867be6d 6813 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
9f7d9405 6814 PADOFFSET offset;
79072805 6815
22c35a8c 6816 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
13765c85 6817 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
aeea060c 6818
11343788 6819 if (o->op_flags & OPf_STACKED) {
a0d0e21e 6820 OP* k;
11343788
MB		 6821 o = ck_sort(o);
6822 kid = cLISTOPo->op_first->op_sibling;
d09ad856
BS		 6823 if (!cUNOPx(kid)->op_next)
6824 Perl_croak(aTHX_ "panic: ck_grep");
e3c9a8b9 6825 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
a0d0e21e
LW		 6826 kid = k;
6827 }
03ca120d 6828 NewOp(1101, gwop, 1, LOGOP);
a0d0e21e 6829 kid->op_next = (OP*)gwop;
11343788 6830 o->op_flags &= ~OPf_STACKED;
93a17b20 6831 }
11343788 6832 kid = cLISTOPo->op_first->op_sibling;
a0d0e21e
LW		 6833 if (type == OP_MAPWHILE)
6834 list(kid);
6835 else
6836 scalar(kid);
11343788 6837 o = ck_fun(o);
13765c85 6838 if (PL_parser && PL_parser->error_count)
11343788 6839 return o;
aeea060c 6840 kid = cLISTOPo->op_first->op_sibling;
79072805 6841 if (kid->op_type != OP_NULL)
cea2e8a9 6842 Perl_croak(aTHX_ "panic: ck_grep");
79072805
LW		 6843 kid = kUNOP->op_first;
6844
03ca120d
MHM		 6845 if (!gwop)
6846 NewOp(1101, gwop, 1, LOGOP);
a0d0e21e 6847 gwop->op_type = type;
22c35a8c 6848 gwop->op_ppaddr = PL_ppaddr[type];
11343788 6849 gwop->op_first = listkids(o);
79072805 6850 gwop->op_flags |= OPf_KIDS;
79072805 6851 gwop->op_other = LINKLIST(kid);
79072805 6852 kid->op_next = (OP*)gwop;
59f00321 6853 offset = pad_findmy("$_");
00b1698f 6854 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
59f00321
RGS		 6855 o->op_private = gwop->op_private = 0;
6856 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6857 }
6858 else {
6859 o->op_private = gwop->op_private = OPpGREP_LEX;
6860 gwop->op_targ = o->op_targ = offset;
6861 }
79072805 6862
11343788 6863 kid = cLISTOPo->op_first->op_sibling;
a0d0e21e 6864 if (!kid || !kid->op_sibling)
53e06cf0 6865 return too_few_arguments(o,OP_DESC(o));
a0d0e21e
LW		 6866 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6867 mod(kid, OP_GREPSTART);
6868
79072805
LW		 6869 return (OP*)gwop;
6870}
6871
6872OP *
cea2e8a9 6873Perl_ck_index(pTHX_ OP *o)
79072805 6874{
11343788
MB		 6875 if (o->op_flags & OPf_KIDS) {
6876 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
0b71040e
LW		 6877 if (kid)
6878 kid = kid->op_sibling; /* get past "big" */
79072805 6879 if (kid && kid->op_type == OP_CONST)
2779dcf1 6880 fbm_compile(((SVOP*)kid)->op_sv, 0);
79072805 6881 }
11343788 6882 return ck_fun(o);
79072805
LW		 6883}
6884
6885OP *
cea2e8a9 6886Perl_ck_lengthconst(pTHX_ OP *o)
79072805
LW		 6887{
6888 /* XXX length optimization goes here */
11343788 6889 return ck_fun(o);
79072805
LW		 6890}
6891
6892OP *
cea2e8a9 6893Perl_ck_lfun(pTHX_ OP *o)
79072805 6894{
6867be6d 6895 const OPCODE type = o->op_type;
5dc0d613 6896 return modkids(ck_fun(o), type);
79072805
LW		 6897}
6898
6899OP *
cea2e8a9 6900Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
69794302 6901{
12bcd1a6 6902 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
d0334bed
GS		 6903 switch (cUNOPo->op_first->op_type) {
6904 case OP_RV2AV:
a8739d98
JH		 6905 /* This is needed for
6906 if (defined %stash::)
6907 to work. Do not break Tk.
6908 */
1c846c1f 6909 break; /* Globals via GV can be undef */
d0334bed
GS		 6910 case OP_PADAV:
6911 case OP_AASSIGN: /* Is this a good idea? */
12bcd1a6 6912 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
f10b0346 6913 "defined(@array) is deprecated");
12bcd1a6 6914 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
cc507455 6915 "\t(Maybe you should just omit the defined()?)\n");
69794302 6916 break;
d0334bed 6917 case OP_RV2HV:
a8739d98
JH		 6918 /* This is needed for
6919 if (defined %stash::)
6920 to work. Do not break Tk.
6921 */
1c846c1f 6922 break; /* Globals via GV can be undef */
d0334bed 6923 case OP_PADHV:
12bcd1a6 6924 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
894356b3 6925 "defined(%%hash) is deprecated");
12bcd1a6 6926 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
cc507455 6927 "\t(Maybe you should just omit the defined()?)\n");
d0334bed
GS		 6928 break;
6929 default:
6930 /* no warning */
6931 break;
6932 }
69794302
MJD		 6933 }
6934 return ck_rfun(o);
6935}
6936
6937OP *
e4b7ebf3
RGS		 6938Perl_ck_readline(pTHX_ OP *o)
6939{
6940 if (!(o->op_flags & OPf_KIDS)) {
6941 OP * const newop
6942 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
6943#ifdef PERL_MAD
6944 op_getmad(o,newop,'O');
6945#else
6946 op_free(o);
6947#endif
6948 return newop;
6949 }
6950 return o;
6951}
6952
6953OP *
cea2e8a9 6954Perl_ck_rfun(pTHX_ OP *o)
8990e307 6955{
6867be6d 6956 const OPCODE type = o->op_type;
5dc0d613 6957 return refkids(ck_fun(o), type);
8990e307
LW		 6958}
6959
6960OP *
cea2e8a9 6961Perl_ck_listiob(pTHX_ OP *o)
79072805
LW		 6962{
6963 register OP *kid;
aeea060c 6964
11343788 6965 kid = cLISTOPo->op_first;
79072805 6966 if (!kid) {
11343788
MB		 6967 o = force_list(o);
6968 kid = cLISTOPo->op_first;
79072805
LW		 6969 }
6970 if (kid->op_type == OP_PUSHMARK)
6971 kid = kid->op_sibling;
11343788 6972 if (kid && o->op_flags & OPf_STACKED)
79072805
LW		 6973 kid = kid->op_sibling;
6974 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6975 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
11343788 6976 o->op_flags |= OPf_STACKED; /* make it a filehandle */
748a9306 6977 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
11343788
MB		 6978 cLISTOPo->op_first->op_sibling = kid;
6979 cLISTOPo->op_last = kid;
79072805
LW		 6980 kid = kid->op_sibling;
6981 }
6982 }
b2ffa427 6983
79072805 6984 if (!kid)
54b9620d 6985 append_elem(o->op_type, o, newDEFSVOP());
79072805 6986
2de3dbcc 6987 return listkids(o);
bbce6d69 6988}
6989
6990OP *
0d863452
RH		 6991Perl_ck_smartmatch(pTHX_ OP *o)
6992{
97aff369 6993 dVAR;
0d863452
RH		 6994 if (0 == (o->op_flags & OPf_SPECIAL)) {
6995 OP *first = cBINOPo->op_first;
6996 OP *second = first->op_sibling;
6997
6998 /* Implicitly take a reference to an array or hash */
5f66b61c 6999 first->op_sibling = NULL;
0d863452
RH		 7000 first = cBINOPo->op_first = ref_array_or_hash(first);
7001 second = first->op_sibling = ref_array_or_hash(second);
7002
7003 /* Implicitly take a reference to a regular expression */
7004 if (first->op_type == OP_MATCH) {
7005 first->op_type = OP_QR;
7006 first->op_ppaddr = PL_ppaddr[OP_QR];
7007 }
7008 if (second->op_type == OP_MATCH) {
7009 second->op_type = OP_QR;
7010 second->op_ppaddr = PL_ppaddr[OP_QR];
7011 }
7012 }
7013
7014 return o;
7015}
7016
7017
7018OP *
b162f9ea
IZ		 7019Perl_ck_sassign(pTHX_ OP *o)
7020{
1496a290 7021 OP * const kid = cLISTOPo->op_first;
b162f9ea
IZ		 7022 /* has a disposable target? */
7023 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6b66af17
GS		 7024 && !(kid->op_flags & OPf_STACKED)
7025 /* Cannot steal the second time! */
1b438339
GG		 7026 && !(kid->op_private & OPpTARGET_MY)
7027 /* Keep the full thing for madskills */
7028 && !PL_madskills
7029 )
b162f9ea 7030 {
551405c4 7031 OP * const kkid = kid->op_sibling;
b162f9ea
IZ		 7032
7033 /* Can just relocate the target. */
2c2d71f5
JH		 7034 if (kkid && kkid->op_type == OP_PADSV
7035 && !(kkid->op_private & OPpLVAL_INTRO))
7036 {
b162f9ea 7037 kid->op_targ = kkid->op_targ;
743e66e6 7038 kkid->op_targ = 0;
b162f9ea
IZ		 7039 /* Now we do not need PADSV and SASSIGN. */
7040 kid->op_sibling = o->op_sibling; /* NULL */
7041 cLISTOPo->op_first = NULL;
7042 op_free(o);
7043 op_free(kkid);
7044 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
7045 return kid;
7046 }
7047 }
c5917253
NC		 7048 if (kid->op_sibling) {
7049 OP *kkid = kid->op_sibling;
7050 if (kkid->op_type == OP_PADSV
7051 && (kkid->op_private & OPpLVAL_INTRO)
7052 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
7053 const PADOFFSET target = kkid->op_targ;
7054 OP *const other = newOP(OP_PADSV,
7055 kkid->op_flags
7056 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
7057 OP *const first = newOP(OP_NULL, 0);
7058 OP *const nullop = newCONDOP(0, first, o, other);
7059 OP *const condop = first->op_next;
7060 /* hijacking PADSTALE for uninitialized state variables */
7061 SvPADSTALE_on(PAD_SVl(target));
7062
7063 condop->op_type = OP_ONCE;
7064 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
7065 condop->op_targ = target;
7066 other->op_targ = target;
7067
95562366
NC		 7068 /* Because we change the type of the op here, we will skip the
7069 assinment binop->op_last = binop->op_first->op_sibling; at the
7070 end of Perl_newBINOP(). So need to do it here. */
7071 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
7072
c5917253
NC		 7073 return nullop;
7074 }
7075 }
b162f9ea
IZ		 7076 return o;
7077}
7078
7079OP *
cea2e8a9 7080Perl_ck_match(pTHX_ OP *o)
79072805 7081{
97aff369 7082 dVAR;
0d863452 7083 if (o->op_type != OP_QR && PL_compcv) {
9f7d9405 7084 const PADOFFSET offset = pad_findmy("$_");
00b1698f 7085 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
59f00321
RGS		 7086 o->op_targ = offset;
7087 o->op_private |= OPpTARGET_MY;
7088 }
7089 }
7090 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
7091 o->op_private |= OPpRUNTIME;
11343788 7092 return o;
79072805
LW		 7093}
7094
7095OP *
f5d5a27c
CS		 7096Perl_ck_method(pTHX_ OP *o)
7097{
551405c4 7098 OP * const kid = cUNOPo->op_first;
f5d5a27c
CS		 7099 if (kid->op_type == OP_CONST) {
7100 SV* sv = kSVOP->op_sv;
a4fc7abc
AL		 7101 const char * const method = SvPVX_const(sv);
7102 if (!(strchr(method, ':') || strchr(method, '\''))) {
f5d5a27c 7103 OP *cmop;
1c846c1f 7104 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
a4fc7abc 7105 sv = newSVpvn_share(method, SvCUR(sv), 0);
1c846c1f
NIS		 7106 }
7107 else {
a0714e2c 7108 kSVOP->op_sv = NULL;
1c846c1f 7109 }
f5d5a27c 7110 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
eb8433b7
NC		 7111#ifdef PERL_MAD
7112 op_getmad(o,cmop,'O');
7113#else
f5d5a27c 7114 op_free(o);
eb8433b7 7115#endif
f5d5a27c
CS		 7116 return cmop;
7117 }
7118 }
7119 return o;
7120}
7121
7122OP *
cea2e8a9 7123Perl_ck_null(pTHX_ OP *o)
79072805 7124{
96a5add6 7125 PERL_UNUSED_CONTEXT;
11343788 7126 return o;
79072805
LW		 7127}
7128
7129OP *
16fe6d59
GS		 7130Perl_ck_open(pTHX_ OP *o)
7131{
97aff369 7132 dVAR;
551405c4 7133 HV * const table = GvHV(PL_hintgv);
16fe6d59 7134 if (table) {
a4fc7abc 7135 SV **svp = hv_fetchs(table, "open_IN", FALSE);
16fe6d59 7136 if (svp && *svp) {
551405c4 7137 const I32 mode = mode_from_discipline(*svp);
16fe6d59
GS		 7138 if (mode & O_BINARY)
7139 o->op_private |= OPpOPEN_IN_RAW;
7140 else if (mode & O_TEXT)
7141 o->op_private |= OPpOPEN_IN_CRLF;
7142 }
7143
a4fc7abc 7144 svp = hv_fetchs(table, "open_OUT", FALSE);
16fe6d59 7145 if (svp && *svp) {
551405c4 7146 const I32 mode = mode_from_discipline(*svp);
16fe6d59
GS		 7147 if (mode & O_BINARY)
7148 o->op_private |= OPpOPEN_OUT_RAW;
7149 else if (mode & O_TEXT)
7150 o->op_private |= OPpOPEN_OUT_CRLF;
7151 }
7152 }
8d7403e6
RGS		 7153 if (o->op_type == OP_BACKTICK) {
7154 if (!(o->op_flags & OPf_KIDS)) {
e4b7ebf3
RGS		 7155 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
7156#ifdef PERL_MAD
7157 op_getmad(o,newop,'O');
7158#else
8d7403e6 7159 op_free(o);
e4b7ebf3
RGS		 7160#endif
7161 return newop;
8d7403e6 7162 }
16fe6d59 7163 return o;
8d7403e6 7164 }
3b82e551
JH		 7165 {
7166 /* In case of three-arg dup open remove strictness
7167 * from the last arg if it is a bareword. */
551405c4
AL		 7168 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
7169 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
3b82e551 7170 OP *oa;
b15aece3 7171 const char *mode;
3b82e551
JH		 7172
7173 if ((last->op_type == OP_CONST) && /* The bareword. */
7174 (last->op_private & OPpCONST_BARE) &&
7175 (last->op_private & OPpCONST_STRICT) &&
7176 (oa = first->op_sibling) && /* The fh. */
7177 (oa = oa->op_sibling) && /* The mode. */
ea1d064a 7178 (oa->op_type == OP_CONST) &&
3b82e551 7179 SvPOK(((SVOP*)oa)->op_sv) &&
b15aece3 7180 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
3b82e551
JH		 7181 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
7182 (last == oa->op_sibling)) /* The bareword. */
7183 last->op_private &= ~OPpCONST_STRICT;
7184 }
16fe6d59
GS		 7185 return ck_fun(o);
7186}
7187
7188OP *
cea2e8a9 7189Perl_ck_repeat(pTHX_ OP *o)
79072805 7190{
11343788
MB		 7191 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
7192 o->op_private |= OPpREPEAT_DOLIST;
7193 cBINOPo->op_first = force_list(cBINOPo->op_first);
79072805
LW		 7194 }
7195 else
11343788
MB		 7196 scalar(o);
7197 return o;
79072805
LW		 7198}
7199
7200OP *
cea2e8a9 7201Perl_ck_require(pTHX_ OP *o)
8990e307 7202{
97aff369 7203 dVAR;
a0714e2c 7204 GV* gv = NULL;
ec4ab249 7205
11343788 7206 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
551405c4 7207 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8990e307
LW		 7208
7209 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
551405c4 7210 SV * const sv = kid->op_sv;
5c144d81 7211 U32 was_readonly = SvREADONLY(sv);
8990e307 7212 char *s;
5c144d81
NC		 7213
7214 if (was_readonly) {
7215 if (SvFAKE(sv)) {
7216 sv_force_normal_flags(sv, 0);
7217 assert(!SvREADONLY(sv));
7218 was_readonly = 0;
7219 } else {
7220 SvREADONLY_off(sv);
7221 }
7222 }
7223
7224 for (s = SvPVX(sv); *s; s++) {
a0d0e21e 7225 if (*s == ':' && s[1] == ':') {
42d9b98d 7226 const STRLEN len = strlen(s+2)+1;
a0d0e21e 7227 *s = '/';
42d9b98d 7228 Move(s+2, s+1, len, char);
5c144d81 7229 SvCUR_set(sv, SvCUR(sv) - 1);
a0d0e21e 7230 }
8990e307 7231 }
396482e1 7232 sv_catpvs(sv, ".pm");
5c144d81 7233 SvFLAGS(sv) |= was_readonly;
8990e307
LW		 7234 }
7235 }
ec4ab249 7236
a72a1c8b
RGS		 7237 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
7238 /* handle override, if any */
fafc274c 7239 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
d6a985f2 7240 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
a4fc7abc 7241 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
a0714e2c 7242 gv = gvp ? *gvp : NULL;
d6a985f2 7243 }
a72a1c8b 7244 }
ec4ab249 7245
b9f751c0 7246 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
551405c4 7247 OP * const kid = cUNOPo->op_first;
f11453cb
NC		 7248 OP * newop;
7249
ec4ab249 7250 cUNOPo->op_first = 0;
f11453cb 7251#ifndef PERL_MAD
ec4ab249 7252 op_free(o);
eb8433b7 7253#endif
f11453cb
NC		 7254 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7255 append_elem(OP_LIST, kid,
7256 scalar(newUNOP(OP_RV2CV, 0,
7257 newGVOP(OP_GV, 0,
7258 gv))))));
7259 op_getmad(o,newop,'O');
eb8433b7 7260 return newop;
ec4ab249
GA		 7261 }
7262
11343788 7263 return ck_fun(o);
8990e307
LW		 7264}
7265
78f9721b
SM		 7266OP *
7267Perl_ck_return(pTHX_ OP *o)
7268{
97aff369 7269 dVAR;
78f9721b 7270 if (CvLVALUE(PL_compcv)) {
6867be6d 7271 OP *kid;
78f9721b
SM		 7272 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
7273 mod(kid, OP_LEAVESUBLV);
7274 }
7275 return o;
7276}
7277
79072805 7278OP *
cea2e8a9 7279Perl_ck_select(pTHX_ OP *o)
79072805 7280{
27da23d5 7281 dVAR;
c07a80fd 7282 OP* kid;
11343788
MB		 7283 if (o->op_flags & OPf_KIDS) {
7284 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
2304df62 7285 if (kid && kid->op_sibling) {
11343788 7286 o->op_type = OP_SSELECT;
22c35a8c 7287 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
11343788
MB		 7288 o = ck_fun(o);
7289 return fold_constants(o);
79072805
LW		 7290 }
7291 }
11343788
MB		 7292 o = ck_fun(o);
7293 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
c07a80fd 7294 if (kid && kid->op_type == OP_RV2GV)
7295 kid->op_private &= ~HINT_STRICT_REFS;
11343788 7296 return o;
79072805
LW		 7297}
7298
7299OP *
cea2e8a9 7300Perl_ck_shift(pTHX_ OP *o)
79072805 7301{
97aff369 7302 dVAR;
6867be6d 7303 const I32 type = o->op_type;
79072805 7304
11343788 7305 if (!(o->op_flags & OPf_KIDS)) {
6d4ff0d2 7306 OP *argop;
eb8433b7
NC		 7307 /* FIXME - this can be refactored to reduce code in #ifdefs */
7308#ifdef PERL_MAD
1d866c12 7309 OP * const oldo = o;
eb8433b7 7310#else
11343788 7311 op_free(o);
eb8433b7 7312#endif
6d4ff0d2 7313 argop = newUNOP(OP_RV2AV, 0,
8fde6460 7314 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
eb8433b7
NC		 7315#ifdef PERL_MAD
7316 o = newUNOP(type, 0, scalar(argop));
7317 op_getmad(oldo,o,'O');
7318 return o;
7319#else
6d4ff0d2 7320 return newUNOP(type, 0, scalar(argop));
eb8433b7 7321#endif
79072805 7322 }
11343788 7323 return scalar(modkids(ck_fun(o), type));
79072805
LW		 7324}
7325
7326OP *
cea2e8a9 7327Perl_ck_sort(pTHX_ OP *o)
79072805 7328{
97aff369 7329 dVAR;
8e3f9bdf 7330 OP *firstkid;
bbce6d69 7331
1496a290 7332 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
a4fc7abc 7333 HV * const hinthv = GvHV(PL_hintgv);
7b9ef140 7334 if (hinthv) {
a4fc7abc 7335 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7b9ef140 7336 if (svp) {
a4fc7abc 7337 const I32 sorthints = (I32)SvIV(*svp);
7b9ef140
RH		 7338 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7339 o->op_private |= OPpSORT_QSORT;
7340 if ((sorthints & HINT_SORT_STABLE) != 0)
7341 o->op_private |= OPpSORT_STABLE;
7342 }
7343 }
7344 }
7345
9ea6e965 7346 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
51a19bc0 7347 simplify_sort(o);
8e3f9bdf
GS		 7348 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7349 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
9c5ffd7c 7350 OP *k = NULL;
8e3f9bdf 7351 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
79072805 7352
463ee0b2 7353 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
79072805 7354 linklist(kid);
463ee0b2
LW		 7355 if (kid->op_type == OP_SCOPE) {
7356 k = kid->op_next;
7357 kid->op_next = 0;
79072805 7358 }
463ee0b2 7359 else if (kid->op_type == OP_LEAVE) {
11343788 7360 if (o->op_type == OP_SORT) {
93c66552 7361 op_null(kid); /* wipe out leave */
748a9306 7362 kid->op_next = kid;
463ee0b2 7363
748a9306
LW		 7364 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7365 if (k->op_next == kid)
7366 k->op_next = 0;
71a29c3c
GS		 7367 /* don't descend into loops */
7368 else if (k->op_type == OP_ENTERLOOP
7369 || k->op_type == OP_ENTERITER)
7370 {
7371 k = cLOOPx(k)->op_lastop;
7372 }
748a9306 7373 }
463ee0b2 7374 }
748a9306
LW		 7375 else
7376 kid->op_next = 0; /* just disconnect the leave */
a0d0e21e 7377 k = kLISTOP->op_first;
463ee0b2 7378 }
a2efc822 7379 CALL_PEEP(k);
a0d0e21e 7380
8e3f9bdf
GS		 7381 kid = firstkid;
7382 if (o->op_type == OP_SORT) {
7383 /* provide scalar context for comparison function/block */
7384 kid = scalar(kid);
a0d0e21e 7385 kid->op_next = kid;
8e3f9bdf 7386 }
a0d0e21e
LW		 7387 else
7388 kid->op_next = k;
11343788 7389 o->op_flags |= OPf_SPECIAL;
79072805 7390 }
c6e96bcb 7391 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
93c66552 7392 op_null(firstkid);
8e3f9bdf
GS		 7393
7394 firstkid = firstkid->op_sibling;
79072805 7395 }
bbce6d69 7396
8e3f9bdf
GS		 7397 /* provide list context for arguments */
7398 if (o->op_type == OP_SORT)
7399 list(firstkid);
7400
11343788 7401 return o;
79072805 7402}
bda4119b
GS		 7403
7404STATIC void
cea2e8a9 7405S_simplify_sort(pTHX_ OP *o)
9c007264 7406{
97aff369 7407 dVAR;
9c007264
JH		 7408 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7409 OP *k;
eb209983 7410 int descending;
350de78d 7411 GV *gv;
770526c1 7412 const char *gvname;
9c007264
JH		 7413 if (!(o->op_flags & OPf_STACKED))
7414 return;
fafc274c
NC		 7415 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7416 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
82092f1d 7417 kid = kUNOP->op_first; /* get past null */
9c007264
JH		 7418 if (kid->op_type != OP_SCOPE)
7419 return;
7420 kid = kLISTOP->op_last; /* get past scope */
7421 switch(kid->op_type) {
7422 case OP_NCMP:
7423 case OP_I_NCMP:
7424 case OP_SCMP:
7425 break;
7426 default:
7427 return;
7428 }
7429 k = kid; /* remember this node*/
7430 if (kBINOP->op_first->op_type != OP_RV2SV)
7431 return;
7432 kid = kBINOP->op_first; /* get past cmp */
7433 if (kUNOP->op_first->op_type != OP_GV)
7434 return;
7435 kid = kUNOP->op_first; /* get past rv2sv */
638eceb6 7436 gv = kGVOP_gv;
350de78d 7437 if (GvSTASH(gv) != PL_curstash)
9c007264 7438 return;
770526c1
NC		 7439 gvname = GvNAME(gv);
7440 if (*gvname == 'a' && gvname[1] == '\0')
eb209983 7441 descending = 0;
770526c1 7442 else if (*gvname == 'b' && gvname[1] == '\0')
eb209983 7443 descending = 1;
9c007264
JH		 7444 else
7445 return;
eb209983 7446
9c007264
JH		 7447 kid = k; /* back to cmp */
7448 if (kBINOP->op_last->op_type != OP_RV2SV)
7449 return;
7450 kid = kBINOP->op_last; /* down to 2nd arg */
7451 if (kUNOP->op_first->op_type != OP_GV)
7452 return;
7453 kid = kUNOP->op_first; /* get past rv2sv */
638eceb6 7454 gv = kGVOP_gv;
770526c1
NC		 7455 if (GvSTASH(gv) != PL_curstash)
7456 return;
7457 gvname = GvNAME(gv);
7458 if ( descending
7459 ? !(*gvname == 'a' && gvname[1] == '\0')
7460 : !(*gvname == 'b' && gvname[1] == '\0'))
9c007264
JH		 7461 return;
7462 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
eb209983
NC		 7463 if (descending)
7464 o->op_private |= OPpSORT_DESCEND;
9c007264
JH		 7465 if (k->op_type == OP_NCMP)
7466 o->op_private |= OPpSORT_NUMERIC;
7467 if (k->op_type == OP_I_NCMP)
7468 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
e507f050
SM		 7469 kid = cLISTOPo->op_first->op_sibling;
7470 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
eb8433b7
NC		 7471#ifdef PERL_MAD
7472 op_getmad(kid,o,'S'); /* then delete it */
7473#else
e507f050 7474 op_free(kid); /* then delete it */
eb8433b7 7475#endif
9c007264 7476}
79072805
LW		 7477
7478OP *
cea2e8a9 7479Perl_ck_split(pTHX_ OP *o)
79072805 7480{
27da23d5 7481 dVAR;
79072805 7482 register OP *kid;
aeea060c 7483
11343788
MB		 7484 if (o->op_flags & OPf_STACKED)
7485 return no_fh_allowed(o);
79072805 7486
11343788 7487 kid = cLISTOPo->op_first;
8990e307 7488 if (kid->op_type != OP_NULL)
cea2e8a9 7489 Perl_croak(aTHX_ "panic: ck_split");
8990e307 7490 kid = kid->op_sibling;
11343788
MB		 7491 op_free(cLISTOPo->op_first);
7492 cLISTOPo->op_first = kid;
85e6fe83 7493 if (!kid) {
396482e1 7494 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
11343788 7495 cLISTOPo->op_last = kid; /* There was only one element previously */
85e6fe83 7496 }
79072805 7497
de4bf5b3 7498 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
551405c4 7499 OP * const sibl = kid->op_sibling;
463ee0b2 7500 kid->op_sibling = 0;
131b3ad0 7501 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
11343788
MB		 7502 if (cLISTOPo->op_first == cLISTOPo->op_last)
7503 cLISTOPo->op_last = kid;
7504 cLISTOPo->op_first = kid;
79072805
LW		 7505 kid->op_sibling = sibl;
7506 }
7507
7508 kid->op_type = OP_PUSHRE;
22c35a8c 7509 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
79072805 7510 scalar(kid);
041457d9 7511 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
f34840d8
MJD		 7512 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7513 "Use of /g modifier is meaningless in split");
7514 }
79072805
LW		 7515
7516 if (!kid->op_sibling)
54b9620d 7517 append_elem(OP_SPLIT, o, newDEFSVOP());
79072805
LW		 7518
7519 kid = kid->op_sibling;
7520 scalar(kid);
7521
7522 if (!kid->op_sibling)
11343788 7523 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
ce3e5c45 7524 assert(kid->op_sibling);
79072805
LW		 7525
7526 kid = kid->op_sibling;
7527 scalar(kid);
7528
7529 if (kid->op_sibling)
53e06cf0 7530 return too_many_arguments(o,OP_DESC(o));
79072805 7531
11343788 7532 return o;
79072805
LW		 7533}
7534
7535OP *
1c846c1f 7536Perl_ck_join(pTHX_ OP *o)
eb6e2d6f 7537{
551405c4 7538 const OP * const kid = cLISTOPo->op_first->op_sibling;
041457d9
DM		 7539 if (kid && kid->op_type == OP_MATCH) {
7540 if (ckWARN(WARN_SYNTAX)) {
6867be6d 7541 const REGEXP *re = PM_GETRE(kPMOP);
666ea192 7542 const char *pmstr = re ? re->precomp : "STRING";
bcdf7404 7543 const STRLEN len = re ? re->prelen : 6;
9014280d 7544 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
bcdf7404 7545 "/%.*s/ should probably be written as \"%.*s\"",
d83b45b8 7546 (int)len, pmstr, (int)len, pmstr);
eb6e2d6f
GS		 7547 }
7548 }
7549 return ck_fun(o);
7550}
7551
7552OP *
cea2e8a9 7553Perl_ck_subr(pTHX_ OP *o)
79072805 7554{
97aff369 7555 dVAR;
11343788
MB		 7556 OP *prev = ((cUNOPo->op_first->op_sibling)
7557 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7558 OP *o2 = prev->op_sibling;
4633a7c4 7559 OP *cvop;
a0751766 7560 const char *proto = NULL;
cbf82dd0 7561 const char *proto_end = NULL;
c445ea15
AL		 7562 CV *cv = NULL;
7563 GV *namegv = NULL;
4633a7c4
LW		 7564 int optional = 0;
7565 I32 arg = 0;
5b794e05 7566 I32 contextclass = 0;
d3fcec1f 7567 const char *e = NULL;
0723351e 7568 bool delete_op = 0;
4633a7c4 7569
d3011074 7570 o->op_private |= OPpENTERSUB_HASTARG;
11343788 7571 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
4633a7c4
LW		 7572 if (cvop->op_type == OP_RV2CV) {
7573 SVOP* tmpop;
11343788 7574 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
93c66552 7575 op_null(cvop); /* disable rv2cv */
4633a7c4 7576 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
76cd736e 7577 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
638eceb6 7578 GV *gv = cGVOPx_gv(tmpop);
350de78d 7579 cv = GvCVu(gv);
76cd736e
GS		 7580 if (!cv)
7581 tmpop->op_private |= OPpEARLY_CV;
06492da6
SF		 7582 else {
7583 if (SvPOK(cv)) {
cbf82dd0 7584 STRLEN len;
06492da6 7585 namegv = CvANON(cv) ? gv : CvGV(cv);
cbf82dd0
NC		 7586 proto = SvPV((SV*)cv, len);
7587 proto_end = proto + len;
06492da6 7588 }
46fc3d4c 7589 }
4633a7c4
LW		 7590 }
7591 }
f5d5a27c 7592 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7a52d87a
GS		 7593 if (o2->op_type == OP_CONST)
7594 o2->op_private &= ~OPpCONST_STRICT;
58a40671 7595 else if (o2->op_type == OP_LIST) {
5f66b61c
AL		 7596 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7597 if (sib && sib->op_type == OP_CONST)
7598 sib->op_private &= ~OPpCONST_STRICT;
58a40671 7599 }
7a52d87a 7600 }
3280af22
NIS		 7601 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7602 if (PERLDB_SUB && PL_curstash != PL_debstash)
11343788
MB		 7603 o->op_private |= OPpENTERSUB_DB;
7604 while (o2 != cvop) {
eb8433b7 7605 OP* o3;
9fc012f4
GG		 7606 if (PL_madskills && o2->op_type == OP_STUB) {
7607 o2 = o2->op_sibling;
7608 continue;
7609 }
eb8433b7
NC		 7610 if (PL_madskills && o2->op_type == OP_NULL)
7611 o3 = ((UNOP*)o2)->op_first;
7612 else
7613 o3 = o2;
4633a7c4 7614 if (proto) {
cbf82dd0 7615 if (proto >= proto_end)
5dc0d613 7616 return too_many_arguments(o, gv_ename(namegv));
cbf82dd0
NC		 7617
7618 switch (*proto) {
4633a7c4
LW		 7619 case ';':
7620 optional = 1;
7621 proto++;
7622 continue;
b13fd70a 7623 case '_':
f00d1d61 7624 /* _ must be at the end */
cb40c25d 7625 if (proto[1] && proto[1] != ';')
f00d1d61 7626 goto oops;
4633a7c4
LW		 7627 case '$':
7628 proto++;
7629 arg++;
11343788 7630 scalar(o2);
4633a7c4
LW		 7631 break;
7632 case '%':
7633 case '@':
11343788 7634 list(o2);
4633a7c4
LW		 7635 arg++;
7636 break;
7637 case '&':
7638 proto++;
7639 arg++;
eb8433b7 7640 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
75fc29ea 7641 bad_type(arg,
666ea192
JH		 7642 arg == 1 ? "block or sub {}" : "sub {}",
7643 gv_ename(namegv), o3);
4633a7c4
LW		 7644 break;
7645 case '*':
2ba6ecf4 7646 /* '*' allows any scalar type, including bareword */
4633a7c4
LW		 7647 proto++;
7648 arg++;
eb8433b7 7649 if (o3->op_type == OP_RV2GV)
2ba6ecf4 7650 goto wrapref; /* autoconvert GLOB -> GLOBref */
eb8433b7
NC		 7651 else if (o3->op_type == OP_CONST)
7652 o3->op_private &= ~OPpCONST_STRICT;
7653 else if (o3->op_type == OP_ENTERSUB) {
9675f7ac 7654 /* accidental subroutine, revert to bareword */
eb8433b7 7655 OP *gvop = ((UNOP*)o3)->op_first;
9675f7ac
GS		 7656 if (gvop && gvop->op_type == OP_NULL) {
7657 gvop = ((UNOP*)gvop)->op_first;
7658 if (gvop) {
7659 for (; gvop->op_sibling; gvop = gvop->op_sibling)
7660 ;
7661 if (gvop &&
7662 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
7663 (gvop = ((UNOP*)gvop)->op_first) &&
7664 gvop->op_type == OP_GV)
7665 {
551405c4
AL		 7666 GV * const gv = cGVOPx_gv(gvop);
7667 OP * const sibling = o2->op_sibling;
396482e1 7668 SV * const n = newSVpvs("");
eb8433b7 7669#ifdef PERL_MAD
1d866c12 7670 OP * const oldo2 = o2;
eb8433b7 7671#else
9675f7ac 7672 op_free(o2);
eb8433b7 7673#endif
2a797ae2 7674 gv_fullname4(n, gv, "", FALSE);
2692f720 7675 o2 = newSVOP(OP_CONST, 0, n);
eb8433b7 7676 op_getmad(oldo2,o2,'O');
9675f7ac
GS		 7677 prev->op_sibling = o2;
7678 o2->op_sibling = sibling;
7679 }
7680 }
7681 }
7682 }
2ba6ecf4
GS		 7683 scalar(o2);
7684 break;
5b794e05
JH		 7685 case '[': case ']':
7686 goto oops;
7687 break;
4633a7c4
LW		 7688 case '\\':
7689 proto++;
7690 arg++;
5b794e05 7691 again:
4633a7c4 7692 switch (*proto++) {
5b794e05
JH		 7693 case '[':
7694 if (contextclass++ == 0) {
841d93c8 7695 e = strchr(proto, ']');
5b794e05
JH		 7696 if (!e || e == proto)
7697 goto oops;
7698 }
7699 else
7700 goto oops;
7701 goto again;
7702 break;
7703 case ']':
466bafcd 7704 if (contextclass) {
a0751766
NC		 7705 const char *p = proto;
7706 const char *const end = proto;
466bafcd 7707 contextclass = 0;
466bafcd 7708 while (*--p != '[');
a0751766
NC		 7709 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
7710 (int)(end - p), p),
7711 gv_ename(namegv), o3);
466bafcd 7712 } else
5b794e05
JH		 7713 goto oops;
7714 break;
4633a7c4 7715 case '*':
eb8433b7 7716 if (o3->op_type == OP_RV2GV)
5b794e05
JH		 7717 goto wrapref;
7718 if (!contextclass)
eb8433b7 7719 bad_type(arg, "symbol", gv_ename(namegv), o3);
5b794e05 7720 break;
4633a7c4 7721 case '&':
eb8433b7 7722 if (o3->op_type == OP_ENTERSUB)
5b794e05
JH		 7723 goto wrapref;
7724 if (!contextclass)
eb8433b7
NC		 7725 bad_type(arg, "subroutine entry", gv_ename(namegv),
7726 o3);
5b794e05 7727 break;
4633a7c4 7728 case '$':
eb8433b7
NC		 7729 if (o3->op_type == OP_RV2SV ||
7730 o3->op_type == OP_PADSV ||
7731 o3->op_type == OP_HELEM ||
5b9081af 7732 o3->op_type == OP_AELEM)
5b794e05
JH		 7733 goto wrapref;
7734 if (!contextclass)
eb8433b7 7735 bad_type(arg, "scalar", gv_ename(namegv), o3);
5b794e05 7736 break;
4633a7c4 7737 case '@':
eb8433b7
NC		 7738 if (o3->op_type == OP_RV2AV ||
7739 o3->op_type == OP_PADAV)
5b794e05
JH		 7740 goto wrapref;
7741 if (!contextclass)
eb8433b7 7742 bad_type(arg, "array", gv_ename(namegv), o3);
5b794e05 7743 break;
4633a7c4 7744 case '%':
eb8433b7
NC		 7745 if (o3->op_type == OP_RV2HV ||
7746 o3->op_type == OP_PADHV)
5b794e05
JH		 7747 goto wrapref;
7748 if (!contextclass)
eb8433b7 7749 bad_type(arg, "hash", gv_ename(namegv), o3);
5b794e05
JH		 7750 break;
7751 wrapref:
4633a7c4 7752 {
551405c4
AL		 7753 OP* const kid = o2;
7754 OP* const sib = kid->op_sibling;
4633a7c4 7755 kid->op_sibling = 0;
6fa846a0
GS		 7756 o2 = newUNOP(OP_REFGEN, 0, kid);
7757 o2->op_sibling = sib;
e858de61 7758 prev->op_sibling = o2;
4633a7c4 7759 }
841d93c8 7760 if (contextclass && e) {
5b794e05
JH		 7761 proto = e + 1;
7762 contextclass = 0;
7763 }
4633a7c4
LW		 7764 break;
7765 default: goto oops;
7766 }
5b794e05
JH		 7767 if (contextclass)
7768 goto again;
4633a7c4 7769 break;
b1cb66bf 7770 case ' ':
7771 proto++;
7772 continue;
4633a7c4
LW		 7773 default:
7774 oops:
35c1215d 7775 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
be2597df 7776 gv_ename(namegv), SVfARG(cv));
4633a7c4
LW		 7777 }
7778 }
7779 else
11343788
MB		 7780 list(o2);
7781 mod(o2, OP_ENTERSUB);
7782 prev = o2;
7783 o2 = o2->op_sibling;
551405c4 7784 } /* while */
236b555a
RGS		 7785 if (o2 == cvop && proto && *proto == '_') {
7786 /* generate an access to $_ */
7787 o2 = newDEFSVOP();
7788 o2->op_sibling = prev->op_sibling;
7789 prev->op_sibling = o2; /* instead of cvop */
7790 }
cbf82dd0 7791 if (proto && !optional && proto_end > proto &&
236b555a 7792 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
5dc0d613 7793 return too_few_arguments(o, gv_ename(namegv));
0723351e 7794 if(delete_op) {
eb8433b7 7795#ifdef PERL_MAD
1d866c12 7796 OP * const oldo = o;
eb8433b7 7797#else
06492da6 7798 op_free(o);
eb8433b7 7799#endif
06492da6 7800 o=newSVOP(OP_CONST, 0, newSViv(0));
eb8433b7 7801 op_getmad(oldo,o,'O');
06492da6 7802 }
11343788 7803 return o;
79072805
LW		 7804}
7805
7806OP *
cea2e8a9 7807Perl_ck_svconst(pTHX_ OP *o)
8990e307 7808{
96a5add6 7809 PERL_UNUSED_CONTEXT;
11343788
MB		 7810 SvREADONLY_on(cSVOPo->op_sv);
7811 return o;
8990e307
LW		 7812}
7813
7814OP *
d4ac975e
GA		 7815Perl_ck_chdir(pTHX_ OP *o)
7816{
7817 if (o->op_flags & OPf_KIDS) {
1496a290 7818 SVOP * const kid = (SVOP*)cUNOPo->op_first;
d4ac975e
GA		 7819
7820 if (kid && kid->op_type == OP_CONST &&
7821 (kid->op_private & OPpCONST_BARE))
7822 {
7823 o->op_flags |= OPf_SPECIAL;
7824 kid->op_private &= ~OPpCONST_STRICT;
7825 }
7826 }
7827 return ck_fun(o);
7828}
7829
7830OP *
cea2e8a9 7831Perl_ck_trunc(pTHX_ OP *o)
79072805 7832{
11343788
MB		 7833 if (o->op_flags & OPf_KIDS) {
7834 SVOP *kid = (SVOP*)cUNOPo->op_first;
79072805 7835
a0d0e21e
LW		 7836 if (kid->op_type == OP_NULL)
7837 kid = (SVOP*)kid->op_sibling;
bb53490d
GS		 7838 if (kid && kid->op_type == OP_CONST &&
7839 (kid->op_private & OPpCONST_BARE))
7840 {
11343788 7841 o->op_flags |= OPf_SPECIAL;
bb53490d
GS		 7842 kid->op_private &= ~OPpCONST_STRICT;
7843 }
79072805 7844 }
11343788 7845 return ck_fun(o);
79072805
LW		 7846}
7847
35fba0d9 7848OP *
bab9c0ac
RGS		 7849Perl_ck_unpack(pTHX_ OP *o)
7850{
7851 OP *kid = cLISTOPo->op_first;
7852 if (kid->op_sibling) {
7853 kid = kid->op_sibling;
7854 if (!kid->op_sibling)
7855 kid->op_sibling = newDEFSVOP();
7856 }
7857 return ck_fun(o);
7858}
7859
7860OP *
35fba0d9
RG		 7861Perl_ck_substr(pTHX_ OP *o)
7862{
7863 o = ck_fun(o);
1d866c12 7864 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
35fba0d9
RG		 7865 OP *kid = cLISTOPo->op_first;
7866
7867 if (kid->op_type == OP_NULL)
7868 kid = kid->op_sibling;
7869 if (kid)
7870 kid->op_flags |= OPf_MOD;
7871
7872 }
7873 return o;
7874}
7875
61b743bb
DM		 7876/* A peephole optimizer. We visit the ops in the order they're to execute.
7877 * See the comments at the top of this file for more details about when
7878 * peep() is called */
463ee0b2 7879
79072805 7880void
864dbfa3 7881Perl_peep(pTHX_ register OP *o)
79072805 7882{
27da23d5 7883 dVAR;
c445ea15 7884 register OP* oldop = NULL;
2d8e6c8d 7885
2814eb74 7886 if (!o || o->op_opt)
79072805 7887 return;
a0d0e21e 7888 ENTER;
462e5cf6 7889 SAVEOP();
7766f137 7890 SAVEVPTR(PL_curcop);
a0d0e21e 7891 for (; o; o = o->op_next) {
2814eb74 7892 if (o->op_opt)
a0d0e21e 7893 break;
6d7dd4a5
NC		 7894 /* By default, this op has now been optimised. A couple of cases below
7895 clear this again. */
7896 o->op_opt = 1;
533c011a 7897 PL_op = o;
a0d0e21e 7898 switch (o->op_type) {
acb36ea4 7899 case OP_SETSTATE:
a0d0e21e
LW		 7900 case OP_NEXTSTATE:
7901 case OP_DBSTATE:
3280af22 7902 PL_curcop = ((COP*)o); /* for warnings */
a0d0e21e
LW		 7903 break;
7904
a0d0e21e 7905 case OP_CONST:
7a52d87a
GS		 7906 if (cSVOPo->op_private & OPpCONST_STRICT)
7907 no_bareword_allowed(o);
7766f137 7908#ifdef USE_ITHREADS
3848b962 7909 case OP_METHOD_NAMED:
7766f137
GS		 7910 /* Relocate sv to the pad for thread safety.
7911 * Despite being a "constant", the SV is written to,
7912 * for reference counts, sv_upgrade() etc. */
7913 if (cSVOP->op_sv) {
6867be6d 7914 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
330e22d5 7915 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6a7129a1 7916 /* If op_sv is already a PADTMP then it is being used by
9a049f1c 7917 * some pad, so make a copy. */
dd2155a4
DM		 7918 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
7919 SvREADONLY_on(PAD_SVl(ix));
6a7129a1
GS		 7920 SvREFCNT_dec(cSVOPo->op_sv);
7921 }
052ca17e
NC		 7922 else if (o->op_type == OP_CONST
7923 && cSVOPo->op_sv == &PL_sv_undef) {
7924 /* PL_sv_undef is hack - it's unsafe to store it in the
7925 AV that is the pad, because av_fetch treats values of
7926 PL_sv_undef as a "free" AV entry and will merrily
7927 replace them with a new SV, causing pad_alloc to think
7928 that this pad slot is free. (When, clearly, it is not)
7929 */
7930 SvOK_off(PAD_SVl(ix));
7931 SvPADTMP_on(PAD_SVl(ix));
7932 SvREADONLY_on(PAD_SVl(ix));
7933 }
6a7129a1 7934 else {
dd2155a4 7935 SvREFCNT_dec(PAD_SVl(ix));
6a7129a1 7936 SvPADTMP_on(cSVOPo->op_sv);
dd2155a4 7937 PAD_SETSV(ix, cSVOPo->op_sv);
9a049f1c 7938 /* XXX I don't know how this isn't readonly already. */
dd2155a4 7939 SvREADONLY_on(PAD_SVl(ix));
6a7129a1 7940 }
a0714e2c 7941 cSVOPo->op_sv = NULL;
7766f137
GS		 7942 o->op_targ = ix;
7943 }
7944#endif
07447971
GS		 7945 break;
7946
df91b2c5
AE		 7947 case OP_CONCAT:
7948 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
7949 if (o->op_next->op_private & OPpTARGET_MY) {
7950 if (o->op_flags & OPf_STACKED) /* chained concats */
a6aa0b75 7951 break; /* ignore_optimization */
df91b2c5
AE		 7952 else {
7953 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
7954 o->op_targ = o->op_next->op_targ;
7955 o->op_next->op_targ = 0;
7956 o->op_private |= OPpTARGET_MY;
7957 }
7958 }
7959 op_null(o->op_next);
7960 }
df91b2c5 7961 break;
6d7dd4a5
NC		 7962 case OP_STUB:
7963 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
7964 break; /* Scalar stub must produce undef. List stub is noop */
7965 }
7966 goto nothin;
79072805 7967 case OP_NULL:
acb36ea4
GS		 7968 if (o->op_targ == OP_NEXTSTATE
7969 || o->op_targ == OP_DBSTATE
7970 || o->op_targ == OP_SETSTATE)
7971 {
3280af22 7972 PL_curcop = ((COP*)o);
acb36ea4 7973 }
dad75012
AMS		 7974 /* XXX: We avoid setting op_seq here to prevent later calls
7975 to peep() from mistakenly concluding that optimisation
7976 has already occurred. This doesn't fix the real problem,
7977 though (See 20010220.007). AMS 20010719 */
2814eb74 7978 /* op_seq functionality is now replaced by op_opt */
6d7dd4a5 7979 o->op_opt = 0;
f46f2f82 7980 /* FALL THROUGH */
79072805 7981 case OP_SCALAR:
93a17b20 7982 case OP_LINESEQ:
463ee0b2 7983 case OP_SCOPE:
6d7dd4a5 7984 nothin:
a0d0e21e
LW		 7985 if (oldop && o->op_next) {
7986 oldop->op_next = o->op_next;
6d7dd4a5 7987 o->op_opt = 0;
79072805
LW		 7988 continue;
7989 }
79072805
LW		 7990 break;
7991
6a077020 7992 case OP_PADAV:
79072805 7993 case OP_GV:
6a077020 7994 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
0bd48802 7995 OP* const pop = (o->op_type == OP_PADAV) ?
6a077020 7996 o->op_next : o->op_next->op_next;
a0d0e21e 7997 IV i;
f9dc862f 7998 if (pop && pop->op_type == OP_CONST &&
af5acbb4 7999 ((PL_op = pop->op_next)) &&
8990e307 8000 pop->op_next->op_type == OP_AELEM &&
a0d0e21e 8001 !(pop->op_next->op_private &
78f9721b 8002 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
fc15ae8f 8003 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
a0d0e21e 8004 <= 255 &&
8990e307
LW		 8005 i >= 0)
8006 {
350de78d 8007 GV *gv;
af5acbb4
DM		 8008 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
8009 no_bareword_allowed(pop);
6a077020
DM		 8010 if (o->op_type == OP_GV)
8011 op_null(o->op_next);
93c66552
DM		 8012 op_null(pop->op_next);
8013 op_null(pop);
a0d0e21e
LW		 8014 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
8015 o->op_next = pop->op_next->op_next;
22c35a8c 8016 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
a0d0e21e 8017 o->op_private = (U8)i;
6a077020
DM		 8018 if (o->op_type == OP_GV) {
8019 gv = cGVOPo_gv;
8020 GvAVn(gv);
8021 }
8022 else
8023 o->op_flags |= OPf_SPECIAL;
8024 o->op_type = OP_AELEMFAST;
8025 }
6a077020
DM		 8026 break;
8027 }
8028
8029 if (o->op_next->op_type == OP_RV2SV) {
8030 if (!(o->op_next->op_private & OPpDEREF)) {
8031 op_null(o->op_next);
8032 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
8033 | OPpOUR_INTRO);
8034 o->op_next = o->op_next->op_next;
8035 o->op_type = OP_GVSV;
8036 o->op_ppaddr = PL_ppaddr[OP_GVSV];
8990e307 8037 }
79072805 8038 }
e476b1b5 8039 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
551405c4 8040 GV * const gv = cGVOPo_gv;
b15aece3 8041 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
76cd736e 8042 /* XXX could check prototype here instead of just carping */
551405c4 8043 SV * const sv = sv_newmortal();
bd61b366 8044 gv_efullname3(sv, gv, NULL);
9014280d 8045 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
35c1215d 8046 "%"SVf"() called too early to check prototype",
be2597df 8047 SVfARG(sv));
76cd736e
GS		 8048 }
8049 }
89de2904
AMS		 8050 else if (o->op_next->op_type == OP_READLINE
8051 && o->op_next->op_next->op_type == OP_CONCAT
8052 && (o->op_next->op_next->op_flags & OPf_STACKED))
8053 {
d2c45030
AMS		 8054 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
8055 o->op_type = OP_RCATLINE;
8056 o->op_flags |= OPf_STACKED;
8057 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
89de2904 8058 op_null(o->op_next->op_next);
d2c45030 8059 op_null(o->op_next);
89de2904 8060 }
76cd736e 8061
79072805
LW		 8062 break;
8063
a0d0e21e 8064 case OP_MAPWHILE:
79072805
LW		 8065 case OP_GREPWHILE:
8066 case OP_AND:
8067 case OP_OR:
c963b151 8068 case OP_DOR:
2c2d71f5
JH		 8069 case OP_ANDASSIGN:
8070 case OP_ORASSIGN:
c963b151 8071 case OP_DORASSIGN:
1a67a97c
SM		 8072 case OP_COND_EXPR:
8073 case OP_RANGE:
c5917253 8074 case OP_ONCE:
fd4d1407
IZ		 8075 while (cLOGOP->op_other->op_type == OP_NULL)
8076 cLOGOP->op_other = cLOGOP->op_other->op_next;
a2efc822 8077 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
79072805
LW		 8078 break;
8079
79072805 8080 case OP_ENTERLOOP:
9c2ca71a 8081 case OP_ENTERITER:
58cccf98
SM		 8082 while (cLOOP->op_redoop->op_type == OP_NULL)
8083 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
79072805 8084 peep(cLOOP->op_redoop);
58cccf98
SM		 8085 while (cLOOP->op_nextop->op_type == OP_NULL)
8086 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
79072805 8087 peep(cLOOP->op_nextop);
58cccf98
SM		 8088 while (cLOOP->op_lastop->op_type == OP_NULL)
8089 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
79072805
LW		 8090 peep(cLOOP->op_lastop);
8091 break;
8092
79072805 8093 case OP_SUBST:
29f2e912
NC		 8094 assert(!(cPMOP->op_pmflags & PMf_ONCE));
8095 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
8096 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
8097 cPMOP->op_pmstashstartu.op_pmreplstart
8098 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
8099 peep(cPMOP->op_pmstashstartu.op_pmreplstart);
79072805
LW		 8100 break;
8101
a0d0e21e 8102 case OP_EXEC:
041457d9
DM		 8103 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
8104 && ckWARN(WARN_SYNTAX))
8105 {
1496a290
AL		 8106 if (o->op_next->op_sibling) {
8107 const OPCODE type = o->op_next->op_sibling->op_type;
8108 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
8109 const line_t oldline = CopLINE(PL_curcop);
8110 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
8111 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8112 "Statement unlikely to be reached");
8113 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8114 "\t(Maybe you meant system() when you said exec()?)\n");
8115 CopLINE_set(PL_curcop, oldline);
8116 }
a0d0e21e
LW		 8117 }
8118 }
8119 break;
b2ffa427 8120
c750a3ec 8121 case OP_HELEM: {
e75d1f10 8122 UNOP *rop;
6d822dc4 8123 SV *lexname;
e75d1f10 8124 GV **fields;
6d822dc4 8125 SV **svp, *sv;
d5263905 8126 const char *key = NULL;
c750a3ec 8127 STRLEN keylen;
b2ffa427 8128
1c846c1f 8129 if (((BINOP*)o)->op_last->op_type != OP_CONST)
c750a3ec 8130 break;
1c846c1f
NIS		 8131
8132 /* Make the CONST have a shared SV */
8133 svp = cSVOPx_svp(((BINOP*)o)->op_last);
3049cdab 8134 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
d5263905 8135 key = SvPV_const(sv, keylen);
25716404 8136 lexname = newSVpvn_share(key,
bb7a0f54 8137 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
25716404 8138 0);
1c846c1f
NIS		 8139 SvREFCNT_dec(sv);
8140 *svp = lexname;
8141 }
e75d1f10
RD		 8142
8143 if ((o->op_private & (OPpLVAL_INTRO)))
8144 break;
8145
8146 rop = (UNOP*)((BINOP*)o)->op_first;
8147 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
8148 break;
8149 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
00b1698f 8150 if (!SvPAD_TYPED(lexname))
e75d1f10 8151 break;
a4fc7abc 8152 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
e75d1f10
RD		 8153 if (!fields || !GvHV(*fields))
8154 break;
93524f2b 8155 key = SvPV_const(*svp, keylen);
e75d1f10 8156 if (!hv_fetch(GvHV(*fields), key,
bb7a0f54 8157 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
e75d1f10
RD		 8158 {
8159 Perl_croak(aTHX_ "No such class field \"%s\" "
8160 "in variable %s of type %s",
93524f2b 8161 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
e75d1f10
RD		 8162 }
8163
6d822dc4
MS		 8164 break;
8165 }
c750a3ec 8166
e75d1f10
RD		 8167 case OP_HSLICE: {
8168 UNOP *rop;
8169 SV *lexname;
8170 GV **fields;
8171 SV **svp;
93524f2b 8172 const char *key;
e75d1f10
RD		 8173 STRLEN keylen;
8174 SVOP *first_key_op, *key_op;
8175
8176 if ((o->op_private & (OPpLVAL_INTRO))
8177 /* I bet there's always a pushmark... */
8178 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
8179 /* hmmm, no optimization if list contains only one key. */
8180 break;
8181 rop = (UNOP*)((LISTOP*)o)->op_last;
8182 if (rop->op_type != OP_RV2HV)
8183 break;
8184 if (rop->op_first->op_type == OP_PADSV)
8185 /* @$hash{qw(keys here)} */
8186 rop = (UNOP*)rop->op_first;
8187 else {
8188 /* @{$hash}{qw(keys here)} */
8189 if (rop->op_first->op_type == OP_SCOPE
8190 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
8191 {
8192 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
8193 }
8194 else
8195 break;
8196 }
8197
8198 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
00b1698f 8199 if (!SvPAD_TYPED(lexname))
e75d1f10 8200 break;
a4fc7abc 8201 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
e75d1f10
RD		 8202 if (!fields || !GvHV(*fields))
8203 break;
8204 /* Again guessing that the pushmark can be jumped over.... */
8205 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
8206 ->op_first->op_sibling;
8207 for (key_op = first_key_op; key_op;
8208 key_op = (SVOP*)key_op->op_sibling) {
8209 if (key_op->op_type != OP_CONST)
8210 continue;
8211 svp = cSVOPx_svp(key_op);
93524f2b 8212 key = SvPV_const(*svp, keylen);
e75d1f10 8213 if (!hv_fetch(GvHV(*fields), key,
bb7a0f54 8214 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
e75d1f10
RD		 8215 {
8216 Perl_croak(aTHX_ "No such class field \"%s\" "
8217 "in variable %s of type %s",
bfcb3514 8218 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
e75d1f10
RD		 8219 }
8220 }
8221 break;
8222 }
8223
fe1bc4cf 8224 case OP_SORT: {
fe1bc4cf 8225 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
551405c4 8226 OP *oleft;
fe1bc4cf
DM		 8227 OP *o2;
8228
fe1bc4cf 8229 /* check that RHS of sort is a single plain array */
551405c4 8230 OP *oright = cUNOPo->op_first;
fe1bc4cf
DM		 8231 if (!oright || oright->op_type != OP_PUSHMARK)
8232 break;
471178c0
NC		 8233
8234 /* reverse sort ... can be optimised. */
8235 if (!cUNOPo->op_sibling) {
8236 /* Nothing follows us on the list. */
551405c4 8237 OP * const reverse = o->op_next;
471178c0
NC		 8238
8239 if (reverse->op_type == OP_REVERSE &&
8240 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
551405c4 8241 OP * const pushmark = cUNOPx(reverse)->op_first;
471178c0
NC		 8242 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8243 && (cUNOPx(pushmark)->op_sibling == o)) {
8244 /* reverse -> pushmark -> sort */
8245 o->op_private |= OPpSORT_REVERSE;
8246 op_null(reverse);
8247 pushmark->op_next = oright->op_next;
8248 op_null(oright);
8249 }
8250 }
8251 }
8252
8253 /* make @a = sort @a act in-place */
8254
fe1bc4cf
DM		 8255 oright = cUNOPx(oright)->op_sibling;
8256 if (!oright)
8257 break;
8258 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8259 oright = cUNOPx(oright)->op_sibling;
8260 }
8261
8262 if (!oright ||
8263 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8264 || oright->op_next != o
8265 || (oright->op_private & OPpLVAL_INTRO)
8266 )
8267 break;
8268
8269 /* o2 follows the chain of op_nexts through the LHS of the
8270 * assign (if any) to the aassign op itself */
8271 o2 = o->op_next;
8272 if (!o2 || o2->op_type != OP_NULL)
8273 break;
8274 o2 = o2->op_next;
8275 if (!o2 || o2->op_type != OP_PUSHMARK)
8276 break;
8277 o2 = o2->op_next;
8278 if (o2 && o2->op_type == OP_GV)
8279 o2 = o2->op_next;
8280 if (!o2
8281 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8282 || (o2->op_private & OPpLVAL_INTRO)
8283 )
8284 break;
8285 oleft = o2;
8286 o2 = o2->op_next;
8287 if (!o2 || o2->op_type != OP_NULL)
8288 break;
8289 o2 = o2->op_next;
8290 if (!o2 || o2->op_type != OP_AASSIGN
8291 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8292 break;
8293
db7511db
DM		 8294 /* check that the sort is the first arg on RHS of assign */
8295
8296 o2 = cUNOPx(o2)->op_first;
8297 if (!o2 || o2->op_type != OP_NULL)
8298 break;
8299 o2 = cUNOPx(o2)->op_first;
8300 if (!o2 || o2->op_type != OP_PUSHMARK)
8301 break;
8302 if (o2->op_sibling != o)
8303 break;
8304
fe1bc4cf
DM		 8305 /* check the array is the same on both sides */
8306 if (oleft->op_type == OP_RV2AV) {
8307 if (oright->op_type != OP_RV2AV
8308 || !cUNOPx(oright)->op_first
8309 || cUNOPx(oright)->op_first->op_type != OP_GV
8310 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8311 cGVOPx_gv(cUNOPx(oright)->op_first)
8312 )
8313 break;
8314 }
8315 else if (oright->op_type != OP_PADAV
8316 || oright->op_targ != oleft->op_targ
8317 )
8318 break;
8319
8320 /* transfer MODishness etc from LHS arg to RHS arg */
8321 oright->op_flags = oleft->op_flags;
8322 o->op_private |= OPpSORT_INPLACE;
8323
8324 /* excise push->gv->rv2av->null->aassign */
8325 o2 = o->op_next->op_next;
8326 op_null(o2); /* PUSHMARK */
8327 o2 = o2->op_next;
8328 if (o2->op_type == OP_GV) {
8329 op_null(o2); /* GV */
8330 o2 = o2->op_next;
8331 }
8332 op_null(o2); /* RV2AV or PADAV */
8333 o2 = o2->op_next->op_next;
8334 op_null(o2); /* AASSIGN */
8335
8336 o->op_next = o2->op_next;
8337
8338 break;
8339 }
ef3e5ea9
NC		 8340
8341 case OP_REVERSE: {
e682d7b7 8342 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
ce335f37 8343 OP *gvop = NULL;
ef3e5ea9 8344 LISTOP *enter, *exlist;
ef3e5ea9
NC		 8345
8346 enter = (LISTOP *) o->op_next;
8347 if (!enter)
8348 break;
8349 if (enter->op_type == OP_NULL) {
8350 enter = (LISTOP *) enter->op_next;
8351 if (!enter)
8352 break;
8353 }
d46f46af
NC		 8354 /* for $a (...) will have OP_GV then OP_RV2GV here.
8355 for (...) just has an OP_GV. */
ce335f37
NC		 8356 if (enter->op_type == OP_GV) {
8357 gvop = (OP *) enter;
8358 enter = (LISTOP *) enter->op_next;
8359 if (!enter)
8360 break;
d46f46af
NC		 8361 if (enter->op_type == OP_RV2GV) {
8362 enter = (LISTOP *) enter->op_next;
8363 if (!enter)
ce335f37 8364 break;
d46f46af 8365 }
ce335f37
NC		 8366 }
8367
ef3e5ea9
NC		 8368 if (enter->op_type != OP_ENTERITER)
8369 break;
8370
8371 iter = enter->op_next;
8372 if (!iter || iter->op_type != OP_ITER)
8373 break;
8374
ce335f37
NC		 8375 expushmark = enter->op_first;
8376 if (!expushmark || expushmark->op_type != OP_NULL
8377 || expushmark->op_targ != OP_PUSHMARK)
8378 break;
8379
8380 exlist = (LISTOP *) expushmark->op_sibling;
ef3e5ea9
NC		 8381 if (!exlist || exlist->op_type != OP_NULL
8382 || exlist->op_targ != OP_LIST)
8383 break;
8384
8385 if (exlist->op_last != o) {
8386 /* Mmm. Was expecting to point back to this op. */
8387 break;
8388 }
8389 theirmark = exlist->op_first;
8390 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8391 break;
8392
c491ecac 8393 if (theirmark->op_sibling != o) {
ef3e5ea9
NC		 8394 /* There's something between the mark and the reverse, eg
8395 for (1, reverse (...))
8396 so no go. */
8397 break;
8398 }
8399
c491ecac
NC		 8400 ourmark = ((LISTOP *)o)->op_first;
8401 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8402 break;
8403
ef3e5ea9
NC		 8404 ourlast = ((LISTOP *)o)->op_last;
8405 if (!ourlast || ourlast->op_next != o)
8406 break;
8407
e682d7b7
NC		 8408 rv2av = ourmark->op_sibling;
8409 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8410 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8411 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8412 /* We're just reversing a single array. */
8413 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8414 enter->op_flags |= OPf_STACKED;
8415 }
8416
ef3e5ea9
NC		 8417 /* We don't have control over who points to theirmark, so sacrifice
8418 ours. */
8419 theirmark->op_next = ourmark->op_next;
8420 theirmark->op_flags = ourmark->op_flags;
ce335f37 8421 ourlast->op_next = gvop ? gvop : (OP *) enter;
ef3e5ea9
NC		 8422 op_null(ourmark);
8423 op_null(o);
8424 enter->op_private |= OPpITER_REVERSED;
8425 iter->op_private |= OPpITER_REVERSED;
8426
8427 break;
8428 }
e26df76a
NC		 8429
8430 case OP_SASSIGN: {
8431 OP *rv2gv;
8432 UNOP *refgen, *rv2cv;
8433 LISTOP *exlist;
8434
de3370bc
NC		 8435 if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID)
8436 break;
8437
e26df76a
NC		 8438 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8439 break;
8440
8441 rv2gv = ((BINOP *)o)->op_last;
8442 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8443 break;
8444
8445 refgen = (UNOP *)((BINOP *)o)->op_first;
8446
8447 if (!refgen || refgen->op_type != OP_REFGEN)
8448 break;
8449
8450 exlist = (LISTOP *)refgen->op_first;
8451 if (!exlist || exlist->op_type != OP_NULL
8452 || exlist->op_targ != OP_LIST)
8453 break;
8454
8455 if (exlist->op_first->op_type != OP_PUSHMARK)
8456 break;
8457
8458 rv2cv = (UNOP*)exlist->op_last;
8459
8460 if (rv2cv->op_type != OP_RV2CV)
8461 break;
8462
8463 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8464 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8465 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8466
8467 o->op_private |= OPpASSIGN_CV_TO_GV;
8468 rv2gv->op_private |= OPpDONT_INIT_GV;
8469 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8470
8471 break;
8472 }
8473
fe1bc4cf 8474
0477511c
NC		 8475 case OP_QR:
8476 case OP_MATCH:
29f2e912
NC		 8477 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
8478 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
8479 }
79072805
LW		 8480 break;
8481 }
a0d0e21e 8482 oldop = o;
79072805 8483 }
a0d0e21e 8484 LEAVE;
79072805 8485}
beab0874 8486
cef6ea9d 8487const char*
1cb0ed9b 8488Perl_custom_op_name(pTHX_ const OP* o)
53e06cf0 8489{
97aff369 8490 dVAR;
e1ec3a88 8491 const IV index = PTR2IV(o->op_ppaddr);
53e06cf0
SC		 8492 SV* keysv;
8493 HE* he;
8494
8495 if (!PL_custom_op_names) /* This probably shouldn't happen */
27da23d5 8496 return (char *)PL_op_name[OP_CUSTOM];
53e06cf0
SC		 8497
8498 keysv = sv_2mortal(newSViv(index));
8499
8500 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8501 if (!he)
27da23d5 8502 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
53e06cf0
SC		 8503
8504 return SvPV_nolen(HeVAL(he));
8505}
8506
cef6ea9d 8507const char*
1cb0ed9b 8508Perl_custom_op_desc(pTHX_ const OP* o)
53e06cf0 8509{
97aff369 8510 dVAR;
e1ec3a88 8511 const IV index = PTR2IV(o->op_ppaddr);
53e06cf0
SC		 8512 SV* keysv;
8513 HE* he;
8514
8515 if (!PL_custom_op_descs)
27da23d5 8516 return (char *)PL_op_desc[OP_CUSTOM];
53e06cf0
SC		 8517
8518 keysv = sv_2mortal(newSViv(index));
8519
8520 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8521 if (!he)
27da23d5 8522 return (char *)PL_op_desc[OP_CUSTOM];
53e06cf0
SC		 8523
8524 return SvPV_nolen(HeVAL(he));
8525}
19e8ce8e 8526
beab0874
JT		 8527#include "XSUB.h"
8528
8529/* Efficient sub that returns a constant scalar value. */
8530static void
acfe0abc 8531const_sv_xsub(pTHX_ CV* cv)
beab0874 8532{
97aff369 8533 dVAR;
beab0874 8534 dXSARGS;
9cbac4c7 8535 if (items != 0) {
6f207bd3 8536 NOOP;
9cbac4c7
DM		 8537#if 0
8538 Perl_croak(aTHX_ "usage: %s::%s()",
bfcb3514 8539 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
9cbac4c7
DM		 8540#endif
8541 }
9a049f1c 8542 EXTEND(sp, 1);
0768512c 8543 ST(0) = (SV*)XSANY.any_ptr;
beab0874
JT		 8544 XSRETURN(1);
8545}
4946a0fa
NC		 8546
8547/*
8548 * Local variables:
8549 * c-indentation-style: bsd
8550 * c-basic-offset: 4
8551 * indent-tabs-mode: t
8552 * End:
8553 *
37442d52
RGS		 8554 * ex: set ts=8 sts=4 sw=4 noet:
8555 */
Unnamed repository; edit this file 'description' to name the repository.