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