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