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
Don’t use CopFILESV for ‘once’ warnings
[perl5.git] / op.c
CommitLineData
4b88f280 1#line 2 "op.c"
a0d0e21e 2/* op.c
79072805 3 *
1129b882
NC		 4 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
5 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
79072805
LW		 6 *
7 * You may distribute under the terms of either the GNU General Public
8 * License or the Artistic License, as specified in the README file.
9 *
a0d0e21e
LW		 10 */
11
12/*
4ac71550
TC		 13 * 'You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
14 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
15 * youngest of the Old Took's daughters); and Mr. Drogo was his second
16 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
17 * either way, as the saying is, if you follow me.' --the Gaffer
18 *
19 * [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
79072805
LW		 20 */
21
166f8a29
DM		 22/* This file contains the functions that create, manipulate and optimize
23 * the OP structures that hold a compiled perl program.
24 *
25 * A Perl program is compiled into a tree of OPs. Each op contains
26 * structural pointers (eg to its siblings and the next op in the
27 * execution sequence), a pointer to the function that would execute the
28 * op, plus any data specific to that op. For example, an OP_CONST op
29 * points to the pp_const() function and to an SV containing the constant
30 * value. When pp_const() is executed, its job is to push that SV onto the
31 * stack.
32 *
33 * OPs are mainly created by the newFOO() functions, which are mainly
34 * called from the parser (in perly.y) as the code is parsed. For example
35 * the Perl code $a + $b * $c would cause the equivalent of the following
36 * to be called (oversimplifying a bit):
37 *
38 * newBINOP(OP_ADD, flags,
39 * newSVREF($a),
40 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
41 * )
42 *
43 * Note that during the build of miniperl, a temporary copy of this file
44 * is made, called opmini.c.
45 */
ccfc67b7 46
61b743bb
DM		 47/*
48Perl's compiler is essentially a 3-pass compiler with interleaved phases:
49
50 A bottom-up pass
51 A top-down pass
52 An execution-order pass
53
54The bottom-up pass is represented by all the "newOP" routines and
55the ck_ routines. The bottom-upness is actually driven by yacc.
56So at the point that a ck_ routine fires, we have no idea what the
57context is, either upward in the syntax tree, or either forward or
58backward in the execution order. (The bottom-up parser builds that
59part of the execution order it knows about, but if you follow the "next"
60links around, you'll find it's actually a closed loop through the
ef9da979 61top level node.)
61b743bb
DM		 62
63Whenever the bottom-up parser gets to a node that supplies context to
64its components, it invokes that portion of the top-down pass that applies
65to that part of the subtree (and marks the top node as processed, so
66if a node further up supplies context, it doesn't have to take the
67plunge again). As a particular subcase of this, as the new node is
68built, it takes all the closed execution loops of its subcomponents
69and links them into a new closed loop for the higher level node. But
70it's still not the real execution order.
71
72The actual execution order is not known till we get a grammar reduction
73to a top-level unit like a subroutine or file that will be called by
74"name" rather than via a "next" pointer. At that point, we can call
75into peep() to do that code's portion of the 3rd pass. It has to be
76recursive, but it's recursive on basic blocks, not on tree nodes.
77*/
78
06e0342d 79/* To implement user lexical pragmas, there needs to be a way at run time to
b3ca2e83
NC		 80 get the compile time state of %^H for that block. Storing %^H in every
81 block (or even COP) would be very expensive, so a different approach is
82 taken. The (running) state of %^H is serialised into a tree of HE-like
83 structs. Stores into %^H are chained onto the current leaf as a struct
84 refcounted_he * with the key and the value. Deletes from %^H are saved
85 with a value of PL_sv_placeholder. The state of %^H at any point can be
86 turned back into a regular HV by walking back up the tree from that point's
06e0342d 87 leaf, ignoring any key you've already seen (placeholder or not), storing
b3ca2e83
NC		 88 the rest into the HV structure, then removing the placeholders. Hence
89 memory is only used to store the %^H deltas from the enclosing COP, rather
90 than the entire %^H on each COP.
91
92 To cause actions on %^H to write out the serialisation records, it has
93 magic type 'H'. This magic (itself) does nothing, but its presence causes
94 the values to gain magic type 'h', which has entries for set and clear.
c28fe1ec 95 C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
34795b44 96 record, with deletes written by C<Perl_magic_clearhint>. C<SAVEHINTS>
c28fe1ec
NC		 97 saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
98 it will be correctly restored when any inner compiling scope is exited.
b3ca2e83
NC		 99*/
100
79072805 101#include "EXTERN.h"
864dbfa3 102#define PERL_IN_OP_C
79072805 103#include "perl.h"
77ca0c92 104#include "keywords.h"
2846acbf 105#include "feature.h"
74529a43 106#include "regcomp.h"
79072805 107
16c91539 108#define CALL_PEEP(o) PL_peepp(aTHX_ o)
1a0a2ba9 109#define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
16c91539 110#define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
a2efc822 111
8be227ab
FC		 112/* See the explanatory comments above struct opslab in op.h. */
113
7aef8e5b 114#ifdef PERL_DEBUG_READONLY_OPS
3107b51f
FC		 115# define PERL_SLAB_SIZE 128
116# define PERL_MAX_SLAB_SIZE 4096
117# include <sys/mman.h>
7aef8e5b 118#endif
3107b51f 119
7aef8e5b 120#ifndef PERL_SLAB_SIZE
8be227ab 121# define PERL_SLAB_SIZE 64
7aef8e5b
FC		 122#endif
123#ifndef PERL_MAX_SLAB_SIZE
e6cee8c0 124# define PERL_MAX_SLAB_SIZE 2048
7aef8e5b 125#endif
8be227ab
FC		 126
127/* rounds up to nearest pointer */
7aef8e5b
FC		 128#define SIZE_TO_PSIZE(x) (((x) + sizeof(I32 *) - 1)/sizeof(I32 *))
129#define DIFF(o,p) ((size_t)((I32 **)(p) - (I32**)(o)))
8be227ab
FC		 130
131static OPSLAB *
132S_new_slab(pTHX_ size_t sz)
133{
7aef8e5b 134#ifdef PERL_DEBUG_READONLY_OPS
3107b51f
FC		 135 OPSLAB *slab = (OPSLAB *) mmap(0, sz * sizeof(I32 *),
136 PROT_READ|PROT_WRITE,
137 MAP_ANON|MAP_PRIVATE, -1, 0);
138 DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
139 (unsigned long) sz, slab));
140 if (slab == MAP_FAILED) {
141 perror("mmap failed");
142 abort();
143 }
144 slab->opslab_size = (U16)sz;
7aef8e5b 145#else
8be227ab 146 OPSLAB *slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *));
7aef8e5b 147#endif
8be227ab
FC		 148 slab->opslab_first = (OPSLOT *)((I32 **)slab + sz - 1);
149 return slab;
150}
151
e7372881
FC		 152/* requires double parens and aTHX_ */
153#define DEBUG_S_warn(args) \
154 DEBUG_S( \
155 PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \
156 )
157
8be227ab
FC		 158void *
159Perl_Slab_Alloc(pTHX_ size_t sz)
160{
161 dVAR;
162 OPSLAB *slab;
163 OPSLAB *slab2;
164 OPSLOT *slot;
165 OP *o;
5cb52f30 166 size_t opsz, space;
8be227ab 167
2073970f
NC		 168 /* We only allocate ops from the slab during subroutine compilation.
169 We find the slab via PL_compcv, hence that must be non-NULL. It could
170 also be pointing to a subroutine which is now fully set up (CvROOT()
171 pointing to the top of the optree for that sub), or a subroutine
172 which isn't using the slab allocator. If our sanity checks aren't met,
173 don't use a slab, but allocate the OP directly from the heap. */
8be227ab
FC		 174 if (!PL_compcv || CvROOT(PL_compcv)
175 || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv)))
176 return PerlMemShared_calloc(1, sz);
177
2073970f
NC		 178 /* While the subroutine is under construction, the slabs are accessed via
179 CvSTART(), to avoid needing to expand PVCV by one pointer for something
180 unneeded at runtime. Once a subroutine is constructed, the slabs are
181 accessed via CvROOT(). So if CvSTART() is NULL, no slab has been
182 allocated yet. See the commit message for 8be227ab5eaa23f2 for more
183 details. */
184 if (!CvSTART(PL_compcv)) {
8be227ab
FC		 185 CvSTART(PL_compcv) =
186 (OP *)(slab = S_new_slab(aTHX_ PERL_SLAB_SIZE));
187 CvSLABBED_on(PL_compcv);
188 slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */
189 }
190 else ++(slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
191
5cb52f30
FC		 192 opsz = SIZE_TO_PSIZE(sz);
193 sz = opsz + OPSLOT_HEADER_P;
8be227ab 194
2073970f
NC		 195 /* The slabs maintain a free list of OPs. In particular, constant folding
196 will free up OPs, so it makes sense to re-use them where possible. A
197 freed up slot is used in preference to a new allocation. */
8be227ab
FC		 198 if (slab->opslab_freed) {
199 OP **too = &slab->opslab_freed;
200 o = *too;
e7372881 201 DEBUG_S_warn((aTHX_ "found free op at %p, slab %p", o, slab));
8be227ab 202 while (o && DIFF(OpSLOT(o), OpSLOT(o)->opslot_next) < sz) {
e7372881 203 DEBUG_S_warn((aTHX_ "Alas! too small"));
8be227ab 204 o = *(too = &o->op_next);
94b67eb2 205 if (o) { DEBUG_S_warn((aTHX_ "found another free op at %p", o)); }
8be227ab
FC		 206 }
207 if (o) {
208 *too = o->op_next;
5cb52f30 209 Zero(o, opsz, I32 *);
8be227ab
FC		 210 o->op_slabbed = 1;
211 return (void *)o;
212 }
213 }
214
7aef8e5b 215#define INIT_OPSLOT \
8be227ab
FC		 216 slot->opslot_slab = slab; \
217 slot->opslot_next = slab2->opslab_first; \
218 slab2->opslab_first = slot; \
219 o = &slot->opslot_op; \
220 o->op_slabbed = 1
221
222 /* The partially-filled slab is next in the chain. */
223 slab2 = slab->opslab_next ? slab->opslab_next : slab;
224 if ((space = DIFF(&slab2->opslab_slots, slab2->opslab_first)) < sz) {
225 /* Remaining space is too small. */
226
8be227ab
FC		 227 /* If we can fit a BASEOP, add it to the free chain, so as not
228 to waste it. */
229 if (space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) {
230 slot = &slab2->opslab_slots;
231 INIT_OPSLOT;
232 o->op_type = OP_FREED;
233 o->op_next = slab->opslab_freed;
234 slab->opslab_freed = o;
235 }
236
237 /* Create a new slab. Make this one twice as big. */
238 slot = slab2->opslab_first;
239 while (slot->opslot_next) slot = slot->opslot_next;
af7751f6
FC		 240 slab2 = S_new_slab(aTHX_
241 (DIFF(slab2, slot)+1)*2 > PERL_MAX_SLAB_SIZE
e6cee8c0 242 ? PERL_MAX_SLAB_SIZE
af7751f6 243 : (DIFF(slab2, slot)+1)*2);
9963ffa2
FC		 244 slab2->opslab_next = slab->opslab_next;
245 slab->opslab_next = slab2;
8be227ab
FC		 246 }
247 assert(DIFF(&slab2->opslab_slots, slab2->opslab_first) >= sz);
248
249 /* Create a new op slot */
250 slot = (OPSLOT *)((I32 **)slab2->opslab_first - sz);
251 assert(slot >= &slab2->opslab_slots);
51c777ca
FC		 252 if (DIFF(&slab2->opslab_slots, slot)
253 < SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P)
254 slot = &slab2->opslab_slots;
8be227ab 255 INIT_OPSLOT;
e7372881 256 DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", o, slab));
8be227ab
FC		 257 return (void *)o;
258}
259
7aef8e5b 260#undef INIT_OPSLOT
8be227ab 261
7aef8e5b 262#ifdef PERL_DEBUG_READONLY_OPS
3107b51f
FC		 263void
264Perl_Slab_to_ro(pTHX_ OPSLAB *slab)
265{
266 PERL_ARGS_ASSERT_SLAB_TO_RO;
267
268 if (slab->opslab_readonly) return;
269 slab->opslab_readonly = 1;
270 for (; slab; slab = slab->opslab_next) {
271 /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->ro %lu at %p\n",
272 (unsigned long) slab->opslab_size, slab));*/
273 if (mprotect(slab, slab->opslab_size * sizeof(I32 *), PROT_READ))
274 Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", slab,
275 (unsigned long)slab->opslab_size, errno);
276 }
277}
278
7bbbc3c0
NC		 279void
280Perl_Slab_to_rw(pTHX_ OPSLAB *const slab)
3107b51f 281{
3107b51f
FC		 282 OPSLAB *slab2;
283
284 PERL_ARGS_ASSERT_SLAB_TO_RW;
285
3107b51f
FC		 286 if (!slab->opslab_readonly) return;
287 slab2 = slab;
288 for (; slab2; slab2 = slab2->opslab_next) {
289 /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n",
290 (unsigned long) size, slab2));*/
291 if (mprotect((void *)slab2, slab2->opslab_size * sizeof(I32 *),
292 PROT_READ|PROT_WRITE)) {
293 Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", slab,
294 (unsigned long)slab2->opslab_size, errno);
295 }
296 }
297 slab->opslab_readonly = 0;
298}
299
300#else
9e4d7a13 301# define Slab_to_rw(op) NOOP
3107b51f
FC		 302#endif
303
8be227ab
FC		 304/* This cannot possibly be right, but it was copied from the old slab
305 allocator, to which it was originally added, without explanation, in
306 commit 083fcd5. */
7aef8e5b 307#ifdef NETWARE
8be227ab 308# define PerlMemShared PerlMem
7aef8e5b 309#endif
8be227ab
FC		 310
311void
312Perl_Slab_Free(pTHX_ void *op)
313{
20429ba0 314 dVAR;
8be227ab
FC		 315 OP * const o = (OP *)op;
316 OPSLAB *slab;
317
318 PERL_ARGS_ASSERT_SLAB_FREE;
319
320 if (!o->op_slabbed) {
90840c5d
RU		 321 if (!o->op_static)
322 PerlMemShared_free(op);
8be227ab
FC		 323 return;
324 }
325
326 slab = OpSLAB(o);
327 /* If this op is already freed, our refcount will get screwy. */
328 assert(o->op_type != OP_FREED);
329 o->op_type = OP_FREED;
330 o->op_next = slab->opslab_freed;
331 slab->opslab_freed = o;
e7372881 332 DEBUG_S_warn((aTHX_ "free op at %p, recorded in slab %p", o, slab));
8be227ab
FC		 333 OpslabREFCNT_dec_padok(slab);
334}
335
336void
337Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
338{
339 dVAR;
340 const bool havepad = !!PL_comppad;
341 PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD;
342 if (havepad) {
343 ENTER;
344 PAD_SAVE_SETNULLPAD();
345 }
346 opslab_free(slab);
347 if (havepad) LEAVE;
348}
349
350void
351Perl_opslab_free(pTHX_ OPSLAB *slab)
352{
20429ba0 353 dVAR;
8be227ab
FC		 354 OPSLAB *slab2;
355 PERL_ARGS_ASSERT_OPSLAB_FREE;
e7372881 356 DEBUG_S_warn((aTHX_ "freeing slab %p", slab));
8be227ab
FC		 357 assert(slab->opslab_refcnt == 1);
358 for (; slab; slab = slab2) {
359 slab2 = slab->opslab_next;
7aef8e5b 360#ifdef DEBUGGING
8be227ab 361 slab->opslab_refcnt = ~(size_t)0;
7aef8e5b
FC		 362#endif
363#ifdef PERL_DEBUG_READONLY_OPS
3107b51f
FC		 364 DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
365 slab));
366 if (munmap(slab, slab->opslab_size * sizeof(I32 *))) {
367 perror("munmap failed");
368 abort();
369 }
7aef8e5b 370#else
8be227ab 371 PerlMemShared_free(slab);
7aef8e5b 372#endif
8be227ab
FC		 373 }
374}
375
376void
377Perl_opslab_force_free(pTHX_ OPSLAB *slab)
378{
379 OPSLAB *slab2;
380 OPSLOT *slot;
7aef8e5b 381#ifdef DEBUGGING
8be227ab 382 size_t savestack_count = 0;
7aef8e5b 383#endif
8be227ab
FC		 384 PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
385 slab2 = slab;
386 do {
387 for (slot = slab2->opslab_first;
388 slot->opslot_next;
389 slot = slot->opslot_next) {
390 if (slot->opslot_op.op_type != OP_FREED
391 && !(slot->opslot_op.op_savefree
7aef8e5b 392#ifdef DEBUGGING
8be227ab 393 && ++savestack_count
7aef8e5b 394#endif
8be227ab
FC		 395 )
396 ) {
397 assert(slot->opslot_op.op_slabbed);
8be227ab 398 op_free(&slot->opslot_op);
3bf28c7e 399 if (slab->opslab_refcnt == 1) goto free;
8be227ab
FC		 400 }
401 }
402 } while ((slab2 = slab2->opslab_next));
403 /* > 1 because the CV still holds a reference count. */
404 if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */
7aef8e5b 405#ifdef DEBUGGING
8be227ab 406 assert(savestack_count == slab->opslab_refcnt-1);
7aef8e5b 407#endif
ee5ee853
FC		 408 /* Remove the CV’s reference count. */
409 slab->opslab_refcnt--;
8be227ab
FC		 410 return;
411 }
412 free:
413 opslab_free(slab);
414}
415
3107b51f
FC		 416#ifdef PERL_DEBUG_READONLY_OPS
417OP *
418Perl_op_refcnt_inc(pTHX_ OP *o)
419{
420 if(o) {
372eab01
NC		 421 OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
422 if (slab && slab->opslab_readonly) {
83519873 423 Slab_to_rw(slab);
372eab01
NC		 424 ++o->op_targ;
425 Slab_to_ro(slab);
426 } else {
427 ++o->op_targ;
428 }
3107b51f
FC		 429 }
430 return o;
431
432}
433
434PADOFFSET
435Perl_op_refcnt_dec(pTHX_ OP *o)
436{
372eab01
NC		 437 PADOFFSET result;
438 OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
439
3107b51f 440 PERL_ARGS_ASSERT_OP_REFCNT_DEC;
372eab01
NC		 441
442 if (slab && slab->opslab_readonly) {
83519873 443 Slab_to_rw(slab);
372eab01
NC		 444 result = --o->op_targ;
445 Slab_to_ro(slab);
446 } else {
447 result = --o->op_targ;
448 }
449 return result;
3107b51f
FC		 450}
451#endif
e50aee73 452/*
ce6f1cbc 453 * In the following definition, the ", (OP*)0" is just to make the compiler
a5f75d66 454 * think the expression is of the right type: croak actually does a Siglongjmp.
e50aee73 455 */
11343788 456#define CHECKOP(type,o) \
ce6f1cbc 457 ((PL_op_mask && PL_op_mask[type]) \
5dc0d613 458 ? ( op_free((OP*)o), \
cb77fdf0 459 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
ce6f1cbc 460 (OP*)0 ) \
16c91539 461 : PL_check[type](aTHX_ (OP*)o))
e50aee73 462
e6438c1a 463#define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
c53d7c7d 464
cba5a3b0
DG		 465#define CHANGE_TYPE(o,type) \
466 STMT_START { \
467 o->op_type = (OPCODE)type; \
468 o->op_ppaddr = PL_ppaddr[type]; \
469 } STMT_END
470
ce16c625 471STATIC SV*
cea2e8a9 472S_gv_ename(pTHX_ GV *gv)
4633a7c4 473{
46c461b5 474 SV* const tmpsv = sv_newmortal();
7918f24d
NC		 475
476 PERL_ARGS_ASSERT_GV_ENAME;
477
bd61b366 478 gv_efullname3(tmpsv, gv, NULL);
ce16c625 479 return tmpsv;
4633a7c4
LW		 480}
481
76e3520e 482STATIC OP *
cea2e8a9 483S_no_fh_allowed(pTHX_ OP *o)
79072805 484{
7918f24d
NC		 485 PERL_ARGS_ASSERT_NO_FH_ALLOWED;
486
cea2e8a9 487 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
53e06cf0 488 OP_DESC(o)));
11343788 489 return o;
79072805
LW		 490}
491
76e3520e 492STATIC OP *
ce16c625 493S_too_few_arguments_sv(pTHX_ OP *o, SV *namesv, U32 flags)
79072805 494{
ce16c625
BF		 495 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_SV;
496 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf, namesv),
497 SvUTF8(namesv) | flags);
498 return o;
499}
500
501STATIC OP *
502S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
503{
504 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
505 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
506 return o;
507}
508
509STATIC OP *
510S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
511{
512 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
7918f24d 513
ce16c625 514 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
11343788 515 return o;
79072805
LW		 516}
517
76e3520e 518STATIC OP *
ce16c625 519S_too_many_arguments_sv(pTHX_ OP *o, SV *namesv, U32 flags)
79072805 520{
ce16c625 521 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_SV;
7918f24d 522
ce16c625
BF		 523 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %"SVf, SVfARG(namesv)),
524 SvUTF8(namesv) | flags);
11343788 525 return o;
79072805
LW		 526}
527
76e3520e 528STATIC void
ce16c625 529S_bad_type_pv(pTHX_ I32 n, const char *t, const char *name, U32 flags, const OP *kid)
8990e307 530{
ce16c625
BF		 531 PERL_ARGS_ASSERT_BAD_TYPE_PV;
532
533 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
534 (int)n, name, t, OP_DESC(kid)), flags);
535}
7918f24d 536
ce16c625 537STATIC void
7b3b0904 538S_bad_type_gv(pTHX_ I32 n, const char *t, GV *gv, U32 flags, const OP *kid)
ce16c625 539{
7b3b0904
FC		 540 SV * const namesv = gv_ename(gv);
541 PERL_ARGS_ASSERT_BAD_TYPE_GV;
ce16c625
BF		 542
543 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %"SVf" must be %s (not %s)",
544 (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv) | flags);
8990e307
LW		 545}
546
7a52d87a 547STATIC void
eb796c7f 548S_no_bareword_allowed(pTHX_ OP *o)
7a52d87a 549{
7918f24d
NC		 550 PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
551
eb8433b7
NC		 552 if (PL_madskills)
553 return; /* various ok barewords are hidden in extra OP_NULL */
5a844595 554 qerror(Perl_mess(aTHX_
35c1215d 555 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
be2597df 556 SVfARG(cSVOPo_sv)));
eb796c7f 557 o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
7a52d87a
GS		 558}
559
79072805
LW		 560/* "register" allocation */
561
562PADOFFSET
d6447115 563Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
93a17b20 564{
97aff369 565 dVAR;
a0d0e21e 566 PADOFFSET off;
12bd6ede 567 const bool is_our = (PL_parser->in_my == KEY_our);
a0d0e21e 568
7918f24d
NC		 569 PERL_ARGS_ASSERT_ALLOCMY;
570
48d0d1be 571 if (flags & ~SVf_UTF8)
d6447115
NC		 572 Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
573 (UV)flags);
574
575 /* Until we're using the length for real, cross check that we're being
576 told the truth. */
577 assert(strlen(name) == len);
578
59f00321 579 /* complain about "my $<special_var>" etc etc */
d6447115 580 if (len &&
3edf23ff 581 !(is_our ||
155aba94 582 isALPHA(name[1]) ||
b14845b4 583 ((flags & SVf_UTF8) && isIDFIRST_utf8((U8 *)name+1)) ||
d6447115 584 (name[1] == '_' && (*name == '$' || len > 2))))
834a4ddd 585 {
6b58708b 586 /* name[2] is true if strlen(name) > 2 */
b14845b4
FC		 587 if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
588 && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
d6447115
NC		 589 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
590 name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
aab6a793 591 PL_parser->in_my == KEY_state ? "state" : "my"));
d1544d85 592 } else {
ce16c625
BF		 593 yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
594 PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
46fc3d4c 595 }
a0d0e21e 596 }
4055dbce
RS		 597 else if (len == 2 && name[1] == '_' && !is_our)
598 /* diag_listed_as: Use of my $_ is experimental */
599 Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__LEXICAL_TOPIC),
600 "Use of %s $_ is experimental",
601 PL_parser->in_my == KEY_state
602 ? "state"
603 : "my");
748a9306 604
dd2155a4 605 /* allocate a spare slot and store the name in that slot */
93a17b20 606
cc76b5cc 607 off = pad_add_name_pvn(name, len,
48d0d1be
BF		 608 (is_our ? padadd_OUR :
609 PL_parser->in_my == KEY_state ? padadd_STATE : 0)
610 | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 ),
12bd6ede 611 PL_parser->in_my_stash,
3edf23ff 612 (is_our
133706a6
RGS		 613 /* $_ is always in main::, even with our */
614 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
5c284bb0 615 : NULL
cca43f78 616 )
dd2155a4 617 );
a74073ad
DM		 618 /* anon sub prototypes contains state vars should always be cloned,
619 * otherwise the state var would be shared between anon subs */
620
621 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
622 CvCLONE_on(PL_compcv);
623
dd2155a4 624 return off;
79072805
LW		 625}
626
c0b8aebd
FC		 627/*
628=for apidoc alloccopstash
629
630Available only under threaded builds, this function allocates an entry in
631C<PL_stashpad> for the stash passed to it.
632
633=cut
634*/
635
d4d03940 636#ifdef USE_ITHREADS
c82ecf34 637
d4d03940 638PADOFFSET
c82ecf34
FC		 639S_alloc_global_pad_slot(pTHX_ SV *sv, svtype type, SV ***padp,
640 PADOFFSET *ixp, PADOFFSET *maxp)
d4d03940
FC		 641{
642 PADOFFSET off = 0, o = 1;
643 bool found_slot = FALSE;
c82ecf34 644 SV **pad = *padp;
d4d03940 645
c82ecf34 646 if (pad[*ixp] == sv) return *ixp;
d4d03940 647
c82ecf34
FC		 648 for (; o < *maxp; ++o) {
649 if (pad[o] == sv) return *ixp = o;
650 if (!pad[o] || SvTYPE(pad[o]) != type)
d4d03940
FC		 651 found_slot = TRUE, off = o;
652 }
653 if (!found_slot) {
c82ecf34
FC		 654 Renew(*padp, *maxp + 10, SV *);
655 pad = *padp;
656 Zero(pad + *maxp, 10, SV *);
657 off = *maxp;
658 *maxp += 10;
d4d03940
FC		 659 }
660
c82ecf34 661 pad[*ixp = off] = sv;
d4d03940
FC		 662 return off;
663}
c82ecf34
FC		 664
665PADOFFSET
666Perl_alloccopstash(pTHX_ HV *hv)
667{
668 PERL_ARGS_ASSERT_ALLOCCOPSTASH;
669 return S_alloc_global_pad_slot(aTHX_
670 (SV *)hv, SVt_PVHV, (SV ***)&PL_stashpad, &PL_stashpadix,
671 &PL_stashpadmax
672 );
673}
674#endif
675
676/*
677=for apidoc allocfilegv
678
679Available only under threaded builds, this function allocates an entry in
680C<PL_filegvpad> for the GV passed to it.
681
682=cut
683*/
684
685#ifdef USE_ITHREADS
686PADOFFSET
687Perl_allocfilegv(pTHX_ GV *gv)
688{
689 PERL_ARGS_ASSERT_ALLOCFILEGV;
690 return S_alloc_global_pad_slot(aTHX_
691 (SV *)gv, SVt_PVGV, (SV ***)&PL_filegvpad, &PL_filegvpadix,
692 &PL_filegvpadmax
693 );
694}
d4d03940
FC		 695#endif
696
d2c837a0
DM		 697/* free the body of an op without examining its contents.
698 * Always use this rather than FreeOp directly */
699
4136a0f7 700static void
d2c837a0
DM		 701S_op_destroy(pTHX_ OP *o)
702{
d2c837a0
DM		 703 FreeOp(o);
704}
705
79072805
LW		 706/* Destructor */
707
708void
864dbfa3 709Perl_op_free(pTHX_ OP *o)
79072805 710{
27da23d5 711 dVAR;
acb36ea4 712 OPCODE type;
79072805 713
8be227ab
FC		 714 /* Though ops may be freed twice, freeing the op after its slab is a
715 big no-no. */
716 assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
8be227ab
FC		 717 /* During the forced freeing of ops after compilation failure, kidops
718 may be freed before their parents. */
719 if (!o || o->op_type == OP_FREED)
79072805
LW		 720 return;
721
67566ccd 722 type = o->op_type;
7934575e 723 if (o->op_private & OPpREFCOUNTED) {
67566ccd 724 switch (type) {
7934575e
GS		 725 case OP_LEAVESUB:
726 case OP_LEAVESUBLV:
727 case OP_LEAVEEVAL:
728 case OP_LEAVE:
729 case OP_SCOPE:
730 case OP_LEAVEWRITE:
67566ccd
AL		 731 {
732 PADOFFSET refcnt;
7934575e 733 OP_REFCNT_LOCK;
4026c95a 734 refcnt = OpREFCNT_dec(o);
7934575e 735 OP_REFCNT_UNLOCK;
bfd0ff22
NC		 736 if (refcnt) {
737 /* Need to find and remove any pattern match ops from the list
738 we maintain for reset(). */
739 find_and_forget_pmops(o);
4026c95a 740 return;
67566ccd 741 }
bfd0ff22 742 }
7934575e
GS		 743 break;
744 default:
745 break;
746 }
747 }
748
f37b8c3f
VP		 749 /* Call the op_free hook if it has been set. Do it now so that it's called
750 * at the right time for refcounted ops, but still before all of the kids
751 * are freed. */
752 CALL_OPFREEHOOK(o);
753
11343788 754 if (o->op_flags & OPf_KIDS) {
eb578fdb 755 OP *kid, *nextkid;
11343788 756 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
85e6fe83 757 nextkid = kid->op_sibling; /* Get before next freeing kid */
79072805 758 op_free(kid);
85e6fe83 759 }
79072805 760 }
513f78f7
FC		 761 if (type == OP_NULL)
762 type = (OPCODE)o->op_targ;
acb36ea4 763
9e4d7a13
NC		 764 if (o->op_slabbed)
765 Slab_to_rw(OpSLAB(o));
fc97af9c 766
acb36ea4
GS		 767 /* COP* is not cleared by op_clear() so that we may track line
768 * numbers etc even after null() */
513f78f7 769 if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
acb36ea4 770 cop_free((COP*)o);
3235b7a3 771 }
acb36ea4
GS		 772
773 op_clear(o);
238a4c30 774 FreeOp(o);
4d494880
DM		 775#ifdef DEBUG_LEAKING_SCALARS
776 if (PL_op == o)
5f66b61c 777 PL_op = NULL;
4d494880 778#endif
acb36ea4 779}
79072805 780
93c66552
DM		 781void
782Perl_op_clear(pTHX_ OP *o)
acb36ea4 783{
13137afc 784
27da23d5 785 dVAR;
7918f24d
NC		 786
787 PERL_ARGS_ASSERT_OP_CLEAR;
788
eb8433b7 789#ifdef PERL_MAD
df31c78c
NC		 790 mad_free(o->op_madprop);
791 o->op_madprop = 0;
eb8433b7
NC		 792#endif
793
794 retry:
11343788 795 switch (o->op_type) {
acb36ea4 796 case OP_NULL: /* Was holding old type, if any. */
eb8433b7 797 if (PL_madskills && o->op_targ != OP_NULL) {
61a59f30 798 o->op_type = (Optype)o->op_targ;
eb8433b7
NC		 799 o->op_targ = 0;
800 goto retry;
801 }
4d193d44 802 case OP_ENTERTRY:
acb36ea4 803 case OP_ENTEREVAL: /* Was holding hints. */
acb36ea4 804 o->op_targ = 0;
a0d0e21e 805 break;
a6006777 806 default:
ac4c12e7 807 if (!(o->op_flags & OPf_REF)
ef69c8fc 808 || (PL_check[o->op_type] != Perl_ck_ftst))
a6006777 809 break;
810 /* FALL THROUGH */
463ee0b2 811 case OP_GVSV:
79072805 812 case OP_GV:
a6006777 813 case OP_AELEMFAST:
93bad3fd 814 {
f7461760
Z		 815 GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV)
816#ifdef USE_ITHREADS
817 && PL_curpad
818#endif
819 ? cGVOPo_gv : NULL;
b327b36f
NC		 820 /* It's possible during global destruction that the GV is freed
821 before the optree. Whilst the SvREFCNT_inc is happy to bump from
822 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
823 will trigger an assertion failure, because the entry to sv_clear
824 checks that the scalar is not already freed. A check of for
825 !SvIS_FREED(gv) turns out to be invalid, because during global
826 destruction the reference count can be forced down to zero
827 (with SVf_BREAK set). In which case raising to 1 and then
828 dropping to 0 triggers cleanup before it should happen. I
829 *think* that this might actually be a general, systematic,
830 weakness of the whole idea of SVf_BREAK, in that code *is*
831 allowed to raise and lower references during global destruction,
832 so any *valid* code that happens to do this during global
833 destruction might well trigger premature cleanup. */
834 bool still_valid = gv && SvREFCNT(gv);
835
836 if (still_valid)
837 SvREFCNT_inc_simple_void(gv);
350de78d 838#ifdef USE_ITHREADS
6a077020
DM		 839 if (cPADOPo->op_padix > 0) {
840 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
841 * may still exist on the pad */
842 pad_swipe(cPADOPo->op_padix, TRUE);
843 cPADOPo->op_padix = 0;
844 }
350de78d 845#else
6a077020 846 SvREFCNT_dec(cSVOPo->op_sv);
a0714e2c 847 cSVOPo->op_sv = NULL;
350de78d 848#endif
b327b36f 849 if (still_valid) {
f7461760 850 int try_downgrade = SvREFCNT(gv) == 2;
fc2b2dca 851 SvREFCNT_dec_NN(gv);
f7461760
Z		 852 if (try_downgrade)
853 gv_try_downgrade(gv);
854 }
6a077020 855 }
79072805 856 break;
a1ae71d2 857 case OP_METHOD_NAMED:
79072805 858 case OP_CONST:
996c9baa 859 case OP_HINTSEVAL:
11343788 860 SvREFCNT_dec(cSVOPo->op_sv);
a0714e2c 861 cSVOPo->op_sv = NULL;
3b1c21fa
AB		 862#ifdef USE_ITHREADS
863 /** Bug #15654
864 Even if op_clear does a pad_free for the target of the op,
6a077020 865 pad_free doesn't actually remove the sv that exists in the pad;
3b1c21fa
AB		 866 instead it lives on. This results in that it could be reused as
867 a target later on when the pad was reallocated.
868 **/
869 if(o->op_targ) {
870 pad_swipe(o->op_targ,1);
871 o->op_targ = 0;
872 }
873#endif
79072805 874 break;
c9df4fda 875 case OP_DUMP:
748a9306
LW		 876 case OP_GOTO:
877 case OP_NEXT:
878 case OP_LAST:
879 case OP_REDO:
11343788 880 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
748a9306
LW		 881 break;
882 /* FALL THROUGH */
a0d0e21e 883 case OP_TRANS:
bb16bae8 884 case OP_TRANSR:
acb36ea4 885 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
99a1d0d1 886 assert(o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
043e41b8
DM		 887#ifdef USE_ITHREADS
888 if (cPADOPo->op_padix > 0) {
889 pad_swipe(cPADOPo->op_padix, TRUE);
890 cPADOPo->op_padix = 0;
891 }
892#else
a0ed51b3 893 SvREFCNT_dec(cSVOPo->op_sv);
a0714e2c 894 cSVOPo->op_sv = NULL;
043e41b8 895#endif
acb36ea4
GS		 896 }
897 else {
ea71c68d 898 PerlMemShared_free(cPVOPo->op_pv);
bd61b366 899 cPVOPo->op_pv = NULL;
acb36ea4 900 }
a0d0e21e
LW		 901 break;
902 case OP_SUBST:
20e98b0f 903 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
971a9dd3 904 goto clear_pmop;
748a9306 905 case OP_PUSHRE:
971a9dd3 906#ifdef USE_ITHREADS
20e98b0f 907 if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
dd2155a4
DM		 908 /* No GvIN_PAD_off here, because other references may still
909 * exist on the pad */
20e98b0f 910 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
971a9dd3
GS		 911 }
912#else
ad64d0ec 913 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
971a9dd3
GS		 914#endif
915 /* FALL THROUGH */
a0d0e21e 916 case OP_MATCH:
8782bef2 917 case OP_QR:
971a9dd3 918clear_pmop:
867940b8
DM		 919 if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
920 op_free(cPMOPo->op_code_list);
68e2671b 921 cPMOPo->op_code_list = NULL;
23083432 922 forget_pmop(cPMOPo);
20e98b0f 923 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
9cddf794
NC		 924 /* we use the same protection as the "SAFE" version of the PM_ macros
925 * here since sv_clean_all might release some PMOPs
5f8cb046
DM		 926 * after PL_regex_padav has been cleared
927 * and the clearing of PL_regex_padav needs to
928 * happen before sv_clean_all
929 */
13137afc
AB		 930#ifdef USE_ITHREADS
931 if(PL_regex_pad) { /* We could be in destruction */
402d2eb1 932 const IV offset = (cPMOPo)->op_pmoffset;
9cddf794 933 ReREFCNT_dec(PM_GETRE(cPMOPo));
402d2eb1
NC		 934 PL_regex_pad[offset] = &PL_sv_undef;
935 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
936 sizeof(offset));
13137afc 937 }
9cddf794
NC		 938#else
939 ReREFCNT_dec(PM_GETRE(cPMOPo));
940 PM_SETRE(cPMOPo, NULL);
1eb1540c 941#endif
13137afc 942
a0d0e21e 943 break;
79072805
LW		 944 }
945
743e66e6 946 if (o->op_targ > 0) {
11343788 947 pad_free(o->op_targ);
743e66e6
GS		 948 o->op_targ = 0;
949 }
79072805
LW		 950}
951
76e3520e 952STATIC void
3eb57f73
HS		 953S_cop_free(pTHX_ COP* cop)
954{
7918f24d
NC		 955 PERL_ARGS_ASSERT_COP_FREE;
956
05ec9bb3 957 CopFILE_free(cop);
0453d815 958 if (! specialWARN(cop->cop_warnings))
72dc9ed5 959 PerlMemShared_free(cop->cop_warnings);
20439bc7 960 cophh_free(CopHINTHASH_get(cop));
3eb57f73
HS		 961}
962
c2b1997a 963STATIC void
c4bd3ae5 964S_forget_pmop(pTHX_ PMOP *const o
c4bd3ae5 965 )
c2b1997a
NC		 966{
967 HV * const pmstash = PmopSTASH(o);
7918f24d
NC		 968
969 PERL_ARGS_ASSERT_FORGET_PMOP;
970
e39a6381 971 if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
ad64d0ec 972 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
c2b1997a
NC		 973 if (mg) {
974 PMOP **const array = (PMOP**) mg->mg_ptr;
975 U32 count = mg->mg_len / sizeof(PMOP**);
976 U32 i = count;
977
978 while (i--) {
979 if (array[i] == o) {
980 /* Found it. Move the entry at the end to overwrite it. */
981 array[i] = array[--count];
982 mg->mg_len = count * sizeof(PMOP**);
983 /* Could realloc smaller at this point always, but probably
984 not worth it. Probably worth free()ing if we're the
985 last. */
986 if(!count) {
987 Safefree(mg->mg_ptr);
988 mg->mg_ptr = NULL;
989 }
990 break;
991 }
992 }
993 }
994 }
1cdf7faf
NC		 995 if (PL_curpm == o)
996 PL_curpm = NULL;
c2b1997a
NC		 997}
998
bfd0ff22
NC		 999STATIC void
1000S_find_and_forget_pmops(pTHX_ OP *o)
1001{
7918f24d
NC		 1002 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
1003
bfd0ff22
NC		 1004 if (o->op_flags & OPf_KIDS) {
1005 OP *kid = cUNOPo->op_first;
1006 while (kid) {
1007 switch (kid->op_type) {
1008 case OP_SUBST:
1009 case OP_PUSHRE:
1010 case OP_MATCH:
1011 case OP_QR:
23083432 1012 forget_pmop((PMOP*)kid);
bfd0ff22
NC		 1013 }
1014 find_and_forget_pmops(kid);
1015 kid = kid->op_sibling;
1016 }
1017 }
1018}
1019
93c66552
DM		 1020void
1021Perl_op_null(pTHX_ OP *o)
8990e307 1022{
27da23d5 1023 dVAR;
7918f24d
NC		 1024
1025 PERL_ARGS_ASSERT_OP_NULL;
1026
acb36ea4
GS		 1027 if (o->op_type == OP_NULL)
1028 return;
eb8433b7
NC		 1029 if (!PL_madskills)
1030 op_clear(o);
11343788
MB		 1031 o->op_targ = o->op_type;
1032 o->op_type = OP_NULL;
22c35a8c 1033 o->op_ppaddr = PL_ppaddr[OP_NULL];
8990e307
LW		 1034}
1035
4026c95a
SH		 1036void
1037Perl_op_refcnt_lock(pTHX)
1038{
27da23d5 1039 dVAR;
96a5add6 1040 PERL_UNUSED_CONTEXT;
4026c95a
SH		 1041 OP_REFCNT_LOCK;
1042}
1043
1044void
1045Perl_op_refcnt_unlock(pTHX)
1046{
27da23d5 1047 dVAR;
96a5add6 1048 PERL_UNUSED_CONTEXT;
4026c95a
SH		 1049 OP_REFCNT_UNLOCK;
1050}
1051
79072805
LW		 1052/* Contextualizers */
1053
d9088386
Z		 1054/*
1055=for apidoc Am|OP *|op_contextualize|OP *o|I32 context
1056
1057Applies a syntactic context to an op tree representing an expression.
1058I<o> is the op tree, and I<context> must be C<G_SCALAR>, C<G_ARRAY>,
1059or C<G_VOID> to specify the context to apply. The modified op tree
1060is returned.
1061
1062=cut
1063*/
1064
1065OP *
1066Perl_op_contextualize(pTHX_ OP *o, I32 context)
1067{
1068 PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1069 switch (context) {
1070 case G_SCALAR: return scalar(o);
1071 case G_ARRAY: return list(o);
1072 case G_VOID: return scalarvoid(o);
1073 default:
5637ef5b
NC		 1074 Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1075 (long) context);
d9088386
Z		 1076 return o;
1077 }
1078}
1079
5983a79d
BM		 1080/*
1081=head1 Optree Manipulation Functions
79072805 1082
5983a79d
BM		 1083=for apidoc Am|OP*|op_linklist|OP *o
1084This function is the implementation of the L</LINKLIST> macro. It should
1085not be called directly.
1086
1087=cut
1088*/
1089
1090OP *
1091Perl_op_linklist(pTHX_ OP *o)
79072805 1092{
3edf23ff 1093 OP *first;
79072805 1094
5983a79d 1095 PERL_ARGS_ASSERT_OP_LINKLIST;
7918f24d 1096
11343788
MB		 1097 if (o->op_next)
1098 return o->op_next;
79072805
LW		 1099
1100 /* establish postfix order */
3edf23ff
AL		 1101 first = cUNOPo->op_first;
1102 if (first) {
eb578fdb 1103 OP *kid;
3edf23ff
AL		 1104 o->op_next = LINKLIST(first);
1105 kid = first;
1106 for (;;) {
1107 if (kid->op_sibling) {
79072805 1108 kid->op_next = LINKLIST(kid->op_sibling);
3edf23ff
AL		 1109 kid = kid->op_sibling;
1110 } else {
11343788 1111 kid->op_next = o;
3edf23ff
AL		 1112 break;
1113 }
79072805
LW		 1114 }
1115 }
1116 else
11343788 1117 o->op_next = o;
79072805 1118
11343788 1119 return o->op_next;
79072805
LW		 1120}
1121
1f676739 1122static OP *
2dd5337b 1123S_scalarkids(pTHX_ OP *o)
79072805 1124{
11343788 1125 if (o && o->op_flags & OPf_KIDS) {
bfed75c6 1126 OP *kid;
11343788 1127 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW		 1128 scalar(kid);
1129 }
11343788 1130 return o;
79072805
LW		 1131}
1132
76e3520e 1133STATIC OP *
cea2e8a9 1134S_scalarboolean(pTHX_ OP *o)
8990e307 1135{
97aff369 1136 dVAR;
7918f24d
NC		 1137
1138 PERL_ARGS_ASSERT_SCALARBOOLEAN;
1139
6b7c6d95
FC		 1140 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST
1141 && !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) {
d008e5eb 1142 if (ckWARN(WARN_SYNTAX)) {
6867be6d 1143 const line_t oldline = CopLINE(PL_curcop);
a0d0e21e 1144
2b7cddde
NC		 1145 if (PL_parser && PL_parser->copline != NOLINE) {
1146 /* This ensures that warnings are reported at the first line
1147 of the conditional, not the last. */
53a7735b 1148 CopLINE_set(PL_curcop, PL_parser->copline);
2b7cddde 1149 }
9014280d 1150 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
57843af0 1151 CopLINE_set(PL_curcop, oldline);
d008e5eb 1152 }
a0d0e21e 1153 }
11343788 1154 return scalar(o);
8990e307
LW		 1155}
1156
1157OP *
864dbfa3 1158Perl_scalar(pTHX_ OP *o)
79072805 1159{
27da23d5 1160 dVAR;
79072805
LW		 1161 OP *kid;
1162
a0d0e21e 1163 /* assumes no premature commitment */
13765c85
DM		 1164 if (!o || (PL_parser && PL_parser->error_count)
1165 || (o->op_flags & OPf_WANT)
5dc0d613 1166 || o->op_type == OP_RETURN)
7e363e51 1167 {
11343788 1168 return o;
7e363e51 1169 }
79072805 1170
5dc0d613 1171 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
79072805 1172
11343788 1173 switch (o->op_type) {
79072805 1174 case OP_REPEAT:
11343788 1175 scalar(cBINOPo->op_first);
8990e307 1176 break;
79072805
LW		 1177 case OP_OR:
1178 case OP_AND:
1179 case OP_COND_EXPR:
11343788 1180 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
8990e307 1181 scalar(kid);
79072805 1182 break;
a0d0e21e 1183 /* FALL THROUGH */
a6d8037e 1184 case OP_SPLIT:
79072805 1185 case OP_MATCH:
8782bef2 1186 case OP_QR:
79072805
LW		 1187 case OP_SUBST:
1188 case OP_NULL:
8990e307 1189 default:
11343788
MB		 1190 if (o->op_flags & OPf_KIDS) {
1191 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
8990e307
LW		 1192 scalar(kid);
1193 }
79072805
LW		 1194 break;
1195 case OP_LEAVE:
1196 case OP_LEAVETRY:
5dc0d613 1197 kid = cLISTOPo->op_first;
54310121 1198 scalar(kid);
25b991bf
VP		 1199 kid = kid->op_sibling;
1200 do_kids:
1201 while (kid) {
1202 OP *sib = kid->op_sibling;
c08f093b
VP		 1203 if (sib && kid->op_type != OP_LEAVEWHEN)
1204 scalarvoid(kid);
1205 else
54310121 1206 scalar(kid);
25b991bf 1207 kid = sib;
54310121 1208 }
11206fdd 1209 PL_curcop = &PL_compiling;
54310121 1210 break;
748a9306 1211 case OP_SCOPE:
79072805 1212 case OP_LINESEQ:
8990e307 1213 case OP_LIST:
25b991bf
VP		 1214 kid = cLISTOPo->op_first;
1215 goto do_kids;
a801c63c 1216 case OP_SORT:
a2a5de95 1217 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
553e7bb0 1218 break;
79072805 1219 }
11343788 1220 return o;
79072805
LW		 1221}
1222
1223OP *
864dbfa3 1224Perl_scalarvoid(pTHX_ OP *o)
79072805 1225{
27da23d5 1226 dVAR;
79072805 1227 OP *kid;
095b19d1 1228 SV *useless_sv = NULL;
c445ea15 1229 const char* useless = NULL;
8990e307 1230 SV* sv;
2ebea0a1
GS		 1231 U8 want;
1232
7918f24d
NC		 1233 PERL_ARGS_ASSERT_SCALARVOID;
1234
eb8433b7
NC		 1235 /* trailing mad null ops don't count as "there" for void processing */
1236 if (PL_madskills &&
1237 o->op_type != OP_NULL &&
1238 o->op_sibling &&
1239 o->op_sibling->op_type == OP_NULL)
1240 {
1241 OP *sib;
1242 for (sib = o->op_sibling;
1243 sib && sib->op_type == OP_NULL;
1244 sib = sib->op_sibling) ;
1245
1246 if (!sib)
1247 return o;
1248 }
1249
acb36ea4 1250 if (o->op_type == OP_NEXTSTATE
acb36ea4
GS		 1251 || o->op_type == OP_DBSTATE
1252 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
acb36ea4 1253 || o->op_targ == OP_DBSTATE)))
2ebea0a1 1254 PL_curcop = (COP*)o; /* for warning below */
79072805 1255
54310121 1256 /* assumes no premature commitment */
2ebea0a1 1257 want = o->op_flags & OPf_WANT;
13765c85
DM		 1258 if ((want && want != OPf_WANT_SCALAR)
1259 || (PL_parser && PL_parser->error_count)
25b991bf 1260 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
7e363e51 1261 {
11343788 1262 return o;
7e363e51 1263 }
79072805 1264
b162f9ea 1265 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS		 1266 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1267 {
b162f9ea 1268 return scalar(o); /* As if inside SASSIGN */
7e363e51 1269 }
1c846c1f 1270
5dc0d613 1271 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
79072805 1272
11343788 1273 switch (o->op_type) {
79072805 1274 default:
22c35a8c 1275 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
8990e307 1276 break;
36477c24 1277 /* FALL THROUGH */
1278 case OP_REPEAT:
11343788 1279 if (o->op_flags & OPf_STACKED)
8990e307 1280 break;
5d82c453
GA		 1281 goto func_ops;
1282 case OP_SUBSTR:
1283 if (o->op_private == 4)
1284 break;
8990e307
LW		 1285 /* FALL THROUGH */
1286 case OP_GVSV:
1287 case OP_WANTARRAY:
1288 case OP_GV:
74295f0b 1289 case OP_SMARTMATCH:
8990e307
LW		 1290 case OP_PADSV:
1291 case OP_PADAV:
1292 case OP_PADHV:
1293 case OP_PADANY:
1294 case OP_AV2ARYLEN:
8990e307 1295 case OP_REF:
a0d0e21e
LW		 1296 case OP_REFGEN:
1297 case OP_SREFGEN:
8990e307
LW		 1298 case OP_DEFINED:
1299 case OP_HEX:
1300 case OP_OCT:
1301 case OP_LENGTH:
8990e307
LW		 1302 case OP_VEC:
1303 case OP_INDEX:
1304 case OP_RINDEX:
1305 case OP_SPRINTF:
1306 case OP_AELEM:
1307 case OP_AELEMFAST:
93bad3fd 1308 case OP_AELEMFAST_LEX:
8990e307 1309 case OP_ASLICE:
8990e307
LW		 1310 case OP_HELEM:
1311 case OP_HSLICE:
1312 case OP_UNPACK:
1313 case OP_PACK:
8990e307
LW		 1314 case OP_JOIN:
1315 case OP_LSLICE:
1316 case OP_ANONLIST:
1317 case OP_ANONHASH:
1318 case OP_SORT:
1319 case OP_REVERSE:
1320 case OP_RANGE:
1321 case OP_FLIP:
1322 case OP_FLOP:
1323 case OP_CALLER:
1324 case OP_FILENO:
1325 case OP_EOF:
1326 case OP_TELL:
1327 case OP_GETSOCKNAME:
1328 case OP_GETPEERNAME:
1329 case OP_READLINK:
1330 case OP_TELLDIR:
1331 case OP_GETPPID:
1332 case OP_GETPGRP:
1333 case OP_GETPRIORITY:
1334 case OP_TIME:
1335 case OP_TMS:
1336 case OP_LOCALTIME:
1337 case OP_GMTIME:
1338 case OP_GHBYNAME:
1339 case OP_GHBYADDR:
1340 case OP_GHOSTENT:
1341 case OP_GNBYNAME:
1342 case OP_GNBYADDR:
1343 case OP_GNETENT:
1344 case OP_GPBYNAME:
1345 case OP_GPBYNUMBER:
1346 case OP_GPROTOENT:
1347 case OP_GSBYNAME:
1348 case OP_GSBYPORT:
1349 case OP_GSERVENT:
1350 case OP_GPWNAM:
1351 case OP_GPWUID:
1352 case OP_GGRNAM:
1353 case OP_GGRGID:
1354 case OP_GETLOGIN:
78e1b766 1355 case OP_PROTOTYPE:
703227f5 1356 case OP_RUNCV:
5d82c453 1357 func_ops:
64aac5a9 1358 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
74295f0b 1359 /* Otherwise it's "Useless use of grep iterator" */
f5df4782 1360 useless = OP_DESC(o);
75068674
RGS		 1361 break;
1362
1363 case OP_SPLIT:
1364 kid = cLISTOPo->op_first;
1365 if (kid && kid->op_type == OP_PUSHRE
1366#ifdef USE_ITHREADS
1367 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff)
1368#else
1369 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv)
1370#endif
1371 useless = OP_DESC(o);
8990e307
LW		 1372 break;
1373
9f82cd5f
YST		 1374 case OP_NOT:
1375 kid = cUNOPo->op_first;
1376 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
bb16bae8 1377 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
9f82cd5f
YST		 1378 goto func_ops;
1379 }
1380 useless = "negative pattern binding (!~)";
1381 break;
1382
4f4d7508
DC		 1383 case OP_SUBST:
1384 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
8db9069c 1385 useless = "non-destructive substitution (s///r)";
4f4d7508
DC		 1386 break;
1387
bb16bae8
FC		 1388 case OP_TRANSR:
1389 useless = "non-destructive transliteration (tr///r)";
1390 break;
1391
8990e307
LW		 1392 case OP_RV2GV:
1393 case OP_RV2SV:
1394 case OP_RV2AV:
1395 case OP_RV2HV:
192587c2 1396 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
11343788 1397 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
8990e307
LW		 1398 useless = "a variable";
1399 break;
79072805
LW		 1400
1401 case OP_CONST:
7766f137 1402 sv = cSVOPo_sv;
7a52d87a
GS		 1403 if (cSVOPo->op_private & OPpCONST_STRICT)
1404 no_bareword_allowed(o);
1405 else {
d008e5eb 1406 if (ckWARN(WARN_VOID)) {
e7fec78e 1407 /* don't warn on optimised away booleans, eg
b5a930ec 1408 * use constant Foo, 5; Foo || print; */
e7fec78e 1409 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
d4c19fe8 1410 useless = NULL;
960b4253
MG		 1411 /* the constants 0 and 1 are permitted as they are
1412 conventionally used as dummies in constructs like
1413 1 while some_condition_with_side_effects; */
e7fec78e 1414 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
d4c19fe8 1415 useless = NULL;
d008e5eb 1416 else if (SvPOK(sv)) {
1e3f3188
KW		 1417 SV * const dsv = newSVpvs("");
1418 useless_sv
1419 = Perl_newSVpvf(aTHX_
1420 "a constant (%s)",
1421 pv_pretty(dsv, SvPVX_const(sv),
1422 SvCUR(sv), 32, NULL, NULL,
1423 PERL_PV_PRETTY_DUMP
1424 | PERL_PV_ESCAPE_NOCLEAR
1425 | PERL_PV_ESCAPE_UNI_DETECT));
1426 SvREFCNT_dec_NN(dsv);
d008e5eb 1427 }
919f76a3 1428 else if (SvOK(sv)) {
095b19d1 1429 useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", sv);
919f76a3
RGS		 1430 }
1431 else
1432 useless = "a constant (undef)";
8990e307
LW		 1433 }
1434 }
93c66552 1435 op_null(o); /* don't execute or even remember it */
79072805
LW		 1436 break;
1437
1438 case OP_POSTINC:
11343788 1439 o->op_type = OP_PREINC; /* pre-increment is faster */
22c35a8c 1440 o->op_ppaddr = PL_ppaddr[OP_PREINC];
79072805
LW		 1441 break;
1442
1443 case OP_POSTDEC:
11343788 1444 o->op_type = OP_PREDEC; /* pre-decrement is faster */
22c35a8c 1445 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
79072805
LW		 1446 break;
1447
679d6c4e
HS		 1448 case OP_I_POSTINC:
1449 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1450 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1451 break;
1452
1453 case OP_I_POSTDEC:
1454 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1455 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1456 break;
1457
f2f8fd84
GG		 1458 case OP_SASSIGN: {
1459 OP *rv2gv;
1460 UNOP *refgen, *rv2cv;
1461 LISTOP *exlist;
1462
1463 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
1464 break;
1465
1466 rv2gv = ((BINOP *)o)->op_last;
1467 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
1468 break;
1469
1470 refgen = (UNOP *)((BINOP *)o)->op_first;
1471
1472 if (!refgen || refgen->op_type != OP_REFGEN)
1473 break;
1474
1475 exlist = (LISTOP *)refgen->op_first;
1476 if (!exlist || exlist->op_type != OP_NULL
1477 || exlist->op_targ != OP_LIST)
1478 break;
1479
1480 if (exlist->op_first->op_type != OP_PUSHMARK)
1481 break;
1482
1483 rv2cv = (UNOP*)exlist->op_last;
1484
1485 if (rv2cv->op_type != OP_RV2CV)
1486 break;
1487
1488 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
1489 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
1490 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
1491
1492 o->op_private |= OPpASSIGN_CV_TO_GV;
1493 rv2gv->op_private |= OPpDONT_INIT_GV;
1494 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
1495
1496 break;
1497 }
1498
540dd770
GG		 1499 case OP_AASSIGN: {
1500 inplace_aassign(o);
1501 break;
1502 }
1503
79072805
LW		 1504 case OP_OR:
1505 case OP_AND:
edbe35ea
VP		 1506 kid = cLOGOPo->op_first;
1507 if (kid->op_type == OP_NOT
1508 && (kid->op_flags & OPf_KIDS)
1509 && !PL_madskills) {
1510 if (o->op_type == OP_AND) {
1511 o->op_type = OP_OR;
1512 o->op_ppaddr = PL_ppaddr[OP_OR];
1513 } else {
1514 o->op_type = OP_AND;
1515 o->op_ppaddr = PL_ppaddr[OP_AND];
1516 }
1517 op_null(kid);
1518 }
1519
c963b151 1520 case OP_DOR:
79072805 1521 case OP_COND_EXPR:
0d863452
RH		 1522 case OP_ENTERGIVEN:
1523 case OP_ENTERWHEN:
11343788 1524 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
79072805
LW		 1525 scalarvoid(kid);
1526 break;
5aabfad6 1527
a0d0e21e 1528 case OP_NULL:
11343788 1529 if (o->op_flags & OPf_STACKED)
a0d0e21e 1530 break;
5aabfad6 1531 /* FALL THROUGH */
2ebea0a1
GS		 1532 case OP_NEXTSTATE:
1533 case OP_DBSTATE:
79072805
LW		 1534 case OP_ENTERTRY:
1535 case OP_ENTER:
11343788 1536 if (!(o->op_flags & OPf_KIDS))
79072805 1537 break;
54310121 1538 /* FALL THROUGH */
463ee0b2 1539 case OP_SCOPE:
79072805
LW		 1540 case OP_LEAVE:
1541 case OP_LEAVETRY:
a0d0e21e 1542 case OP_LEAVELOOP:
79072805 1543 case OP_LINESEQ:
79072805 1544 case OP_LIST:
0d863452
RH		 1545 case OP_LEAVEGIVEN:
1546 case OP_LEAVEWHEN:
11343788 1547 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW		 1548 scalarvoid(kid);
1549 break;
c90c0ff4 1550 case OP_ENTEREVAL:
5196be3e 1551 scalarkids(o);
c90c0ff4 1552 break;
d6483035 1553 case OP_SCALAR:
5196be3e 1554 return scalar(o);
79072805 1555 }
095b19d1
NC		 1556
1557 if (useless_sv) {
1558 /* mortalise it, in case warnings are fatal. */
1559 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
1560 "Useless use of %"SVf" in void context",
1561 sv_2mortal(useless_sv));
1562 }
1563 else if (useless) {
1564 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
1565 "Useless use of %s in void context",
1566 useless);
1567 }
11343788 1568 return o;
79072805
LW		 1569}
1570
1f676739 1571static OP *
412da003 1572S_listkids(pTHX_ OP *o)
79072805 1573{
11343788 1574 if (o && o->op_flags & OPf_KIDS) {
6867be6d 1575 OP *kid;
11343788 1576 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW		 1577 list(kid);
1578 }
11343788 1579 return o;
79072805
LW		 1580}
1581
1582OP *
864dbfa3 1583Perl_list(pTHX_ OP *o)
79072805 1584{
27da23d5 1585 dVAR;
79072805
LW		 1586 OP *kid;
1587
a0d0e21e 1588 /* assumes no premature commitment */
13765c85
DM		 1589 if (!o || (o->op_flags & OPf_WANT)
1590 || (PL_parser && PL_parser->error_count)
5dc0d613 1591 || o->op_type == OP_RETURN)
7e363e51 1592 {
11343788 1593 return o;
7e363e51 1594 }
79072805 1595
b162f9ea 1596 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS		 1597 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1598 {
b162f9ea 1599 return o; /* As if inside SASSIGN */
7e363e51 1600 }
1c846c1f 1601
5dc0d613 1602 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
79072805 1603
11343788 1604 switch (o->op_type) {
79072805
LW		 1605 case OP_FLOP:
1606 case OP_REPEAT:
11343788 1607 list(cBINOPo->op_first);
79072805
LW		 1608 break;
1609 case OP_OR:
1610 case OP_AND:
1611 case OP_COND_EXPR:
11343788 1612 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
79072805
LW		 1613 list(kid);
1614 break;
1615 default:
1616 case OP_MATCH:
8782bef2 1617 case OP_QR:
79072805
LW		 1618 case OP_SUBST:
1619 case OP_NULL:
11343788 1620 if (!(o->op_flags & OPf_KIDS))
79072805 1621 break;
11343788
MB		 1622 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1623 list(cBINOPo->op_first);
1624 return gen_constant_list(o);
79072805
LW		 1625 }
1626 case OP_LIST:
11343788 1627 listkids(o);
79072805
LW		 1628 break;
1629 case OP_LEAVE:
1630 case OP_LEAVETRY:
5dc0d613 1631 kid = cLISTOPo->op_first;
54310121 1632 list(kid);
25b991bf
VP		 1633 kid = kid->op_sibling;
1634 do_kids:
1635 while (kid) {
1636 OP *sib = kid->op_sibling;
c08f093b
VP		 1637 if (sib && kid->op_type != OP_LEAVEWHEN)
1638 scalarvoid(kid);
1639 else
54310121 1640 list(kid);
25b991bf 1641 kid = sib;
54310121 1642 }
11206fdd 1643 PL_curcop = &PL_compiling;
54310121 1644 break;
748a9306 1645 case OP_SCOPE:
79072805 1646 case OP_LINESEQ:
25b991bf
VP		 1647 kid = cLISTOPo->op_first;
1648 goto do_kids;
79072805 1649 }
11343788 1650 return o;
79072805
LW		 1651}
1652
1f676739 1653static OP *
2dd5337b 1654S_scalarseq(pTHX_ OP *o)
79072805 1655{
97aff369 1656 dVAR;
11343788 1657 if (o) {
1496a290
AL		 1658 const OPCODE type = o->op_type;
1659
1660 if (type == OP_LINESEQ || type == OP_SCOPE ||
1661 type == OP_LEAVE || type == OP_LEAVETRY)
463ee0b2 1662 {
6867be6d 1663 OP *kid;
11343788 1664 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
ed6116ce 1665 if (kid->op_sibling) {
463ee0b2 1666 scalarvoid(kid);
ed6116ce 1667 }
463ee0b2 1668 }
3280af22 1669 PL_curcop = &PL_compiling;
79072805 1670 }
11343788 1671 o->op_flags &= ~OPf_PARENS;
3280af22 1672 if (PL_hints & HINT_BLOCK_SCOPE)
11343788 1673 o->op_flags |= OPf_PARENS;
79072805 1674 }
8990e307 1675 else
11343788
MB		 1676 o = newOP(OP_STUB, 0);
1677 return o;
79072805
LW		 1678}
1679
76e3520e 1680STATIC OP *
cea2e8a9 1681S_modkids(pTHX_ OP *o, I32 type)
79072805 1682{
11343788 1683 if (o && o->op_flags & OPf_KIDS) {
6867be6d 1684 OP *kid;
11343788 1685 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
3ad73efd 1686 op_lvalue(kid, type);
79072805 1687 }
11343788 1688 return o;
79072805
LW		 1689}
1690
3ad73efd 1691/*
d164302a
GG		 1692=for apidoc finalize_optree
1693
1694This function finalizes the optree. Should be called directly after
1695the complete optree is built. It does some additional
1696checking which can't be done in the normal ck_xxx functions and makes
1697the tree thread-safe.
1698
1699=cut
1700*/
1701void
1702Perl_finalize_optree(pTHX_ OP* o)
1703{
1704 PERL_ARGS_ASSERT_FINALIZE_OPTREE;
1705
1706 ENTER;
1707 SAVEVPTR(PL_curcop);
1708
1709 finalize_op(o);
1710
1711 LEAVE;
1712}
1713
60dde6b2 1714STATIC void
d164302a
GG		 1715S_finalize_op(pTHX_ OP* o)
1716{
1717 PERL_ARGS_ASSERT_FINALIZE_OP;
1718
1719#if defined(PERL_MAD) && defined(USE_ITHREADS)
1720 {
1721 /* Make sure mad ops are also thread-safe */
1722 MADPROP *mp = o->op_madprop;
1723 while (mp) {
1724 if (mp->mad_type == MAD_OP && mp->mad_vlen) {
1725 OP *prop_op = (OP *) mp->mad_val;
1726 /* We only need "Relocate sv to the pad for thread safety.", but this
1727 easiest way to make sure it traverses everything */
4dc304e0
FC		 1728 if (prop_op->op_type == OP_CONST)
1729 cSVOPx(prop_op)->op_private &= ~OPpCONST_STRICT;
d164302a
GG		 1730 finalize_op(prop_op);
1731 }
1732 mp = mp->mad_next;
1733 }
1734 }
1735#endif
1736
1737 switch (o->op_type) {
1738 case OP_NEXTSTATE:
1739 case OP_DBSTATE:
1740 PL_curcop = ((COP*)o); /* for warnings */
1741 break;
1742 case OP_EXEC:
ea31ed66
GG		 1743 if ( o->op_sibling
1744 && (o->op_sibling->op_type == OP_NEXTSTATE || o->op_sibling->op_type == OP_DBSTATE)
573d2b1a 1745 && ckWARN(WARN_EXEC))
d164302a 1746 {
ea31ed66
GG		 1747 if (o->op_sibling->op_sibling) {
1748 const OPCODE type = o->op_sibling->op_sibling->op_type;
d164302a
GG		 1749 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
1750 const line_t oldline = CopLINE(PL_curcop);
ea31ed66 1751 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_sibling));
d164302a
GG		 1752 Perl_warner(aTHX_ packWARN(WARN_EXEC),
1753 "Statement unlikely to be reached");
1754 Perl_warner(aTHX_ packWARN(WARN_EXEC),
1755 "\t(Maybe you meant system() when you said exec()?)\n");
1756 CopLINE_set(PL_curcop, oldline);
1757 }
1758 }
1759 }
1760 break;
1761
1762 case OP_GV:
1763 if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
1764 GV * const gv = cGVOPo_gv;
1765 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
1766 /* XXX could check prototype here instead of just carping */
1767 SV * const sv = sv_newmortal();
1768 gv_efullname3(sv, gv, NULL);
1769 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
1770 "%"SVf"() called too early to check prototype",
1771 SVfARG(sv));
1772 }
1773 }
1774 break;
1775
1776 case OP_CONST:
eb796c7f
GG		 1777 if (cSVOPo->op_private & OPpCONST_STRICT)
1778 no_bareword_allowed(o);
1779 /* FALLTHROUGH */
d164302a
GG		 1780#ifdef USE_ITHREADS
1781 case OP_HINTSEVAL:
1782 case OP_METHOD_NAMED:
1783 /* Relocate sv to the pad for thread safety.
1784 * Despite being a "constant", the SV is written to,
1785 * for reference counts, sv_upgrade() etc. */
1786 if (cSVOPo->op_sv) {
325e1816 1787 const PADOFFSET ix = pad_alloc(OP_CONST, SVf_READONLY);
82b84d04 1788 if (o->op_type != OP_METHOD_NAMED
d164302a
GG		 1789 && cSVOPo->op_sv == &PL_sv_undef) {
1790 /* PL_sv_undef is hack - it's unsafe to store it in the
1791 AV that is the pad, because av_fetch treats values of
1792 PL_sv_undef as a "free" AV entry and will merrily
1793 replace them with a new SV, causing pad_alloc to think
1794 that this pad slot is free. (When, clearly, it is not)
1795 */
1796 SvOK_off(PAD_SVl(ix));
1797 SvPADTMP_on(PAD_SVl(ix));
1798 SvREADONLY_on(PAD_SVl(ix));
1799 }
1800 else {
1801 SvREFCNT_dec(PAD_SVl(ix));
d164302a
GG		 1802 PAD_SETSV(ix, cSVOPo->op_sv);
1803 /* XXX I don't know how this isn't readonly already. */
e3918bb7 1804 if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
d164302a
GG		 1805 }
1806 cSVOPo->op_sv = NULL;
1807 o->op_targ = ix;
1808 }
1809#endif
1810 break;
1811
1812 case OP_HELEM: {
1813 UNOP *rop;
1814 SV *lexname;
1815 GV **fields;
1816 SV **svp, *sv;
1817 const char *key = NULL;
1818 STRLEN keylen;
1819
1820 if (((BINOP*)o)->op_last->op_type != OP_CONST)
1821 break;
1822
1823 /* Make the CONST have a shared SV */
1824 svp = cSVOPx_svp(((BINOP*)o)->op_last);
e3918bb7 1825 if ((!SvIsCOW(sv = *svp))
d164302a
GG		 1826 && SvTYPE(sv) < SVt_PVMG && !SvROK(sv)) {
1827 key = SvPV_const(sv, keylen);
1828 lexname = newSVpvn_share(key,
1829 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
1830 0);
fc2b2dca 1831 SvREFCNT_dec_NN(sv);
d164302a
GG		 1832 *svp = lexname;
1833 }
1834
1835 if ((o->op_private & (OPpLVAL_INTRO)))
1836 break;
1837
1838 rop = (UNOP*)((BINOP*)o)->op_first;
1839 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
1840 break;
1841 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
1842 if (!SvPAD_TYPED(lexname))
1843 break;
1844 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
1845 if (!fields || !GvHV(*fields))
1846 break;
1847 key = SvPV_const(*svp, keylen);
1848 if (!hv_fetch(GvHV(*fields), key,
1849 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) {
ce16c625 1850 Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
84cf752c 1851 "in variable %"SVf" of type %"HEKf,
ce16c625 1852 SVfARG(*svp), SVfARG(lexname),
84cf752c 1853 HEKfARG(HvNAME_HEK(SvSTASH(lexname))));
d164302a
GG		 1854 }
1855 break;
1856 }
1857
1858 case OP_HSLICE: {
1859 UNOP *rop;
1860 SV *lexname;
1861 GV **fields;
1862 SV **svp;
1863 const char *key;
1864 STRLEN keylen;
1865 SVOP *first_key_op, *key_op;
1866
1867 if ((o->op_private & (OPpLVAL_INTRO))
1868 /* I bet there's always a pushmark... */
1869 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
1870 /* hmmm, no optimization if list contains only one key. */
1871 break;
1872 rop = (UNOP*)((LISTOP*)o)->op_last;
1873 if (rop->op_type != OP_RV2HV)
1874 break;
1875 if (rop->op_first->op_type == OP_PADSV)
1876 /* @$hash{qw(keys here)} */
1877 rop = (UNOP*)rop->op_first;
1878 else {
1879 /* @{$hash}{qw(keys here)} */
1880 if (rop->op_first->op_type == OP_SCOPE
1881 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
1882 {
1883 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
1884 }
1885 else
1886 break;
1887 }
1888
1889 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
1890 if (!SvPAD_TYPED(lexname))
1891 break;
1892 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
1893 if (!fields || !GvHV(*fields))
1894 break;
1895 /* Again guessing that the pushmark can be jumped over.... */
1896 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
1897 ->op_first->op_sibling;
1898 for (key_op = first_key_op; key_op;
1899 key_op = (SVOP*)key_op->op_sibling) {
1900 if (key_op->op_type != OP_CONST)
1901 continue;
1902 svp = cSVOPx_svp(key_op);
1903 key = SvPV_const(*svp, keylen);
1904 if (!hv_fetch(GvHV(*fields), key,
1905 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) {
ce16c625 1906 Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
84cf752c 1907 "in variable %"SVf" of type %"HEKf,
ce16c625 1908 SVfARG(*svp), SVfARG(lexname),
84cf752c 1909 HEKfARG(HvNAME_HEK(SvSTASH(lexname))));
d164302a
GG		 1910 }
1911 }
1912 break;
1913 }
a7fd8ef6 1914
d164302a
GG		 1915 case OP_SUBST: {
1916 if (cPMOPo->op_pmreplrootu.op_pmreplroot)
1917 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
1918 break;
1919 }
1920 default:
1921 break;
1922 }
1923
1924 if (o->op_flags & OPf_KIDS) {
1925 OP *kid;
1926 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1927 finalize_op(kid);
1928 }
1929}
1930
1931/*
3ad73efd
Z		 1932=for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
1933
1934Propagate lvalue ("modifiable") context to an op and its children.
1935I<type> represents the context type, roughly based on the type of op that
1936would do the modifying, although C<local()> is represented by OP_NULL,
1937because it has no op type of its own (it is signalled by a flag on
001c3c51
FC		 1938the lvalue op).
1939
1940This function detects things that can't be modified, such as C<$x+1>, and
1941generates errors for them. For example, C<$x+1 = 2> would cause it to be
1942called with an op of type OP_ADD and a C<type> argument of OP_SASSIGN.
1943
1944It also flags things that need to behave specially in an lvalue context,
1945such as C<$$x = 5> which might have to vivify a reference in C<$x>.
3ad73efd
Z		 1946
1947=cut
1948*/
ddeae0f1 1949
79072805 1950OP *
d3d7d28f 1951Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
79072805 1952{
27da23d5 1953 dVAR;
79072805 1954 OP *kid;
ddeae0f1
DM		 1955 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1956 int localize = -1;
79072805 1957
13765c85 1958 if (!o || (PL_parser && PL_parser->error_count))
11343788 1959 return o;
79072805 1960
b162f9ea 1961 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS		 1962 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1963 {
b162f9ea 1964 return o;
7e363e51 1965 }
1c846c1f 1966
5c906035
GG		 1967 assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
1968
69974ce6
FC		 1969 if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
1970
11343788 1971 switch (o->op_type) {
68dc0745 1972 case OP_UNDEF:
3280af22 1973 PL_modcount++;
5dc0d613 1974 return o;
5f05dabc 1975 case OP_STUB:
58bde88d 1976 if ((o->op_flags & OPf_PARENS) || PL_madskills)
5f05dabc 1977 break;
1978 goto nomod;
a0d0e21e 1979 case OP_ENTERSUB:
f79aa60b 1980 if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
11343788
MB		 1981 !(o->op_flags & OPf_STACKED)) {
1982 o->op_type = OP_RV2CV; /* entersub => rv2cv */
767eda44
FC		 1983 /* Both ENTERSUB and RV2CV use this bit, but for different pur-
1984 poses, so we need it clear. */
e26df76a 1985 o->op_private &= ~1;
22c35a8c 1986 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
11343788 1987 assert(cUNOPo->op_first->op_type == OP_NULL);
93c66552 1988 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
79072805
LW		 1989 break;
1990 }
cd06dffe 1991 else { /* lvalue subroutine call */
777d9014
FC		 1992 o->op_private |= OPpLVAL_INTRO
1993 |(OPpENTERSUB_INARGS * (type == OP_LEAVESUBLV));
e6438c1a 1994 PL_modcount = RETURN_UNLIMITED_NUMBER;
4978d6d9 1995 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
d0887bf3 1996 /* Potential lvalue context: */
cd06dffe
GS		 1997 o->op_private |= OPpENTERSUB_INARGS;
1998 break;
1999 }
2000 else { /* Compile-time error message: */
2001 OP *kid = cUNOPo->op_first;
2002 CV *cv;
cd06dffe 2003
3ea285d1
AL		 2004 if (kid->op_type != OP_PUSHMARK) {
2005 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
2006 Perl_croak(aTHX_
2007 "panic: unexpected lvalue entersub "
2008 "args: type/targ %ld:%"UVuf,
2009 (long)kid->op_type, (UV)kid->op_targ);
2010 kid = kLISTOP->op_first;
2011 }
cd06dffe
GS		 2012 while (kid->op_sibling)
2013 kid = kid->op_sibling;
2014 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
cd06dffe
GS		 2015 break; /* Postpone until runtime */
2016 }
b2ffa427 2017
cd06dffe
GS		 2018 kid = kUNOP->op_first;
2019 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
2020 kid = kUNOP->op_first;
b2ffa427 2021 if (kid->op_type == OP_NULL)
cd06dffe
GS		 2022 Perl_croak(aTHX_
2023 "Unexpected constant lvalue entersub "
55140b79 2024 "entry via type/targ %ld:%"UVuf,
3d811634 2025 (long)kid->op_type, (UV)kid->op_targ);
cd06dffe 2026 if (kid->op_type != OP_GV) {
cd06dffe
GS		 2027 break;
2028 }
b2ffa427 2029
638eceb6 2030 cv = GvCV(kGVOP_gv);
1c846c1f 2031 if (!cv)
da1dff94 2032 break;
cd06dffe
GS		 2033 if (CvLVALUE(cv))
2034 break;
2035 }
2036 }
79072805
LW		 2037 /* FALL THROUGH */
2038 default:
a0d0e21e 2039 nomod:
f5d552b4 2040 if (flags & OP_LVALUE_NO_CROAK) return NULL;
6fbb66d6 2041 /* grep, foreach, subcalls, refgen */
145b2bbb
FC		 2042 if (type == OP_GREPSTART || type == OP_ENTERSUB
2043 || type == OP_REFGEN || type == OP_LEAVESUBLV)
a0d0e21e 2044 break;
cea2e8a9 2045 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
638bc118 2046 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
cd06dffe
GS		 2047 ? "do block"
2048 : (o->op_type == OP_ENTERSUB
2049 ? "non-lvalue subroutine call"
53e06cf0 2050 : OP_DESC(o))),
22c35a8c 2051 type ? PL_op_desc[type] : "local"));
11343788 2052 return o;
79072805 2053
a0d0e21e
LW		 2054 case OP_PREINC:
2055 case OP_PREDEC:
2056 case OP_POW:
2057 case OP_MULTIPLY:
2058 case OP_DIVIDE:
2059 case OP_MODULO:
2060 case OP_REPEAT:
2061 case OP_ADD:
2062 case OP_SUBTRACT:
2063 case OP_CONCAT:
2064 case OP_LEFT_SHIFT:
2065 case OP_RIGHT_SHIFT:
2066 case OP_BIT_AND:
2067 case OP_BIT_XOR:
2068 case OP_BIT_OR:
2069 case OP_I_MULTIPLY:
2070 case OP_I_DIVIDE:
2071 case OP_I_MODULO:
2072 case OP_I_ADD:
2073 case OP_I_SUBTRACT:
11343788 2074 if (!(o->op_flags & OPf_STACKED))
a0d0e21e 2075 goto nomod;
3280af22 2076 PL_modcount++;
a0d0e21e 2077 break;
b2ffa427 2078
79072805 2079 case OP_COND_EXPR:
ddeae0f1 2080 localize = 1;
11343788 2081 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
3ad73efd 2082 op_lvalue(kid, type);
79072805
LW		 2083 break;
2084
2085 case OP_RV2AV:
2086 case OP_RV2HV:
11343788 2087 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
e6438c1a 2088 PL_modcount = RETURN_UNLIMITED_NUMBER;
11343788 2089 return o; /* Treat \(@foo) like ordinary list. */
748a9306
LW		 2090 }
2091 /* FALL THROUGH */
79072805 2092 case OP_RV2GV:
5dc0d613 2093 if (scalar_mod_type(o, type))
3fe9a6f1 2094 goto nomod;
11343788 2095 ref(cUNOPo->op_first, o->op_type);
79072805 2096 /* FALL THROUGH */
79072805
LW		 2097 case OP_ASLICE:
2098 case OP_HSLICE:
ddeae0f1 2099 localize = 1;
78f9721b
SM		 2100 /* FALL THROUGH */
2101 case OP_AASSIGN:
631dbaa2
FC		 2102 if (type == OP_LEAVESUBLV)
2103 o->op_private |= OPpMAYBE_LVSUB;
2104 /* FALL THROUGH */
93a17b20
LW		 2105 case OP_NEXTSTATE:
2106 case OP_DBSTATE:
e6438c1a 2107 PL_modcount = RETURN_UNLIMITED_NUMBER;
79072805 2108 break;
28c5b5bc
RGS		 2109 case OP_AV2ARYLEN:
2110 PL_hints |= HINT_BLOCK_SCOPE;
2111 if (type == OP_LEAVESUBLV)
2112 o->op_private |= OPpMAYBE_LVSUB;
2113 PL_modcount++;
2114 break;
463ee0b2 2115 case OP_RV2SV:
aeea060c 2116 ref(cUNOPo->op_first, o->op_type);
ddeae0f1 2117 localize = 1;
463ee0b2 2118 /* FALL THROUGH */
79072805 2119 case OP_GV:
3280af22 2120 PL_hints |= HINT_BLOCK_SCOPE;
463ee0b2 2121 case OP_SASSIGN:
bf4b1e52
GS		 2122 case OP_ANDASSIGN:
2123 case OP_ORASSIGN:
c963b151 2124 case OP_DORASSIGN:
ddeae0f1
DM		 2125 PL_modcount++;
2126 break;
2127
8990e307 2128 case OP_AELEMFAST:
93bad3fd 2129 case OP_AELEMFAST_LEX:
6a077020 2130 localize = -1;
3280af22 2131 PL_modcount++;
8990e307
LW		 2132 break;
2133
748a9306
LW		 2134 case OP_PADAV:
2135 case OP_PADHV:
e6438c1a 2136 PL_modcount = RETURN_UNLIMITED_NUMBER;
5196be3e
MB		 2137 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
2138 return o; /* Treat \(@foo) like ordinary list. */
2139 if (scalar_mod_type(o, type))
3fe9a6f1 2140 goto nomod;
78f9721b
SM		 2141 if (type == OP_LEAVESUBLV)
2142 o->op_private |= OPpMAYBE_LVSUB;
748a9306
LW		 2143 /* FALL THROUGH */
2144 case OP_PADSV:
3280af22 2145 PL_modcount++;
ddeae0f1 2146 if (!type) /* local() */
5ede95a0
BF		 2147 Perl_croak(aTHX_ "Can't localize lexical variable %"SVf,
2148 PAD_COMPNAME_SV(o->op_targ));
463ee0b2
LW		 2149 break;
2150
748a9306 2151 case OP_PUSHMARK:
ddeae0f1 2152 localize = 0;
748a9306 2153 break;
b2ffa427 2154
69969c6f 2155 case OP_KEYS:
d8065907 2156 case OP_RKEYS:
fad4a2e4 2157 if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
69969c6f 2158 goto nomod;
5d82c453
GA		 2159 goto lvalue_func;
2160 case OP_SUBSTR:
2161 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
2162 goto nomod;
5f05dabc 2163 /* FALL THROUGH */
a0d0e21e 2164 case OP_POS:
463ee0b2 2165 case OP_VEC:
fad4a2e4 2166 lvalue_func:
78f9721b
SM		 2167 if (type == OP_LEAVESUBLV)
2168 o->op_private |= OPpMAYBE_LVSUB;
11343788 2169 if (o->op_flags & OPf_KIDS)
3ad73efd 2170 op_lvalue(cBINOPo->op_first->op_sibling, type);
463ee0b2 2171 break;
a0d0e21e 2172
463ee0b2
LW		 2173 case OP_AELEM:
2174 case OP_HELEM:
11343788 2175 ref(cBINOPo->op_first, o->op_type);
68dc0745 2176 if (type == OP_ENTERSUB &&
5dc0d613
MB		 2177 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
2178 o->op_private |= OPpLVAL_DEFER;
78f9721b
SM		 2179 if (type == OP_LEAVESUBLV)
2180 o->op_private |= OPpMAYBE_LVSUB;
ddeae0f1 2181 localize = 1;
3280af22 2182 PL_modcount++;
463ee0b2
LW		 2183 break;
2184
2185 case OP_SCOPE:
2186 case OP_LEAVE:
2187 case OP_ENTER:
78f9721b 2188 case OP_LINESEQ:
ddeae0f1 2189 localize = 0;
11343788 2190 if (o->op_flags & OPf_KIDS)
3ad73efd 2191 op_lvalue(cLISTOPo->op_last, type);
a0d0e21e
LW		 2192 break;
2193
2194 case OP_NULL:
ddeae0f1 2195 localize = 0;
638bc118
GS		 2196 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
2197 goto nomod;
2198 else if (!(o->op_flags & OPf_KIDS))
463ee0b2 2199 break;
11343788 2200 if (o->op_targ != OP_LIST) {
3ad73efd 2201 op_lvalue(cBINOPo->op_first, type);
a0d0e21e
LW		 2202 break;
2203 }
2204 /* FALL THROUGH */
463ee0b2 2205 case OP_LIST:
ddeae0f1 2206 localize = 0;
11343788 2207 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
5c906035
GG		 2208 /* elements might be in void context because the list is
2209 in scalar context or because they are attribute sub calls */
2210 if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
2211 op_lvalue(kid, type);
463ee0b2 2212 break;
78f9721b
SM		 2213
2214 case OP_RETURN:
2215 if (type != OP_LEAVESUBLV)
2216 goto nomod;
3ad73efd 2217 break; /* op_lvalue()ing was handled by ck_return() */
1efec5ed
FC		 2218
2219 case OP_COREARGS:
2220 return o;
463ee0b2 2221 }
58d95175 2222
8be1be90
AMS		 2223 /* [20011101.069] File test operators interpret OPf_REF to mean that
2224 their argument is a filehandle; thus \stat(".") should not set
2225 it. AMS 20011102 */
2226 if (type == OP_REFGEN &&
ef69c8fc 2227 PL_check[o->op_type] == Perl_ck_ftst)
8be1be90
AMS		 2228 return o;
2229
2230 if (type != OP_LEAVESUBLV)
2231 o->op_flags |= OPf_MOD;
2232
2233 if (type == OP_AASSIGN || type == OP_SASSIGN)
2234 o->op_flags |= OPf_SPECIAL|OPf_REF;
ddeae0f1
DM		 2235 else if (!type) { /* local() */
2236 switch (localize) {
2237 case 1:
2238 o->op_private |= OPpLVAL_INTRO;
2239 o->op_flags &= ~OPf_SPECIAL;
2240 PL_hints |= HINT_BLOCK_SCOPE;
2241 break;
2242 case 0:
2243 break;
2244 case -1:
a2a5de95
NC		 2245 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
2246 "Useless localization of %s", OP_DESC(o));
ddeae0f1 2247 }
463ee0b2 2248 }
8be1be90
AMS		 2249 else if (type != OP_GREPSTART && type != OP_ENTERSUB
2250 && type != OP_LEAVESUBLV)
2251 o->op_flags |= OPf_REF;
11343788 2252 return o;
463ee0b2
LW		 2253}
2254
864dbfa3 2255STATIC bool
5f66b61c 2256S_scalar_mod_type(const OP *o, I32 type)
3fe9a6f1 2257{
2258 switch (type) {
32a60974 2259 case OP_POS:
3fe9a6f1 2260 case OP_SASSIGN:
1efec5ed 2261 if (o && o->op_type == OP_RV2GV)
3fe9a6f1 2262 return FALSE;
2263 /* FALL THROUGH */
2264 case OP_PREINC:
2265 case OP_PREDEC:
2266 case OP_POSTINC:
2267 case OP_POSTDEC:
2268 case OP_I_PREINC:
2269 case OP_I_PREDEC:
2270 case OP_I_POSTINC:
2271 case OP_I_POSTDEC:
2272 case OP_POW:
2273 case OP_MULTIPLY:
2274 case OP_DIVIDE:
2275 case OP_MODULO:
2276 case OP_REPEAT:
2277 case OP_ADD:
2278 case OP_SUBTRACT:
2279 case OP_I_MULTIPLY:
2280 case OP_I_DIVIDE:
2281 case OP_I_MODULO:
2282 case OP_I_ADD:
2283 case OP_I_SUBTRACT:
2284 case OP_LEFT_SHIFT:
2285 case OP_RIGHT_SHIFT:
2286 case OP_BIT_AND:
2287 case OP_BIT_XOR:
2288 case OP_BIT_OR:
2289 case OP_CONCAT:
2290 case OP_SUBST:
2291 case OP_TRANS:
bb16bae8 2292 case OP_TRANSR:
49e9fbe6
GS		 2293 case OP_READ:
2294 case OP_SYSREAD:
2295 case OP_RECV:
bf4b1e52
GS		 2296 case OP_ANDASSIGN:
2297 case OP_ORASSIGN:
410d09fe 2298 case OP_DORASSIGN:
3fe9a6f1 2299 return TRUE;
2300 default:
2301 return FALSE;
2302 }
2303}
2304
35cd451c 2305STATIC bool
5f66b61c 2306S_is_handle_constructor(const OP *o, I32 numargs)
35cd451c 2307{
7918f24d
NC		 2308 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
2309
35cd451c
GS		 2310 switch (o->op_type) {
2311 case OP_PIPE_OP:
2312 case OP_SOCKPAIR:
504618e9 2313 if (numargs == 2)
35cd451c
GS		 2314 return TRUE;
2315 /* FALL THROUGH */
2316 case OP_SYSOPEN:
2317 case OP_OPEN:
ded8aa31 2318 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
35cd451c
GS		 2319 case OP_SOCKET:
2320 case OP_OPEN_DIR:
2321 case OP_ACCEPT:
504618e9 2322 if (numargs == 1)
35cd451c 2323 return TRUE;
5f66b61c 2324 /* FALLTHROUGH */
35cd451c
GS		 2325 default:
2326 return FALSE;
2327 }
2328}
2329
0d86688d
NC		 2330static OP *
2331S_refkids(pTHX_ OP *o, I32 type)
463ee0b2 2332{
11343788 2333 if (o && o->op_flags & OPf_KIDS) {
6867be6d 2334 OP *kid;
11343788 2335 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
463ee0b2
LW		 2336 ref(kid, type);
2337 }
11343788 2338 return o;
463ee0b2
LW		 2339}
2340
2341OP *
e4c5ccf3 2342Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
463ee0b2 2343{
27da23d5 2344 dVAR;
463ee0b2 2345 OP *kid;
463ee0b2 2346
7918f24d
NC		 2347 PERL_ARGS_ASSERT_DOREF;
2348
13765c85 2349 if (!o || (PL_parser && PL_parser->error_count))
11343788 2350 return o;
463ee0b2 2351
11343788 2352 switch (o->op_type) {
a0d0e21e 2353 case OP_ENTERSUB:
f4df43b5 2354 if ((type == OP_EXISTS || type == OP_DEFINED) &&
11343788
MB		 2355 !(o->op_flags & OPf_STACKED)) {
2356 o->op_type = OP_RV2CV; /* entersub => rv2cv */
22c35a8c 2357 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
11343788 2358 assert(cUNOPo->op_first->op_type == OP_NULL);
93c66552 2359 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
11343788 2360 o->op_flags |= OPf_SPECIAL;
e26df76a 2361 o->op_private &= ~1;
8990e307 2362 }
767eda44 2363 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
0e9700df
GG		 2364 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2365 : type == OP_RV2HV ? OPpDEREF_HV
2366 : OPpDEREF_SV);
767eda44
FC		 2367 o->op_flags |= OPf_MOD;
2368 }
2369
8990e307 2370 break;
aeea060c 2371
463ee0b2 2372 case OP_COND_EXPR:
11343788 2373 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
e4c5ccf3 2374 doref(kid, type, set_op_ref);
463ee0b2 2375 break;
8990e307 2376 case OP_RV2SV:
35cd451c
GS		 2377 if (type == OP_DEFINED)
2378 o->op_flags |= OPf_SPECIAL; /* don't create GV */
e4c5ccf3 2379 doref(cUNOPo->op_first, o->op_type, set_op_ref);
4633a7c4
LW		 2380 /* FALL THROUGH */
2381 case OP_PADSV:
5f05dabc 2382 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5dc0d613
MB		 2383 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2384 : type == OP_RV2HV ? OPpDEREF_HV
2385 : OPpDEREF_SV);
11343788 2386 o->op_flags |= OPf_MOD;
a0d0e21e 2387 }
8990e307 2388 break;
1c846c1f 2389
463ee0b2
LW		 2390 case OP_RV2AV:
2391 case OP_RV2HV:
e4c5ccf3
RH		 2392 if (set_op_ref)
2393 o->op_flags |= OPf_REF;
8990e307 2394 /* FALL THROUGH */
463ee0b2 2395 case OP_RV2GV:
35cd451c
GS		 2396 if (type == OP_DEFINED)
2397 o->op_flags |= OPf_SPECIAL; /* don't create GV */
e4c5ccf3 2398 doref(cUNOPo->op_first, o->op_type, set_op_ref);
463ee0b2 2399 break;
8990e307 2400
463ee0b2
LW		 2401 case OP_PADAV:
2402 case OP_PADHV:
e4c5ccf3
RH		 2403 if (set_op_ref)
2404 o->op_flags |= OPf_REF;
79072805 2405 break;
aeea060c 2406
8990e307 2407 case OP_SCALAR:
79072805 2408 case OP_NULL:
518618af 2409 if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
463ee0b2 2410 break;
e4c5ccf3 2411 doref(cBINOPo->op_first, type, set_op_ref);
79072805
LW		 2412 break;
2413 case OP_AELEM:
2414 case OP_HELEM:
e4c5ccf3 2415 doref(cBINOPo->op_first, o->op_type, set_op_ref);
5f05dabc 2416 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5dc0d613
MB		 2417 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2418 : type == OP_RV2HV ? OPpDEREF_HV
2419 : OPpDEREF_SV);
11343788 2420 o->op_flags |= OPf_MOD;
8990e307 2421 }
79072805
LW		 2422 break;
2423
463ee0b2 2424 case OP_SCOPE:
79072805 2425 case OP_LEAVE:
e4c5ccf3
RH		 2426 set_op_ref = FALSE;
2427 /* FALL THROUGH */
79072805 2428 case OP_ENTER:
8990e307 2429 case OP_LIST:
11343788 2430 if (!(o->op_flags & OPf_KIDS))
79072805 2431 break;
e4c5ccf3 2432 doref(cLISTOPo->op_last, type, set_op_ref);
79072805 2433 break;
a0d0e21e
LW		 2434 default:
2435 break;
79072805 2436 }
11343788 2437 return scalar(o);
8990e307 2438
79072805
LW		 2439}
2440
09bef843
SB		 2441STATIC OP *
2442S_dup_attrlist(pTHX_ OP *o)
2443{
97aff369 2444 dVAR;
0bd48802 2445 OP *rop;
09bef843 2446
7918f24d
NC		 2447 PERL_ARGS_ASSERT_DUP_ATTRLIST;
2448
09bef843
SB		 2449 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
2450 * where the first kid is OP_PUSHMARK and the remaining ones
2451 * are OP_CONST. We need to push the OP_CONST values.
2452 */
2453 if (o->op_type == OP_CONST)
b37c2d43 2454 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
eb8433b7
NC		 2455#ifdef PERL_MAD
2456 else if (o->op_type == OP_NULL)
1d866c12 2457 rop = NULL;
eb8433b7 2458#endif
09bef843
SB		 2459 else {
2460 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
5f66b61c 2461 rop = NULL;
09bef843
SB		 2462 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
2463 if (o->op_type == OP_CONST)
2fcb4757 2464 rop = op_append_elem(OP_LIST, rop,
09bef843 2465 newSVOP(OP_CONST, o->op_flags,
b37c2d43 2466 SvREFCNT_inc_NN(cSVOPo->op_sv)));
09bef843
SB		 2467 }
2468 }
2469 return rop;
2470}
2471
2472STATIC void
ad0dc73b 2473S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
09bef843 2474{
27da23d5 2475 dVAR;
ad0dc73b 2476 SV * const stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
09bef843 2477
7918f24d
NC		 2478 PERL_ARGS_ASSERT_APPLY_ATTRS;
2479
09bef843
SB		 2480 /* fake up C<use attributes $pkg,$rv,@attrs> */
2481 ENTER; /* need to protect against side-effects of 'use' */
e4783991 2482
09bef843 2483#define ATTRSMODULE "attributes"
95f0a2f1
SB		 2484#define ATTRSMODULE_PM "attributes.pm"
2485
ad0dc73b 2486 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
6136c704
AL		 2487 newSVpvs(ATTRSMODULE),
2488 NULL,
2fcb4757 2489 op_prepend_elem(OP_LIST,
95f0a2f1 2490 newSVOP(OP_CONST, 0, stashsv),
2fcb4757 2491 op_prepend_elem(OP_LIST,
95f0a2f1
SB		 2492 newSVOP(OP_CONST, 0,
2493 newRV(target)),
2494 dup_attrlist(attrs))));
09bef843
SB		 2495 LEAVE;
2496}
2497
95f0a2f1
SB		 2498STATIC void
2499S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
2500{
97aff369 2501 dVAR;
95f0a2f1 2502 OP *pack, *imop, *arg;
ad0dc73b 2503 SV *meth, *stashsv, **svp;
95f0a2f1 2504
7918f24d
NC		 2505 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
2506
95f0a2f1
SB		 2507 if (!attrs)
2508 return;
2509
2510 assert(target->op_type == OP_PADSV ||
2511 target->op_type == OP_PADHV ||
2512 target->op_type == OP_PADAV);
2513
2514 /* Ensure that attributes.pm is loaded. */
ad0dc73b
FC		 2515 ENTER; /* need to protect against side-effects of 'use' */
2516 /* Don't force the C<use> if we don't need it. */
2517 svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
2518 if (svp && *svp != &PL_sv_undef)
2519 NOOP; /* already in %INC */
2520 else
2521 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
2522 newSVpvs(ATTRSMODULE), NULL);
2523 LEAVE;
95f0a2f1
SB		 2524
2525 /* Need package name for method call. */
6136c704 2526 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
95f0a2f1
SB		 2527
2528 /* Build up the real arg-list. */
5aaec2b4
NC		 2529 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2530
95f0a2f1
SB		 2531 arg = newOP(OP_PADSV, 0);
2532 arg->op_targ = target->op_targ;
2fcb4757 2533 arg = op_prepend_elem(OP_LIST,
95f0a2f1 2534 newSVOP(OP_CONST, 0, stashsv),
2fcb4757 2535 op_prepend_elem(OP_LIST,
95f0a2f1 2536 newUNOP(OP_REFGEN, 0,
3ad73efd 2537 op_lvalue(arg, OP_REFGEN)),
95f0a2f1
SB		 2538 dup_attrlist(attrs)));
2539
2540 /* Fake up a method call to import */
18916d0d 2541 meth = newSVpvs_share("import");
95f0a2f1 2542 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2fcb4757
Z		 2543 op_append_elem(OP_LIST,
2544 op_prepend_elem(OP_LIST, pack, list(arg)),
95f0a2f1 2545 newSVOP(OP_METHOD_NAMED, 0, meth)));
95f0a2f1
SB		 2546
2547 /* Combine the ops. */
2fcb4757 2548 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
95f0a2f1
SB		 2549}
2550
2551/*
2552=notfor apidoc apply_attrs_string
2553
2554Attempts to apply a list of attributes specified by the C<attrstr> and
2555C<len> arguments to the subroutine identified by the C<cv> argument which
2556is expected to be associated with the package identified by the C<stashpv>
2557argument (see L<attributes>). It gets this wrong, though, in that it
2558does not correctly identify the boundaries of the individual attribute
2559specifications within C<attrstr>. This is not really intended for the
2560public API, but has to be listed here for systems such as AIX which
2561need an explicit export list for symbols. (It's called from XS code
2562in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
2563to respect attribute syntax properly would be welcome.
2564
2565=cut
2566*/
2567
be3174d2 2568void
6867be6d
AL		 2569Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
2570 const char *attrstr, STRLEN len)
be3174d2 2571{
5f66b61c 2572 OP *attrs = NULL;
be3174d2 2573
7918f24d
NC		 2574 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2575
be3174d2
GS		 2576 if (!len) {
2577 len = strlen(attrstr);
2578 }
2579
2580 while (len) {
2581 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2582 if (len) {
890ce7af 2583 const char * const sstr = attrstr;
be3174d2 2584 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2fcb4757 2585 attrs = op_append_elem(OP_LIST, attrs,
be3174d2
GS		 2586 newSVOP(OP_CONST, 0,
2587 newSVpvn(sstr, attrstr-sstr)));
2588 }
2589 }
2590
2591 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
6136c704 2592 newSVpvs(ATTRSMODULE),
2fcb4757 2593 NULL, op_prepend_elem(OP_LIST,
be3174d2 2594 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2fcb4757 2595 op_prepend_elem(OP_LIST,
be3174d2 2596 newSVOP(OP_CONST, 0,
ad64d0ec 2597 newRV(MUTABLE_SV(cv))),
be3174d2
GS		 2598 attrs)));
2599}
2600
09bef843 2601STATIC OP *
95f0a2f1 2602S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
93a17b20 2603{
97aff369 2604 dVAR;
93a17b20 2605 I32 type;
a1fba7eb 2606 const bool stately = PL_parser && PL_parser->in_my == KEY_state;
93a17b20 2607
7918f24d
NC		 2608 PERL_ARGS_ASSERT_MY_KID;
2609
13765c85 2610 if (!o || (PL_parser && PL_parser->error_count))
11343788 2611 return o;
93a17b20 2612
bc61e325 2613 type = o->op_type;
eb8433b7
NC		 2614 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2615 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2616 return o;
2617 }
2618
93a17b20 2619 if (type == OP_LIST) {
6867be6d 2620 OP *kid;
11343788 2621 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
95f0a2f1 2622 my_kid(kid, attrs, imopsp);
0865059d 2623 return o;
8b8c1fb9 2624 } else if (type == OP_UNDEF || type == OP_STUB) {
7766148a 2625 return o;
77ca0c92
LW		 2626 } else if (type == OP_RV2SV || /* "our" declaration */
2627 type == OP_RV2AV ||
2628 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1ce0b88c 2629 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
fab01b8e 2630 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
952306ac 2631 OP_DESC(o),
12bd6ede
DM		 2632 PL_parser->in_my == KEY_our
2633 ? "our"
2634 : PL_parser->in_my == KEY_state ? "state" : "my"));
1ce0b88c 2635 } else if (attrs) {
551405c4 2636 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
12bd6ede
DM		 2637 PL_parser->in_my = FALSE;
2638 PL_parser->in_my_stash = NULL;
1ce0b88c
RGS		 2639 apply_attrs(GvSTASH(gv),
2640 (type == OP_RV2SV ? GvSV(gv) :
ad64d0ec
NC		 2641 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2642 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
ad0dc73b 2643 attrs);
1ce0b88c 2644 }
192587c2 2645 o->op_private |= OPpOUR_INTRO;
77ca0c92 2646 return o;
95f0a2f1
SB		 2647 }
2648 else if (type != OP_PADSV &&
93a17b20
LW		 2649 type != OP_PADAV &&
2650 type != OP_PADHV &&
2651 type != OP_PUSHMARK)
2652 {
eb64745e 2653 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
53e06cf0 2654 OP_DESC(o),
12bd6ede
DM		 2655 PL_parser->in_my == KEY_our
2656 ? "our"
2657 : PL_parser->in_my == KEY_state ? "state" : "my"));
11343788 2658 return o;
93a17b20 2659 }
09bef843
SB		 2660 else if (attrs && type != OP_PUSHMARK) {
2661 HV *stash;
09bef843 2662
12bd6ede
DM		 2663 PL_parser->in_my = FALSE;
2664 PL_parser->in_my_stash = NULL;
eb64745e 2665
09bef843 2666 /* check for C<my Dog $spot> when deciding package */
dd2155a4
DM		 2667 stash = PAD_COMPNAME_TYPE(o->op_targ);
2668 if (!stash)
09bef843 2669 stash = PL_curstash;
95f0a2f1 2670 apply_attrs_my(stash, o, attrs, imopsp);
09bef843 2671 }
11343788
MB		 2672 o->op_flags |= OPf_MOD;
2673 o->op_private |= OPpLVAL_INTRO;
a1fba7eb 2674 if (stately)
952306ac 2675 o->op_private |= OPpPAD_STATE;
11343788 2676 return o;
93a17b20
LW		 2677}
2678
2679OP *
09bef843
SB		 2680Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2681{
97aff369 2682 dVAR;
0bd48802 2683 OP *rops;
95f0a2f1
SB		 2684 int maybe_scalar = 0;
2685
7918f24d
NC		 2686 PERL_ARGS_ASSERT_MY_ATTRS;
2687
d2be0de5 2688/* [perl #17376]: this appears to be premature, and results in code such as
c754c3d7 2689 C< our(%x); > executing in list mode rather than void mode */
d2be0de5 2690#if 0
09bef843
SB		 2691 if (o->op_flags & OPf_PARENS)
2692 list(o);
95f0a2f1
SB		 2693 else
2694 maybe_scalar = 1;
d2be0de5
YST		 2695#else
2696 maybe_scalar = 1;
2697#endif
09bef843
SB		 2698 if (attrs)
2699 SAVEFREEOP(attrs);
5f66b61c 2700 rops = NULL;
95f0a2f1
SB		 2701 o = my_kid(o, attrs, &rops);
2702 if (rops) {
2703 if (maybe_scalar && o->op_type == OP_PADSV) {
2fcb4757 2704 o = scalar(op_append_list(OP_LIST, rops, o));
95f0a2f1
SB		 2705 o->op_private |= OPpLVAL_INTRO;
2706 }
f5d1ed10
FC		 2707 else {
2708 /* The listop in rops might have a pushmark at the beginning,
2709 which will mess up list assignment. */
2710 LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
2711 if (rops->op_type == OP_LIST &&
2712 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
2713 {
2714 OP * const pushmark = lrops->op_first;
2715 lrops->op_first = pushmark->op_sibling;
2716 op_free(pushmark);
2717 }
2fcb4757 2718 o = op_append_list(OP_LIST, o, rops);
f5d1ed10 2719 }
95f0a2f1 2720 }
12bd6ede
DM		 2721 PL_parser->in_my = FALSE;
2722 PL_parser->in_my_stash = NULL;
eb64745e 2723 return o;
09bef843
SB		 2724}
2725
2726OP *
864dbfa3 2727Perl_sawparens(pTHX_ OP *o)
79072805 2728{
96a5add6 2729 PERL_UNUSED_CONTEXT;
79072805
LW		 2730 if (o)
2731 o->op_flags |= OPf_PARENS;
2732 return o;
2733}
2734
2735OP *
864dbfa3 2736Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
79072805 2737{
11343788 2738 OP *o;
59f00321 2739 bool ismatchop = 0;
1496a290
AL		 2740 const OPCODE ltype = left->op_type;
2741 const OPCODE rtype = right->op_type;
79072805 2742
7918f24d
NC		 2743 PERL_ARGS_ASSERT_BIND_MATCH;
2744
1496a290
AL		 2745 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2746 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
041457d9 2747 {
1496a290 2748 const char * const desc
bb16bae8
FC		 2749 = PL_op_desc[(
2750 rtype == OP_SUBST || rtype == OP_TRANS
2751 || rtype == OP_TRANSR
2752 )
666ea192 2753 ? (int)rtype : OP_MATCH];
c6771ab6
FC		 2754 const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
2755 GV *gv;
2756 SV * const name =
2757 (ltype == OP_RV2AV || ltype == OP_RV2HV)
2758 ? cUNOPx(left)->op_first->op_type == OP_GV
2759 && (gv = cGVOPx_gv(cUNOPx(left)->op_first))
2760 ? varname(gv, isary ? '@' : '%', 0, NULL, 0, 1)
2761 : NULL
ba510004
FC		 2762 : varname(
2763 (GV *)PL_compcv, isary ? '@' : '%', left->op_targ, NULL, 0, 1
2764 );
c6771ab6
FC		 2765 if (name)
2766 Perl_warner(aTHX_ packWARN(WARN_MISC),
2767 "Applying %s to %"SVf" will act on scalar(%"SVf")",
2768 desc, name, name);
2769 else {
2770 const char * const sample = (isary
666ea192 2771 ? "@array" : "%hash");
c6771ab6 2772 Perl_warner(aTHX_ packWARN(WARN_MISC),
1c846c1f 2773 "Applying %s to %s will act on scalar(%s)",
599cee73 2774 desc, sample, sample);
c6771ab6 2775 }
2ae324a7 2776 }
2777
1496a290 2778 if (rtype == OP_CONST &&
5cc9e5c9
RH		 2779 cSVOPx(right)->op_private & OPpCONST_BARE &&
2780 cSVOPx(right)->op_private & OPpCONST_STRICT)
2781 {
2782 no_bareword_allowed(right);
2783 }
2784
bb16bae8 2785 /* !~ doesn't make sense with /r, so error on it for now */
4f4d7508
DC		 2786 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
2787 type == OP_NOT)
2788 yyerror("Using !~ with s///r doesn't make sense");
bb16bae8
FC		 2789 if (rtype == OP_TRANSR && type == OP_NOT)
2790 yyerror("Using !~ with tr///r doesn't make sense");
4f4d7508 2791
2474a784
FC		 2792 ismatchop = (rtype == OP_MATCH ||
2793 rtype == OP_SUBST ||
bb16bae8 2794 rtype == OP_TRANS || rtype == OP_TRANSR)
2474a784 2795 && !(right->op_flags & OPf_SPECIAL);
59f00321
RGS		 2796 if (ismatchop && right->op_private & OPpTARGET_MY) {
2797 right->op_targ = 0;
2798 right->op_private &= ~OPpTARGET_MY;
2799 }
2800 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1496a290
AL		 2801 OP *newleft;
2802
79072805 2803 right->op_flags |= OPf_STACKED;
bb16bae8 2804 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
1496a290 2805 ! (rtype == OP_TRANS &&
4f4d7508
DC		 2806 right->op_private & OPpTRANS_IDENTICAL) &&
2807 ! (rtype == OP_SUBST &&
2808 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
3ad73efd 2809 newleft = op_lvalue(left, rtype);
1496a290
AL		 2810 else
2811 newleft = left;
bb16bae8 2812 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
1496a290 2813 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
79072805 2814 else
2fcb4757 2815 o = op_prepend_elem(rtype, scalar(newleft), right);
79072805 2816 if (type == OP_NOT)
11343788
MB		 2817 return newUNOP(OP_NOT, 0, scalar(o));
2818 return o;
79072805
LW		 2819 }
2820 else
2821 return bind_match(type, left,
d63c20f2 2822 pmruntime(newPMOP(OP_MATCH, 0), right, 0, 0));
79072805
LW		 2823}
2824
2825OP *
864dbfa3 2826Perl_invert(pTHX_ OP *o)
79072805 2827{
11343788 2828 if (!o)
1d866c12 2829 return NULL;
11343788 2830 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
79072805
LW		 2831}
2832
3ad73efd
Z		 2833/*
2834=for apidoc Amx|OP *|op_scope|OP *o
2835
2836Wraps up an op tree with some additional ops so that at runtime a dynamic
2837scope will be created. The original ops run in the new dynamic scope,
2838and then, provided that they exit normally, the scope will be unwound.
2839The additional ops used to create and unwind the dynamic scope will
2840normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
2841instead if the ops are simple enough to not need the full dynamic scope
2842structure.
2843
2844=cut
2845*/
2846
79072805 2847OP *
3ad73efd 2848Perl_op_scope(pTHX_ OP *o)
79072805 2849{
27da23d5 2850 dVAR;
79072805 2851 if (o) {
284167a5 2852 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
2fcb4757 2853 o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
463ee0b2 2854 o->op_type = OP_LEAVE;
22c35a8c 2855 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
463ee0b2 2856 }
fdb22418
HS		 2857 else if (o->op_type == OP_LINESEQ) {
2858 OP *kid;
2859 o->op_type = OP_SCOPE;
2860 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2861 kid = ((LISTOP*)o)->op_first;
59110972 2862 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
fdb22418 2863 op_null(kid);
59110972
RH		 2864
2865 /* The following deals with things like 'do {1 for 1}' */
2866 kid = kid->op_sibling;
2867 if (kid &&
2868 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2869 op_null(kid);
2870 }
463ee0b2 2871 }
fdb22418 2872 else
5f66b61c 2873 o = newLISTOP(OP_SCOPE, 0, o, NULL);
79072805
LW		 2874 }
2875 return o;
2876}
1930840b 2877
705fe0e5
FC		 2878OP *
2879Perl_op_unscope(pTHX_ OP *o)
2880{
2881 if (o && o->op_type == OP_LINESEQ) {
2882 OP *kid = cLISTOPo->op_first;
2883 for(; kid; kid = kid->op_sibling)
2884 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
2885 op_null(kid);
2886 }
2887 return o;
2888}
2889
a0d0e21e 2890int
864dbfa3 2891Perl_block_start(pTHX_ int full)
79072805 2892{
97aff369 2893 dVAR;
73d840c0 2894 const int retval = PL_savestack_ix;
1930840b 2895
dd2155a4 2896 pad_block_start(full);
b3ac6de7 2897 SAVEHINTS();
3280af22 2898 PL_hints &= ~HINT_BLOCK_SCOPE;
68da3b2f 2899 SAVECOMPILEWARNINGS();
72dc9ed5 2900 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
1930840b 2901
a88d97bf 2902 CALL_BLOCK_HOOKS(bhk_start, full);
1930840b 2903
a0d0e21e
LW		 2904 return retval;
2905}
2906
2907OP*
864dbfa3 2908Perl_block_end(pTHX_ I32 floor, OP *seq)
a0d0e21e 2909{
97aff369 2910 dVAR;
6867be6d 2911 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1930840b 2912 OP* retval = scalarseq(seq);
6d5c2147 2913 OP *o;
1930840b 2914
a88d97bf 2915 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
1930840b 2916
e9818f4e 2917 LEAVE_SCOPE(floor);
623e6609 2918 CopHINTS_set(&PL_compiling, PL_hints);
a0d0e21e 2919 if (needblockscope)
3280af22 2920 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
6d5c2147
FC		 2921 o = pad_leavemy();
2922
2923 if (o) {
2924 /* pad_leavemy has created a sequence of introcv ops for all my
2925 subs declared in the block. We have to replicate that list with
2926 clonecv ops, to deal with this situation:
2927
2928 sub {
2929 my sub s1;
2930 my sub s2;
2931 sub s1 { state sub foo { \&s2 } }
2932 }->()
2933
2934 Originally, I was going to have introcv clone the CV and turn
2935 off the stale flag. Since &s1 is declared before &s2, the
2936 introcv op for &s1 is executed (on sub entry) before the one for
2937 &s2. But the &foo sub inside &s1 (which is cloned when &s1 is
2938 cloned, since it is a state sub) closes over &s2 and expects
2939 to see it in its outer CV’s pad. If the introcv op clones &s1,
2940 then &s2 is still marked stale. Since &s1 is not active, and
2941 &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
2942 ble will not stay shared’ warning. Because it is the same stub
2943 that will be used when the introcv op for &s2 is executed, clos-
2944 ing over it is safe. Hence, we have to turn off the stale flag
2945 on all lexical subs in the block before we clone any of them.
2946 Hence, having introcv clone the sub cannot work. So we create a
2947 list of ops like this:
2948
2949 lineseq
2950 |
2951 +-- introcv
2952 |
2953 +-- introcv
2954 |
2955 +-- introcv
2956 |
2957 .
2958 .
2959 .
2960 |
2961 +-- clonecv
2962 |
2963 +-- clonecv
2964 |
2965 +-- clonecv
2966 |
2967 .
2968 .
2969 .
2970 */
2971 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
2972 OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
2973 for (;; kid = kid->op_sibling) {
2974 OP *newkid = newOP(OP_CLONECV, 0);
2975 newkid->op_targ = kid->op_targ;
2976 o = op_append_elem(OP_LINESEQ, o, newkid);
2977 if (kid == last) break;
2978 }
2979 retval = op_prepend_elem(OP_LINESEQ, o, retval);
2980 }
1930840b 2981
a88d97bf 2982 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
1930840b 2983
a0d0e21e
LW		 2984 return retval;
2985}
2986
fd85fad2
BM		 2987/*
2988=head1 Compile-time scope hooks
2989
3e4ddde5 2990=for apidoc Aox||blockhook_register
fd85fad2
BM		 2991
2992Register a set of hooks to be called when the Perl lexical scope changes
2993at compile time. See L<perlguts/"Compile-time scope hooks">.
2994
2995=cut
2996*/
2997
bb6c22e7
BM		 2998void
2999Perl_blockhook_register(pTHX_ BHK *hk)
3000{
3001 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
3002
3003 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
3004}
3005
76e3520e 3006STATIC OP *
cea2e8a9 3007S_newDEFSVOP(pTHX)
54b9620d 3008{
97aff369 3009 dVAR;
cc76b5cc 3010 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
00b1698f 3011 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
59f00321
RGS		 3012 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
3013 }
3014 else {
551405c4 3015 OP * const o = newOP(OP_PADSV, 0);
59f00321
RGS		 3016 o->op_targ = offset;
3017 return o;
3018 }
54b9620d
MB		 3019}
3020
a0d0e21e 3021void
864dbfa3 3022Perl_newPROG(pTHX_ OP *o)
a0d0e21e 3023{
97aff369 3024 dVAR;
7918f24d
NC		 3025
3026 PERL_ARGS_ASSERT_NEWPROG;
3027
3280af22 3028 if (PL_in_eval) {
86a64801 3029 PERL_CONTEXT *cx;
63429d50 3030 I32 i;
b295d113
TH		 3031 if (PL_eval_root)
3032 return;
faef0170
HS		 3033 PL_eval_root = newUNOP(OP_LEAVEEVAL,
3034 ((PL_in_eval & EVAL_KEEPERR)
3035 ? OPf_SPECIAL : 0), o);
86a64801
GG		 3036
3037 cx = &cxstack[cxstack_ix];
3038 assert(CxTYPE(cx) == CXt_EVAL);
3039
3040 if ((cx->blk_gimme & G_WANT) == G_VOID)
3041 scalarvoid(PL_eval_root);
3042 else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
3043 list(PL_eval_root);
3044 else
3045 scalar(PL_eval_root);
3046
5983a79d 3047 PL_eval_start = op_linklist(PL_eval_root);
7934575e
GS		 3048 PL_eval_root->op_private |= OPpREFCOUNTED;
3049 OpREFCNT_set(PL_eval_root, 1);
3280af22 3050 PL_eval_root->op_next = 0;
63429d50
FC		 3051 i = PL_savestack_ix;
3052 SAVEFREEOP(o);
3053 ENTER;
a2efc822 3054 CALL_PEEP(PL_eval_start);
86a64801 3055 finalize_optree(PL_eval_root);
63429d50
FC		 3056 LEAVE;
3057 PL_savestack_ix = i;
a0d0e21e
LW		 3058 }
3059 else {
6be89cf9 3060 if (o->op_type == OP_STUB) {
22e660b4
NC		 3061 /* This block is entered if nothing is compiled for the main
3062 program. This will be the case for an genuinely empty main
3063 program, or one which only has BEGIN blocks etc, so already
3064 run and freed.
3065
3066 Historically (5.000) the guard above was !o. However, commit
3067 f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
3068 c71fccf11fde0068, changed perly.y so that newPROG() is now
3069 called with the output of block_end(), which returns a new
3070 OP_STUB for the case of an empty optree. ByteLoader (and
3071 maybe other things) also take this path, because they set up
3072 PL_main_start and PL_main_root directly, without generating an
3073 optree.
8b31d4e4
NC		 3074
3075 If the parsing the main program aborts (due to parse errors,
3076 or due to BEGIN or similar calling exit), then newPROG()
3077 isn't even called, and hence this code path and its cleanups
3078 are skipped. This shouldn't make a make a difference:
3079 * a non-zero return from perl_parse is a failure, and
3080 perl_destruct() should be called immediately.
3081 * however, if exit(0) is called during the parse, then
3082 perl_parse() returns 0, and perl_run() is called. As
3083 PL_main_start will be NULL, perl_run() will return
3084 promptly, and the exit code will remain 0.
22e660b4
NC		 3085 */
3086
6be89cf9
AE		 3087 PL_comppad_name = 0;
3088 PL_compcv = 0;
d2c837a0 3089 S_op_destroy(aTHX_ o);
a0d0e21e 3090 return;
6be89cf9 3091 }
3ad73efd 3092 PL_main_root = op_scope(sawparens(scalarvoid(o)));
3280af22
NIS		 3093 PL_curcop = &PL_compiling;
3094 PL_main_start = LINKLIST(PL_main_root);
7934575e
GS		 3095 PL_main_root->op_private |= OPpREFCOUNTED;
3096 OpREFCNT_set(PL_main_root, 1);
3280af22 3097 PL_main_root->op_next = 0;
a2efc822 3098 CALL_PEEP(PL_main_start);
d164302a 3099 finalize_optree(PL_main_root);
8be227ab 3100 cv_forget_slab(PL_compcv);
3280af22 3101 PL_compcv = 0;
3841441e 3102
4fdae800 3103 /* Register with debugger */
84902520 3104 if (PERLDB_INTER) {
b96d8cd9 3105 CV * const cv = get_cvs("DB::postponed", 0);
3841441e
CS		 3106 if (cv) {
3107 dSP;
924508f0 3108 PUSHMARK(SP);
ad64d0ec 3109 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3841441e 3110 PUTBACK;
ad64d0ec 3111 call_sv(MUTABLE_SV(cv), G_DISCARD);
3841441e
CS		 3112 }
3113 }
79072805 3114 }
79072805
LW		 3115}
3116
3117OP *
864dbfa3 3118Perl_localize(pTHX_ OP *o, I32 lex)
79072805 3119{
97aff369 3120 dVAR;
7918f24d
NC		 3121
3122 PERL_ARGS_ASSERT_LOCALIZE;
3123
79072805 3124 if (o->op_flags & OPf_PARENS)
d2be0de5
YST		 3125/* [perl #17376]: this appears to be premature, and results in code such as
3126 C< our(%x); > executing in list mode rather than void mode */
3127#if 0
79072805 3128 list(o);
d2be0de5 3129#else
6f207bd3 3130 NOOP;
d2be0de5 3131#endif
8990e307 3132 else {
f06b5848
DM		 3133 if ( PL_parser->bufptr > PL_parser->oldbufptr
3134 && PL_parser->bufptr[-1] == ','
041457d9 3135 && ckWARN(WARN_PARENTHESIS))
64420d0d 3136 {
f06b5848 3137 char *s = PL_parser->bufptr;
bac662ee 3138 bool sigil = FALSE;
64420d0d 3139
8473848f 3140 /* some heuristics to detect a potential error */
bac662ee 3141 while (*s && (strchr(", \t\n", *s)))
64420d0d 3142 s++;
8473848f 3143
bac662ee
TS		 3144 while (1) {
3145 if (*s && strchr("@$%*", *s) && *++s
0eb30aeb 3146 && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
bac662ee
TS		 3147 s++;
3148 sigil = TRUE;
0eb30aeb 3149 while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
bac662ee
TS		 3150 s++;
3151 while (*s && (strchr(", \t\n", *s)))
3152 s++;
3153 }
3154 else
3155 break;
3156 }
3157 if (sigil && (*s == ';' || *s == '=')) {
3158 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
8473848f 3159 "Parentheses missing around \"%s\" list",
12bd6ede
DM		 3160 lex
3161 ? (PL_parser->in_my == KEY_our
3162 ? "our"
3163 : PL_parser->in_my == KEY_state
3164 ? "state"
3165 : "my")
3166 : "local");
8473848f 3167 }
8990e307
LW		 3168 }
3169 }
93a17b20 3170 if (lex)
eb64745e 3171 o = my(o);
93a17b20 3172 else
3ad73efd 3173 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
12bd6ede
DM		 3174 PL_parser->in_my = FALSE;
3175 PL_parser->in_my_stash = NULL;
eb64745e 3176 return o;
79072805
LW		 3177}
3178
3179OP *
864dbfa3 3180Perl_jmaybe(pTHX_ OP *o)
79072805 3181{
7918f24d
NC		 3182 PERL_ARGS_ASSERT_JMAYBE;
3183
79072805 3184 if (o->op_type == OP_LIST) {
fafc274c 3185 OP * const o2
d4c19fe8 3186 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2fcb4757 3187 o = convert(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
79072805
LW		 3188 }
3189 return o;
3190}
3191
985b9e54
GG		 3192PERL_STATIC_INLINE OP *
3193S_op_std_init(pTHX_ OP *o)
3194{
3195 I32 type = o->op_type;
3196
3197 PERL_ARGS_ASSERT_OP_STD_INIT;
3198
3199 if (PL_opargs[type] & OA_RETSCALAR)
3200 scalar(o);
3201 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
3202 o->op_targ = pad_alloc(type, SVs_PADTMP);
3203
3204 return o;
3205}
3206
3207PERL_STATIC_INLINE OP *
3208S_op_integerize(pTHX_ OP *o)
3209{
3210 I32 type = o->op_type;
3211
3212 PERL_ARGS_ASSERT_OP_INTEGERIZE;
3213
077da62f
FC		 3214 /* integerize op. */
3215 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
985b9e54 3216 {
f5f19483 3217 dVAR;
985b9e54
GG		 3218 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
3219 }
3220
3221 if (type == OP_NEGATE)
3222 /* XXX might want a ck_negate() for this */
3223 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
3224
3225 return o;
3226}
3227
1f676739 3228static OP *
5aaab254 3229S_fold_constants(pTHX_ OP *o)
79072805 3230{
27da23d5 3231 dVAR;
eb578fdb 3232 OP * VOL curop;
eb8433b7 3233 OP *newop;
8ea43dc8 3234 VOL I32 type = o->op_type;
e3cbe32f 3235 SV * VOL sv = NULL;
b7f7fd0b
NC		 3236 int ret = 0;
3237 I32 oldscope;
3238 OP *old_next;
5f2d9966
DM		 3239 SV * const oldwarnhook = PL_warnhook;
3240 SV * const olddiehook = PL_diehook;
c427f4d2 3241 COP not_compiling;
b7f7fd0b 3242 dJMPENV;
79072805 3243
7918f24d
NC		 3244 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
3245
22c35a8c 3246 if (!(PL_opargs[type] & OA_FOLDCONST))
79072805
LW		 3247 goto nope;
3248
de939608 3249 switch (type) {
de939608
CS		 3250 case OP_UCFIRST:
3251 case OP_LCFIRST:
3252 case OP_UC:
3253 case OP_LC:
7ccde120 3254 case OP_FC:
69dcf70c
MB		 3255 case OP_SLT:
3256 case OP_SGT:
3257 case OP_SLE:
3258 case OP_SGE:
3259 case OP_SCMP:
b3fd6149 3260 case OP_SPRINTF:
2de3dbcc 3261 /* XXX what about the numeric ops? */
82ad65bb 3262 if (IN_LOCALE_COMPILETIME)
de939608 3263 goto nope;
553e7bb0 3264 break;
dd9a6ccf
FC		 3265 case OP_PACK:
3266 if (!cLISTOPo->op_first->op_sibling
3267 || cLISTOPo->op_first->op_sibling->op_type != OP_CONST)
3268 goto nope;
3269 {
3270 SV * const sv = cSVOPx_sv(cLISTOPo->op_first->op_sibling);
3271 if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
3272 {
3273 const char *s = SvPVX_const(sv);
3274 while (s < SvEND(sv)) {
3275 if (*s == 'p' || *s == 'P') goto nope;
3276 s++;
3277 }
3278 }
3279 }
3280 break;
baed7faa
FC		 3281 case OP_REPEAT:
3282 if (o->op_private & OPpREPEAT_DOLIST) goto nope;
de939608
CS		 3283 }
3284
13765c85 3285 if (PL_parser && PL_parser->error_count)
a0d0e21e
LW		 3286 goto nope; /* Don't try to run w/ errors */
3287
79072805 3288 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
1496a290
AL		 3289 const OPCODE type = curop->op_type;
3290 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
3291 type != OP_LIST &&
3292 type != OP_SCALAR &&
3293 type != OP_NULL &&
3294 type != OP_PUSHMARK)
7a52d87a 3295 {
79072805
LW		 3296 goto nope;
3297 }
3298 }
3299
3300 curop = LINKLIST(o);
b7f7fd0b 3301 old_next = o->op_next;
79072805 3302 o->op_next = 0;
533c011a 3303 PL_op = curop;
b7f7fd0b
NC		 3304
3305 oldscope = PL_scopestack_ix;
edb2152a 3306 create_eval_scope(G_FAKINGEVAL);
b7f7fd0b 3307
c427f4d2
NC		 3308 /* Verify that we don't need to save it: */
3309 assert(PL_curcop == &PL_compiling);
3310 StructCopy(&PL_compiling, &not_compiling, COP);
3311 PL_curcop = &not_compiling;
3312 /* The above ensures that we run with all the correct hints of the
3313 currently compiling COP, but that IN_PERL_RUNTIME is not true. */
3314 assert(IN_PERL_RUNTIME);
5f2d9966
DM		 3315 PL_warnhook = PERL_WARNHOOK_FATAL;
3316 PL_diehook = NULL;
b7f7fd0b
NC		 3317 JMPENV_PUSH(ret);
3318
3319 switch (ret) {
3320 case 0:
3321 CALLRUNOPS(aTHX);
3322 sv = *(PL_stack_sp--);
523a0f0c
NC		 3323 if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
3324#ifdef PERL_MAD
3325 /* Can't simply swipe the SV from the pad, because that relies on
3326 the op being freed "real soon now". Under MAD, this doesn't
3327 happen (see the #ifdef below). */
3328 sv = newSVsv(sv);
3329#else
b7f7fd0b 3330 pad_swipe(o->op_targ, FALSE);
523a0f0c
NC		 3331#endif
3332 }
b7f7fd0b
NC		 3333 else if (SvTEMP(sv)) { /* grab mortal temp? */
3334 SvREFCNT_inc_simple_void(sv);
3335 SvTEMP_off(sv);
3336 }
ba610af8 3337 else { assert(SvIMMORTAL(sv)); }
b7f7fd0b
NC		 3338 break;
3339 case 3:
3340 /* Something tried to die. Abandon constant folding. */
3341 /* Pretend the error never happened. */
ab69dbc2 3342 CLEAR_ERRSV();
b7f7fd0b
NC		 3343 o->op_next = old_next;
3344 break;
3345 default:
3346 JMPENV_POP;
5f2d9966
DM		 3347 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
3348 PL_warnhook = oldwarnhook;
3349 PL_diehook = olddiehook;
3350 /* XXX note that this croak may fail as we've already blown away
3351 * the stack - eg any nested evals */
b7f7fd0b
NC		 3352 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
3353 }
b7f7fd0b 3354 JMPENV_POP;
5f2d9966
DM		 3355 PL_warnhook = oldwarnhook;
3356 PL_diehook = olddiehook;
c427f4d2 3357 PL_curcop = &PL_compiling;
edb2152a
NC		 3358
3359 if (PL_scopestack_ix > oldscope)
3360 delete_eval_scope();
eb8433b7 3361
b7f7fd0b
NC		 3362 if (ret)
3363 goto nope;
3364
eb8433b7 3365#ifndef PERL_MAD
79072805 3366 op_free(o);
eb8433b7 3367#endif
de5e01c2 3368 assert(sv);
07a05c08
FC		 3369 if (type == OP_STRINGIFY) SvPADTMP_off(sv);
3370 else if (!SvIMMORTAL(sv)) SvPADTMP_on(sv);
79072805 3371 if (type == OP_RV2GV)
159b6efe 3372 newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
eb8433b7 3373 else
3513c740 3374 {
cc2ebcd7 3375 newop = newSVOP(OP_CONST, OPpCONST_FOLDED<<8, MUTABLE_SV(sv));
3513c740
NT		 3376 newop->op_folded = 1;
3377 }
eb8433b7
NC		 3378 op_getmad(o,newop,'f');
3379 return newop;
aeea060c 3380
b7f7fd0b 3381 nope:
79072805
LW		 3382 return o;
3383}
3384
1f676739 3385static OP *
5aaab254 3386S_gen_constant_list(pTHX_ OP *o)
79072805 3387{
27da23d5 3388 dVAR;
eb578fdb 3389 OP *curop;
6867be6d 3390 const I32 oldtmps_floor = PL_tmps_floor;
5608dcc6
FC		 3391 SV **svp;
3392 AV *av;
79072805 3393
a0d0e21e 3394 list(o);
13765c85 3395 if (PL_parser && PL_parser->error_count)
a0d0e21e
LW		 3396 return o; /* Don't attempt to run with errors */
3397
533c011a 3398 PL_op = curop = LINKLIST(o);
a0d0e21e 3399 o->op_next = 0;
a2efc822 3400 CALL_PEEP(curop);
897d3989 3401 Perl_pp_pushmark(aTHX);
cea2e8a9 3402 CALLRUNOPS(aTHX);
533c011a 3403 PL_op = curop;
78c72037
NC		 3404 assert (!(curop->op_flags & OPf_SPECIAL));
3405 assert(curop->op_type == OP_RANGE);
897d3989 3406 Perl_pp_anonlist(aTHX);
3280af22 3407 PL_tmps_floor = oldtmps_floor;
79072805
LW		 3408
3409 o->op_type = OP_RV2AV;
22c35a8c 3410 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
fb53bbb2
SG		 3411 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
3412 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
1a0a2ba9 3413 o->op_opt = 0; /* needs to be revisited in rpeep() */
79072805 3414 curop = ((UNOP*)o)->op_first;
5608dcc6
FC		 3415 av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
3416 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, (SV *)av);
3417 if (AvFILLp(av) != -1)
3418 for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
3419 SvPADTMP_on(*svp);
eb8433b7
NC		 3420#ifdef PERL_MAD
3421 op_getmad(curop,o,'O');
3422#else
79072805 3423 op_free(curop);
eb8433b7 3424#endif
5983a79d 3425 LINKLIST(o);
79072805
LW		 3426 return list(o);
3427}
3428
3429OP *
864dbfa3 3430Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
79072805 3431{
27da23d5 3432 dVAR;
d67594ff 3433 if (type < 0) type = -type, flags |= OPf_SPECIAL;
11343788 3434 if (!o || o->op_type != OP_LIST)
5f66b61c 3435 o = newLISTOP(OP_LIST, 0, o, NULL);
748a9306 3436 else
5dc0d613 3437 o->op_flags &= ~OPf_WANT;
79072805 3438
22c35a8c 3439 if (!(PL_opargs[type] & OA_MARK))
93c66552 3440 op_null(cLISTOPo->op_first);
bf0571fd
FC		 3441 else {
3442 OP * const kid2 = cLISTOPo->op_first->op_sibling;
3443 if (kid2 && kid2->op_type == OP_COREARGS) {
3444 op_null(cLISTOPo->op_first);
3445 kid2->op_private |= OPpCOREARGS_PUSHMARK;
3446 }
3447 }
8990e307 3448
eb160463 3449 o->op_type = (OPCODE)type;
22c35a8c 3450 o->op_ppaddr = PL_ppaddr[type];
11343788 3451 o->op_flags |= flags;
79072805 3452
11343788 3453 o = CHECKOP(type, o);
fe2774ed 3454 if (o->op_type != (unsigned)type)
11343788 3455 return o;
79072805 3456
985b9e54 3457 return fold_constants(op_integerize(op_std_init(o)));
79072805
LW		 3458}
3459
2fcb4757
Z		 3460/*
3461=head1 Optree Manipulation Functions
3462*/
3463
79072805
LW		 3464/* List constructors */
3465
2fcb4757
Z		 3466/*
3467=for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
3468
3469Append an item to the list of ops contained directly within a list-type
3470op, returning the lengthened list. I<first> is the list-type op,
3471and I<last> is the op to append to the list. I<optype> specifies the
3472intended opcode for the list. If I<first> is not already a list of the
3473right type, it will be upgraded into one. If either I<first> or I<last>
3474is null, the other is returned unchanged.
3475
3476=cut
3477*/
3478
79072805 3479OP *
2fcb4757 3480Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW		 3481{
3482 if (!first)
3483 return last;
8990e307
LW		 3484
3485 if (!last)
79072805 3486 return first;
8990e307 3487
fe2774ed 3488 if (first->op_type != (unsigned)type
155aba94
GS		 3489 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
3490 {
3491 return newLISTOP(type, 0, first, last);
3492 }
79072805 3493
a0d0e21e
LW		 3494 if (first->op_flags & OPf_KIDS)
3495 ((LISTOP*)first)->op_last->op_sibling = last;
3496 else {
3497 first->op_flags |= OPf_KIDS;
3498 ((LISTOP*)first)->op_first = last;
3499 }
3500 ((LISTOP*)first)->op_last = last;
a0d0e21e 3501 return first;
79072805
LW		 3502}
3503
2fcb4757
Z		 3504/*
3505=for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
3506
3507Concatenate the lists of ops contained directly within two list-type ops,
3508returning the combined list. I<first> and I<last> are the list-type ops
3509to concatenate. I<optype> specifies the intended opcode for the list.
3510If either I<first> or I<last> is not already a list of the right type,
3511it will be upgraded into one. If either I<first> or I<last> is null,
3512the other is returned unchanged.
3513
3514=cut
3515*/
3516
79072805 3517OP *
2fcb4757 3518Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
79072805
LW		 3519{
3520 if (!first)
2fcb4757 3521 return last;
8990e307
LW		 3522
3523 if (!last)
2fcb4757 3524 return first;
8990e307 3525
fe2774ed 3526 if (first->op_type != (unsigned)type)
2fcb4757 3527 return op_prepend_elem(type, first, last);
8990e307 3528
fe2774ed 3529 if (last->op_type != (unsigned)type)
2fcb4757 3530 return op_append_elem(type, first, last);
79072805 3531
2fcb4757
Z		 3532 ((LISTOP*)first)->op_last->op_sibling = ((LISTOP*)last)->op_first;
3533 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
117dada2 3534 first->op_flags |= (last->op_flags & OPf_KIDS);
1c846c1f 3535
eb8433b7 3536#ifdef PERL_MAD
2fcb4757
Z		 3537 if (((LISTOP*)last)->op_first && first->op_madprop) {
3538 MADPROP *mp = ((LISTOP*)last)->op_first->op_madprop;
eb8433b7
NC		 3539 if (mp) {
3540 while (mp->mad_next)
3541 mp = mp->mad_next;
3542 mp->mad_next = first->op_madprop;
3543 }
3544 else {
2fcb4757 3545 ((LISTOP*)last)->op_first->op_madprop = first->op_madprop;
eb8433b7
NC		 3546 }
3547 }
3548 first->op_madprop = last->op_madprop;
3549 last->op_madprop = 0;
3550#endif
3551
2fcb4757 3552 S_op_destroy(aTHX_ last);
238a4c30 3553
2fcb4757 3554 return first;
79072805
LW		 3555}
3556
2fcb4757
Z		 3557/*
3558=for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
3559
3560Prepend an item to the list of ops contained directly within a list-type
3561op, returning the lengthened list. I<first> is the op to prepend to the
3562list, and I<last> is the list-type op. I<optype> specifies the intended
3563opcode for the list. If I<last> is not already a list of the right type,
3564it will be upgraded into one. If either I<first> or I<last> is null,
3565the other is returned unchanged.
3566
3567=cut
3568*/
3569
79072805 3570OP *
2fcb4757 3571Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW		 3572{
3573 if (!first)
3574 return last;
8990e307
LW		 3575
3576 if (!last)
79072805 3577 return first;
8990e307 3578
fe2774ed 3579 if (last->op_type == (unsigned)type) {
8990e307
LW		 3580 if (type == OP_LIST) { /* already a PUSHMARK there */
3581 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
3582 ((LISTOP*)last)->op_first->op_sibling = first;
36a5d4ba
DC		 3583 if (!(first->op_flags & OPf_PARENS))
3584 last->op_flags &= ~OPf_PARENS;
8990e307
LW		 3585 }
3586 else {
3587 if (!(last->op_flags & OPf_KIDS)) {
3588 ((LISTOP*)last)->op_last = first;
3589 last->op_flags |= OPf_KIDS;
3590 }
3591 first->op_sibling = ((LISTOP*)last)->op_first;
3592 ((LISTOP*)last)->op_first = first;
79072805 3593 }
117dada2 3594 last->op_flags |= OPf_KIDS;
79072805
LW		 3595 return last;
3596 }
3597
3598 return newLISTOP(type, 0, first, last);
3599}
3600
3601/* Constructors */
3602
eb8433b7
NC		 3603#ifdef PERL_MAD
3604
3605TOKEN *
3606Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
3607{
3608 TOKEN *tk;
99129197 3609 Newxz(tk, 1, TOKEN);
eb8433b7
NC		 3610 tk->tk_type = (OPCODE)optype;
3611 tk->tk_type = 12345;
3612 tk->tk_lval = lval;
3613 tk->tk_mad = madprop;
3614 return tk;
3615}
3616
3617void
3618Perl_token_free(pTHX_ TOKEN* tk)
3619{
7918f24d
NC		 3620 PERL_ARGS_ASSERT_TOKEN_FREE;
3621
eb8433b7
NC		 3622 if (tk->tk_type != 12345)
3623 return;
3624 mad_free(tk->tk_mad);
3625 Safefree(tk);
3626}
3627
3628void
3629Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
3630{
3631 MADPROP* mp;
3632 MADPROP* tm;
7918f24d
NC		 3633
3634 PERL_ARGS_ASSERT_TOKEN_GETMAD;
3635
eb8433b7
NC		 3636 if (tk->tk_type != 12345) {
3637 Perl_warner(aTHX_ packWARN(WARN_MISC),
3638 "Invalid TOKEN object ignored");
3639 return;
3640 }
3641 tm = tk->tk_mad;
3642 if (!tm)
3643 return;
3644
3645 /* faked up qw list? */
3646 if (slot == '(' &&
3647 tm->mad_type == MAD_SV &&
d503a9ba 3648 SvPVX((SV *)tm->mad_val)[0] == 'q')
eb8433b7
NC		 3649 slot = 'x';
3650
3651 if (o) {
3652 mp = o->op_madprop;
3653 if (mp) {
3654 for (;;) {
3655 /* pretend constant fold didn't happen? */
3656 if (mp->mad_key == 'f' &&
3657 (o->op_type == OP_CONST ||
3658 o->op_type == OP_GV) )
3659 {
3660 token_getmad(tk,(OP*)mp->mad_val,slot);
3661 return;
3662 }
3663 if (!mp->mad_next)
3664 break;
3665 mp = mp->mad_next;
3666 }
3667 mp->mad_next = tm;
3668 mp = mp->mad_next;
3669 }
3670 else {
3671 o->op_madprop = tm;
3672 mp = o->op_madprop;
3673 }
3674 if (mp->mad_key == 'X')
3675 mp->mad_key = slot; /* just change the first one */
3676
3677 tk->tk_mad = 0;
3678 }
3679 else
3680 mad_free(tm);
3681 Safefree(tk);
3682}
3683
3684void
3685Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
3686{
3687 MADPROP* mp;
3688 if (!from)
3689 return;
3690 if (o) {
3691 mp = o->op_madprop;
3692 if (mp) {
3693 for (;;) {
3694 /* pretend constant fold didn't happen? */
3695 if (mp->mad_key == 'f' &&
3696 (o->op_type == OP_CONST ||
3697 o->op_type == OP_GV) )
3698 {
3699 op_getmad(from,(OP*)mp->mad_val,slot);
3700 return;
3701 }
3702 if (!mp->mad_next)
3703 break;
3704 mp = mp->mad_next;
3705 }
3706 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
3707 }
3708 else {
3709 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
3710 }
3711 }
3712}
3713
3714void
3715Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
3716{
3717 MADPROP* mp;
3718 if (!from)
3719 return;
3720 if (o) {
3721 mp = o->op_madprop;
3722 if (mp) {
3723 for (;;) {
3724 /* pretend constant fold didn't happen? */
3725 if (mp->mad_key == 'f' &&
3726 (o->op_type == OP_CONST ||
3727 o->op_type == OP_GV) )
3728 {
3729 op_getmad(from,(OP*)mp->mad_val,slot);
3730 return;
3731 }
3732 if (!mp->mad_next)
3733 break;
3734 mp = mp->mad_next;
3735 }
3736 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
3737 }
3738 else {
3739 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
3740 }
3741 }
3742 else {
99129197
NC		 3743 PerlIO_printf(PerlIO_stderr(),
3744 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
eb8433b7
NC		 3745 op_free(from);
3746 }
3747}
3748
3749void
3750Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
3751{
3752 MADPROP* tm;
3753 if (!mp || !o)
3754 return;
3755 if (slot)
3756 mp->mad_key = slot;
3757 tm = o->op_madprop;
3758 o->op_madprop = mp;
3759 for (;;) {
3760 if (!mp->mad_next)
3761 break;
3762 mp = mp->mad_next;
3763 }
3764 mp->mad_next = tm;
3765}
3766
3767void
3768Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
3769{
3770 if (!o)
3771 return;
3772 addmad(tm, &(o->op_madprop), slot);
3773}
3774
3775void
3776Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
3777{
3778 MADPROP* mp;
3779 if (!tm || !root)
3780 return;
3781 if (slot)
3782 tm->mad_key = slot;
3783 mp = *root;
3784 if (!mp) {
3785 *root = tm;
3786 return;
3787 }
3788 for (;;) {
3789 if (!mp->mad_next)
3790 break;
3791 mp = mp->mad_next;
3792 }
3793 mp->mad_next = tm;
3794}
3795
3796MADPROP *
3797Perl_newMADsv(pTHX_ char key, SV* sv)
3798{
7918f24d
NC		 3799 PERL_ARGS_ASSERT_NEWMADSV;
3800
eb8433b7
NC		 3801 return newMADPROP(key, MAD_SV, sv, 0);
3802}
3803
3804MADPROP *
d503a9ba 3805Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
eb8433b7 3806{
c111d5f1 3807 MADPROP *const mp = (MADPROP *) PerlMemShared_malloc(sizeof(MADPROP));
eb8433b7
NC		 3808 mp->mad_next = 0;
3809 mp->mad_key = key;
3810 mp->mad_vlen = vlen;
3811 mp->mad_type = type;
3812 mp->mad_val = val;
3813/* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
3814 return mp;
3815}
3816
3817void
3818Perl_mad_free(pTHX_ MADPROP* mp)
3819{
3820/* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
3821 if (!mp)
3822 return;
3823 if (mp->mad_next)
3824 mad_free(mp->mad_next);
bc177e6b 3825/* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
eb8433b7
NC		 3826 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
3827 switch (mp->mad_type) {
3828 case MAD_NULL:
3829 break;
3830 case MAD_PV:
04d1a275 3831 Safefree(mp->mad_val);
eb8433b7
NC		 3832 break;
3833 case MAD_OP:
3834 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
3835 op_free((OP*)mp->mad_val);
3836 break;
3837 case MAD_SV:
ad64d0ec 3838 sv_free(MUTABLE_SV(mp->mad_val));
eb8433b7
NC		 3839 break;
3840 default:
3841 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
3842 break;
3843 }
c111d5f1 3844 PerlMemShared_free(mp);
eb8433b7
NC		 3845}
3846
3847#endif
3848
d67eb5f4
Z		 3849/*
3850=head1 Optree construction
3851
3852=for apidoc Am|OP *|newNULLLIST
3853
3854Constructs, checks, and returns a new C<stub> op, which represents an
3855empty list expression.
3856
3857=cut
3858*/
3859
79072805 3860OP *
864dbfa3 3861Perl_newNULLLIST(pTHX)
79072805 3862{
8990e307
LW		 3863 return newOP(OP_STUB, 0);
3864}
3865
1f676739 3866static OP *
b7783a12 3867S_force_list(pTHX_ OP *o)
8990e307 3868{
11343788 3869 if (!o || o->op_type != OP_LIST)
5f66b61c 3870 o = newLISTOP(OP_LIST, 0, o, NULL);
93c66552 3871 op_null(o);
11343788 3872 return o;
79072805
LW		 3873}
3874
d67eb5f4
Z		 3875/*
3876=for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
3877
3878Constructs, checks, and returns an op of any list type. I<type> is
3879the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3880C<OPf_KIDS> will be set automatically if required. I<first> and I<last>
3881supply up to two ops to be direct children of the list op; they are
3882consumed by this function and become part of the constructed op tree.
3883
3884=cut
3885*/
3886
79072805 3887OP *
864dbfa3 3888Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
79072805 3889{
27da23d5 3890 dVAR;
79072805
LW		 3891 LISTOP *listop;
3892
e69777c1
GG		 3893 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
3894
b7dc083c 3895 NewOp(1101, listop, 1, LISTOP);
79072805 3896
eb160463 3897 listop->op_type = (OPCODE)type;
22c35a8c 3898 listop->op_ppaddr = PL_ppaddr[type];
117dada2
SM		 3899 if (first || last)
3900 flags |= OPf_KIDS;
eb160463 3901 listop->op_flags = (U8)flags;
79072805
LW		 3902
3903 if (!last && first)
3904 last = first;
3905 else if (!first && last)
3906 first = last;
8990e307
LW		 3907 else if (first)
3908 first->op_sibling = last;
79072805
LW		 3909 listop->op_first = first;
3910 listop->op_last = last;
8990e307 3911 if (type == OP_LIST) {
551405c4 3912 OP* const pushop = newOP(OP_PUSHMARK, 0);
8990e307
LW		 3913 pushop->op_sibling = first;
3914 listop->op_first = pushop;
3915 listop->op_flags |= OPf_KIDS;
3916 if (!last)
3917 listop->op_last = pushop;
3918 }
79072805 3919
463d09e6 3920 return CHECKOP(type, listop);
79072805
LW		 3921}
3922
d67eb5f4
Z		 3923/*
3924=for apidoc Am|OP *|newOP|I32 type|I32 flags
3925
3926Constructs, checks, and returns an op of any base type (any type that
3927has no extra fields). I<type> is the opcode. I<flags> gives the
3928eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
3929of C<op_private>.
3930
3931=cut
3932*/
3933
79072805 3934OP *
864dbfa3 3935Perl_newOP(pTHX_ I32 type, I32 flags)
79072805 3936{
27da23d5 3937 dVAR;
11343788 3938 OP *o;
e69777c1 3939
7d789282
FC		 3940 if (type == -OP_ENTEREVAL) {
3941 type = OP_ENTEREVAL;
3942 flags |= OPpEVAL_BYTES<<8;
3943 }
3944
e69777c1
GG		 3945 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
3946 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3947 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3948 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
3949
b7dc083c 3950 NewOp(1101, o, 1, OP);
eb160463 3951 o->op_type = (OPCODE)type;
22c35a8c 3952 o->op_ppaddr = PL_ppaddr[type];
eb160463 3953 o->op_flags = (U8)flags;
79072805 3954
11343788 3955 o->op_next = o;
eb160463 3956 o->op_private = (U8)(0 | (flags >> 8));
22c35a8c 3957 if (PL_opargs[type] & OA_RETSCALAR)
11343788 3958 scalar(o);
22c35a8c 3959 if (PL_opargs[type] & OA_TARGET)
11343788
MB		 3960 o->op_targ = pad_alloc(type, SVs_PADTMP);
3961 return CHECKOP(type, o);
79072805
LW		 3962}
3963
d67eb5f4
Z		 3964/*
3965=for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
3966
3967Constructs, checks, and returns an op of any unary type. I<type> is
3968the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3969C<OPf_KIDS> will be set automatically if required, and, shifted up eight
3970bits, the eight bits of C<op_private>, except that the bit with value 1
3971is automatically set. I<first> supplies an optional op to be the direct
3972child of the unary op; it is consumed by this function and become part
3973of the constructed op tree.
3974
3975=cut
3976*/
3977
79072805 3978OP *
864dbfa3 3979Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
79072805 3980{
27da23d5 3981 dVAR;
79072805
LW		 3982 UNOP *unop;
3983
7d789282
FC		 3984 if (type == -OP_ENTEREVAL) {
3985 type = OP_ENTEREVAL;
3986 flags |= OPpEVAL_BYTES<<8;
3987 }
3988
e69777c1
GG		 3989 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
3990 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3991 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3992 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
3993 || type == OP_SASSIGN
32e2a35d 3994 || type == OP_ENTERTRY
e69777c1
GG		 3995 || type == OP_NULL );
3996
93a17b20 3997 if (!first)
aeea060c 3998 first = newOP(OP_STUB, 0);
22c35a8c 3999 if (PL_opargs[type] & OA_MARK)
8990e307 4000 first = force_list(first);
93a17b20 4001
b7dc083c 4002 NewOp(1101, unop, 1, UNOP);
eb160463 4003 unop->op_type = (OPCODE)type;
22c35a8c 4004 unop->op_ppaddr = PL_ppaddr[type];
79072805 4005 unop->op_first = first;
585ec06d 4006 unop->op_flags = (U8)(flags | OPf_KIDS);
eb160463 4007 unop->op_private = (U8)(1 | (flags >> 8));
e50aee73 4008 unop = (UNOP*) CHECKOP(type, unop);
79072805
LW		 4009 if (unop->op_next)
4010 return (OP*)unop;
4011
985b9e54 4012 return fold_constants(op_integerize(op_std_init((OP *) unop)));
79072805
LW		 4013}
4014
d67eb5f4
Z		 4015/*
4016=for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
4017
4018Constructs, checks, and returns an op of any binary type. I<type>
4019is the opcode. I<flags> gives the eight bits of C<op_flags>, except
4020that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
4021the eight bits of C<op_private>, except that the bit with value 1 or
40222 is automatically set as required. I<first> and I<last> supply up to
4023two ops to be the direct children of the binary op; they are consumed
4024by this function and become part of the constructed op tree.
4025
4026=cut
4027*/
4028
79072805 4029OP *
864dbfa3 4030Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
79072805 4031{
27da23d5 4032 dVAR;
79072805 4033 BINOP *binop;
e69777c1
GG		 4034
4035 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
4036 || type == OP_SASSIGN || type == OP_NULL );
4037
b7dc083c 4038 NewOp(1101, binop, 1, BINOP);
79072805
LW		 4039
4040 if (!first)
4041 first = newOP(OP_NULL, 0);
4042
eb160463 4043 binop->op_type = (OPCODE)type;
22c35a8c 4044 binop->op_ppaddr = PL_ppaddr[type];
79072805 4045 binop->op_first = first;
585ec06d 4046 binop->op_flags = (U8)(flags | OPf_KIDS);
79072805
LW		 4047 if (!last) {
4048 last = first;
eb160463 4049 binop->op_private = (U8)(1 | (flags >> 8));
79072805
LW		 4050 }
4051 else {
eb160463 4052 binop->op_private = (U8)(2 | (flags >> 8));
79072805
LW		 4053 first->op_sibling = last;
4054 }
4055
e50aee73 4056 binop = (BINOP*)CHECKOP(type, binop);
eb160463 4057 if (binop->op_next || binop->op_type != (OPCODE)type)
79072805
LW		 4058 return (OP*)binop;
4059
7284ab6f 4060 binop->op_last = binop->op_first->op_sibling;
79072805 4061
985b9e54 4062 return fold_constants(op_integerize(op_std_init((OP *)binop)));
79072805
LW		 4063}
4064
5f66b61c
AL		 4065static int uvcompare(const void *a, const void *b)
4066 __attribute__nonnull__(1)
4067 __attribute__nonnull__(2)
4068 __attribute__pure__;
abb2c242 4069static int uvcompare(const void *a, const void *b)
2b9d42f0 4070{
e1ec3a88 4071 if (*((const UV *)a) < (*(const UV *)b))
2b9d42f0 4072 return -1;
e1ec3a88 4073 if (*((const UV *)a) > (*(const UV *)b))
2b9d42f0 4074 return 1;
e1ec3a88 4075 if (*((const UV *)a+1) < (*(const UV *)b+1))
2b9d42f0 4076 return -1;
e1ec3a88 4077 if (*((const UV *)a+1) > (*(const UV *)b+1))
2b9d42f0 4078 return 1;
a0ed51b3
LW		 4079 return 0;
4080}
4081
0d86688d
NC		 4082static OP *
4083S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
79072805 4084{
97aff369 4085 dVAR;
2d03de9c 4086 SV * const tstr = ((SVOP*)expr)->op_sv;
fbbb0949
DM		 4087 SV * const rstr =
4088#ifdef PERL_MAD
4089 (repl->op_type == OP_NULL)
4090 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
4091#endif
4092 ((SVOP*)repl)->op_sv;
463ee0b2
LW		 4093 STRLEN tlen;
4094 STRLEN rlen;
5c144d81
NC		 4095 const U8 *t = (U8*)SvPV_const(tstr, tlen);
4096 const U8 *r = (U8*)SvPV_const(rstr, rlen);
eb578fdb
KW		 4097 I32 i;
4098 I32 j;
9b877dbb 4099 I32 grows = 0;
eb578fdb 4100 short *tbl;
79072805 4101
551405c4
AL		 4102 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
4103 const I32 squash = o->op_private & OPpTRANS_SQUASH;
4104 I32 del = o->op_private & OPpTRANS_DELETE;
043e41b8 4105 SV* swash;
7918f24d
NC		 4106
4107 PERL_ARGS_ASSERT_PMTRANS;
4108
800b4dc4 4109 PL_hints |= HINT_BLOCK_SCOPE;
1c846c1f 4110
036b4402
GS		 4111 if (SvUTF8(tstr))
4112 o->op_private |= OPpTRANS_FROM_UTF;
1c846c1f
NIS		 4113
4114 if (SvUTF8(rstr))
036b4402 4115 o->op_private |= OPpTRANS_TO_UTF;
79072805 4116
a0ed51b3 4117 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
396482e1 4118 SV* const listsv = newSVpvs("# comment\n");
c445ea15 4119 SV* transv = NULL;
5c144d81
NC		 4120 const U8* tend = t + tlen;
4121 const U8* rend = r + rlen;
ba210ebe 4122 STRLEN ulen;
84c133a0
RB		 4123 UV tfirst = 1;
4124 UV tlast = 0;
4125 IV tdiff;
4126 UV rfirst = 1;
4127 UV rlast = 0;
4128 IV rdiff;
4129 IV diff;
a0ed51b3
LW		 4130 I32 none = 0;
4131 U32 max = 0;
4132 I32 bits;
a0ed51b3 4133 I32 havefinal = 0;
9c5ffd7c 4134 U32 final = 0;
551405c4
AL		 4135 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
4136 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
bf4a1e57
JH		 4137 U8* tsave = NULL;
4138 U8* rsave = NULL;
9f7f3913 4139 const U32 flags = UTF8_ALLOW_DEFAULT;
bf4a1e57
JH		 4140
4141 if (!from_utf) {
4142 STRLEN len = tlen;
5c144d81 4143 t = tsave = bytes_to_utf8(t, &len);
bf4a1e57
JH		 4144 tend = t + len;
4145 }
4146 if (!to_utf && rlen) {
4147 STRLEN len = rlen;
5c144d81 4148 r = rsave = bytes_to_utf8(r, &len);
bf4a1e57
JH		 4149 rend = r + len;
4150 }
a0ed51b3 4151
2b9d42f0
NIS		 4152/* There are several snags with this code on EBCDIC:
4153 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
4154 2. scan_const() in toke.c has encoded chars in native encoding which makes
4155 ranges at least in EBCDIC 0..255 range the bottom odd.
4156*/
4157
a0ed51b3 4158 if (complement) {
89ebb4a3 4159 U8 tmpbuf[UTF8_MAXBYTES+1];
2b9d42f0 4160 UV *cp;
a0ed51b3 4161 UV nextmin = 0;
a02a5408 4162 Newx(cp, 2*tlen, UV);
a0ed51b3 4163 i = 0;
396482e1 4164 transv = newSVpvs("");
a0ed51b3 4165 while (t < tend) {
9f7f3913 4166 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
2b9d42f0
NIS		 4167 t += ulen;
4168 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
a0ed51b3 4169 t++;
9f7f3913 4170 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
2b9d42f0 4171 t += ulen;
a0ed51b3 4172 }
2b9d42f0
NIS		 4173 else {
4174 cp[2*i+1] = cp[2*i];
4175 }
4176 i++;
a0ed51b3 4177 }
2b9d42f0 4178 qsort(cp, i, 2*sizeof(UV), uvcompare);
a0ed51b3 4179 for (j = 0; j < i; j++) {
2b9d42f0 4180 UV val = cp[2*j];
a0ed51b3
LW		 4181 diff = val - nextmin;
4182 if (diff > 0) {
9041c2e3 4183 t = uvuni_to_utf8(tmpbuf,nextmin);
dfe13c55 4184 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
a0ed51b3 4185 if (diff > 1) {
2b9d42f0 4186 U8 range_mark = UTF_TO_NATIVE(0xff);
9041c2e3 4187 t = uvuni_to_utf8(tmpbuf, val - 1);
2b9d42f0 4188 sv_catpvn(transv, (char *)&range_mark, 1);
dfe13c55 4189 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
a0ed51b3
LW		 4190 }
4191 }
2b9d42f0 4192 val = cp[2*j+1];
a0ed51b3
LW		 4193 if (val >= nextmin)
4194 nextmin = val + 1;
4195 }
9041c2e3 4196 t = uvuni_to_utf8(tmpbuf,nextmin);
dfe13c55 4197 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2b9d42f0
NIS		 4198 {
4199 U8 range_mark = UTF_TO_NATIVE(0xff);
4200 sv_catpvn(transv, (char *)&range_mark, 1);
4201 }
6247ead0 4202 t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
dfe13c55 4203 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
93524f2b 4204 t = (const U8*)SvPVX_const(transv);
a0ed51b3
LW		 4205 tlen = SvCUR(transv);
4206 tend = t + tlen;
455d824a 4207 Safefree(cp);
a0ed51b3
LW		 4208 }
4209 else if (!rlen && !del) {
4210 r = t; rlen = tlen; rend = tend;
4757a243
LW		 4211 }
4212 if (!squash) {
05d340b8 4213 if ((!rlen && !del) || t == r ||
12ae5dfc 4214 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
01ec43d0 4215 {
4757a243 4216 o->op_private |= OPpTRANS_IDENTICAL;
01ec43d0 4217 }
a0ed51b3
LW		 4218 }
4219
4220 while (t < tend || tfirst <= tlast) {
4221 /* see if we need more "t" chars */
4222 if (tfirst > tlast) {
9f7f3913 4223 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
a0ed51b3 4224 t += ulen;
2b9d42f0 4225 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
ba210ebe 4226 t++;
9f7f3913 4227 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
a0ed51b3
LW		 4228 t += ulen;
4229 }
4230 else
4231 tlast = tfirst;
4232 }
4233
4234 /* now see if we need more "r" chars */
4235 if (rfirst > rlast) {
4236 if (r < rend) {
9f7f3913 4237 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
a0ed51b3 4238 r += ulen;
2b9d42f0 4239 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
ba210ebe 4240 r++;
9f7f3913 4241 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
a0ed51b3
LW		 4242 r += ulen;
4243 }
4244 else
4245 rlast = rfirst;
4246 }
4247 else {
4248 if (!havefinal++)
4249 final = rlast;
4250 rfirst = rlast = 0xffffffff;
4251 }
4252 }
4253
4254 /* now see which range will peter our first, if either. */
4255 tdiff = tlast - tfirst;
4256 rdiff = rlast - rfirst;
4257
4258 if (tdiff <= rdiff)
4259 diff = tdiff;
4260 else
4261 diff = rdiff;
4262
4263 if (rfirst == 0xffffffff) {
4264 diff = tdiff; /* oops, pretend rdiff is infinite */
4265 if (diff > 0)
894356b3
GS		 4266 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
4267 (long)tfirst, (long)tlast);
a0ed51b3 4268 else
894356b3 4269 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
a0ed51b3
LW		 4270 }
4271 else {
4272 if (diff > 0)
894356b3
GS		 4273 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
4274 (long)tfirst, (long)(tfirst + diff),
4275 (long)rfirst);
a0ed51b3 4276 else
894356b3
GS		 4277 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
4278 (long)tfirst, (long)rfirst);
a0ed51b3
LW		 4279
4280 if (rfirst + diff > max)
4281 max = rfirst + diff;
9b877dbb 4282 if (!grows)
45005bfb
JH		 4283 grows = (tfirst < rfirst &&
4284 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
4285 rfirst += diff + 1;
a0ed51b3
LW		 4286 }
4287 tfirst += diff + 1;
4288 }
4289
4290 none = ++max;
4291 if (del)
4292 del = ++max;
4293
4294 if (max > 0xffff)
4295 bits = 32;
4296 else if (max > 0xff)
4297 bits = 16;
4298 else
4299 bits = 8;
4300
ad64d0ec 4301 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
043e41b8
DM		 4302#ifdef USE_ITHREADS
4303 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
4304 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
4305 PAD_SETSV(cPADOPo->op_padix, swash);
4306 SvPADTMP_on(swash);
a5446a64 4307 SvREADONLY_on(swash);
043e41b8
DM		 4308#else
4309 cSVOPo->op_sv = swash;
4310#endif
a0ed51b3 4311 SvREFCNT_dec(listsv);
b37c2d43 4312 SvREFCNT_dec(transv);
a0ed51b3 4313
45005bfb 4314 if (!del && havefinal && rlen)
85fbaab2 4315 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
b448e4fe 4316 newSVuv((UV)final), 0);
a0ed51b3 4317
9b877dbb 4318 if (grows)
a0ed51b3
LW		 4319 o->op_private |= OPpTRANS_GROWS;
4320
b37c2d43
AL		 4321 Safefree(tsave);
4322 Safefree(rsave);
9b877dbb 4323
eb8433b7
NC		 4324#ifdef PERL_MAD
4325 op_getmad(expr,o,'e');
4326 op_getmad(repl,o,'r');
4327#else
a0ed51b3
LW		 4328 op_free(expr);
4329 op_free(repl);
eb8433b7 4330#endif
a0ed51b3
LW		 4331 return o;
4332 }
4333
9100eeb1
Z		 4334 tbl = (short*)PerlMemShared_calloc(
4335 (o->op_private & OPpTRANS_COMPLEMENT) &&
4336 !(o->op_private & OPpTRANS_DELETE) ? 258 : 256,
4337 sizeof(short));
4338 cPVOPo->op_pv = (char*)tbl;
79072805 4339 if (complement) {
eb160463 4340 for (i = 0; i < (I32)tlen; i++)
ec49126f 4341 tbl[t[i]] = -1;
79072805
LW		 4342 for (i = 0, j = 0; i < 256; i++) {
4343 if (!tbl[i]) {
eb160463 4344 if (j >= (I32)rlen) {
a0ed51b3 4345 if (del)
79072805
LW		 4346 tbl[i] = -2;
4347 else if (rlen)
ec49126f 4348 tbl[i] = r[j-1];
79072805 4349 else
eb160463 4350 tbl[i] = (short)i;
79072805 4351 }
9b877dbb
IH		 4352 else {
4353 if (i < 128 && r[j] >= 128)
4354 grows = 1;
ec49126f 4355 tbl[i] = r[j++];
9b877dbb 4356 }
79072805
LW		 4357 }
4358 }
05d340b8
JH		 4359 if (!del) {
4360 if (!rlen) {
4361 j = rlen;
4362 if (!squash)
4363 o->op_private |= OPpTRANS_IDENTICAL;
4364 }
eb160463 4365 else if (j >= (I32)rlen)
05d340b8 4366 j = rlen - 1;
10db182f 4367 else {
aa1f7c5b
JH		 4368 tbl =
4369 (short *)
4370 PerlMemShared_realloc(tbl,
4371 (0x101+rlen-j) * sizeof(short));
10db182f
YO		 4372 cPVOPo->op_pv = (char*)tbl;
4373 }
585ec06d 4374 tbl[0x100] = (short)(rlen - j);
eb160463 4375 for (i=0; i < (I32)rlen - j; i++)
8973db79
JH		 4376 tbl[0x101+i] = r[j+i];
4377 }
79072805
LW		 4378 }
4379 else {
a0ed51b3 4380 if (!rlen && !del) {
79072805 4381 r = t; rlen = tlen;
5d06d08e 4382 if (!squash)
4757a243 4383 o->op_private |= OPpTRANS_IDENTICAL;
79072805 4384 }
94bfe852
RGS		 4385 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
4386 o->op_private |= OPpTRANS_IDENTICAL;
4387 }
79072805
LW		 4388 for (i = 0; i < 256; i++)
4389 tbl[i] = -1;
eb160463
GS		 4390 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
4391 if (j >= (I32)rlen) {
a0ed51b3 4392 if (del) {
ec49126f 4393 if (tbl[t[i]] == -1)
4394 tbl[t[i]] = -2;
79072805
LW		 4395 continue;
4396 }
4397 --j;
4398 }
9b877dbb
IH		 4399 if (tbl[t[i]] == -1) {
4400 if (t[i] < 128 && r[j] >= 128)
4401 grows = 1;
ec49126f 4402 tbl[t[i]] = r[j];
9b877dbb 4403 }
79072805
LW		 4404 }
4405 }
b08e453b 4406
a2a5de95
NC		 4407 if(del && rlen == tlen) {
4408 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
b8c388a9 4409 } else if(rlen > tlen && !complement) {
a2a5de95 4410 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
b08e453b
RB		 4411 }
4412
9b877dbb
IH		 4413 if (grows)
4414 o->op_private |= OPpTRANS_GROWS;
eb8433b7
NC		 4415#ifdef PERL_MAD
4416 op_getmad(expr,o,'e');
4417 op_getmad(repl,o,'r');
4418#else
79072805
LW		 4419 op_free(expr);
4420 op_free(repl);
eb8433b7 4421#endif
79072805 4422
11343788 4423 return o;
79072805
LW		 4424}
4425
d67eb5f4
Z		 4426/*
4427=for apidoc Am|OP *|newPMOP|I32 type|I32 flags
4428
4429Constructs, checks, and returns an op of any pattern matching type.
4430I<type> is the opcode. I<flags> gives the eight bits of C<op_flags>
4431and, shifted up eight bits, the eight bits of C<op_private>.
4432
4433=cut
4434*/
4435
79072805 4436OP *
864dbfa3 4437Perl_newPMOP(pTHX_ I32 type, I32 flags)
79072805 4438{
27da23d5 4439 dVAR;
79072805
LW		 4440 PMOP *pmop;
4441
e69777c1
GG		 4442 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
4443
b7dc083c 4444 NewOp(1101, pmop, 1, PMOP);
eb160463 4445 pmop->op_type = (OPCODE)type;
22c35a8c 4446 pmop->op_ppaddr = PL_ppaddr[type];
eb160463
GS		 4447 pmop->op_flags = (U8)flags;
4448 pmop->op_private = (U8)(0 | (flags >> 8));
79072805 4449
3280af22 4450 if (PL_hints & HINT_RE_TAINT)
c737faaf 4451 pmop->op_pmflags |= PMf_RETAINT;
82ad65bb 4452 if (IN_LOCALE_COMPILETIME) {
a62b1201 4453 set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
9de15fec 4454 }
66cbab2c
KW		 4455 else if ((! (PL_hints & HINT_BYTES))
4456 /* Both UNI_8_BIT and locale :not_characters imply Unicode */
4457 && (PL_hints & (HINT_UNI_8_BIT|HINT_LOCALE_NOT_CHARS)))
4458 {
a62b1201 4459 set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
9de15fec 4460 }
1e215989 4461 if (PL_hints & HINT_RE_FLAGS) {
20439bc7
Z		 4462 SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4463 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
1e215989
FC		 4464 );
4465 if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
20439bc7 4466 reflags = Perl_refcounted_he_fetch_pvn(aTHX_
6320bfaf 4467 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
1e215989
FC		 4468 );
4469 if (reflags && SvOK(reflags)) {
dabded94 4470 set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
1e215989
FC		 4471 }
4472 }
c737faaf 4473
36477c24 4474
debc9467 4475#ifdef USE_ITHREADS
402d2eb1
NC		 4476 assert(SvPOK(PL_regex_pad[0]));
4477 if (SvCUR(PL_regex_pad[0])) {
4478 /* Pop off the "packed" IV from the end. */
4479 SV *const repointer_list = PL_regex_pad[0];
4480 const char *p = SvEND(repointer_list) - sizeof(IV);
4481 const IV offset = *((IV*)p);
4482
4483 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
4484
4485 SvEND_set(repointer_list, p);
4486
110f3028 4487 pmop->op_pmoffset = offset;
14a49a24
NC		 4488 /* This slot should be free, so assert this: */
4489 assert(PL_regex_pad[offset] == &PL_sv_undef);
551405c4 4490 } else {
14a49a24 4491 SV * const repointer = &PL_sv_undef;
9a8b6709 4492 av_push(PL_regex_padav, repointer);
551405c4
AL		 4493 pmop->op_pmoffset = av_len(PL_regex_padav);
4494 PL_regex_pad = AvARRAY(PL_regex_padav);
13137afc 4495 }
debc9467 4496#endif
1eb1540c 4497
463d09e6 4498 return CHECKOP(type, pmop);
79072805
LW		 4499}
4500
131b3ad0
DM		 4501/* Given some sort of match op o, and an expression expr containing a
4502 * pattern, either compile expr into a regex and attach it to o (if it's
4503 * constant), or convert expr into a runtime regcomp op sequence (if it's
4504 * not)
4505 *
4506 * isreg indicates that the pattern is part of a regex construct, eg
4507 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
4508 * split "pattern", which aren't. In the former case, expr will be a list
4509 * if the pattern contains more than one term (eg /a$b/) or if it contains
4510 * a replacement, ie s/// or tr///.
d63c20f2
DM		 4511 *
4512 * When the pattern has been compiled within a new anon CV (for
4513 * qr/(?{...})/ ), then floor indicates the savestack level just before
4514 * the new sub was created
131b3ad0
DM		 4515 */
4516
79072805 4517OP *
d63c20f2 4518Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor)
79072805 4519{
27da23d5 4520 dVAR;
79072805
LW		 4521 PMOP *pm;
4522 LOGOP *rcop;
ce862d02 4523 I32 repl_has_vars = 0;
5f66b61c 4524 OP* repl = NULL;
74529a43
DM		 4525 bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
4526 bool is_compiletime;
4527 bool has_code;
131b3ad0 4528
7918f24d
NC		 4529 PERL_ARGS_ASSERT_PMRUNTIME;
4530
74529a43
DM		 4531 /* for s/// and tr///, last element in list is the replacement; pop it */
4532
4533 if (is_trans || o->op_type == OP_SUBST) {
131b3ad0
DM		 4534 OP* kid;
4535 repl = cLISTOPx(expr)->op_last;
4536 kid = cLISTOPx(expr)->op_first;
4537 while (kid->op_sibling != repl)
4538 kid = kid->op_sibling;
5f66b61c 4539 kid->op_sibling = NULL;
131b3ad0
DM		 4540 cLISTOPx(expr)->op_last = kid;
4541 }
79072805 4542
74529a43
DM		 4543 /* for TRANS, convert LIST/PUSH/CONST into CONST, and pass to pmtrans() */
4544
4545 if (is_trans) {
4546 OP* const oe = expr;
4547 assert(expr->op_type == OP_LIST);
4548 assert(cLISTOPx(expr)->op_first->op_type == OP_PUSHMARK);
4549 assert(cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last);
4550 expr = cLISTOPx(oe)->op_last;
4551 cLISTOPx(oe)->op_first->op_sibling = NULL;
4552 cLISTOPx(oe)->op_last = NULL;
4553 op_free(oe);
4554
4555 return pmtrans(o, expr, repl);
4556 }
4557
8a45afe5
DM		 4558 /* find whether we have any runtime or code elements;
4559 * at the same time, temporarily set the op_next of each DO block;
4560 * then when we LINKLIST, this will cause the DO blocks to be excluded
4561 * from the op_next chain (and from having LINKLIST recursively
4562 * applied to them). We fix up the DOs specially later */
74529a43
DM		 4563
4564 is_compiletime = 1;
4565 has_code = 0;
4566 if (expr->op_type == OP_LIST) {
4567 OP *o;
4568 for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) {
8a45afe5 4569 if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
74529a43 4570 has_code = 1;
8a45afe5
DM		 4571 assert(!o->op_next && o->op_sibling);
4572 o->op_next = o->op_sibling;
4573 }
74529a43
DM		 4574 else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
4575 is_compiletime = 0;
4576 }
4577 }
68e2671b 4578 else if (expr->op_type != OP_CONST)
74529a43 4579 is_compiletime = 0;
74529a43 4580
8a45afe5
DM		 4581 LINKLIST(expr);
4582
491453ba
DM		 4583 /* fix up DO blocks; treat each one as a separate little sub;
4584 * also, mark any arrays as LIST/REF */
74529a43 4585
68e2671b 4586 if (expr->op_type == OP_LIST) {
8a45afe5
DM		 4587 OP *o;
4588 for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) {
491453ba
DM		 4589
4590 if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) {
4591 assert( !(o->op_flags & OPf_WANT));
4592 /* push the array rather than its contents. The regex
4593 * engine will retrieve and join the elements later */
4594 o->op_flags |= (OPf_WANT_LIST | OPf_REF);
4595 continue;
4596 }
4597
8a45afe5
DM		 4598 if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
4599 continue;
4600 o->op_next = NULL; /* undo temporary hack from above */
4601 scalar(o);
4602 LINKLIST(o);
4603 if (cLISTOPo->op_first->op_type == OP_LEAVE) {
106d2451 4604 LISTOP *leaveop = cLISTOPx(cLISTOPo->op_first);
8a45afe5 4605 /* skip ENTER */
106d2451
DM		 4606 assert(leaveop->op_first->op_type == OP_ENTER);
4607 assert(leaveop->op_first->op_sibling);
4608 o->op_next = leaveop->op_first->op_sibling;
4609 /* skip leave */
4610 assert(leaveop->op_flags & OPf_KIDS);
35431808 4611 assert(leaveop->op_last->op_next == (OP*)leaveop);
106d2451
DM		 4612 leaveop->op_next = NULL; /* stop on last op */
4613 op_null((OP*)leaveop);
9da1dd8f 4614 }
8a45afe5
DM		 4615 else {
4616 /* skip SCOPE */
4617 OP *scope = cLISTOPo->op_first;
4618 assert(scope->op_type == OP_SCOPE);
4619 assert(scope->op_flags & OPf_KIDS);
4620 scope->op_next = NULL; /* stop on last op */
4621 op_null(scope);
9da1dd8f 4622 }
8a45afe5
DM		 4623 /* have to peep the DOs individually as we've removed it from
4624 * the op_next chain */
4625 CALL_PEEP(o);
4626 if (is_compiletime)
4627 /* runtime finalizes as part of finalizing whole tree */
4628 finalize_optree(o);
9da1dd8f 4629 }
9da1dd8f 4630 }
491453ba
DM		 4631 else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
4632 assert( !(expr->op_flags & OPf_WANT));
4633 /* push the array rather than its contents. The regex
4634 * engine will retrieve and join the elements later */
4635 expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
4636 }
9da1dd8f 4637
3280af22 4638 PL_hints |= HINT_BLOCK_SCOPE;
11343788 4639 pm = (PMOP*)o;
d63c20f2 4640 assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
79072805 4641
74529a43 4642 if (is_compiletime) {
514a91f1 4643 U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
3c13cae6 4644 regexp_engine const *eng = current_re_engine();
5c144d81 4645
dbc200c5
YO		 4646 if (o->op_flags & OPf_SPECIAL)
4647 rx_flags |= RXf_SPLIT;
4648
3c13cae6 4649 if (!has_code || !eng->op_comp) {
d63c20f2 4650 /* compile-time simple constant pattern */
d63c20f2
DM		 4651
4652 if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
4653 /* whoops! we guessed that a qr// had a code block, but we
4654 * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
4655 * that isn't required now. Note that we have to be pretty
4656 * confident that nothing used that CV's pad while the
4657 * regex was parsed */
4658 assert(AvFILLp(PL_comppad) == 0); /* just @_ */
8be227ab
FC		 4659 /* But we know that one op is using this CV's slab. */
4660 cv_forget_slab(PL_compcv);
d63c20f2
DM		 4661 LEAVE_SCOPE(floor);
4662 pm->op_pmflags &= ~PMf_HAS_CV;
4663 }
4664
e485beb8
DM		 4665 PM_SETRE(pm,
4666 eng->op_comp
4667 ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
4668 rx_flags, pm->op_pmflags)
4669 : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
4670 rx_flags, pm->op_pmflags)
4671 );
eb8433b7 4672#ifdef PERL_MAD
68e2671b 4673 op_getmad(expr,(OP*)pm,'e');
eb8433b7 4674#else
68e2671b 4675 op_free(expr);
eb8433b7 4676#endif
68e2671b
DM		 4677 }
4678 else {
d63c20f2 4679 /* compile-time pattern that includes literal code blocks */
3c13cae6 4680 REGEXP* re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
732caac7
DM		 4681 rx_flags,
4682 (pm->op_pmflags |
4683 ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
4684 );
d63c20f2
DM		 4685 PM_SETRE(pm, re);
4686 if (pm->op_pmflags & PMf_HAS_CV) {
4687 CV *cv;
4688 /* this QR op (and the anon sub we embed it in) is never
4689 * actually executed. It's just a placeholder where we can
4690 * squirrel away expr in op_code_list without the peephole
4691 * optimiser etc processing it for a second time */
4692 OP *qr = newPMOP(OP_QR, 0);
4693 ((PMOP*)qr)->op_code_list = expr;
4694
4695 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
4696 SvREFCNT_inc_simple_void(PL_compcv);
4697 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
8d919b0a 4698 ReANY(re)->qr_anoncv = cv;
d63c20f2
DM		 4699
4700 /* attach the anon CV to the pad so that
4701 * pad_fixup_inner_anons() can find it */
4d2dfd15 4702 (void)pad_add_anon(cv, o->op_type);
d63c20f2
DM		 4703 SvREFCNT_inc_simple_void(cv);
4704 }
4705 else {
4706 pm->op_code_list = expr;
4707 }
68e2671b 4708 }
79072805
LW		 4709 }
4710 else {
d63c20f2 4711 /* runtime pattern: build chain of regcomp etc ops */
74529a43 4712 bool reglist;
346d3070 4713 PADOFFSET cv_targ = 0;
74529a43
DM		 4714
4715 reglist = isreg && expr->op_type == OP_LIST;
4716 if (reglist)
4717 op_null(expr);
4718
867940b8
DM		 4719 if (has_code) {
4720 pm->op_code_list = expr;
4721 /* don't free op_code_list; its ops are embedded elsewhere too */
4722 pm->op_pmflags |= PMf_CODELIST_PRIVATE;
4723 }
4724
dbc200c5
YO		 4725 if (o->op_flags & OPf_SPECIAL)
4726 pm->op_pmflags |= PMf_SPLIT;
4727
7fb31b92
DM		 4728 /* the OP_REGCMAYBE is a placeholder in the non-threaded case
4729 * to allow its op_next to be pointed past the regcomp and
4730 * preceding stacking ops;
4731 * OP_REGCRESET is there to reset taint before executing the
4732 * stacking ops */
284167a5
S		 4733 if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
4734 expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
463ee0b2 4735
d63c20f2
DM		 4736 if (pm->op_pmflags & PMf_HAS_CV) {
4737 /* we have a runtime qr with literal code. This means
4738 * that the qr// has been wrapped in a new CV, which
4739 * means that runtime consts, vars etc will have been compiled
4740 * against a new pad. So... we need to execute those ops
4741 * within the environment of the new CV. So wrap them in a call
4742 * to a new anon sub. i.e. for
4743 *
4744 * qr/a$b(?{...})/,
4745 *
4746 * we build an anon sub that looks like
4747 *
4748 * sub { "a", $b, '(?{...})' }
4749 *
4750 * and call it, passing the returned list to regcomp.
4751 * Or to put it another way, the list of ops that get executed
4752 * are:
4753 *
4754 * normal PMf_HAS_CV
4755 * ------ -------------------
4756 * pushmark (for regcomp)
4757 * pushmark (for entersub)
4758 * pushmark (for refgen)
4759 * anoncode
4760 * refgen
4761 * entersub
4762 * regcreset regcreset
4763 * pushmark pushmark
4764 * const("a") const("a")
4765 * gvsv(b) gvsv(b)
4766 * const("(?{...})") const("(?{...})")
4767 * leavesub
4768 * regcomp regcomp
4769 */
4770
4771 SvREFCNT_inc_simple_void(PL_compcv);
346d3070
DM		 4772 /* these lines are just an unrolled newANONATTRSUB */
4773 expr = newSVOP(OP_ANONCODE, 0,
4774 MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
4775 cv_targ = expr->op_targ;
4776 expr = newUNOP(OP_REFGEN, 0, expr);
4777
4778 expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr))));
d63c20f2
DM		 4779 }
4780
b7dc083c 4781 NewOp(1101, rcop, 1, LOGOP);
79072805 4782 rcop->op_type = OP_REGCOMP;
22c35a8c 4783 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
79072805 4784 rcop->op_first = scalar(expr);
131b3ad0
DM		 4785 rcop->op_flags |= OPf_KIDS
4786 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
4787 | (reglist ? OPf_STACKED : 0);
188c1910 4788 rcop->op_private = 0;
11343788 4789 rcop->op_other = o;
346d3070 4790 rcop->op_targ = cv_targ;
131b3ad0 4791
b5c19bd7 4792 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
ec192197 4793 if (PL_hints & HINT_RE_EVAL) PL_cv_has_eval = 1;
79072805
LW		 4794
4795 /* establish postfix order */
d63c20f2 4796 if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
463ee0b2
LW		 4797 LINKLIST(expr);
4798 rcop->op_next = expr;
4799 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
4800 }
4801 else {
4802 rcop->op_next = LINKLIST(expr);
4803 expr->op_next = (OP*)rcop;
4804 }
79072805 4805
2fcb4757 4806 op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
79072805
LW		 4807 }
4808
4809 if (repl) {
ef90d20a 4810 OP *curop = repl;
bb933b9b 4811 bool konst;
0244c3a4 4812 if (pm->op_pmflags & PMf_EVAL) {
670a9cb2
DM		 4813 if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
4814 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
0244c3a4 4815 }
ef90d20a
FC		 4816 /* If we are looking at s//.../e with a single statement, get past
4817 the implicit do{}. */
4818 if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
4819 && cUNOPx(curop)->op_first->op_type == OP_SCOPE
4820 && cUNOPx(curop)->op_first->op_flags & OPf_KIDS) {
4821 OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
4822 if (kid->op_type == OP_NULL && kid->op_sibling
4823 && !kid->op_sibling->op_sibling)
4824 curop = kid->op_sibling;
4825 }
4826 if (curop->op_type == OP_CONST)
bb933b9b 4827 konst = TRUE;
ef90d20a
FC		 4828 else if (( (curop->op_type == OP_RV2SV ||
4829 curop->op_type == OP_RV2AV ||
4830 curop->op_type == OP_RV2HV ||
4831 curop->op_type == OP_RV2GV)
4832 && cUNOPx(curop)->op_first
4833 && cUNOPx(curop)->op_first->op_type == OP_GV )
4834 || curop->op_type == OP_PADSV
4835 || curop->op_type == OP_PADAV
4836 || curop->op_type == OP_PADHV
4837 || curop->op_type == OP_PADANY) {
bb933b9b
FC		 4838 repl_has_vars = 1;
4839 konst = TRUE;
748a9306 4840 }
bb933b9b
FC		 4841 else konst = FALSE;
4842 if (konst
e80b829c
RGS		 4843 && !(repl_has_vars
4844 && (!PM_GETRE(pm)
b97b7b69 4845 || !RX_PRELEN(PM_GETRE(pm))
07bc277f 4846 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
3be69782 4847 {
748a9306 4848 pm->op_pmflags |= PMf_CONST; /* const for long enough */
2fcb4757 4849 op_prepend_elem(o->op_type, scalar(repl), o);
748a9306
LW		 4850 }
4851 else {
b7dc083c 4852 NewOp(1101, rcop, 1, LOGOP);
748a9306 4853 rcop->op_type = OP_SUBSTCONT;
22c35a8c 4854 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
748a9306
LW		 4855 rcop->op_first = scalar(repl);
4856 rcop->op_flags |= OPf_KIDS;
4857 rcop->op_private = 1;
11343788 4858 rcop->op_other = o;
748a9306
LW		 4859
4860 /* establish postfix order */
4861 rcop->op_next = LINKLIST(repl);
4862 repl->op_next = (OP*)rcop;
4863
20e98b0f 4864 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
29f2e912
NC		 4865 assert(!(pm->op_pmflags & PMf_ONCE));
4866 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
748a9306 4867 rcop->op_next = 0;
79072805
LW		 4868 }
4869 }
4870
4871 return (OP*)pm;
4872}
4873
d67eb5f4
Z		 4874/*
4875=for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
4876
4877Constructs, checks, and returns an op of any type that involves an
4878embedded SV. I<type> is the opcode. I<flags> gives the eight bits
4879of C<op_flags>. I<sv> gives the SV to embed in the op; this function
4880takes ownership of one reference to it.
4881
4882=cut
4883*/
4884
79072805 4885OP *
864dbfa3 4886Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
79072805 4887{
27da23d5 4888 dVAR;
79072805 4889 SVOP *svop;
7918f24d
NC		 4890
4891 PERL_ARGS_ASSERT_NEWSVOP;
4892
e69777c1
GG		 4893 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4894 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4895 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4896
b7dc083c 4897 NewOp(1101, svop, 1, SVOP);
eb160463 4898 svop->op_type = (OPCODE)type;
22c35a8c 4899 svop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 4900 svop->op_sv = sv;
4901 svop->op_next = (OP*)svop;
eb160463 4902 svop->op_flags = (U8)flags;
cc2ebcd7 4903 svop->op_private = (U8)(0 | (flags >> 8));
22c35a8c 4904 if (PL_opargs[type] & OA_RETSCALAR)
463ee0b2 4905 scalar((OP*)svop);
22c35a8c 4906 if (PL_opargs[type] & OA_TARGET)
ed6116ce 4907 svop->op_targ = pad_alloc(type, SVs_PADTMP);
e50aee73 4908 return CHECKOP(type, svop);
79072805
LW		 4909}
4910
392d04bb 4911#ifdef USE_ITHREADS
d67eb5f4
Z		 4912
4913/*
4914=for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
4915
4916Constructs, checks, and returns an op of any type that involves a
4917reference to a pad element. I<type> is the opcode. I<flags> gives the
4918eight bits of C<op_flags>. A pad slot is automatically allocated, and
4919is populated with I<sv>; this function takes ownership of one reference
4920to it.
4921
4922This function only exists if Perl has been compiled to use ithreads.
4923
4924=cut
4925*/
4926
79072805 4927OP *
350de78d
GS		 4928Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
4929{
27da23d5 4930 dVAR;
350de78d 4931 PADOP *padop;
7918f24d
NC		 4932
4933 PERL_ARGS_ASSERT_NEWPADOP;
4934
e69777c1
GG		 4935 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4936 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4937 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4938
350de78d 4939 NewOp(1101, padop, 1, PADOP);
eb160463 4940 padop->op_type = (OPCODE)type;
350de78d
GS		 4941 padop->op_ppaddr = PL_ppaddr[type];
4942 padop->op_padix = pad_alloc(type, SVs_PADTMP);
dd2155a4
DM		 4943 SvREFCNT_dec(PAD_SVl(padop->op_padix));
4944 PAD_SETSV(padop->op_padix, sv);
58182927
NC		 4945 assert(sv);
4946 SvPADTMP_on(sv);
350de78d 4947 padop->op_next = (OP*)padop;
eb160463 4948 padop->op_flags = (U8)flags;
350de78d
GS		 4949 if (PL_opargs[type] & OA_RETSCALAR)
4950 scalar((OP*)padop);
4951 if (PL_opargs[type] & OA_TARGET)
4952 padop->op_targ = pad_alloc(type, SVs_PADTMP);
4953 return CHECKOP(type, padop);
4954}
d67eb5f4 4955
a9fc22f0 4956#endif /* USE_ITHREADS */
d67eb5f4
Z		 4957
4958/*
4959=for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
4960
4961Constructs, checks, and returns an op of any type that involves an
4962embedded reference to a GV. I<type> is the opcode. I<flags> gives the
4963eight bits of C<op_flags>. I<gv> identifies the GV that the op should
4964reference; calling this function does not transfer ownership of any
4965reference to it.
4966
4967=cut
4968*/
350de78d
GS		 4969
4970OP *
864dbfa3 4971Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
79072805 4972{
27da23d5 4973 dVAR;
7918f24d
NC		 4974
4975 PERL_ARGS_ASSERT_NEWGVOP;
4976
350de78d 4977#ifdef USE_ITHREADS
58182927 4978 GvIN_PAD_on(gv);
ff8997d7 4979 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
350de78d 4980#else
ff8997d7 4981 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
350de78d 4982#endif
79072805
LW		 4983}
4984
d67eb5f4
Z		 4985/*
4986=for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
4987
4988Constructs, checks, and returns an op of any type that involves an
4989embedded C-level pointer (PV). I<type> is the opcode. I<flags> gives
4990the eight bits of C<op_flags>. I<pv> supplies the C-level pointer, which
3d6c5fec 4991must have been allocated using C<PerlMemShared_malloc>; the memory will
d67eb5f4
Z		 4992be freed when the op is destroyed.
4993
4994=cut
4995*/
4996
79072805 4997OP *
864dbfa3 4998Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
79072805 4999{
27da23d5 5000 dVAR;
5db1eb8d 5001 const bool utf8 = cBOOL(flags & SVf_UTF8);
79072805 5002 PVOP *pvop;
e69777c1 5003
5db1eb8d
BF		 5004 flags &= ~SVf_UTF8;
5005
e69777c1 5006 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
1a35f9ff 5007 || type == OP_RUNCV
e69777c1
GG		 5008 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
5009
b7dc083c 5010 NewOp(1101, pvop, 1, PVOP);
eb160463 5011 pvop->op_type = (OPCODE)type;
22c35a8c 5012 pvop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 5013 pvop->op_pv = pv;
5014 pvop->op_next = (OP*)pvop;
eb160463 5015 pvop->op_flags = (U8)flags;
5db1eb8d 5016 pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
22c35a8c 5017 if (PL_opargs[type] & OA_RETSCALAR)
463ee0b2 5018 scalar((OP*)pvop);
22c35a8c 5019 if (PL_opargs[type] & OA_TARGET)
ed6116ce 5020 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
e50aee73 5021 return CHECKOP(type, pvop);
79072805
LW		 5022}
5023
eb8433b7
NC		 5024#ifdef PERL_MAD
5025OP*
5026#else
79072805 5027void
eb8433b7 5028#endif
864dbfa3 5029Perl_package(pTHX_ OP *o)
79072805 5030{
97aff369 5031 dVAR;
bf070237 5032 SV *const sv = cSVOPo->op_sv;
eb8433b7
NC		 5033#ifdef PERL_MAD
5034 OP *pegop;
5035#endif
79072805 5036
7918f24d
NC		 5037 PERL_ARGS_ASSERT_PACKAGE;
5038
03d9f026 5039 SAVEGENERICSV(PL_curstash);
3280af22 5040 save_item(PL_curstname);
de11ba31 5041
03d9f026 5042 PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
e1a479c5 5043
bf070237 5044 sv_setsv(PL_curstname, sv);
de11ba31 5045
7ad382f4 5046 PL_hints |= HINT_BLOCK_SCOPE;
53a7735b
DM		 5047 PL_parser->copline = NOLINE;
5048 PL_parser->expect = XSTATE;
eb8433b7
NC		 5049
5050#ifndef PERL_MAD
5051 op_free(o);
5052#else
5053 if (!PL_madskills) {
5054 op_free(o);
1d866c12 5055 return NULL;
eb8433b7
NC		 5056 }
5057
5058 pegop = newOP(OP_NULL,0);
5059 op_getmad(o,pegop,'P');
5060 return pegop;
5061#endif
79072805
LW		 5062}
5063
6fa4d285
DG		 5064void
5065Perl_package_version( pTHX_ OP *v )
5066{
5067 dVAR;
458818ec 5068 U32 savehints = PL_hints;
6fa4d285 5069 PERL_ARGS_ASSERT_PACKAGE_VERSION;
458818ec 5070 PL_hints &= ~HINT_STRICT_VARS;
e92f586b 5071 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
458818ec 5072 PL_hints = savehints;
6fa4d285
DG		 5073 op_free(v);
5074}
5075
eb8433b7
NC		 5076#ifdef PERL_MAD
5077OP*
5078#else
85e6fe83 5079void
eb8433b7 5080#endif
88d95a4d 5081Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
85e6fe83 5082{
97aff369 5083 dVAR;
a0d0e21e 5084 OP *pack;
a0d0e21e 5085 OP *imop;
b1cb66bf 5086 OP *veop;
eb8433b7 5087#ifdef PERL_MAD
d8842ae9 5088 OP *pegop = PL_madskills ? newOP(OP_NULL,0) : NULL;
eb8433b7 5089#endif
88e9444c 5090 SV *use_version = NULL;
85e6fe83 5091
7918f24d
NC		 5092 PERL_ARGS_ASSERT_UTILIZE;
5093
88d95a4d 5094 if (idop->op_type != OP_CONST)
cea2e8a9 5095 Perl_croak(aTHX_ "Module name must be constant");
85e6fe83 5096
eb8433b7
NC		 5097 if (PL_madskills)
5098 op_getmad(idop,pegop,'U');
5099
5f66b61c 5100 veop = NULL;
b1cb66bf 5101
aec46f14 5102 if (version) {
551405c4 5103 SV * const vesv = ((SVOP*)version)->op_sv;
b1cb66bf 5104
eb8433b7
NC		 5105 if (PL_madskills)
5106 op_getmad(version,pegop,'V');
aec46f14 5107 if (!arg && !SvNIOKp(vesv)) {
b1cb66bf 5108 arg = version;
5109 }
5110 else {
5111 OP *pack;
0f79a09d 5112 SV *meth;
b1cb66bf 5113
44dcb63b 5114 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
fe13d51d 5115 Perl_croak(aTHX_ "Version number must be a constant number");
b1cb66bf 5116
88d95a4d
JH		 5117 /* Make copy of idop so we don't free it twice */
5118 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
b1cb66bf 5119
5120 /* Fake up a method call to VERSION */
18916d0d 5121 meth = newSVpvs_share("VERSION");
b1cb66bf 5122 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2fcb4757
Z		 5123 op_append_elem(OP_LIST,
5124 op_prepend_elem(OP_LIST, pack, list(version)),
0f79a09d 5125 newSVOP(OP_METHOD_NAMED, 0, meth)));
b1cb66bf 5126 }
5127 }
aeea060c 5128
a0d0e21e 5129 /* Fake up an import/unimport */
eb8433b7
NC		 5130 if (arg && arg->op_type == OP_STUB) {
5131 if (PL_madskills)
5132 op_getmad(arg,pegop,'S');
4633a7c4 5133 imop = arg; /* no import on explicit () */
eb8433b7 5134 }
88d95a4d 5135 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
5f66b61c 5136 imop = NULL; /* use 5.0; */
88e9444c
NC		 5137 if (aver)
5138 use_version = ((SVOP*)idop)->op_sv;
5139 else
468aa647 5140 idop->op_private |= OPpCONST_NOVER;
b1cb66bf 5141 }
4633a7c4 5142 else {
0f79a09d
GS		 5143 SV *meth;
5144
eb8433b7
NC		 5145 if (PL_madskills)
5146 op_getmad(arg,pegop,'A');
5147
88d95a4d
JH		 5148 /* Make copy of idop so we don't free it twice */
5149 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
0f79a09d
GS		 5150
5151 /* Fake up a method call to import/unimport */
427d62a4 5152 meth = aver
18916d0d 5153 ? newSVpvs_share("import") : newSVpvs_share("unimport");
4633a7c4 5154 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2fcb4757
Z		 5155 op_append_elem(OP_LIST,
5156 op_prepend_elem(OP_LIST, pack, list(arg)),
0f79a09d 5157 newSVOP(OP_METHOD_NAMED, 0, meth)));
4633a7c4
LW		 5158 }
5159
a0d0e21e 5160 /* Fake up the BEGIN {}, which does its thing immediately. */
09bef843 5161 newATTRSUB(floor,
18916d0d 5162 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
5f66b61c
AL		 5163 NULL,
5164 NULL,
2fcb4757
Z		 5165 op_append_elem(OP_LINESEQ,
5166 op_append_elem(OP_LINESEQ,
bd61b366
SS		 5167 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
5168 newSTATEOP(0, NULL, veop)),
5169 newSTATEOP(0, NULL, imop) ));
85e6fe83 5170
88e9444c 5171 if (use_version) {
6634bb9d 5172 /* Enable the
88e9444c
NC		 5173 * feature bundle that corresponds to the required version. */
5174 use_version = sv_2mortal(new_version(use_version));
6634bb9d 5175 S_enable_feature_bundle(aTHX_ use_version);
88e9444c 5176
88e9444c
NC		 5177 /* If a version >= 5.11.0 is requested, strictures are on by default! */
5178 if (vcmp(use_version,
5179 sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
d1718a7c 5180 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
b50b2058 5181 PL_hints |= HINT_STRICT_REFS;
d1718a7c 5182 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
b50b2058 5183 PL_hints |= HINT_STRICT_SUBS;
d1718a7c 5184 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
b50b2058
FC		 5185 PL_hints |= HINT_STRICT_VARS;
5186 }
5187 /* otherwise they are off */
5188 else {
d1718a7c 5189 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
b50b2058 5190 PL_hints &= ~HINT_STRICT_REFS;
d1718a7c 5191 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
b50b2058 5192 PL_hints &= ~HINT_STRICT_SUBS;
d1718a7c 5193 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
b50b2058 5194 PL_hints &= ~HINT_STRICT_VARS;
88e9444c
NC		 5195 }
5196 }
5197
70f5e4ed
JH		 5198 /* The "did you use incorrect case?" warning used to be here.
5199 * The problem is that on case-insensitive filesystems one
5200 * might get false positives for "use" (and "require"):
5201 * "use Strict" or "require CARP" will work. This causes
5202 * portability problems for the script: in case-strict
5203 * filesystems the script will stop working.
5204 *
5205 * The "incorrect case" warning checked whether "use Foo"
5206 * imported "Foo" to your namespace, but that is wrong, too:
5207 * there is no requirement nor promise in the language that
5208 * a Foo.pm should or would contain anything in package "Foo".
5209 *
5210 * There is very little Configure-wise that can be done, either:
5211 * the case-sensitivity of the build filesystem of Perl does not
5212 * help in guessing the case-sensitivity of the runtime environment.
5213 */
18fc9488 5214
c305c6a0 5215 PL_hints |= HINT_BLOCK_SCOPE;
53a7735b
DM		 5216 PL_parser->copline = NOLINE;
5217 PL_parser->expect = XSTATE;
8ec8fbef 5218 PL_cop_seqmax++; /* Purely for B::*'s benefit */
6012dc80
DM		 5219 if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
5220 PL_cop_seqmax++;
eb8433b7
NC		 5221
5222#ifdef PERL_MAD
eb8433b7
NC		 5223 return pegop;
5224#endif
85e6fe83
LW		 5225}
5226
7d3fb230 5227/*
ccfc67b7
JH		 5228=head1 Embedding Functions
5229
7d3fb230
BS		 5230=for apidoc load_module
5231
5232Loads the module whose name is pointed to by the string part of name.
5233Note that the actual module name, not its filename, should be given.
5234Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
5235PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
d9f23c72 5236(or 0 for no flags). ver, if specified and not NULL, provides version semantics
7d3fb230
BS		 5237similar to C<use Foo::Bar VERSION>. The optional trailing SV*
5238arguments can be used to specify arguments to the module's import()
76f108ac
JD		 5239method, similar to C<use Foo::Bar VERSION LIST>. They must be
5240terminated with a final NULL pointer. Note that this list can only
5241be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
5242Otherwise at least a single NULL pointer to designate the default
5243import list is required.
7d3fb230 5244
d9f23c72
KW		 5245The reference count for each specified C<SV*> parameter is decremented.
5246
7d3fb230
BS		 5247=cut */
5248
e4783991
GS		 5249void
5250Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
5251{
5252 va_list args;
7918f24d
NC		 5253
5254 PERL_ARGS_ASSERT_LOAD_MODULE;
5255
e4783991
GS		 5256 va_start(args, ver);
5257 vload_module(flags, name, ver, &args);
5258 va_end(args);
5259}
5260
5261#ifdef PERL_IMPLICIT_CONTEXT
5262void
5263Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
5264{
5265 dTHX;
5266 va_list args;
7918f24d 5267 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
e4783991
GS		 5268 va_start(args, ver);
5269 vload_module(flags, name, ver, &args);
5270 va_end(args);
5271}
5272#endif
5273
5274void
5275Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
5276{
97aff369 5277 dVAR;
551405c4 5278 OP *veop, *imop;
551405c4 5279 OP * const modname = newSVOP(OP_CONST, 0, name);
7918f24d
NC		 5280
5281 PERL_ARGS_ASSERT_VLOAD_MODULE;
5282
e4783991
GS		 5283 modname->op_private |= OPpCONST_BARE;
5284 if (ver) {
5285 veop = newSVOP(OP_CONST, 0, ver);
5286 }
5287 else
5f66b61c 5288 veop = NULL;
e4783991
GS		 5289 if (flags & PERL_LOADMOD_NOIMPORT) {
5290 imop = sawparens(newNULLLIST());
5291 }
5292 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
5293 imop = va_arg(*args, OP*);
5294 }
5295 else {
5296 SV *sv;
5f66b61c 5297 imop = NULL;
e4783991
GS		 5298 sv = va_arg(*args, SV*);
5299 while (sv) {
2fcb4757 5300 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
e4783991
GS		 5301 sv = va_arg(*args, SV*);
5302 }
5303 }
81885997 5304
53a7735b
DM		 5305 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
5306 * that it has a PL_parser to play with while doing that, and also
5307 * that it doesn't mess with any existing parser, by creating a tmp
5308 * new parser with lex_start(). This won't actually be used for much,
5309 * since pp_require() will create another parser for the real work. */
5310
5311 ENTER;
5312 SAVEVPTR(PL_curcop);
27fcb6ee 5313 lex_start(NULL, NULL, LEX_START_SAME_FILTER);
53a7735b
DM		 5314 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
5315 veop, modname, imop);
5316 LEAVE;
e4783991
GS		 5317}
5318
79072805 5319OP *
850e8516 5320Perl_dofile(pTHX_ OP *term, I32 force_builtin)
78ca652e 5321{
97aff369 5322 dVAR;
78ca652e 5323 OP *doop;
a0714e2c 5324 GV *gv = NULL;
78ca652e 5325
7918f24d
NC		 5326 PERL_ARGS_ASSERT_DOFILE;
5327
850e8516 5328 if (!force_builtin) {
fafc274c 5329 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
850e8516 5330 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
a4fc7abc 5331 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
a0714e2c 5332 gv = gvp ? *gvp : NULL;
850e8516
RGS		 5333 }
5334 }
78ca652e 5335
b9f751c0 5336 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
213aa87d 5337 doop = newUNOP(OP_ENTERSUB, OPf_STACKED,
2fcb4757 5338 op_append_elem(OP_LIST, term,
78ca652e 5339 scalar(newUNOP(OP_RV2CV, 0,
213aa87d 5340 newGVOP(OP_GV, 0, gv)))));
78ca652e
GS		 5341 }
5342 else {
5343 doop = newUNOP(OP_DOFILE, 0, scalar(term));
5344 }
5345 return doop;
5346}
5347
d67eb5f4
Z		 5348/*
5349=head1 Optree construction
5350
5351=for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
5352
5353Constructs, checks, and returns an C<lslice> (list slice) op. I<flags>
5354gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
5355be set automatically, and, shifted up eight bits, the eight bits of
5356C<op_private>, except that the bit with value 1 or 2 is automatically
5357set as required. I<listval> and I<subscript> supply the parameters of
5358the slice; they are consumed by this function and become part of the
5359constructed op tree.
5360
5361=cut
5362*/
5363
78ca652e 5364OP *
864dbfa3 5365Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
79072805
LW		 5366{
5367 return newBINOP(OP_LSLICE, flags,
8990e307
LW		 5368 list(force_list(subscript)),
5369 list(force_list(listval)) );
79072805
LW		 5370}
5371
76e3520e 5372STATIC I32
5aaab254 5373S_is_list_assignment(pTHX_ const OP *o)
79072805 5374{
1496a290
AL		 5375 unsigned type;
5376 U8 flags;
5377
11343788 5378 if (!o)
79072805
LW		 5379 return TRUE;
5380
1496a290 5381 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
11343788 5382 o = cUNOPo->op_first;
79072805 5383
1496a290
AL		 5384 flags = o->op_flags;
5385 type = o->op_type;
5386 if (type == OP_COND_EXPR) {
504618e9
AL		 5387 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
5388 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
79072805
LW		 5389
5390 if (t && f)
5391 return TRUE;
5392 if (t || f)
5393 yyerror("Assignment to both a list and a scalar");
5394 return FALSE;
5395 }
5396
1496a290
AL		 5397 if (type == OP_LIST &&
5398 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
95f0a2f1
SB		 5399 o->op_private & OPpLVAL_INTRO)
5400 return FALSE;
5401
1496a290
AL		 5402 if (type == OP_LIST || flags & OPf_PARENS ||
5403 type == OP_RV2AV || type == OP_RV2HV ||
5404 type == OP_ASLICE || type == OP_HSLICE)
79072805
LW		 5405 return TRUE;
5406
1496a290 5407 if (type == OP_PADAV || type == OP_PADHV)
93a17b20
LW		 5408 return TRUE;
5409
1496a290 5410 if (type == OP_RV2SV)
79072805
LW		 5411 return FALSE;
5412
5413 return FALSE;
5414}
5415
d67eb5f4 5416/*
83f9fced
GG		 5417 Helper function for newASSIGNOP to detection commonality between the
5418 lhs and the rhs. Marks all variables with PL_generation. If it
5419 returns TRUE the assignment must be able to handle common variables.
5420*/
5421PERL_STATIC_INLINE bool
5422S_aassign_common_vars(pTHX_ OP* o)
5423{
83f9fced 5424 OP *curop;
3023b5f3 5425 for (curop = cUNOPo->op_first; curop; curop=curop->op_sibling) {
83f9fced
GG		 5426 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
5427 if (curop->op_type == OP_GV) {
5428 GV *gv = cGVOPx_gv(curop);
5429 if (gv == PL_defgv
5430 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
5431 return TRUE;
5432 GvASSIGN_GENERATION_set(gv, PL_generation);
5433 }
5434 else if (curop->op_type == OP_PADSV ||
5435 curop->op_type == OP_PADAV ||
5436 curop->op_type == OP_PADHV ||
5437 curop->op_type == OP_PADANY)
5438 {
5439 if (PAD_COMPNAME_GEN(curop->op_targ)
5440 == (STRLEN)PL_generation)
5441 return TRUE;
5442 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
5443
5444 }
5445 else if (curop->op_type == OP_RV2CV)
5446 return TRUE;
5447 else if (curop->op_type == OP_RV2SV ||
5448 curop->op_type == OP_RV2AV ||
5449 curop->op_type == OP_RV2HV ||
5450 curop->op_type == OP_RV2GV) {
3023b5f3 5451 if (cUNOPx(curop)->op_first->op_type != OP_GV) /* funny deref? */
83f9fced
GG		 5452 return TRUE;
5453 }
5454 else if (curop->op_type == OP_PUSHRE) {
18c95846 5455 GV *const gv =
83f9fced 5456#ifdef USE_ITHREADS
18c95846
FC		 5457 ((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff
5458 ? MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff))
5459 : NULL;
83f9fced 5460#else
18c95846
FC		 5461 ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
5462#endif
83f9fced
GG		 5463 if (gv) {
5464 if (gv == PL_defgv
5465 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
5466 return TRUE;
5467 GvASSIGN_GENERATION_set(gv, PL_generation);
5468 }
83f9fced
GG		 5469 }
5470 else
5471 return TRUE;
5472 }
3023b5f3
GG		 5473
5474 if (curop->op_flags & OPf_KIDS) {
5475 if (aassign_common_vars(curop))
5476 return TRUE;
5477 }
83f9fced
GG		 5478 }
5479 return FALSE;
5480}
5481
5482/*
d67eb5f4
Z		 5483=for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
5484
5485Constructs, checks, and returns an assignment op. I<left> and I<right>
5486supply the parameters of the assignment; they are consumed by this
5487function and become part of the constructed op tree.
5488
5489If I<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
5490a suitable conditional optree is constructed. If I<optype> is the opcode
5491of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
5492performs the binary operation and assigns the result to the left argument.
5493Either way, if I<optype> is non-zero then I<flags> has no effect.
5494
5495If I<optype> is zero, then a plain scalar or list assignment is
5496constructed. Which type of assignment it is is automatically determined.
5497I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
5498will be set automatically, and, shifted up eight bits, the eight bits
5499of C<op_private>, except that the bit with value 1 or 2 is automatically
5500set as required.
5501
5502=cut
5503*/
5504
79072805 5505OP *
864dbfa3 5506Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
79072805 5507{
97aff369 5508 dVAR;
11343788 5509 OP *o;
79072805 5510
a0d0e21e 5511 if (optype) {
c963b151 5512 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
a0d0e21e 5513 return newLOGOP(optype, 0,
3ad73efd 5514 op_lvalue(scalar(left), optype),
a0d0e21e
LW		 5515 newUNOP(OP_SASSIGN, 0, scalar(right)));
5516 }
5517 else {
5518 return newBINOP(optype, OPf_STACKED,
3ad73efd 5519 op_lvalue(scalar(left), optype), scalar(right));
a0d0e21e
LW		 5520 }
5521 }
5522
504618e9 5523 if (is_list_assignment(left)) {
6dbe9451
NC		 5524 static const char no_list_state[] = "Initialization of state variables"
5525 " in list context currently forbidden";
10c8fecd 5526 OP *curop;
fafafbaf 5527 bool maybe_common_vars = TRUE;
10c8fecd 5528
3280af22 5529 PL_modcount = 0;
3ad73efd 5530 left = op_lvalue(left, OP_AASSIGN);
10c8fecd
GS		 5531 curop = list(force_list(left));
5532 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
eb160463 5533 o->op_private = (U8)(0 | (flags >> 8));
dd2155a4 5534
fafafbaf
RD		 5535 if ((left->op_type == OP_LIST
5536 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
5537 {
5538 OP* lop = ((LISTOP*)left)->op_first;
5539 maybe_common_vars = FALSE;
5540 while (lop) {
5541 if (lop->op_type == OP_PADSV ||
5542 lop->op_type == OP_PADAV ||
5543 lop->op_type == OP_PADHV ||
5544 lop->op_type == OP_PADANY) {
5545 if (!(lop->op_private & OPpLVAL_INTRO))
5546 maybe_common_vars = TRUE;
5547
5548 if (lop->op_private & OPpPAD_STATE) {
5549 if (left->op_private & OPpLVAL_INTRO) {
5550 /* Each variable in state($a, $b, $c) = ... */
5551 }
5552 else {
5553 /* Each state variable in
5554 (state $a, my $b, our $c, $d, undef) = ... */
5555 }
5556 yyerror(no_list_state);
5557 } else {
5558 /* Each my variable in
5559 (state $a, my $b, our $c, $d, undef) = ... */
5560 }
5561 } else if (lop->op_type == OP_UNDEF ||
5562 lop->op_type == OP_PUSHMARK) {
5563 /* undef may be interesting in
5564 (state $a, undef, state $c) */
5565 } else {
5566 /* Other ops in the list. */
5567 maybe_common_vars = TRUE;
5568 }
5569 lop = lop->op_sibling;
5570 }
5571 }
5572 else if ((left->op_private & OPpLVAL_INTRO)
5573 && ( left->op_type == OP_PADSV
5574 || left->op_type == OP_PADAV
5575 || left->op_type == OP_PADHV
5576 || left->op_type == OP_PADANY))
5577 {
0f907b96 5578 if (left->op_type == OP_PADSV) maybe_common_vars = FALSE;
fafafbaf
RD		 5579 if (left->op_private & OPpPAD_STATE) {
5580 /* All single variable list context state assignments, hence
5581 state ($a) = ...
5582 (state $a) = ...
5583 state @a = ...
5584 state (@a) = ...
5585 (state @a) = ...
5586 state %a = ...
5587 state (%a) = ...
5588 (state %a) = ...
5589 */
5590 yyerror(no_list_state);
5591 }
5592 }
5593
dd2155a4
DM		 5594 /* PL_generation sorcery:
5595 * an assignment like ($a,$b) = ($c,$d) is easier than
5596 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
5597 * To detect whether there are common vars, the global var
5598 * PL_generation is incremented for each assign op we compile.
5599 * Then, while compiling the assign op, we run through all the
5600 * variables on both sides of the assignment, setting a spare slot
5601 * in each of them to PL_generation. If any of them already have
5602 * that value, we know we've got commonality. We could use a
5603 * single bit marker, but then we'd have to make 2 passes, first
5604 * to clear the flag, then to test and set it. To find somewhere
931b58fb 5605 * to store these values, evil chicanery is done with SvUVX().
dd2155a4
DM		 5606 */
5607
fafafbaf 5608 if (maybe_common_vars) {
3280af22 5609 PL_generation++;
83f9fced 5610 if (aassign_common_vars(o))
10c8fecd 5611 o->op_private |= OPpASSIGN_COMMON;
3023b5f3 5612 LINKLIST(o);
461824dc 5613 }
9fdc7570 5614
e9cc17ba 5615 if (right && right->op_type == OP_SPLIT && !PL_madskills) {
1496a290
AL		 5616 OP* tmpop = ((LISTOP*)right)->op_first;
5617 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
551405c4 5618 PMOP * const pm = (PMOP*)tmpop;
c07a80fd 5619 if (left->op_type == OP_RV2AV &&
5620 !(left->op_private & OPpLVAL_INTRO) &&
11343788 5621 !(o->op_private & OPpASSIGN_COMMON) )
c07a80fd 5622 {
5623 tmpop = ((UNOP*)left)->op_first;
20e98b0f
NC		 5624 if (tmpop->op_type == OP_GV
5625#ifdef USE_ITHREADS
5626 && !pm->op_pmreplrootu.op_pmtargetoff
5627#else
5628 && !pm->op_pmreplrootu.op_pmtargetgv
5629#endif
5630 ) {
971a9dd3 5631#ifdef USE_ITHREADS
20e98b0f
NC		 5632 pm->op_pmreplrootu.op_pmtargetoff
5633 = cPADOPx(tmpop)->op_padix;
971a9dd3
GS		 5634 cPADOPx(tmpop)->op_padix = 0; /* steal it */
5635#else
20e98b0f 5636 pm->op_pmreplrootu.op_pmtargetgv
159b6efe 5637 = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
a0714e2c 5638 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
971a9dd3 5639#endif
11343788 5640 tmpop = cUNOPo->op_first; /* to list (nulled) */
c07a80fd 5641 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
5f66b61c 5642 tmpop->op_sibling = NULL; /* don't free split */
c07a80fd 5643 right->op_next = tmpop->op_next; /* fix starting loc */
11343788 5644 op_free(o); /* blow off assign */
54310121 5645 right->op_flags &= ~OPf_WANT;
a5f75d66 5646 /* "I don't know and I don't care." */
c07a80fd 5647 return right;
5648 }
5649 }
5650 else {
e6438c1a 5651 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
c07a80fd 5652 ((LISTOP*)right)->op_last->op_type == OP_CONST)
5653 {
60041a09
FC		 5654 SV ** const svp =
5655 &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
5656 SV * const sv = *svp;
b8de32d5 5657 if (SvIOK(sv) && SvIVX(sv) == 0)
60041a09
FC		 5658 {
5659 if (right->op_private & OPpSPLIT_IMPLIM) {
5660 /* our own SV, created in ck_split */
5661 SvREADONLY_off(sv);
3280af22 5662 sv_setiv(sv, PL_modcount+1);
60041a09
FC		 5663 }
5664 else {
5665 /* SV may belong to someone else */
5666 SvREFCNT_dec(sv);
5667 *svp = newSViv(PL_modcount+1);
5668 }
5669 }
c07a80fd 5670 }
5671 }
5672 }
5673 }
11343788 5674 return o;
79072805
LW		 5675 }
5676 if (!right)
5677 right = newOP(OP_UNDEF, 0);
5678 if (right->op_type == OP_READLINE) {
5679 right->op_flags |= OPf_STACKED;
3ad73efd
Z		 5680 return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
5681 scalar(right));
79072805 5682 }
a0d0e21e 5683 else {
11343788 5684 o = newBINOP(OP_SASSIGN, flags,
3ad73efd 5685 scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
a0d0e21e 5686 }
11343788 5687 return o;
79072805
LW		 5688}
5689
d67eb5f4
Z		 5690/*
5691=for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
5692
5693Constructs a state op (COP). The state op is normally a C<nextstate> op,
5694but will be a C<dbstate> op if debugging is enabled for currently-compiled
3d6c5fec 5695code. The state op is populated from C<PL_curcop> (or C<PL_compiling>).
d67eb5f4
Z		 5696If I<label> is non-null, it supplies the name of a label to attach to
5697the state op; this function takes ownership of the memory pointed at by
5698I<label>, and will free it. I<flags> gives the eight bits of C<op_flags>
5699for the state op.
5700
5701If I<o> is null, the state op is returned. Otherwise the state op is
5702combined with I<o> into a C<lineseq> list op, which is returned. I<o>
5703is consumed by this function and becomes part of the returned op tree.
5704
5705=cut
5706*/
5707
79072805 5708OP *
864dbfa3 5709Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
79072805 5710{
27da23d5 5711 dVAR;
e1ec3a88 5712 const U32 seq = intro_my();
5db1eb8d 5713 const U32 utf8 = flags & SVf_UTF8;
eb578fdb 5714 COP *cop;
79072805 5715
5db1eb8d
BF		 5716 flags &= ~SVf_UTF8;
5717
b7dc083c 5718 NewOp(1101, cop, 1, COP);
57843af0 5719 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
8990e307 5720 cop->op_type = OP_DBSTATE;
22c35a8c 5721 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
8990e307
LW		 5722 }
5723 else {
5724 cop->op_type = OP_NEXTSTATE;
22c35a8c 5725 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
8990e307 5726 }
eb160463 5727 cop->op_flags = (U8)flags;
623e6609 5728 CopHINTS_set(cop, PL_hints);
ff0cee69 5729#ifdef NATIVE_HINTS
5730 cop->op_private |= NATIVE_HINTS;
5731#endif
623e6609 5732 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
79072805
LW		 5733 cop->op_next = (OP*)cop;
5734
bbce6d69 5735 cop->cop_seq = seq;
72dc9ed5 5736 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
20439bc7 5737 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
dca6062a 5738 if (label) {
5db1eb8d
BF		 5739 Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
5740
dca6062a
NC		 5741 PL_hints |= HINT_BLOCK_SCOPE;
5742 /* It seems that we need to defer freeing this pointer, as other parts
5743 of the grammar end up wanting to copy it after this op has been
5744 created. */
5745 SAVEFREEPV(label);
dca6062a 5746 }
79072805 5747
53a7735b 5748 if (PL_parser && PL_parser->copline == NOLINE)
57843af0 5749 CopLINE_set(cop, CopLINE(PL_curcop));
79072805 5750 else {
53a7735b 5751 CopLINE_set(cop, PL_parser->copline);
4b1709c8 5752 PL_parser->copline = NOLINE;
79072805 5753 }
57843af0 5754#ifdef USE_ITHREADS
c82ecf34
FC		 5755 /* While CopFILEGV_set does work under ithreads, this is faster, as it
5756 avoids a linear scan of the filegv pad: */
5757 if((cop->cop_filegvoff = PL_curcop->cop_filegvoff))
5758 SvREFCNT_inc_void_NN(PL_filegvpad[cop->cop_filegvoff]);
57843af0 5759#else
f4dd75d9 5760 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
57843af0 5761#endif
11faa288 5762 CopSTASH_set(cop, PL_curstash);
79072805 5763
65269a95
TB		 5764 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) {
5765 /* this line can have a breakpoint - store the cop in IV */
80a702cd
RGS		 5766 AV *av = CopFILEAVx(PL_curcop);
5767 if (av) {
5768 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
5769 if (svp && *svp != &PL_sv_undef ) {
5770 (void)SvIOK_on(*svp);
5771 SvIV_set(*svp, PTR2IV(cop));
5772 }
1eb1540c 5773 }
93a17b20
LW		 5774 }
5775
f6f3a1fe
RGS		 5776 if (flags & OPf_SPECIAL)
5777 op_null((OP*)cop);
2fcb4757 5778 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
79072805
LW		 5779}
5780
d67eb5f4
Z		 5781/*
5782=for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
5783
5784Constructs, checks, and returns a logical (flow control) op. I<type>
5785is the opcode. I<flags> gives the eight bits of C<op_flags>, except
5786that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
5787the eight bits of C<op_private>, except that the bit with value 1 is
5788automatically set. I<first> supplies the expression controlling the
5789flow, and I<other> supplies the side (alternate) chain of ops; they are
5790consumed by this function and become part of the constructed op tree.
5791
5792=cut
5793*/
bbce6d69 5794
79072805 5795OP *
864dbfa3 5796Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
79072805 5797{
27da23d5 5798 dVAR;
7918f24d
NC		 5799
5800 PERL_ARGS_ASSERT_NEWLOGOP;
5801
883ffac3
CS		 5802 return new_logop(type, flags, &first, &other);
5803}
5804
3bd495df 5805STATIC OP *
71c4dbc3
VP		 5806S_search_const(pTHX_ OP *o)
5807{
5808 PERL_ARGS_ASSERT_SEARCH_CONST;
5809
5810 switch (o->op_type) {
5811 case OP_CONST:
5812 return o;
5813 case OP_NULL:
5814 if (o->op_flags & OPf_KIDS)
5815 return search_const(cUNOPo->op_first);
5816 break;
5817 case OP_LEAVE:
5818 case OP_SCOPE:
5819 case OP_LINESEQ:
5820 {
5821 OP *kid;
5822 if (!(o->op_flags & OPf_KIDS))
5823 return NULL;
5824 kid = cLISTOPo->op_first;
5825 do {
5826 switch (kid->op_type) {
5827 case OP_ENTER:
5828 case OP_NULL:
5829 case OP_NEXTSTATE:
5830 kid = kid->op_sibling;
5831 break;
5832 default:
5833 if (kid != cLISTOPo->op_last)
5834 return NULL;
5835 goto last;
5836 }
5837 } while (kid);
5838 if (!kid)
5839 kid = cLISTOPo->op_last;
5840last:
5841 return search_const(kid);
5842 }
5843 }
5844
5845 return NULL;
5846}
5847
5848STATIC OP *
cea2e8a9 5849S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
883ffac3 5850{
27da23d5 5851 dVAR;
79072805 5852 LOGOP *logop;
11343788 5853 OP *o;
71c4dbc3
VP		 5854 OP *first;
5855 OP *other;
5856 OP *cstop = NULL;
edbe35ea 5857 int prepend_not = 0;
79072805 5858
7918f24d
NC		 5859 PERL_ARGS_ASSERT_NEW_LOGOP;
5860
71c4dbc3
VP		 5861 first = *firstp;
5862 other = *otherp;
5863
a0d0e21e
LW		 5864 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
5865 return newBINOP(type, flags, scalar(first), scalar(other));
5866
e69777c1
GG		 5867 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP);
5868
8990e307 5869 scalarboolean(first);
edbe35ea 5870 /* optimize AND and OR ops that have NOTs as children */
68726e16 5871 if (first->op_type == OP_NOT
b6214b80 5872 && (first->op_flags & OPf_KIDS)
edbe35ea
VP		 5873 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
5874 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
b6214b80 5875 && !PL_madskills) {
79072805
LW		 5876 if (type == OP_AND || type == OP_OR) {
5877 if (type == OP_AND)
5878 type = OP_OR;
5879 else
5880 type = OP_AND;
07f3cdf5 5881 op_null(first);
edbe35ea 5882 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
07f3cdf5 5883 op_null(other);
edbe35ea
VP		 5884 prepend_not = 1; /* prepend a NOT op later */
5885 }
79072805
LW		 5886 }
5887 }
71c4dbc3
VP		 5888 /* search for a constant op that could let us fold the test */
5889 if ((cstop = search_const(first))) {
5890 if (cstop->op_private & OPpCONST_STRICT)
5891 no_bareword_allowed(cstop);
a2a5de95
NC		 5892 else if ((cstop->op_private & OPpCONST_BARE))
5893 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
71c4dbc3
VP		 5894 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
5895 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
5896 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
5f66b61c 5897 *firstp = NULL;
d6fee5c7
DM		 5898 if (other->op_type == OP_CONST)
5899 other->op_private |= OPpCONST_SHORTCIRCUIT;
eb8433b7
NC		 5900 if (PL_madskills) {
5901 OP *newop = newUNOP(OP_NULL, 0, other);
5902 op_getmad(first, newop, '1');
5903 newop->op_targ = type; /* set "was" field */
5904 return newop;
5905 }
5906 op_free(first);
dd3e51dc
VP		 5907 if (other->op_type == OP_LEAVE)
5908 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
2474a784
FC		 5909 else if (other->op_type == OP_MATCH
5910 || other->op_type == OP_SUBST
bb16bae8 5911 || other->op_type == OP_TRANSR
2474a784
FC		 5912 || other->op_type == OP_TRANS)
5913 /* Mark the op as being unbindable with =~ */
5914 other->op_flags |= OPf_SPECIAL;
cc2ebcd7
FC		 5915 else if (other->op_type == OP_CONST)
5916 other->op_private |= OPpCONST_FOLDED;
3513c740
NT		 5917
5918 other->op_folded = 1;
79072805
LW		 5919 return other;
5920 }
5921 else {
7921d0f2 5922 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
6867be6d 5923 const OP *o2 = other;
7921d0f2
DM		 5924 if ( ! (o2->op_type == OP_LIST
5925 && (( o2 = cUNOPx(o2)->op_first))
5926 && o2->op_type == OP_PUSHMARK
5927 && (( o2 = o2->op_sibling)) )
5928 )
5929 o2 = other;
5930 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
5931 || o2->op_type == OP_PADHV)
5932 && o2->op_private & OPpLVAL_INTRO
a2a5de95 5933 && !(o2->op_private & OPpPAD_STATE))
7921d0f2 5934 {
d1d15184
NC		 5935 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
5936 "Deprecated use of my() in false conditional");
7921d0f2
DM		 5937 }
5938
5f66b61c 5939 *otherp = NULL;
d6fee5c7
DM		 5940 if (first->op_type == OP_CONST)
5941 first->op_private |= OPpCONST_SHORTCIRCUIT;
eb8433b7
NC		 5942 if (PL_madskills) {
5943 first = newUNOP(OP_NULL, 0, first);
5944 op_getmad(other, first, '2');
5945 first->op_targ = type; /* set "was" field */
5946 }
5947 else
5948 op_free(other);
79072805
LW		 5949 return first;
5950 }
5951 }
041457d9
DM		 5952 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
5953 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
59e10468 5954 {
b22e6366
AL		 5955 const OP * const k1 = ((UNOP*)first)->op_first;
5956 const OP * const k2 = k1->op_sibling;
a6006777 5957 OPCODE warnop = 0;
5958 switch (first->op_type)
5959 {
5960 case OP_NULL:
5961 if (k2 && k2->op_type == OP_READLINE
5962 && (k2->op_flags & OPf_STACKED)
1c846c1f 5963 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
72b16652 5964 {
a6006777 5965 warnop = k2->op_type;
72b16652 5966 }
a6006777 5967 break;
5968
5969 case OP_SASSIGN:
68dc0745 5970 if (k1->op_type == OP_READDIR
5971 || k1->op_type == OP_GLOB
72b16652 5972 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
459b64da
HY		 5973 || k1->op_type == OP_EACH
5974 || k1->op_type == OP_AEACH)
72b16652
GS		 5975 {
5976 warnop = ((k1->op_type == OP_NULL)
eb160463 5977 ? (OPCODE)k1->op_targ : k1->op_type);
72b16652 5978 }
a6006777 5979 break;
5980 }
8ebc5c01 5981 if (warnop) {
6867be6d 5982 const line_t oldline = CopLINE(PL_curcop);
502e5101
NC		 5983 /* This ensures that warnings are reported at the first line
5984 of the construction, not the last. */
53a7735b 5985 CopLINE_set(PL_curcop, PL_parser->copline);
9014280d 5986 Perl_warner(aTHX_ packWARN(WARN_MISC),
599cee73 5987 "Value of %s%s can be \"0\"; test with defined()",
22c35a8c 5988 PL_op_desc[warnop],
68dc0745 5989 ((warnop == OP_READLINE || warnop == OP_GLOB)
5990 ? " construct" : "() operator"));
57843af0 5991 CopLINE_set(PL_curcop, oldline);
8ebc5c01 5992 }
a6006777 5993 }
79072805
LW		 5994
5995 if (!other)
5996 return first;
5997
c963b151 5998 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
a0d0e21e
LW		 5999 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
6000
b7dc083c 6001 NewOp(1101, logop, 1, LOGOP);
79072805 6002
eb160463 6003 logop->op_type = (OPCODE)type;
22c35a8c 6004 logop->op_ppaddr = PL_ppaddr[type];
79072805 6005 logop->op_first = first;
585ec06d 6006 logop->op_flags = (U8)(flags | OPf_KIDS);
79072805 6007 logop->op_other = LINKLIST(other);
eb160463 6008 logop->op_private = (U8)(1 | (flags >> 8));
79072805
LW		 6009
6010 /* establish postfix order */
6011 logop->op_next = LINKLIST(first);
6012 first->op_next = (OP*)logop;
6013 first->op_sibling = other;
6014
463d09e6
RGS		 6015 CHECKOP(type,logop);
6016
edbe35ea 6017 o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
11343788 6018 other->op_next = o;
79072805 6019
11343788 6020 return o;
79072805
LW		 6021}
6022
d67eb5f4
Z		 6023/*
6024=for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
6025
6026Constructs, checks, and returns a conditional-expression (C<cond_expr>)
6027op. I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
6028will be set automatically, and, shifted up eight bits, the eight bits of
6029C<op_private>, except that the bit with value 1 is automatically set.
6030I<first> supplies the expression selecting between the two branches,
6031and I<trueop> and I<falseop> supply the branches; they are consumed by
6032this function and become part of the constructed op tree.
6033
6034=cut
6035*/
6036
79072805 6037OP *
864dbfa3 6038Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
79072805 6039{
27da23d5 6040 dVAR;
1a67a97c
SM		 6041 LOGOP *logop;
6042 OP *start;
11343788 6043 OP *o;
71c4dbc3 6044 OP *cstop;
79072805 6045
7918f24d
NC		 6046 PERL_ARGS_ASSERT_NEWCONDOP;
6047
b1cb66bf 6048 if (!falseop)
6049 return newLOGOP(OP_AND, 0, first, trueop);
6050 if (!trueop)
6051 return newLOGOP(OP_OR, 0, first, falseop);
79072805 6052
8990e307 6053 scalarboolean(first);
71c4dbc3 6054 if ((cstop = search_const(first))) {
5b6782b2 6055 /* Left or right arm of the conditional? */
71c4dbc3 6056 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
5b6782b2
NC		 6057 OP *live = left ? trueop : falseop;
6058 OP *const dead = left ? falseop : trueop;
71c4dbc3
VP		 6059 if (cstop->op_private & OPpCONST_BARE &&
6060 cstop->op_private & OPpCONST_STRICT) {
6061 no_bareword_allowed(cstop);
b22e6366 6062 }
5b6782b2
NC		 6063 if (PL_madskills) {
6064 /* This is all dead code when PERL_MAD is not defined. */
6065 live = newUNOP(OP_NULL, 0, live);
6066 op_getmad(first, live, 'C');
6067 op_getmad(dead, live, left ? 'e' : 't');
6068 } else {
6069 op_free(first);
6070 op_free(dead);
79072805 6071 }
ef9da979
FC		 6072 if (live->op_type == OP_LEAVE)
6073 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
2474a784 6074 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
bb16bae8 6075 || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
2474a784
FC		 6076 /* Mark the op as being unbindable with =~ */
6077 live->op_flags |= OPf_SPECIAL;
cc2ebcd7
FC		 6078 else if (live->op_type == OP_CONST)
6079 live->op_private |= OPpCONST_FOLDED;
3513c740 6080 live->op_folded = 1;
5b6782b2 6081 return live;
79072805 6082 }
1a67a97c
SM		 6083 NewOp(1101, logop, 1, LOGOP);
6084 logop->op_type = OP_COND_EXPR;
6085 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
6086 logop->op_first = first;
585ec06d 6087 logop->op_flags = (U8)(flags | OPf_KIDS);
eb160463 6088 logop->op_private = (U8)(1 | (flags >> 8));
1a67a97c
SM		 6089 logop->op_other = LINKLIST(trueop);
6090 logop->op_next = LINKLIST(falseop);
79072805 6091
463d09e6
RGS		 6092 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
6093 logop);
79072805
LW		 6094
6095 /* establish postfix order */
1a67a97c
SM		 6096 start = LINKLIST(first);
6097 first->op_next = (OP*)logop;
79072805 6098
b1cb66bf 6099 first->op_sibling = trueop;
6100 trueop->op_sibling = falseop;
1a67a97c 6101 o = newUNOP(OP_NULL, 0, (OP*)logop);
79072805 6102
1a67a97c 6103 trueop->op_next = falseop->op_next = o;
79072805 6104
1a67a97c 6105 o->op_next = start;
11343788 6106 return o;
79072805
LW		 6107}
6108
d67eb5f4
Z		 6109/*
6110=for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
6111
6112Constructs and returns a C<range> op, with subordinate C<flip> and
6113C<flop> ops. I<flags> gives the eight bits of C<op_flags> for the
6114C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
6115for both the C<flip> and C<range> ops, except that the bit with value
61161 is automatically set. I<left> and I<right> supply the expressions
6117controlling the endpoints of the range; they are consumed by this function
6118and become part of the constructed op tree.
6119
6120=cut
6121*/
6122
79072805 6123OP *
864dbfa3 6124Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
79072805 6125{
27da23d5 6126 dVAR;
1a67a97c 6127 LOGOP *range;
79072805
LW		 6128 OP *flip;
6129 OP *flop;
1a67a97c 6130 OP *leftstart;
11343788 6131 OP *o;
79072805 6132
7918f24d
NC		 6133 PERL_ARGS_ASSERT_NEWRANGE;
6134
1a67a97c 6135 NewOp(1101, range, 1, LOGOP);
79072805 6136
1a67a97c
SM		 6137 range->op_type = OP_RANGE;
6138 range->op_ppaddr = PL_ppaddr[OP_RANGE];
6139 range->op_first = left;
6140 range->op_flags = OPf_KIDS;
6141 leftstart = LINKLIST(left);
6142 range->op_other = LINKLIST(right);
eb160463 6143 range->op_private = (U8)(1 | (flags >> 8));
79072805
LW		 6144
6145 left->op_sibling = right;
6146
1a67a97c
SM		 6147 range->op_next = (OP*)range;
6148 flip = newUNOP(OP_FLIP, flags, (OP*)range);
79072805 6149 flop = newUNOP(OP_FLOP, 0, flip);
11343788 6150 o = newUNOP(OP_NULL, 0, flop);
5983a79d 6151 LINKLIST(flop);
1a67a97c 6152 range->op_next = leftstart;
79072805
LW		 6153
6154 left->op_next = flip;
6155 right->op_next = flop;
6156
1a67a97c
SM		 6157 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
6158 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
ed6116ce 6159 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
79072805
LW		 6160 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
6161
6162 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
6163 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
6164
eb796c7f
GG		 6165 /* check barewords before they might be optimized aways */
6166 if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
6167 no_bareword_allowed(left);
6168 if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
6169 no_bareword_allowed(right);
6170
11343788 6171 flip->op_next = o;
79072805 6172 if (!flip->op_private || !flop->op_private)
5983a79d 6173 LINKLIST(o); /* blow off optimizer unless constant */
79072805 6174
11343788 6175 return o;
79072805
LW		 6176}
6177
d67eb5f4
Z		 6178/*
6179=for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
6180
6181Constructs, checks, and returns an op tree expressing a loop. This is
6182only a loop in the control flow through the op tree; it does not have
6183the heavyweight loop structure that allows exiting the loop by C<last>
6184and suchlike. I<flags> gives the eight bits of C<op_flags> for the
6185top-level op, except that some bits will be set automatically as required.
6186I<expr> supplies the expression controlling loop iteration, and I<block>
6187supplies the body of the loop; they are consumed by this function and
6188become part of the constructed op tree. I<debuggable> is currently
6189unused and should always be 1.
6190
6191=cut
6192*/
6193
79072805 6194OP *
864dbfa3 6195Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
79072805 6196{
97aff369 6197 dVAR;
463ee0b2 6198 OP* listop;
11343788 6199 OP* o;
73d840c0 6200 const bool once = block && block->op_flags & OPf_SPECIAL &&
a0d0e21e 6201 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
46c461b5
AL		 6202
6203 PERL_UNUSED_ARG(debuggable);
93a17b20 6204
463ee0b2
LW		 6205 if (expr) {
6206 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
6207 return block; /* do {} while 0 does once */
114c60ec
BG		 6208 if (expr->op_type == OP_READLINE
6209 || expr->op_type == OP_READDIR
6210 || expr->op_type == OP_GLOB
8ae39f60 6211 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
fb73857a 6212 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
774d564b 6213 expr = newUNOP(OP_DEFINED, 0,
54b9620d 6214 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
55d729e4 6215 } else if (expr->op_flags & OPf_KIDS) {
46c461b5
AL		 6216 const OP * const k1 = ((UNOP*)expr)->op_first;
6217 const OP * const k2 = k1 ? k1->op_sibling : NULL;
55d729e4 6218 switch (expr->op_type) {
1c846c1f 6219 case OP_NULL:
114c60ec 6220 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
55d729e4 6221 && (k2->op_flags & OPf_STACKED)
1c846c1f 6222 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
55d729e4 6223 expr = newUNOP(OP_DEFINED, 0, expr);
1c846c1f 6224 break;
55d729e4
GS		 6225
6226 case OP_SASSIGN:
06dc7ac6 6227 if (k1 && (k1->op_type == OP_READDIR
55d729e4 6228 || k1->op_type == OP_GLOB
6531c3e6 6229 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
459b64da
HY		 6230 || k1->op_type == OP_EACH
6231 || k1->op_type == OP_AEACH))
55d729e4
GS		 6232 expr = newUNOP(OP_DEFINED, 0, expr);
6233 break;
6234 }
774d564b 6235 }
463ee0b2 6236 }
93a17b20 6237
2fcb4757 6238 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
e1548254
RGS		 6239 * op, in listop. This is wrong. [perl #27024] */
6240 if (!block)
6241 block = newOP(OP_NULL, 0);
2fcb4757 6242 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
883ffac3 6243 o = new_logop(OP_AND, 0, &expr, &listop);
463ee0b2 6244
883ffac3
CS		 6245 if (listop)
6246 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
79072805 6247
11343788
MB		 6248 if (once && o != listop)
6249 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
79072805 6250
11343788
MB		 6251 if (o == listop)
6252 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
748a9306 6253
11343788 6254 o->op_flags |= flags;
3ad73efd 6255 o = op_scope(o);
11343788
MB		 6256 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
6257 return o;
79072805
LW		 6258}
6259
d67eb5f4 6260/*
94bf0465 6261=for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
d67eb5f4
Z		 6262
6263Constructs, checks, and returns an op tree expressing a C<while> loop.
6264This is a heavyweight loop, with structure that allows exiting the loop
6265by C<last> and suchlike.
6266
6267I<loop> is an optional preconstructed C<enterloop> op to use in the
6268loop; if it is null then a suitable op will be constructed automatically.
6269I<expr> supplies the loop's controlling expression. I<block> supplies the
6270main body of the loop, and I<cont> optionally supplies a C<continue> block
6271that operates as a second half of the body. All of these optree inputs
6272are consumed by this function and become part of the constructed op tree.
6273
6274I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
6275op and, shifted up eight bits, the eight bits of C<op_private> for
6276the C<leaveloop> op, except that (in both cases) some bits will be set
6277automatically. I<debuggable> is currently unused and should always be 1.
94bf0465 6278I<has_my> can be supplied as true to force the
d67eb5f4
Z		 6279loop body to be enclosed in its own scope.
6280
6281=cut
6282*/
6283
79072805 6284OP *
94bf0465
Z		 6285Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
6286 OP *expr, OP *block, OP *cont, I32 has_my)
79072805 6287{
27da23d5 6288 dVAR;
79072805 6289 OP *redo;
c445ea15 6290 OP *next = NULL;
79072805 6291 OP *listop;
11343788 6292 OP *o;
1ba6ee2b 6293 U8 loopflags = 0;
46c461b5
AL		 6294
6295 PERL_UNUSED_ARG(debuggable);
79072805 6296
2d03de9c 6297 if (expr) {
114c60ec
BG		 6298 if (expr->op_type == OP_READLINE
6299 || expr->op_type == OP_READDIR
6300 || expr->op_type == OP_GLOB
8ae39f60 6301 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
2d03de9c
AL		 6302 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
6303 expr = newUNOP(OP_DEFINED, 0,
6304 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
6305 } else if (expr->op_flags & OPf_KIDS) {
6306 const OP * const k1 = ((UNOP*)expr)->op_first;
6307 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
6308 switch (expr->op_type) {
6309 case OP_NULL:
114c60ec 6310 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
2d03de9c
AL		 6311 && (k2->op_flags & OPf_STACKED)
6312 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
6313 expr = newUNOP(OP_DEFINED, 0, expr);
6314 break;
55d729e4 6315
2d03de9c 6316 case OP_SASSIGN:
72c8de1a 6317 if (k1 && (k1->op_type == OP_READDIR
2d03de9c
AL		 6318 || k1->op_type == OP_GLOB
6319 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
459b64da
HY		 6320 || k1->op_type == OP_EACH
6321 || k1->op_type == OP_AEACH))
2d03de9c
AL		 6322 expr = newUNOP(OP_DEFINED, 0, expr);
6323 break;
6324 }
55d729e4 6325 }
748a9306 6326 }
79072805
LW		 6327
6328 if (!block)
6329 block = newOP(OP_NULL, 0);
a034e688 6330 else if (cont || has_my) {
3ad73efd 6331 block = op_scope(block);
87246558 6332 }
79072805 6333
1ba6ee2b 6334 if (cont) {
79072805 6335 next = LINKLIST(cont);
1ba6ee2b 6336 }
fb73857a 6337 if (expr) {
551405c4 6338 OP * const unstack = newOP(OP_UNSTACK, 0);
85538317
GS		 6339 if (!next)
6340 next = unstack;
2fcb4757 6341 cont = op_append_elem(OP_LINESEQ, cont, unstack);
fb73857a 6342 }
79072805 6343
ce3e5c45 6344 assert(block);
2fcb4757 6345 listop = op_append_list(OP_LINESEQ, block, cont);
ce3e5c45 6346 assert(listop);
79072805
LW		 6347 redo = LINKLIST(listop);
6348
6349 if (expr) {
883ffac3
CS		 6350 scalar(listop);
6351 o = new_logop(OP_AND, 0, &expr, &listop);
11343788 6352 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
463ee0b2 6353 op_free((OP*)loop);
317f3b66 6354 return expr; /* listop already freed by new_logop */
463ee0b2 6355 }
883ffac3 6356 if (listop)
497b47a8 6357 ((LISTOP*)listop)->op_last->op_next =
883ffac3 6358 (o == listop ? redo : LINKLIST(o));
79072805
LW		 6359 }
6360 else
11343788 6361 o = listop;
79072805
LW		 6362
6363 if (!loop) {
b7dc083c 6364 NewOp(1101,loop,1,LOOP);
79072805 6365 loop->op_type = OP_ENTERLOOP;
22c35a8c 6366 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
79072805
LW		 6367 loop->op_private = 0;
6368 loop->op_next = (OP*)loop;
6369 }
6370
11343788 6371 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
79072805
LW		 6372
6373 loop->op_redoop = redo;
11343788 6374 loop->op_lastop = o;
1ba6ee2b 6375 o->op_private |= loopflags;
79072805
LW		 6376
6377 if (next)
6378 loop->op_nextop = next;
6379 else
11343788 6380 loop->op_nextop = o;
79072805 6381
11343788
MB		 6382 o->op_flags |= flags;
6383 o->op_private |= (flags >> 8);
6384 return o;
79072805
LW		 6385}
6386
d67eb5f4 6387/*
94bf0465 6388=for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
d67eb5f4
Z		 6389
6390Constructs, checks, and returns an op tree expressing a C<foreach>
6391loop (iteration through a list of values). This is a heavyweight loop,
6392with structure that allows exiting the loop by C<last> and suchlike.
6393
6394I<sv> optionally supplies the variable that will be aliased to each
6395item in turn; if null, it defaults to C<$_> (either lexical or global).
6396I<expr> supplies the list of values to iterate over. I<block> supplies
6397the main body of the loop, and I<cont> optionally supplies a C<continue>
6398block that operates as a second half of the body. All of these optree
6399inputs are consumed by this function and become part of the constructed
6400op tree.
6401
6402I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
6403op and, shifted up eight bits, the eight bits of C<op_private> for
6404the C<leaveloop> op, except that (in both cases) some bits will be set
94bf0465 6405automatically.
d67eb5f4
Z		 6406
6407=cut
6408*/
6409
79072805 6410OP *
94bf0465 6411Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
79072805 6412{
27da23d5 6413 dVAR;
79072805 6414 LOOP *loop;
fb73857a 6415 OP *wop;
4bbc6d12 6416 PADOFFSET padoff = 0;
4633a7c4 6417 I32 iterflags = 0;
241416b8 6418 I32 iterpflags = 0;
d4c19fe8 6419 OP *madsv = NULL;
79072805 6420
7918f24d
NC		 6421 PERL_ARGS_ASSERT_NEWFOROP;
6422
79072805 6423 if (sv) {
85e6fe83 6424 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
241416b8 6425 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
748a9306 6426 sv->op_type = OP_RV2GV;
22c35a8c 6427 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
0be9a6bb
RH		 6428
6429 /* The op_type check is needed to prevent a possible segfault
6430 * if the loop variable is undeclared and 'strict vars' is in
6431 * effect. This is illegal but is nonetheless parsed, so we
6432 * may reach this point with an OP_CONST where we're expecting
6433 * an OP_GV.
6434 */
6435 if (cUNOPx(sv)->op_first->op_type == OP_GV
6436 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
0d863452 6437 iterpflags |= OPpITER_DEF;
79072805 6438 }
85e6fe83 6439 else if (sv->op_type == OP_PADSV) { /* private variable */
241416b8 6440 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
85e6fe83 6441 padoff = sv->op_targ;
eb8433b7
NC		 6442 if (PL_madskills)
6443 madsv = sv;
6444 else {
6445 sv->op_targ = 0;
6446 op_free(sv);
6447 }
5f66b61c 6448 sv = NULL;
85e6fe83 6449 }
79072805 6450 else
cea2e8a9 6451 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
f8503592
NC		 6452 if (padoff) {
6453 SV *const namesv = PAD_COMPNAME_SV(padoff);
6454 STRLEN len;
6455 const char *const name = SvPV_const(namesv, len);
6456
6457 if (len == 2 && name[0] == '$' && name[1] == '_')
6458 iterpflags |= OPpITER_DEF;
6459 }
79072805
LW		 6460 }
6461 else {
cc76b5cc 6462 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
00b1698f 6463 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
aabe9514
RGS		 6464 sv = newGVOP(OP_GV, 0, PL_defgv);
6465 }
6466 else {
6467 padoff = offset;
aabe9514 6468 }
0d863452 6469 iterpflags |= OPpITER_DEF;
79072805 6470 }
5f05dabc 6471 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3ad73efd 6472 expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4633a7c4
LW		 6473 iterflags |= OPf_STACKED;
6474 }
89ea2908
GA		 6475 else if (expr->op_type == OP_NULL &&
6476 (expr->op_flags & OPf_KIDS) &&
6477 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
6478 {
6479 /* Basically turn for($x..$y) into the same as for($x,$y), but we
6480 * set the STACKED flag to indicate that these values are to be
08bf00be 6481 * treated as min/max values by 'pp_enteriter'.
89ea2908 6482 */
d4c19fe8 6483 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
551405c4 6484 LOGOP* const range = (LOGOP*) flip->op_first;
66a1b24b
AL		 6485 OP* const left = range->op_first;
6486 OP* const right = left->op_sibling;
5152d7c7 6487 LISTOP* listop;
89ea2908
GA		 6488
6489 range->op_flags &= ~OPf_KIDS;
5f66b61c 6490 range->op_first = NULL;
89ea2908 6491
5152d7c7 6492 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
1a67a97c
SM		 6493 listop->op_first->op_next = range->op_next;
6494 left->op_next = range->op_other;
5152d7c7
GS		 6495 right->op_next = (OP*)listop;
6496 listop->op_next = listop->op_first;
89ea2908 6497
eb8433b7
NC		 6498#ifdef PERL_MAD
6499 op_getmad(expr,(OP*)listop,'O');
6500#else
89ea2908 6501 op_free(expr);
eb8433b7 6502#endif
5152d7c7 6503 expr = (OP*)(listop);
93c66552 6504 op_null(expr);
89ea2908
GA		 6505 iterflags |= OPf_STACKED;
6506 }
6507 else {
3ad73efd 6508 expr = op_lvalue(force_list(expr), OP_GREPSTART);
89ea2908
GA		 6509 }
6510
4633a7c4 6511 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
2fcb4757 6512 op_append_elem(OP_LIST, expr, scalar(sv))));
85e6fe83 6513 assert(!loop->op_next);
241416b8 6514 /* for my $x () sets OPpLVAL_INTRO;
14f338dc 6515 * for our $x () sets OPpOUR_INTRO */
c5661c80 6516 loop->op_private = (U8)iterpflags;
b448305b
FC		 6517 if (loop->op_slabbed
6518 && DIFF(loop, OpSLOT(loop)->opslot_next)
8be227ab 6519 < SIZE_TO_PSIZE(sizeof(LOOP)))
155aba94
GS		 6520 {
6521 LOOP *tmp;
6522 NewOp(1234,tmp,1,LOOP);
bd5f3bc4 6523 Copy(loop,tmp,1,LISTOP);
bfafaa29 6524 S_op_destroy(aTHX_ (OP*)loop);
155aba94
GS		 6525 loop = tmp;
6526 }
b448305b
FC		 6527 else if (!loop->op_slabbed)
6528 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
85e6fe83 6529 loop->op_targ = padoff;
94bf0465 6530 wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
eb8433b7
NC		 6531 if (madsv)
6532 op_getmad(madsv, (OP*)loop, 'v');
eae48c89 6533 return wop;
79072805
LW		 6534}
6535
d67eb5f4
Z		 6536/*
6537=for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
6538
6539Constructs, checks, and returns a loop-exiting op (such as C<goto>
6540or C<last>). I<type> is the opcode. I<label> supplies the parameter
6541determining the target of the op; it is consumed by this function and
d001e19d 6542becomes part of the constructed op tree.
d67eb5f4
Z		 6543
6544=cut
6545*/
6546
8990e307 6547OP*
864dbfa3 6548Perl_newLOOPEX(pTHX_ I32 type, OP *label)
8990e307 6549{
97aff369 6550 dVAR;
1ec4f607 6551 OP *o = NULL;
2d8e6c8d 6552
7918f24d
NC		 6553 PERL_ARGS_ASSERT_NEWLOOPEX;
6554
e69777c1
GG		 6555 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
6556
3532f34a 6557 if (type != OP_GOTO) {
cdaebead 6558 /* "last()" means "last" */
1f039d60 6559 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
cdaebead 6560 o = newOP(type, OPf_SPECIAL);
cdaebead 6561 }
8990e307
LW		 6562 }
6563 else {
e3aba57a
RGS		 6564 /* Check whether it's going to be a goto &function */
6565 if (label->op_type == OP_ENTERSUB
6566 && !(label->op_flags & OPf_STACKED))
3ad73efd 6567 label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
1f039d60
FC		 6568 }
6569
6570 /* Check for a constant argument */
6571 if (label->op_type == OP_CONST) {
3532f34a
FC		 6572 SV * const sv = ((SVOP *)label)->op_sv;
6573 STRLEN l;
6574 const char *s = SvPV_const(sv,l);
1f039d60
FC		 6575 if (l == strlen(s)) {
6576 o = newPVOP(type,
6577 SvUTF8(((SVOP*)label)->op_sv),
6578 savesharedpv(
6579 SvPV_nolen_const(((SVOP*)label)->op_sv)));
1ec4f607
FC		 6580 }
6581 }
6582
6583 /* If we have already created an op, we do not need the label. */
6584 if (o)
1f039d60
FC		 6585#ifdef PERL_MAD
6586 op_getmad(label,o,'L');
6587#else
6588 op_free(label);
6589#endif
1ec4f607 6590 else o = newUNOP(type, OPf_STACKED, label);
1f039d60 6591
3280af22 6592 PL_hints |= HINT_BLOCK_SCOPE;
11343788 6593 return o;
8990e307
LW		 6594}
6595
0d863452
RH		 6596/* if the condition is a literal array or hash
6597 (or @{ ... } etc), make a reference to it.
6598 */
6599STATIC OP *
6600S_ref_array_or_hash(pTHX_ OP *cond)
6601{
6602 if (cond
6603 && (cond->op_type == OP_RV2AV
6604 || cond->op_type == OP_PADAV
6605 || cond->op_type == OP_RV2HV
6606 || cond->op_type == OP_PADHV))
6607
3ad73efd 6608 return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
0d863452 6609
329a333e
DL		 6610 else if(cond
6611 && (cond->op_type == OP_ASLICE
6612 || cond->op_type == OP_HSLICE)) {
6613
6614 /* anonlist now needs a list from this op, was previously used in
6615 * scalar context */
6616 cond->op_flags |= ~(OPf_WANT_SCALAR | OPf_REF);
6617 cond->op_flags |= OPf_WANT_LIST;
6618
3ad73efd 6619 return newANONLIST(op_lvalue(cond, OP_ANONLIST));
329a333e
DL		 6620 }
6621
0d863452
RH		 6622 else
6623 return cond;
6624}
6625
6626/* These construct the optree fragments representing given()
6627 and when() blocks.
6628
6629 entergiven and enterwhen are LOGOPs; the op_other pointer
6630 points up to the associated leave op. We need this so we
6631 can put it in the context and make break/continue work.
6632 (Also, of course, pp_enterwhen will jump straight to
6633 op_other if the match fails.)
6634 */
6635
4136a0f7 6636STATIC OP *
0d863452
RH		 6637S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
6638 I32 enter_opcode, I32 leave_opcode,
6639 PADOFFSET entertarg)
6640{
97aff369 6641 dVAR;
0d863452
RH		 6642 LOGOP *enterop;
6643 OP *o;
6644
7918f24d
NC		 6645 PERL_ARGS_ASSERT_NEWGIVWHENOP;
6646
0d863452 6647 NewOp(1101, enterop, 1, LOGOP);
61a59f30 6648 enterop->op_type = (Optype)enter_opcode;
0d863452
RH		 6649 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
6650 enterop->op_flags = (U8) OPf_KIDS;
6651 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
6652 enterop->op_private = 0;
6653
6654 o = newUNOP(leave_opcode, 0, (OP *) enterop);
6655
6656 if (cond) {
6657 enterop->op_first = scalar(cond);
6658 cond->op_sibling = block;
6659
6660 o->op_next = LINKLIST(cond);
6661 cond->op_next = (OP *) enterop;
6662 }
6663 else {
6664 /* This is a default {} block */
6665 enterop->op_first = block;
6666 enterop->op_flags |= OPf_SPECIAL;
fc7debfb 6667 o ->op_flags |= OPf_SPECIAL;
0d863452
RH		 6668
6669 o->op_next = (OP *) enterop;
6670 }
6671
6672 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
6673 entergiven and enterwhen both
6674 use ck_null() */
6675
6676 enterop->op_next = LINKLIST(block);
6677 block->op_next = enterop->op_other = o;
6678
6679 return o;
6680}
6681
6682/* Does this look like a boolean operation? For these purposes
6683 a boolean operation is:
6684 - a subroutine call [*]
6685 - a logical connective
6686 - a comparison operator
6687 - a filetest operator, with the exception of -s -M -A -C
6688 - defined(), exists() or eof()
6689 - /$re/ or $foo =~ /$re/
6690
6691 [*] possibly surprising
6692 */
4136a0f7 6693STATIC bool
ef519e13 6694S_looks_like_bool(pTHX_ const OP *o)
0d863452 6695{
97aff369 6696 dVAR;
7918f24d
NC		 6697
6698 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
6699
0d863452
RH		 6700 switch(o->op_type) {
6701 case OP_OR:
f92e1a16 6702 case OP_DOR:
0d863452
RH		 6703 return looks_like_bool(cLOGOPo->op_first);
6704
6705 case OP_AND:
6706 return (
6707 looks_like_bool(cLOGOPo->op_first)
6708 && looks_like_bool(cLOGOPo->op_first->op_sibling));
6709
1e1d4b91 6710 case OP_NULL:
08fe1c44 6711 case OP_SCALAR:
1e1d4b91
JJ		 6712 return (
6713 o->op_flags & OPf_KIDS
6714 && looks_like_bool(cUNOPo->op_first));
6715
0d863452
RH		 6716 case OP_ENTERSUB:
6717
6718 case OP_NOT: case OP_XOR:
0d863452
RH		 6719
6720 case OP_EQ: case OP_NE: case OP_LT:
6721 case OP_GT: case OP_LE: case OP_GE:
6722
6723 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
6724 case OP_I_GT: case OP_I_LE: case OP_I_GE:
6725
6726 case OP_SEQ: case OP_SNE: case OP_SLT:
6727 case OP_SGT: case OP_SLE: case OP_SGE:
6728
6729 case OP_SMARTMATCH:
6730
6731 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
6732 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
6733 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
6734 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
6735 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
6736 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
6737 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
6738 case OP_FTTEXT: case OP_FTBINARY:
6739
6740 case OP_DEFINED: case OP_EXISTS:
6741 case OP_MATCH: case OP_EOF:
6742
f118ea0d
RGS		 6743 case OP_FLOP:
6744
0d863452
RH		 6745 return TRUE;
6746
6747 case OP_CONST:
6748 /* Detect comparisons that have been optimized away */
6749 if (cSVOPo->op_sv == &PL_sv_yes
6750 || cSVOPo->op_sv == &PL_sv_no)
6751
6752 return TRUE;
6e03d743
RGS		 6753 else
6754 return FALSE;
6e03d743 6755
0d863452
RH		 6756 /* FALL THROUGH */
6757 default:
6758 return FALSE;
6759 }
6760}
6761
d67eb5f4
Z		 6762/*
6763=for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
6764
6765Constructs, checks, and returns an op tree expressing a C<given> block.
6766I<cond> supplies the expression that will be locally assigned to a lexical
6767variable, and I<block> supplies the body of the C<given> construct; they
6768are consumed by this function and become part of the constructed op tree.
6769I<defsv_off> is the pad offset of the scalar lexical variable that will
a8bd1c84 6770be affected. If it is 0, the global $_ will be used.
d67eb5f4
Z		 6771
6772=cut
6773*/
6774
0d863452
RH		 6775OP *
6776Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
6777{
97aff369 6778 dVAR;
7918f24d 6779 PERL_ARGS_ASSERT_NEWGIVENOP;
0d863452
RH		 6780 return newGIVWHENOP(
6781 ref_array_or_hash(cond),
6782 block,
6783 OP_ENTERGIVEN, OP_LEAVEGIVEN,
6784 defsv_off);
6785}
6786
d67eb5f4
Z		 6787/*
6788=for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
6789
6790Constructs, checks, and returns an op tree expressing a C<when> block.
6791I<cond> supplies the test expression, and I<block> supplies the block
6792that will be executed if the test evaluates to true; they are consumed
6793by this function and become part of the constructed op tree. I<cond>
6794will be interpreted DWIMically, often as a comparison against C<$_>,
6795and may be null to generate a C<default> block.
6796
6797=cut
6798*/
6799
0d863452
RH		 6800OP *
6801Perl_newWHENOP(pTHX_ OP *cond, OP *block)
6802{
ef519e13 6803 const bool cond_llb = (!cond || looks_like_bool(cond));
0d863452
RH		 6804 OP *cond_op;
6805
7918f24d
NC		 6806 PERL_ARGS_ASSERT_NEWWHENOP;
6807
0d863452
RH		 6808 if (cond_llb)
6809 cond_op = cond;
6810 else {
6811 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
6812 newDEFSVOP(),
6813 scalar(ref_array_or_hash(cond)));
6814 }
6815
c08f093b 6816 return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
0d863452
RH		 6817}
6818
3fe9a6f1 6819void
dab1c735
BF		 6820Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
6821 const STRLEN len, const U32 flags)
cbf82dd0 6822{
7a2f0b06
PM		 6823 SV *name = NULL, *msg;
6824 const char * cvp = SvROK(cv) ? "" : CvPROTO(cv);
6825 STRLEN clen = CvPROTOLEN(cv), plen = len;
8fa6a409 6826
dab1c735 6827 PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
8fa6a409 6828
38d27505 6829 if (p == NULL && cvp == NULL)
7a2f0b06 6830 return;
3fe9a6f1 6831
38d27505 6832 if (!ckWARN_d(WARN_PROTOTYPE))
7a2f0b06
PM		 6833 return;
6834
6835 if (p && cvp) {
6836 p = S_strip_spaces(aTHX_ p, &plen);
6837 cvp = S_strip_spaces(aTHX_ cvp, &clen);
6838 if ((flags & SVf_UTF8) == SvUTF8(cv)) {
6839 if (plen == clen && memEQ(cvp, p, plen))
6840 return;
6841 } else {
6842 if (flags & SVf_UTF8) {
6843 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
6844 return;
6845 }
6846 else {
6847 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
6848 return;
6849 }
105ff74c 6850 }
3fe9a6f1 6851 }
7a2f0b06
PM		 6852
6853 msg = sv_newmortal();
6854
6855 if (gv)
6856 {
6857 if (isGV(gv))
6858 gv_efullname3(name = sv_newmortal(), gv, NULL);
6859 else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
6860 name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
6861 else name = (SV *)gv;
6862 }
6863 sv_setpvs(msg, "Prototype mismatch:");
6864 if (name)
6865 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
6866 if (cvp)
b17a0679
FC		 6867 Perl_sv_catpvf(aTHX_ msg, " (%"UTF8f")",
6868 UTF8fARG(SvUTF8(cv),clen,cvp)
7a2f0b06
PM		 6869 );
6870 else
6871 sv_catpvs(msg, ": none");
6872 sv_catpvs(msg, " vs ");
6873 if (p)
b17a0679 6874 Perl_sv_catpvf(aTHX_ msg, "(%"UTF8f")", UTF8fARG(flags & SVf_UTF8,len,p));
7a2f0b06
PM		 6875 else
6876 sv_catpvs(msg, "none");
6877 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
3fe9a6f1 6878}
6879
35f1c1c7 6880static void const_sv_xsub(pTHX_ CV* cv);
6f1b3ab0 6881static void const_av_xsub(pTHX_ CV* cv);
35f1c1c7 6882
beab0874 6883/*
ccfc67b7
JH		 6884
6885=head1 Optree Manipulation Functions
6886
beab0874
JT		 6887=for apidoc cv_const_sv
6888
6889If C<cv> is a constant sub eligible for inlining. returns the constant
6890value returned by the sub. Otherwise, returns NULL.
6891
6892Constant subs can be created with C<newCONSTSUB> or as described in
6893L<perlsub/"Constant Functions">.
6894
6895=cut
6896*/
760ac839 6897SV *
d45f5b30 6898Perl_cv_const_sv(pTHX_ const CV *const cv)
760ac839 6899{
6f1b3ab0 6900 SV *sv;
96a5add6 6901 PERL_UNUSED_CONTEXT;
5069cc75
NC		 6902 if (!cv)
6903 return NULL;
6904 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
6905 return NULL;
6f1b3ab0
FC		 6906 sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
6907 if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
6908 return sv;
fe5e78ed 6909}
760ac839 6910
f815dc14
FC		 6911SV *
6912Perl_cv_const_sv_or_av(pTHX_ const CV * const cv)
6913{
6914 PERL_UNUSED_CONTEXT;
6915 if (!cv)
6916 return NULL;
6917 assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
6918 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
6919}
6920
b5c19bd7 6921/* op_const_sv: examine an optree to determine whether it's in-lineable.
b5c19bd7
DM		 6922 */
6923
fe5e78ed 6924SV *
137da2b0 6925Perl_op_const_sv(pTHX_ const OP *o)
fe5e78ed 6926{
97aff369 6927 dVAR;
a0714e2c 6928 SV *sv = NULL;
fe5e78ed 6929
c631f32b
GG		 6930 if (PL_madskills)
6931 return NULL;
6932
0f79a09d 6933 if (!o)
a0714e2c 6934 return NULL;
1c846c1f
NIS		 6935
6936 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
fe5e78ed
GS		 6937 o = cLISTOPo->op_first->op_sibling;
6938
6939 for (; o; o = o->op_next) {
890ce7af 6940 const OPCODE type = o->op_type;
fe5e78ed 6941
1c846c1f 6942 if (sv && o->op_next == o)
fe5e78ed 6943 return sv;
e576b457 6944 if (o->op_next != o) {
dbe92b04
FC		 6945 if (type == OP_NEXTSTATE
6946 || (type == OP_NULL && !(o->op_flags & OPf_KIDS))
6947 || type == OP_PUSHMARK)
e576b457
JT		 6948 continue;
6949 if (type == OP_DBSTATE)
6950 continue;
6951 }
54310121 6952 if (type == OP_LEAVESUB || type == OP_RETURN)
6953 break;
6954 if (sv)
a0714e2c 6955 return NULL;
7766f137 6956 if (type == OP_CONST && cSVOPo->op_sv)
5dc0d613 6957 sv = cSVOPo->op_sv;
b5c19bd7 6958 else {
a0714e2c 6959 return NULL;
b5c19bd7 6960 }
760ac839
LW		 6961 }
6962 return sv;
6963}
6964
2b141370
FC		 6965static bool
6966S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
6967 PADNAME * const name, SV ** const const_svp)
6968{
6969 assert (cv);
6970 assert (o || name);
6971 assert (const_svp);
6972 if ((!block
6973#ifdef PERL_MAD
6974 || block->op_type == OP_NULL
6975#endif
6976 )) {
6977 if (CvFLAGS(PL_compcv)) {
6978 /* might have had built-in attrs applied */
6979 const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
6980 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
6981 && ckWARN(WARN_MISC))
6982 {
6983 /* protect against fatal warnings leaking compcv */
6984 SAVEFREESV(PL_compcv);
6985 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
6986 SvREFCNT_inc_simple_void_NN(PL_compcv);
6987 }
6988 CvFLAGS(cv) |=
6989 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
6990 & ~(CVf_LVALUE * pureperl));
6991 }
6992 return FALSE;
6993 }
6994
6995 /* redundant check for speed: */
6996 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
6997 const line_t oldline = CopLINE(PL_curcop);
6998 SV *namesv = o
6999 ? cSVOPo->op_sv
7000 : sv_2mortal(newSVpvn_utf8(
7001 PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name)
7002 ));
7003 if (PL_parser && PL_parser->copline != NOLINE)
7004 /* This ensures that warnings are reported at the first
7005 line of a redefinition, not the last. */
7006 CopLINE_set(PL_curcop, PL_parser->copline);
d0761305
FC		 7007 /* protect against fatal warnings leaking compcv */
7008 SAVEFREESV(PL_compcv);
2b141370 7009 report_redefined_cv(namesv, cv, const_svp);
d0761305 7010 SvREFCNT_inc_simple_void_NN(PL_compcv);
2b141370
FC		 7011 CopLINE_set(PL_curcop, oldline);
7012 }
7013#ifdef PERL_MAD
7014 if (!PL_minus_c) /* keep old one around for madskills */
7015#endif
7016 {
7017 /* (PL_madskills unset in used file.) */
7018 SvREFCNT_dec(cv);
7019 }
7020 return TRUE;
7021}
7022
50278755 7023CV *
09bef843
SB		 7024Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
7025{
50278755 7026 dVAR;
50278755
FC		 7027 CV **spot;
7028 SV **svspot;
7029 const char *ps;
7030 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
7031 U32 ps_utf8 = 0;
5aaab254
KW		 7032 CV *cv = NULL;
7033 CV *compcv = PL_compcv;
50278755 7034 SV *const_sv;
50278755 7035 PADNAME *name;
10342479
FC		 7036 PADOFFSET pax = o->op_targ;
7037 CV *outcv = CvOUTSIDE(PL_compcv);
a70c2d56 7038 CV *clonee = NULL;
6d5c2147 7039 HEK *hek = NULL;
a70c2d56 7040 bool reusable = FALSE;
50278755
FC		 7041
7042 PERL_ARGS_ASSERT_NEWMYSUB;
7043
10342479
FC		 7044 /* Find the pad slot for storing the new sub.
7045 We cannot use PL_comppad, as it is the pad owned by the new sub. We
7046 need to look in CvOUTSIDE and find the pad belonging to the enclos-
7047 ing sub. And then we need to dig deeper if this is a lexical from
7048 outside, as in:
7049 my sub foo; sub { sub foo { } }
7050 */
7051 redo:
7052 name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
7053 if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
7054 pax = PARENT_PAD_INDEX(name);
7055 outcv = CvOUTSIDE(outcv);
7056 assert(outcv);
7057 goto redo;
7058 }
2435fbd5 7059 svspot =
a70c2d56
FC		 7060 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
7061 [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
50278755
FC		 7062 spot = (CV **)svspot;
7063
7064 if (proto) {
7065 assert(proto->op_type == OP_CONST);
7066 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
7067 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
7068 }
7069 else
7070 ps = NULL;
7071
50278755 7072 if (!PL_madskills) {
50278755
FC		 7073 if (proto)
7074 SAVEFREEOP(proto);
7075 if (attrs)
7076 SAVEFREEOP(attrs);
7077 }
7078
b0305fa3 7079 if (PL_parser && PL_parser->error_count) {
50278755 7080 op_free(block);
8ca8859f
FC		 7081 SvREFCNT_dec(PL_compcv);
7082 PL_compcv = 0;
50278755
FC		 7083 goto done;
7084 }
7085
a70c2d56
FC		 7086 if (CvDEPTH(outcv) && CvCLONE(compcv)) {
7087 cv = *spot;
7088 svspot = (SV **)(spot = &clonee);
7089 }
7090 else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
6d5c2147
FC		 7091 cv = *spot;
7092 else {
7093 MAGIC *mg;
81df9f6f
FC		 7094 SvUPGRADE(name, SVt_PVMG);
7095 mg = mg_find(name, PERL_MAGIC_proto);
6d5c2147 7096 assert (SvTYPE(*spot) == SVt_PVCV);
6d5c2147
FC		 7097 if (CvNAMED(*spot))
7098 hek = CvNAME_HEK(*spot);
7099 else {
2e800d79 7100 CvNAME_HEK_set(*spot, hek =
6d5c2147
FC		 7101 share_hek(
7102 PadnamePV(name)+1,
7103 PadnameLEN(name)-1 * (PadnameUTF8(name) ? -1 : 1), 0
2e800d79
FC		 7104 )
7105 );
6d5c2147 7106 }
6d5c2147
FC		 7107 if (mg) {
7108 assert(mg->mg_obj);
7109 cv = (CV *)mg->mg_obj;
7110 }
7111 else {
81df9f6f
FC		 7112 sv_magic(name, &PL_sv_undef, PERL_MAGIC_proto, NULL, 0);
7113 mg = mg_find(name, PERL_MAGIC_proto);
6d5c2147
FC		 7114 }
7115 spot = (CV **)(svspot = &mg->mg_obj);
50278755
FC		 7116 }
7117
50278755
FC		 7118 if (!block || !ps || *ps || attrs
7119 || (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS)
7120#ifdef PERL_MAD
7121 || block->op_type == OP_NULL
eb8433b7 7122#endif
50278755
FC		 7123 )
7124 const_sv = NULL;
7125 else
137da2b0 7126 const_sv = op_const_sv(block);
eb8433b7 7127
50278755
FC		 7128 if (cv) {
7129 const bool exists = CvROOT(cv) || CvXSUB(cv);
46c461b5 7130
50278755
FC		 7131 /* if the subroutine doesn't exist and wasn't pre-declared
7132 * with a prototype, assume it will be AUTOLOADed,
7133 * skipping the prototype check
7134 */
7135 if (exists || SvPOK(cv))
2435fbd5 7136 cv_ckproto_len_flags(cv, (GV *)name, ps, ps_len, ps_utf8);
50278755
FC		 7137 /* already defined? */
7138 if (exists) {
2b141370
FC		 7139 if (S_already_defined(aTHX_ cv, block, NULL, name, &const_sv))
7140 cv = NULL;
7141 else {
50278755
FC		 7142 if (attrs) goto attrs;
7143 /* just a "sub foo;" when &foo is already defined */
7144 SAVEFREESV(compcv);
7145 goto done;
7146 }
50278755 7147 }
a70c2d56
FC		 7148 else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
7149 cv = NULL;
7150 reusable = TRUE;
7151 }
50278755
FC		 7152 }
7153 if (const_sv) {
7154 SvREFCNT_inc_simple_void_NN(const_sv);
d2440203 7155 SvFLAGS(const_sv) = (SvFLAGS(const_sv) & ~SVs_PADMY) | SVs_PADTMP;
50278755
FC		 7156 if (cv) {
7157 assert(!CvROOT(cv) && !CvCONST(cv));
7158 cv_forget_slab(cv);
7159 }
7160 else {
7161 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
7162 CvFILE_set_from_cop(cv, PL_curcop);
7163 CvSTASH_set(cv, PL_curstash);
7164 *spot = cv;
7165 }
7166 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
7167 CvXSUBANY(cv).any_ptr = const_sv;
7168 CvXSUB(cv) = const_sv_xsub;
7169 CvCONST_on(cv);
7170 CvISXSUB_on(cv);
7171 if (PL_madskills)
7172 goto install_block;
7173 op_free(block);
7174 SvREFCNT_dec(compcv);
2435fbd5 7175 PL_compcv = NULL;
83a72a15 7176 goto setname;
50278755 7177 }
1f122f9b
FC		 7178 /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
7179 determine whether this sub definition is in the same scope as its
7180 declaration. If this sub definition is inside an inner named pack-
7181 age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
7182 the package sub. So check PadnameOUTER(name) too.
7183 */
7184 if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
10342479
FC		 7185 assert(!CvWEAKOUTSIDE(compcv));
7186 SvREFCNT_dec(CvOUTSIDE(compcv));
7187 CvWEAKOUTSIDE_on(compcv);
7188 }
7189 /* XXX else do we have a circular reference? */
50278755
FC		 7190 if (cv) { /* must reuse cv in case stub is referenced elsewhere */
7191 /* transfer PL_compcv to cv */
7192 if (block
eb8433b7 7193#ifdef PERL_MAD
50278755 7194 && block->op_type != OP_NULL
eb8433b7 7195#endif
50278755 7196 ) {
6d5c2147
FC		 7197 cv_flags_t preserved_flags =
7198 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
50278755
FC		 7199 PADLIST *const temp_padl = CvPADLIST(cv);
7200 CV *const temp_cv = CvOUTSIDE(cv);
10342479
FC		 7201 const cv_flags_t other_flags =
7202 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
50278755
FC		 7203 OP * const cvstart = CvSTART(cv);
7204
50278755
FC		 7205 SvPOK_off(cv);
7206 CvFLAGS(cv) =
6d5c2147 7207 CvFLAGS(compcv) | preserved_flags;
50278755
FC		 7208 CvOUTSIDE(cv) = CvOUTSIDE(compcv);
7209 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
7210 CvPADLIST(cv) = CvPADLIST(compcv);
7211 CvOUTSIDE(compcv) = temp_cv;
7212 CvPADLIST(compcv) = temp_padl;
7213 CvSTART(cv) = CvSTART(compcv);
7214 CvSTART(compcv) = cvstart;
10342479
FC		 7215 CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
7216 CvFLAGS(compcv) |= other_flags;
50278755
FC		 7217
7218 if (CvFILE(cv) && CvDYNFILE(cv)) {
7219 Safefree(CvFILE(cv));
7220 }
7221
7222 /* inner references to compcv must be fixed up ... */
7223 pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
7224 if (PERLDB_INTER)/* Advice debugger on the new sub. */
7225 ++PL_sub_generation;
7226 }
7227 else {
7228 /* Might have had built-in attributes applied -- propagate them. */
7229 CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
7230 }
7231 /* ... before we throw it away */
7232 SvREFCNT_dec(compcv);
2435fbd5 7233 PL_compcv = compcv = cv;
50278755
FC		 7234 }
7235 else {
7236 cv = compcv;
7237 *spot = cv;
6d5c2147 7238 }
83a72a15 7239 setname:
6d5c2147 7240 if (!CvNAME_HEK(cv)) {
2e800d79 7241 CvNAME_HEK_set(cv,
6d5c2147
FC		 7242 hek
7243 ? share_hek_hek(hek)
7244 : share_hek(PadnamePV(name)+1,
2435fbd5 7245 PadnameLEN(name)-1 * (PadnameUTF8(name) ? -1 : 1),
2e800d79
FC		 7246 0)
7247 );
50278755 7248 }
83a72a15
FC		 7249 if (const_sv) goto clone;
7250
50278755
FC		 7251 CvFILE_set_from_cop(cv, PL_curcop);
7252 CvSTASH_set(cv, PL_curstash);
7253
7254 if (ps) {
7255 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
7256 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
7257 }
7258
7259 install_block:
7260 if (!block)
7261 goto attrs;
7262
7263 /* If we assign an optree to a PVCV, then we've defined a subroutine that
7264 the debugger could be able to set a breakpoint in, so signal to
7265 pp_entereval that it should not throw away any saved lines at scope
7266 exit. */
7267
7268 PL_breakable_sub_gen++;
7269 /* This makes sub {}; work as expected. */
7270 if (block->op_type == OP_STUB) {
7271 OP* const newblock = newSTATEOP(0, NULL, 0);
7272#ifdef PERL_MAD
7273 op_getmad(block,newblock,'B');
7274#else
7275 op_free(block);
7276#endif
7277 block = newblock;
7278 }
7279 CvROOT(cv) = CvLVALUE(cv)
7280 ? newUNOP(OP_LEAVESUBLV, 0,
7281 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
7282 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
7283 CvROOT(cv)->op_private |= OPpREFCOUNTED;
7284 OpREFCNT_set(CvROOT(cv), 1);
7285 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
7286 itself has a refcount. */
7287 CvSLABBED_off(cv);
7288 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
7289 CvSTART(cv) = LINKLIST(CvROOT(cv));
7290 CvROOT(cv)->op_next = 0;
7291 CALL_PEEP(CvSTART(cv));
7292 finalize_optree(CvROOT(cv));
7293
7294 /* now that optimizer has done its work, adjust pad values */
7295
50278755 7296 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
50278755 7297
50278755
FC		 7298 attrs:
7299 if (attrs) {
7300 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
ad0dc73b 7301 apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
50278755
FC		 7302 }
7303
7304 if (block) {
7305 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
7306 SV * const tmpstr = sv_newmortal();
7307 GV * const db_postponed = gv_fetchpvs("DB::postponed",
7308 GV_ADDMULTI, SVt_PVHV);
7309 HV *hv;
7310 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
7311 CopFILE(PL_curcop),
7312 (long)PL_subline,
7313 (long)CopLINE(PL_curcop));
a56613a9
FC		 7314 if (HvNAME_HEK(PL_curstash)) {
7315 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
7316 sv_catpvs(tmpstr, "::");
7317 }
7318 else sv_setpvs(tmpstr, "__ANON__::");
2435fbd5
FC		 7319 sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
7320 PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
50278755
FC		 7321 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
7322 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
7323 hv = GvHVn(db_postponed);
7324 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
7325 CV * const pcv = GvCV(db_postponed);
7326 if (pcv) {
7327 dSP;
7328 PUSHMARK(SP);
7329 XPUSHs(tmpstr);
7330 PUTBACK;
7331 call_sv(MUTABLE_SV(pcv), G_DISCARD);
7332 }
7333 }
7334 }
7335 }
7336
a70c2d56
FC		 7337 clone:
7338 if (clonee) {
7339 assert(CvDEPTH(outcv));
7340 spot = (CV **)
7341 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
7342 if (reusable) cv_clone_into(clonee, *spot);
7343 else *spot = cv_clone(clonee);
fc2b2dca 7344 SvREFCNT_dec_NN(clonee);
a70c2d56
FC		 7345 cv = *spot;
7346 SvPADMY_on(cv);
7347 }
7348 if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
7349 PADOFFSET depth = CvDEPTH(outcv);
7350 while (--depth) {
7351 SV *oldcv;
7352 svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
7353 oldcv = *svspot;
7354 *svspot = SvREFCNT_inc_simple_NN(cv);
7355 SvREFCNT_dec(oldcv);
7356 }
7357 }
7358
50278755
FC		 7359 done:
7360 if (PL_parser)
7361 PL_parser->copline = NOLINE;
2435fbd5
FC		 7362 LEAVE_SCOPE(floor);
7363 if (o) op_free(o);
50278755 7364 return cv;
09bef843
SB		 7365}
7366
748a9306 7367CV *
09bef843
SB		 7368Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
7369{
7e68c38b
FC		 7370 return newATTRSUB_flags(floor, o, proto, attrs, block, 0);
7371}
7372
7373CV *
7374Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
7375 OP *block, U32 flags)
7376{
27da23d5 7377 dVAR;
83ee9e09 7378 GV *gv;
5c144d81 7379 const char *ps;
52a9a866 7380 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
e0260a5b 7381 U32 ps_utf8 = 0;
eb578fdb 7382 CV *cv = NULL;
beab0874 7383 SV *const_sv;
a73ef99b 7384 const bool ec = PL_parser && PL_parser->error_count;
b48b272a
NC		 7385 /* If the subroutine has no body, no attributes, and no builtin attributes
7386 then it's just a sub declaration, and we may be able to get away with
7387 storing with a placeholder scalar in the symbol table, rather than a
7388 full GV and CV. If anything is present then it will take a full CV to
7389 store it. */
7390 const I32 gv_fetch_flags
a73ef99b
FC		 7391 = ec ? GV_NOADD_NOINIT :
7392 (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
eb8433b7 7393 || PL_madskills)
b48b272a 7394 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
6e948d54 7395 STRLEN namlen = 0;
7e68c38b
FC		 7396 const bool o_is_gv = flags & 1;
7397 const char * const name =
7398 o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
ed4a8a9b 7399 bool has_name;
7e68c38b 7400 bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
7aef8e5b 7401#ifdef PERL_DEBUG_READONLY_OPS
3107b51f
FC		 7402 OPSLAB *slab = NULL;
7403#endif
8e742a20
MHM		 7404
7405 if (proto) {
7406 assert(proto->op_type == OP_CONST);
4ea561bc 7407 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
e0260a5b 7408 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
8e742a20
MHM		 7409 }
7410 else
bd61b366 7411 ps = NULL;
8e742a20 7412
7e68c38b
FC		 7413 if (o_is_gv) {
7414 gv = (GV*)o;
7415 o = NULL;
7416 has_name = TRUE;
7417 } else if (name) {
7418 gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
ed4a8a9b
NC		 7419 has_name = TRUE;
7420 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
aec46f14 7421 SV * const sv = sv_newmortal();
c99da370
JH		 7422 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
7423 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
83ee9e09 7424 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
ed4a8a9b
NC		 7425 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
7426 has_name = TRUE;
c1754fce
NC		 7427 } else if (PL_curstash) {
7428 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
ed4a8a9b 7429 has_name = FALSE;
c1754fce
NC		 7430 } else {
7431 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
ed4a8a9b 7432 has_name = FALSE;
c1754fce 7433 }
83ee9e09 7434
eb8433b7
NC		 7435 if (!PL_madskills) {
7436 if (o)
7437 SAVEFREEOP(o);
7438 if (proto)
7439 SAVEFREEOP(proto);
7440 if (attrs)
7441 SAVEFREEOP(attrs);
7442 }
3fe9a6f1 7443
a73ef99b
FC		 7444 if (ec) {
7445 op_free(block);
4d2dfd15
FC		 7446 if (name) SvREFCNT_dec(PL_compcv);
7447 else cv = PL_compcv;
9ffcdca1 7448 PL_compcv = 0;
a73ef99b
FC		 7449 if (name && block) {
7450 const char *s = strrchr(name, ':');
7451 s = s ? s+1 : name;
7452 if (strEQ(s, "BEGIN")) {
a73ef99b 7453 if (PL_in_eval & EVAL_KEEPERR)
eed484f9 7454 Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
a73ef99b 7455 else {
eed484f9 7456 SV * const errsv = ERRSV;
a73ef99b 7457 /* force display of errors found but not reported */
eed484f9
DD		 7458 sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
7459 Perl_croak_nocontext("%"SVf, SVfARG(errsv));
a73ef99b
FC		 7460 }
7461 }
7462 }
a73ef99b
FC		 7463 goto done;
7464 }
7465
09bef843 7466 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
55d729e4
GS		 7467 maximum a prototype before. */
7468 if (SvTYPE(gv) > SVt_NULL) {
105ff74c
FC		 7469 cv_ckproto_len_flags((const CV *)gv,
7470 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
7471 ps_len, ps_utf8);
55d729e4 7472 }
e0260a5b 7473 if (ps) {
ad64d0ec 7474 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
e0260a5b
BF		 7475 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(gv));
7476 }
55d729e4 7477 else
ad64d0ec 7478 sv_setiv(MUTABLE_SV(gv), -1);
e1a479c5 7479
3280af22
NIS		 7480 SvREFCNT_dec(PL_compcv);
7481 cv = PL_compcv = NULL;
beab0874 7482 goto done;
55d729e4
GS		 7483 }
7484
601f1833 7485 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
beab0874 7486
eb8433b7
NC		 7487 if (!block || !ps || *ps || attrs
7488 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
7489#ifdef PERL_MAD
7490 || block->op_type == OP_NULL
7491#endif
7492 )
a0714e2c 7493 const_sv = NULL;
beab0874 7494 else
137da2b0 7495 const_sv = op_const_sv(block);
beab0874
JT		 7496
7497 if (cv) {
6867be6d 7498 const bool exists = CvROOT(cv) || CvXSUB(cv);
5bd07a3d 7499
60ed1d8c
GS		 7500 /* if the subroutine doesn't exist and wasn't pre-declared
7501 * with a prototype, assume it will be AUTOLOADed,
7502 * skipping the prototype check
7503 */
7504 if (exists || SvPOK(cv))
dab1c735 7505 cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
68dc0745 7506 /* already defined (or promised)? */
60ed1d8c 7507 if (exists || GvASSUMECV(gv)) {
2b141370
FC		 7508 if (S_already_defined(aTHX_ cv, block, o, NULL, &const_sv))
7509 cv = NULL;
7510 else {
fff96ff7 7511 if (attrs) goto attrs;
aa689395 7512 /* just a "sub foo;" when &foo is already defined */
3280af22 7513 SAVEFREESV(PL_compcv);
aa689395 7514 goto done;
7515 }
79072805
LW		 7516 }
7517 }
beab0874 7518 if (const_sv) {
f84c484e 7519 SvREFCNT_inc_simple_void_NN(const_sv);
d2440203 7520 SvFLAGS(const_sv) = (SvFLAGS(const_sv) & ~SVs_PADMY) | SVs_PADTMP;
beab0874 7521 if (cv) {
0768512c 7522 assert(!CvROOT(cv) && !CvCONST(cv));
8be227ab 7523 cv_forget_slab(cv);
ad64d0ec 7524 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
beab0874
JT		 7525 CvXSUBANY(cv).any_ptr = const_sv;
7526 CvXSUB(cv) = const_sv_xsub;
7527 CvCONST_on(cv);
d04ba589 7528 CvISXSUB_on(cv);
beab0874
JT		 7529 }
7530 else {
c43ae56f 7531 GvCV_set(gv, NULL);
9c0a6090 7532 cv = newCONSTSUB_flags(
6e948d54 7533 NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
9c0a6090
FC		 7534 const_sv
7535 );
7ad40bcb 7536 }
eb8433b7
NC		 7537 if (PL_madskills)
7538 goto install_block;
beab0874
JT		 7539 op_free(block);
7540 SvREFCNT_dec(PL_compcv);
7541 PL_compcv = NULL;
beab0874
JT		 7542 goto done;
7543 }
09330df8
Z		 7544 if (cv) { /* must reuse cv if autoloaded */
7545 /* transfer PL_compcv to cv */
7546 if (block
eb8433b7 7547#ifdef PERL_MAD
09330df8 7548 && block->op_type != OP_NULL
eb8433b7 7549#endif
09330df8 7550 ) {
eac910c8 7551 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
b70d5558 7552 PADLIST *const temp_av = CvPADLIST(cv);
437388a9 7553 CV *const temp_cv = CvOUTSIDE(cv);
e52de15a
FC		 7554 const cv_flags_t other_flags =
7555 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
8be227ab 7556 OP * const cvstart = CvSTART(cv);
437388a9 7557
f6894bc8 7558 CvGV_set(cv,gv);
437388a9
NC		 7559 assert(!CvCVGV_RC(cv));
7560 assert(CvGV(cv) == gv);
7561
7562 SvPOK_off(cv);
eac910c8 7563 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs;
09330df8
Z		 7564 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
7565 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
09330df8 7566 CvPADLIST(cv) = CvPADLIST(PL_compcv);
437388a9
NC		 7567 CvOUTSIDE(PL_compcv) = temp_cv;
7568 CvPADLIST(PL_compcv) = temp_av;
8be227ab
FC		 7569 CvSTART(cv) = CvSTART(PL_compcv);
7570 CvSTART(PL_compcv) = cvstart;
e52de15a
FC		 7571 CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
7572 CvFLAGS(PL_compcv) |= other_flags;
437388a9 7573
bad4ae38 7574 if (CvFILE(cv) && CvDYNFILE(cv)) {
437388a9
NC		 7575 Safefree(CvFILE(cv));
7576 }
437388a9
NC		 7577 CvFILE_set_from_cop(cv, PL_curcop);
7578 CvSTASH_set(cv, PL_curstash);
7579
09330df8
Z		 7580 /* inner references to PL_compcv must be fixed up ... */
7581 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
7582 if (PERLDB_INTER)/* Advice debugger on the new sub. */
7583 ++PL_sub_generation;
09bef843
SB		 7584 }
7585 else {
09330df8
Z		 7586 /* Might have had built-in attributes applied -- propagate them. */
7587 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
09bef843 7588 }
282f25c9 7589 /* ... before we throw it away */
3280af22 7590 SvREFCNT_dec(PL_compcv);
b5c19bd7 7591 PL_compcv = cv;
a0d0e21e
LW		 7592 }
7593 else {
3280af22 7594 cv = PL_compcv;
44a8e56a 7595 if (name) {
c43ae56f 7596 GvCV_set(gv, cv);
44a8e56a 7597 GvCVGEN(gv) = 0;
03d9f026
FC		 7598 if (HvENAME_HEK(GvSTASH(gv)))
7599 /* sub Foo::bar { (shift)+1 } */
978a498e 7600 gv_method_changed(gv);
44a8e56a 7601 }
a0d0e21e 7602 }
09330df8 7603 if (!CvGV(cv)) {
b3f91e91 7604 CvGV_set(cv, gv);
09330df8 7605 CvFILE_set_from_cop(cv, PL_curcop);
c68d9564 7606 CvSTASH_set(cv, PL_curstash);
09330df8 7607 }
8990e307 7608
e0260a5b 7609 if (ps) {
ad64d0ec 7610 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
e0260a5b
BF		 7611 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
7612 }
4633a7c4 7613
eb8433b7 7614 install_block:
beab0874 7615 if (!block)
fb834abd 7616 goto attrs;
a0d0e21e 7617
aac018bb
NC		 7618 /* If we assign an optree to a PVCV, then we've defined a subroutine that
7619 the debugger could be able to set a breakpoint in, so signal to
7620 pp_entereval that it should not throw away any saved lines at scope
7621 exit. */
7622
fd06b02c 7623 PL_breakable_sub_gen++;
69b22cd1
FC		 7624 /* This makes sub {}; work as expected. */
7625 if (block->op_type == OP_STUB) {
1496a290 7626 OP* const newblock = newSTATEOP(0, NULL, 0);
eb8433b7
NC		 7627#ifdef PERL_MAD
7628 op_getmad(block,newblock,'B');
7629#else
09c2fd24 7630 op_free(block);
eb8433b7
NC		 7631#endif
7632 block = newblock;
7766f137 7633 }
69b22cd1
FC		 7634 CvROOT(cv) = CvLVALUE(cv)
7635 ? newUNOP(OP_LEAVESUBLV, 0,
7636 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
7637 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
7766f137
GS		 7638 CvROOT(cv)->op_private |= OPpREFCOUNTED;
7639 OpREFCNT_set(CvROOT(cv), 1);
8be227ab
FC		 7640 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
7641 itself has a refcount. */
7642 CvSLABBED_off(cv);
7643 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
7aef8e5b 7644#ifdef PERL_DEBUG_READONLY_OPS
3107b51f 7645 slab = (OPSLAB *)CvSTART(cv);
8be227ab 7646#endif
7766f137
GS		 7647 CvSTART(cv) = LINKLIST(CvROOT(cv));
7648 CvROOT(cv)->op_next = 0;
a2efc822 7649 CALL_PEEP(CvSTART(cv));
d164302a 7650 finalize_optree(CvROOT(cv));
7766f137
GS		 7651
7652 /* now that optimizer has done its work, adjust pad values */
54310121 7653
dd2155a4
DM		 7654 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
7655
fb834abd
FC		 7656 attrs:
7657 if (attrs) {
7658 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
7659 HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
12d3c230 7660 if (!name) SAVEFREESV(cv);
ad0dc73b 7661 apply_attrs(stash, MUTABLE_SV(cv), attrs);
12d3c230 7662 if (!name) SvREFCNT_inc_simple_void_NN(cv);
fb834abd
FC		 7663 }
7664
7665 if (block && has_name) {
3280af22 7666 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
c4420975 7667 SV * const tmpstr = sv_newmortal();
5c1737d1
NC		 7668 GV * const db_postponed = gv_fetchpvs("DB::postponed",
7669 GV_ADDMULTI, SVt_PVHV);
44a8e56a 7670 HV *hv;
b081dd7e
NC		 7671 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
7672 CopFILE(PL_curcop),
7673 (long)PL_subline,
7674 (long)CopLINE(PL_curcop));
bd61b366 7675 gv_efullname3(tmpstr, gv, NULL);
04fe65b0 7676 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
c60dbbc3 7677 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
44a8e56a 7678 hv = GvHVn(db_postponed);
c60dbbc3 7679 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
551405c4
AL		 7680 CV * const pcv = GvCV(db_postponed);
7681 if (pcv) {
7682 dSP;
7683 PUSHMARK(SP);
7684 XPUSHs(tmpstr);
7685 PUTBACK;
ad64d0ec 7686 call_sv(MUTABLE_SV(pcv), G_DISCARD);
551405c4 7687 }
44a8e56a 7688 }
7689 }
79072805 7690
13765c85 7691 if (name && ! (PL_parser && PL_parser->error_count))
d699ecb7 7692 process_special_blocks(floor, name, gv, cv);
33fb7a6e 7693 }
ed094faf 7694
33fb7a6e 7695 done:
53a7735b
DM		 7696 if (PL_parser)
7697 PL_parser->copline = NOLINE;
33fb7a6e 7698 LEAVE_SCOPE(floor);
7aef8e5b 7699#ifdef PERL_DEBUG_READONLY_OPS
3107b51f
FC		 7700 /* Watch out for BEGIN blocks */
7701 if (slab && gv && isGV(gv) && GvCV(gv)) Slab_to_ro(slab);
7702#endif
33fb7a6e
NC		 7703 return cv;
7704}
ed094faf 7705
33fb7a6e 7706STATIC void
d699ecb7
FC		 7707S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
7708 GV *const gv,
33fb7a6e
NC		 7709 CV *const cv)
7710{
7711 const char *const colon = strrchr(fullname,':');
7712 const char *const name = colon ? colon + 1 : fullname;
7713
7918f24d
NC		 7714 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
7715
33fb7a6e 7716 if (*name == 'B') {
6952d67e 7717 if (strEQ(name, "BEGIN")) {
6867be6d 7718 const I32 oldscope = PL_scopestack_ix;
d699ecb7 7719 if (floor) LEAVE_SCOPE(floor);
28757baa 7720 ENTER;
57843af0
GS		 7721 SAVECOPFILE(&PL_compiling);
7722 SAVECOPLINE(&PL_compiling);
16c63275 7723 SAVEVPTR(PL_curcop);
28757baa 7724
a58fb6f9 7725 DEBUG_x( dump_sub(gv) );
ad64d0ec 7726 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
c43ae56f 7727 GvCV_set(gv,0); /* cv has been hijacked */
3280af22 7728 call_list(oldscope, PL_beginav);
a6006777 7729
623e6609 7730 CopHINTS_set(&PL_compiling, PL_hints);
28757baa 7731 LEAVE;
7732 }
33fb7a6e
NC		 7733 else
7734 return;
7735 } else {
7736 if (*name == 'E') {
7737 if strEQ(name, "END") {
a58fb6f9 7738 DEBUG_x( dump_sub(gv) );
ad64d0ec 7739 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
33fb7a6e
NC		 7740 } else
7741 return;
7742 } else if (*name == 'U') {
7743 if (strEQ(name, "UNITCHECK")) {
7744 /* It's never too late to run a unitcheck block */
ad64d0ec 7745 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
33fb7a6e
NC		 7746 }
7747 else
7748 return;
7749 } else if (*name == 'C') {
7750 if (strEQ(name, "CHECK")) {
a2a5de95 7751 if (PL_main_start)
dcbac5bb 7752 /* diag_listed_as: Too late to run %s block */
a2a5de95
NC		 7753 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
7754 "Too late to run CHECK block");
ad64d0ec 7755 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
33fb7a6e
NC		 7756 }
7757 else
7758 return;
7759 } else if (*name == 'I') {
7760 if (strEQ(name, "INIT")) {
a2a5de95 7761 if (PL_main_start)
dcbac5bb 7762 /* diag_listed_as: Too late to run %s block */
a2a5de95
NC		 7763 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
7764 "Too late to run INIT block");
ad64d0ec 7765 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
33fb7a6e
NC		 7766 }
7767 else
7768 return;
7769 } else
7770 return;
a58fb6f9 7771 DEBUG_x( dump_sub(gv) );
c43ae56f 7772 GvCV_set(gv,0); /* cv has been hijacked */
79072805 7773 }
79072805
LW		 7774}
7775
954c1994
GS		 7776/*
7777=for apidoc newCONSTSUB
7778
3453414d
BF		 7779See L</newCONSTSUB_flags>.
7780
7781=cut
7782*/
7783
7784CV *
7785Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
7786{
9c0a6090 7787 return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
3453414d
BF		 7788}
7789
7790/*
7791=for apidoc newCONSTSUB_flags
7792
954c1994
GS		 7793Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
7794eligible for inlining at compile-time.
7795
3453414d
BF		 7796Currently, the only useful value for C<flags> is SVf_UTF8.
7797
be8851fc
NC		 7798The newly created subroutine takes ownership of a reference to the passed in
7799SV.
7800
99ab892b
NC		 7801Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
7802which won't be called if used as a destructor, but will suppress the overhead
7803of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
7804compile time.)
7805
954c1994
GS		 7806=cut
7807*/
7808
beab0874 7809CV *
9c0a6090
FC		 7810Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
7811 U32 flags, SV *sv)
5476c433 7812{
27da23d5 7813 dVAR;
beab0874 7814 CV* cv;
cbf82dd0 7815#ifdef USE_ITHREADS
54d012c6 7816 const char *const file = CopFILE(PL_curcop);
cbf82dd0
NC		 7817#else
7818 SV *const temp_sv = CopFILESV(PL_curcop);
def18e4c 7819 const char *const file = temp_sv ? SvPV_nolen_const(temp_sv) : NULL;
cbf82dd0 7820#endif
5476c433 7821
11faa288 7822 ENTER;
11faa288 7823
401667e9
DM		 7824 if (IN_PERL_RUNTIME) {
7825 /* at runtime, it's not safe to manipulate PL_curcop: it may be
7826 * an op shared between threads. Use a non-shared COP for our
7827 * dirty work */
7828 SAVEVPTR(PL_curcop);
08f1b312
FC		 7829 SAVECOMPILEWARNINGS();
7830 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
401667e9
DM		 7831 PL_curcop = &PL_compiling;
7832 }
f4dd75d9 7833 SAVECOPLINE(PL_curcop);
53a7735b 7834 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
f4dd75d9
GS		 7835
7836 SAVEHINTS();
3280af22 7837 PL_hints &= ~HINT_BLOCK_SCOPE;
11faa288
GS		 7838
7839 if (stash) {
03d9f026 7840 SAVEGENERICSV(PL_curstash);
03d9f026 7841 PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
11faa288 7842 }
5476c433 7843
95934569
FC		 7844 /* Protect sv against leakage caused by fatal warnings. */
7845 if (sv) SAVEFREESV(sv);
7846
bad4ae38 7847 /* file becomes the CvFILE. For an XS, it's usually static storage,
cbf82dd0
NC		 7848 and so doesn't get free()d. (It's expected to be from the C pre-
7849 processor __FILE__ directive). But we need a dynamically allocated one,
77004dee 7850 and we need it to get freed. */
6f1b3ab0
FC		 7851 cv = newXS_len_flags(name, len,
7852 sv && SvTYPE(sv) == SVt_PVAV
7853 ? const_av_xsub
7854 : const_sv_xsub,
7855 file ? file : "", "",
8f82b567 7856 &sv, XS_DYNAMIC_FILENAME | flags);
95934569 7857 CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
beab0874 7858 CvCONST_on(cv);
5476c433 7859
11faa288 7860 LEAVE;
beab0874
JT		 7861
7862 return cv;
5476c433
JD		 7863}
7864
77004dee
NC		 7865CV *
7866Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
7867 const char *const filename, const char *const proto,
7868 U32 flags)
7869{
032a0447
FC		 7870 PERL_ARGS_ASSERT_NEWXS_FLAGS;
7871 return newXS_len_flags(
8f82b567 7872 name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
032a0447
FC		 7873 );
7874}
7875
7876CV *
7877Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
7878 XSUBADDR_t subaddr, const char *const filename,
8f82b567
FC		 7879 const char *const proto, SV **const_svp,
7880 U32 flags)
032a0447 7881{
3453414d 7882 CV *cv;
77004dee 7883
032a0447 7884 PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
7918f24d 7885
3453414d 7886 {
9b566a5e
DD		 7887 GV * const gv = gv_fetchpvn(
7888 name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
7889 name ? len : PL_curstash ? sizeof("__ANON__") - 1:
7890 sizeof("__ANON__::__ANON__") - 1,
7891 GV_ADDMULTI | flags, SVt_PVCV);
3453414d
BF		 7892
7893 if (!subaddr)
7894 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
7895
7896 if ((cv = (name ? GvCV(gv) : NULL))) {
7897 if (GvCVGEN(gv)) {
7898 /* just a cached method */
7899 SvREFCNT_dec(cv);
7900 cv = NULL;
7901 }
7902 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
7903 /* already defined (or promised) */
18225a01 7904 /* Redundant check that allows us to avoid creating an SV
156d738f
FC		 7905 most of the time: */
7906 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
156d738f 7907 report_redefined_cv(newSVpvn_flags(
46538741 7908 name,len,(flags&SVf_UTF8)|SVs_TEMP
156d738f
FC		 7909 ),
7910 cv, const_svp);
3453414d 7911 }
fc2b2dca 7912 SvREFCNT_dec_NN(cv);
3453414d
BF		 7913 cv = NULL;
7914 }
7915 }
7916
7917 if (cv) /* must reuse cv if autoloaded */
7918 cv_undef(cv);
7919 else {
7920 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
7921 if (name) {
7922 GvCV_set(gv,cv);
7923 GvCVGEN(gv) = 0;
03d9f026 7924 if (HvENAME_HEK(GvSTASH(gv)))
978a498e 7925 gv_method_changed(gv); /* newXS */
3453414d
BF		 7926 }
7927 }
7928 if (!name)
7929 CvANON_on(cv);
7930 CvGV_set(cv, gv);
7931 (void)gv_fetchfile(filename);
7932 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
7933 an external constant string */
7934 assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
7935 CvISXSUB_on(cv);
7936 CvXSUB(cv) = subaddr;
7937
7938 if (name)
d699ecb7 7939 process_special_blocks(0, name, gv, cv);
3453414d
BF		 7940 }
7941
77004dee 7942 if (flags & XS_DYNAMIC_FILENAME) {
bad4ae38
FC		 7943 CvFILE(cv) = savepv(filename);
7944 CvDYNFILE_on(cv);
77004dee 7945 }
bad4ae38 7946 sv_setpv(MUTABLE_SV(cv), proto);
77004dee
NC		 7947 return cv;
7948}
7949
186a5ba8
FC		 7950CV *
7951Perl_newSTUB(pTHX_ GV *gv, bool fake)
7952{
eb578fdb 7953 CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
2f222bbd 7954 GV *cvgv;
186a5ba8
FC		 7955 PERL_ARGS_ASSERT_NEWSTUB;
7956 assert(!GvCVu(gv));
7957 GvCV_set(gv, cv);
7958 GvCVGEN(gv) = 0;
7959 if (!fake && HvENAME_HEK(GvSTASH(gv)))
978a498e 7960 gv_method_changed(gv);
2f222bbd
FC		 7961 if (SvFAKE(gv)) {
7962 cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
7963 SvFAKE_off(cvgv);
7964 }
7965 else cvgv = gv;
7966 CvGV_set(cv, cvgv);
186a5ba8
FC		 7967 CvFILE_set_from_cop(cv, PL_curcop);
7968 CvSTASH_set(cv, PL_curstash);
7969 GvMULTI_on(gv);
7970 return cv;
7971}
7972
954c1994
GS		 7973/*
7974=for apidoc U||newXS
7975
77004dee
NC		 7976Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
7977static storage, as it is used directly as CvFILE(), without a copy being made.
954c1994
GS		 7978
7979=cut
7980*/
7981
57d3b86d 7982CV *
bfed75c6 7983Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
a0d0e21e 7984{
7918f24d 7985 PERL_ARGS_ASSERT_NEWXS;
ce9f52ad
FC		 7986 return newXS_len_flags(
7987 name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
7988 );
79072805
LW		 7989}
7990
eb8433b7
NC		 7991#ifdef PERL_MAD
7992OP *
7993#else
79072805 7994void
eb8433b7 7995#endif
864dbfa3 7996Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
79072805 7997{
97aff369 7998 dVAR;
eb578fdb 7999 CV *cv;
eb8433b7
NC		 8000#ifdef PERL_MAD
8001 OP* pegop = newOP(OP_NULL, 0);
8002#endif
79072805 8003
2c658e55
FC		 8004 GV *gv;
8005
8006 if (PL_parser && PL_parser->error_count) {
8007 op_free(block);
8008 goto finish;
8009 }
8010
8011 gv = o
f776e3cd 8012 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
fafc274c 8013 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
0bd48802 8014
a5f75d66 8015 GvMULTI_on(gv);
155aba94 8016 if ((cv = GvFORM(gv))) {
599cee73 8017 if (ckWARN(WARN_REDEFINE)) {
6867be6d 8018 const line_t oldline = CopLINE(PL_curcop);
53a7735b
DM		 8019 if (PL_parser && PL_parser->copline != NOLINE)
8020 CopLINE_set(PL_curcop, PL_parser->copline);
ee6d2783
NC		 8021 if (o) {
8022 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
8023 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
8024 } else {
dcbac5bb 8025 /* diag_listed_as: Format %s redefined */
ee6d2783
NC		 8026 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
8027 "Format STDOUT redefined");
8028 }
57843af0 8029 CopLINE_set(PL_curcop, oldline);
79072805 8030 }
8990e307 8031 SvREFCNT_dec(cv);
79072805 8032 }
3280af22 8033 cv = PL_compcv;
2c658e55 8034 GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
b3f91e91 8035 CvGV_set(cv, gv);
a636914a 8036 CvFILE_set_from_cop(cv, PL_curcop);
79072805 8037
a0d0e21e 8038
dd2155a4 8039 pad_tidy(padtidy_FORMAT);
79072805 8040 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
7934575e
GS		 8041 CvROOT(cv)->op_private |= OPpREFCOUNTED;
8042 OpREFCNT_set(CvROOT(cv), 1);
79072805
LW		 8043 CvSTART(cv) = LINKLIST(CvROOT(cv));
8044 CvROOT(cv)->op_next = 0;
a2efc822 8045 CALL_PEEP(CvSTART(cv));
aee4f072 8046 finalize_optree(CvROOT(cv));
2c658e55
FC		 8047 cv_forget_slab(cv);
8048
8049 finish:
eb8433b7
NC		 8050#ifdef PERL_MAD
8051 op_getmad(o,pegop,'n');
8052 op_getmad_weak(block, pegop, 'b');
8053#else
11343788 8054 op_free(o);
eb8433b7 8055#endif
53a7735b
DM		 8056 if (PL_parser)
8057 PL_parser->copline = NOLINE;
8990e307 8058 LEAVE_SCOPE(floor);
eb8433b7
NC		 8059#ifdef PERL_MAD
8060 return pegop;
8061#endif
79072805
LW		 8062}
8063
8064OP *
864dbfa3 8065Perl_newANONLIST(pTHX_ OP *o)
79072805 8066{
78c72037 8067 return convert(OP_ANONLIST, OPf_SPECIAL, o);
79072805
LW		 8068}
8069
8070OP *
864dbfa3 8071Perl_newANONHASH(pTHX_ OP *o)
79072805 8072{
78c72037 8073 return convert(OP_ANONHASH, OPf_SPECIAL, o);
a0d0e21e
LW		 8074}
8075
8076OP *
864dbfa3 8077Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
a0d0e21e 8078{
5f66b61c 8079 return newANONATTRSUB(floor, proto, NULL, block);
09bef843
SB		 8080}
8081
8082OP *
8083Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
8084{
a0d0e21e 8085 return newUNOP(OP_REFGEN, 0,
09bef843 8086 newSVOP(OP_ANONCODE, 0,
ad64d0ec 8087 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
79072805
LW		 8088}
8089
8090OP *
864dbfa3 8091Perl_oopsAV(pTHX_ OP *o)
79072805 8092{
27da23d5 8093 dVAR;
7918f24d
NC		 8094
8095 PERL_ARGS_ASSERT_OOPSAV;
8096
ed6116ce
LW		 8097 switch (o->op_type) {
8098 case OP_PADSV:
8099 o->op_type = OP_PADAV;
22c35a8c 8100 o->op_ppaddr = PL_ppaddr[OP_PADAV];
51e247a3 8101 return ref(o, OP_RV2AV);
b2ffa427 8102
ed6116ce 8103 case OP_RV2SV:
79072805 8104 o->op_type = OP_RV2AV;
22c35a8c 8105 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
79072805 8106 ref(o, OP_RV2AV);
ed6116ce
LW		 8107 break;
8108
8109 default:
9b387841 8110 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
ed6116ce
LW		 8111 break;
8112 }
79072805
LW		 8113 return o;
8114}
8115
8116OP *
864dbfa3 8117Perl_oopsHV(pTHX_ OP *o)
79072805 8118{
27da23d5 8119 dVAR;
7918f24d
NC		 8120
8121 PERL_ARGS_ASSERT_OOPSHV;
8122
ed6116ce
LW		 8123 switch (o->op_type) {
8124 case OP_PADSV:
8125 case OP_PADAV:
8126 o->op_type = OP_PADHV;
22c35a8c 8127 o->op_ppaddr = PL_ppaddr[OP_PADHV];
51e247a3 8128 return ref(o, OP_RV2HV);
ed6116ce
LW		 8129
8130 case OP_RV2SV:
8131 case OP_RV2AV:
79072805 8132 o->op_type = OP_RV2HV;
22c35a8c 8133 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
79072805 8134 ref(o, OP_RV2HV);
ed6116ce
LW		 8135 break;
8136
8137 default:
9b387841 8138 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
ed6116ce
LW		 8139 break;
8140 }
79072805
LW		 8141 return o;
8142}
8143
8144OP *
864dbfa3 8145Perl_newAVREF(pTHX_ OP *o)
79072805 8146{
27da23d5 8147 dVAR;
7918f24d
NC		 8148
8149 PERL_ARGS_ASSERT_NEWAVREF;
8150
ed6116ce
LW		 8151 if (o->op_type == OP_PADANY) {
8152 o->op_type = OP_PADAV;
22c35a8c 8153 o->op_ppaddr = PL_ppaddr[OP_PADAV];
93a17b20 8154 return o;
ed6116ce 8155 }
a2a5de95 8156 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
d1d15184 8157 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
a2a5de95 8158 "Using an array as a reference is deprecated");
a1063b2d 8159 }
79072805
LW		 8160 return newUNOP(OP_RV2AV, 0, scalar(o));
8161}
8162
8163OP *
864dbfa3 8164Perl_newGVREF(pTHX_ I32 type, OP *o)
79072805 8165{
82092f1d 8166 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
a0d0e21e 8167 return newUNOP(OP_NULL, 0, o);
748a9306 8168 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
79072805
LW		 8169}
8170
8171OP *
864dbfa3 8172Perl_newHVREF(pTHX_ OP *o)
79072805 8173{
27da23d5 8174 dVAR;
7918f24d
NC		 8175
8176 PERL_ARGS_ASSERT_NEWHVREF;
8177
ed6116ce
LW		 8178 if (o->op_type == OP_PADANY) {
8179 o->op_type = OP_PADHV;
22c35a8c 8180 o->op_ppaddr = PL_ppaddr[OP_PADHV];
93a17b20 8181 return o;
ed6116ce 8182 }
a2a5de95 8183 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
d1d15184 8184 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
a2a5de95 8185 "Using a hash as a reference is deprecated");
a1063b2d 8186 }
79072805
LW		 8187 return newUNOP(OP_RV2HV, 0, scalar(o));
8188}
8189
8190OP *
864dbfa3 8191Perl_newCVREF(pTHX_ I32 flags, OP *o)
79072805 8192{
97b03d64 8193 if (o->op_type == OP_PADANY) {
c04ef36e 8194 dVAR;
97b03d64
FC		 8195 o->op_type = OP_PADCV;
8196 o->op_ppaddr = PL_ppaddr[OP_PADCV];
8197 }
c07a80fd 8198 return newUNOP(OP_RV2CV, flags, scalar(o));
79072805
LW		 8199}
8200
8201OP *
864dbfa3 8202Perl_newSVREF(pTHX_ OP *o)
79072805 8203{
27da23d5 8204 dVAR;
7918f24d
NC		 8205
8206 PERL_ARGS_ASSERT_NEWSVREF;
8207
ed6116ce
LW		 8208 if (o->op_type == OP_PADANY) {
8209 o->op_type = OP_PADSV;
22c35a8c 8210 o->op_ppaddr = PL_ppaddr[OP_PADSV];
93a17b20 8211 return o;
ed6116ce 8212 }
79072805
LW		 8213 return newUNOP(OP_RV2SV, 0, scalar(o));
8214}
8215
61b743bb
DM		 8216/* Check routines. See the comments at the top of this file for details
8217 * on when these are called */
79072805
LW		 8218
8219OP *
cea2e8a9 8220Perl_ck_anoncode(pTHX_ OP *o)
5f05dabc 8221{
7918f24d
NC		 8222 PERL_ARGS_ASSERT_CK_ANONCODE;
8223
cc76b5cc 8224 cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
eb8433b7 8225 if (!PL_madskills)
1d866c12 8226 cSVOPo->op_sv = NULL;
5dc0d613 8227 return o;
5f05dabc 8228}
8229
8230OP *
cea2e8a9 8231Perl_ck_bitop(pTHX_ OP *o)
55497cff 8232{
97aff369 8233 dVAR;
7918f24d
NC		 8234
8235 PERL_ARGS_ASSERT_CK_BITOP;
8236
d5ec2987 8237 o->op_private = (U8)(PL_hints & HINT_INTEGER);
2b84528b
RGS		 8238 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
8239 && (o->op_type == OP_BIT_OR
8240 || o->op_type == OP_BIT_AND
8241 || o->op_type == OP_BIT_XOR))
276b2a0c 8242 {
1df70142
AL		 8243 const OP * const left = cBINOPo->op_first;
8244 const OP * const right = left->op_sibling;
96a925ab
YST		 8245 if ((OP_IS_NUMCOMPARE(left->op_type) &&
8246 (left->op_flags & OPf_PARENS) == 0) ||
8247 (OP_IS_NUMCOMPARE(right->op_type) &&
8248 (right->op_flags & OPf_PARENS) == 0))
a2a5de95
NC		 8249 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
8250 "Possible precedence problem on bitwise %c operator",
8251 o->op_type == OP_BIT_OR ? '|'
8252 : o->op_type == OP_BIT_AND ? '&' : '^'
8253 );
276b2a0c 8254 }
5dc0d613 8255 return o;
55497cff 8256}
8257
89474f50
FC		 8258PERL_STATIC_INLINE bool
8259is_dollar_bracket(pTHX_ const OP * const o)
8260{
8261 const OP *kid;
8262 return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
8263 && (kid = cUNOPx(o)->op_first)
8264 && kid->op_type == OP_GV
8265 && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
8266}
8267
8268OP *
8269Perl_ck_cmp(pTHX_ OP *o)
8270{
8271 PERL_ARGS_ASSERT_CK_CMP;
8272 if (ckWARN(WARN_SYNTAX)) {
8273 const OP *kid = cUNOPo->op_first;
8274 if (kid && (
7c2b3c78
FC		 8275 (
8276 is_dollar_bracket(aTHX_ kid)
8277 && kid->op_sibling && kid->op_sibling->op_type == OP_CONST
8278 )
8279 || ( kid->op_type == OP_CONST
8280 && (kid = kid->op_sibling) && is_dollar_bracket(aTHX_ kid))
89474f50
FC		 8281 ))
8282 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
8283 "$[ used in %s (did you mean $] ?)", OP_DESC(o));
8284 }
8285 return o;
8286}
8287
55497cff 8288OP *
cea2e8a9 8289Perl_ck_concat(pTHX_ OP *o)
79072805 8290{
0bd48802 8291 const OP * const kid = cUNOPo->op_first;
7918f24d
NC		 8292
8293 PERL_ARGS_ASSERT_CK_CONCAT;
96a5add6 8294 PERL_UNUSED_CONTEXT;
7918f24d 8295
df91b2c5
AE		 8296 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
8297 !(kUNOP->op_first->op_flags & OPf_MOD))
0165acc7 8298 o->op_flags |= OPf_STACKED;
11343788 8299 return o;
79072805
LW		 8300}
8301
8302OP *
cea2e8a9 8303Perl_ck_spair(pTHX_ OP *o)
79072805 8304{
27da23d5 8305 dVAR;
7918f24d
NC		 8306
8307 PERL_ARGS_ASSERT_CK_SPAIR;
8308
11343788 8309 if (o->op_flags & OPf_KIDS) {
79072805 8310 OP* newop;
a0d0e21e 8311 OP* kid;
6867be6d 8312 const OPCODE type = o->op_type;
5dc0d613 8313 o = modkids(ck_fun(o), type);
11343788 8314 kid = cUNOPo->op_first;
a0d0e21e 8315 newop = kUNOP->op_first->op_sibling;
1496a290
AL		 8316 if (newop) {
8317 const OPCODE type = newop->op_type;
8318 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
8319 type == OP_PADAV || type == OP_PADHV ||
8320 type == OP_RV2AV || type == OP_RV2HV)
8321 return o;
a0d0e21e 8322 }
eb8433b7
NC		 8323#ifdef PERL_MAD
8324 op_getmad(kUNOP->op_first,newop,'K');
8325#else
a0d0e21e 8326 op_free(kUNOP->op_first);
eb8433b7 8327#endif
a0d0e21e
LW		 8328 kUNOP->op_first = newop;
8329 }
707b805e
RGS		 8330 /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
8331 * and OP_CHOMP into OP_SCHOMP */
22c35a8c 8332 o->op_ppaddr = PL_ppaddr[++o->op_type];
11343788 8333 return ck_fun(o);
a0d0e21e
LW		 8334}
8335
8336OP *
cea2e8a9 8337Perl_ck_delete(pTHX_ OP *o)
a0d0e21e 8338{
7918f24d
NC		 8339 PERL_ARGS_ASSERT_CK_DELETE;
8340
11343788 8341 o = ck_fun(o);
5dc0d613 8342 o->op_private = 0;
11343788 8343 if (o->op_flags & OPf_KIDS) {
551405c4 8344 OP * const kid = cUNOPo->op_first;
01020589
GS		 8345 switch (kid->op_type) {
8346 case OP_ASLICE:
8347 o->op_flags |= OPf_SPECIAL;
8348 /* FALL THROUGH */
8349 case OP_HSLICE:
5dc0d613 8350 o->op_private |= OPpSLICE;
01020589
GS		 8351 break;
8352 case OP_AELEM:
8353 o->op_flags |= OPf_SPECIAL;
8354 /* FALL THROUGH */
8355 case OP_HELEM:
8356 break;
8357 default:
8358 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
53e06cf0 8359 OP_DESC(o));
01020589 8360 }
7332a6c4
VP		 8361 if (kid->op_private & OPpLVAL_INTRO)
8362 o->op_private |= OPpLVAL_INTRO;
93c66552 8363 op_null(kid);
79072805 8364 }
11343788 8365 return o;
79072805
LW		 8366}
8367
8368OP *
96e176bf
CL		 8369Perl_ck_die(pTHX_ OP *o)
8370{
7918f24d
NC		 8371 PERL_ARGS_ASSERT_CK_DIE;
8372
96e176bf
CL		 8373#ifdef VMS
8374 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
8375#endif
8376 return ck_fun(o);
8377}
8378
8379OP *
cea2e8a9 8380Perl_ck_eof(pTHX_ OP *o)
79072805 8381{
97aff369 8382 dVAR;
79072805 8383
7918f24d
NC		 8384 PERL_ARGS_ASSERT_CK_EOF;
8385
11343788 8386 if (o->op_flags & OPf_KIDS) {
3500db16 8387 OP *kid;
11343788 8388 if (cLISTOPo->op_first->op_type == OP_STUB) {
1d866c12
AL		 8389 OP * const newop
8390 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
eb8433b7
NC		 8391#ifdef PERL_MAD
8392 op_getmad(o,newop,'O');
8393#else
11343788 8394 op_free(o);
eb8433b7
NC		 8395#endif
8396 o = newop;
8990e307 8397 }
3500db16
FC		 8398 o = ck_fun(o);
8399 kid = cLISTOPo->op_first;
8400 if (kid->op_type == OP_RV2GV)
8401 kid->op_private |= OPpALLOW_FAKE;
79072805 8402 }
11343788 8403 return o;
79072805
LW		 8404}
8405
8406OP *
cea2e8a9 8407Perl_ck_eval(pTHX_ OP *o)
79072805 8408{
27da23d5 8409 dVAR;
7918f24d
NC		 8410
8411 PERL_ARGS_ASSERT_CK_EVAL;
8412
3280af22 8413 PL_hints |= HINT_BLOCK_SCOPE;
11343788 8414 if (o->op_flags & OPf_KIDS) {
46c461b5 8415 SVOP * const kid = (SVOP*)cUNOPo->op_first;
79072805 8416
93a17b20 8417 if (!kid) {
11343788 8418 o->op_flags &= ~OPf_KIDS;
93c66552 8419 op_null(o);
79072805 8420 }
b14574b4 8421 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
79072805 8422 LOGOP *enter;
eb8433b7 8423#ifdef PERL_MAD
1d866c12 8424 OP* const oldo = o;
eb8433b7 8425#endif
79072805 8426
11343788 8427 cUNOPo->op_first = 0;
eb8433b7 8428#ifndef PERL_MAD
11343788 8429 op_free(o);
eb8433b7 8430#endif
79072805 8431
b7dc083c 8432 NewOp(1101, enter, 1, LOGOP);
79072805 8433 enter->op_type = OP_ENTERTRY;
22c35a8c 8434 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
79072805
LW		 8435 enter->op_private = 0;
8436
8437 /* establish postfix order */
8438 enter->op_next = (OP*)enter;
8439
2fcb4757 8440 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
11343788 8441 o->op_type = OP_LEAVETRY;
22c35a8c 8442 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
11343788 8443 enter->op_other = o;
eb8433b7 8444 op_getmad(oldo,o,'O');
11343788 8445 return o;
79072805 8446 }
b5c19bd7 8447 else {
473986ff 8448 scalar((OP*)kid);
b5c19bd7
DM		 8449 PL_cv_has_eval = 1;
8450 }
79072805
LW		 8451 }
8452 else {
a4a3cf74 8453 const U8 priv = o->op_private;
eb8433b7 8454#ifdef PERL_MAD
1d866c12 8455 OP* const oldo = o;
eb8433b7 8456#else
11343788 8457 op_free(o);
eb8433b7 8458#endif
7d789282 8459 o = newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
eb8433b7 8460 op_getmad(oldo,o,'O');
79072805 8461 }
3280af22 8462 o->op_targ = (PADOFFSET)PL_hints;
547ae129 8463 if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
7d789282
FC		 8464 if ((PL_hints & HINT_LOCALIZE_HH) != 0
8465 && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
996c9baa
VP		 8466 /* Store a copy of %^H that pp_entereval can pick up. */
8467 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
defdfed5 8468 MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
0d863452
RH		 8469 cUNOPo->op_first->op_sibling = hhop;
8470 o->op_private |= OPpEVAL_HAS_HH;
915a83fe
FC		 8471 }
8472 if (!(o->op_private & OPpEVAL_BYTES)
2846acbf 8473 && FEATURE_UNIEVAL_IS_ENABLED)
802a15e9 8474 o->op_private |= OPpEVAL_UNICODE;
11343788 8475 return o;
79072805
LW		 8476}
8477
8478OP *
d98f61e7
GS		 8479Perl_ck_exit(pTHX_ OP *o)
8480{
7918f24d
NC		 8481 PERL_ARGS_ASSERT_CK_EXIT;
8482
d98f61e7 8483#ifdef VMS
551405c4 8484 HV * const table = GvHV(PL_hintgv);
d98f61e7 8485 if (table) {
a4fc7abc 8486 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
d98f61e7
GS		 8487 if (svp && *svp && SvTRUE(*svp))
8488 o->op_private |= OPpEXIT_VMSISH;
8489 }
96e176bf 8490 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
d98f61e7
GS		 8491#endif
8492 return ck_fun(o);
8493}
8494
8495OP *
cea2e8a9 8496Perl_ck_exec(pTHX_ OP *o)
79072805 8497{
7918f24d
NC		 8498 PERL_ARGS_ASSERT_CK_EXEC;
8499
11343788 8500 if (o->op_flags & OPf_STACKED) {
6867be6d 8501 OP *kid;
11343788
MB		 8502 o = ck_fun(o);
8503 kid = cUNOPo->op_first->op_sibling;
8990e307 8504 if (kid->op_type == OP_RV2GV)
93c66552 8505 op_null(kid);
79072805 8506 }
463ee0b2 8507 else
11343788
MB		 8508 o = listkids(o);
8509 return o;
79072805
LW		 8510}
8511
8512OP *
cea2e8a9 8513Perl_ck_exists(pTHX_ OP *o)
5f05dabc 8514{
97aff369 8515 dVAR;
7918f24d
NC		 8516
8517 PERL_ARGS_ASSERT_CK_EXISTS;
8518
5196be3e
MB		 8519 o = ck_fun(o);
8520 if (o->op_flags & OPf_KIDS) {
46c461b5 8521 OP * const kid = cUNOPo->op_first;
afebc493
GS		 8522 if (kid->op_type == OP_ENTERSUB) {
8523 (void) ref(kid, o->op_type);
13765c85
DM		 8524 if (kid->op_type != OP_RV2CV
8525 && !(PL_parser && PL_parser->error_count))
afebc493 8526 Perl_croak(aTHX_ "%s argument is not a subroutine name",
53e06cf0 8527 OP_DESC(o));
afebc493
GS		 8528 o->op_private |= OPpEXISTS_SUB;
8529 }
8530 else if (kid->op_type == OP_AELEM)
01020589
GS		 8531 o->op_flags |= OPf_SPECIAL;
8532 else if (kid->op_type != OP_HELEM)
b0fdf69e 8533 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine",
53e06cf0 8534 OP_DESC(o));
93c66552 8535 op_null(kid);
5f05dabc 8536 }
5196be3e 8537 return o;
5f05dabc 8538}
8539
79072805 8540OP *
5aaab254 8541Perl_ck_rvconst(pTHX_ OP *o)
79072805 8542{
27da23d5 8543 dVAR;
0bd48802 8544 SVOP * const kid = (SVOP*)cUNOPo->op_first;
85e6fe83 8545
7918f24d
NC		 8546 PERL_ARGS_ASSERT_CK_RVCONST;
8547
3280af22 8548 o->op_private |= (PL_hints & HINT_STRICT_REFS);
e26df76a
NC		 8549 if (o->op_type == OP_RV2CV)
8550 o->op_private &= ~1;
8551
79072805 8552 if (kid->op_type == OP_CONST) {
44a8e56a 8553 int iscv;
8554 GV *gv;
504618e9 8555 SV * const kidsv = kid->op_sv;
44a8e56a 8556
779c5bc9
GS		 8557 /* Is it a constant from cv_const_sv()? */
8558 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
0bd48802 8559 SV * const rsv = SvRV(kidsv);
42d0e0b7 8560 const svtype type = SvTYPE(rsv);
bd61b366 8561 const char *badtype = NULL;
779c5bc9
GS		 8562
8563 switch (o->op_type) {
8564 case OP_RV2SV:
42d0e0b7 8565 if (type > SVt_PVMG)
779c5bc9
GS		 8566 badtype = "a SCALAR";
8567 break;
8568 case OP_RV2AV:
42d0e0b7 8569 if (type != SVt_PVAV)
779c5bc9
GS		 8570 badtype = "an ARRAY";
8571 break;
8572 case OP_RV2HV:
42d0e0b7 8573 if (type != SVt_PVHV)
779c5bc9 8574 badtype = "a HASH";
779c5bc9
GS		 8575 break;
8576 case OP_RV2CV:
42d0e0b7 8577 if (type != SVt_PVCV)
779c5bc9
GS		 8578 badtype = "a CODE";
8579 break;
8580 }
8581 if (badtype)
cea2e8a9 8582 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
779c5bc9
GS		 8583 return o;
8584 }
f815dc14 8585 if (SvTYPE(kidsv) == SVt_PVAV) return o;
ce10b5d1 8586 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5f66b61c 8587 const char *badthing;
5dc0d613 8588 switch (o->op_type) {
44a8e56a 8589 case OP_RV2SV:
8590 badthing = "a SCALAR";
8591 break;
8592 case OP_RV2AV:
8593 badthing = "an ARRAY";
8594 break;
8595 case OP_RV2HV:
8596 badthing = "a HASH";
8597 break;
5f66b61c
AL		 8598 default:
8599 badthing = NULL;
8600 break;
44a8e56a 8601 }
8602 if (badthing)
1c846c1f 8603 Perl_croak(aTHX_
95b63a38 8604 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
be2597df 8605 SVfARG(kidsv), badthing);
44a8e56a 8606 }
93233ece
CS		 8607 /*
8608 * This is a little tricky. We only want to add the symbol if we
8609 * didn't add it in the lexer. Otherwise we get duplicate strict
8610 * warnings. But if we didn't add it in the lexer, we must at
8611 * least pretend like we wanted to add it even if it existed before,
8612 * or we get possible typo warnings. OPpCONST_ENTERED says
8613 * whether the lexer already added THIS instance of this symbol.
8614 */
5196be3e 8615 iscv = (o->op_type == OP_RV2CV) * 2;
93233ece 8616 do {
7a5fd60d 8617 gv = gv_fetchsv(kidsv,
748a9306 8618 iscv | !(kid->op_private & OPpCONST_ENTERED),
a0d0e21e
LW		 8619 iscv
8620 ? SVt_PVCV
11343788 8621 : o->op_type == OP_RV2SV
a0d0e21e 8622 ? SVt_PV
11343788 8623 : o->op_type == OP_RV2AV
a0d0e21e 8624 ? SVt_PVAV
11343788 8625 : o->op_type == OP_RV2HV
a0d0e21e
LW		 8626 ? SVt_PVHV
8627 : SVt_PVGV);
93233ece
CS		 8628 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
8629 if (gv) {
8630 kid->op_type = OP_GV;
8631 SvREFCNT_dec(kid->op_sv);
350de78d 8632#ifdef USE_ITHREADS
638eceb6 8633 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
653e8c97 8634 assert (sizeof(PADOP) <= sizeof(SVOP));
350de78d 8635 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
dd2155a4 8636 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
743e66e6 8637 GvIN_PAD_on(gv);
ad64d0ec 8638 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
350de78d 8639#else
b37c2d43 8640 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
350de78d 8641#endif
23f1ca44 8642 kid->op_private = 0;
76cd736e 8643 kid->op_ppaddr = PL_ppaddr[OP_GV];
2acc3314
FC		 8644 /* FAKE globs in the symbol table cause weird bugs (#77810) */
8645 SvFAKE_off(gv);
a0d0e21e 8646 }
79072805 8647 }
11343788 8648 return o;
79072805
LW		 8649}
8650
8651OP *
cea2e8a9 8652Perl_ck_ftst(pTHX_ OP *o)
79072805 8653{
27da23d5 8654 dVAR;
6867be6d 8655 const I32 type = o->op_type;
79072805 8656
7918f24d
NC		 8657 PERL_ARGS_ASSERT_CK_FTST;
8658
d0dca557 8659 if (o->op_flags & OPf_REF) {
6f207bd3 8660 NOOP;
d0dca557
JD		 8661 }
8662 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
551405c4 8663 SVOP * const kid = (SVOP*)cUNOPo->op_first;
1496a290 8664 const OPCODE kidtype = kid->op_type;
79072805 8665
9a0c9949 8666 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
3513c740 8667 && !kid->op_folded) {
551405c4 8668 OP * const newop = newGVOP(type, OPf_REF,
f776e3cd 8669 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
eb8433b7
NC		 8670#ifdef PERL_MAD
8671 op_getmad(o,newop,'O');
8672#else
11343788 8673 op_free(o);
eb8433b7 8674#endif
1d866c12 8675 return newop;
79072805 8676 }
6ecf81d6 8677 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
1af34c76 8678 o->op_private |= OPpFT_ACCESS;
ef69c8fc 8679 if (PL_check[kidtype] == Perl_ck_ftst
bbd91306 8680 && kidtype != OP_STAT && kidtype != OP_LSTAT) {
fbb0b3b3 8681 o->op_private |= OPpFT_STACKED;
bbd91306 8682 kid->op_private |= OPpFT_STACKING;
8db8f6b6
FC		 8683 if (kidtype == OP_FTTTY && (
8684 !(kid->op_private & OPpFT_STACKED)
8685 || kid->op_private & OPpFT_AFTER_t
8686 ))
8687 o->op_private |= OPpFT_AFTER_t;
bbd91306 8688 }
79072805
LW		 8689 }
8690 else {
eb8433b7 8691#ifdef PERL_MAD
1d866c12 8692 OP* const oldo = o;
eb8433b7 8693#else
11343788 8694 op_free(o);
eb8433b7 8695#endif
79072805 8696 if (type == OP_FTTTY)
8fde6460 8697 o = newGVOP(type, OPf_REF, PL_stdingv);
79072805 8698 else
d0dca557 8699 o = newUNOP(type, 0, newDEFSVOP());
eb8433b7 8700 op_getmad(oldo,o,'O');
79072805 8701 }
11343788 8702 return o;
79072805
LW		 8703}
8704
8705OP *
cea2e8a9 8706Perl_ck_fun(pTHX_ OP *o)
79072805 8707{
97aff369 8708 dVAR;
6867be6d 8709 const int type = o->op_type;
eb578fdb 8710 I32 oa = PL_opargs[type] >> OASHIFT;
aeea060c 8711
7918f24d
NC		 8712 PERL_ARGS_ASSERT_CK_FUN;
8713
11343788 8714 if (o->op_flags & OPf_STACKED) {
79072805
LW		 8715 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
8716 oa &= ~OA_OPTIONAL;
8717 else
11343788 8718 return no_fh_allowed(o);
79072805
LW		 8719 }
8720
11343788 8721 if (o->op_flags & OPf_KIDS) {
6867be6d 8722 OP **tokid = &cLISTOPo->op_first;
eb578fdb 8723 OP *kid = cLISTOPo->op_first;
6867be6d
AL		 8724 OP *sibl;
8725 I32 numargs = 0;
ea5703f4 8726 bool seen_optional = FALSE;
6867be6d 8727
8990e307 8728 if (kid->op_type == OP_PUSHMARK ||
155aba94 8729 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
8990e307 8730 {
79072805
LW		 8731 tokid = &kid->op_sibling;
8732 kid = kid->op_sibling;
8733 }
f6a16869
FC		 8734 if (kid && kid->op_type == OP_COREARGS) {
8735 bool optional = FALSE;
8736 while (oa) {
8737 numargs++;
8738 if (oa & OA_OPTIONAL) optional = TRUE;
8739 oa = oa >> 4;
8740 }
8741 if (optional) o->op_private |= numargs;
8742 return o;
8743 }
79072805 8744
ea5703f4 8745 while (oa) {
72ec8a82 8746 if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
ea5703f4
FC		 8747 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV)
8748 *tokid = kid = newDEFSVOP();
8749 seen_optional = TRUE;
8750 }
8751 if (!kid) break;
8752
79072805
LW		 8753 numargs++;
8754 sibl = kid->op_sibling;
eb8433b7
NC		 8755#ifdef PERL_MAD
8756 if (!sibl && kid->op_type == OP_STUB) {
8757 numargs--;
8758 break;
8759 }
8760#endif
79072805
LW		 8761 switch (oa & 7) {
8762 case OA_SCALAR:
62c18ce2
GS		 8763 /* list seen where single (scalar) arg expected? */
8764 if (numargs == 1 && !(oa >> 4)
8765 && kid->op_type == OP_LIST && type != OP_SCALAR)
8766 {
ce16c625 8767 return too_many_arguments_pv(o,PL_op_desc[type], 0);
62c18ce2 8768 }
79072805
LW		 8769 scalar(kid);
8770 break;
8771 case OA_LIST:
8772 if (oa < 16) {
8773 kid = 0;
8774 continue;
8775 }
8776 else
8777 list(kid);
8778 break;
8779 case OA_AVREF:
936edb8b 8780 if ((type == OP_PUSH || type == OP_UNSHIFT)
a2a5de95
NC		 8781 && !kid->op_sibling)
8782 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
8783 "Useless use of %s with no values",
8784 PL_op_desc[type]);
b2ffa427 8785
79072805 8786 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 8787 (kid->op_private & OPpCONST_BARE))
8788 {
551405c4 8789 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
f776e3cd 8790 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
d1d15184 8791 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
a2a5de95
NC		 8792 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
8793 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
eb8433b7
NC		 8794#ifdef PERL_MAD
8795 op_getmad(kid,newop,'K');
8796#else
79072805 8797 op_free(kid);
eb8433b7 8798#endif
79072805
LW		 8799 kid = newop;
8800 kid->op_sibling = sibl;
8801 *tokid = kid;
8802 }
d4fc4415
FC		 8803 else if (kid->op_type == OP_CONST
8804 && ( !SvROK(cSVOPx_sv(kid))
8805 || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
8806 )
ce16c625 8807 bad_type_pv(numargs, "array", PL_op_desc[type], 0, kid);
d4fc4415
FC		 8808 /* Defer checks to run-time if we have a scalar arg */
8809 if (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV)
8810 op_lvalue(kid, type);
8811 else scalar(kid);
79072805
LW		 8812 break;
8813 case OA_HVREF:
8814 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 8815 (kid->op_private & OPpCONST_BARE))
8816 {
551405c4 8817 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
f776e3cd 8818 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
d1d15184 8819 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
a2a5de95
NC		 8820 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
8821 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
eb8433b7
NC		 8822#ifdef PERL_MAD
8823 op_getmad(kid,newop,'K');
8824#else
79072805 8825 op_free(kid);
eb8433b7 8826#endif
79072805
LW		 8827 kid = newop;
8828 kid->op_sibling = sibl;
8829 *tokid = kid;
8830 }
8990e307 8831 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
ce16c625 8832 bad_type_pv(numargs, "hash", PL_op_desc[type], 0, kid);
3ad73efd 8833 op_lvalue(kid, type);
79072805
LW		 8834 break;
8835 case OA_CVREF:
8836 {
551405c4 8837 OP * const newop = newUNOP(OP_NULL, 0, kid);
79072805 8838 kid->op_sibling = 0;
79072805
LW		 8839 newop->op_next = newop;
8840 kid = newop;
8841 kid->op_sibling = sibl;
8842 *tokid = kid;
8843 }
8844 break;
8845 case OA_FILEREF:
c340be78 8846 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
79072805 8847 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 8848 (kid->op_private & OPpCONST_BARE))
8849 {
0bd48802 8850 OP * const newop = newGVOP(OP_GV, 0,
f776e3cd 8851 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
afbdacea 8852 if (!(o->op_private & 1) && /* if not unop */
8a996ce8 8853 kid == cLISTOPo->op_last)
364daeac 8854 cLISTOPo->op_last = newop;
eb8433b7
NC		 8855#ifdef PERL_MAD
8856 op_getmad(kid,newop,'K');
8857#else
79072805 8858 op_free(kid);
eb8433b7 8859#endif
79072805
LW		 8860 kid = newop;
8861 }
1ea32a52
GS		 8862 else if (kid->op_type == OP_READLINE) {
8863 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
ce16c625 8864 bad_type_pv(numargs, "HANDLE", OP_DESC(o), 0, kid);
1ea32a52 8865 }
79072805 8866 else {
35cd451c 8867 I32 flags = OPf_SPECIAL;
a6c40364 8868 I32 priv = 0;
2c8ac474
GS		 8869 PADOFFSET targ = 0;
8870
35cd451c 8871 /* is this op a FH constructor? */
853846ea 8872 if (is_handle_constructor(o,numargs)) {
bd61b366 8873 const char *name = NULL;
dd2155a4 8874 STRLEN len = 0;
2dc9cdca 8875 U32 name_utf8 = 0;
885f468a 8876 bool want_dollar = TRUE;
2c8ac474
GS		 8877
8878 flags = 0;
8879 /* Set a flag to tell rv2gv to vivify
853846ea
NIS		 8880 * need to "prove" flag does not mean something
8881 * else already - NI-S 1999/05/07
2c8ac474
GS		 8882 */
8883 priv = OPpDEREF;
8884 if (kid->op_type == OP_PADSV) {
f8503592
NC		 8885 SV *const namesv
8886 = PAD_COMPNAME_SV(kid->op_targ);
8887 name = SvPV_const(namesv, len);
2dc9cdca 8888 name_utf8 = SvUTF8(namesv);
2c8ac474
GS		 8889 }
8890 else if (kid->op_type == OP_RV2SV
8891 && kUNOP->op_first->op_type == OP_GV)
8892 {
0bd48802 8893 GV * const gv = cGVOPx_gv(kUNOP->op_first);
2c8ac474
GS		 8894 name = GvNAME(gv);
8895 len = GvNAMELEN(gv);
2dc9cdca 8896 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
2c8ac474 8897 }
afd1915d
GS		 8898 else if (kid->op_type == OP_AELEM
8899 || kid->op_type == OP_HELEM)
8900 {
735fec84 8901 OP *firstop;
551405c4 8902 OP *op = ((BINOP*)kid)->op_first;
a4fc7abc 8903 name = NULL;
551405c4 8904 if (op) {
a0714e2c 8905 SV *tmpstr = NULL;
551405c4 8906 const char * const a =
666ea192
JH		 8907 kid->op_type == OP_AELEM ?
8908 "[]" : "{}";
0c4b0a3f
JH		 8909 if (((op->op_type == OP_RV2AV) ||
8910 (op->op_type == OP_RV2HV)) &&
735fec84
RGS		 8911 (firstop = ((UNOP*)op)->op_first) &&
8912 (firstop->op_type == OP_GV)) {
0c4b0a3f 8913 /* packagevar $a[] or $h{} */
735fec84 8914 GV * const gv = cGVOPx_gv(firstop);
0c4b0a3f
JH		 8915 if (gv)
8916 tmpstr =
8917 Perl_newSVpvf(aTHX_
8918 "%s%c...%c",
8919 GvNAME(gv),
8920 a[0], a[1]);
8921 }
8922 else if (op->op_type == OP_PADAV
8923 || op->op_type == OP_PADHV) {
8924 /* lexicalvar $a[] or $h{} */
551405c4 8925 const char * const padname =
0c4b0a3f
JH		 8926 PAD_COMPNAME_PV(op->op_targ);
8927 if (padname)
8928 tmpstr =
8929 Perl_newSVpvf(aTHX_
8930 "%s%c...%c",
8931 padname + 1,
8932 a[0], a[1]);
0c4b0a3f
JH		 8933 }
8934 if (tmpstr) {
93524f2b 8935 name = SvPV_const(tmpstr, len);
2dc9cdca 8936 name_utf8 = SvUTF8(tmpstr);
0c4b0a3f
JH		 8937 sv_2mortal(tmpstr);
8938 }
8939 }
8940 if (!name) {
8941 name = "__ANONIO__";
8942 len = 10;
885f468a 8943 want_dollar = FALSE;
0c4b0a3f 8944 }
3ad73efd 8945 op_lvalue(kid, type);
afd1915d 8946 }
2c8ac474
GS		 8947 if (name) {
8948 SV *namesv;
8949 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
dd2155a4 8950 namesv = PAD_SVl(targ);
862a34c6 8951 SvUPGRADE(namesv, SVt_PV);
885f468a 8952 if (want_dollar && *name != '$')
76f68e9b 8953 sv_setpvs(namesv, "$");
2c8ac474 8954 sv_catpvn(namesv, name, len);
2dc9cdca 8955 if ( name_utf8 ) SvUTF8_on(namesv);
2c8ac474 8956 }
853846ea 8957 }
79072805 8958 kid->op_sibling = 0;
35cd451c 8959 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
2c8ac474
GS		 8960 kid->op_targ = targ;
8961 kid->op_private |= priv;
79072805
LW		 8962 }
8963 kid->op_sibling = sibl;
8964 *tokid = kid;
8965 }
8966 scalar(kid);
8967 break;
8968 case OA_SCALARREF:
1efec5ed
FC		 8969 if ((type == OP_UNDEF || type == OP_POS)
8970 && numargs == 1 && !(oa >> 4)
89c5c07e
FC		 8971 && kid->op_type == OP_LIST)
8972 return too_many_arguments_pv(o,PL_op_desc[type], 0);
3ad73efd 8973 op_lvalue(scalar(kid), type);
79072805
LW		 8974 break;
8975 }
8976 oa >>= 4;
8977 tokid = &kid->op_sibling;
8978 kid = kid->op_sibling;
8979 }
eb8433b7
NC		 8980#ifdef PERL_MAD
8981 if (kid && kid->op_type != OP_STUB)
ce16c625 8982 return too_many_arguments_pv(o,OP_DESC(o), 0);
eb8433b7
NC		 8983 o->op_private |= numargs;
8984#else
8985 /* FIXME - should the numargs move as for the PERL_MAD case? */
11343788 8986 o->op_private |= numargs;
79072805 8987 if (kid)
ce16c625 8988 return too_many_arguments_pv(o,OP_DESC(o), 0);
eb8433b7 8989#endif
11343788 8990 listkids(o);
79072805 8991 }
22c35a8c 8992 else if (PL_opargs[type] & OA_DEFGV) {
c56915e3 8993#ifdef PERL_MAD
c7fe699d 8994 OP *newop = newUNOP(type, 0, newDEFSVOP());
c56915e3 8995 op_getmad(o,newop,'O');
c7fe699d 8996 return newop;
c56915e3 8997#else
c7fe699d 8998 /* Ordering of these two is important to keep f_map.t passing. */
11343788 8999 op_free(o);
c7fe699d 9000 return newUNOP(type, 0, newDEFSVOP());
c56915e3 9001#endif
a0d0e21e
LW		 9002 }
9003
79072805
LW		 9004 if (oa) {
9005 while (oa & OA_OPTIONAL)
9006 oa >>= 4;
9007 if (oa && oa != OA_LIST)
ce16c625 9008 return too_few_arguments_pv(o,OP_DESC(o), 0);
79072805 9009 }
11343788 9010 return o;
79072805
LW		 9011}
9012
9013OP *
cea2e8a9 9014Perl_ck_glob(pTHX_ OP *o)
79072805 9015{
27da23d5 9016 dVAR;
fb73857a 9017 GV *gv;
d67594ff 9018 const bool core = o->op_flags & OPf_SPECIAL;
fb73857a 9019
7918f24d
NC		 9020 PERL_ARGS_ASSERT_CK_GLOB;
9021
649da076 9022 o = ck_fun(o);
1f2bfc8a 9023 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
bd31915d 9024 op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
fb73857a 9025
d67594ff
FC		 9026 if (core) gv = NULL;
9027 else if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
b9f751c0
GS		 9028 && GvCVu(gv) && GvIMPORTED_CV(gv)))
9029 {
8113e1cc
FC		 9030 GV * const * const gvp =
9031 (GV **)hv_fetchs(PL_globalstash, "glob", FALSE);
9032 gv = gvp ? *gvp : NULL;
b9f751c0 9033 }
b1cb66bf 9034
b9f751c0 9035 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
d1bea3d8
DM		 9036 /* convert
9037 * glob
9038 * \ null - const(wildcard)
9039 * into
9040 * null
9041 * \ enter
9042 * \ list
9043 * \ mark - glob - rv2cv
9044 * | \ gv(CORE::GLOBAL::glob)
9045 * |
9423a867 9046 * \ null - const(wildcard)
d1bea3d8
DM		 9047 */
9048 o->op_flags |= OPf_SPECIAL;
9426e1a5 9049 o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
d1bea3d8 9050 o = newLISTOP(OP_LIST, 0, o, NULL);
1f2bfc8a 9051 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
2fcb4757 9052 op_append_elem(OP_LIST, o,
1f2bfc8a
MB		 9053 scalar(newUNOP(OP_RV2CV, 0,
9054 newGVOP(OP_GV, 0, gv)))));
7ae76aaa 9055 o = newUNOP(OP_NULL, 0, o);
d1bea3d8 9056 o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
d58bf5aa 9057 return o;
b1cb66bf 9058 }
d67594ff 9059 else o->op_flags &= ~OPf_SPECIAL;
39e3b1bc
FC		 9060#if !defined(PERL_EXTERNAL_GLOB)
9061 if (!PL_globhook) {
9062 ENTER;
9063 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
9064 newSVpvs("File::Glob"), NULL, NULL, NULL);
9065 LEAVE;
9066 }
9067#endif /* !PERL_EXTERNAL_GLOB */
e88567f2
FC		 9068 gv = (GV *)newSV(0);
9069 gv_init(gv, 0, "", 0, 0);
a0d0e21e 9070 gv_IOadd(gv);
2fcb4757 9071 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
fc2b2dca 9072 SvREFCNT_dec_NN(gv); /* newGVOP increased it */
11343788 9073 scalarkids(o);
649da076 9074 return o;
79072805
LW		 9075}
9076
9077OP *
cea2e8a9 9078Perl_ck_grep(pTHX_ OP *o)
79072805 9079{
27da23d5 9080 dVAR;
2471236a 9081 LOGOP *gwop;
79072805 9082 OP *kid;
6867be6d 9083 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
9f7d9405 9084 PADOFFSET offset;
79072805 9085
7918f24d
NC		 9086 PERL_ARGS_ASSERT_CK_GREP;
9087
22c35a8c 9088 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
13765c85 9089 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
aeea060c 9090
11343788 9091 if (o->op_flags & OPf_STACKED) {
2471236a 9092 kid = cUNOPx(cLISTOPo->op_first->op_sibling)->op_first;
f6435df3
GG		 9093 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
9094 return no_fh_allowed(o);
11343788 9095 o->op_flags &= ~OPf_STACKED;
93a17b20 9096 }
11343788 9097 kid = cLISTOPo->op_first->op_sibling;
a0d0e21e
LW		 9098 if (type == OP_MAPWHILE)
9099 list(kid);
9100 else
9101 scalar(kid);
11343788 9102 o = ck_fun(o);
13765c85 9103 if (PL_parser && PL_parser->error_count)
11343788 9104 return o;
aeea060c 9105 kid = cLISTOPo->op_first->op_sibling;
79072805 9106 if (kid->op_type != OP_NULL)
5637ef5b 9107 Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
79072805
LW		 9108 kid = kUNOP->op_first;
9109
2471236a 9110 NewOp(1101, gwop, 1, LOGOP);
a0d0e21e 9111 gwop->op_type = type;
22c35a8c 9112 gwop->op_ppaddr = PL_ppaddr[type];
09fe0e74 9113 gwop->op_first = o;
79072805 9114 gwop->op_flags |= OPf_KIDS;
79072805 9115 gwop->op_other = LINKLIST(kid);
79072805 9116 kid->op_next = (OP*)gwop;
cc76b5cc 9117 offset = pad_findmy_pvs("$_", 0);
00b1698f 9118 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
59f00321
RGS		 9119 o->op_private = gwop->op_private = 0;
9120 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
9121 }
9122 else {
9123 o->op_private = gwop->op_private = OPpGREP_LEX;
9124 gwop->op_targ = o->op_targ = offset;
9125 }
79072805 9126
11343788 9127 kid = cLISTOPo->op_first->op_sibling;
a0d0e21e 9128 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
3ad73efd 9129 op_lvalue(kid, OP_GREPSTART);
a0d0e21e 9130
79072805
LW		 9131 return (OP*)gwop;
9132}
9133
9134OP *
cea2e8a9 9135Perl_ck_index(pTHX_ OP *o)
79072805 9136{
7918f24d
NC		 9137 PERL_ARGS_ASSERT_CK_INDEX;
9138
11343788
MB		 9139 if (o->op_flags & OPf_KIDS) {
9140 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
0b71040e
LW		 9141 if (kid)
9142 kid = kid->op_sibling; /* get past "big" */
3b36395d 9143 if (kid && kid->op_type == OP_CONST) {
9a9b5ec9 9144 const bool save_taint = TAINT_get;
310f4fdb
FC		 9145 SV *sv = kSVOP->op_sv;
9146 if ((!SvPOK(sv) || SvNIOKp(sv)) && SvOK(sv) && !SvROK(sv)) {
9147 sv = newSV(0);
9148 sv_copypv(sv, kSVOP->op_sv);
9149 SvREFCNT_dec_NN(kSVOP->op_sv);
9150 kSVOP->op_sv = sv;
9151 }
9152 if (SvOK(sv)) fbm_compile(sv, 0);
284167a5 9153 TAINT_set(save_taint);
9a9b5ec9
DM		 9154#ifdef NO_TAINT_SUPPORT
9155 PERL_UNUSED_VAR(save_taint);
9156#endif
3b36395d 9157 }
79072805 9158 }
11343788 9159 return ck_fun(o);
79072805
LW		 9160}
9161
9162OP *
cea2e8a9 9163Perl_ck_lfun(pTHX_ OP *o)
79072805 9164{
6867be6d 9165 const OPCODE type = o->op_type;
7918f24d
NC		 9166
9167 PERL_ARGS_ASSERT_CK_LFUN;
9168
5dc0d613 9169 return modkids(ck_fun(o), type);
79072805
LW		 9170}
9171
9172OP *
cea2e8a9 9173Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
69794302 9174{
7918f24d
NC		 9175 PERL_ARGS_ASSERT_CK_DEFINED;
9176
a2a5de95 9177 if ((o->op_flags & OPf_KIDS)) {
d0334bed
GS		 9178 switch (cUNOPo->op_first->op_type) {
9179 case OP_RV2AV:
9180 case OP_PADAV:
9181 case OP_AASSIGN: /* Is this a good idea? */
d1d15184 9182 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
a2a5de95 9183 "defined(@array) is deprecated");
d1d15184 9184 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
a2a5de95 9185 "\t(Maybe you should just omit the defined()?)\n");
69794302 9186 break;
d0334bed
GS		 9187 case OP_RV2HV:
9188 case OP_PADHV:
d1d15184 9189 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
a2a5de95 9190 "defined(%%hash) is deprecated");
d1d15184 9191 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
a2a5de95 9192 "\t(Maybe you should just omit the defined()?)\n");
d0334bed
GS		 9193 break;
9194 default:
9195 /* no warning */
9196 break;
9197 }
69794302
MJD		 9198 }
9199 return ck_rfun(o);
9200}
9201
9202OP *
e4b7ebf3
RGS		 9203Perl_ck_readline(pTHX_ OP *o)
9204{
7918f24d
NC		 9205 PERL_ARGS_ASSERT_CK_READLINE;
9206
b73e5385
FC		 9207 if (o->op_flags & OPf_KIDS) {
9208 OP *kid = cLISTOPo->op_first;
9209 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
9210 }
9211 else {
e4b7ebf3
RGS		 9212 OP * const newop
9213 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
9214#ifdef PERL_MAD
9215 op_getmad(o,newop,'O');
9216#else
9217 op_free(o);
9218#endif
9219 return newop;
9220 }
9221 return o;
9222}
9223
9224OP *
cea2e8a9 9225Perl_ck_rfun(pTHX_ OP *o)
8990e307 9226{
6867be6d 9227 const OPCODE type = o->op_type;
7918f24d
NC		 9228
9229 PERL_ARGS_ASSERT_CK_RFUN;
9230
5dc0d613 9231 return refkids(ck_fun(o), type);
8990e307
LW		 9232}
9233
9234OP *
cea2e8a9 9235Perl_ck_listiob(pTHX_ OP *o)
79072805 9236{
eb578fdb 9237 OP *kid;
aeea060c 9238
7918f24d
NC		 9239 PERL_ARGS_ASSERT_CK_LISTIOB;
9240
11343788 9241 kid = cLISTOPo->op_first;
79072805 9242 if (!kid) {
11343788
MB		 9243 o = force_list(o);
9244 kid = cLISTOPo->op_first;
79072805
LW		 9245 }
9246 if (kid->op_type == OP_PUSHMARK)
9247 kid = kid->op_sibling;
11343788 9248 if (kid && o->op_flags & OPf_STACKED)
79072805
LW		 9249 kid = kid->op_sibling;
9250 else if (kid && !kid->op_sibling) { /* print HANDLE; */
01050d49 9251 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
3513c740 9252 && !kid->op_folded) {
11343788 9253 o->op_flags |= OPf_STACKED; /* make it a filehandle */
748a9306 9254 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
11343788
MB		 9255 cLISTOPo->op_first->op_sibling = kid;
9256 cLISTOPo->op_last = kid;
79072805
LW		 9257 kid = kid->op_sibling;
9258 }
9259 }
b2ffa427 9260
79072805 9261 if (!kid)
2fcb4757 9262 op_append_elem(o->op_type, o, newDEFSVOP());
79072805 9263
69974ce6 9264 if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
2de3dbcc 9265 return listkids(o);
bbce6d69 9266}
9267
9268OP *
0d863452
RH		 9269Perl_ck_smartmatch(pTHX_ OP *o)
9270{
97aff369 9271 dVAR;
a4e74480 9272 PERL_ARGS_ASSERT_CK_SMARTMATCH;
0d863452
RH		 9273 if (0 == (o->op_flags & OPf_SPECIAL)) {
9274 OP *first = cBINOPo->op_first;
9275 OP *second = first->op_sibling;
9276
9277 /* Implicitly take a reference to an array or hash */
5f66b61c 9278 first->op_sibling = NULL;
0d863452
RH		 9279 first = cBINOPo->op_first = ref_array_or_hash(first);
9280 second = first->op_sibling = ref_array_or_hash(second);
9281
9282 /* Implicitly take a reference to a regular expression */
9283 if (first->op_type == OP_MATCH) {
9284 first->op_type = OP_QR;
9285 first->op_ppaddr = PL_ppaddr[OP_QR];
9286 }
9287 if (second->op_type == OP_MATCH) {
9288 second->op_type = OP_QR;
9289 second->op_ppaddr = PL_ppaddr[OP_QR];
9290 }
9291 }
9292
9293 return o;
9294}
9295
9296
9297OP *
b162f9ea
IZ		 9298Perl_ck_sassign(pTHX_ OP *o)
9299{
3088bf26 9300 dVAR;
1496a290 9301 OP * const kid = cLISTOPo->op_first;
7918f24d
NC		 9302
9303 PERL_ARGS_ASSERT_CK_SASSIGN;
9304
b162f9ea
IZ		 9305 /* has a disposable target? */
9306 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6b66af17
GS		 9307 && !(kid->op_flags & OPf_STACKED)
9308 /* Cannot steal the second time! */
1b438339
GG		 9309 && !(kid->op_private & OPpTARGET_MY)
9310 /* Keep the full thing for madskills */
9311 && !PL_madskills
9312 )
b162f9ea 9313 {
551405c4 9314 OP * const kkid = kid->op_sibling;
b162f9ea
IZ		 9315
9316 /* Can just relocate the target. */
2c2d71f5
JH		 9317 if (kkid && kkid->op_type == OP_PADSV
9318 && !(kkid->op_private & OPpLVAL_INTRO))
9319 {
b162f9ea 9320 kid->op_targ = kkid->op_targ;
743e66e6 9321 kkid->op_targ = 0;
b162f9ea
IZ		 9322 /* Now we do not need PADSV and SASSIGN. */
9323 kid->op_sibling = o->op_sibling; /* NULL */
9324 cLISTOPo->op_first = NULL;
9325 op_free(o);
9326 op_free(kkid);
9327 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
9328 return kid;
9329 }
9330 }
c5917253
NC		 9331 if (kid->op_sibling) {
9332 OP *kkid = kid->op_sibling;
a1fba7eb
FC		 9333 /* For state variable assignment, kkid is a list op whose op_last
9334 is a padsv. */
9335 if ((kkid->op_type == OP_PADSV ||
9336 (kkid->op_type == OP_LIST &&
9337 (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
9338 )
9339 )
c5917253
NC		 9340 && (kkid->op_private & OPpLVAL_INTRO)
9341 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
9342 const PADOFFSET target = kkid->op_targ;
9343 OP *const other = newOP(OP_PADSV,
9344 kkid->op_flags
9345 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
9346 OP *const first = newOP(OP_NULL, 0);
9347 OP *const nullop = newCONDOP(0, first, o, other);
9348 OP *const condop = first->op_next;
9349 /* hijacking PADSTALE for uninitialized state variables */
9350 SvPADSTALE_on(PAD_SVl(target));
9351
9352 condop->op_type = OP_ONCE;
9353 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
9354 condop->op_targ = target;
9355 other->op_targ = target;
9356
95562366 9357 /* Because we change the type of the op here, we will skip the
486ec47a 9358 assignment binop->op_last = binop->op_first->op_sibling; at the
95562366
NC		 9359 end of Perl_newBINOP(). So need to do it here. */
9360 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
9361
c5917253
NC		 9362 return nullop;
9363 }
9364 }
b162f9ea
IZ		 9365 return o;
9366}
9367
9368OP *
cea2e8a9 9369Perl_ck_match(pTHX_ OP *o)
79072805 9370{
97aff369 9371 dVAR;
7918f24d
NC		 9372
9373 PERL_ARGS_ASSERT_CK_MATCH;
9374
0d863452 9375 if (o->op_type != OP_QR && PL_compcv) {
cc76b5cc 9376 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
00b1698f 9377 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
59f00321
RGS		 9378 o->op_targ = offset;
9379 o->op_private |= OPpTARGET_MY;
9380 }
9381 }
9382 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
9383 o->op_private |= OPpRUNTIME;
11343788 9384 return o;
79072805
LW		 9385}
9386
9387OP *
f5d5a27c
CS		 9388Perl_ck_method(pTHX_ OP *o)
9389{
551405c4 9390 OP * const kid = cUNOPo->op_first;
7918f24d
NC		 9391
9392 PERL_ARGS_ASSERT_CK_METHOD;
9393
f5d5a27c
CS		 9394 if (kid->op_type == OP_CONST) {
9395 SV* sv = kSVOP->op_sv;
a4fc7abc
AL		 9396 const char * const method = SvPVX_const(sv);
9397 if (!(strchr(method, ':') || strchr(method, '\''))) {
f5d5a27c 9398 OP *cmop;
e3918bb7 9399 if (!SvIsCOW(sv)) {
c60dbbc3 9400 sv = newSVpvn_share(method, SvUTF8(sv) ? -(I32)SvCUR(sv) : (I32)SvCUR(sv), 0);
1c846c1f
NIS		 9401 }
9402 else {
a0714e2c 9403 kSVOP->op_sv = NULL;
1c846c1f 9404 }
f5d5a27c 9405 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
eb8433b7
NC		 9406#ifdef PERL_MAD
9407 op_getmad(o,cmop,'O');
9408#else
f5d5a27c 9409 op_free(o);
eb8433b7 9410#endif
f5d5a27c
CS		 9411 return cmop;
9412 }
9413 }
9414 return o;
9415}
9416
9417OP *
cea2e8a9 9418Perl_ck_null(pTHX_ OP *o)
79072805 9419{
7918f24d 9420 PERL_ARGS_ASSERT_CK_NULL;
96a5add6 9421 PERL_UNUSED_CONTEXT;
11343788 9422 return o;
79072805
LW		 9423}
9424
9425OP *
16fe6d59
GS		 9426Perl_ck_open(pTHX_ OP *o)
9427{
97aff369 9428 dVAR;
551405c4 9429 HV * const table = GvHV(PL_hintgv);
7918f24d
NC		 9430
9431 PERL_ARGS_ASSERT_CK_OPEN;
9432
16fe6d59 9433 if (table) {
a4fc7abc 9434 SV **svp = hv_fetchs(table, "open_IN", FALSE);
16fe6d59 9435 if (svp && *svp) {
a79b25b7
VP		 9436 STRLEN len = 0;
9437 const char *d = SvPV_const(*svp, len);
9438 const I32 mode = mode_from_discipline(d, len);
16fe6d59
GS		 9439 if (mode & O_BINARY)
9440 o->op_private |= OPpOPEN_IN_RAW;
9441 else if (mode & O_TEXT)
9442 o->op_private |= OPpOPEN_IN_CRLF;
9443 }
9444
a4fc7abc 9445 svp = hv_fetchs(table, "open_OUT", FALSE);
16fe6d59 9446 if (svp && *svp) {
a79b25b7
VP		 9447 STRLEN len = 0;
9448 const char *d = SvPV_const(*svp, len);
9449 const I32 mode = mode_from_discipline(d, len);
16fe6d59
GS		 9450 if (mode & O_BINARY)
9451 o->op_private |= OPpOPEN_OUT_RAW;
9452 else if (mode & O_TEXT)
9453 o->op_private |= OPpOPEN_OUT_CRLF;
9454 }
9455 }
8d7403e6
RGS		 9456 if (o->op_type == OP_BACKTICK) {
9457 if (!(o->op_flags & OPf_KIDS)) {
e4b7ebf3
RGS		 9458 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
9459#ifdef PERL_MAD
9460 op_getmad(o,newop,'O');
9461#else
8d7403e6 9462 op_free(o);
e4b7ebf3
RGS		 9463#endif
9464 return newop;
8d7403e6 9465 }
16fe6d59 9466 return o;
8d7403e6 9467 }
3b82e551
JH		 9468 {
9469 /* In case of three-arg dup open remove strictness
9470 * from the last arg if it is a bareword. */
551405c4
AL		 9471 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
9472 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
3b82e551 9473 OP *oa;
b15aece3 9474 const char *mode;
3b82e551
JH		 9475
9476 if ((last->op_type == OP_CONST) && /* The bareword. */
9477 (last->op_private & OPpCONST_BARE) &&
9478 (last->op_private & OPpCONST_STRICT) &&
9479 (oa = first->op_sibling) && /* The fh. */
9480 (oa = oa->op_sibling) && /* The mode. */
ea1d064a 9481 (oa->op_type == OP_CONST) &&
3b82e551 9482 SvPOK(((SVOP*)oa)->op_sv) &&
b15aece3 9483 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
3b82e551
JH		 9484 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
9485 (last == oa->op_sibling)) /* The bareword. */
9486 last->op_private &= ~OPpCONST_STRICT;
9487 }
16fe6d59
GS		 9488 return ck_fun(o);
9489}
9490
9491OP *
cea2e8a9 9492Perl_ck_repeat(pTHX_ OP *o)
79072805 9493{
7918f24d
NC		 9494 PERL_ARGS_ASSERT_CK_REPEAT;
9495
11343788
MB		 9496 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
9497 o->op_private |= OPpREPEAT_DOLIST;
9498 cBINOPo->op_first = force_list(cBINOPo->op_first);
79072805
LW		 9499 }
9500 else
11343788
MB		 9501 scalar(o);
9502 return o;
79072805
LW		 9503}
9504
9505OP *
cea2e8a9 9506Perl_ck_require(pTHX_ OP *o)
8990e307 9507{
97aff369 9508 dVAR;
a0714e2c 9509 GV* gv = NULL;
ec4ab249 9510
7918f24d
NC		 9511 PERL_ARGS_ASSERT_CK_REQUIRE;
9512
11343788 9513 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
551405c4 9514 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8990e307
LW		 9515
9516 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
551405c4 9517 SV * const sv = kid->op_sv;
5c144d81 9518 U32 was_readonly = SvREADONLY(sv);
8990e307 9519 char *s;
cfff9797
NC		 9520 STRLEN len;
9521 const char *end;
5c144d81
NC		 9522
9523 if (was_readonly) {
5c144d81 9524 SvREADONLY_off(sv);
5c144d81 9525 }
e3918bb7 9526 if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
5c144d81 9527
cfff9797
NC		 9528 s = SvPVX(sv);
9529 len = SvCUR(sv);
9530 end = s + len;
9531 for (; s < end; s++) {
a0d0e21e
LW		 9532 if (*s == ':' && s[1] == ':') {
9533 *s = '/';
5c6b2528 9534 Move(s+2, s+1, end - s - 1, char);
cfff9797 9535 --end;
a0d0e21e 9536 }
8990e307 9537 }
cfff9797 9538 SvEND_set(sv, end);
396482e1 9539 sv_catpvs(sv, ".pm");
5c144d81 9540 SvFLAGS(sv) |= was_readonly;
8990e307
LW		 9541 }
9542 }
ec4ab249 9543
a72a1c8b
RGS		 9544 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
9545 /* handle override, if any */
fafc274c 9546 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
d6a985f2 9547 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
a4fc7abc 9548 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
a0714e2c 9549 gv = gvp ? *gvp : NULL;
d6a985f2 9550 }
a72a1c8b 9551 }
ec4ab249 9552
b9f751c0 9553 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7c864bb3
VP		 9554 OP *kid, *newop;
9555 if (o->op_flags & OPf_KIDS) {
9556 kid = cUNOPo->op_first;
9557 cUNOPo->op_first = NULL;
9558 }
9559 else {
9560 kid = newDEFSVOP();
9561 }
f11453cb 9562#ifndef PERL_MAD
ec4ab249 9563 op_free(o);
eb8433b7 9564#endif
d1bef648 9565 newop = newUNOP(OP_ENTERSUB, OPf_STACKED,
2fcb4757 9566 op_append_elem(OP_LIST, kid,
f11453cb
NC		 9567 scalar(newUNOP(OP_RV2CV, 0,
9568 newGVOP(OP_GV, 0,
d1bef648 9569 gv)))));
f11453cb 9570 op_getmad(o,newop,'O');
eb8433b7 9571 return newop;
ec4ab249
GA		 9572 }
9573
021f53de 9574 return scalar(ck_fun(o));
8990e307
LW		 9575}
9576
78f9721b
SM		 9577OP *
9578Perl_ck_return(pTHX_ OP *o)
9579{
97aff369 9580 dVAR;
e91684bf 9581 OP *kid;
7918f24d
NC		 9582
9583 PERL_ARGS_ASSERT_CK_RETURN;
9584
e91684bf 9585 kid = cLISTOPo->op_first->op_sibling;
78f9721b 9586 if (CvLVALUE(PL_compcv)) {
e91684bf 9587 for (; kid; kid = kid->op_sibling)
3ad73efd 9588 op_lvalue(kid, OP_LEAVESUBLV);
78f9721b 9589 }
e91684bf 9590
78f9721b
SM		 9591 return o;
9592}
9593
79072805 9594OP *
cea2e8a9 9595Perl_ck_select(pTHX_ OP *o)
79072805 9596{
27da23d5 9597 dVAR;
c07a80fd 9598 OP* kid;
7918f24d
NC		 9599
9600 PERL_ARGS_ASSERT_CK_SELECT;
9601
11343788
MB		 9602 if (o->op_flags & OPf_KIDS) {
9603 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
2304df62 9604 if (kid && kid->op_sibling) {
11343788 9605 o->op_type = OP_SSELECT;
22c35a8c 9606 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
11343788 9607 o = ck_fun(o);
985b9e54 9608 return fold_constants(op_integerize(op_std_init(o)));
79072805
LW		 9609 }
9610 }
11343788
MB		 9611 o = ck_fun(o);
9612 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
c07a80fd 9613 if (kid && kid->op_type == OP_RV2GV)
9614 kid->op_private &= ~HINT_STRICT_REFS;
11343788 9615 return o;
79072805
LW		 9616}
9617
9618OP *
cea2e8a9 9619Perl_ck_shift(pTHX_ OP *o)
79072805 9620{
97aff369 9621 dVAR;
6867be6d 9622 const I32 type = o->op_type;
79072805 9623
7918f24d
NC		 9624 PERL_ARGS_ASSERT_CK_SHIFT;
9625
11343788 9626 if (!(o->op_flags & OPf_KIDS)) {
538f5756
RZ		 9627 OP *argop;
9628
9629 if (!CvUNIQUE(PL_compcv)) {
9630 o->op_flags |= OPf_SPECIAL;
9631 return o;
9632 }
9633
9634 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
eb8433b7 9635#ifdef PERL_MAD
790427a5
DM		 9636 {
9637 OP * const oldo = o;
9638 o = newUNOP(type, 0, scalar(argop));
9639 op_getmad(oldo,o,'O');
9640 return o;
9641 }
eb8433b7 9642#else
821005df 9643 op_free(o);
6d4ff0d2 9644 return newUNOP(type, 0, scalar(argop));
eb8433b7 9645#endif
79072805 9646 }
d4fc4415 9647 return scalar(ck_fun(o));
79072805
LW		 9648}
9649
9650OP *
cea2e8a9 9651Perl_ck_sort(pTHX_ OP *o)
79072805 9652{
97aff369 9653 dVAR;
8e3f9bdf 9654 OP *firstkid;
f65493df 9655 OP *kid;
c3258369
FC		 9656 HV * const hinthv =
9657 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;
f65493df 9658 U8 stacked;
bbce6d69 9659
7918f24d
NC		 9660 PERL_ARGS_ASSERT_CK_SORT;
9661
354dd559 9662 if (hinthv) {
a4fc7abc 9663 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7b9ef140 9664 if (svp) {
a4fc7abc 9665 const I32 sorthints = (I32)SvIV(*svp);
7b9ef140
RH		 9666 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
9667 o->op_private |= OPpSORT_QSORT;
9668 if ((sorthints & HINT_SORT_STABLE) != 0)
9669 o->op_private |= OPpSORT_STABLE;
9670 }
7b9ef140
RH		 9671 }
9672
354dd559 9673 if (o->op_flags & OPf_STACKED)
51a19bc0 9674 simplify_sort(o);
8e3f9bdf 9675 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
f65493df 9676 if ((stacked = o->op_flags & OPf_STACKED)) { /* may have been cleared */
8e3f9bdf 9677 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
79072805 9678
463ee0b2 9679 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
5983a79d 9680 LINKLIST(kid);
c650d697 9681 if (kid->op_type == OP_LEAVE)
93c66552 9682 op_null(kid); /* wipe out leave */
c650d697
FC		 9683 /* Prevent execution from escaping out of the sort block. */
9684 kid->op_next = 0;
a0d0e21e 9685
354dd559
FC		 9686 /* provide scalar context for comparison function/block */
9687 kid = scalar(firstkid);
9688 kid->op_next = kid;
11343788 9689 o->op_flags |= OPf_SPECIAL;
79072805 9690 }
8e3f9bdf
GS		 9691
9692 firstkid = firstkid->op_sibling;
79072805 9693 }
bbce6d69 9694
f65493df 9695 for (kid = firstkid; kid; kid = kid->op_sibling) {
e9d9e6f3
FC		 9696 /* provide list context for arguments */
9697 list(kid);
f65493df
FC		 9698 if (stacked)
9699 op_lvalue(kid, OP_GREPSTART);
9700 }
8e3f9bdf 9701
11343788 9702 return o;
79072805 9703}
bda4119b
GS		 9704
9705STATIC void
cea2e8a9 9706S_simplify_sort(pTHX_ OP *o)
9c007264 9707{
97aff369 9708 dVAR;
eb578fdb 9709 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
9c007264 9710 OP *k;
eb209983 9711 int descending;
350de78d 9712 GV *gv;
770526c1 9713 const char *gvname;
8023b711 9714 bool have_scopeop;
7918f24d
NC		 9715
9716 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
9717
fafc274c
NC		 9718 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
9719 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
82092f1d 9720 kid = kUNOP->op_first; /* get past null */
8023b711
FC		 9721 if (!(have_scopeop = kid->op_type == OP_SCOPE)
9722 && kid->op_type != OP_LEAVE)
9c007264
JH		 9723 return;
9724 kid = kLISTOP->op_last; /* get past scope */
9725 switch(kid->op_type) {
9726 case OP_NCMP:
9727 case OP_I_NCMP:
9728 case OP_SCMP:
8023b711 9729 if (!have_scopeop) goto padkids;
9c007264
JH		 9730 break;
9731 default:
9732 return;
9733 }
9734 k = kid; /* remember this node*/
271c8bde
FC		 9735 if (kBINOP->op_first->op_type != OP_RV2SV
9736 || kBINOP->op_last ->op_type != OP_RV2SV)
9737 {
9738 /*
9739 Warn about my($a) or my($b) in a sort block, *if* $a or $b is
9740 then used in a comparison. This catches most, but not
9741 all cases. For instance, it catches
9742 sort { my($a); $a <=> $b }
9743 but not
9744 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
9745 (although why you'd do that is anyone's guess).
9746 */
9747
9748 padkids:
9749 if (!ckWARN(WARN_SYNTAX)) return;
9750 kid = kBINOP->op_first;
9751 do {
9752 if (kid->op_type == OP_PADSV) {
9753 SV * const name = AvARRAY(PL_comppad_name)[kid->op_targ];
9754 if (SvCUR(name) == 2 && *SvPVX(name) == '$'
9755 && (SvPVX(name)[1] == 'a' || SvPVX(name)[1] == 'b'))
a2e39214 9756 /* diag_listed_as: "my %s" used in sort comparison */
271c8bde 9757 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
a2e39214
FC		 9758 "\"%s %s\" used in sort comparison",
9759 SvPAD_STATE(name) ? "state" : "my",
271c8bde
FC		 9760 SvPVX(name));
9761 }
9762 } while ((kid = kid->op_sibling));
9c007264 9763 return;
271c8bde 9764 }
9c007264
JH		 9765 kid = kBINOP->op_first; /* get past cmp */
9766 if (kUNOP->op_first->op_type != OP_GV)
9767 return;
9768 kid = kUNOP->op_first; /* get past rv2sv */
638eceb6 9769 gv = kGVOP_gv;
350de78d 9770 if (GvSTASH(gv) != PL_curstash)
9c007264 9771 return;
770526c1
NC		 9772 gvname = GvNAME(gv);
9773 if (*gvname == 'a' && gvname[1] == '\0')
eb209983 9774 descending = 0;
770526c1 9775 else if (*gvname == 'b' && gvname[1] == '\0')
eb209983 9776 descending = 1;
9c007264
JH		 9777 else
9778 return;
eb209983 9779
9c007264 9780 kid = k; /* back to cmp */
271c8bde 9781 /* already checked above that it is rv2sv */
9c007264
JH		 9782 kid = kBINOP->op_last; /* down to 2nd arg */
9783 if (kUNOP->op_first->op_type != OP_GV)
9784 return;
9785 kid = kUNOP->op_first; /* get past rv2sv */
638eceb6 9786 gv = kGVOP_gv;
770526c1
NC		 9787 if (GvSTASH(gv) != PL_curstash)
9788 return;
9789 gvname = GvNAME(gv);
9790 if ( descending
9791 ? !(*gvname == 'a' && gvname[1] == '\0')
9792 : !(*gvname == 'b' && gvname[1] == '\0'))
9c007264
JH		 9793 return;
9794 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
eb209983
NC		 9795 if (descending)
9796 o->op_private |= OPpSORT_DESCEND;
9c007264
JH		 9797 if (k->op_type == OP_NCMP)
9798 o->op_private |= OPpSORT_NUMERIC;
9799 if (k->op_type == OP_I_NCMP)
9800 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
e507f050
SM		 9801 kid = cLISTOPo->op_first->op_sibling;
9802 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
eb8433b7
NC		 9803#ifdef PERL_MAD
9804 op_getmad(kid,o,'S'); /* then delete it */
9805#else
e507f050 9806 op_free(kid); /* then delete it */
eb8433b7 9807#endif
9c007264 9808}
79072805
LW		 9809
9810OP *
cea2e8a9 9811Perl_ck_split(pTHX_ OP *o)
79072805 9812{
27da23d5 9813 dVAR;
eb578fdb 9814 OP *kid;
aeea060c 9815
7918f24d
NC		 9816 PERL_ARGS_ASSERT_CK_SPLIT;
9817
11343788
MB		 9818 if (o->op_flags & OPf_STACKED)
9819 return no_fh_allowed(o);
79072805 9820
11343788 9821 kid = cLISTOPo->op_first;
8990e307 9822 if (kid->op_type != OP_NULL)
5637ef5b 9823 Perl_croak(aTHX_ "panic: ck_split, type=%u", (unsigned) kid->op_type);
8990e307 9824 kid = kid->op_sibling;
11343788 9825 op_free(cLISTOPo->op_first);
f126b75f
MW		 9826 if (kid)
9827 cLISTOPo->op_first = kid;
9828 else {
396482e1 9829 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
11343788 9830 cLISTOPo->op_last = kid; /* There was only one element previously */
85e6fe83 9831 }
79072805 9832
de4bf5b3 9833 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
551405c4 9834 OP * const sibl = kid->op_sibling;
463ee0b2 9835 kid->op_sibling = 0;
dbc200c5 9836 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0, 0); /* OPf_SPECIAL is used to trigger split " " behavior */
11343788
MB		 9837 if (cLISTOPo->op_first == cLISTOPo->op_last)
9838 cLISTOPo->op_last = kid;
9839 cLISTOPo->op_first = kid;
79072805
LW		 9840 kid->op_sibling = sibl;
9841 }
9842
9843 kid->op_type = OP_PUSHRE;
22c35a8c 9844 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
79072805 9845 scalar(kid);
a2a5de95
NC		 9846 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
9847 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
9848 "Use of /g modifier is meaningless in split");
f34840d8 9849 }
79072805
LW		 9850
9851 if (!kid->op_sibling)
2fcb4757 9852 op_append_elem(OP_SPLIT, o, newDEFSVOP());
79072805
LW		 9853
9854 kid = kid->op_sibling;
9855 scalar(kid);
9856
9857 if (!kid->op_sibling)
60041a09 9858 {
2fcb4757 9859 op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
60041a09
FC		 9860 o->op_private |= OPpSPLIT_IMPLIM;
9861 }
ce3e5c45 9862 assert(kid->op_sibling);
79072805
LW		 9863
9864 kid = kid->op_sibling;
9865 scalar(kid);
9866
9867 if (kid->op_sibling)
ce16c625 9868 return too_many_arguments_pv(o,OP_DESC(o), 0);
79072805 9869
11343788 9870 return o;
79072805
LW		 9871}
9872
9873OP *
1c846c1f 9874Perl_ck_join(pTHX_ OP *o)
eb6e2d6f 9875{
551405c4 9876 const OP * const kid = cLISTOPo->op_first->op_sibling;
7918f24d
NC		 9877
9878 PERL_ARGS_ASSERT_CK_JOIN;
9879
041457d9
DM		 9880 if (kid && kid->op_type == OP_MATCH) {
9881 if (ckWARN(WARN_SYNTAX)) {
6867be6d 9882 const REGEXP *re = PM_GETRE(kPMOP);
ce16c625
BF		 9883 const SV *msg = re
9884 ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
9885 SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
9886 : newSVpvs_flags( "STRING", SVs_TEMP );
9014280d 9887 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
ce16c625
BF		 9888 "/%"SVf"/ should probably be written as \"%"SVf"\"",
9889 SVfARG(msg), SVfARG(msg));
eb6e2d6f
GS		 9890 }
9891 }
9892 return ck_fun(o);
9893}
9894
d9088386
Z		 9895/*
9896=for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
9897
9898Examines an op, which is expected to identify a subroutine at runtime,
9899and attempts to determine at compile time which subroutine it identifies.
9900This is normally used during Perl compilation to determine whether
9901a prototype can be applied to a function call. I<cvop> is the op
9902being considered, normally an C<rv2cv> op. A pointer to the identified
9903subroutine is returned, if it could be determined statically, and a null
9904pointer is returned if it was not possible to determine statically.
9905
9906Currently, the subroutine can be identified statically if the RV that the
9907C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
9908A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
9909suitable if the constant value must be an RV pointing to a CV. Details of
9910this process may change in future versions of Perl. If the C<rv2cv> op
9911has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
9912the subroutine statically: this flag is used to suppress compile-time
9913magic on a subroutine call, forcing it to use default runtime behaviour.
9914
9915If I<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
9916of a GV reference is modified. If a GV was examined and its CV slot was
9917found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
9918If the op is not optimised away, and the CV slot is later populated with
9919a subroutine having a prototype, that flag eventually triggers the warning
9920"called too early to check prototype".
9921
9922If I<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
9923of returning a pointer to the subroutine it returns a pointer to the
9924GV giving the most appropriate name for the subroutine in this context.
9925Normally this is just the C<CvGV> of the subroutine, but for an anonymous
9926(C<CvANON>) subroutine that is referenced through a GV it will be the
9927referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
9928A null pointer is returned as usual if there is no statically-determinable
9929subroutine.
7918f24d 9930
d9088386
Z		 9931=cut
9932*/
9d88f058 9933
9a5e6f3c
FC		 9934/* shared by toke.c:yylex */
9935CV *
9936Perl_find_lexical_cv(pTHX_ PADOFFSET off)
9937{
9938 PADNAME *name = PAD_COMPNAME(off);
9939 CV *compcv = PL_compcv;
9940 while (PadnameOUTER(name)) {
9941 assert(PARENT_PAD_INDEX(name));
9942 compcv = CvOUTSIDE(PL_compcv);
9943 name = PadlistNAMESARRAY(CvPADLIST(compcv))
9944 [off = PARENT_PAD_INDEX(name)];
9945 }
9946 assert(!PadnameIsOUR(name));
3a74e0e2 9947 if (!PadnameIsSTATE(name) && SvMAGICAL(name)) {
9a5e6f3c
FC		 9948 MAGIC * mg = mg_find(name, PERL_MAGIC_proto);
9949 assert(mg);
9950 assert(mg->mg_obj);
9951 return (CV *)mg->mg_obj;
9952 }
9953 return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
9954}
9955
d9088386
Z		 9956CV *
9957Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
9958{
9959 OP *rvop;
9960 CV *cv;
9961 GV *gv;
9962 PERL_ARGS_ASSERT_RV2CV_OP_CV;
9963 if (flags & ~(RV2CVOPCV_MARK_EARLY|RV2CVOPCV_RETURN_NAME_GV))
9964 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
9965 if (cvop->op_type != OP_RV2CV)
9966 return NULL;
9967 if (cvop->op_private & OPpENTERSUB_AMPER)
9968 return NULL;
9969 if (!(cvop->op_flags & OPf_KIDS))
9970 return NULL;
9971 rvop = cUNOPx(cvop)->op_first;
9972 switch (rvop->op_type) {
9973 case OP_GV: {
9974 gv = cGVOPx_gv(rvop);
9975 cv = GvCVu(gv);
9976 if (!cv) {
9977 if (flags & RV2CVOPCV_MARK_EARLY)
9978 rvop->op_private |= OPpEARLY_CV;
9979 return NULL;
46fc3d4c 9980 }
d9088386
Z		 9981 } break;
9982 case OP_CONST: {
9983 SV *rv = cSVOPx_sv(rvop);
9984 if (!SvROK(rv))
9985 return NULL;
9986 cv = (CV*)SvRV(rv);
9987 gv = NULL;
9988 } break;
279d09bf 9989 case OP_PADCV: {
9a5e6f3c 9990 cv = find_lexical_cv(rvop->op_targ);
279d09bf
FC		 9991 gv = NULL;
9992 } break;
d9088386
Z		 9993 default: {
9994 return NULL;
9995 } break;
4633a7c4 9996 }
d9088386
Z		 9997 if (SvTYPE((SV*)cv) != SVt_PVCV)
9998 return NULL;
9999 if (flags & RV2CVOPCV_RETURN_NAME_GV) {
10000 if (!CvANON(cv) || !gv)
10001 gv = CvGV(cv);
10002 return (CV*)gv;
10003 } else {
10004 return cv;
7a52d87a 10005 }
d9088386 10006}
9d88f058 10007
d9088386
Z		 10008/*
10009=for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
824afba1 10010
d9088386
Z		 10011Performs the default fixup of the arguments part of an C<entersub>
10012op tree. This consists of applying list context to each of the
10013argument ops. This is the standard treatment used on a call marked
10014with C<&>, or a method call, or a call through a subroutine reference,
10015or any other call where the callee can't be identified at compile time,
10016or a call where the callee has no prototype.
824afba1 10017
d9088386
Z		 10018=cut
10019*/
340458b5 10020
d9088386
Z		 10021OP *
10022Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
10023{
10024 OP *aop;
10025 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
10026 aop = cUNOPx(entersubop)->op_first;
10027 if (!aop->op_sibling)
10028 aop = cUNOPx(aop)->op_first;
10029 for (aop = aop->op_sibling; aop->op_sibling; aop = aop->op_sibling) {
10030 if (!(PL_madskills && aop->op_type == OP_STUB)) {
10031 list(aop);
3ad73efd 10032 op_lvalue(aop, OP_ENTERSUB);
d9088386
Z		 10033 }
10034 }
10035 return entersubop;
10036}
340458b5 10037
d9088386
Z		 10038/*
10039=for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
10040
10041Performs the fixup of the arguments part of an C<entersub> op tree
10042based on a subroutine prototype. This makes various modifications to
10043the argument ops, from applying context up to inserting C<refgen> ops,
10044and checking the number and syntactic types of arguments, as directed by
10045the prototype. This is the standard treatment used on a subroutine call,
10046not marked with C<&>, where the callee can be identified at compile time
10047and has a prototype.
10048
10049I<protosv> supplies the subroutine prototype to be applied to the call.
10050It may be a normal defined scalar, of which the string value will be used.
10051Alternatively, for convenience, it may be a subroutine object (a C<CV*>
10052that has been cast to C<SV*>) which has a prototype. The prototype
10053supplied, in whichever form, does not need to match the actual callee
10054referenced by the op tree.
10055
10056If the argument ops disagree with the prototype, for example by having
10057an unacceptable number of arguments, a valid op tree is returned anyway.
10058The error is reflected in the parser state, normally resulting in a single
10059exception at the top level of parsing which covers all the compilation
10060errors that occurred. In the error message, the callee is referred to
10061by the name defined by the I<namegv> parameter.
cbf82dd0 10062
d9088386
Z		 10063=cut
10064*/
10065
10066OP *
10067Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
10068{
10069 STRLEN proto_len;
10070 const char *proto, *proto_end;
10071 OP *aop, *prev, *cvop;
10072 int optional = 0;
10073 I32 arg = 0;
10074 I32 contextclass = 0;
10075 const char *e = NULL;
10076 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
10077 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
cb197492 10078 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
5637ef5b 10079 "flags=%lx", (unsigned long) SvFLAGS(protosv));
8fa6a409
FC		 10080 if (SvTYPE(protosv) == SVt_PVCV)
10081 proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
10082 else proto = SvPV(protosv, proto_len);
d16269d8 10083 proto = S_strip_spaces(aTHX_ proto, &proto_len);
d9088386
Z		 10084 proto_end = proto + proto_len;
10085 aop = cUNOPx(entersubop)->op_first;
10086 if (!aop->op_sibling)
10087 aop = cUNOPx(aop)->op_first;
10088 prev = aop;
10089 aop = aop->op_sibling;
10090 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
10091 while (aop != cvop) {
10092 OP* o3;
10093 if (PL_madskills && aop->op_type == OP_STUB) {
10094 aop = aop->op_sibling;
10095 continue;
10096 }
10097 if (PL_madskills && aop->op_type == OP_NULL)
10098 o3 = ((UNOP*)aop)->op_first;
10099 else
10100 o3 = aop;
10101
10102 if (proto >= proto_end)
ce16c625 10103 return too_many_arguments_sv(entersubop, gv_ename(namegv), 0);
d9088386
Z		 10104
10105 switch (*proto) {
597dcb2b
DG		 10106 case ';':
10107 optional = 1;
10108 proto++;
10109 continue;
10110 case '_':
10111 /* _ must be at the end */
34daab0f 10112 if (proto[1] && !strchr(";@%", proto[1]))
597dcb2b
DG		 10113 goto oops;
10114 case '$':
10115 proto++;
10116 arg++;
10117 scalar(aop);
10118 break;
10119 case '%':
10120 case '@':
10121 list(aop);
10122 arg++;
10123 break;
10124 case '&':
10125 proto++;
10126 arg++;
10127 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
7b3b0904 10128 bad_type_gv(arg,
597dcb2b 10129 arg == 1 ? "block or sub {}" : "sub {}",
7b3b0904 10130 namegv, 0, o3);
597dcb2b
DG		 10131 break;
10132 case '*':
10133 /* '*' allows any scalar type, including bareword */
10134 proto++;
10135 arg++;
10136 if (o3->op_type == OP_RV2GV)
10137 goto wrapref; /* autoconvert GLOB -> GLOBref */
10138 else if (o3->op_type == OP_CONST)
10139 o3->op_private &= ~OPpCONST_STRICT;
10140 else if (o3->op_type == OP_ENTERSUB) {
10141 /* accidental subroutine, revert to bareword */
10142 OP *gvop = ((UNOP*)o3)->op_first;
10143 if (gvop && gvop->op_type == OP_NULL) {
10144 gvop = ((UNOP*)gvop)->op_first;
10145 if (gvop) {
10146 for (; gvop->op_sibling; gvop = gvop->op_sibling)
10147 ;
10148 if (gvop &&
10149 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
10150 (gvop = ((UNOP*)gvop)->op_first) &&
10151 gvop->op_type == OP_GV)
10152 {
10153 GV * const gv = cGVOPx_gv(gvop);
10154 OP * const sibling = aop->op_sibling;
10155 SV * const n = newSVpvs("");
eb8433b7 10156#ifdef PERL_MAD
597dcb2b 10157 OP * const oldaop = aop;
eb8433b7 10158#else
597dcb2b 10159 op_free(aop);
eb8433b7 10160#endif
597dcb2b
DG		 10161 gv_fullname4(n, gv, "", FALSE);
10162 aop = newSVOP(OP_CONST, 0, n);
10163 op_getmad(oldaop,aop,'O');
10164 prev->op_sibling = aop;
10165 aop->op_sibling = sibling;
10166 }
9675f7ac
GS		 10167 }
10168 }
10169 }
597dcb2b 10170 scalar(aop);
c035a075
DG		 10171 break;
10172 case '+':
10173 proto++;
10174 arg++;
10175 if (o3->op_type == OP_RV2AV ||
10176 o3->op_type == OP_PADAV ||
10177 o3->op_type == OP_RV2HV ||
10178 o3->op_type == OP_PADHV
10179 ) {
10180 goto wrapref;
10181 }
10182 scalar(aop);
d9088386 10183 break;
597dcb2b
DG		 10184 case '[': case ']':
10185 goto oops;
d9088386 10186 break;
597dcb2b
DG		 10187 case '\\':
10188 proto++;
10189 arg++;
10190 again:
10191 switch (*proto++) {
10192 case '[':
10193 if (contextclass++ == 0) {
10194 e = strchr(proto, ']');
10195 if (!e || e == proto)
10196 goto oops;
10197 }
10198 else
10199 goto oops;
10200 goto again;
10201 break;
10202 case ']':
10203 if (contextclass) {
10204 const char *p = proto;
10205 const char *const end = proto;
10206 contextclass = 0;
062678b2
FC		 10207 while (*--p != '[')
10208 /* \[$] accepts any scalar lvalue */
10209 if (*p == '$'
10210 && Perl_op_lvalue_flags(aTHX_
10211 scalar(o3),
10212 OP_READ, /* not entersub */
10213 OP_LVALUE_NO_CROAK
10214 )) goto wrapref;
7b3b0904 10215 bad_type_gv(arg, Perl_form(aTHX_ "one of %.*s",
597dcb2b 10216 (int)(end - p), p),
7b3b0904 10217 namegv, 0, o3);
597dcb2b
DG		 10218 } else
10219 goto oops;
10220 break;
10221 case '*':
10222 if (o3->op_type == OP_RV2GV)
10223 goto wrapref;
10224 if (!contextclass)
7b3b0904 10225 bad_type_gv(arg, "symbol", namegv, 0, o3);
597dcb2b
DG		 10226 break;
10227 case '&':
10228 if (o3->op_type == OP_ENTERSUB)
10229 goto wrapref;
10230 if (!contextclass)
7b3b0904 10231 bad_type_gv(arg, "subroutine entry", namegv, 0,
597dcb2b
DG		 10232 o3);
10233 break;
10234 case '$':
10235 if (o3->op_type == OP_RV2SV ||
10236 o3->op_type == OP_PADSV ||
10237 o3->op_type == OP_HELEM ||
10238 o3->op_type == OP_AELEM)
10239 goto wrapref;
062678b2
FC		 10240 if (!contextclass) {
10241 /* \$ accepts any scalar lvalue */
10242 if (Perl_op_lvalue_flags(aTHX_
10243 scalar(o3),
10244 OP_READ, /* not entersub */
10245 OP_LVALUE_NO_CROAK
10246 )) goto wrapref;
7b3b0904 10247 bad_type_gv(arg, "scalar", namegv, 0, o3);
062678b2 10248 }
597dcb2b
DG		 10249 break;
10250 case '@':
10251 if (o3->op_type == OP_RV2AV ||
10252 o3->op_type == OP_PADAV)
10253 goto wrapref;
10254 if (!contextclass)
7b3b0904 10255 bad_type_gv(arg, "array", namegv, 0, o3);
597dcb2b
DG		 10256 break;
10257 case '%':
10258 if (o3->op_type == OP_RV2HV ||
10259 o3->op_type == OP_PADHV)
10260 goto wrapref;
10261 if (!contextclass)
7b3b0904 10262 bad_type_gv(arg, "hash", namegv, 0, o3);
597dcb2b
DG		 10263 break;
10264 wrapref:
10265 {
10266 OP* const kid = aop;
10267 OP* const sib = kid->op_sibling;
10268 kid->op_sibling = 0;
10269 aop = newUNOP(OP_REFGEN, 0, kid);
10270 aop->op_sibling = sib;
10271 prev->op_sibling = aop;
10272 }
10273 if (contextclass && e) {
10274 proto = e + 1;
10275 contextclass = 0;
10276 }
10277 break;
10278 default: goto oops;
4633a7c4 10279 }
597dcb2b
DG		 10280 if (contextclass)
10281 goto again;
4633a7c4 10282 break;
597dcb2b
DG		 10283 case ' ':
10284 proto++;
10285 continue;
10286 default:
108f32a5
BF		 10287 oops: {
10288 SV* const tmpsv = sv_newmortal();
10289 gv_efullname3(tmpsv, namegv, NULL);
10290 Perl_croak(aTHX_ "Malformed prototype for %"SVf": %"SVf,
10291 SVfARG(tmpsv), SVfARG(protosv));
10292 }
d9088386
Z		 10293 }
10294
3ad73efd 10295 op_lvalue(aop, OP_ENTERSUB);
d9088386
Z		 10296 prev = aop;
10297 aop = aop->op_sibling;
10298 }
10299 if (aop == cvop && *proto == '_') {
10300 /* generate an access to $_ */
10301 aop = newDEFSVOP();
10302 aop->op_sibling = prev->op_sibling;
10303 prev->op_sibling = aop; /* instead of cvop */
10304 }
10305 if (!optional && proto_end > proto &&
10306 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
ce16c625 10307 return too_few_arguments_sv(entersubop, gv_ename(namegv), 0);
d9088386
Z		 10308 return entersubop;
10309}
10310
10311/*
10312=for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
10313
10314Performs the fixup of the arguments part of an C<entersub> op tree either
10315based on a subroutine prototype or using default list-context processing.
10316This is the standard treatment used on a subroutine call, not marked
10317with C<&>, where the callee can be identified at compile time.
10318
10319I<protosv> supplies the subroutine prototype to be applied to the call,
10320or indicates that there is no prototype. It may be a normal scalar,
10321in which case if it is defined then the string value will be used
10322as a prototype, and if it is undefined then there is no prototype.
10323Alternatively, for convenience, it may be a subroutine object (a C<CV*>
10324that has been cast to C<SV*>), of which the prototype will be used if it
10325has one. The prototype (or lack thereof) supplied, in whichever form,
10326does not need to match the actual callee referenced by the op tree.
10327
10328If the argument ops disagree with the prototype, for example by having
10329an unacceptable number of arguments, a valid op tree is returned anyway.
10330The error is reflected in the parser state, normally resulting in a single
10331exception at the top level of parsing which covers all the compilation
10332errors that occurred. In the error message, the callee is referred to
10333by the name defined by the I<namegv> parameter.
10334
10335=cut
10336*/
10337
10338OP *
10339Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
10340 GV *namegv, SV *protosv)
10341{
10342 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
10343 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
10344 return ck_entersub_args_proto(entersubop, namegv, protosv);
10345 else
10346 return ck_entersub_args_list(entersubop);
10347}
10348
4aaa4757
FC		 10349OP *
10350Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
10351{
10352 int opnum = SvTYPE(protosv) == SVt_PVCV ? 0 : (int)SvUV(protosv);
10353 OP *aop = cUNOPx(entersubop)->op_first;
10354
10355 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
10356
10357 if (!opnum) {
14f0f125 10358 OP *cvop;
4aaa4757
FC		 10359 if (!aop->op_sibling)
10360 aop = cUNOPx(aop)->op_first;
4aaa4757
FC		 10361 aop = aop->op_sibling;
10362 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
10363 if (PL_madskills) while (aop != cvop && aop->op_type == OP_STUB) {
10364 aop = aop->op_sibling;
4aaa4757
FC		 10365 }
10366 if (aop != cvop)
ce16c625 10367 (void)too_many_arguments_pv(entersubop, GvNAME(namegv), 0);
4aaa4757
FC		 10368
10369 op_free(entersubop);
10370 switch(GvNAME(namegv)[2]) {
10371 case 'F': return newSVOP(OP_CONST, 0,
10372 newSVpv(CopFILE(PL_curcop),0));
10373 case 'L': return newSVOP(
10374 OP_CONST, 0,
10375 Perl_newSVpvf(aTHX_
10376 "%"IVdf, (IV)CopLINE(PL_curcop)
10377 )
10378 );
10379 case 'P': return newSVOP(OP_CONST, 0,
10380 (PL_curstash
10381 ? newSVhek(HvNAME_HEK(PL_curstash))
10382 : &PL_sv_undef
10383 )
10384 );
10385 }
10386 assert(0);
10387 }
10388 else {
10389 OP *prev, *cvop;
7d789282 10390 U32 flags;
4aaa4757
FC		 10391#ifdef PERL_MAD
10392 bool seenarg = FALSE;
10393#endif
10394 if (!aop->op_sibling)
10395 aop = cUNOPx(aop)->op_first;
10396
10397 prev = aop;
10398 aop = aop->op_sibling;
10399 prev->op_sibling = NULL;
10400 for (cvop = aop;
10401 cvop->op_sibling;
10402 prev=cvop, cvop = cvop->op_sibling)
10403#ifdef PERL_MAD
10404 if (PL_madskills && cvop->op_sibling
10405 && cvop->op_type != OP_STUB) seenarg = TRUE
10406#endif
10407 ;
10408 prev->op_sibling = NULL;
7d789282 10409 flags = OPf_SPECIAL * !(cvop->op_private & OPpENTERSUB_NOPAREN);
4aaa4757
FC		 10410 op_free(cvop);
10411 if (aop == cvop) aop = NULL;
10412 op_free(entersubop);
10413
7d789282
FC		 10414 if (opnum == OP_ENTEREVAL
10415 && GvNAMELEN(namegv)==9 && strnEQ(GvNAME(namegv), "evalbytes", 9))
10416 flags |= OPpEVAL_BYTES <<8;
10417
4aaa4757
FC		 10418 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
10419 case OA_UNOP:
10420 case OA_BASEOP_OR_UNOP:
10421 case OA_FILESTATOP:
7d789282 10422 return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
4aaa4757
FC		 10423 case OA_BASEOP:
10424 if (aop) {
10425#ifdef PERL_MAD
10426 if (!PL_madskills || seenarg)
10427#endif
ce16c625 10428 (void)too_many_arguments_pv(aop, GvNAME(namegv), 0);
4aaa4757
FC		 10429 op_free(aop);
10430 }
98be9964
FC		 10431 return opnum == OP_RUNCV
10432 ? newPVOP(OP_RUNCV,0,NULL)
10433 : newOP(opnum,0);
4aaa4757
FC		 10434 default:
10435 return convert(opnum,0,aop);
10436 }
10437 }
10438 assert(0);
10439 return entersubop;
10440}
10441
d9088386
Z		 10442/*
10443=for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
10444
10445Retrieves the function that will be used to fix up a call to I<cv>.
10446Specifically, the function is applied to an C<entersub> op tree for a
10447subroutine call, not marked with C<&>, where the callee can be identified
10448at compile time as I<cv>.
10449
10450The C-level function pointer is returned in I<*ckfun_p>, and an SV
10451argument for it is returned in I<*ckobj_p>. The function is intended
10452to be called in this manner:
10453
10454 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
10455
10456In this call, I<entersubop> is a pointer to the C<entersub> op,
10457which may be replaced by the check function, and I<namegv> is a GV
10458supplying the name that should be used by the check function to refer
10459to the callee of the C<entersub> op if it needs to emit any diagnostics.
10460It is permitted to apply the check function in non-standard situations,
10461such as to a call to a different subroutine or to a method call.
340458b5 10462
d9088386
Z		 10463By default, the function is
10464L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
10465and the SV parameter is I<cv> itself. This implements standard
10466prototype processing. It can be changed, for a particular subroutine,
10467by L</cv_set_call_checker>.
74735042 10468
d9088386
Z		 10469=cut
10470*/
10471
10472void
10473Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
10474{
10475 MAGIC *callmg;
10476 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
10477 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
10478 if (callmg) {
10479 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
10480 *ckobj_p = callmg->mg_obj;
10481 } else {
10482 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
10483 *ckobj_p = (SV*)cv;
10484 }
10485}
10486
10487/*
10488=for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
10489
10490Sets the function that will be used to fix up a call to I<cv>.
10491Specifically, the function is applied to an C<entersub> op tree for a
10492subroutine call, not marked with C<&>, where the callee can be identified
10493at compile time as I<cv>.
10494
10495The C-level function pointer is supplied in I<ckfun>, and an SV argument
10496for it is supplied in I<ckobj>. The function is intended to be called
10497in this manner:
10498
10499 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
10500
10501In this call, I<entersubop> is a pointer to the C<entersub> op,
10502which may be replaced by the check function, and I<namegv> is a GV
10503supplying the name that should be used by the check function to refer
10504to the callee of the C<entersub> op if it needs to emit any diagnostics.
10505It is permitted to apply the check function in non-standard situations,
10506such as to a call to a different subroutine or to a method call.
10507
10508The current setting for a particular CV can be retrieved by
10509L</cv_get_call_checker>.
10510
10511=cut
10512*/
10513
10514void
10515Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
10516{
10517 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
10518 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
10519 if (SvMAGICAL((SV*)cv))
10520 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
10521 } else {
10522 MAGIC *callmg;
10523 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
10524 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
10525 if (callmg->mg_flags & MGf_REFCOUNTED) {
10526 SvREFCNT_dec(callmg->mg_obj);
10527 callmg->mg_flags &= ~MGf_REFCOUNTED;
10528 }
10529 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
10530 callmg->mg_obj = ckobj;
10531 if (ckobj != (SV*)cv) {
10532 SvREFCNT_inc_simple_void_NN(ckobj);
10533 callmg->mg_flags |= MGf_REFCOUNTED;
74735042 10534 }
09fb282d 10535 callmg->mg_flags |= MGf_COPY;
340458b5 10536 }
d9088386
Z		 10537}
10538
10539OP *
10540Perl_ck_subr(pTHX_ OP *o)
10541{
10542 OP *aop, *cvop;
10543 CV *cv;
10544 GV *namegv;
10545
10546 PERL_ARGS_ASSERT_CK_SUBR;
10547
10548 aop = cUNOPx(o)->op_first;
10549 if (!aop->op_sibling)
10550 aop = cUNOPx(aop)->op_first;
10551 aop = aop->op_sibling;
10552 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
10553 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
10554 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_RETURN_NAME_GV) : NULL;
10555
767eda44 10556 o->op_private &= ~1;
d9088386
Z		 10557 o->op_private |= OPpENTERSUB_HASTARG;
10558 o->op_private |= (PL_hints & HINT_STRICT_REFS);
10559 if (PERLDB_SUB && PL_curstash != PL_debstash)
10560 o->op_private |= OPpENTERSUB_DB;
10561 if (cvop->op_type == OP_RV2CV) {
10562 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
10563 op_null(cvop);
10564 } else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
10565 if (aop->op_type == OP_CONST)
10566 aop->op_private &= ~OPpCONST_STRICT;
10567 else if (aop->op_type == OP_LIST) {
10568 OP * const sib = ((UNOP*)aop)->op_first->op_sibling;
10569 if (sib && sib->op_type == OP_CONST)
10570 sib->op_private &= ~OPpCONST_STRICT;
10571 }
10572 }
10573
10574 if (!cv) {
10575 return ck_entersub_args_list(o);
10576 } else {
10577 Perl_call_checker ckfun;
10578 SV *ckobj;
10579 cv_get_call_checker(cv, &ckfun, &ckobj);
279d09bf
FC		 10580 if (!namegv) { /* expletive! */
10581 /* XXX The call checker API is public. And it guarantees that
10582 a GV will be provided with the right name. So we have
10583 to create a GV. But it is still not correct, as its
10584 stringification will include the package. What we
10585 really need is a new call checker API that accepts a
10586 GV or string (or GV or CV). */
10587 HEK * const hek = CvNAME_HEK(cv);
3a74e0e2
FC		 10588 /* After a syntax error in a lexical sub, the cv that
10589 rv2cv_op_cv returns may be a nameless stub. */
10590 if (!hek) return ck_entersub_args_list(o);;
279d09bf
FC		 10591 namegv = (GV *)sv_newmortal();
10592 gv_init_pvn(namegv, PL_curstash, HEK_KEY(hek), HEK_LEN(hek),
10593 SVf_UTF8 * !!HEK_UTF8(hek));
10594 }
d9088386
Z		 10595 return ckfun(aTHX_ o, namegv, ckobj);
10596 }
79072805
LW		 10597}
10598
10599OP *
cea2e8a9 10600Perl_ck_svconst(pTHX_ OP *o)
8990e307 10601{
7918f24d 10602 PERL_ARGS_ASSERT_CK_SVCONST;
96a5add6 10603 PERL_UNUSED_CONTEXT;
9a0a8507 10604 SvREADONLY_on(cSVOPo->op_sv);
11343788 10605 return o;
8990e307
LW		 10606}
10607
10608OP *
cea2e8a9 10609Perl_ck_trunc(pTHX_ OP *o)
79072805 10610{
7918f24d
NC		 10611 PERL_ARGS_ASSERT_CK_TRUNC;
10612
11343788
MB		 10613 if (o->op_flags & OPf_KIDS) {
10614 SVOP *kid = (SVOP*)cUNOPo->op_first;
79072805 10615
a0d0e21e
LW		 10616 if (kid->op_type == OP_NULL)
10617 kid = (SVOP*)kid->op_sibling;
bb53490d 10618 if (kid && kid->op_type == OP_CONST &&
3513c740
NT		 10619 (kid->op_private & OPpCONST_BARE) &&
10620 !kid->op_folded)
bb53490d 10621 {
11343788 10622 o->op_flags |= OPf_SPECIAL;
bb53490d
GS		 10623 kid->op_private &= ~OPpCONST_STRICT;
10624 }
79072805 10625 }
11343788 10626 return ck_fun(o);
79072805
LW		 10627}
10628
35fba0d9
RG		 10629OP *
10630Perl_ck_substr(pTHX_ OP *o)
10631{
7918f24d
NC		 10632 PERL_ARGS_ASSERT_CK_SUBSTR;
10633
35fba0d9 10634 o = ck_fun(o);
1d866c12 10635 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
35fba0d9
RG		 10636 OP *kid = cLISTOPo->op_first;
10637
10638 if (kid->op_type == OP_NULL)
10639 kid = kid->op_sibling;
10640 if (kid)
10641 kid->op_flags |= OPf_MOD;
10642
10643 }
10644 return o;
10645}
10646
878d132a 10647OP *
8dc99089
FC		 10648Perl_ck_tell(pTHX_ OP *o)
10649{
8dc99089
FC		 10650 PERL_ARGS_ASSERT_CK_TELL;
10651 o = ck_fun(o);
e9d7a483
FC		 10652 if (o->op_flags & OPf_KIDS) {
10653 OP *kid = cLISTOPo->op_first;
423e8af5 10654 if (kid->op_type == OP_NULL && kid->op_sibling) kid = kid->op_sibling;
e9d7a483
FC		 10655 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
10656 }
8dc99089
FC		 10657 return o;
10658}
10659
10660OP *
cba5a3b0
DG		 10661Perl_ck_each(pTHX_ OP *o)
10662{
10663 dVAR;
10664 OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
10665 const unsigned orig_type = o->op_type;
10666 const unsigned array_type = orig_type == OP_EACH ? OP_AEACH
10667 : orig_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
10668 const unsigned ref_type = orig_type == OP_EACH ? OP_REACH
10669 : orig_type == OP_KEYS ? OP_RKEYS : OP_RVALUES;
10670
10671 PERL_ARGS_ASSERT_CK_EACH;
10672
10673 if (kid) {
10674 switch (kid->op_type) {
10675 case OP_PADHV:
10676 case OP_RV2HV:
10677 break;
10678 case OP_PADAV:
10679 case OP_RV2AV:
10680 CHANGE_TYPE(o, array_type);
10681 break;
10682 case OP_CONST:
7ac5715b
FC		 10683 if (kid->op_private == OPpCONST_BARE
10684 || !SvROK(cSVOPx_sv(kid))
10685 || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
10686 && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV )
10687 )
10688 /* we let ck_fun handle it */
cba5a3b0
DG		 10689 break;
10690 default:
10691 CHANGE_TYPE(o, ref_type);
7ac5715b 10692 scalar(kid);
cba5a3b0
DG		 10693 }
10694 }
10695 /* if treating as a reference, defer additional checks to runtime */
10696 return o->op_type == ref_type ? o : ck_fun(o);
10697}
10698
e508c8a4
MH		 10699OP *
10700Perl_ck_length(pTHX_ OP *o)
10701{
10702 PERL_ARGS_ASSERT_CK_LENGTH;
10703
10704 o = ck_fun(o);
10705
10706 if (ckWARN(WARN_SYNTAX)) {
10707 const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
10708
10709 if (kid) {
579333ee
FC		 10710 SV *name = NULL;
10711 const bool hash = kid->op_type == OP_PADHV
10712 || kid->op_type == OP_RV2HV;
e508c8a4
MH		 10713 switch (kid->op_type) {
10714 case OP_PADHV:
e508c8a4 10715 case OP_PADAV:
579333ee 10716 name = varname(
c6fb3f6e
FC		 10717 (GV *)PL_compcv, hash ? '%' : '@', kid->op_targ,
10718 NULL, 0, 1
579333ee
FC		 10719 );
10720 break;
10721 case OP_RV2HV:
e508c8a4 10722 case OP_RV2AV:
579333ee
FC		 10723 if (cUNOPx(kid)->op_first->op_type != OP_GV) break;
10724 {
10725 GV *gv = cGVOPx_gv(cUNOPx(kid)->op_first);
10726 if (!gv) break;
10727 name = varname(gv, hash?'%':'@', 0, NULL, 0, 1);
10728 }
e508c8a4 10729 break;
e508c8a4 10730 default:
579333ee 10731 return o;
e508c8a4 10732 }
579333ee
FC		 10733 if (name)
10734 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10735 "length() used on %"SVf" (did you mean \"scalar(%s%"SVf
10736 ")\"?)",
10737 name, hash ? "keys " : "", name
10738 );
10739 else if (hash)
25e26107 10740 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
579333ee
FC		 10741 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10742 "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
10743 else
25e26107 10744 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
579333ee
FC		 10745 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10746 "length() used on @array (did you mean \"scalar(@array)\"?)");
e508c8a4
MH		 10747 }
10748 }
10749
10750 return o;
10751}
10752
540dd770
GG		 10753/* Check for in place reverse and sort assignments like "@a = reverse @a"
10754 and modify the optree to make them work inplace */
e52d58aa 10755
540dd770
GG		 10756STATIC void
10757S_inplace_aassign(pTHX_ OP *o) {
e52d58aa 10758
540dd770
GG		 10759 OP *modop, *modop_pushmark;
10760 OP *oright;
10761 OP *oleft, *oleft_pushmark;
e52d58aa 10762
540dd770 10763 PERL_ARGS_ASSERT_INPLACE_AASSIGN;
e52d58aa 10764
540dd770 10765 assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
e52d58aa 10766
540dd770
GG		 10767 assert(cUNOPo->op_first->op_type == OP_NULL);
10768 modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
10769 assert(modop_pushmark->op_type == OP_PUSHMARK);
10770 modop = modop_pushmark->op_sibling;
e92f843d 10771
540dd770
GG		 10772 if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
10773 return;
10774
10775 /* no other operation except sort/reverse */
10776 if (modop->op_sibling)
10777 return;
10778
10779 assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
a46b39a8 10780 if (!(oright = cUNOPx(modop)->op_first->op_sibling)) return;
540dd770
GG		 10781
10782 if (modop->op_flags & OPf_STACKED) {
10783 /* skip sort subroutine/block */
10784 assert(oright->op_type == OP_NULL);
10785 oright = oright->op_sibling;
10786 }
10787
10788 assert(cUNOPo->op_first->op_sibling->op_type == OP_NULL);
10789 oleft_pushmark = cUNOPx(cUNOPo->op_first->op_sibling)->op_first;
10790 assert(oleft_pushmark->op_type == OP_PUSHMARK);
10791 oleft = oleft_pushmark->op_sibling;
10792
10793 /* Check the lhs is an array */
10794 if (!oleft ||
10795 (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
10796 || oleft->op_sibling
10797 || (oleft->op_private & OPpLVAL_INTRO)
10798 )
10799 return;
10800
10801 /* Only one thing on the rhs */
10802 if (oright->op_sibling)
10803 return;
2f9e2db0
VP		 10804
10805 /* check the array is the same on both sides */
10806 if (oleft->op_type == OP_RV2AV) {
10807 if (oright->op_type != OP_RV2AV
10808 || !cUNOPx(oright)->op_first
10809 || cUNOPx(oright)->op_first->op_type != OP_GV
18e3e9ce 10810 || cUNOPx(oleft )->op_first->op_type != OP_GV
2f9e2db0
VP		 10811 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
10812 cGVOPx_gv(cUNOPx(oright)->op_first)
10813 )
540dd770 10814 return;
2f9e2db0
VP		 10815 }
10816 else if (oright->op_type != OP_PADAV
10817 || oright->op_targ != oleft->op_targ
10818 )
540dd770
GG		 10819 return;
10820
10821 /* This actually is an inplace assignment */
e52d58aa 10822
540dd770
GG		 10823 modop->op_private |= OPpSORT_INPLACE;
10824
10825 /* transfer MODishness etc from LHS arg to RHS arg */
10826 oright->op_flags = oleft->op_flags;
10827
10828 /* remove the aassign op and the lhs */
10829 op_null(o);
10830 op_null(oleft_pushmark);
10831 if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
10832 op_null(cUNOPx(oleft)->op_first);
10833 op_null(oleft);
2f9e2db0
VP		 10834}
10835
3c78429c
DM		 10836#define MAX_DEFERRED 4
10837
10838#define DEFER(o) \
d7ab38e8 10839 STMT_START { \
3c78429c
DM		 10840 if (defer_ix == (MAX_DEFERRED-1)) { \
10841 CALL_RPEEP(defer_queue[defer_base]); \
10842 defer_base = (defer_base + 1) % MAX_DEFERRED; \
10843 defer_ix--; \
10844 } \
d7ab38e8
FC		 10845 defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = o; \
10846 } STMT_END
3c78429c 10847
61b743bb
DM		 10848/* A peephole optimizer. We visit the ops in the order they're to execute.
10849 * See the comments at the top of this file for more details about when
10850 * peep() is called */
463ee0b2 10851
79072805 10852void
5aaab254 10853Perl_rpeep(pTHX_ OP *o)
79072805 10854{
27da23d5 10855 dVAR;
eb578fdb 10856 OP* oldop = NULL;
4774ee0a 10857 OP* oldoldop = NULL;
3c78429c
DM		 10858 OP* defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
10859 int defer_base = 0;
10860 int defer_ix = -1;
2d8e6c8d 10861
2814eb74 10862 if (!o || o->op_opt)
79072805 10863 return;
a0d0e21e 10864 ENTER;
462e5cf6 10865 SAVEOP();
7766f137 10866 SAVEVPTR(PL_curcop);
3c78429c
DM		 10867 for (;; o = o->op_next) {
10868 if (o && o->op_opt)
10869 o = NULL;
cd197e1e
VP		 10870 if (!o) {
10871 while (defer_ix >= 0)
10872 CALL_RPEEP(defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED]);
3c78429c 10873 break;
cd197e1e 10874 }
3c78429c 10875
6d7dd4a5
NC		 10876 /* By default, this op has now been optimised. A couple of cases below
10877 clear this again. */
10878 o->op_opt = 1;
533c011a 10879 PL_op = o;
a0d0e21e 10880 switch (o->op_type) {
a0d0e21e 10881 case OP_DBSTATE:
3280af22 10882 PL_curcop = ((COP*)o); /* for warnings */
a0d0e21e 10883 break;
ac56e7de
NC		 10884 case OP_NEXTSTATE:
10885 PL_curcop = ((COP*)o); /* for warnings */
10886
10887 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
10888 to carry two labels. For now, take the easier option, and skip
10889 this optimisation if the first NEXTSTATE has a label. */
bcc76ee3 10890 if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
ac56e7de
NC		 10891 OP *nextop = o->op_next;
10892 while (nextop && nextop->op_type == OP_NULL)
10893 nextop = nextop->op_next;
10894
10895 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
10896 COP *firstcop = (COP *)o;
10897 COP *secondcop = (COP *)nextop;
10898 /* We want the COP pointed to by o (and anything else) to
10899 become the next COP down the line. */
10900 cop_free(firstcop);
10901
10902 firstcop->op_next = secondcop->op_next;
10903
10904 /* Now steal all its pointers, and duplicate the other
10905 data. */
10906 firstcop->cop_line = secondcop->cop_line;
10907#ifdef USE_ITHREADS
d4d03940 10908 firstcop->cop_stashoff = secondcop->cop_stashoff;
c82ecf34 10909 firstcop->cop_filegvoff = secondcop->cop_filegvoff;
ac56e7de
NC		 10910#else
10911 firstcop->cop_stash = secondcop->cop_stash;
10912 firstcop->cop_filegv = secondcop->cop_filegv;
10913#endif
10914 firstcop->cop_hints = secondcop->cop_hints;
10915 firstcop->cop_seq = secondcop->cop_seq;
10916 firstcop->cop_warnings = secondcop->cop_warnings;
10917 firstcop->cop_hints_hash = secondcop->cop_hints_hash;
10918
10919#ifdef USE_ITHREADS
647688d8 10920 secondcop->cop_stashoff = 0;
c82ecf34 10921 secondcop->cop_filegvoff = 0;
ac56e7de
NC		 10922#else
10923 secondcop->cop_stash = NULL;
10924 secondcop->cop_filegv = NULL;
10925#endif
10926 secondcop->cop_warnings = NULL;
10927 secondcop->cop_hints_hash = NULL;
10928
10929 /* If we use op_null(), and hence leave an ex-COP, some
10930 warnings are misreported. For example, the compile-time
10931 error in 'use strict; no strict refs;' */
10932 secondcop->op_type = OP_NULL;
10933 secondcop->op_ppaddr = PL_ppaddr[OP_NULL];
10934 }
10935 }
10936 break;
a0d0e21e 10937
df91b2c5
AE		 10938 case OP_CONCAT:
10939 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
10940 if (o->op_next->op_private & OPpTARGET_MY) {
10941 if (o->op_flags & OPf_STACKED) /* chained concats */
a6aa0b75 10942 break; /* ignore_optimization */
df91b2c5
AE		 10943 else {
10944 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
10945 o->op_targ = o->op_next->op_targ;
10946 o->op_next->op_targ = 0;
10947 o->op_private |= OPpTARGET_MY;
10948 }
10949 }
10950 op_null(o->op_next);
10951 }
df91b2c5 10952 break;
6d7dd4a5
NC		 10953 case OP_STUB:
10954 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
10955 break; /* Scalar stub must produce undef. List stub is noop */
10956 }
10957 goto nothin;
79072805 10958 case OP_NULL:
acb36ea4 10959 if (o->op_targ == OP_NEXTSTATE
5edb5b2a 10960 || o->op_targ == OP_DBSTATE)
acb36ea4 10961 {
3280af22 10962 PL_curcop = ((COP*)o);
acb36ea4 10963 }
dad75012 10964 /* XXX: We avoid setting op_seq here to prevent later calls
1a0a2ba9 10965 to rpeep() from mistakenly concluding that optimisation
dad75012
AMS		 10966 has already occurred. This doesn't fix the real problem,
10967 though (See 20010220.007). AMS 20010719 */
2814eb74 10968 /* op_seq functionality is now replaced by op_opt */
6d7dd4a5 10969 o->op_opt = 0;
f46f2f82 10970 /* FALL THROUGH */
79072805 10971 case OP_SCALAR:
93a17b20 10972 case OP_LINESEQ:
463ee0b2 10973 case OP_SCOPE:
6d7dd4a5 10974 nothin:
a0d0e21e
LW		 10975 if (oldop && o->op_next) {
10976 oldop->op_next = o->op_next;
6d7dd4a5 10977 o->op_opt = 0;
79072805
LW		 10978 continue;
10979 }
79072805
LW		 10980 break;
10981
a7fd8ef6
DM		 10982 case OP_PUSHMARK:
10983
10984 /* Convert a series of PAD ops for my vars plus support into a
10985 * single padrange op. Basically
10986 *
10987 * pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
10988 *
10989 * becomes, depending on circumstances, one of
10990 *
10991 * padrange ----------------------------------> (list) -> rest
10992 * padrange --------------------------------------------> rest
10993 *
10994 * where all the pad indexes are sequential and of the same type
10995 * (INTRO or not).
10996 * We convert the pushmark into a padrange op, then skip
10997 * any other pad ops, and possibly some trailing ops.
10998 * Note that we don't null() the skipped ops, to make it
10999 * easier for Deparse to undo this optimisation (and none of
11000 * the skipped ops are holding any resourses). It also makes
11001 * it easier for find_uninit_var(), as it can just ignore
11002 * padrange, and examine the original pad ops.
11003 */
11004 {
11005 OP *p;
11006 OP *followop = NULL; /* the op that will follow the padrange op */
11007 U8 count = 0;
11008 U8 intro = 0;
11009 PADOFFSET base = 0; /* init only to stop compiler whining */
11010 U8 gimme = 0; /* init only to stop compiler whining */
d5524600 11011 bool defav = 0; /* seen (...) = @_ */
fd3cc9e5 11012 bool reuse = 0; /* reuse an existing padrange op */
d5524600
DM		 11013
11014 /* look for a pushmark -> gv[_] -> rv2av */
11015
11016 {
11017 GV *gv;
11018 OP *rv2av, *q;
11019 p = o->op_next;
11020 if ( p->op_type == OP_GV
11021 && (gv = cGVOPx_gv(p))
11022 && GvNAMELEN_get(gv) == 1
11023 && *GvNAME_get(gv) == '_'
11024 && GvSTASH(gv) == PL_defstash
11025 && (rv2av = p->op_next)
11026 && rv2av->op_type == OP_RV2AV
11027 && !(rv2av->op_flags & OPf_REF)
11028 && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
11029 && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
11030 && o->op_sibling == rv2av /* these two for Deparse */
11031 && cUNOPx(rv2av)->op_first == p
11032 ) {
11033 q = rv2av->op_next;
11034 if (q->op_type == OP_NULL)
11035 q = q->op_next;
11036 if (q->op_type == OP_PUSHMARK) {
11037 defav = 1;
11038 p = q;
11039 }
11040 }
11041 }
11042 if (!defav) {
11043 /* To allow Deparse to pessimise this, it needs to be able
11044 * to restore the pushmark's original op_next, which it
11045 * will assume to be the same as op_sibling. */
11046 if (o->op_next != o->op_sibling)
11047 break;
11048 p = o;
11049 }
a7fd8ef6
DM		 11050
11051 /* scan for PAD ops */
11052
d5524600 11053 for (p = p->op_next; p; p = p->op_next) {
a7fd8ef6
DM		 11054 if (p->op_type == OP_NULL)
11055 continue;
11056
11057 if (( p->op_type != OP_PADSV
11058 && p->op_type != OP_PADAV
11059 && p->op_type != OP_PADHV
11060 )
11061 /* any private flag other than INTRO? e.g. STATE */
11062 || (p->op_private & ~OPpLVAL_INTRO)
11063 )
11064 break;
11065
11066 /* let $a[N] potentially be optimised into ALEMFAST_LEX
11067 * instead */
11068 if ( p->op_type == OP_PADAV
11069 && p->op_next
11070 && p->op_next->op_type == OP_CONST
11071 && p->op_next->op_next
11072 && p->op_next->op_next->op_type == OP_AELEM
11073 )
11074 break;
11075
11076 /* for 1st padop, note what type it is and the range
11077 * start; for the others, check that it's the same type
11078 * and that the targs are contiguous */
11079 if (count == 0) {
11080 intro = (p->op_private & OPpLVAL_INTRO);
11081 base = p->op_targ;
11082 gimme = (p->op_flags & OPf_WANT);
11083 }
11084 else {
11085 if ((p->op_private & OPpLVAL_INTRO) != intro)
11086 break;
18c931a3
DM		 11087 /* Note that you'd normally expect targs to be
11088 * contiguous in my($a,$b,$c), but that's not the case
11089 * when external modules start doing things, e.g.
11090 i* Function::Parameters */
11091 if (p->op_targ != base + count)
a7fd8ef6
DM		 11092 break;
11093 assert(p->op_targ == base + count);
11094 /* all the padops should be in the same context */
11095 if (gimme != (p->op_flags & OPf_WANT))
11096 break;
11097 }
11098
11099 /* for AV, HV, only when we're not flattening */
11100 if ( p->op_type != OP_PADSV
11101 && gimme != OPf_WANT_VOID
11102 && !(p->op_flags & OPf_REF)
11103 )
11104 break;
11105
11106 if (count >= OPpPADRANGE_COUNTMASK)
11107 break;
11108
4e09461c
DM		 11109 /* there's a biggest base we can fit into a
11110 * SAVEt_CLEARPADRANGE in pp_padrange */
11111 if (intro && base >
11112 (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT)))
11113 break;
11114
a7fd8ef6
DM		 11115 /* Success! We've got another valid pad op to optimise away */
11116 count++;
11117 followop = p->op_next;
11118 }
11119
11120 if (count < 1)
11121 break;
11122
4774ee0a 11123 /* pp_padrange in specifically compile-time void context
a7fd8ef6
DM		 11124 * skips pushing a mark and lexicals; in all other contexts
11125 * (including unknown till runtime) it pushes a mark and the
11126 * lexicals. We must be very careful then, that the ops we
11127 * optimise away would have exactly the same effect as the
11128 * padrange.
11129 * In particular in void context, we can only optimise to
11130 * a padrange if see see the complete sequence
11131 * pushmark, pad*v, ...., list, nextstate
11132 * which has the net effect of of leaving the stack empty
11133 * (for now we leave the nextstate in the execution chain, for
11134 * its other side-effects).
11135 */
11136 assert(followop);
11137 if (gimme == OPf_WANT_VOID) {
11138 if (followop->op_type == OP_LIST
11139 && gimme == (followop->op_flags & OPf_WANT)
11140 && ( followop->op_next->op_type == OP_NEXTSTATE
11141 || followop->op_next->op_type == OP_DBSTATE))
4774ee0a 11142 {
a7fd8ef6 11143 followop = followop->op_next; /* skip OP_LIST */
4774ee0a
DM		 11144
11145 /* consolidate two successive my(...);'s */
fd3cc9e5 11146
4774ee0a
DM		 11147 if ( oldoldop
11148 && oldoldop->op_type == OP_PADRANGE
11149 && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
11150 && (oldoldop->op_private & OPpLVAL_INTRO) == intro
fd3cc9e5 11151 && !(oldoldop->op_flags & OPf_SPECIAL)
4774ee0a
DM		 11152 ) {
11153 U8 old_count;
11154 assert(oldoldop->op_next == oldop);
11155 assert( oldop->op_type == OP_NEXTSTATE
11156 || oldop->op_type == OP_DBSTATE);
11157 assert(oldop->op_next == o);
11158
11159 old_count
11160 = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
11161 assert(oldoldop->op_targ + old_count == base);
11162
11163 if (old_count < OPpPADRANGE_COUNTMASK - count) {
fd3cc9e5
DM		 11164 base = oldoldop->op_targ;
11165 count += old_count;
11166 reuse = 1;
4774ee0a
DM		 11167 }
11168 }
fd3cc9e5
DM		 11169
11170 /* if there's any immediately following singleton
11171 * my var's; then swallow them and the associated
11172 * nextstates; i.e.
11173 * my ($a,$b); my $c; my $d;
11174 * is treated as
11175 * my ($a,$b,$c,$d);
11176 */
11177
11178 while ( ((p = followop->op_next))
11179 && ( p->op_type == OP_PADSV
11180 || p->op_type == OP_PADAV
11181 || p->op_type == OP_PADHV)
11182 && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
11183 && (p->op_private & OPpLVAL_INTRO) == intro
11184 && p->op_next
11185 && ( p->op_next->op_type == OP_NEXTSTATE
11186 || p->op_next->op_type == OP_DBSTATE)
11187 && count < OPpPADRANGE_COUNTMASK
11188 ) {
11189 assert(base + count == p->op_targ);
11190 count++;
11191 followop = p->op_next;
11192 }
4774ee0a 11193 }
a7fd8ef6
DM		 11194 else
11195 break;
11196 }
11197
fd3cc9e5
DM		 11198 if (reuse) {
11199 assert(oldoldop->op_type == OP_PADRANGE);
11200 oldoldop->op_next = followop;
11201 oldoldop->op_private = (intro | count);
11202 o = oldoldop;
11203 oldop = NULL;
11204 oldoldop = NULL;
11205 }
11206 else {
11207 /* Convert the pushmark into a padrange.
11208 * To make Deparse easier, we guarantee that a padrange was
11209 * *always* formerly a pushmark */
11210 assert(o->op_type == OP_PUSHMARK);
11211 o->op_next = followop;
11212 o->op_type = OP_PADRANGE;
11213 o->op_ppaddr = PL_ppaddr[OP_PADRANGE];
11214 o->op_targ = base;
11215 /* bit 7: INTRO; bit 6..0: count */
11216 o->op_private = (intro | count);
11217 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
11218 | gimme | (defav ? OPf_SPECIAL : 0));
11219 }
a7fd8ef6
DM		 11220 break;
11221 }
11222
6a077020 11223 case OP_PADAV:
79072805 11224 case OP_GV:
6a077020 11225 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
0bd48802 11226 OP* const pop = (o->op_type == OP_PADAV) ?
6a077020 11227 o->op_next : o->op_next->op_next;
a0d0e21e 11228 IV i;
f9dc862f 11229 if (pop && pop->op_type == OP_CONST &&
af5acbb4 11230 ((PL_op = pop->op_next)) &&
8990e307 11231 pop->op_next->op_type == OP_AELEM &&
a0d0e21e 11232 !(pop->op_next->op_private &
78f9721b 11233 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
e1dccc0d 11234 (i = SvIV(((SVOP*)pop)->op_sv)) <= 255 && i >= 0)
8990e307 11235 {
350de78d 11236 GV *gv;
af5acbb4
DM		 11237 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
11238 no_bareword_allowed(pop);
6a077020
DM		 11239 if (o->op_type == OP_GV)
11240 op_null(o->op_next);
93c66552
DM		 11241 op_null(pop->op_next);
11242 op_null(pop);
a0d0e21e
LW		 11243 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
11244 o->op_next = pop->op_next->op_next;
22c35a8c 11245 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
a0d0e21e 11246 o->op_private = (U8)i;
6a077020
DM		 11247 if (o->op_type == OP_GV) {
11248 gv = cGVOPo_gv;
11249 GvAVn(gv);
93bad3fd 11250 o->op_type = OP_AELEMFAST;
6a077020
DM		 11251 }
11252 else
93bad3fd 11253 o->op_type = OP_AELEMFAST_LEX;
6a077020 11254 }
6a077020
DM		 11255 break;
11256 }
11257
11258 if (o->op_next->op_type == OP_RV2SV) {
11259 if (!(o->op_next->op_private & OPpDEREF)) {
11260 op_null(o->op_next);
11261 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
11262 | OPpOUR_INTRO);
11263 o->op_next = o->op_next->op_next;
11264 o->op_type = OP_GVSV;
11265 o->op_ppaddr = PL_ppaddr[OP_GVSV];
8990e307 11266 }
79072805 11267 }
89de2904
AMS		 11268 else if (o->op_next->op_type == OP_READLINE
11269 && o->op_next->op_next->op_type == OP_CONCAT
11270 && (o->op_next->op_next->op_flags & OPf_STACKED))
11271 {
d2c45030
AMS		 11272 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
11273 o->op_type = OP_RCATLINE;
11274 o->op_flags |= OPf_STACKED;
11275 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
89de2904 11276 op_null(o->op_next->op_next);
d2c45030 11277 op_null(o->op_next);
89de2904 11278 }
76cd736e 11279
79072805 11280 break;
867fa1e2
YO		 11281
11282 {
11283 OP *fop;
11284 OP *sop;
11285
9e7f031c
FC		 11286#define HV_OR_SCALARHV(op) \
11287 ( (op)->op_type == OP_PADHV || (op)->op_type == OP_RV2HV \
11288 ? (op) \
11289 : (op)->op_type == OP_SCALAR && (op)->op_flags & OPf_KIDS \
11290 && ( cUNOPx(op)->op_first->op_type == OP_PADHV \
11291 || cUNOPx(op)->op_first->op_type == OP_RV2HV) \
11292 ? cUNOPx(op)->op_first \
11293 : NULL)
11294
867fa1e2 11295 case OP_NOT:
9e7f031c
FC		 11296 if ((fop = HV_OR_SCALARHV(cUNOP->op_first)))
11297 fop->op_private |= OPpTRUEBOOL;
867fa1e2
YO		 11298 break;
11299
11300 case OP_AND:
79072805 11301 case OP_OR:
c963b151 11302 case OP_DOR:
867fa1e2
YO		 11303 fop = cLOGOP->op_first;
11304 sop = fop->op_sibling;
11305 while (cLOGOP->op_other->op_type == OP_NULL)
11306 cLOGOP->op_other = cLOGOP->op_other->op_next;
db4d68cf
DM		 11307 while (o->op_next && ( o->op_type == o->op_next->op_type
11308 || o->op_next->op_type == OP_NULL))
11309 o->op_next = o->op_next->op_next;
3c78429c 11310 DEFER(cLOGOP->op_other);
867fa1e2 11311
867fa1e2 11312 o->op_opt = 1;
c8fe3bdf
FC		 11313 fop = HV_OR_SCALARHV(fop);
11314 if (sop) sop = HV_OR_SCALARHV(sop);
11315 if (fop || sop
867fa1e2
YO		 11316 ){
11317 OP * nop = o;
11318 OP * lop = o;
aaf643ce 11319 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
867fa1e2
YO		 11320 while (nop && nop->op_next) {
11321 switch (nop->op_next->op_type) {
11322 case OP_NOT:
11323 case OP_AND:
11324 case OP_OR:
11325 case OP_DOR:
11326 lop = nop = nop->op_next;
11327 break;
11328 case OP_NULL:
11329 nop = nop->op_next;
11330 break;
11331 default:
11332 nop = NULL;
11333 break;
11334 }
11335 }
11336 }
c8fe3bdf
FC		 11337 if (fop) {
11338 if ( (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
20e53f5f 11339 || o->op_type == OP_AND )
c8fe3bdf
FC		 11340 fop->op_private |= OPpTRUEBOOL;
11341 else if (!(lop->op_flags & OPf_WANT))
adc42c31 11342 fop->op_private |= OPpMAYBE_TRUEBOOL;
6ea72b3a 11343 }
20e53f5f 11344 if ( (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
c8fe3bdf
FC		 11345 && sop)
11346 sop->op_private |= OPpTRUEBOOL;
867fa1e2
YO		 11347 }
11348
11349
11350 break;
867fa1e2 11351
a8b106e9 11352 case OP_COND_EXPR:
c8fe3bdf 11353 if ((fop = HV_OR_SCALARHV(cLOGOP->op_first)))
9e7f031c 11354 fop->op_private |= OPpTRUEBOOL;
a8b106e9
FC		 11355#undef HV_OR_SCALARHV
11356 /* GERONIMO! */
c8fe3bdf 11357 }
a8b106e9 11358
867fa1e2
YO		 11359 case OP_MAPWHILE:
11360 case OP_GREPWHILE:
2c2d71f5
JH		 11361 case OP_ANDASSIGN:
11362 case OP_ORASSIGN:
c963b151 11363 case OP_DORASSIGN:
1a67a97c 11364 case OP_RANGE:
c5917253 11365 case OP_ONCE:
fd4d1407
IZ		 11366 while (cLOGOP->op_other->op_type == OP_NULL)
11367 cLOGOP->op_other = cLOGOP->op_other->op_next;
3c78429c 11368 DEFER(cLOGOP->op_other);
79072805
LW		 11369 break;
11370
79072805 11371 case OP_ENTERLOOP:
9c2ca71a 11372 case OP_ENTERITER:
58cccf98
SM		 11373 while (cLOOP->op_redoop->op_type == OP_NULL)
11374 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
58cccf98
SM		 11375 while (cLOOP->op_nextop->op_type == OP_NULL)
11376 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
58cccf98
SM		 11377 while (cLOOP->op_lastop->op_type == OP_NULL)
11378 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
3c78429c
DM		 11379 /* a while(1) loop doesn't have an op_next that escapes the
11380 * loop, so we have to explicitly follow the op_lastop to
11381 * process the rest of the code */
11382 DEFER(cLOOP->op_lastop);
79072805
LW		 11383 break;
11384
79072805 11385 case OP_SUBST:
29f2e912
NC		 11386 assert(!(cPMOP->op_pmflags & PMf_ONCE));
11387 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
11388 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
11389 cPMOP->op_pmstashstartu.op_pmreplstart
11390 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
3c78429c 11391 DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
79072805
LW		 11392 break;
11393
fe1bc4cf 11394 case OP_SORT: {
d7ab38e8
FC		 11395 OP *oright;
11396
11397 if (o->op_flags & OPf_STACKED) {
11398 OP * const kid =
11399 cUNOPx(cLISTOP->op_first->op_sibling)->op_first;
11400 if (kid->op_type == OP_SCOPE
08fdcd99
FC		 11401 || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE))
11402 DEFER(kLISTOP->op_first);
d7ab38e8
FC		 11403 }
11404
fe1bc4cf 11405 /* check that RHS of sort is a single plain array */
d7ab38e8 11406 oright = cUNOPo->op_first;
fe1bc4cf
DM		 11407 if (!oright || oright->op_type != OP_PUSHMARK)
11408 break;
471178c0 11409
540dd770
GG		 11410 if (o->op_private & OPpSORT_INPLACE)
11411 break;
11412
471178c0
NC		 11413 /* reverse sort ... can be optimised. */
11414 if (!cUNOPo->op_sibling) {
11415 /* Nothing follows us on the list. */
551405c4 11416 OP * const reverse = o->op_next;
471178c0
NC		 11417
11418 if (reverse->op_type == OP_REVERSE &&
11419 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
551405c4 11420 OP * const pushmark = cUNOPx(reverse)->op_first;
471178c0
NC		 11421 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
11422 && (cUNOPx(pushmark)->op_sibling == o)) {
11423 /* reverse -> pushmark -> sort */
11424 o->op_private |= OPpSORT_REVERSE;
11425 op_null(reverse);
11426 pushmark->op_next = oright->op_next;
11427 op_null(oright);
11428 }
11429 }
11430 }
11431
fe1bc4cf
DM		 11432 break;
11433 }
ef3e5ea9
NC		 11434
11435 case OP_REVERSE: {
e682d7b7 11436 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
ce335f37 11437 OP *gvop = NULL;
ef3e5ea9 11438 LISTOP *enter, *exlist;
ef3e5ea9 11439
540dd770 11440 if (o->op_private & OPpSORT_INPLACE)
484c818f 11441 break;
484c818f 11442
ef3e5ea9
NC		 11443 enter = (LISTOP *) o->op_next;
11444 if (!enter)
11445 break;
11446 if (enter->op_type == OP_NULL) {
11447 enter = (LISTOP *) enter->op_next;
11448 if (!enter)
11449 break;
11450 }
d46f46af
NC		 11451 /* for $a (...) will have OP_GV then OP_RV2GV here.
11452 for (...) just has an OP_GV. */
ce335f37
NC		 11453 if (enter->op_type == OP_GV) {
11454 gvop = (OP *) enter;
11455 enter = (LISTOP *) enter->op_next;
11456 if (!enter)
11457 break;
d46f46af
NC		 11458 if (enter->op_type == OP_RV2GV) {
11459 enter = (LISTOP *) enter->op_next;
11460 if (!enter)
ce335f37 11461 break;
d46f46af 11462 }
ce335f37
NC		 11463 }
11464
ef3e5ea9
NC		 11465 if (enter->op_type != OP_ENTERITER)
11466 break;
11467
11468 iter = enter->op_next;
11469 if (!iter || iter->op_type != OP_ITER)
11470 break;
11471
ce335f37
NC		 11472 expushmark = enter->op_first;
11473 if (!expushmark || expushmark->op_type != OP_NULL
11474 || expushmark->op_targ != OP_PUSHMARK)
11475 break;
11476
11477 exlist = (LISTOP *) expushmark->op_sibling;
ef3e5ea9
NC		 11478 if (!exlist || exlist->op_type != OP_NULL
11479 || exlist->op_targ != OP_LIST)
11480 break;
11481
11482 if (exlist->op_last != o) {
11483 /* Mmm. Was expecting to point back to this op. */
11484 break;
11485 }
11486 theirmark = exlist->op_first;
11487 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
11488 break;
11489
c491ecac 11490 if (theirmark->op_sibling != o) {
ef3e5ea9
NC		 11491 /* There's something between the mark and the reverse, eg
11492 for (1, reverse (...))
11493 so no go. */
11494 break;
11495 }
11496
c491ecac
NC		 11497 ourmark = ((LISTOP *)o)->op_first;
11498 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
11499 break;
11500
ef3e5ea9
NC		 11501 ourlast = ((LISTOP *)o)->op_last;
11502 if (!ourlast || ourlast->op_next != o)
11503 break;
11504
e682d7b7
NC		 11505 rv2av = ourmark->op_sibling;
11506 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
11507 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
11508 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
11509 /* We're just reversing a single array. */
11510 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
11511 enter->op_flags |= OPf_STACKED;
11512 }
11513
ef3e5ea9
NC		 11514 /* We don't have control over who points to theirmark, so sacrifice
11515 ours. */
11516 theirmark->op_next = ourmark->op_next;
11517 theirmark->op_flags = ourmark->op_flags;
ce335f37 11518 ourlast->op_next = gvop ? gvop : (OP *) enter;
ef3e5ea9
NC		 11519 op_null(ourmark);
11520 op_null(o);
11521 enter->op_private |= OPpITER_REVERSED;
11522 iter->op_private |= OPpITER_REVERSED;
11523
11524 break;
11525 }
e26df76a 11526
0477511c
NC		 11527 case OP_QR:
11528 case OP_MATCH:
29f2e912
NC		 11529 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
11530 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
11531 }
79072805 11532 break;
1830b3d9 11533
1a35f9ff
FC		 11534 case OP_RUNCV:
11535 if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)) {
11536 SV *sv;
e157a82b 11537 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
1a35f9ff
FC		 11538 else {
11539 sv = newRV((SV *)PL_compcv);
11540 sv_rvweaken(sv);
11541 SvREADONLY_on(sv);
11542 }
11543 o->op_type = OP_CONST;
11544 o->op_ppaddr = PL_ppaddr[OP_CONST];
11545 o->op_flags |= OPf_SPECIAL;
11546 cSVOPo->op_sv = sv;
11547 }
11548 break;
11549
24fcb59f
FC		 11550 case OP_SASSIGN:
11551 if (OP_GIMME(o,0) == G_VOID) {
11552 OP *right = cBINOP->op_first;
11553 if (right) {
11554 OP *left = right->op_sibling;
11555 if (left->op_type == OP_SUBSTR
11556 && (left->op_private & 7) < 4) {
11557 op_null(o);
11558 cBINOP->op_first = left;
11559 right->op_sibling =
11560 cBINOPx(left)->op_first->op_sibling;
11561 cBINOPx(left)->op_first->op_sibling = right;
11562 left->op_private |= OPpSUBSTR_REPL_FIRST;
d72a08ce
FC		 11563 left->op_flags =
11564 (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
24fcb59f
FC		 11565 }
11566 }
11567 }
11568 break;
11569
1830b3d9
BM		 11570 case OP_CUSTOM: {
11571 Perl_cpeep_t cpeep =
11572 XopENTRY(Perl_custom_op_xop(aTHX_ o), xop_peep);
11573 if (cpeep)
11574 cpeep(aTHX_ o, oldop);
11575 break;
11576 }
11577
79072805 11578 }
4774ee0a 11579 oldoldop = oldop;
a0d0e21e 11580 oldop = o;
79072805 11581 }
a0d0e21e 11582 LEAVE;
79072805 11583}
beab0874 11584
1a0a2ba9 11585void
5aaab254 11586Perl_peep(pTHX_ OP *o)
1a0a2ba9
Z		 11587{
11588 CALL_RPEEP(o);
11589}
11590
9733086d
BM		 11591/*
11592=head1 Custom Operators
11593
11594=for apidoc Ao||custom_op_xop
11595Return the XOP structure for a given custom op. This function should be
11596considered internal to OP_NAME and the other access macros: use them instead.
11597
11598=cut
11599*/
11600
1830b3d9
BM		 11601const XOP *
11602Perl_custom_op_xop(pTHX_ const OP *o)
53e06cf0 11603{
1830b3d9
BM		 11604 SV *keysv;
11605 HE *he = NULL;
11606 XOP *xop;
11607
11608 static const XOP xop_null = { 0, 0, 0, 0, 0 };
53e06cf0 11609
1830b3d9
BM		 11610 PERL_ARGS_ASSERT_CUSTOM_OP_XOP;
11611 assert(o->op_type == OP_CUSTOM);
7918f24d 11612
1830b3d9
BM		 11613 /* This is wrong. It assumes a function pointer can be cast to IV,
11614 * which isn't guaranteed, but this is what the old custom OP code
11615 * did. In principle it should be safer to Copy the bytes of the
11616 * pointer into a PV: since the new interface is hidden behind
11617 * functions, this can be changed later if necessary. */
11618 /* Change custom_op_xop if this ever happens */
11619 keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
53e06cf0 11620
1830b3d9
BM		 11621 if (PL_custom_ops)
11622 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
11623
11624 /* assume noone will have just registered a desc */
11625 if (!he && PL_custom_op_names &&
11626 (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
11627 ) {
11628 const char *pv;
11629 STRLEN l;
11630
11631 /* XXX does all this need to be shared mem? */
aca83993 11632 Newxz(xop, 1, XOP);
1830b3d9
BM		 11633 pv = SvPV(HeVAL(he), l);
11634 XopENTRY_set(xop, xop_name, savepvn(pv, l));
11635 if (PL_custom_op_descs &&
11636 (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
11637 ) {
11638 pv = SvPV(HeVAL(he), l);
11639 XopENTRY_set(xop, xop_desc, savepvn(pv, l));
11640 }
11641 Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
11642 return xop;
11643 }
53e06cf0 11644
1830b3d9 11645 if (!he) return &xop_null;
53e06cf0 11646
1830b3d9
BM		 11647 xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
11648 return xop;
53e06cf0
SC		 11649}
11650
9733086d
BM		 11651/*
11652=for apidoc Ao||custom_op_register
11653Register a custom op. See L<perlguts/"Custom Operators">.
53e06cf0 11654
9733086d
BM		 11655=cut
11656*/
7918f24d 11657
1830b3d9
BM		 11658void
11659Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
11660{
11661 SV *keysv;
11662
11663 PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
53e06cf0 11664
1830b3d9
BM		 11665 /* see the comment in custom_op_xop */
11666 keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
53e06cf0 11667
1830b3d9
BM		 11668 if (!PL_custom_ops)
11669 PL_custom_ops = newHV();
53e06cf0 11670
1830b3d9
BM		 11671 if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
11672 Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
53e06cf0 11673}
19e8ce8e 11674
b8c38f0a
FC		 11675/*
11676=head1 Functions in file op.c
11677
11678=for apidoc core_prototype
11679This function assigns the prototype of the named core function to C<sv>, or
11680to a new mortal SV if C<sv> is NULL. It returns the modified C<sv>, or
a051f6c4 11681NULL if the core function has no prototype. C<code> is a code as returned
4e338c21 11682by C<keyword()>. It must not be equal to 0 or -KEY_CORE.
b8c38f0a
FC		 11683
11684=cut
11685*/
11686
11687SV *
be1b855b 11688Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
b66130dd 11689 int * const opnum)
b8c38f0a 11690{
b8c38f0a
FC		 11691 int i = 0, n = 0, seen_question = 0, defgv = 0;
11692 I32 oa;
11693#define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
11694 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
9927957a 11695 bool nullret = FALSE;
b8c38f0a
FC		 11696
11697 PERL_ARGS_ASSERT_CORE_PROTOTYPE;
11698
4e338c21 11699 assert (code && code != -KEY_CORE);
b8c38f0a
FC		 11700
11701 if (!sv) sv = sv_newmortal();
11702
9927957a 11703#define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
b8c38f0a 11704
4e338c21 11705 switch (code < 0 ? -code : code) {
b8c38f0a 11706 case KEY_and : case KEY_chop: case KEY_chomp:
4e338c21
FC		 11707 case KEY_cmp : case KEY_defined: case KEY_delete: case KEY_exec :
11708 case KEY_exists: case KEY_eq : case KEY_ge : case KEY_goto :
11709 case KEY_grep : case KEY_gt : case KEY_last : case KEY_le :
11710 case KEY_lt : case KEY_map : case KEY_ne : case KEY_next :
11711 case KEY_or : case KEY_print : case KEY_printf: case KEY_qr :
11712 case KEY_redo : case KEY_require: case KEY_return: case KEY_say :
11713 case KEY_select: case KEY_sort : case KEY_split : case KEY_system:
11714 case KEY_x : case KEY_xor :
9927957a 11715 if (!opnum) return NULL; nullret = TRUE; goto findopnum;
4e338c21 11716 case KEY_glob: retsetpvs("_;", OP_GLOB);
9927957a
FC		 11717 case KEY_keys: retsetpvs("+", OP_KEYS);
11718 case KEY_values: retsetpvs("+", OP_VALUES);
11719 case KEY_each: retsetpvs("+", OP_EACH);
11720 case KEY_push: retsetpvs("+@", OP_PUSH);
11721 case KEY_unshift: retsetpvs("+@", OP_UNSHIFT);
11722 case KEY_pop: retsetpvs(";+", OP_POP);
11723 case KEY_shift: retsetpvs(";+", OP_SHIFT);
4e338c21 11724 case KEY_pos: retsetpvs(";\\[$*]", OP_POS);
b8c38f0a 11725 case KEY_splice:
9927957a 11726 retsetpvs("+;$$@", OP_SPLICE);
b8c38f0a 11727 case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
9927957a 11728 retsetpvs("", 0);
7d789282
FC		 11729 case KEY_evalbytes:
11730 name = "entereval"; break;
b8c38f0a
FC		 11731 case KEY_readpipe:
11732 name = "backtick";
11733 }
11734
11735#undef retsetpvs
11736
9927957a 11737 findopnum:
b8c38f0a
FC		 11738 while (i < MAXO) { /* The slow way. */
11739 if (strEQ(name, PL_op_name[i])
11740 || strEQ(name, PL_op_desc[i]))
11741 {
9927957a 11742 if (nullret) { assert(opnum); *opnum = i; return NULL; }
b8c38f0a
FC		 11743 goto found;
11744 }
11745 i++;
11746 }
4e338c21 11747 return NULL;
b8c38f0a
FC		 11748 found:
11749 defgv = PL_opargs[i] & OA_DEFGV;
11750 oa = PL_opargs[i] >> OASHIFT;
11751 while (oa) {
465bc0f5 11752 if (oa & OA_OPTIONAL && !seen_question && (
ea5703f4 11753 !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
465bc0f5 11754 )) {
b8c38f0a
FC		 11755 seen_question = 1;
11756 str[n++] = ';';
11757 }
11758 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
11759 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
11760 /* But globs are already references (kinda) */
11761 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
11762 ) {
11763 str[n++] = '\\';
11764 }
1ecbeecf
FC		 11765 if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
11766 && !scalar_mod_type(NULL, i)) {
11767 str[n++] = '[';
11768 str[n++] = '$';
11769 str[n++] = '@';
11770 str[n++] = '%';
89c5c07e 11771 if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
1ecbeecf
FC		 11772 str[n++] = '*';
11773 str[n++] = ']';
11774 }
11775 else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
ea5703f4
FC		 11776 if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
11777 str[n-1] = '_'; defgv = 0;
11778 }
b8c38f0a
FC		 11779 oa = oa >> 4;
11780 }
dcbdef25 11781 if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
b8c38f0a
FC		 11782 str[n++] = '\0';
11783 sv_setpvn(sv, str, n - 1);
9927957a 11784 if (opnum) *opnum = i;
b8c38f0a
FC		 11785 return sv;
11786}
11787
1e4b6aa1
FC		 11788OP *
11789Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
11790 const int opnum)
11791{
11792 OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
c931b036 11793 OP *o;
1e4b6aa1
FC		 11794
11795 PERL_ARGS_ASSERT_CORESUB_OP;
11796
11797 switch(opnum) {
11798 case 0:
c2f605db 11799 return op_append_elem(OP_LINESEQ,
1e4b6aa1
FC		 11800 argop,
11801 newSLICEOP(0,
c2f605db 11802 newSVOP(OP_CONST, 0, newSViv(-code % 3)),
1e4b6aa1
FC		 11803 newOP(OP_CALLER,0)
11804 )
c2f605db 11805 );
720d5b2f
FC		 11806 case OP_SELECT: /* which represents OP_SSELECT as well */
11807 if (code)
11808 return newCONDOP(
11809 0,
11810 newBINOP(OP_GT, 0,
11811 newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
11812 newSVOP(OP_CONST, 0, newSVuv(1))
11813 ),
11814 coresub_op(newSVuv((UV)OP_SSELECT), 0,
11815 OP_SSELECT),
11816 coresub_op(coreargssv, 0, OP_SELECT)
11817 );
11818 /* FALL THROUGH */
1e4b6aa1
FC		 11819 default:
11820 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
11821 case OA_BASEOP:
11822 return op_append_elem(
11823 OP_LINESEQ, argop,
11824 newOP(opnum,
84ed0108
FC		 11825 opnum == OP_WANTARRAY || opnum == OP_RUNCV
11826 ? OPpOFFBYONE << 8 : 0)
1e4b6aa1 11827 );
527d644b 11828 case OA_BASEOP_OR_UNOP:
7d789282
FC		 11829 if (opnum == OP_ENTEREVAL) {
11830 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
11831 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
11832 }
11833 else o = newUNOP(opnum,0,argop);
ce0b554b
FC		 11834 if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
11835 else {
c931b036 11836 onearg:
ce0b554b 11837 if (is_handle_constructor(o, 1))
c931b036 11838 argop->op_private |= OPpCOREARGS_DEREF1;
1efec5ed
FC		 11839 if (scalar_mod_type(NULL, opnum))
11840 argop->op_private |= OPpCOREARGS_SCALARMOD;
ce0b554b 11841 }
c931b036 11842 return o;
527d644b 11843 default:
498a02d8 11844 o = convert(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
c931b036
FC		 11845 if (is_handle_constructor(o, 2))
11846 argop->op_private |= OPpCOREARGS_DEREF2;
7bc95ae1
FC		 11847 if (opnum == OP_SUBSTR) {
11848 o->op_private |= OPpMAYBE_LVSUB;
11849 return o;
11850 }
11851 else goto onearg;
1e4b6aa1
FC		 11852 }
11853 }
11854}
11855
156d738f
FC		 11856void
11857Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
11858 SV * const *new_const_svp)
11859{
11860 const char *hvname;
11861 bool is_const = !!CvCONST(old_cv);
11862 SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
11863
11864 PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
11865
11866 if (is_const && new_const_svp && old_const_sv == *new_const_svp)
11867 return;
11868 /* They are 2 constant subroutines generated from
11869 the same constant. This probably means that
11870 they are really the "same" proxy subroutine
11871 instantiated in 2 places. Most likely this is
11872 when a constant is exported twice. Don't warn.
11873 */
11874 if (
11875 (ckWARN(WARN_REDEFINE)
11876 && !(
11877 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
11878 && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
11879 && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
11880 strEQ(hvname, "autouse"))
11881 )
11882 )
11883 || (is_const
11884 && ckWARN_d(WARN_REDEFINE)
11885 && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
11886 )
11887 )
11888 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
11889 is_const
11890 ? "Constant subroutine %"SVf" redefined"
11891 : "Subroutine %"SVf" redefined",
11892 name);
11893}
11894
e8570548
Z		 11895/*
11896=head1 Hook manipulation
11897
11898These functions provide convenient and thread-safe means of manipulating
11899hook variables.
11900
11901=cut
11902*/
11903
11904/*
11905=for apidoc Am|void|wrap_op_checker|Optype opcode|Perl_check_t new_checker|Perl_check_t *old_checker_p
11906
11907Puts a C function into the chain of check functions for a specified op
11908type. This is the preferred way to manipulate the L</PL_check> array.
11909I<opcode> specifies which type of op is to be affected. I<new_checker>
11910is a pointer to the C function that is to be added to that opcode's
11911check chain, and I<old_checker_p> points to the storage location where a
11912pointer to the next function in the chain will be stored. The value of
11913I<new_pointer> is written into the L</PL_check> array, while the value
11914previously stored there is written to I<*old_checker_p>.
11915
11916L</PL_check> is global to an entire process, and a module wishing to
11917hook op checking may find itself invoked more than once per process,
11918typically in different threads. To handle that situation, this function
11919is idempotent. The location I<*old_checker_p> must initially (once
11920per process) contain a null pointer. A C variable of static duration
11921(declared at file scope, typically also marked C<static> to give
11922it internal linkage) will be implicitly initialised appropriately,
11923if it does not have an explicit initialiser. This function will only
11924actually modify the check chain if it finds I<*old_checker_p> to be null.
11925This function is also thread safe on the small scale. It uses appropriate
11926locking to avoid race conditions in accessing L</PL_check>.
11927
11928When this function is called, the function referenced by I<new_checker>
11929must be ready to be called, except for I<*old_checker_p> being unfilled.
11930In a threading situation, I<new_checker> may be called immediately,
11931even before this function has returned. I<*old_checker_p> will always
11932be appropriately set before I<new_checker> is called. If I<new_checker>
11933decides not to do anything special with an op that it is given (which
11934is the usual case for most uses of op check hooking), it must chain the
11935check function referenced by I<*old_checker_p>.
11936
11937If you want to influence compilation of calls to a specific subroutine,
11938then use L</cv_set_call_checker> rather than hooking checking of all
11939C<entersub> ops.
11940
11941=cut
11942*/
11943
11944void
11945Perl_wrap_op_checker(pTHX_ Optype opcode,
11946 Perl_check_t new_checker, Perl_check_t *old_checker_p)
11947{
9b11155f
TC		 11948 dVAR;
11949
e8570548
Z		 11950 PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
11951 if (*old_checker_p) return;
11952 OP_CHECK_MUTEX_LOCK;
11953 if (!*old_checker_p) {
11954 *old_checker_p = PL_check[opcode];
11955 PL_check[opcode] = new_checker;
11956 }
11957 OP_CHECK_MUTEX_UNLOCK;
11958}
11959
beab0874
JT		 11960#include "XSUB.h"
11961
11962/* Efficient sub that returns a constant scalar value. */
11963static void
acfe0abc 11964const_sv_xsub(pTHX_ CV* cv)
beab0874 11965{
97aff369 11966 dVAR;
beab0874 11967 dXSARGS;
99ab892b 11968 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
fcfc2536 11969 PERL_UNUSED_ARG(items);
99ab892b
NC		 11970 if (!sv) {
11971 XSRETURN(0);
11972 }
9a049f1c 11973 EXTEND(sp, 1);
99ab892b 11974 ST(0) = sv;
beab0874
JT		 11975 XSRETURN(1);
11976}
4946a0fa 11977
6f1b3ab0
FC		 11978static void
11979const_av_xsub(pTHX_ CV* cv)
11980{
11981 dVAR;
11982 dXSARGS;
11983 AV * const av = MUTABLE_AV(XSANY.any_ptr);
11984 SP -= items;
11985 assert(av);
11986#ifndef DEBUGGING
11987 if (!av) {
11988 XSRETURN(0);
11989 }
11990#endif
11991 if (SvRMAGICAL(av))
11992 Perl_croak(aTHX_ "Magical list constants are not supported");
11993 if (GIMME_V != G_ARRAY) {
11994 EXTEND(SP, 1);
11995 ST(0) = newSViv((IV)AvFILLp(av)+1);
11996 XSRETURN(1);
11997 }
11998 EXTEND(SP, AvFILLp(av)+1);
11999 Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
12000 XSRETURN(AvFILLp(av)+1);
12001}
12002
4946a0fa
NC		 12003/*
12004 * Local variables:
12005 * c-indentation-style: bsd
12006 * c-basic-offset: 4
14d04a33 12007 * indent-tabs-mode: nil
4946a0fa
NC		 12008 * End:
12009 *
14d04a33 12010 * ex: set ts=8 sts=4 sw=4 et:
37442d52 12011 */
Unnamed repository; edit this file 'description' to name the repository.