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