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
Don't quote a whitespace-containing ABSPERL when the whitespace
[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 */
402d2eb1 626 const IV offset = (cPMOPo)->op_pmoffset;
9cddf794 627 ReREFCNT_dec(PM_GETRE(cPMOPo));
402d2eb1
NC		 628 PL_regex_pad[offset] = &PL_sv_undef;
629 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
630 sizeof(offset));
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
402d2eb1
NC		 3369 assert(SvPOK(PL_regex_pad[0]));
3370 if (SvCUR(PL_regex_pad[0])) {
3371 /* Pop off the "packed" IV from the end. */
3372 SV *const repointer_list = PL_regex_pad[0];
3373 const char *p = SvEND(repointer_list) - sizeof(IV);
3374 const IV offset = *((IV*)p);
3375
3376 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
3377
3378 SvEND_set(repointer_list, p);
3379
110f3028 3380 pmop->op_pmoffset = offset;
14a49a24
NC		 3381 /* This slot should be free, so assert this: */
3382 assert(PL_regex_pad[offset] == &PL_sv_undef);
551405c4 3383 } else {
14a49a24 3384 SV * const repointer = &PL_sv_undef;
9a8b6709 3385 av_push(PL_regex_padav, repointer);
551405c4
AL		 3386 pmop->op_pmoffset = av_len(PL_regex_padav);
3387 PL_regex_pad = AvARRAY(PL_regex_padav);
13137afc 3388 }
debc9467 3389#endif
1eb1540c 3390
463d09e6 3391 return CHECKOP(type, pmop);
79072805
LW		 3392}
3393
131b3ad0
DM		 3394/* Given some sort of match op o, and an expression expr containing a
3395 * pattern, either compile expr into a regex and attach it to o (if it's
3396 * constant), or convert expr into a runtime regcomp op sequence (if it's
3397 * not)
3398 *
3399 * isreg indicates that the pattern is part of a regex construct, eg
3400 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3401 * split "pattern", which aren't. In the former case, expr will be a list
3402 * if the pattern contains more than one term (eg /a$b/) or if it contains
3403 * a replacement, ie s/// or tr///.
3404 */
3405
79072805 3406OP *
131b3ad0 3407Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
79072805 3408{
27da23d5 3409 dVAR;
79072805
LW		 3410 PMOP *pm;
3411 LOGOP *rcop;
ce862d02 3412 I32 repl_has_vars = 0;
5f66b61c 3413 OP* repl = NULL;
131b3ad0
DM		 3414 bool reglist;
3415
3416 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3417 /* last element in list is the replacement; pop it */
3418 OP* kid;
3419 repl = cLISTOPx(expr)->op_last;
3420 kid = cLISTOPx(expr)->op_first;
3421 while (kid->op_sibling != repl)
3422 kid = kid->op_sibling;
5f66b61c 3423 kid->op_sibling = NULL;
131b3ad0
DM		 3424 cLISTOPx(expr)->op_last = kid;
3425 }
79072805 3426
131b3ad0
DM		 3427 if (isreg && expr->op_type == OP_LIST &&
3428 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3429 {
3430 /* convert single element list to element */
0bd48802 3431 OP* const oe = expr;
131b3ad0 3432 expr = cLISTOPx(oe)->op_first->op_sibling;
5f66b61c
AL		 3433 cLISTOPx(oe)->op_first->op_sibling = NULL;
3434 cLISTOPx(oe)->op_last = NULL;
131b3ad0
DM		 3435 op_free(oe);
3436 }
3437
3438 if (o->op_type == OP_TRANS) {
11343788 3439 return pmtrans(o, expr, repl);
131b3ad0
DM		 3440 }
3441
3442 reglist = isreg && expr->op_type == OP_LIST;
3443 if (reglist)
3444 op_null(expr);
79072805 3445
3280af22 3446 PL_hints |= HINT_BLOCK_SCOPE;
11343788 3447 pm = (PMOP*)o;
79072805
LW		 3448
3449 if (expr->op_type == OP_CONST) {
b9ad30b4 3450 SV *pat = ((SVOP*)expr)->op_sv;
c737faaf 3451 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
5c144d81 3452
0ac6acae
AB		 3453 if (o->op_flags & OPf_SPECIAL)
3454 pm_flags |= RXf_SPLIT;
5c144d81 3455
b9ad30b4
NC		 3456 if (DO_UTF8(pat)) {
3457 assert (SvUTF8(pat));
3458 } else if (SvUTF8(pat)) {
3459 /* Not doing UTF-8, despite what the SV says. Is this only if we're
3460 trapped in use 'bytes'? */
3461 /* Make a copy of the octet sequence, but without the flag on, as
3462 the compiler now honours the SvUTF8 flag on pat. */
3463 STRLEN len;
3464 const char *const p = SvPV(pat, len);
3465 pat = newSVpvn_flags(p, len, SVs_TEMP);
3466 }
0ac6acae 3467
3ab4a224 3468 PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
c737faaf 3469
eb8433b7
NC		 3470#ifdef PERL_MAD
3471 op_getmad(expr,(OP*)pm,'e');
3472#else
79072805 3473 op_free(expr);
eb8433b7 3474#endif
79072805
LW		 3475 }
3476 else {
3280af22 3477 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
1c846c1f 3478 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2cd61cdb
IZ		 3479 ? OP_REGCRESET
3480 : OP_REGCMAYBE),0,expr);
463ee0b2 3481
b7dc083c 3482 NewOp(1101, rcop, 1, LOGOP);
79072805 3483 rcop->op_type = OP_REGCOMP;
22c35a8c 3484 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
79072805 3485 rcop->op_first = scalar(expr);
131b3ad0
DM		 3486 rcop->op_flags |= OPf_KIDS
3487 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3488 | (reglist ? OPf_STACKED : 0);
79072805 3489 rcop->op_private = 1;
11343788 3490 rcop->op_other = o;
131b3ad0
DM		 3491 if (reglist)
3492 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3493
b5c19bd7
DM		 3494 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3495 PL_cv_has_eval = 1;
79072805
LW		 3496
3497 /* establish postfix order */
3280af22 3498 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
463ee0b2
LW		 3499 LINKLIST(expr);
3500 rcop->op_next = expr;
3501 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3502 }
3503 else {
3504 rcop->op_next = LINKLIST(expr);
3505 expr->op_next = (OP*)rcop;
3506 }
79072805 3507
11343788 3508 prepend_elem(o->op_type, scalar((OP*)rcop), o);
79072805
LW		 3509 }
3510
3511 if (repl) {
748a9306 3512 OP *curop;
0244c3a4 3513 if (pm->op_pmflags & PMf_EVAL) {
6136c704 3514 curop = NULL;
670a9cb2
DM		 3515 if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
3516 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
0244c3a4 3517 }
748a9306
LW		 3518 else if (repl->op_type == OP_CONST)
3519 curop = repl;
79072805 3520 else {
c445ea15 3521 OP *lastop = NULL;
79072805 3522 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
e80b829c 3523 if (curop->op_type == OP_SCOPE
10250113 3524 || curop->op_type == OP_LEAVE
e80b829c 3525 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
79072805 3526 if (curop->op_type == OP_GV) {
6136c704 3527 GV * const gv = cGVOPx_gv(curop);
ce862d02 3528 repl_has_vars = 1;
f702bf4a 3529 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
79072805
LW		 3530 break;
3531 }
3532 else if (curop->op_type == OP_RV2CV)
3533 break;
3534 else if (curop->op_type == OP_RV2SV ||
3535 curop->op_type == OP_RV2AV ||
3536 curop->op_type == OP_RV2HV ||
3537 curop->op_type == OP_RV2GV) {
3538 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3539 break;
3540 }
748a9306
LW		 3541 else if (curop->op_type == OP_PADSV ||
3542 curop->op_type == OP_PADAV ||
3543 curop->op_type == OP_PADHV ||
e80b829c
RGS		 3544 curop->op_type == OP_PADANY)
3545 {
ce862d02 3546 repl_has_vars = 1;
748a9306 3547 }
1167e5da 3548 else if (curop->op_type == OP_PUSHRE)
6f207bd3 3549 NOOP; /* Okay here, dangerous in newASSIGNOP */
79072805
LW		 3550 else
3551 break;
3552 }
3553 lastop = curop;
3554 }
748a9306 3555 }
ce862d02 3556 if (curop == repl
e80b829c
RGS		 3557 && !(repl_has_vars
3558 && (!PM_GETRE(pm)
07bc277f 3559 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
3be69782 3560 {
748a9306 3561 pm->op_pmflags |= PMf_CONST; /* const for long enough */
11343788 3562 prepend_elem(o->op_type, scalar(repl), o);
748a9306
LW		 3563 }
3564 else {
aaa362c4 3565 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
ce862d02 3566 pm->op_pmflags |= PMf_MAYBE_CONST;
ce862d02 3567 }
b7dc083c 3568 NewOp(1101, rcop, 1, LOGOP);
748a9306 3569 rcop->op_type = OP_SUBSTCONT;
22c35a8c 3570 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
748a9306
LW		 3571 rcop->op_first = scalar(repl);
3572 rcop->op_flags |= OPf_KIDS;
3573 rcop->op_private = 1;
11343788 3574 rcop->op_other = o;
748a9306
LW		 3575
3576 /* establish postfix order */
3577 rcop->op_next = LINKLIST(repl);
3578 repl->op_next = (OP*)rcop;
3579
20e98b0f 3580 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
29f2e912
NC		 3581 assert(!(pm->op_pmflags & PMf_ONCE));
3582 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
748a9306 3583 rcop->op_next = 0;
79072805
LW		 3584 }
3585 }
3586
3587 return (OP*)pm;
3588}
3589
3590OP *
864dbfa3 3591Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
79072805 3592{
27da23d5 3593 dVAR;
79072805 3594 SVOP *svop;
b7dc083c 3595 NewOp(1101, svop, 1, SVOP);
eb160463 3596 svop->op_type = (OPCODE)type;
22c35a8c 3597 svop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 3598 svop->op_sv = sv;
3599 svop->op_next = (OP*)svop;
eb160463 3600 svop->op_flags = (U8)flags;
22c35a8c 3601 if (PL_opargs[type] & OA_RETSCALAR)
463ee0b2 3602 scalar((OP*)svop);
22c35a8c 3603 if (PL_opargs[type] & OA_TARGET)
ed6116ce 3604 svop->op_targ = pad_alloc(type, SVs_PADTMP);
e50aee73 3605 return CHECKOP(type, svop);
79072805
LW		 3606}
3607
392d04bb 3608#ifdef USE_ITHREADS
79072805 3609OP *
350de78d
GS		 3610Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3611{
27da23d5 3612 dVAR;
350de78d
GS		 3613 PADOP *padop;
3614 NewOp(1101, padop, 1, PADOP);
eb160463 3615 padop->op_type = (OPCODE)type;
350de78d
GS		 3616 padop->op_ppaddr = PL_ppaddr[type];
3617 padop->op_padix = pad_alloc(type, SVs_PADTMP);
dd2155a4
DM		 3618 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3619 PAD_SETSV(padop->op_padix, sv);
58182927
NC		 3620 assert(sv);
3621 SvPADTMP_on(sv);
350de78d 3622 padop->op_next = (OP*)padop;
eb160463 3623 padop->op_flags = (U8)flags;
350de78d
GS		 3624 if (PL_opargs[type] & OA_RETSCALAR)
3625 scalar((OP*)padop);
3626 if (PL_opargs[type] & OA_TARGET)
3627 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3628 return CHECKOP(type, padop);
3629}
392d04bb 3630#endif
350de78d
GS		 3631
3632OP *
864dbfa3 3633Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
79072805 3634{
27da23d5 3635 dVAR;
58182927 3636 assert(gv);
350de78d 3637#ifdef USE_ITHREADS
58182927 3638 GvIN_PAD_on(gv);
ff8997d7 3639 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
350de78d 3640#else
ff8997d7 3641 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
350de78d 3642#endif
79072805
LW		 3643}
3644
3645OP *
864dbfa3 3646Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
79072805 3647{
27da23d5 3648 dVAR;
79072805 3649 PVOP *pvop;
b7dc083c 3650 NewOp(1101, pvop, 1, PVOP);
eb160463 3651 pvop->op_type = (OPCODE)type;
22c35a8c 3652 pvop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 3653 pvop->op_pv = pv;
3654 pvop->op_next = (OP*)pvop;
eb160463 3655 pvop->op_flags = (U8)flags;
22c35a8c 3656 if (PL_opargs[type] & OA_RETSCALAR)
463ee0b2 3657 scalar((OP*)pvop);
22c35a8c 3658 if (PL_opargs[type] & OA_TARGET)
ed6116ce 3659 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
e50aee73 3660 return CHECKOP(type, pvop);
79072805
LW		 3661}
3662
eb8433b7
NC		 3663#ifdef PERL_MAD
3664OP*
3665#else
79072805 3666void
eb8433b7 3667#endif
864dbfa3 3668Perl_package(pTHX_ OP *o)
79072805 3669{
97aff369 3670 dVAR;
bf070237 3671 SV *const sv = cSVOPo->op_sv;
eb8433b7
NC		 3672#ifdef PERL_MAD
3673 OP *pegop;
3674#endif
79072805 3675
3280af22
NIS		 3676 save_hptr(&PL_curstash);
3677 save_item(PL_curstname);
de11ba31 3678
bf070237 3679 PL_curstash = gv_stashsv(sv, GV_ADD);
e1a479c5 3680
bf070237 3681 sv_setsv(PL_curstname, sv);
de11ba31 3682
7ad382f4 3683 PL_hints |= HINT_BLOCK_SCOPE;
53a7735b
DM		 3684 PL_parser->copline = NOLINE;
3685 PL_parser->expect = XSTATE;
eb8433b7
NC		 3686
3687#ifndef PERL_MAD
3688 op_free(o);
3689#else
3690 if (!PL_madskills) {
3691 op_free(o);
1d866c12 3692 return NULL;
eb8433b7
NC		 3693 }
3694
3695 pegop = newOP(OP_NULL,0);
3696 op_getmad(o,pegop,'P');
3697 return pegop;
3698#endif
79072805
LW		 3699}
3700
eb8433b7
NC		 3701#ifdef PERL_MAD
3702OP*
3703#else
85e6fe83 3704void
eb8433b7 3705#endif
88d95a4d 3706Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
85e6fe83 3707{
97aff369 3708 dVAR;
a0d0e21e 3709 OP *pack;
a0d0e21e 3710 OP *imop;
b1cb66bf 3711 OP *veop;
eb8433b7
NC		 3712#ifdef PERL_MAD
3713 OP *pegop = newOP(OP_NULL,0);
3714#endif
85e6fe83 3715
88d95a4d 3716 if (idop->op_type != OP_CONST)
cea2e8a9 3717 Perl_croak(aTHX_ "Module name must be constant");
85e6fe83 3718
eb8433b7
NC		 3719 if (PL_madskills)
3720 op_getmad(idop,pegop,'U');
3721
5f66b61c 3722 veop = NULL;
b1cb66bf 3723
aec46f14 3724 if (version) {
551405c4 3725 SV * const vesv = ((SVOP*)version)->op_sv;
b1cb66bf 3726
eb8433b7
NC		 3727 if (PL_madskills)
3728 op_getmad(version,pegop,'V');
aec46f14 3729 if (!arg && !SvNIOKp(vesv)) {
b1cb66bf 3730 arg = version;
3731 }
3732 else {
3733 OP *pack;
0f79a09d 3734 SV *meth;
b1cb66bf 3735
44dcb63b 3736 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
cea2e8a9 3737 Perl_croak(aTHX_ "Version number must be constant number");
b1cb66bf 3738
88d95a4d
JH		 3739 /* Make copy of idop so we don't free it twice */
3740 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
b1cb66bf 3741
3742 /* Fake up a method call to VERSION */
18916d0d 3743 meth = newSVpvs_share("VERSION");
b1cb66bf 3744 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3745 append_elem(OP_LIST,
0f79a09d
GS		 3746 prepend_elem(OP_LIST, pack, list(version)),
3747 newSVOP(OP_METHOD_NAMED, 0, meth)));
b1cb66bf 3748 }
3749 }
aeea060c 3750
a0d0e21e 3751 /* Fake up an import/unimport */
eb8433b7
NC		 3752 if (arg && arg->op_type == OP_STUB) {
3753 if (PL_madskills)
3754 op_getmad(arg,pegop,'S');
4633a7c4 3755 imop = arg; /* no import on explicit () */
eb8433b7 3756 }
88d95a4d 3757 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
5f66b61c 3758 imop = NULL; /* use 5.0; */
468aa647
RGS		 3759 if (!aver)
3760 idop->op_private |= OPpCONST_NOVER;
b1cb66bf 3761 }
4633a7c4 3762 else {
0f79a09d
GS		 3763 SV *meth;
3764
eb8433b7
NC		 3765 if (PL_madskills)
3766 op_getmad(arg,pegop,'A');
3767
88d95a4d
JH		 3768 /* Make copy of idop so we don't free it twice */
3769 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
0f79a09d
GS		 3770
3771 /* Fake up a method call to import/unimport */
427d62a4 3772 meth = aver
18916d0d 3773 ? newSVpvs_share("import") : newSVpvs_share("unimport");
4633a7c4 3774 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
0f79a09d
GS		 3775 append_elem(OP_LIST,
3776 prepend_elem(OP_LIST, pack, list(arg)),
3777 newSVOP(OP_METHOD_NAMED, 0, meth)));
4633a7c4
LW		 3778 }
3779
a0d0e21e 3780 /* Fake up the BEGIN {}, which does its thing immediately. */
09bef843 3781 newATTRSUB(floor,
18916d0d 3782 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
5f66b61c
AL		 3783 NULL,
3784 NULL,
a0d0e21e 3785 append_elem(OP_LINESEQ,
b1cb66bf 3786 append_elem(OP_LINESEQ,
bd61b366
SS		 3787 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3788 newSTATEOP(0, NULL, veop)),
3789 newSTATEOP(0, NULL, imop) ));
85e6fe83 3790
70f5e4ed
JH		 3791 /* The "did you use incorrect case?" warning used to be here.
3792 * The problem is that on case-insensitive filesystems one
3793 * might get false positives for "use" (and "require"):
3794 * "use Strict" or "require CARP" will work. This causes
3795 * portability problems for the script: in case-strict
3796 * filesystems the script will stop working.
3797 *
3798 * The "incorrect case" warning checked whether "use Foo"
3799 * imported "Foo" to your namespace, but that is wrong, too:
3800 * there is no requirement nor promise in the language that
3801 * a Foo.pm should or would contain anything in package "Foo".
3802 *
3803 * There is very little Configure-wise that can be done, either:
3804 * the case-sensitivity of the build filesystem of Perl does not
3805 * help in guessing the case-sensitivity of the runtime environment.
3806 */
18fc9488 3807
c305c6a0 3808 PL_hints |= HINT_BLOCK_SCOPE;
53a7735b
DM		 3809 PL_parser->copline = NOLINE;
3810 PL_parser->expect = XSTATE;
8ec8fbef 3811 PL_cop_seqmax++; /* Purely for B::*'s benefit */
eb8433b7
NC		 3812
3813#ifdef PERL_MAD
3814 if (!PL_madskills) {
3815 /* FIXME - don't allocate pegop if !PL_madskills */
3816 op_free(pegop);
1d866c12 3817 return NULL;
eb8433b7
NC		 3818 }
3819 return pegop;
3820#endif
85e6fe83
LW		 3821}
3822
7d3fb230 3823/*
ccfc67b7
JH		 3824=head1 Embedding Functions
3825
7d3fb230
BS		 3826=for apidoc load_module
3827
3828Loads the module whose name is pointed to by the string part of name.
3829Note that the actual module name, not its filename, should be given.
3830Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3831PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3832(or 0 for no flags). ver, if specified, provides version semantics
3833similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3834arguments can be used to specify arguments to the module's import()
3835method, similar to C<use Foo::Bar VERSION LIST>.
3836
3837=cut */
3838
e4783991
GS		 3839void
3840Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3841{
3842 va_list args;
3843 va_start(args, ver);
3844 vload_module(flags, name, ver, &args);
3845 va_end(args);
3846}
3847
3848#ifdef PERL_IMPLICIT_CONTEXT
3849void
3850Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3851{
3852 dTHX;
3853 va_list args;
3854 va_start(args, ver);
3855 vload_module(flags, name, ver, &args);
3856 va_end(args);
3857}
3858#endif
3859
3860void
3861Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3862{
97aff369 3863 dVAR;
551405c4 3864 OP *veop, *imop;
e4783991 3865
551405c4 3866 OP * const modname = newSVOP(OP_CONST, 0, name);
e4783991
GS		 3867 modname->op_private |= OPpCONST_BARE;
3868 if (ver) {
3869 veop = newSVOP(OP_CONST, 0, ver);
3870 }
3871 else
5f66b61c 3872 veop = NULL;
e4783991
GS		 3873 if (flags & PERL_LOADMOD_NOIMPORT) {
3874 imop = sawparens(newNULLLIST());
3875 }
3876 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3877 imop = va_arg(*args, OP*);
3878 }
3879 else {
3880 SV *sv;
5f66b61c 3881 imop = NULL;
e4783991
GS		 3882 sv = va_arg(*args, SV*);
3883 while (sv) {
3884 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3885 sv = va_arg(*args, SV*);
3886 }
3887 }
81885997 3888
53a7735b
DM		 3889 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
3890 * that it has a PL_parser to play with while doing that, and also
3891 * that it doesn't mess with any existing parser, by creating a tmp
3892 * new parser with lex_start(). This won't actually be used for much,
3893 * since pp_require() will create another parser for the real work. */
3894
3895 ENTER;
3896 SAVEVPTR(PL_curcop);
5486870f 3897 lex_start(NULL, NULL, FALSE);
53a7735b
DM		 3898 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3899 veop, modname, imop);
3900 LEAVE;
e4783991
GS		 3901}
3902
79072805 3903OP *
850e8516 3904Perl_dofile(pTHX_ OP *term, I32 force_builtin)
78ca652e 3905{
97aff369 3906 dVAR;
78ca652e 3907 OP *doop;
a0714e2c 3908 GV *gv = NULL;
78ca652e 3909
850e8516 3910 if (!force_builtin) {
fafc274c 3911 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
850e8516 3912 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
a4fc7abc 3913 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
a0714e2c 3914 gv = gvp ? *gvp : NULL;
850e8516
RGS		 3915 }
3916 }
78ca652e 3917
b9f751c0 3918 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
78ca652e
GS		 3919 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3920 append_elem(OP_LIST, term,
3921 scalar(newUNOP(OP_RV2CV, 0,
d4c19fe8 3922 newGVOP(OP_GV, 0, gv))))));
78ca652e
GS		 3923 }
3924 else {
3925 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3926 }
3927 return doop;
3928}
3929
3930OP *
864dbfa3 3931Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
79072805
LW		 3932{
3933 return newBINOP(OP_LSLICE, flags,
8990e307
LW		 3934 list(force_list(subscript)),
3935 list(force_list(listval)) );
79072805
LW		 3936}
3937
76e3520e 3938STATIC I32
504618e9 3939S_is_list_assignment(pTHX_ register const OP *o)
79072805 3940{
1496a290
AL		 3941 unsigned type;
3942 U8 flags;
3943
11343788 3944 if (!o)
79072805
LW		 3945 return TRUE;
3946
1496a290 3947 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
11343788 3948 o = cUNOPo->op_first;
79072805 3949
1496a290
AL		 3950 flags = o->op_flags;
3951 type = o->op_type;
3952 if (type == OP_COND_EXPR) {
504618e9
AL		 3953 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3954 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
79072805
LW		 3955
3956 if (t && f)
3957 return TRUE;
3958 if (t || f)
3959 yyerror("Assignment to both a list and a scalar");
3960 return FALSE;
3961 }
3962
1496a290
AL		 3963 if (type == OP_LIST &&
3964 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
95f0a2f1
SB		 3965 o->op_private & OPpLVAL_INTRO)
3966 return FALSE;
3967
1496a290
AL		 3968 if (type == OP_LIST || flags & OPf_PARENS ||
3969 type == OP_RV2AV || type == OP_RV2HV ||
3970 type == OP_ASLICE || type == OP_HSLICE)
79072805
LW		 3971 return TRUE;
3972
1496a290 3973 if (type == OP_PADAV || type == OP_PADHV)
93a17b20
LW		 3974 return TRUE;
3975
1496a290 3976 if (type == OP_RV2SV)
79072805
LW		 3977 return FALSE;
3978
3979 return FALSE;
3980}
3981
3982OP *
864dbfa3 3983Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
79072805 3984{
97aff369 3985 dVAR;
11343788 3986 OP *o;
79072805 3987
a0d0e21e 3988 if (optype) {
c963b151 3989 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
a0d0e21e
LW		 3990 return newLOGOP(optype, 0,
3991 mod(scalar(left), optype),
3992 newUNOP(OP_SASSIGN, 0, scalar(right)));
3993 }
3994 else {
3995 return newBINOP(optype, OPf_STACKED,
3996 mod(scalar(left), optype), scalar(right));
3997 }
3998 }
3999
504618e9 4000 if (is_list_assignment(left)) {
6dbe9451
NC		 4001 static const char no_list_state[] = "Initialization of state variables"
4002 " in list context currently forbidden";
10c8fecd 4003 OP *curop;
fafafbaf 4004 bool maybe_common_vars = TRUE;
10c8fecd 4005
3280af22 4006 PL_modcount = 0;
dbfe47cf
RD		 4007 /* Grandfathering $[ assignment here. Bletch.*/
4008 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
fe5bfecd 4009 PL_eval_start = (left->op_type == OP_CONST) ? right : NULL;
463ee0b2 4010 left = mod(left, OP_AASSIGN);
3280af22
NIS		 4011 if (PL_eval_start)
4012 PL_eval_start = 0;
dbfe47cf 4013 else if (left->op_type == OP_CONST) {
eb8433b7 4014 /* FIXME for MAD */
dbfe47cf
RD		 4015 /* Result of assignment is always 1 (or we'd be dead already) */
4016 return newSVOP(OP_CONST, 0, newSViv(1));
a0d0e21e 4017 }
10c8fecd
GS		 4018 curop = list(force_list(left));
4019 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
eb160463 4020 o->op_private = (U8)(0 | (flags >> 8));
dd2155a4 4021
fafafbaf
RD		 4022 if ((left->op_type == OP_LIST
4023 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
4024 {
4025 OP* lop = ((LISTOP*)left)->op_first;
4026 maybe_common_vars = FALSE;
4027 while (lop) {
4028 if (lop->op_type == OP_PADSV ||
4029 lop->op_type == OP_PADAV ||
4030 lop->op_type == OP_PADHV ||
4031 lop->op_type == OP_PADANY) {
4032 if (!(lop->op_private & OPpLVAL_INTRO))
4033 maybe_common_vars = TRUE;
4034
4035 if (lop->op_private & OPpPAD_STATE) {
4036 if (left->op_private & OPpLVAL_INTRO) {
4037 /* Each variable in state($a, $b, $c) = ... */
4038 }
4039 else {
4040 /* Each state variable in
4041 (state $a, my $b, our $c, $d, undef) = ... */
4042 }
4043 yyerror(no_list_state);
4044 } else {
4045 /* Each my variable in
4046 (state $a, my $b, our $c, $d, undef) = ... */
4047 }
4048 } else if (lop->op_type == OP_UNDEF ||
4049 lop->op_type == OP_PUSHMARK) {
4050 /* undef may be interesting in
4051 (state $a, undef, state $c) */
4052 } else {
4053 /* Other ops in the list. */
4054 maybe_common_vars = TRUE;
4055 }
4056 lop = lop->op_sibling;
4057 }
4058 }
4059 else if ((left->op_private & OPpLVAL_INTRO)
4060 && ( left->op_type == OP_PADSV
4061 || left->op_type == OP_PADAV
4062 || left->op_type == OP_PADHV
4063 || left->op_type == OP_PADANY))
4064 {
4065 maybe_common_vars = FALSE;
4066 if (left->op_private & OPpPAD_STATE) {
4067 /* All single variable list context state assignments, hence
4068 state ($a) = ...
4069 (state $a) = ...
4070 state @a = ...
4071 state (@a) = ...
4072 (state @a) = ...
4073 state %a = ...
4074 state (%a) = ...
4075 (state %a) = ...
4076 */
4077 yyerror(no_list_state);
4078 }
4079 }
4080
dd2155a4
DM		 4081 /* PL_generation sorcery:
4082 * an assignment like ($a,$b) = ($c,$d) is easier than
4083 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
4084 * To detect whether there are common vars, the global var
4085 * PL_generation is incremented for each assign op we compile.
4086 * Then, while compiling the assign op, we run through all the
4087 * variables on both sides of the assignment, setting a spare slot
4088 * in each of them to PL_generation. If any of them already have
4089 * that value, we know we've got commonality. We could use a
4090 * single bit marker, but then we'd have to make 2 passes, first
4091 * to clear the flag, then to test and set it. To find somewhere
931b58fb 4092 * to store these values, evil chicanery is done with SvUVX().
dd2155a4
DM		 4093 */
4094
fafafbaf 4095 if (maybe_common_vars) {
11343788 4096 OP *lastop = o;
3280af22 4097 PL_generation++;
11343788 4098 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
22c35a8c 4099 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
79072805 4100 if (curop->op_type == OP_GV) {
638eceb6 4101 GV *gv = cGVOPx_gv(curop);
169d2d72
NC		 4102 if (gv == PL_defgv
4103 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
79072805 4104 break;
169d2d72 4105 GvASSIGN_GENERATION_set(gv, PL_generation);
79072805 4106 }
748a9306
LW		 4107 else if (curop->op_type == OP_PADSV ||
4108 curop->op_type == OP_PADAV ||
4109 curop->op_type == OP_PADHV ||
dd2155a4
DM		 4110 curop->op_type == OP_PADANY)
4111 {
4112 if (PAD_COMPNAME_GEN(curop->op_targ)
92251a1e 4113 == (STRLEN)PL_generation)
748a9306 4114 break;
b162af07 4115 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
dd2155a4 4116
748a9306 4117 }
79072805
LW		 4118 else if (curop->op_type == OP_RV2CV)
4119 break;
4120 else if (curop->op_type == OP_RV2SV ||
4121 curop->op_type == OP_RV2AV ||
4122 curop->op_type == OP_RV2HV ||
4123 curop->op_type == OP_RV2GV) {
4124 if (lastop->op_type != OP_GV) /* funny deref? */
4125 break;
4126 }
1167e5da 4127 else if (curop->op_type == OP_PUSHRE) {
b3f5893f 4128#ifdef USE_ITHREADS
20e98b0f
NC		 4129 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4130 GV *const gv = (GV*)PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff);
169d2d72
NC		 4131 if (gv == PL_defgv
4132 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
1167e5da 4133 break;
169d2d72 4134 GvASSIGN_GENERATION_set(gv, PL_generation);
20e98b0f
NC		 4135 }
4136#else
4137 GV *const gv
4138 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4139 if (gv) {
4140 if (gv == PL_defgv
4141 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4142 break;
169d2d72 4143 GvASSIGN_GENERATION_set(gv, PL_generation);
b2ffa427 4144 }
20e98b0f 4145#endif
1167e5da 4146 }
79072805
LW		 4147 else
4148 break;
4149 }
4150 lastop = curop;
4151 }
11343788 4152 if (curop != o)
10c8fecd 4153 o->op_private |= OPpASSIGN_COMMON;
461824dc 4154 }
9fdc7570 4155
e9cc17ba 4156 if (right && right->op_type == OP_SPLIT && !PL_madskills) {
1496a290
AL		 4157 OP* tmpop = ((LISTOP*)right)->op_first;
4158 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
551405c4 4159 PMOP * const pm = (PMOP*)tmpop;
c07a80fd 4160 if (left->op_type == OP_RV2AV &&
4161 !(left->op_private & OPpLVAL_INTRO) &&
11343788 4162 !(o->op_private & OPpASSIGN_COMMON) )
c07a80fd 4163 {
4164 tmpop = ((UNOP*)left)->op_first;
20e98b0f
NC		 4165 if (tmpop->op_type == OP_GV
4166#ifdef USE_ITHREADS
4167 && !pm->op_pmreplrootu.op_pmtargetoff
4168#else
4169 && !pm->op_pmreplrootu.op_pmtargetgv
4170#endif
4171 ) {
971a9dd3 4172#ifdef USE_ITHREADS
20e98b0f
NC		 4173 pm->op_pmreplrootu.op_pmtargetoff
4174 = cPADOPx(tmpop)->op_padix;
971a9dd3
GS		 4175 cPADOPx(tmpop)->op_padix = 0; /* steal it */
4176#else
20e98b0f
NC		 4177 pm->op_pmreplrootu.op_pmtargetgv
4178 = (GV*)cSVOPx(tmpop)->op_sv;
a0714e2c 4179 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
971a9dd3 4180#endif
c07a80fd 4181 pm->op_pmflags |= PMf_ONCE;
11343788 4182 tmpop = cUNOPo->op_first; /* to list (nulled) */
c07a80fd 4183 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
5f66b61c 4184 tmpop->op_sibling = NULL; /* don't free split */
c07a80fd 4185 right->op_next = tmpop->op_next; /* fix starting loc */
11343788 4186 op_free(o); /* blow off assign */
54310121 4187 right->op_flags &= ~OPf_WANT;
a5f75d66 4188 /* "I don't know and I don't care." */
c07a80fd 4189 return right;
4190 }
4191 }
4192 else {
e6438c1a 4193 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
c07a80fd 4194 ((LISTOP*)right)->op_last->op_type == OP_CONST)
4195 {
4196 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
4197 if (SvIVX(sv) == 0)
3280af22 4198 sv_setiv(sv, PL_modcount+1);
c07a80fd 4199 }
4200 }
4201 }
4202 }
11343788 4203 return o;
79072805
LW		 4204 }
4205 if (!right)
4206 right = newOP(OP_UNDEF, 0);
4207 if (right->op_type == OP_READLINE) {
4208 right->op_flags |= OPf_STACKED;
463ee0b2 4209 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
79072805 4210 }
a0d0e21e 4211 else {
3280af22 4212 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
11343788 4213 o = newBINOP(OP_SASSIGN, flags,
463ee0b2 4214 scalar(right), mod(scalar(left), OP_SASSIGN) );
3280af22
NIS		 4215 if (PL_eval_start)
4216 PL_eval_start = 0;
748a9306 4217 else {
eb8433b7 4218 /* FIXME for MAD */
3b6547f5 4219 op_free(o);
fc15ae8f 4220 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
2e0ae2d3 4221 o->op_private |= OPpCONST_ARYBASE;
a0d0e21e
LW		 4222 }
4223 }
11343788 4224 return o;
79072805
LW		 4225}
4226
4227OP *
864dbfa3 4228Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
79072805 4229{
27da23d5 4230 dVAR;
e1ec3a88 4231 const U32 seq = intro_my();
79072805
LW		 4232 register COP *cop;
4233
b7dc083c 4234 NewOp(1101, cop, 1, COP);
57843af0 4235 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
8990e307 4236 cop->op_type = OP_DBSTATE;
22c35a8c 4237 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
8990e307
LW		 4238 }
4239 else {
4240 cop->op_type = OP_NEXTSTATE;
22c35a8c 4241 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
8990e307 4242 }
eb160463 4243 cop->op_flags = (U8)flags;
623e6609 4244 CopHINTS_set(cop, PL_hints);
ff0cee69 4245#ifdef NATIVE_HINTS
4246 cop->op_private |= NATIVE_HINTS;
4247#endif
623e6609 4248 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
79072805
LW		 4249 cop->op_next = (OP*)cop;
4250
463ee0b2 4251 if (label) {
6a3d5e3d 4252 CopLABEL_set(cop, label);
3280af22 4253 PL_hints |= HINT_BLOCK_SCOPE;
463ee0b2 4254 }
bbce6d69 4255 cop->cop_seq = seq;
7b0bddfa 4256 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
c28fe1ec
NC		 4257 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4258 */
72dc9ed5 4259 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
c28fe1ec
NC		 4260 cop->cop_hints_hash = PL_curcop->cop_hints_hash;
4261 if (cop->cop_hints_hash) {
cbb1fbea 4262 HINTS_REFCNT_LOCK;
c28fe1ec 4263 cop->cop_hints_hash->refcounted_he_refcnt++;
cbb1fbea 4264 HINTS_REFCNT_UNLOCK;
b3ca2e83 4265 }
79072805 4266
53a7735b 4267 if (PL_parser && PL_parser->copline == NOLINE)
57843af0 4268 CopLINE_set(cop, CopLINE(PL_curcop));
79072805 4269 else {
53a7735b
DM		 4270 CopLINE_set(cop, PL_parser->copline);
4271 if (PL_parser)
4272 PL_parser->copline = NOLINE;
79072805 4273 }
57843af0 4274#ifdef USE_ITHREADS
f4dd75d9 4275 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
57843af0 4276#else
f4dd75d9 4277 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
57843af0 4278#endif
11faa288 4279 CopSTASH_set(cop, PL_curstash);
79072805 4280
3280af22 4281 if (PERLDB_LINE && PL_curstash != PL_debstash) {
80a702cd
RGS		 4282 AV *av = CopFILEAVx(PL_curcop);
4283 if (av) {
4284 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4285 if (svp && *svp != &PL_sv_undef ) {
4286 (void)SvIOK_on(*svp);
4287 SvIV_set(*svp, PTR2IV(cop));
4288 }
1eb1540c 4289 }
93a17b20
LW		 4290 }
4291
722969e2 4292 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
79072805
LW		 4293}
4294
bbce6d69 4295
79072805 4296OP *
864dbfa3 4297Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
79072805 4298{
27da23d5 4299 dVAR;
883ffac3
CS		 4300 return new_logop(type, flags, &first, &other);
4301}
4302
3bd495df 4303STATIC OP *
cea2e8a9 4304S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
883ffac3 4305{
27da23d5 4306 dVAR;
79072805 4307 LOGOP *logop;
11343788 4308 OP *o;
883ffac3 4309 OP *first = *firstp;
b22e6366 4310 OP * const other = *otherp;
79072805 4311
a0d0e21e
LW		 4312 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4313 return newBINOP(type, flags, scalar(first), scalar(other));
4314
8990e307 4315 scalarboolean(first);
79072805 4316 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
68726e16
NC		 4317 if (first->op_type == OP_NOT
4318 && (first->op_flags & OPf_SPECIAL)
b6214b80
GG		 4319 && (first->op_flags & OPf_KIDS)
4320 && !PL_madskills) {
79072805
LW		 4321 if (type == OP_AND || type == OP_OR) {
4322 if (type == OP_AND)
4323 type = OP_OR;
4324 else
4325 type = OP_AND;
11343788 4326 o = first;
883ffac3 4327 first = *firstp = cUNOPo->op_first;
11343788
MB		 4328 if (o->op_next)
4329 first->op_next = o->op_next;
5f66b61c 4330 cUNOPo->op_first = NULL;
11343788 4331 op_free(o);
79072805
LW		 4332 }
4333 }
4334 if (first->op_type == OP_CONST) {
39a440a3
DM		 4335 if (first->op_private & OPpCONST_STRICT)
4336 no_bareword_allowed(first);
041457d9 4337 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
989dfb19 4338 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
75cc09e4
MHM		 4339 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
4340 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
4341 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
5f66b61c 4342 *firstp = NULL;
d6fee5c7
DM		 4343 if (other->op_type == OP_CONST)
4344 other->op_private |= OPpCONST_SHORTCIRCUIT;
eb8433b7
NC		 4345 if (PL_madskills) {
4346 OP *newop = newUNOP(OP_NULL, 0, other);
4347 op_getmad(first, newop, '1');
4348 newop->op_targ = type; /* set "was" field */
4349 return newop;
4350 }
4351 op_free(first);
79072805
LW		 4352 return other;
4353 }
4354 else {
7921d0f2 4355 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
6867be6d 4356 const OP *o2 = other;
7921d0f2
DM		 4357 if ( ! (o2->op_type == OP_LIST
4358 && (( o2 = cUNOPx(o2)->op_first))
4359 && o2->op_type == OP_PUSHMARK
4360 && (( o2 = o2->op_sibling)) )
4361 )
4362 o2 = other;
4363 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4364 || o2->op_type == OP_PADHV)
4365 && o2->op_private & OPpLVAL_INTRO
52351015 4366 && !(o2->op_private & OPpPAD_STATE)
7921d0f2
DM		 4367 && ckWARN(WARN_DEPRECATED))
4368 {
4369 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4370 "Deprecated use of my() in false conditional");
4371 }
4372
5f66b61c 4373 *otherp = NULL;
d6fee5c7
DM		 4374 if (first->op_type == OP_CONST)
4375 first->op_private |= OPpCONST_SHORTCIRCUIT;
eb8433b7
NC		 4376 if (PL_madskills) {
4377 first = newUNOP(OP_NULL, 0, first);
4378 op_getmad(other, first, '2');
4379 first->op_targ = type; /* set "was" field */
4380 }
4381 else
4382 op_free(other);
79072805
LW		 4383 return first;
4384 }
4385 }
041457d9
DM		 4386 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4387 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
59e10468 4388 {
b22e6366
AL		 4389 const OP * const k1 = ((UNOP*)first)->op_first;
4390 const OP * const k2 = k1->op_sibling;
a6006777 4391 OPCODE warnop = 0;
4392 switch (first->op_type)
4393 {
4394 case OP_NULL:
4395 if (k2 && k2->op_type == OP_READLINE
4396 && (k2->op_flags & OPf_STACKED)
1c846c1f 4397 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
72b16652 4398 {
a6006777 4399 warnop = k2->op_type;
72b16652 4400 }
a6006777 4401 break;
4402
4403 case OP_SASSIGN:
68dc0745 4404 if (k1->op_type == OP_READDIR
4405 || k1->op_type == OP_GLOB
72b16652 4406 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
68dc0745 4407 || k1->op_type == OP_EACH)
72b16652
GS		 4408 {
4409 warnop = ((k1->op_type == OP_NULL)
eb160463 4410 ? (OPCODE)k1->op_targ : k1->op_type);
72b16652 4411 }
a6006777 4412 break;
4413 }
8ebc5c01 4414 if (warnop) {
6867be6d 4415 const line_t oldline = CopLINE(PL_curcop);
53a7735b 4416 CopLINE_set(PL_curcop, PL_parser->copline);
9014280d 4417 Perl_warner(aTHX_ packWARN(WARN_MISC),
599cee73 4418 "Value of %s%s can be \"0\"; test with defined()",
22c35a8c 4419 PL_op_desc[warnop],
68dc0745 4420 ((warnop == OP_READLINE || warnop == OP_GLOB)
4421 ? " construct" : "() operator"));
57843af0 4422 CopLINE_set(PL_curcop, oldline);
8ebc5c01 4423 }
a6006777 4424 }
79072805
LW		 4425
4426 if (!other)
4427 return first;
4428
c963b151 4429 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
a0d0e21e
LW		 4430 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4431
b7dc083c 4432 NewOp(1101, logop, 1, LOGOP);
79072805 4433
eb160463 4434 logop->op_type = (OPCODE)type;
22c35a8c 4435 logop->op_ppaddr = PL_ppaddr[type];
79072805 4436 logop->op_first = first;
585ec06d 4437 logop->op_flags = (U8)(flags | OPf_KIDS);
79072805 4438 logop->op_other = LINKLIST(other);
eb160463 4439 logop->op_private = (U8)(1 | (flags >> 8));
79072805
LW		 4440
4441 /* establish postfix order */
4442 logop->op_next = LINKLIST(first);
4443 first->op_next = (OP*)logop;
4444 first->op_sibling = other;
4445
463d09e6
RGS		 4446 CHECKOP(type,logop);
4447
11343788
MB		 4448 o = newUNOP(OP_NULL, 0, (OP*)logop);
4449 other->op_next = o;
79072805 4450
11343788 4451 return o;
79072805
LW		 4452}
4453
4454OP *
864dbfa3 4455Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
79072805 4456{
27da23d5 4457 dVAR;
1a67a97c
SM		 4458 LOGOP *logop;
4459 OP *start;
11343788 4460 OP *o;
79072805 4461
b1cb66bf 4462 if (!falseop)
4463 return newLOGOP(OP_AND, 0, first, trueop);
4464 if (!trueop)
4465 return newLOGOP(OP_OR, 0, first, falseop);
79072805 4466
8990e307 4467 scalarboolean(first);
79072805 4468 if (first->op_type == OP_CONST) {
5b6782b2
NC		 4469 /* Left or right arm of the conditional? */
4470 const bool left = SvTRUE(((SVOP*)first)->op_sv);
4471 OP *live = left ? trueop : falseop;
4472 OP *const dead = left ? falseop : trueop;
2bc6235c 4473 if (first->op_private & OPpCONST_BARE &&
b22e6366
AL		 4474 first->op_private & OPpCONST_STRICT) {
4475 no_bareword_allowed(first);
4476 }
5b6782b2
NC		 4477 if (PL_madskills) {
4478 /* This is all dead code when PERL_MAD is not defined. */
4479 live = newUNOP(OP_NULL, 0, live);
4480 op_getmad(first, live, 'C');
4481 op_getmad(dead, live, left ? 'e' : 't');
4482 } else {
4483 op_free(first);
4484 op_free(dead);
79072805 4485 }
5b6782b2 4486 return live;
79072805 4487 }
1a67a97c
SM		 4488 NewOp(1101, logop, 1, LOGOP);
4489 logop->op_type = OP_COND_EXPR;
4490 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4491 logop->op_first = first;
585ec06d 4492 logop->op_flags = (U8)(flags | OPf_KIDS);
eb160463 4493 logop->op_private = (U8)(1 | (flags >> 8));
1a67a97c
SM		 4494 logop->op_other = LINKLIST(trueop);
4495 logop->op_next = LINKLIST(falseop);
79072805 4496
463d09e6
RGS		 4497 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4498 logop);
79072805
LW		 4499
4500 /* establish postfix order */
1a67a97c
SM		 4501 start = LINKLIST(first);
4502 first->op_next = (OP*)logop;
79072805 4503
b1cb66bf 4504 first->op_sibling = trueop;
4505 trueop->op_sibling = falseop;
1a67a97c 4506 o = newUNOP(OP_NULL, 0, (OP*)logop);
79072805 4507
1a67a97c 4508 trueop->op_next = falseop->op_next = o;
79072805 4509
1a67a97c 4510 o->op_next = start;
11343788 4511 return o;
79072805
LW		 4512}
4513
4514OP *
864dbfa3 4515Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
79072805 4516{
27da23d5 4517 dVAR;
1a67a97c 4518 LOGOP *range;
79072805
LW		 4519 OP *flip;
4520 OP *flop;
1a67a97c 4521 OP *leftstart;
11343788 4522 OP *o;
79072805 4523
1a67a97c 4524 NewOp(1101, range, 1, LOGOP);
79072805 4525
1a67a97c
SM		 4526 range->op_type = OP_RANGE;
4527 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4528 range->op_first = left;
4529 range->op_flags = OPf_KIDS;
4530 leftstart = LINKLIST(left);
4531 range->op_other = LINKLIST(right);
eb160463 4532 range->op_private = (U8)(1 | (flags >> 8));
79072805
LW		 4533
4534 left->op_sibling = right;
4535
1a67a97c
SM		 4536 range->op_next = (OP*)range;
4537 flip = newUNOP(OP_FLIP, flags, (OP*)range);
79072805 4538 flop = newUNOP(OP_FLOP, 0, flip);
11343788 4539 o = newUNOP(OP_NULL, 0, flop);
79072805 4540 linklist(flop);
1a67a97c 4541 range->op_next = leftstart;
79072805
LW		 4542
4543 left->op_next = flip;
4544 right->op_next = flop;
4545
1a67a97c
SM		 4546 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4547 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
ed6116ce 4548 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
79072805
LW		 4549 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4550
4551 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4552 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4553
11343788 4554 flip->op_next = o;
79072805 4555 if (!flip->op_private || !flop->op_private)
11343788 4556 linklist(o); /* blow off optimizer unless constant */
79072805 4557
11343788 4558 return o;
79072805
LW		 4559}
4560
4561OP *
864dbfa3 4562Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
79072805 4563{
97aff369 4564 dVAR;
463ee0b2 4565 OP* listop;
11343788 4566 OP* o;
73d840c0 4567 const bool once = block && block->op_flags & OPf_SPECIAL &&
a0d0e21e 4568 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
46c461b5
AL		 4569
4570 PERL_UNUSED_ARG(debuggable);
93a17b20 4571
463ee0b2
LW		 4572 if (expr) {
4573 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4574 return block; /* do {} while 0 does once */
fb73857a 4575 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4576 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
774d564b 4577 expr = newUNOP(OP_DEFINED, 0,
54b9620d 4578 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
55d729e4 4579 } else if (expr->op_flags & OPf_KIDS) {
46c461b5
AL		 4580 const OP * const k1 = ((UNOP*)expr)->op_first;
4581 const OP * const k2 = k1 ? k1->op_sibling : NULL;
55d729e4 4582 switch (expr->op_type) {
1c846c1f 4583 case OP_NULL:
55d729e4
GS		 4584 if (k2 && k2->op_type == OP_READLINE
4585 && (k2->op_flags & OPf_STACKED)
1c846c1f 4586 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
55d729e4 4587 expr = newUNOP(OP_DEFINED, 0, expr);
1c846c1f 4588 break;
55d729e4
GS		 4589
4590 case OP_SASSIGN:
06dc7ac6 4591 if (k1 && (k1->op_type == OP_READDIR
55d729e4 4592 || k1->op_type == OP_GLOB
6531c3e6 4593 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
06dc7ac6 4594 || k1->op_type == OP_EACH))
55d729e4
GS		 4595 expr = newUNOP(OP_DEFINED, 0, expr);
4596 break;
4597 }
774d564b 4598 }
463ee0b2 4599 }
93a17b20 4600
e1548254
RGS		 4601 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4602 * op, in listop. This is wrong. [perl #27024] */
4603 if (!block)
4604 block = newOP(OP_NULL, 0);
8990e307 4605 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
883ffac3 4606 o = new_logop(OP_AND, 0, &expr, &listop);
463ee0b2 4607
883ffac3
CS		 4608 if (listop)
4609 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
79072805 4610
11343788
MB		 4611 if (once && o != listop)
4612 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
79072805 4613
11343788
MB		 4614 if (o == listop)
4615 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
748a9306 4616
11343788
MB		 4617 o->op_flags |= flags;
4618 o = scope(o);
4619 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4620 return o;
79072805
LW		 4621}
4622
4623OP *
a034e688
DM		 4624Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4625whileline, OP *expr, OP *block, OP *cont, I32 has_my)
79072805 4626{
27da23d5 4627 dVAR;
79072805 4628 OP *redo;
c445ea15 4629 OP *next = NULL;
79072805 4630 OP *listop;
11343788 4631 OP *o;
1ba6ee2b 4632 U8 loopflags = 0;
46c461b5
AL		 4633
4634 PERL_UNUSED_ARG(debuggable);
79072805 4635
2d03de9c
AL		 4636 if (expr) {
4637 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4638 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4639 expr = newUNOP(OP_DEFINED, 0,
4640 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4641 } else if (expr->op_flags & OPf_KIDS) {
4642 const OP * const k1 = ((UNOP*)expr)->op_first;
4643 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4644 switch (expr->op_type) {
4645 case OP_NULL:
4646 if (k2 && k2->op_type == OP_READLINE
4647 && (k2->op_flags & OPf_STACKED)
4648 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4649 expr = newUNOP(OP_DEFINED, 0, expr);
4650 break;
55d729e4 4651
2d03de9c 4652 case OP_SASSIGN:
72c8de1a 4653 if (k1 && (k1->op_type == OP_READDIR
2d03de9c
AL		 4654 || k1->op_type == OP_GLOB
4655 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
72c8de1a 4656 || k1->op_type == OP_EACH))
2d03de9c
AL		 4657 expr = newUNOP(OP_DEFINED, 0, expr);
4658 break;
4659 }
55d729e4 4660 }
748a9306 4661 }
79072805
LW		 4662
4663 if (!block)
4664 block = newOP(OP_NULL, 0);
a034e688 4665 else if (cont || has_my) {
87246558
GS		 4666 block = scope(block);
4667 }
79072805 4668
1ba6ee2b 4669 if (cont) {
79072805 4670 next = LINKLIST(cont);
1ba6ee2b 4671 }
fb73857a 4672 if (expr) {
551405c4 4673 OP * const unstack = newOP(OP_UNSTACK, 0);
85538317
GS		 4674 if (!next)
4675 next = unstack;
4676 cont = append_elem(OP_LINESEQ, cont, unstack);
fb73857a 4677 }
79072805 4678
ce3e5c45 4679 assert(block);
463ee0b2 4680 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
ce3e5c45 4681 assert(listop);
79072805
LW		 4682 redo = LINKLIST(listop);
4683
4684 if (expr) {
53a7735b 4685 PL_parser->copline = (line_t)whileline;
883ffac3
CS		 4686 scalar(listop);
4687 o = new_logop(OP_AND, 0, &expr, &listop);
11343788 4688 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
85e6fe83 4689 op_free(expr); /* oops, it's a while (0) */
463ee0b2 4690 op_free((OP*)loop);
5f66b61c 4691 return NULL; /* listop already freed by new_logop */
463ee0b2 4692 }
883ffac3 4693 if (listop)
497b47a8 4694 ((LISTOP*)listop)->op_last->op_next =
883ffac3 4695 (o == listop ? redo : LINKLIST(o));
79072805
LW		 4696 }
4697 else
11343788 4698 o = listop;
79072805
LW		 4699
4700 if (!loop) {
b7dc083c 4701 NewOp(1101,loop,1,LOOP);
79072805 4702 loop->op_type = OP_ENTERLOOP;
22c35a8c 4703 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
79072805
LW		 4704 loop->op_private = 0;
4705 loop->op_next = (OP*)loop;
4706 }
4707
11343788 4708 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
79072805
LW		 4709
4710 loop->op_redoop = redo;
11343788 4711 loop->op_lastop = o;
1ba6ee2b 4712 o->op_private |= loopflags;
79072805
LW		 4713
4714 if (next)
4715 loop->op_nextop = next;
4716 else
11343788 4717 loop->op_nextop = o;
79072805 4718
11343788
MB		 4719 o->op_flags |= flags;
4720 o->op_private |= (flags >> 8);
4721 return o;
79072805
LW		 4722}
4723
4724OP *
66a1b24b 4725Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
79072805 4726{
27da23d5 4727 dVAR;
79072805 4728 LOOP *loop;
fb73857a 4729 OP *wop;
4bbc6d12 4730 PADOFFSET padoff = 0;
4633a7c4 4731 I32 iterflags = 0;
241416b8 4732 I32 iterpflags = 0;
d4c19fe8 4733 OP *madsv = NULL;
79072805 4734
79072805 4735 if (sv) {
85e6fe83 4736 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
241416b8 4737 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
748a9306 4738 sv->op_type = OP_RV2GV;
22c35a8c 4739 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
0be9a6bb
RH		 4740
4741 /* The op_type check is needed to prevent a possible segfault
4742 * if the loop variable is undeclared and 'strict vars' is in
4743 * effect. This is illegal but is nonetheless parsed, so we
4744 * may reach this point with an OP_CONST where we're expecting
4745 * an OP_GV.
4746 */
4747 if (cUNOPx(sv)->op_first->op_type == OP_GV
4748 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
0d863452 4749 iterpflags |= OPpITER_DEF;
79072805 4750 }
85e6fe83 4751 else if (sv->op_type == OP_PADSV) { /* private variable */
241416b8 4752 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
85e6fe83 4753 padoff = sv->op_targ;
eb8433b7
NC		 4754 if (PL_madskills)
4755 madsv = sv;
4756 else {
4757 sv->op_targ = 0;
4758 op_free(sv);
4759 }
5f66b61c 4760 sv = NULL;
85e6fe83 4761 }
79072805 4762 else
cea2e8a9 4763 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
f8503592
NC		 4764 if (padoff) {
4765 SV *const namesv = PAD_COMPNAME_SV(padoff);
4766 STRLEN len;
4767 const char *const name = SvPV_const(namesv, len);
4768
4769 if (len == 2 && name[0] == '$' && name[1] == '_')
4770 iterpflags |= OPpITER_DEF;
4771 }
79072805
LW		 4772 }
4773 else {
9f7d9405 4774 const PADOFFSET offset = pad_findmy("$_");
00b1698f 4775 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
aabe9514
RGS		 4776 sv = newGVOP(OP_GV, 0, PL_defgv);
4777 }
4778 else {
4779 padoff = offset;
aabe9514 4780 }
0d863452 4781 iterpflags |= OPpITER_DEF;
79072805 4782 }
5f05dabc 4783 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
89ea2908 4784 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4633a7c4
LW		 4785 iterflags |= OPf_STACKED;
4786 }
89ea2908
GA		 4787 else if (expr->op_type == OP_NULL &&
4788 (expr->op_flags & OPf_KIDS) &&
4789 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4790 {
4791 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4792 * set the STACKED flag to indicate that these values are to be
4793 * treated as min/max values by 'pp_iterinit'.
4794 */
d4c19fe8 4795 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
551405c4 4796 LOGOP* const range = (LOGOP*) flip->op_first;
66a1b24b
AL		 4797 OP* const left = range->op_first;
4798 OP* const right = left->op_sibling;
5152d7c7 4799 LISTOP* listop;
89ea2908
GA		 4800
4801 range->op_flags &= ~OPf_KIDS;
5f66b61c 4802 range->op_first = NULL;
89ea2908 4803
5152d7c7 4804 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
1a67a97c
SM		 4805 listop->op_first->op_next = range->op_next;
4806 left->op_next = range->op_other;
5152d7c7
GS		 4807 right->op_next = (OP*)listop;
4808 listop->op_next = listop->op_first;
89ea2908 4809
eb8433b7
NC		 4810#ifdef PERL_MAD
4811 op_getmad(expr,(OP*)listop,'O');
4812#else
89ea2908 4813 op_free(expr);
eb8433b7 4814#endif
5152d7c7 4815 expr = (OP*)(listop);
93c66552 4816 op_null(expr);
89ea2908
GA		 4817 iterflags |= OPf_STACKED;
4818 }
4819 else {
4820 expr = mod(force_list(expr), OP_GREPSTART);
4821 }
4822
4633a7c4 4823 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
89ea2908 4824 append_elem(OP_LIST, expr, scalar(sv))));
85e6fe83 4825 assert(!loop->op_next);
241416b8 4826 /* for my $x () sets OPpLVAL_INTRO;
14f338dc 4827 * for our $x () sets OPpOUR_INTRO */
c5661c80 4828 loop->op_private = (U8)iterpflags;
b7dc083c 4829#ifdef PL_OP_SLAB_ALLOC
155aba94
GS		 4830 {
4831 LOOP *tmp;
4832 NewOp(1234,tmp,1,LOOP);
bd5f3bc4 4833 Copy(loop,tmp,1,LISTOP);
bfafaa29 4834 S_op_destroy(aTHX_ (OP*)loop);
155aba94
GS		 4835 loop = tmp;
4836 }
b7dc083c 4837#else
10edeb5d 4838 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
1c846c1f 4839#endif
85e6fe83 4840 loop->op_targ = padoff;
a034e688 4841 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
eb8433b7
NC		 4842 if (madsv)
4843 op_getmad(madsv, (OP*)loop, 'v');
53a7735b 4844 PL_parser->copline = forline;
fb73857a 4845 return newSTATEOP(0, label, wop);
79072805
LW		 4846}
4847
8990e307 4848OP*
864dbfa3 4849Perl_newLOOPEX(pTHX_ I32 type, OP *label)
8990e307 4850{
97aff369 4851 dVAR;
11343788 4852 OP *o;
2d8e6c8d 4853
8990e307 4854 if (type != OP_GOTO || label->op_type == OP_CONST) {
cdaebead
MB		 4855 /* "last()" means "last" */
4856 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4857 o = newOP(type, OPf_SPECIAL);
4858 else {
ea71c68d 4859 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
4ea561bc 4860 ? SvPV_nolen_const(((SVOP*)label)->op_sv)
666ea192 4861 : ""));
cdaebead 4862 }
eb8433b7
NC		 4863#ifdef PERL_MAD
4864 op_getmad(label,o,'L');
4865#else
8990e307 4866 op_free(label);
eb8433b7 4867#endif
8990e307
LW		 4868 }
4869 else {
e3aba57a
RGS		 4870 /* Check whether it's going to be a goto &function */
4871 if (label->op_type == OP_ENTERSUB
4872 && !(label->op_flags & OPf_STACKED))
a0d0e21e 4873 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
11343788 4874 o = newUNOP(type, OPf_STACKED, label);
8990e307 4875 }
3280af22 4876 PL_hints |= HINT_BLOCK_SCOPE;
11343788 4877 return o;
8990e307
LW		 4878}
4879
0d863452
RH		 4880/* if the condition is a literal array or hash
4881 (or @{ ... } etc), make a reference to it.
4882 */
4883STATIC OP *
4884S_ref_array_or_hash(pTHX_ OP *cond)
4885{
4886 if (cond
4887 && (cond->op_type == OP_RV2AV
4888 || cond->op_type == OP_PADAV
4889 || cond->op_type == OP_RV2HV
4890 || cond->op_type == OP_PADHV))
4891
4892 return newUNOP(OP_REFGEN,
4893 0, mod(cond, OP_REFGEN));
4894
4895 else
4896 return cond;
4897}
4898
4899/* These construct the optree fragments representing given()
4900 and when() blocks.
4901
4902 entergiven and enterwhen are LOGOPs; the op_other pointer
4903 points up to the associated leave op. We need this so we
4904 can put it in the context and make break/continue work.
4905 (Also, of course, pp_enterwhen will jump straight to
4906 op_other if the match fails.)
4907 */
4908
4136a0f7 4909STATIC OP *
0d863452
RH		 4910S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
4911 I32 enter_opcode, I32 leave_opcode,
4912 PADOFFSET entertarg)
4913{
97aff369 4914 dVAR;
0d863452
RH		 4915 LOGOP *enterop;
4916 OP *o;
4917
4918 NewOp(1101, enterop, 1, LOGOP);
4919 enterop->op_type = enter_opcode;
4920 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
4921 enterop->op_flags = (U8) OPf_KIDS;
4922 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
4923 enterop->op_private = 0;
4924
4925 o = newUNOP(leave_opcode, 0, (OP *) enterop);
4926
4927 if (cond) {
4928 enterop->op_first = scalar(cond);
4929 cond->op_sibling = block;
4930
4931 o->op_next = LINKLIST(cond);
4932 cond->op_next = (OP *) enterop;
4933 }
4934 else {
4935 /* This is a default {} block */
4936 enterop->op_first = block;
4937 enterop->op_flags |= OPf_SPECIAL;
4938
4939 o->op_next = (OP *) enterop;
4940 }
4941
4942 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
4943 entergiven and enterwhen both
4944 use ck_null() */
4945
4946 enterop->op_next = LINKLIST(block);
4947 block->op_next = enterop->op_other = o;
4948
4949 return o;
4950}
4951
4952/* Does this look like a boolean operation? For these purposes
4953 a boolean operation is:
4954 - a subroutine call [*]
4955 - a logical connective
4956 - a comparison operator
4957 - a filetest operator, with the exception of -s -M -A -C
4958 - defined(), exists() or eof()
4959 - /$re/ or $foo =~ /$re/
4960
4961 [*] possibly surprising
4962 */
4136a0f7 4963STATIC bool
ef519e13 4964S_looks_like_bool(pTHX_ const OP *o)
0d863452 4965{
97aff369 4966 dVAR;
0d863452
RH		 4967 switch(o->op_type) {
4968 case OP_OR:
4969 return looks_like_bool(cLOGOPo->op_first);
4970
4971 case OP_AND:
4972 return (
4973 looks_like_bool(cLOGOPo->op_first)
4974 && looks_like_bool(cLOGOPo->op_first->op_sibling));
4975
1e1d4b91
JJ		 4976 case OP_NULL:
4977 return (
4978 o->op_flags & OPf_KIDS
4979 && looks_like_bool(cUNOPo->op_first));
4980
0d863452
RH		 4981 case OP_ENTERSUB:
4982
4983 case OP_NOT: case OP_XOR:
4984 /* Note that OP_DOR is not here */
4985
4986 case OP_EQ: case OP_NE: case OP_LT:
4987 case OP_GT: case OP_LE: case OP_GE:
4988
4989 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
4990 case OP_I_GT: case OP_I_LE: case OP_I_GE:
4991
4992 case OP_SEQ: case OP_SNE: case OP_SLT:
4993 case OP_SGT: case OP_SLE: case OP_SGE:
4994
4995 case OP_SMARTMATCH:
4996
4997 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
4998 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
4999 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
5000 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
5001 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
5002 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
5003 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
5004 case OP_FTTEXT: case OP_FTBINARY:
5005
5006 case OP_DEFINED: case OP_EXISTS:
5007 case OP_MATCH: case OP_EOF:
5008
5009 return TRUE;
5010
5011 case OP_CONST:
5012 /* Detect comparisons that have been optimized away */
5013 if (cSVOPo->op_sv == &PL_sv_yes
5014 || cSVOPo->op_sv == &PL_sv_no)
5015
5016 return TRUE;
5017
5018 /* FALL THROUGH */
5019 default:
5020 return FALSE;
5021 }
5022}
5023
5024OP *
5025Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
5026{
97aff369 5027 dVAR;
0d863452
RH		 5028 assert( cond );
5029 return newGIVWHENOP(
5030 ref_array_or_hash(cond),
5031 block,
5032 OP_ENTERGIVEN, OP_LEAVEGIVEN,
5033 defsv_off);
5034}
5035
5036/* If cond is null, this is a default {} block */
5037OP *
5038Perl_newWHENOP(pTHX_ OP *cond, OP *block)
5039{
ef519e13 5040 const bool cond_llb = (!cond || looks_like_bool(cond));
0d863452
RH		 5041 OP *cond_op;
5042
5043 if (cond_llb)
5044 cond_op = cond;
5045 else {
5046 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
5047 newDEFSVOP(),
5048 scalar(ref_array_or_hash(cond)));
5049 }
5050
5051 return newGIVWHENOP(
5052 cond_op,
5053 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
5054 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
5055}
5056
7dafbf52
DM		 5057/*
5058=for apidoc cv_undef
5059
5060Clear out all the active components of a CV. This can happen either
5061by an explicit C<undef &foo>, or by the reference count going to zero.
5062In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
5063children can still follow the full lexical scope chain.
5064
5065=cut
5066*/
5067
79072805 5068void
864dbfa3 5069Perl_cv_undef(pTHX_ CV *cv)
79072805 5070{
27da23d5 5071 dVAR;
503de470
DM		 5072
5073 DEBUG_X(PerlIO_printf(Perl_debug_log,
5074 "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
5075 PTR2UV(cv), PTR2UV(PL_comppad))
5076 );
5077
a636914a 5078#ifdef USE_ITHREADS
aed2304a 5079 if (CvFILE(cv) && !CvISXSUB(cv)) {
35f1c1c7 5080 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
a636914a 5081 Safefree(CvFILE(cv));
a636914a 5082 }
b3123a61 5083 CvFILE(cv) = NULL;
a636914a
RH		 5084#endif
5085
aed2304a 5086 if (!CvISXSUB(cv) && CvROOT(cv)) {
bb172083 5087 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
cea2e8a9 5088 Perl_croak(aTHX_ "Can't undef active subroutine");
8990e307 5089 ENTER;
a0d0e21e 5090
f3548bdc 5091 PAD_SAVE_SETNULLPAD();
a0d0e21e 5092
282f25c9 5093 op_free(CvROOT(cv));
5f66b61c
AL		 5094 CvROOT(cv) = NULL;
5095 CvSTART(cv) = NULL;
8990e307 5096 LEAVE;
79072805 5097 }
1d5db326 5098 SvPOK_off((SV*)cv); /* forget prototype */
a0714e2c 5099 CvGV(cv) = NULL;
a3985cdc
DM		 5100
5101 pad_undef(cv);
5102
7dafbf52
DM		 5103 /* remove CvOUTSIDE unless this is an undef rather than a free */
5104 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
5105 if (!CvWEAKOUTSIDE(cv))
5106 SvREFCNT_dec(CvOUTSIDE(cv));
601f1833 5107 CvOUTSIDE(cv) = NULL;
7dafbf52 5108 }
beab0874
JT		 5109 if (CvCONST(cv)) {
5110 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
5111 CvCONST_off(cv);
5112 }
d04ba589 5113 if (CvISXSUB(cv) && CvXSUB(cv)) {
96a5add6 5114 CvXSUB(cv) = NULL;
50762d59 5115 }
7dafbf52
DM		 5116 /* delete all flags except WEAKOUTSIDE */
5117 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
79072805
LW		 5118}
5119
3fe9a6f1 5120void
cbf82dd0
NC		 5121Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5122 const STRLEN len)
5123{
5124 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5125 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
5126 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
5127 || (p && (len != SvCUR(cv) /* Not the same length. */
5128 || memNE(p, SvPVX_const(cv), len))))
5129 && ckWARN_d(WARN_PROTOTYPE)) {
2d03de9c 5130 SV* const msg = sv_newmortal();
a0714e2c 5131 SV* name = NULL;
3fe9a6f1 5132
5133 if (gv)
bd61b366 5134 gv_efullname3(name = sv_newmortal(), gv, NULL);
6502358f 5135 sv_setpvs(msg, "Prototype mismatch:");
46fc3d4c 5136 if (name)
be2597df 5137 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
3fe9a6f1 5138 if (SvPOK(cv))
be2597df 5139 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
ebe643b9 5140 else
396482e1
GA		 5141 sv_catpvs(msg, ": none");
5142 sv_catpvs(msg, " vs ");
46fc3d4c 5143 if (p)
cbf82dd0 5144 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
46fc3d4c 5145 else
396482e1 5146 sv_catpvs(msg, "none");
be2597df 5147 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
3fe9a6f1 5148 }
5149}
5150
35f1c1c7
SB		 5151static void const_sv_xsub(pTHX_ CV* cv);
5152
beab0874 5153/*
ccfc67b7
JH		 5154
5155=head1 Optree Manipulation Functions
5156
beab0874
JT		 5157=for apidoc cv_const_sv
5158
5159If C<cv> is a constant sub eligible for inlining. returns the constant
5160value returned by the sub. Otherwise, returns NULL.
5161
5162Constant subs can be created with C<newCONSTSUB> or as described in
5163L<perlsub/"Constant Functions">.
5164
5165=cut
5166*/
760ac839 5167SV *
864dbfa3 5168Perl_cv_const_sv(pTHX_ CV *cv)
760ac839 5169{
96a5add6 5170 PERL_UNUSED_CONTEXT;
5069cc75
NC		 5171 if (!cv)
5172 return NULL;
5173 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5174 return NULL;
5175 return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
fe5e78ed 5176}
760ac839 5177
b5c19bd7
DM		 5178/* op_const_sv: examine an optree to determine whether it's in-lineable.
5179 * Can be called in 3 ways:
5180 *
5181 * !cv
5182 * look for a single OP_CONST with attached value: return the value
5183 *
5184 * cv && CvCLONE(cv) && !CvCONST(cv)
5185 *
5186 * examine the clone prototype, and if contains only a single
5187 * OP_CONST referencing a pad const, or a single PADSV referencing
5188 * an outer lexical, return a non-zero value to indicate the CV is
5189 * a candidate for "constizing" at clone time
5190 *
5191 * cv && CvCONST(cv)
5192 *
5193 * We have just cloned an anon prototype that was marked as a const
5194 * candidiate. Try to grab the current value, and in the case of
5195 * PADSV, ignore it if it has multiple references. Return the value.
5196 */
5197
fe5e78ed 5198SV *
6867be6d 5199Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
fe5e78ed 5200{
97aff369 5201 dVAR;
a0714e2c 5202 SV *sv = NULL;
fe5e78ed 5203
c631f32b
GG		 5204 if (PL_madskills)
5205 return NULL;
5206
0f79a09d 5207 if (!o)
a0714e2c 5208 return NULL;
1c846c1f
NIS		 5209
5210 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
fe5e78ed
GS		 5211 o = cLISTOPo->op_first->op_sibling;
5212
5213 for (; o; o = o->op_next) {
890ce7af 5214 const OPCODE type = o->op_type;
fe5e78ed 5215
1c846c1f 5216 if (sv && o->op_next == o)
fe5e78ed 5217 return sv;
e576b457
JT		 5218 if (o->op_next != o) {
5219 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
5220 continue;
5221 if (type == OP_DBSTATE)
5222 continue;
5223 }
54310121 5224 if (type == OP_LEAVESUB || type == OP_RETURN)
5225 break;
5226 if (sv)
a0714e2c 5227 return NULL;
7766f137 5228 if (type == OP_CONST && cSVOPo->op_sv)
5dc0d613 5229 sv = cSVOPo->op_sv;
b5c19bd7 5230 else if (cv && type == OP_CONST) {
dd2155a4 5231 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
beab0874 5232 if (!sv)
a0714e2c 5233 return NULL;
b5c19bd7
DM		 5234 }
5235 else if (cv && type == OP_PADSV) {
5236 if (CvCONST(cv)) { /* newly cloned anon */
5237 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5238 /* the candidate should have 1 ref from this pad and 1 ref
5239 * from the parent */
5240 if (!sv || SvREFCNT(sv) != 2)
a0714e2c 5241 return NULL;
beab0874 5242 sv = newSVsv(sv);
b5c19bd7
DM		 5243 SvREADONLY_on(sv);
5244 return sv;
5245 }
5246 else {
5247 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
5248 sv = &PL_sv_undef; /* an arbitrary non-null value */
beab0874 5249 }
760ac839 5250 }
b5c19bd7 5251 else {
a0714e2c 5252 return NULL;
b5c19bd7 5253 }
760ac839
LW		 5254 }
5255 return sv;
5256}
5257
eb8433b7
NC		 5258#ifdef PERL_MAD
5259OP *
5260#else
09bef843 5261void
eb8433b7 5262#endif
09bef843
SB		 5263Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5264{
99129197
NC		 5265#if 0
5266 /* This would be the return value, but the return cannot be reached. */
eb8433b7
NC		 5267 OP* pegop = newOP(OP_NULL, 0);
5268#endif
5269
46c461b5
AL		 5270 PERL_UNUSED_ARG(floor);
5271
09bef843
SB		 5272 if (o)
5273 SAVEFREEOP(o);
5274 if (proto)
5275 SAVEFREEOP(proto);
5276 if (attrs)
5277 SAVEFREEOP(attrs);
5278 if (block)
5279 SAVEFREEOP(block);
5280 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
eb8433b7 5281#ifdef PERL_MAD
99129197 5282 NORETURN_FUNCTION_END;
eb8433b7 5283#endif
09bef843
SB		 5284}
5285
748a9306 5286CV *
864dbfa3 5287Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
79072805 5288{
5f66b61c 5289 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
09bef843
SB		 5290}
5291
5292CV *
5293Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5294{
27da23d5 5295 dVAR;
6867be6d 5296 const char *aname;
83ee9e09 5297 GV *gv;
5c144d81 5298 const char *ps;
ea6e9374 5299 STRLEN ps_len;
c445ea15 5300 register CV *cv = NULL;
beab0874 5301 SV *const_sv;
b48b272a
NC		 5302 /* If the subroutine has no body, no attributes, and no builtin attributes
5303 then it's just a sub declaration, and we may be able to get away with
5304 storing with a placeholder scalar in the symbol table, rather than a
5305 full GV and CV. If anything is present then it will take a full CV to
5306 store it. */
5307 const I32 gv_fetch_flags
eb8433b7
NC		 5308 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5309 || PL_madskills)
b48b272a 5310 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
4ea561bc 5311 const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
8e742a20
MHM		 5312
5313 if (proto) {
5314 assert(proto->op_type == OP_CONST);
4ea561bc 5315 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
8e742a20
MHM		 5316 }
5317 else
bd61b366 5318 ps = NULL;
8e742a20 5319
83ee9e09 5320 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
aec46f14 5321 SV * const sv = sv_newmortal();
c99da370
JH		 5322 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5323 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
83ee9e09 5324 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
b15aece3 5325 aname = SvPVX_const(sv);
83ee9e09
GS		 5326 }
5327 else
bd61b366 5328 aname = NULL;
61dbb99a 5329
61dbb99a 5330 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
666ea192
JH		 5331 : gv_fetchpv(aname ? aname
5332 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
61dbb99a 5333 gv_fetch_flags, SVt_PVCV);
83ee9e09 5334
eb8433b7
NC		 5335 if (!PL_madskills) {
5336 if (o)
5337 SAVEFREEOP(o);
5338 if (proto)
5339 SAVEFREEOP(proto);
5340 if (attrs)
5341 SAVEFREEOP(attrs);
5342 }
3fe9a6f1 5343
09bef843 5344 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
55d729e4
GS		 5345 maximum a prototype before. */
5346 if (SvTYPE(gv) > SVt_NULL) {
0453d815 5347 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
e476b1b5 5348 && ckWARN_d(WARN_PROTOTYPE))
f248d071 5349 {
9014280d 5350 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
f248d071 5351 }
cbf82dd0 5352 cv_ckproto_len((CV*)gv, NULL, ps, ps_len);
55d729e4
GS		 5353 }
5354 if (ps)
ea6e9374 5355 sv_setpvn((SV*)gv, ps, ps_len);
55d729e4
GS		 5356 else
5357 sv_setiv((SV*)gv, -1);
e1a479c5 5358
3280af22
NIS		 5359 SvREFCNT_dec(PL_compcv);
5360 cv = PL_compcv = NULL;
beab0874 5361 goto done;
55d729e4
GS		 5362 }
5363
601f1833 5364 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
beab0874 5365
7fb37951
AMS		 5366#ifdef GV_UNIQUE_CHECK
5367 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
5368 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
5bd07a3d
DM		 5369 }
5370#endif
5371
eb8433b7
NC		 5372 if (!block || !ps || *ps || attrs
5373 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5374#ifdef PERL_MAD
5375 || block->op_type == OP_NULL
5376#endif
5377 )
a0714e2c 5378 const_sv = NULL;
beab0874 5379 else
601f1833 5380 const_sv = op_const_sv(block, NULL);
beab0874
JT		 5381
5382 if (cv) {
6867be6d 5383 const bool exists = CvROOT(cv) || CvXSUB(cv);
5bd07a3d 5384
7fb37951
AMS		 5385#ifdef GV_UNIQUE_CHECK
5386 if (exists && GvUNIQUE(gv)) {
5387 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5bd07a3d
DM		 5388 }
5389#endif
5390
60ed1d8c
GS		 5391 /* if the subroutine doesn't exist and wasn't pre-declared
5392 * with a prototype, assume it will be AUTOLOADed,
5393 * skipping the prototype check
5394 */
5395 if (exists || SvPOK(cv))
cbf82dd0 5396 cv_ckproto_len(cv, gv, ps, ps_len);
68dc0745 5397 /* already defined (or promised)? */
60ed1d8c 5398 if (exists || GvASSUMECV(gv)) {
eb8433b7
NC		 5399 if ((!block
5400#ifdef PERL_MAD
5401 || block->op_type == OP_NULL
5402#endif
5403 )&& !attrs) {
d3cea301
SB		 5404 if (CvFLAGS(PL_compcv)) {
5405 /* might have had built-in attrs applied */
5406 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5407 }
aa689395 5408 /* just a "sub foo;" when &foo is already defined */
3280af22 5409 SAVEFREESV(PL_compcv);
aa689395 5410 goto done;
5411 }
eb8433b7
NC		 5412 if (block
5413#ifdef PERL_MAD
5414 && block->op_type != OP_NULL
5415#endif
5416 ) {
beab0874
JT		 5417 if (ckWARN(WARN_REDEFINE)
5418 || (CvCONST(cv)
5419 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5420 {
6867be6d 5421 const line_t oldline = CopLINE(PL_curcop);
53a7735b
DM		 5422 if (PL_parser && PL_parser->copline != NOLINE)
5423 CopLINE_set(PL_curcop, PL_parser->copline);
9014280d 5424 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
666ea192
JH		 5425 CvCONST(cv) ? "Constant subroutine %s redefined"
5426 : "Subroutine %s redefined", name);
beab0874
JT		 5427 CopLINE_set(PL_curcop, oldline);
5428 }
eb8433b7
NC		 5429#ifdef PERL_MAD
5430 if (!PL_minus_c) /* keep old one around for madskills */
5431#endif
5432 {
5433 /* (PL_madskills unset in used file.) */
5434 SvREFCNT_dec(cv);
5435 }
601f1833 5436 cv = NULL;
79072805 5437 }
79072805
LW		 5438 }
5439 }
beab0874 5440 if (const_sv) {
f84c484e 5441 SvREFCNT_inc_simple_void_NN(const_sv);
beab0874 5442 if (cv) {
0768512c 5443 assert(!CvROOT(cv) && !CvCONST(cv));
c69006e4 5444 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
beab0874
JT		 5445 CvXSUBANY(cv).any_ptr = const_sv;
5446 CvXSUB(cv) = const_sv_xsub;
5447 CvCONST_on(cv);
d04ba589 5448 CvISXSUB_on(cv);
beab0874
JT		 5449 }
5450 else {
601f1833 5451 GvCV(gv) = NULL;
beab0874
JT		 5452 cv = newCONSTSUB(NULL, name, const_sv);
5453 }
e1a479c5
BB		 5454 mro_method_changed_in( /* sub Foo::Bar () { 123 } */
5455 (CvGV(cv) && GvSTASH(CvGV(cv)))
5456 ? GvSTASH(CvGV(cv))
5457 : CvSTASH(cv)
5458 ? CvSTASH(cv)
5459 : PL_curstash
5460 );
eb8433b7
NC		 5461 if (PL_madskills)
5462 goto install_block;
beab0874
JT		 5463 op_free(block);
5464 SvREFCNT_dec(PL_compcv);
5465 PL_compcv = NULL;
beab0874
JT		 5466 goto done;
5467 }
09bef843
SB		 5468 if (attrs) {
5469 HV *stash;
5470 SV *rcv;
5471
5472 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
5473 * before we clobber PL_compcv.
5474 */
99129197 5475 if (cv && (!block
eb8433b7
NC		 5476#ifdef PERL_MAD
5477 || block->op_type == OP_NULL
5478#endif
5479 )) {
09bef843 5480 rcv = (SV*)cv;
020f0e03
SB		 5481 /* Might have had built-in attributes applied -- propagate them. */
5482 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
a9164de8 5483 if (CvGV(cv) && GvSTASH(CvGV(cv)))
09bef843 5484 stash = GvSTASH(CvGV(cv));
a9164de8 5485 else if (CvSTASH(cv))
09bef843
SB		 5486 stash = CvSTASH(cv);
5487 else
5488 stash = PL_curstash;
5489 }
5490 else {
5491 /* possibly about to re-define existing subr -- ignore old cv */
5492 rcv = (SV*)PL_compcv;
a9164de8 5493 if (name && GvSTASH(gv))
09bef843
SB		 5494 stash = GvSTASH(gv);
5495 else
5496 stash = PL_curstash;
5497 }
95f0a2f1 5498 apply_attrs(stash, rcv, attrs, FALSE);
09bef843 5499 }
a0d0e21e 5500 if (cv) { /* must reuse cv if autoloaded */
eb8433b7
NC		 5501 if (
5502#ifdef PERL_MAD
5503 (
5504#endif
5505 !block
5506#ifdef PERL_MAD
5507 || block->op_type == OP_NULL) && !PL_madskills
5508#endif
5509 ) {
09bef843
SB		 5510 /* got here with just attrs -- work done, so bug out */
5511 SAVEFREESV(PL_compcv);
5512 goto done;
5513 }
a3985cdc 5514 /* transfer PL_compcv to cv */
4633a7c4 5515 cv_undef(cv);
3280af22 5516 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5c41a5fa
DM		 5517 if (!CvWEAKOUTSIDE(cv))
5518 SvREFCNT_dec(CvOUTSIDE(cv));
3280af22 5519 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
a3985cdc 5520 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
3280af22
NIS		 5521 CvOUTSIDE(PL_compcv) = 0;
5522 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5523 CvPADLIST(PL_compcv) = 0;
282f25c9 5524 /* inner references to PL_compcv must be fixed up ... */
dd2155a4 5525 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
282f25c9 5526 /* ... before we throw it away */
3280af22 5527 SvREFCNT_dec(PL_compcv);
b5c19bd7 5528 PL_compcv = cv;
a933f601
IZ		 5529 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5530 ++PL_sub_generation;
a0d0e21e
LW		 5531 }
5532 else {
3280af22 5533 cv = PL_compcv;
44a8e56a 5534 if (name) {
5535 GvCV(gv) = cv;
eb8433b7
NC		 5536 if (PL_madskills) {
5537 if (strEQ(name, "import")) {
5538 PL_formfeed = (SV*)cv;
5539 Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5540 }
5541 }
44a8e56a 5542 GvCVGEN(gv) = 0;
e1a479c5 5543 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
44a8e56a 5544 }
a0d0e21e 5545 }
65c50114 5546 CvGV(cv) = gv;
a636914a 5547 CvFILE_set_from_cop(cv, PL_curcop);
3280af22 5548 CvSTASH(cv) = PL_curstash;
8990e307 5549
3fe9a6f1 5550 if (ps)
ea6e9374 5551 sv_setpvn((SV*)cv, ps, ps_len);
4633a7c4 5552
13765c85 5553 if (PL_parser && PL_parser->error_count) {
c07a80fd 5554 op_free(block);
5f66b61c 5555 block = NULL;
68dc0745 5556 if (name) {
6867be6d 5557 const char *s = strrchr(name, ':');
68dc0745 5558 s = s ? s+1 : name;
6d4c2119 5559 if (strEQ(s, "BEGIN")) {
e1ec3a88 5560 const char not_safe[] =
6d4c2119 5561 "BEGIN not safe after errors--compilation aborted";
faef0170 5562 if (PL_in_eval & EVAL_KEEPERR)
cea2e8a9 5563 Perl_croak(aTHX_ not_safe);
6d4c2119
CS		 5564 else {
5565 /* force display of errors found but not reported */
38a03e6e 5566 sv_catpv(ERRSV, not_safe);
be2597df 5567 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
6d4c2119
CS		 5568 }
5569 }
68dc0745 5570 }
c07a80fd 5571 }
eb8433b7 5572 install_block:
beab0874
JT		 5573 if (!block)
5574 goto done;
a0d0e21e 5575
7766f137 5576 if (CvLVALUE(cv)) {
78f9721b
SM		 5577 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5578 mod(scalarseq(block), OP_LEAVESUBLV));
7e5d8ed2 5579 block->op_attached = 1;
7766f137
GS		 5580 }
5581 else {
09c2fd24
AE		 5582 /* This makes sub {}; work as expected. */
5583 if (block->op_type == OP_STUB) {
1496a290 5584 OP* const newblock = newSTATEOP(0, NULL, 0);
eb8433b7
NC		 5585#ifdef PERL_MAD
5586 op_getmad(block,newblock,'B');
5587#else
09c2fd24 5588 op_free(block);
eb8433b7
NC		 5589#endif
5590 block = newblock;
09c2fd24 5591 }
7e5d8ed2
DM		 5592 else
5593 block->op_attached = 1;
7766f137
GS		 5594 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5595 }
5596 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5597 OpREFCNT_set(CvROOT(cv), 1);
5598 CvSTART(cv) = LINKLIST(CvROOT(cv));
5599 CvROOT(cv)->op_next = 0;
a2efc822 5600 CALL_PEEP(CvSTART(cv));
7766f137
GS		 5601
5602 /* now that optimizer has done its work, adjust pad values */
54310121 5603
dd2155a4
DM		 5604 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5605
5606 if (CvCLONE(cv)) {
beab0874
JT		 5607 assert(!CvCONST(cv));
5608 if (ps && !*ps && op_const_sv(block, cv))
5609 CvCONST_on(cv);
a0d0e21e 5610 }
79072805 5611
83ee9e09 5612 if (name || aname) {
3280af22 5613 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
561b68a9 5614 SV * const sv = newSV(0);
c4420975 5615 SV * const tmpstr = sv_newmortal();
5c1737d1
NC		 5616 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5617 GV_ADDMULTI, SVt_PVHV);
44a8e56a 5618 HV *hv;
5619
ed094faf
GS		 5620 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5621 CopFILE(PL_curcop),
cc49e20b 5622 (long)PL_subline, (long)CopLINE(PL_curcop));
bd61b366 5623 gv_efullname3(tmpstr, gv, NULL);
04fe65b0
RGS		 5624 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
5625 SvCUR(tmpstr), sv, 0);
44a8e56a 5626 hv = GvHVn(db_postponed);
551405c4
AL		 5627 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5628 CV * const pcv = GvCV(db_postponed);
5629 if (pcv) {
5630 dSP;
5631 PUSHMARK(SP);
5632 XPUSHs(tmpstr);
5633 PUTBACK;
5634 call_sv((SV*)pcv, G_DISCARD);
5635 }
44a8e56a 5636 }
5637 }
79072805 5638
13765c85 5639 if (name && ! (PL_parser && PL_parser->error_count))
0cd10f52 5640 process_special_blocks(name, gv, cv);
33fb7a6e 5641 }
ed094faf 5642
33fb7a6e 5643 done:
53a7735b
DM		 5644 if (PL_parser)
5645 PL_parser->copline = NOLINE;
33fb7a6e
NC		 5646 LEAVE_SCOPE(floor);
5647 return cv;
5648}
ed094faf 5649
33fb7a6e
NC		 5650STATIC void
5651S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
5652 CV *const cv)
5653{
5654 const char *const colon = strrchr(fullname,':');
5655 const char *const name = colon ? colon + 1 : fullname;
5656
5657 if (*name == 'B') {
6952d67e 5658 if (strEQ(name, "BEGIN")) {
6867be6d 5659 const I32 oldscope = PL_scopestack_ix;
28757baa 5660 ENTER;
57843af0
GS		 5661 SAVECOPFILE(&PL_compiling);
5662 SAVECOPLINE(&PL_compiling);
28757baa 5663
28757baa 5664 DEBUG_x( dump_sub(gv) );
29a861e7 5665 Perl_av_create_and_push(aTHX_ &PL_beginav, (SV*)cv);
ea2f84a3 5666 GvCV(gv) = 0; /* cv has been hijacked */
3280af22 5667 call_list(oldscope, PL_beginav);
a6006777 5668
3280af22 5669 PL_curcop = &PL_compiling;
623e6609 5670 CopHINTS_set(&PL_compiling, PL_hints);
28757baa 5671 LEAVE;
5672 }
33fb7a6e
NC		 5673 else
5674 return;
5675 } else {
5676 if (*name == 'E') {
5677 if strEQ(name, "END") {
5678 DEBUG_x( dump_sub(gv) );
5679 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, (SV*)cv);
5680 } else
5681 return;
5682 } else if (*name == 'U') {
5683 if (strEQ(name, "UNITCHECK")) {
5684 /* It's never too late to run a unitcheck block */
5685 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, (SV*)cv);
5686 }
5687 else
5688 return;
5689 } else if (*name == 'C') {
5690 if (strEQ(name, "CHECK")) {
5691 if (PL_main_start && ckWARN(WARN_VOID))
5692 Perl_warner(aTHX_ packWARN(WARN_VOID),
5693 "Too late to run CHECK block");
5694 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, (SV*)cv);
5695 }
5696 else
5697 return;
5698 } else if (*name == 'I') {
5699 if (strEQ(name, "INIT")) {
5700 if (PL_main_start && ckWARN(WARN_VOID))
5701 Perl_warner(aTHX_ packWARN(WARN_VOID),
5702 "Too late to run INIT block");
5703 Perl_av_create_and_push(aTHX_ &PL_initav, (SV*)cv);
5704 }
5705 else
5706 return;
5707 } else
5708 return;
5709 DEBUG_x( dump_sub(gv) );
5710 GvCV(gv) = 0; /* cv has been hijacked */
79072805 5711 }
79072805
LW		 5712}
5713
954c1994
GS		 5714/*
5715=for apidoc newCONSTSUB
5716
5717Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5718eligible for inlining at compile-time.
5719
5720=cut
5721*/
5722
beab0874 5723CV *
e1ec3a88 5724Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5476c433 5725{
27da23d5 5726 dVAR;
beab0874 5727 CV* cv;
cbf82dd0
NC		 5728#ifdef USE_ITHREADS
5729 const char *const temp_p = CopFILE(PL_curcop);
07fcac01 5730 const STRLEN len = temp_p ? strlen(temp_p) : 0;
cbf82dd0
NC		 5731#else
5732 SV *const temp_sv = CopFILESV(PL_curcop);
5733 STRLEN len;
5734 const char *const temp_p = temp_sv ? SvPV_const(temp_sv, len) : NULL;
5735#endif
07fcac01 5736 char *const file = savepvn(temp_p, temp_p ? len : 0);
5476c433 5737
11faa288 5738 ENTER;
11faa288 5739
401667e9
DM		 5740 if (IN_PERL_RUNTIME) {
5741 /* at runtime, it's not safe to manipulate PL_curcop: it may be
5742 * an op shared between threads. Use a non-shared COP for our
5743 * dirty work */
5744 SAVEVPTR(PL_curcop);
5745 PL_curcop = &PL_compiling;
5746 }
f4dd75d9 5747 SAVECOPLINE(PL_curcop);
53a7735b 5748 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
f4dd75d9
GS		 5749
5750 SAVEHINTS();
3280af22 5751 PL_hints &= ~HINT_BLOCK_SCOPE;
11faa288
GS		 5752
5753 if (stash) {
5754 SAVESPTR(PL_curstash);
5755 SAVECOPSTASH(PL_curcop);
5756 PL_curstash = stash;
05ec9bb3 5757 CopSTASH_set(PL_curcop,stash);
11faa288 5758 }
5476c433 5759
cbf82dd0
NC		 5760 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
5761 and so doesn't get free()d. (It's expected to be from the C pre-
5762 processor __FILE__ directive). But we need a dynamically allocated one,
77004dee
NC		 5763 and we need it to get freed. */
5764 cv = newXS_flags(name, const_sv_xsub, file, "", XS_DYNAMIC_FILENAME);
beab0874
JT		 5765 CvXSUBANY(cv).any_ptr = sv;
5766 CvCONST_on(cv);
c3db7d92 5767 Safefree(file);
5476c433 5768
65e66c80 5769#ifdef USE_ITHREADS
02f28d44
MHM		 5770 if (stash)
5771 CopSTASH_free(PL_curcop);
65e66c80 5772#endif
11faa288 5773 LEAVE;
beab0874
JT		 5774
5775 return cv;
5476c433
JD		 5776}
5777
77004dee
NC		 5778CV *
5779Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
5780 const char *const filename, const char *const proto,
5781 U32 flags)
5782{
5783 CV *cv = newXS(name, subaddr, filename);
5784
5785 if (flags & XS_DYNAMIC_FILENAME) {
5786 /* We need to "make arrangements" (ie cheat) to ensure that the
5787 filename lasts as long as the PVCV we just created, but also doesn't
5788 leak */
5789 STRLEN filename_len = strlen(filename);
5790 STRLEN proto_and_file_len = filename_len;
5791 char *proto_and_file;
5792 STRLEN proto_len;
5793
5794 if (proto) {
5795 proto_len = strlen(proto);
5796 proto_and_file_len += proto_len;
5797
5798 Newx(proto_and_file, proto_and_file_len + 1, char);
5799 Copy(proto, proto_and_file, proto_len, char);
5800 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
5801 } else {
5802 proto_len = 0;
5803 proto_and_file = savepvn(filename, filename_len);
5804 }
5805
5806 /* This gets free()d. :-) */
5807 sv_usepvn_flags((SV*)cv, proto_and_file, proto_and_file_len,
5808 SV_HAS_TRAILING_NUL);
5809 if (proto) {
5810 /* This gives us the correct prototype, rather than one with the
5811 file name appended. */
5812 SvCUR_set(cv, proto_len);
5813 } else {
5814 SvPOK_off(cv);
5815 }
81a2b3b6 5816 CvFILE(cv) = proto_and_file + proto_len;
77004dee
NC		 5817 } else {
5818 sv_setpv((SV *)cv, proto);
5819 }
5820 return cv;
5821}
5822
954c1994
GS		 5823/*
5824=for apidoc U||newXS
5825
77004dee
NC		 5826Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
5827static storage, as it is used directly as CvFILE(), without a copy being made.
954c1994
GS		 5828
5829=cut
5830*/
5831
57d3b86d 5832CV *
bfed75c6 5833Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
a0d0e21e 5834{
97aff369 5835 dVAR;
666ea192
JH		 5836 GV * const gv = gv_fetchpv(name ? name :
5837 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5838 GV_ADDMULTI, SVt_PVCV);
79072805 5839 register CV *cv;
44a8e56a 5840
1ecdd9a8
HS		 5841 if (!subaddr)
5842 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
5843
601f1833 5844 if ((cv = (name ? GvCV(gv) : NULL))) {
44a8e56a 5845 if (GvCVGEN(gv)) {
5846 /* just a cached method */
5847 SvREFCNT_dec(cv);
601f1833 5848 cv = NULL;
44a8e56a 5849 }
5850 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5851 /* already defined (or promised) */
1df70142 5852 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
66a1b24b
AL		 5853 if (ckWARN(WARN_REDEFINE)) {
5854 GV * const gvcv = CvGV(cv);
5855 if (gvcv) {
5856 HV * const stash = GvSTASH(gvcv);
5857 if (stash) {
8b38226b
AL		 5858 const char *redefined_name = HvNAME_get(stash);
5859 if ( strEQ(redefined_name,"autouse") ) {
66a1b24b 5860 const line_t oldline = CopLINE(PL_curcop);
53a7735b
DM		 5861 if (PL_parser && PL_parser->copline != NOLINE)
5862 CopLINE_set(PL_curcop, PL_parser->copline);
66a1b24b 5863 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
666ea192
JH		 5864 CvCONST(cv) ? "Constant subroutine %s redefined"
5865 : "Subroutine %s redefined"
5866 ,name);
66a1b24b
AL		 5867 CopLINE_set(PL_curcop, oldline);
5868 }
5869 }
5870 }
a0d0e21e
LW		 5871 }
5872 SvREFCNT_dec(cv);
601f1833 5873 cv = NULL;
79072805 5874 }
79072805 5875 }
44a8e56a 5876
5877 if (cv) /* must reuse cv if autoloaded */
5878 cv_undef(cv);
a0d0e21e 5879 else {
b9f83d2f 5880 cv = (CV*)newSV_type(SVt_PVCV);
44a8e56a 5881 if (name) {
5882 GvCV(gv) = cv;
5883 GvCVGEN(gv) = 0;
e1a479c5 5884 mro_method_changed_in(GvSTASH(gv)); /* newXS */
44a8e56a 5885 }
a0d0e21e 5886 }
65c50114 5887 CvGV(cv) = gv;
b195d487 5888 (void)gv_fetchfile(filename);
dd374669 5889 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
57843af0 5890 an external constant string */
d04ba589 5891 CvISXSUB_on(cv);
a0d0e21e 5892 CvXSUB(cv) = subaddr;
44a8e56a 5893
33fb7a6e
NC		 5894 if (name)
5895 process_special_blocks(name, gv, cv);
8990e307 5896 else
a5f75d66 5897 CvANON_on(cv);
44a8e56a 5898
a0d0e21e 5899 return cv;
79072805
LW		 5900}
5901
eb8433b7
NC		 5902#ifdef PERL_MAD
5903OP *
5904#else
79072805 5905void
eb8433b7 5906#endif
864dbfa3 5907Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
79072805 5908{
97aff369 5909 dVAR;
79072805 5910 register CV *cv;
eb8433b7
NC		 5911#ifdef PERL_MAD
5912 OP* pegop = newOP(OP_NULL, 0);
5913#endif
79072805 5914
0bd48802 5915 GV * const gv = o
f776e3cd 5916 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
fafc274c 5917 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
0bd48802 5918
7fb37951
AMS		 5919#ifdef GV_UNIQUE_CHECK
5920 if (GvUNIQUE(gv)) {
666ea192 5921 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5bd07a3d
DM		 5922 }
5923#endif
a5f75d66 5924 GvMULTI_on(gv);
155aba94 5925 if ((cv = GvFORM(gv))) {
599cee73 5926 if (ckWARN(WARN_REDEFINE)) {
6867be6d 5927 const line_t oldline = CopLINE(PL_curcop);
53a7735b
DM		 5928 if (PL_parser && PL_parser->copline != NOLINE)
5929 CopLINE_set(PL_curcop, PL_parser->copline);
7a5fd60d 5930 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
666ea192 5931 o ? "Format %"SVf" redefined"
be2597df 5932 : "Format STDOUT redefined", SVfARG(cSVOPo->op_sv));
57843af0 5933 CopLINE_set(PL_curcop, oldline);
79072805 5934 }
8990e307 5935 SvREFCNT_dec(cv);
79072805 5936 }
3280af22 5937 cv = PL_compcv;
79072805 5938 GvFORM(gv) = cv;
65c50114 5939 CvGV(cv) = gv;
a636914a 5940 CvFILE_set_from_cop(cv, PL_curcop);
79072805 5941
a0d0e21e 5942
dd2155a4 5943 pad_tidy(padtidy_FORMAT);
79072805 5944 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
7934575e
GS		 5945 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5946 OpREFCNT_set(CvROOT(cv), 1);
79072805
LW		 5947 CvSTART(cv) = LINKLIST(CvROOT(cv));
5948 CvROOT(cv)->op_next = 0;
a2efc822 5949 CALL_PEEP(CvSTART(cv));
eb8433b7
NC		 5950#ifdef PERL_MAD
5951 op_getmad(o,pegop,'n');
5952 op_getmad_weak(block, pegop, 'b');
5953#else
11343788 5954 op_free(o);
eb8433b7 5955#endif
53a7735b
DM		 5956 if (PL_parser)
5957 PL_parser->copline = NOLINE;
8990e307 5958 LEAVE_SCOPE(floor);
eb8433b7
NC		 5959#ifdef PERL_MAD
5960 return pegop;
5961#endif
79072805
LW		 5962}
5963
5964OP *
864dbfa3 5965Perl_newANONLIST(pTHX_ OP *o)
79072805 5966{
78c72037 5967 return convert(OP_ANONLIST, OPf_SPECIAL, o);
79072805
LW		 5968}
5969
5970OP *
864dbfa3 5971Perl_newANONHASH(pTHX_ OP *o)
79072805 5972{
78c72037 5973 return convert(OP_ANONHASH, OPf_SPECIAL, o);
a0d0e21e
LW		 5974}
5975
5976OP *
864dbfa3 5977Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
a0d0e21e 5978{
5f66b61c 5979 return newANONATTRSUB(floor, proto, NULL, block);
09bef843
SB		 5980}
5981
5982OP *
5983Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5984{
a0d0e21e 5985 return newUNOP(OP_REFGEN, 0,
09bef843
SB		 5986 newSVOP(OP_ANONCODE, 0,
5987 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
79072805
LW		 5988}
5989
5990OP *
864dbfa3 5991Perl_oopsAV(pTHX_ OP *o)
79072805 5992{
27da23d5 5993 dVAR;
ed6116ce
LW		 5994 switch (o->op_type) {
5995 case OP_PADSV:
5996 o->op_type = OP_PADAV;
22c35a8c 5997 o->op_ppaddr = PL_ppaddr[OP_PADAV];
51e247a3 5998 return ref(o, OP_RV2AV);
b2ffa427 5999
ed6116ce 6000 case OP_RV2SV:
79072805 6001 o->op_type = OP_RV2AV;
22c35a8c 6002 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
79072805 6003 ref(o, OP_RV2AV);
ed6116ce
LW		 6004 break;
6005
6006 default:
0453d815 6007 if (ckWARN_d(WARN_INTERNAL))
9014280d 6008 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
ed6116ce
LW		 6009 break;
6010 }
79072805
LW		 6011 return o;
6012}
6013
6014OP *
864dbfa3 6015Perl_oopsHV(pTHX_ OP *o)
79072805 6016{
27da23d5 6017 dVAR;
ed6116ce
LW		 6018 switch (o->op_type) {
6019 case OP_PADSV:
6020 case OP_PADAV:
6021 o->op_type = OP_PADHV;
22c35a8c 6022 o->op_ppaddr = PL_ppaddr[OP_PADHV];
51e247a3 6023 return ref(o, OP_RV2HV);
ed6116ce
LW		 6024
6025 case OP_RV2SV:
6026 case OP_RV2AV:
79072805 6027 o->op_type = OP_RV2HV;
22c35a8c 6028 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
79072805 6029 ref(o, OP_RV2HV);
ed6116ce
LW		 6030 break;
6031
6032 default:
0453d815 6033 if (ckWARN_d(WARN_INTERNAL))
9014280d 6034 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
ed6116ce
LW		 6035 break;
6036 }
79072805
LW		 6037 return o;
6038}
6039
6040OP *
864dbfa3 6041Perl_newAVREF(pTHX_ OP *o)
79072805 6042{
27da23d5 6043 dVAR;
ed6116ce
LW		 6044 if (o->op_type == OP_PADANY) {
6045 o->op_type = OP_PADAV;
22c35a8c 6046 o->op_ppaddr = PL_ppaddr[OP_PADAV];
93a17b20 6047 return o;
ed6116ce 6048 }
a1063b2d 6049 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
9014280d
PM		 6050 && ckWARN(WARN_DEPRECATED)) {
6051 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
a1063b2d
RH		 6052 "Using an array as a reference is deprecated");
6053 }
79072805
LW		 6054 return newUNOP(OP_RV2AV, 0, scalar(o));
6055}
6056
6057OP *
864dbfa3 6058Perl_newGVREF(pTHX_ I32 type, OP *o)
79072805 6059{
82092f1d 6060 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
a0d0e21e 6061 return newUNOP(OP_NULL, 0, o);
748a9306 6062 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
79072805
LW		 6063}
6064
6065OP *
864dbfa3 6066Perl_newHVREF(pTHX_ OP *o)
79072805 6067{
27da23d5 6068 dVAR;
ed6116ce
LW		 6069 if (o->op_type == OP_PADANY) {
6070 o->op_type = OP_PADHV;
22c35a8c 6071 o->op_ppaddr = PL_ppaddr[OP_PADHV];
93a17b20 6072 return o;
ed6116ce 6073 }
a1063b2d 6074 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
9014280d
PM		 6075 && ckWARN(WARN_DEPRECATED)) {
6076 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
a1063b2d
RH		 6077 "Using a hash as a reference is deprecated");
6078 }
79072805
LW		 6079 return newUNOP(OP_RV2HV, 0, scalar(o));
6080}
6081
6082OP *
864dbfa3 6083Perl_newCVREF(pTHX_ I32 flags, OP *o)
79072805 6084{
c07a80fd 6085 return newUNOP(OP_RV2CV, flags, scalar(o));
79072805
LW		 6086}
6087
6088OP *
864dbfa3 6089Perl_newSVREF(pTHX_ OP *o)
79072805 6090{
27da23d5 6091 dVAR;
ed6116ce
LW		 6092 if (o->op_type == OP_PADANY) {
6093 o->op_type = OP_PADSV;
22c35a8c 6094 o->op_ppaddr = PL_ppaddr[OP_PADSV];
93a17b20 6095 return o;
ed6116ce 6096 }
79072805
LW		 6097 return newUNOP(OP_RV2SV, 0, scalar(o));
6098}
6099
61b743bb
DM		 6100/* Check routines. See the comments at the top of this file for details
6101 * on when these are called */
79072805
LW		 6102
6103OP *
cea2e8a9 6104Perl_ck_anoncode(pTHX_ OP *o)
5f05dabc 6105{
dd2155a4 6106 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
eb8433b7 6107 if (!PL_madskills)
1d866c12 6108 cSVOPo->op_sv = NULL;
5dc0d613 6109 return o;
5f05dabc 6110}
6111
6112OP *
cea2e8a9 6113Perl_ck_bitop(pTHX_ OP *o)
55497cff 6114{
97aff369 6115 dVAR;
276b2a0c
RGS		 6116#define OP_IS_NUMCOMPARE(op) \
6117 ((op) == OP_LT || (op) == OP_I_LT || \
6118 (op) == OP_GT || (op) == OP_I_GT || \
6119 (op) == OP_LE || (op) == OP_I_LE || \
6120 (op) == OP_GE || (op) == OP_I_GE || \
6121 (op) == OP_EQ || (op) == OP_I_EQ || \
6122 (op) == OP_NE || (op) == OP_I_NE || \
6123 (op) == OP_NCMP || (op) == OP_I_NCMP)
d5ec2987 6124 o->op_private = (U8)(PL_hints & HINT_INTEGER);
2b84528b
RGS		 6125 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6126 && (o->op_type == OP_BIT_OR
6127 || o->op_type == OP_BIT_AND
6128 || o->op_type == OP_BIT_XOR))
276b2a0c 6129 {
1df70142
AL		 6130 const OP * const left = cBINOPo->op_first;
6131 const OP * const right = left->op_sibling;
96a925ab
YST		 6132 if ((OP_IS_NUMCOMPARE(left->op_type) &&
6133 (left->op_flags & OPf_PARENS) == 0) ||
6134 (OP_IS_NUMCOMPARE(right->op_type) &&
6135 (right->op_flags & OPf_PARENS) == 0))
276b2a0c
RGS		 6136 if (ckWARN(WARN_PRECEDENCE))
6137 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6138 "Possible precedence problem on bitwise %c operator",
6139 o->op_type == OP_BIT_OR ? '|'
6140 : o->op_type == OP_BIT_AND ? '&' : '^'
6141 );
6142 }
5dc0d613 6143 return o;
55497cff 6144}
6145
6146OP *
cea2e8a9 6147Perl_ck_concat(pTHX_ OP *o)
79072805 6148{
0bd48802 6149 const OP * const kid = cUNOPo->op_first;
96a5add6 6150 PERL_UNUSED_CONTEXT;
df91b2c5
AE		 6151 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6152 !(kUNOP->op_first->op_flags & OPf_MOD))
0165acc7 6153 o->op_flags |= OPf_STACKED;
11343788 6154 return o;
79072805
LW		 6155}
6156
6157OP *
cea2e8a9 6158Perl_ck_spair(pTHX_ OP *o)
79072805 6159{
27da23d5 6160 dVAR;
11343788 6161 if (o->op_flags & OPf_KIDS) {
79072805 6162 OP* newop;
a0d0e21e 6163 OP* kid;
6867be6d 6164 const OPCODE type = o->op_type;
5dc0d613 6165 o = modkids(ck_fun(o), type);
11343788 6166 kid = cUNOPo->op_first;
a0d0e21e 6167 newop = kUNOP->op_first->op_sibling;
1496a290
AL		 6168 if (newop) {
6169 const OPCODE type = newop->op_type;
6170 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6171 type == OP_PADAV || type == OP_PADHV ||
6172 type == OP_RV2AV || type == OP_RV2HV)
6173 return o;
a0d0e21e 6174 }
eb8433b7
NC		 6175#ifdef PERL_MAD
6176 op_getmad(kUNOP->op_first,newop,'K');
6177#else
a0d0e21e 6178 op_free(kUNOP->op_first);
eb8433b7 6179#endif
a0d0e21e
LW		 6180 kUNOP->op_first = newop;
6181 }
22c35a8c 6182 o->op_ppaddr = PL_ppaddr[++o->op_type];
11343788 6183 return ck_fun(o);
a0d0e21e
LW		 6184}
6185
6186OP *
cea2e8a9 6187Perl_ck_delete(pTHX_ OP *o)
a0d0e21e 6188{
11343788 6189 o = ck_fun(o);
5dc0d613 6190 o->op_private = 0;
11343788 6191 if (o->op_flags & OPf_KIDS) {
551405c4 6192 OP * const kid = cUNOPo->op_first;
01020589
GS		 6193 switch (kid->op_type) {
6194 case OP_ASLICE:
6195 o->op_flags |= OPf_SPECIAL;
6196 /* FALL THROUGH */
6197 case OP_HSLICE:
5dc0d613 6198 o->op_private |= OPpSLICE;
01020589
GS		 6199 break;
6200 case OP_AELEM:
6201 o->op_flags |= OPf_SPECIAL;
6202 /* FALL THROUGH */
6203 case OP_HELEM:
6204 break;
6205 default:
6206 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
53e06cf0 6207 OP_DESC(o));
01020589 6208 }
93c66552 6209 op_null(kid);
79072805 6210 }
11343788 6211 return o;
79072805
LW		 6212}
6213
6214OP *
96e176bf
CL		 6215Perl_ck_die(pTHX_ OP *o)
6216{
6217#ifdef VMS
6218 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6219#endif
6220 return ck_fun(o);
6221}
6222
6223OP *
cea2e8a9 6224Perl_ck_eof(pTHX_ OP *o)
79072805 6225{
97aff369 6226 dVAR;
79072805 6227
11343788
MB		 6228 if (o->op_flags & OPf_KIDS) {
6229 if (cLISTOPo->op_first->op_type == OP_STUB) {
1d866c12
AL		 6230 OP * const newop
6231 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
eb8433b7
NC		 6232#ifdef PERL_MAD
6233 op_getmad(o,newop,'O');
6234#else
11343788 6235 op_free(o);
eb8433b7
NC		 6236#endif
6237 o = newop;
8990e307 6238 }
11343788 6239 return ck_fun(o);
79072805 6240 }
11343788 6241 return o;
79072805
LW		 6242}
6243
6244OP *
cea2e8a9 6245Perl_ck_eval(pTHX_ OP *o)
79072805 6246{
27da23d5 6247 dVAR;
3280af22 6248 PL_hints |= HINT_BLOCK_SCOPE;
11343788 6249 if (o->op_flags & OPf_KIDS) {
46c461b5 6250 SVOP * const kid = (SVOP*)cUNOPo->op_first;
79072805 6251
93a17b20 6252 if (!kid) {
11343788 6253 o->op_flags &= ~OPf_KIDS;
93c66552 6254 op_null(o);
79072805 6255 }
b14574b4 6256 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
79072805 6257 LOGOP *enter;
eb8433b7 6258#ifdef PERL_MAD
1d866c12 6259 OP* const oldo = o;
eb8433b7 6260#endif
79072805 6261
11343788 6262 cUNOPo->op_first = 0;
eb8433b7 6263#ifndef PERL_MAD
11343788 6264 op_free(o);
eb8433b7 6265#endif
79072805 6266
b7dc083c 6267 NewOp(1101, enter, 1, LOGOP);
79072805 6268 enter->op_type = OP_ENTERTRY;
22c35a8c 6269 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
79072805
LW		 6270 enter->op_private = 0;
6271
6272 /* establish postfix order */
6273 enter->op_next = (OP*)enter;
6274
11343788
MB		 6275 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6276 o->op_type = OP_LEAVETRY;
22c35a8c 6277 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
11343788 6278 enter->op_other = o;
eb8433b7 6279 op_getmad(oldo,o,'O');
11343788 6280 return o;
79072805 6281 }
b5c19bd7 6282 else {
473986ff 6283 scalar((OP*)kid);
b5c19bd7
DM		 6284 PL_cv_has_eval = 1;
6285 }
79072805
LW		 6286 }
6287 else {
eb8433b7 6288#ifdef PERL_MAD
1d866c12 6289 OP* const oldo = o;
eb8433b7 6290#else
11343788 6291 op_free(o);
eb8433b7 6292#endif
54b9620d 6293 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
eb8433b7 6294 op_getmad(oldo,o,'O');
79072805 6295 }
3280af22 6296 o->op_targ = (PADOFFSET)PL_hints;
7168684c 6297 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
0282be92
RGS		 6298 /* Store a copy of %^H that pp_entereval can pick up.
6299 OPf_SPECIAL flags the opcode as being for this purpose,
6300 so that it in turn will return a copy at every
6301 eval.*/
6302 OP *hhop = newSVOP(OP_CONST, OPf_SPECIAL,
5b9c0671 6303 (SV*)Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)));
0d863452
RH		 6304 cUNOPo->op_first->op_sibling = hhop;
6305 o->op_private |= OPpEVAL_HAS_HH;
6306 }
11343788 6307 return o;
79072805
LW		 6308}
6309
6310OP *
d98f61e7
GS		 6311Perl_ck_exit(pTHX_ OP *o)
6312{
6313#ifdef VMS
551405c4 6314 HV * const table = GvHV(PL_hintgv);
d98f61e7 6315 if (table) {
a4fc7abc 6316 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
d98f61e7
GS		 6317 if (svp && *svp && SvTRUE(*svp))
6318 o->op_private |= OPpEXIT_VMSISH;
6319 }
96e176bf 6320 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
d98f61e7
GS		 6321#endif
6322 return ck_fun(o);
6323}
6324
6325OP *
cea2e8a9 6326Perl_ck_exec(pTHX_ OP *o)
79072805 6327{
11343788 6328 if (o->op_flags & OPf_STACKED) {
6867be6d 6329 OP *kid;
11343788
MB		 6330 o = ck_fun(o);
6331 kid = cUNOPo->op_first->op_sibling;
8990e307 6332 if (kid->op_type == OP_RV2GV)
93c66552 6333 op_null(kid);
79072805 6334 }
463ee0b2 6335 else
11343788
MB		 6336 o = listkids(o);
6337 return o;
79072805
LW		 6338}
6339
6340OP *
cea2e8a9 6341Perl_ck_exists(pTHX_ OP *o)
5f05dabc 6342{
97aff369 6343 dVAR;
5196be3e
MB		 6344 o = ck_fun(o);
6345 if (o->op_flags & OPf_KIDS) {
46c461b5 6346 OP * const kid = cUNOPo->op_first;
afebc493
GS		 6347 if (kid->op_type == OP_ENTERSUB) {
6348 (void) ref(kid, o->op_type);
13765c85
DM		 6349 if (kid->op_type != OP_RV2CV
6350 && !(PL_parser && PL_parser->error_count))
afebc493 6351 Perl_croak(aTHX_ "%s argument is not a subroutine name",
53e06cf0 6352 OP_DESC(o));
afebc493
GS		 6353 o->op_private |= OPpEXISTS_SUB;
6354 }
6355 else if (kid->op_type == OP_AELEM)
01020589
GS		 6356 o->op_flags |= OPf_SPECIAL;
6357 else if (kid->op_type != OP_HELEM)
6358 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
53e06cf0 6359 OP_DESC(o));
93c66552 6360 op_null(kid);
5f05dabc 6361 }
5196be3e 6362 return o;
5f05dabc 6363}
6364
79072805 6365OP *
cea2e8a9 6366Perl_ck_rvconst(pTHX_ register OP *o)
79072805 6367{
27da23d5 6368 dVAR;
0bd48802 6369 SVOP * const kid = (SVOP*)cUNOPo->op_first;
85e6fe83 6370
3280af22 6371 o->op_private |= (PL_hints & HINT_STRICT_REFS);
e26df76a
NC		 6372 if (o->op_type == OP_RV2CV)
6373 o->op_private &= ~1;
6374
79072805 6375 if (kid->op_type == OP_CONST) {
44a8e56a 6376 int iscv;
6377 GV *gv;
504618e9 6378 SV * const kidsv = kid->op_sv;
44a8e56a 6379
779c5bc9
GS		 6380 /* Is it a constant from cv_const_sv()? */
6381 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
0bd48802 6382 SV * const rsv = SvRV(kidsv);
42d0e0b7 6383 const svtype type = SvTYPE(rsv);
bd61b366 6384 const char *badtype = NULL;
779c5bc9
GS		 6385
6386 switch (o->op_type) {
6387 case OP_RV2SV:
42d0e0b7 6388 if (type > SVt_PVMG)
779c5bc9
GS		 6389 badtype = "a SCALAR";
6390 break;
6391 case OP_RV2AV:
42d0e0b7 6392 if (type != SVt_PVAV)
779c5bc9
GS		 6393 badtype = "an ARRAY";
6394 break;
6395 case OP_RV2HV:
42d0e0b7 6396 if (type != SVt_PVHV)
779c5bc9 6397 badtype = "a HASH";
779c5bc9
GS		 6398 break;
6399 case OP_RV2CV:
42d0e0b7 6400 if (type != SVt_PVCV)
779c5bc9
GS		 6401 badtype = "a CODE";
6402 break;
6403 }
6404 if (badtype)
cea2e8a9 6405 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
779c5bc9
GS		 6406 return o;
6407 }
ce10b5d1
RGS		 6408 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6409 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6410 /* If this is an access to a stash, disable "strict refs", because
6411 * stashes aren't auto-vivified at compile-time (unless we store
6412 * symbols in them), and we don't want to produce a run-time
6413 * stricture error when auto-vivifying the stash. */
6414 const char *s = SvPV_nolen(kidsv);
6415 const STRLEN l = SvCUR(kidsv);
6416 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6417 o->op_private &= ~HINT_STRICT_REFS;
6418 }
6419 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5f66b61c 6420 const char *badthing;
5dc0d613 6421 switch (o->op_type) {
44a8e56a 6422 case OP_RV2SV:
6423 badthing = "a SCALAR";
6424 break;
6425 case OP_RV2AV:
6426 badthing = "an ARRAY";
6427 break;
6428 case OP_RV2HV:
6429 badthing = "a HASH";
6430 break;
5f66b61c
AL		 6431 default:
6432 badthing = NULL;
6433 break;
44a8e56a 6434 }
6435 if (badthing)
1c846c1f 6436 Perl_croak(aTHX_
95b63a38 6437 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
be2597df 6438 SVfARG(kidsv), badthing);
44a8e56a 6439 }
93233ece
CS		 6440 /*
6441 * This is a little tricky. We only want to add the symbol if we
6442 * didn't add it in the lexer. Otherwise we get duplicate strict
6443 * warnings. But if we didn't add it in the lexer, we must at
6444 * least pretend like we wanted to add it even if it existed before,
6445 * or we get possible typo warnings. OPpCONST_ENTERED says
6446 * whether the lexer already added THIS instance of this symbol.
6447 */
5196be3e 6448 iscv = (o->op_type == OP_RV2CV) * 2;
93233ece 6449 do {
7a5fd60d 6450 gv = gv_fetchsv(kidsv,
748a9306 6451 iscv | !(kid->op_private & OPpCONST_ENTERED),
a0d0e21e
LW		 6452 iscv
6453 ? SVt_PVCV
11343788 6454 : o->op_type == OP_RV2SV
a0d0e21e 6455 ? SVt_PV
11343788 6456 : o->op_type == OP_RV2AV
a0d0e21e 6457 ? SVt_PVAV
11343788 6458 : o->op_type == OP_RV2HV
a0d0e21e
LW		 6459 ? SVt_PVHV
6460 : SVt_PVGV);
93233ece
CS		 6461 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6462 if (gv) {
6463 kid->op_type = OP_GV;
6464 SvREFCNT_dec(kid->op_sv);
350de78d 6465#ifdef USE_ITHREADS
638eceb6 6466 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
350de78d 6467 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
dd2155a4 6468 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
743e66e6 6469 GvIN_PAD_on(gv);
b37c2d43 6470 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv));
350de78d 6471#else
b37c2d43 6472 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
350de78d 6473#endif
23f1ca44 6474 kid->op_private = 0;
76cd736e 6475 kid->op_ppaddr = PL_ppaddr[OP_GV];
a0d0e21e 6476 }
79072805 6477 }
11343788 6478 return o;
79072805
LW		 6479}
6480
6481OP *
cea2e8a9 6482Perl_ck_ftst(pTHX_ OP *o)
79072805 6483{
27da23d5 6484 dVAR;
6867be6d 6485 const I32 type = o->op_type;
79072805 6486
d0dca557 6487 if (o->op_flags & OPf_REF) {
6f207bd3 6488 NOOP;
d0dca557
JD		 6489 }
6490 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
551405c4 6491 SVOP * const kid = (SVOP*)cUNOPo->op_first;
1496a290 6492 const OPCODE kidtype = kid->op_type;
79072805 6493
1496a290 6494 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
551405c4 6495 OP * const newop = newGVOP(type, OPf_REF,
f776e3cd 6496 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
eb8433b7
NC		 6497#ifdef PERL_MAD
6498 op_getmad(o,newop,'O');
6499#else
11343788 6500 op_free(o);
eb8433b7 6501#endif
1d866c12 6502 return newop;
79072805 6503 }
1d866c12 6504 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o))
1af34c76 6505 o->op_private |= OPpFT_ACCESS;
1496a290
AL		 6506 if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6507 && kidtype != OP_STAT && kidtype != OP_LSTAT)
fbb0b3b3 6508 o->op_private |= OPpFT_STACKED;
79072805
LW		 6509 }
6510 else {
eb8433b7 6511#ifdef PERL_MAD
1d866c12 6512 OP* const oldo = o;
eb8433b7 6513#else
11343788 6514 op_free(o);
eb8433b7 6515#endif
79072805 6516 if (type == OP_FTTTY)
8fde6460 6517 o = newGVOP(type, OPf_REF, PL_stdingv);
79072805 6518 else
d0dca557 6519 o = newUNOP(type, 0, newDEFSVOP());
eb8433b7 6520 op_getmad(oldo,o,'O');
79072805 6521 }
11343788 6522 return o;
79072805
LW		 6523}
6524
6525OP *
cea2e8a9 6526Perl_ck_fun(pTHX_ OP *o)
79072805 6527{
97aff369 6528 dVAR;
6867be6d 6529 const int type = o->op_type;
22c35a8c 6530 register I32 oa = PL_opargs[type] >> OASHIFT;
aeea060c 6531
11343788 6532 if (o->op_flags & OPf_STACKED) {
79072805
LW		 6533 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6534 oa &= ~OA_OPTIONAL;
6535 else
11343788 6536 return no_fh_allowed(o);
79072805
LW		 6537 }
6538
11343788 6539 if (o->op_flags & OPf_KIDS) {
6867be6d
AL		 6540 OP **tokid = &cLISTOPo->op_first;
6541 register OP *kid = cLISTOPo->op_first;
6542 OP *sibl;
6543 I32 numargs = 0;
6544
8990e307 6545 if (kid->op_type == OP_PUSHMARK ||
155aba94 6546 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
8990e307 6547 {
79072805
LW		 6548 tokid = &kid->op_sibling;
6549 kid = kid->op_sibling;
6550 }
22c35a8c 6551 if (!kid && PL_opargs[type] & OA_DEFGV)
54b9620d 6552 *tokid = kid = newDEFSVOP();
79072805
LW		 6553
6554 while (oa && kid) {
6555 numargs++;
6556 sibl = kid->op_sibling;
eb8433b7
NC		 6557#ifdef PERL_MAD
6558 if (!sibl && kid->op_type == OP_STUB) {
6559 numargs--;
6560 break;
6561 }
6562#endif
79072805
LW		 6563 switch (oa & 7) {
6564 case OA_SCALAR:
62c18ce2
GS		 6565 /* list seen where single (scalar) arg expected? */
6566 if (numargs == 1 && !(oa >> 4)
6567 && kid->op_type == OP_LIST && type != OP_SCALAR)
6568 {
6569 return too_many_arguments(o,PL_op_desc[type]);
6570 }
79072805
LW		 6571 scalar(kid);
6572 break;
6573 case OA_LIST:
6574 if (oa < 16) {
6575 kid = 0;
6576 continue;
6577 }
6578 else
6579 list(kid);
6580 break;
6581 case OA_AVREF:
936edb8b 6582 if ((type == OP_PUSH || type == OP_UNSHIFT)
f87c3213 6583 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
9014280d 6584 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
de4864e4 6585 "Useless use of %s with no values",
936edb8b 6586 PL_op_desc[type]);
b2ffa427 6587
79072805 6588 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 6589 (kid->op_private & OPpCONST_BARE))
6590 {
551405c4 6591 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
f776e3cd 6592 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
12bcd1a6
PM		 6593 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6594 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7a5fd60d 6595 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
be2597df 6596 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
eb8433b7
NC		 6597#ifdef PERL_MAD
6598 op_getmad(kid,newop,'K');
6599#else
79072805 6600 op_free(kid);
eb8433b7 6601#endif
79072805
LW		 6602 kid = newop;
6603 kid->op_sibling = sibl;
6604 *tokid = kid;
6605 }
8990e307 6606 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
35cd451c 6607 bad_type(numargs, "array", PL_op_desc[type], kid);
a0d0e21e 6608 mod(kid, type);
79072805
LW		 6609 break;
6610 case OA_HVREF:
6611 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 6612 (kid->op_private & OPpCONST_BARE))
6613 {
551405c4 6614 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
f776e3cd 6615 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
12bcd1a6
PM		 6616 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6617 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7a5fd60d 6618 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
be2597df 6619 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
eb8433b7
NC		 6620#ifdef PERL_MAD
6621 op_getmad(kid,newop,'K');
6622#else
79072805 6623 op_free(kid);
eb8433b7 6624#endif
79072805
LW		 6625 kid = newop;
6626 kid->op_sibling = sibl;
6627 *tokid = kid;
6628 }
8990e307 6629 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
35cd451c 6630 bad_type(numargs, "hash", PL_op_desc[type], kid);
a0d0e21e 6631 mod(kid, type);
79072805
LW		 6632 break;
6633 case OA_CVREF:
6634 {
551405c4 6635 OP * const newop = newUNOP(OP_NULL, 0, kid);
79072805
LW		 6636 kid->op_sibling = 0;
6637 linklist(kid);
6638 newop->op_next = newop;
6639 kid = newop;
6640 kid->op_sibling = sibl;
6641 *tokid = kid;
6642 }
6643 break;
6644 case OA_FILEREF:
c340be78 6645 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
79072805 6646 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 6647 (kid->op_private & OPpCONST_BARE))
6648 {
0bd48802 6649 OP * const newop = newGVOP(OP_GV, 0,
f776e3cd 6650 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
afbdacea 6651 if (!(o->op_private & 1) && /* if not unop */
8a996ce8 6652 kid == cLISTOPo->op_last)
364daeac 6653 cLISTOPo->op_last = newop;
eb8433b7
NC		 6654#ifdef PERL_MAD
6655 op_getmad(kid,newop,'K');
6656#else
79072805 6657 op_free(kid);
eb8433b7 6658#endif
79072805
LW		 6659 kid = newop;
6660 }
1ea32a52
GS		 6661 else if (kid->op_type == OP_READLINE) {
6662 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
53e06cf0 6663 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
1ea32a52 6664 }
79072805 6665 else {
35cd451c 6666 I32 flags = OPf_SPECIAL;
a6c40364 6667 I32 priv = 0;
2c8ac474
GS		 6668 PADOFFSET targ = 0;
6669
35cd451c 6670 /* is this op a FH constructor? */
853846ea 6671 if (is_handle_constructor(o,numargs)) {
bd61b366 6672 const char *name = NULL;
dd2155a4 6673 STRLEN len = 0;
2c8ac474
GS		 6674
6675 flags = 0;
6676 /* Set a flag to tell rv2gv to vivify
853846ea
NIS		 6677 * need to "prove" flag does not mean something
6678 * else already - NI-S 1999/05/07
2c8ac474
GS		 6679 */
6680 priv = OPpDEREF;
6681 if (kid->op_type == OP_PADSV) {
f8503592
NC		 6682 SV *const namesv
6683 = PAD_COMPNAME_SV(kid->op_targ);
6684 name = SvPV_const(namesv, len);
2c8ac474
GS		 6685 }
6686 else if (kid->op_type == OP_RV2SV
6687 && kUNOP->op_first->op_type == OP_GV)
6688 {
0bd48802 6689 GV * const gv = cGVOPx_gv(kUNOP->op_first);
2c8ac474
GS		 6690 name = GvNAME(gv);
6691 len = GvNAMELEN(gv);
6692 }
afd1915d
GS		 6693 else if (kid->op_type == OP_AELEM
6694 || kid->op_type == OP_HELEM)
6695 {
735fec84 6696 OP *firstop;
551405c4 6697 OP *op = ((BINOP*)kid)->op_first;
a4fc7abc 6698 name = NULL;
551405c4 6699 if (op) {
a0714e2c 6700 SV *tmpstr = NULL;
551405c4 6701 const char * const a =
666ea192
JH		 6702 kid->op_type == OP_AELEM ?
6703 "[]" : "{}";
0c4b0a3f
JH		 6704 if (((op->op_type == OP_RV2AV) ||
6705 (op->op_type == OP_RV2HV)) &&
735fec84
RGS		 6706 (firstop = ((UNOP*)op)->op_first) &&
6707 (firstop->op_type == OP_GV)) {
0c4b0a3f 6708 /* packagevar $a[] or $h{} */
735fec84 6709 GV * const gv = cGVOPx_gv(firstop);
0c4b0a3f
JH		 6710 if (gv)
6711 tmpstr =
6712 Perl_newSVpvf(aTHX_
6713 "%s%c...%c",
6714 GvNAME(gv),
6715 a[0], a[1]);
6716 }
6717 else if (op->op_type == OP_PADAV
6718 || op->op_type == OP_PADHV) {
6719 /* lexicalvar $a[] or $h{} */
551405c4 6720 const char * const padname =
0c4b0a3f
JH		 6721 PAD_COMPNAME_PV(op->op_targ);
6722 if (padname)
6723 tmpstr =
6724 Perl_newSVpvf(aTHX_
6725 "%s%c...%c",
6726 padname + 1,
6727 a[0], a[1]);
0c4b0a3f
JH		 6728 }
6729 if (tmpstr) {
93524f2b 6730 name = SvPV_const(tmpstr, len);
0c4b0a3f
JH		 6731 sv_2mortal(tmpstr);
6732 }
6733 }
6734 if (!name) {
6735 name = "__ANONIO__";
6736 len = 10;
6737 }
6738 mod(kid, type);
afd1915d 6739 }
2c8ac474
GS		 6740 if (name) {
6741 SV *namesv;
6742 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
dd2155a4 6743 namesv = PAD_SVl(targ);
862a34c6 6744 SvUPGRADE(namesv, SVt_PV);
2c8ac474
GS		 6745 if (*name != '$')
6746 sv_setpvn(namesv, "$", 1);
6747 sv_catpvn(namesv, name, len);
6748 }
853846ea 6749 }
79072805 6750 kid->op_sibling = 0;
35cd451c 6751 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
2c8ac474
GS		 6752 kid->op_targ = targ;
6753 kid->op_private |= priv;
79072805
LW		 6754 }
6755 kid->op_sibling = sibl;
6756 *tokid = kid;
6757 }
6758 scalar(kid);
6759 break;
6760 case OA_SCALARREF:
a0d0e21e 6761 mod(scalar(kid), type);
79072805
LW		 6762 break;
6763 }
6764 oa >>= 4;
6765 tokid = &kid->op_sibling;
6766 kid = kid->op_sibling;
6767 }
eb8433b7
NC		 6768#ifdef PERL_MAD
6769 if (kid && kid->op_type != OP_STUB)
6770 return too_many_arguments(o,OP_DESC(o));
6771 o->op_private |= numargs;
6772#else
6773 /* FIXME - should the numargs move as for the PERL_MAD case? */
11343788 6774 o->op_private |= numargs;
79072805 6775 if (kid)
53e06cf0 6776 return too_many_arguments(o,OP_DESC(o));
eb8433b7 6777#endif
11343788 6778 listkids(o);
79072805 6779 }
22c35a8c 6780 else if (PL_opargs[type] & OA_DEFGV) {
c56915e3 6781#ifdef PERL_MAD
c7fe699d 6782 OP *newop = newUNOP(type, 0, newDEFSVOP());
c56915e3 6783 op_getmad(o,newop,'O');
c7fe699d 6784 return newop;
c56915e3 6785#else
c7fe699d 6786 /* Ordering of these two is important to keep f_map.t passing. */
11343788 6787 op_free(o);
c7fe699d 6788 return newUNOP(type, 0, newDEFSVOP());
c56915e3 6789#endif
a0d0e21e
LW		 6790 }
6791
79072805
LW		 6792 if (oa) {
6793 while (oa & OA_OPTIONAL)
6794 oa >>= 4;
6795 if (oa && oa != OA_LIST)
53e06cf0 6796 return too_few_arguments(o,OP_DESC(o));
79072805 6797 }
11343788 6798 return o;
79072805
LW		 6799}
6800
6801OP *
cea2e8a9 6802Perl_ck_glob(pTHX_ OP *o)
79072805 6803{
27da23d5 6804 dVAR;
fb73857a 6805 GV *gv;
6806
649da076 6807 o = ck_fun(o);
1f2bfc8a 6808 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
54b9620d 6809 append_elem(OP_GLOB, o, newDEFSVOP());
fb73857a 6810
fafc274c 6811 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
b9f751c0
GS		 6812 && GvCVu(gv) && GvIMPORTED_CV(gv)))
6813 {
5c1737d1 6814 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
b9f751c0 6815 }
b1cb66bf 6816
52bb0670 6817#if !defined(PERL_EXTERNAL_GLOB)
72b16652 6818 /* XXX this can be tightened up and made more failsafe. */
f444d496 6819 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7d3fb230 6820 GV *glob_gv;
72b16652 6821 ENTER;
00ca71c1 6822 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
a0714e2c 6823 newSVpvs("File::Glob"), NULL, NULL, NULL);
5c1737d1
NC		 6824 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6825 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
7d3fb230 6826 GvCV(gv) = GvCV(glob_gv);
b37c2d43 6827 SvREFCNT_inc_void((SV*)GvCV(gv));
7d3fb230 6828 GvIMPORTED_CV_on(gv);
72b16652
GS		 6829 LEAVE;
6830 }
52bb0670 6831#endif /* PERL_EXTERNAL_GLOB */
72b16652 6832
b9f751c0 6833 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5196be3e 6834 append_elem(OP_GLOB, o,
80252599 6835 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
1f2bfc8a 6836 o->op_type = OP_LIST;
22c35a8c 6837 o->op_ppaddr = PL_ppaddr[OP_LIST];
1f2bfc8a 6838 cLISTOPo->op_first->op_type = OP_PUSHMARK;
22c35a8c 6839 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
ad33f57d 6840 cLISTOPo->op_first->op_targ = 0;
1f2bfc8a 6841 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
aeea060c 6842 append_elem(OP_LIST, o,
1f2bfc8a
MB		 6843 scalar(newUNOP(OP_RV2CV, 0,
6844 newGVOP(OP_GV, 0, gv)))));
d58bf5aa
MB		 6845 o = newUNOP(OP_NULL, 0, ck_subr(o));
6846 o->op_targ = OP_GLOB; /* hint at what it used to be */
6847 return o;
b1cb66bf 6848 }
6849 gv = newGVgen("main");
a0d0e21e 6850 gv_IOadd(gv);
11343788
MB		 6851 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6852 scalarkids(o);
649da076 6853 return o;
79072805
LW		 6854}
6855
6856OP *
cea2e8a9 6857Perl_ck_grep(pTHX_ OP *o)
79072805 6858{
27da23d5 6859 dVAR;
03ca120d 6860 LOGOP *gwop = NULL;
79072805 6861 OP *kid;
6867be6d 6862 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
9f7d9405 6863 PADOFFSET offset;
79072805 6864
22c35a8c 6865 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
13765c85 6866 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
aeea060c 6867
11343788 6868 if (o->op_flags & OPf_STACKED) {
a0d0e21e 6869 OP* k;
11343788
MB		 6870 o = ck_sort(o);
6871 kid = cLISTOPo->op_first->op_sibling;
d09ad856
BS		 6872 if (!cUNOPx(kid)->op_next)
6873 Perl_croak(aTHX_ "panic: ck_grep");
e3c9a8b9 6874 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
a0d0e21e
LW		 6875 kid = k;
6876 }
03ca120d 6877 NewOp(1101, gwop, 1, LOGOP);
a0d0e21e 6878 kid->op_next = (OP*)gwop;
11343788 6879 o->op_flags &= ~OPf_STACKED;
93a17b20 6880 }
11343788 6881 kid = cLISTOPo->op_first->op_sibling;
a0d0e21e
LW		 6882 if (type == OP_MAPWHILE)
6883 list(kid);
6884 else
6885 scalar(kid);
11343788 6886 o = ck_fun(o);
13765c85 6887 if (PL_parser && PL_parser->error_count)
11343788 6888 return o;
aeea060c 6889 kid = cLISTOPo->op_first->op_sibling;
79072805 6890 if (kid->op_type != OP_NULL)
cea2e8a9 6891 Perl_croak(aTHX_ "panic: ck_grep");
79072805
LW		 6892 kid = kUNOP->op_first;
6893
03ca120d
MHM		 6894 if (!gwop)
6895 NewOp(1101, gwop, 1, LOGOP);
a0d0e21e 6896 gwop->op_type = type;
22c35a8c 6897 gwop->op_ppaddr = PL_ppaddr[type];
11343788 6898 gwop->op_first = listkids(o);
79072805 6899 gwop->op_flags |= OPf_KIDS;
79072805 6900 gwop->op_other = LINKLIST(kid);
79072805 6901 kid->op_next = (OP*)gwop;
59f00321 6902 offset = pad_findmy("$_");
00b1698f 6903 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
59f00321
RGS		 6904 o->op_private = gwop->op_private = 0;
6905 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6906 }
6907 else {
6908 o->op_private = gwop->op_private = OPpGREP_LEX;
6909 gwop->op_targ = o->op_targ = offset;
6910 }
79072805 6911
11343788 6912 kid = cLISTOPo->op_first->op_sibling;
a0d0e21e 6913 if (!kid || !kid->op_sibling)
53e06cf0 6914 return too_few_arguments(o,OP_DESC(o));
a0d0e21e
LW		 6915 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6916 mod(kid, OP_GREPSTART);
6917
79072805
LW		 6918 return (OP*)gwop;
6919}
6920
6921OP *
cea2e8a9 6922Perl_ck_index(pTHX_ OP *o)
79072805 6923{
11343788
MB		 6924 if (o->op_flags & OPf_KIDS) {
6925 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
0b71040e
LW		 6926 if (kid)
6927 kid = kid->op_sibling; /* get past "big" */
79072805 6928 if (kid && kid->op_type == OP_CONST)
2779dcf1 6929 fbm_compile(((SVOP*)kid)->op_sv, 0);
79072805 6930 }
11343788 6931 return ck_fun(o);
79072805
LW		 6932}
6933
6934OP *
cea2e8a9 6935Perl_ck_lengthconst(pTHX_ OP *o)
79072805
LW		 6936{
6937 /* XXX length optimization goes here */
11343788 6938 return ck_fun(o);
79072805
LW		 6939}
6940
6941OP *
cea2e8a9 6942Perl_ck_lfun(pTHX_ OP *o)
79072805 6943{
6867be6d 6944 const OPCODE type = o->op_type;
5dc0d613 6945 return modkids(ck_fun(o), type);
79072805
LW		 6946}
6947
6948OP *
cea2e8a9 6949Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
69794302 6950{
12bcd1a6 6951 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
d0334bed
GS		 6952 switch (cUNOPo->op_first->op_type) {
6953 case OP_RV2AV:
a8739d98
JH		 6954 /* This is needed for
6955 if (defined %stash::)
6956 to work. Do not break Tk.
6957 */
1c846c1f 6958 break; /* Globals via GV can be undef */
d0334bed
GS		 6959 case OP_PADAV:
6960 case OP_AASSIGN: /* Is this a good idea? */
12bcd1a6 6961 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
f10b0346 6962 "defined(@array) is deprecated");
12bcd1a6 6963 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
cc507455 6964 "\t(Maybe you should just omit the defined()?)\n");
69794302 6965 break;
d0334bed 6966 case OP_RV2HV:
a8739d98
JH		 6967 /* This is needed for
6968 if (defined %stash::)
6969 to work. Do not break Tk.
6970 */
1c846c1f 6971 break; /* Globals via GV can be undef */
d0334bed 6972 case OP_PADHV:
12bcd1a6 6973 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
894356b3 6974 "defined(%%hash) is deprecated");
12bcd1a6 6975 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
cc507455 6976 "\t(Maybe you should just omit the defined()?)\n");
d0334bed
GS		 6977 break;
6978 default:
6979 /* no warning */
6980 break;
6981 }
69794302
MJD		 6982 }
6983 return ck_rfun(o);
6984}
6985
6986OP *
e4b7ebf3
RGS		 6987Perl_ck_readline(pTHX_ OP *o)
6988{
6989 if (!(o->op_flags & OPf_KIDS)) {
6990 OP * const newop
6991 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
6992#ifdef PERL_MAD
6993 op_getmad(o,newop,'O');
6994#else
6995 op_free(o);
6996#endif
6997 return newop;
6998 }
6999 return o;
7000}
7001
7002OP *
cea2e8a9 7003Perl_ck_rfun(pTHX_ OP *o)
8990e307 7004{
6867be6d 7005 const OPCODE type = o->op_type;
5dc0d613 7006 return refkids(ck_fun(o), type);
8990e307
LW		 7007}
7008
7009OP *
cea2e8a9 7010Perl_ck_listiob(pTHX_ OP *o)
79072805
LW		 7011{
7012 register OP *kid;
aeea060c 7013
11343788 7014 kid = cLISTOPo->op_first;
79072805 7015 if (!kid) {
11343788
MB		 7016 o = force_list(o);
7017 kid = cLISTOPo->op_first;
79072805
LW		 7018 }
7019 if (kid->op_type == OP_PUSHMARK)
7020 kid = kid->op_sibling;
11343788 7021 if (kid && o->op_flags & OPf_STACKED)
79072805
LW		 7022 kid = kid->op_sibling;
7023 else if (kid && !kid->op_sibling) { /* print HANDLE; */
7024 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
11343788 7025 o->op_flags |= OPf_STACKED; /* make it a filehandle */
748a9306 7026 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
11343788
MB		 7027 cLISTOPo->op_first->op_sibling = kid;
7028 cLISTOPo->op_last = kid;
79072805
LW		 7029 kid = kid->op_sibling;
7030 }
7031 }
b2ffa427 7032
79072805 7033 if (!kid)
54b9620d 7034 append_elem(o->op_type, o, newDEFSVOP());
79072805 7035
2de3dbcc 7036 return listkids(o);
bbce6d69 7037}
7038
7039OP *
0d863452
RH		 7040Perl_ck_smartmatch(pTHX_ OP *o)
7041{
97aff369 7042 dVAR;
0d863452
RH		 7043 if (0 == (o->op_flags & OPf_SPECIAL)) {
7044 OP *first = cBINOPo->op_first;
7045 OP *second = first->op_sibling;
7046
7047 /* Implicitly take a reference to an array or hash */
5f66b61c 7048 first->op_sibling = NULL;
0d863452
RH		 7049 first = cBINOPo->op_first = ref_array_or_hash(first);
7050 second = first->op_sibling = ref_array_or_hash(second);
7051
7052 /* Implicitly take a reference to a regular expression */
7053 if (first->op_type == OP_MATCH) {
7054 first->op_type = OP_QR;
7055 first->op_ppaddr = PL_ppaddr[OP_QR];
7056 }
7057 if (second->op_type == OP_MATCH) {
7058 second->op_type = OP_QR;
7059 second->op_ppaddr = PL_ppaddr[OP_QR];
7060 }
7061 }
7062
7063 return o;
7064}
7065
7066
7067OP *
b162f9ea
IZ		 7068Perl_ck_sassign(pTHX_ OP *o)
7069{
3088bf26 7070 dVAR;
1496a290 7071 OP * const kid = cLISTOPo->op_first;
b162f9ea
IZ		 7072 /* has a disposable target? */
7073 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6b66af17
GS		 7074 && !(kid->op_flags & OPf_STACKED)
7075 /* Cannot steal the second time! */
1b438339
GG		 7076 && !(kid->op_private & OPpTARGET_MY)
7077 /* Keep the full thing for madskills */
7078 && !PL_madskills
7079 )
b162f9ea 7080 {
551405c4 7081 OP * const kkid = kid->op_sibling;
b162f9ea
IZ		 7082
7083 /* Can just relocate the target. */
2c2d71f5
JH		 7084 if (kkid && kkid->op_type == OP_PADSV
7085 && !(kkid->op_private & OPpLVAL_INTRO))
7086 {
b162f9ea 7087 kid->op_targ = kkid->op_targ;
743e66e6 7088 kkid->op_targ = 0;
b162f9ea
IZ		 7089 /* Now we do not need PADSV and SASSIGN. */
7090 kid->op_sibling = o->op_sibling; /* NULL */
7091 cLISTOPo->op_first = NULL;
7092 op_free(o);
7093 op_free(kkid);
7094 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
7095 return kid;
7096 }
7097 }
c5917253
NC		 7098 if (kid->op_sibling) {
7099 OP *kkid = kid->op_sibling;
7100 if (kkid->op_type == OP_PADSV
7101 && (kkid->op_private & OPpLVAL_INTRO)
7102 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
7103 const PADOFFSET target = kkid->op_targ;
7104 OP *const other = newOP(OP_PADSV,
7105 kkid->op_flags
7106 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
7107 OP *const first = newOP(OP_NULL, 0);
7108 OP *const nullop = newCONDOP(0, first, o, other);
7109 OP *const condop = first->op_next;
7110 /* hijacking PADSTALE for uninitialized state variables */
7111 SvPADSTALE_on(PAD_SVl(target));
7112
7113 condop->op_type = OP_ONCE;
7114 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
7115 condop->op_targ = target;
7116 other->op_targ = target;
7117
95562366
NC		 7118 /* Because we change the type of the op here, we will skip the
7119 assinment binop->op_last = binop->op_first->op_sibling; at the
7120 end of Perl_newBINOP(). So need to do it here. */
7121 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
7122
c5917253
NC		 7123 return nullop;
7124 }
7125 }
b162f9ea
IZ		 7126 return o;
7127}
7128
7129OP *
cea2e8a9 7130Perl_ck_match(pTHX_ OP *o)
79072805 7131{
97aff369 7132 dVAR;
0d863452 7133 if (o->op_type != OP_QR && PL_compcv) {
9f7d9405 7134 const PADOFFSET offset = pad_findmy("$_");
00b1698f 7135 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
59f00321
RGS		 7136 o->op_targ = offset;
7137 o->op_private |= OPpTARGET_MY;
7138 }
7139 }
7140 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
7141 o->op_private |= OPpRUNTIME;
11343788 7142 return o;
79072805
LW		 7143}
7144
7145OP *
f5d5a27c
CS		 7146Perl_ck_method(pTHX_ OP *o)
7147{
551405c4 7148 OP * const kid = cUNOPo->op_first;
f5d5a27c
CS		 7149 if (kid->op_type == OP_CONST) {
7150 SV* sv = kSVOP->op_sv;
a4fc7abc
AL		 7151 const char * const method = SvPVX_const(sv);
7152 if (!(strchr(method, ':') || strchr(method, '\''))) {
f5d5a27c 7153 OP *cmop;
1c846c1f 7154 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
a4fc7abc 7155 sv = newSVpvn_share(method, SvCUR(sv), 0);
1c846c1f
NIS		 7156 }
7157 else {
a0714e2c 7158 kSVOP->op_sv = NULL;
1c846c1f 7159 }
f5d5a27c 7160 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
eb8433b7
NC		 7161#ifdef PERL_MAD
7162 op_getmad(o,cmop,'O');
7163#else
f5d5a27c 7164 op_free(o);
eb8433b7 7165#endif
f5d5a27c
CS		 7166 return cmop;
7167 }
7168 }
7169 return o;
7170}
7171
7172OP *
cea2e8a9 7173Perl_ck_null(pTHX_ OP *o)
79072805 7174{
96a5add6 7175 PERL_UNUSED_CONTEXT;
11343788 7176 return o;
79072805
LW		 7177}
7178
7179OP *
16fe6d59
GS		 7180Perl_ck_open(pTHX_ OP *o)
7181{
97aff369 7182 dVAR;
551405c4 7183 HV * const table = GvHV(PL_hintgv);
16fe6d59 7184 if (table) {
a4fc7abc 7185 SV **svp = hv_fetchs(table, "open_IN", FALSE);
16fe6d59 7186 if (svp && *svp) {
551405c4 7187 const I32 mode = mode_from_discipline(*svp);
16fe6d59
GS		 7188 if (mode & O_BINARY)
7189 o->op_private |= OPpOPEN_IN_RAW;
7190 else if (mode & O_TEXT)
7191 o->op_private |= OPpOPEN_IN_CRLF;
7192 }
7193
a4fc7abc 7194 svp = hv_fetchs(table, "open_OUT", FALSE);
16fe6d59 7195 if (svp && *svp) {
551405c4 7196 const I32 mode = mode_from_discipline(*svp);
16fe6d59
GS		 7197 if (mode & O_BINARY)
7198 o->op_private |= OPpOPEN_OUT_RAW;
7199 else if (mode & O_TEXT)
7200 o->op_private |= OPpOPEN_OUT_CRLF;
7201 }
7202 }
8d7403e6
RGS		 7203 if (o->op_type == OP_BACKTICK) {
7204 if (!(o->op_flags & OPf_KIDS)) {
e4b7ebf3
RGS		 7205 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
7206#ifdef PERL_MAD
7207 op_getmad(o,newop,'O');
7208#else
8d7403e6 7209 op_free(o);
e4b7ebf3
RGS		 7210#endif
7211 return newop;
8d7403e6 7212 }
16fe6d59 7213 return o;
8d7403e6 7214 }
3b82e551
JH		 7215 {
7216 /* In case of three-arg dup open remove strictness
7217 * from the last arg if it is a bareword. */
551405c4
AL		 7218 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
7219 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
3b82e551 7220 OP *oa;
b15aece3 7221 const char *mode;
3b82e551
JH		 7222
7223 if ((last->op_type == OP_CONST) && /* The bareword. */
7224 (last->op_private & OPpCONST_BARE) &&
7225 (last->op_private & OPpCONST_STRICT) &&
7226 (oa = first->op_sibling) && /* The fh. */
7227 (oa = oa->op_sibling) && /* The mode. */
ea1d064a 7228 (oa->op_type == OP_CONST) &&
3b82e551 7229 SvPOK(((SVOP*)oa)->op_sv) &&
b15aece3 7230 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
3b82e551
JH		 7231 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
7232 (last == oa->op_sibling)) /* The bareword. */
7233 last->op_private &= ~OPpCONST_STRICT;
7234 }
16fe6d59
GS		 7235 return ck_fun(o);
7236}
7237
7238OP *
cea2e8a9 7239Perl_ck_repeat(pTHX_ OP *o)
79072805 7240{
11343788
MB		 7241 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
7242 o->op_private |= OPpREPEAT_DOLIST;
7243 cBINOPo->op_first = force_list(cBINOPo->op_first);
79072805
LW		 7244 }
7245 else
11343788
MB		 7246 scalar(o);
7247 return o;
79072805
LW		 7248}
7249
7250OP *
cea2e8a9 7251Perl_ck_require(pTHX_ OP *o)
8990e307 7252{
97aff369 7253 dVAR;
a0714e2c 7254 GV* gv = NULL;
ec4ab249 7255
11343788 7256 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
551405c4 7257 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8990e307
LW		 7258
7259 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
551405c4 7260 SV * const sv = kid->op_sv;
5c144d81 7261 U32 was_readonly = SvREADONLY(sv);
8990e307 7262 char *s;
cfff9797
NC		 7263 STRLEN len;
7264 const char *end;
5c144d81
NC		 7265
7266 if (was_readonly) {
7267 if (SvFAKE(sv)) {
7268 sv_force_normal_flags(sv, 0);
7269 assert(!SvREADONLY(sv));
7270 was_readonly = 0;
7271 } else {
7272 SvREADONLY_off(sv);
7273 }
7274 }
7275
cfff9797
NC		 7276 s = SvPVX(sv);
7277 len = SvCUR(sv);
7278 end = s + len;
7279 for (; s < end; s++) {
a0d0e21e
LW		 7280 if (*s == ':' && s[1] == ':') {
7281 *s = '/';
5c6b2528 7282 Move(s+2, s+1, end - s - 1, char);
cfff9797 7283 --end;
a0d0e21e 7284 }
8990e307 7285 }
cfff9797 7286 SvEND_set(sv, end);
396482e1 7287 sv_catpvs(sv, ".pm");
5c144d81 7288 SvFLAGS(sv) |= was_readonly;
8990e307
LW		 7289 }
7290 }
ec4ab249 7291
a72a1c8b
RGS		 7292 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
7293 /* handle override, if any */
fafc274c 7294 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
d6a985f2 7295 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
a4fc7abc 7296 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
a0714e2c 7297 gv = gvp ? *gvp : NULL;
d6a985f2 7298 }
a72a1c8b 7299 }
ec4ab249 7300
b9f751c0 7301 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
551405c4 7302 OP * const kid = cUNOPo->op_first;
f11453cb
NC		 7303 OP * newop;
7304
ec4ab249 7305 cUNOPo->op_first = 0;
f11453cb 7306#ifndef PERL_MAD
ec4ab249 7307 op_free(o);
eb8433b7 7308#endif
f11453cb
NC		 7309 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7310 append_elem(OP_LIST, kid,
7311 scalar(newUNOP(OP_RV2CV, 0,
7312 newGVOP(OP_GV, 0,
7313 gv))))));
7314 op_getmad(o,newop,'O');
eb8433b7 7315 return newop;
ec4ab249
GA		 7316 }
7317
11343788 7318 return ck_fun(o);
8990e307
LW		 7319}
7320
78f9721b
SM		 7321OP *
7322Perl_ck_return(pTHX_ OP *o)
7323{
97aff369 7324 dVAR;
78f9721b 7325 if (CvLVALUE(PL_compcv)) {
6867be6d 7326 OP *kid;
78f9721b
SM		 7327 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
7328 mod(kid, OP_LEAVESUBLV);
7329 }
7330 return o;
7331}
7332
79072805 7333OP *
cea2e8a9 7334Perl_ck_select(pTHX_ OP *o)
79072805 7335{
27da23d5 7336 dVAR;
c07a80fd 7337 OP* kid;
11343788
MB		 7338 if (o->op_flags & OPf_KIDS) {
7339 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
2304df62 7340 if (kid && kid->op_sibling) {
11343788 7341 o->op_type = OP_SSELECT;
22c35a8c 7342 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
11343788
MB		 7343 o = ck_fun(o);
7344 return fold_constants(o);
79072805
LW		 7345 }
7346 }
11343788
MB		 7347 o = ck_fun(o);
7348 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
c07a80fd 7349 if (kid && kid->op_type == OP_RV2GV)
7350 kid->op_private &= ~HINT_STRICT_REFS;
11343788 7351 return o;
79072805
LW		 7352}
7353
7354OP *
cea2e8a9 7355Perl_ck_shift(pTHX_ OP *o)
79072805 7356{
97aff369 7357 dVAR;
6867be6d 7358 const I32 type = o->op_type;
79072805 7359
11343788 7360 if (!(o->op_flags & OPf_KIDS)) {
6d4ff0d2 7361 OP *argop;
eb8433b7
NC		 7362 /* FIXME - this can be refactored to reduce code in #ifdefs */
7363#ifdef PERL_MAD
1d866c12 7364 OP * const oldo = o;
eb8433b7 7365#else
11343788 7366 op_free(o);
eb8433b7 7367#endif
6d4ff0d2 7368 argop = newUNOP(OP_RV2AV, 0,
8fde6460 7369 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
eb8433b7
NC		 7370#ifdef PERL_MAD
7371 o = newUNOP(type, 0, scalar(argop));
7372 op_getmad(oldo,o,'O');
7373 return o;
7374#else
6d4ff0d2 7375 return newUNOP(type, 0, scalar(argop));
eb8433b7 7376#endif
79072805 7377 }
11343788 7378 return scalar(modkids(ck_fun(o), type));
79072805
LW		 7379}
7380
7381OP *
cea2e8a9 7382Perl_ck_sort(pTHX_ OP *o)
79072805 7383{
97aff369 7384 dVAR;
8e3f9bdf 7385 OP *firstkid;
bbce6d69 7386
1496a290 7387 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
a4fc7abc 7388 HV * const hinthv = GvHV(PL_hintgv);
7b9ef140 7389 if (hinthv) {
a4fc7abc 7390 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7b9ef140 7391 if (svp) {
a4fc7abc 7392 const I32 sorthints = (I32)SvIV(*svp);
7b9ef140
RH		 7393 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7394 o->op_private |= OPpSORT_QSORT;
7395 if ((sorthints & HINT_SORT_STABLE) != 0)
7396 o->op_private |= OPpSORT_STABLE;
7397 }
7398 }
7399 }
7400
9ea6e965 7401 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
51a19bc0 7402 simplify_sort(o);
8e3f9bdf
GS		 7403 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7404 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
9c5ffd7c 7405 OP *k = NULL;
8e3f9bdf 7406 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
79072805 7407
463ee0b2 7408 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
79072805 7409 linklist(kid);
463ee0b2
LW		 7410 if (kid->op_type == OP_SCOPE) {
7411 k = kid->op_next;
7412 kid->op_next = 0;
79072805 7413 }
463ee0b2 7414 else if (kid->op_type == OP_LEAVE) {
11343788 7415 if (o->op_type == OP_SORT) {
93c66552 7416 op_null(kid); /* wipe out leave */
748a9306 7417 kid->op_next = kid;
463ee0b2 7418
748a9306
LW		 7419 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7420 if (k->op_next == kid)
7421 k->op_next = 0;
71a29c3c
GS		 7422 /* don't descend into loops */
7423 else if (k->op_type == OP_ENTERLOOP
7424 || k->op_type == OP_ENTERITER)
7425 {
7426 k = cLOOPx(k)->op_lastop;
7427 }
748a9306 7428 }
463ee0b2 7429 }
748a9306
LW		 7430 else
7431 kid->op_next = 0; /* just disconnect the leave */
a0d0e21e 7432 k = kLISTOP->op_first;
463ee0b2 7433 }
a2efc822 7434 CALL_PEEP(k);
a0d0e21e 7435
8e3f9bdf
GS		 7436 kid = firstkid;
7437 if (o->op_type == OP_SORT) {
7438 /* provide scalar context for comparison function/block */
7439 kid = scalar(kid);
a0d0e21e 7440 kid->op_next = kid;
8e3f9bdf 7441 }
a0d0e21e
LW		 7442 else
7443 kid->op_next = k;
11343788 7444 o->op_flags |= OPf_SPECIAL;
79072805 7445 }
c6e96bcb 7446 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
93c66552 7447 op_null(firstkid);
8e3f9bdf
GS		 7448
7449 firstkid = firstkid->op_sibling;
79072805 7450 }
bbce6d69 7451
8e3f9bdf
GS		 7452 /* provide list context for arguments */
7453 if (o->op_type == OP_SORT)
7454 list(firstkid);
7455
11343788 7456 return o;
79072805 7457}
bda4119b
GS		 7458
7459STATIC void
cea2e8a9 7460S_simplify_sort(pTHX_ OP *o)
9c007264 7461{
97aff369 7462 dVAR;
9c007264
JH		 7463 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7464 OP *k;
eb209983 7465 int descending;
350de78d 7466 GV *gv;
770526c1 7467 const char *gvname;
9c007264
JH		 7468 if (!(o->op_flags & OPf_STACKED))
7469 return;
fafc274c
NC		 7470 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7471 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
82092f1d 7472 kid = kUNOP->op_first; /* get past null */
9c007264
JH		 7473 if (kid->op_type != OP_SCOPE)
7474 return;
7475 kid = kLISTOP->op_last; /* get past scope */
7476 switch(kid->op_type) {
7477 case OP_NCMP:
7478 case OP_I_NCMP:
7479 case OP_SCMP:
7480 break;
7481 default:
7482 return;
7483 }
7484 k = kid; /* remember this node*/
7485 if (kBINOP->op_first->op_type != OP_RV2SV)
7486 return;
7487 kid = kBINOP->op_first; /* get past cmp */
7488 if (kUNOP->op_first->op_type != OP_GV)
7489 return;
7490 kid = kUNOP->op_first; /* get past rv2sv */
638eceb6 7491 gv = kGVOP_gv;
350de78d 7492 if (GvSTASH(gv) != PL_curstash)
9c007264 7493 return;
770526c1
NC		 7494 gvname = GvNAME(gv);
7495 if (*gvname == 'a' && gvname[1] == '\0')
eb209983 7496 descending = 0;
770526c1 7497 else if (*gvname == 'b' && gvname[1] == '\0')
eb209983 7498 descending = 1;
9c007264
JH		 7499 else
7500 return;
eb209983 7501
9c007264
JH		 7502 kid = k; /* back to cmp */
7503 if (kBINOP->op_last->op_type != OP_RV2SV)
7504 return;
7505 kid = kBINOP->op_last; /* down to 2nd arg */
7506 if (kUNOP->op_first->op_type != OP_GV)
7507 return;
7508 kid = kUNOP->op_first; /* get past rv2sv */
638eceb6 7509 gv = kGVOP_gv;
770526c1
NC		 7510 if (GvSTASH(gv) != PL_curstash)
7511 return;
7512 gvname = GvNAME(gv);
7513 if ( descending
7514 ? !(*gvname == 'a' && gvname[1] == '\0')
7515 : !(*gvname == 'b' && gvname[1] == '\0'))
9c007264
JH		 7516 return;
7517 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
eb209983
NC		 7518 if (descending)
7519 o->op_private |= OPpSORT_DESCEND;
9c007264
JH		 7520 if (k->op_type == OP_NCMP)
7521 o->op_private |= OPpSORT_NUMERIC;
7522 if (k->op_type == OP_I_NCMP)
7523 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
e507f050
SM		 7524 kid = cLISTOPo->op_first->op_sibling;
7525 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
eb8433b7
NC		 7526#ifdef PERL_MAD
7527 op_getmad(kid,o,'S'); /* then delete it */
7528#else
e507f050 7529 op_free(kid); /* then delete it */
eb8433b7 7530#endif
9c007264 7531}
79072805
LW		 7532
7533OP *
cea2e8a9 7534Perl_ck_split(pTHX_ OP *o)
79072805 7535{
27da23d5 7536 dVAR;
79072805 7537 register OP *kid;
aeea060c 7538
11343788
MB		 7539 if (o->op_flags & OPf_STACKED)
7540 return no_fh_allowed(o);
79072805 7541
11343788 7542 kid = cLISTOPo->op_first;
8990e307 7543 if (kid->op_type != OP_NULL)
cea2e8a9 7544 Perl_croak(aTHX_ "panic: ck_split");
8990e307 7545 kid = kid->op_sibling;
11343788
MB		 7546 op_free(cLISTOPo->op_first);
7547 cLISTOPo->op_first = kid;
85e6fe83 7548 if (!kid) {
396482e1 7549 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
11343788 7550 cLISTOPo->op_last = kid; /* There was only one element previously */
85e6fe83 7551 }
79072805 7552
de4bf5b3 7553 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
551405c4 7554 OP * const sibl = kid->op_sibling;
463ee0b2 7555 kid->op_sibling = 0;
131b3ad0 7556 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
11343788
MB		 7557 if (cLISTOPo->op_first == cLISTOPo->op_last)
7558 cLISTOPo->op_last = kid;
7559 cLISTOPo->op_first = kid;
79072805
LW		 7560 kid->op_sibling = sibl;
7561 }
7562
7563 kid->op_type = OP_PUSHRE;
22c35a8c 7564 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
79072805 7565 scalar(kid);
041457d9 7566 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
f34840d8
MJD		 7567 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7568 "Use of /g modifier is meaningless in split");
7569 }
79072805
LW		 7570
7571 if (!kid->op_sibling)
54b9620d 7572 append_elem(OP_SPLIT, o, newDEFSVOP());
79072805
LW		 7573
7574 kid = kid->op_sibling;
7575 scalar(kid);
7576
7577 if (!kid->op_sibling)
11343788 7578 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
ce3e5c45 7579 assert(kid->op_sibling);
79072805
LW		 7580
7581 kid = kid->op_sibling;
7582 scalar(kid);
7583
7584 if (kid->op_sibling)
53e06cf0 7585 return too_many_arguments(o,OP_DESC(o));
79072805 7586
11343788 7587 return o;
79072805
LW		 7588}
7589
7590OP *
1c846c1f 7591Perl_ck_join(pTHX_ OP *o)
eb6e2d6f 7592{
551405c4 7593 const OP * const kid = cLISTOPo->op_first->op_sibling;
041457d9
DM		 7594 if (kid && kid->op_type == OP_MATCH) {
7595 if (ckWARN(WARN_SYNTAX)) {
6867be6d 7596 const REGEXP *re = PM_GETRE(kPMOP);
220fc49f
NC		 7597 const char *pmstr = re ? RX_PRECOMP(re) : "STRING";
7598 const STRLEN len = re ? RX_PRELEN(re) : 6;
9014280d 7599 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
bcdf7404 7600 "/%.*s/ should probably be written as \"%.*s\"",
d83b45b8 7601 (int)len, pmstr, (int)len, pmstr);
eb6e2d6f
GS		 7602 }
7603 }
7604 return ck_fun(o);
7605}
7606
7607OP *
cea2e8a9 7608Perl_ck_subr(pTHX_ OP *o)
79072805 7609{
97aff369 7610 dVAR;
11343788
MB		 7611 OP *prev = ((cUNOPo->op_first->op_sibling)
7612 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7613 OP *o2 = prev->op_sibling;
4633a7c4 7614 OP *cvop;
a0751766 7615 const char *proto = NULL;
cbf82dd0 7616 const char *proto_end = NULL;
c445ea15
AL		 7617 CV *cv = NULL;
7618 GV *namegv = NULL;
4633a7c4
LW		 7619 int optional = 0;
7620 I32 arg = 0;
5b794e05 7621 I32 contextclass = 0;
d3fcec1f 7622 const char *e = NULL;
0723351e 7623 bool delete_op = 0;
4633a7c4 7624
d3011074 7625 o->op_private |= OPpENTERSUB_HASTARG;
11343788 7626 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
4633a7c4
LW		 7627 if (cvop->op_type == OP_RV2CV) {
7628 SVOP* tmpop;
11343788 7629 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
93c66552 7630 op_null(cvop); /* disable rv2cv */
4633a7c4 7631 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
76cd736e 7632 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
638eceb6 7633 GV *gv = cGVOPx_gv(tmpop);
350de78d 7634 cv = GvCVu(gv);
76cd736e
GS		 7635 if (!cv)
7636 tmpop->op_private |= OPpEARLY_CV;
06492da6
SF		 7637 else {
7638 if (SvPOK(cv)) {
cbf82dd0 7639 STRLEN len;
06492da6 7640 namegv = CvANON(cv) ? gv : CvGV(cv);
cbf82dd0
NC		 7641 proto = SvPV((SV*)cv, len);
7642 proto_end = proto + len;
06492da6 7643 }
46fc3d4c 7644 }
4633a7c4
LW		 7645 }
7646 }
f5d5a27c 7647 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7a52d87a
GS		 7648 if (o2->op_type == OP_CONST)
7649 o2->op_private &= ~OPpCONST_STRICT;
58a40671 7650 else if (o2->op_type == OP_LIST) {
5f66b61c
AL		 7651 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7652 if (sib && sib->op_type == OP_CONST)
7653 sib->op_private &= ~OPpCONST_STRICT;
58a40671 7654 }
7a52d87a 7655 }
3280af22
NIS		 7656 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7657 if (PERLDB_SUB && PL_curstash != PL_debstash)
11343788
MB		 7658 o->op_private |= OPpENTERSUB_DB;
7659 while (o2 != cvop) {
eb8433b7 7660 OP* o3;
9fc012f4
GG		 7661 if (PL_madskills && o2->op_type == OP_STUB) {
7662 o2 = o2->op_sibling;
7663 continue;
7664 }
eb8433b7
NC		 7665 if (PL_madskills && o2->op_type == OP_NULL)
7666 o3 = ((UNOP*)o2)->op_first;
7667 else
7668 o3 = o2;
4633a7c4 7669 if (proto) {
cbf82dd0 7670 if (proto >= proto_end)
5dc0d613 7671 return too_many_arguments(o, gv_ename(namegv));
cbf82dd0
NC		 7672
7673 switch (*proto) {
4633a7c4
LW		 7674 case ';':
7675 optional = 1;
7676 proto++;
7677 continue;
b13fd70a 7678 case '_':
f00d1d61 7679 /* _ must be at the end */
cb40c25d 7680 if (proto[1] && proto[1] != ';')
f00d1d61 7681 goto oops;
4633a7c4
LW		 7682 case '$':
7683 proto++;
7684 arg++;
11343788 7685 scalar(o2);
4633a7c4
LW		 7686 break;
7687 case '%':
7688 case '@':
11343788 7689 list(o2);
4633a7c4
LW		 7690 arg++;
7691 break;
7692 case '&':
7693 proto++;
7694 arg++;
eb8433b7 7695 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
75fc29ea 7696 bad_type(arg,
666ea192
JH		 7697 arg == 1 ? "block or sub {}" : "sub {}",
7698 gv_ename(namegv), o3);
4633a7c4
LW		 7699 break;
7700 case '*':
2ba6ecf4 7701 /* '*' allows any scalar type, including bareword */
4633a7c4
LW		 7702 proto++;
7703 arg++;
eb8433b7 7704 if (o3->op_type == OP_RV2GV)
2ba6ecf4 7705 goto wrapref; /* autoconvert GLOB -> GLOBref */
eb8433b7
NC		 7706 else if (o3->op_type == OP_CONST)
7707 o3->op_private &= ~OPpCONST_STRICT;
7708 else if (o3->op_type == OP_ENTERSUB) {
9675f7ac 7709 /* accidental subroutine, revert to bareword */
eb8433b7 7710 OP *gvop = ((UNOP*)o3)->op_first;
9675f7ac
GS		 7711 if (gvop && gvop->op_type == OP_NULL) {
7712 gvop = ((UNOP*)gvop)->op_first;
7713 if (gvop) {
7714 for (; gvop->op_sibling; gvop = gvop->op_sibling)
7715 ;
7716 if (gvop &&
7717 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
7718 (gvop = ((UNOP*)gvop)->op_first) &&
7719 gvop->op_type == OP_GV)
7720 {
551405c4
AL		 7721 GV * const gv = cGVOPx_gv(gvop);
7722 OP * const sibling = o2->op_sibling;
396482e1 7723 SV * const n = newSVpvs("");
eb8433b7 7724#ifdef PERL_MAD
1d866c12 7725 OP * const oldo2 = o2;
eb8433b7 7726#else
9675f7ac 7727 op_free(o2);
eb8433b7 7728#endif
2a797ae2 7729 gv_fullname4(n, gv, "", FALSE);
2692f720 7730 o2 = newSVOP(OP_CONST, 0, n);
eb8433b7 7731 op_getmad(oldo2,o2,'O');
9675f7ac
GS		 7732 prev->op_sibling = o2;
7733 o2->op_sibling = sibling;
7734 }
7735 }
7736 }
7737 }
2ba6ecf4
GS		 7738 scalar(o2);
7739 break;
5b794e05
JH		 7740 case '[': case ']':
7741 goto oops;
7742 break;
4633a7c4
LW		 7743 case '\\':
7744 proto++;
7745 arg++;
5b794e05 7746 again:
4633a7c4 7747 switch (*proto++) {
5b794e05
JH		 7748 case '[':
7749 if (contextclass++ == 0) {
841d93c8 7750 e = strchr(proto, ']');
5b794e05
JH		 7751 if (!e || e == proto)
7752 goto oops;
7753 }
7754 else
7755 goto oops;
7756 goto again;
7757 break;
7758 case ']':
466bafcd 7759 if (contextclass) {
a0751766
NC		 7760 const char *p = proto;
7761 const char *const end = proto;
466bafcd 7762 contextclass = 0;
466bafcd 7763 while (*--p != '[');
a0751766
NC		 7764 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
7765 (int)(end - p), p),
7766 gv_ename(namegv), o3);
466bafcd 7767 } else
5b794e05
JH		 7768 goto oops;
7769 break;
4633a7c4 7770 case '*':
eb8433b7 7771 if (o3->op_type == OP_RV2GV)
5b794e05
JH		 7772 goto wrapref;
7773 if (!contextclass)
eb8433b7 7774 bad_type(arg, "symbol", gv_ename(namegv), o3);
5b794e05 7775 break;
4633a7c4 7776 case '&':
eb8433b7 7777 if (o3->op_type == OP_ENTERSUB)
5b794e05
JH		 7778 goto wrapref;
7779 if (!contextclass)
eb8433b7
NC		 7780 bad_type(arg, "subroutine entry", gv_ename(namegv),
7781 o3);
5b794e05 7782 break;
4633a7c4 7783 case '$':
eb8433b7
NC		 7784 if (o3->op_type == OP_RV2SV ||
7785 o3->op_type == OP_PADSV ||
7786 o3->op_type == OP_HELEM ||
5b9081af 7787 o3->op_type == OP_AELEM)
5b794e05
JH		 7788 goto wrapref;
7789 if (!contextclass)
eb8433b7 7790 bad_type(arg, "scalar", gv_ename(namegv), o3);
5b794e05 7791 break;
4633a7c4 7792 case '@':
eb8433b7
NC		 7793 if (o3->op_type == OP_RV2AV ||
7794 o3->op_type == OP_PADAV)
5b794e05
JH		 7795 goto wrapref;
7796 if (!contextclass)
eb8433b7 7797 bad_type(arg, "array", gv_ename(namegv), o3);
5b794e05 7798 break;
4633a7c4 7799 case '%':
eb8433b7
NC		 7800 if (o3->op_type == OP_RV2HV ||
7801 o3->op_type == OP_PADHV)
5b794e05
JH		 7802 goto wrapref;
7803 if (!contextclass)
eb8433b7 7804 bad_type(arg, "hash", gv_ename(namegv), o3);
5b794e05
JH		 7805 break;
7806 wrapref:
4633a7c4 7807 {
551405c4
AL		 7808 OP* const kid = o2;
7809 OP* const sib = kid->op_sibling;
4633a7c4 7810 kid->op_sibling = 0;
6fa846a0
GS		 7811 o2 = newUNOP(OP_REFGEN, 0, kid);
7812 o2->op_sibling = sib;
e858de61 7813 prev->op_sibling = o2;
4633a7c4 7814 }
841d93c8 7815 if (contextclass && e) {
5b794e05
JH		 7816 proto = e + 1;
7817 contextclass = 0;
7818 }
4633a7c4
LW		 7819 break;
7820 default: goto oops;
7821 }
5b794e05
JH		 7822 if (contextclass)
7823 goto again;
4633a7c4 7824 break;
b1cb66bf 7825 case ' ':
7826 proto++;
7827 continue;
4633a7c4
LW		 7828 default:
7829 oops:
35c1215d 7830 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
be2597df 7831 gv_ename(namegv), SVfARG(cv));
4633a7c4
LW		 7832 }
7833 }
7834 else
11343788
MB		 7835 list(o2);
7836 mod(o2, OP_ENTERSUB);
7837 prev = o2;
7838 o2 = o2->op_sibling;
551405c4 7839 } /* while */
236b555a
RGS		 7840 if (o2 == cvop && proto && *proto == '_') {
7841 /* generate an access to $_ */
7842 o2 = newDEFSVOP();
7843 o2->op_sibling = prev->op_sibling;
7844 prev->op_sibling = o2; /* instead of cvop */
7845 }
cbf82dd0 7846 if (proto && !optional && proto_end > proto &&
236b555a 7847 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
5dc0d613 7848 return too_few_arguments(o, gv_ename(namegv));
0723351e 7849 if(delete_op) {
eb8433b7 7850#ifdef PERL_MAD
1d866c12 7851 OP * const oldo = o;
eb8433b7 7852#else
06492da6 7853 op_free(o);
eb8433b7 7854#endif
06492da6 7855 o=newSVOP(OP_CONST, 0, newSViv(0));
eb8433b7 7856 op_getmad(oldo,o,'O');
06492da6 7857 }
11343788 7858 return o;
79072805
LW		 7859}
7860
7861OP *
cea2e8a9 7862Perl_ck_svconst(pTHX_ OP *o)
8990e307 7863{
96a5add6 7864 PERL_UNUSED_CONTEXT;
11343788
MB		 7865 SvREADONLY_on(cSVOPo->op_sv);
7866 return o;
8990e307
LW		 7867}
7868
7869OP *
d4ac975e
GA		 7870Perl_ck_chdir(pTHX_ OP *o)
7871{
7872 if (o->op_flags & OPf_KIDS) {
1496a290 7873 SVOP * const kid = (SVOP*)cUNOPo->op_first;
d4ac975e
GA		 7874
7875 if (kid && kid->op_type == OP_CONST &&
7876 (kid->op_private & OPpCONST_BARE))
7877 {
7878 o->op_flags |= OPf_SPECIAL;
7879 kid->op_private &= ~OPpCONST_STRICT;
7880 }
7881 }
7882 return ck_fun(o);
7883}
7884
7885OP *
cea2e8a9 7886Perl_ck_trunc(pTHX_ OP *o)
79072805 7887{
11343788
MB		 7888 if (o->op_flags & OPf_KIDS) {
7889 SVOP *kid = (SVOP*)cUNOPo->op_first;
79072805 7890
a0d0e21e
LW		 7891 if (kid->op_type == OP_NULL)
7892 kid = (SVOP*)kid->op_sibling;
bb53490d
GS		 7893 if (kid && kid->op_type == OP_CONST &&
7894 (kid->op_private & OPpCONST_BARE))
7895 {
11343788 7896 o->op_flags |= OPf_SPECIAL;
bb53490d
GS		 7897 kid->op_private &= ~OPpCONST_STRICT;
7898 }
79072805 7899 }
11343788 7900 return ck_fun(o);
79072805
LW		 7901}
7902
35fba0d9 7903OP *
bab9c0ac
RGS		 7904Perl_ck_unpack(pTHX_ OP *o)
7905{
7906 OP *kid = cLISTOPo->op_first;
7907 if (kid->op_sibling) {
7908 kid = kid->op_sibling;
7909 if (!kid->op_sibling)
7910 kid->op_sibling = newDEFSVOP();
7911 }
7912 return ck_fun(o);
7913}
7914
7915OP *
35fba0d9
RG		 7916Perl_ck_substr(pTHX_ OP *o)
7917{
7918 o = ck_fun(o);
1d866c12 7919 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
35fba0d9
RG		 7920 OP *kid = cLISTOPo->op_first;
7921
7922 if (kid->op_type == OP_NULL)
7923 kid = kid->op_sibling;
7924 if (kid)
7925 kid->op_flags |= OPf_MOD;
7926
7927 }
7928 return o;
7929}
7930
878d132a
NC		 7931OP *
7932Perl_ck_each(pTHX_ OP *o)
7933{
d75c0fe7 7934 dVAR;
878d132a
NC		 7935 OP *kid = cLISTOPo->op_first;
7936
7937 if (kid->op_type == OP_PADAV || kid->op_type == OP_RV2AV) {
7938 const unsigned new_type = o->op_type == OP_EACH ? OP_AEACH
7939 : o->op_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
7940 o->op_type = new_type;
7941 o->op_ppaddr = PL_ppaddr[new_type];
7942 }
7943 else if (!(kid->op_type == OP_PADHV || kid->op_type == OP_RV2HV
7944 || (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE)
7945 )) {
7946 bad_type(1, "hash or array", PL_op_desc[o->op_type], kid);
7947 return o;
7948 }
7949 return ck_fun(o);
7950}
7951
61b743bb
DM		 7952/* A peephole optimizer. We visit the ops in the order they're to execute.
7953 * See the comments at the top of this file for more details about when
7954 * peep() is called */
463ee0b2 7955
79072805 7956void
864dbfa3 7957Perl_peep(pTHX_ register OP *o)
79072805 7958{
27da23d5 7959 dVAR;
c445ea15 7960 register OP* oldop = NULL;
2d8e6c8d 7961
2814eb74 7962 if (!o || o->op_opt)
79072805 7963 return;
a0d0e21e 7964 ENTER;
462e5cf6 7965 SAVEOP();
7766f137 7966 SAVEVPTR(PL_curcop);
a0d0e21e 7967 for (; o; o = o->op_next) {
2814eb74 7968 if (o->op_opt)
a0d0e21e 7969 break;
6d7dd4a5
NC		 7970 /* By default, this op has now been optimised. A couple of cases below
7971 clear this again. */
7972 o->op_opt = 1;
533c011a 7973 PL_op = o;
a0d0e21e 7974 switch (o->op_type) {
acb36ea4 7975 case OP_SETSTATE:
a0d0e21e
LW		 7976 case OP_NEXTSTATE:
7977 case OP_DBSTATE:
3280af22 7978 PL_curcop = ((COP*)o); /* for warnings */
a0d0e21e
LW		 7979 break;
7980
a0d0e21e 7981 case OP_CONST:
7a52d87a
GS		 7982 if (cSVOPo->op_private & OPpCONST_STRICT)
7983 no_bareword_allowed(o);
7766f137 7984#ifdef USE_ITHREADS
3848b962 7985 case OP_METHOD_NAMED:
7766f137
GS		 7986 /* Relocate sv to the pad for thread safety.
7987 * Despite being a "constant", the SV is written to,
7988 * for reference counts, sv_upgrade() etc. */
7989 if (cSVOP->op_sv) {
6867be6d 7990 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
330e22d5 7991 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6a7129a1 7992 /* If op_sv is already a PADTMP then it is being used by
9a049f1c 7993 * some pad, so make a copy. */
dd2155a4
DM		 7994 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
7995 SvREADONLY_on(PAD_SVl(ix));
6a7129a1
GS		 7996 SvREFCNT_dec(cSVOPo->op_sv);
7997 }
052ca17e
NC		 7998 else if (o->op_type == OP_CONST
7999 && cSVOPo->op_sv == &PL_sv_undef) {
8000 /* PL_sv_undef is hack - it's unsafe to store it in the
8001 AV that is the pad, because av_fetch treats values of
8002 PL_sv_undef as a "free" AV entry and will merrily
8003 replace them with a new SV, causing pad_alloc to think
8004 that this pad slot is free. (When, clearly, it is not)
8005 */
8006 SvOK_off(PAD_SVl(ix));
8007 SvPADTMP_on(PAD_SVl(ix));
8008 SvREADONLY_on(PAD_SVl(ix));
8009 }
6a7129a1 8010 else {
dd2155a4 8011 SvREFCNT_dec(PAD_SVl(ix));
6a7129a1 8012 SvPADTMP_on(cSVOPo->op_sv);
dd2155a4 8013 PAD_SETSV(ix, cSVOPo->op_sv);
9a049f1c 8014 /* XXX I don't know how this isn't readonly already. */
dd2155a4 8015 SvREADONLY_on(PAD_SVl(ix));
6a7129a1 8016 }
a0714e2c 8017 cSVOPo->op_sv = NULL;
7766f137
GS		 8018 o->op_targ = ix;
8019 }
8020#endif
07447971
GS		 8021 break;
8022
df91b2c5
AE		 8023 case OP_CONCAT:
8024 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
8025 if (o->op_next->op_private & OPpTARGET_MY) {
8026 if (o->op_flags & OPf_STACKED) /* chained concats */
a6aa0b75 8027 break; /* ignore_optimization */
df91b2c5
AE		 8028 else {
8029 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
8030 o->op_targ = o->op_next->op_targ;
8031 o->op_next->op_targ = 0;
8032 o->op_private |= OPpTARGET_MY;
8033 }
8034 }
8035 op_null(o->op_next);
8036 }
df91b2c5 8037 break;
6d7dd4a5
NC		 8038 case OP_STUB:
8039 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
8040 break; /* Scalar stub must produce undef. List stub is noop */
8041 }
8042 goto nothin;
79072805 8043 case OP_NULL:
acb36ea4
GS		 8044 if (o->op_targ == OP_NEXTSTATE
8045 || o->op_targ == OP_DBSTATE
8046 || o->op_targ == OP_SETSTATE)
8047 {
3280af22 8048 PL_curcop = ((COP*)o);
acb36ea4 8049 }
dad75012
AMS		 8050 /* XXX: We avoid setting op_seq here to prevent later calls
8051 to peep() from mistakenly concluding that optimisation
8052 has already occurred. This doesn't fix the real problem,
8053 though (See 20010220.007). AMS 20010719 */
2814eb74 8054 /* op_seq functionality is now replaced by op_opt */
6d7dd4a5 8055 o->op_opt = 0;
f46f2f82 8056 /* FALL THROUGH */
79072805 8057 case OP_SCALAR:
93a17b20 8058 case OP_LINESEQ:
463ee0b2 8059 case OP_SCOPE:
6d7dd4a5 8060 nothin:
a0d0e21e
LW		 8061 if (oldop && o->op_next) {
8062 oldop->op_next = o->op_next;
6d7dd4a5 8063 o->op_opt = 0;
79072805
LW		 8064 continue;
8065 }
79072805
LW		 8066 break;
8067
6a077020 8068 case OP_PADAV:
79072805 8069 case OP_GV:
6a077020 8070 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
0bd48802 8071 OP* const pop = (o->op_type == OP_PADAV) ?
6a077020 8072 o->op_next : o->op_next->op_next;
a0d0e21e 8073 IV i;
f9dc862f 8074 if (pop && pop->op_type == OP_CONST &&
af5acbb4 8075 ((PL_op = pop->op_next)) &&
8990e307 8076 pop->op_next->op_type == OP_AELEM &&
a0d0e21e 8077 !(pop->op_next->op_private &
78f9721b 8078 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
fc15ae8f 8079 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
a0d0e21e 8080 <= 255 &&
8990e307
LW		 8081 i >= 0)
8082 {
350de78d 8083 GV *gv;
af5acbb4
DM		 8084 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
8085 no_bareword_allowed(pop);
6a077020
DM		 8086 if (o->op_type == OP_GV)
8087 op_null(o->op_next);
93c66552
DM		 8088 op_null(pop->op_next);
8089 op_null(pop);
a0d0e21e
LW		 8090 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
8091 o->op_next = pop->op_next->op_next;
22c35a8c 8092 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
a0d0e21e 8093 o->op_private = (U8)i;
6a077020
DM		 8094 if (o->op_type == OP_GV) {
8095 gv = cGVOPo_gv;
8096 GvAVn(gv);
8097 }
8098 else
8099 o->op_flags |= OPf_SPECIAL;
8100 o->op_type = OP_AELEMFAST;
8101 }
6a077020
DM		 8102 break;
8103 }
8104
8105 if (o->op_next->op_type == OP_RV2SV) {
8106 if (!(o->op_next->op_private & OPpDEREF)) {
8107 op_null(o->op_next);
8108 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
8109 | OPpOUR_INTRO);
8110 o->op_next = o->op_next->op_next;
8111 o->op_type = OP_GVSV;
8112 o->op_ppaddr = PL_ppaddr[OP_GVSV];
8990e307 8113 }
79072805 8114 }
e476b1b5 8115 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
551405c4 8116 GV * const gv = cGVOPo_gv;
b15aece3 8117 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
76cd736e 8118 /* XXX could check prototype here instead of just carping */
551405c4 8119 SV * const sv = sv_newmortal();
bd61b366 8120 gv_efullname3(sv, gv, NULL);
9014280d 8121 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
35c1215d 8122 "%"SVf"() called too early to check prototype",
be2597df 8123 SVfARG(sv));
76cd736e
GS		 8124 }
8125 }
89de2904
AMS		 8126 else if (o->op_next->op_type == OP_READLINE
8127 && o->op_next->op_next->op_type == OP_CONCAT
8128 && (o->op_next->op_next->op_flags & OPf_STACKED))
8129 {
d2c45030
AMS		 8130 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
8131 o->op_type = OP_RCATLINE;
8132 o->op_flags |= OPf_STACKED;
8133 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
89de2904 8134 op_null(o->op_next->op_next);
d2c45030 8135 op_null(o->op_next);
89de2904 8136 }
76cd736e 8137
79072805
LW		 8138 break;
8139
a0d0e21e 8140 case OP_MAPWHILE:
79072805
LW		 8141 case OP_GREPWHILE:
8142 case OP_AND:
8143 case OP_OR:
c963b151 8144 case OP_DOR:
2c2d71f5
JH		 8145 case OP_ANDASSIGN:
8146 case OP_ORASSIGN:
c963b151 8147 case OP_DORASSIGN:
1a67a97c
SM		 8148 case OP_COND_EXPR:
8149 case OP_RANGE:
c5917253 8150 case OP_ONCE:
fd4d1407
IZ		 8151 while (cLOGOP->op_other->op_type == OP_NULL)
8152 cLOGOP->op_other = cLOGOP->op_other->op_next;
a2efc822 8153 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
79072805
LW		 8154 break;
8155
79072805 8156 case OP_ENTERLOOP:
9c2ca71a 8157 case OP_ENTERITER:
58cccf98
SM		 8158 while (cLOOP->op_redoop->op_type == OP_NULL)
8159 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
79072805 8160 peep(cLOOP->op_redoop);
58cccf98
SM		 8161 while (cLOOP->op_nextop->op_type == OP_NULL)
8162 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
79072805 8163 peep(cLOOP->op_nextop);
58cccf98
SM		 8164 while (cLOOP->op_lastop->op_type == OP_NULL)
8165 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
79072805
LW		 8166 peep(cLOOP->op_lastop);
8167 break;
8168
79072805 8169 case OP_SUBST:
29f2e912
NC		 8170 assert(!(cPMOP->op_pmflags & PMf_ONCE));
8171 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
8172 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
8173 cPMOP->op_pmstashstartu.op_pmreplstart
8174 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
8175 peep(cPMOP->op_pmstashstartu.op_pmreplstart);
79072805
LW		 8176 break;
8177
a0d0e21e 8178 case OP_EXEC:
041457d9
DM		 8179 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
8180 && ckWARN(WARN_SYNTAX))
8181 {
1496a290
AL		 8182 if (o->op_next->op_sibling) {
8183 const OPCODE type = o->op_next->op_sibling->op_type;
8184 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
8185 const line_t oldline = CopLINE(PL_curcop);
8186 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
8187 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8188 "Statement unlikely to be reached");
8189 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8190 "\t(Maybe you meant system() when you said exec()?)\n");
8191 CopLINE_set(PL_curcop, oldline);
8192 }
a0d0e21e
LW		 8193 }
8194 }
8195 break;
b2ffa427 8196
c750a3ec 8197 case OP_HELEM: {
e75d1f10 8198 UNOP *rop;
6d822dc4 8199 SV *lexname;
e75d1f10 8200 GV **fields;
6d822dc4 8201 SV **svp, *sv;
d5263905 8202 const char *key = NULL;
c750a3ec 8203 STRLEN keylen;
b2ffa427 8204
1c846c1f 8205 if (((BINOP*)o)->op_last->op_type != OP_CONST)
c750a3ec 8206 break;
1c846c1f
NIS		 8207
8208 /* Make the CONST have a shared SV */
8209 svp = cSVOPx_svp(((BINOP*)o)->op_last);
3049cdab 8210 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
d5263905 8211 key = SvPV_const(sv, keylen);
25716404 8212 lexname = newSVpvn_share(key,
bb7a0f54 8213 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
25716404 8214 0);
1c846c1f
NIS		 8215 SvREFCNT_dec(sv);
8216 *svp = lexname;
8217 }
e75d1f10
RD		 8218
8219 if ((o->op_private & (OPpLVAL_INTRO)))
8220 break;
8221
8222 rop = (UNOP*)((BINOP*)o)->op_first;
8223 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
8224 break;
8225 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
00b1698f 8226 if (!SvPAD_TYPED(lexname))
e75d1f10 8227 break;
a4fc7abc 8228 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
e75d1f10
RD		 8229 if (!fields || !GvHV(*fields))
8230 break;
93524f2b 8231 key = SvPV_const(*svp, keylen);
e75d1f10 8232 if (!hv_fetch(GvHV(*fields), key,
bb7a0f54 8233 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
e75d1f10
RD		 8234 {
8235 Perl_croak(aTHX_ "No such class field \"%s\" "
8236 "in variable %s of type %s",
93524f2b 8237 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
e75d1f10
RD		 8238 }
8239
6d822dc4
MS		 8240 break;
8241 }
c750a3ec 8242
e75d1f10
RD		 8243 case OP_HSLICE: {
8244 UNOP *rop;
8245 SV *lexname;
8246 GV **fields;
8247 SV **svp;
93524f2b 8248 const char *key;
e75d1f10
RD		 8249 STRLEN keylen;
8250 SVOP *first_key_op, *key_op;
8251
8252 if ((o->op_private & (OPpLVAL_INTRO))
8253 /* I bet there's always a pushmark... */
8254 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
8255 /* hmmm, no optimization if list contains only one key. */
8256 break;
8257 rop = (UNOP*)((LISTOP*)o)->op_last;
8258 if (rop->op_type != OP_RV2HV)
8259 break;
8260 if (rop->op_first->op_type == OP_PADSV)
8261 /* @$hash{qw(keys here)} */
8262 rop = (UNOP*)rop->op_first;
8263 else {
8264 /* @{$hash}{qw(keys here)} */
8265 if (rop->op_first->op_type == OP_SCOPE
8266 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
8267 {
8268 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
8269 }
8270 else
8271 break;
8272 }
8273
8274 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
00b1698f 8275 if (!SvPAD_TYPED(lexname))
e75d1f10 8276 break;
a4fc7abc 8277 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
e75d1f10
RD		 8278 if (!fields || !GvHV(*fields))
8279 break;
8280 /* Again guessing that the pushmark can be jumped over.... */
8281 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
8282 ->op_first->op_sibling;
8283 for (key_op = first_key_op; key_op;
8284 key_op = (SVOP*)key_op->op_sibling) {
8285 if (key_op->op_type != OP_CONST)
8286 continue;
8287 svp = cSVOPx_svp(key_op);
93524f2b 8288 key = SvPV_const(*svp, keylen);
e75d1f10 8289 if (!hv_fetch(GvHV(*fields), key,
bb7a0f54 8290 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
e75d1f10
RD		 8291 {
8292 Perl_croak(aTHX_ "No such class field \"%s\" "
8293 "in variable %s of type %s",
bfcb3514 8294 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
e75d1f10
RD		 8295 }
8296 }
8297 break;
8298 }
8299
fe1bc4cf 8300 case OP_SORT: {
fe1bc4cf 8301 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
551405c4 8302 OP *oleft;
fe1bc4cf
DM		 8303 OP *o2;
8304
fe1bc4cf 8305 /* check that RHS of sort is a single plain array */
551405c4 8306 OP *oright = cUNOPo->op_first;
fe1bc4cf
DM		 8307 if (!oright || oright->op_type != OP_PUSHMARK)
8308 break;
471178c0
NC		 8309
8310 /* reverse sort ... can be optimised. */
8311 if (!cUNOPo->op_sibling) {
8312 /* Nothing follows us on the list. */
551405c4 8313 OP * const reverse = o->op_next;
471178c0
NC		 8314
8315 if (reverse->op_type == OP_REVERSE &&
8316 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
551405c4 8317 OP * const pushmark = cUNOPx(reverse)->op_first;
471178c0
NC		 8318 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8319 && (cUNOPx(pushmark)->op_sibling == o)) {
8320 /* reverse -> pushmark -> sort */
8321 o->op_private |= OPpSORT_REVERSE;
8322 op_null(reverse);
8323 pushmark->op_next = oright->op_next;
8324 op_null(oright);
8325 }
8326 }
8327 }
8328
8329 /* make @a = sort @a act in-place */
8330
fe1bc4cf
DM		 8331 oright = cUNOPx(oright)->op_sibling;
8332 if (!oright)
8333 break;
8334 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8335 oright = cUNOPx(oright)->op_sibling;
8336 }
8337
8338 if (!oright ||
8339 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8340 || oright->op_next != o
8341 || (oright->op_private & OPpLVAL_INTRO)
8342 )
8343 break;
8344
8345 /* o2 follows the chain of op_nexts through the LHS of the
8346 * assign (if any) to the aassign op itself */
8347 o2 = o->op_next;
8348 if (!o2 || o2->op_type != OP_NULL)
8349 break;
8350 o2 = o2->op_next;
8351 if (!o2 || o2->op_type != OP_PUSHMARK)
8352 break;
8353 o2 = o2->op_next;
8354 if (o2 && o2->op_type == OP_GV)
8355 o2 = o2->op_next;
8356 if (!o2
8357 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8358 || (o2->op_private & OPpLVAL_INTRO)
8359 )
8360 break;
8361 oleft = o2;
8362 o2 = o2->op_next;
8363 if (!o2 || o2->op_type != OP_NULL)
8364 break;
8365 o2 = o2->op_next;
8366 if (!o2 || o2->op_type != OP_AASSIGN
8367 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8368 break;
8369
db7511db
DM		 8370 /* check that the sort is the first arg on RHS of assign */
8371
8372 o2 = cUNOPx(o2)->op_first;
8373 if (!o2 || o2->op_type != OP_NULL)
8374 break;
8375 o2 = cUNOPx(o2)->op_first;
8376 if (!o2 || o2->op_type != OP_PUSHMARK)
8377 break;
8378 if (o2->op_sibling != o)
8379 break;
8380
fe1bc4cf
DM		 8381 /* check the array is the same on both sides */
8382 if (oleft->op_type == OP_RV2AV) {
8383 if (oright->op_type != OP_RV2AV
8384 || !cUNOPx(oright)->op_first
8385 || cUNOPx(oright)->op_first->op_type != OP_GV
8386 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8387 cGVOPx_gv(cUNOPx(oright)->op_first)
8388 )
8389 break;
8390 }
8391 else if (oright->op_type != OP_PADAV
8392 || oright->op_targ != oleft->op_targ
8393 )
8394 break;
8395
8396 /* transfer MODishness etc from LHS arg to RHS arg */
8397 oright->op_flags = oleft->op_flags;
8398 o->op_private |= OPpSORT_INPLACE;
8399
8400 /* excise push->gv->rv2av->null->aassign */
8401 o2 = o->op_next->op_next;
8402 op_null(o2); /* PUSHMARK */
8403 o2 = o2->op_next;
8404 if (o2->op_type == OP_GV) {
8405 op_null(o2); /* GV */
8406 o2 = o2->op_next;
8407 }
8408 op_null(o2); /* RV2AV or PADAV */
8409 o2 = o2->op_next->op_next;
8410 op_null(o2); /* AASSIGN */
8411
8412 o->op_next = o2->op_next;
8413
8414 break;
8415 }
ef3e5ea9
NC		 8416
8417 case OP_REVERSE: {
e682d7b7 8418 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
ce335f37 8419 OP *gvop = NULL;
ef3e5ea9 8420 LISTOP *enter, *exlist;
ef3e5ea9
NC		 8421
8422 enter = (LISTOP *) o->op_next;
8423 if (!enter)
8424 break;
8425 if (enter->op_type == OP_NULL) {
8426 enter = (LISTOP *) enter->op_next;
8427 if (!enter)
8428 break;
8429 }
d46f46af
NC		 8430 /* for $a (...) will have OP_GV then OP_RV2GV here.
8431 for (...) just has an OP_GV. */
ce335f37
NC		 8432 if (enter->op_type == OP_GV) {
8433 gvop = (OP *) enter;
8434 enter = (LISTOP *) enter->op_next;
8435 if (!enter)
8436 break;
d46f46af
NC		 8437 if (enter->op_type == OP_RV2GV) {
8438 enter = (LISTOP *) enter->op_next;
8439 if (!enter)
ce335f37 8440 break;
d46f46af 8441 }
ce335f37
NC		 8442 }
8443
ef3e5ea9
NC		 8444 if (enter->op_type != OP_ENTERITER)
8445 break;
8446
8447 iter = enter->op_next;
8448 if (!iter || iter->op_type != OP_ITER)
8449 break;
8450
ce335f37
NC		 8451 expushmark = enter->op_first;
8452 if (!expushmark || expushmark->op_type != OP_NULL
8453 || expushmark->op_targ != OP_PUSHMARK)
8454 break;
8455
8456 exlist = (LISTOP *) expushmark->op_sibling;
ef3e5ea9
NC		 8457 if (!exlist || exlist->op_type != OP_NULL
8458 || exlist->op_targ != OP_LIST)
8459 break;
8460
8461 if (exlist->op_last != o) {
8462 /* Mmm. Was expecting to point back to this op. */
8463 break;
8464 }
8465 theirmark = exlist->op_first;
8466 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8467 break;
8468
c491ecac 8469 if (theirmark->op_sibling != o) {
ef3e5ea9
NC		 8470 /* There's something between the mark and the reverse, eg
8471 for (1, reverse (...))
8472 so no go. */
8473 break;
8474 }
8475
c491ecac
NC		 8476 ourmark = ((LISTOP *)o)->op_first;
8477 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8478 break;
8479
ef3e5ea9
NC		 8480 ourlast = ((LISTOP *)o)->op_last;
8481 if (!ourlast || ourlast->op_next != o)
8482 break;
8483
e682d7b7
NC		 8484 rv2av = ourmark->op_sibling;
8485 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8486 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8487 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8488 /* We're just reversing a single array. */
8489 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8490 enter->op_flags |= OPf_STACKED;
8491 }
8492
ef3e5ea9
NC		 8493 /* We don't have control over who points to theirmark, so sacrifice
8494 ours. */
8495 theirmark->op_next = ourmark->op_next;
8496 theirmark->op_flags = ourmark->op_flags;
ce335f37 8497 ourlast->op_next = gvop ? gvop : (OP *) enter;
ef3e5ea9
NC		 8498 op_null(ourmark);
8499 op_null(o);
8500 enter->op_private |= OPpITER_REVERSED;
8501 iter->op_private |= OPpITER_REVERSED;
8502
8503 break;
8504 }
e26df76a
NC		 8505
8506 case OP_SASSIGN: {
8507 OP *rv2gv;
8508 UNOP *refgen, *rv2cv;
8509 LISTOP *exlist;
8510
50baa5ea 8511 if ((o->op_flags & OPf_WANT) != OPf_WANT_VOID)
de3370bc
NC		 8512 break;
8513
e26df76a
NC		 8514 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8515 break;
8516
8517 rv2gv = ((BINOP *)o)->op_last;
8518 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8519 break;
8520
8521 refgen = (UNOP *)((BINOP *)o)->op_first;
8522
8523 if (!refgen || refgen->op_type != OP_REFGEN)
8524 break;
8525
8526 exlist = (LISTOP *)refgen->op_first;
8527 if (!exlist || exlist->op_type != OP_NULL
8528 || exlist->op_targ != OP_LIST)
8529 break;
8530
8531 if (exlist->op_first->op_type != OP_PUSHMARK)
8532 break;
8533
8534 rv2cv = (UNOP*)exlist->op_last;
8535
8536 if (rv2cv->op_type != OP_RV2CV)
8537 break;
8538
8539 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8540 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8541 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8542
8543 o->op_private |= OPpASSIGN_CV_TO_GV;
8544 rv2gv->op_private |= OPpDONT_INIT_GV;
8545 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8546
8547 break;
8548 }
8549
fe1bc4cf 8550
0477511c
NC		 8551 case OP_QR:
8552 case OP_MATCH:
29f2e912
NC		 8553 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
8554 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
8555 }
79072805
LW		 8556 break;
8557 }
a0d0e21e 8558 oldop = o;
79072805 8559 }
a0d0e21e 8560 LEAVE;
79072805 8561}
beab0874 8562
cef6ea9d 8563const char*
1cb0ed9b 8564Perl_custom_op_name(pTHX_ const OP* o)
53e06cf0 8565{
97aff369 8566 dVAR;
e1ec3a88 8567 const IV index = PTR2IV(o->op_ppaddr);
53e06cf0
SC		 8568 SV* keysv;
8569 HE* he;
8570
8571 if (!PL_custom_op_names) /* This probably shouldn't happen */
27da23d5 8572 return (char *)PL_op_name[OP_CUSTOM];
53e06cf0
SC		 8573
8574 keysv = sv_2mortal(newSViv(index));
8575
8576 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8577 if (!he)
27da23d5 8578 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
53e06cf0
SC		 8579
8580 return SvPV_nolen(HeVAL(he));
8581}
8582
cef6ea9d 8583const char*
1cb0ed9b 8584Perl_custom_op_desc(pTHX_ const OP* o)
53e06cf0 8585{
97aff369 8586 dVAR;
e1ec3a88 8587 const IV index = PTR2IV(o->op_ppaddr);
53e06cf0
SC		 8588 SV* keysv;
8589 HE* he;
8590
8591 if (!PL_custom_op_descs)
27da23d5 8592 return (char *)PL_op_desc[OP_CUSTOM];
53e06cf0
SC		 8593
8594 keysv = sv_2mortal(newSViv(index));
8595
8596 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8597 if (!he)
27da23d5 8598 return (char *)PL_op_desc[OP_CUSTOM];
53e06cf0
SC		 8599
8600 return SvPV_nolen(HeVAL(he));
8601}
19e8ce8e 8602
beab0874
JT		 8603#include "XSUB.h"
8604
8605/* Efficient sub that returns a constant scalar value. */
8606static void
acfe0abc 8607const_sv_xsub(pTHX_ CV* cv)
beab0874 8608{
97aff369 8609 dVAR;
beab0874 8610 dXSARGS;
9cbac4c7 8611 if (items != 0) {
6f207bd3 8612 NOOP;
9cbac4c7
DM		 8613#if 0
8614 Perl_croak(aTHX_ "usage: %s::%s()",
bfcb3514 8615 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
9cbac4c7
DM		 8616#endif
8617 }
9a049f1c 8618 EXTEND(sp, 1);
0768512c 8619 ST(0) = (SV*)XSANY.any_ptr;
beab0874
JT		 8620 XSRETURN(1);
8621}
4946a0fa
NC		 8622
8623/*
8624 * Local variables:
8625 * c-indentation-style: bsd
8626 * c-basic-offset: 4
8627 * indent-tabs-mode: t
8628 * End:
8629 *
37442d52
RGS		 8630 * ex: set ts=8 sts=4 sw=4 noet:
8631 */
Unnamed repository; edit this file 'description' to name the repository.