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