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