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
Move autodie from ext/ to cpan/
[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
0d863452
RH		 5197 case OP_ENTERSUB:
5198
5199 case OP_NOT: case OP_XOR:
0d863452
RH		 5200
5201 case OP_EQ: case OP_NE: case OP_LT:
5202 case OP_GT: case OP_LE: case OP_GE:
5203
5204 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
5205 case OP_I_GT: case OP_I_LE: case OP_I_GE:
5206
5207 case OP_SEQ: case OP_SNE: case OP_SLT:
5208 case OP_SGT: case OP_SLE: case OP_SGE:
5209
5210 case OP_SMARTMATCH:
5211
5212 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
5213 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
5214 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
5215 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
5216 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
5217 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
5218 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
5219 case OP_FTTEXT: case OP_FTBINARY:
5220
5221 case OP_DEFINED: case OP_EXISTS:
5222 case OP_MATCH: case OP_EOF:
5223
f118ea0d
RGS		 5224 case OP_FLOP:
5225
0d863452
RH		 5226 return TRUE;
5227
5228 case OP_CONST:
5229 /* Detect comparisons that have been optimized away */
5230 if (cSVOPo->op_sv == &PL_sv_yes
5231 || cSVOPo->op_sv == &PL_sv_no)
5232
5233 return TRUE;
6e03d743
RGS		 5234 else
5235 return FALSE;
6e03d743 5236
0d863452
RH		 5237 /* FALL THROUGH */
5238 default:
5239 return FALSE;
5240 }
5241}
5242
5243OP *
5244Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
5245{
97aff369 5246 dVAR;
7918f24d 5247 PERL_ARGS_ASSERT_NEWGIVENOP;
0d863452
RH		 5248 return newGIVWHENOP(
5249 ref_array_or_hash(cond),
5250 block,
5251 OP_ENTERGIVEN, OP_LEAVEGIVEN,
5252 defsv_off);
5253}
5254
5255/* If cond is null, this is a default {} block */
5256OP *
5257Perl_newWHENOP(pTHX_ OP *cond, OP *block)
5258{
ef519e13 5259 const bool cond_llb = (!cond || looks_like_bool(cond));
0d863452
RH		 5260 OP *cond_op;
5261
7918f24d
NC		 5262 PERL_ARGS_ASSERT_NEWWHENOP;
5263
0d863452
RH		 5264 if (cond_llb)
5265 cond_op = cond;
5266 else {
5267 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
5268 newDEFSVOP(),
5269 scalar(ref_array_or_hash(cond)));
5270 }
5271
5272 return newGIVWHENOP(
5273 cond_op,
5274 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
5275 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
5276}
5277
7dafbf52
DM		 5278/*
5279=for apidoc cv_undef
5280
5281Clear out all the active components of a CV. This can happen either
5282by an explicit C<undef &foo>, or by the reference count going to zero.
5283In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
5284children can still follow the full lexical scope chain.
5285
5286=cut
5287*/
5288
79072805 5289void
864dbfa3 5290Perl_cv_undef(pTHX_ CV *cv)
79072805 5291{
27da23d5 5292 dVAR;
503de470 5293
7918f24d
NC		 5294 PERL_ARGS_ASSERT_CV_UNDEF;
5295
503de470
DM		 5296 DEBUG_X(PerlIO_printf(Perl_debug_log,
5297 "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
5298 PTR2UV(cv), PTR2UV(PL_comppad))
5299 );
5300
a636914a 5301#ifdef USE_ITHREADS
aed2304a 5302 if (CvFILE(cv) && !CvISXSUB(cv)) {
35f1c1c7 5303 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
a636914a 5304 Safefree(CvFILE(cv));
a636914a 5305 }
b3123a61 5306 CvFILE(cv) = NULL;
a636914a
RH		 5307#endif
5308
aed2304a 5309 if (!CvISXSUB(cv) && CvROOT(cv)) {
bb172083 5310 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
cea2e8a9 5311 Perl_croak(aTHX_ "Can't undef active subroutine");
8990e307 5312 ENTER;
a0d0e21e 5313
f3548bdc 5314 PAD_SAVE_SETNULLPAD();
a0d0e21e 5315
282f25c9 5316 op_free(CvROOT(cv));
5f66b61c
AL		 5317 CvROOT(cv) = NULL;
5318 CvSTART(cv) = NULL;
8990e307 5319 LEAVE;
79072805 5320 }
ad64d0ec 5321 SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
a0714e2c 5322 CvGV(cv) = NULL;
a3985cdc
DM		 5323
5324 pad_undef(cv);
5325
7dafbf52
DM		 5326 /* remove CvOUTSIDE unless this is an undef rather than a free */
5327 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
5328 if (!CvWEAKOUTSIDE(cv))
5329 SvREFCNT_dec(CvOUTSIDE(cv));
601f1833 5330 CvOUTSIDE(cv) = NULL;
7dafbf52 5331 }
beab0874 5332 if (CvCONST(cv)) {
ad64d0ec 5333 SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(cv).any_ptr));
beab0874
JT		 5334 CvCONST_off(cv);
5335 }
d04ba589 5336 if (CvISXSUB(cv) && CvXSUB(cv)) {
96a5add6 5337 CvXSUB(cv) = NULL;
50762d59 5338 }
7dafbf52
DM		 5339 /* delete all flags except WEAKOUTSIDE */
5340 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
79072805
LW		 5341}
5342
3fe9a6f1 5343void
cbf82dd0
NC		 5344Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5345 const STRLEN len)
5346{
7918f24d
NC		 5347 PERL_ARGS_ASSERT_CV_CKPROTO_LEN;
5348
cbf82dd0
NC		 5349 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5350 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
5351 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
5352 || (p && (len != SvCUR(cv) /* Not the same length. */
5353 || memNE(p, SvPVX_const(cv), len))))
5354 && ckWARN_d(WARN_PROTOTYPE)) {
2d03de9c 5355 SV* const msg = sv_newmortal();
a0714e2c 5356 SV* name = NULL;
3fe9a6f1 5357
5358 if (gv)
bd61b366 5359 gv_efullname3(name = sv_newmortal(), gv, NULL);
6502358f 5360 sv_setpvs(msg, "Prototype mismatch:");
46fc3d4c 5361 if (name)
be2597df 5362 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
3fe9a6f1 5363 if (SvPOK(cv))
be2597df 5364 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
ebe643b9 5365 else
396482e1
GA		 5366 sv_catpvs(msg, ": none");
5367 sv_catpvs(msg, " vs ");
46fc3d4c 5368 if (p)
cbf82dd0 5369 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
46fc3d4c 5370 else
396482e1 5371 sv_catpvs(msg, "none");
be2597df 5372 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
3fe9a6f1 5373 }
5374}
5375
35f1c1c7
SB		 5376static void const_sv_xsub(pTHX_ CV* cv);
5377
beab0874 5378/*
ccfc67b7
JH		 5379
5380=head1 Optree Manipulation Functions
5381
beab0874
JT		 5382=for apidoc cv_const_sv
5383
5384If C<cv> is a constant sub eligible for inlining. returns the constant
5385value returned by the sub. Otherwise, returns NULL.
5386
5387Constant subs can be created with C<newCONSTSUB> or as described in
5388L<perlsub/"Constant Functions">.
5389
5390=cut
5391*/
760ac839 5392SV *
d45f5b30 5393Perl_cv_const_sv(pTHX_ const CV *const cv)
760ac839 5394{
96a5add6 5395 PERL_UNUSED_CONTEXT;
5069cc75
NC		 5396 if (!cv)
5397 return NULL;
5398 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5399 return NULL;
ad64d0ec 5400 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
fe5e78ed 5401}
760ac839 5402
b5c19bd7
DM		 5403/* op_const_sv: examine an optree to determine whether it's in-lineable.
5404 * Can be called in 3 ways:
5405 *
5406 * !cv
5407 * look for a single OP_CONST with attached value: return the value
5408 *
5409 * cv && CvCLONE(cv) && !CvCONST(cv)
5410 *
5411 * examine the clone prototype, and if contains only a single
5412 * OP_CONST referencing a pad const, or a single PADSV referencing
5413 * an outer lexical, return a non-zero value to indicate the CV is
5414 * a candidate for "constizing" at clone time
5415 *
5416 * cv && CvCONST(cv)
5417 *
5418 * We have just cloned an anon prototype that was marked as a const
5419 * candidiate. Try to grab the current value, and in the case of
5420 * PADSV, ignore it if it has multiple references. Return the value.
5421 */
5422
fe5e78ed 5423SV *
6867be6d 5424Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
fe5e78ed 5425{
97aff369 5426 dVAR;
a0714e2c 5427 SV *sv = NULL;
fe5e78ed 5428
c631f32b
GG		 5429 if (PL_madskills)
5430 return NULL;
5431
0f79a09d 5432 if (!o)
a0714e2c 5433 return NULL;
1c846c1f
NIS		 5434
5435 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
fe5e78ed
GS		 5436 o = cLISTOPo->op_first->op_sibling;
5437
5438 for (; o; o = o->op_next) {
890ce7af 5439 const OPCODE type = o->op_type;
fe5e78ed 5440
1c846c1f 5441 if (sv && o->op_next == o)
fe5e78ed 5442 return sv;
e576b457
JT		 5443 if (o->op_next != o) {
5444 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
5445 continue;
5446 if (type == OP_DBSTATE)
5447 continue;
5448 }
54310121 5449 if (type == OP_LEAVESUB || type == OP_RETURN)
5450 break;
5451 if (sv)
a0714e2c 5452 return NULL;
7766f137 5453 if (type == OP_CONST && cSVOPo->op_sv)
5dc0d613 5454 sv = cSVOPo->op_sv;
b5c19bd7 5455 else if (cv && type == OP_CONST) {
dd2155a4 5456 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
beab0874 5457 if (!sv)
a0714e2c 5458 return NULL;
b5c19bd7
DM		 5459 }
5460 else if (cv && type == OP_PADSV) {
5461 if (CvCONST(cv)) { /* newly cloned anon */
5462 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5463 /* the candidate should have 1 ref from this pad and 1 ref
5464 * from the parent */
5465 if (!sv || SvREFCNT(sv) != 2)
a0714e2c 5466 return NULL;
beab0874 5467 sv = newSVsv(sv);
b5c19bd7
DM		 5468 SvREADONLY_on(sv);
5469 return sv;
5470 }
5471 else {
5472 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
5473 sv = &PL_sv_undef; /* an arbitrary non-null value */
beab0874 5474 }
760ac839 5475 }
b5c19bd7 5476 else {
a0714e2c 5477 return NULL;
b5c19bd7 5478 }
760ac839
LW		 5479 }
5480 return sv;
5481}
5482
eb8433b7
NC		 5483#ifdef PERL_MAD
5484OP *
5485#else
09bef843 5486void
eb8433b7 5487#endif
09bef843
SB		 5488Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5489{
99129197
NC		 5490#if 0
5491 /* This would be the return value, but the return cannot be reached. */
eb8433b7
NC		 5492 OP* pegop = newOP(OP_NULL, 0);
5493#endif
5494
46c461b5
AL		 5495 PERL_UNUSED_ARG(floor);
5496
09bef843
SB		 5497 if (o)
5498 SAVEFREEOP(o);
5499 if (proto)
5500 SAVEFREEOP(proto);
5501 if (attrs)
5502 SAVEFREEOP(attrs);
5503 if (block)
5504 SAVEFREEOP(block);
5505 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
eb8433b7 5506#ifdef PERL_MAD
99129197 5507 NORETURN_FUNCTION_END;
eb8433b7 5508#endif
09bef843
SB		 5509}
5510
748a9306 5511CV *
864dbfa3 5512Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
79072805 5513{
5f66b61c 5514 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
09bef843
SB		 5515}
5516
5517CV *
5518Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5519{
27da23d5 5520 dVAR;
83ee9e09 5521 GV *gv;
5c144d81 5522 const char *ps;
ea6e9374 5523 STRLEN ps_len;
c445ea15 5524 register CV *cv = NULL;
beab0874 5525 SV *const_sv;
b48b272a
NC		 5526 /* If the subroutine has no body, no attributes, and no builtin attributes
5527 then it's just a sub declaration, and we may be able to get away with
5528 storing with a placeholder scalar in the symbol table, rather than a
5529 full GV and CV. If anything is present then it will take a full CV to
5530 store it. */
5531 const I32 gv_fetch_flags
eb8433b7
NC		 5532 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5533 || PL_madskills)
b48b272a 5534 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
4ea561bc 5535 const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
ed4a8a9b 5536 bool has_name;
8e742a20
MHM		 5537
5538 if (proto) {
5539 assert(proto->op_type == OP_CONST);
4ea561bc 5540 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
8e742a20
MHM		 5541 }
5542 else
bd61b366 5543 ps = NULL;
8e742a20 5544
ed4a8a9b
NC		 5545 if (name) {
5546 gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
5547 has_name = TRUE;
5548 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
aec46f14 5549 SV * const sv = sv_newmortal();
c99da370
JH		 5550 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5551 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
83ee9e09 5552 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
ed4a8a9b
NC		 5553 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
5554 has_name = TRUE;
c1754fce
NC		 5555 } else if (PL_curstash) {
5556 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
ed4a8a9b 5557 has_name = FALSE;
c1754fce
NC		 5558 } else {
5559 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
ed4a8a9b 5560 has_name = FALSE;
c1754fce 5561 }
83ee9e09 5562
eb8433b7
NC		 5563 if (!PL_madskills) {
5564 if (o)
5565 SAVEFREEOP(o);
5566 if (proto)
5567 SAVEFREEOP(proto);
5568 if (attrs)
5569 SAVEFREEOP(attrs);
5570 }
3fe9a6f1 5571
09bef843 5572 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
55d729e4
GS		 5573 maximum a prototype before. */
5574 if (SvTYPE(gv) > SVt_NULL) {
ad64d0ec
NC		 5575 if (!SvPOK((const SV *)gv)
5576 && !(SvIOK((const SV *)gv) && SvIVX((const SV *)gv) == -1)
e476b1b5 5577 && ckWARN_d(WARN_PROTOTYPE))
f248d071 5578 {
9014280d 5579 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
f248d071 5580 }
ea726b52 5581 cv_ckproto_len((const CV *)gv, NULL, ps, ps_len);
55d729e4
GS		 5582 }
5583 if (ps)
ad64d0ec 5584 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
55d729e4 5585 else
ad64d0ec 5586 sv_setiv(MUTABLE_SV(gv), -1);
e1a479c5 5587
3280af22
NIS		 5588 SvREFCNT_dec(PL_compcv);
5589 cv = PL_compcv = NULL;
beab0874 5590 goto done;
55d729e4
GS		 5591 }
5592
601f1833 5593 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
beab0874 5594
eb8433b7
NC		 5595 if (!block || !ps || *ps || attrs
5596 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5597#ifdef PERL_MAD
5598 || block->op_type == OP_NULL
5599#endif
5600 )
a0714e2c 5601 const_sv = NULL;
beab0874 5602 else
601f1833 5603 const_sv = op_const_sv(block, NULL);
beab0874
JT		 5604
5605 if (cv) {
6867be6d 5606 const bool exists = CvROOT(cv) || CvXSUB(cv);
5bd07a3d 5607
60ed1d8c
GS		 5608 /* if the subroutine doesn't exist and wasn't pre-declared
5609 * with a prototype, assume it will be AUTOLOADed,
5610 * skipping the prototype check
5611 */
5612 if (exists || SvPOK(cv))
cbf82dd0 5613 cv_ckproto_len(cv, gv, ps, ps_len);
68dc0745 5614 /* already defined (or promised)? */
60ed1d8c 5615 if (exists || GvASSUMECV(gv)) {
eb8433b7
NC		 5616 if ((!block
5617#ifdef PERL_MAD
5618 || block->op_type == OP_NULL
5619#endif
5620 )&& !attrs) {
d3cea301
SB		 5621 if (CvFLAGS(PL_compcv)) {
5622 /* might have had built-in attrs applied */
5623 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5624 }
aa689395 5625 /* just a "sub foo;" when &foo is already defined */
3280af22 5626 SAVEFREESV(PL_compcv);
aa689395 5627 goto done;
5628 }
eb8433b7
NC		 5629 if (block
5630#ifdef PERL_MAD
5631 && block->op_type != OP_NULL
5632#endif
5633 ) {
beab0874
JT		 5634 if (ckWARN(WARN_REDEFINE)
5635 || (CvCONST(cv)
5636 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5637 {
6867be6d 5638 const line_t oldline = CopLINE(PL_curcop);
53a7735b
DM		 5639 if (PL_parser && PL_parser->copline != NOLINE)
5640 CopLINE_set(PL_curcop, PL_parser->copline);
9014280d 5641 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
666ea192
JH		 5642 CvCONST(cv) ? "Constant subroutine %s redefined"
5643 : "Subroutine %s redefined", name);
beab0874
JT		 5644 CopLINE_set(PL_curcop, oldline);
5645 }
eb8433b7
NC		 5646#ifdef PERL_MAD
5647 if (!PL_minus_c) /* keep old one around for madskills */
5648#endif
5649 {
5650 /* (PL_madskills unset in used file.) */
5651 SvREFCNT_dec(cv);
5652 }
601f1833 5653 cv = NULL;
79072805 5654 }
79072805
LW		 5655 }
5656 }
beab0874 5657 if (const_sv) {
f84c484e 5658 SvREFCNT_inc_simple_void_NN(const_sv);
beab0874 5659 if (cv) {
0768512c 5660 assert(!CvROOT(cv) && !CvCONST(cv));
ad64d0ec 5661 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
beab0874
JT		 5662 CvXSUBANY(cv).any_ptr = const_sv;
5663 CvXSUB(cv) = const_sv_xsub;
5664 CvCONST_on(cv);
d04ba589 5665 CvISXSUB_on(cv);
beab0874
JT		 5666 }
5667 else {
601f1833 5668 GvCV(gv) = NULL;
beab0874
JT		 5669 cv = newCONSTSUB(NULL, name, const_sv);
5670 }
e1a479c5
BB		 5671 mro_method_changed_in( /* sub Foo::Bar () { 123 } */
5672 (CvGV(cv) && GvSTASH(CvGV(cv)))
5673 ? GvSTASH(CvGV(cv))
5674 : CvSTASH(cv)
5675 ? CvSTASH(cv)
5676 : PL_curstash
5677 );
eb8433b7
NC		 5678 if (PL_madskills)
5679 goto install_block;
beab0874
JT		 5680 op_free(block);
5681 SvREFCNT_dec(PL_compcv);
5682 PL_compcv = NULL;
beab0874
JT		 5683 goto done;
5684 }
09330df8
Z		 5685 if (cv) { /* must reuse cv if autoloaded */
5686 /* transfer PL_compcv to cv */
5687 if (block
eb8433b7 5688#ifdef PERL_MAD
09330df8 5689 && block->op_type != OP_NULL
eb8433b7 5690#endif
09330df8
Z		 5691 ) {
5692 cv_undef(cv);
5693 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5694 if (!CvWEAKOUTSIDE(cv))
5695 SvREFCNT_dec(CvOUTSIDE(cv));
5696 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5697 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5698 CvOUTSIDE(PL_compcv) = 0;
5699 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5700 CvPADLIST(PL_compcv) = 0;
5701 /* inner references to PL_compcv must be fixed up ... */
5702 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5703 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5704 ++PL_sub_generation;
09bef843
SB		 5705 }
5706 else {
09330df8
Z		 5707 /* Might have had built-in attributes applied -- propagate them. */
5708 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
09bef843 5709 }
282f25c9 5710 /* ... before we throw it away */
3280af22 5711 SvREFCNT_dec(PL_compcv);
b5c19bd7 5712 PL_compcv = cv;
a0d0e21e
LW		 5713 }
5714 else {
3280af22 5715 cv = PL_compcv;
44a8e56a 5716 if (name) {
5717 GvCV(gv) = cv;
eb8433b7
NC		 5718 if (PL_madskills) {
5719 if (strEQ(name, "import")) {
ad64d0ec 5720 PL_formfeed = MUTABLE_SV(cv);
eb8433b7
NC		 5721 Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5722 }
5723 }
44a8e56a 5724 GvCVGEN(gv) = 0;
e1a479c5 5725 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
44a8e56a 5726 }
a0d0e21e 5727 }
09330df8
Z		 5728 if (!CvGV(cv)) {
5729 CvGV(cv) = gv;
5730 CvFILE_set_from_cop(cv, PL_curcop);
5731 CvSTASH(cv) = PL_curstash;
5732 }
5733 if (attrs) {
5734 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
5735 HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
5736 apply_attrs(stash, MUTABLE_SV(cv), attrs, FALSE);
5737 }
8990e307 5738
3fe9a6f1 5739 if (ps)
ad64d0ec 5740 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
4633a7c4 5741
13765c85 5742 if (PL_parser && PL_parser->error_count) {
c07a80fd 5743 op_free(block);
5f66b61c 5744 block = NULL;
68dc0745 5745 if (name) {
6867be6d 5746 const char *s = strrchr(name, ':');
68dc0745 5747 s = s ? s+1 : name;
6d4c2119 5748 if (strEQ(s, "BEGIN")) {
e1ec3a88 5749 const char not_safe[] =
6d4c2119 5750 "BEGIN not safe after errors--compilation aborted";
faef0170 5751 if (PL_in_eval & EVAL_KEEPERR)
cea2e8a9 5752 Perl_croak(aTHX_ not_safe);
6d4c2119
CS		 5753 else {
5754 /* force display of errors found but not reported */
38a03e6e 5755 sv_catpv(ERRSV, not_safe);
be2597df 5756 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
6d4c2119
CS		 5757 }
5758 }
68dc0745 5759 }
c07a80fd 5760 }
eb8433b7 5761 install_block:
beab0874
JT		 5762 if (!block)
5763 goto done;
a0d0e21e 5764
aac018bb
NC		 5765 /* If we assign an optree to a PVCV, then we've defined a subroutine that
5766 the debugger could be able to set a breakpoint in, so signal to
5767 pp_entereval that it should not throw away any saved lines at scope
5768 exit. */
5769
fd06b02c 5770 PL_breakable_sub_gen++;
7766f137 5771 if (CvLVALUE(cv)) {
78f9721b
SM		 5772 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5773 mod(scalarseq(block), OP_LEAVESUBLV));
7e5d8ed2 5774 block->op_attached = 1;
7766f137
GS		 5775 }
5776 else {
09c2fd24
AE		 5777 /* This makes sub {}; work as expected. */
5778 if (block->op_type == OP_STUB) {
1496a290 5779 OP* const newblock = newSTATEOP(0, NULL, 0);
eb8433b7
NC		 5780#ifdef PERL_MAD
5781 op_getmad(block,newblock,'B');
5782#else
09c2fd24 5783 op_free(block);
eb8433b7
NC		 5784#endif
5785 block = newblock;
09c2fd24 5786 }
7e5d8ed2
DM		 5787 else
5788 block->op_attached = 1;
7766f137
GS		 5789 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5790 }
5791 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5792 OpREFCNT_set(CvROOT(cv), 1);
5793 CvSTART(cv) = LINKLIST(CvROOT(cv));
5794 CvROOT(cv)->op_next = 0;
a2efc822 5795 CALL_PEEP(CvSTART(cv));
7766f137
GS		 5796
5797 /* now that optimizer has done its work, adjust pad values */
54310121 5798
dd2155a4
DM		 5799 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5800
5801 if (CvCLONE(cv)) {
beab0874
JT		 5802 assert(!CvCONST(cv));
5803 if (ps && !*ps && op_const_sv(block, cv))
5804 CvCONST_on(cv);
a0d0e21e 5805 }
79072805 5806
ed4a8a9b 5807 if (has_name) {
3280af22 5808 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
561b68a9 5809 SV * const sv = newSV(0);
c4420975 5810 SV * const tmpstr = sv_newmortal();
5c1737d1
NC		 5811 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5812 GV_ADDMULTI, SVt_PVHV);
44a8e56a 5813 HV *hv;
5814
ed094faf
GS		 5815 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5816 CopFILE(PL_curcop),
cc49e20b 5817 (long)PL_subline, (long)CopLINE(PL_curcop));
bd61b366 5818 gv_efullname3(tmpstr, gv, NULL);
04fe65b0
RGS		 5819 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
5820 SvCUR(tmpstr), sv, 0);
44a8e56a 5821 hv = GvHVn(db_postponed);
551405c4
AL		 5822 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5823 CV * const pcv = GvCV(db_postponed);
5824 if (pcv) {
5825 dSP;
5826 PUSHMARK(SP);
5827 XPUSHs(tmpstr);
5828 PUTBACK;
ad64d0ec 5829 call_sv(MUTABLE_SV(pcv), G_DISCARD);
551405c4 5830 }
44a8e56a 5831 }
5832 }
79072805 5833
13765c85 5834 if (name && ! (PL_parser && PL_parser->error_count))
0cd10f52 5835 process_special_blocks(name, gv, cv);
33fb7a6e 5836 }
ed094faf 5837
33fb7a6e 5838 done:
53a7735b
DM		 5839 if (PL_parser)
5840 PL_parser->copline = NOLINE;
33fb7a6e
NC		 5841 LEAVE_SCOPE(floor);
5842 return cv;
5843}
ed094faf 5844
33fb7a6e
NC		 5845STATIC void
5846S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
5847 CV *const cv)
5848{
5849 const char *const colon = strrchr(fullname,':');
5850 const char *const name = colon ? colon + 1 : fullname;
5851
7918f24d
NC		 5852 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
5853
33fb7a6e 5854 if (*name == 'B') {
6952d67e 5855 if (strEQ(name, "BEGIN")) {
6867be6d 5856 const I32 oldscope = PL_scopestack_ix;
28757baa 5857 ENTER;
57843af0
GS		 5858 SAVECOPFILE(&PL_compiling);
5859 SAVECOPLINE(&PL_compiling);
28757baa 5860
a58fb6f9 5861 DEBUG_x( dump_sub(gv) );
ad64d0ec 5862 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
ea2f84a3 5863 GvCV(gv) = 0; /* cv has been hijacked */
3280af22 5864 call_list(oldscope, PL_beginav);
a6006777 5865
3280af22 5866 PL_curcop = &PL_compiling;
623e6609 5867 CopHINTS_set(&PL_compiling, PL_hints);
28757baa 5868 LEAVE;
5869 }
33fb7a6e
NC		 5870 else
5871 return;
5872 } else {
5873 if (*name == 'E') {
5874 if strEQ(name, "END") {
a58fb6f9 5875 DEBUG_x( dump_sub(gv) );
ad64d0ec 5876 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
33fb7a6e
NC		 5877 } else
5878 return;
5879 } else if (*name == 'U') {
5880 if (strEQ(name, "UNITCHECK")) {
5881 /* It's never too late to run a unitcheck block */
ad64d0ec 5882 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
33fb7a6e
NC		 5883 }
5884 else
5885 return;
5886 } else if (*name == 'C') {
5887 if (strEQ(name, "CHECK")) {
5888 if (PL_main_start && ckWARN(WARN_VOID))
5889 Perl_warner(aTHX_ packWARN(WARN_VOID),
5890 "Too late to run CHECK block");
ad64d0ec 5891 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
33fb7a6e
NC		 5892 }
5893 else
5894 return;
5895 } else if (*name == 'I') {
5896 if (strEQ(name, "INIT")) {
5897 if (PL_main_start && ckWARN(WARN_VOID))
5898 Perl_warner(aTHX_ packWARN(WARN_VOID),
5899 "Too late to run INIT block");
ad64d0ec 5900 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
33fb7a6e
NC		 5901 }
5902 else
5903 return;
5904 } else
5905 return;
a58fb6f9 5906 DEBUG_x( dump_sub(gv) );
33fb7a6e 5907 GvCV(gv) = 0; /* cv has been hijacked */
79072805 5908 }
79072805
LW		 5909}
5910
954c1994
GS		 5911/*
5912=for apidoc newCONSTSUB
5913
5914Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5915eligible for inlining at compile-time.
5916
99ab892b
NC		 5917Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
5918which won't be called if used as a destructor, but will suppress the overhead
5919of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
5920compile time.)
5921
954c1994
GS		 5922=cut
5923*/
5924
beab0874 5925CV *
e1ec3a88 5926Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5476c433 5927{
27da23d5 5928 dVAR;
beab0874 5929 CV* cv;
cbf82dd0 5930#ifdef USE_ITHREADS
54d012c6 5931 const char *const file = CopFILE(PL_curcop);
cbf82dd0
NC		 5932#else
5933 SV *const temp_sv = CopFILESV(PL_curcop);
def18e4c 5934 const char *const file = temp_sv ? SvPV_nolen_const(temp_sv) : NULL;
cbf82dd0 5935#endif
5476c433 5936
11faa288 5937 ENTER;
11faa288 5938
401667e9
DM		 5939 if (IN_PERL_RUNTIME) {
5940 /* at runtime, it's not safe to manipulate PL_curcop: it may be
5941 * an op shared between threads. Use a non-shared COP for our
5942 * dirty work */
5943 SAVEVPTR(PL_curcop);
5944 PL_curcop = &PL_compiling;
5945 }
f4dd75d9 5946 SAVECOPLINE(PL_curcop);
53a7735b 5947 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
f4dd75d9
GS		 5948
5949 SAVEHINTS();
3280af22 5950 PL_hints &= ~HINT_BLOCK_SCOPE;
11faa288
GS		 5951
5952 if (stash) {
5953 SAVESPTR(PL_curstash);
5954 SAVECOPSTASH(PL_curcop);
5955 PL_curstash = stash;
05ec9bb3 5956 CopSTASH_set(PL_curcop,stash);
11faa288 5957 }
5476c433 5958
cbf82dd0
NC		 5959 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
5960 and so doesn't get free()d. (It's expected to be from the C pre-
5961 processor __FILE__ directive). But we need a dynamically allocated one,
77004dee 5962 and we need it to get freed. */
54d012c6
NC		 5963 cv = newXS_flags(name, const_sv_xsub, file ? file : "", "",
5964 XS_DYNAMIC_FILENAME);
beab0874
JT		 5965 CvXSUBANY(cv).any_ptr = sv;
5966 CvCONST_on(cv);
5476c433 5967
65e66c80 5968#ifdef USE_ITHREADS
02f28d44
MHM		 5969 if (stash)
5970 CopSTASH_free(PL_curcop);
65e66c80 5971#endif
11faa288 5972 LEAVE;
beab0874
JT		 5973
5974 return cv;
5476c433
JD		 5975}
5976
77004dee
NC		 5977CV *
5978Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
5979 const char *const filename, const char *const proto,
5980 U32 flags)
5981{
5982 CV *cv = newXS(name, subaddr, filename);
5983
7918f24d
NC		 5984 PERL_ARGS_ASSERT_NEWXS_FLAGS;
5985
77004dee
NC		 5986 if (flags & XS_DYNAMIC_FILENAME) {
5987 /* We need to "make arrangements" (ie cheat) to ensure that the
5988 filename lasts as long as the PVCV we just created, but also doesn't
5989 leak */
5990 STRLEN filename_len = strlen(filename);
5991 STRLEN proto_and_file_len = filename_len;
5992 char *proto_and_file;
5993 STRLEN proto_len;
5994
5995 if (proto) {
5996 proto_len = strlen(proto);
5997 proto_and_file_len += proto_len;
5998
5999 Newx(proto_and_file, proto_and_file_len + 1, char);
6000 Copy(proto, proto_and_file, proto_len, char);
6001 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
6002 } else {
6003 proto_len = 0;
6004 proto_and_file = savepvn(filename, filename_len);
6005 }
6006
6007 /* This gets free()d. :-) */
ad64d0ec 6008 sv_usepvn_flags(MUTABLE_SV(cv), proto_and_file, proto_and_file_len,
77004dee
NC		 6009 SV_HAS_TRAILING_NUL);
6010 if (proto) {
6011 /* This gives us the correct prototype, rather than one with the
6012 file name appended. */
6013 SvCUR_set(cv, proto_len);
6014 } else {
6015 SvPOK_off(cv);
6016 }
81a2b3b6 6017 CvFILE(cv) = proto_and_file + proto_len;
77004dee 6018 } else {
ad64d0ec 6019 sv_setpv(MUTABLE_SV(cv), proto);
77004dee
NC		 6020 }
6021 return cv;
6022}
6023
954c1994
GS		 6024/*
6025=for apidoc U||newXS
6026
77004dee
NC		 6027Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
6028static storage, as it is used directly as CvFILE(), without a copy being made.
954c1994
GS		 6029
6030=cut
6031*/
6032
57d3b86d 6033CV *
bfed75c6 6034Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
a0d0e21e 6035{
97aff369 6036 dVAR;
666ea192
JH		 6037 GV * const gv = gv_fetchpv(name ? name :
6038 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
6039 GV_ADDMULTI, SVt_PVCV);
79072805 6040 register CV *cv;
44a8e56a 6041
7918f24d
NC		 6042 PERL_ARGS_ASSERT_NEWXS;
6043
1ecdd9a8
HS		 6044 if (!subaddr)
6045 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
6046
601f1833 6047 if ((cv = (name ? GvCV(gv) : NULL))) {
44a8e56a 6048 if (GvCVGEN(gv)) {
6049 /* just a cached method */
6050 SvREFCNT_dec(cv);
601f1833 6051 cv = NULL;
44a8e56a 6052 }
6053 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
6054 /* already defined (or promised) */
1df70142 6055 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
66a1b24b
AL		 6056 if (ckWARN(WARN_REDEFINE)) {
6057 GV * const gvcv = CvGV(cv);
6058 if (gvcv) {
6059 HV * const stash = GvSTASH(gvcv);
6060 if (stash) {
8b38226b
AL		 6061 const char *redefined_name = HvNAME_get(stash);
6062 if ( strEQ(redefined_name,"autouse") ) {
66a1b24b 6063 const line_t oldline = CopLINE(PL_curcop);
53a7735b
DM		 6064 if (PL_parser && PL_parser->copline != NOLINE)
6065 CopLINE_set(PL_curcop, PL_parser->copline);
66a1b24b 6066 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
666ea192
JH		 6067 CvCONST(cv) ? "Constant subroutine %s redefined"
6068 : "Subroutine %s redefined"
6069 ,name);
66a1b24b
AL		 6070 CopLINE_set(PL_curcop, oldline);
6071 }
6072 }
6073 }
a0d0e21e
LW		 6074 }
6075 SvREFCNT_dec(cv);
601f1833 6076 cv = NULL;
79072805 6077 }
79072805 6078 }
44a8e56a 6079
6080 if (cv) /* must reuse cv if autoloaded */
6081 cv_undef(cv);
a0d0e21e 6082 else {
ea726b52 6083 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
44a8e56a 6084 if (name) {
6085 GvCV(gv) = cv;
6086 GvCVGEN(gv) = 0;
e1a479c5 6087 mro_method_changed_in(GvSTASH(gv)); /* newXS */
44a8e56a 6088 }
a0d0e21e 6089 }
65c50114 6090 CvGV(cv) = gv;
b195d487 6091 (void)gv_fetchfile(filename);
dd374669 6092 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
57843af0 6093 an external constant string */
d04ba589 6094 CvISXSUB_on(cv);
a0d0e21e 6095 CvXSUB(cv) = subaddr;
44a8e56a 6096
33fb7a6e
NC		 6097 if (name)
6098 process_special_blocks(name, gv, cv);
8990e307 6099 else
a5f75d66 6100 CvANON_on(cv);
44a8e56a 6101
a0d0e21e 6102 return cv;
79072805
LW		 6103}
6104
eb8433b7
NC		 6105#ifdef PERL_MAD
6106OP *
6107#else
79072805 6108void
eb8433b7 6109#endif
864dbfa3 6110Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
79072805 6111{
97aff369 6112 dVAR;
79072805 6113 register CV *cv;
eb8433b7
NC		 6114#ifdef PERL_MAD
6115 OP* pegop = newOP(OP_NULL, 0);
6116#endif
79072805 6117
0bd48802 6118 GV * const gv = o
f776e3cd 6119 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
fafc274c 6120 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
0bd48802 6121
a5f75d66 6122 GvMULTI_on(gv);
155aba94 6123 if ((cv = GvFORM(gv))) {
599cee73 6124 if (ckWARN(WARN_REDEFINE)) {
6867be6d 6125 const line_t oldline = CopLINE(PL_curcop);
53a7735b
DM		 6126 if (PL_parser && PL_parser->copline != NOLINE)
6127 CopLINE_set(PL_curcop, PL_parser->copline);
ee6d2783
NC		 6128 if (o) {
6129 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6130 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
6131 } else {
6132 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6133 "Format STDOUT redefined");
6134 }
57843af0 6135 CopLINE_set(PL_curcop, oldline);
79072805 6136 }
8990e307 6137 SvREFCNT_dec(cv);
79072805 6138 }
3280af22 6139 cv = PL_compcv;
79072805 6140 GvFORM(gv) = cv;
65c50114 6141 CvGV(cv) = gv;
a636914a 6142 CvFILE_set_from_cop(cv, PL_curcop);
79072805 6143
a0d0e21e 6144
dd2155a4 6145 pad_tidy(padtidy_FORMAT);
79072805 6146 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
7934575e
GS		 6147 CvROOT(cv)->op_private |= OPpREFCOUNTED;
6148 OpREFCNT_set(CvROOT(cv), 1);
79072805
LW		 6149 CvSTART(cv) = LINKLIST(CvROOT(cv));
6150 CvROOT(cv)->op_next = 0;
a2efc822 6151 CALL_PEEP(CvSTART(cv));
eb8433b7
NC		 6152#ifdef PERL_MAD
6153 op_getmad(o,pegop,'n');
6154 op_getmad_weak(block, pegop, 'b');
6155#else
11343788 6156 op_free(o);
eb8433b7 6157#endif
53a7735b
DM		 6158 if (PL_parser)
6159 PL_parser->copline = NOLINE;
8990e307 6160 LEAVE_SCOPE(floor);
eb8433b7
NC		 6161#ifdef PERL_MAD
6162 return pegop;
6163#endif
79072805
LW		 6164}
6165
6166OP *
864dbfa3 6167Perl_newANONLIST(pTHX_ OP *o)
79072805 6168{
78c72037 6169 return convert(OP_ANONLIST, OPf_SPECIAL, o);
79072805
LW		 6170}
6171
6172OP *
864dbfa3 6173Perl_newANONHASH(pTHX_ OP *o)
79072805 6174{
78c72037 6175 return convert(OP_ANONHASH, OPf_SPECIAL, o);
a0d0e21e
LW		 6176}
6177
6178OP *
864dbfa3 6179Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
a0d0e21e 6180{
5f66b61c 6181 return newANONATTRSUB(floor, proto, NULL, block);
09bef843
SB		 6182}
6183
6184OP *
6185Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
6186{
a0d0e21e 6187 return newUNOP(OP_REFGEN, 0,
09bef843 6188 newSVOP(OP_ANONCODE, 0,
ad64d0ec 6189 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
79072805
LW		 6190}
6191
6192OP *
864dbfa3 6193Perl_oopsAV(pTHX_ OP *o)
79072805 6194{
27da23d5 6195 dVAR;
7918f24d
NC		 6196
6197 PERL_ARGS_ASSERT_OOPSAV;
6198
ed6116ce
LW		 6199 switch (o->op_type) {
6200 case OP_PADSV:
6201 o->op_type = OP_PADAV;
22c35a8c 6202 o->op_ppaddr = PL_ppaddr[OP_PADAV];
51e247a3 6203 return ref(o, OP_RV2AV);
b2ffa427 6204
ed6116ce 6205 case OP_RV2SV:
79072805 6206 o->op_type = OP_RV2AV;
22c35a8c 6207 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
79072805 6208 ref(o, OP_RV2AV);
ed6116ce
LW		 6209 break;
6210
6211 default:
0453d815 6212 if (ckWARN_d(WARN_INTERNAL))
9014280d 6213 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
ed6116ce
LW		 6214 break;
6215 }
79072805
LW		 6216 return o;
6217}
6218
6219OP *
864dbfa3 6220Perl_oopsHV(pTHX_ OP *o)
79072805 6221{
27da23d5 6222 dVAR;
7918f24d
NC		 6223
6224 PERL_ARGS_ASSERT_OOPSHV;
6225
ed6116ce
LW		 6226 switch (o->op_type) {
6227 case OP_PADSV:
6228 case OP_PADAV:
6229 o->op_type = OP_PADHV;
22c35a8c 6230 o->op_ppaddr = PL_ppaddr[OP_PADHV];
51e247a3 6231 return ref(o, OP_RV2HV);
ed6116ce
LW		 6232
6233 case OP_RV2SV:
6234 case OP_RV2AV:
79072805 6235 o->op_type = OP_RV2HV;
22c35a8c 6236 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
79072805 6237 ref(o, OP_RV2HV);
ed6116ce
LW		 6238 break;
6239
6240 default:
0453d815 6241 if (ckWARN_d(WARN_INTERNAL))
9014280d 6242 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
ed6116ce
LW		 6243 break;
6244 }
79072805
LW		 6245 return o;
6246}
6247
6248OP *
864dbfa3 6249Perl_newAVREF(pTHX_ OP *o)
79072805 6250{
27da23d5 6251 dVAR;
7918f24d
NC		 6252
6253 PERL_ARGS_ASSERT_NEWAVREF;
6254
ed6116ce
LW		 6255 if (o->op_type == OP_PADANY) {
6256 o->op_type = OP_PADAV;
22c35a8c 6257 o->op_ppaddr = PL_ppaddr[OP_PADAV];
93a17b20 6258 return o;
ed6116ce 6259 }
a1063b2d 6260 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
9014280d
PM		 6261 && ckWARN(WARN_DEPRECATED)) {
6262 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
a1063b2d
RH		 6263 "Using an array as a reference is deprecated");
6264 }
79072805
LW		 6265 return newUNOP(OP_RV2AV, 0, scalar(o));
6266}
6267
6268OP *
864dbfa3 6269Perl_newGVREF(pTHX_ I32 type, OP *o)
79072805 6270{
82092f1d 6271 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
a0d0e21e 6272 return newUNOP(OP_NULL, 0, o);
748a9306 6273 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
79072805
LW		 6274}
6275
6276OP *
864dbfa3 6277Perl_newHVREF(pTHX_ OP *o)
79072805 6278{
27da23d5 6279 dVAR;
7918f24d
NC		 6280
6281 PERL_ARGS_ASSERT_NEWHVREF;
6282
ed6116ce
LW		 6283 if (o->op_type == OP_PADANY) {
6284 o->op_type = OP_PADHV;
22c35a8c 6285 o->op_ppaddr = PL_ppaddr[OP_PADHV];
93a17b20 6286 return o;
ed6116ce 6287 }
a1063b2d 6288 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
9014280d
PM		 6289 && ckWARN(WARN_DEPRECATED)) {
6290 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
a1063b2d
RH		 6291 "Using a hash as a reference is deprecated");
6292 }
79072805
LW		 6293 return newUNOP(OP_RV2HV, 0, scalar(o));
6294}
6295
6296OP *
864dbfa3 6297Perl_newCVREF(pTHX_ I32 flags, OP *o)
79072805 6298{
c07a80fd 6299 return newUNOP(OP_RV2CV, flags, scalar(o));
79072805
LW		 6300}
6301
6302OP *
864dbfa3 6303Perl_newSVREF(pTHX_ OP *o)
79072805 6304{
27da23d5 6305 dVAR;
7918f24d
NC		 6306
6307 PERL_ARGS_ASSERT_NEWSVREF;
6308
ed6116ce
LW		 6309 if (o->op_type == OP_PADANY) {
6310 o->op_type = OP_PADSV;
22c35a8c 6311 o->op_ppaddr = PL_ppaddr[OP_PADSV];
93a17b20 6312 return o;
ed6116ce 6313 }
79072805
LW		 6314 return newUNOP(OP_RV2SV, 0, scalar(o));
6315}
6316
61b743bb
DM		 6317/* Check routines. See the comments at the top of this file for details
6318 * on when these are called */
79072805
LW		 6319
6320OP *
cea2e8a9 6321Perl_ck_anoncode(pTHX_ OP *o)
5f05dabc 6322{
7918f24d
NC		 6323 PERL_ARGS_ASSERT_CK_ANONCODE;
6324
dd2155a4 6325 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
eb8433b7 6326 if (!PL_madskills)
1d866c12 6327 cSVOPo->op_sv = NULL;
5dc0d613 6328 return o;
5f05dabc 6329}
6330
6331OP *
cea2e8a9 6332Perl_ck_bitop(pTHX_ OP *o)
55497cff 6333{
97aff369 6334 dVAR;
7918f24d
NC		 6335
6336 PERL_ARGS_ASSERT_CK_BITOP;
6337
276b2a0c
RGS		 6338#define OP_IS_NUMCOMPARE(op) \
6339 ((op) == OP_LT || (op) == OP_I_LT || \
6340 (op) == OP_GT || (op) == OP_I_GT || \
6341 (op) == OP_LE || (op) == OP_I_LE || \
6342 (op) == OP_GE || (op) == OP_I_GE || \
6343 (op) == OP_EQ || (op) == OP_I_EQ || \
6344 (op) == OP_NE || (op) == OP_I_NE || \
6345 (op) == OP_NCMP || (op) == OP_I_NCMP)
d5ec2987 6346 o->op_private = (U8)(PL_hints & HINT_INTEGER);
2b84528b
RGS		 6347 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6348 && (o->op_type == OP_BIT_OR
6349 || o->op_type == OP_BIT_AND
6350 || o->op_type == OP_BIT_XOR))
276b2a0c 6351 {
1df70142
AL		 6352 const OP * const left = cBINOPo->op_first;
6353 const OP * const right = left->op_sibling;
96a925ab
YST		 6354 if ((OP_IS_NUMCOMPARE(left->op_type) &&
6355 (left->op_flags & OPf_PARENS) == 0) ||
6356 (OP_IS_NUMCOMPARE(right->op_type) &&
6357 (right->op_flags & OPf_PARENS) == 0))
276b2a0c
RGS		 6358 if (ckWARN(WARN_PRECEDENCE))
6359 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6360 "Possible precedence problem on bitwise %c operator",
6361 o->op_type == OP_BIT_OR ? '|'
6362 : o->op_type == OP_BIT_AND ? '&' : '^'
6363 );
6364 }
5dc0d613 6365 return o;
55497cff 6366}
6367
6368OP *
cea2e8a9 6369Perl_ck_concat(pTHX_ OP *o)
79072805 6370{
0bd48802 6371 const OP * const kid = cUNOPo->op_first;
7918f24d
NC		 6372
6373 PERL_ARGS_ASSERT_CK_CONCAT;
96a5add6 6374 PERL_UNUSED_CONTEXT;
7918f24d 6375
df91b2c5
AE		 6376 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6377 !(kUNOP->op_first->op_flags & OPf_MOD))
0165acc7 6378 o->op_flags |= OPf_STACKED;
11343788 6379 return o;
79072805
LW		 6380}
6381
6382OP *
cea2e8a9 6383Perl_ck_spair(pTHX_ OP *o)
79072805 6384{
27da23d5 6385 dVAR;
7918f24d
NC		 6386
6387 PERL_ARGS_ASSERT_CK_SPAIR;
6388
11343788 6389 if (o->op_flags & OPf_KIDS) {
79072805 6390 OP* newop;
a0d0e21e 6391 OP* kid;
6867be6d 6392 const OPCODE type = o->op_type;
5dc0d613 6393 o = modkids(ck_fun(o), type);
11343788 6394 kid = cUNOPo->op_first;
a0d0e21e 6395 newop = kUNOP->op_first->op_sibling;
1496a290
AL		 6396 if (newop) {
6397 const OPCODE type = newop->op_type;
6398 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6399 type == OP_PADAV || type == OP_PADHV ||
6400 type == OP_RV2AV || type == OP_RV2HV)
6401 return o;
a0d0e21e 6402 }
eb8433b7
NC		 6403#ifdef PERL_MAD
6404 op_getmad(kUNOP->op_first,newop,'K');
6405#else
a0d0e21e 6406 op_free(kUNOP->op_first);
eb8433b7 6407#endif
a0d0e21e
LW		 6408 kUNOP->op_first = newop;
6409 }
22c35a8c 6410 o->op_ppaddr = PL_ppaddr[++o->op_type];
11343788 6411 return ck_fun(o);
a0d0e21e
LW		 6412}
6413
6414OP *
cea2e8a9 6415Perl_ck_delete(pTHX_ OP *o)
a0d0e21e 6416{
7918f24d
NC		 6417 PERL_ARGS_ASSERT_CK_DELETE;
6418
11343788 6419 o = ck_fun(o);
5dc0d613 6420 o->op_private = 0;
11343788 6421 if (o->op_flags & OPf_KIDS) {
551405c4 6422 OP * const kid = cUNOPo->op_first;
01020589
GS		 6423 switch (kid->op_type) {
6424 case OP_ASLICE:
6425 o->op_flags |= OPf_SPECIAL;
6426 /* FALL THROUGH */
6427 case OP_HSLICE:
5dc0d613 6428 o->op_private |= OPpSLICE;
01020589
GS		 6429 break;
6430 case OP_AELEM:
6431 o->op_flags |= OPf_SPECIAL;
6432 /* FALL THROUGH */
6433 case OP_HELEM:
6434 break;
6435 default:
6436 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
53e06cf0 6437 OP_DESC(o));
01020589 6438 }
7332a6c4
VP		 6439 if (kid->op_private & OPpLVAL_INTRO)
6440 o->op_private |= OPpLVAL_INTRO;
93c66552 6441 op_null(kid);
79072805 6442 }
11343788 6443 return o;
79072805
LW		 6444}
6445
6446OP *
96e176bf
CL		 6447Perl_ck_die(pTHX_ OP *o)
6448{
7918f24d
NC		 6449 PERL_ARGS_ASSERT_CK_DIE;
6450
96e176bf
CL		 6451#ifdef VMS
6452 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6453#endif
6454 return ck_fun(o);
6455}
6456
6457OP *
cea2e8a9 6458Perl_ck_eof(pTHX_ OP *o)
79072805 6459{
97aff369 6460 dVAR;
79072805 6461
7918f24d
NC		 6462 PERL_ARGS_ASSERT_CK_EOF;
6463
11343788
MB		 6464 if (o->op_flags & OPf_KIDS) {
6465 if (cLISTOPo->op_first->op_type == OP_STUB) {
1d866c12
AL		 6466 OP * const newop
6467 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
eb8433b7
NC		 6468#ifdef PERL_MAD
6469 op_getmad(o,newop,'O');
6470#else
11343788 6471 op_free(o);
eb8433b7
NC		 6472#endif
6473 o = newop;
8990e307 6474 }
11343788 6475 return ck_fun(o);
79072805 6476 }
11343788 6477 return o;
79072805
LW		 6478}
6479
6480OP *
cea2e8a9 6481Perl_ck_eval(pTHX_ OP *o)
79072805 6482{
27da23d5 6483 dVAR;
7918f24d
NC		 6484
6485 PERL_ARGS_ASSERT_CK_EVAL;
6486
3280af22 6487 PL_hints |= HINT_BLOCK_SCOPE;
11343788 6488 if (o->op_flags & OPf_KIDS) {
46c461b5 6489 SVOP * const kid = (SVOP*)cUNOPo->op_first;
79072805 6490
93a17b20 6491 if (!kid) {
11343788 6492 o->op_flags &= ~OPf_KIDS;
93c66552 6493 op_null(o);
79072805 6494 }
b14574b4 6495 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
79072805 6496 LOGOP *enter;
eb8433b7 6497#ifdef PERL_MAD
1d866c12 6498 OP* const oldo = o;
eb8433b7 6499#endif
79072805 6500
11343788 6501 cUNOPo->op_first = 0;
eb8433b7 6502#ifndef PERL_MAD
11343788 6503 op_free(o);
eb8433b7 6504#endif
79072805 6505
b7dc083c 6506 NewOp(1101, enter, 1, LOGOP);
79072805 6507 enter->op_type = OP_ENTERTRY;
22c35a8c 6508 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
79072805
LW		 6509 enter->op_private = 0;
6510
6511 /* establish postfix order */
6512 enter->op_next = (OP*)enter;
6513
3a7a94e2
RGS		 6514 CHECKOP(OP_ENTERTRY, enter);
6515
11343788
MB		 6516 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6517 o->op_type = OP_LEAVETRY;
22c35a8c 6518 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
11343788 6519 enter->op_other = o;
eb8433b7 6520 op_getmad(oldo,o,'O');
11343788 6521 return o;
79072805 6522 }
b5c19bd7 6523 else {
473986ff 6524 scalar((OP*)kid);
b5c19bd7
DM		 6525 PL_cv_has_eval = 1;
6526 }
79072805
LW		 6527 }
6528 else {
eb8433b7 6529#ifdef PERL_MAD
1d866c12 6530 OP* const oldo = o;
eb8433b7 6531#else
11343788 6532 op_free(o);
eb8433b7 6533#endif
54b9620d 6534 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
eb8433b7 6535 op_getmad(oldo,o,'O');
79072805 6536 }
3280af22 6537 o->op_targ = (PADOFFSET)PL_hints;
7168684c 6538 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
996c9baa
VP		 6539 /* Store a copy of %^H that pp_entereval can pick up. */
6540 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
ad64d0ec 6541 MUTABLE_SV(Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv))));
0d863452
RH		 6542 cUNOPo->op_first->op_sibling = hhop;
6543 o->op_private |= OPpEVAL_HAS_HH;
6544 }
11343788 6545 return o;
79072805
LW		 6546}
6547
6548OP *
d98f61e7
GS		 6549Perl_ck_exit(pTHX_ OP *o)
6550{
7918f24d
NC		 6551 PERL_ARGS_ASSERT_CK_EXIT;
6552
d98f61e7 6553#ifdef VMS
551405c4 6554 HV * const table = GvHV(PL_hintgv);
d98f61e7 6555 if (table) {
a4fc7abc 6556 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
d98f61e7
GS		 6557 if (svp && *svp && SvTRUE(*svp))
6558 o->op_private |= OPpEXIT_VMSISH;
6559 }
96e176bf 6560 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
d98f61e7
GS		 6561#endif
6562 return ck_fun(o);
6563}
6564
6565OP *
cea2e8a9 6566Perl_ck_exec(pTHX_ OP *o)
79072805 6567{
7918f24d
NC		 6568 PERL_ARGS_ASSERT_CK_EXEC;
6569
11343788 6570 if (o->op_flags & OPf_STACKED) {
6867be6d 6571 OP *kid;
11343788
MB		 6572 o = ck_fun(o);
6573 kid = cUNOPo->op_first->op_sibling;
8990e307 6574 if (kid->op_type == OP_RV2GV)
93c66552 6575 op_null(kid);
79072805 6576 }
463ee0b2 6577 else
11343788
MB		 6578 o = listkids(o);
6579 return o;
79072805
LW		 6580}
6581
6582OP *
cea2e8a9 6583Perl_ck_exists(pTHX_ OP *o)
5f05dabc 6584{
97aff369 6585 dVAR;
7918f24d
NC		 6586
6587 PERL_ARGS_ASSERT_CK_EXISTS;
6588
5196be3e
MB		 6589 o = ck_fun(o);
6590 if (o->op_flags & OPf_KIDS) {
46c461b5 6591 OP * const kid = cUNOPo->op_first;
afebc493
GS		 6592 if (kid->op_type == OP_ENTERSUB) {
6593 (void) ref(kid, o->op_type);
13765c85
DM		 6594 if (kid->op_type != OP_RV2CV
6595 && !(PL_parser && PL_parser->error_count))
afebc493 6596 Perl_croak(aTHX_ "%s argument is not a subroutine name",
53e06cf0 6597 OP_DESC(o));
afebc493
GS		 6598 o->op_private |= OPpEXISTS_SUB;
6599 }
6600 else if (kid->op_type == OP_AELEM)
01020589
GS		 6601 o->op_flags |= OPf_SPECIAL;
6602 else if (kid->op_type != OP_HELEM)
b0fdf69e 6603 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine",
53e06cf0 6604 OP_DESC(o));
93c66552 6605 op_null(kid);
5f05dabc 6606 }
5196be3e 6607 return o;
5f05dabc 6608}
6609
79072805 6610OP *
cea2e8a9 6611Perl_ck_rvconst(pTHX_ register OP *o)
79072805 6612{
27da23d5 6613 dVAR;
0bd48802 6614 SVOP * const kid = (SVOP*)cUNOPo->op_first;
85e6fe83 6615
7918f24d
NC		 6616 PERL_ARGS_ASSERT_CK_RVCONST;
6617
3280af22 6618 o->op_private |= (PL_hints & HINT_STRICT_REFS);
e26df76a
NC		 6619 if (o->op_type == OP_RV2CV)
6620 o->op_private &= ~1;
6621
79072805 6622 if (kid->op_type == OP_CONST) {
44a8e56a 6623 int iscv;
6624 GV *gv;
504618e9 6625 SV * const kidsv = kid->op_sv;
44a8e56a 6626
779c5bc9
GS		 6627 /* Is it a constant from cv_const_sv()? */
6628 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
0bd48802 6629 SV * const rsv = SvRV(kidsv);
42d0e0b7 6630 const svtype type = SvTYPE(rsv);
bd61b366 6631 const char *badtype = NULL;
779c5bc9
GS		 6632
6633 switch (o->op_type) {
6634 case OP_RV2SV:
42d0e0b7 6635 if (type > SVt_PVMG)
779c5bc9
GS		 6636 badtype = "a SCALAR";
6637 break;
6638 case OP_RV2AV:
42d0e0b7 6639 if (type != SVt_PVAV)
779c5bc9
GS		 6640 badtype = "an ARRAY";
6641 break;
6642 case OP_RV2HV:
42d0e0b7 6643 if (type != SVt_PVHV)
779c5bc9 6644 badtype = "a HASH";
779c5bc9
GS		 6645 break;
6646 case OP_RV2CV:
42d0e0b7 6647 if (type != SVt_PVCV)
779c5bc9
GS		 6648 badtype = "a CODE";
6649 break;
6650 }
6651 if (badtype)
cea2e8a9 6652 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
779c5bc9
GS		 6653 return o;
6654 }
ce10b5d1
RGS		 6655 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6656 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6657 /* If this is an access to a stash, disable "strict refs", because
6658 * stashes aren't auto-vivified at compile-time (unless we store
6659 * symbols in them), and we don't want to produce a run-time
6660 * stricture error when auto-vivifying the stash. */
6661 const char *s = SvPV_nolen(kidsv);
6662 const STRLEN l = SvCUR(kidsv);
6663 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6664 o->op_private &= ~HINT_STRICT_REFS;
6665 }
6666 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5f66b61c 6667 const char *badthing;
5dc0d613 6668 switch (o->op_type) {
44a8e56a 6669 case OP_RV2SV:
6670 badthing = "a SCALAR";
6671 break;
6672 case OP_RV2AV:
6673 badthing = "an ARRAY";
6674 break;
6675 case OP_RV2HV:
6676 badthing = "a HASH";
6677 break;
5f66b61c
AL		 6678 default:
6679 badthing = NULL;
6680 break;
44a8e56a 6681 }
6682 if (badthing)
1c846c1f 6683 Perl_croak(aTHX_
95b63a38 6684 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
be2597df 6685 SVfARG(kidsv), badthing);
44a8e56a 6686 }
93233ece
CS		 6687 /*
6688 * This is a little tricky. We only want to add the symbol if we
6689 * didn't add it in the lexer. Otherwise we get duplicate strict
6690 * warnings. But if we didn't add it in the lexer, we must at
6691 * least pretend like we wanted to add it even if it existed before,
6692 * or we get possible typo warnings. OPpCONST_ENTERED says
6693 * whether the lexer already added THIS instance of this symbol.
6694 */
5196be3e 6695 iscv = (o->op_type == OP_RV2CV) * 2;
93233ece 6696 do {
7a5fd60d 6697 gv = gv_fetchsv(kidsv,
748a9306 6698 iscv | !(kid->op_private & OPpCONST_ENTERED),
a0d0e21e
LW		 6699 iscv
6700 ? SVt_PVCV
11343788 6701 : o->op_type == OP_RV2SV
a0d0e21e 6702 ? SVt_PV
11343788 6703 : o->op_type == OP_RV2AV
a0d0e21e 6704 ? SVt_PVAV
11343788 6705 : o->op_type == OP_RV2HV
a0d0e21e
LW		 6706 ? SVt_PVHV
6707 : SVt_PVGV);
93233ece
CS		 6708 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6709 if (gv) {
6710 kid->op_type = OP_GV;
6711 SvREFCNT_dec(kid->op_sv);
350de78d 6712#ifdef USE_ITHREADS
638eceb6 6713 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
350de78d 6714 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
dd2155a4 6715 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
743e66e6 6716 GvIN_PAD_on(gv);
ad64d0ec 6717 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
350de78d 6718#else
b37c2d43 6719 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
350de78d 6720#endif
23f1ca44 6721 kid->op_private = 0;
76cd736e 6722 kid->op_ppaddr = PL_ppaddr[OP_GV];
a0d0e21e 6723 }
79072805 6724 }
11343788 6725 return o;
79072805
LW		 6726}
6727
6728OP *
cea2e8a9 6729Perl_ck_ftst(pTHX_ OP *o)
79072805 6730{
27da23d5 6731 dVAR;
6867be6d 6732 const I32 type = o->op_type;
79072805 6733
7918f24d
NC		 6734 PERL_ARGS_ASSERT_CK_FTST;
6735
d0dca557 6736 if (o->op_flags & OPf_REF) {
6f207bd3 6737 NOOP;
d0dca557
JD		 6738 }
6739 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
551405c4 6740 SVOP * const kid = (SVOP*)cUNOPo->op_first;
1496a290 6741 const OPCODE kidtype = kid->op_type;
79072805 6742
1496a290 6743 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
551405c4 6744 OP * const newop = newGVOP(type, OPf_REF,
f776e3cd 6745 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
eb8433b7
NC		 6746#ifdef PERL_MAD
6747 op_getmad(o,newop,'O');
6748#else
11343788 6749 op_free(o);
eb8433b7 6750#endif
1d866c12 6751 return newop;
79072805 6752 }
6ecf81d6 6753 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
1af34c76 6754 o->op_private |= OPpFT_ACCESS;
1496a290
AL		 6755 if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6756 && kidtype != OP_STAT && kidtype != OP_LSTAT)
fbb0b3b3 6757 o->op_private |= OPpFT_STACKED;
79072805
LW		 6758 }
6759 else {
eb8433b7 6760#ifdef PERL_MAD
1d866c12 6761 OP* const oldo = o;
eb8433b7 6762#else
11343788 6763 op_free(o);
eb8433b7 6764#endif
79072805 6765 if (type == OP_FTTTY)
8fde6460 6766 o = newGVOP(type, OPf_REF, PL_stdingv);
79072805 6767 else
d0dca557 6768 o = newUNOP(type, 0, newDEFSVOP());
eb8433b7 6769 op_getmad(oldo,o,'O');
79072805 6770 }
11343788 6771 return o;
79072805
LW		 6772}
6773
6774OP *
cea2e8a9 6775Perl_ck_fun(pTHX_ OP *o)
79072805 6776{
97aff369 6777 dVAR;
6867be6d 6778 const int type = o->op_type;
22c35a8c 6779 register I32 oa = PL_opargs[type] >> OASHIFT;
aeea060c 6780
7918f24d
NC		 6781 PERL_ARGS_ASSERT_CK_FUN;
6782
11343788 6783 if (o->op_flags & OPf_STACKED) {
79072805
LW		 6784 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6785 oa &= ~OA_OPTIONAL;
6786 else
11343788 6787 return no_fh_allowed(o);
79072805
LW		 6788 }
6789
11343788 6790 if (o->op_flags & OPf_KIDS) {
6867be6d
AL		 6791 OP **tokid = &cLISTOPo->op_first;
6792 register OP *kid = cLISTOPo->op_first;
6793 OP *sibl;
6794 I32 numargs = 0;
6795
8990e307 6796 if (kid->op_type == OP_PUSHMARK ||
155aba94 6797 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
8990e307 6798 {
79072805
LW		 6799 tokid = &kid->op_sibling;
6800 kid = kid->op_sibling;
6801 }
22c35a8c 6802 if (!kid && PL_opargs[type] & OA_DEFGV)
54b9620d 6803 *tokid = kid = newDEFSVOP();
79072805
LW		 6804
6805 while (oa && kid) {
6806 numargs++;
6807 sibl = kid->op_sibling;
eb8433b7
NC		 6808#ifdef PERL_MAD
6809 if (!sibl && kid->op_type == OP_STUB) {
6810 numargs--;
6811 break;
6812 }
6813#endif
79072805
LW		 6814 switch (oa & 7) {
6815 case OA_SCALAR:
62c18ce2
GS		 6816 /* list seen where single (scalar) arg expected? */
6817 if (numargs == 1 && !(oa >> 4)
6818 && kid->op_type == OP_LIST && type != OP_SCALAR)
6819 {
6820 return too_many_arguments(o,PL_op_desc[type]);
6821 }
79072805
LW		 6822 scalar(kid);
6823 break;
6824 case OA_LIST:
6825 if (oa < 16) {
6826 kid = 0;
6827 continue;
6828 }
6829 else
6830 list(kid);
6831 break;
6832 case OA_AVREF:
936edb8b 6833 if ((type == OP_PUSH || type == OP_UNSHIFT)
f87c3213 6834 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
9014280d 6835 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
de4864e4 6836 "Useless use of %s with no values",
936edb8b 6837 PL_op_desc[type]);
b2ffa427 6838
79072805 6839 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 6840 (kid->op_private & OPpCONST_BARE))
6841 {
551405c4 6842 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
f776e3cd 6843 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
12bcd1a6
PM		 6844 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6845 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7a5fd60d 6846 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
be2597df 6847 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
eb8433b7
NC		 6848#ifdef PERL_MAD
6849 op_getmad(kid,newop,'K');
6850#else
79072805 6851 op_free(kid);
eb8433b7 6852#endif
79072805
LW		 6853 kid = newop;
6854 kid->op_sibling = sibl;
6855 *tokid = kid;
6856 }
8990e307 6857 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
35cd451c 6858 bad_type(numargs, "array", PL_op_desc[type], kid);
a0d0e21e 6859 mod(kid, type);
79072805
LW		 6860 break;
6861 case OA_HVREF:
6862 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 6863 (kid->op_private & OPpCONST_BARE))
6864 {
551405c4 6865 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
f776e3cd 6866 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
12bcd1a6
PM		 6867 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6868 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7a5fd60d 6869 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
be2597df 6870 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
eb8433b7
NC		 6871#ifdef PERL_MAD
6872 op_getmad(kid,newop,'K');
6873#else
79072805 6874 op_free(kid);
eb8433b7 6875#endif
79072805
LW		 6876 kid = newop;
6877 kid->op_sibling = sibl;
6878 *tokid = kid;
6879 }
8990e307 6880 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
35cd451c 6881 bad_type(numargs, "hash", PL_op_desc[type], kid);
a0d0e21e 6882 mod(kid, type);
79072805
LW		 6883 break;
6884 case OA_CVREF:
6885 {
551405c4 6886 OP * const newop = newUNOP(OP_NULL, 0, kid);
79072805
LW		 6887 kid->op_sibling = 0;
6888 linklist(kid);
6889 newop->op_next = newop;
6890 kid = newop;
6891 kid->op_sibling = sibl;
6892 *tokid = kid;
6893 }
6894 break;
6895 case OA_FILEREF:
c340be78 6896 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
79072805 6897 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 6898 (kid->op_private & OPpCONST_BARE))
6899 {
0bd48802 6900 OP * const newop = newGVOP(OP_GV, 0,
f776e3cd 6901 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
afbdacea 6902 if (!(o->op_private & 1) && /* if not unop */
8a996ce8 6903 kid == cLISTOPo->op_last)
364daeac 6904 cLISTOPo->op_last = newop;
eb8433b7
NC		 6905#ifdef PERL_MAD
6906 op_getmad(kid,newop,'K');
6907#else
79072805 6908 op_free(kid);
eb8433b7 6909#endif
79072805
LW		 6910 kid = newop;
6911 }
1ea32a52
GS		 6912 else if (kid->op_type == OP_READLINE) {
6913 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
53e06cf0 6914 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
1ea32a52 6915 }
79072805 6916 else {
35cd451c 6917 I32 flags = OPf_SPECIAL;
a6c40364 6918 I32 priv = 0;
2c8ac474
GS		 6919 PADOFFSET targ = 0;
6920
35cd451c 6921 /* is this op a FH constructor? */
853846ea 6922 if (is_handle_constructor(o,numargs)) {
bd61b366 6923 const char *name = NULL;
dd2155a4 6924 STRLEN len = 0;
2c8ac474
GS		 6925
6926 flags = 0;
6927 /* Set a flag to tell rv2gv to vivify
853846ea
NIS		 6928 * need to "prove" flag does not mean something
6929 * else already - NI-S 1999/05/07
2c8ac474
GS		 6930 */
6931 priv = OPpDEREF;
6932 if (kid->op_type == OP_PADSV) {
f8503592
NC		 6933 SV *const namesv
6934 = PAD_COMPNAME_SV(kid->op_targ);
6935 name = SvPV_const(namesv, len);
2c8ac474
GS		 6936 }
6937 else if (kid->op_type == OP_RV2SV
6938 && kUNOP->op_first->op_type == OP_GV)
6939 {
0bd48802 6940 GV * const gv = cGVOPx_gv(kUNOP->op_first);
2c8ac474
GS		 6941 name = GvNAME(gv);
6942 len = GvNAMELEN(gv);
6943 }
afd1915d
GS		 6944 else if (kid->op_type == OP_AELEM
6945 || kid->op_type == OP_HELEM)
6946 {
735fec84 6947 OP *firstop;
551405c4 6948 OP *op = ((BINOP*)kid)->op_first;
a4fc7abc 6949 name = NULL;
551405c4 6950 if (op) {
a0714e2c 6951 SV *tmpstr = NULL;
551405c4 6952 const char * const a =
666ea192
JH		 6953 kid->op_type == OP_AELEM ?
6954 "[]" : "{}";
0c4b0a3f
JH		 6955 if (((op->op_type == OP_RV2AV) ||
6956 (op->op_type == OP_RV2HV)) &&
735fec84
RGS		 6957 (firstop = ((UNOP*)op)->op_first) &&
6958 (firstop->op_type == OP_GV)) {
0c4b0a3f 6959 /* packagevar $a[] or $h{} */
735fec84 6960 GV * const gv = cGVOPx_gv(firstop);
0c4b0a3f
JH		 6961 if (gv)
6962 tmpstr =
6963 Perl_newSVpvf(aTHX_
6964 "%s%c...%c",
6965 GvNAME(gv),
6966 a[0], a[1]);
6967 }
6968 else if (op->op_type == OP_PADAV
6969 || op->op_type == OP_PADHV) {
6970 /* lexicalvar $a[] or $h{} */
551405c4 6971 const char * const padname =
0c4b0a3f
JH		 6972 PAD_COMPNAME_PV(op->op_targ);
6973 if (padname)
6974 tmpstr =
6975 Perl_newSVpvf(aTHX_
6976 "%s%c...%c",
6977 padname + 1,
6978 a[0], a[1]);
0c4b0a3f
JH		 6979 }
6980 if (tmpstr) {
93524f2b 6981 name = SvPV_const(tmpstr, len);
0c4b0a3f
JH		 6982 sv_2mortal(tmpstr);
6983 }
6984 }
6985 if (!name) {
6986 name = "__ANONIO__";
6987 len = 10;
6988 }
6989 mod(kid, type);
afd1915d 6990 }
2c8ac474
GS		 6991 if (name) {
6992 SV *namesv;
6993 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
dd2155a4 6994 namesv = PAD_SVl(targ);
862a34c6 6995 SvUPGRADE(namesv, SVt_PV);
2c8ac474 6996 if (*name != '$')
76f68e9b 6997 sv_setpvs(namesv, "$");
2c8ac474
GS		 6998 sv_catpvn(namesv, name, len);
6999 }
853846ea 7000 }
79072805 7001 kid->op_sibling = 0;
35cd451c 7002 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
2c8ac474
GS		 7003 kid->op_targ = targ;
7004 kid->op_private |= priv;
79072805
LW		 7005 }
7006 kid->op_sibling = sibl;
7007 *tokid = kid;
7008 }
7009 scalar(kid);
7010 break;
7011 case OA_SCALARREF:
a0d0e21e 7012 mod(scalar(kid), type);
79072805
LW		 7013 break;
7014 }
7015 oa >>= 4;
7016 tokid = &kid->op_sibling;
7017 kid = kid->op_sibling;
7018 }
eb8433b7
NC		 7019#ifdef PERL_MAD
7020 if (kid && kid->op_type != OP_STUB)
7021 return too_many_arguments(o,OP_DESC(o));
7022 o->op_private |= numargs;
7023#else
7024 /* FIXME - should the numargs move as for the PERL_MAD case? */
11343788 7025 o->op_private |= numargs;
79072805 7026 if (kid)
53e06cf0 7027 return too_many_arguments(o,OP_DESC(o));
eb8433b7 7028#endif
11343788 7029 listkids(o);
79072805 7030 }
22c35a8c 7031 else if (PL_opargs[type] & OA_DEFGV) {
c56915e3 7032#ifdef PERL_MAD
c7fe699d 7033 OP *newop = newUNOP(type, 0, newDEFSVOP());
c56915e3 7034 op_getmad(o,newop,'O');
c7fe699d 7035 return newop;
c56915e3 7036#else
c7fe699d 7037 /* Ordering of these two is important to keep f_map.t passing. */
11343788 7038 op_free(o);
c7fe699d 7039 return newUNOP(type, 0, newDEFSVOP());
c56915e3 7040#endif
a0d0e21e
LW		 7041 }
7042
79072805
LW		 7043 if (oa) {
7044 while (oa & OA_OPTIONAL)
7045 oa >>= 4;
7046 if (oa && oa != OA_LIST)
53e06cf0 7047 return too_few_arguments(o,OP_DESC(o));
79072805 7048 }
11343788 7049 return o;
79072805
LW		 7050}
7051
7052OP *
cea2e8a9 7053Perl_ck_glob(pTHX_ OP *o)
79072805 7054{
27da23d5 7055 dVAR;
fb73857a 7056 GV *gv;
7057
7918f24d
NC		 7058 PERL_ARGS_ASSERT_CK_GLOB;
7059
649da076 7060 o = ck_fun(o);
1f2bfc8a 7061 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
54b9620d 7062 append_elem(OP_GLOB, o, newDEFSVOP());
fb73857a 7063
fafc274c 7064 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
b9f751c0
GS		 7065 && GvCVu(gv) && GvIMPORTED_CV(gv)))
7066 {
5c1737d1 7067 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
b9f751c0 7068 }
b1cb66bf 7069
52bb0670 7070#if !defined(PERL_EXTERNAL_GLOB)
72b16652 7071 /* XXX this can be tightened up and made more failsafe. */
f444d496 7072 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7d3fb230 7073 GV *glob_gv;
72b16652 7074 ENTER;
00ca71c1 7075 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
a0714e2c 7076 newSVpvs("File::Glob"), NULL, NULL, NULL);
5c1737d1
NC		 7077 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7078 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
7d3fb230 7079 GvCV(gv) = GvCV(glob_gv);
ad64d0ec 7080 SvREFCNT_inc_void(MUTABLE_SV(GvCV(gv)));
7d3fb230 7081 GvIMPORTED_CV_on(gv);
72b16652
GS		 7082 LEAVE;
7083 }
52bb0670 7084#endif /* PERL_EXTERNAL_GLOB */
72b16652 7085
b9f751c0 7086 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5196be3e 7087 append_elem(OP_GLOB, o,
80252599 7088 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
1f2bfc8a 7089 o->op_type = OP_LIST;
22c35a8c 7090 o->op_ppaddr = PL_ppaddr[OP_LIST];
1f2bfc8a 7091 cLISTOPo->op_first->op_type = OP_PUSHMARK;
22c35a8c 7092 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
ad33f57d 7093 cLISTOPo->op_first->op_targ = 0;
1f2bfc8a 7094 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
aeea060c 7095 append_elem(OP_LIST, o,
1f2bfc8a
MB		 7096 scalar(newUNOP(OP_RV2CV, 0,
7097 newGVOP(OP_GV, 0, gv)))));
d58bf5aa
MB		 7098 o = newUNOP(OP_NULL, 0, ck_subr(o));
7099 o->op_targ = OP_GLOB; /* hint at what it used to be */
7100 return o;
b1cb66bf 7101 }
7102 gv = newGVgen("main");
a0d0e21e 7103 gv_IOadd(gv);
11343788
MB		 7104 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
7105 scalarkids(o);
649da076 7106 return o;
79072805
LW		 7107}
7108
7109OP *
cea2e8a9 7110Perl_ck_grep(pTHX_ OP *o)
79072805 7111{
27da23d5 7112 dVAR;
03ca120d 7113 LOGOP *gwop = NULL;
79072805 7114 OP *kid;
6867be6d 7115 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
9f7d9405 7116 PADOFFSET offset;
79072805 7117
7918f24d
NC		 7118 PERL_ARGS_ASSERT_CK_GREP;
7119
22c35a8c 7120 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
13765c85 7121 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
aeea060c 7122
11343788 7123 if (o->op_flags & OPf_STACKED) {
a0d0e21e 7124 OP* k;
11343788
MB		 7125 o = ck_sort(o);
7126 kid = cLISTOPo->op_first->op_sibling;
d09ad856
BS		 7127 if (!cUNOPx(kid)->op_next)
7128 Perl_croak(aTHX_ "panic: ck_grep");
e3c9a8b9 7129 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
a0d0e21e
LW		 7130 kid = k;
7131 }
03ca120d 7132 NewOp(1101, gwop, 1, LOGOP);
a0d0e21e 7133 kid->op_next = (OP*)gwop;
11343788 7134 o->op_flags &= ~OPf_STACKED;
93a17b20 7135 }
11343788 7136 kid = cLISTOPo->op_first->op_sibling;
a0d0e21e
LW		 7137 if (type == OP_MAPWHILE)
7138 list(kid);
7139 else
7140 scalar(kid);
11343788 7141 o = ck_fun(o);
13765c85 7142 if (PL_parser && PL_parser->error_count)
11343788 7143 return o;
aeea060c 7144 kid = cLISTOPo->op_first->op_sibling;
79072805 7145 if (kid->op_type != OP_NULL)
cea2e8a9 7146 Perl_croak(aTHX_ "panic: ck_grep");
79072805
LW		 7147 kid = kUNOP->op_first;
7148
03ca120d
MHM		 7149 if (!gwop)
7150 NewOp(1101, gwop, 1, LOGOP);
a0d0e21e 7151 gwop->op_type = type;
22c35a8c 7152 gwop->op_ppaddr = PL_ppaddr[type];
11343788 7153 gwop->op_first = listkids(o);
79072805 7154 gwop->op_flags |= OPf_KIDS;
79072805 7155 gwop->op_other = LINKLIST(kid);
79072805 7156 kid->op_next = (OP*)gwop;
59f00321 7157 offset = pad_findmy("$_");
00b1698f 7158 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
59f00321
RGS		 7159 o->op_private = gwop->op_private = 0;
7160 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
7161 }
7162 else {
7163 o->op_private = gwop->op_private = OPpGREP_LEX;
7164 gwop->op_targ = o->op_targ = offset;
7165 }
79072805 7166
11343788 7167 kid = cLISTOPo->op_first->op_sibling;
a0d0e21e 7168 if (!kid || !kid->op_sibling)
53e06cf0 7169 return too_few_arguments(o,OP_DESC(o));
a0d0e21e
LW		 7170 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
7171 mod(kid, OP_GREPSTART);
7172
79072805
LW		 7173 return (OP*)gwop;
7174}
7175
7176OP *
cea2e8a9 7177Perl_ck_index(pTHX_ OP *o)
79072805 7178{
7918f24d
NC		 7179 PERL_ARGS_ASSERT_CK_INDEX;
7180
11343788
MB		 7181 if (o->op_flags & OPf_KIDS) {
7182 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
0b71040e
LW		 7183 if (kid)
7184 kid = kid->op_sibling; /* get past "big" */
79072805 7185 if (kid && kid->op_type == OP_CONST)
2779dcf1 7186 fbm_compile(((SVOP*)kid)->op_sv, 0);
79072805 7187 }
11343788 7188 return ck_fun(o);
79072805
LW		 7189}
7190
7191OP *
cea2e8a9 7192Perl_ck_lfun(pTHX_ OP *o)
79072805 7193{
6867be6d 7194 const OPCODE type = o->op_type;
7918f24d
NC		 7195
7196 PERL_ARGS_ASSERT_CK_LFUN;
7197
5dc0d613 7198 return modkids(ck_fun(o), type);
79072805
LW		 7199}
7200
7201OP *
cea2e8a9 7202Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
69794302 7203{
7918f24d
NC		 7204 PERL_ARGS_ASSERT_CK_DEFINED;
7205
12bcd1a6 7206 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
d0334bed
GS		 7207 switch (cUNOPo->op_first->op_type) {
7208 case OP_RV2AV:
a8739d98
JH		 7209 /* This is needed for
7210 if (defined %stash::)
7211 to work. Do not break Tk.
7212 */
1c846c1f 7213 break; /* Globals via GV can be undef */
d0334bed
GS		 7214 case OP_PADAV:
7215 case OP_AASSIGN: /* Is this a good idea? */
12bcd1a6 7216 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
f10b0346 7217 "defined(@array) is deprecated");
12bcd1a6 7218 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
cc507455 7219 "\t(Maybe you should just omit the defined()?)\n");
69794302 7220 break;
d0334bed 7221 case OP_RV2HV:
a8739d98
JH		 7222 /* This is needed for
7223 if (defined %stash::)
7224 to work. Do not break Tk.
7225 */
1c846c1f 7226 break; /* Globals via GV can be undef */
d0334bed 7227 case OP_PADHV:
12bcd1a6 7228 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
894356b3 7229 "defined(%%hash) is deprecated");
12bcd1a6 7230 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
cc507455 7231 "\t(Maybe you should just omit the defined()?)\n");
d0334bed
GS		 7232 break;
7233 default:
7234 /* no warning */
7235 break;
7236 }
69794302
MJD		 7237 }
7238 return ck_rfun(o);
7239}
7240
7241OP *
e4b7ebf3
RGS		 7242Perl_ck_readline(pTHX_ OP *o)
7243{
7918f24d
NC		 7244 PERL_ARGS_ASSERT_CK_READLINE;
7245
e4b7ebf3
RGS		 7246 if (!(o->op_flags & OPf_KIDS)) {
7247 OP * const newop
7248 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
7249#ifdef PERL_MAD
7250 op_getmad(o,newop,'O');
7251#else
7252 op_free(o);
7253#endif
7254 return newop;
7255 }
7256 return o;
7257}
7258
7259OP *
cea2e8a9 7260Perl_ck_rfun(pTHX_ OP *o)
8990e307 7261{
6867be6d 7262 const OPCODE type = o->op_type;
7918f24d
NC		 7263
7264 PERL_ARGS_ASSERT_CK_RFUN;
7265
5dc0d613 7266 return refkids(ck_fun(o), type);
8990e307
LW		 7267}
7268
7269OP *
cea2e8a9 7270Perl_ck_listiob(pTHX_ OP *o)
79072805
LW		 7271{
7272 register OP *kid;
aeea060c 7273
7918f24d
NC		 7274 PERL_ARGS_ASSERT_CK_LISTIOB;
7275
11343788 7276 kid = cLISTOPo->op_first;
79072805 7277 if (!kid) {
11343788
MB		 7278 o = force_list(o);
7279 kid = cLISTOPo->op_first;
79072805
LW		 7280 }
7281 if (kid->op_type == OP_PUSHMARK)
7282 kid = kid->op_sibling;
11343788 7283 if (kid && o->op_flags & OPf_STACKED)
79072805
LW		 7284 kid = kid->op_sibling;
7285 else if (kid && !kid->op_sibling) { /* print HANDLE; */
7286 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
11343788 7287 o->op_flags |= OPf_STACKED; /* make it a filehandle */
748a9306 7288 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
11343788
MB		 7289 cLISTOPo->op_first->op_sibling = kid;
7290 cLISTOPo->op_last = kid;
79072805
LW		 7291 kid = kid->op_sibling;
7292 }
7293 }
b2ffa427 7294
79072805 7295 if (!kid)
54b9620d 7296 append_elem(o->op_type, o, newDEFSVOP());
79072805 7297
2de3dbcc 7298 return listkids(o);
bbce6d69 7299}
7300
7301OP *
0d863452
RH		 7302Perl_ck_smartmatch(pTHX_ OP *o)
7303{
97aff369 7304 dVAR;
0d863452
RH		 7305 if (0 == (o->op_flags & OPf_SPECIAL)) {
7306 OP *first = cBINOPo->op_first;
7307 OP *second = first->op_sibling;
7308
7309 /* Implicitly take a reference to an array or hash */
5f66b61c 7310 first->op_sibling = NULL;
0d863452
RH		 7311 first = cBINOPo->op_first = ref_array_or_hash(first);
7312 second = first->op_sibling = ref_array_or_hash(second);
7313
7314 /* Implicitly take a reference to a regular expression */
7315 if (first->op_type == OP_MATCH) {
7316 first->op_type = OP_QR;
7317 first->op_ppaddr = PL_ppaddr[OP_QR];
7318 }
7319 if (second->op_type == OP_MATCH) {
7320 second->op_type = OP_QR;
7321 second->op_ppaddr = PL_ppaddr[OP_QR];
7322 }
7323 }
7324
7325 return o;
7326}
7327
7328
7329OP *
b162f9ea
IZ		 7330Perl_ck_sassign(pTHX_ OP *o)
7331{
3088bf26 7332 dVAR;
1496a290 7333 OP * const kid = cLISTOPo->op_first;
7918f24d
NC		 7334
7335 PERL_ARGS_ASSERT_CK_SASSIGN;
7336
b162f9ea
IZ		 7337 /* has a disposable target? */
7338 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6b66af17
GS		 7339 && !(kid->op_flags & OPf_STACKED)
7340 /* Cannot steal the second time! */
1b438339
GG		 7341 && !(kid->op_private & OPpTARGET_MY)
7342 /* Keep the full thing for madskills */
7343 && !PL_madskills
7344 )
b162f9ea 7345 {
551405c4 7346 OP * const kkid = kid->op_sibling;
b162f9ea
IZ		 7347
7348 /* Can just relocate the target. */
2c2d71f5
JH		 7349 if (kkid && kkid->op_type == OP_PADSV
7350 && !(kkid->op_private & OPpLVAL_INTRO))
7351 {
b162f9ea 7352 kid->op_targ = kkid->op_targ;
743e66e6 7353 kkid->op_targ = 0;
b162f9ea
IZ		 7354 /* Now we do not need PADSV and SASSIGN. */
7355 kid->op_sibling = o->op_sibling; /* NULL */
7356 cLISTOPo->op_first = NULL;
7357 op_free(o);
7358 op_free(kkid);
7359 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
7360 return kid;
7361 }
7362 }
c5917253
NC		 7363 if (kid->op_sibling) {
7364 OP *kkid = kid->op_sibling;
7365 if (kkid->op_type == OP_PADSV
7366 && (kkid->op_private & OPpLVAL_INTRO)
7367 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
7368 const PADOFFSET target = kkid->op_targ;
7369 OP *const other = newOP(OP_PADSV,
7370 kkid->op_flags
7371 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
7372 OP *const first = newOP(OP_NULL, 0);
7373 OP *const nullop = newCONDOP(0, first, o, other);
7374 OP *const condop = first->op_next;
7375 /* hijacking PADSTALE for uninitialized state variables */
7376 SvPADSTALE_on(PAD_SVl(target));
7377
7378 condop->op_type = OP_ONCE;
7379 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
7380 condop->op_targ = target;
7381 other->op_targ = target;
7382
95562366
NC		 7383 /* Because we change the type of the op here, we will skip the
7384 assinment binop->op_last = binop->op_first->op_sibling; at the
7385 end of Perl_newBINOP(). So need to do it here. */
7386 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
7387
c5917253
NC		 7388 return nullop;
7389 }
7390 }
b162f9ea
IZ		 7391 return o;
7392}
7393
7394OP *
cea2e8a9 7395Perl_ck_match(pTHX_ OP *o)
79072805 7396{
97aff369 7397 dVAR;
7918f24d
NC		 7398
7399 PERL_ARGS_ASSERT_CK_MATCH;
7400
0d863452 7401 if (o->op_type != OP_QR && PL_compcv) {
9f7d9405 7402 const PADOFFSET offset = pad_findmy("$_");
00b1698f 7403 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
59f00321
RGS		 7404 o->op_targ = offset;
7405 o->op_private |= OPpTARGET_MY;
7406 }
7407 }
7408 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
7409 o->op_private |= OPpRUNTIME;
11343788 7410 return o;
79072805
LW		 7411}
7412
7413OP *
f5d5a27c
CS		 7414Perl_ck_method(pTHX_ OP *o)
7415{
551405c4 7416 OP * const kid = cUNOPo->op_first;
7918f24d
NC		 7417
7418 PERL_ARGS_ASSERT_CK_METHOD;
7419
f5d5a27c
CS		 7420 if (kid->op_type == OP_CONST) {
7421 SV* sv = kSVOP->op_sv;
a4fc7abc
AL		 7422 const char * const method = SvPVX_const(sv);
7423 if (!(strchr(method, ':') || strchr(method, '\''))) {
f5d5a27c 7424 OP *cmop;
1c846c1f 7425 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
a4fc7abc 7426 sv = newSVpvn_share(method, SvCUR(sv), 0);
1c846c1f
NIS		 7427 }
7428 else {
a0714e2c 7429 kSVOP->op_sv = NULL;
1c846c1f 7430 }
f5d5a27c 7431 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
eb8433b7
NC		 7432#ifdef PERL_MAD
7433 op_getmad(o,cmop,'O');
7434#else
f5d5a27c 7435 op_free(o);
eb8433b7 7436#endif
f5d5a27c
CS		 7437 return cmop;
7438 }
7439 }
7440 return o;
7441}
7442
7443OP *
cea2e8a9 7444Perl_ck_null(pTHX_ OP *o)
79072805 7445{
7918f24d 7446 PERL_ARGS_ASSERT_CK_NULL;
96a5add6 7447 PERL_UNUSED_CONTEXT;
11343788 7448 return o;
79072805
LW		 7449}
7450
7451OP *
16fe6d59
GS		 7452Perl_ck_open(pTHX_ OP *o)
7453{
97aff369 7454 dVAR;
551405c4 7455 HV * const table = GvHV(PL_hintgv);
7918f24d
NC		 7456
7457 PERL_ARGS_ASSERT_CK_OPEN;
7458
16fe6d59 7459 if (table) {
a4fc7abc 7460 SV **svp = hv_fetchs(table, "open_IN", FALSE);
16fe6d59 7461 if (svp && *svp) {
a79b25b7
VP		 7462 STRLEN len = 0;
7463 const char *d = SvPV_const(*svp, len);
7464 const I32 mode = mode_from_discipline(d, len);
16fe6d59
GS		 7465 if (mode & O_BINARY)
7466 o->op_private |= OPpOPEN_IN_RAW;
7467 else if (mode & O_TEXT)
7468 o->op_private |= OPpOPEN_IN_CRLF;
7469 }
7470
a4fc7abc 7471 svp = hv_fetchs(table, "open_OUT", FALSE);
16fe6d59 7472 if (svp && *svp) {
a79b25b7
VP		 7473 STRLEN len = 0;
7474 const char *d = SvPV_const(*svp, len);
7475 const I32 mode = mode_from_discipline(d, len);
16fe6d59
GS		 7476 if (mode & O_BINARY)
7477 o->op_private |= OPpOPEN_OUT_RAW;
7478 else if (mode & O_TEXT)
7479 o->op_private |= OPpOPEN_OUT_CRLF;
7480 }
7481 }
8d7403e6
RGS		 7482 if (o->op_type == OP_BACKTICK) {
7483 if (!(o->op_flags & OPf_KIDS)) {
e4b7ebf3
RGS		 7484 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
7485#ifdef PERL_MAD
7486 op_getmad(o,newop,'O');
7487#else
8d7403e6 7488 op_free(o);
e4b7ebf3
RGS		 7489#endif
7490 return newop;
8d7403e6 7491 }
16fe6d59 7492 return o;
8d7403e6 7493 }
3b82e551
JH		 7494 {
7495 /* In case of three-arg dup open remove strictness
7496 * from the last arg if it is a bareword. */
551405c4
AL		 7497 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
7498 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
3b82e551 7499 OP *oa;
b15aece3 7500 const char *mode;
3b82e551
JH		 7501
7502 if ((last->op_type == OP_CONST) && /* The bareword. */
7503 (last->op_private & OPpCONST_BARE) &&
7504 (last->op_private & OPpCONST_STRICT) &&
7505 (oa = first->op_sibling) && /* The fh. */
7506 (oa = oa->op_sibling) && /* The mode. */
ea1d064a 7507 (oa->op_type == OP_CONST) &&
3b82e551 7508 SvPOK(((SVOP*)oa)->op_sv) &&
b15aece3 7509 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
3b82e551
JH		 7510 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
7511 (last == oa->op_sibling)) /* The bareword. */
7512 last->op_private &= ~OPpCONST_STRICT;
7513 }
16fe6d59
GS		 7514 return ck_fun(o);
7515}
7516
7517OP *
cea2e8a9 7518Perl_ck_repeat(pTHX_ OP *o)
79072805 7519{
7918f24d
NC		 7520 PERL_ARGS_ASSERT_CK_REPEAT;
7521
11343788
MB		 7522 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
7523 o->op_private |= OPpREPEAT_DOLIST;
7524 cBINOPo->op_first = force_list(cBINOPo->op_first);
79072805
LW		 7525 }
7526 else
11343788
MB		 7527 scalar(o);
7528 return o;
79072805
LW		 7529}
7530
7531OP *
cea2e8a9 7532Perl_ck_require(pTHX_ OP *o)
8990e307 7533{
97aff369 7534 dVAR;
a0714e2c 7535 GV* gv = NULL;
ec4ab249 7536
7918f24d
NC		 7537 PERL_ARGS_ASSERT_CK_REQUIRE;
7538
11343788 7539 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
551405c4 7540 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8990e307
LW		 7541
7542 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
551405c4 7543 SV * const sv = kid->op_sv;
5c144d81 7544 U32 was_readonly = SvREADONLY(sv);
8990e307 7545 char *s;
cfff9797
NC		 7546 STRLEN len;
7547 const char *end;
5c144d81
NC		 7548
7549 if (was_readonly) {
7550 if (SvFAKE(sv)) {
7551 sv_force_normal_flags(sv, 0);
7552 assert(!SvREADONLY(sv));
7553 was_readonly = 0;
7554 } else {
7555 SvREADONLY_off(sv);
7556 }
7557 }
7558
cfff9797
NC		 7559 s = SvPVX(sv);
7560 len = SvCUR(sv);
7561 end = s + len;
7562 for (; s < end; s++) {
a0d0e21e
LW		 7563 if (*s == ':' && s[1] == ':') {
7564 *s = '/';
5c6b2528 7565 Move(s+2, s+1, end - s - 1, char);
cfff9797 7566 --end;
a0d0e21e 7567 }
8990e307 7568 }
cfff9797 7569 SvEND_set(sv, end);
396482e1 7570 sv_catpvs(sv, ".pm");
5c144d81 7571 SvFLAGS(sv) |= was_readonly;
8990e307
LW		 7572 }
7573 }
ec4ab249 7574
a72a1c8b
RGS		 7575 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
7576 /* handle override, if any */
fafc274c 7577 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
d6a985f2 7578 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
a4fc7abc 7579 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
a0714e2c 7580 gv = gvp ? *gvp : NULL;
d6a985f2 7581 }
a72a1c8b 7582 }
ec4ab249 7583
b9f751c0 7584 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
551405c4 7585 OP * const kid = cUNOPo->op_first;
f11453cb
NC		 7586 OP * newop;
7587
ec4ab249 7588 cUNOPo->op_first = 0;
f11453cb 7589#ifndef PERL_MAD
ec4ab249 7590 op_free(o);
eb8433b7 7591#endif
f11453cb
NC		 7592 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7593 append_elem(OP_LIST, kid,
7594 scalar(newUNOP(OP_RV2CV, 0,
7595 newGVOP(OP_GV, 0,
7596 gv))))));
7597 op_getmad(o,newop,'O');
eb8433b7 7598 return newop;
ec4ab249
GA		 7599 }
7600
11343788 7601 return ck_fun(o);
8990e307
LW		 7602}
7603
78f9721b
SM		 7604OP *
7605Perl_ck_return(pTHX_ OP *o)
7606{
97aff369 7607 dVAR;
e91684bf 7608 OP *kid;
7918f24d
NC		 7609
7610 PERL_ARGS_ASSERT_CK_RETURN;
7611
e91684bf 7612 kid = cLISTOPo->op_first->op_sibling;
78f9721b 7613 if (CvLVALUE(PL_compcv)) {
e91684bf 7614 for (; kid; kid = kid->op_sibling)
78f9721b 7615 mod(kid, OP_LEAVESUBLV);
e91684bf
VP		 7616 } else {
7617 for (; kid; kid = kid->op_sibling)
7618 if ((kid->op_type == OP_NULL)
1c8a4223 7619 && ((kid->op_flags & (OPf_SPECIAL|OPf_KIDS)) == (OPf_SPECIAL|OPf_KIDS))) {
e91684bf 7620 /* This is a do block */
1c8a4223
VP		 7621 OP *op = kUNOP->op_first;
7622 if (op->op_type == OP_LEAVE && op->op_flags & OPf_KIDS) {
7623 op = cUNOPx(op)->op_first;
7624 assert(op->op_type == OP_ENTER && !(op->op_flags & OPf_SPECIAL));
7625 /* Force the use of the caller's context */
7626 op->op_flags |= OPf_SPECIAL;
7627 }
e91684bf 7628 }
78f9721b 7629 }
e91684bf 7630
78f9721b
SM		 7631 return o;
7632}
7633
79072805 7634OP *
cea2e8a9 7635Perl_ck_select(pTHX_ OP *o)
79072805 7636{
27da23d5 7637 dVAR;
c07a80fd 7638 OP* kid;
7918f24d
NC		 7639
7640 PERL_ARGS_ASSERT_CK_SELECT;
7641
11343788
MB		 7642 if (o->op_flags & OPf_KIDS) {
7643 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
2304df62 7644 if (kid && kid->op_sibling) {
11343788 7645 o->op_type = OP_SSELECT;
22c35a8c 7646 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
11343788
MB		 7647 o = ck_fun(o);
7648 return fold_constants(o);
79072805
LW		 7649 }
7650 }
11343788
MB		 7651 o = ck_fun(o);
7652 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
c07a80fd 7653 if (kid && kid->op_type == OP_RV2GV)
7654 kid->op_private &= ~HINT_STRICT_REFS;
11343788 7655 return o;
79072805
LW		 7656}
7657
7658OP *
cea2e8a9 7659Perl_ck_shift(pTHX_ OP *o)
79072805 7660{
97aff369 7661 dVAR;
6867be6d 7662 const I32 type = o->op_type;
79072805 7663
7918f24d
NC		 7664 PERL_ARGS_ASSERT_CK_SHIFT;
7665
11343788 7666 if (!(o->op_flags & OPf_KIDS)) {
821005df 7667 OP *argop = newUNOP(OP_RV2AV, 0,
8fde6460 7668 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
eb8433b7 7669#ifdef PERL_MAD
821005df 7670 OP * const oldo = o;
eb8433b7
NC		 7671 o = newUNOP(type, 0, scalar(argop));
7672 op_getmad(oldo,o,'O');
7673 return o;
7674#else
821005df 7675 op_free(o);
6d4ff0d2 7676 return newUNOP(type, 0, scalar(argop));
eb8433b7 7677#endif
79072805 7678 }
11343788 7679 return scalar(modkids(ck_fun(o), type));
79072805
LW		 7680}
7681
7682OP *
cea2e8a9 7683Perl_ck_sort(pTHX_ OP *o)
79072805 7684{
97aff369 7685 dVAR;
8e3f9bdf 7686 OP *firstkid;
bbce6d69 7687
7918f24d
NC		 7688 PERL_ARGS_ASSERT_CK_SORT;
7689
1496a290 7690 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
a4fc7abc 7691 HV * const hinthv = GvHV(PL_hintgv);
7b9ef140 7692 if (hinthv) {
a4fc7abc 7693 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7b9ef140 7694 if (svp) {
a4fc7abc 7695 const I32 sorthints = (I32)SvIV(*svp);
7b9ef140
RH		 7696 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7697 o->op_private |= OPpSORT_QSORT;
7698 if ((sorthints & HINT_SORT_STABLE) != 0)
7699 o->op_private |= OPpSORT_STABLE;
7700 }
7701 }
7702 }
7703
9ea6e965 7704 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
51a19bc0 7705 simplify_sort(o);
8e3f9bdf
GS		 7706 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7707 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
9c5ffd7c 7708 OP *k = NULL;
8e3f9bdf 7709 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
79072805 7710
463ee0b2 7711 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
79072805 7712 linklist(kid);
463ee0b2
LW		 7713 if (kid->op_type == OP_SCOPE) {
7714 k = kid->op_next;
7715 kid->op_next = 0;
79072805 7716 }
463ee0b2 7717 else if (kid->op_type == OP_LEAVE) {
11343788 7718 if (o->op_type == OP_SORT) {
93c66552 7719 op_null(kid); /* wipe out leave */
748a9306 7720 kid->op_next = kid;
463ee0b2 7721
748a9306
LW		 7722 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7723 if (k->op_next == kid)
7724 k->op_next = 0;
71a29c3c
GS		 7725 /* don't descend into loops */
7726 else if (k->op_type == OP_ENTERLOOP
7727 || k->op_type == OP_ENTERITER)
7728 {
7729 k = cLOOPx(k)->op_lastop;
7730 }
748a9306 7731 }
463ee0b2 7732 }
748a9306
LW		 7733 else
7734 kid->op_next = 0; /* just disconnect the leave */
a0d0e21e 7735 k = kLISTOP->op_first;
463ee0b2 7736 }
a2efc822 7737 CALL_PEEP(k);
a0d0e21e 7738
8e3f9bdf
GS		 7739 kid = firstkid;
7740 if (o->op_type == OP_SORT) {
7741 /* provide scalar context for comparison function/block */
7742 kid = scalar(kid);
a0d0e21e 7743 kid->op_next = kid;
8e3f9bdf 7744 }
a0d0e21e
LW		 7745 else
7746 kid->op_next = k;
11343788 7747 o->op_flags |= OPf_SPECIAL;
79072805 7748 }
c6e96bcb 7749 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
93c66552 7750 op_null(firstkid);
8e3f9bdf
GS		 7751
7752 firstkid = firstkid->op_sibling;
79072805 7753 }
bbce6d69 7754
8e3f9bdf
GS		 7755 /* provide list context for arguments */
7756 if (o->op_type == OP_SORT)
7757 list(firstkid);
7758
11343788 7759 return o;
79072805 7760}
bda4119b
GS		 7761
7762STATIC void
cea2e8a9 7763S_simplify_sort(pTHX_ OP *o)
9c007264 7764{
97aff369 7765 dVAR;
9c007264
JH		 7766 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7767 OP *k;
eb209983 7768 int descending;
350de78d 7769 GV *gv;
770526c1 7770 const char *gvname;
7918f24d
NC		 7771
7772 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
7773
9c007264
JH		 7774 if (!(o->op_flags & OPf_STACKED))
7775 return;
fafc274c
NC		 7776 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7777 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
82092f1d 7778 kid = kUNOP->op_first; /* get past null */
9c007264
JH		 7779 if (kid->op_type != OP_SCOPE)
7780 return;
7781 kid = kLISTOP->op_last; /* get past scope */
7782 switch(kid->op_type) {
7783 case OP_NCMP:
7784 case OP_I_NCMP:
7785 case OP_SCMP:
7786 break;
7787 default:
7788 return;
7789 }
7790 k = kid; /* remember this node*/
7791 if (kBINOP->op_first->op_type != OP_RV2SV)
7792 return;
7793 kid = kBINOP->op_first; /* get past cmp */
7794 if (kUNOP->op_first->op_type != OP_GV)
7795 return;
7796 kid = kUNOP->op_first; /* get past rv2sv */
638eceb6 7797 gv = kGVOP_gv;
350de78d 7798 if (GvSTASH(gv) != PL_curstash)
9c007264 7799 return;
770526c1
NC		 7800 gvname = GvNAME(gv);
7801 if (*gvname == 'a' && gvname[1] == '\0')
eb209983 7802 descending = 0;
770526c1 7803 else if (*gvname == 'b' && gvname[1] == '\0')
eb209983 7804 descending = 1;
9c007264
JH		 7805 else
7806 return;
eb209983 7807
9c007264
JH		 7808 kid = k; /* back to cmp */
7809 if (kBINOP->op_last->op_type != OP_RV2SV)
7810 return;
7811 kid = kBINOP->op_last; /* down to 2nd arg */
7812 if (kUNOP->op_first->op_type != OP_GV)
7813 return;
7814 kid = kUNOP->op_first; /* get past rv2sv */
638eceb6 7815 gv = kGVOP_gv;
770526c1
NC		 7816 if (GvSTASH(gv) != PL_curstash)
7817 return;
7818 gvname = GvNAME(gv);
7819 if ( descending
7820 ? !(*gvname == 'a' && gvname[1] == '\0')
7821 : !(*gvname == 'b' && gvname[1] == '\0'))
9c007264
JH		 7822 return;
7823 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
eb209983
NC		 7824 if (descending)
7825 o->op_private |= OPpSORT_DESCEND;
9c007264
JH		 7826 if (k->op_type == OP_NCMP)
7827 o->op_private |= OPpSORT_NUMERIC;
7828 if (k->op_type == OP_I_NCMP)
7829 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
e507f050
SM		 7830 kid = cLISTOPo->op_first->op_sibling;
7831 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
eb8433b7
NC		 7832#ifdef PERL_MAD
7833 op_getmad(kid,o,'S'); /* then delete it */
7834#else
e507f050 7835 op_free(kid); /* then delete it */
eb8433b7 7836#endif
9c007264 7837}
79072805
LW		 7838
7839OP *
cea2e8a9 7840Perl_ck_split(pTHX_ OP *o)
79072805 7841{
27da23d5 7842 dVAR;
79072805 7843 register OP *kid;
aeea060c 7844
7918f24d
NC		 7845 PERL_ARGS_ASSERT_CK_SPLIT;
7846
11343788
MB		 7847 if (o->op_flags & OPf_STACKED)
7848 return no_fh_allowed(o);
79072805 7849
11343788 7850 kid = cLISTOPo->op_first;
8990e307 7851 if (kid->op_type != OP_NULL)
cea2e8a9 7852 Perl_croak(aTHX_ "panic: ck_split");
8990e307 7853 kid = kid->op_sibling;
11343788
MB		 7854 op_free(cLISTOPo->op_first);
7855 cLISTOPo->op_first = kid;
85e6fe83 7856 if (!kid) {
396482e1 7857 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
11343788 7858 cLISTOPo->op_last = kid; /* There was only one element previously */
85e6fe83 7859 }
79072805 7860
de4bf5b3 7861 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
551405c4 7862 OP * const sibl = kid->op_sibling;
463ee0b2 7863 kid->op_sibling = 0;
131b3ad0 7864 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
11343788
MB		 7865 if (cLISTOPo->op_first == cLISTOPo->op_last)
7866 cLISTOPo->op_last = kid;
7867 cLISTOPo->op_first = kid;
79072805
LW		 7868 kid->op_sibling = sibl;
7869 }
7870
7871 kid->op_type = OP_PUSHRE;
22c35a8c 7872 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
79072805 7873 scalar(kid);
041457d9 7874 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
f34840d8
MJD		 7875 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7876 "Use of /g modifier is meaningless in split");
7877 }
79072805
LW		 7878
7879 if (!kid->op_sibling)
54b9620d 7880 append_elem(OP_SPLIT, o, newDEFSVOP());
79072805
LW		 7881
7882 kid = kid->op_sibling;
7883 scalar(kid);
7884
7885 if (!kid->op_sibling)
11343788 7886 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
ce3e5c45 7887 assert(kid->op_sibling);
79072805
LW		 7888
7889 kid = kid->op_sibling;
7890 scalar(kid);
7891
7892 if (kid->op_sibling)
53e06cf0 7893 return too_many_arguments(o,OP_DESC(o));
79072805 7894
11343788 7895 return o;
79072805
LW		 7896}
7897
7898OP *
1c846c1f 7899Perl_ck_join(pTHX_ OP *o)
eb6e2d6f 7900{
551405c4 7901 const OP * const kid = cLISTOPo->op_first->op_sibling;
7918f24d
NC		 7902
7903 PERL_ARGS_ASSERT_CK_JOIN;
7904
041457d9
DM		 7905 if (kid && kid->op_type == OP_MATCH) {
7906 if (ckWARN(WARN_SYNTAX)) {
6867be6d 7907 const REGEXP *re = PM_GETRE(kPMOP);
d2c6dc5e 7908 const char *pmstr = re ? RX_PRECOMP_const(re) : "STRING";
220fc49f 7909 const STRLEN len = re ? RX_PRELEN(re) : 6;
9014280d 7910 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
bcdf7404 7911 "/%.*s/ should probably be written as \"%.*s\"",
d83b45b8 7912 (int)len, pmstr, (int)len, pmstr);
eb6e2d6f
GS		 7913 }
7914 }
7915 return ck_fun(o);
7916}
7917
7918OP *
cea2e8a9 7919Perl_ck_subr(pTHX_ OP *o)
79072805 7920{
97aff369 7921 dVAR;
11343788
MB		 7922 OP *prev = ((cUNOPo->op_first->op_sibling)
7923 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7924 OP *o2 = prev->op_sibling;
4633a7c4 7925 OP *cvop;
a0751766 7926 const char *proto = NULL;
cbf82dd0 7927 const char *proto_end = NULL;
c445ea15
AL		 7928 CV *cv = NULL;
7929 GV *namegv = NULL;
4633a7c4
LW		 7930 int optional = 0;
7931 I32 arg = 0;
5b794e05 7932 I32 contextclass = 0;
d3fcec1f 7933 const char *e = NULL;
0723351e 7934 bool delete_op = 0;
4633a7c4 7935
7918f24d
NC		 7936 PERL_ARGS_ASSERT_CK_SUBR;
7937
d3011074 7938 o->op_private |= OPpENTERSUB_HASTARG;
11343788 7939 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
4633a7c4
LW		 7940 if (cvop->op_type == OP_RV2CV) {
7941 SVOP* tmpop;
11343788 7942 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
93c66552 7943 op_null(cvop); /* disable rv2cv */
4633a7c4 7944 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
76cd736e 7945 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
638eceb6 7946 GV *gv = cGVOPx_gv(tmpop);
350de78d 7947 cv = GvCVu(gv);
76cd736e
GS		 7948 if (!cv)
7949 tmpop->op_private |= OPpEARLY_CV;
06492da6
SF		 7950 else {
7951 if (SvPOK(cv)) {
cbf82dd0 7952 STRLEN len;
06492da6 7953 namegv = CvANON(cv) ? gv : CvGV(cv);
ad64d0ec 7954 proto = SvPV(MUTABLE_SV(cv), len);
cbf82dd0 7955 proto_end = proto + len;
06492da6 7956 }
46fc3d4c 7957 }
4633a7c4
LW		 7958 }
7959 }
f5d5a27c 7960 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7a52d87a
GS		 7961 if (o2->op_type == OP_CONST)
7962 o2->op_private &= ~OPpCONST_STRICT;
58a40671 7963 else if (o2->op_type == OP_LIST) {
5f66b61c
AL		 7964 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7965 if (sib && sib->op_type == OP_CONST)
7966 sib->op_private &= ~OPpCONST_STRICT;
58a40671 7967 }
7a52d87a 7968 }
3280af22
NIS		 7969 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7970 if (PERLDB_SUB && PL_curstash != PL_debstash)
11343788
MB		 7971 o->op_private |= OPpENTERSUB_DB;
7972 while (o2 != cvop) {
eb8433b7 7973 OP* o3;
9fc012f4
GG		 7974 if (PL_madskills && o2->op_type == OP_STUB) {
7975 o2 = o2->op_sibling;
7976 continue;
7977 }
eb8433b7
NC		 7978 if (PL_madskills && o2->op_type == OP_NULL)
7979 o3 = ((UNOP*)o2)->op_first;
7980 else
7981 o3 = o2;
4633a7c4 7982 if (proto) {
cbf82dd0 7983 if (proto >= proto_end)
5dc0d613 7984 return too_many_arguments(o, gv_ename(namegv));
cbf82dd0
NC		 7985
7986 switch (*proto) {
4633a7c4
LW		 7987 case ';':
7988 optional = 1;
7989 proto++;
7990 continue;
b13fd70a 7991 case '_':
f00d1d61 7992 /* _ must be at the end */
cb40c25d 7993 if (proto[1] && proto[1] != ';')
f00d1d61 7994 goto oops;
4633a7c4
LW		 7995 case '$':
7996 proto++;
7997 arg++;
11343788 7998 scalar(o2);
4633a7c4
LW		 7999 break;
8000 case '%':
8001 case '@':
11343788 8002 list(o2);
4633a7c4
LW		 8003 arg++;
8004 break;
8005 case '&':
8006 proto++;
8007 arg++;
eb8433b7 8008 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
75fc29ea 8009 bad_type(arg,
666ea192
JH		 8010 arg == 1 ? "block or sub {}" : "sub {}",
8011 gv_ename(namegv), o3);
4633a7c4
LW		 8012 break;
8013 case '*':
2ba6ecf4 8014 /* '*' allows any scalar type, including bareword */
4633a7c4
LW		 8015 proto++;
8016 arg++;
eb8433b7 8017 if (o3->op_type == OP_RV2GV)
2ba6ecf4 8018 goto wrapref; /* autoconvert GLOB -> GLOBref */
eb8433b7
NC		 8019 else if (o3->op_type == OP_CONST)
8020 o3->op_private &= ~OPpCONST_STRICT;
8021 else if (o3->op_type == OP_ENTERSUB) {
9675f7ac 8022 /* accidental subroutine, revert to bareword */
eb8433b7 8023 OP *gvop = ((UNOP*)o3)->op_first;
9675f7ac
GS		 8024 if (gvop && gvop->op_type == OP_NULL) {
8025 gvop = ((UNOP*)gvop)->op_first;
8026 if (gvop) {
8027 for (; gvop->op_sibling; gvop = gvop->op_sibling)
8028 ;
8029 if (gvop &&
8030 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
8031 (gvop = ((UNOP*)gvop)->op_first) &&
8032 gvop->op_type == OP_GV)
8033 {
551405c4
AL		 8034 GV * const gv = cGVOPx_gv(gvop);
8035 OP * const sibling = o2->op_sibling;
396482e1 8036 SV * const n = newSVpvs("");
eb8433b7 8037#ifdef PERL_MAD
1d866c12 8038 OP * const oldo2 = o2;
eb8433b7 8039#else
9675f7ac 8040 op_free(o2);
eb8433b7 8041#endif
2a797ae2 8042 gv_fullname4(n, gv, "", FALSE);
2692f720 8043 o2 = newSVOP(OP_CONST, 0, n);
eb8433b7 8044 op_getmad(oldo2,o2,'O');
9675f7ac
GS		 8045 prev->op_sibling = o2;
8046 o2->op_sibling = sibling;
8047 }
8048 }
8049 }
8050 }
2ba6ecf4
GS		 8051 scalar(o2);
8052 break;
5b794e05
JH		 8053 case '[': case ']':
8054 goto oops;
8055 break;
4633a7c4
LW		 8056 case '\\':
8057 proto++;
8058 arg++;
5b794e05 8059 again:
4633a7c4 8060 switch (*proto++) {
5b794e05
JH		 8061 case '[':
8062 if (contextclass++ == 0) {
841d93c8 8063 e = strchr(proto, ']');
5b794e05
JH		 8064 if (!e || e == proto)
8065 goto oops;
8066 }
8067 else
8068 goto oops;
8069 goto again;
8070 break;
8071 case ']':
466bafcd 8072 if (contextclass) {
a0751766
NC		 8073 const char *p = proto;
8074 const char *const end = proto;
466bafcd 8075 contextclass = 0;
47127b64 8076 while (*--p != '[') {}
a0751766
NC		 8077 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
8078 (int)(end - p), p),
8079 gv_ename(namegv), o3);
466bafcd 8080 } else
5b794e05
JH		 8081 goto oops;
8082 break;
4633a7c4 8083 case '*':
eb8433b7 8084 if (o3->op_type == OP_RV2GV)
5b794e05
JH		 8085 goto wrapref;
8086 if (!contextclass)
eb8433b7 8087 bad_type(arg, "symbol", gv_ename(namegv), o3);
5b794e05 8088 break;
4633a7c4 8089 case '&':
eb8433b7 8090 if (o3->op_type == OP_ENTERSUB)
5b794e05
JH		 8091 goto wrapref;
8092 if (!contextclass)
eb8433b7
NC		 8093 bad_type(arg, "subroutine entry", gv_ename(namegv),
8094 o3);
5b794e05 8095 break;
4633a7c4 8096 case '$':
eb8433b7
NC		 8097 if (o3->op_type == OP_RV2SV ||
8098 o3->op_type == OP_PADSV ||
8099 o3->op_type == OP_HELEM ||
5b9081af 8100 o3->op_type == OP_AELEM)
5b794e05
JH		 8101 goto wrapref;
8102 if (!contextclass)
eb8433b7 8103 bad_type(arg, "scalar", gv_ename(namegv), o3);
5b794e05 8104 break;
4633a7c4 8105 case '@':
eb8433b7
NC		 8106 if (o3->op_type == OP_RV2AV ||
8107 o3->op_type == OP_PADAV)
5b794e05
JH		 8108 goto wrapref;
8109 if (!contextclass)
eb8433b7 8110 bad_type(arg, "array", gv_ename(namegv), o3);
5b794e05 8111 break;
4633a7c4 8112 case '%':
eb8433b7
NC		 8113 if (o3->op_type == OP_RV2HV ||
8114 o3->op_type == OP_PADHV)
5b794e05
JH		 8115 goto wrapref;
8116 if (!contextclass)
eb8433b7 8117 bad_type(arg, "hash", gv_ename(namegv), o3);
5b794e05
JH		 8118 break;
8119 wrapref:
4633a7c4 8120 {
551405c4
AL		 8121 OP* const kid = o2;
8122 OP* const sib = kid->op_sibling;
4633a7c4 8123 kid->op_sibling = 0;
6fa846a0
GS		 8124 o2 = newUNOP(OP_REFGEN, 0, kid);
8125 o2->op_sibling = sib;
e858de61 8126 prev->op_sibling = o2;
4633a7c4 8127 }
841d93c8 8128 if (contextclass && e) {
5b794e05
JH		 8129 proto = e + 1;
8130 contextclass = 0;
8131 }
4633a7c4
LW		 8132 break;
8133 default: goto oops;
8134 }
5b794e05
JH		 8135 if (contextclass)
8136 goto again;
4633a7c4 8137 break;
b1cb66bf 8138 case ' ':
8139 proto++;
8140 continue;
4633a7c4
LW		 8141 default:
8142 oops:
35c1215d 8143 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
be2597df 8144 gv_ename(namegv), SVfARG(cv));
4633a7c4
LW		 8145 }
8146 }
8147 else
11343788
MB		 8148 list(o2);
8149 mod(o2, OP_ENTERSUB);
8150 prev = o2;
8151 o2 = o2->op_sibling;
551405c4 8152 } /* while */
236b555a
RGS		 8153 if (o2 == cvop && proto && *proto == '_') {
8154 /* generate an access to $_ */
8155 o2 = newDEFSVOP();
8156 o2->op_sibling = prev->op_sibling;
8157 prev->op_sibling = o2; /* instead of cvop */
8158 }
cbf82dd0 8159 if (proto && !optional && proto_end > proto &&
236b555a 8160 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
5dc0d613 8161 return too_few_arguments(o, gv_ename(namegv));
0723351e 8162 if(delete_op) {
eb8433b7 8163#ifdef PERL_MAD
1d866c12 8164 OP * const oldo = o;
eb8433b7 8165#else
06492da6 8166 op_free(o);
eb8433b7 8167#endif
06492da6 8168 o=newSVOP(OP_CONST, 0, newSViv(0));
eb8433b7 8169 op_getmad(oldo,o,'O');
06492da6 8170 }
11343788 8171 return o;
79072805
LW		 8172}
8173
8174OP *
cea2e8a9 8175Perl_ck_svconst(pTHX_ OP *o)
8990e307 8176{
7918f24d 8177 PERL_ARGS_ASSERT_CK_SVCONST;
96a5add6 8178 PERL_UNUSED_CONTEXT;
11343788
MB		 8179 SvREADONLY_on(cSVOPo->op_sv);
8180 return o;
8990e307
LW		 8181}
8182
8183OP *
d4ac975e
GA		 8184Perl_ck_chdir(pTHX_ OP *o)
8185{
8186 if (o->op_flags & OPf_KIDS) {
1496a290 8187 SVOP * const kid = (SVOP*)cUNOPo->op_first;
d4ac975e
GA		 8188
8189 if (kid && kid->op_type == OP_CONST &&
8190 (kid->op_private & OPpCONST_BARE))
8191 {
8192 o->op_flags |= OPf_SPECIAL;
8193 kid->op_private &= ~OPpCONST_STRICT;
8194 }
8195 }
8196 return ck_fun(o);
8197}
8198
8199OP *
cea2e8a9 8200Perl_ck_trunc(pTHX_ OP *o)
79072805 8201{
7918f24d
NC		 8202 PERL_ARGS_ASSERT_CK_TRUNC;
8203
11343788
MB		 8204 if (o->op_flags & OPf_KIDS) {
8205 SVOP *kid = (SVOP*)cUNOPo->op_first;
79072805 8206
a0d0e21e
LW		 8207 if (kid->op_type == OP_NULL)
8208 kid = (SVOP*)kid->op_sibling;
bb53490d
GS		 8209 if (kid && kid->op_type == OP_CONST &&
8210 (kid->op_private & OPpCONST_BARE))
8211 {
11343788 8212 o->op_flags |= OPf_SPECIAL;
bb53490d
GS		 8213 kid->op_private &= ~OPpCONST_STRICT;
8214 }
79072805 8215 }
11343788 8216 return ck_fun(o);
79072805
LW		 8217}
8218
35fba0d9 8219OP *
bab9c0ac
RGS		 8220Perl_ck_unpack(pTHX_ OP *o)
8221{
8222 OP *kid = cLISTOPo->op_first;
7918f24d
NC		 8223
8224 PERL_ARGS_ASSERT_CK_UNPACK;
8225
bab9c0ac
RGS		 8226 if (kid->op_sibling) {
8227 kid = kid->op_sibling;
8228 if (!kid->op_sibling)
8229 kid->op_sibling = newDEFSVOP();
8230 }
8231 return ck_fun(o);
8232}
8233
8234OP *
35fba0d9
RG		 8235Perl_ck_substr(pTHX_ OP *o)
8236{
7918f24d
NC		 8237 PERL_ARGS_ASSERT_CK_SUBSTR;
8238
35fba0d9 8239 o = ck_fun(o);
1d866c12 8240 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
35fba0d9
RG		 8241 OP *kid = cLISTOPo->op_first;
8242
8243 if (kid->op_type == OP_NULL)
8244 kid = kid->op_sibling;
8245 if (kid)
8246 kid->op_flags |= OPf_MOD;
8247
8248 }
8249 return o;
8250}
8251
878d132a
NC		 8252OP *
8253Perl_ck_each(pTHX_ OP *o)
8254{
d75c0fe7 8255 dVAR;
878d132a
NC		 8256 OP *kid = cLISTOPo->op_first;
8257
7918f24d
NC		 8258 PERL_ARGS_ASSERT_CK_EACH;
8259
878d132a
NC		 8260 if (kid->op_type == OP_PADAV || kid->op_type == OP_RV2AV) {
8261 const unsigned new_type = o->op_type == OP_EACH ? OP_AEACH
8262 : o->op_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
8263 o->op_type = new_type;
8264 o->op_ppaddr = PL_ppaddr[new_type];
8265 }
8266 else if (!(kid->op_type == OP_PADHV || kid->op_type == OP_RV2HV
8267 || (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE)
8268 )) {
8269 bad_type(1, "hash or array", PL_op_desc[o->op_type], kid);
8270 return o;
8271 }
8272 return ck_fun(o);
8273}
8274
61b743bb
DM		 8275/* A peephole optimizer. We visit the ops in the order they're to execute.
8276 * See the comments at the top of this file for more details about when
8277 * peep() is called */
463ee0b2 8278
79072805 8279void
864dbfa3 8280Perl_peep(pTHX_ register OP *o)
79072805 8281{
27da23d5 8282 dVAR;
c445ea15 8283 register OP* oldop = NULL;
2d8e6c8d 8284
2814eb74 8285 if (!o || o->op_opt)
79072805 8286 return;
a0d0e21e 8287 ENTER;
462e5cf6 8288 SAVEOP();
7766f137 8289 SAVEVPTR(PL_curcop);
a0d0e21e 8290 for (; o; o = o->op_next) {
2814eb74 8291 if (o->op_opt)
a0d0e21e 8292 break;
6d7dd4a5
NC		 8293 /* By default, this op has now been optimised. A couple of cases below
8294 clear this again. */
8295 o->op_opt = 1;
533c011a 8296 PL_op = o;
a0d0e21e
LW		 8297 switch (o->op_type) {
8298 case OP_NEXTSTATE:
8299 case OP_DBSTATE:
3280af22 8300 PL_curcop = ((COP*)o); /* for warnings */
a0d0e21e
LW		 8301 break;
8302
a0d0e21e 8303 case OP_CONST:
7a52d87a
GS		 8304 if (cSVOPo->op_private & OPpCONST_STRICT)
8305 no_bareword_allowed(o);
7766f137 8306#ifdef USE_ITHREADS
996c9baa 8307 case OP_HINTSEVAL:
3848b962 8308 case OP_METHOD_NAMED:
7766f137
GS		 8309 /* Relocate sv to the pad for thread safety.
8310 * Despite being a "constant", the SV is written to,
8311 * for reference counts, sv_upgrade() etc. */
8312 if (cSVOP->op_sv) {
6867be6d 8313 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
996c9baa 8314 if (o->op_type != OP_METHOD_NAMED && SvPADTMP(cSVOPo->op_sv)) {
6a7129a1 8315 /* If op_sv is already a PADTMP then it is being used by
9a049f1c 8316 * some pad, so make a copy. */
dd2155a4
DM		 8317 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
8318 SvREADONLY_on(PAD_SVl(ix));
6a7129a1
GS		 8319 SvREFCNT_dec(cSVOPo->op_sv);
8320 }
996c9baa 8321 else if (o->op_type != OP_METHOD_NAMED
052ca17e
NC		 8322 && cSVOPo->op_sv == &PL_sv_undef) {
8323 /* PL_sv_undef is hack - it's unsafe to store it in the
8324 AV that is the pad, because av_fetch treats values of
8325 PL_sv_undef as a "free" AV entry and will merrily
8326 replace them with a new SV, causing pad_alloc to think
8327 that this pad slot is free. (When, clearly, it is not)
8328 */
8329 SvOK_off(PAD_SVl(ix));
8330 SvPADTMP_on(PAD_SVl(ix));
8331 SvREADONLY_on(PAD_SVl(ix));
8332 }
6a7129a1 8333 else {
dd2155a4 8334 SvREFCNT_dec(PAD_SVl(ix));
6a7129a1 8335 SvPADTMP_on(cSVOPo->op_sv);
dd2155a4 8336 PAD_SETSV(ix, cSVOPo->op_sv);
9a049f1c 8337 /* XXX I don't know how this isn't readonly already. */
dd2155a4 8338 SvREADONLY_on(PAD_SVl(ix));
6a7129a1 8339 }
a0714e2c 8340 cSVOPo->op_sv = NULL;
7766f137
GS		 8341 o->op_targ = ix;
8342 }
8343#endif
07447971
GS		 8344 break;
8345
df91b2c5
AE		 8346 case OP_CONCAT:
8347 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
8348 if (o->op_next->op_private & OPpTARGET_MY) {
8349 if (o->op_flags & OPf_STACKED) /* chained concats */
a6aa0b75 8350 break; /* ignore_optimization */
df91b2c5
AE		 8351 else {
8352 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
8353 o->op_targ = o->op_next->op_targ;
8354 o->op_next->op_targ = 0;
8355 o->op_private |= OPpTARGET_MY;
8356 }
8357 }
8358 op_null(o->op_next);
8359 }
df91b2c5 8360 break;
6d7dd4a5
NC		 8361 case OP_STUB:
8362 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
8363 break; /* Scalar stub must produce undef. List stub is noop */
8364 }
8365 goto nothin;
79072805 8366 case OP_NULL:
acb36ea4 8367 if (o->op_targ == OP_NEXTSTATE
5edb5b2a 8368 || o->op_targ == OP_DBSTATE)
acb36ea4 8369 {
3280af22 8370 PL_curcop = ((COP*)o);
acb36ea4 8371 }
dad75012
AMS		 8372 /* XXX: We avoid setting op_seq here to prevent later calls
8373 to peep() from mistakenly concluding that optimisation
8374 has already occurred. This doesn't fix the real problem,
8375 though (See 20010220.007). AMS 20010719 */
2814eb74 8376 /* op_seq functionality is now replaced by op_opt */
6d7dd4a5 8377 o->op_opt = 0;
f46f2f82 8378 /* FALL THROUGH */
79072805 8379 case OP_SCALAR:
93a17b20 8380 case OP_LINESEQ:
463ee0b2 8381 case OP_SCOPE:
6d7dd4a5 8382 nothin:
a0d0e21e
LW		 8383 if (oldop && o->op_next) {
8384 oldop->op_next = o->op_next;
6d7dd4a5 8385 o->op_opt = 0;
79072805
LW		 8386 continue;
8387 }
79072805
LW		 8388 break;
8389
6a077020 8390 case OP_PADAV:
79072805 8391 case OP_GV:
6a077020 8392 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
0bd48802 8393 OP* const pop = (o->op_type == OP_PADAV) ?
6a077020 8394 o->op_next : o->op_next->op_next;
a0d0e21e 8395 IV i;
f9dc862f 8396 if (pop && pop->op_type == OP_CONST &&
af5acbb4 8397 ((PL_op = pop->op_next)) &&
8990e307 8398 pop->op_next->op_type == OP_AELEM &&
a0d0e21e 8399 !(pop->op_next->op_private &
78f9721b 8400 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
fc15ae8f 8401 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
a0d0e21e 8402 <= 255 &&
8990e307
LW		 8403 i >= 0)
8404 {
350de78d 8405 GV *gv;
af5acbb4
DM		 8406 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
8407 no_bareword_allowed(pop);
6a077020
DM		 8408 if (o->op_type == OP_GV)
8409 op_null(o->op_next);
93c66552
DM		 8410 op_null(pop->op_next);
8411 op_null(pop);
a0d0e21e
LW		 8412 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
8413 o->op_next = pop->op_next->op_next;
22c35a8c 8414 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
a0d0e21e 8415 o->op_private = (U8)i;
6a077020
DM		 8416 if (o->op_type == OP_GV) {
8417 gv = cGVOPo_gv;
8418 GvAVn(gv);
8419 }
8420 else
8421 o->op_flags |= OPf_SPECIAL;
8422 o->op_type = OP_AELEMFAST;
8423 }
6a077020
DM		 8424 break;
8425 }
8426
8427 if (o->op_next->op_type == OP_RV2SV) {
8428 if (!(o->op_next->op_private & OPpDEREF)) {
8429 op_null(o->op_next);
8430 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
8431 | OPpOUR_INTRO);
8432 o->op_next = o->op_next->op_next;
8433 o->op_type = OP_GVSV;
8434 o->op_ppaddr = PL_ppaddr[OP_GVSV];
8990e307 8435 }
79072805 8436 }
e476b1b5 8437 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
551405c4 8438 GV * const gv = cGVOPo_gv;
b15aece3 8439 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
76cd736e 8440 /* XXX could check prototype here instead of just carping */
551405c4 8441 SV * const sv = sv_newmortal();
bd61b366 8442 gv_efullname3(sv, gv, NULL);
9014280d 8443 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
35c1215d 8444 "%"SVf"() called too early to check prototype",
be2597df 8445 SVfARG(sv));
76cd736e
GS		 8446 }
8447 }
89de2904
AMS		 8448 else if (o->op_next->op_type == OP_READLINE
8449 && o->op_next->op_next->op_type == OP_CONCAT
8450 && (o->op_next->op_next->op_flags & OPf_STACKED))
8451 {
d2c45030
AMS		 8452 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
8453 o->op_type = OP_RCATLINE;
8454 o->op_flags |= OPf_STACKED;
8455 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
89de2904 8456 op_null(o->op_next->op_next);
d2c45030 8457 op_null(o->op_next);
89de2904 8458 }
76cd736e 8459
79072805
LW		 8460 break;
8461
a0d0e21e 8462 case OP_MAPWHILE:
79072805
LW		 8463 case OP_GREPWHILE:
8464 case OP_AND:
8465 case OP_OR:
c963b151 8466 case OP_DOR:
2c2d71f5
JH		 8467 case OP_ANDASSIGN:
8468 case OP_ORASSIGN:
c963b151 8469 case OP_DORASSIGN:
1a67a97c
SM		 8470 case OP_COND_EXPR:
8471 case OP_RANGE:
c5917253 8472 case OP_ONCE:
fd4d1407
IZ		 8473 while (cLOGOP->op_other->op_type == OP_NULL)
8474 cLOGOP->op_other = cLOGOP->op_other->op_next;
a2efc822 8475 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
79072805
LW		 8476 break;
8477
79072805 8478 case OP_ENTERLOOP:
9c2ca71a 8479 case OP_ENTERITER:
58cccf98
SM		 8480 while (cLOOP->op_redoop->op_type == OP_NULL)
8481 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
79072805 8482 peep(cLOOP->op_redoop);
58cccf98
SM		 8483 while (cLOOP->op_nextop->op_type == OP_NULL)
8484 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
79072805 8485 peep(cLOOP->op_nextop);
58cccf98
SM		 8486 while (cLOOP->op_lastop->op_type == OP_NULL)
8487 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
79072805
LW		 8488 peep(cLOOP->op_lastop);
8489 break;
8490
79072805 8491 case OP_SUBST:
29f2e912
NC		 8492 assert(!(cPMOP->op_pmflags & PMf_ONCE));
8493 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
8494 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
8495 cPMOP->op_pmstashstartu.op_pmreplstart
8496 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
8497 peep(cPMOP->op_pmstashstartu.op_pmreplstart);
79072805
LW		 8498 break;
8499
a0d0e21e 8500 case OP_EXEC:
041457d9
DM		 8501 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
8502 && ckWARN(WARN_SYNTAX))
8503 {
1496a290
AL		 8504 if (o->op_next->op_sibling) {
8505 const OPCODE type = o->op_next->op_sibling->op_type;
8506 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
8507 const line_t oldline = CopLINE(PL_curcop);
8508 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
8509 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8510 "Statement unlikely to be reached");
8511 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8512 "\t(Maybe you meant system() when you said exec()?)\n");
8513 CopLINE_set(PL_curcop, oldline);
8514 }
a0d0e21e
LW		 8515 }
8516 }
8517 break;
b2ffa427 8518
c750a3ec 8519 case OP_HELEM: {
e75d1f10 8520 UNOP *rop;
6d822dc4 8521 SV *lexname;
e75d1f10 8522 GV **fields;
6d822dc4 8523 SV **svp, *sv;
d5263905 8524 const char *key = NULL;
c750a3ec 8525 STRLEN keylen;
b2ffa427 8526
1c846c1f 8527 if (((BINOP*)o)->op_last->op_type != OP_CONST)
c750a3ec 8528 break;
1c846c1f
NIS		 8529
8530 /* Make the CONST have a shared SV */
8531 svp = cSVOPx_svp(((BINOP*)o)->op_last);
38bb37b9 8532 if (!SvFAKE(sv = *svp) || !SvREADONLY(sv)) {
d5263905 8533 key = SvPV_const(sv, keylen);
25716404 8534 lexname = newSVpvn_share(key,
bb7a0f54 8535 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
25716404 8536 0);
1c846c1f
NIS		 8537 SvREFCNT_dec(sv);
8538 *svp = lexname;
8539 }
e75d1f10
RD		 8540
8541 if ((o->op_private & (OPpLVAL_INTRO)))
8542 break;
8543
8544 rop = (UNOP*)((BINOP*)o)->op_first;
8545 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
8546 break;
8547 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
00b1698f 8548 if (!SvPAD_TYPED(lexname))
e75d1f10 8549 break;
a4fc7abc 8550 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
e75d1f10
RD		 8551 if (!fields || !GvHV(*fields))
8552 break;
93524f2b 8553 key = SvPV_const(*svp, keylen);
e75d1f10 8554 if (!hv_fetch(GvHV(*fields), key,
bb7a0f54 8555 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
e75d1f10
RD		 8556 {
8557 Perl_croak(aTHX_ "No such class field \"%s\" "
8558 "in variable %s of type %s",
93524f2b 8559 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
e75d1f10
RD		 8560 }
8561
6d822dc4
MS		 8562 break;
8563 }
c750a3ec 8564
e75d1f10
RD		 8565 case OP_HSLICE: {
8566 UNOP *rop;
8567 SV *lexname;
8568 GV **fields;
8569 SV **svp;
93524f2b 8570 const char *key;
e75d1f10
RD		 8571 STRLEN keylen;
8572 SVOP *first_key_op, *key_op;
8573
8574 if ((o->op_private & (OPpLVAL_INTRO))
8575 /* I bet there's always a pushmark... */
8576 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
8577 /* hmmm, no optimization if list contains only one key. */
8578 break;
8579 rop = (UNOP*)((LISTOP*)o)->op_last;
8580 if (rop->op_type != OP_RV2HV)
8581 break;
8582 if (rop->op_first->op_type == OP_PADSV)
8583 /* @$hash{qw(keys here)} */
8584 rop = (UNOP*)rop->op_first;
8585 else {
8586 /* @{$hash}{qw(keys here)} */
8587 if (rop->op_first->op_type == OP_SCOPE
8588 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
8589 {
8590 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
8591 }
8592 else
8593 break;
8594 }
8595
8596 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
00b1698f 8597 if (!SvPAD_TYPED(lexname))
e75d1f10 8598 break;
a4fc7abc 8599 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
e75d1f10
RD		 8600 if (!fields || !GvHV(*fields))
8601 break;
8602 /* Again guessing that the pushmark can be jumped over.... */
8603 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
8604 ->op_first->op_sibling;
8605 for (key_op = first_key_op; key_op;
8606 key_op = (SVOP*)key_op->op_sibling) {
8607 if (key_op->op_type != OP_CONST)
8608 continue;
8609 svp = cSVOPx_svp(key_op);
93524f2b 8610 key = SvPV_const(*svp, keylen);
e75d1f10 8611 if (!hv_fetch(GvHV(*fields), key,
bb7a0f54 8612 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
e75d1f10
RD		 8613 {
8614 Perl_croak(aTHX_ "No such class field \"%s\" "
8615 "in variable %s of type %s",
bfcb3514 8616 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
e75d1f10
RD		 8617 }
8618 }
8619 break;
8620 }
8621
fe1bc4cf 8622 case OP_SORT: {
fe1bc4cf 8623 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
551405c4 8624 OP *oleft;
fe1bc4cf
DM		 8625 OP *o2;
8626
fe1bc4cf 8627 /* check that RHS of sort is a single plain array */
551405c4 8628 OP *oright = cUNOPo->op_first;
fe1bc4cf
DM		 8629 if (!oright || oright->op_type != OP_PUSHMARK)
8630 break;
471178c0
NC		 8631
8632 /* reverse sort ... can be optimised. */
8633 if (!cUNOPo->op_sibling) {
8634 /* Nothing follows us on the list. */
551405c4 8635 OP * const reverse = o->op_next;
471178c0
NC		 8636
8637 if (reverse->op_type == OP_REVERSE &&
8638 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
551405c4 8639 OP * const pushmark = cUNOPx(reverse)->op_first;
471178c0
NC		 8640 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8641 && (cUNOPx(pushmark)->op_sibling == o)) {
8642 /* reverse -> pushmark -> sort */
8643 o->op_private |= OPpSORT_REVERSE;
8644 op_null(reverse);
8645 pushmark->op_next = oright->op_next;
8646 op_null(oright);
8647 }
8648 }
8649 }
8650
8651 /* make @a = sort @a act in-place */
8652
fe1bc4cf
DM		 8653 oright = cUNOPx(oright)->op_sibling;
8654 if (!oright)
8655 break;
8656 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8657 oright = cUNOPx(oright)->op_sibling;
8658 }
8659
8660 if (!oright ||
8661 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8662 || oright->op_next != o
8663 || (oright->op_private & OPpLVAL_INTRO)
8664 )
8665 break;
8666
8667 /* o2 follows the chain of op_nexts through the LHS of the
8668 * assign (if any) to the aassign op itself */
8669 o2 = o->op_next;
8670 if (!o2 || o2->op_type != OP_NULL)
8671 break;
8672 o2 = o2->op_next;
8673 if (!o2 || o2->op_type != OP_PUSHMARK)
8674 break;
8675 o2 = o2->op_next;
8676 if (o2 && o2->op_type == OP_GV)
8677 o2 = o2->op_next;
8678 if (!o2
8679 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8680 || (o2->op_private & OPpLVAL_INTRO)
8681 )
8682 break;
8683 oleft = o2;
8684 o2 = o2->op_next;
8685 if (!o2 || o2->op_type != OP_NULL)
8686 break;
8687 o2 = o2->op_next;
8688 if (!o2 || o2->op_type != OP_AASSIGN
8689 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8690 break;
8691
db7511db
DM		 8692 /* check that the sort is the first arg on RHS of assign */
8693
8694 o2 = cUNOPx(o2)->op_first;
8695 if (!o2 || o2->op_type != OP_NULL)
8696 break;
8697 o2 = cUNOPx(o2)->op_first;
8698 if (!o2 || o2->op_type != OP_PUSHMARK)
8699 break;
8700 if (o2->op_sibling != o)
8701 break;
8702
fe1bc4cf
DM		 8703 /* check the array is the same on both sides */
8704 if (oleft->op_type == OP_RV2AV) {
8705 if (oright->op_type != OP_RV2AV
8706 || !cUNOPx(oright)->op_first
8707 || cUNOPx(oright)->op_first->op_type != OP_GV
8708 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8709 cGVOPx_gv(cUNOPx(oright)->op_first)
8710 )
8711 break;
8712 }
8713 else if (oright->op_type != OP_PADAV
8714 || oright->op_targ != oleft->op_targ
8715 )
8716 break;
8717
8718 /* transfer MODishness etc from LHS arg to RHS arg */
8719 oright->op_flags = oleft->op_flags;
8720 o->op_private |= OPpSORT_INPLACE;
8721
8722 /* excise push->gv->rv2av->null->aassign */
8723 o2 = o->op_next->op_next;
8724 op_null(o2); /* PUSHMARK */
8725 o2 = o2->op_next;
8726 if (o2->op_type == OP_GV) {
8727 op_null(o2); /* GV */
8728 o2 = o2->op_next;
8729 }
8730 op_null(o2); /* RV2AV or PADAV */
8731 o2 = o2->op_next->op_next;
8732 op_null(o2); /* AASSIGN */
8733
8734 o->op_next = o2->op_next;
8735
8736 break;
8737 }
ef3e5ea9
NC		 8738
8739 case OP_REVERSE: {
e682d7b7 8740 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
ce335f37 8741 OP *gvop = NULL;
ef3e5ea9 8742 LISTOP *enter, *exlist;
ef3e5ea9
NC		 8743
8744 enter = (LISTOP *) o->op_next;
8745 if (!enter)
8746 break;
8747 if (enter->op_type == OP_NULL) {
8748 enter = (LISTOP *) enter->op_next;
8749 if (!enter)
8750 break;
8751 }
d46f46af
NC		 8752 /* for $a (...) will have OP_GV then OP_RV2GV here.
8753 for (...) just has an OP_GV. */
ce335f37
NC		 8754 if (enter->op_type == OP_GV) {
8755 gvop = (OP *) enter;
8756 enter = (LISTOP *) enter->op_next;
8757 if (!enter)
8758 break;
d46f46af
NC		 8759 if (enter->op_type == OP_RV2GV) {
8760 enter = (LISTOP *) enter->op_next;
8761 if (!enter)
ce335f37 8762 break;
d46f46af 8763 }
ce335f37
NC		 8764 }
8765
ef3e5ea9
NC		 8766 if (enter->op_type != OP_ENTERITER)
8767 break;
8768
8769 iter = enter->op_next;
8770 if (!iter || iter->op_type != OP_ITER)
8771 break;
8772
ce335f37
NC		 8773 expushmark = enter->op_first;
8774 if (!expushmark || expushmark->op_type != OP_NULL
8775 || expushmark->op_targ != OP_PUSHMARK)
8776 break;
8777
8778 exlist = (LISTOP *) expushmark->op_sibling;
ef3e5ea9
NC		 8779 if (!exlist || exlist->op_type != OP_NULL
8780 || exlist->op_targ != OP_LIST)
8781 break;
8782
8783 if (exlist->op_last != o) {
8784 /* Mmm. Was expecting to point back to this op. */
8785 break;
8786 }
8787 theirmark = exlist->op_first;
8788 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8789 break;
8790
c491ecac 8791 if (theirmark->op_sibling != o) {
ef3e5ea9
NC		 8792 /* There's something between the mark and the reverse, eg
8793 for (1, reverse (...))
8794 so no go. */
8795 break;
8796 }
8797
c491ecac
NC		 8798 ourmark = ((LISTOP *)o)->op_first;
8799 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8800 break;
8801
ef3e5ea9
NC		 8802 ourlast = ((LISTOP *)o)->op_last;
8803 if (!ourlast || ourlast->op_next != o)
8804 break;
8805
e682d7b7
NC		 8806 rv2av = ourmark->op_sibling;
8807 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8808 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8809 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8810 /* We're just reversing a single array. */
8811 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8812 enter->op_flags |= OPf_STACKED;
8813 }
8814
ef3e5ea9
NC		 8815 /* We don't have control over who points to theirmark, so sacrifice
8816 ours. */
8817 theirmark->op_next = ourmark->op_next;
8818 theirmark->op_flags = ourmark->op_flags;
ce335f37 8819 ourlast->op_next = gvop ? gvop : (OP *) enter;
ef3e5ea9
NC		 8820 op_null(ourmark);
8821 op_null(o);
8822 enter->op_private |= OPpITER_REVERSED;
8823 iter->op_private |= OPpITER_REVERSED;
8824
8825 break;
8826 }
e26df76a
NC		 8827
8828 case OP_SASSIGN: {
8829 OP *rv2gv;
8830 UNOP *refgen, *rv2cv;
8831 LISTOP *exlist;
8832
50baa5ea 8833 if ((o->op_flags & OPf_WANT) != OPf_WANT_VOID)
de3370bc
NC		 8834 break;
8835
e26df76a
NC		 8836 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8837 break;
8838
8839 rv2gv = ((BINOP *)o)->op_last;
8840 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8841 break;
8842
8843 refgen = (UNOP *)((BINOP *)o)->op_first;
8844
8845 if (!refgen || refgen->op_type != OP_REFGEN)
8846 break;
8847
8848 exlist = (LISTOP *)refgen->op_first;
8849 if (!exlist || exlist->op_type != OP_NULL
8850 || exlist->op_targ != OP_LIST)
8851 break;
8852
8853 if (exlist->op_first->op_type != OP_PUSHMARK)
8854 break;
8855
8856 rv2cv = (UNOP*)exlist->op_last;
8857
8858 if (rv2cv->op_type != OP_RV2CV)
8859 break;
8860
8861 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8862 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8863 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8864
8865 o->op_private |= OPpASSIGN_CV_TO_GV;
8866 rv2gv->op_private |= OPpDONT_INIT_GV;
8867 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8868
8869 break;
8870 }
8871
fe1bc4cf 8872
0477511c
NC		 8873 case OP_QR:
8874 case OP_MATCH:
29f2e912
NC		 8875 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
8876 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
8877 }
79072805
LW		 8878 break;
8879 }
a0d0e21e 8880 oldop = o;
79072805 8881 }
a0d0e21e 8882 LEAVE;
79072805 8883}
beab0874 8884
cef6ea9d 8885const char*
1cb0ed9b 8886Perl_custom_op_name(pTHX_ const OP* o)
53e06cf0 8887{
97aff369 8888 dVAR;
e1ec3a88 8889 const IV index = PTR2IV(o->op_ppaddr);
53e06cf0
SC		 8890 SV* keysv;
8891 HE* he;
8892
7918f24d
NC		 8893 PERL_ARGS_ASSERT_CUSTOM_OP_NAME;
8894
53e06cf0 8895 if (!PL_custom_op_names) /* This probably shouldn't happen */
27da23d5 8896 return (char *)PL_op_name[OP_CUSTOM];
53e06cf0
SC		 8897
8898 keysv = sv_2mortal(newSViv(index));
8899
8900 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8901 if (!he)
27da23d5 8902 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
53e06cf0
SC		 8903
8904 return SvPV_nolen(HeVAL(he));
8905}
8906
cef6ea9d 8907const char*
1cb0ed9b 8908Perl_custom_op_desc(pTHX_ const OP* o)
53e06cf0 8909{
97aff369 8910 dVAR;
e1ec3a88 8911 const IV index = PTR2IV(o->op_ppaddr);
53e06cf0
SC		 8912 SV* keysv;
8913 HE* he;
8914
7918f24d
NC		 8915 PERL_ARGS_ASSERT_CUSTOM_OP_DESC;
8916
53e06cf0 8917 if (!PL_custom_op_descs)
27da23d5 8918 return (char *)PL_op_desc[OP_CUSTOM];
53e06cf0
SC		 8919
8920 keysv = sv_2mortal(newSViv(index));
8921
8922 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8923 if (!he)
27da23d5 8924 return (char *)PL_op_desc[OP_CUSTOM];
53e06cf0
SC		 8925
8926 return SvPV_nolen(HeVAL(he));
8927}
19e8ce8e 8928
beab0874
JT		 8929#include "XSUB.h"
8930
8931/* Efficient sub that returns a constant scalar value. */
8932static void
acfe0abc 8933const_sv_xsub(pTHX_ CV* cv)
beab0874 8934{
97aff369 8935 dVAR;
beab0874 8936 dXSARGS;
99ab892b 8937 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
9cbac4c7 8938 if (items != 0) {
6f207bd3 8939 NOOP;
9cbac4c7 8940#if 0
fe13d51d 8941 /* diag_listed_as: SKIPME */
9cbac4c7 8942 Perl_croak(aTHX_ "usage: %s::%s()",
bfcb3514 8943 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
9cbac4c7
DM		 8944#endif
8945 }
99ab892b
NC		 8946 if (!sv) {
8947 XSRETURN(0);
8948 }
9a049f1c 8949 EXTEND(sp, 1);
99ab892b 8950 ST(0) = sv;
beab0874
JT		 8951 XSRETURN(1);
8952}
4946a0fa
NC		 8953
8954/*
8955 * Local variables:
8956 * c-indentation-style: bsd
8957 * c-basic-offset: 4
8958 * indent-tabs-mode: t
8959 * End:
8960 *
37442d52
RGS		 8961 * ex: set ts=8 sts=4 sw=4 noet:
8962 */
Unnamed repository; edit this file 'description' to name the repository.