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