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
Stop folding of ops from changing mutability
[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
FC		 636#ifdef USE_ITHREADS
637PADOFFSET
638Perl_alloccopstash(pTHX_ HV *hv)
639{
640 PADOFFSET off = 0, o = 1;
641 bool found_slot = FALSE;
642
643 PERL_ARGS_ASSERT_ALLOCCOPSTASH;
644
645 if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
646
647 for (; o < PL_stashpadmax; ++o) {
648 if (PL_stashpad[o] == hv) return PL_stashpadix = o;
649 if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
650 found_slot = TRUE, off = o;
651 }
652 if (!found_slot) {
653 Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
654 Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
655 off = PL_stashpadmax;
656 PL_stashpadmax += 10;
657 }
658
659 PL_stashpad[PL_stashpadix = off] = hv;
660 return off;
661}
662#endif
663
d2c837a0
DM		 664/* free the body of an op without examining its contents.
665 * Always use this rather than FreeOp directly */
666
4136a0f7 667static void
d2c837a0
DM		 668S_op_destroy(pTHX_ OP *o)
669{
d2c837a0
DM		 670 FreeOp(o);
671}
672
79072805
LW		 673/* Destructor */
674
675void
864dbfa3 676Perl_op_free(pTHX_ OP *o)
79072805 677{
27da23d5 678 dVAR;
acb36ea4 679 OPCODE type;
79072805 680
8be227ab
FC		 681 /* Though ops may be freed twice, freeing the op after its slab is a
682 big no-no. */
683 assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
8be227ab
FC		 684 /* During the forced freeing of ops after compilation failure, kidops
685 may be freed before their parents. */
686 if (!o || o->op_type == OP_FREED)
79072805
LW		 687 return;
688
67566ccd 689 type = o->op_type;
7934575e 690 if (o->op_private & OPpREFCOUNTED) {
67566ccd 691 switch (type) {
7934575e
GS		 692 case OP_LEAVESUB:
693 case OP_LEAVESUBLV:
694 case OP_LEAVEEVAL:
695 case OP_LEAVE:
696 case OP_SCOPE:
697 case OP_LEAVEWRITE:
67566ccd
AL		 698 {
699 PADOFFSET refcnt;
7934575e 700 OP_REFCNT_LOCK;
4026c95a 701 refcnt = OpREFCNT_dec(o);
7934575e 702 OP_REFCNT_UNLOCK;
bfd0ff22
NC		 703 if (refcnt) {
704 /* Need to find and remove any pattern match ops from the list
705 we maintain for reset(). */
706 find_and_forget_pmops(o);
4026c95a 707 return;
67566ccd 708 }
bfd0ff22 709 }
7934575e
GS		 710 break;
711 default:
712 break;
713 }
714 }
715
f37b8c3f
VP		 716 /* Call the op_free hook if it has been set. Do it now so that it's called
717 * at the right time for refcounted ops, but still before all of the kids
718 * are freed. */
719 CALL_OPFREEHOOK(o);
720
11343788 721 if (o->op_flags & OPf_KIDS) {
eb578fdb 722 OP *kid, *nextkid;
11343788 723 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
85e6fe83 724 nextkid = kid->op_sibling; /* Get before next freeing kid */
79072805 725 op_free(kid);
85e6fe83 726 }
79072805 727 }
513f78f7
FC		 728 if (type == OP_NULL)
729 type = (OPCODE)o->op_targ;
acb36ea4 730
9e4d7a13
NC		 731 if (o->op_slabbed)
732 Slab_to_rw(OpSLAB(o));
fc97af9c 733
acb36ea4
GS		 734 /* COP* is not cleared by op_clear() so that we may track line
735 * numbers etc even after null() */
513f78f7 736 if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
acb36ea4 737 cop_free((COP*)o);
3235b7a3 738 }
acb36ea4
GS		 739
740 op_clear(o);
238a4c30 741 FreeOp(o);
4d494880
DM		 742#ifdef DEBUG_LEAKING_SCALARS
743 if (PL_op == o)
5f66b61c 744 PL_op = NULL;
4d494880 745#endif
acb36ea4 746}
79072805 747
93c66552
DM		 748void
749Perl_op_clear(pTHX_ OP *o)
acb36ea4 750{
13137afc 751
27da23d5 752 dVAR;
7918f24d
NC		 753
754 PERL_ARGS_ASSERT_OP_CLEAR;
755
eb8433b7 756#ifdef PERL_MAD
df31c78c
NC		 757 mad_free(o->op_madprop);
758 o->op_madprop = 0;
eb8433b7
NC		 759#endif
760
761 retry:
11343788 762 switch (o->op_type) {
acb36ea4 763 case OP_NULL: /* Was holding old type, if any. */
eb8433b7 764 if (PL_madskills && o->op_targ != OP_NULL) {
61a59f30 765 o->op_type = (Optype)o->op_targ;
eb8433b7
NC		 766 o->op_targ = 0;
767 goto retry;
768 }
4d193d44 769 case OP_ENTERTRY:
acb36ea4 770 case OP_ENTEREVAL: /* Was holding hints. */
acb36ea4 771 o->op_targ = 0;
a0d0e21e 772 break;
a6006777 773 default:
ac4c12e7 774 if (!(o->op_flags & OPf_REF)
ef69c8fc 775 || (PL_check[o->op_type] != Perl_ck_ftst))
a6006777 776 break;
777 /* FALL THROUGH */
463ee0b2 778 case OP_GVSV:
79072805 779 case OP_GV:
a6006777 780 case OP_AELEMFAST:
93bad3fd 781 {
f7461760
Z		 782 GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV)
783#ifdef USE_ITHREADS
784 && PL_curpad
785#endif
786 ? cGVOPo_gv : NULL;
b327b36f
NC		 787 /* It's possible during global destruction that the GV is freed
788 before the optree. Whilst the SvREFCNT_inc is happy to bump from
789 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
790 will trigger an assertion failure, because the entry to sv_clear
791 checks that the scalar is not already freed. A check of for
792 !SvIS_FREED(gv) turns out to be invalid, because during global
793 destruction the reference count can be forced down to zero
794 (with SVf_BREAK set). In which case raising to 1 and then
795 dropping to 0 triggers cleanup before it should happen. I
796 *think* that this might actually be a general, systematic,
797 weakness of the whole idea of SVf_BREAK, in that code *is*
798 allowed to raise and lower references during global destruction,
799 so any *valid* code that happens to do this during global
800 destruction might well trigger premature cleanup. */
801 bool still_valid = gv && SvREFCNT(gv);
802
803 if (still_valid)
804 SvREFCNT_inc_simple_void(gv);
350de78d 805#ifdef USE_ITHREADS
6a077020
DM		 806 if (cPADOPo->op_padix > 0) {
807 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
808 * may still exist on the pad */
809 pad_swipe(cPADOPo->op_padix, TRUE);
810 cPADOPo->op_padix = 0;
811 }
350de78d 812#else
6a077020 813 SvREFCNT_dec(cSVOPo->op_sv);
a0714e2c 814 cSVOPo->op_sv = NULL;
350de78d 815#endif
b327b36f 816 if (still_valid) {
f7461760 817 int try_downgrade = SvREFCNT(gv) == 2;
fc2b2dca 818 SvREFCNT_dec_NN(gv);
f7461760
Z		 819 if (try_downgrade)
820 gv_try_downgrade(gv);
821 }
6a077020 822 }
79072805 823 break;
a1ae71d2 824 case OP_METHOD_NAMED:
79072805 825 case OP_CONST:
996c9baa 826 case OP_HINTSEVAL:
11343788 827 SvREFCNT_dec(cSVOPo->op_sv);
a0714e2c 828 cSVOPo->op_sv = NULL;
3b1c21fa
AB		 829#ifdef USE_ITHREADS
830 /** Bug #15654
831 Even if op_clear does a pad_free for the target of the op,
6a077020 832 pad_free doesn't actually remove the sv that exists in the pad;
3b1c21fa
AB		 833 instead it lives on. This results in that it could be reused as
834 a target later on when the pad was reallocated.
835 **/
836 if(o->op_targ) {
837 pad_swipe(o->op_targ,1);
838 o->op_targ = 0;
839 }
840#endif
79072805 841 break;
c9df4fda 842 case OP_DUMP:
748a9306
LW		 843 case OP_GOTO:
844 case OP_NEXT:
845 case OP_LAST:
846 case OP_REDO:
11343788 847 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
748a9306
LW		 848 break;
849 /* FALL THROUGH */
a0d0e21e 850 case OP_TRANS:
bb16bae8 851 case OP_TRANSR:
acb36ea4 852 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
99a1d0d1 853 assert(o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
043e41b8
DM		 854#ifdef USE_ITHREADS
855 if (cPADOPo->op_padix > 0) {
856 pad_swipe(cPADOPo->op_padix, TRUE);
857 cPADOPo->op_padix = 0;
858 }
859#else
a0ed51b3 860 SvREFCNT_dec(cSVOPo->op_sv);
a0714e2c 861 cSVOPo->op_sv = NULL;
043e41b8 862#endif
acb36ea4
GS		 863 }
864 else {
ea71c68d 865 PerlMemShared_free(cPVOPo->op_pv);
bd61b366 866 cPVOPo->op_pv = NULL;
acb36ea4 867 }
a0d0e21e
LW		 868 break;
869 case OP_SUBST:
20e98b0f 870 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
971a9dd3 871 goto clear_pmop;
748a9306 872 case OP_PUSHRE:
971a9dd3 873#ifdef USE_ITHREADS
20e98b0f 874 if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
dd2155a4
DM		 875 /* No GvIN_PAD_off here, because other references may still
876 * exist on the pad */
20e98b0f 877 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
971a9dd3
GS		 878 }
879#else
ad64d0ec 880 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
971a9dd3
GS		 881#endif
882 /* FALL THROUGH */
a0d0e21e 883 case OP_MATCH:
8782bef2 884 case OP_QR:
971a9dd3 885clear_pmop:
867940b8
DM		 886 if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
887 op_free(cPMOPo->op_code_list);
68e2671b 888 cPMOPo->op_code_list = NULL;
23083432 889 forget_pmop(cPMOPo);
20e98b0f 890 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
9cddf794
NC		 891 /* we use the same protection as the "SAFE" version of the PM_ macros
892 * here since sv_clean_all might release some PMOPs
5f8cb046
DM		 893 * after PL_regex_padav has been cleared
894 * and the clearing of PL_regex_padav needs to
895 * happen before sv_clean_all
896 */
13137afc
AB		 897#ifdef USE_ITHREADS
898 if(PL_regex_pad) { /* We could be in destruction */
402d2eb1 899 const IV offset = (cPMOPo)->op_pmoffset;
9cddf794 900 ReREFCNT_dec(PM_GETRE(cPMOPo));
402d2eb1
NC		 901 PL_regex_pad[offset] = &PL_sv_undef;
902 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
903 sizeof(offset));
13137afc 904 }
9cddf794
NC		 905#else
906 ReREFCNT_dec(PM_GETRE(cPMOPo));
907 PM_SETRE(cPMOPo, NULL);
1eb1540c 908#endif
13137afc 909
a0d0e21e 910 break;
79072805
LW		 911 }
912
743e66e6 913 if (o->op_targ > 0) {
11343788 914 pad_free(o->op_targ);
743e66e6
GS		 915 o->op_targ = 0;
916 }
79072805
LW		 917}
918
76e3520e 919STATIC void
3eb57f73
HS		 920S_cop_free(pTHX_ COP* cop)
921{
7918f24d
NC		 922 PERL_ARGS_ASSERT_COP_FREE;
923
05ec9bb3 924 CopFILE_free(cop);
0453d815 925 if (! specialWARN(cop->cop_warnings))
72dc9ed5 926 PerlMemShared_free(cop->cop_warnings);
20439bc7 927 cophh_free(CopHINTHASH_get(cop));
3eb57f73
HS		 928}
929
c2b1997a 930STATIC void
c4bd3ae5 931S_forget_pmop(pTHX_ PMOP *const o
c4bd3ae5 932 )
c2b1997a
NC		 933{
934 HV * const pmstash = PmopSTASH(o);
7918f24d
NC		 935
936 PERL_ARGS_ASSERT_FORGET_PMOP;
937
e39a6381 938 if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
ad64d0ec 939 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
c2b1997a
NC		 940 if (mg) {
941 PMOP **const array = (PMOP**) mg->mg_ptr;
942 U32 count = mg->mg_len / sizeof(PMOP**);
943 U32 i = count;
944
945 while (i--) {
946 if (array[i] == o) {
947 /* Found it. Move the entry at the end to overwrite it. */
948 array[i] = array[--count];
949 mg->mg_len = count * sizeof(PMOP**);
950 /* Could realloc smaller at this point always, but probably
951 not worth it. Probably worth free()ing if we're the
952 last. */
953 if(!count) {
954 Safefree(mg->mg_ptr);
955 mg->mg_ptr = NULL;
956 }
957 break;
958 }
959 }
960 }
961 }
1cdf7faf
NC		 962 if (PL_curpm == o)
963 PL_curpm = NULL;
c2b1997a
NC		 964}
965
bfd0ff22
NC		 966STATIC void
967S_find_and_forget_pmops(pTHX_ OP *o)
968{
7918f24d
NC		 969 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
970
bfd0ff22
NC		 971 if (o->op_flags & OPf_KIDS) {
972 OP *kid = cUNOPo->op_first;
973 while (kid) {
974 switch (kid->op_type) {
975 case OP_SUBST:
976 case OP_PUSHRE:
977 case OP_MATCH:
978 case OP_QR:
23083432 979 forget_pmop((PMOP*)kid);
bfd0ff22
NC		 980 }
981 find_and_forget_pmops(kid);
982 kid = kid->op_sibling;
983 }
984 }
985}
986
93c66552
DM		 987void
988Perl_op_null(pTHX_ OP *o)
8990e307 989{
27da23d5 990 dVAR;
7918f24d
NC		 991
992 PERL_ARGS_ASSERT_OP_NULL;
993
acb36ea4
GS		 994 if (o->op_type == OP_NULL)
995 return;
eb8433b7
NC		 996 if (!PL_madskills)
997 op_clear(o);
11343788
MB		 998 o->op_targ = o->op_type;
999 o->op_type = OP_NULL;
22c35a8c 1000 o->op_ppaddr = PL_ppaddr[OP_NULL];
8990e307
LW		 1001}
1002
4026c95a
SH		 1003void
1004Perl_op_refcnt_lock(pTHX)
1005{
27da23d5 1006 dVAR;
96a5add6 1007 PERL_UNUSED_CONTEXT;
4026c95a
SH		 1008 OP_REFCNT_LOCK;
1009}
1010
1011void
1012Perl_op_refcnt_unlock(pTHX)
1013{
27da23d5 1014 dVAR;
96a5add6 1015 PERL_UNUSED_CONTEXT;
4026c95a
SH		 1016 OP_REFCNT_UNLOCK;
1017}
1018
79072805
LW		 1019/* Contextualizers */
1020
d9088386
Z		 1021/*
1022=for apidoc Am|OP *|op_contextualize|OP *o|I32 context
1023
1024Applies a syntactic context to an op tree representing an expression.
1025I<o> is the op tree, and I<context> must be C<G_SCALAR>, C<G_ARRAY>,
1026or C<G_VOID> to specify the context to apply. The modified op tree
1027is returned.
1028
1029=cut
1030*/
1031
1032OP *
1033Perl_op_contextualize(pTHX_ OP *o, I32 context)
1034{
1035 PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1036 switch (context) {
1037 case G_SCALAR: return scalar(o);
1038 case G_ARRAY: return list(o);
1039 case G_VOID: return scalarvoid(o);
1040 default:
5637ef5b
NC		 1041 Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1042 (long) context);
d9088386
Z		 1043 return o;
1044 }
1045}
1046
5983a79d
BM		 1047/*
1048=head1 Optree Manipulation Functions
79072805 1049
5983a79d
BM		 1050=for apidoc Am|OP*|op_linklist|OP *o
1051This function is the implementation of the L</LINKLIST> macro. It should
1052not be called directly.
1053
1054=cut
1055*/
1056
1057OP *
1058Perl_op_linklist(pTHX_ OP *o)
79072805 1059{
3edf23ff 1060 OP *first;
79072805 1061
5983a79d 1062 PERL_ARGS_ASSERT_OP_LINKLIST;
7918f24d 1063
11343788
MB		 1064 if (o->op_next)
1065 return o->op_next;
79072805
LW		 1066
1067 /* establish postfix order */
3edf23ff
AL		 1068 first = cUNOPo->op_first;
1069 if (first) {
eb578fdb 1070 OP *kid;
3edf23ff
AL		 1071 o->op_next = LINKLIST(first);
1072 kid = first;
1073 for (;;) {
1074 if (kid->op_sibling) {
79072805 1075 kid->op_next = LINKLIST(kid->op_sibling);
3edf23ff
AL		 1076 kid = kid->op_sibling;
1077 } else {
11343788 1078 kid->op_next = o;
3edf23ff
AL		 1079 break;
1080 }
79072805
LW		 1081 }
1082 }
1083 else
11343788 1084 o->op_next = o;
79072805 1085
11343788 1086 return o->op_next;
79072805
LW		 1087}
1088
1f676739 1089static OP *
2dd5337b 1090S_scalarkids(pTHX_ OP *o)
79072805 1091{
11343788 1092 if (o && o->op_flags & OPf_KIDS) {
bfed75c6 1093 OP *kid;
11343788 1094 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW		 1095 scalar(kid);
1096 }
11343788 1097 return o;
79072805
LW		 1098}
1099
76e3520e 1100STATIC OP *
cea2e8a9 1101S_scalarboolean(pTHX_ OP *o)
8990e307 1102{
97aff369 1103 dVAR;
7918f24d
NC		 1104
1105 PERL_ARGS_ASSERT_SCALARBOOLEAN;
1106
6b7c6d95
FC		 1107 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST
1108 && !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) {
d008e5eb 1109 if (ckWARN(WARN_SYNTAX)) {
6867be6d 1110 const line_t oldline = CopLINE(PL_curcop);
a0d0e21e 1111
2b7cddde
NC		 1112 if (PL_parser && PL_parser->copline != NOLINE) {
1113 /* This ensures that warnings are reported at the first line
1114 of the conditional, not the last. */
53a7735b 1115 CopLINE_set(PL_curcop, PL_parser->copline);
2b7cddde 1116 }
9014280d 1117 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
57843af0 1118 CopLINE_set(PL_curcop, oldline);
d008e5eb 1119 }
a0d0e21e 1120 }
11343788 1121 return scalar(o);
8990e307
LW		 1122}
1123
1124OP *
864dbfa3 1125Perl_scalar(pTHX_ OP *o)
79072805 1126{
27da23d5 1127 dVAR;
79072805
LW		 1128 OP *kid;
1129
a0d0e21e 1130 /* assumes no premature commitment */
13765c85
DM		 1131 if (!o || (PL_parser && PL_parser->error_count)
1132 || (o->op_flags & OPf_WANT)
5dc0d613 1133 || o->op_type == OP_RETURN)
7e363e51 1134 {
11343788 1135 return o;
7e363e51 1136 }
79072805 1137
5dc0d613 1138 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
79072805 1139
11343788 1140 switch (o->op_type) {
79072805 1141 case OP_REPEAT:
11343788 1142 scalar(cBINOPo->op_first);
8990e307 1143 break;
79072805
LW		 1144 case OP_OR:
1145 case OP_AND:
1146 case OP_COND_EXPR:
11343788 1147 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
8990e307 1148 scalar(kid);
79072805 1149 break;
a0d0e21e 1150 /* FALL THROUGH */
a6d8037e 1151 case OP_SPLIT:
79072805 1152 case OP_MATCH:
8782bef2 1153 case OP_QR:
79072805
LW		 1154 case OP_SUBST:
1155 case OP_NULL:
8990e307 1156 default:
11343788
MB		 1157 if (o->op_flags & OPf_KIDS) {
1158 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
8990e307
LW		 1159 scalar(kid);
1160 }
79072805
LW		 1161 break;
1162 case OP_LEAVE:
1163 case OP_LEAVETRY:
5dc0d613 1164 kid = cLISTOPo->op_first;
54310121 1165 scalar(kid);
25b991bf
VP		 1166 kid = kid->op_sibling;
1167 do_kids:
1168 while (kid) {
1169 OP *sib = kid->op_sibling;
c08f093b
VP		 1170 if (sib && kid->op_type != OP_LEAVEWHEN)
1171 scalarvoid(kid);
1172 else
54310121 1173 scalar(kid);
25b991bf 1174 kid = sib;
54310121 1175 }
11206fdd 1176 PL_curcop = &PL_compiling;
54310121 1177 break;
748a9306 1178 case OP_SCOPE:
79072805 1179 case OP_LINESEQ:
8990e307 1180 case OP_LIST:
25b991bf
VP		 1181 kid = cLISTOPo->op_first;
1182 goto do_kids;
a801c63c 1183 case OP_SORT:
a2a5de95 1184 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
553e7bb0 1185 break;
79072805 1186 }
11343788 1187 return o;
79072805
LW		 1188}
1189
1190OP *
864dbfa3 1191Perl_scalarvoid(pTHX_ OP *o)
79072805 1192{
27da23d5 1193 dVAR;
79072805 1194 OP *kid;
095b19d1 1195 SV *useless_sv = NULL;
c445ea15 1196 const char* useless = NULL;
8990e307 1197 SV* sv;
2ebea0a1
GS		 1198 U8 want;
1199
7918f24d
NC		 1200 PERL_ARGS_ASSERT_SCALARVOID;
1201
eb8433b7
NC		 1202 /* trailing mad null ops don't count as "there" for void processing */
1203 if (PL_madskills &&
1204 o->op_type != OP_NULL &&
1205 o->op_sibling &&
1206 o->op_sibling->op_type == OP_NULL)
1207 {
1208 OP *sib;
1209 for (sib = o->op_sibling;
1210 sib && sib->op_type == OP_NULL;
1211 sib = sib->op_sibling) ;
1212
1213 if (!sib)
1214 return o;
1215 }
1216
acb36ea4 1217 if (o->op_type == OP_NEXTSTATE
acb36ea4
GS		 1218 || o->op_type == OP_DBSTATE
1219 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
acb36ea4 1220 || o->op_targ == OP_DBSTATE)))
2ebea0a1 1221 PL_curcop = (COP*)o; /* for warning below */
79072805 1222
54310121 1223 /* assumes no premature commitment */
2ebea0a1 1224 want = o->op_flags & OPf_WANT;
13765c85
DM		 1225 if ((want && want != OPf_WANT_SCALAR)
1226 || (PL_parser && PL_parser->error_count)
25b991bf 1227 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
7e363e51 1228 {
11343788 1229 return o;
7e363e51 1230 }
79072805 1231
b162f9ea 1232 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS		 1233 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1234 {
b162f9ea 1235 return scalar(o); /* As if inside SASSIGN */
7e363e51 1236 }
1c846c1f 1237
5dc0d613 1238 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
79072805 1239
11343788 1240 switch (o->op_type) {
79072805 1241 default:
22c35a8c 1242 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
8990e307 1243 break;
36477c24 1244 /* FALL THROUGH */
1245 case OP_REPEAT:
11343788 1246 if (o->op_flags & OPf_STACKED)
8990e307 1247 break;
5d82c453
GA		 1248 goto func_ops;
1249 case OP_SUBSTR:
1250 if (o->op_private == 4)
1251 break;
8990e307
LW		 1252 /* FALL THROUGH */
1253 case OP_GVSV:
1254 case OP_WANTARRAY:
1255 case OP_GV:
74295f0b 1256 case OP_SMARTMATCH:
8990e307
LW		 1257 case OP_PADSV:
1258 case OP_PADAV:
1259 case OP_PADHV:
1260 case OP_PADANY:
1261 case OP_AV2ARYLEN:
8990e307 1262 case OP_REF:
a0d0e21e
LW		 1263 case OP_REFGEN:
1264 case OP_SREFGEN:
8990e307
LW		 1265 case OP_DEFINED:
1266 case OP_HEX:
1267 case OP_OCT:
1268 case OP_LENGTH:
8990e307
LW		 1269 case OP_VEC:
1270 case OP_INDEX:
1271 case OP_RINDEX:
1272 case OP_SPRINTF:
1273 case OP_AELEM:
1274 case OP_AELEMFAST:
93bad3fd 1275 case OP_AELEMFAST_LEX:
8990e307 1276 case OP_ASLICE:
8990e307
LW		 1277 case OP_HELEM:
1278 case OP_HSLICE:
1279 case OP_UNPACK:
1280 case OP_PACK:
8990e307
LW		 1281 case OP_JOIN:
1282 case OP_LSLICE:
1283 case OP_ANONLIST:
1284 case OP_ANONHASH:
1285 case OP_SORT:
1286 case OP_REVERSE:
1287 case OP_RANGE:
1288 case OP_FLIP:
1289 case OP_FLOP:
1290 case OP_CALLER:
1291 case OP_FILENO:
1292 case OP_EOF:
1293 case OP_TELL:
1294 case OP_GETSOCKNAME:
1295 case OP_GETPEERNAME:
1296 case OP_READLINK:
1297 case OP_TELLDIR:
1298 case OP_GETPPID:
1299 case OP_GETPGRP:
1300 case OP_GETPRIORITY:
1301 case OP_TIME:
1302 case OP_TMS:
1303 case OP_LOCALTIME:
1304 case OP_GMTIME:
1305 case OP_GHBYNAME:
1306 case OP_GHBYADDR:
1307 case OP_GHOSTENT:
1308 case OP_GNBYNAME:
1309 case OP_GNBYADDR:
1310 case OP_GNETENT:
1311 case OP_GPBYNAME:
1312 case OP_GPBYNUMBER:
1313 case OP_GPROTOENT:
1314 case OP_GSBYNAME:
1315 case OP_GSBYPORT:
1316 case OP_GSERVENT:
1317 case OP_GPWNAM:
1318 case OP_GPWUID:
1319 case OP_GGRNAM:
1320 case OP_GGRGID:
1321 case OP_GETLOGIN:
78e1b766 1322 case OP_PROTOTYPE:
703227f5 1323 case OP_RUNCV:
5d82c453 1324 func_ops:
64aac5a9 1325 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
74295f0b 1326 /* Otherwise it's "Useless use of grep iterator" */
f5df4782 1327 useless = OP_DESC(o);
75068674
RGS		 1328 break;
1329
1330 case OP_SPLIT:
1331 kid = cLISTOPo->op_first;
1332 if (kid && kid->op_type == OP_PUSHRE
1333#ifdef USE_ITHREADS
1334 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff)
1335#else
1336 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv)
1337#endif
1338 useless = OP_DESC(o);
8990e307
LW		 1339 break;
1340
9f82cd5f
YST		 1341 case OP_NOT:
1342 kid = cUNOPo->op_first;
1343 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
bb16bae8 1344 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
9f82cd5f
YST		 1345 goto func_ops;
1346 }
1347 useless = "negative pattern binding (!~)";
1348 break;
1349
4f4d7508
DC		 1350 case OP_SUBST:
1351 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
8db9069c 1352 useless = "non-destructive substitution (s///r)";
4f4d7508
DC		 1353 break;
1354
bb16bae8
FC		 1355 case OP_TRANSR:
1356 useless = "non-destructive transliteration (tr///r)";
1357 break;
1358
8990e307
LW		 1359 case OP_RV2GV:
1360 case OP_RV2SV:
1361 case OP_RV2AV:
1362 case OP_RV2HV:
192587c2 1363 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
11343788 1364 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
8990e307
LW		 1365 useless = "a variable";
1366 break;
79072805
LW		 1367
1368 case OP_CONST:
7766f137 1369 sv = cSVOPo_sv;
7a52d87a
GS		 1370 if (cSVOPo->op_private & OPpCONST_STRICT)
1371 no_bareword_allowed(o);
1372 else {
d008e5eb 1373 if (ckWARN(WARN_VOID)) {
e7fec78e 1374 /* don't warn on optimised away booleans, eg
b5a930ec 1375 * use constant Foo, 5; Foo || print; */
e7fec78e 1376 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
d4c19fe8 1377 useless = NULL;
960b4253
MG		 1378 /* the constants 0 and 1 are permitted as they are
1379 conventionally used as dummies in constructs like
1380 1 while some_condition_with_side_effects; */
e7fec78e 1381 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
d4c19fe8 1382 useless = NULL;
d008e5eb 1383 else if (SvPOK(sv)) {
1e3f3188
KW		 1384 SV * const dsv = newSVpvs("");
1385 useless_sv
1386 = Perl_newSVpvf(aTHX_
1387 "a constant (%s)",
1388 pv_pretty(dsv, SvPVX_const(sv),
1389 SvCUR(sv), 32, NULL, NULL,
1390 PERL_PV_PRETTY_DUMP
1391 | PERL_PV_ESCAPE_NOCLEAR
1392 | PERL_PV_ESCAPE_UNI_DETECT));
1393 SvREFCNT_dec_NN(dsv);
d008e5eb 1394 }
919f76a3 1395 else if (SvOK(sv)) {
095b19d1 1396 useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", sv);
919f76a3
RGS		 1397 }
1398 else
1399 useless = "a constant (undef)";
8990e307
LW		 1400 }
1401 }
93c66552 1402 op_null(o); /* don't execute or even remember it */
79072805
LW		 1403 break;
1404
1405 case OP_POSTINC:
11343788 1406 o->op_type = OP_PREINC; /* pre-increment is faster */
22c35a8c 1407 o->op_ppaddr = PL_ppaddr[OP_PREINC];
79072805
LW		 1408 break;
1409
1410 case OP_POSTDEC:
11343788 1411 o->op_type = OP_PREDEC; /* pre-decrement is faster */
22c35a8c 1412 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
79072805
LW		 1413 break;
1414
679d6c4e
HS		 1415 case OP_I_POSTINC:
1416 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1417 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1418 break;
1419
1420 case OP_I_POSTDEC:
1421 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1422 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1423 break;
1424
f2f8fd84
GG		 1425 case OP_SASSIGN: {
1426 OP *rv2gv;
1427 UNOP *refgen, *rv2cv;
1428 LISTOP *exlist;
1429
1430 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
1431 break;
1432
1433 rv2gv = ((BINOP *)o)->op_last;
1434 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
1435 break;
1436
1437 refgen = (UNOP *)((BINOP *)o)->op_first;
1438
1439 if (!refgen || refgen->op_type != OP_REFGEN)
1440 break;
1441
1442 exlist = (LISTOP *)refgen->op_first;
1443 if (!exlist || exlist->op_type != OP_NULL
1444 || exlist->op_targ != OP_LIST)
1445 break;
1446
1447 if (exlist->op_first->op_type != OP_PUSHMARK)
1448 break;
1449
1450 rv2cv = (UNOP*)exlist->op_last;
1451
1452 if (rv2cv->op_type != OP_RV2CV)
1453 break;
1454
1455 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
1456 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
1457 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
1458
1459 o->op_private |= OPpASSIGN_CV_TO_GV;
1460 rv2gv->op_private |= OPpDONT_INIT_GV;
1461 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
1462
1463 break;
1464 }
1465
540dd770
GG		 1466 case OP_AASSIGN: {
1467 inplace_aassign(o);
1468 break;
1469 }
1470
79072805
LW		 1471 case OP_OR:
1472 case OP_AND:
edbe35ea
VP		 1473 kid = cLOGOPo->op_first;
1474 if (kid->op_type == OP_NOT
1475 && (kid->op_flags & OPf_KIDS)
1476 && !PL_madskills) {
1477 if (o->op_type == OP_AND) {
1478 o->op_type = OP_OR;
1479 o->op_ppaddr = PL_ppaddr[OP_OR];
1480 } else {
1481 o->op_type = OP_AND;
1482 o->op_ppaddr = PL_ppaddr[OP_AND];
1483 }
1484 op_null(kid);
1485 }
1486
c963b151 1487 case OP_DOR:
79072805 1488 case OP_COND_EXPR:
0d863452
RH		 1489 case OP_ENTERGIVEN:
1490 case OP_ENTERWHEN:
11343788 1491 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
79072805
LW		 1492 scalarvoid(kid);
1493 break;
5aabfad6 1494
a0d0e21e 1495 case OP_NULL:
11343788 1496 if (o->op_flags & OPf_STACKED)
a0d0e21e 1497 break;
5aabfad6 1498 /* FALL THROUGH */
2ebea0a1
GS		 1499 case OP_NEXTSTATE:
1500 case OP_DBSTATE:
79072805
LW		 1501 case OP_ENTERTRY:
1502 case OP_ENTER:
11343788 1503 if (!(o->op_flags & OPf_KIDS))
79072805 1504 break;
54310121 1505 /* FALL THROUGH */
463ee0b2 1506 case OP_SCOPE:
79072805
LW		 1507 case OP_LEAVE:
1508 case OP_LEAVETRY:
a0d0e21e 1509 case OP_LEAVELOOP:
79072805 1510 case OP_LINESEQ:
79072805 1511 case OP_LIST:
0d863452
RH		 1512 case OP_LEAVEGIVEN:
1513 case OP_LEAVEWHEN:
11343788 1514 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW		 1515 scalarvoid(kid);
1516 break;
c90c0ff4 1517 case OP_ENTEREVAL:
5196be3e 1518 scalarkids(o);
c90c0ff4 1519 break;
d6483035 1520 case OP_SCALAR:
5196be3e 1521 return scalar(o);
79072805 1522 }
095b19d1
NC		 1523
1524 if (useless_sv) {
1525 /* mortalise it, in case warnings are fatal. */
1526 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
1527 "Useless use of %"SVf" in void context",
1528 sv_2mortal(useless_sv));
1529 }
1530 else if (useless) {
1531 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
1532 "Useless use of %s in void context",
1533 useless);
1534 }
11343788 1535 return o;
79072805
LW		 1536}
1537
1f676739 1538static OP *
412da003 1539S_listkids(pTHX_ OP *o)
79072805 1540{
11343788 1541 if (o && o->op_flags & OPf_KIDS) {
6867be6d 1542 OP *kid;
11343788 1543 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW		 1544 list(kid);
1545 }
11343788 1546 return o;
79072805
LW		 1547}
1548
1549OP *
864dbfa3 1550Perl_list(pTHX_ OP *o)
79072805 1551{
27da23d5 1552 dVAR;
79072805
LW		 1553 OP *kid;
1554
a0d0e21e 1555 /* assumes no premature commitment */
13765c85
DM		 1556 if (!o || (o->op_flags & OPf_WANT)
1557 || (PL_parser && PL_parser->error_count)
5dc0d613 1558 || o->op_type == OP_RETURN)
7e363e51 1559 {
11343788 1560 return o;
7e363e51 1561 }
79072805 1562
b162f9ea 1563 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS		 1564 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1565 {
b162f9ea 1566 return o; /* As if inside SASSIGN */
7e363e51 1567 }
1c846c1f 1568
5dc0d613 1569 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
79072805 1570
11343788 1571 switch (o->op_type) {
79072805
LW		 1572 case OP_FLOP:
1573 case OP_REPEAT:
11343788 1574 list(cBINOPo->op_first);
79072805
LW		 1575 break;
1576 case OP_OR:
1577 case OP_AND:
1578 case OP_COND_EXPR:
11343788 1579 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
79072805
LW		 1580 list(kid);
1581 break;
1582 default:
1583 case OP_MATCH:
8782bef2 1584 case OP_QR:
79072805
LW		 1585 case OP_SUBST:
1586 case OP_NULL:
11343788 1587 if (!(o->op_flags & OPf_KIDS))
79072805 1588 break;
11343788
MB		 1589 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1590 list(cBINOPo->op_first);
1591 return gen_constant_list(o);
79072805
LW		 1592 }
1593 case OP_LIST:
11343788 1594 listkids(o);
79072805
LW		 1595 break;
1596 case OP_LEAVE:
1597 case OP_LEAVETRY:
5dc0d613 1598 kid = cLISTOPo->op_first;
54310121 1599 list(kid);
25b991bf
VP		 1600 kid = kid->op_sibling;
1601 do_kids:
1602 while (kid) {
1603 OP *sib = kid->op_sibling;
c08f093b
VP		 1604 if (sib && kid->op_type != OP_LEAVEWHEN)
1605 scalarvoid(kid);
1606 else
54310121 1607 list(kid);
25b991bf 1608 kid = sib;
54310121 1609 }
11206fdd 1610 PL_curcop = &PL_compiling;
54310121 1611 break;
748a9306 1612 case OP_SCOPE:
79072805 1613 case OP_LINESEQ:
25b991bf
VP		 1614 kid = cLISTOPo->op_first;
1615 goto do_kids;
79072805 1616 }
11343788 1617 return o;
79072805
LW		 1618}
1619
1f676739 1620static OP *
2dd5337b 1621S_scalarseq(pTHX_ OP *o)
79072805 1622{
97aff369 1623 dVAR;
11343788 1624 if (o) {
1496a290
AL		 1625 const OPCODE type = o->op_type;
1626
1627 if (type == OP_LINESEQ || type == OP_SCOPE ||
1628 type == OP_LEAVE || type == OP_LEAVETRY)
463ee0b2 1629 {
6867be6d 1630 OP *kid;
11343788 1631 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
ed6116ce 1632 if (kid->op_sibling) {
463ee0b2 1633 scalarvoid(kid);
ed6116ce 1634 }
463ee0b2 1635 }
3280af22 1636 PL_curcop = &PL_compiling;
79072805 1637 }
11343788 1638 o->op_flags &= ~OPf_PARENS;
3280af22 1639 if (PL_hints & HINT_BLOCK_SCOPE)
11343788 1640 o->op_flags |= OPf_PARENS;
79072805 1641 }
8990e307 1642 else
11343788
MB		 1643 o = newOP(OP_STUB, 0);
1644 return o;
79072805
LW		 1645}
1646
76e3520e 1647STATIC OP *
cea2e8a9 1648S_modkids(pTHX_ OP *o, I32 type)
79072805 1649{
11343788 1650 if (o && o->op_flags & OPf_KIDS) {
6867be6d 1651 OP *kid;
11343788 1652 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
3ad73efd 1653 op_lvalue(kid, type);
79072805 1654 }
11343788 1655 return o;
79072805
LW		 1656}
1657
3ad73efd 1658/*
d164302a
GG		 1659=for apidoc finalize_optree
1660
1661This function finalizes the optree. Should be called directly after
1662the complete optree is built. It does some additional
1663checking which can't be done in the normal ck_xxx functions and makes
1664the tree thread-safe.
1665
1666=cut
1667*/
1668void
1669Perl_finalize_optree(pTHX_ OP* o)
1670{
1671 PERL_ARGS_ASSERT_FINALIZE_OPTREE;
1672
1673 ENTER;
1674 SAVEVPTR(PL_curcop);
1675
1676 finalize_op(o);
1677
1678 LEAVE;
1679}
1680
60dde6b2 1681STATIC void
d164302a
GG		 1682S_finalize_op(pTHX_ OP* o)
1683{
1684 PERL_ARGS_ASSERT_FINALIZE_OP;
1685
1686#if defined(PERL_MAD) && defined(USE_ITHREADS)
1687 {
1688 /* Make sure mad ops are also thread-safe */
1689 MADPROP *mp = o->op_madprop;
1690 while (mp) {
1691 if (mp->mad_type == MAD_OP && mp->mad_vlen) {
1692 OP *prop_op = (OP *) mp->mad_val;
1693 /* We only need "Relocate sv to the pad for thread safety.", but this
1694 easiest way to make sure it traverses everything */
4dc304e0
FC		 1695 if (prop_op->op_type == OP_CONST)
1696 cSVOPx(prop_op)->op_private &= ~OPpCONST_STRICT;
d164302a
GG		 1697 finalize_op(prop_op);
1698 }
1699 mp = mp->mad_next;
1700 }
1701 }
1702#endif
1703
1704 switch (o->op_type) {
1705 case OP_NEXTSTATE:
1706 case OP_DBSTATE:
1707 PL_curcop = ((COP*)o); /* for warnings */
1708 break;
1709 case OP_EXEC:
ea31ed66
GG		 1710 if ( o->op_sibling
1711 && (o->op_sibling->op_type == OP_NEXTSTATE || o->op_sibling->op_type == OP_DBSTATE)
573d2b1a 1712 && ckWARN(WARN_EXEC))
d164302a 1713 {
ea31ed66
GG		 1714 if (o->op_sibling->op_sibling) {
1715 const OPCODE type = o->op_sibling->op_sibling->op_type;
d164302a
GG		 1716 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
1717 const line_t oldline = CopLINE(PL_curcop);
ea31ed66 1718 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_sibling));
d164302a
GG		 1719 Perl_warner(aTHX_ packWARN(WARN_EXEC),
1720 "Statement unlikely to be reached");
1721 Perl_warner(aTHX_ packWARN(WARN_EXEC),
1722 "\t(Maybe you meant system() when you said exec()?)\n");
1723 CopLINE_set(PL_curcop, oldline);
1724 }
1725 }
1726 }
1727 break;
1728
1729 case OP_GV:
1730 if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
1731 GV * const gv = cGVOPo_gv;
1732 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
1733 /* XXX could check prototype here instead of just carping */
1734 SV * const sv = sv_newmortal();
1735 gv_efullname3(sv, gv, NULL);
1736 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
1737 "%"SVf"() called too early to check prototype",
1738 SVfARG(sv));
1739 }
1740 }
1741 break;
1742
1743 case OP_CONST:
eb796c7f
GG		 1744 if (cSVOPo->op_private & OPpCONST_STRICT)
1745 no_bareword_allowed(o);
1746 /* FALLTHROUGH */
d164302a
GG		 1747#ifdef USE_ITHREADS
1748 case OP_HINTSEVAL:
1749 case OP_METHOD_NAMED:
1750 /* Relocate sv to the pad for thread safety.
1751 * Despite being a "constant", the SV is written to,
1752 * for reference counts, sv_upgrade() etc. */
1753 if (cSVOPo->op_sv) {
325e1816 1754 const PADOFFSET ix = pad_alloc(OP_CONST, SVf_READONLY);
82b84d04 1755 if (o->op_type != OP_METHOD_NAMED
d164302a
GG		 1756 && cSVOPo->op_sv == &PL_sv_undef) {
1757 /* PL_sv_undef is hack - it's unsafe to store it in the
1758 AV that is the pad, because av_fetch treats values of
1759 PL_sv_undef as a "free" AV entry and will merrily
1760 replace them with a new SV, causing pad_alloc to think
1761 that this pad slot is free. (When, clearly, it is not)
1762 */
1763 SvOK_off(PAD_SVl(ix));
1764 SvPADTMP_on(PAD_SVl(ix));
1765 SvREADONLY_on(PAD_SVl(ix));
1766 }
1767 else {
1768 SvREFCNT_dec(PAD_SVl(ix));
d164302a
GG		 1769 PAD_SETSV(ix, cSVOPo->op_sv);
1770 /* XXX I don't know how this isn't readonly already. */
e3918bb7 1771 if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
d164302a
GG		 1772 }
1773 cSVOPo->op_sv = NULL;
1774 o->op_targ = ix;
1775 }
1776#endif
1777 break;
1778
1779 case OP_HELEM: {
1780 UNOP *rop;
1781 SV *lexname;
1782 GV **fields;
1783 SV **svp, *sv;
1784 const char *key = NULL;
1785 STRLEN keylen;
1786
1787 if (((BINOP*)o)->op_last->op_type != OP_CONST)
1788 break;
1789
1790 /* Make the CONST have a shared SV */
1791 svp = cSVOPx_svp(((BINOP*)o)->op_last);
e3918bb7 1792 if ((!SvIsCOW(sv = *svp))
d164302a
GG		 1793 && SvTYPE(sv) < SVt_PVMG && !SvROK(sv)) {
1794 key = SvPV_const(sv, keylen);
1795 lexname = newSVpvn_share(key,
1796 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
1797 0);
fc2b2dca 1798 SvREFCNT_dec_NN(sv);
d164302a
GG		 1799 *svp = lexname;
1800 }
1801
1802 if ((o->op_private & (OPpLVAL_INTRO)))
1803 break;
1804
1805 rop = (UNOP*)((BINOP*)o)->op_first;
1806 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
1807 break;
1808 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
1809 if (!SvPAD_TYPED(lexname))
1810 break;
1811 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
1812 if (!fields || !GvHV(*fields))
1813 break;
1814 key = SvPV_const(*svp, keylen);
1815 if (!hv_fetch(GvHV(*fields), key,
1816 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) {
ce16c625 1817 Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
84cf752c 1818 "in variable %"SVf" of type %"HEKf,
ce16c625 1819 SVfARG(*svp), SVfARG(lexname),
84cf752c 1820 HEKfARG(HvNAME_HEK(SvSTASH(lexname))));
d164302a
GG		 1821 }
1822 break;
1823 }
1824
1825 case OP_HSLICE: {
1826 UNOP *rop;
1827 SV *lexname;
1828 GV **fields;
1829 SV **svp;
1830 const char *key;
1831 STRLEN keylen;
1832 SVOP *first_key_op, *key_op;
1833
1834 if ((o->op_private & (OPpLVAL_INTRO))
1835 /* I bet there's always a pushmark... */
1836 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
1837 /* hmmm, no optimization if list contains only one key. */
1838 break;
1839 rop = (UNOP*)((LISTOP*)o)->op_last;
1840 if (rop->op_type != OP_RV2HV)
1841 break;
1842 if (rop->op_first->op_type == OP_PADSV)
1843 /* @$hash{qw(keys here)} */
1844 rop = (UNOP*)rop->op_first;
1845 else {
1846 /* @{$hash}{qw(keys here)} */
1847 if (rop->op_first->op_type == OP_SCOPE
1848 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
1849 {
1850 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
1851 }
1852 else
1853 break;
1854 }
1855
1856 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
1857 if (!SvPAD_TYPED(lexname))
1858 break;
1859 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
1860 if (!fields || !GvHV(*fields))
1861 break;
1862 /* Again guessing that the pushmark can be jumped over.... */
1863 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
1864 ->op_first->op_sibling;
1865 for (key_op = first_key_op; key_op;
1866 key_op = (SVOP*)key_op->op_sibling) {
1867 if (key_op->op_type != OP_CONST)
1868 continue;
1869 svp = cSVOPx_svp(key_op);
1870 key = SvPV_const(*svp, keylen);
1871 if (!hv_fetch(GvHV(*fields), key,
1872 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) {
ce16c625 1873 Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
84cf752c 1874 "in variable %"SVf" of type %"HEKf,
ce16c625 1875 SVfARG(*svp), SVfARG(lexname),
84cf752c 1876 HEKfARG(HvNAME_HEK(SvSTASH(lexname))));
d164302a
GG		 1877 }
1878 }
1879 break;
1880 }
a7fd8ef6 1881
d164302a
GG		 1882 case OP_SUBST: {
1883 if (cPMOPo->op_pmreplrootu.op_pmreplroot)
1884 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
1885 break;
1886 }
1887 default:
1888 break;
1889 }
1890
1891 if (o->op_flags & OPf_KIDS) {
1892 OP *kid;
1893 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1894 finalize_op(kid);
1895 }
1896}
1897
1898/*
3ad73efd
Z		 1899=for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
1900
1901Propagate lvalue ("modifiable") context to an op and its children.
1902I<type> represents the context type, roughly based on the type of op that
1903would do the modifying, although C<local()> is represented by OP_NULL,
1904because it has no op type of its own (it is signalled by a flag on
001c3c51
FC		 1905the lvalue op).
1906
1907This function detects things that can't be modified, such as C<$x+1>, and
1908generates errors for them. For example, C<$x+1 = 2> would cause it to be
1909called with an op of type OP_ADD and a C<type> argument of OP_SASSIGN.
1910
1911It also flags things that need to behave specially in an lvalue context,
1912such as C<$$x = 5> which might have to vivify a reference in C<$x>.
3ad73efd
Z		 1913
1914=cut
1915*/
ddeae0f1 1916
79072805 1917OP *
d3d7d28f 1918Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
79072805 1919{
27da23d5 1920 dVAR;
79072805 1921 OP *kid;
ddeae0f1
DM		 1922 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1923 int localize = -1;
79072805 1924
13765c85 1925 if (!o || (PL_parser && PL_parser->error_count))
11343788 1926 return o;
79072805 1927
b162f9ea 1928 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS		 1929 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1930 {
b162f9ea 1931 return o;
7e363e51 1932 }
1c846c1f 1933
5c906035
GG		 1934 assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
1935
69974ce6
FC		 1936 if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
1937
11343788 1938 switch (o->op_type) {
68dc0745 1939 case OP_UNDEF:
3280af22 1940 PL_modcount++;
5dc0d613 1941 return o;
5f05dabc 1942 case OP_STUB:
58bde88d 1943 if ((o->op_flags & OPf_PARENS) || PL_madskills)
5f05dabc 1944 break;
1945 goto nomod;
a0d0e21e 1946 case OP_ENTERSUB:
f79aa60b 1947 if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
11343788
MB		 1948 !(o->op_flags & OPf_STACKED)) {
1949 o->op_type = OP_RV2CV; /* entersub => rv2cv */
767eda44
FC		 1950 /* Both ENTERSUB and RV2CV use this bit, but for different pur-
1951 poses, so we need it clear. */
e26df76a 1952 o->op_private &= ~1;
22c35a8c 1953 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
11343788 1954 assert(cUNOPo->op_first->op_type == OP_NULL);
93c66552 1955 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
79072805
LW		 1956 break;
1957 }
cd06dffe 1958 else { /* lvalue subroutine call */
777d9014
FC		 1959 o->op_private |= OPpLVAL_INTRO
1960 |(OPpENTERSUB_INARGS * (type == OP_LEAVESUBLV));
e6438c1a 1961 PL_modcount = RETURN_UNLIMITED_NUMBER;
4978d6d9 1962 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
d0887bf3 1963 /* Potential lvalue context: */
cd06dffe
GS		 1964 o->op_private |= OPpENTERSUB_INARGS;
1965 break;
1966 }
1967 else { /* Compile-time error message: */
1968 OP *kid = cUNOPo->op_first;
1969 CV *cv;
cd06dffe 1970
3ea285d1
AL		 1971 if (kid->op_type != OP_PUSHMARK) {
1972 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1973 Perl_croak(aTHX_
1974 "panic: unexpected lvalue entersub "
1975 "args: type/targ %ld:%"UVuf,
1976 (long)kid->op_type, (UV)kid->op_targ);
1977 kid = kLISTOP->op_first;
1978 }
cd06dffe
GS		 1979 while (kid->op_sibling)
1980 kid = kid->op_sibling;
1981 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
cd06dffe
GS		 1982 break; /* Postpone until runtime */
1983 }
b2ffa427 1984
cd06dffe
GS		 1985 kid = kUNOP->op_first;
1986 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1987 kid = kUNOP->op_first;
b2ffa427 1988 if (kid->op_type == OP_NULL)
cd06dffe
GS		 1989 Perl_croak(aTHX_
1990 "Unexpected constant lvalue entersub "
55140b79 1991 "entry via type/targ %ld:%"UVuf,
3d811634 1992 (long)kid->op_type, (UV)kid->op_targ);
cd06dffe 1993 if (kid->op_type != OP_GV) {
cd06dffe
GS		 1994 break;
1995 }
b2ffa427 1996
638eceb6 1997 cv = GvCV(kGVOP_gv);
1c846c1f 1998 if (!cv)
da1dff94 1999 break;
cd06dffe
GS		 2000 if (CvLVALUE(cv))
2001 break;
2002 }
2003 }
79072805
LW		 2004 /* FALL THROUGH */
2005 default:
a0d0e21e 2006 nomod:
f5d552b4 2007 if (flags & OP_LVALUE_NO_CROAK) return NULL;
6fbb66d6 2008 /* grep, foreach, subcalls, refgen */
145b2bbb
FC		 2009 if (type == OP_GREPSTART || type == OP_ENTERSUB
2010 || type == OP_REFGEN || type == OP_LEAVESUBLV)
a0d0e21e 2011 break;
cea2e8a9 2012 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
638bc118 2013 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
cd06dffe
GS		 2014 ? "do block"
2015 : (o->op_type == OP_ENTERSUB
2016 ? "non-lvalue subroutine call"
53e06cf0 2017 : OP_DESC(o))),
22c35a8c 2018 type ? PL_op_desc[type] : "local"));
11343788 2019 return o;
79072805 2020
a0d0e21e
LW		 2021 case OP_PREINC:
2022 case OP_PREDEC:
2023 case OP_POW:
2024 case OP_MULTIPLY:
2025 case OP_DIVIDE:
2026 case OP_MODULO:
2027 case OP_REPEAT:
2028 case OP_ADD:
2029 case OP_SUBTRACT:
2030 case OP_CONCAT:
2031 case OP_LEFT_SHIFT:
2032 case OP_RIGHT_SHIFT:
2033 case OP_BIT_AND:
2034 case OP_BIT_XOR:
2035 case OP_BIT_OR:
2036 case OP_I_MULTIPLY:
2037 case OP_I_DIVIDE:
2038 case OP_I_MODULO:
2039 case OP_I_ADD:
2040 case OP_I_SUBTRACT:
11343788 2041 if (!(o->op_flags & OPf_STACKED))
a0d0e21e 2042 goto nomod;
3280af22 2043 PL_modcount++;
a0d0e21e 2044 break;
b2ffa427 2045
79072805 2046 case OP_COND_EXPR:
ddeae0f1 2047 localize = 1;
11343788 2048 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
3ad73efd 2049 op_lvalue(kid, type);
79072805
LW		 2050 break;
2051
2052 case OP_RV2AV:
2053 case OP_RV2HV:
11343788 2054 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
e6438c1a 2055 PL_modcount = RETURN_UNLIMITED_NUMBER;
11343788 2056 return o; /* Treat \(@foo) like ordinary list. */
748a9306
LW		 2057 }
2058 /* FALL THROUGH */
79072805 2059 case OP_RV2GV:
5dc0d613 2060 if (scalar_mod_type(o, type))
3fe9a6f1 2061 goto nomod;
11343788 2062 ref(cUNOPo->op_first, o->op_type);
79072805 2063 /* FALL THROUGH */
79072805
LW		 2064 case OP_ASLICE:
2065 case OP_HSLICE:
ddeae0f1 2066 localize = 1;
78f9721b
SM		 2067 /* FALL THROUGH */
2068 case OP_AASSIGN:
631dbaa2
FC		 2069 if (type == OP_LEAVESUBLV)
2070 o->op_private |= OPpMAYBE_LVSUB;
2071 /* FALL THROUGH */
93a17b20
LW		 2072 case OP_NEXTSTATE:
2073 case OP_DBSTATE:
e6438c1a 2074 PL_modcount = RETURN_UNLIMITED_NUMBER;
79072805 2075 break;
28c5b5bc
RGS		 2076 case OP_AV2ARYLEN:
2077 PL_hints |= HINT_BLOCK_SCOPE;
2078 if (type == OP_LEAVESUBLV)
2079 o->op_private |= OPpMAYBE_LVSUB;
2080 PL_modcount++;
2081 break;
463ee0b2 2082 case OP_RV2SV:
aeea060c 2083 ref(cUNOPo->op_first, o->op_type);
ddeae0f1 2084 localize = 1;
463ee0b2 2085 /* FALL THROUGH */
79072805 2086 case OP_GV:
3280af22 2087 PL_hints |= HINT_BLOCK_SCOPE;
463ee0b2 2088 case OP_SASSIGN:
bf4b1e52
GS		 2089 case OP_ANDASSIGN:
2090 case OP_ORASSIGN:
c963b151 2091 case OP_DORASSIGN:
ddeae0f1
DM		 2092 PL_modcount++;
2093 break;
2094
8990e307 2095 case OP_AELEMFAST:
93bad3fd 2096 case OP_AELEMFAST_LEX:
6a077020 2097 localize = -1;
3280af22 2098 PL_modcount++;
8990e307
LW		 2099 break;
2100
748a9306
LW		 2101 case OP_PADAV:
2102 case OP_PADHV:
e6438c1a 2103 PL_modcount = RETURN_UNLIMITED_NUMBER;
5196be3e
MB		 2104 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
2105 return o; /* Treat \(@foo) like ordinary list. */
2106 if (scalar_mod_type(o, type))
3fe9a6f1 2107 goto nomod;
78f9721b
SM		 2108 if (type == OP_LEAVESUBLV)
2109 o->op_private |= OPpMAYBE_LVSUB;
748a9306
LW		 2110 /* FALL THROUGH */
2111 case OP_PADSV:
3280af22 2112 PL_modcount++;
ddeae0f1 2113 if (!type) /* local() */
5ede95a0
BF		 2114 Perl_croak(aTHX_ "Can't localize lexical variable %"SVf,
2115 PAD_COMPNAME_SV(o->op_targ));
463ee0b2
LW		 2116 break;
2117
748a9306 2118 case OP_PUSHMARK:
ddeae0f1 2119 localize = 0;
748a9306 2120 break;
b2ffa427 2121
69969c6f 2122 case OP_KEYS:
d8065907 2123 case OP_RKEYS:
fad4a2e4 2124 if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
69969c6f 2125 goto nomod;
5d82c453
GA		 2126 goto lvalue_func;
2127 case OP_SUBSTR:
2128 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
2129 goto nomod;
5f05dabc 2130 /* FALL THROUGH */
a0d0e21e 2131 case OP_POS:
463ee0b2 2132 case OP_VEC:
fad4a2e4 2133 lvalue_func:
78f9721b
SM		 2134 if (type == OP_LEAVESUBLV)
2135 o->op_private |= OPpMAYBE_LVSUB;
11343788 2136 if (o->op_flags & OPf_KIDS)
3ad73efd 2137 op_lvalue(cBINOPo->op_first->op_sibling, type);
463ee0b2 2138 break;
a0d0e21e 2139
463ee0b2
LW		 2140 case OP_AELEM:
2141 case OP_HELEM:
11343788 2142 ref(cBINOPo->op_first, o->op_type);
68dc0745 2143 if (type == OP_ENTERSUB &&
5dc0d613
MB		 2144 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
2145 o->op_private |= OPpLVAL_DEFER;
78f9721b
SM		 2146 if (type == OP_LEAVESUBLV)
2147 o->op_private |= OPpMAYBE_LVSUB;
ddeae0f1 2148 localize = 1;
3280af22 2149 PL_modcount++;
463ee0b2
LW		 2150 break;
2151
2152 case OP_SCOPE:
2153 case OP_LEAVE:
2154 case OP_ENTER:
78f9721b 2155 case OP_LINESEQ:
ddeae0f1 2156 localize = 0;
11343788 2157 if (o->op_flags & OPf_KIDS)
3ad73efd 2158 op_lvalue(cLISTOPo->op_last, type);
a0d0e21e
LW		 2159 break;
2160
2161 case OP_NULL:
ddeae0f1 2162 localize = 0;
638bc118
GS		 2163 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
2164 goto nomod;
2165 else if (!(o->op_flags & OPf_KIDS))
463ee0b2 2166 break;
11343788 2167 if (o->op_targ != OP_LIST) {
3ad73efd 2168 op_lvalue(cBINOPo->op_first, type);
a0d0e21e
LW		 2169 break;
2170 }
2171 /* FALL THROUGH */
463ee0b2 2172 case OP_LIST:
ddeae0f1 2173 localize = 0;
11343788 2174 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
5c906035
GG		 2175 /* elements might be in void context because the list is
2176 in scalar context or because they are attribute sub calls */
2177 if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
2178 op_lvalue(kid, type);
463ee0b2 2179 break;
78f9721b
SM		 2180
2181 case OP_RETURN:
2182 if (type != OP_LEAVESUBLV)
2183 goto nomod;
3ad73efd 2184 break; /* op_lvalue()ing was handled by ck_return() */
1efec5ed
FC		 2185
2186 case OP_COREARGS:
2187 return o;
463ee0b2 2188 }
58d95175 2189
8be1be90
AMS		 2190 /* [20011101.069] File test operators interpret OPf_REF to mean that
2191 their argument is a filehandle; thus \stat(".") should not set
2192 it. AMS 20011102 */
2193 if (type == OP_REFGEN &&
ef69c8fc 2194 PL_check[o->op_type] == Perl_ck_ftst)
8be1be90
AMS		 2195 return o;
2196
2197 if (type != OP_LEAVESUBLV)
2198 o->op_flags |= OPf_MOD;
2199
2200 if (type == OP_AASSIGN || type == OP_SASSIGN)
2201 o->op_flags |= OPf_SPECIAL|OPf_REF;
ddeae0f1
DM		 2202 else if (!type) { /* local() */
2203 switch (localize) {
2204 case 1:
2205 o->op_private |= OPpLVAL_INTRO;
2206 o->op_flags &= ~OPf_SPECIAL;
2207 PL_hints |= HINT_BLOCK_SCOPE;
2208 break;
2209 case 0:
2210 break;
2211 case -1:
a2a5de95
NC		 2212 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
2213 "Useless localization of %s", OP_DESC(o));
ddeae0f1 2214 }
463ee0b2 2215 }
8be1be90
AMS		 2216 else if (type != OP_GREPSTART && type != OP_ENTERSUB
2217 && type != OP_LEAVESUBLV)
2218 o->op_flags |= OPf_REF;
11343788 2219 return o;
463ee0b2
LW		 2220}
2221
864dbfa3 2222STATIC bool
5f66b61c 2223S_scalar_mod_type(const OP *o, I32 type)
3fe9a6f1 2224{
2225 switch (type) {
32a60974 2226 case OP_POS:
3fe9a6f1 2227 case OP_SASSIGN:
1efec5ed 2228 if (o && o->op_type == OP_RV2GV)
3fe9a6f1 2229 return FALSE;
2230 /* FALL THROUGH */
2231 case OP_PREINC:
2232 case OP_PREDEC:
2233 case OP_POSTINC:
2234 case OP_POSTDEC:
2235 case OP_I_PREINC:
2236 case OP_I_PREDEC:
2237 case OP_I_POSTINC:
2238 case OP_I_POSTDEC:
2239 case OP_POW:
2240 case OP_MULTIPLY:
2241 case OP_DIVIDE:
2242 case OP_MODULO:
2243 case OP_REPEAT:
2244 case OP_ADD:
2245 case OP_SUBTRACT:
2246 case OP_I_MULTIPLY:
2247 case OP_I_DIVIDE:
2248 case OP_I_MODULO:
2249 case OP_I_ADD:
2250 case OP_I_SUBTRACT:
2251 case OP_LEFT_SHIFT:
2252 case OP_RIGHT_SHIFT:
2253 case OP_BIT_AND:
2254 case OP_BIT_XOR:
2255 case OP_BIT_OR:
2256 case OP_CONCAT:
2257 case OP_SUBST:
2258 case OP_TRANS:
bb16bae8 2259 case OP_TRANSR:
49e9fbe6
GS		 2260 case OP_READ:
2261 case OP_SYSREAD:
2262 case OP_RECV:
bf4b1e52
GS		 2263 case OP_ANDASSIGN:
2264 case OP_ORASSIGN:
410d09fe 2265 case OP_DORASSIGN:
3fe9a6f1 2266 return TRUE;
2267 default:
2268 return FALSE;
2269 }
2270}
2271
35cd451c 2272STATIC bool
5f66b61c 2273S_is_handle_constructor(const OP *o, I32 numargs)
35cd451c 2274{
7918f24d
NC		 2275 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
2276
35cd451c
GS		 2277 switch (o->op_type) {
2278 case OP_PIPE_OP:
2279 case OP_SOCKPAIR:
504618e9 2280 if (numargs == 2)
35cd451c
GS		 2281 return TRUE;
2282 /* FALL THROUGH */
2283 case OP_SYSOPEN:
2284 case OP_OPEN:
ded8aa31 2285 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
35cd451c
GS		 2286 case OP_SOCKET:
2287 case OP_OPEN_DIR:
2288 case OP_ACCEPT:
504618e9 2289 if (numargs == 1)
35cd451c 2290 return TRUE;
5f66b61c 2291 /* FALLTHROUGH */
35cd451c
GS		 2292 default:
2293 return FALSE;
2294 }
2295}
2296
0d86688d
NC		 2297static OP *
2298S_refkids(pTHX_ OP *o, I32 type)
463ee0b2 2299{
11343788 2300 if (o && o->op_flags & OPf_KIDS) {
6867be6d 2301 OP *kid;
11343788 2302 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
463ee0b2
LW		 2303 ref(kid, type);
2304 }
11343788 2305 return o;
463ee0b2
LW		 2306}
2307
2308OP *
e4c5ccf3 2309Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
463ee0b2 2310{
27da23d5 2311 dVAR;
463ee0b2 2312 OP *kid;
463ee0b2 2313
7918f24d
NC		 2314 PERL_ARGS_ASSERT_DOREF;
2315
13765c85 2316 if (!o || (PL_parser && PL_parser->error_count))
11343788 2317 return o;
463ee0b2 2318
11343788 2319 switch (o->op_type) {
a0d0e21e 2320 case OP_ENTERSUB:
f4df43b5 2321 if ((type == OP_EXISTS || type == OP_DEFINED) &&
11343788
MB		 2322 !(o->op_flags & OPf_STACKED)) {
2323 o->op_type = OP_RV2CV; /* entersub => rv2cv */
22c35a8c 2324 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
11343788 2325 assert(cUNOPo->op_first->op_type == OP_NULL);
93c66552 2326 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
11343788 2327 o->op_flags |= OPf_SPECIAL;
e26df76a 2328 o->op_private &= ~1;
8990e307 2329 }
767eda44 2330 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
0e9700df
GG		 2331 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2332 : type == OP_RV2HV ? OPpDEREF_HV
2333 : OPpDEREF_SV);
767eda44
FC		 2334 o->op_flags |= OPf_MOD;
2335 }
2336
8990e307 2337 break;
aeea060c 2338
463ee0b2 2339 case OP_COND_EXPR:
11343788 2340 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
e4c5ccf3 2341 doref(kid, type, set_op_ref);
463ee0b2 2342 break;
8990e307 2343 case OP_RV2SV:
35cd451c
GS		 2344 if (type == OP_DEFINED)
2345 o->op_flags |= OPf_SPECIAL; /* don't create GV */
e4c5ccf3 2346 doref(cUNOPo->op_first, o->op_type, set_op_ref);
4633a7c4
LW		 2347 /* FALL THROUGH */
2348 case OP_PADSV:
5f05dabc 2349 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5dc0d613
MB		 2350 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2351 : type == OP_RV2HV ? OPpDEREF_HV
2352 : OPpDEREF_SV);
11343788 2353 o->op_flags |= OPf_MOD;
a0d0e21e 2354 }
8990e307 2355 break;
1c846c1f 2356
463ee0b2
LW		 2357 case OP_RV2AV:
2358 case OP_RV2HV:
e4c5ccf3
RH		 2359 if (set_op_ref)
2360 o->op_flags |= OPf_REF;
8990e307 2361 /* FALL THROUGH */
463ee0b2 2362 case OP_RV2GV:
35cd451c
GS		 2363 if (type == OP_DEFINED)
2364 o->op_flags |= OPf_SPECIAL; /* don't create GV */
e4c5ccf3 2365 doref(cUNOPo->op_first, o->op_type, set_op_ref);
463ee0b2 2366 break;
8990e307 2367
463ee0b2
LW		 2368 case OP_PADAV:
2369 case OP_PADHV:
e4c5ccf3
RH		 2370 if (set_op_ref)
2371 o->op_flags |= OPf_REF;
79072805 2372 break;
aeea060c 2373
8990e307 2374 case OP_SCALAR:
79072805 2375 case OP_NULL:
518618af 2376 if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
463ee0b2 2377 break;
e4c5ccf3 2378 doref(cBINOPo->op_first, type, set_op_ref);
79072805
LW		 2379 break;
2380 case OP_AELEM:
2381 case OP_HELEM:
e4c5ccf3 2382 doref(cBINOPo->op_first, o->op_type, set_op_ref);
5f05dabc 2383 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5dc0d613
MB		 2384 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2385 : type == OP_RV2HV ? OPpDEREF_HV
2386 : OPpDEREF_SV);
11343788 2387 o->op_flags |= OPf_MOD;
8990e307 2388 }
79072805
LW		 2389 break;
2390
463ee0b2 2391 case OP_SCOPE:
79072805 2392 case OP_LEAVE:
e4c5ccf3
RH		 2393 set_op_ref = FALSE;
2394 /* FALL THROUGH */
79072805 2395 case OP_ENTER:
8990e307 2396 case OP_LIST:
11343788 2397 if (!(o->op_flags & OPf_KIDS))
79072805 2398 break;
e4c5ccf3 2399 doref(cLISTOPo->op_last, type, set_op_ref);
79072805 2400 break;
a0d0e21e
LW		 2401 default:
2402 break;
79072805 2403 }
11343788 2404 return scalar(o);
8990e307 2405
79072805
LW		 2406}
2407
09bef843
SB		 2408STATIC OP *
2409S_dup_attrlist(pTHX_ OP *o)
2410{
97aff369 2411 dVAR;
0bd48802 2412 OP *rop;
09bef843 2413
7918f24d
NC		 2414 PERL_ARGS_ASSERT_DUP_ATTRLIST;
2415
09bef843
SB		 2416 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
2417 * where the first kid is OP_PUSHMARK and the remaining ones
2418 * are OP_CONST. We need to push the OP_CONST values.
2419 */
2420 if (o->op_type == OP_CONST)
b37c2d43 2421 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
eb8433b7
NC		 2422#ifdef PERL_MAD
2423 else if (o->op_type == OP_NULL)
1d866c12 2424 rop = NULL;
eb8433b7 2425#endif
09bef843
SB		 2426 else {
2427 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
5f66b61c 2428 rop = NULL;
09bef843
SB		 2429 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
2430 if (o->op_type == OP_CONST)
2fcb4757 2431 rop = op_append_elem(OP_LIST, rop,
09bef843 2432 newSVOP(OP_CONST, o->op_flags,
b37c2d43 2433 SvREFCNT_inc_NN(cSVOPo->op_sv)));
09bef843
SB		 2434 }
2435 }
2436 return rop;
2437}
2438
2439STATIC void
ad0dc73b 2440S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
09bef843 2441{
27da23d5 2442 dVAR;
ad0dc73b 2443 SV * const stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
09bef843 2444
7918f24d
NC		 2445 PERL_ARGS_ASSERT_APPLY_ATTRS;
2446
09bef843
SB		 2447 /* fake up C<use attributes $pkg,$rv,@attrs> */
2448 ENTER; /* need to protect against side-effects of 'use' */
e4783991 2449
09bef843 2450#define ATTRSMODULE "attributes"
95f0a2f1
SB		 2451#define ATTRSMODULE_PM "attributes.pm"
2452
ad0dc73b 2453 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
6136c704
AL		 2454 newSVpvs(ATTRSMODULE),
2455 NULL,
2fcb4757 2456 op_prepend_elem(OP_LIST,
95f0a2f1 2457 newSVOP(OP_CONST, 0, stashsv),
2fcb4757 2458 op_prepend_elem(OP_LIST,
95f0a2f1
SB		 2459 newSVOP(OP_CONST, 0,
2460 newRV(target)),
2461 dup_attrlist(attrs))));
09bef843
SB		 2462 LEAVE;
2463}
2464
95f0a2f1
SB		 2465STATIC void
2466S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
2467{
97aff369 2468 dVAR;
95f0a2f1 2469 OP *pack, *imop, *arg;
ad0dc73b 2470 SV *meth, *stashsv, **svp;
95f0a2f1 2471
7918f24d
NC		 2472 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
2473
95f0a2f1
SB		 2474 if (!attrs)
2475 return;
2476
2477 assert(target->op_type == OP_PADSV ||
2478 target->op_type == OP_PADHV ||
2479 target->op_type == OP_PADAV);
2480
2481 /* Ensure that attributes.pm is loaded. */
ad0dc73b
FC		 2482 ENTER; /* need to protect against side-effects of 'use' */
2483 /* Don't force the C<use> if we don't need it. */
2484 svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
2485 if (svp && *svp != &PL_sv_undef)
2486 NOOP; /* already in %INC */
2487 else
2488 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
2489 newSVpvs(ATTRSMODULE), NULL);
2490 LEAVE;
95f0a2f1
SB		 2491
2492 /* Need package name for method call. */
6136c704 2493 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
95f0a2f1
SB		 2494
2495 /* Build up the real arg-list. */
5aaec2b4
NC		 2496 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2497
95f0a2f1
SB		 2498 arg = newOP(OP_PADSV, 0);
2499 arg->op_targ = target->op_targ;
2fcb4757 2500 arg = op_prepend_elem(OP_LIST,
95f0a2f1 2501 newSVOP(OP_CONST, 0, stashsv),
2fcb4757 2502 op_prepend_elem(OP_LIST,
95f0a2f1 2503 newUNOP(OP_REFGEN, 0,
3ad73efd 2504 op_lvalue(arg, OP_REFGEN)),
95f0a2f1
SB		 2505 dup_attrlist(attrs)));
2506
2507 /* Fake up a method call to import */
18916d0d 2508 meth = newSVpvs_share("import");
95f0a2f1 2509 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2fcb4757
Z		 2510 op_append_elem(OP_LIST,
2511 op_prepend_elem(OP_LIST, pack, list(arg)),
95f0a2f1 2512 newSVOP(OP_METHOD_NAMED, 0, meth)));
95f0a2f1
SB		 2513
2514 /* Combine the ops. */
2fcb4757 2515 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
95f0a2f1
SB		 2516}
2517
2518/*
2519=notfor apidoc apply_attrs_string
2520
2521Attempts to apply a list of attributes specified by the C<attrstr> and
2522C<len> arguments to the subroutine identified by the C<cv> argument which
2523is expected to be associated with the package identified by the C<stashpv>
2524argument (see L<attributes>). It gets this wrong, though, in that it
2525does not correctly identify the boundaries of the individual attribute
2526specifications within C<attrstr>. This is not really intended for the
2527public API, but has to be listed here for systems such as AIX which
2528need an explicit export list for symbols. (It's called from XS code
2529in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
2530to respect attribute syntax properly would be welcome.
2531
2532=cut
2533*/
2534
be3174d2 2535void
6867be6d
AL		 2536Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
2537 const char *attrstr, STRLEN len)
be3174d2 2538{
5f66b61c 2539 OP *attrs = NULL;
be3174d2 2540
7918f24d
NC		 2541 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2542
be3174d2
GS		 2543 if (!len) {
2544 len = strlen(attrstr);
2545 }
2546
2547 while (len) {
2548 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2549 if (len) {
890ce7af 2550 const char * const sstr = attrstr;
be3174d2 2551 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2fcb4757 2552 attrs = op_append_elem(OP_LIST, attrs,
be3174d2
GS		 2553 newSVOP(OP_CONST, 0,
2554 newSVpvn(sstr, attrstr-sstr)));
2555 }
2556 }
2557
2558 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
6136c704 2559 newSVpvs(ATTRSMODULE),
2fcb4757 2560 NULL, op_prepend_elem(OP_LIST,
be3174d2 2561 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2fcb4757 2562 op_prepend_elem(OP_LIST,
be3174d2 2563 newSVOP(OP_CONST, 0,
ad64d0ec 2564 newRV(MUTABLE_SV(cv))),
be3174d2
GS		 2565 attrs)));
2566}
2567
09bef843 2568STATIC OP *
95f0a2f1 2569S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
93a17b20 2570{
97aff369 2571 dVAR;
93a17b20 2572 I32 type;
a1fba7eb 2573 const bool stately = PL_parser && PL_parser->in_my == KEY_state;
93a17b20 2574
7918f24d
NC		 2575 PERL_ARGS_ASSERT_MY_KID;
2576
13765c85 2577 if (!o || (PL_parser && PL_parser->error_count))
11343788 2578 return o;
93a17b20 2579
bc61e325 2580 type = o->op_type;
eb8433b7
NC		 2581 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2582 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2583 return o;
2584 }
2585
93a17b20 2586 if (type == OP_LIST) {
6867be6d 2587 OP *kid;
11343788 2588 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
95f0a2f1 2589 my_kid(kid, attrs, imopsp);
0865059d 2590 return o;
8b8c1fb9 2591 } else if (type == OP_UNDEF || type == OP_STUB) {
7766148a 2592 return o;
77ca0c92
LW		 2593 } else if (type == OP_RV2SV || /* "our" declaration */
2594 type == OP_RV2AV ||
2595 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1ce0b88c 2596 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
fab01b8e 2597 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
952306ac 2598 OP_DESC(o),
12bd6ede
DM		 2599 PL_parser->in_my == KEY_our
2600 ? "our"
2601 : PL_parser->in_my == KEY_state ? "state" : "my"));
1ce0b88c 2602 } else if (attrs) {
551405c4 2603 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
12bd6ede
DM		 2604 PL_parser->in_my = FALSE;
2605 PL_parser->in_my_stash = NULL;
1ce0b88c
RGS		 2606 apply_attrs(GvSTASH(gv),
2607 (type == OP_RV2SV ? GvSV(gv) :
ad64d0ec
NC		 2608 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2609 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
ad0dc73b 2610 attrs);
1ce0b88c 2611 }
192587c2 2612 o->op_private |= OPpOUR_INTRO;
77ca0c92 2613 return o;
95f0a2f1
SB		 2614 }
2615 else if (type != OP_PADSV &&
93a17b20
LW		 2616 type != OP_PADAV &&
2617 type != OP_PADHV &&
2618 type != OP_PUSHMARK)
2619 {
eb64745e 2620 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
53e06cf0 2621 OP_DESC(o),
12bd6ede
DM		 2622 PL_parser->in_my == KEY_our
2623 ? "our"
2624 : PL_parser->in_my == KEY_state ? "state" : "my"));
11343788 2625 return o;
93a17b20 2626 }
09bef843
SB		 2627 else if (attrs && type != OP_PUSHMARK) {
2628 HV *stash;
09bef843 2629
12bd6ede
DM		 2630 PL_parser->in_my = FALSE;
2631 PL_parser->in_my_stash = NULL;
eb64745e 2632
09bef843 2633 /* check for C<my Dog $spot> when deciding package */
dd2155a4
DM		 2634 stash = PAD_COMPNAME_TYPE(o->op_targ);
2635 if (!stash)
09bef843 2636 stash = PL_curstash;
95f0a2f1 2637 apply_attrs_my(stash, o, attrs, imopsp);
09bef843 2638 }
11343788
MB		 2639 o->op_flags |= OPf_MOD;
2640 o->op_private |= OPpLVAL_INTRO;
a1fba7eb 2641 if (stately)
952306ac 2642 o->op_private |= OPpPAD_STATE;
11343788 2643 return o;
93a17b20
LW		 2644}
2645
2646OP *
09bef843
SB		 2647Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2648{
97aff369 2649 dVAR;
0bd48802 2650 OP *rops;
95f0a2f1
SB		 2651 int maybe_scalar = 0;
2652
7918f24d
NC		 2653 PERL_ARGS_ASSERT_MY_ATTRS;
2654
d2be0de5 2655/* [perl #17376]: this appears to be premature, and results in code such as
c754c3d7 2656 C< our(%x); > executing in list mode rather than void mode */
d2be0de5 2657#if 0
09bef843
SB		 2658 if (o->op_flags & OPf_PARENS)
2659 list(o);
95f0a2f1
SB		 2660 else
2661 maybe_scalar = 1;
d2be0de5
YST		 2662#else
2663 maybe_scalar = 1;
2664#endif
09bef843
SB		 2665 if (attrs)
2666 SAVEFREEOP(attrs);
5f66b61c 2667 rops = NULL;
95f0a2f1
SB		 2668 o = my_kid(o, attrs, &rops);
2669 if (rops) {
2670 if (maybe_scalar && o->op_type == OP_PADSV) {
2fcb4757 2671 o = scalar(op_append_list(OP_LIST, rops, o));
95f0a2f1
SB		 2672 o->op_private |= OPpLVAL_INTRO;
2673 }
f5d1ed10
FC		 2674 else {
2675 /* The listop in rops might have a pushmark at the beginning,
2676 which will mess up list assignment. */
2677 LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
2678 if (rops->op_type == OP_LIST &&
2679 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
2680 {
2681 OP * const pushmark = lrops->op_first;
2682 lrops->op_first = pushmark->op_sibling;
2683 op_free(pushmark);
2684 }
2fcb4757 2685 o = op_append_list(OP_LIST, o, rops);
f5d1ed10 2686 }
95f0a2f1 2687 }
12bd6ede
DM		 2688 PL_parser->in_my = FALSE;
2689 PL_parser->in_my_stash = NULL;
eb64745e 2690 return o;
09bef843
SB		 2691}
2692
2693OP *
864dbfa3 2694Perl_sawparens(pTHX_ OP *o)
79072805 2695{
96a5add6 2696 PERL_UNUSED_CONTEXT;
79072805
LW		 2697 if (o)
2698 o->op_flags |= OPf_PARENS;
2699 return o;
2700}
2701
2702OP *
864dbfa3 2703Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
79072805 2704{
11343788 2705 OP *o;
59f00321 2706 bool ismatchop = 0;
1496a290
AL		 2707 const OPCODE ltype = left->op_type;
2708 const OPCODE rtype = right->op_type;
79072805 2709
7918f24d
NC		 2710 PERL_ARGS_ASSERT_BIND_MATCH;
2711
1496a290
AL		 2712 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2713 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
041457d9 2714 {
1496a290 2715 const char * const desc
bb16bae8
FC		 2716 = PL_op_desc[(
2717 rtype == OP_SUBST || rtype == OP_TRANS
2718 || rtype == OP_TRANSR
2719 )
666ea192 2720 ? (int)rtype : OP_MATCH];
c6771ab6
FC		 2721 const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
2722 GV *gv;
2723 SV * const name =
2724 (ltype == OP_RV2AV || ltype == OP_RV2HV)
2725 ? cUNOPx(left)->op_first->op_type == OP_GV
2726 && (gv = cGVOPx_gv(cUNOPx(left)->op_first))
2727 ? varname(gv, isary ? '@' : '%', 0, NULL, 0, 1)
2728 : NULL
ba510004
FC		 2729 : varname(
2730 (GV *)PL_compcv, isary ? '@' : '%', left->op_targ, NULL, 0, 1
2731 );
c6771ab6
FC		 2732 if (name)
2733 Perl_warner(aTHX_ packWARN(WARN_MISC),
2734 "Applying %s to %"SVf" will act on scalar(%"SVf")",
2735 desc, name, name);
2736 else {
2737 const char * const sample = (isary
666ea192 2738 ? "@array" : "%hash");
c6771ab6 2739 Perl_warner(aTHX_ packWARN(WARN_MISC),
1c846c1f 2740 "Applying %s to %s will act on scalar(%s)",
599cee73 2741 desc, sample, sample);
c6771ab6 2742 }
2ae324a7 2743 }
2744
1496a290 2745 if (rtype == OP_CONST &&
5cc9e5c9
RH		 2746 cSVOPx(right)->op_private & OPpCONST_BARE &&
2747 cSVOPx(right)->op_private & OPpCONST_STRICT)
2748 {
2749 no_bareword_allowed(right);
2750 }
2751
bb16bae8 2752 /* !~ doesn't make sense with /r, so error on it for now */
4f4d7508
DC		 2753 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
2754 type == OP_NOT)
2755 yyerror("Using !~ with s///r doesn't make sense");
bb16bae8
FC		 2756 if (rtype == OP_TRANSR && type == OP_NOT)
2757 yyerror("Using !~ with tr///r doesn't make sense");
4f4d7508 2758
2474a784
FC		 2759 ismatchop = (rtype == OP_MATCH ||
2760 rtype == OP_SUBST ||
bb16bae8 2761 rtype == OP_TRANS || rtype == OP_TRANSR)
2474a784 2762 && !(right->op_flags & OPf_SPECIAL);
59f00321
RGS		 2763 if (ismatchop && right->op_private & OPpTARGET_MY) {
2764 right->op_targ = 0;
2765 right->op_private &= ~OPpTARGET_MY;
2766 }
2767 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1496a290
AL		 2768 OP *newleft;
2769
79072805 2770 right->op_flags |= OPf_STACKED;
bb16bae8 2771 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
1496a290 2772 ! (rtype == OP_TRANS &&
4f4d7508
DC		 2773 right->op_private & OPpTRANS_IDENTICAL) &&
2774 ! (rtype == OP_SUBST &&
2775 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
3ad73efd 2776 newleft = op_lvalue(left, rtype);
1496a290
AL		 2777 else
2778 newleft = left;
bb16bae8 2779 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
1496a290 2780 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
79072805 2781 else
2fcb4757 2782 o = op_prepend_elem(rtype, scalar(newleft), right);
79072805 2783 if (type == OP_NOT)
11343788
MB		 2784 return newUNOP(OP_NOT, 0, scalar(o));
2785 return o;
79072805
LW		 2786 }
2787 else
2788 return bind_match(type, left,
d63c20f2 2789 pmruntime(newPMOP(OP_MATCH, 0), right, 0, 0));
79072805
LW		 2790}
2791
2792OP *
864dbfa3 2793Perl_invert(pTHX_ OP *o)
79072805 2794{
11343788 2795 if (!o)
1d866c12 2796 return NULL;
11343788 2797 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
79072805
LW		 2798}
2799
3ad73efd
Z		 2800/*
2801=for apidoc Amx|OP *|op_scope|OP *o
2802
2803Wraps up an op tree with some additional ops so that at runtime a dynamic
2804scope will be created. The original ops run in the new dynamic scope,
2805and then, provided that they exit normally, the scope will be unwound.
2806The additional ops used to create and unwind the dynamic scope will
2807normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
2808instead if the ops are simple enough to not need the full dynamic scope
2809structure.
2810
2811=cut
2812*/
2813
79072805 2814OP *
3ad73efd 2815Perl_op_scope(pTHX_ OP *o)
79072805 2816{
27da23d5 2817 dVAR;
79072805 2818 if (o) {
284167a5 2819 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
2fcb4757 2820 o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
463ee0b2 2821 o->op_type = OP_LEAVE;
22c35a8c 2822 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
463ee0b2 2823 }
fdb22418
HS		 2824 else if (o->op_type == OP_LINESEQ) {
2825 OP *kid;
2826 o->op_type = OP_SCOPE;
2827 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2828 kid = ((LISTOP*)o)->op_first;
59110972 2829 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
fdb22418 2830 op_null(kid);
59110972
RH		 2831
2832 /* The following deals with things like 'do {1 for 1}' */
2833 kid = kid->op_sibling;
2834 if (kid &&
2835 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2836 op_null(kid);
2837 }
463ee0b2 2838 }
fdb22418 2839 else
5f66b61c 2840 o = newLISTOP(OP_SCOPE, 0, o, NULL);
79072805
LW		 2841 }
2842 return o;
2843}
1930840b 2844
705fe0e5
FC		 2845OP *
2846Perl_op_unscope(pTHX_ OP *o)
2847{
2848 if (o && o->op_type == OP_LINESEQ) {
2849 OP *kid = cLISTOPo->op_first;
2850 for(; kid; kid = kid->op_sibling)
2851 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
2852 op_null(kid);
2853 }
2854 return o;
2855}
2856
a0d0e21e 2857int
864dbfa3 2858Perl_block_start(pTHX_ int full)
79072805 2859{
97aff369 2860 dVAR;
73d840c0 2861 const int retval = PL_savestack_ix;
1930840b 2862
dd2155a4 2863 pad_block_start(full);
b3ac6de7 2864 SAVEHINTS();
3280af22 2865 PL_hints &= ~HINT_BLOCK_SCOPE;
68da3b2f 2866 SAVECOMPILEWARNINGS();
72dc9ed5 2867 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
1930840b 2868
a88d97bf 2869 CALL_BLOCK_HOOKS(bhk_start, full);
1930840b 2870
a0d0e21e
LW		 2871 return retval;
2872}
2873
2874OP*
864dbfa3 2875Perl_block_end(pTHX_ I32 floor, OP *seq)
a0d0e21e 2876{
97aff369 2877 dVAR;
6867be6d 2878 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1930840b 2879 OP* retval = scalarseq(seq);
6d5c2147 2880 OP *o;
1930840b 2881
a88d97bf 2882 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
1930840b 2883
e9818f4e 2884 LEAVE_SCOPE(floor);
623e6609 2885 CopHINTS_set(&PL_compiling, PL_hints);
a0d0e21e 2886 if (needblockscope)
3280af22 2887 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
6d5c2147
FC		 2888 o = pad_leavemy();
2889
2890 if (o) {
2891 /* pad_leavemy has created a sequence of introcv ops for all my
2892 subs declared in the block. We have to replicate that list with
2893 clonecv ops, to deal with this situation:
2894
2895 sub {
2896 my sub s1;
2897 my sub s2;
2898 sub s1 { state sub foo { \&s2 } }
2899 }->()
2900
2901 Originally, I was going to have introcv clone the CV and turn
2902 off the stale flag. Since &s1 is declared before &s2, the
2903 introcv op for &s1 is executed (on sub entry) before the one for
2904 &s2. But the &foo sub inside &s1 (which is cloned when &s1 is
2905 cloned, since it is a state sub) closes over &s2 and expects
2906 to see it in its outer CV’s pad. If the introcv op clones &s1,
2907 then &s2 is still marked stale. Since &s1 is not active, and
2908 &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
2909 ble will not stay shared’ warning. Because it is the same stub
2910 that will be used when the introcv op for &s2 is executed, clos-
2911 ing over it is safe. Hence, we have to turn off the stale flag
2912 on all lexical subs in the block before we clone any of them.
2913 Hence, having introcv clone the sub cannot work. So we create a
2914 list of ops like this:
2915
2916 lineseq
2917 |
2918 +-- introcv
2919 |
2920 +-- introcv
2921 |
2922 +-- introcv
2923 |
2924 .
2925 .
2926 .
2927 |
2928 +-- clonecv
2929 |
2930 +-- clonecv
2931 |
2932 +-- clonecv
2933 |
2934 .
2935 .
2936 .
2937 */
2938 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
2939 OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
2940 for (;; kid = kid->op_sibling) {
2941 OP *newkid = newOP(OP_CLONECV, 0);
2942 newkid->op_targ = kid->op_targ;
2943 o = op_append_elem(OP_LINESEQ, o, newkid);
2944 if (kid == last) break;
2945 }
2946 retval = op_prepend_elem(OP_LINESEQ, o, retval);
2947 }
1930840b 2948
a88d97bf 2949 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
1930840b 2950
a0d0e21e
LW		 2951 return retval;
2952}
2953
fd85fad2
BM		 2954/*
2955=head1 Compile-time scope hooks
2956
3e4ddde5 2957=for apidoc Aox||blockhook_register
fd85fad2
BM		 2958
2959Register a set of hooks to be called when the Perl lexical scope changes
2960at compile time. See L<perlguts/"Compile-time scope hooks">.
2961
2962=cut
2963*/
2964
bb6c22e7
BM		 2965void
2966Perl_blockhook_register(pTHX_ BHK *hk)
2967{
2968 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
2969
2970 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
2971}
2972
76e3520e 2973STATIC OP *
cea2e8a9 2974S_newDEFSVOP(pTHX)
54b9620d 2975{
97aff369 2976 dVAR;
cc76b5cc 2977 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
00b1698f 2978 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
59f00321
RGS		 2979 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2980 }
2981 else {
551405c4 2982 OP * const o = newOP(OP_PADSV, 0);
59f00321
RGS		 2983 o->op_targ = offset;
2984 return o;
2985 }
54b9620d
MB		 2986}
2987
a0d0e21e 2988void
864dbfa3 2989Perl_newPROG(pTHX_ OP *o)
a0d0e21e 2990{
97aff369 2991 dVAR;
7918f24d
NC		 2992
2993 PERL_ARGS_ASSERT_NEWPROG;
2994
3280af22 2995 if (PL_in_eval) {
86a64801 2996 PERL_CONTEXT *cx;
63429d50 2997 I32 i;
b295d113
TH		 2998 if (PL_eval_root)
2999 return;
faef0170
HS		 3000 PL_eval_root = newUNOP(OP_LEAVEEVAL,
3001 ((PL_in_eval & EVAL_KEEPERR)
3002 ? OPf_SPECIAL : 0), o);
86a64801
GG		 3003
3004 cx = &cxstack[cxstack_ix];
3005 assert(CxTYPE(cx) == CXt_EVAL);
3006
3007 if ((cx->blk_gimme & G_WANT) == G_VOID)
3008 scalarvoid(PL_eval_root);
3009 else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
3010 list(PL_eval_root);
3011 else
3012 scalar(PL_eval_root);
3013
5983a79d 3014 PL_eval_start = op_linklist(PL_eval_root);
7934575e
GS		 3015 PL_eval_root->op_private |= OPpREFCOUNTED;
3016 OpREFCNT_set(PL_eval_root, 1);
3280af22 3017 PL_eval_root->op_next = 0;
63429d50
FC		 3018 i = PL_savestack_ix;
3019 SAVEFREEOP(o);
3020 ENTER;
a2efc822 3021 CALL_PEEP(PL_eval_start);
86a64801 3022 finalize_optree(PL_eval_root);
63429d50
FC		 3023 LEAVE;
3024 PL_savestack_ix = i;
a0d0e21e
LW		 3025 }
3026 else {
6be89cf9 3027 if (o->op_type == OP_STUB) {
22e660b4
NC		 3028 /* This block is entered if nothing is compiled for the main
3029 program. This will be the case for an genuinely empty main
3030 program, or one which only has BEGIN blocks etc, so already
3031 run and freed.
3032
3033 Historically (5.000) the guard above was !o. However, commit
3034 f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
3035 c71fccf11fde0068, changed perly.y so that newPROG() is now
3036 called with the output of block_end(), which returns a new
3037 OP_STUB for the case of an empty optree. ByteLoader (and
3038 maybe other things) also take this path, because they set up
3039 PL_main_start and PL_main_root directly, without generating an
3040 optree.
8b31d4e4
NC		 3041
3042 If the parsing the main program aborts (due to parse errors,
3043 or due to BEGIN or similar calling exit), then newPROG()
3044 isn't even called, and hence this code path and its cleanups
3045 are skipped. This shouldn't make a make a difference:
3046 * a non-zero return from perl_parse is a failure, and
3047 perl_destruct() should be called immediately.
3048 * however, if exit(0) is called during the parse, then
3049 perl_parse() returns 0, and perl_run() is called. As
3050 PL_main_start will be NULL, perl_run() will return
3051 promptly, and the exit code will remain 0.
22e660b4
NC		 3052 */
3053
6be89cf9
AE		 3054 PL_comppad_name = 0;
3055 PL_compcv = 0;
d2c837a0 3056 S_op_destroy(aTHX_ o);
a0d0e21e 3057 return;
6be89cf9 3058 }
3ad73efd 3059 PL_main_root = op_scope(sawparens(scalarvoid(o)));
3280af22
NIS		 3060 PL_curcop = &PL_compiling;
3061 PL_main_start = LINKLIST(PL_main_root);
7934575e
GS		 3062 PL_main_root->op_private |= OPpREFCOUNTED;
3063 OpREFCNT_set(PL_main_root, 1);
3280af22 3064 PL_main_root->op_next = 0;
a2efc822 3065 CALL_PEEP(PL_main_start);
d164302a 3066 finalize_optree(PL_main_root);
8be227ab 3067 cv_forget_slab(PL_compcv);
3280af22 3068 PL_compcv = 0;
3841441e 3069
4fdae800 3070 /* Register with debugger */
84902520 3071 if (PERLDB_INTER) {
b96d8cd9 3072 CV * const cv = get_cvs("DB::postponed", 0);
3841441e
CS		 3073 if (cv) {
3074 dSP;
924508f0 3075 PUSHMARK(SP);
ad64d0ec 3076 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3841441e 3077 PUTBACK;
ad64d0ec 3078 call_sv(MUTABLE_SV(cv), G_DISCARD);
3841441e
CS		 3079 }
3080 }
79072805 3081 }
79072805
LW		 3082}
3083
3084OP *
864dbfa3 3085Perl_localize(pTHX_ OP *o, I32 lex)
79072805 3086{
97aff369 3087 dVAR;
7918f24d
NC		 3088
3089 PERL_ARGS_ASSERT_LOCALIZE;
3090
79072805 3091 if (o->op_flags & OPf_PARENS)
d2be0de5
YST		 3092/* [perl #17376]: this appears to be premature, and results in code such as
3093 C< our(%x); > executing in list mode rather than void mode */
3094#if 0
79072805 3095 list(o);
d2be0de5 3096#else
6f207bd3 3097 NOOP;
d2be0de5 3098#endif
8990e307 3099 else {
f06b5848
DM		 3100 if ( PL_parser->bufptr > PL_parser->oldbufptr
3101 && PL_parser->bufptr[-1] == ','
041457d9 3102 && ckWARN(WARN_PARENTHESIS))
64420d0d 3103 {
f06b5848 3104 char *s = PL_parser->bufptr;
bac662ee 3105 bool sigil = FALSE;
64420d0d 3106
8473848f 3107 /* some heuristics to detect a potential error */
bac662ee 3108 while (*s && (strchr(", \t\n", *s)))
64420d0d 3109 s++;
8473848f 3110
bac662ee
TS		 3111 while (1) {
3112 if (*s && strchr("@$%*", *s) && *++s
0eb30aeb 3113 && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
bac662ee
TS		 3114 s++;
3115 sigil = TRUE;
0eb30aeb 3116 while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
bac662ee
TS		 3117 s++;
3118 while (*s && (strchr(", \t\n", *s)))
3119 s++;
3120 }
3121 else
3122 break;
3123 }
3124 if (sigil && (*s == ';' || *s == '=')) {
3125 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
8473848f 3126 "Parentheses missing around \"%s\" list",
12bd6ede
DM		 3127 lex
3128 ? (PL_parser->in_my == KEY_our
3129 ? "our"
3130 : PL_parser->in_my == KEY_state
3131 ? "state"
3132 : "my")
3133 : "local");
8473848f 3134 }
8990e307
LW		 3135 }
3136 }
93a17b20 3137 if (lex)
eb64745e 3138 o = my(o);
93a17b20 3139 else
3ad73efd 3140 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
12bd6ede
DM		 3141 PL_parser->in_my = FALSE;
3142 PL_parser->in_my_stash = NULL;
eb64745e 3143 return o;
79072805
LW		 3144}
3145
3146OP *
864dbfa3 3147Perl_jmaybe(pTHX_ OP *o)
79072805 3148{
7918f24d
NC		 3149 PERL_ARGS_ASSERT_JMAYBE;
3150
79072805 3151 if (o->op_type == OP_LIST) {
fafc274c 3152 OP * const o2
d4c19fe8 3153 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2fcb4757 3154 o = convert(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
79072805
LW		 3155 }
3156 return o;
3157}
3158
985b9e54
GG		 3159PERL_STATIC_INLINE OP *
3160S_op_std_init(pTHX_ OP *o)
3161{
3162 I32 type = o->op_type;
3163
3164 PERL_ARGS_ASSERT_OP_STD_INIT;
3165
3166 if (PL_opargs[type] & OA_RETSCALAR)
3167 scalar(o);
3168 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
3169 o->op_targ = pad_alloc(type, SVs_PADTMP);
3170
3171 return o;
3172}
3173
3174PERL_STATIC_INLINE OP *
3175S_op_integerize(pTHX_ OP *o)
3176{
3177 I32 type = o->op_type;
3178
3179 PERL_ARGS_ASSERT_OP_INTEGERIZE;
3180
077da62f
FC		 3181 /* integerize op. */
3182 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
985b9e54 3183 {
f5f19483 3184 dVAR;
985b9e54
GG		 3185 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
3186 }
3187
3188 if (type == OP_NEGATE)
3189 /* XXX might want a ck_negate() for this */
3190 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
3191
3192 return o;
3193}
3194
1f676739 3195static OP *
5aaab254 3196S_fold_constants(pTHX_ OP *o)
79072805 3197{
27da23d5 3198 dVAR;
eb578fdb 3199 OP * VOL curop;
eb8433b7 3200 OP *newop;
8ea43dc8 3201 VOL I32 type = o->op_type;
e3cbe32f 3202 SV * VOL sv = NULL;
b7f7fd0b
NC		 3203 int ret = 0;
3204 I32 oldscope;
3205 OP *old_next;
5f2d9966
DM		 3206 SV * const oldwarnhook = PL_warnhook;
3207 SV * const olddiehook = PL_diehook;
c427f4d2 3208 COP not_compiling;
b7f7fd0b 3209 dJMPENV;
79072805 3210
7918f24d
NC		 3211 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
3212
22c35a8c 3213 if (!(PL_opargs[type] & OA_FOLDCONST))
79072805
LW		 3214 goto nope;
3215
de939608 3216 switch (type) {
de939608
CS		 3217 case OP_UCFIRST:
3218 case OP_LCFIRST:
3219 case OP_UC:
3220 case OP_LC:
7ccde120 3221 case OP_FC:
69dcf70c
MB		 3222 case OP_SLT:
3223 case OP_SGT:
3224 case OP_SLE:
3225 case OP_SGE:
3226 case OP_SCMP:
b3fd6149 3227 case OP_SPRINTF:
2de3dbcc 3228 /* XXX what about the numeric ops? */
82ad65bb 3229 if (IN_LOCALE_COMPILETIME)
de939608 3230 goto nope;
553e7bb0 3231 break;
dd9a6ccf
FC		 3232 case OP_PACK:
3233 if (!cLISTOPo->op_first->op_sibling
3234 || cLISTOPo->op_first->op_sibling->op_type != OP_CONST)
3235 goto nope;
3236 {
3237 SV * const sv = cSVOPx_sv(cLISTOPo->op_first->op_sibling);
3238 if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
3239 {
3240 const char *s = SvPVX_const(sv);
3241 while (s < SvEND(sv)) {
3242 if (*s == 'p' || *s == 'P') goto nope;
3243 s++;
3244 }
3245 }
3246 }
3247 break;
baed7faa
FC		 3248 case OP_REPEAT:
3249 if (o->op_private & OPpREPEAT_DOLIST) goto nope;
de939608
CS		 3250 }
3251
13765c85 3252 if (PL_parser && PL_parser->error_count)
a0d0e21e
LW		 3253 goto nope; /* Don't try to run w/ errors */
3254
79072805 3255 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
1496a290
AL		 3256 const OPCODE type = curop->op_type;
3257 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
3258 type != OP_LIST &&
3259 type != OP_SCALAR &&
3260 type != OP_NULL &&
3261 type != OP_PUSHMARK)
7a52d87a 3262 {
79072805
LW		 3263 goto nope;
3264 }
3265 }
3266
3267 curop = LINKLIST(o);
b7f7fd0b 3268 old_next = o->op_next;
79072805 3269 o->op_next = 0;
533c011a 3270 PL_op = curop;
b7f7fd0b
NC		 3271
3272 oldscope = PL_scopestack_ix;
edb2152a 3273 create_eval_scope(G_FAKINGEVAL);
b7f7fd0b 3274
c427f4d2
NC		 3275 /* Verify that we don't need to save it: */
3276 assert(PL_curcop == &PL_compiling);
3277 StructCopy(&PL_compiling, &not_compiling, COP);
3278 PL_curcop = &not_compiling;
3279 /* The above ensures that we run with all the correct hints of the
3280 currently compiling COP, but that IN_PERL_RUNTIME is not true. */
3281 assert(IN_PERL_RUNTIME);
5f2d9966
DM		 3282 PL_warnhook = PERL_WARNHOOK_FATAL;
3283 PL_diehook = NULL;
b7f7fd0b
NC		 3284 JMPENV_PUSH(ret);
3285
3286 switch (ret) {
3287 case 0:
3288 CALLRUNOPS(aTHX);
3289 sv = *(PL_stack_sp--);
523a0f0c
NC		 3290 if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
3291#ifdef PERL_MAD
3292 /* Can't simply swipe the SV from the pad, because that relies on
3293 the op being freed "real soon now". Under MAD, this doesn't
3294 happen (see the #ifdef below). */
3295 sv = newSVsv(sv);
3296#else
b7f7fd0b 3297 pad_swipe(o->op_targ, FALSE);
523a0f0c
NC		 3298#endif
3299 }
b7f7fd0b
NC		 3300 else if (SvTEMP(sv)) { /* grab mortal temp? */
3301 SvREFCNT_inc_simple_void(sv);
3302 SvTEMP_off(sv);
3303 }
ba610af8 3304 else { assert(SvIMMORTAL(sv)); }
b7f7fd0b
NC		 3305 break;
3306 case 3:
3307 /* Something tried to die. Abandon constant folding. */
3308 /* Pretend the error never happened. */
ab69dbc2 3309 CLEAR_ERRSV();
b7f7fd0b
NC		 3310 o->op_next = old_next;
3311 break;
3312 default:
3313 JMPENV_POP;
5f2d9966
DM		 3314 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
3315 PL_warnhook = oldwarnhook;
3316 PL_diehook = olddiehook;
3317 /* XXX note that this croak may fail as we've already blown away
3318 * the stack - eg any nested evals */
b7f7fd0b
NC		 3319 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
3320 }
b7f7fd0b 3321 JMPENV_POP;
5f2d9966
DM		 3322 PL_warnhook = oldwarnhook;
3323 PL_diehook = olddiehook;
c427f4d2 3324 PL_curcop = &PL_compiling;
edb2152a
NC		 3325
3326 if (PL_scopestack_ix > oldscope)
3327 delete_eval_scope();
eb8433b7 3328
b7f7fd0b
NC		 3329 if (ret)
3330 goto nope;
3331
eb8433b7 3332#ifndef PERL_MAD
79072805 3333 op_free(o);
eb8433b7 3334#endif
de5e01c2 3335 assert(sv);
2484f8db 3336 if (!SvIMMORTAL(sv)) SvPADTMP_on(sv);
79072805 3337 if (type == OP_RV2GV)
159b6efe 3338 newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
eb8433b7 3339 else
3513c740 3340 {
cc2ebcd7 3341 newop = newSVOP(OP_CONST, OPpCONST_FOLDED<<8, MUTABLE_SV(sv));
3513c740
NT		 3342 newop->op_folded = 1;
3343 }
eb8433b7
NC		 3344 op_getmad(o,newop,'f');
3345 return newop;
aeea060c 3346
b7f7fd0b 3347 nope:
79072805
LW		 3348 return o;
3349}
3350
1f676739 3351static OP *
5aaab254 3352S_gen_constant_list(pTHX_ OP *o)
79072805 3353{
27da23d5 3354 dVAR;
eb578fdb 3355 OP *curop;
6867be6d 3356 const I32 oldtmps_floor = PL_tmps_floor;
5608dcc6
FC		 3357 SV **svp;
3358 AV *av;
79072805 3359
a0d0e21e 3360 list(o);
13765c85 3361 if (PL_parser && PL_parser->error_count)
a0d0e21e
LW		 3362 return o; /* Don't attempt to run with errors */
3363
533c011a 3364 PL_op = curop = LINKLIST(o);
a0d0e21e 3365 o->op_next = 0;
a2efc822 3366 CALL_PEEP(curop);
897d3989 3367 Perl_pp_pushmark(aTHX);
cea2e8a9 3368 CALLRUNOPS(aTHX);
533c011a 3369 PL_op = curop;
78c72037
NC		 3370 assert (!(curop->op_flags & OPf_SPECIAL));
3371 assert(curop->op_type == OP_RANGE);
897d3989 3372 Perl_pp_anonlist(aTHX);
3280af22 3373 PL_tmps_floor = oldtmps_floor;
79072805
LW		 3374
3375 o->op_type = OP_RV2AV;
22c35a8c 3376 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
fb53bbb2
SG		 3377 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
3378 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
1a0a2ba9 3379 o->op_opt = 0; /* needs to be revisited in rpeep() */
79072805 3380 curop = ((UNOP*)o)->op_first;
5608dcc6
FC		 3381 av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
3382 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, (SV *)av);
3383 if (AvFILLp(av) != -1)
3384 for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
3385 SvPADTMP_on(*svp);
eb8433b7
NC		 3386#ifdef PERL_MAD
3387 op_getmad(curop,o,'O');
3388#else
79072805 3389 op_free(curop);
eb8433b7 3390#endif
5983a79d 3391 LINKLIST(o);
79072805
LW		 3392 return list(o);
3393}
3394
3395OP *
864dbfa3 3396Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
79072805 3397{
27da23d5 3398 dVAR;
d67594ff 3399 if (type < 0) type = -type, flags |= OPf_SPECIAL;
11343788 3400 if (!o || o->op_type != OP_LIST)
5f66b61c 3401 o = newLISTOP(OP_LIST, 0, o, NULL);
748a9306 3402 else
5dc0d613 3403 o->op_flags &= ~OPf_WANT;
79072805 3404
22c35a8c 3405 if (!(PL_opargs[type] & OA_MARK))
93c66552 3406 op_null(cLISTOPo->op_first);
bf0571fd
FC		 3407 else {
3408 OP * const kid2 = cLISTOPo->op_first->op_sibling;
3409 if (kid2 && kid2->op_type == OP_COREARGS) {
3410 op_null(cLISTOPo->op_first);
3411 kid2->op_private |= OPpCOREARGS_PUSHMARK;
3412 }
3413 }
8990e307 3414
eb160463 3415 o->op_type = (OPCODE)type;
22c35a8c 3416 o->op_ppaddr = PL_ppaddr[type];
11343788 3417 o->op_flags |= flags;
79072805 3418
11343788 3419 o = CHECKOP(type, o);
fe2774ed 3420 if (o->op_type != (unsigned)type)
11343788 3421 return o;
79072805 3422
985b9e54 3423 return fold_constants(op_integerize(op_std_init(o)));
79072805
LW		 3424}
3425
2fcb4757
Z		 3426/*
3427=head1 Optree Manipulation Functions
3428*/
3429
79072805
LW		 3430/* List constructors */
3431
2fcb4757
Z		 3432/*
3433=for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
3434
3435Append an item to the list of ops contained directly within a list-type
3436op, returning the lengthened list. I<first> is the list-type op,
3437and I<last> is the op to append to the list. I<optype> specifies the
3438intended opcode for the list. If I<first> is not already a list of the
3439right type, it will be upgraded into one. If either I<first> or I<last>
3440is null, the other is returned unchanged.
3441
3442=cut
3443*/
3444
79072805 3445OP *
2fcb4757 3446Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW		 3447{
3448 if (!first)
3449 return last;
8990e307
LW		 3450
3451 if (!last)
79072805 3452 return first;
8990e307 3453
fe2774ed 3454 if (first->op_type != (unsigned)type
155aba94
GS		 3455 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
3456 {
3457 return newLISTOP(type, 0, first, last);
3458 }
79072805 3459
a0d0e21e
LW		 3460 if (first->op_flags & OPf_KIDS)
3461 ((LISTOP*)first)->op_last->op_sibling = last;
3462 else {
3463 first->op_flags |= OPf_KIDS;
3464 ((LISTOP*)first)->op_first = last;
3465 }
3466 ((LISTOP*)first)->op_last = last;
a0d0e21e 3467 return first;
79072805
LW		 3468}
3469
2fcb4757
Z		 3470/*
3471=for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
3472
3473Concatenate the lists of ops contained directly within two list-type ops,
3474returning the combined list. I<first> and I<last> are the list-type ops
3475to concatenate. I<optype> specifies the intended opcode for the list.
3476If either I<first> or I<last> is not already a list of the right type,
3477it will be upgraded into one. If either I<first> or I<last> is null,
3478the other is returned unchanged.
3479
3480=cut
3481*/
3482
79072805 3483OP *
2fcb4757 3484Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
79072805
LW		 3485{
3486 if (!first)
2fcb4757 3487 return last;
8990e307
LW		 3488
3489 if (!last)
2fcb4757 3490 return first;
8990e307 3491
fe2774ed 3492 if (first->op_type != (unsigned)type)
2fcb4757 3493 return op_prepend_elem(type, first, last);
8990e307 3494
fe2774ed 3495 if (last->op_type != (unsigned)type)
2fcb4757 3496 return op_append_elem(type, first, last);
79072805 3497
2fcb4757
Z		 3498 ((LISTOP*)first)->op_last->op_sibling = ((LISTOP*)last)->op_first;
3499 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
117dada2 3500 first->op_flags |= (last->op_flags & OPf_KIDS);
1c846c1f 3501
eb8433b7 3502#ifdef PERL_MAD
2fcb4757
Z		 3503 if (((LISTOP*)last)->op_first && first->op_madprop) {
3504 MADPROP *mp = ((LISTOP*)last)->op_first->op_madprop;
eb8433b7
NC		 3505 if (mp) {
3506 while (mp->mad_next)
3507 mp = mp->mad_next;
3508 mp->mad_next = first->op_madprop;
3509 }
3510 else {
2fcb4757 3511 ((LISTOP*)last)->op_first->op_madprop = first->op_madprop;
eb8433b7
NC		 3512 }
3513 }
3514 first->op_madprop = last->op_madprop;
3515 last->op_madprop = 0;
3516#endif
3517
2fcb4757 3518 S_op_destroy(aTHX_ last);
238a4c30 3519
2fcb4757 3520 return first;
79072805
LW		 3521}
3522
2fcb4757
Z		 3523/*
3524=for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
3525
3526Prepend an item to the list of ops contained directly within a list-type
3527op, returning the lengthened list. I<first> is the op to prepend to the
3528list, and I<last> is the list-type op. I<optype> specifies the intended
3529opcode for the list. If I<last> is not already a list of the right type,
3530it will be upgraded into one. If either I<first> or I<last> is null,
3531the other is returned unchanged.
3532
3533=cut
3534*/
3535
79072805 3536OP *
2fcb4757 3537Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW		 3538{
3539 if (!first)
3540 return last;
8990e307
LW		 3541
3542 if (!last)
79072805 3543 return first;
8990e307 3544
fe2774ed 3545 if (last->op_type == (unsigned)type) {
8990e307
LW		 3546 if (type == OP_LIST) { /* already a PUSHMARK there */
3547 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
3548 ((LISTOP*)last)->op_first->op_sibling = first;
36a5d4ba
DC		 3549 if (!(first->op_flags & OPf_PARENS))
3550 last->op_flags &= ~OPf_PARENS;
8990e307
LW		 3551 }
3552 else {
3553 if (!(last->op_flags & OPf_KIDS)) {
3554 ((LISTOP*)last)->op_last = first;
3555 last->op_flags |= OPf_KIDS;
3556 }
3557 first->op_sibling = ((LISTOP*)last)->op_first;
3558 ((LISTOP*)last)->op_first = first;
79072805 3559 }
117dada2 3560 last->op_flags |= OPf_KIDS;
79072805
LW		 3561 return last;
3562 }
3563
3564 return newLISTOP(type, 0, first, last);
3565}
3566
3567/* Constructors */
3568
eb8433b7
NC		 3569#ifdef PERL_MAD
3570
3571TOKEN *
3572Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
3573{
3574 TOKEN *tk;
99129197 3575 Newxz(tk, 1, TOKEN);
eb8433b7
NC		 3576 tk->tk_type = (OPCODE)optype;
3577 tk->tk_type = 12345;
3578 tk->tk_lval = lval;
3579 tk->tk_mad = madprop;
3580 return tk;
3581}
3582
3583void
3584Perl_token_free(pTHX_ TOKEN* tk)
3585{
7918f24d
NC		 3586 PERL_ARGS_ASSERT_TOKEN_FREE;
3587
eb8433b7
NC		 3588 if (tk->tk_type != 12345)
3589 return;
3590 mad_free(tk->tk_mad);
3591 Safefree(tk);
3592}
3593
3594void
3595Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
3596{
3597 MADPROP* mp;
3598 MADPROP* tm;
7918f24d
NC		 3599
3600 PERL_ARGS_ASSERT_TOKEN_GETMAD;
3601
eb8433b7
NC		 3602 if (tk->tk_type != 12345) {
3603 Perl_warner(aTHX_ packWARN(WARN_MISC),
3604 "Invalid TOKEN object ignored");
3605 return;
3606 }
3607 tm = tk->tk_mad;
3608 if (!tm)
3609 return;
3610
3611 /* faked up qw list? */
3612 if (slot == '(' &&
3613 tm->mad_type == MAD_SV &&
d503a9ba 3614 SvPVX((SV *)tm->mad_val)[0] == 'q')
eb8433b7
NC		 3615 slot = 'x';
3616
3617 if (o) {
3618 mp = o->op_madprop;
3619 if (mp) {
3620 for (;;) {
3621 /* pretend constant fold didn't happen? */
3622 if (mp->mad_key == 'f' &&
3623 (o->op_type == OP_CONST ||
3624 o->op_type == OP_GV) )
3625 {
3626 token_getmad(tk,(OP*)mp->mad_val,slot);
3627 return;
3628 }
3629 if (!mp->mad_next)
3630 break;
3631 mp = mp->mad_next;
3632 }
3633 mp->mad_next = tm;
3634 mp = mp->mad_next;
3635 }
3636 else {
3637 o->op_madprop = tm;
3638 mp = o->op_madprop;
3639 }
3640 if (mp->mad_key == 'X')
3641 mp->mad_key = slot; /* just change the first one */
3642
3643 tk->tk_mad = 0;
3644 }
3645 else
3646 mad_free(tm);
3647 Safefree(tk);
3648}
3649
3650void
3651Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
3652{
3653 MADPROP* mp;
3654 if (!from)
3655 return;
3656 if (o) {
3657 mp = o->op_madprop;
3658 if (mp) {
3659 for (;;) {
3660 /* pretend constant fold didn't happen? */
3661 if (mp->mad_key == 'f' &&
3662 (o->op_type == OP_CONST ||
3663 o->op_type == OP_GV) )
3664 {
3665 op_getmad(from,(OP*)mp->mad_val,slot);
3666 return;
3667 }
3668 if (!mp->mad_next)
3669 break;
3670 mp = mp->mad_next;
3671 }
3672 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
3673 }
3674 else {
3675 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
3676 }
3677 }
3678}
3679
3680void
3681Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
3682{
3683 MADPROP* mp;
3684 if (!from)
3685 return;
3686 if (o) {
3687 mp = o->op_madprop;
3688 if (mp) {
3689 for (;;) {
3690 /* pretend constant fold didn't happen? */
3691 if (mp->mad_key == 'f' &&
3692 (o->op_type == OP_CONST ||
3693 o->op_type == OP_GV) )
3694 {
3695 op_getmad(from,(OP*)mp->mad_val,slot);
3696 return;
3697 }
3698 if (!mp->mad_next)
3699 break;
3700 mp = mp->mad_next;
3701 }
3702 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
3703 }
3704 else {
3705 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
3706 }
3707 }
3708 else {
99129197
NC		 3709 PerlIO_printf(PerlIO_stderr(),
3710 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
eb8433b7
NC		 3711 op_free(from);
3712 }
3713}
3714
3715void
3716Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
3717{
3718 MADPROP* tm;
3719 if (!mp || !o)
3720 return;
3721 if (slot)
3722 mp->mad_key = slot;
3723 tm = o->op_madprop;
3724 o->op_madprop = mp;
3725 for (;;) {
3726 if (!mp->mad_next)
3727 break;
3728 mp = mp->mad_next;
3729 }
3730 mp->mad_next = tm;
3731}
3732
3733void
3734Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
3735{
3736 if (!o)
3737 return;
3738 addmad(tm, &(o->op_madprop), slot);
3739}
3740
3741void
3742Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
3743{
3744 MADPROP* mp;
3745 if (!tm || !root)
3746 return;
3747 if (slot)
3748 tm->mad_key = slot;
3749 mp = *root;
3750 if (!mp) {
3751 *root = tm;
3752 return;
3753 }
3754 for (;;) {
3755 if (!mp->mad_next)
3756 break;
3757 mp = mp->mad_next;
3758 }
3759 mp->mad_next = tm;
3760}
3761
3762MADPROP *
3763Perl_newMADsv(pTHX_ char key, SV* sv)
3764{
7918f24d
NC		 3765 PERL_ARGS_ASSERT_NEWMADSV;
3766
eb8433b7
NC		 3767 return newMADPROP(key, MAD_SV, sv, 0);
3768}
3769
3770MADPROP *
d503a9ba 3771Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
eb8433b7 3772{
c111d5f1 3773 MADPROP *const mp = (MADPROP *) PerlMemShared_malloc(sizeof(MADPROP));
eb8433b7
NC		 3774 mp->mad_next = 0;
3775 mp->mad_key = key;
3776 mp->mad_vlen = vlen;
3777 mp->mad_type = type;
3778 mp->mad_val = val;
3779/* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
3780 return mp;
3781}
3782
3783void
3784Perl_mad_free(pTHX_ MADPROP* mp)
3785{
3786/* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
3787 if (!mp)
3788 return;
3789 if (mp->mad_next)
3790 mad_free(mp->mad_next);
bc177e6b 3791/* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
eb8433b7
NC		 3792 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
3793 switch (mp->mad_type) {
3794 case MAD_NULL:
3795 break;
3796 case MAD_PV:
04d1a275 3797 Safefree(mp->mad_val);
eb8433b7
NC		 3798 break;
3799 case MAD_OP:
3800 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
3801 op_free((OP*)mp->mad_val);
3802 break;
3803 case MAD_SV:
ad64d0ec 3804 sv_free(MUTABLE_SV(mp->mad_val));
eb8433b7
NC		 3805 break;
3806 default:
3807 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
3808 break;
3809 }
c111d5f1 3810 PerlMemShared_free(mp);
eb8433b7
NC		 3811}
3812
3813#endif
3814
d67eb5f4
Z		 3815/*
3816=head1 Optree construction
3817
3818=for apidoc Am|OP *|newNULLLIST
3819
3820Constructs, checks, and returns a new C<stub> op, which represents an
3821empty list expression.
3822
3823=cut
3824*/
3825
79072805 3826OP *
864dbfa3 3827Perl_newNULLLIST(pTHX)
79072805 3828{
8990e307
LW		 3829 return newOP(OP_STUB, 0);
3830}
3831
1f676739 3832static OP *
b7783a12 3833S_force_list(pTHX_ OP *o)
8990e307 3834{
11343788 3835 if (!o || o->op_type != OP_LIST)
5f66b61c 3836 o = newLISTOP(OP_LIST, 0, o, NULL);
93c66552 3837 op_null(o);
11343788 3838 return o;
79072805
LW		 3839}
3840
d67eb5f4
Z		 3841/*
3842=for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
3843
3844Constructs, checks, and returns an op of any list type. I<type> is
3845the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3846C<OPf_KIDS> will be set automatically if required. I<first> and I<last>
3847supply up to two ops to be direct children of the list op; they are
3848consumed by this function and become part of the constructed op tree.
3849
3850=cut
3851*/
3852
79072805 3853OP *
864dbfa3 3854Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
79072805 3855{
27da23d5 3856 dVAR;
79072805
LW		 3857 LISTOP *listop;
3858
e69777c1
GG		 3859 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
3860
b7dc083c 3861 NewOp(1101, listop, 1, LISTOP);
79072805 3862
eb160463 3863 listop->op_type = (OPCODE)type;
22c35a8c 3864 listop->op_ppaddr = PL_ppaddr[type];
117dada2
SM		 3865 if (first || last)
3866 flags |= OPf_KIDS;
eb160463 3867 listop->op_flags = (U8)flags;
79072805
LW		 3868
3869 if (!last && first)
3870 last = first;
3871 else if (!first && last)
3872 first = last;
8990e307
LW		 3873 else if (first)
3874 first->op_sibling = last;
79072805
LW		 3875 listop->op_first = first;
3876 listop->op_last = last;
8990e307 3877 if (type == OP_LIST) {
551405c4 3878 OP* const pushop = newOP(OP_PUSHMARK, 0);
8990e307
LW		 3879 pushop->op_sibling = first;
3880 listop->op_first = pushop;
3881 listop->op_flags |= OPf_KIDS;
3882 if (!last)
3883 listop->op_last = pushop;
3884 }
79072805 3885
463d09e6 3886 return CHECKOP(type, listop);
79072805
LW		 3887}
3888
d67eb5f4
Z		 3889/*
3890=for apidoc Am|OP *|newOP|I32 type|I32 flags
3891
3892Constructs, checks, and returns an op of any base type (any type that
3893has no extra fields). I<type> is the opcode. I<flags> gives the
3894eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
3895of C<op_private>.
3896
3897=cut
3898*/
3899
79072805 3900OP *
864dbfa3 3901Perl_newOP(pTHX_ I32 type, I32 flags)
79072805 3902{
27da23d5 3903 dVAR;
11343788 3904 OP *o;
e69777c1 3905
7d789282
FC		 3906 if (type == -OP_ENTEREVAL) {
3907 type = OP_ENTEREVAL;
3908 flags |= OPpEVAL_BYTES<<8;
3909 }
3910
e69777c1
GG		 3911 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
3912 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3913 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3914 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
3915
b7dc083c 3916 NewOp(1101, o, 1, OP);
eb160463 3917 o->op_type = (OPCODE)type;
22c35a8c 3918 o->op_ppaddr = PL_ppaddr[type];
eb160463 3919 o->op_flags = (U8)flags;
79072805 3920
11343788 3921 o->op_next = o;
eb160463 3922 o->op_private = (U8)(0 | (flags >> 8));
22c35a8c 3923 if (PL_opargs[type] & OA_RETSCALAR)
11343788 3924 scalar(o);
22c35a8c 3925 if (PL_opargs[type] & OA_TARGET)
11343788
MB		 3926 o->op_targ = pad_alloc(type, SVs_PADTMP);
3927 return CHECKOP(type, o);
79072805
LW		 3928}
3929
d67eb5f4
Z		 3930/*
3931=for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
3932
3933Constructs, checks, and returns an op of any unary type. I<type> is
3934the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3935C<OPf_KIDS> will be set automatically if required, and, shifted up eight
3936bits, the eight bits of C<op_private>, except that the bit with value 1
3937is automatically set. I<first> supplies an optional op to be the direct
3938child of the unary op; it is consumed by this function and become part
3939of the constructed op tree.
3940
3941=cut
3942*/
3943
79072805 3944OP *
864dbfa3 3945Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
79072805 3946{
27da23d5 3947 dVAR;
79072805
LW		 3948 UNOP *unop;
3949
7d789282
FC		 3950 if (type == -OP_ENTEREVAL) {
3951 type = OP_ENTEREVAL;
3952 flags |= OPpEVAL_BYTES<<8;
3953 }
3954
e69777c1
GG		 3955 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
3956 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3957 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3958 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
3959 || type == OP_SASSIGN
32e2a35d 3960 || type == OP_ENTERTRY
e69777c1
GG		 3961 || type == OP_NULL );
3962
93a17b20 3963 if (!first)
aeea060c 3964 first = newOP(OP_STUB, 0);
22c35a8c 3965 if (PL_opargs[type] & OA_MARK)
8990e307 3966 first = force_list(first);
93a17b20 3967
b7dc083c 3968 NewOp(1101, unop, 1, UNOP);
eb160463 3969 unop->op_type = (OPCODE)type;
22c35a8c 3970 unop->op_ppaddr = PL_ppaddr[type];
79072805 3971 unop->op_first = first;
585ec06d 3972 unop->op_flags = (U8)(flags | OPf_KIDS);
eb160463 3973 unop->op_private = (U8)(1 | (flags >> 8));
e50aee73 3974 unop = (UNOP*) CHECKOP(type, unop);
79072805
LW		 3975 if (unop->op_next)
3976 return (OP*)unop;
3977
985b9e54 3978 return fold_constants(op_integerize(op_std_init((OP *) unop)));
79072805
LW		 3979}
3980
d67eb5f4
Z		 3981/*
3982=for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
3983
3984Constructs, checks, and returns an op of any binary type. I<type>
3985is the opcode. I<flags> gives the eight bits of C<op_flags>, except
3986that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
3987the eight bits of C<op_private>, except that the bit with value 1 or
39882 is automatically set as required. I<first> and I<last> supply up to
3989two ops to be the direct children of the binary op; they are consumed
3990by this function and become part of the constructed op tree.
3991
3992=cut
3993*/
3994
79072805 3995OP *
864dbfa3 3996Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
79072805 3997{
27da23d5 3998 dVAR;
79072805 3999 BINOP *binop;
e69777c1
GG		 4000
4001 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
4002 || type == OP_SASSIGN || type == OP_NULL );
4003
b7dc083c 4004 NewOp(1101, binop, 1, BINOP);
79072805
LW		 4005
4006 if (!first)
4007 first = newOP(OP_NULL, 0);
4008
eb160463 4009 binop->op_type = (OPCODE)type;
22c35a8c 4010 binop->op_ppaddr = PL_ppaddr[type];
79072805 4011 binop->op_first = first;
585ec06d 4012 binop->op_flags = (U8)(flags | OPf_KIDS);
79072805
LW		 4013 if (!last) {
4014 last = first;
eb160463 4015 binop->op_private = (U8)(1 | (flags >> 8));
79072805
LW		 4016 }
4017 else {
eb160463 4018 binop->op_private = (U8)(2 | (flags >> 8));
79072805
LW		 4019 first->op_sibling = last;
4020 }
4021
e50aee73 4022 binop = (BINOP*)CHECKOP(type, binop);
eb160463 4023 if (binop->op_next || binop->op_type != (OPCODE)type)
79072805
LW		 4024 return (OP*)binop;
4025
7284ab6f 4026 binop->op_last = binop->op_first->op_sibling;
79072805 4027
985b9e54 4028 return fold_constants(op_integerize(op_std_init((OP *)binop)));
79072805
LW		 4029}
4030
5f66b61c
AL		 4031static int uvcompare(const void *a, const void *b)
4032 __attribute__nonnull__(1)
4033 __attribute__nonnull__(2)
4034 __attribute__pure__;
abb2c242 4035static int uvcompare(const void *a, const void *b)
2b9d42f0 4036{
e1ec3a88 4037 if (*((const UV *)a) < (*(const UV *)b))
2b9d42f0 4038 return -1;
e1ec3a88 4039 if (*((const UV *)a) > (*(const UV *)b))
2b9d42f0 4040 return 1;
e1ec3a88 4041 if (*((const UV *)a+1) < (*(const UV *)b+1))
2b9d42f0 4042 return -1;
e1ec3a88 4043 if (*((const UV *)a+1) > (*(const UV *)b+1))
2b9d42f0 4044 return 1;
a0ed51b3
LW		 4045 return 0;
4046}
4047
0d86688d
NC		 4048static OP *
4049S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
79072805 4050{
97aff369 4051 dVAR;
2d03de9c 4052 SV * const tstr = ((SVOP*)expr)->op_sv;
fbbb0949
DM		 4053 SV * const rstr =
4054#ifdef PERL_MAD
4055 (repl->op_type == OP_NULL)
4056 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
4057#endif
4058 ((SVOP*)repl)->op_sv;
463ee0b2
LW		 4059 STRLEN tlen;
4060 STRLEN rlen;
5c144d81
NC		 4061 const U8 *t = (U8*)SvPV_const(tstr, tlen);
4062 const U8 *r = (U8*)SvPV_const(rstr, rlen);
eb578fdb
KW		 4063 I32 i;
4064 I32 j;
9b877dbb 4065 I32 grows = 0;
eb578fdb 4066 short *tbl;
79072805 4067
551405c4
AL		 4068 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
4069 const I32 squash = o->op_private & OPpTRANS_SQUASH;
4070 I32 del = o->op_private & OPpTRANS_DELETE;
043e41b8 4071 SV* swash;
7918f24d
NC		 4072
4073 PERL_ARGS_ASSERT_PMTRANS;
4074
800b4dc4 4075 PL_hints |= HINT_BLOCK_SCOPE;
1c846c1f 4076
036b4402
GS		 4077 if (SvUTF8(tstr))
4078 o->op_private |= OPpTRANS_FROM_UTF;
1c846c1f
NIS		 4079
4080 if (SvUTF8(rstr))
036b4402 4081 o->op_private |= OPpTRANS_TO_UTF;
79072805 4082
a0ed51b3 4083 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
396482e1 4084 SV* const listsv = newSVpvs("# comment\n");
c445ea15 4085 SV* transv = NULL;
5c144d81
NC		 4086 const U8* tend = t + tlen;
4087 const U8* rend = r + rlen;
ba210ebe 4088 STRLEN ulen;
84c133a0
RB		 4089 UV tfirst = 1;
4090 UV tlast = 0;
4091 IV tdiff;
4092 UV rfirst = 1;
4093 UV rlast = 0;
4094 IV rdiff;
4095 IV diff;
a0ed51b3
LW		 4096 I32 none = 0;
4097 U32 max = 0;
4098 I32 bits;
a0ed51b3 4099 I32 havefinal = 0;
9c5ffd7c 4100 U32 final = 0;
551405c4
AL		 4101 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
4102 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
bf4a1e57
JH		 4103 U8* tsave = NULL;
4104 U8* rsave = NULL;
9f7f3913 4105 const U32 flags = UTF8_ALLOW_DEFAULT;
bf4a1e57
JH		 4106
4107 if (!from_utf) {
4108 STRLEN len = tlen;
5c144d81 4109 t = tsave = bytes_to_utf8(t, &len);
bf4a1e57
JH		 4110 tend = t + len;
4111 }
4112 if (!to_utf && rlen) {
4113 STRLEN len = rlen;
5c144d81 4114 r = rsave = bytes_to_utf8(r, &len);
bf4a1e57
JH		 4115 rend = r + len;
4116 }
a0ed51b3 4117
2b9d42f0
NIS		 4118/* There are several snags with this code on EBCDIC:
4119 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
4120 2. scan_const() in toke.c has encoded chars in native encoding which makes
4121 ranges at least in EBCDIC 0..255 range the bottom odd.
4122*/
4123
a0ed51b3 4124 if (complement) {
89ebb4a3 4125 U8 tmpbuf[UTF8_MAXBYTES+1];
2b9d42f0 4126 UV *cp;
a0ed51b3 4127 UV nextmin = 0;
a02a5408 4128 Newx(cp, 2*tlen, UV);
a0ed51b3 4129 i = 0;
396482e1 4130 transv = newSVpvs("");
a0ed51b3 4131 while (t < tend) {
9f7f3913 4132 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
2b9d42f0
NIS		 4133 t += ulen;
4134 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
a0ed51b3 4135 t++;
9f7f3913 4136 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
2b9d42f0 4137 t += ulen;
a0ed51b3 4138 }
2b9d42f0
NIS		 4139 else {
4140 cp[2*i+1] = cp[2*i];
4141 }
4142 i++;
a0ed51b3 4143 }
2b9d42f0 4144 qsort(cp, i, 2*sizeof(UV), uvcompare);
a0ed51b3 4145 for (j = 0; j < i; j++) {
2b9d42f0 4146 UV val = cp[2*j];
a0ed51b3
LW		 4147 diff = val - nextmin;
4148 if (diff > 0) {
9041c2e3 4149 t = uvuni_to_utf8(tmpbuf,nextmin);
dfe13c55 4150 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
a0ed51b3 4151 if (diff > 1) {
2b9d42f0 4152 U8 range_mark = UTF_TO_NATIVE(0xff);
9041c2e3 4153 t = uvuni_to_utf8(tmpbuf, val - 1);
2b9d42f0 4154 sv_catpvn(transv, (char *)&range_mark, 1);
dfe13c55 4155 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
a0ed51b3
LW		 4156 }
4157 }
2b9d42f0 4158 val = cp[2*j+1];
a0ed51b3
LW		 4159 if (val >= nextmin)
4160 nextmin = val + 1;
4161 }
9041c2e3 4162 t = uvuni_to_utf8(tmpbuf,nextmin);
dfe13c55 4163 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2b9d42f0
NIS		 4164 {
4165 U8 range_mark = UTF_TO_NATIVE(0xff);
4166 sv_catpvn(transv, (char *)&range_mark, 1);
4167 }
6247ead0 4168 t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
dfe13c55 4169 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
93524f2b 4170 t = (const U8*)SvPVX_const(transv);
a0ed51b3
LW		 4171 tlen = SvCUR(transv);
4172 tend = t + tlen;
455d824a 4173 Safefree(cp);
a0ed51b3
LW		 4174 }
4175 else if (!rlen && !del) {
4176 r = t; rlen = tlen; rend = tend;
4757a243
LW		 4177 }
4178 if (!squash) {
05d340b8 4179 if ((!rlen && !del) || t == r ||
12ae5dfc 4180 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
01ec43d0 4181 {
4757a243 4182 o->op_private |= OPpTRANS_IDENTICAL;
01ec43d0 4183 }
a0ed51b3
LW		 4184 }
4185
4186 while (t < tend || tfirst <= tlast) {
4187 /* see if we need more "t" chars */
4188 if (tfirst > tlast) {
9f7f3913 4189 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
a0ed51b3 4190 t += ulen;
2b9d42f0 4191 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
ba210ebe 4192 t++;
9f7f3913 4193 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
a0ed51b3
LW		 4194 t += ulen;
4195 }
4196 else
4197 tlast = tfirst;
4198 }
4199
4200 /* now see if we need more "r" chars */
4201 if (rfirst > rlast) {
4202 if (r < rend) {
9f7f3913 4203 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
a0ed51b3 4204 r += ulen;
2b9d42f0 4205 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
ba210ebe 4206 r++;
9f7f3913 4207 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
a0ed51b3
LW		 4208 r += ulen;
4209 }
4210 else
4211 rlast = rfirst;
4212 }
4213 else {
4214 if (!havefinal++)
4215 final = rlast;
4216 rfirst = rlast = 0xffffffff;
4217 }
4218 }
4219
4220 /* now see which range will peter our first, if either. */
4221 tdiff = tlast - tfirst;
4222 rdiff = rlast - rfirst;
4223
4224 if (tdiff <= rdiff)
4225 diff = tdiff;
4226 else
4227 diff = rdiff;
4228
4229 if (rfirst == 0xffffffff) {
4230 diff = tdiff; /* oops, pretend rdiff is infinite */
4231 if (diff > 0)
894356b3
GS		 4232 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
4233 (long)tfirst, (long)tlast);
a0ed51b3 4234 else
894356b3 4235 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
a0ed51b3
LW		 4236 }
4237 else {
4238 if (diff > 0)
894356b3
GS		 4239 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
4240 (long)tfirst, (long)(tfirst + diff),
4241 (long)rfirst);
a0ed51b3 4242 else
894356b3
GS		 4243 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
4244 (long)tfirst, (long)rfirst);
a0ed51b3
LW		 4245
4246 if (rfirst + diff > max)
4247 max = rfirst + diff;
9b877dbb 4248 if (!grows)
45005bfb
JH		 4249 grows = (tfirst < rfirst &&
4250 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
4251 rfirst += diff + 1;
a0ed51b3
LW		 4252 }
4253 tfirst += diff + 1;
4254 }
4255
4256 none = ++max;
4257 if (del)
4258 del = ++max;
4259
4260 if (max > 0xffff)
4261 bits = 32;
4262 else if (max > 0xff)
4263 bits = 16;
4264 else
4265 bits = 8;
4266
ad64d0ec 4267 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
043e41b8
DM		 4268#ifdef USE_ITHREADS
4269 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
4270 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
4271 PAD_SETSV(cPADOPo->op_padix, swash);
4272 SvPADTMP_on(swash);
a5446a64 4273 SvREADONLY_on(swash);
043e41b8
DM		 4274#else
4275 cSVOPo->op_sv = swash;
4276#endif
a0ed51b3 4277 SvREFCNT_dec(listsv);
b37c2d43 4278 SvREFCNT_dec(transv);
a0ed51b3 4279
45005bfb 4280 if (!del && havefinal && rlen)
85fbaab2 4281 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
b448e4fe 4282 newSVuv((UV)final), 0);
a0ed51b3 4283
9b877dbb 4284 if (grows)
a0ed51b3
LW		 4285 o->op_private |= OPpTRANS_GROWS;
4286
b37c2d43
AL		 4287 Safefree(tsave);
4288 Safefree(rsave);
9b877dbb 4289
eb8433b7
NC		 4290#ifdef PERL_MAD
4291 op_getmad(expr,o,'e');
4292 op_getmad(repl,o,'r');
4293#else
a0ed51b3
LW		 4294 op_free(expr);
4295 op_free(repl);
eb8433b7 4296#endif
a0ed51b3
LW		 4297 return o;
4298 }
4299
9100eeb1
Z		 4300 tbl = (short*)PerlMemShared_calloc(
4301 (o->op_private & OPpTRANS_COMPLEMENT) &&
4302 !(o->op_private & OPpTRANS_DELETE) ? 258 : 256,
4303 sizeof(short));
4304 cPVOPo->op_pv = (char*)tbl;
79072805 4305 if (complement) {
eb160463 4306 for (i = 0; i < (I32)tlen; i++)
ec49126f 4307 tbl[t[i]] = -1;
79072805
LW		 4308 for (i = 0, j = 0; i < 256; i++) {
4309 if (!tbl[i]) {
eb160463 4310 if (j >= (I32)rlen) {
a0ed51b3 4311 if (del)
79072805
LW		 4312 tbl[i] = -2;
4313 else if (rlen)
ec49126f 4314 tbl[i] = r[j-1];
79072805 4315 else
eb160463 4316 tbl[i] = (short)i;
79072805 4317 }
9b877dbb
IH		 4318 else {
4319 if (i < 128 && r[j] >= 128)
4320 grows = 1;
ec49126f 4321 tbl[i] = r[j++];
9b877dbb 4322 }
79072805
LW		 4323 }
4324 }
05d340b8
JH		 4325 if (!del) {
4326 if (!rlen) {
4327 j = rlen;
4328 if (!squash)
4329 o->op_private |= OPpTRANS_IDENTICAL;
4330 }
eb160463 4331 else if (j >= (I32)rlen)
05d340b8 4332 j = rlen - 1;
10db182f 4333 else {
aa1f7c5b
JH		 4334 tbl =
4335 (short *)
4336 PerlMemShared_realloc(tbl,
4337 (0x101+rlen-j) * sizeof(short));
10db182f
YO		 4338 cPVOPo->op_pv = (char*)tbl;
4339 }
585ec06d 4340 tbl[0x100] = (short)(rlen - j);
eb160463 4341 for (i=0; i < (I32)rlen - j; i++)
8973db79
JH		 4342 tbl[0x101+i] = r[j+i];
4343 }
79072805
LW		 4344 }
4345 else {
a0ed51b3 4346 if (!rlen && !del) {
79072805 4347 r = t; rlen = tlen;
5d06d08e 4348 if (!squash)
4757a243 4349 o->op_private |= OPpTRANS_IDENTICAL;
79072805 4350 }
94bfe852
RGS		 4351 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
4352 o->op_private |= OPpTRANS_IDENTICAL;
4353 }
79072805
LW		 4354 for (i = 0; i < 256; i++)
4355 tbl[i] = -1;
eb160463
GS		 4356 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
4357 if (j >= (I32)rlen) {
a0ed51b3 4358 if (del) {
ec49126f 4359 if (tbl[t[i]] == -1)
4360 tbl[t[i]] = -2;
79072805
LW		 4361 continue;
4362 }
4363 --j;
4364 }
9b877dbb
IH		 4365 if (tbl[t[i]] == -1) {
4366 if (t[i] < 128 && r[j] >= 128)
4367 grows = 1;
ec49126f 4368 tbl[t[i]] = r[j];
9b877dbb 4369 }
79072805
LW		 4370 }
4371 }
b08e453b 4372
a2a5de95
NC		 4373 if(del && rlen == tlen) {
4374 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
b8c388a9 4375 } else if(rlen > tlen && !complement) {
a2a5de95 4376 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
b08e453b
RB		 4377 }
4378
9b877dbb
IH		 4379 if (grows)
4380 o->op_private |= OPpTRANS_GROWS;
eb8433b7
NC		 4381#ifdef PERL_MAD
4382 op_getmad(expr,o,'e');
4383 op_getmad(repl,o,'r');
4384#else
79072805
LW		 4385 op_free(expr);
4386 op_free(repl);
eb8433b7 4387#endif
79072805 4388
11343788 4389 return o;
79072805
LW		 4390}
4391
d67eb5f4
Z		 4392/*
4393=for apidoc Am|OP *|newPMOP|I32 type|I32 flags
4394
4395Constructs, checks, and returns an op of any pattern matching type.
4396I<type> is the opcode. I<flags> gives the eight bits of C<op_flags>
4397and, shifted up eight bits, the eight bits of C<op_private>.
4398
4399=cut
4400*/
4401
79072805 4402OP *
864dbfa3 4403Perl_newPMOP(pTHX_ I32 type, I32 flags)
79072805 4404{
27da23d5 4405 dVAR;
79072805
LW		 4406 PMOP *pmop;
4407
e69777c1
GG		 4408 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
4409
b7dc083c 4410 NewOp(1101, pmop, 1, PMOP);
eb160463 4411 pmop->op_type = (OPCODE)type;
22c35a8c 4412 pmop->op_ppaddr = PL_ppaddr[type];
eb160463
GS		 4413 pmop->op_flags = (U8)flags;
4414 pmop->op_private = (U8)(0 | (flags >> 8));
79072805 4415
3280af22 4416 if (PL_hints & HINT_RE_TAINT)
c737faaf 4417 pmop->op_pmflags |= PMf_RETAINT;
82ad65bb 4418 if (IN_LOCALE_COMPILETIME) {
a62b1201 4419 set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
9de15fec 4420 }
66cbab2c
KW		 4421 else if ((! (PL_hints & HINT_BYTES))
4422 /* Both UNI_8_BIT and locale :not_characters imply Unicode */
4423 && (PL_hints & (HINT_UNI_8_BIT|HINT_LOCALE_NOT_CHARS)))
4424 {
a62b1201 4425 set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
9de15fec 4426 }
1e215989 4427 if (PL_hints & HINT_RE_FLAGS) {
20439bc7
Z		 4428 SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4429 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
1e215989
FC		 4430 );
4431 if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
20439bc7 4432 reflags = Perl_refcounted_he_fetch_pvn(aTHX_
6320bfaf 4433 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
1e215989
FC		 4434 );
4435 if (reflags && SvOK(reflags)) {
dabded94 4436 set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
1e215989
FC		 4437 }
4438 }
c737faaf 4439
36477c24 4440
debc9467 4441#ifdef USE_ITHREADS
402d2eb1
NC		 4442 assert(SvPOK(PL_regex_pad[0]));
4443 if (SvCUR(PL_regex_pad[0])) {
4444 /* Pop off the "packed" IV from the end. */
4445 SV *const repointer_list = PL_regex_pad[0];
4446 const char *p = SvEND(repointer_list) - sizeof(IV);
4447 const IV offset = *((IV*)p);
4448
4449 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
4450
4451 SvEND_set(repointer_list, p);
4452
110f3028 4453 pmop->op_pmoffset = offset;
14a49a24
NC		 4454 /* This slot should be free, so assert this: */
4455 assert(PL_regex_pad[offset] == &PL_sv_undef);
551405c4 4456 } else {
14a49a24 4457 SV * const repointer = &PL_sv_undef;
9a8b6709 4458 av_push(PL_regex_padav, repointer);
551405c4
AL		 4459 pmop->op_pmoffset = av_len(PL_regex_padav);
4460 PL_regex_pad = AvARRAY(PL_regex_padav);
13137afc 4461 }
debc9467 4462#endif
1eb1540c 4463
463d09e6 4464 return CHECKOP(type, pmop);
79072805
LW		 4465}
4466
131b3ad0
DM		 4467/* Given some sort of match op o, and an expression expr containing a
4468 * pattern, either compile expr into a regex and attach it to o (if it's
4469 * constant), or convert expr into a runtime regcomp op sequence (if it's
4470 * not)
4471 *
4472 * isreg indicates that the pattern is part of a regex construct, eg
4473 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
4474 * split "pattern", which aren't. In the former case, expr will be a list
4475 * if the pattern contains more than one term (eg /a$b/) or if it contains
4476 * a replacement, ie s/// or tr///.
d63c20f2
DM		 4477 *
4478 * When the pattern has been compiled within a new anon CV (for
4479 * qr/(?{...})/ ), then floor indicates the savestack level just before
4480 * the new sub was created
131b3ad0
DM		 4481 */
4482
79072805 4483OP *
d63c20f2 4484Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor)
79072805 4485{
27da23d5 4486 dVAR;
79072805
LW		 4487 PMOP *pm;
4488 LOGOP *rcop;
ce862d02 4489 I32 repl_has_vars = 0;
5f66b61c 4490 OP* repl = NULL;
74529a43
DM		 4491 bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
4492 bool is_compiletime;
4493 bool has_code;
131b3ad0 4494
7918f24d
NC		 4495 PERL_ARGS_ASSERT_PMRUNTIME;
4496
74529a43
DM		 4497 /* for s/// and tr///, last element in list is the replacement; pop it */
4498
4499 if (is_trans || o->op_type == OP_SUBST) {
131b3ad0
DM		 4500 OP* kid;
4501 repl = cLISTOPx(expr)->op_last;
4502 kid = cLISTOPx(expr)->op_first;
4503 while (kid->op_sibling != repl)
4504 kid = kid->op_sibling;
5f66b61c 4505 kid->op_sibling = NULL;
131b3ad0
DM		 4506 cLISTOPx(expr)->op_last = kid;
4507 }
79072805 4508
74529a43
DM		 4509 /* for TRANS, convert LIST/PUSH/CONST into CONST, and pass to pmtrans() */
4510
4511 if (is_trans) {
4512 OP* const oe = expr;
4513 assert(expr->op_type == OP_LIST);
4514 assert(cLISTOPx(expr)->op_first->op_type == OP_PUSHMARK);
4515 assert(cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last);
4516 expr = cLISTOPx(oe)->op_last;
4517 cLISTOPx(oe)->op_first->op_sibling = NULL;
4518 cLISTOPx(oe)->op_last = NULL;
4519 op_free(oe);
4520
4521 return pmtrans(o, expr, repl);
4522 }
4523
8a45afe5
DM		 4524 /* find whether we have any runtime or code elements;
4525 * at the same time, temporarily set the op_next of each DO block;
4526 * then when we LINKLIST, this will cause the DO blocks to be excluded
4527 * from the op_next chain (and from having LINKLIST recursively
4528 * applied to them). We fix up the DOs specially later */
74529a43
DM		 4529
4530 is_compiletime = 1;
4531 has_code = 0;
4532 if (expr->op_type == OP_LIST) {
4533 OP *o;
4534 for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) {
8a45afe5 4535 if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
74529a43 4536 has_code = 1;
8a45afe5
DM		 4537 assert(!o->op_next && o->op_sibling);
4538 o->op_next = o->op_sibling;
4539 }
74529a43
DM		 4540 else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
4541 is_compiletime = 0;
4542 }
4543 }
68e2671b 4544 else if (expr->op_type != OP_CONST)
74529a43 4545 is_compiletime = 0;
74529a43 4546
8a45afe5
DM		 4547 LINKLIST(expr);
4548
491453ba
DM		 4549 /* fix up DO blocks; treat each one as a separate little sub;
4550 * also, mark any arrays as LIST/REF */
74529a43 4551
68e2671b 4552 if (expr->op_type == OP_LIST) {
8a45afe5
DM		 4553 OP *o;
4554 for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) {
491453ba
DM		 4555
4556 if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) {
4557 assert( !(o->op_flags & OPf_WANT));
4558 /* push the array rather than its contents. The regex
4559 * engine will retrieve and join the elements later */
4560 o->op_flags |= (OPf_WANT_LIST | OPf_REF);
4561 continue;
4562 }
4563
8a45afe5
DM		 4564 if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
4565 continue;
4566 o->op_next = NULL; /* undo temporary hack from above */
4567 scalar(o);
4568 LINKLIST(o);
4569 if (cLISTOPo->op_first->op_type == OP_LEAVE) {
106d2451 4570 LISTOP *leaveop = cLISTOPx(cLISTOPo->op_first);
8a45afe5 4571 /* skip ENTER */
106d2451
DM		 4572 assert(leaveop->op_first->op_type == OP_ENTER);
4573 assert(leaveop->op_first->op_sibling);
4574 o->op_next = leaveop->op_first->op_sibling;
4575 /* skip leave */
4576 assert(leaveop->op_flags & OPf_KIDS);
35431808 4577 assert(leaveop->op_last->op_next == (OP*)leaveop);
106d2451
DM		 4578 leaveop->op_next = NULL; /* stop on last op */
4579 op_null((OP*)leaveop);
9da1dd8f 4580 }
8a45afe5
DM		 4581 else {
4582 /* skip SCOPE */
4583 OP *scope = cLISTOPo->op_first;
4584 assert(scope->op_type == OP_SCOPE);
4585 assert(scope->op_flags & OPf_KIDS);
4586 scope->op_next = NULL; /* stop on last op */
4587 op_null(scope);
9da1dd8f 4588 }
8a45afe5
DM		 4589 /* have to peep the DOs individually as we've removed it from
4590 * the op_next chain */
4591 CALL_PEEP(o);
4592 if (is_compiletime)
4593 /* runtime finalizes as part of finalizing whole tree */
4594 finalize_optree(o);
9da1dd8f 4595 }
9da1dd8f 4596 }
491453ba
DM		 4597 else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
4598 assert( !(expr->op_flags & OPf_WANT));
4599 /* push the array rather than its contents. The regex
4600 * engine will retrieve and join the elements later */
4601 expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
4602 }
9da1dd8f 4603
3280af22 4604 PL_hints |= HINT_BLOCK_SCOPE;
11343788 4605 pm = (PMOP*)o;
d63c20f2 4606 assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
79072805 4607
74529a43 4608 if (is_compiletime) {
514a91f1 4609 U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
3c13cae6 4610 regexp_engine const *eng = current_re_engine();
5c144d81 4611
dbc200c5
YO		 4612 if (o->op_flags & OPf_SPECIAL)
4613 rx_flags |= RXf_SPLIT;
4614
3c13cae6 4615 if (!has_code || !eng->op_comp) {
d63c20f2 4616 /* compile-time simple constant pattern */
d63c20f2
DM		 4617
4618 if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
4619 /* whoops! we guessed that a qr// had a code block, but we
4620 * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
4621 * that isn't required now. Note that we have to be pretty
4622 * confident that nothing used that CV's pad while the
4623 * regex was parsed */
4624 assert(AvFILLp(PL_comppad) == 0); /* just @_ */
8be227ab
FC		 4625 /* But we know that one op is using this CV's slab. */
4626 cv_forget_slab(PL_compcv);
d63c20f2
DM		 4627 LEAVE_SCOPE(floor);
4628 pm->op_pmflags &= ~PMf_HAS_CV;
4629 }
4630
e485beb8
DM		 4631 PM_SETRE(pm,
4632 eng->op_comp
4633 ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
4634 rx_flags, pm->op_pmflags)
4635 : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
4636 rx_flags, pm->op_pmflags)
4637 );
eb8433b7 4638#ifdef PERL_MAD
68e2671b 4639 op_getmad(expr,(OP*)pm,'e');
eb8433b7 4640#else
68e2671b 4641 op_free(expr);
eb8433b7 4642#endif
68e2671b
DM		 4643 }
4644 else {
d63c20f2 4645 /* compile-time pattern that includes literal code blocks */
3c13cae6 4646 REGEXP* re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
732caac7
DM		 4647 rx_flags,
4648 (pm->op_pmflags |
4649 ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
4650 );
d63c20f2
DM		 4651 PM_SETRE(pm, re);
4652 if (pm->op_pmflags & PMf_HAS_CV) {
4653 CV *cv;
4654 /* this QR op (and the anon sub we embed it in) is never
4655 * actually executed. It's just a placeholder where we can
4656 * squirrel away expr in op_code_list without the peephole
4657 * optimiser etc processing it for a second time */
4658 OP *qr = newPMOP(OP_QR, 0);
4659 ((PMOP*)qr)->op_code_list = expr;
4660
4661 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
4662 SvREFCNT_inc_simple_void(PL_compcv);
4663 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
8d919b0a 4664 ReANY(re)->qr_anoncv = cv;
d63c20f2
DM		 4665
4666 /* attach the anon CV to the pad so that
4667 * pad_fixup_inner_anons() can find it */
4d2dfd15 4668 (void)pad_add_anon(cv, o->op_type);
d63c20f2
DM		 4669 SvREFCNT_inc_simple_void(cv);
4670 }
4671 else {
4672 pm->op_code_list = expr;
4673 }
68e2671b 4674 }
79072805
LW		 4675 }
4676 else {
d63c20f2 4677 /* runtime pattern: build chain of regcomp etc ops */
74529a43 4678 bool reglist;
346d3070 4679 PADOFFSET cv_targ = 0;
74529a43
DM		 4680
4681 reglist = isreg && expr->op_type == OP_LIST;
4682 if (reglist)
4683 op_null(expr);
4684
867940b8
DM		 4685 if (has_code) {
4686 pm->op_code_list = expr;
4687 /* don't free op_code_list; its ops are embedded elsewhere too */
4688 pm->op_pmflags |= PMf_CODELIST_PRIVATE;
4689 }
4690
dbc200c5
YO		 4691 if (o->op_flags & OPf_SPECIAL)
4692 pm->op_pmflags |= PMf_SPLIT;
4693
7fb31b92
DM		 4694 /* the OP_REGCMAYBE is a placeholder in the non-threaded case
4695 * to allow its op_next to be pointed past the regcomp and
4696 * preceding stacking ops;
4697 * OP_REGCRESET is there to reset taint before executing the
4698 * stacking ops */
284167a5
S		 4699 if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
4700 expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
463ee0b2 4701
d63c20f2
DM		 4702 if (pm->op_pmflags & PMf_HAS_CV) {
4703 /* we have a runtime qr with literal code. This means
4704 * that the qr// has been wrapped in a new CV, which
4705 * means that runtime consts, vars etc will have been compiled
4706 * against a new pad. So... we need to execute those ops
4707 * within the environment of the new CV. So wrap them in a call
4708 * to a new anon sub. i.e. for
4709 *
4710 * qr/a$b(?{...})/,
4711 *
4712 * we build an anon sub that looks like
4713 *
4714 * sub { "a", $b, '(?{...})' }
4715 *
4716 * and call it, passing the returned list to regcomp.
4717 * Or to put it another way, the list of ops that get executed
4718 * are:
4719 *
4720 * normal PMf_HAS_CV
4721 * ------ -------------------
4722 * pushmark (for regcomp)
4723 * pushmark (for entersub)
4724 * pushmark (for refgen)
4725 * anoncode
4726 * refgen
4727 * entersub
4728 * regcreset regcreset
4729 * pushmark pushmark
4730 * const("a") const("a")
4731 * gvsv(b) gvsv(b)
4732 * const("(?{...})") const("(?{...})")
4733 * leavesub
4734 * regcomp regcomp
4735 */
4736
4737 SvREFCNT_inc_simple_void(PL_compcv);
346d3070
DM		 4738 /* these lines are just an unrolled newANONATTRSUB */
4739 expr = newSVOP(OP_ANONCODE, 0,
4740 MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
4741 cv_targ = expr->op_targ;
4742 expr = newUNOP(OP_REFGEN, 0, expr);
4743
4744 expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr))));
d63c20f2
DM		 4745 }
4746
b7dc083c 4747 NewOp(1101, rcop, 1, LOGOP);
79072805 4748 rcop->op_type = OP_REGCOMP;
22c35a8c 4749 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
79072805 4750 rcop->op_first = scalar(expr);
131b3ad0
DM		 4751 rcop->op_flags |= OPf_KIDS
4752 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
4753 | (reglist ? OPf_STACKED : 0);
188c1910 4754 rcop->op_private = 0;
11343788 4755 rcop->op_other = o;
346d3070 4756 rcop->op_targ = cv_targ;
131b3ad0 4757
b5c19bd7 4758 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
ec192197 4759 if (PL_hints & HINT_RE_EVAL) PL_cv_has_eval = 1;
79072805
LW		 4760
4761 /* establish postfix order */
d63c20f2 4762 if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
463ee0b2
LW		 4763 LINKLIST(expr);
4764 rcop->op_next = expr;
4765 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
4766 }
4767 else {
4768 rcop->op_next = LINKLIST(expr);
4769 expr->op_next = (OP*)rcop;
4770 }
79072805 4771
2fcb4757 4772 op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
79072805
LW		 4773 }
4774
4775 if (repl) {
ef90d20a 4776 OP *curop = repl;
bb933b9b 4777 bool konst;
0244c3a4 4778 if (pm->op_pmflags & PMf_EVAL) {
670a9cb2
DM		 4779 if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
4780 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
0244c3a4 4781 }
ef90d20a
FC		 4782 /* If we are looking at s//.../e with a single statement, get past
4783 the implicit do{}. */
4784 if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
4785 && cUNOPx(curop)->op_first->op_type == OP_SCOPE
4786 && cUNOPx(curop)->op_first->op_flags & OPf_KIDS) {
4787 OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
4788 if (kid->op_type == OP_NULL && kid->op_sibling
4789 && !kid->op_sibling->op_sibling)
4790 curop = kid->op_sibling;
4791 }
4792 if (curop->op_type == OP_CONST)
bb933b9b 4793 konst = TRUE;
ef90d20a
FC		 4794 else if (( (curop->op_type == OP_RV2SV ||
4795 curop->op_type == OP_RV2AV ||
4796 curop->op_type == OP_RV2HV ||
4797 curop->op_type == OP_RV2GV)
4798 && cUNOPx(curop)->op_first
4799 && cUNOPx(curop)->op_first->op_type == OP_GV )
4800 || curop->op_type == OP_PADSV
4801 || curop->op_type == OP_PADAV
4802 || curop->op_type == OP_PADHV
4803 || curop->op_type == OP_PADANY) {
bb933b9b
FC		 4804 repl_has_vars = 1;
4805 konst = TRUE;
748a9306 4806 }
bb933b9b
FC		 4807 else konst = FALSE;
4808 if (konst
e80b829c
RGS		 4809 && !(repl_has_vars
4810 && (!PM_GETRE(pm)
b97b7b69 4811 || !RX_PRELEN(PM_GETRE(pm))
07bc277f 4812 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
3be69782 4813 {
748a9306 4814 pm->op_pmflags |= PMf_CONST; /* const for long enough */
2fcb4757 4815 op_prepend_elem(o->op_type, scalar(repl), o);
748a9306
LW		 4816 }
4817 else {
b7dc083c 4818 NewOp(1101, rcop, 1, LOGOP);
748a9306 4819 rcop->op_type = OP_SUBSTCONT;
22c35a8c 4820 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
748a9306
LW		 4821 rcop->op_first = scalar(repl);
4822 rcop->op_flags |= OPf_KIDS;
4823 rcop->op_private = 1;
11343788 4824 rcop->op_other = o;
748a9306
LW		 4825
4826 /* establish postfix order */
4827 rcop->op_next = LINKLIST(repl);
4828 repl->op_next = (OP*)rcop;
4829
20e98b0f 4830 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
29f2e912
NC		 4831 assert(!(pm->op_pmflags & PMf_ONCE));
4832 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
748a9306 4833 rcop->op_next = 0;
79072805
LW		 4834 }
4835 }
4836
4837 return (OP*)pm;
4838}
4839
d67eb5f4
Z		 4840/*
4841=for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
4842
4843Constructs, checks, and returns an op of any type that involves an
4844embedded SV. I<type> is the opcode. I<flags> gives the eight bits
4845of C<op_flags>. I<sv> gives the SV to embed in the op; this function
4846takes ownership of one reference to it.
4847
4848=cut
4849*/
4850
79072805 4851OP *
864dbfa3 4852Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
79072805 4853{
27da23d5 4854 dVAR;
79072805 4855 SVOP *svop;
7918f24d
NC		 4856
4857 PERL_ARGS_ASSERT_NEWSVOP;
4858
e69777c1
GG		 4859 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4860 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4861 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4862
b7dc083c 4863 NewOp(1101, svop, 1, SVOP);
eb160463 4864 svop->op_type = (OPCODE)type;
22c35a8c 4865 svop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 4866 svop->op_sv = sv;
4867 svop->op_next = (OP*)svop;
eb160463 4868 svop->op_flags = (U8)flags;
cc2ebcd7 4869 svop->op_private = (U8)(0 | (flags >> 8));
22c35a8c 4870 if (PL_opargs[type] & OA_RETSCALAR)
463ee0b2 4871 scalar((OP*)svop);
22c35a8c 4872 if (PL_opargs[type] & OA_TARGET)
ed6116ce 4873 svop->op_targ = pad_alloc(type, SVs_PADTMP);
e50aee73 4874 return CHECKOP(type, svop);
79072805
LW		 4875}
4876
392d04bb 4877#ifdef USE_ITHREADS
d67eb5f4
Z		 4878
4879/*
4880=for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
4881
4882Constructs, checks, and returns an op of any type that involves a
4883reference to a pad element. I<type> is the opcode. I<flags> gives the
4884eight bits of C<op_flags>. A pad slot is automatically allocated, and
4885is populated with I<sv>; this function takes ownership of one reference
4886to it.
4887
4888This function only exists if Perl has been compiled to use ithreads.
4889
4890=cut
4891*/
4892
79072805 4893OP *
350de78d
GS		 4894Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
4895{
27da23d5 4896 dVAR;
350de78d 4897 PADOP *padop;
7918f24d
NC		 4898
4899 PERL_ARGS_ASSERT_NEWPADOP;
4900
e69777c1
GG		 4901 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4902 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4903 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4904
350de78d 4905 NewOp(1101, padop, 1, PADOP);
eb160463 4906 padop->op_type = (OPCODE)type;
350de78d
GS		 4907 padop->op_ppaddr = PL_ppaddr[type];
4908 padop->op_padix = pad_alloc(type, SVs_PADTMP);
dd2155a4
DM		 4909 SvREFCNT_dec(PAD_SVl(padop->op_padix));
4910 PAD_SETSV(padop->op_padix, sv);
58182927
NC		 4911 assert(sv);
4912 SvPADTMP_on(sv);
350de78d 4913 padop->op_next = (OP*)padop;
eb160463 4914 padop->op_flags = (U8)flags;
350de78d
GS		 4915 if (PL_opargs[type] & OA_RETSCALAR)
4916 scalar((OP*)padop);
4917 if (PL_opargs[type] & OA_TARGET)
4918 padop->op_targ = pad_alloc(type, SVs_PADTMP);
4919 return CHECKOP(type, padop);
4920}
d67eb5f4
Z		 4921
4922#endif /* !USE_ITHREADS */
4923
4924/*
4925=for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
4926
4927Constructs, checks, and returns an op of any type that involves an
4928embedded reference to a GV. I<type> is the opcode. I<flags> gives the
4929eight bits of C<op_flags>. I<gv> identifies the GV that the op should
4930reference; calling this function does not transfer ownership of any
4931reference to it.
4932
4933=cut
4934*/
350de78d
GS		 4935
4936OP *
864dbfa3 4937Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
79072805 4938{
27da23d5 4939 dVAR;
7918f24d
NC		 4940
4941 PERL_ARGS_ASSERT_NEWGVOP;
4942
350de78d 4943#ifdef USE_ITHREADS
58182927 4944 GvIN_PAD_on(gv);
ff8997d7 4945 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
350de78d 4946#else
ff8997d7 4947 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
350de78d 4948#endif
79072805
LW		 4949}
4950
d67eb5f4
Z		 4951/*
4952=for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
4953
4954Constructs, checks, and returns an op of any type that involves an
4955embedded C-level pointer (PV). I<type> is the opcode. I<flags> gives
4956the eight bits of C<op_flags>. I<pv> supplies the C-level pointer, which
3d6c5fec 4957must have been allocated using C<PerlMemShared_malloc>; the memory will
d67eb5f4
Z		 4958be freed when the op is destroyed.
4959
4960=cut
4961*/
4962
79072805 4963OP *
864dbfa3 4964Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
79072805 4965{
27da23d5 4966 dVAR;
5db1eb8d 4967 const bool utf8 = cBOOL(flags & SVf_UTF8);
79072805 4968 PVOP *pvop;
e69777c1 4969
5db1eb8d
BF		 4970 flags &= ~SVf_UTF8;
4971
e69777c1 4972 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
1a35f9ff 4973 || type == OP_RUNCV
e69777c1
GG		 4974 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4975
b7dc083c 4976 NewOp(1101, pvop, 1, PVOP);
eb160463 4977 pvop->op_type = (OPCODE)type;
22c35a8c 4978 pvop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 4979 pvop->op_pv = pv;
4980 pvop->op_next = (OP*)pvop;
eb160463 4981 pvop->op_flags = (U8)flags;
5db1eb8d 4982 pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
22c35a8c 4983 if (PL_opargs[type] & OA_RETSCALAR)
463ee0b2 4984 scalar((OP*)pvop);
22c35a8c 4985 if (PL_opargs[type] & OA_TARGET)
ed6116ce 4986 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
e50aee73 4987 return CHECKOP(type, pvop);
79072805
LW		 4988}
4989
eb8433b7
NC		 4990#ifdef PERL_MAD
4991OP*
4992#else
79072805 4993void
eb8433b7 4994#endif
864dbfa3 4995Perl_package(pTHX_ OP *o)
79072805 4996{
97aff369 4997 dVAR;
bf070237 4998 SV *const sv = cSVOPo->op_sv;
eb8433b7
NC		 4999#ifdef PERL_MAD
5000 OP *pegop;
5001#endif
79072805 5002
7918f24d
NC		 5003 PERL_ARGS_ASSERT_PACKAGE;
5004
03d9f026 5005 SAVEGENERICSV(PL_curstash);
3280af22 5006 save_item(PL_curstname);
de11ba31 5007
03d9f026 5008 PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
e1a479c5 5009
bf070237 5010 sv_setsv(PL_curstname, sv);
de11ba31 5011
7ad382f4 5012 PL_hints |= HINT_BLOCK_SCOPE;
53a7735b
DM		 5013 PL_parser->copline = NOLINE;
5014 PL_parser->expect = XSTATE;
eb8433b7
NC		 5015
5016#ifndef PERL_MAD
5017 op_free(o);
5018#else
5019 if (!PL_madskills) {
5020 op_free(o);
1d866c12 5021 return NULL;
eb8433b7
NC		 5022 }
5023
5024 pegop = newOP(OP_NULL,0);
5025 op_getmad(o,pegop,'P');
5026 return pegop;
5027#endif
79072805
LW		 5028}
5029
6fa4d285
DG		 5030void
5031Perl_package_version( pTHX_ OP *v )
5032{
5033 dVAR;
458818ec 5034 U32 savehints = PL_hints;
6fa4d285 5035 PERL_ARGS_ASSERT_PACKAGE_VERSION;
458818ec 5036 PL_hints &= ~HINT_STRICT_VARS;
e92f586b 5037 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
458818ec 5038 PL_hints = savehints;
6fa4d285
DG		 5039 op_free(v);
5040}
5041
eb8433b7
NC		 5042#ifdef PERL_MAD
5043OP*
5044#else
85e6fe83 5045void
eb8433b7 5046#endif
88d95a4d 5047Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
85e6fe83 5048{
97aff369 5049 dVAR;
a0d0e21e 5050 OP *pack;
a0d0e21e 5051 OP *imop;
b1cb66bf 5052 OP *veop;
eb8433b7 5053#ifdef PERL_MAD
d8842ae9 5054 OP *pegop = PL_madskills ? newOP(OP_NULL,0) : NULL;
eb8433b7 5055#endif
88e9444c 5056 SV *use_version = NULL;
85e6fe83 5057
7918f24d
NC		 5058 PERL_ARGS_ASSERT_UTILIZE;
5059
88d95a4d 5060 if (idop->op_type != OP_CONST)
cea2e8a9 5061 Perl_croak(aTHX_ "Module name must be constant");
85e6fe83 5062
eb8433b7
NC		 5063 if (PL_madskills)
5064 op_getmad(idop,pegop,'U');
5065
5f66b61c 5066 veop = NULL;
b1cb66bf 5067
aec46f14 5068 if (version) {
551405c4 5069 SV * const vesv = ((SVOP*)version)->op_sv;
b1cb66bf 5070
eb8433b7
NC		 5071 if (PL_madskills)
5072 op_getmad(version,pegop,'V');
aec46f14 5073 if (!arg && !SvNIOKp(vesv)) {
b1cb66bf 5074 arg = version;
5075 }
5076 else {
5077 OP *pack;
0f79a09d 5078 SV *meth;
b1cb66bf 5079
44dcb63b 5080 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
fe13d51d 5081 Perl_croak(aTHX_ "Version number must be a constant number");
b1cb66bf 5082
88d95a4d
JH		 5083 /* Make copy of idop so we don't free it twice */
5084 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
b1cb66bf 5085
5086 /* Fake up a method call to VERSION */
18916d0d 5087 meth = newSVpvs_share("VERSION");
b1cb66bf 5088 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2fcb4757
Z		 5089 op_append_elem(OP_LIST,
5090 op_prepend_elem(OP_LIST, pack, list(version)),
0f79a09d 5091 newSVOP(OP_METHOD_NAMED, 0, meth)));
b1cb66bf 5092 }
5093 }
aeea060c 5094
a0d0e21e 5095 /* Fake up an import/unimport */
eb8433b7
NC		 5096 if (arg && arg->op_type == OP_STUB) {
5097 if (PL_madskills)
5098 op_getmad(arg,pegop,'S');
4633a7c4 5099 imop = arg; /* no import on explicit () */
eb8433b7 5100 }
88d95a4d 5101 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
5f66b61c 5102 imop = NULL; /* use 5.0; */
88e9444c
NC		 5103 if (aver)
5104 use_version = ((SVOP*)idop)->op_sv;
5105 else
468aa647 5106 idop->op_private |= OPpCONST_NOVER;
b1cb66bf 5107 }
4633a7c4 5108 else {
0f79a09d
GS		 5109 SV *meth;
5110
eb8433b7
NC		 5111 if (PL_madskills)
5112 op_getmad(arg,pegop,'A');
5113
88d95a4d
JH		 5114 /* Make copy of idop so we don't free it twice */
5115 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
0f79a09d
GS		 5116
5117 /* Fake up a method call to import/unimport */
427d62a4 5118 meth = aver
18916d0d 5119 ? newSVpvs_share("import") : newSVpvs_share("unimport");
4633a7c4 5120 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2fcb4757
Z		 5121 op_append_elem(OP_LIST,
5122 op_prepend_elem(OP_LIST, pack, list(arg)),
0f79a09d 5123 newSVOP(OP_METHOD_NAMED, 0, meth)));
4633a7c4
LW		 5124 }
5125
a0d0e21e 5126 /* Fake up the BEGIN {}, which does its thing immediately. */
09bef843 5127 newATTRSUB(floor,
18916d0d 5128 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
5f66b61c
AL		 5129 NULL,
5130 NULL,
2fcb4757
Z		 5131 op_append_elem(OP_LINESEQ,
5132 op_append_elem(OP_LINESEQ,
bd61b366
SS		 5133 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
5134 newSTATEOP(0, NULL, veop)),
5135 newSTATEOP(0, NULL, imop) ));
85e6fe83 5136
88e9444c 5137 if (use_version) {
6634bb9d 5138 /* Enable the
88e9444c
NC		 5139 * feature bundle that corresponds to the required version. */
5140 use_version = sv_2mortal(new_version(use_version));
6634bb9d 5141 S_enable_feature_bundle(aTHX_ use_version);
88e9444c 5142
88e9444c
NC		 5143 /* If a version >= 5.11.0 is requested, strictures are on by default! */
5144 if (vcmp(use_version,
5145 sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
d1718a7c 5146 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
b50b2058 5147 PL_hints |= HINT_STRICT_REFS;
d1718a7c 5148 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
b50b2058 5149 PL_hints |= HINT_STRICT_SUBS;
d1718a7c 5150 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
b50b2058
FC		 5151 PL_hints |= HINT_STRICT_VARS;
5152 }
5153 /* otherwise they are off */
5154 else {
d1718a7c 5155 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
b50b2058 5156 PL_hints &= ~HINT_STRICT_REFS;
d1718a7c 5157 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
b50b2058 5158 PL_hints &= ~HINT_STRICT_SUBS;
d1718a7c 5159 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
b50b2058 5160 PL_hints &= ~HINT_STRICT_VARS;
88e9444c
NC		 5161 }
5162 }
5163
70f5e4ed
JH		 5164 /* The "did you use incorrect case?" warning used to be here.
5165 * The problem is that on case-insensitive filesystems one
5166 * might get false positives for "use" (and "require"):
5167 * "use Strict" or "require CARP" will work. This causes
5168 * portability problems for the script: in case-strict
5169 * filesystems the script will stop working.
5170 *
5171 * The "incorrect case" warning checked whether "use Foo"
5172 * imported "Foo" to your namespace, but that is wrong, too:
5173 * there is no requirement nor promise in the language that
5174 * a Foo.pm should or would contain anything in package "Foo".
5175 *
5176 * There is very little Configure-wise that can be done, either:
5177 * the case-sensitivity of the build filesystem of Perl does not
5178 * help in guessing the case-sensitivity of the runtime environment.
5179 */
18fc9488 5180
c305c6a0 5181 PL_hints |= HINT_BLOCK_SCOPE;
53a7735b
DM		 5182 PL_parser->copline = NOLINE;
5183 PL_parser->expect = XSTATE;
8ec8fbef 5184 PL_cop_seqmax++; /* Purely for B::*'s benefit */
6012dc80
DM		 5185 if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
5186 PL_cop_seqmax++;
eb8433b7
NC		 5187
5188#ifdef PERL_MAD
eb8433b7
NC		 5189 return pegop;
5190#endif
85e6fe83
LW		 5191}
5192
7d3fb230 5193/*
ccfc67b7
JH		 5194=head1 Embedding Functions
5195
7d3fb230
BS		 5196=for apidoc load_module
5197
5198Loads the module whose name is pointed to by the string part of name.
5199Note that the actual module name, not its filename, should be given.
5200Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
5201PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
d9f23c72 5202(or 0 for no flags). ver, if specified and not NULL, provides version semantics
7d3fb230
BS		 5203similar to C<use Foo::Bar VERSION>. The optional trailing SV*
5204arguments can be used to specify arguments to the module's import()
76f108ac
JD		 5205method, similar to C<use Foo::Bar VERSION LIST>. They must be
5206terminated with a final NULL pointer. Note that this list can only
5207be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
5208Otherwise at least a single NULL pointer to designate the default
5209import list is required.
7d3fb230 5210
d9f23c72
KW		 5211The reference count for each specified C<SV*> parameter is decremented.
5212
7d3fb230
BS		 5213=cut */
5214
e4783991
GS		 5215void
5216Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
5217{
5218 va_list args;
7918f24d
NC		 5219
5220 PERL_ARGS_ASSERT_LOAD_MODULE;
5221
e4783991
GS		 5222 va_start(args, ver);
5223 vload_module(flags, name, ver, &args);
5224 va_end(args);
5225}
5226
5227#ifdef PERL_IMPLICIT_CONTEXT
5228void
5229Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
5230{
5231 dTHX;
5232 va_list args;
7918f24d 5233 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
e4783991
GS		 5234 va_start(args, ver);
5235 vload_module(flags, name, ver, &args);
5236 va_end(args);
5237}
5238#endif
5239
5240void
5241Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
5242{
97aff369 5243 dVAR;
551405c4 5244 OP *veop, *imop;
551405c4 5245 OP * const modname = newSVOP(OP_CONST, 0, name);
7918f24d
NC		 5246
5247 PERL_ARGS_ASSERT_VLOAD_MODULE;
5248
e4783991
GS		 5249 modname->op_private |= OPpCONST_BARE;
5250 if (ver) {
5251 veop = newSVOP(OP_CONST, 0, ver);
5252 }
5253 else
5f66b61c 5254 veop = NULL;
e4783991
GS		 5255 if (flags & PERL_LOADMOD_NOIMPORT) {
5256 imop = sawparens(newNULLLIST());
5257 }
5258 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
5259 imop = va_arg(*args, OP*);
5260 }
5261 else {
5262 SV *sv;
5f66b61c 5263 imop = NULL;
e4783991
GS		 5264 sv = va_arg(*args, SV*);
5265 while (sv) {
2fcb4757 5266 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
e4783991
GS		 5267 sv = va_arg(*args, SV*);
5268 }
5269 }
81885997 5270
53a7735b
DM		 5271 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
5272 * that it has a PL_parser to play with while doing that, and also
5273 * that it doesn't mess with any existing parser, by creating a tmp
5274 * new parser with lex_start(). This won't actually be used for much,
5275 * since pp_require() will create another parser for the real work. */
5276
5277 ENTER;
5278 SAVEVPTR(PL_curcop);
27fcb6ee 5279 lex_start(NULL, NULL, LEX_START_SAME_FILTER);
53a7735b
DM		 5280 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
5281 veop, modname, imop);
5282 LEAVE;
e4783991
GS		 5283}
5284
79072805 5285OP *
850e8516 5286Perl_dofile(pTHX_ OP *term, I32 force_builtin)
78ca652e 5287{
97aff369 5288 dVAR;
78ca652e 5289 OP *doop;
a0714e2c 5290 GV *gv = NULL;
78ca652e 5291
7918f24d
NC		 5292 PERL_ARGS_ASSERT_DOFILE;
5293
850e8516 5294 if (!force_builtin) {
fafc274c 5295 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
850e8516 5296 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
a4fc7abc 5297 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
a0714e2c 5298 gv = gvp ? *gvp : NULL;
850e8516
RGS		 5299 }
5300 }
78ca652e 5301
b9f751c0 5302 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
213aa87d 5303 doop = newUNOP(OP_ENTERSUB, OPf_STACKED,
2fcb4757 5304 op_append_elem(OP_LIST, term,
78ca652e 5305 scalar(newUNOP(OP_RV2CV, 0,
213aa87d 5306 newGVOP(OP_GV, 0, gv)))));
78ca652e
GS		 5307 }
5308 else {
5309 doop = newUNOP(OP_DOFILE, 0, scalar(term));
5310 }
5311 return doop;
5312}
5313
d67eb5f4
Z		 5314/*
5315=head1 Optree construction
5316
5317=for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
5318
5319Constructs, checks, and returns an C<lslice> (list slice) op. I<flags>
5320gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
5321be set automatically, and, shifted up eight bits, the eight bits of
5322C<op_private>, except that the bit with value 1 or 2 is automatically
5323set as required. I<listval> and I<subscript> supply the parameters of
5324the slice; they are consumed by this function and become part of the
5325constructed op tree.
5326
5327=cut
5328*/
5329
78ca652e 5330OP *
864dbfa3 5331Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
79072805
LW		 5332{
5333 return newBINOP(OP_LSLICE, flags,
8990e307
LW		 5334 list(force_list(subscript)),
5335 list(force_list(listval)) );
79072805
LW		 5336}
5337
76e3520e 5338STATIC I32
5aaab254 5339S_is_list_assignment(pTHX_ const OP *o)
79072805 5340{
1496a290
AL		 5341 unsigned type;
5342 U8 flags;
5343
11343788 5344 if (!o)
79072805
LW		 5345 return TRUE;
5346
1496a290 5347 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
11343788 5348 o = cUNOPo->op_first;
79072805 5349
1496a290
AL		 5350 flags = o->op_flags;
5351 type = o->op_type;
5352 if (type == OP_COND_EXPR) {
504618e9
AL		 5353 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
5354 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
79072805
LW		 5355
5356 if (t && f)
5357 return TRUE;
5358 if (t || f)
5359 yyerror("Assignment to both a list and a scalar");
5360 return FALSE;
5361 }
5362
1496a290
AL		 5363 if (type == OP_LIST &&
5364 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
95f0a2f1
SB		 5365 o->op_private & OPpLVAL_INTRO)
5366 return FALSE;
5367
1496a290
AL		 5368 if (type == OP_LIST || flags & OPf_PARENS ||
5369 type == OP_RV2AV || type == OP_RV2HV ||
5370 type == OP_ASLICE || type == OP_HSLICE)
79072805
LW		 5371 return TRUE;
5372
1496a290 5373 if (type == OP_PADAV || type == OP_PADHV)
93a17b20
LW		 5374 return TRUE;
5375
1496a290 5376 if (type == OP_RV2SV)
79072805
LW		 5377 return FALSE;
5378
5379 return FALSE;
5380}
5381
d67eb5f4 5382/*
83f9fced
GG		 5383 Helper function for newASSIGNOP to detection commonality between the
5384 lhs and the rhs. Marks all variables with PL_generation. If it
5385 returns TRUE the assignment must be able to handle common variables.
5386*/
5387PERL_STATIC_INLINE bool
5388S_aassign_common_vars(pTHX_ OP* o)
5389{
83f9fced 5390 OP *curop;
3023b5f3 5391 for (curop = cUNOPo->op_first; curop; curop=curop->op_sibling) {
83f9fced
GG		 5392 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
5393 if (curop->op_type == OP_GV) {
5394 GV *gv = cGVOPx_gv(curop);
5395 if (gv == PL_defgv
5396 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
5397 return TRUE;
5398 GvASSIGN_GENERATION_set(gv, PL_generation);
5399 }
5400 else if (curop->op_type == OP_PADSV ||
5401 curop->op_type == OP_PADAV ||
5402 curop->op_type == OP_PADHV ||
5403 curop->op_type == OP_PADANY)
5404 {
5405 if (PAD_COMPNAME_GEN(curop->op_targ)
5406 == (STRLEN)PL_generation)
5407 return TRUE;
5408 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
5409
5410 }
5411 else if (curop->op_type == OP_RV2CV)
5412 return TRUE;
5413 else if (curop->op_type == OP_RV2SV ||
5414 curop->op_type == OP_RV2AV ||
5415 curop->op_type == OP_RV2HV ||
5416 curop->op_type == OP_RV2GV) {
3023b5f3 5417 if (cUNOPx(curop)->op_first->op_type != OP_GV) /* funny deref? */
83f9fced
GG		 5418 return TRUE;
5419 }
5420 else if (curop->op_type == OP_PUSHRE) {
5421#ifdef USE_ITHREADS
5422 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
5423 GV *const gv = MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff));
5424 if (gv == PL_defgv
5425 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
5426 return TRUE;
5427 GvASSIGN_GENERATION_set(gv, PL_generation);
5428 }
5429#else
5430 GV *const gv
5431 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
5432 if (gv) {
5433 if (gv == PL_defgv
5434 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
5435 return TRUE;
5436 GvASSIGN_GENERATION_set(gv, PL_generation);
5437 }
5438#endif
5439 }
5440 else
5441 return TRUE;
5442 }
3023b5f3
GG		 5443
5444 if (curop->op_flags & OPf_KIDS) {
5445 if (aassign_common_vars(curop))
5446 return TRUE;
5447 }
83f9fced
GG		 5448 }
5449 return FALSE;
5450}
5451
5452/*
d67eb5f4
Z		 5453=for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
5454
5455Constructs, checks, and returns an assignment op. I<left> and I<right>
5456supply the parameters of the assignment; they are consumed by this
5457function and become part of the constructed op tree.
5458
5459If I<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
5460a suitable conditional optree is constructed. If I<optype> is the opcode
5461of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
5462performs the binary operation and assigns the result to the left argument.
5463Either way, if I<optype> is non-zero then I<flags> has no effect.
5464
5465If I<optype> is zero, then a plain scalar or list assignment is
5466constructed. Which type of assignment it is is automatically determined.
5467I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
5468will be set automatically, and, shifted up eight bits, the eight bits
5469of C<op_private>, except that the bit with value 1 or 2 is automatically
5470set as required.
5471
5472=cut
5473*/
5474
79072805 5475OP *
864dbfa3 5476Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
79072805 5477{
97aff369 5478 dVAR;
11343788 5479 OP *o;
79072805 5480
a0d0e21e 5481 if (optype) {
c963b151 5482 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
a0d0e21e 5483 return newLOGOP(optype, 0,
3ad73efd 5484 op_lvalue(scalar(left), optype),
a0d0e21e
LW		 5485 newUNOP(OP_SASSIGN, 0, scalar(right)));
5486 }
5487 else {
5488 return newBINOP(optype, OPf_STACKED,
3ad73efd 5489 op_lvalue(scalar(left), optype), scalar(right));
a0d0e21e
LW		 5490 }
5491 }
5492
504618e9 5493 if (is_list_assignment(left)) {
6dbe9451
NC		 5494 static const char no_list_state[] = "Initialization of state variables"
5495 " in list context currently forbidden";
10c8fecd 5496 OP *curop;
fafafbaf 5497 bool maybe_common_vars = TRUE;
10c8fecd 5498
3280af22 5499 PL_modcount = 0;
3ad73efd 5500 left = op_lvalue(left, OP_AASSIGN);
10c8fecd
GS		 5501 curop = list(force_list(left));
5502 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
eb160463 5503 o->op_private = (U8)(0 | (flags >> 8));
dd2155a4 5504
fafafbaf
RD		 5505 if ((left->op_type == OP_LIST
5506 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
5507 {
5508 OP* lop = ((LISTOP*)left)->op_first;
5509 maybe_common_vars = FALSE;
5510 while (lop) {
5511 if (lop->op_type == OP_PADSV ||
5512 lop->op_type == OP_PADAV ||
5513 lop->op_type == OP_PADHV ||
5514 lop->op_type == OP_PADANY) {
5515 if (!(lop->op_private & OPpLVAL_INTRO))
5516 maybe_common_vars = TRUE;
5517
5518 if (lop->op_private & OPpPAD_STATE) {
5519 if (left->op_private & OPpLVAL_INTRO) {
5520 /* Each variable in state($a, $b, $c) = ... */
5521 }
5522 else {
5523 /* Each state variable in
5524 (state $a, my $b, our $c, $d, undef) = ... */
5525 }
5526 yyerror(no_list_state);
5527 } else {
5528 /* Each my variable in
5529 (state $a, my $b, our $c, $d, undef) = ... */
5530 }
5531 } else if (lop->op_type == OP_UNDEF ||
5532 lop->op_type == OP_PUSHMARK) {
5533 /* undef may be interesting in
5534 (state $a, undef, state $c) */
5535 } else {
5536 /* Other ops in the list. */
5537 maybe_common_vars = TRUE;
5538 }
5539 lop = lop->op_sibling;
5540 }
5541 }
5542 else if ((left->op_private & OPpLVAL_INTRO)
5543 && ( left->op_type == OP_PADSV
5544 || left->op_type == OP_PADAV
5545 || left->op_type == OP_PADHV
5546 || left->op_type == OP_PADANY))
5547 {
0f907b96 5548 if (left->op_type == OP_PADSV) maybe_common_vars = FALSE;
fafafbaf
RD		 5549 if (left->op_private & OPpPAD_STATE) {
5550 /* All single variable list context state assignments, hence
5551 state ($a) = ...
5552 (state $a) = ...
5553 state @a = ...
5554 state (@a) = ...
5555 (state @a) = ...
5556 state %a = ...
5557 state (%a) = ...
5558 (state %a) = ...
5559 */
5560 yyerror(no_list_state);
5561 }
5562 }
5563
dd2155a4
DM		 5564 /* PL_generation sorcery:
5565 * an assignment like ($a,$b) = ($c,$d) is easier than
5566 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
5567 * To detect whether there are common vars, the global var
5568 * PL_generation is incremented for each assign op we compile.
5569 * Then, while compiling the assign op, we run through all the
5570 * variables on both sides of the assignment, setting a spare slot
5571 * in each of them to PL_generation. If any of them already have
5572 * that value, we know we've got commonality. We could use a
5573 * single bit marker, but then we'd have to make 2 passes, first
5574 * to clear the flag, then to test and set it. To find somewhere
931b58fb 5575 * to store these values, evil chicanery is done with SvUVX().
dd2155a4
DM		 5576 */
5577
fafafbaf 5578 if (maybe_common_vars) {
3280af22 5579 PL_generation++;
83f9fced 5580 if (aassign_common_vars(o))
10c8fecd 5581 o->op_private |= OPpASSIGN_COMMON;
3023b5f3 5582 LINKLIST(o);
461824dc 5583 }
9fdc7570 5584
e9cc17ba 5585 if (right && right->op_type == OP_SPLIT && !PL_madskills) {
1496a290
AL		 5586 OP* tmpop = ((LISTOP*)right)->op_first;
5587 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
551405c4 5588 PMOP * const pm = (PMOP*)tmpop;
c07a80fd 5589 if (left->op_type == OP_RV2AV &&
5590 !(left->op_private & OPpLVAL_INTRO) &&
11343788 5591 !(o->op_private & OPpASSIGN_COMMON) )
c07a80fd 5592 {
5593 tmpop = ((UNOP*)left)->op_first;
20e98b0f
NC		 5594 if (tmpop->op_type == OP_GV
5595#ifdef USE_ITHREADS
5596 && !pm->op_pmreplrootu.op_pmtargetoff
5597#else
5598 && !pm->op_pmreplrootu.op_pmtargetgv
5599#endif
5600 ) {
971a9dd3 5601#ifdef USE_ITHREADS
20e98b0f
NC		 5602 pm->op_pmreplrootu.op_pmtargetoff
5603 = cPADOPx(tmpop)->op_padix;
971a9dd3
GS		 5604 cPADOPx(tmpop)->op_padix = 0; /* steal it */
5605#else
20e98b0f 5606 pm->op_pmreplrootu.op_pmtargetgv
159b6efe 5607 = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
a0714e2c 5608 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
971a9dd3 5609#endif
11343788 5610 tmpop = cUNOPo->op_first; /* to list (nulled) */
c07a80fd 5611 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
5f66b61c 5612 tmpop->op_sibling = NULL; /* don't free split */
c07a80fd 5613 right->op_next = tmpop->op_next; /* fix starting loc */
11343788 5614 op_free(o); /* blow off assign */
54310121 5615 right->op_flags &= ~OPf_WANT;
a5f75d66 5616 /* "I don't know and I don't care." */
c07a80fd 5617 return right;
5618 }
5619 }
5620 else {
e6438c1a 5621 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
c07a80fd 5622 ((LISTOP*)right)->op_last->op_type == OP_CONST)
5623 {
60041a09
FC		 5624 SV ** const svp =
5625 &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
5626 SV * const sv = *svp;
b8de32d5 5627 if (SvIOK(sv) && SvIVX(sv) == 0)
60041a09
FC		 5628 {
5629 if (right->op_private & OPpSPLIT_IMPLIM) {
5630 /* our own SV, created in ck_split */
5631 SvREADONLY_off(sv);
3280af22 5632 sv_setiv(sv, PL_modcount+1);
60041a09
FC		 5633 }
5634 else {
5635 /* SV may belong to someone else */
5636 SvREFCNT_dec(sv);
5637 *svp = newSViv(PL_modcount+1);
5638 }
5639 }
c07a80fd 5640 }
5641 }
5642 }
5643 }
11343788 5644 return o;
79072805
LW		 5645 }
5646 if (!right)
5647 right = newOP(OP_UNDEF, 0);
5648 if (right->op_type == OP_READLINE) {
5649 right->op_flags |= OPf_STACKED;
3ad73efd
Z		 5650 return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
5651 scalar(right));
79072805 5652 }
a0d0e21e 5653 else {
11343788 5654 o = newBINOP(OP_SASSIGN, flags,
3ad73efd 5655 scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
a0d0e21e 5656 }
11343788 5657 return o;
79072805
LW		 5658}
5659
d67eb5f4
Z		 5660/*
5661=for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
5662
5663Constructs a state op (COP). The state op is normally a C<nextstate> op,
5664but will be a C<dbstate> op if debugging is enabled for currently-compiled
3d6c5fec 5665code. The state op is populated from C<PL_curcop> (or C<PL_compiling>).
d67eb5f4
Z		 5666If I<label> is non-null, it supplies the name of a label to attach to
5667the state op; this function takes ownership of the memory pointed at by
5668I<label>, and will free it. I<flags> gives the eight bits of C<op_flags>
5669for the state op.
5670
5671If I<o> is null, the state op is returned. Otherwise the state op is
5672combined with I<o> into a C<lineseq> list op, which is returned. I<o>
5673is consumed by this function and becomes part of the returned op tree.
5674
5675=cut
5676*/
5677
79072805 5678OP *
864dbfa3 5679Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
79072805 5680{
27da23d5 5681 dVAR;
e1ec3a88 5682 const U32 seq = intro_my();
5db1eb8d 5683 const U32 utf8 = flags & SVf_UTF8;
eb578fdb 5684 COP *cop;
79072805 5685
5db1eb8d
BF		 5686 flags &= ~SVf_UTF8;
5687
b7dc083c 5688 NewOp(1101, cop, 1, COP);
57843af0 5689 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
8990e307 5690 cop->op_type = OP_DBSTATE;
22c35a8c 5691 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
8990e307
LW		 5692 }
5693 else {
5694 cop->op_type = OP_NEXTSTATE;
22c35a8c 5695 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
8990e307 5696 }
eb160463 5697 cop->op_flags = (U8)flags;
623e6609 5698 CopHINTS_set(cop, PL_hints);
ff0cee69 5699#ifdef NATIVE_HINTS
5700 cop->op_private |= NATIVE_HINTS;
5701#endif
623e6609 5702 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
79072805
LW		 5703 cop->op_next = (OP*)cop;
5704
bbce6d69 5705 cop->cop_seq = seq;
72dc9ed5 5706 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
20439bc7 5707 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
dca6062a 5708 if (label) {
5db1eb8d
BF		 5709 Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
5710
dca6062a
NC		 5711 PL_hints |= HINT_BLOCK_SCOPE;
5712 /* It seems that we need to defer freeing this pointer, as other parts
5713 of the grammar end up wanting to copy it after this op has been
5714 created. */
5715 SAVEFREEPV(label);
dca6062a 5716 }
79072805 5717
53a7735b 5718 if (PL_parser && PL_parser->copline == NOLINE)
57843af0 5719 CopLINE_set(cop, CopLINE(PL_curcop));
79072805 5720 else {
53a7735b 5721 CopLINE_set(cop, PL_parser->copline);
4b1709c8 5722 PL_parser->copline = NOLINE;
79072805 5723 }
57843af0 5724#ifdef USE_ITHREADS
f4dd75d9 5725 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
57843af0 5726#else
f4dd75d9 5727 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
57843af0 5728#endif
11faa288 5729 CopSTASH_set(cop, PL_curstash);
79072805 5730
65269a95
TB		 5731 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) {
5732 /* this line can have a breakpoint - store the cop in IV */
80a702cd
RGS		 5733 AV *av = CopFILEAVx(PL_curcop);
5734 if (av) {
5735 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
5736 if (svp && *svp != &PL_sv_undef ) {
5737 (void)SvIOK_on(*svp);
5738 SvIV_set(*svp, PTR2IV(cop));
5739 }
1eb1540c 5740 }
93a17b20
LW		 5741 }
5742
f6f3a1fe
RGS		 5743 if (flags & OPf_SPECIAL)
5744 op_null((OP*)cop);
2fcb4757 5745 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
79072805
LW		 5746}
5747
d67eb5f4
Z		 5748/*
5749=for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
5750
5751Constructs, checks, and returns a logical (flow control) op. I<type>
5752is the opcode. I<flags> gives the eight bits of C<op_flags>, except
5753that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
5754the eight bits of C<op_private>, except that the bit with value 1 is
5755automatically set. I<first> supplies the expression controlling the
5756flow, and I<other> supplies the side (alternate) chain of ops; they are
5757consumed by this function and become part of the constructed op tree.
5758
5759=cut
5760*/
bbce6d69 5761
79072805 5762OP *
864dbfa3 5763Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
79072805 5764{
27da23d5 5765 dVAR;
7918f24d
NC		 5766
5767 PERL_ARGS_ASSERT_NEWLOGOP;
5768
883ffac3
CS		 5769 return new_logop(type, flags, &first, &other);
5770}
5771
3bd495df 5772STATIC OP *
71c4dbc3
VP		 5773S_search_const(pTHX_ OP *o)
5774{
5775 PERL_ARGS_ASSERT_SEARCH_CONST;
5776
5777 switch (o->op_type) {
5778 case OP_CONST:
5779 return o;
5780 case OP_NULL:
5781 if (o->op_flags & OPf_KIDS)
5782 return search_const(cUNOPo->op_first);
5783 break;
5784 case OP_LEAVE:
5785 case OP_SCOPE:
5786 case OP_LINESEQ:
5787 {
5788 OP *kid;
5789 if (!(o->op_flags & OPf_KIDS))
5790 return NULL;
5791 kid = cLISTOPo->op_first;
5792 do {
5793 switch (kid->op_type) {
5794 case OP_ENTER:
5795 case OP_NULL:
5796 case OP_NEXTSTATE:
5797 kid = kid->op_sibling;
5798 break;
5799 default:
5800 if (kid != cLISTOPo->op_last)
5801 return NULL;
5802 goto last;
5803 }
5804 } while (kid);
5805 if (!kid)
5806 kid = cLISTOPo->op_last;
5807last:
5808 return search_const(kid);
5809 }
5810 }
5811
5812 return NULL;
5813}
5814
5815STATIC OP *
cea2e8a9 5816S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
883ffac3 5817{
27da23d5 5818 dVAR;
79072805 5819 LOGOP *logop;
11343788 5820 OP *o;
71c4dbc3
VP		 5821 OP *first;
5822 OP *other;
5823 OP *cstop = NULL;
edbe35ea 5824 int prepend_not = 0;
79072805 5825
7918f24d
NC		 5826 PERL_ARGS_ASSERT_NEW_LOGOP;
5827
71c4dbc3
VP		 5828 first = *firstp;
5829 other = *otherp;
5830
a0d0e21e
LW		 5831 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
5832 return newBINOP(type, flags, scalar(first), scalar(other));
5833
e69777c1
GG		 5834 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP);
5835
8990e307 5836 scalarboolean(first);
edbe35ea 5837 /* optimize AND and OR ops that have NOTs as children */
68726e16 5838 if (first->op_type == OP_NOT
b6214b80 5839 && (first->op_flags & OPf_KIDS)
edbe35ea
VP		 5840 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
5841 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
b6214b80 5842 && !PL_madskills) {
79072805
LW		 5843 if (type == OP_AND || type == OP_OR) {
5844 if (type == OP_AND)
5845 type = OP_OR;
5846 else
5847 type = OP_AND;
07f3cdf5 5848 op_null(first);
edbe35ea 5849 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
07f3cdf5 5850 op_null(other);
edbe35ea
VP		 5851 prepend_not = 1; /* prepend a NOT op later */
5852 }
79072805
LW		 5853 }
5854 }
71c4dbc3
VP		 5855 /* search for a constant op that could let us fold the test */
5856 if ((cstop = search_const(first))) {
5857 if (cstop->op_private & OPpCONST_STRICT)
5858 no_bareword_allowed(cstop);
a2a5de95
NC		 5859 else if ((cstop->op_private & OPpCONST_BARE))
5860 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
71c4dbc3
VP		 5861 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
5862 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
5863 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
5f66b61c 5864 *firstp = NULL;
d6fee5c7
DM		 5865 if (other->op_type == OP_CONST)
5866 other->op_private |= OPpCONST_SHORTCIRCUIT;
eb8433b7
NC		 5867 if (PL_madskills) {
5868 OP *newop = newUNOP(OP_NULL, 0, other);
5869 op_getmad(first, newop, '1');
5870 newop->op_targ = type; /* set "was" field */
5871 return newop;
5872 }
5873 op_free(first);
dd3e51dc
VP		 5874 if (other->op_type == OP_LEAVE)
5875 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
2474a784
FC		 5876 else if (other->op_type == OP_MATCH
5877 || other->op_type == OP_SUBST
bb16bae8 5878 || other->op_type == OP_TRANSR
2474a784
FC		 5879 || other->op_type == OP_TRANS)
5880 /* Mark the op as being unbindable with =~ */
5881 other->op_flags |= OPf_SPECIAL;
cc2ebcd7
FC		 5882 else if (other->op_type == OP_CONST)
5883 other->op_private |= OPpCONST_FOLDED;
3513c740
NT		 5884
5885 other->op_folded = 1;
79072805
LW		 5886 return other;
5887 }
5888 else {
7921d0f2 5889 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
6867be6d 5890 const OP *o2 = other;
7921d0f2
DM		 5891 if ( ! (o2->op_type == OP_LIST
5892 && (( o2 = cUNOPx(o2)->op_first))
5893 && o2->op_type == OP_PUSHMARK
5894 && (( o2 = o2->op_sibling)) )
5895 )
5896 o2 = other;
5897 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
5898 || o2->op_type == OP_PADHV)
5899 && o2->op_private & OPpLVAL_INTRO
a2a5de95 5900 && !(o2->op_private & OPpPAD_STATE))
7921d0f2 5901 {
d1d15184
NC		 5902 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
5903 "Deprecated use of my() in false conditional");
7921d0f2
DM		 5904 }
5905
5f66b61c 5906 *otherp = NULL;
d6fee5c7
DM		 5907 if (first->op_type == OP_CONST)
5908 first->op_private |= OPpCONST_SHORTCIRCUIT;
eb8433b7
NC		 5909 if (PL_madskills) {
5910 first = newUNOP(OP_NULL, 0, first);
5911 op_getmad(other, first, '2');
5912 first->op_targ = type; /* set "was" field */
5913 }
5914 else
5915 op_free(other);
79072805
LW		 5916 return first;
5917 }
5918 }
041457d9
DM		 5919 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
5920 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
59e10468 5921 {
b22e6366
AL		 5922 const OP * const k1 = ((UNOP*)first)->op_first;
5923 const OP * const k2 = k1->op_sibling;
a6006777 5924 OPCODE warnop = 0;
5925 switch (first->op_type)
5926 {
5927 case OP_NULL:
5928 if (k2 && k2->op_type == OP_READLINE
5929 && (k2->op_flags & OPf_STACKED)
1c846c1f 5930 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
72b16652 5931 {
a6006777 5932 warnop = k2->op_type;
72b16652 5933 }
a6006777 5934 break;
5935
5936 case OP_SASSIGN:
68dc0745 5937 if (k1->op_type == OP_READDIR
5938 || k1->op_type == OP_GLOB
72b16652 5939 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
459b64da
HY		 5940 || k1->op_type == OP_EACH
5941 || k1->op_type == OP_AEACH)
72b16652
GS		 5942 {
5943 warnop = ((k1->op_type == OP_NULL)
eb160463 5944 ? (OPCODE)k1->op_targ : k1->op_type);
72b16652 5945 }
a6006777 5946 break;
5947 }
8ebc5c01 5948 if (warnop) {
6867be6d 5949 const line_t oldline = CopLINE(PL_curcop);
502e5101
NC		 5950 /* This ensures that warnings are reported at the first line
5951 of the construction, not the last. */
53a7735b 5952 CopLINE_set(PL_curcop, PL_parser->copline);
9014280d 5953 Perl_warner(aTHX_ packWARN(WARN_MISC),
599cee73 5954 "Value of %s%s can be \"0\"; test with defined()",
22c35a8c 5955 PL_op_desc[warnop],
68dc0745 5956 ((warnop == OP_READLINE || warnop == OP_GLOB)
5957 ? " construct" : "() operator"));
57843af0 5958 CopLINE_set(PL_curcop, oldline);
8ebc5c01 5959 }
a6006777 5960 }
79072805
LW		 5961
5962 if (!other)
5963 return first;
5964
c963b151 5965 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
a0d0e21e
LW		 5966 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
5967
b7dc083c 5968 NewOp(1101, logop, 1, LOGOP);
79072805 5969
eb160463 5970 logop->op_type = (OPCODE)type;
22c35a8c 5971 logop->op_ppaddr = PL_ppaddr[type];
79072805 5972 logop->op_first = first;
585ec06d 5973 logop->op_flags = (U8)(flags | OPf_KIDS);
79072805 5974 logop->op_other = LINKLIST(other);
eb160463 5975 logop->op_private = (U8)(1 | (flags >> 8));
79072805
LW		 5976
5977 /* establish postfix order */
5978 logop->op_next = LINKLIST(first);
5979 first->op_next = (OP*)logop;
5980 first->op_sibling = other;
5981
463d09e6
RGS		 5982 CHECKOP(type,logop);
5983
edbe35ea 5984 o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
11343788 5985 other->op_next = o;
79072805 5986
11343788 5987 return o;
79072805
LW		 5988}
5989
d67eb5f4
Z		 5990/*
5991=for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
5992
5993Constructs, checks, and returns a conditional-expression (C<cond_expr>)
5994op. I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
5995will be set automatically, and, shifted up eight bits, the eight bits of
5996C<op_private>, except that the bit with value 1 is automatically set.
5997I<first> supplies the expression selecting between the two branches,
5998and I<trueop> and I<falseop> supply the branches; they are consumed by
5999this function and become part of the constructed op tree.
6000
6001=cut
6002*/
6003
79072805 6004OP *
864dbfa3 6005Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
79072805 6006{
27da23d5 6007 dVAR;
1a67a97c
SM		 6008 LOGOP *logop;
6009 OP *start;
11343788 6010 OP *o;
71c4dbc3 6011 OP *cstop;
79072805 6012
7918f24d
NC		 6013 PERL_ARGS_ASSERT_NEWCONDOP;
6014
b1cb66bf 6015 if (!falseop)
6016 return newLOGOP(OP_AND, 0, first, trueop);
6017 if (!trueop)
6018 return newLOGOP(OP_OR, 0, first, falseop);
79072805 6019
8990e307 6020 scalarboolean(first);
71c4dbc3 6021 if ((cstop = search_const(first))) {
5b6782b2 6022 /* Left or right arm of the conditional? */
71c4dbc3 6023 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
5b6782b2
NC		 6024 OP *live = left ? trueop : falseop;
6025 OP *const dead = left ? falseop : trueop;
71c4dbc3
VP		 6026 if (cstop->op_private & OPpCONST_BARE &&
6027 cstop->op_private & OPpCONST_STRICT) {
6028 no_bareword_allowed(cstop);
b22e6366 6029 }
5b6782b2
NC		 6030 if (PL_madskills) {
6031 /* This is all dead code when PERL_MAD is not defined. */
6032 live = newUNOP(OP_NULL, 0, live);
6033 op_getmad(first, live, 'C');
6034 op_getmad(dead, live, left ? 'e' : 't');
6035 } else {
6036 op_free(first);
6037 op_free(dead);
79072805 6038 }
ef9da979
FC		 6039 if (live->op_type == OP_LEAVE)
6040 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
2474a784 6041 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
bb16bae8 6042 || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
2474a784
FC		 6043 /* Mark the op as being unbindable with =~ */
6044 live->op_flags |= OPf_SPECIAL;
cc2ebcd7
FC		 6045 else if (live->op_type == OP_CONST)
6046 live->op_private |= OPpCONST_FOLDED;
3513c740 6047 live->op_folded = 1;
5b6782b2 6048 return live;
79072805 6049 }
1a67a97c
SM		 6050 NewOp(1101, logop, 1, LOGOP);
6051 logop->op_type = OP_COND_EXPR;
6052 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
6053 logop->op_first = first;
585ec06d 6054 logop->op_flags = (U8)(flags | OPf_KIDS);
eb160463 6055 logop->op_private = (U8)(1 | (flags >> 8));
1a67a97c
SM		 6056 logop->op_other = LINKLIST(trueop);
6057 logop->op_next = LINKLIST(falseop);
79072805 6058
463d09e6
RGS		 6059 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
6060 logop);
79072805
LW		 6061
6062 /* establish postfix order */
1a67a97c
SM		 6063 start = LINKLIST(first);
6064 first->op_next = (OP*)logop;
79072805 6065
b1cb66bf 6066 first->op_sibling = trueop;
6067 trueop->op_sibling = falseop;
1a67a97c 6068 o = newUNOP(OP_NULL, 0, (OP*)logop);
79072805 6069
1a67a97c 6070 trueop->op_next = falseop->op_next = o;
79072805 6071
1a67a97c 6072 o->op_next = start;
11343788 6073 return o;
79072805
LW		 6074}
6075
d67eb5f4
Z		 6076/*
6077=for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
6078
6079Constructs and returns a C<range> op, with subordinate C<flip> and
6080C<flop> ops. I<flags> gives the eight bits of C<op_flags> for the
6081C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
6082for both the C<flip> and C<range> ops, except that the bit with value
60831 is automatically set. I<left> and I<right> supply the expressions
6084controlling the endpoints of the range; they are consumed by this function
6085and become part of the constructed op tree.
6086
6087=cut
6088*/
6089
79072805 6090OP *
864dbfa3 6091Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
79072805 6092{
27da23d5 6093 dVAR;
1a67a97c 6094 LOGOP *range;
79072805
LW		 6095 OP *flip;
6096 OP *flop;
1a67a97c 6097 OP *leftstart;
11343788 6098 OP *o;
79072805 6099
7918f24d
NC		 6100 PERL_ARGS_ASSERT_NEWRANGE;
6101
1a67a97c 6102 NewOp(1101, range, 1, LOGOP);
79072805 6103
1a67a97c
SM		 6104 range->op_type = OP_RANGE;
6105 range->op_ppaddr = PL_ppaddr[OP_RANGE];
6106 range->op_first = left;
6107 range->op_flags = OPf_KIDS;
6108 leftstart = LINKLIST(left);
6109 range->op_other = LINKLIST(right);
eb160463 6110 range->op_private = (U8)(1 | (flags >> 8));
79072805
LW		 6111
6112 left->op_sibling = right;
6113
1a67a97c
SM		 6114 range->op_next = (OP*)range;
6115 flip = newUNOP(OP_FLIP, flags, (OP*)range);
79072805 6116 flop = newUNOP(OP_FLOP, 0, flip);
11343788 6117 o = newUNOP(OP_NULL, 0, flop);
5983a79d 6118 LINKLIST(flop);
1a67a97c 6119 range->op_next = leftstart;
79072805
LW		 6120
6121 left->op_next = flip;
6122 right->op_next = flop;
6123
1a67a97c
SM		 6124 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
6125 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
ed6116ce 6126 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
79072805
LW		 6127 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
6128
6129 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
6130 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
6131
eb796c7f
GG		 6132 /* check barewords before they might be optimized aways */
6133 if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
6134 no_bareword_allowed(left);
6135 if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
6136 no_bareword_allowed(right);
6137
11343788 6138 flip->op_next = o;
79072805 6139 if (!flip->op_private || !flop->op_private)
5983a79d 6140 LINKLIST(o); /* blow off optimizer unless constant */
79072805 6141
11343788 6142 return o;
79072805
LW		 6143}
6144
d67eb5f4
Z		 6145/*
6146=for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
6147
6148Constructs, checks, and returns an op tree expressing a loop. This is
6149only a loop in the control flow through the op tree; it does not have
6150the heavyweight loop structure that allows exiting the loop by C<last>
6151and suchlike. I<flags> gives the eight bits of C<op_flags> for the
6152top-level op, except that some bits will be set automatically as required.
6153I<expr> supplies the expression controlling loop iteration, and I<block>
6154supplies the body of the loop; they are consumed by this function and
6155become part of the constructed op tree. I<debuggable> is currently
6156unused and should always be 1.
6157
6158=cut
6159*/
6160
79072805 6161OP *
864dbfa3 6162Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
79072805 6163{
97aff369 6164 dVAR;
463ee0b2 6165 OP* listop;
11343788 6166 OP* o;
73d840c0 6167 const bool once = block && block->op_flags & OPf_SPECIAL &&
a0d0e21e 6168 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
46c461b5
AL		 6169
6170 PERL_UNUSED_ARG(debuggable);
93a17b20 6171
463ee0b2
LW		 6172 if (expr) {
6173 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
6174 return block; /* do {} while 0 does once */
114c60ec
BG		 6175 if (expr->op_type == OP_READLINE
6176 || expr->op_type == OP_READDIR
6177 || expr->op_type == OP_GLOB
8ae39f60 6178 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
fb73857a 6179 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
774d564b 6180 expr = newUNOP(OP_DEFINED, 0,
54b9620d 6181 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
55d729e4 6182 } else if (expr->op_flags & OPf_KIDS) {
46c461b5
AL		 6183 const OP * const k1 = ((UNOP*)expr)->op_first;
6184 const OP * const k2 = k1 ? k1->op_sibling : NULL;
55d729e4 6185 switch (expr->op_type) {
1c846c1f 6186 case OP_NULL:
114c60ec 6187 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
55d729e4 6188 && (k2->op_flags & OPf_STACKED)
1c846c1f 6189 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
55d729e4 6190 expr = newUNOP(OP_DEFINED, 0, expr);
1c846c1f 6191 break;
55d729e4
GS		 6192
6193 case OP_SASSIGN:
06dc7ac6 6194 if (k1 && (k1->op_type == OP_READDIR
55d729e4 6195 || k1->op_type == OP_GLOB
6531c3e6 6196 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
459b64da
HY		 6197 || k1->op_type == OP_EACH
6198 || k1->op_type == OP_AEACH))
55d729e4
GS		 6199 expr = newUNOP(OP_DEFINED, 0, expr);
6200 break;
6201 }
774d564b 6202 }
463ee0b2 6203 }
93a17b20 6204
2fcb4757 6205 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
e1548254
RGS		 6206 * op, in listop. This is wrong. [perl #27024] */
6207 if (!block)
6208 block = newOP(OP_NULL, 0);
2fcb4757 6209 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
883ffac3 6210 o = new_logop(OP_AND, 0, &expr, &listop);
463ee0b2 6211
883ffac3
CS		 6212 if (listop)
6213 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
79072805 6214
11343788
MB		 6215 if (once && o != listop)
6216 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
79072805 6217
11343788
MB		 6218 if (o == listop)
6219 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
748a9306 6220
11343788 6221 o->op_flags |= flags;
3ad73efd 6222 o = op_scope(o);
11343788
MB		 6223 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
6224 return o;
79072805
LW		 6225}
6226
d67eb5f4 6227/*
94bf0465 6228=for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
d67eb5f4
Z		 6229
6230Constructs, checks, and returns an op tree expressing a C<while> loop.
6231This is a heavyweight loop, with structure that allows exiting the loop
6232by C<last> and suchlike.
6233
6234I<loop> is an optional preconstructed C<enterloop> op to use in the
6235loop; if it is null then a suitable op will be constructed automatically.
6236I<expr> supplies the loop's controlling expression. I<block> supplies the
6237main body of the loop, and I<cont> optionally supplies a C<continue> block
6238that operates as a second half of the body. All of these optree inputs
6239are consumed by this function and become part of the constructed op tree.
6240
6241I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
6242op and, shifted up eight bits, the eight bits of C<op_private> for
6243the C<leaveloop> op, except that (in both cases) some bits will be set
6244automatically. I<debuggable> is currently unused and should always be 1.
94bf0465 6245I<has_my> can be supplied as true to force the
d67eb5f4
Z		 6246loop body to be enclosed in its own scope.
6247
6248=cut
6249*/
6250
79072805 6251OP *
94bf0465
Z		 6252Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
6253 OP *expr, OP *block, OP *cont, I32 has_my)
79072805 6254{
27da23d5 6255 dVAR;
79072805 6256 OP *redo;
c445ea15 6257 OP *next = NULL;
79072805 6258 OP *listop;
11343788 6259 OP *o;
1ba6ee2b 6260 U8 loopflags = 0;
46c461b5
AL		 6261
6262 PERL_UNUSED_ARG(debuggable);
79072805 6263
2d03de9c 6264 if (expr) {
114c60ec
BG		 6265 if (expr->op_type == OP_READLINE
6266 || expr->op_type == OP_READDIR
6267 || expr->op_type == OP_GLOB
8ae39f60 6268 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
2d03de9c
AL		 6269 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
6270 expr = newUNOP(OP_DEFINED, 0,
6271 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
6272 } else if (expr->op_flags & OPf_KIDS) {
6273 const OP * const k1 = ((UNOP*)expr)->op_first;
6274 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
6275 switch (expr->op_type) {
6276 case OP_NULL:
114c60ec 6277 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
2d03de9c
AL		 6278 && (k2->op_flags & OPf_STACKED)
6279 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
6280 expr = newUNOP(OP_DEFINED, 0, expr);
6281 break;
55d729e4 6282
2d03de9c 6283 case OP_SASSIGN:
72c8de1a 6284 if (k1 && (k1->op_type == OP_READDIR
2d03de9c
AL		 6285 || k1->op_type == OP_GLOB
6286 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
459b64da
HY		 6287 || k1->op_type == OP_EACH
6288 || k1->op_type == OP_AEACH))
2d03de9c
AL		 6289 expr = newUNOP(OP_DEFINED, 0, expr);
6290 break;
6291 }
55d729e4 6292 }
748a9306 6293 }
79072805
LW		 6294
6295 if (!block)
6296 block = newOP(OP_NULL, 0);
a034e688 6297 else if (cont || has_my) {
3ad73efd 6298 block = op_scope(block);
87246558 6299 }
79072805 6300
1ba6ee2b 6301 if (cont) {
79072805 6302 next = LINKLIST(cont);
1ba6ee2b 6303 }
fb73857a 6304 if (expr) {
551405c4 6305 OP * const unstack = newOP(OP_UNSTACK, 0);
85538317
GS		 6306 if (!next)
6307 next = unstack;
2fcb4757 6308 cont = op_append_elem(OP_LINESEQ, cont, unstack);
fb73857a 6309 }
79072805 6310
ce3e5c45 6311 assert(block);
2fcb4757 6312 listop = op_append_list(OP_LINESEQ, block, cont);
ce3e5c45 6313 assert(listop);
79072805
LW		 6314 redo = LINKLIST(listop);
6315
6316 if (expr) {
883ffac3
CS		 6317 scalar(listop);
6318 o = new_logop(OP_AND, 0, &expr, &listop);
11343788 6319 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
463ee0b2 6320 op_free((OP*)loop);
317f3b66 6321 return expr; /* listop already freed by new_logop */
463ee0b2 6322 }
883ffac3 6323 if (listop)
497b47a8 6324 ((LISTOP*)listop)->op_last->op_next =
883ffac3 6325 (o == listop ? redo : LINKLIST(o));
79072805
LW		 6326 }
6327 else
11343788 6328 o = listop;
79072805
LW		 6329
6330 if (!loop) {
b7dc083c 6331 NewOp(1101,loop,1,LOOP);
79072805 6332 loop->op_type = OP_ENTERLOOP;
22c35a8c 6333 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
79072805
LW		 6334 loop->op_private = 0;
6335 loop->op_next = (OP*)loop;
6336 }
6337
11343788 6338 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
79072805
LW		 6339
6340 loop->op_redoop = redo;
11343788 6341 loop->op_lastop = o;
1ba6ee2b 6342 o->op_private |= loopflags;
79072805
LW		 6343
6344 if (next)
6345 loop->op_nextop = next;
6346 else
11343788 6347 loop->op_nextop = o;
79072805 6348
11343788
MB		 6349 o->op_flags |= flags;
6350 o->op_private |= (flags >> 8);
6351 return o;
79072805
LW		 6352}
6353
d67eb5f4 6354/*
94bf0465 6355=for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
d67eb5f4
Z		 6356
6357Constructs, checks, and returns an op tree expressing a C<foreach>
6358loop (iteration through a list of values). This is a heavyweight loop,
6359with structure that allows exiting the loop by C<last> and suchlike.
6360
6361I<sv> optionally supplies the variable that will be aliased to each
6362item in turn; if null, it defaults to C<$_> (either lexical or global).
6363I<expr> supplies the list of values to iterate over. I<block> supplies
6364the main body of the loop, and I<cont> optionally supplies a C<continue>
6365block that operates as a second half of the body. All of these optree
6366inputs are consumed by this function and become part of the constructed
6367op tree.
6368
6369I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
6370op and, shifted up eight bits, the eight bits of C<op_private> for
6371the C<leaveloop> op, except that (in both cases) some bits will be set
94bf0465 6372automatically.
d67eb5f4
Z		 6373
6374=cut
6375*/
6376
79072805 6377OP *
94bf0465 6378Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
79072805 6379{
27da23d5 6380 dVAR;
79072805 6381 LOOP *loop;
fb73857a 6382 OP *wop;
4bbc6d12 6383 PADOFFSET padoff = 0;
4633a7c4 6384 I32 iterflags = 0;
241416b8 6385 I32 iterpflags = 0;
d4c19fe8 6386 OP *madsv = NULL;
79072805 6387
7918f24d
NC		 6388 PERL_ARGS_ASSERT_NEWFOROP;
6389
79072805 6390 if (sv) {
85e6fe83 6391 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
241416b8 6392 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
748a9306 6393 sv->op_type = OP_RV2GV;
22c35a8c 6394 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
0be9a6bb
RH		 6395
6396 /* The op_type check is needed to prevent a possible segfault
6397 * if the loop variable is undeclared and 'strict vars' is in
6398 * effect. This is illegal but is nonetheless parsed, so we
6399 * may reach this point with an OP_CONST where we're expecting
6400 * an OP_GV.
6401 */
6402 if (cUNOPx(sv)->op_first->op_type == OP_GV
6403 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
0d863452 6404 iterpflags |= OPpITER_DEF;
79072805 6405 }
85e6fe83 6406 else if (sv->op_type == OP_PADSV) { /* private variable */
241416b8 6407 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
85e6fe83 6408 padoff = sv->op_targ;
eb8433b7
NC		 6409 if (PL_madskills)
6410 madsv = sv;
6411 else {
6412 sv->op_targ = 0;
6413 op_free(sv);
6414 }
5f66b61c 6415 sv = NULL;
85e6fe83 6416 }
79072805 6417 else
cea2e8a9 6418 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
f8503592
NC		 6419 if (padoff) {
6420 SV *const namesv = PAD_COMPNAME_SV(padoff);
6421 STRLEN len;
6422 const char *const name = SvPV_const(namesv, len);
6423
6424 if (len == 2 && name[0] == '$' && name[1] == '_')
6425 iterpflags |= OPpITER_DEF;
6426 }
79072805
LW		 6427 }
6428 else {
cc76b5cc 6429 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
00b1698f 6430 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
aabe9514
RGS		 6431 sv = newGVOP(OP_GV, 0, PL_defgv);
6432 }
6433 else {
6434 padoff = offset;
aabe9514 6435 }
0d863452 6436 iterpflags |= OPpITER_DEF;
79072805 6437 }
5f05dabc 6438 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3ad73efd 6439 expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4633a7c4
LW		 6440 iterflags |= OPf_STACKED;
6441 }
89ea2908
GA		 6442 else if (expr->op_type == OP_NULL &&
6443 (expr->op_flags & OPf_KIDS) &&
6444 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
6445 {
6446 /* Basically turn for($x..$y) into the same as for($x,$y), but we
6447 * set the STACKED flag to indicate that these values are to be
08bf00be 6448 * treated as min/max values by 'pp_enteriter'.
89ea2908 6449 */
d4c19fe8 6450 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
551405c4 6451 LOGOP* const range = (LOGOP*) flip->op_first;
66a1b24b
AL		 6452 OP* const left = range->op_first;
6453 OP* const right = left->op_sibling;
5152d7c7 6454 LISTOP* listop;
89ea2908
GA		 6455
6456 range->op_flags &= ~OPf_KIDS;
5f66b61c 6457 range->op_first = NULL;
89ea2908 6458
5152d7c7 6459 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
1a67a97c
SM		 6460 listop->op_first->op_next = range->op_next;
6461 left->op_next = range->op_other;
5152d7c7
GS		 6462 right->op_next = (OP*)listop;
6463 listop->op_next = listop->op_first;
89ea2908 6464
eb8433b7
NC		 6465#ifdef PERL_MAD
6466 op_getmad(expr,(OP*)listop,'O');
6467#else
89ea2908 6468 op_free(expr);
eb8433b7 6469#endif
5152d7c7 6470 expr = (OP*)(listop);
93c66552 6471 op_null(expr);
89ea2908
GA		 6472 iterflags |= OPf_STACKED;
6473 }
6474 else {
3ad73efd 6475 expr = op_lvalue(force_list(expr), OP_GREPSTART);
89ea2908
GA		 6476 }
6477
4633a7c4 6478 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
2fcb4757 6479 op_append_elem(OP_LIST, expr, scalar(sv))));
85e6fe83 6480 assert(!loop->op_next);
241416b8 6481 /* for my $x () sets OPpLVAL_INTRO;
14f338dc 6482 * for our $x () sets OPpOUR_INTRO */
c5661c80 6483 loop->op_private = (U8)iterpflags;
b448305b
FC		 6484 if (loop->op_slabbed
6485 && DIFF(loop, OpSLOT(loop)->opslot_next)
8be227ab 6486 < SIZE_TO_PSIZE(sizeof(LOOP)))
155aba94
GS		 6487 {
6488 LOOP *tmp;
6489 NewOp(1234,tmp,1,LOOP);
bd5f3bc4 6490 Copy(loop,tmp,1,LISTOP);
bfafaa29 6491 S_op_destroy(aTHX_ (OP*)loop);
155aba94
GS		 6492 loop = tmp;
6493 }
b448305b
FC		 6494 else if (!loop->op_slabbed)
6495 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
85e6fe83 6496 loop->op_targ = padoff;
94bf0465 6497 wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
eb8433b7
NC		 6498 if (madsv)
6499 op_getmad(madsv, (OP*)loop, 'v');
eae48c89 6500 return wop;
79072805
LW		 6501}
6502
d67eb5f4
Z		 6503/*
6504=for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
6505
6506Constructs, checks, and returns a loop-exiting op (such as C<goto>
6507or C<last>). I<type> is the opcode. I<label> supplies the parameter
6508determining the target of the op; it is consumed by this function and
d001e19d 6509becomes part of the constructed op tree.
d67eb5f4
Z		 6510
6511=cut
6512*/
6513
8990e307 6514OP*
864dbfa3 6515Perl_newLOOPEX(pTHX_ I32 type, OP *label)
8990e307 6516{
97aff369 6517 dVAR;
1ec4f607 6518 OP *o = NULL;
2d8e6c8d 6519
7918f24d
NC		 6520 PERL_ARGS_ASSERT_NEWLOOPEX;
6521
e69777c1
GG		 6522 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
6523
3532f34a 6524 if (type != OP_GOTO) {
cdaebead 6525 /* "last()" means "last" */
1f039d60 6526 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
cdaebead 6527 o = newOP(type, OPf_SPECIAL);
cdaebead 6528 }
8990e307
LW		 6529 }
6530 else {
e3aba57a
RGS		 6531 /* Check whether it's going to be a goto &function */
6532 if (label->op_type == OP_ENTERSUB
6533 && !(label->op_flags & OPf_STACKED))
3ad73efd 6534 label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
1f039d60
FC		 6535 }
6536
6537 /* Check for a constant argument */
6538 if (label->op_type == OP_CONST) {
3532f34a
FC		 6539 SV * const sv = ((SVOP *)label)->op_sv;
6540 STRLEN l;
6541 const char *s = SvPV_const(sv,l);
1f039d60
FC		 6542 if (l == strlen(s)) {
6543 o = newPVOP(type,
6544 SvUTF8(((SVOP*)label)->op_sv),
6545 savesharedpv(
6546 SvPV_nolen_const(((SVOP*)label)->op_sv)));
1ec4f607
FC		 6547 }
6548 }
6549
6550 /* If we have already created an op, we do not need the label. */
6551 if (o)
1f039d60
FC		 6552#ifdef PERL_MAD
6553 op_getmad(label,o,'L');
6554#else
6555 op_free(label);
6556#endif
1ec4f607 6557 else o = newUNOP(type, OPf_STACKED, label);
1f039d60 6558
3280af22 6559 PL_hints |= HINT_BLOCK_SCOPE;
11343788 6560 return o;
8990e307
LW		 6561}
6562
0d863452
RH		 6563/* if the condition is a literal array or hash
6564 (or @{ ... } etc), make a reference to it.
6565 */
6566STATIC OP *
6567S_ref_array_or_hash(pTHX_ OP *cond)
6568{
6569 if (cond
6570 && (cond->op_type == OP_RV2AV
6571 || cond->op_type == OP_PADAV
6572 || cond->op_type == OP_RV2HV
6573 || cond->op_type == OP_PADHV))
6574
3ad73efd 6575 return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
0d863452 6576
329a333e
DL		 6577 else if(cond
6578 && (cond->op_type == OP_ASLICE
6579 || cond->op_type == OP_HSLICE)) {
6580
6581 /* anonlist now needs a list from this op, was previously used in
6582 * scalar context */
6583 cond->op_flags |= ~(OPf_WANT_SCALAR | OPf_REF);
6584 cond->op_flags |= OPf_WANT_LIST;
6585
3ad73efd 6586 return newANONLIST(op_lvalue(cond, OP_ANONLIST));
329a333e
DL		 6587 }
6588
0d863452
RH		 6589 else
6590 return cond;
6591}
6592
6593/* These construct the optree fragments representing given()
6594 and when() blocks.
6595
6596 entergiven and enterwhen are LOGOPs; the op_other pointer
6597 points up to the associated leave op. We need this so we
6598 can put it in the context and make break/continue work.
6599 (Also, of course, pp_enterwhen will jump straight to
6600 op_other if the match fails.)
6601 */
6602
4136a0f7 6603STATIC OP *
0d863452
RH		 6604S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
6605 I32 enter_opcode, I32 leave_opcode,
6606 PADOFFSET entertarg)
6607{
97aff369 6608 dVAR;
0d863452
RH		 6609 LOGOP *enterop;
6610 OP *o;
6611
7918f24d
NC		 6612 PERL_ARGS_ASSERT_NEWGIVWHENOP;
6613
0d863452 6614 NewOp(1101, enterop, 1, LOGOP);
61a59f30 6615 enterop->op_type = (Optype)enter_opcode;
0d863452
RH		 6616 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
6617 enterop->op_flags = (U8) OPf_KIDS;
6618 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
6619 enterop->op_private = 0;
6620
6621 o = newUNOP(leave_opcode, 0, (OP *) enterop);
6622
6623 if (cond) {
6624 enterop->op_first = scalar(cond);
6625 cond->op_sibling = block;
6626
6627 o->op_next = LINKLIST(cond);
6628 cond->op_next = (OP *) enterop;
6629 }
6630 else {
6631 /* This is a default {} block */
6632 enterop->op_first = block;
6633 enterop->op_flags |= OPf_SPECIAL;
fc7debfb 6634 o ->op_flags |= OPf_SPECIAL;
0d863452
RH		 6635
6636 o->op_next = (OP *) enterop;
6637 }
6638
6639 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
6640 entergiven and enterwhen both
6641 use ck_null() */
6642
6643 enterop->op_next = LINKLIST(block);
6644 block->op_next = enterop->op_other = o;
6645
6646 return o;
6647}
6648
6649/* Does this look like a boolean operation? For these purposes
6650 a boolean operation is:
6651 - a subroutine call [*]
6652 - a logical connective
6653 - a comparison operator
6654 - a filetest operator, with the exception of -s -M -A -C
6655 - defined(), exists() or eof()
6656 - /$re/ or $foo =~ /$re/
6657
6658 [*] possibly surprising
6659 */
4136a0f7 6660STATIC bool
ef519e13 6661S_looks_like_bool(pTHX_ const OP *o)
0d863452 6662{
97aff369 6663 dVAR;
7918f24d
NC		 6664
6665 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
6666
0d863452
RH		 6667 switch(o->op_type) {
6668 case OP_OR:
f92e1a16 6669 case OP_DOR:
0d863452
RH		 6670 return looks_like_bool(cLOGOPo->op_first);
6671
6672 case OP_AND:
6673 return (
6674 looks_like_bool(cLOGOPo->op_first)
6675 && looks_like_bool(cLOGOPo->op_first->op_sibling));
6676
1e1d4b91 6677 case OP_NULL:
08fe1c44 6678 case OP_SCALAR:
1e1d4b91
JJ		 6679 return (
6680 o->op_flags & OPf_KIDS
6681 && looks_like_bool(cUNOPo->op_first));
6682
0d863452
RH		 6683 case OP_ENTERSUB:
6684
6685 case OP_NOT: case OP_XOR:
0d863452
RH		 6686
6687 case OP_EQ: case OP_NE: case OP_LT:
6688 case OP_GT: case OP_LE: case OP_GE:
6689
6690 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
6691 case OP_I_GT: case OP_I_LE: case OP_I_GE:
6692
6693 case OP_SEQ: case OP_SNE: case OP_SLT:
6694 case OP_SGT: case OP_SLE: case OP_SGE:
6695
6696 case OP_SMARTMATCH:
6697
6698 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
6699 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
6700 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
6701 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
6702 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
6703 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
6704 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
6705 case OP_FTTEXT: case OP_FTBINARY:
6706
6707 case OP_DEFINED: case OP_EXISTS:
6708 case OP_MATCH: case OP_EOF:
6709
f118ea0d
RGS		 6710 case OP_FLOP:
6711
0d863452
RH		 6712 return TRUE;
6713
6714 case OP_CONST:
6715 /* Detect comparisons that have been optimized away */
6716 if (cSVOPo->op_sv == &PL_sv_yes
6717 || cSVOPo->op_sv == &PL_sv_no)
6718
6719 return TRUE;
6e03d743
RGS		 6720 else
6721 return FALSE;
6e03d743 6722
0d863452
RH		 6723 /* FALL THROUGH */
6724 default:
6725 return FALSE;
6726 }
6727}
6728
d67eb5f4
Z		 6729/*
6730=for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
6731
6732Constructs, checks, and returns an op tree expressing a C<given> block.
6733I<cond> supplies the expression that will be locally assigned to a lexical
6734variable, and I<block> supplies the body of the C<given> construct; they
6735are consumed by this function and become part of the constructed op tree.
6736I<defsv_off> is the pad offset of the scalar lexical variable that will
a8bd1c84 6737be affected. If it is 0, the global $_ will be used.
d67eb5f4
Z		 6738
6739=cut
6740*/
6741
0d863452
RH		 6742OP *
6743Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
6744{
97aff369 6745 dVAR;
7918f24d 6746 PERL_ARGS_ASSERT_NEWGIVENOP;
0d863452
RH		 6747 return newGIVWHENOP(
6748 ref_array_or_hash(cond),
6749 block,
6750 OP_ENTERGIVEN, OP_LEAVEGIVEN,
6751 defsv_off);
6752}
6753
d67eb5f4
Z		 6754/*
6755=for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
6756
6757Constructs, checks, and returns an op tree expressing a C<when> block.
6758I<cond> supplies the test expression, and I<block> supplies the block
6759that will be executed if the test evaluates to true; they are consumed
6760by this function and become part of the constructed op tree. I<cond>
6761will be interpreted DWIMically, often as a comparison against C<$_>,
6762and may be null to generate a C<default> block.
6763
6764=cut
6765*/
6766
0d863452
RH		 6767OP *
6768Perl_newWHENOP(pTHX_ OP *cond, OP *block)
6769{
ef519e13 6770 const bool cond_llb = (!cond || looks_like_bool(cond));
0d863452
RH		 6771 OP *cond_op;
6772
7918f24d
NC		 6773 PERL_ARGS_ASSERT_NEWWHENOP;
6774
0d863452
RH		 6775 if (cond_llb)
6776 cond_op = cond;
6777 else {
6778 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
6779 newDEFSVOP(),
6780 scalar(ref_array_or_hash(cond)));
6781 }
6782
c08f093b 6783 return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
0d863452
RH		 6784}
6785
3fe9a6f1 6786void
dab1c735
BF		 6787Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
6788 const STRLEN len, const U32 flags)
cbf82dd0 6789{
7a2f0b06
PM		 6790 SV *name = NULL, *msg;
6791 const char * cvp = SvROK(cv) ? "" : CvPROTO(cv);
6792 STRLEN clen = CvPROTOLEN(cv), plen = len;
8fa6a409 6793
dab1c735 6794 PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
8fa6a409 6795
38d27505 6796 if (p == NULL && cvp == NULL)
7a2f0b06 6797 return;
3fe9a6f1 6798
38d27505 6799 if (!ckWARN_d(WARN_PROTOTYPE))
7a2f0b06
PM		 6800 return;
6801
6802 if (p && cvp) {
6803 p = S_strip_spaces(aTHX_ p, &plen);
6804 cvp = S_strip_spaces(aTHX_ cvp, &clen);
6805 if ((flags & SVf_UTF8) == SvUTF8(cv)) {
6806 if (plen == clen && memEQ(cvp, p, plen))
6807 return;
6808 } else {
6809 if (flags & SVf_UTF8) {
6810 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
6811 return;
6812 }
6813 else {
6814 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
6815 return;
6816 }
105ff74c 6817 }
3fe9a6f1 6818 }
7a2f0b06
PM		 6819
6820 msg = sv_newmortal();
6821
6822 if (gv)
6823 {
6824 if (isGV(gv))
6825 gv_efullname3(name = sv_newmortal(), gv, NULL);
6826 else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
6827 name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
6828 else name = (SV *)gv;
6829 }
6830 sv_setpvs(msg, "Prototype mismatch:");
6831 if (name)
6832 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
6833 if (cvp)
b17a0679
FC		 6834 Perl_sv_catpvf(aTHX_ msg, " (%"UTF8f")",
6835 UTF8fARG(SvUTF8(cv),clen,cvp)
7a2f0b06
PM		 6836 );
6837 else
6838 sv_catpvs(msg, ": none");
6839 sv_catpvs(msg, " vs ");
6840 if (p)
b17a0679 6841 Perl_sv_catpvf(aTHX_ msg, "(%"UTF8f")", UTF8fARG(flags & SVf_UTF8,len,p));
7a2f0b06
PM		 6842 else
6843 sv_catpvs(msg, "none");
6844 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
3fe9a6f1 6845}
6846
35f1c1c7
SB		 6847static void const_sv_xsub(pTHX_ CV* cv);
6848
beab0874 6849/*
ccfc67b7
JH		 6850
6851=head1 Optree Manipulation Functions
6852
beab0874
JT		 6853=for apidoc cv_const_sv
6854
6855If C<cv> is a constant sub eligible for inlining. returns the constant
6856value returned by the sub. Otherwise, returns NULL.
6857
6858Constant subs can be created with C<newCONSTSUB> or as described in
6859L<perlsub/"Constant Functions">.
6860
6861=cut
6862*/
760ac839 6863SV *
d45f5b30 6864Perl_cv_const_sv(pTHX_ const CV *const cv)
760ac839 6865{
96a5add6 6866 PERL_UNUSED_CONTEXT;
5069cc75
NC		 6867 if (!cv)
6868 return NULL;
6869 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
6870 return NULL;
ad64d0ec 6871 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
fe5e78ed 6872}
760ac839 6873
b5c19bd7
DM		 6874/* op_const_sv: examine an optree to determine whether it's in-lineable.
6875 * Can be called in 3 ways:
6876 *
6877 * !cv
6878 * look for a single OP_CONST with attached value: return the value
6879 *
6880 * cv && CvCLONE(cv) && !CvCONST(cv)
6881 *
6882 * examine the clone prototype, and if contains only a single
6883 * OP_CONST referencing a pad const, or a single PADSV referencing
6884 * an outer lexical, return a non-zero value to indicate the CV is
6885 * a candidate for "constizing" at clone time
6886 *
6887 * cv && CvCONST(cv)
6888 *
6889 * We have just cloned an anon prototype that was marked as a const
486ec47a 6890 * candidate. Try to grab the current value, and in the case of
be8851fc
NC		 6891 * PADSV, ignore it if it has multiple references. In this case we
6892 * return a newly created *copy* of the value.
b5c19bd7
DM		 6893 */
6894
fe5e78ed 6895SV *
6867be6d 6896Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
fe5e78ed 6897{
97aff369 6898 dVAR;
a0714e2c 6899 SV *sv = NULL;
fe5e78ed 6900
c631f32b
GG		 6901 if (PL_madskills)
6902 return NULL;
6903
0f79a09d 6904 if (!o)
a0714e2c 6905 return NULL;
1c846c1f
NIS		 6906
6907 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
fe5e78ed
GS		 6908 o = cLISTOPo->op_first->op_sibling;
6909
6910 for (; o; o = o->op_next) {
890ce7af 6911 const OPCODE type = o->op_type;
fe5e78ed 6912
1c846c1f 6913 if (sv && o->op_next == o)
fe5e78ed 6914 return sv;
e576b457 6915 if (o->op_next != o) {
dbe92b04
FC		 6916 if (type == OP_NEXTSTATE
6917 || (type == OP_NULL && !(o->op_flags & OPf_KIDS))
6918 || type == OP_PUSHMARK)
e576b457
JT		 6919 continue;
6920 if (type == OP_DBSTATE)
6921 continue;
6922 }
54310121 6923 if (type == OP_LEAVESUB || type == OP_RETURN)
6924 break;
6925 if (sv)
a0714e2c 6926 return NULL;
7766f137 6927 if (type == OP_CONST && cSVOPo->op_sv)
5dc0d613 6928 sv = cSVOPo->op_sv;
b5c19bd7 6929 else if (cv && type == OP_CONST) {
dd2155a4 6930 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
beab0874 6931 if (!sv)
a0714e2c 6932 return NULL;
b5c19bd7
DM		 6933 }
6934 else if (cv && type == OP_PADSV) {
6935 if (CvCONST(cv)) { /* newly cloned anon */
6936 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
6937 /* the candidate should have 1 ref from this pad and 1 ref
6938 * from the parent */
6939 if (!sv || SvREFCNT(sv) != 2)
a0714e2c 6940 return NULL;
beab0874 6941 sv = newSVsv(sv);
b5c19bd7
DM		 6942 SvREADONLY_on(sv);
6943 return sv;
6944 }
6945 else {
6946 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
6947 sv = &PL_sv_undef; /* an arbitrary non-null value */
beab0874 6948 }
760ac839 6949 }
b5c19bd7 6950 else {
a0714e2c 6951 return NULL;
b5c19bd7 6952 }
760ac839
LW		 6953 }
6954 return sv;
6955}
6956
2b141370
FC		 6957static bool
6958S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
6959 PADNAME * const name, SV ** const const_svp)
6960{
6961 assert (cv);
6962 assert (o || name);
6963 assert (const_svp);
6964 if ((!block
6965#ifdef PERL_MAD
6966 || block->op_type == OP_NULL
6967#endif
6968 )) {
6969 if (CvFLAGS(PL_compcv)) {
6970 /* might have had built-in attrs applied */
6971 const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
6972 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
6973 && ckWARN(WARN_MISC))
6974 {
6975 /* protect against fatal warnings leaking compcv */
6976 SAVEFREESV(PL_compcv);
6977 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
6978 SvREFCNT_inc_simple_void_NN(PL_compcv);
6979 }
6980 CvFLAGS(cv) |=
6981 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
6982 & ~(CVf_LVALUE * pureperl));
6983 }
6984 return FALSE;
6985 }
6986
6987 /* redundant check for speed: */
6988 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
6989 const line_t oldline = CopLINE(PL_curcop);
6990 SV *namesv = o
6991 ? cSVOPo->op_sv
6992 : sv_2mortal(newSVpvn_utf8(
6993 PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name)
6994 ));
6995 if (PL_parser && PL_parser->copline != NOLINE)
6996 /* This ensures that warnings are reported at the first
6997 line of a redefinition, not the last. */
6998 CopLINE_set(PL_curcop, PL_parser->copline);
d0761305
FC		 6999 /* protect against fatal warnings leaking compcv */
7000 SAVEFREESV(PL_compcv);
2b141370 7001 report_redefined_cv(namesv, cv, const_svp);
d0761305 7002 SvREFCNT_inc_simple_void_NN(PL_compcv);
2b141370
FC		 7003 CopLINE_set(PL_curcop, oldline);
7004 }
7005#ifdef PERL_MAD
7006 if (!PL_minus_c) /* keep old one around for madskills */
7007#endif
7008 {
7009 /* (PL_madskills unset in used file.) */
7010 SvREFCNT_dec(cv);
7011 }
7012 return TRUE;
7013}
7014
50278755 7015CV *
09bef843
SB		 7016Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
7017{
50278755 7018 dVAR;
50278755
FC		 7019 CV **spot;
7020 SV **svspot;
7021 const char *ps;
7022 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
7023 U32 ps_utf8 = 0;
5aaab254
KW		 7024 CV *cv = NULL;
7025 CV *compcv = PL_compcv;
50278755 7026 SV *const_sv;
50278755 7027 PADNAME *name;
10342479
FC		 7028 PADOFFSET pax = o->op_targ;
7029 CV *outcv = CvOUTSIDE(PL_compcv);
a70c2d56 7030 CV *clonee = NULL;
6d5c2147 7031 HEK *hek = NULL;
a70c2d56 7032 bool reusable = FALSE;
50278755
FC		 7033
7034 PERL_ARGS_ASSERT_NEWMYSUB;
7035
10342479
FC		 7036 /* Find the pad slot for storing the new sub.
7037 We cannot use PL_comppad, as it is the pad owned by the new sub. We
7038 need to look in CvOUTSIDE and find the pad belonging to the enclos-
7039 ing sub. And then we need to dig deeper if this is a lexical from
7040 outside, as in:
7041 my sub foo; sub { sub foo { } }
7042 */
7043 redo:
7044 name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
7045 if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
7046 pax = PARENT_PAD_INDEX(name);
7047 outcv = CvOUTSIDE(outcv);
7048 assert(outcv);
7049 goto redo;
7050 }
2435fbd5 7051 svspot =
a70c2d56
FC		 7052 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
7053 [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
50278755
FC		 7054 spot = (CV **)svspot;
7055
7056 if (proto) {
7057 assert(proto->op_type == OP_CONST);
7058 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
7059 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
7060 }
7061 else
7062 ps = NULL;
7063
50278755 7064 if (!PL_madskills) {
50278755
FC		 7065 if (proto)
7066 SAVEFREEOP(proto);
7067 if (attrs)
7068 SAVEFREEOP(attrs);
7069 }
7070
b0305fa3 7071 if (PL_parser && PL_parser->error_count) {
50278755 7072 op_free(block);
8ca8859f
FC		 7073 SvREFCNT_dec(PL_compcv);
7074 PL_compcv = 0;
50278755
FC		 7075 goto done;
7076 }
7077
a70c2d56
FC		 7078 if (CvDEPTH(outcv) && CvCLONE(compcv)) {
7079 cv = *spot;
7080 svspot = (SV **)(spot = &clonee);
7081 }
7082 else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
6d5c2147
FC		 7083 cv = *spot;
7084 else {
7085 MAGIC *mg;
81df9f6f
FC		 7086 SvUPGRADE(name, SVt_PVMG);
7087 mg = mg_find(name, PERL_MAGIC_proto);
6d5c2147 7088 assert (SvTYPE(*spot) == SVt_PVCV);
6d5c2147
FC		 7089 if (CvNAMED(*spot))
7090 hek = CvNAME_HEK(*spot);
7091 else {
2e800d79 7092 CvNAME_HEK_set(*spot, hek =
6d5c2147
FC		 7093 share_hek(
7094 PadnamePV(name)+1,
7095 PadnameLEN(name)-1 * (PadnameUTF8(name) ? -1 : 1), 0
2e800d79
FC		 7096 )
7097 );
6d5c2147 7098 }
6d5c2147
FC		 7099 if (mg) {
7100 assert(mg->mg_obj);
7101 cv = (CV *)mg->mg_obj;
7102 }
7103 else {
81df9f6f
FC		 7104 sv_magic(name, &PL_sv_undef, PERL_MAGIC_proto, NULL, 0);
7105 mg = mg_find(name, PERL_MAGIC_proto);
6d5c2147
FC		 7106 }
7107 spot = (CV **)(svspot = &mg->mg_obj);
50278755
FC		 7108 }
7109
50278755
FC		 7110 if (!block || !ps || *ps || attrs
7111 || (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS)
7112#ifdef PERL_MAD
7113 || block->op_type == OP_NULL
eb8433b7 7114#endif
50278755
FC		 7115 )
7116 const_sv = NULL;
7117 else
7118 const_sv = op_const_sv(block, NULL);
eb8433b7 7119
50278755
FC		 7120 if (cv) {
7121 const bool exists = CvROOT(cv) || CvXSUB(cv);
46c461b5 7122
50278755
FC		 7123 /* if the subroutine doesn't exist and wasn't pre-declared
7124 * with a prototype, assume it will be AUTOLOADed,
7125 * skipping the prototype check
7126 */
7127 if (exists || SvPOK(cv))
2435fbd5 7128 cv_ckproto_len_flags(cv, (GV *)name, ps, ps_len, ps_utf8);
50278755
FC		 7129 /* already defined? */
7130 if (exists) {
2b141370
FC		 7131 if (S_already_defined(aTHX_ cv, block, NULL, name, &const_sv))
7132 cv = NULL;
7133 else {
50278755
FC		 7134 if (attrs) goto attrs;
7135 /* just a "sub foo;" when &foo is already defined */
7136 SAVEFREESV(compcv);
7137 goto done;
7138 }
50278755 7139 }
a70c2d56
FC		 7140 else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
7141 cv = NULL;
7142 reusable = TRUE;
7143 }
50278755
FC		 7144 }
7145 if (const_sv) {
7146 SvREFCNT_inc_simple_void_NN(const_sv);
7147 if (cv) {
7148 assert(!CvROOT(cv) && !CvCONST(cv));
7149 cv_forget_slab(cv);
7150 }
7151 else {
7152 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
7153 CvFILE_set_from_cop(cv, PL_curcop);
7154 CvSTASH_set(cv, PL_curstash);
7155 *spot = cv;
7156 }
7157 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
7158 CvXSUBANY(cv).any_ptr = const_sv;
7159 CvXSUB(cv) = const_sv_xsub;
7160 CvCONST_on(cv);
7161 CvISXSUB_on(cv);
7162 if (PL_madskills)
7163 goto install_block;
7164 op_free(block);
7165 SvREFCNT_dec(compcv);
2435fbd5 7166 PL_compcv = NULL;
83a72a15 7167 goto setname;
50278755 7168 }
1f122f9b
FC		 7169 /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
7170 determine whether this sub definition is in the same scope as its
7171 declaration. If this sub definition is inside an inner named pack-
7172 age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
7173 the package sub. So check PadnameOUTER(name) too.
7174 */
7175 if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
10342479
FC		 7176 assert(!CvWEAKOUTSIDE(compcv));
7177 SvREFCNT_dec(CvOUTSIDE(compcv));
7178 CvWEAKOUTSIDE_on(compcv);
7179 }
7180 /* XXX else do we have a circular reference? */
50278755
FC		 7181 if (cv) { /* must reuse cv in case stub is referenced elsewhere */
7182 /* transfer PL_compcv to cv */
7183 if (block
eb8433b7 7184#ifdef PERL_MAD
50278755 7185 && block->op_type != OP_NULL
eb8433b7 7186#endif
50278755 7187 ) {
6d5c2147
FC		 7188 cv_flags_t preserved_flags =
7189 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
50278755
FC		 7190 PADLIST *const temp_padl = CvPADLIST(cv);
7191 CV *const temp_cv = CvOUTSIDE(cv);
10342479
FC		 7192 const cv_flags_t other_flags =
7193 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
50278755
FC		 7194 OP * const cvstart = CvSTART(cv);
7195
50278755
FC		 7196 SvPOK_off(cv);
7197 CvFLAGS(cv) =
6d5c2147 7198 CvFLAGS(compcv) | preserved_flags;
50278755
FC		 7199 CvOUTSIDE(cv) = CvOUTSIDE(compcv);
7200 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
7201 CvPADLIST(cv) = CvPADLIST(compcv);
7202 CvOUTSIDE(compcv) = temp_cv;
7203 CvPADLIST(compcv) = temp_padl;
7204 CvSTART(cv) = CvSTART(compcv);
7205 CvSTART(compcv) = cvstart;
10342479
FC		 7206 CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
7207 CvFLAGS(compcv) |= other_flags;
50278755
FC		 7208
7209 if (CvFILE(cv) && CvDYNFILE(cv)) {
7210 Safefree(CvFILE(cv));
7211 }
7212
7213 /* inner references to compcv must be fixed up ... */
7214 pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
7215 if (PERLDB_INTER)/* Advice debugger on the new sub. */
7216 ++PL_sub_generation;
7217 }
7218 else {
7219 /* Might have had built-in attributes applied -- propagate them. */
7220 CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
7221 }
7222 /* ... before we throw it away */
7223 SvREFCNT_dec(compcv);
2435fbd5 7224 PL_compcv = compcv = cv;
50278755
FC		 7225 }
7226 else {
7227 cv = compcv;
7228 *spot = cv;
6d5c2147 7229 }
83a72a15 7230 setname:
6d5c2147 7231 if (!CvNAME_HEK(cv)) {
2e800d79 7232 CvNAME_HEK_set(cv,
6d5c2147
FC		 7233 hek
7234 ? share_hek_hek(hek)
7235 : share_hek(PadnamePV(name)+1,
2435fbd5 7236 PadnameLEN(name)-1 * (PadnameUTF8(name) ? -1 : 1),
2e800d79
FC		 7237 0)
7238 );
50278755 7239 }
83a72a15
FC		 7240 if (const_sv) goto clone;
7241
50278755
FC		 7242 CvFILE_set_from_cop(cv, PL_curcop);
7243 CvSTASH_set(cv, PL_curstash);
7244
7245 if (ps) {
7246 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
7247 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
7248 }
7249
7250 install_block:
7251 if (!block)
7252 goto attrs;
7253
7254 /* If we assign an optree to a PVCV, then we've defined a subroutine that
7255 the debugger could be able to set a breakpoint in, so signal to
7256 pp_entereval that it should not throw away any saved lines at scope
7257 exit. */
7258
7259 PL_breakable_sub_gen++;
7260 /* This makes sub {}; work as expected. */
7261 if (block->op_type == OP_STUB) {
7262 OP* const newblock = newSTATEOP(0, NULL, 0);
7263#ifdef PERL_MAD
7264 op_getmad(block,newblock,'B');
7265#else
7266 op_free(block);
7267#endif
7268 block = newblock;
7269 }
7270 CvROOT(cv) = CvLVALUE(cv)
7271 ? newUNOP(OP_LEAVESUBLV, 0,
7272 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
7273 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
7274 CvROOT(cv)->op_private |= OPpREFCOUNTED;
7275 OpREFCNT_set(CvROOT(cv), 1);
7276 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
7277 itself has a refcount. */
7278 CvSLABBED_off(cv);
7279 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
7280 CvSTART(cv) = LINKLIST(CvROOT(cv));
7281 CvROOT(cv)->op_next = 0;
7282 CALL_PEEP(CvSTART(cv));
7283 finalize_optree(CvROOT(cv));
7284
7285 /* now that optimizer has done its work, adjust pad values */
7286
50278755 7287 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
50278755
FC		 7288
7289 if (CvCLONE(cv)) {
7290 assert(!CvCONST(cv));
7291 if (ps && !*ps && op_const_sv(block, cv))
7292 CvCONST_on(cv);
7293 }
7294
7295 attrs:
7296 if (attrs) {
7297 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
ad0dc73b 7298 apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
50278755
FC		 7299 }
7300
7301 if (block) {
7302 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
7303 SV * const tmpstr = sv_newmortal();
7304 GV * const db_postponed = gv_fetchpvs("DB::postponed",
7305 GV_ADDMULTI, SVt_PVHV);
7306 HV *hv;
7307 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
7308 CopFILE(PL_curcop),
7309 (long)PL_subline,
7310 (long)CopLINE(PL_curcop));
a56613a9
FC		 7311 if (HvNAME_HEK(PL_curstash)) {
7312 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
7313 sv_catpvs(tmpstr, "::");
7314 }
7315 else sv_setpvs(tmpstr, "__ANON__::");
2435fbd5
FC		 7316 sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
7317 PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
50278755
FC		 7318 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
7319 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
7320 hv = GvHVn(db_postponed);
7321 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
7322 CV * const pcv = GvCV(db_postponed);
7323 if (pcv) {
7324 dSP;
7325 PUSHMARK(SP);
7326 XPUSHs(tmpstr);
7327 PUTBACK;
7328 call_sv(MUTABLE_SV(pcv), G_DISCARD);
7329 }
7330 }
7331 }
7332 }
7333
a70c2d56
FC		 7334 clone:
7335 if (clonee) {
7336 assert(CvDEPTH(outcv));
7337 spot = (CV **)
7338 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
7339 if (reusable) cv_clone_into(clonee, *spot);
7340 else *spot = cv_clone(clonee);
fc2b2dca 7341 SvREFCNT_dec_NN(clonee);
a70c2d56
FC		 7342 cv = *spot;
7343 SvPADMY_on(cv);
7344 }
7345 if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
7346 PADOFFSET depth = CvDEPTH(outcv);
7347 while (--depth) {
7348 SV *oldcv;
7349 svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
7350 oldcv = *svspot;
7351 *svspot = SvREFCNT_inc_simple_NN(cv);
7352 SvREFCNT_dec(oldcv);
7353 }
7354 }
7355
50278755
FC		 7356 done:
7357 if (PL_parser)
7358 PL_parser->copline = NOLINE;
2435fbd5
FC		 7359 LEAVE_SCOPE(floor);
7360 if (o) op_free(o);
50278755 7361 return cv;
09bef843
SB		 7362}
7363
748a9306 7364CV *
09bef843
SB		 7365Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
7366{
7e68c38b
FC		 7367 return newATTRSUB_flags(floor, o, proto, attrs, block, 0);
7368}
7369
7370CV *
7371Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
7372 OP *block, U32 flags)
7373{
27da23d5 7374 dVAR;
83ee9e09 7375 GV *gv;
5c144d81 7376 const char *ps;
52a9a866 7377 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
e0260a5b 7378 U32 ps_utf8 = 0;
eb578fdb 7379 CV *cv = NULL;
beab0874 7380 SV *const_sv;
a73ef99b 7381 const bool ec = PL_parser && PL_parser->error_count;
b48b272a
NC		 7382 /* If the subroutine has no body, no attributes, and no builtin attributes
7383 then it's just a sub declaration, and we may be able to get away with
7384 storing with a placeholder scalar in the symbol table, rather than a
7385 full GV and CV. If anything is present then it will take a full CV to
7386 store it. */
7387 const I32 gv_fetch_flags
a73ef99b
FC		 7388 = ec ? GV_NOADD_NOINIT :
7389 (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
eb8433b7 7390 || PL_madskills)
b48b272a 7391 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
6e948d54 7392 STRLEN namlen = 0;
7e68c38b
FC		 7393 const bool o_is_gv = flags & 1;
7394 const char * const name =
7395 o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
ed4a8a9b 7396 bool has_name;
7e68c38b 7397 bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
7aef8e5b 7398#ifdef PERL_DEBUG_READONLY_OPS
3107b51f
FC		 7399 OPSLAB *slab = NULL;
7400#endif
8e742a20
MHM		 7401
7402 if (proto) {
7403 assert(proto->op_type == OP_CONST);
4ea561bc 7404 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
e0260a5b 7405 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
8e742a20
MHM		 7406 }
7407 else
bd61b366 7408 ps = NULL;
8e742a20 7409
7e68c38b
FC		 7410 if (o_is_gv) {
7411 gv = (GV*)o;
7412 o = NULL;
7413 has_name = TRUE;
7414 } else if (name) {
7415 gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
ed4a8a9b
NC		 7416 has_name = TRUE;
7417 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
aec46f14 7418 SV * const sv = sv_newmortal();
c99da370
JH		 7419 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
7420 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
83ee9e09 7421 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
ed4a8a9b
NC		 7422 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
7423 has_name = TRUE;
c1754fce
NC		 7424 } else if (PL_curstash) {
7425 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
ed4a8a9b 7426 has_name = FALSE;
c1754fce
NC		 7427 } else {
7428 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
ed4a8a9b 7429 has_name = FALSE;
c1754fce 7430 }
83ee9e09 7431
eb8433b7
NC		 7432 if (!PL_madskills) {
7433 if (o)
7434 SAVEFREEOP(o);
7435 if (proto)
7436 SAVEFREEOP(proto);
7437 if (attrs)
7438 SAVEFREEOP(attrs);
7439 }
3fe9a6f1 7440
a73ef99b
FC		 7441 if (ec) {
7442 op_free(block);
4d2dfd15
FC		 7443 if (name) SvREFCNT_dec(PL_compcv);
7444 else cv = PL_compcv;
9ffcdca1 7445 PL_compcv = 0;
a73ef99b
FC		 7446 if (name && block) {
7447 const char *s = strrchr(name, ':');
7448 s = s ? s+1 : name;
7449 if (strEQ(s, "BEGIN")) {
a73ef99b 7450 if (PL_in_eval & EVAL_KEEPERR)
eed484f9 7451 Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
a73ef99b 7452 else {
eed484f9 7453 SV * const errsv = ERRSV;
a73ef99b 7454 /* force display of errors found but not reported */
eed484f9
DD		 7455 sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
7456 Perl_croak_nocontext("%"SVf, SVfARG(errsv));
a73ef99b
FC		 7457 }
7458 }
7459 }
a73ef99b
FC		 7460 goto done;
7461 }
7462
09bef843 7463 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
55d729e4
GS		 7464 maximum a prototype before. */
7465 if (SvTYPE(gv) > SVt_NULL) {
105ff74c
FC		 7466 cv_ckproto_len_flags((const CV *)gv,
7467 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
7468 ps_len, ps_utf8);
55d729e4 7469 }
e0260a5b 7470 if (ps) {
ad64d0ec 7471 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
e0260a5b
BF		 7472 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(gv));
7473 }
55d729e4 7474 else
ad64d0ec 7475 sv_setiv(MUTABLE_SV(gv), -1);
e1a479c5 7476
3280af22
NIS		 7477 SvREFCNT_dec(PL_compcv);
7478 cv = PL_compcv = NULL;
beab0874 7479 goto done;
55d729e4
GS		 7480 }
7481
601f1833 7482 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
beab0874 7483
eb8433b7
NC		 7484 if (!block || !ps || *ps || attrs
7485 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
7486#ifdef PERL_MAD
7487 || block->op_type == OP_NULL
7488#endif
7489 )
a0714e2c 7490 const_sv = NULL;
beab0874 7491 else
601f1833 7492 const_sv = op_const_sv(block, NULL);
beab0874
JT		 7493
7494 if (cv) {
6867be6d 7495 const bool exists = CvROOT(cv) || CvXSUB(cv);
5bd07a3d 7496
60ed1d8c
GS		 7497 /* if the subroutine doesn't exist and wasn't pre-declared
7498 * with a prototype, assume it will be AUTOLOADed,
7499 * skipping the prototype check
7500 */
7501 if (exists || SvPOK(cv))
dab1c735 7502 cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
68dc0745 7503 /* already defined (or promised)? */
60ed1d8c 7504 if (exists || GvASSUMECV(gv)) {
2b141370
FC		 7505 if (S_already_defined(aTHX_ cv, block, o, NULL, &const_sv))
7506 cv = NULL;
7507 else {
fff96ff7 7508 if (attrs) goto attrs;
aa689395 7509 /* just a "sub foo;" when &foo is already defined */
3280af22 7510 SAVEFREESV(PL_compcv);
aa689395 7511 goto done;
7512 }
79072805
LW		 7513 }
7514 }
beab0874 7515 if (const_sv) {
f84c484e 7516 SvREFCNT_inc_simple_void_NN(const_sv);
beab0874 7517 if (cv) {
0768512c 7518 assert(!CvROOT(cv) && !CvCONST(cv));
8be227ab 7519 cv_forget_slab(cv);
ad64d0ec 7520 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
beab0874
JT		 7521 CvXSUBANY(cv).any_ptr = const_sv;
7522 CvXSUB(cv) = const_sv_xsub;
7523 CvCONST_on(cv);
d04ba589 7524 CvISXSUB_on(cv);
beab0874
JT		 7525 }
7526 else {
c43ae56f 7527 GvCV_set(gv, NULL);
9c0a6090 7528 cv = newCONSTSUB_flags(
6e948d54 7529 NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
9c0a6090
FC		 7530 const_sv
7531 );
7ad40bcb 7532 }
eb8433b7
NC		 7533 if (PL_madskills)
7534 goto install_block;
beab0874
JT		 7535 op_free(block);
7536 SvREFCNT_dec(PL_compcv);
7537 PL_compcv = NULL;
beab0874
JT		 7538 goto done;
7539 }
09330df8
Z		 7540 if (cv) { /* must reuse cv if autoloaded */
7541 /* transfer PL_compcv to cv */
7542 if (block
eb8433b7 7543#ifdef PERL_MAD
09330df8 7544 && block->op_type != OP_NULL
eb8433b7 7545#endif
09330df8 7546 ) {
eac910c8 7547 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
b70d5558 7548 PADLIST *const temp_av = CvPADLIST(cv);
437388a9 7549 CV *const temp_cv = CvOUTSIDE(cv);
e52de15a
FC		 7550 const cv_flags_t other_flags =
7551 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
8be227ab 7552 OP * const cvstart = CvSTART(cv);
437388a9 7553
f6894bc8 7554 CvGV_set(cv,gv);
437388a9
NC		 7555 assert(!CvCVGV_RC(cv));
7556 assert(CvGV(cv) == gv);
7557
7558 SvPOK_off(cv);
eac910c8 7559 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs;
09330df8
Z		 7560 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
7561 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
09330df8 7562 CvPADLIST(cv) = CvPADLIST(PL_compcv);
437388a9
NC		 7563 CvOUTSIDE(PL_compcv) = temp_cv;
7564 CvPADLIST(PL_compcv) = temp_av;
8be227ab
FC		 7565 CvSTART(cv) = CvSTART(PL_compcv);
7566 CvSTART(PL_compcv) = cvstart;
e52de15a
FC		 7567 CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
7568 CvFLAGS(PL_compcv) |= other_flags;
437388a9 7569
bad4ae38 7570 if (CvFILE(cv) && CvDYNFILE(cv)) {
437388a9
NC		 7571 Safefree(CvFILE(cv));
7572 }
437388a9
NC		 7573 CvFILE_set_from_cop(cv, PL_curcop);
7574 CvSTASH_set(cv, PL_curstash);
7575
09330df8
Z		 7576 /* inner references to PL_compcv must be fixed up ... */
7577 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
7578 if (PERLDB_INTER)/* Advice debugger on the new sub. */
7579 ++PL_sub_generation;
09bef843
SB		 7580 }
7581 else {
09330df8
Z		 7582 /* Might have had built-in attributes applied -- propagate them. */
7583 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
09bef843 7584 }
282f25c9 7585 /* ... before we throw it away */
3280af22 7586 SvREFCNT_dec(PL_compcv);
b5c19bd7 7587 PL_compcv = cv;
a0d0e21e
LW		 7588 }
7589 else {
3280af22 7590 cv = PL_compcv;
44a8e56a 7591 if (name) {
c43ae56f 7592 GvCV_set(gv, cv);
44a8e56a 7593 GvCVGEN(gv) = 0;
03d9f026
FC		 7594 if (HvENAME_HEK(GvSTASH(gv)))
7595 /* sub Foo::bar { (shift)+1 } */
978a498e 7596 gv_method_changed(gv);
44a8e56a 7597 }
a0d0e21e 7598 }
09330df8 7599 if (!CvGV(cv)) {
b3f91e91 7600 CvGV_set(cv, gv);
09330df8 7601 CvFILE_set_from_cop(cv, PL_curcop);
c68d9564 7602 CvSTASH_set(cv, PL_curstash);
09330df8 7603 }
8990e307 7604
e0260a5b 7605 if (ps) {
ad64d0ec 7606 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
e0260a5b
BF		 7607 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
7608 }
4633a7c4 7609
eb8433b7 7610 install_block:
beab0874 7611 if (!block)
fb834abd 7612 goto attrs;
a0d0e21e 7613
aac018bb
NC		 7614 /* If we assign an optree to a PVCV, then we've defined a subroutine that
7615 the debugger could be able to set a breakpoint in, so signal to
7616 pp_entereval that it should not throw away any saved lines at scope
7617 exit. */
7618
fd06b02c 7619 PL_breakable_sub_gen++;
69b22cd1
FC		 7620 /* This makes sub {}; work as expected. */
7621 if (block->op_type == OP_STUB) {
1496a290 7622 OP* const newblock = newSTATEOP(0, NULL, 0);
eb8433b7
NC		 7623#ifdef PERL_MAD
7624 op_getmad(block,newblock,'B');
7625#else
09c2fd24 7626 op_free(block);
eb8433b7
NC		 7627#endif
7628 block = newblock;
7766f137 7629 }
69b22cd1
FC		 7630 CvROOT(cv) = CvLVALUE(cv)
7631 ? newUNOP(OP_LEAVESUBLV, 0,
7632 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
7633 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
7766f137
GS		 7634 CvROOT(cv)->op_private |= OPpREFCOUNTED;
7635 OpREFCNT_set(CvROOT(cv), 1);
8be227ab
FC		 7636 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
7637 itself has a refcount. */
7638 CvSLABBED_off(cv);
7639 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
7aef8e5b 7640#ifdef PERL_DEBUG_READONLY_OPS
3107b51f 7641 slab = (OPSLAB *)CvSTART(cv);
8be227ab 7642#endif
7766f137
GS		 7643 CvSTART(cv) = LINKLIST(CvROOT(cv));
7644 CvROOT(cv)->op_next = 0;
a2efc822 7645 CALL_PEEP(CvSTART(cv));
d164302a 7646 finalize_optree(CvROOT(cv));
7766f137
GS		 7647
7648 /* now that optimizer has done its work, adjust pad values */
54310121 7649
dd2155a4
DM		 7650 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
7651
7652 if (CvCLONE(cv)) {
beab0874
JT		 7653 assert(!CvCONST(cv));
7654 if (ps && !*ps && op_const_sv(block, cv))
7655 CvCONST_on(cv);
a0d0e21e 7656 }
79072805 7657
fb834abd
FC		 7658 attrs:
7659 if (attrs) {
7660 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
7661 HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
12d3c230 7662 if (!name) SAVEFREESV(cv);
ad0dc73b 7663 apply_attrs(stash, MUTABLE_SV(cv), attrs);
12d3c230 7664 if (!name) SvREFCNT_inc_simple_void_NN(cv);
fb834abd
FC		 7665 }
7666
7667 if (block && has_name) {
3280af22 7668 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
c4420975 7669 SV * const tmpstr = sv_newmortal();
5c1737d1
NC		 7670 GV * const db_postponed = gv_fetchpvs("DB::postponed",
7671 GV_ADDMULTI, SVt_PVHV);
44a8e56a 7672 HV *hv;
b081dd7e
NC		 7673 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
7674 CopFILE(PL_curcop),
7675 (long)PL_subline,
7676 (long)CopLINE(PL_curcop));
bd61b366 7677 gv_efullname3(tmpstr, gv, NULL);
04fe65b0 7678 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
c60dbbc3 7679 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
44a8e56a 7680 hv = GvHVn(db_postponed);
c60dbbc3 7681 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
551405c4
AL		 7682 CV * const pcv = GvCV(db_postponed);
7683 if (pcv) {
7684 dSP;
7685 PUSHMARK(SP);
7686 XPUSHs(tmpstr);
7687 PUTBACK;
ad64d0ec 7688 call_sv(MUTABLE_SV(pcv), G_DISCARD);
551405c4 7689 }
44a8e56a 7690 }
7691 }
79072805 7692
13765c85 7693 if (name && ! (PL_parser && PL_parser->error_count))
d699ecb7 7694 process_special_blocks(floor, name, gv, cv);
33fb7a6e 7695 }
ed094faf 7696
33fb7a6e 7697 done:
53a7735b
DM		 7698 if (PL_parser)
7699 PL_parser->copline = NOLINE;
33fb7a6e 7700 LEAVE_SCOPE(floor);
7aef8e5b 7701#ifdef PERL_DEBUG_READONLY_OPS
3107b51f
FC		 7702 /* Watch out for BEGIN blocks */
7703 if (slab && gv && isGV(gv) && GvCV(gv)) Slab_to_ro(slab);
7704#endif
33fb7a6e
NC		 7705 return cv;
7706}
ed094faf 7707
33fb7a6e 7708STATIC void
d699ecb7
FC		 7709S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
7710 GV *const gv,
33fb7a6e
NC		 7711 CV *const cv)
7712{
7713 const char *const colon = strrchr(fullname,':');
7714 const char *const name = colon ? colon + 1 : fullname;
7715
7918f24d
NC		 7716 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
7717
33fb7a6e 7718 if (*name == 'B') {
6952d67e 7719 if (strEQ(name, "BEGIN")) {
6867be6d 7720 const I32 oldscope = PL_scopestack_ix;
d699ecb7 7721 if (floor) LEAVE_SCOPE(floor);
28757baa 7722 ENTER;
57843af0
GS		 7723 SAVECOPFILE(&PL_compiling);
7724 SAVECOPLINE(&PL_compiling);
16c63275 7725 SAVEVPTR(PL_curcop);
28757baa 7726
a58fb6f9 7727 DEBUG_x( dump_sub(gv) );
ad64d0ec 7728 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
c43ae56f 7729 GvCV_set(gv,0); /* cv has been hijacked */
3280af22 7730 call_list(oldscope, PL_beginav);
a6006777 7731
623e6609 7732 CopHINTS_set(&PL_compiling, PL_hints);
28757baa 7733 LEAVE;
7734 }
33fb7a6e
NC		 7735 else
7736 return;
7737 } else {
7738 if (*name == 'E') {
7739 if strEQ(name, "END") {
a58fb6f9 7740 DEBUG_x( dump_sub(gv) );
ad64d0ec 7741 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
33fb7a6e
NC		 7742 } else
7743 return;
7744 } else if (*name == 'U') {
7745 if (strEQ(name, "UNITCHECK")) {
7746 /* It's never too late to run a unitcheck block */
ad64d0ec 7747 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
33fb7a6e
NC		 7748 }
7749 else
7750 return;
7751 } else if (*name == 'C') {
7752 if (strEQ(name, "CHECK")) {
a2a5de95 7753 if (PL_main_start)
dcbac5bb 7754 /* diag_listed_as: Too late to run %s block */
a2a5de95
NC		 7755 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
7756 "Too late to run CHECK block");
ad64d0ec 7757 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
33fb7a6e
NC		 7758 }
7759 else
7760 return;
7761 } else if (*name == 'I') {
7762 if (strEQ(name, "INIT")) {
a2a5de95 7763 if (PL_main_start)
dcbac5bb 7764 /* diag_listed_as: Too late to run %s block */
a2a5de95
NC		 7765 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
7766 "Too late to run INIT block");
ad64d0ec 7767 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
33fb7a6e
NC		 7768 }
7769 else
7770 return;
7771 } else
7772 return;
a58fb6f9 7773 DEBUG_x( dump_sub(gv) );
c43ae56f 7774 GvCV_set(gv,0); /* cv has been hijacked */
79072805 7775 }
79072805
LW		 7776}
7777
954c1994
GS		 7778/*
7779=for apidoc newCONSTSUB
7780
3453414d
BF		 7781See L</newCONSTSUB_flags>.
7782
7783=cut
7784*/
7785
7786CV *
7787Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
7788{
9c0a6090 7789 return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
3453414d
BF		 7790}
7791
7792/*
7793=for apidoc newCONSTSUB_flags
7794
954c1994
GS		 7795Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
7796eligible for inlining at compile-time.
7797
3453414d
BF		 7798Currently, the only useful value for C<flags> is SVf_UTF8.
7799
be8851fc
NC		 7800The newly created subroutine takes ownership of a reference to the passed in
7801SV.
7802
99ab892b
NC		 7803Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
7804which won't be called if used as a destructor, but will suppress the overhead
7805of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
7806compile time.)
7807
954c1994
GS		 7808=cut
7809*/
7810
beab0874 7811CV *
9c0a6090
FC		 7812Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
7813 U32 flags, SV *sv)
5476c433 7814{
27da23d5 7815 dVAR;
beab0874 7816 CV* cv;
cbf82dd0 7817#ifdef USE_ITHREADS
54d012c6 7818 const char *const file = CopFILE(PL_curcop);
cbf82dd0
NC		 7819#else
7820 SV *const temp_sv = CopFILESV(PL_curcop);
def18e4c 7821 const char *const file = temp_sv ? SvPV_nolen_const(temp_sv) : NULL;
cbf82dd0 7822#endif
5476c433 7823
11faa288 7824 ENTER;
11faa288 7825
401667e9
DM		 7826 if (IN_PERL_RUNTIME) {
7827 /* at runtime, it's not safe to manipulate PL_curcop: it may be
7828 * an op shared between threads. Use a non-shared COP for our
7829 * dirty work */
7830 SAVEVPTR(PL_curcop);
08f1b312
FC		 7831 SAVECOMPILEWARNINGS();
7832 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
401667e9
DM		 7833 PL_curcop = &PL_compiling;
7834 }
f4dd75d9 7835 SAVECOPLINE(PL_curcop);
53a7735b 7836 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
f4dd75d9
GS		 7837
7838 SAVEHINTS();
3280af22 7839 PL_hints &= ~HINT_BLOCK_SCOPE;
11faa288
GS		 7840
7841 if (stash) {
03d9f026 7842 SAVEGENERICSV(PL_curstash);
03d9f026 7843 PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
11faa288 7844 }
5476c433 7845
95934569
FC		 7846 /* Protect sv against leakage caused by fatal warnings. */
7847 if (sv) SAVEFREESV(sv);
7848
bad4ae38 7849 /* file becomes the CvFILE. For an XS, it's usually static storage,
cbf82dd0
NC		 7850 and so doesn't get free()d. (It's expected to be from the C pre-
7851 processor __FILE__ directive). But we need a dynamically allocated one,
77004dee 7852 and we need it to get freed. */
8e1fa37c 7853 cv = newXS_len_flags(name, len, const_sv_xsub, file ? file : "", "",
8f82b567 7854 &sv, XS_DYNAMIC_FILENAME | flags);
95934569 7855 CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
beab0874 7856 CvCONST_on(cv);
5476c433 7857
11faa288 7858 LEAVE;
beab0874
JT		 7859
7860 return cv;
5476c433
JD		 7861}
7862
77004dee
NC		 7863CV *
7864Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
7865 const char *const filename, const char *const proto,
7866 U32 flags)
7867{
032a0447
FC		 7868 PERL_ARGS_ASSERT_NEWXS_FLAGS;
7869 return newXS_len_flags(
8f82b567 7870 name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
032a0447
FC		 7871 );
7872}
7873
7874CV *
7875Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
7876 XSUBADDR_t subaddr, const char *const filename,
8f82b567
FC		 7877 const char *const proto, SV **const_svp,
7878 U32 flags)
032a0447 7879{
3453414d 7880 CV *cv;
77004dee 7881
032a0447 7882 PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
7918f24d 7883
3453414d 7884 {
9b566a5e
DD		 7885 GV * const gv = gv_fetchpvn(
7886 name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
7887 name ? len : PL_curstash ? sizeof("__ANON__") - 1:
7888 sizeof("__ANON__::__ANON__") - 1,
7889 GV_ADDMULTI | flags, SVt_PVCV);
3453414d
BF		 7890
7891 if (!subaddr)
7892 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
7893
7894 if ((cv = (name ? GvCV(gv) : NULL))) {
7895 if (GvCVGEN(gv)) {
7896 /* just a cached method */
7897 SvREFCNT_dec(cv);
7898 cv = NULL;
7899 }
7900 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
7901 /* already defined (or promised) */
18225a01 7902 /* Redundant check that allows us to avoid creating an SV
156d738f
FC		 7903 most of the time: */
7904 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
156d738f 7905 report_redefined_cv(newSVpvn_flags(
46538741 7906 name,len,(flags&SVf_UTF8)|SVs_TEMP
156d738f
FC		 7907 ),
7908 cv, const_svp);
3453414d 7909 }
fc2b2dca 7910 SvREFCNT_dec_NN(cv);
3453414d
BF		 7911 cv = NULL;
7912 }
7913 }
7914
7915 if (cv) /* must reuse cv if autoloaded */
7916 cv_undef(cv);
7917 else {
7918 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
7919 if (name) {
7920 GvCV_set(gv,cv);
7921 GvCVGEN(gv) = 0;
03d9f026 7922 if (HvENAME_HEK(GvSTASH(gv)))
978a498e 7923 gv_method_changed(gv); /* newXS */
3453414d
BF		 7924 }
7925 }
7926 if (!name)
7927 CvANON_on(cv);
7928 CvGV_set(cv, gv);
7929 (void)gv_fetchfile(filename);
7930 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
7931 an external constant string */
7932 assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
7933 CvISXSUB_on(cv);
7934 CvXSUB(cv) = subaddr;
7935
7936 if (name)
d699ecb7 7937 process_special_blocks(0, name, gv, cv);
3453414d
BF		 7938 }
7939
77004dee 7940 if (flags & XS_DYNAMIC_FILENAME) {
bad4ae38
FC		 7941 CvFILE(cv) = savepv(filename);
7942 CvDYNFILE_on(cv);
77004dee 7943 }
bad4ae38 7944 sv_setpv(MUTABLE_SV(cv), proto);
77004dee
NC		 7945 return cv;
7946}
7947
186a5ba8
FC		 7948CV *
7949Perl_newSTUB(pTHX_ GV *gv, bool fake)
7950{
eb578fdb 7951 CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
186a5ba8
FC		 7952 PERL_ARGS_ASSERT_NEWSTUB;
7953 assert(!GvCVu(gv));
7954 GvCV_set(gv, cv);
7955 GvCVGEN(gv) = 0;
7956 if (!fake && HvENAME_HEK(GvSTASH(gv)))
978a498e 7957 gv_method_changed(gv);
186a5ba8
FC		 7958 CvGV_set(cv, gv);
7959 CvFILE_set_from_cop(cv, PL_curcop);
7960 CvSTASH_set(cv, PL_curstash);
7961 GvMULTI_on(gv);
7962 return cv;
7963}
7964
954c1994
GS		 7965/*
7966=for apidoc U||newXS
7967
77004dee
NC		 7968Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
7969static storage, as it is used directly as CvFILE(), without a copy being made.
954c1994
GS		 7970
7971=cut
7972*/
7973
57d3b86d 7974CV *
bfed75c6 7975Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
a0d0e21e 7976{
7918f24d 7977 PERL_ARGS_ASSERT_NEWXS;
ce9f52ad
FC		 7978 return newXS_len_flags(
7979 name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
7980 );
79072805
LW		 7981}
7982
eb8433b7
NC		 7983#ifdef PERL_MAD
7984OP *
7985#else
79072805 7986void
eb8433b7 7987#endif
864dbfa3 7988Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
79072805 7989{
97aff369 7990 dVAR;
eb578fdb 7991 CV *cv;
eb8433b7
NC		 7992#ifdef PERL_MAD
7993 OP* pegop = newOP(OP_NULL, 0);
7994#endif
79072805 7995
2c658e55
FC		 7996 GV *gv;
7997
7998 if (PL_parser && PL_parser->error_count) {
7999 op_free(block);
8000 goto finish;
8001 }
8002
8003 gv = o
f776e3cd 8004 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
fafc274c 8005 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
0bd48802 8006
a5f75d66 8007 GvMULTI_on(gv);
155aba94 8008 if ((cv = GvFORM(gv))) {
599cee73 8009 if (ckWARN(WARN_REDEFINE)) {
6867be6d 8010 const line_t oldline = CopLINE(PL_curcop);
53a7735b
DM		 8011 if (PL_parser && PL_parser->copline != NOLINE)
8012 CopLINE_set(PL_curcop, PL_parser->copline);
ee6d2783
NC		 8013 if (o) {
8014 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
8015 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
8016 } else {
dcbac5bb 8017 /* diag_listed_as: Format %s redefined */
ee6d2783
NC		 8018 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
8019 "Format STDOUT redefined");
8020 }
57843af0 8021 CopLINE_set(PL_curcop, oldline);
79072805 8022 }
8990e307 8023 SvREFCNT_dec(cv);
79072805 8024 }
3280af22 8025 cv = PL_compcv;
2c658e55 8026 GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
b3f91e91 8027 CvGV_set(cv, gv);
a636914a 8028 CvFILE_set_from_cop(cv, PL_curcop);
79072805 8029
a0d0e21e 8030
dd2155a4 8031 pad_tidy(padtidy_FORMAT);
79072805 8032 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
7934575e
GS		 8033 CvROOT(cv)->op_private |= OPpREFCOUNTED;
8034 OpREFCNT_set(CvROOT(cv), 1);
79072805
LW		 8035 CvSTART(cv) = LINKLIST(CvROOT(cv));
8036 CvROOT(cv)->op_next = 0;
a2efc822 8037 CALL_PEEP(CvSTART(cv));
aee4f072 8038 finalize_optree(CvROOT(cv));
2c658e55
FC		 8039 cv_forget_slab(cv);
8040
8041 finish:
eb8433b7
NC		 8042#ifdef PERL_MAD
8043 op_getmad(o,pegop,'n');
8044 op_getmad_weak(block, pegop, 'b');
8045#else
11343788 8046 op_free(o);
eb8433b7 8047#endif
53a7735b
DM		 8048 if (PL_parser)
8049 PL_parser->copline = NOLINE;
8990e307 8050 LEAVE_SCOPE(floor);
eb8433b7
NC		 8051#ifdef PERL_MAD
8052 return pegop;
8053#endif
79072805
LW		 8054}
8055
8056OP *
864dbfa3 8057Perl_newANONLIST(pTHX_ OP *o)
79072805 8058{
78c72037 8059 return convert(OP_ANONLIST, OPf_SPECIAL, o);
79072805
LW		 8060}
8061
8062OP *
864dbfa3 8063Perl_newANONHASH(pTHX_ OP *o)
79072805 8064{
78c72037 8065 return convert(OP_ANONHASH, OPf_SPECIAL, o);
a0d0e21e
LW		 8066}
8067
8068OP *
864dbfa3 8069Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
a0d0e21e 8070{
5f66b61c 8071 return newANONATTRSUB(floor, proto, NULL, block);
09bef843
SB		 8072}
8073
8074OP *
8075Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
8076{
a0d0e21e 8077 return newUNOP(OP_REFGEN, 0,
09bef843 8078 newSVOP(OP_ANONCODE, 0,
ad64d0ec 8079 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
79072805
LW		 8080}
8081
8082OP *
864dbfa3 8083Perl_oopsAV(pTHX_ OP *o)
79072805 8084{
27da23d5 8085 dVAR;
7918f24d
NC		 8086
8087 PERL_ARGS_ASSERT_OOPSAV;
8088
ed6116ce
LW		 8089 switch (o->op_type) {
8090 case OP_PADSV:
8091 o->op_type = OP_PADAV;
22c35a8c 8092 o->op_ppaddr = PL_ppaddr[OP_PADAV];
51e247a3 8093 return ref(o, OP_RV2AV);
b2ffa427 8094
ed6116ce 8095 case OP_RV2SV:
79072805 8096 o->op_type = OP_RV2AV;
22c35a8c 8097 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
79072805 8098 ref(o, OP_RV2AV);
ed6116ce
LW		 8099 break;
8100
8101 default:
9b387841 8102 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
ed6116ce
LW		 8103 break;
8104 }
79072805
LW		 8105 return o;
8106}
8107
8108OP *
864dbfa3 8109Perl_oopsHV(pTHX_ OP *o)
79072805 8110{
27da23d5 8111 dVAR;
7918f24d
NC		 8112
8113 PERL_ARGS_ASSERT_OOPSHV;
8114
ed6116ce
LW		 8115 switch (o->op_type) {
8116 case OP_PADSV:
8117 case OP_PADAV:
8118 o->op_type = OP_PADHV;
22c35a8c 8119 o->op_ppaddr = PL_ppaddr[OP_PADHV];
51e247a3 8120 return ref(o, OP_RV2HV);
ed6116ce
LW		 8121
8122 case OP_RV2SV:
8123 case OP_RV2AV:
79072805 8124 o->op_type = OP_RV2HV;
22c35a8c 8125 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
79072805 8126 ref(o, OP_RV2HV);
ed6116ce
LW		 8127 break;
8128
8129 default:
9b387841 8130 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
ed6116ce
LW		 8131 break;
8132 }
79072805
LW		 8133 return o;
8134}
8135
8136OP *
864dbfa3 8137Perl_newAVREF(pTHX_ OP *o)
79072805 8138{
27da23d5 8139 dVAR;
7918f24d
NC		 8140
8141 PERL_ARGS_ASSERT_NEWAVREF;
8142
ed6116ce
LW		 8143 if (o->op_type == OP_PADANY) {
8144 o->op_type = OP_PADAV;
22c35a8c 8145 o->op_ppaddr = PL_ppaddr[OP_PADAV];
93a17b20 8146 return o;
ed6116ce 8147 }
a2a5de95 8148 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
d1d15184 8149 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
a2a5de95 8150 "Using an array as a reference is deprecated");
a1063b2d 8151 }
79072805
LW		 8152 return newUNOP(OP_RV2AV, 0, scalar(o));
8153}
8154
8155OP *
864dbfa3 8156Perl_newGVREF(pTHX_ I32 type, OP *o)
79072805 8157{
82092f1d 8158 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
a0d0e21e 8159 return newUNOP(OP_NULL, 0, o);
748a9306 8160 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
79072805
LW		 8161}
8162
8163OP *
864dbfa3 8164Perl_newHVREF(pTHX_ OP *o)
79072805 8165{
27da23d5 8166 dVAR;
7918f24d
NC		 8167
8168 PERL_ARGS_ASSERT_NEWHVREF;
8169
ed6116ce
LW		 8170 if (o->op_type == OP_PADANY) {
8171 o->op_type = OP_PADHV;
22c35a8c 8172 o->op_ppaddr = PL_ppaddr[OP_PADHV];
93a17b20 8173 return o;
ed6116ce 8174 }
a2a5de95 8175 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
d1d15184 8176 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
a2a5de95 8177 "Using a hash as a reference is deprecated");
a1063b2d 8178 }
79072805
LW		 8179 return newUNOP(OP_RV2HV, 0, scalar(o));
8180}
8181
8182OP *
864dbfa3 8183Perl_newCVREF(pTHX_ I32 flags, OP *o)
79072805 8184{
97b03d64 8185 if (o->op_type == OP_PADANY) {
c04ef36e 8186 dVAR;
97b03d64
FC		 8187 o->op_type = OP_PADCV;
8188 o->op_ppaddr = PL_ppaddr[OP_PADCV];
8189 }
c07a80fd 8190 return newUNOP(OP_RV2CV, flags, scalar(o));
79072805
LW		 8191}
8192
8193OP *
864dbfa3 8194Perl_newSVREF(pTHX_ OP *o)
79072805 8195{
27da23d5 8196 dVAR;
7918f24d
NC		 8197
8198 PERL_ARGS_ASSERT_NEWSVREF;
8199
ed6116ce
LW		 8200 if (o->op_type == OP_PADANY) {
8201 o->op_type = OP_PADSV;
22c35a8c 8202 o->op_ppaddr = PL_ppaddr[OP_PADSV];
93a17b20 8203 return o;
ed6116ce 8204 }
79072805
LW		 8205 return newUNOP(OP_RV2SV, 0, scalar(o));
8206}
8207
61b743bb
DM		 8208/* Check routines. See the comments at the top of this file for details
8209 * on when these are called */
79072805
LW		 8210
8211OP *
cea2e8a9 8212Perl_ck_anoncode(pTHX_ OP *o)
5f05dabc 8213{
7918f24d
NC		 8214 PERL_ARGS_ASSERT_CK_ANONCODE;
8215
cc76b5cc 8216 cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
eb8433b7 8217 if (!PL_madskills)
1d866c12 8218 cSVOPo->op_sv = NULL;
5dc0d613 8219 return o;
5f05dabc 8220}
8221
8222OP *
cea2e8a9 8223Perl_ck_bitop(pTHX_ OP *o)
55497cff 8224{
97aff369 8225 dVAR;
7918f24d
NC		 8226
8227 PERL_ARGS_ASSERT_CK_BITOP;
8228
d5ec2987 8229 o->op_private = (U8)(PL_hints & HINT_INTEGER);
2b84528b
RGS		 8230 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
8231 && (o->op_type == OP_BIT_OR
8232 || o->op_type == OP_BIT_AND
8233 || o->op_type == OP_BIT_XOR))
276b2a0c 8234 {
1df70142
AL		 8235 const OP * const left = cBINOPo->op_first;
8236 const OP * const right = left->op_sibling;
96a925ab
YST		 8237 if ((OP_IS_NUMCOMPARE(left->op_type) &&
8238 (left->op_flags & OPf_PARENS) == 0) ||
8239 (OP_IS_NUMCOMPARE(right->op_type) &&
8240 (right->op_flags & OPf_PARENS) == 0))
a2a5de95
NC		 8241 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
8242 "Possible precedence problem on bitwise %c operator",
8243 o->op_type == OP_BIT_OR ? '|'
8244 : o->op_type == OP_BIT_AND ? '&' : '^'
8245 );
276b2a0c 8246 }
5dc0d613 8247 return o;
55497cff 8248}
8249
89474f50
FC		 8250PERL_STATIC_INLINE bool
8251is_dollar_bracket(pTHX_ const OP * const o)
8252{
8253 const OP *kid;
8254 return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
8255 && (kid = cUNOPx(o)->op_first)
8256 && kid->op_type == OP_GV
8257 && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
8258}
8259
8260OP *
8261Perl_ck_cmp(pTHX_ OP *o)
8262{
8263 PERL_ARGS_ASSERT_CK_CMP;
8264 if (ckWARN(WARN_SYNTAX)) {
8265 const OP *kid = cUNOPo->op_first;
8266 if (kid && (
7c2b3c78
FC		 8267 (
8268 is_dollar_bracket(aTHX_ kid)
8269 && kid->op_sibling && kid->op_sibling->op_type == OP_CONST
8270 )
8271 || ( kid->op_type == OP_CONST
8272 && (kid = kid->op_sibling) && is_dollar_bracket(aTHX_ kid))
89474f50
FC		 8273 ))
8274 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
8275 "$[ used in %s (did you mean $] ?)", OP_DESC(o));
8276 }
8277 return o;
8278}
8279
55497cff 8280OP *
cea2e8a9 8281Perl_ck_concat(pTHX_ OP *o)
79072805 8282{
0bd48802 8283 const OP * const kid = cUNOPo->op_first;
7918f24d
NC		 8284
8285 PERL_ARGS_ASSERT_CK_CONCAT;
96a5add6 8286 PERL_UNUSED_CONTEXT;
7918f24d 8287
df91b2c5
AE		 8288 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
8289 !(kUNOP->op_first->op_flags & OPf_MOD))
0165acc7 8290 o->op_flags |= OPf_STACKED;
11343788 8291 return o;
79072805
LW		 8292}
8293
8294OP *
cea2e8a9 8295Perl_ck_spair(pTHX_ OP *o)
79072805 8296{
27da23d5 8297 dVAR;
7918f24d
NC		 8298
8299 PERL_ARGS_ASSERT_CK_SPAIR;
8300
11343788 8301 if (o->op_flags & OPf_KIDS) {
79072805 8302 OP* newop;
a0d0e21e 8303 OP* kid;
6867be6d 8304 const OPCODE type = o->op_type;
5dc0d613 8305 o = modkids(ck_fun(o), type);
11343788 8306 kid = cUNOPo->op_first;
a0d0e21e 8307 newop = kUNOP->op_first->op_sibling;
1496a290
AL		 8308 if (newop) {
8309 const OPCODE type = newop->op_type;
8310 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
8311 type == OP_PADAV || type == OP_PADHV ||
8312 type == OP_RV2AV || type == OP_RV2HV)
8313 return o;
a0d0e21e 8314 }
eb8433b7
NC		 8315#ifdef PERL_MAD
8316 op_getmad(kUNOP->op_first,newop,'K');
8317#else
a0d0e21e 8318 op_free(kUNOP->op_first);
eb8433b7 8319#endif
a0d0e21e
LW		 8320 kUNOP->op_first = newop;
8321 }
707b805e
RGS		 8322 /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
8323 * and OP_CHOMP into OP_SCHOMP */
22c35a8c 8324 o->op_ppaddr = PL_ppaddr[++o->op_type];
11343788 8325 return ck_fun(o);
a0d0e21e
LW		 8326}
8327
8328OP *
cea2e8a9 8329Perl_ck_delete(pTHX_ OP *o)
a0d0e21e 8330{
7918f24d
NC		 8331 PERL_ARGS_ASSERT_CK_DELETE;
8332
11343788 8333 o = ck_fun(o);
5dc0d613 8334 o->op_private = 0;
11343788 8335 if (o->op_flags & OPf_KIDS) {
551405c4 8336 OP * const kid = cUNOPo->op_first;
01020589
GS		 8337 switch (kid->op_type) {
8338 case OP_ASLICE:
8339 o->op_flags |= OPf_SPECIAL;
8340 /* FALL THROUGH */
8341 case OP_HSLICE:
5dc0d613 8342 o->op_private |= OPpSLICE;
01020589
GS		 8343 break;
8344 case OP_AELEM:
8345 o->op_flags |= OPf_SPECIAL;
8346 /* FALL THROUGH */
8347 case OP_HELEM:
8348 break;
8349 default:
8350 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
53e06cf0 8351 OP_DESC(o));
01020589 8352 }
7332a6c4
VP		 8353 if (kid->op_private & OPpLVAL_INTRO)
8354 o->op_private |= OPpLVAL_INTRO;
93c66552 8355 op_null(kid);
79072805 8356 }
11343788 8357 return o;
79072805
LW		 8358}
8359
8360OP *
96e176bf
CL		 8361Perl_ck_die(pTHX_ OP *o)
8362{
7918f24d
NC		 8363 PERL_ARGS_ASSERT_CK_DIE;
8364
96e176bf
CL		 8365#ifdef VMS
8366 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
8367#endif
8368 return ck_fun(o);
8369}
8370
8371OP *
cea2e8a9 8372Perl_ck_eof(pTHX_ OP *o)
79072805 8373{
97aff369 8374 dVAR;
79072805 8375
7918f24d
NC		 8376 PERL_ARGS_ASSERT_CK_EOF;
8377
11343788 8378 if (o->op_flags & OPf_KIDS) {
3500db16 8379 OP *kid;
11343788 8380 if (cLISTOPo->op_first->op_type == OP_STUB) {
1d866c12
AL		 8381 OP * const newop
8382 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
eb8433b7
NC		 8383#ifdef PERL_MAD
8384 op_getmad(o,newop,'O');
8385#else
11343788 8386 op_free(o);
eb8433b7
NC		 8387#endif
8388 o = newop;
8990e307 8389 }
3500db16
FC		 8390 o = ck_fun(o);
8391 kid = cLISTOPo->op_first;
8392 if (kid->op_type == OP_RV2GV)
8393 kid->op_private |= OPpALLOW_FAKE;
79072805 8394 }
11343788 8395 return o;
79072805
LW		 8396}
8397
8398OP *
cea2e8a9 8399Perl_ck_eval(pTHX_ OP *o)
79072805 8400{
27da23d5 8401 dVAR;
7918f24d
NC		 8402
8403 PERL_ARGS_ASSERT_CK_EVAL;
8404
3280af22 8405 PL_hints |= HINT_BLOCK_SCOPE;
11343788 8406 if (o->op_flags & OPf_KIDS) {
46c461b5 8407 SVOP * const kid = (SVOP*)cUNOPo->op_first;
79072805 8408
93a17b20 8409 if (!kid) {
11343788 8410 o->op_flags &= ~OPf_KIDS;
93c66552 8411 op_null(o);
79072805 8412 }
b14574b4 8413 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
79072805 8414 LOGOP *enter;
eb8433b7 8415#ifdef PERL_MAD
1d866c12 8416 OP* const oldo = o;
eb8433b7 8417#endif
79072805 8418
11343788 8419 cUNOPo->op_first = 0;
eb8433b7 8420#ifndef PERL_MAD
11343788 8421 op_free(o);
eb8433b7 8422#endif
79072805 8423
b7dc083c 8424 NewOp(1101, enter, 1, LOGOP);
79072805 8425 enter->op_type = OP_ENTERTRY;
22c35a8c 8426 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
79072805
LW		 8427 enter->op_private = 0;
8428
8429 /* establish postfix order */
8430 enter->op_next = (OP*)enter;
8431
2fcb4757 8432 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
11343788 8433 o->op_type = OP_LEAVETRY;
22c35a8c 8434 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
11343788 8435 enter->op_other = o;
eb8433b7 8436 op_getmad(oldo,o,'O');
11343788 8437 return o;
79072805 8438 }
b5c19bd7 8439 else {
473986ff 8440 scalar((OP*)kid);
b5c19bd7
DM		 8441 PL_cv_has_eval = 1;
8442 }
79072805
LW		 8443 }
8444 else {
a4a3cf74 8445 const U8 priv = o->op_private;
eb8433b7 8446#ifdef PERL_MAD
1d866c12 8447 OP* const oldo = o;
eb8433b7 8448#else
11343788 8449 op_free(o);
eb8433b7 8450#endif
7d789282 8451 o = newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
eb8433b7 8452 op_getmad(oldo,o,'O');
79072805 8453 }
3280af22 8454 o->op_targ = (PADOFFSET)PL_hints;
547ae129 8455 if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
7d789282
FC		 8456 if ((PL_hints & HINT_LOCALIZE_HH) != 0
8457 && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
996c9baa
VP		 8458 /* Store a copy of %^H that pp_entereval can pick up. */
8459 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
defdfed5 8460 MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
0d863452
RH		 8461 cUNOPo->op_first->op_sibling = hhop;
8462 o->op_private |= OPpEVAL_HAS_HH;
915a83fe
FC		 8463 }
8464 if (!(o->op_private & OPpEVAL_BYTES)
2846acbf 8465 && FEATURE_UNIEVAL_IS_ENABLED)
802a15e9 8466 o->op_private |= OPpEVAL_UNICODE;
11343788 8467 return o;
79072805
LW		 8468}
8469
8470OP *
d98f61e7
GS		 8471Perl_ck_exit(pTHX_ OP *o)
8472{
7918f24d
NC		 8473 PERL_ARGS_ASSERT_CK_EXIT;
8474
d98f61e7 8475#ifdef VMS
551405c4 8476 HV * const table = GvHV(PL_hintgv);
d98f61e7 8477 if (table) {
a4fc7abc 8478 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
d98f61e7
GS		 8479 if (svp && *svp && SvTRUE(*svp))
8480 o->op_private |= OPpEXIT_VMSISH;
8481 }
96e176bf 8482 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
d98f61e7
GS		 8483#endif
8484 return ck_fun(o);
8485}
8486
8487OP *
cea2e8a9 8488Perl_ck_exec(pTHX_ OP *o)
79072805 8489{
7918f24d
NC		 8490 PERL_ARGS_ASSERT_CK_EXEC;
8491
11343788 8492 if (o->op_flags & OPf_STACKED) {
6867be6d 8493 OP *kid;
11343788
MB		 8494 o = ck_fun(o);
8495 kid = cUNOPo->op_first->op_sibling;
8990e307 8496 if (kid->op_type == OP_RV2GV)
93c66552 8497 op_null(kid);
79072805 8498 }
463ee0b2 8499 else
11343788
MB		 8500 o = listkids(o);
8501 return o;
79072805
LW		 8502}
8503
8504OP *
cea2e8a9 8505Perl_ck_exists(pTHX_ OP *o)
5f05dabc 8506{
97aff369 8507 dVAR;
7918f24d
NC		 8508
8509 PERL_ARGS_ASSERT_CK_EXISTS;
8510
5196be3e
MB		 8511 o = ck_fun(o);
8512 if (o->op_flags & OPf_KIDS) {
46c461b5 8513 OP * const kid = cUNOPo->op_first;
afebc493
GS		 8514 if (kid->op_type == OP_ENTERSUB) {
8515 (void) ref(kid, o->op_type);
13765c85
DM		 8516 if (kid->op_type != OP_RV2CV
8517 && !(PL_parser && PL_parser->error_count))
afebc493 8518 Perl_croak(aTHX_ "%s argument is not a subroutine name",
53e06cf0 8519 OP_DESC(o));
afebc493
GS		 8520 o->op_private |= OPpEXISTS_SUB;
8521 }
8522 else if (kid->op_type == OP_AELEM)
01020589
GS		 8523 o->op_flags |= OPf_SPECIAL;
8524 else if (kid->op_type != OP_HELEM)
b0fdf69e 8525 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine",
53e06cf0 8526 OP_DESC(o));
93c66552 8527 op_null(kid);
5f05dabc 8528 }
5196be3e 8529 return o;
5f05dabc 8530}
8531
79072805 8532OP *
5aaab254 8533Perl_ck_rvconst(pTHX_ OP *o)
79072805 8534{
27da23d5 8535 dVAR;
0bd48802 8536 SVOP * const kid = (SVOP*)cUNOPo->op_first;
85e6fe83 8537
7918f24d
NC		 8538 PERL_ARGS_ASSERT_CK_RVCONST;
8539
3280af22 8540 o->op_private |= (PL_hints & HINT_STRICT_REFS);
e26df76a
NC		 8541 if (o->op_type == OP_RV2CV)
8542 o->op_private &= ~1;
8543
79072805 8544 if (kid->op_type == OP_CONST) {
44a8e56a 8545 int iscv;
8546 GV *gv;
504618e9 8547 SV * const kidsv = kid->op_sv;
44a8e56a 8548
779c5bc9
GS		 8549 /* Is it a constant from cv_const_sv()? */
8550 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
0bd48802 8551 SV * const rsv = SvRV(kidsv);
42d0e0b7 8552 const svtype type = SvTYPE(rsv);
bd61b366 8553 const char *badtype = NULL;
779c5bc9
GS		 8554
8555 switch (o->op_type) {
8556 case OP_RV2SV:
42d0e0b7 8557 if (type > SVt_PVMG)
779c5bc9
GS		 8558 badtype = "a SCALAR";
8559 break;
8560 case OP_RV2AV:
42d0e0b7 8561 if (type != SVt_PVAV)
779c5bc9
GS		 8562 badtype = "an ARRAY";
8563 break;
8564 case OP_RV2HV:
42d0e0b7 8565 if (type != SVt_PVHV)
779c5bc9 8566 badtype = "a HASH";
779c5bc9
GS		 8567 break;
8568 case OP_RV2CV:
42d0e0b7 8569 if (type != SVt_PVCV)
779c5bc9
GS		 8570 badtype = "a CODE";
8571 break;
8572 }
8573 if (badtype)
cea2e8a9 8574 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
779c5bc9
GS		 8575 return o;
8576 }
ce10b5d1 8577 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5f66b61c 8578 const char *badthing;
5dc0d613 8579 switch (o->op_type) {
44a8e56a 8580 case OP_RV2SV:
8581 badthing = "a SCALAR";
8582 break;
8583 case OP_RV2AV:
8584 badthing = "an ARRAY";
8585 break;
8586 case OP_RV2HV:
8587 badthing = "a HASH";
8588 break;
5f66b61c
AL		 8589 default:
8590 badthing = NULL;
8591 break;
44a8e56a 8592 }
8593 if (badthing)
1c846c1f 8594 Perl_croak(aTHX_
95b63a38 8595 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
be2597df 8596 SVfARG(kidsv), badthing);
44a8e56a 8597 }
93233ece
CS		 8598 /*
8599 * This is a little tricky. We only want to add the symbol if we
8600 * didn't add it in the lexer. Otherwise we get duplicate strict
8601 * warnings. But if we didn't add it in the lexer, we must at
8602 * least pretend like we wanted to add it even if it existed before,
8603 * or we get possible typo warnings. OPpCONST_ENTERED says
8604 * whether the lexer already added THIS instance of this symbol.
8605 */
5196be3e 8606 iscv = (o->op_type == OP_RV2CV) * 2;
93233ece 8607 do {
7a5fd60d 8608 gv = gv_fetchsv(kidsv,
748a9306 8609 iscv | !(kid->op_private & OPpCONST_ENTERED),
a0d0e21e
LW		 8610 iscv
8611 ? SVt_PVCV
11343788 8612 : o->op_type == OP_RV2SV
a0d0e21e 8613 ? SVt_PV
11343788 8614 : o->op_type == OP_RV2AV
a0d0e21e 8615 ? SVt_PVAV
11343788 8616 : o->op_type == OP_RV2HV
a0d0e21e
LW		 8617 ? SVt_PVHV
8618 : SVt_PVGV);
93233ece
CS		 8619 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
8620 if (gv) {
8621 kid->op_type = OP_GV;
8622 SvREFCNT_dec(kid->op_sv);
350de78d 8623#ifdef USE_ITHREADS
638eceb6 8624 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
653e8c97 8625 assert (sizeof(PADOP) <= sizeof(SVOP));
350de78d 8626 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
dd2155a4 8627 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
743e66e6 8628 GvIN_PAD_on(gv);
ad64d0ec 8629 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
350de78d 8630#else
b37c2d43 8631 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
350de78d 8632#endif
23f1ca44 8633 kid->op_private = 0;
76cd736e 8634 kid->op_ppaddr = PL_ppaddr[OP_GV];
2acc3314
FC		 8635 /* FAKE globs in the symbol table cause weird bugs (#77810) */
8636 SvFAKE_off(gv);
a0d0e21e 8637 }
79072805 8638 }
11343788 8639 return o;
79072805
LW		 8640}
8641
8642OP *
cea2e8a9 8643Perl_ck_ftst(pTHX_ OP *o)
79072805 8644{
27da23d5 8645 dVAR;
6867be6d 8646 const I32 type = o->op_type;
79072805 8647
7918f24d
NC		 8648 PERL_ARGS_ASSERT_CK_FTST;
8649
d0dca557 8650 if (o->op_flags & OPf_REF) {
6f207bd3 8651 NOOP;
d0dca557
JD		 8652 }
8653 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
551405c4 8654 SVOP * const kid = (SVOP*)cUNOPo->op_first;
1496a290 8655 const OPCODE kidtype = kid->op_type;
79072805 8656
9a0c9949 8657 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
3513c740 8658 && !kid->op_folded) {
551405c4 8659 OP * const newop = newGVOP(type, OPf_REF,
f776e3cd 8660 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
eb8433b7
NC		 8661#ifdef PERL_MAD
8662 op_getmad(o,newop,'O');
8663#else
11343788 8664 op_free(o);
eb8433b7 8665#endif
1d866c12 8666 return newop;
79072805 8667 }
6ecf81d6 8668 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
1af34c76 8669 o->op_private |= OPpFT_ACCESS;
ef69c8fc 8670 if (PL_check[kidtype] == Perl_ck_ftst
bbd91306 8671 && kidtype != OP_STAT && kidtype != OP_LSTAT) {
fbb0b3b3 8672 o->op_private |= OPpFT_STACKED;
bbd91306 8673 kid->op_private |= OPpFT_STACKING;
8db8f6b6
FC		 8674 if (kidtype == OP_FTTTY && (
8675 !(kid->op_private & OPpFT_STACKED)
8676 || kid->op_private & OPpFT_AFTER_t
8677 ))
8678 o->op_private |= OPpFT_AFTER_t;
bbd91306 8679 }
79072805
LW		 8680 }
8681 else {
eb8433b7 8682#ifdef PERL_MAD
1d866c12 8683 OP* const oldo = o;
eb8433b7 8684#else
11343788 8685 op_free(o);
eb8433b7 8686#endif
79072805 8687 if (type == OP_FTTTY)
8fde6460 8688 o = newGVOP(type, OPf_REF, PL_stdingv);
79072805 8689 else
d0dca557 8690 o = newUNOP(type, 0, newDEFSVOP());
eb8433b7 8691 op_getmad(oldo,o,'O');
79072805 8692 }
11343788 8693 return o;
79072805
LW		 8694}
8695
8696OP *
cea2e8a9 8697Perl_ck_fun(pTHX_ OP *o)
79072805 8698{
97aff369 8699 dVAR;
6867be6d 8700 const int type = o->op_type;
eb578fdb 8701 I32 oa = PL_opargs[type] >> OASHIFT;
aeea060c 8702
7918f24d
NC		 8703 PERL_ARGS_ASSERT_CK_FUN;
8704
11343788 8705 if (o->op_flags & OPf_STACKED) {
79072805
LW		 8706 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
8707 oa &= ~OA_OPTIONAL;
8708 else
11343788 8709 return no_fh_allowed(o);
79072805
LW		 8710 }
8711
11343788 8712 if (o->op_flags & OPf_KIDS) {
6867be6d 8713 OP **tokid = &cLISTOPo->op_first;
eb578fdb 8714 OP *kid = cLISTOPo->op_first;
6867be6d
AL		 8715 OP *sibl;
8716 I32 numargs = 0;
ea5703f4 8717 bool seen_optional = FALSE;
6867be6d 8718
8990e307 8719 if (kid->op_type == OP_PUSHMARK ||
155aba94 8720 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
8990e307 8721 {
79072805
LW		 8722 tokid = &kid->op_sibling;
8723 kid = kid->op_sibling;
8724 }
f6a16869
FC		 8725 if (kid && kid->op_type == OP_COREARGS) {
8726 bool optional = FALSE;
8727 while (oa) {
8728 numargs++;
8729 if (oa & OA_OPTIONAL) optional = TRUE;
8730 oa = oa >> 4;
8731 }
8732 if (optional) o->op_private |= numargs;
8733 return o;
8734 }
79072805 8735
ea5703f4 8736 while (oa) {
72ec8a82 8737 if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
ea5703f4
FC		 8738 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV)
8739 *tokid = kid = newDEFSVOP();
8740 seen_optional = TRUE;
8741 }
8742 if (!kid) break;
8743
79072805
LW		 8744 numargs++;
8745 sibl = kid->op_sibling;
eb8433b7
NC		 8746#ifdef PERL_MAD
8747 if (!sibl && kid->op_type == OP_STUB) {
8748 numargs--;
8749 break;
8750 }
8751#endif
79072805
LW		 8752 switch (oa & 7) {
8753 case OA_SCALAR:
62c18ce2
GS		 8754 /* list seen where single (scalar) arg expected? */
8755 if (numargs == 1 && !(oa >> 4)
8756 && kid->op_type == OP_LIST && type != OP_SCALAR)
8757 {
ce16c625 8758 return too_many_arguments_pv(o,PL_op_desc[type], 0);
62c18ce2 8759 }
79072805
LW		 8760 scalar(kid);
8761 break;
8762 case OA_LIST:
8763 if (oa < 16) {
8764 kid = 0;
8765 continue;
8766 }
8767 else
8768 list(kid);
8769 break;
8770 case OA_AVREF:
936edb8b 8771 if ((type == OP_PUSH || type == OP_UNSHIFT)
a2a5de95
NC		 8772 && !kid->op_sibling)
8773 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
8774 "Useless use of %s with no values",
8775 PL_op_desc[type]);
b2ffa427 8776
79072805 8777 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 8778 (kid->op_private & OPpCONST_BARE))
8779 {
551405c4 8780 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
f776e3cd 8781 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
d1d15184 8782 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
a2a5de95
NC		 8783 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
8784 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
eb8433b7
NC		 8785#ifdef PERL_MAD
8786 op_getmad(kid,newop,'K');
8787#else
79072805 8788 op_free(kid);
eb8433b7 8789#endif
79072805
LW		 8790 kid = newop;
8791 kid->op_sibling = sibl;
8792 *tokid = kid;
8793 }
d4fc4415
FC		 8794 else if (kid->op_type == OP_CONST
8795 && ( !SvROK(cSVOPx_sv(kid))
8796 || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
8797 )
ce16c625 8798 bad_type_pv(numargs, "array", PL_op_desc[type], 0, kid);
d4fc4415
FC		 8799 /* Defer checks to run-time if we have a scalar arg */
8800 if (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV)
8801 op_lvalue(kid, type);
8802 else scalar(kid);
79072805
LW		 8803 break;
8804 case OA_HVREF:
8805 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 8806 (kid->op_private & OPpCONST_BARE))
8807 {
551405c4 8808 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
f776e3cd 8809 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
d1d15184 8810 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
a2a5de95
NC		 8811 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
8812 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
eb8433b7
NC		 8813#ifdef PERL_MAD
8814 op_getmad(kid,newop,'K');
8815#else
79072805 8816 op_free(kid);
eb8433b7 8817#endif
79072805
LW		 8818 kid = newop;
8819 kid->op_sibling = sibl;
8820 *tokid = kid;
8821 }
8990e307 8822 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
ce16c625 8823 bad_type_pv(numargs, "hash", PL_op_desc[type], 0, kid);
3ad73efd 8824 op_lvalue(kid, type);
79072805
LW		 8825 break;
8826 case OA_CVREF:
8827 {
551405c4 8828 OP * const newop = newUNOP(OP_NULL, 0, kid);
79072805 8829 kid->op_sibling = 0;
79072805
LW		 8830 newop->op_next = newop;
8831 kid = newop;
8832 kid->op_sibling = sibl;
8833 *tokid = kid;
8834 }
8835 break;
8836 case OA_FILEREF:
c340be78 8837 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
79072805 8838 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 8839 (kid->op_private & OPpCONST_BARE))
8840 {
0bd48802 8841 OP * const newop = newGVOP(OP_GV, 0,
f776e3cd 8842 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
afbdacea 8843 if (!(o->op_private & 1) && /* if not unop */
8a996ce8 8844 kid == cLISTOPo->op_last)
364daeac 8845 cLISTOPo->op_last = newop;
eb8433b7
NC		 8846#ifdef PERL_MAD
8847 op_getmad(kid,newop,'K');
8848#else
79072805 8849 op_free(kid);
eb8433b7 8850#endif
79072805
LW		 8851 kid = newop;
8852 }
1ea32a52
GS		 8853 else if (kid->op_type == OP_READLINE) {
8854 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
ce16c625 8855 bad_type_pv(numargs, "HANDLE", OP_DESC(o), 0, kid);
1ea32a52 8856 }
79072805 8857 else {
35cd451c 8858 I32 flags = OPf_SPECIAL;
a6c40364 8859 I32 priv = 0;
2c8ac474
GS		 8860 PADOFFSET targ = 0;
8861
35cd451c 8862 /* is this op a FH constructor? */
853846ea 8863 if (is_handle_constructor(o,numargs)) {
bd61b366 8864 const char *name = NULL;
dd2155a4 8865 STRLEN len = 0;
2dc9cdca 8866 U32 name_utf8 = 0;
885f468a 8867 bool want_dollar = TRUE;
2c8ac474
GS		 8868
8869 flags = 0;
8870 /* Set a flag to tell rv2gv to vivify
853846ea
NIS		 8871 * need to "prove" flag does not mean something
8872 * else already - NI-S 1999/05/07
2c8ac474
GS		 8873 */
8874 priv = OPpDEREF;
8875 if (kid->op_type == OP_PADSV) {
f8503592
NC		 8876 SV *const namesv
8877 = PAD_COMPNAME_SV(kid->op_targ);
8878 name = SvPV_const(namesv, len);
2dc9cdca 8879 name_utf8 = SvUTF8(namesv);
2c8ac474
GS		 8880 }
8881 else if (kid->op_type == OP_RV2SV
8882 && kUNOP->op_first->op_type == OP_GV)
8883 {
0bd48802 8884 GV * const gv = cGVOPx_gv(kUNOP->op_first);
2c8ac474
GS		 8885 name = GvNAME(gv);
8886 len = GvNAMELEN(gv);
2dc9cdca 8887 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
2c8ac474 8888 }
afd1915d
GS		 8889 else if (kid->op_type == OP_AELEM
8890 || kid->op_type == OP_HELEM)
8891 {
735fec84 8892 OP *firstop;
551405c4 8893 OP *op = ((BINOP*)kid)->op_first;
a4fc7abc 8894 name = NULL;
551405c4 8895 if (op) {
a0714e2c 8896 SV *tmpstr = NULL;
551405c4 8897 const char * const a =
666ea192
JH		 8898 kid->op_type == OP_AELEM ?
8899 "[]" : "{}";
0c4b0a3f
JH		 8900 if (((op->op_type == OP_RV2AV) ||
8901 (op->op_type == OP_RV2HV)) &&
735fec84
RGS		 8902 (firstop = ((UNOP*)op)->op_first) &&
8903 (firstop->op_type == OP_GV)) {
0c4b0a3f 8904 /* packagevar $a[] or $h{} */
735fec84 8905 GV * const gv = cGVOPx_gv(firstop);
0c4b0a3f
JH		 8906 if (gv)
8907 tmpstr =
8908 Perl_newSVpvf(aTHX_
8909 "%s%c...%c",
8910 GvNAME(gv),
8911 a[0], a[1]);
8912 }
8913 else if (op->op_type == OP_PADAV
8914 || op->op_type == OP_PADHV) {
8915 /* lexicalvar $a[] or $h{} */
551405c4 8916 const char * const padname =
0c4b0a3f
JH		 8917 PAD_COMPNAME_PV(op->op_targ);
8918 if (padname)
8919 tmpstr =
8920 Perl_newSVpvf(aTHX_
8921 "%s%c...%c",
8922 padname + 1,
8923 a[0], a[1]);
0c4b0a3f
JH		 8924 }
8925 if (tmpstr) {
93524f2b 8926 name = SvPV_const(tmpstr, len);
2dc9cdca 8927 name_utf8 = SvUTF8(tmpstr);
0c4b0a3f
JH		 8928 sv_2mortal(tmpstr);
8929 }
8930 }
8931 if (!name) {
8932 name = "__ANONIO__";
8933 len = 10;
885f468a 8934 want_dollar = FALSE;
0c4b0a3f 8935 }
3ad73efd 8936 op_lvalue(kid, type);
afd1915d 8937 }
2c8ac474
GS		 8938 if (name) {
8939 SV *namesv;
8940 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
dd2155a4 8941 namesv = PAD_SVl(targ);
862a34c6 8942 SvUPGRADE(namesv, SVt_PV);
885f468a 8943 if (want_dollar && *name != '$')
76f68e9b 8944 sv_setpvs(namesv, "$");
2c8ac474 8945 sv_catpvn(namesv, name, len);
2dc9cdca 8946 if ( name_utf8 ) SvUTF8_on(namesv);
2c8ac474 8947 }
853846ea 8948 }
79072805 8949 kid->op_sibling = 0;
35cd451c 8950 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
2c8ac474
GS		 8951 kid->op_targ = targ;
8952 kid->op_private |= priv;
79072805
LW		 8953 }
8954 kid->op_sibling = sibl;
8955 *tokid = kid;
8956 }
8957 scalar(kid);
8958 break;
8959 case OA_SCALARREF:
1efec5ed
FC		 8960 if ((type == OP_UNDEF || type == OP_POS)
8961 && numargs == 1 && !(oa >> 4)
89c5c07e
FC		 8962 && kid->op_type == OP_LIST)
8963 return too_many_arguments_pv(o,PL_op_desc[type], 0);
3ad73efd 8964 op_lvalue(scalar(kid), type);
79072805
LW		 8965 break;
8966 }
8967 oa >>= 4;
8968 tokid = &kid->op_sibling;
8969 kid = kid->op_sibling;
8970 }
eb8433b7
NC		 8971#ifdef PERL_MAD
8972 if (kid && kid->op_type != OP_STUB)
ce16c625 8973 return too_many_arguments_pv(o,OP_DESC(o), 0);
eb8433b7
NC		 8974 o->op_private |= numargs;
8975#else
8976 /* FIXME - should the numargs move as for the PERL_MAD case? */
11343788 8977 o->op_private |= numargs;
79072805 8978 if (kid)
ce16c625 8979 return too_many_arguments_pv(o,OP_DESC(o), 0);
eb8433b7 8980#endif
11343788 8981 listkids(o);
79072805 8982 }
22c35a8c 8983 else if (PL_opargs[type] & OA_DEFGV) {
c56915e3 8984#ifdef PERL_MAD
c7fe699d 8985 OP *newop = newUNOP(type, 0, newDEFSVOP());
c56915e3 8986 op_getmad(o,newop,'O');
c7fe699d 8987 return newop;
c56915e3 8988#else
c7fe699d 8989 /* Ordering of these two is important to keep f_map.t passing. */
11343788 8990 op_free(o);
c7fe699d 8991 return newUNOP(type, 0, newDEFSVOP());
c56915e3 8992#endif
a0d0e21e
LW		 8993 }
8994
79072805
LW		 8995 if (oa) {
8996 while (oa & OA_OPTIONAL)
8997 oa >>= 4;
8998 if (oa && oa != OA_LIST)
ce16c625 8999 return too_few_arguments_pv(o,OP_DESC(o), 0);
79072805 9000 }
11343788 9001 return o;
79072805
LW		 9002}
9003
9004OP *
cea2e8a9 9005Perl_ck_glob(pTHX_ OP *o)
79072805 9006{
27da23d5 9007 dVAR;
fb73857a 9008 GV *gv;
d67594ff 9009 const bool core = o->op_flags & OPf_SPECIAL;
fb73857a 9010
7918f24d
NC		 9011 PERL_ARGS_ASSERT_CK_GLOB;
9012
649da076 9013 o = ck_fun(o);
1f2bfc8a 9014 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
bd31915d 9015 op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
fb73857a 9016
d67594ff
FC		 9017 if (core) gv = NULL;
9018 else if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
b9f751c0
GS		 9019 && GvCVu(gv) && GvIMPORTED_CV(gv)))
9020 {
8113e1cc
FC		 9021 GV * const * const gvp =
9022 (GV **)hv_fetchs(PL_globalstash, "glob", FALSE);
9023 gv = gvp ? *gvp : NULL;
b9f751c0 9024 }
b1cb66bf 9025
b9f751c0 9026 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
d1bea3d8
DM		 9027 /* convert
9028 * glob
9029 * \ null - const(wildcard)
9030 * into
9031 * null
9032 * \ enter
9033 * \ list
9034 * \ mark - glob - rv2cv
9035 * | \ gv(CORE::GLOBAL::glob)
9036 * |
9423a867 9037 * \ null - const(wildcard)
d1bea3d8
DM		 9038 */
9039 o->op_flags |= OPf_SPECIAL;
9426e1a5 9040 o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
d1bea3d8 9041 o = newLISTOP(OP_LIST, 0, o, NULL);
1f2bfc8a 9042 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
2fcb4757 9043 op_append_elem(OP_LIST, o,
1f2bfc8a
MB		 9044 scalar(newUNOP(OP_RV2CV, 0,
9045 newGVOP(OP_GV, 0, gv)))));
7ae76aaa 9046 o = newUNOP(OP_NULL, 0, o);
d1bea3d8 9047 o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
d58bf5aa 9048 return o;
b1cb66bf 9049 }
d67594ff 9050 else o->op_flags &= ~OPf_SPECIAL;
39e3b1bc
FC		 9051#if !defined(PERL_EXTERNAL_GLOB)
9052 if (!PL_globhook) {
9053 ENTER;
9054 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
9055 newSVpvs("File::Glob"), NULL, NULL, NULL);
9056 LEAVE;
9057 }
9058#endif /* !PERL_EXTERNAL_GLOB */
e88567f2
FC		 9059 gv = (GV *)newSV(0);
9060 gv_init(gv, 0, "", 0, 0);
a0d0e21e 9061 gv_IOadd(gv);
2fcb4757 9062 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
fc2b2dca 9063 SvREFCNT_dec_NN(gv); /* newGVOP increased it */
11343788 9064 scalarkids(o);
649da076 9065 return o;
79072805
LW		 9066}
9067
9068OP *
cea2e8a9 9069Perl_ck_grep(pTHX_ OP *o)
79072805 9070{
27da23d5 9071 dVAR;
2471236a 9072 LOGOP *gwop;
79072805 9073 OP *kid;
6867be6d 9074 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
9f7d9405 9075 PADOFFSET offset;
79072805 9076
7918f24d
NC		 9077 PERL_ARGS_ASSERT_CK_GREP;
9078
22c35a8c 9079 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
13765c85 9080 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
aeea060c 9081
11343788 9082 if (o->op_flags & OPf_STACKED) {
2471236a 9083 kid = cUNOPx(cLISTOPo->op_first->op_sibling)->op_first;
f6435df3
GG		 9084 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
9085 return no_fh_allowed(o);
11343788 9086 o->op_flags &= ~OPf_STACKED;
93a17b20 9087 }
11343788 9088 kid = cLISTOPo->op_first->op_sibling;
a0d0e21e
LW		 9089 if (type == OP_MAPWHILE)
9090 list(kid);
9091 else
9092 scalar(kid);
11343788 9093 o = ck_fun(o);
13765c85 9094 if (PL_parser && PL_parser->error_count)
11343788 9095 return o;
aeea060c 9096 kid = cLISTOPo->op_first->op_sibling;
79072805 9097 if (kid->op_type != OP_NULL)
5637ef5b 9098 Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
79072805
LW		 9099 kid = kUNOP->op_first;
9100
2471236a 9101 NewOp(1101, gwop, 1, LOGOP);
a0d0e21e 9102 gwop->op_type = type;
22c35a8c 9103 gwop->op_ppaddr = PL_ppaddr[type];
09fe0e74 9104 gwop->op_first = o;
79072805 9105 gwop->op_flags |= OPf_KIDS;
79072805 9106 gwop->op_other = LINKLIST(kid);
79072805 9107 kid->op_next = (OP*)gwop;
cc76b5cc 9108 offset = pad_findmy_pvs("$_", 0);
00b1698f 9109 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
59f00321
RGS		 9110 o->op_private = gwop->op_private = 0;
9111 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
9112 }
9113 else {
9114 o->op_private = gwop->op_private = OPpGREP_LEX;
9115 gwop->op_targ = o->op_targ = offset;
9116 }
79072805 9117
11343788 9118 kid = cLISTOPo->op_first->op_sibling;
a0d0e21e 9119 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
3ad73efd 9120 op_lvalue(kid, OP_GREPSTART);
a0d0e21e 9121
79072805
LW		 9122 return (OP*)gwop;
9123}
9124
9125OP *
cea2e8a9 9126Perl_ck_index(pTHX_ OP *o)
79072805 9127{
7918f24d
NC		 9128 PERL_ARGS_ASSERT_CK_INDEX;
9129
11343788
MB		 9130 if (o->op_flags & OPf_KIDS) {
9131 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
0b71040e
LW		 9132 if (kid)
9133 kid = kid->op_sibling; /* get past "big" */
3b36395d 9134 if (kid && kid->op_type == OP_CONST) {
9a9b5ec9 9135 const bool save_taint = TAINT_get;
310f4fdb
FC		 9136 SV *sv = kSVOP->op_sv;
9137 if ((!SvPOK(sv) || SvNIOKp(sv)) && SvOK(sv) && !SvROK(sv)) {
9138 sv = newSV(0);
9139 sv_copypv(sv, kSVOP->op_sv);
9140 SvREFCNT_dec_NN(kSVOP->op_sv);
9141 kSVOP->op_sv = sv;
9142 }
9143 if (SvOK(sv)) fbm_compile(sv, 0);
284167a5 9144 TAINT_set(save_taint);
9a9b5ec9
DM		 9145#ifdef NO_TAINT_SUPPORT
9146 PERL_UNUSED_VAR(save_taint);
9147#endif
3b36395d 9148 }
79072805 9149 }
11343788 9150 return ck_fun(o);
79072805
LW		 9151}
9152
9153OP *
cea2e8a9 9154Perl_ck_lfun(pTHX_ OP *o)
79072805 9155{
6867be6d 9156 const OPCODE type = o->op_type;
7918f24d
NC		 9157
9158 PERL_ARGS_ASSERT_CK_LFUN;
9159
5dc0d613 9160 return modkids(ck_fun(o), type);
79072805
LW		 9161}
9162
9163OP *
cea2e8a9 9164Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
69794302 9165{
7918f24d
NC		 9166 PERL_ARGS_ASSERT_CK_DEFINED;
9167
a2a5de95 9168 if ((o->op_flags & OPf_KIDS)) {
d0334bed
GS		 9169 switch (cUNOPo->op_first->op_type) {
9170 case OP_RV2AV:
9171 case OP_PADAV:
9172 case OP_AASSIGN: /* Is this a good idea? */
d1d15184 9173 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
a2a5de95 9174 "defined(@array) is deprecated");
d1d15184 9175 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
a2a5de95 9176 "\t(Maybe you should just omit the defined()?)\n");
69794302 9177 break;
d0334bed
GS		 9178 case OP_RV2HV:
9179 case OP_PADHV:
d1d15184 9180 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
a2a5de95 9181 "defined(%%hash) is deprecated");
d1d15184 9182 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
a2a5de95 9183 "\t(Maybe you should just omit the defined()?)\n");
d0334bed
GS		 9184 break;
9185 default:
9186 /* no warning */
9187 break;
9188 }
69794302
MJD		 9189 }
9190 return ck_rfun(o);
9191}
9192
9193OP *
e4b7ebf3
RGS		 9194Perl_ck_readline(pTHX_ OP *o)
9195{
7918f24d
NC		 9196 PERL_ARGS_ASSERT_CK_READLINE;
9197
b73e5385
FC		 9198 if (o->op_flags & OPf_KIDS) {
9199 OP *kid = cLISTOPo->op_first;
9200 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
9201 }
9202 else {
e4b7ebf3
RGS		 9203 OP * const newop
9204 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
9205#ifdef PERL_MAD
9206 op_getmad(o,newop,'O');
9207#else
9208 op_free(o);
9209#endif
9210 return newop;
9211 }
9212 return o;
9213}
9214
9215OP *
cea2e8a9 9216Perl_ck_rfun(pTHX_ OP *o)
8990e307 9217{
6867be6d 9218 const OPCODE type = o->op_type;
7918f24d
NC		 9219
9220 PERL_ARGS_ASSERT_CK_RFUN;
9221
5dc0d613 9222 return refkids(ck_fun(o), type);
8990e307
LW		 9223}
9224
9225OP *
cea2e8a9 9226Perl_ck_listiob(pTHX_ OP *o)
79072805 9227{
eb578fdb 9228 OP *kid;
aeea060c 9229
7918f24d
NC		 9230 PERL_ARGS_ASSERT_CK_LISTIOB;
9231
11343788 9232 kid = cLISTOPo->op_first;
79072805 9233 if (!kid) {
11343788
MB		 9234 o = force_list(o);
9235 kid = cLISTOPo->op_first;
79072805
LW		 9236 }
9237 if (kid->op_type == OP_PUSHMARK)
9238 kid = kid->op_sibling;
11343788 9239 if (kid && o->op_flags & OPf_STACKED)
79072805
LW		 9240 kid = kid->op_sibling;
9241 else if (kid && !kid->op_sibling) { /* print HANDLE; */
01050d49 9242 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
3513c740 9243 && !kid->op_folded) {
11343788 9244 o->op_flags |= OPf_STACKED; /* make it a filehandle */
748a9306 9245 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
11343788
MB		 9246 cLISTOPo->op_first->op_sibling = kid;
9247 cLISTOPo->op_last = kid;
79072805
LW		 9248 kid = kid->op_sibling;
9249 }
9250 }
b2ffa427 9251
79072805 9252 if (!kid)
2fcb4757 9253 op_append_elem(o->op_type, o, newDEFSVOP());
79072805 9254
69974ce6 9255 if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
2de3dbcc 9256 return listkids(o);
bbce6d69 9257}
9258
9259OP *
0d863452
RH		 9260Perl_ck_smartmatch(pTHX_ OP *o)
9261{
97aff369 9262 dVAR;
a4e74480 9263 PERL_ARGS_ASSERT_CK_SMARTMATCH;
0d863452
RH		 9264 if (0 == (o->op_flags & OPf_SPECIAL)) {
9265 OP *first = cBINOPo->op_first;
9266 OP *second = first->op_sibling;
9267
9268 /* Implicitly take a reference to an array or hash */
5f66b61c 9269 first->op_sibling = NULL;
0d863452
RH		 9270 first = cBINOPo->op_first = ref_array_or_hash(first);
9271 second = first->op_sibling = ref_array_or_hash(second);
9272
9273 /* Implicitly take a reference to a regular expression */
9274 if (first->op_type == OP_MATCH) {
9275 first->op_type = OP_QR;
9276 first->op_ppaddr = PL_ppaddr[OP_QR];
9277 }
9278 if (second->op_type == OP_MATCH) {
9279 second->op_type = OP_QR;
9280 second->op_ppaddr = PL_ppaddr[OP_QR];
9281 }
9282 }
9283
9284 return o;
9285}
9286
9287
9288OP *
b162f9ea
IZ		 9289Perl_ck_sassign(pTHX_ OP *o)
9290{
3088bf26 9291 dVAR;
1496a290 9292 OP * const kid = cLISTOPo->op_first;
7918f24d
NC		 9293
9294 PERL_ARGS_ASSERT_CK_SASSIGN;
9295
b162f9ea
IZ		 9296 /* has a disposable target? */
9297 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6b66af17
GS		 9298 && !(kid->op_flags & OPf_STACKED)
9299 /* Cannot steal the second time! */
1b438339
GG		 9300 && !(kid->op_private & OPpTARGET_MY)
9301 /* Keep the full thing for madskills */
9302 && !PL_madskills
9303 )
b162f9ea 9304 {
551405c4 9305 OP * const kkid = kid->op_sibling;
b162f9ea
IZ		 9306
9307 /* Can just relocate the target. */
2c2d71f5
JH		 9308 if (kkid && kkid->op_type == OP_PADSV
9309 && !(kkid->op_private & OPpLVAL_INTRO))
9310 {
b162f9ea 9311 kid->op_targ = kkid->op_targ;
743e66e6 9312 kkid->op_targ = 0;
b162f9ea
IZ		 9313 /* Now we do not need PADSV and SASSIGN. */
9314 kid->op_sibling = o->op_sibling; /* NULL */
9315 cLISTOPo->op_first = NULL;
9316 op_free(o);
9317 op_free(kkid);
9318 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
9319 return kid;
9320 }
9321 }
c5917253
NC		 9322 if (kid->op_sibling) {
9323 OP *kkid = kid->op_sibling;
a1fba7eb
FC		 9324 /* For state variable assignment, kkid is a list op whose op_last
9325 is a padsv. */
9326 if ((kkid->op_type == OP_PADSV ||
9327 (kkid->op_type == OP_LIST &&
9328 (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
9329 )
9330 )
c5917253
NC		 9331 && (kkid->op_private & OPpLVAL_INTRO)
9332 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
9333 const PADOFFSET target = kkid->op_targ;
9334 OP *const other = newOP(OP_PADSV,
9335 kkid->op_flags
9336 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
9337 OP *const first = newOP(OP_NULL, 0);
9338 OP *const nullop = newCONDOP(0, first, o, other);
9339 OP *const condop = first->op_next;
9340 /* hijacking PADSTALE for uninitialized state variables */
9341 SvPADSTALE_on(PAD_SVl(target));
9342
9343 condop->op_type = OP_ONCE;
9344 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
9345 condop->op_targ = target;
9346 other->op_targ = target;
9347
95562366 9348 /* Because we change the type of the op here, we will skip the
486ec47a 9349 assignment binop->op_last = binop->op_first->op_sibling; at the
95562366
NC		 9350 end of Perl_newBINOP(). So need to do it here. */
9351 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
9352
c5917253
NC		 9353 return nullop;
9354 }
9355 }
b162f9ea
IZ		 9356 return o;
9357}
9358
9359OP *
cea2e8a9 9360Perl_ck_match(pTHX_ OP *o)
79072805 9361{
97aff369 9362 dVAR;
7918f24d
NC		 9363
9364 PERL_ARGS_ASSERT_CK_MATCH;
9365
0d863452 9366 if (o->op_type != OP_QR && PL_compcv) {
cc76b5cc 9367 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
00b1698f 9368 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
59f00321
RGS		 9369 o->op_targ = offset;
9370 o->op_private |= OPpTARGET_MY;
9371 }
9372 }
9373 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
9374 o->op_private |= OPpRUNTIME;
11343788 9375 return o;
79072805
LW		 9376}
9377
9378OP *
f5d5a27c
CS		 9379Perl_ck_method(pTHX_ OP *o)
9380{
551405c4 9381 OP * const kid = cUNOPo->op_first;
7918f24d
NC		 9382
9383 PERL_ARGS_ASSERT_CK_METHOD;
9384
f5d5a27c
CS		 9385 if (kid->op_type == OP_CONST) {
9386 SV* sv = kSVOP->op_sv;
a4fc7abc
AL		 9387 const char * const method = SvPVX_const(sv);
9388 if (!(strchr(method, ':') || strchr(method, '\''))) {
f5d5a27c 9389 OP *cmop;
e3918bb7 9390 if (!SvIsCOW(sv)) {
c60dbbc3 9391 sv = newSVpvn_share(method, SvUTF8(sv) ? -(I32)SvCUR(sv) : (I32)SvCUR(sv), 0);
1c846c1f
NIS		 9392 }
9393 else {
a0714e2c 9394 kSVOP->op_sv = NULL;
1c846c1f 9395 }
f5d5a27c 9396 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
eb8433b7
NC		 9397#ifdef PERL_MAD
9398 op_getmad(o,cmop,'O');
9399#else
f5d5a27c 9400 op_free(o);
eb8433b7 9401#endif
f5d5a27c
CS		 9402 return cmop;
9403 }
9404 }
9405 return o;
9406}
9407
9408OP *
cea2e8a9 9409Perl_ck_null(pTHX_ OP *o)
79072805 9410{
7918f24d 9411 PERL_ARGS_ASSERT_CK_NULL;
96a5add6 9412 PERL_UNUSED_CONTEXT;
11343788 9413 return o;
79072805
LW		 9414}
9415
9416OP *
16fe6d59
GS		 9417Perl_ck_open(pTHX_ OP *o)
9418{
97aff369 9419 dVAR;
551405c4 9420 HV * const table = GvHV(PL_hintgv);
7918f24d
NC		 9421
9422 PERL_ARGS_ASSERT_CK_OPEN;
9423
16fe6d59 9424 if (table) {
a4fc7abc 9425 SV **svp = hv_fetchs(table, "open_IN", FALSE);
16fe6d59 9426 if (svp && *svp) {
a79b25b7
VP		 9427 STRLEN len = 0;
9428 const char *d = SvPV_const(*svp, len);
9429 const I32 mode = mode_from_discipline(d, len);
16fe6d59
GS		 9430 if (mode & O_BINARY)
9431 o->op_private |= OPpOPEN_IN_RAW;
9432 else if (mode & O_TEXT)
9433 o->op_private |= OPpOPEN_IN_CRLF;
9434 }
9435
a4fc7abc 9436 svp = hv_fetchs(table, "open_OUT", FALSE);
16fe6d59 9437 if (svp && *svp) {
a79b25b7
VP		 9438 STRLEN len = 0;
9439 const char *d = SvPV_const(*svp, len);
9440 const I32 mode = mode_from_discipline(d, len);
16fe6d59
GS		 9441 if (mode & O_BINARY)
9442 o->op_private |= OPpOPEN_OUT_RAW;
9443 else if (mode & O_TEXT)
9444 o->op_private |= OPpOPEN_OUT_CRLF;
9445 }
9446 }
8d7403e6
RGS		 9447 if (o->op_type == OP_BACKTICK) {
9448 if (!(o->op_flags & OPf_KIDS)) {
e4b7ebf3
RGS		 9449 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
9450#ifdef PERL_MAD
9451 op_getmad(o,newop,'O');
9452#else
8d7403e6 9453 op_free(o);
e4b7ebf3
RGS		 9454#endif
9455 return newop;
8d7403e6 9456 }
16fe6d59 9457 return o;
8d7403e6 9458 }
3b82e551
JH		 9459 {
9460 /* In case of three-arg dup open remove strictness
9461 * from the last arg if it is a bareword. */
551405c4
AL		 9462 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
9463 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
3b82e551 9464 OP *oa;
b15aece3 9465 const char *mode;
3b82e551
JH		 9466
9467 if ((last->op_type == OP_CONST) && /* The bareword. */
9468 (last->op_private & OPpCONST_BARE) &&
9469 (last->op_private & OPpCONST_STRICT) &&
9470 (oa = first->op_sibling) && /* The fh. */
9471 (oa = oa->op_sibling) && /* The mode. */
ea1d064a 9472 (oa->op_type == OP_CONST) &&
3b82e551 9473 SvPOK(((SVOP*)oa)->op_sv) &&
b15aece3 9474 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
3b82e551
JH		 9475 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
9476 (last == oa->op_sibling)) /* The bareword. */
9477 last->op_private &= ~OPpCONST_STRICT;
9478 }
16fe6d59
GS		 9479 return ck_fun(o);
9480}
9481
9482OP *
cea2e8a9 9483Perl_ck_repeat(pTHX_ OP *o)
79072805 9484{
7918f24d
NC		 9485 PERL_ARGS_ASSERT_CK_REPEAT;
9486
11343788
MB		 9487 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
9488 o->op_private |= OPpREPEAT_DOLIST;
9489 cBINOPo->op_first = force_list(cBINOPo->op_first);
79072805
LW		 9490 }
9491 else
11343788
MB		 9492 scalar(o);
9493 return o;
79072805
LW		 9494}
9495
9496OP *
cea2e8a9 9497Perl_ck_require(pTHX_ OP *o)
8990e307 9498{
97aff369 9499 dVAR;
a0714e2c 9500 GV* gv = NULL;
ec4ab249 9501
7918f24d
NC		 9502 PERL_ARGS_ASSERT_CK_REQUIRE;
9503
11343788 9504 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
551405c4 9505 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8990e307
LW		 9506
9507 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
551405c4 9508 SV * const sv = kid->op_sv;
5c144d81 9509 U32 was_readonly = SvREADONLY(sv);
8990e307 9510 char *s;
cfff9797
NC		 9511 STRLEN len;
9512 const char *end;
5c144d81
NC		 9513
9514 if (was_readonly) {
5c144d81 9515 SvREADONLY_off(sv);
5c144d81 9516 }
e3918bb7 9517 if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
5c144d81 9518
cfff9797
NC		 9519 s = SvPVX(sv);
9520 len = SvCUR(sv);
9521 end = s + len;
9522 for (; s < end; s++) {
a0d0e21e
LW		 9523 if (*s == ':' && s[1] == ':') {
9524 *s = '/';
5c6b2528 9525 Move(s+2, s+1, end - s - 1, char);
cfff9797 9526 --end;
a0d0e21e 9527 }
8990e307 9528 }
cfff9797 9529 SvEND_set(sv, end);
396482e1 9530 sv_catpvs(sv, ".pm");
5c144d81 9531 SvFLAGS(sv) |= was_readonly;
8990e307
LW		 9532 }
9533 }
ec4ab249 9534
a72a1c8b
RGS		 9535 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
9536 /* handle override, if any */
fafc274c 9537 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
d6a985f2 9538 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
a4fc7abc 9539 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
a0714e2c 9540 gv = gvp ? *gvp : NULL;
d6a985f2 9541 }
a72a1c8b 9542 }
ec4ab249 9543
b9f751c0 9544 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7c864bb3
VP		 9545 OP *kid, *newop;
9546 if (o->op_flags & OPf_KIDS) {
9547 kid = cUNOPo->op_first;
9548 cUNOPo->op_first = NULL;
9549 }
9550 else {
9551 kid = newDEFSVOP();
9552 }
f11453cb 9553#ifndef PERL_MAD
ec4ab249 9554 op_free(o);
eb8433b7 9555#endif
d1bef648 9556 newop = newUNOP(OP_ENTERSUB, OPf_STACKED,
2fcb4757 9557 op_append_elem(OP_LIST, kid,
f11453cb
NC		 9558 scalar(newUNOP(OP_RV2CV, 0,
9559 newGVOP(OP_GV, 0,
d1bef648 9560 gv)))));
f11453cb 9561 op_getmad(o,newop,'O');
eb8433b7 9562 return newop;
ec4ab249
GA		 9563 }
9564
021f53de 9565 return scalar(ck_fun(o));
8990e307
LW		 9566}
9567
78f9721b
SM		 9568OP *
9569Perl_ck_return(pTHX_ OP *o)
9570{
97aff369 9571 dVAR;
e91684bf 9572 OP *kid;
7918f24d
NC		 9573
9574 PERL_ARGS_ASSERT_CK_RETURN;
9575
e91684bf 9576 kid = cLISTOPo->op_first->op_sibling;
78f9721b 9577 if (CvLVALUE(PL_compcv)) {
e91684bf 9578 for (; kid; kid = kid->op_sibling)
3ad73efd 9579 op_lvalue(kid, OP_LEAVESUBLV);
78f9721b 9580 }
e91684bf 9581
78f9721b
SM		 9582 return o;
9583}
9584
79072805 9585OP *
cea2e8a9 9586Perl_ck_select(pTHX_ OP *o)
79072805 9587{
27da23d5 9588 dVAR;
c07a80fd 9589 OP* kid;
7918f24d
NC		 9590
9591 PERL_ARGS_ASSERT_CK_SELECT;
9592
11343788
MB		 9593 if (o->op_flags & OPf_KIDS) {
9594 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
2304df62 9595 if (kid && kid->op_sibling) {
11343788 9596 o->op_type = OP_SSELECT;
22c35a8c 9597 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
11343788 9598 o = ck_fun(o);
985b9e54 9599 return fold_constants(op_integerize(op_std_init(o)));
79072805
LW		 9600 }
9601 }
11343788
MB		 9602 o = ck_fun(o);
9603 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
c07a80fd 9604 if (kid && kid->op_type == OP_RV2GV)
9605 kid->op_private &= ~HINT_STRICT_REFS;
11343788 9606 return o;
79072805
LW		 9607}
9608
9609OP *
cea2e8a9 9610Perl_ck_shift(pTHX_ OP *o)
79072805 9611{
97aff369 9612 dVAR;
6867be6d 9613 const I32 type = o->op_type;
79072805 9614
7918f24d
NC		 9615 PERL_ARGS_ASSERT_CK_SHIFT;
9616
11343788 9617 if (!(o->op_flags & OPf_KIDS)) {
538f5756
RZ		 9618 OP *argop;
9619
9620 if (!CvUNIQUE(PL_compcv)) {
9621 o->op_flags |= OPf_SPECIAL;
9622 return o;
9623 }
9624
9625 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
eb8433b7 9626#ifdef PERL_MAD
790427a5
DM		 9627 {
9628 OP * const oldo = o;
9629 o = newUNOP(type, 0, scalar(argop));
9630 op_getmad(oldo,o,'O');
9631 return o;
9632 }
eb8433b7 9633#else
821005df 9634 op_free(o);
6d4ff0d2 9635 return newUNOP(type, 0, scalar(argop));
eb8433b7 9636#endif
79072805 9637 }
d4fc4415 9638 return scalar(ck_fun(o));
79072805
LW		 9639}
9640
9641OP *
cea2e8a9 9642Perl_ck_sort(pTHX_ OP *o)
79072805 9643{
97aff369 9644 dVAR;
8e3f9bdf 9645 OP *firstkid;
f65493df 9646 OP *kid;
c3258369
FC		 9647 HV * const hinthv =
9648 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;
f65493df 9649 U8 stacked;
bbce6d69 9650
7918f24d
NC		 9651 PERL_ARGS_ASSERT_CK_SORT;
9652
354dd559 9653 if (hinthv) {
a4fc7abc 9654 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7b9ef140 9655 if (svp) {
a4fc7abc 9656 const I32 sorthints = (I32)SvIV(*svp);
7b9ef140
RH		 9657 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
9658 o->op_private |= OPpSORT_QSORT;
9659 if ((sorthints & HINT_SORT_STABLE) != 0)
9660 o->op_private |= OPpSORT_STABLE;
9661 }
7b9ef140
RH		 9662 }
9663
354dd559 9664 if (o->op_flags & OPf_STACKED)
51a19bc0 9665 simplify_sort(o);
8e3f9bdf 9666 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
f65493df 9667 if ((stacked = o->op_flags & OPf_STACKED)) { /* may have been cleared */
8e3f9bdf 9668 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
79072805 9669
463ee0b2 9670 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
5983a79d 9671 LINKLIST(kid);
c650d697 9672 if (kid->op_type == OP_LEAVE)
93c66552 9673 op_null(kid); /* wipe out leave */
c650d697
FC		 9674 /* Prevent execution from escaping out of the sort block. */
9675 kid->op_next = 0;
a0d0e21e 9676
354dd559
FC		 9677 /* provide scalar context for comparison function/block */
9678 kid = scalar(firstkid);
9679 kid->op_next = kid;
11343788 9680 o->op_flags |= OPf_SPECIAL;
79072805 9681 }
8e3f9bdf
GS		 9682
9683 firstkid = firstkid->op_sibling;
79072805 9684 }
bbce6d69 9685
f65493df 9686 for (kid = firstkid; kid; kid = kid->op_sibling) {
e9d9e6f3
FC		 9687 /* provide list context for arguments */
9688 list(kid);
f65493df
FC		 9689 if (stacked)
9690 op_lvalue(kid, OP_GREPSTART);
9691 }
8e3f9bdf 9692
11343788 9693 return o;
79072805 9694}
bda4119b
GS		 9695
9696STATIC void
cea2e8a9 9697S_simplify_sort(pTHX_ OP *o)
9c007264 9698{
97aff369 9699 dVAR;
eb578fdb 9700 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
9c007264 9701 OP *k;
eb209983 9702 int descending;
350de78d 9703 GV *gv;
770526c1 9704 const char *gvname;
8023b711 9705 bool have_scopeop;
7918f24d
NC		 9706
9707 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
9708
fafc274c
NC		 9709 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
9710 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
82092f1d 9711 kid = kUNOP->op_first; /* get past null */
8023b711
FC		 9712 if (!(have_scopeop = kid->op_type == OP_SCOPE)
9713 && kid->op_type != OP_LEAVE)
9c007264
JH		 9714 return;
9715 kid = kLISTOP->op_last; /* get past scope */
9716 switch(kid->op_type) {
9717 case OP_NCMP:
9718 case OP_I_NCMP:
9719 case OP_SCMP:
8023b711 9720 if (!have_scopeop) goto padkids;
9c007264
JH		 9721 break;
9722 default:
9723 return;
9724 }
9725 k = kid; /* remember this node*/
271c8bde
FC		 9726 if (kBINOP->op_first->op_type != OP_RV2SV
9727 || kBINOP->op_last ->op_type != OP_RV2SV)
9728 {
9729 /*
9730 Warn about my($a) or my($b) in a sort block, *if* $a or $b is
9731 then used in a comparison. This catches most, but not
9732 all cases. For instance, it catches
9733 sort { my($a); $a <=> $b }
9734 but not
9735 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
9736 (although why you'd do that is anyone's guess).
9737 */
9738
9739 padkids:
9740 if (!ckWARN(WARN_SYNTAX)) return;
9741 kid = kBINOP->op_first;
9742 do {
9743 if (kid->op_type == OP_PADSV) {
9744 SV * const name = AvARRAY(PL_comppad_name)[kid->op_targ];
9745 if (SvCUR(name) == 2 && *SvPVX(name) == '$'
9746 && (SvPVX(name)[1] == 'a' || SvPVX(name)[1] == 'b'))
a2e39214 9747 /* diag_listed_as: "my %s" used in sort comparison */
271c8bde 9748 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
a2e39214
FC		 9749 "\"%s %s\" used in sort comparison",
9750 SvPAD_STATE(name) ? "state" : "my",
271c8bde
FC		 9751 SvPVX(name));
9752 }
9753 } while ((kid = kid->op_sibling));
9c007264 9754 return;
271c8bde 9755 }
9c007264
JH		 9756 kid = kBINOP->op_first; /* get past cmp */
9757 if (kUNOP->op_first->op_type != OP_GV)
9758 return;
9759 kid = kUNOP->op_first; /* get past rv2sv */
638eceb6 9760 gv = kGVOP_gv;
350de78d 9761 if (GvSTASH(gv) != PL_curstash)
9c007264 9762 return;
770526c1
NC		 9763 gvname = GvNAME(gv);
9764 if (*gvname == 'a' && gvname[1] == '\0')
eb209983 9765 descending = 0;
770526c1 9766 else if (*gvname == 'b' && gvname[1] == '\0')
eb209983 9767 descending = 1;
9c007264
JH		 9768 else
9769 return;
eb209983 9770
9c007264 9771 kid = k; /* back to cmp */
271c8bde 9772 /* already checked above that it is rv2sv */
9c007264
JH		 9773 kid = kBINOP->op_last; /* down to 2nd arg */
9774 if (kUNOP->op_first->op_type != OP_GV)
9775 return;
9776 kid = kUNOP->op_first; /* get past rv2sv */
638eceb6 9777 gv = kGVOP_gv;
770526c1
NC		 9778 if (GvSTASH(gv) != PL_curstash)
9779 return;
9780 gvname = GvNAME(gv);
9781 if ( descending
9782 ? !(*gvname == 'a' && gvname[1] == '\0')
9783 : !(*gvname == 'b' && gvname[1] == '\0'))
9c007264
JH		 9784 return;
9785 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
eb209983
NC		 9786 if (descending)
9787 o->op_private |= OPpSORT_DESCEND;
9c007264
JH		 9788 if (k->op_type == OP_NCMP)
9789 o->op_private |= OPpSORT_NUMERIC;
9790 if (k->op_type == OP_I_NCMP)
9791 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
e507f050
SM		 9792 kid = cLISTOPo->op_first->op_sibling;
9793 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
eb8433b7
NC		 9794#ifdef PERL_MAD
9795 op_getmad(kid,o,'S'); /* then delete it */
9796#else
e507f050 9797 op_free(kid); /* then delete it */
eb8433b7 9798#endif
9c007264 9799}
79072805
LW		 9800
9801OP *
cea2e8a9 9802Perl_ck_split(pTHX_ OP *o)
79072805 9803{
27da23d5 9804 dVAR;
eb578fdb 9805 OP *kid;
aeea060c 9806
7918f24d
NC		 9807 PERL_ARGS_ASSERT_CK_SPLIT;
9808
11343788
MB		 9809 if (o->op_flags & OPf_STACKED)
9810 return no_fh_allowed(o);
79072805 9811
11343788 9812 kid = cLISTOPo->op_first;
8990e307 9813 if (kid->op_type != OP_NULL)
5637ef5b 9814 Perl_croak(aTHX_ "panic: ck_split, type=%u", (unsigned) kid->op_type);
8990e307 9815 kid = kid->op_sibling;
11343788 9816 op_free(cLISTOPo->op_first);
f126b75f
MW		 9817 if (kid)
9818 cLISTOPo->op_first = kid;
9819 else {
396482e1 9820 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
11343788 9821 cLISTOPo->op_last = kid; /* There was only one element previously */
85e6fe83 9822 }
79072805 9823
de4bf5b3 9824 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
551405c4 9825 OP * const sibl = kid->op_sibling;
463ee0b2 9826 kid->op_sibling = 0;
dbc200c5 9827 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0, 0); /* OPf_SPECIAL is used to trigger split " " behavior */
11343788
MB		 9828 if (cLISTOPo->op_first == cLISTOPo->op_last)
9829 cLISTOPo->op_last = kid;
9830 cLISTOPo->op_first = kid;
79072805
LW		 9831 kid->op_sibling = sibl;
9832 }
9833
9834 kid->op_type = OP_PUSHRE;
22c35a8c 9835 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
79072805 9836 scalar(kid);
a2a5de95
NC		 9837 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
9838 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
9839 "Use of /g modifier is meaningless in split");
f34840d8 9840 }
79072805
LW		 9841
9842 if (!kid->op_sibling)
2fcb4757 9843 op_append_elem(OP_SPLIT, o, newDEFSVOP());
79072805
LW		 9844
9845 kid = kid->op_sibling;
9846 scalar(kid);
9847
9848 if (!kid->op_sibling)
60041a09 9849 {
2fcb4757 9850 op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
60041a09
FC		 9851 o->op_private |= OPpSPLIT_IMPLIM;
9852 }
ce3e5c45 9853 assert(kid->op_sibling);
79072805
LW		 9854
9855 kid = kid->op_sibling;
9856 scalar(kid);
9857
9858 if (kid->op_sibling)
ce16c625 9859 return too_many_arguments_pv(o,OP_DESC(o), 0);
79072805 9860
11343788 9861 return o;
79072805
LW		 9862}
9863
9864OP *
1c846c1f 9865Perl_ck_join(pTHX_ OP *o)
eb6e2d6f 9866{
551405c4 9867 const OP * const kid = cLISTOPo->op_first->op_sibling;
7918f24d
NC		 9868
9869 PERL_ARGS_ASSERT_CK_JOIN;
9870
041457d9
DM		 9871 if (kid && kid->op_type == OP_MATCH) {
9872 if (ckWARN(WARN_SYNTAX)) {
6867be6d 9873 const REGEXP *re = PM_GETRE(kPMOP);
ce16c625
BF		 9874 const SV *msg = re
9875 ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
9876 SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
9877 : newSVpvs_flags( "STRING", SVs_TEMP );
9014280d 9878 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
ce16c625
BF		 9879 "/%"SVf"/ should probably be written as \"%"SVf"\"",
9880 SVfARG(msg), SVfARG(msg));
eb6e2d6f
GS		 9881 }
9882 }
9883 return ck_fun(o);
9884}
9885
d9088386
Z		 9886/*
9887=for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
9888
9889Examines an op, which is expected to identify a subroutine at runtime,
9890and attempts to determine at compile time which subroutine it identifies.
9891This is normally used during Perl compilation to determine whether
9892a prototype can be applied to a function call. I<cvop> is the op
9893being considered, normally an C<rv2cv> op. A pointer to the identified
9894subroutine is returned, if it could be determined statically, and a null
9895pointer is returned if it was not possible to determine statically.
9896
9897Currently, the subroutine can be identified statically if the RV that the
9898C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
9899A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
9900suitable if the constant value must be an RV pointing to a CV. Details of
9901this process may change in future versions of Perl. If the C<rv2cv> op
9902has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
9903the subroutine statically: this flag is used to suppress compile-time
9904magic on a subroutine call, forcing it to use default runtime behaviour.
9905
9906If I<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
9907of a GV reference is modified. If a GV was examined and its CV slot was
9908found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
9909If the op is not optimised away, and the CV slot is later populated with
9910a subroutine having a prototype, that flag eventually triggers the warning
9911"called too early to check prototype".
9912
9913If I<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
9914of returning a pointer to the subroutine it returns a pointer to the
9915GV giving the most appropriate name for the subroutine in this context.
9916Normally this is just the C<CvGV> of the subroutine, but for an anonymous
9917(C<CvANON>) subroutine that is referenced through a GV it will be the
9918referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
9919A null pointer is returned as usual if there is no statically-determinable
9920subroutine.
7918f24d 9921
d9088386
Z		 9922=cut
9923*/
9d88f058 9924
9a5e6f3c
FC		 9925/* shared by toke.c:yylex */
9926CV *
9927Perl_find_lexical_cv(pTHX_ PADOFFSET off)
9928{
9929 PADNAME *name = PAD_COMPNAME(off);
9930 CV *compcv = PL_compcv;
9931 while (PadnameOUTER(name)) {
9932 assert(PARENT_PAD_INDEX(name));
9933 compcv = CvOUTSIDE(PL_compcv);
9934 name = PadlistNAMESARRAY(CvPADLIST(compcv))
9935 [off = PARENT_PAD_INDEX(name)];
9936 }
9937 assert(!PadnameIsOUR(name));
3a74e0e2 9938 if (!PadnameIsSTATE(name) && SvMAGICAL(name)) {
9a5e6f3c
FC		 9939 MAGIC * mg = mg_find(name, PERL_MAGIC_proto);
9940 assert(mg);
9941 assert(mg->mg_obj);
9942 return (CV *)mg->mg_obj;
9943 }
9944 return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
9945}
9946
d9088386
Z		 9947CV *
9948Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
9949{
9950 OP *rvop;
9951 CV *cv;
9952 GV *gv;
9953 PERL_ARGS_ASSERT_RV2CV_OP_CV;
9954 if (flags & ~(RV2CVOPCV_MARK_EARLY|RV2CVOPCV_RETURN_NAME_GV))
9955 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
9956 if (cvop->op_type != OP_RV2CV)
9957 return NULL;
9958 if (cvop->op_private & OPpENTERSUB_AMPER)
9959 return NULL;
9960 if (!(cvop->op_flags & OPf_KIDS))
9961 return NULL;
9962 rvop = cUNOPx(cvop)->op_first;
9963 switch (rvop->op_type) {
9964 case OP_GV: {
9965 gv = cGVOPx_gv(rvop);
9966 cv = GvCVu(gv);
9967 if (!cv) {
9968 if (flags & RV2CVOPCV_MARK_EARLY)
9969 rvop->op_private |= OPpEARLY_CV;
9970 return NULL;
46fc3d4c 9971 }
d9088386
Z		 9972 } break;
9973 case OP_CONST: {
9974 SV *rv = cSVOPx_sv(rvop);
9975 if (!SvROK(rv))
9976 return NULL;
9977 cv = (CV*)SvRV(rv);
9978 gv = NULL;
9979 } break;
279d09bf 9980 case OP_PADCV: {
9a5e6f3c 9981 cv = find_lexical_cv(rvop->op_targ);
279d09bf
FC		 9982 gv = NULL;
9983 } break;
d9088386
Z		 9984 default: {
9985 return NULL;
9986 } break;
4633a7c4 9987 }
d9088386
Z		 9988 if (SvTYPE((SV*)cv) != SVt_PVCV)
9989 return NULL;
9990 if (flags & RV2CVOPCV_RETURN_NAME_GV) {
9991 if (!CvANON(cv) || !gv)
9992 gv = CvGV(cv);
9993 return (CV*)gv;
9994 } else {
9995 return cv;
7a52d87a 9996 }
d9088386 9997}
9d88f058 9998
d9088386
Z		 9999/*
10000=for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
824afba1 10001
d9088386
Z		 10002Performs the default fixup of the arguments part of an C<entersub>
10003op tree. This consists of applying list context to each of the
10004argument ops. This is the standard treatment used on a call marked
10005with C<&>, or a method call, or a call through a subroutine reference,
10006or any other call where the callee can't be identified at compile time,
10007or a call where the callee has no prototype.
824afba1 10008
d9088386
Z		 10009=cut
10010*/
340458b5 10011
d9088386
Z		 10012OP *
10013Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
10014{
10015 OP *aop;
10016 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
10017 aop = cUNOPx(entersubop)->op_first;
10018 if (!aop->op_sibling)
10019 aop = cUNOPx(aop)->op_first;
10020 for (aop = aop->op_sibling; aop->op_sibling; aop = aop->op_sibling) {
10021 if (!(PL_madskills && aop->op_type == OP_STUB)) {
10022 list(aop);
3ad73efd 10023 op_lvalue(aop, OP_ENTERSUB);
d9088386
Z		 10024 }
10025 }
10026 return entersubop;
10027}
340458b5 10028
d9088386
Z		 10029/*
10030=for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
10031
10032Performs the fixup of the arguments part of an C<entersub> op tree
10033based on a subroutine prototype. This makes various modifications to
10034the argument ops, from applying context up to inserting C<refgen> ops,
10035and checking the number and syntactic types of arguments, as directed by
10036the prototype. This is the standard treatment used on a subroutine call,
10037not marked with C<&>, where the callee can be identified at compile time
10038and has a prototype.
10039
10040I<protosv> supplies the subroutine prototype to be applied to the call.
10041It may be a normal defined scalar, of which the string value will be used.
10042Alternatively, for convenience, it may be a subroutine object (a C<CV*>
10043that has been cast to C<SV*>) which has a prototype. The prototype
10044supplied, in whichever form, does not need to match the actual callee
10045referenced by the op tree.
10046
10047If the argument ops disagree with the prototype, for example by having
10048an unacceptable number of arguments, a valid op tree is returned anyway.
10049The error is reflected in the parser state, normally resulting in a single
10050exception at the top level of parsing which covers all the compilation
10051errors that occurred. In the error message, the callee is referred to
10052by the name defined by the I<namegv> parameter.
cbf82dd0 10053
d9088386
Z		 10054=cut
10055*/
10056
10057OP *
10058Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
10059{
10060 STRLEN proto_len;
10061 const char *proto, *proto_end;
10062 OP *aop, *prev, *cvop;
10063 int optional = 0;
10064 I32 arg = 0;
10065 I32 contextclass = 0;
10066 const char *e = NULL;
10067 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
10068 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
cb197492 10069 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
5637ef5b 10070 "flags=%lx", (unsigned long) SvFLAGS(protosv));
8fa6a409
FC		 10071 if (SvTYPE(protosv) == SVt_PVCV)
10072 proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
10073 else proto = SvPV(protosv, proto_len);
d16269d8 10074 proto = S_strip_spaces(aTHX_ proto, &proto_len);
d9088386
Z		 10075 proto_end = proto + proto_len;
10076 aop = cUNOPx(entersubop)->op_first;
10077 if (!aop->op_sibling)
10078 aop = cUNOPx(aop)->op_first;
10079 prev = aop;
10080 aop = aop->op_sibling;
10081 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
10082 while (aop != cvop) {
10083 OP* o3;
10084 if (PL_madskills && aop->op_type == OP_STUB) {
10085 aop = aop->op_sibling;
10086 continue;
10087 }
10088 if (PL_madskills && aop->op_type == OP_NULL)
10089 o3 = ((UNOP*)aop)->op_first;
10090 else
10091 o3 = aop;
10092
10093 if (proto >= proto_end)
ce16c625 10094 return too_many_arguments_sv(entersubop, gv_ename(namegv), 0);
d9088386
Z		 10095
10096 switch (*proto) {
597dcb2b
DG		 10097 case ';':
10098 optional = 1;
10099 proto++;
10100 continue;
10101 case '_':
10102 /* _ must be at the end */
34daab0f 10103 if (proto[1] && !strchr(";@%", proto[1]))
597dcb2b
DG		 10104 goto oops;
10105 case '$':
10106 proto++;
10107 arg++;
10108 scalar(aop);
10109 break;
10110 case '%':
10111 case '@':
10112 list(aop);
10113 arg++;
10114 break;
10115 case '&':
10116 proto++;
10117 arg++;
10118 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
7b3b0904 10119 bad_type_gv(arg,
597dcb2b 10120 arg == 1 ? "block or sub {}" : "sub {}",
7b3b0904 10121 namegv, 0, o3);
597dcb2b
DG		 10122 break;
10123 case '*':
10124 /* '*' allows any scalar type, including bareword */
10125 proto++;
10126 arg++;
10127 if (o3->op_type == OP_RV2GV)
10128 goto wrapref; /* autoconvert GLOB -> GLOBref */
10129 else if (o3->op_type == OP_CONST)
10130 o3->op_private &= ~OPpCONST_STRICT;
10131 else if (o3->op_type == OP_ENTERSUB) {
10132 /* accidental subroutine, revert to bareword */
10133 OP *gvop = ((UNOP*)o3)->op_first;
10134 if (gvop && gvop->op_type == OP_NULL) {
10135 gvop = ((UNOP*)gvop)->op_first;
10136 if (gvop) {
10137 for (; gvop->op_sibling; gvop = gvop->op_sibling)
10138 ;
10139 if (gvop &&
10140 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
10141 (gvop = ((UNOP*)gvop)->op_first) &&
10142 gvop->op_type == OP_GV)
10143 {
10144 GV * const gv = cGVOPx_gv(gvop);
10145 OP * const sibling = aop->op_sibling;
10146 SV * const n = newSVpvs("");
eb8433b7 10147#ifdef PERL_MAD
597dcb2b 10148 OP * const oldaop = aop;
eb8433b7 10149#else
597dcb2b 10150 op_free(aop);
eb8433b7 10151#endif
597dcb2b
DG		 10152 gv_fullname4(n, gv, "", FALSE);
10153 aop = newSVOP(OP_CONST, 0, n);
10154 op_getmad(oldaop,aop,'O');
10155 prev->op_sibling = aop;
10156 aop->op_sibling = sibling;
10157 }
9675f7ac
GS		 10158 }
10159 }
10160 }
597dcb2b 10161 scalar(aop);
c035a075
DG		 10162 break;
10163 case '+':
10164 proto++;
10165 arg++;
10166 if (o3->op_type == OP_RV2AV ||
10167 o3->op_type == OP_PADAV ||
10168 o3->op_type == OP_RV2HV ||
10169 o3->op_type == OP_PADHV
10170 ) {
10171 goto wrapref;
10172 }
10173 scalar(aop);
d9088386 10174 break;
597dcb2b
DG		 10175 case '[': case ']':
10176 goto oops;
d9088386 10177 break;
597dcb2b
DG		 10178 case '\\':
10179 proto++;
10180 arg++;
10181 again:
10182 switch (*proto++) {
10183 case '[':
10184 if (contextclass++ == 0) {
10185 e = strchr(proto, ']');
10186 if (!e || e == proto)
10187 goto oops;
10188 }
10189 else
10190 goto oops;
10191 goto again;
10192 break;
10193 case ']':
10194 if (contextclass) {
10195 const char *p = proto;
10196 const char *const end = proto;
10197 contextclass = 0;
062678b2
FC		 10198 while (*--p != '[')
10199 /* \[$] accepts any scalar lvalue */
10200 if (*p == '$'
10201 && Perl_op_lvalue_flags(aTHX_
10202 scalar(o3),
10203 OP_READ, /* not entersub */
10204 OP_LVALUE_NO_CROAK
10205 )) goto wrapref;
7b3b0904 10206 bad_type_gv(arg, Perl_form(aTHX_ "one of %.*s",
597dcb2b 10207 (int)(end - p), p),
7b3b0904 10208 namegv, 0, o3);
597dcb2b
DG		 10209 } else
10210 goto oops;
10211 break;
10212 case '*':
10213 if (o3->op_type == OP_RV2GV)
10214 goto wrapref;
10215 if (!contextclass)
7b3b0904 10216 bad_type_gv(arg, "symbol", namegv, 0, o3);
597dcb2b
DG		 10217 break;
10218 case '&':
10219 if (o3->op_type == OP_ENTERSUB)
10220 goto wrapref;
10221 if (!contextclass)
7b3b0904 10222 bad_type_gv(arg, "subroutine entry", namegv, 0,
597dcb2b
DG		 10223 o3);
10224 break;
10225 case '$':
10226 if (o3->op_type == OP_RV2SV ||
10227 o3->op_type == OP_PADSV ||
10228 o3->op_type == OP_HELEM ||
10229 o3->op_type == OP_AELEM)
10230 goto wrapref;
062678b2
FC		 10231 if (!contextclass) {
10232 /* \$ accepts any scalar lvalue */
10233 if (Perl_op_lvalue_flags(aTHX_
10234 scalar(o3),
10235 OP_READ, /* not entersub */
10236 OP_LVALUE_NO_CROAK
10237 )) goto wrapref;
7b3b0904 10238 bad_type_gv(arg, "scalar", namegv, 0, o3);
062678b2 10239 }
597dcb2b
DG		 10240 break;
10241 case '@':
10242 if (o3->op_type == OP_RV2AV ||
10243 o3->op_type == OP_PADAV)
10244 goto wrapref;
10245 if (!contextclass)
7b3b0904 10246 bad_type_gv(arg, "array", namegv, 0, o3);
597dcb2b
DG		 10247 break;
10248 case '%':
10249 if (o3->op_type == OP_RV2HV ||
10250 o3->op_type == OP_PADHV)
10251 goto wrapref;
10252 if (!contextclass)
7b3b0904 10253 bad_type_gv(arg, "hash", namegv, 0, o3);
597dcb2b
DG		 10254 break;
10255 wrapref:
10256 {
10257 OP* const kid = aop;
10258 OP* const sib = kid->op_sibling;
10259 kid->op_sibling = 0;
10260 aop = newUNOP(OP_REFGEN, 0, kid);
10261 aop->op_sibling = sib;
10262 prev->op_sibling = aop;
10263 }
10264 if (contextclass && e) {
10265 proto = e + 1;
10266 contextclass = 0;
10267 }
10268 break;
10269 default: goto oops;
4633a7c4 10270 }
597dcb2b
DG		 10271 if (contextclass)
10272 goto again;
4633a7c4 10273 break;
597dcb2b
DG		 10274 case ' ':
10275 proto++;
10276 continue;
10277 default:
108f32a5
BF		 10278 oops: {
10279 SV* const tmpsv = sv_newmortal();
10280 gv_efullname3(tmpsv, namegv, NULL);
10281 Perl_croak(aTHX_ "Malformed prototype for %"SVf": %"SVf,
10282 SVfARG(tmpsv), SVfARG(protosv));
10283 }
d9088386
Z		 10284 }
10285
3ad73efd 10286 op_lvalue(aop, OP_ENTERSUB);
d9088386
Z		 10287 prev = aop;
10288 aop = aop->op_sibling;
10289 }
10290 if (aop == cvop && *proto == '_') {
10291 /* generate an access to $_ */
10292 aop = newDEFSVOP();
10293 aop->op_sibling = prev->op_sibling;
10294 prev->op_sibling = aop; /* instead of cvop */
10295 }
10296 if (!optional && proto_end > proto &&
10297 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
ce16c625 10298 return too_few_arguments_sv(entersubop, gv_ename(namegv), 0);
d9088386
Z		 10299 return entersubop;
10300}
10301
10302/*
10303=for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
10304
10305Performs the fixup of the arguments part of an C<entersub> op tree either
10306based on a subroutine prototype or using default list-context processing.
10307This is the standard treatment used on a subroutine call, not marked
10308with C<&>, where the callee can be identified at compile time.
10309
10310I<protosv> supplies the subroutine prototype to be applied to the call,
10311or indicates that there is no prototype. It may be a normal scalar,
10312in which case if it is defined then the string value will be used
10313as a prototype, and if it is undefined then there is no prototype.
10314Alternatively, for convenience, it may be a subroutine object (a C<CV*>
10315that has been cast to C<SV*>), of which the prototype will be used if it
10316has one. The prototype (or lack thereof) supplied, in whichever form,
10317does not need to match the actual callee referenced by the op tree.
10318
10319If the argument ops disagree with the prototype, for example by having
10320an unacceptable number of arguments, a valid op tree is returned anyway.
10321The error is reflected in the parser state, normally resulting in a single
10322exception at the top level of parsing which covers all the compilation
10323errors that occurred. In the error message, the callee is referred to
10324by the name defined by the I<namegv> parameter.
10325
10326=cut
10327*/
10328
10329OP *
10330Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
10331 GV *namegv, SV *protosv)
10332{
10333 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
10334 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
10335 return ck_entersub_args_proto(entersubop, namegv, protosv);
10336 else
10337 return ck_entersub_args_list(entersubop);
10338}
10339
4aaa4757
FC		 10340OP *
10341Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
10342{
10343 int opnum = SvTYPE(protosv) == SVt_PVCV ? 0 : (int)SvUV(protosv);
10344 OP *aop = cUNOPx(entersubop)->op_first;
10345
10346 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
10347
10348 if (!opnum) {
14f0f125 10349 OP *cvop;
4aaa4757
FC		 10350 if (!aop->op_sibling)
10351 aop = cUNOPx(aop)->op_first;
4aaa4757
FC		 10352 aop = aop->op_sibling;
10353 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
10354 if (PL_madskills) while (aop != cvop && aop->op_type == OP_STUB) {
10355 aop = aop->op_sibling;
4aaa4757
FC		 10356 }
10357 if (aop != cvop)
ce16c625 10358 (void)too_many_arguments_pv(entersubop, GvNAME(namegv), 0);
4aaa4757
FC		 10359
10360 op_free(entersubop);
10361 switch(GvNAME(namegv)[2]) {
10362 case 'F': return newSVOP(OP_CONST, 0,
10363 newSVpv(CopFILE(PL_curcop),0));
10364 case 'L': return newSVOP(
10365 OP_CONST, 0,
10366 Perl_newSVpvf(aTHX_
10367 "%"IVdf, (IV)CopLINE(PL_curcop)
10368 )
10369 );
10370 case 'P': return newSVOP(OP_CONST, 0,
10371 (PL_curstash
10372 ? newSVhek(HvNAME_HEK(PL_curstash))
10373 : &PL_sv_undef
10374 )
10375 );
10376 }
10377 assert(0);
10378 }
10379 else {
10380 OP *prev, *cvop;
7d789282 10381 U32 flags;
4aaa4757
FC		 10382#ifdef PERL_MAD
10383 bool seenarg = FALSE;
10384#endif
10385 if (!aop->op_sibling)
10386 aop = cUNOPx(aop)->op_first;
10387
10388 prev = aop;
10389 aop = aop->op_sibling;
10390 prev->op_sibling = NULL;
10391 for (cvop = aop;
10392 cvop->op_sibling;
10393 prev=cvop, cvop = cvop->op_sibling)
10394#ifdef PERL_MAD
10395 if (PL_madskills && cvop->op_sibling
10396 && cvop->op_type != OP_STUB) seenarg = TRUE
10397#endif
10398 ;
10399 prev->op_sibling = NULL;
7d789282 10400 flags = OPf_SPECIAL * !(cvop->op_private & OPpENTERSUB_NOPAREN);
4aaa4757
FC		 10401 op_free(cvop);
10402 if (aop == cvop) aop = NULL;
10403 op_free(entersubop);
10404
7d789282
FC		 10405 if (opnum == OP_ENTEREVAL
10406 && GvNAMELEN(namegv)==9 && strnEQ(GvNAME(namegv), "evalbytes", 9))
10407 flags |= OPpEVAL_BYTES <<8;
10408
4aaa4757
FC		 10409 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
10410 case OA_UNOP:
10411 case OA_BASEOP_OR_UNOP:
10412 case OA_FILESTATOP:
7d789282 10413 return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
4aaa4757
FC		 10414 case OA_BASEOP:
10415 if (aop) {
10416#ifdef PERL_MAD
10417 if (!PL_madskills || seenarg)
10418#endif
ce16c625 10419 (void)too_many_arguments_pv(aop, GvNAME(namegv), 0);
4aaa4757
FC		 10420 op_free(aop);
10421 }
98be9964
FC		 10422 return opnum == OP_RUNCV
10423 ? newPVOP(OP_RUNCV,0,NULL)
10424 : newOP(opnum,0);
4aaa4757
FC		 10425 default:
10426 return convert(opnum,0,aop);
10427 }
10428 }
10429 assert(0);
10430 return entersubop;
10431}
10432
d9088386
Z		 10433/*
10434=for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
10435
10436Retrieves the function that will be used to fix up a call to I<cv>.
10437Specifically, the function is applied to an C<entersub> op tree for a
10438subroutine call, not marked with C<&>, where the callee can be identified
10439at compile time as I<cv>.
10440
10441The C-level function pointer is returned in I<*ckfun_p>, and an SV
10442argument for it is returned in I<*ckobj_p>. The function is intended
10443to be called in this manner:
10444
10445 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
10446
10447In this call, I<entersubop> is a pointer to the C<entersub> op,
10448which may be replaced by the check function, and I<namegv> is a GV
10449supplying the name that should be used by the check function to refer
10450to the callee of the C<entersub> op if it needs to emit any diagnostics.
10451It is permitted to apply the check function in non-standard situations,
10452such as to a call to a different subroutine or to a method call.
340458b5 10453
d9088386
Z		 10454By default, the function is
10455L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
10456and the SV parameter is I<cv> itself. This implements standard
10457prototype processing. It can be changed, for a particular subroutine,
10458by L</cv_set_call_checker>.
74735042 10459
d9088386
Z		 10460=cut
10461*/
10462
10463void
10464Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
10465{
10466 MAGIC *callmg;
10467 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
10468 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
10469 if (callmg) {
10470 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
10471 *ckobj_p = callmg->mg_obj;
10472 } else {
10473 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
10474 *ckobj_p = (SV*)cv;
10475 }
10476}
10477
10478/*
10479=for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
10480
10481Sets the function that will be used to fix up a call to I<cv>.
10482Specifically, the function is applied to an C<entersub> op tree for a
10483subroutine call, not marked with C<&>, where the callee can be identified
10484at compile time as I<cv>.
10485
10486The C-level function pointer is supplied in I<ckfun>, and an SV argument
10487for it is supplied in I<ckobj>. The function is intended to be called
10488in this manner:
10489
10490 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
10491
10492In this call, I<entersubop> is a pointer to the C<entersub> op,
10493which may be replaced by the check function, and I<namegv> is a GV
10494supplying the name that should be used by the check function to refer
10495to the callee of the C<entersub> op if it needs to emit any diagnostics.
10496It is permitted to apply the check function in non-standard situations,
10497such as to a call to a different subroutine or to a method call.
10498
10499The current setting for a particular CV can be retrieved by
10500L</cv_get_call_checker>.
10501
10502=cut
10503*/
10504
10505void
10506Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
10507{
10508 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
10509 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
10510 if (SvMAGICAL((SV*)cv))
10511 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
10512 } else {
10513 MAGIC *callmg;
10514 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
10515 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
10516 if (callmg->mg_flags & MGf_REFCOUNTED) {
10517 SvREFCNT_dec(callmg->mg_obj);
10518 callmg->mg_flags &= ~MGf_REFCOUNTED;
10519 }
10520 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
10521 callmg->mg_obj = ckobj;
10522 if (ckobj != (SV*)cv) {
10523 SvREFCNT_inc_simple_void_NN(ckobj);
10524 callmg->mg_flags |= MGf_REFCOUNTED;
74735042 10525 }
09fb282d 10526 callmg->mg_flags |= MGf_COPY;
340458b5 10527 }
d9088386
Z		 10528}
10529
10530OP *
10531Perl_ck_subr(pTHX_ OP *o)
10532{
10533 OP *aop, *cvop;
10534 CV *cv;
10535 GV *namegv;
10536
10537 PERL_ARGS_ASSERT_CK_SUBR;
10538
10539 aop = cUNOPx(o)->op_first;
10540 if (!aop->op_sibling)
10541 aop = cUNOPx(aop)->op_first;
10542 aop = aop->op_sibling;
10543 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
10544 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
10545 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_RETURN_NAME_GV) : NULL;
10546
767eda44 10547 o->op_private &= ~1;
d9088386
Z		 10548 o->op_private |= OPpENTERSUB_HASTARG;
10549 o->op_private |= (PL_hints & HINT_STRICT_REFS);
10550 if (PERLDB_SUB && PL_curstash != PL_debstash)
10551 o->op_private |= OPpENTERSUB_DB;
10552 if (cvop->op_type == OP_RV2CV) {
10553 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
10554 op_null(cvop);
10555 } else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
10556 if (aop->op_type == OP_CONST)
10557 aop->op_private &= ~OPpCONST_STRICT;
10558 else if (aop->op_type == OP_LIST) {
10559 OP * const sib = ((UNOP*)aop)->op_first->op_sibling;
10560 if (sib && sib->op_type == OP_CONST)
10561 sib->op_private &= ~OPpCONST_STRICT;
10562 }
10563 }
10564
10565 if (!cv) {
10566 return ck_entersub_args_list(o);
10567 } else {
10568 Perl_call_checker ckfun;
10569 SV *ckobj;
10570 cv_get_call_checker(cv, &ckfun, &ckobj);
279d09bf
FC		 10571 if (!namegv) { /* expletive! */
10572 /* XXX The call checker API is public. And it guarantees that
10573 a GV will be provided with the right name. So we have
10574 to create a GV. But it is still not correct, as its
10575 stringification will include the package. What we
10576 really need is a new call checker API that accepts a
10577 GV or string (or GV or CV). */
10578 HEK * const hek = CvNAME_HEK(cv);
3a74e0e2
FC		 10579 /* After a syntax error in a lexical sub, the cv that
10580 rv2cv_op_cv returns may be a nameless stub. */
10581 if (!hek) return ck_entersub_args_list(o);;
279d09bf
FC		 10582 namegv = (GV *)sv_newmortal();
10583 gv_init_pvn(namegv, PL_curstash, HEK_KEY(hek), HEK_LEN(hek),
10584 SVf_UTF8 * !!HEK_UTF8(hek));
10585 }
d9088386
Z		 10586 return ckfun(aTHX_ o, namegv, ckobj);
10587 }
79072805
LW		 10588}
10589
10590OP *
cea2e8a9 10591Perl_ck_svconst(pTHX_ OP *o)
8990e307 10592{
7918f24d 10593 PERL_ARGS_ASSERT_CK_SVCONST;
96a5add6 10594 PERL_UNUSED_CONTEXT;
e3918bb7 10595 if (!SvIsCOW(cSVOPo->op_sv)) SvREADONLY_on(cSVOPo->op_sv);
11343788 10596 return o;
8990e307
LW		 10597}
10598
10599OP *
cea2e8a9 10600Perl_ck_trunc(pTHX_ OP *o)
79072805 10601{
7918f24d
NC		 10602 PERL_ARGS_ASSERT_CK_TRUNC;
10603
11343788
MB		 10604 if (o->op_flags & OPf_KIDS) {
10605 SVOP *kid = (SVOP*)cUNOPo->op_first;
79072805 10606
a0d0e21e
LW		 10607 if (kid->op_type == OP_NULL)
10608 kid = (SVOP*)kid->op_sibling;
bb53490d 10609 if (kid && kid->op_type == OP_CONST &&
3513c740
NT		 10610 (kid->op_private & OPpCONST_BARE) &&
10611 !kid->op_folded)
bb53490d 10612 {
11343788 10613 o->op_flags |= OPf_SPECIAL;
bb53490d
GS		 10614 kid->op_private &= ~OPpCONST_STRICT;
10615 }
79072805 10616 }
11343788 10617 return ck_fun(o);
79072805
LW		 10618}
10619
35fba0d9
RG		 10620OP *
10621Perl_ck_substr(pTHX_ OP *o)
10622{
7918f24d
NC		 10623 PERL_ARGS_ASSERT_CK_SUBSTR;
10624
35fba0d9 10625 o = ck_fun(o);
1d866c12 10626 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
35fba0d9
RG		 10627 OP *kid = cLISTOPo->op_first;
10628
10629 if (kid->op_type == OP_NULL)
10630 kid = kid->op_sibling;
10631 if (kid)
10632 kid->op_flags |= OPf_MOD;
10633
10634 }
10635 return o;
10636}
10637
878d132a 10638OP *
8dc99089
FC		 10639Perl_ck_tell(pTHX_ OP *o)
10640{
8dc99089
FC		 10641 PERL_ARGS_ASSERT_CK_TELL;
10642 o = ck_fun(o);
e9d7a483
FC		 10643 if (o->op_flags & OPf_KIDS) {
10644 OP *kid = cLISTOPo->op_first;
423e8af5 10645 if (kid->op_type == OP_NULL && kid->op_sibling) kid = kid->op_sibling;
e9d7a483
FC		 10646 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
10647 }
8dc99089
FC		 10648 return o;
10649}
10650
10651OP *
cba5a3b0
DG		 10652Perl_ck_each(pTHX_ OP *o)
10653{
10654 dVAR;
10655 OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
10656 const unsigned orig_type = o->op_type;
10657 const unsigned array_type = orig_type == OP_EACH ? OP_AEACH
10658 : orig_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
10659 const unsigned ref_type = orig_type == OP_EACH ? OP_REACH
10660 : orig_type == OP_KEYS ? OP_RKEYS : OP_RVALUES;
10661
10662 PERL_ARGS_ASSERT_CK_EACH;
10663
10664 if (kid) {
10665 switch (kid->op_type) {
10666 case OP_PADHV:
10667 case OP_RV2HV:
10668 break;
10669 case OP_PADAV:
10670 case OP_RV2AV:
10671 CHANGE_TYPE(o, array_type);
10672 break;
10673 case OP_CONST:
7ac5715b
FC		 10674 if (kid->op_private == OPpCONST_BARE
10675 || !SvROK(cSVOPx_sv(kid))
10676 || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
10677 && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV )
10678 )
10679 /* we let ck_fun handle it */
cba5a3b0
DG		 10680 break;
10681 default:
10682 CHANGE_TYPE(o, ref_type);
7ac5715b 10683 scalar(kid);
cba5a3b0
DG		 10684 }
10685 }
10686 /* if treating as a reference, defer additional checks to runtime */
10687 return o->op_type == ref_type ? o : ck_fun(o);
10688}
10689
e508c8a4
MH		 10690OP *
10691Perl_ck_length(pTHX_ OP *o)
10692{
10693 PERL_ARGS_ASSERT_CK_LENGTH;
10694
10695 o = ck_fun(o);
10696
10697 if (ckWARN(WARN_SYNTAX)) {
10698 const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
10699
10700 if (kid) {
579333ee
FC		 10701 SV *name = NULL;
10702 const bool hash = kid->op_type == OP_PADHV
10703 || kid->op_type == OP_RV2HV;
e508c8a4
MH		 10704 switch (kid->op_type) {
10705 case OP_PADHV:
e508c8a4 10706 case OP_PADAV:
579333ee 10707 name = varname(
c6fb3f6e
FC		 10708 (GV *)PL_compcv, hash ? '%' : '@', kid->op_targ,
10709 NULL, 0, 1
579333ee
FC		 10710 );
10711 break;
10712 case OP_RV2HV:
e508c8a4 10713 case OP_RV2AV:
579333ee
FC		 10714 if (cUNOPx(kid)->op_first->op_type != OP_GV) break;
10715 {
10716 GV *gv = cGVOPx_gv(cUNOPx(kid)->op_first);
10717 if (!gv) break;
10718 name = varname(gv, hash?'%':'@', 0, NULL, 0, 1);
10719 }
e508c8a4 10720 break;
e508c8a4 10721 default:
579333ee 10722 return o;
e508c8a4 10723 }
579333ee
FC		 10724 if (name)
10725 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10726 "length() used on %"SVf" (did you mean \"scalar(%s%"SVf
10727 ")\"?)",
10728 name, hash ? "keys " : "", name
10729 );
10730 else if (hash)
25e26107 10731 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
579333ee
FC		 10732 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10733 "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
10734 else
25e26107 10735 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
579333ee
FC		 10736 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10737 "length() used on @array (did you mean \"scalar(@array)\"?)");
e508c8a4
MH		 10738 }
10739 }
10740
10741 return o;
10742}
10743
540dd770
GG		 10744/* Check for in place reverse and sort assignments like "@a = reverse @a"
10745 and modify the optree to make them work inplace */
e52d58aa 10746
540dd770
GG		 10747STATIC void
10748S_inplace_aassign(pTHX_ OP *o) {
e52d58aa 10749
540dd770
GG		 10750 OP *modop, *modop_pushmark;
10751 OP *oright;
10752 OP *oleft, *oleft_pushmark;
e52d58aa 10753
540dd770 10754 PERL_ARGS_ASSERT_INPLACE_AASSIGN;
e52d58aa 10755
540dd770 10756 assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
e52d58aa 10757
540dd770
GG		 10758 assert(cUNOPo->op_first->op_type == OP_NULL);
10759 modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
10760 assert(modop_pushmark->op_type == OP_PUSHMARK);
10761 modop = modop_pushmark->op_sibling;
e92f843d 10762
540dd770
GG		 10763 if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
10764 return;
10765
10766 /* no other operation except sort/reverse */
10767 if (modop->op_sibling)
10768 return;
10769
10770 assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
a46b39a8 10771 if (!(oright = cUNOPx(modop)->op_first->op_sibling)) return;
540dd770
GG		 10772
10773 if (modop->op_flags & OPf_STACKED) {
10774 /* skip sort subroutine/block */
10775 assert(oright->op_type == OP_NULL);
10776 oright = oright->op_sibling;
10777 }
10778
10779 assert(cUNOPo->op_first->op_sibling->op_type == OP_NULL);
10780 oleft_pushmark = cUNOPx(cUNOPo->op_first->op_sibling)->op_first;
10781 assert(oleft_pushmark->op_type == OP_PUSHMARK);
10782 oleft = oleft_pushmark->op_sibling;
10783
10784 /* Check the lhs is an array */
10785 if (!oleft ||
10786 (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
10787 || oleft->op_sibling
10788 || (oleft->op_private & OPpLVAL_INTRO)
10789 )
10790 return;
10791
10792 /* Only one thing on the rhs */
10793 if (oright->op_sibling)
10794 return;
2f9e2db0
VP		 10795
10796 /* check the array is the same on both sides */
10797 if (oleft->op_type == OP_RV2AV) {
10798 if (oright->op_type != OP_RV2AV
10799 || !cUNOPx(oright)->op_first
10800 || cUNOPx(oright)->op_first->op_type != OP_GV
18e3e9ce 10801 || cUNOPx(oleft )->op_first->op_type != OP_GV
2f9e2db0
VP		 10802 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
10803 cGVOPx_gv(cUNOPx(oright)->op_first)
10804 )
540dd770 10805 return;
2f9e2db0
VP		 10806 }
10807 else if (oright->op_type != OP_PADAV
10808 || oright->op_targ != oleft->op_targ
10809 )
540dd770
GG		 10810 return;
10811
10812 /* This actually is an inplace assignment */
e52d58aa 10813
540dd770
GG		 10814 modop->op_private |= OPpSORT_INPLACE;
10815
10816 /* transfer MODishness etc from LHS arg to RHS arg */
10817 oright->op_flags = oleft->op_flags;
10818
10819 /* remove the aassign op and the lhs */
10820 op_null(o);
10821 op_null(oleft_pushmark);
10822 if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
10823 op_null(cUNOPx(oleft)->op_first);
10824 op_null(oleft);
2f9e2db0
VP		 10825}
10826
3c78429c
DM		 10827#define MAX_DEFERRED 4
10828
10829#define DEFER(o) \
d7ab38e8 10830 STMT_START { \
3c78429c
DM		 10831 if (defer_ix == (MAX_DEFERRED-1)) { \
10832 CALL_RPEEP(defer_queue[defer_base]); \
10833 defer_base = (defer_base + 1) % MAX_DEFERRED; \
10834 defer_ix--; \
10835 } \
d7ab38e8
FC		 10836 defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = o; \
10837 } STMT_END
3c78429c 10838
61b743bb
DM		 10839/* A peephole optimizer. We visit the ops in the order they're to execute.
10840 * See the comments at the top of this file for more details about when
10841 * peep() is called */
463ee0b2 10842
79072805 10843void
5aaab254 10844Perl_rpeep(pTHX_ OP *o)
79072805 10845{
27da23d5 10846 dVAR;
eb578fdb 10847 OP* oldop = NULL;
4774ee0a 10848 OP* oldoldop = NULL;
3c78429c
DM		 10849 OP* defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
10850 int defer_base = 0;
10851 int defer_ix = -1;
2d8e6c8d 10852
2814eb74 10853 if (!o || o->op_opt)
79072805 10854 return;
a0d0e21e 10855 ENTER;
462e5cf6 10856 SAVEOP();
7766f137 10857 SAVEVPTR(PL_curcop);
3c78429c
DM		 10858 for (;; o = o->op_next) {
10859 if (o && o->op_opt)
10860 o = NULL;
cd197e1e
VP		 10861 if (!o) {
10862 while (defer_ix >= 0)
10863 CALL_RPEEP(defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED]);
3c78429c 10864 break;
cd197e1e 10865 }
3c78429c 10866
6d7dd4a5
NC		 10867 /* By default, this op has now been optimised. A couple of cases below
10868 clear this again. */
10869 o->op_opt = 1;
533c011a 10870 PL_op = o;
a0d0e21e 10871 switch (o->op_type) {
a0d0e21e 10872 case OP_DBSTATE:
3280af22 10873 PL_curcop = ((COP*)o); /* for warnings */
a0d0e21e 10874 break;
ac56e7de
NC		 10875 case OP_NEXTSTATE:
10876 PL_curcop = ((COP*)o); /* for warnings */
10877
10878 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
10879 to carry two labels. For now, take the easier option, and skip
10880 this optimisation if the first NEXTSTATE has a label. */
bcc76ee3 10881 if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
ac56e7de
NC		 10882 OP *nextop = o->op_next;
10883 while (nextop && nextop->op_type == OP_NULL)
10884 nextop = nextop->op_next;
10885
10886 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
10887 COP *firstcop = (COP *)o;
10888 COP *secondcop = (COP *)nextop;
10889 /* We want the COP pointed to by o (and anything else) to
10890 become the next COP down the line. */
10891 cop_free(firstcop);
10892
10893 firstcop->op_next = secondcop->op_next;
10894
10895 /* Now steal all its pointers, and duplicate the other
10896 data. */
10897 firstcop->cop_line = secondcop->cop_line;
10898#ifdef USE_ITHREADS
d4d03940 10899 firstcop->cop_stashoff = secondcop->cop_stashoff;
ac56e7de
NC		 10900 firstcop->cop_file = secondcop->cop_file;
10901#else
10902 firstcop->cop_stash = secondcop->cop_stash;
10903 firstcop->cop_filegv = secondcop->cop_filegv;
10904#endif
10905 firstcop->cop_hints = secondcop->cop_hints;
10906 firstcop->cop_seq = secondcop->cop_seq;
10907 firstcop->cop_warnings = secondcop->cop_warnings;
10908 firstcop->cop_hints_hash = secondcop->cop_hints_hash;
10909
10910#ifdef USE_ITHREADS
647688d8 10911 secondcop->cop_stashoff = 0;
ac56e7de
NC		 10912 secondcop->cop_file = NULL;
10913#else
10914 secondcop->cop_stash = NULL;
10915 secondcop->cop_filegv = NULL;
10916#endif
10917 secondcop->cop_warnings = NULL;
10918 secondcop->cop_hints_hash = NULL;
10919
10920 /* If we use op_null(), and hence leave an ex-COP, some
10921 warnings are misreported. For example, the compile-time
10922 error in 'use strict; no strict refs;' */
10923 secondcop->op_type = OP_NULL;
10924 secondcop->op_ppaddr = PL_ppaddr[OP_NULL];
10925 }
10926 }
10927 break;
a0d0e21e 10928
df91b2c5
AE		 10929 case OP_CONCAT:
10930 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
10931 if (o->op_next->op_private & OPpTARGET_MY) {
10932 if (o->op_flags & OPf_STACKED) /* chained concats */
a6aa0b75 10933 break; /* ignore_optimization */
df91b2c5
AE		 10934 else {
10935 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
10936 o->op_targ = o->op_next->op_targ;
10937 o->op_next->op_targ = 0;
10938 o->op_private |= OPpTARGET_MY;
10939 }
10940 }
10941 op_null(o->op_next);
10942 }
df91b2c5 10943 break;
6d7dd4a5
NC		 10944 case OP_STUB:
10945 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
10946 break; /* Scalar stub must produce undef. List stub is noop */
10947 }
10948 goto nothin;
79072805 10949 case OP_NULL:
acb36ea4 10950 if (o->op_targ == OP_NEXTSTATE
5edb5b2a 10951 || o->op_targ == OP_DBSTATE)
acb36ea4 10952 {
3280af22 10953 PL_curcop = ((COP*)o);
acb36ea4 10954 }
dad75012 10955 /* XXX: We avoid setting op_seq here to prevent later calls
1a0a2ba9 10956 to rpeep() from mistakenly concluding that optimisation
dad75012
AMS		 10957 has already occurred. This doesn't fix the real problem,
10958 though (See 20010220.007). AMS 20010719 */
2814eb74 10959 /* op_seq functionality is now replaced by op_opt */
6d7dd4a5 10960 o->op_opt = 0;
f46f2f82 10961 /* FALL THROUGH */
79072805 10962 case OP_SCALAR:
93a17b20 10963 case OP_LINESEQ:
463ee0b2 10964 case OP_SCOPE:
6d7dd4a5 10965 nothin:
a0d0e21e
LW		 10966 if (oldop && o->op_next) {
10967 oldop->op_next = o->op_next;
6d7dd4a5 10968 o->op_opt = 0;
79072805
LW		 10969 continue;
10970 }
79072805
LW		 10971 break;
10972
a7fd8ef6
DM		 10973 case OP_PUSHMARK:
10974
10975 /* Convert a series of PAD ops for my vars plus support into a
10976 * single padrange op. Basically
10977 *
10978 * pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
10979 *
10980 * becomes, depending on circumstances, one of
10981 *
10982 * padrange ----------------------------------> (list) -> rest
10983 * padrange --------------------------------------------> rest
10984 *
10985 * where all the pad indexes are sequential and of the same type
10986 * (INTRO or not).
10987 * We convert the pushmark into a padrange op, then skip
10988 * any other pad ops, and possibly some trailing ops.
10989 * Note that we don't null() the skipped ops, to make it
10990 * easier for Deparse to undo this optimisation (and none of
10991 * the skipped ops are holding any resourses). It also makes
10992 * it easier for find_uninit_var(), as it can just ignore
10993 * padrange, and examine the original pad ops.
10994 */
10995 {
10996 OP *p;
10997 OP *followop = NULL; /* the op that will follow the padrange op */
10998 U8 count = 0;
10999 U8 intro = 0;
11000 PADOFFSET base = 0; /* init only to stop compiler whining */
11001 U8 gimme = 0; /* init only to stop compiler whining */
d5524600 11002 bool defav = 0; /* seen (...) = @_ */
fd3cc9e5 11003 bool reuse = 0; /* reuse an existing padrange op */
d5524600
DM		 11004
11005 /* look for a pushmark -> gv[_] -> rv2av */
11006
11007 {
11008 GV *gv;
11009 OP *rv2av, *q;
11010 p = o->op_next;
11011 if ( p->op_type == OP_GV
11012 && (gv = cGVOPx_gv(p))
11013 && GvNAMELEN_get(gv) == 1
11014 && *GvNAME_get(gv) == '_'
11015 && GvSTASH(gv) == PL_defstash
11016 && (rv2av = p->op_next)
11017 && rv2av->op_type == OP_RV2AV
11018 && !(rv2av->op_flags & OPf_REF)
11019 && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
11020 && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
11021 && o->op_sibling == rv2av /* these two for Deparse */
11022 && cUNOPx(rv2av)->op_first == p
11023 ) {
11024 q = rv2av->op_next;
11025 if (q->op_type == OP_NULL)
11026 q = q->op_next;
11027 if (q->op_type == OP_PUSHMARK) {
11028 defav = 1;
11029 p = q;
11030 }
11031 }
11032 }
11033 if (!defav) {
11034 /* To allow Deparse to pessimise this, it needs to be able
11035 * to restore the pushmark's original op_next, which it
11036 * will assume to be the same as op_sibling. */
11037 if (o->op_next != o->op_sibling)
11038 break;
11039 p = o;
11040 }
a7fd8ef6
DM		 11041
11042 /* scan for PAD ops */
11043
d5524600 11044 for (p = p->op_next; p; p = p->op_next) {
a7fd8ef6
DM		 11045 if (p->op_type == OP_NULL)
11046 continue;
11047
11048 if (( p->op_type != OP_PADSV
11049 && p->op_type != OP_PADAV
11050 && p->op_type != OP_PADHV
11051 )
11052 /* any private flag other than INTRO? e.g. STATE */
11053 || (p->op_private & ~OPpLVAL_INTRO)
11054 )
11055 break;
11056
11057 /* let $a[N] potentially be optimised into ALEMFAST_LEX
11058 * instead */
11059 if ( p->op_type == OP_PADAV
11060 && p->op_next
11061 && p->op_next->op_type == OP_CONST
11062 && p->op_next->op_next
11063 && p->op_next->op_next->op_type == OP_AELEM
11064 )
11065 break;
11066
11067 /* for 1st padop, note what type it is and the range
11068 * start; for the others, check that it's the same type
11069 * and that the targs are contiguous */
11070 if (count == 0) {
11071 intro = (p->op_private & OPpLVAL_INTRO);
11072 base = p->op_targ;
11073 gimme = (p->op_flags & OPf_WANT);
11074 }
11075 else {
11076 if ((p->op_private & OPpLVAL_INTRO) != intro)
11077 break;
18c931a3
DM		 11078 /* Note that you'd normally expect targs to be
11079 * contiguous in my($a,$b,$c), but that's not the case
11080 * when external modules start doing things, e.g.
11081 i* Function::Parameters */
11082 if (p->op_targ != base + count)
a7fd8ef6
DM		 11083 break;
11084 assert(p->op_targ == base + count);
11085 /* all the padops should be in the same context */
11086 if (gimme != (p->op_flags & OPf_WANT))
11087 break;
11088 }
11089
11090 /* for AV, HV, only when we're not flattening */
11091 if ( p->op_type != OP_PADSV
11092 && gimme != OPf_WANT_VOID
11093 && !(p->op_flags & OPf_REF)
11094 )
11095 break;
11096
11097 if (count >= OPpPADRANGE_COUNTMASK)
11098 break;
11099
4e09461c
DM		 11100 /* there's a biggest base we can fit into a
11101 * SAVEt_CLEARPADRANGE in pp_padrange */
11102 if (intro && base >
11103 (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT)))
11104 break;
11105
a7fd8ef6
DM		 11106 /* Success! We've got another valid pad op to optimise away */
11107 count++;
11108 followop = p->op_next;
11109 }
11110
11111 if (count < 1)
11112 break;
11113
4774ee0a 11114 /* pp_padrange in specifically compile-time void context
a7fd8ef6
DM		 11115 * skips pushing a mark and lexicals; in all other contexts
11116 * (including unknown till runtime) it pushes a mark and the
11117 * lexicals. We must be very careful then, that the ops we
11118 * optimise away would have exactly the same effect as the
11119 * padrange.
11120 * In particular in void context, we can only optimise to
11121 * a padrange if see see the complete sequence
11122 * pushmark, pad*v, ...., list, nextstate
11123 * which has the net effect of of leaving the stack empty
11124 * (for now we leave the nextstate in the execution chain, for
11125 * its other side-effects).
11126 */
11127 assert(followop);
11128 if (gimme == OPf_WANT_VOID) {
11129 if (followop->op_type == OP_LIST
11130 && gimme == (followop->op_flags & OPf_WANT)
11131 && ( followop->op_next->op_type == OP_NEXTSTATE
11132 || followop->op_next->op_type == OP_DBSTATE))
4774ee0a 11133 {
a7fd8ef6 11134 followop = followop->op_next; /* skip OP_LIST */
4774ee0a
DM		 11135
11136 /* consolidate two successive my(...);'s */
fd3cc9e5 11137
4774ee0a
DM		 11138 if ( oldoldop
11139 && oldoldop->op_type == OP_PADRANGE
11140 && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
11141 && (oldoldop->op_private & OPpLVAL_INTRO) == intro
fd3cc9e5 11142 && !(oldoldop->op_flags & OPf_SPECIAL)
4774ee0a
DM		 11143 ) {
11144 U8 old_count;
11145 assert(oldoldop->op_next == oldop);
11146 assert( oldop->op_type == OP_NEXTSTATE
11147 || oldop->op_type == OP_DBSTATE);
11148 assert(oldop->op_next == o);
11149
11150 old_count
11151 = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
11152 assert(oldoldop->op_targ + old_count == base);
11153
11154 if (old_count < OPpPADRANGE_COUNTMASK - count) {
fd3cc9e5
DM		 11155 base = oldoldop->op_targ;
11156 count += old_count;
11157 reuse = 1;
4774ee0a
DM		 11158 }
11159 }
fd3cc9e5
DM		 11160
11161 /* if there's any immediately following singleton
11162 * my var's; then swallow them and the associated
11163 * nextstates; i.e.
11164 * my ($a,$b); my $c; my $d;
11165 * is treated as
11166 * my ($a,$b,$c,$d);
11167 */
11168
11169 while ( ((p = followop->op_next))
11170 && ( p->op_type == OP_PADSV
11171 || p->op_type == OP_PADAV
11172 || p->op_type == OP_PADHV)
11173 && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
11174 && (p->op_private & OPpLVAL_INTRO) == intro
11175 && p->op_next
11176 && ( p->op_next->op_type == OP_NEXTSTATE
11177 || p->op_next->op_type == OP_DBSTATE)
11178 && count < OPpPADRANGE_COUNTMASK
11179 ) {
11180 assert(base + count == p->op_targ);
11181 count++;
11182 followop = p->op_next;
11183 }
4774ee0a 11184 }
a7fd8ef6
DM		 11185 else
11186 break;
11187 }
11188
fd3cc9e5
DM		 11189 if (reuse) {
11190 assert(oldoldop->op_type == OP_PADRANGE);
11191 oldoldop->op_next = followop;
11192 oldoldop->op_private = (intro | count);
11193 o = oldoldop;
11194 oldop = NULL;
11195 oldoldop = NULL;
11196 }
11197 else {
11198 /* Convert the pushmark into a padrange.
11199 * To make Deparse easier, we guarantee that a padrange was
11200 * *always* formerly a pushmark */
11201 assert(o->op_type == OP_PUSHMARK);
11202 o->op_next = followop;
11203 o->op_type = OP_PADRANGE;
11204 o->op_ppaddr = PL_ppaddr[OP_PADRANGE];
11205 o->op_targ = base;
11206 /* bit 7: INTRO; bit 6..0: count */
11207 o->op_private = (intro | count);
11208 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
11209 | gimme | (defav ? OPf_SPECIAL : 0));
11210 }
a7fd8ef6
DM		 11211 break;
11212 }
11213
6a077020 11214 case OP_PADAV:
79072805 11215 case OP_GV:
6a077020 11216 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
0bd48802 11217 OP* const pop = (o->op_type == OP_PADAV) ?
6a077020 11218 o->op_next : o->op_next->op_next;
a0d0e21e 11219 IV i;
f9dc862f 11220 if (pop && pop->op_type == OP_CONST &&
af5acbb4 11221 ((PL_op = pop->op_next)) &&
8990e307 11222 pop->op_next->op_type == OP_AELEM &&
a0d0e21e 11223 !(pop->op_next->op_private &
78f9721b 11224 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
e1dccc0d 11225 (i = SvIV(((SVOP*)pop)->op_sv)) <= 255 && i >= 0)
8990e307 11226 {
350de78d 11227 GV *gv;
af5acbb4
DM		 11228 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
11229 no_bareword_allowed(pop);
6a077020
DM		 11230 if (o->op_type == OP_GV)
11231 op_null(o->op_next);
93c66552
DM		 11232 op_null(pop->op_next);
11233 op_null(pop);
a0d0e21e
LW		 11234 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
11235 o->op_next = pop->op_next->op_next;
22c35a8c 11236 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
a0d0e21e 11237 o->op_private = (U8)i;
6a077020
DM		 11238 if (o->op_type == OP_GV) {
11239 gv = cGVOPo_gv;
11240 GvAVn(gv);
93bad3fd 11241 o->op_type = OP_AELEMFAST;
6a077020
DM		 11242 }
11243 else
93bad3fd 11244 o->op_type = OP_AELEMFAST_LEX;
6a077020 11245 }
6a077020
DM		 11246 break;
11247 }
11248
11249 if (o->op_next->op_type == OP_RV2SV) {
11250 if (!(o->op_next->op_private & OPpDEREF)) {
11251 op_null(o->op_next);
11252 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
11253 | OPpOUR_INTRO);
11254 o->op_next = o->op_next->op_next;
11255 o->op_type = OP_GVSV;
11256 o->op_ppaddr = PL_ppaddr[OP_GVSV];
8990e307 11257 }
79072805 11258 }
89de2904
AMS		 11259 else if (o->op_next->op_type == OP_READLINE
11260 && o->op_next->op_next->op_type == OP_CONCAT
11261 && (o->op_next->op_next->op_flags & OPf_STACKED))
11262 {
d2c45030
AMS		 11263 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
11264 o->op_type = OP_RCATLINE;
11265 o->op_flags |= OPf_STACKED;
11266 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
89de2904 11267 op_null(o->op_next->op_next);
d2c45030 11268 op_null(o->op_next);
89de2904 11269 }
76cd736e 11270
79072805 11271 break;
867fa1e2
YO		 11272
11273 {
11274 OP *fop;
11275 OP *sop;
11276
9e7f031c
FC		 11277#define HV_OR_SCALARHV(op) \
11278 ( (op)->op_type == OP_PADHV || (op)->op_type == OP_RV2HV \
11279 ? (op) \
11280 : (op)->op_type == OP_SCALAR && (op)->op_flags & OPf_KIDS \
11281 && ( cUNOPx(op)->op_first->op_type == OP_PADHV \
11282 || cUNOPx(op)->op_first->op_type == OP_RV2HV) \
11283 ? cUNOPx(op)->op_first \
11284 : NULL)
11285
867fa1e2 11286 case OP_NOT:
9e7f031c
FC		 11287 if ((fop = HV_OR_SCALARHV(cUNOP->op_first)))
11288 fop->op_private |= OPpTRUEBOOL;
867fa1e2
YO		 11289 break;
11290
11291 case OP_AND:
79072805 11292 case OP_OR:
c963b151 11293 case OP_DOR:
867fa1e2
YO		 11294 fop = cLOGOP->op_first;
11295 sop = fop->op_sibling;
11296 while (cLOGOP->op_other->op_type == OP_NULL)
11297 cLOGOP->op_other = cLOGOP->op_other->op_next;
db4d68cf
DM		 11298 while (o->op_next && ( o->op_type == o->op_next->op_type
11299 || o->op_next->op_type == OP_NULL))
11300 o->op_next = o->op_next->op_next;
3c78429c 11301 DEFER(cLOGOP->op_other);
867fa1e2 11302
867fa1e2 11303 o->op_opt = 1;
c8fe3bdf
FC		 11304 fop = HV_OR_SCALARHV(fop);
11305 if (sop) sop = HV_OR_SCALARHV(sop);
11306 if (fop || sop
867fa1e2
YO		 11307 ){
11308 OP * nop = o;
11309 OP * lop = o;
aaf643ce 11310 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
867fa1e2
YO		 11311 while (nop && nop->op_next) {
11312 switch (nop->op_next->op_type) {
11313 case OP_NOT:
11314 case OP_AND:
11315 case OP_OR:
11316 case OP_DOR:
11317 lop = nop = nop->op_next;
11318 break;
11319 case OP_NULL:
11320 nop = nop->op_next;
11321 break;
11322 default:
11323 nop = NULL;
11324 break;
11325 }
11326 }
11327 }
c8fe3bdf
FC		 11328 if (fop) {
11329 if ( (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
20e53f5f 11330 || o->op_type == OP_AND )
c8fe3bdf
FC		 11331 fop->op_private |= OPpTRUEBOOL;
11332 else if (!(lop->op_flags & OPf_WANT))
adc42c31 11333 fop->op_private |= OPpMAYBE_TRUEBOOL;
6ea72b3a 11334 }
20e53f5f 11335 if ( (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
c8fe3bdf
FC		 11336 && sop)
11337 sop->op_private |= OPpTRUEBOOL;
867fa1e2
YO		 11338 }
11339
11340
11341 break;
867fa1e2 11342
a8b106e9 11343 case OP_COND_EXPR:
c8fe3bdf 11344 if ((fop = HV_OR_SCALARHV(cLOGOP->op_first)))
9e7f031c 11345 fop->op_private |= OPpTRUEBOOL;
a8b106e9
FC		 11346#undef HV_OR_SCALARHV
11347 /* GERONIMO! */
c8fe3bdf 11348 }
a8b106e9 11349
867fa1e2
YO		 11350 case OP_MAPWHILE:
11351 case OP_GREPWHILE:
2c2d71f5
JH		 11352 case OP_ANDASSIGN:
11353 case OP_ORASSIGN:
c963b151 11354 case OP_DORASSIGN:
1a67a97c 11355 case OP_RANGE:
c5917253 11356 case OP_ONCE:
fd4d1407
IZ		 11357 while (cLOGOP->op_other->op_type == OP_NULL)
11358 cLOGOP->op_other = cLOGOP->op_other->op_next;
3c78429c 11359 DEFER(cLOGOP->op_other);
79072805
LW		 11360 break;
11361
79072805 11362 case OP_ENTERLOOP:
9c2ca71a 11363 case OP_ENTERITER:
58cccf98
SM		 11364 while (cLOOP->op_redoop->op_type == OP_NULL)
11365 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
58cccf98
SM		 11366 while (cLOOP->op_nextop->op_type == OP_NULL)
11367 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
58cccf98
SM		 11368 while (cLOOP->op_lastop->op_type == OP_NULL)
11369 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
3c78429c
DM		 11370 /* a while(1) loop doesn't have an op_next that escapes the
11371 * loop, so we have to explicitly follow the op_lastop to
11372 * process the rest of the code */
11373 DEFER(cLOOP->op_lastop);
79072805
LW		 11374 break;
11375
79072805 11376 case OP_SUBST:
29f2e912
NC		 11377 assert(!(cPMOP->op_pmflags & PMf_ONCE));
11378 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
11379 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
11380 cPMOP->op_pmstashstartu.op_pmreplstart
11381 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
3c78429c 11382 DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
79072805
LW		 11383 break;
11384
fe1bc4cf 11385 case OP_SORT: {
d7ab38e8
FC		 11386 OP *oright;
11387
11388 if (o->op_flags & OPf_STACKED) {
11389 OP * const kid =
11390 cUNOPx(cLISTOP->op_first->op_sibling)->op_first;
11391 if (kid->op_type == OP_SCOPE
08fdcd99
FC		 11392 || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE))
11393 DEFER(kLISTOP->op_first);
d7ab38e8
FC		 11394 }
11395
fe1bc4cf 11396 /* check that RHS of sort is a single plain array */
d7ab38e8 11397 oright = cUNOPo->op_first;
fe1bc4cf
DM		 11398 if (!oright || oright->op_type != OP_PUSHMARK)
11399 break;
471178c0 11400
540dd770
GG		 11401 if (o->op_private & OPpSORT_INPLACE)
11402 break;
11403
471178c0
NC		 11404 /* reverse sort ... can be optimised. */
11405 if (!cUNOPo->op_sibling) {
11406 /* Nothing follows us on the list. */
551405c4 11407 OP * const reverse = o->op_next;
471178c0
NC		 11408
11409 if (reverse->op_type == OP_REVERSE &&
11410 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
551405c4 11411 OP * const pushmark = cUNOPx(reverse)->op_first;
471178c0
NC		 11412 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
11413 && (cUNOPx(pushmark)->op_sibling == o)) {
11414 /* reverse -> pushmark -> sort */
11415 o->op_private |= OPpSORT_REVERSE;
11416 op_null(reverse);
11417 pushmark->op_next = oright->op_next;
11418 op_null(oright);
11419 }
11420 }
11421 }
11422
fe1bc4cf
DM		 11423 break;
11424 }
ef3e5ea9
NC		 11425
11426 case OP_REVERSE: {
e682d7b7 11427 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
ce335f37 11428 OP *gvop = NULL;
ef3e5ea9 11429 LISTOP *enter, *exlist;
ef3e5ea9 11430
540dd770 11431 if (o->op_private & OPpSORT_INPLACE)
484c818f 11432 break;
484c818f 11433
ef3e5ea9
NC		 11434 enter = (LISTOP *) o->op_next;
11435 if (!enter)
11436 break;
11437 if (enter->op_type == OP_NULL) {
11438 enter = (LISTOP *) enter->op_next;
11439 if (!enter)
11440 break;
11441 }
d46f46af
NC		 11442 /* for $a (...) will have OP_GV then OP_RV2GV here.
11443 for (...) just has an OP_GV. */
ce335f37
NC		 11444 if (enter->op_type == OP_GV) {
11445 gvop = (OP *) enter;
11446 enter = (LISTOP *) enter->op_next;
11447 if (!enter)
11448 break;
d46f46af
NC		 11449 if (enter->op_type == OP_RV2GV) {
11450 enter = (LISTOP *) enter->op_next;
11451 if (!enter)
ce335f37 11452 break;
d46f46af 11453 }
ce335f37
NC		 11454 }
11455
ef3e5ea9
NC		 11456 if (enter->op_type != OP_ENTERITER)
11457 break;
11458
11459 iter = enter->op_next;
11460 if (!iter || iter->op_type != OP_ITER)
11461 break;
11462
ce335f37
NC		 11463 expushmark = enter->op_first;
11464 if (!expushmark || expushmark->op_type != OP_NULL
11465 || expushmark->op_targ != OP_PUSHMARK)
11466 break;
11467
11468 exlist = (LISTOP *) expushmark->op_sibling;
ef3e5ea9
NC		 11469 if (!exlist || exlist->op_type != OP_NULL
11470 || exlist->op_targ != OP_LIST)
11471 break;
11472
11473 if (exlist->op_last != o) {
11474 /* Mmm. Was expecting to point back to this op. */
11475 break;
11476 }
11477 theirmark = exlist->op_first;
11478 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
11479 break;
11480
c491ecac 11481 if (theirmark->op_sibling != o) {
ef3e5ea9
NC		 11482 /* There's something between the mark and the reverse, eg
11483 for (1, reverse (...))
11484 so no go. */
11485 break;
11486 }
11487
c491ecac
NC		 11488 ourmark = ((LISTOP *)o)->op_first;
11489 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
11490 break;
11491
ef3e5ea9
NC		 11492 ourlast = ((LISTOP *)o)->op_last;
11493 if (!ourlast || ourlast->op_next != o)
11494 break;
11495
e682d7b7
NC		 11496 rv2av = ourmark->op_sibling;
11497 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
11498 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
11499 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
11500 /* We're just reversing a single array. */
11501 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
11502 enter->op_flags |= OPf_STACKED;
11503 }
11504
ef3e5ea9
NC		 11505 /* We don't have control over who points to theirmark, so sacrifice
11506 ours. */
11507 theirmark->op_next = ourmark->op_next;
11508 theirmark->op_flags = ourmark->op_flags;
ce335f37 11509 ourlast->op_next = gvop ? gvop : (OP *) enter;
ef3e5ea9
NC		 11510 op_null(ourmark);
11511 op_null(o);
11512 enter->op_private |= OPpITER_REVERSED;
11513 iter->op_private |= OPpITER_REVERSED;
11514
11515 break;
11516 }
e26df76a 11517
0477511c
NC		 11518 case OP_QR:
11519 case OP_MATCH:
29f2e912
NC		 11520 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
11521 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
11522 }
79072805 11523 break;
1830b3d9 11524
1a35f9ff
FC		 11525 case OP_RUNCV:
11526 if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)) {
11527 SV *sv;
e157a82b 11528 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
1a35f9ff
FC		 11529 else {
11530 sv = newRV((SV *)PL_compcv);
11531 sv_rvweaken(sv);
11532 SvREADONLY_on(sv);
11533 }
11534 o->op_type = OP_CONST;
11535 o->op_ppaddr = PL_ppaddr[OP_CONST];
11536 o->op_flags |= OPf_SPECIAL;
11537 cSVOPo->op_sv = sv;
11538 }
11539 break;
11540
24fcb59f
FC		 11541 case OP_SASSIGN:
11542 if (OP_GIMME(o,0) == G_VOID) {
11543 OP *right = cBINOP->op_first;
11544 if (right) {
11545 OP *left = right->op_sibling;
11546 if (left->op_type == OP_SUBSTR
11547 && (left->op_private & 7) < 4) {
11548 op_null(o);
11549 cBINOP->op_first = left;
11550 right->op_sibling =
11551 cBINOPx(left)->op_first->op_sibling;
11552 cBINOPx(left)->op_first->op_sibling = right;
11553 left->op_private |= OPpSUBSTR_REPL_FIRST;
d72a08ce
FC		 11554 left->op_flags =
11555 (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
24fcb59f
FC		 11556 }
11557 }
11558 }
11559 break;
11560
1830b3d9
BM		 11561 case OP_CUSTOM: {
11562 Perl_cpeep_t cpeep =
11563 XopENTRY(Perl_custom_op_xop(aTHX_ o), xop_peep);
11564 if (cpeep)
11565 cpeep(aTHX_ o, oldop);
11566 break;
11567 }
11568
79072805 11569 }
4774ee0a 11570 oldoldop = oldop;
a0d0e21e 11571 oldop = o;
79072805 11572 }
a0d0e21e 11573 LEAVE;
79072805 11574}
beab0874 11575
1a0a2ba9 11576void
5aaab254 11577Perl_peep(pTHX_ OP *o)
1a0a2ba9
Z		 11578{
11579 CALL_RPEEP(o);
11580}
11581
9733086d
BM		 11582/*
11583=head1 Custom Operators
11584
11585=for apidoc Ao||custom_op_xop
11586Return the XOP structure for a given custom op. This function should be
11587considered internal to OP_NAME and the other access macros: use them instead.
11588
11589=cut
11590*/
11591
1830b3d9
BM		 11592const XOP *
11593Perl_custom_op_xop(pTHX_ const OP *o)
53e06cf0 11594{
1830b3d9
BM		 11595 SV *keysv;
11596 HE *he = NULL;
11597 XOP *xop;
11598
11599 static const XOP xop_null = { 0, 0, 0, 0, 0 };
53e06cf0 11600
1830b3d9
BM		 11601 PERL_ARGS_ASSERT_CUSTOM_OP_XOP;
11602 assert(o->op_type == OP_CUSTOM);
7918f24d 11603
1830b3d9
BM		 11604 /* This is wrong. It assumes a function pointer can be cast to IV,
11605 * which isn't guaranteed, but this is what the old custom OP code
11606 * did. In principle it should be safer to Copy the bytes of the
11607 * pointer into a PV: since the new interface is hidden behind
11608 * functions, this can be changed later if necessary. */
11609 /* Change custom_op_xop if this ever happens */
11610 keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
53e06cf0 11611
1830b3d9
BM		 11612 if (PL_custom_ops)
11613 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
11614
11615 /* assume noone will have just registered a desc */
11616 if (!he && PL_custom_op_names &&
11617 (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
11618 ) {
11619 const char *pv;
11620 STRLEN l;
11621
11622 /* XXX does all this need to be shared mem? */
aca83993 11623 Newxz(xop, 1, XOP);
1830b3d9
BM		 11624 pv = SvPV(HeVAL(he), l);
11625 XopENTRY_set(xop, xop_name, savepvn(pv, l));
11626 if (PL_custom_op_descs &&
11627 (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
11628 ) {
11629 pv = SvPV(HeVAL(he), l);
11630 XopENTRY_set(xop, xop_desc, savepvn(pv, l));
11631 }
11632 Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
11633 return xop;
11634 }
53e06cf0 11635
1830b3d9 11636 if (!he) return &xop_null;
53e06cf0 11637
1830b3d9
BM		 11638 xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
11639 return xop;
53e06cf0
SC		 11640}
11641
9733086d
BM		 11642/*
11643=for apidoc Ao||custom_op_register
11644Register a custom op. See L<perlguts/"Custom Operators">.
53e06cf0 11645
9733086d
BM		 11646=cut
11647*/
7918f24d 11648
1830b3d9
BM		 11649void
11650Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
11651{
11652 SV *keysv;
11653
11654 PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
53e06cf0 11655
1830b3d9
BM		 11656 /* see the comment in custom_op_xop */
11657 keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
53e06cf0 11658
1830b3d9
BM		 11659 if (!PL_custom_ops)
11660 PL_custom_ops = newHV();
53e06cf0 11661
1830b3d9
BM		 11662 if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
11663 Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
53e06cf0 11664}
19e8ce8e 11665
b8c38f0a
FC		 11666/*
11667=head1 Functions in file op.c
11668
11669=for apidoc core_prototype
11670This function assigns the prototype of the named core function to C<sv>, or
11671to a new mortal SV if C<sv> is NULL. It returns the modified C<sv>, or
a051f6c4 11672NULL if the core function has no prototype. C<code> is a code as returned
4e338c21 11673by C<keyword()>. It must not be equal to 0 or -KEY_CORE.
b8c38f0a
FC		 11674
11675=cut
11676*/
11677
11678SV *
be1b855b 11679Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
b66130dd 11680 int * const opnum)
b8c38f0a 11681{
b8c38f0a
FC		 11682 int i = 0, n = 0, seen_question = 0, defgv = 0;
11683 I32 oa;
11684#define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
11685 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
9927957a 11686 bool nullret = FALSE;
b8c38f0a
FC		 11687
11688 PERL_ARGS_ASSERT_CORE_PROTOTYPE;
11689
4e338c21 11690 assert (code && code != -KEY_CORE);
b8c38f0a
FC		 11691
11692 if (!sv) sv = sv_newmortal();
11693
9927957a 11694#define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
b8c38f0a 11695
4e338c21 11696 switch (code < 0 ? -code : code) {
b8c38f0a 11697 case KEY_and : case KEY_chop: case KEY_chomp:
4e338c21
FC		 11698 case KEY_cmp : case KEY_defined: case KEY_delete: case KEY_exec :
11699 case KEY_exists: case KEY_eq : case KEY_ge : case KEY_goto :
11700 case KEY_grep : case KEY_gt : case KEY_last : case KEY_le :
11701 case KEY_lt : case KEY_map : case KEY_ne : case KEY_next :
11702 case KEY_or : case KEY_print : case KEY_printf: case KEY_qr :
11703 case KEY_redo : case KEY_require: case KEY_return: case KEY_say :
11704 case KEY_select: case KEY_sort : case KEY_split : case KEY_system:
11705 case KEY_x : case KEY_xor :
9927957a 11706 if (!opnum) return NULL; nullret = TRUE; goto findopnum;
4e338c21 11707 case KEY_glob: retsetpvs("_;", OP_GLOB);
9927957a
FC		 11708 case KEY_keys: retsetpvs("+", OP_KEYS);
11709 case KEY_values: retsetpvs("+", OP_VALUES);
11710 case KEY_each: retsetpvs("+", OP_EACH);
11711 case KEY_push: retsetpvs("+@", OP_PUSH);
11712 case KEY_unshift: retsetpvs("+@", OP_UNSHIFT);
11713 case KEY_pop: retsetpvs(";+", OP_POP);
11714 case KEY_shift: retsetpvs(";+", OP_SHIFT);
4e338c21 11715 case KEY_pos: retsetpvs(";\\[$*]", OP_POS);
b8c38f0a 11716 case KEY_splice:
9927957a 11717 retsetpvs("+;$$@", OP_SPLICE);
b8c38f0a 11718 case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
9927957a 11719 retsetpvs("", 0);
7d789282
FC		 11720 case KEY_evalbytes:
11721 name = "entereval"; break;
b8c38f0a
FC		 11722 case KEY_readpipe:
11723 name = "backtick";
11724 }
11725
11726#undef retsetpvs
11727
9927957a 11728 findopnum:
b8c38f0a
FC		 11729 while (i < MAXO) { /* The slow way. */
11730 if (strEQ(name, PL_op_name[i])
11731 || strEQ(name, PL_op_desc[i]))
11732 {
9927957a 11733 if (nullret) { assert(opnum); *opnum = i; return NULL; }
b8c38f0a
FC		 11734 goto found;
11735 }
11736 i++;
11737 }
4e338c21 11738 return NULL;
b8c38f0a
FC		 11739 found:
11740 defgv = PL_opargs[i] & OA_DEFGV;
11741 oa = PL_opargs[i] >> OASHIFT;
11742 while (oa) {
465bc0f5 11743 if (oa & OA_OPTIONAL && !seen_question && (
ea5703f4 11744 !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
465bc0f5 11745 )) {
b8c38f0a
FC		 11746 seen_question = 1;
11747 str[n++] = ';';
11748 }
11749 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
11750 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
11751 /* But globs are already references (kinda) */
11752 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
11753 ) {
11754 str[n++] = '\\';
11755 }
1ecbeecf
FC		 11756 if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
11757 && !scalar_mod_type(NULL, i)) {
11758 str[n++] = '[';
11759 str[n++] = '$';
11760 str[n++] = '@';
11761 str[n++] = '%';
89c5c07e 11762 if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
1ecbeecf
FC		 11763 str[n++] = '*';
11764 str[n++] = ']';
11765 }
11766 else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
ea5703f4
FC		 11767 if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
11768 str[n-1] = '_'; defgv = 0;
11769 }
b8c38f0a
FC		 11770 oa = oa >> 4;
11771 }
dcbdef25 11772 if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
b8c38f0a
FC		 11773 str[n++] = '\0';
11774 sv_setpvn(sv, str, n - 1);
9927957a 11775 if (opnum) *opnum = i;
b8c38f0a
FC		 11776 return sv;
11777}
11778
1e4b6aa1
FC		 11779OP *
11780Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
11781 const int opnum)
11782{
11783 OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
c931b036 11784 OP *o;
1e4b6aa1
FC		 11785
11786 PERL_ARGS_ASSERT_CORESUB_OP;
11787
11788 switch(opnum) {
11789 case 0:
c2f605db 11790 return op_append_elem(OP_LINESEQ,
1e4b6aa1
FC		 11791 argop,
11792 newSLICEOP(0,
c2f605db 11793 newSVOP(OP_CONST, 0, newSViv(-code % 3)),
1e4b6aa1
FC		 11794 newOP(OP_CALLER,0)
11795 )
c2f605db 11796 );
720d5b2f
FC		 11797 case OP_SELECT: /* which represents OP_SSELECT as well */
11798 if (code)
11799 return newCONDOP(
11800 0,
11801 newBINOP(OP_GT, 0,
11802 newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
11803 newSVOP(OP_CONST, 0, newSVuv(1))
11804 ),
11805 coresub_op(newSVuv((UV)OP_SSELECT), 0,
11806 OP_SSELECT),
11807 coresub_op(coreargssv, 0, OP_SELECT)
11808 );
11809 /* FALL THROUGH */
1e4b6aa1
FC		 11810 default:
11811 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
11812 case OA_BASEOP:
11813 return op_append_elem(
11814 OP_LINESEQ, argop,
11815 newOP(opnum,
84ed0108
FC		 11816 opnum == OP_WANTARRAY || opnum == OP_RUNCV
11817 ? OPpOFFBYONE << 8 : 0)
1e4b6aa1 11818 );
527d644b 11819 case OA_BASEOP_OR_UNOP:
7d789282
FC		 11820 if (opnum == OP_ENTEREVAL) {
11821 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
11822 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
11823 }
11824 else o = newUNOP(opnum,0,argop);
ce0b554b
FC		 11825 if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
11826 else {
c931b036 11827 onearg:
ce0b554b 11828 if (is_handle_constructor(o, 1))
c931b036 11829 argop->op_private |= OPpCOREARGS_DEREF1;
1efec5ed
FC		 11830 if (scalar_mod_type(NULL, opnum))
11831 argop->op_private |= OPpCOREARGS_SCALARMOD;
ce0b554b 11832 }
c931b036 11833 return o;
527d644b 11834 default:
498a02d8 11835 o = convert(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
c931b036
FC		 11836 if (is_handle_constructor(o, 2))
11837 argop->op_private |= OPpCOREARGS_DEREF2;
7bc95ae1
FC		 11838 if (opnum == OP_SUBSTR) {
11839 o->op_private |= OPpMAYBE_LVSUB;
11840 return o;
11841 }
11842 else goto onearg;
1e4b6aa1
FC		 11843 }
11844 }
11845}
11846
156d738f
FC		 11847void
11848Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
11849 SV * const *new_const_svp)
11850{
11851 const char *hvname;
11852 bool is_const = !!CvCONST(old_cv);
11853 SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
11854
11855 PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
11856
11857 if (is_const && new_const_svp && old_const_sv == *new_const_svp)
11858 return;
11859 /* They are 2 constant subroutines generated from
11860 the same constant. This probably means that
11861 they are really the "same" proxy subroutine
11862 instantiated in 2 places. Most likely this is
11863 when a constant is exported twice. Don't warn.
11864 */
11865 if (
11866 (ckWARN(WARN_REDEFINE)
11867 && !(
11868 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
11869 && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
11870 && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
11871 strEQ(hvname, "autouse"))
11872 )
11873 )
11874 || (is_const
11875 && ckWARN_d(WARN_REDEFINE)
11876 && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
11877 )
11878 )
11879 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
11880 is_const
11881 ? "Constant subroutine %"SVf" redefined"
11882 : "Subroutine %"SVf" redefined",
11883 name);
11884}
11885
e8570548
Z		 11886/*
11887=head1 Hook manipulation
11888
11889These functions provide convenient and thread-safe means of manipulating
11890hook variables.
11891
11892=cut
11893*/
11894
11895/*
11896=for apidoc Am|void|wrap_op_checker|Optype opcode|Perl_check_t new_checker|Perl_check_t *old_checker_p
11897
11898Puts a C function into the chain of check functions for a specified op
11899type. This is the preferred way to manipulate the L</PL_check> array.
11900I<opcode> specifies which type of op is to be affected. I<new_checker>
11901is a pointer to the C function that is to be added to that opcode's
11902check chain, and I<old_checker_p> points to the storage location where a
11903pointer to the next function in the chain will be stored. The value of
11904I<new_pointer> is written into the L</PL_check> array, while the value
11905previously stored there is written to I<*old_checker_p>.
11906
11907L</PL_check> is global to an entire process, and a module wishing to
11908hook op checking may find itself invoked more than once per process,
11909typically in different threads. To handle that situation, this function
11910is idempotent. The location I<*old_checker_p> must initially (once
11911per process) contain a null pointer. A C variable of static duration
11912(declared at file scope, typically also marked C<static> to give
11913it internal linkage) will be implicitly initialised appropriately,
11914if it does not have an explicit initialiser. This function will only
11915actually modify the check chain if it finds I<*old_checker_p> to be null.
11916This function is also thread safe on the small scale. It uses appropriate
11917locking to avoid race conditions in accessing L</PL_check>.
11918
11919When this function is called, the function referenced by I<new_checker>
11920must be ready to be called, except for I<*old_checker_p> being unfilled.
11921In a threading situation, I<new_checker> may be called immediately,
11922even before this function has returned. I<*old_checker_p> will always
11923be appropriately set before I<new_checker> is called. If I<new_checker>
11924decides not to do anything special with an op that it is given (which
11925is the usual case for most uses of op check hooking), it must chain the
11926check function referenced by I<*old_checker_p>.
11927
11928If you want to influence compilation of calls to a specific subroutine,
11929then use L</cv_set_call_checker> rather than hooking checking of all
11930C<entersub> ops.
11931
11932=cut
11933*/
11934
11935void
11936Perl_wrap_op_checker(pTHX_ Optype opcode,
11937 Perl_check_t new_checker, Perl_check_t *old_checker_p)
11938{
9b11155f
TC		 11939 dVAR;
11940
e8570548
Z		 11941 PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
11942 if (*old_checker_p) return;
11943 OP_CHECK_MUTEX_LOCK;
11944 if (!*old_checker_p) {
11945 *old_checker_p = PL_check[opcode];
11946 PL_check[opcode] = new_checker;
11947 }
11948 OP_CHECK_MUTEX_UNLOCK;
11949}
11950
beab0874
JT		 11951#include "XSUB.h"
11952
11953/* Efficient sub that returns a constant scalar value. */
11954static void
acfe0abc 11955const_sv_xsub(pTHX_ CV* cv)
beab0874 11956{
97aff369 11957 dVAR;
beab0874 11958 dXSARGS;
99ab892b 11959 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
fcfc2536 11960 PERL_UNUSED_ARG(items);
99ab892b
NC		 11961 if (!sv) {
11962 XSRETURN(0);
11963 }
9a049f1c 11964 EXTEND(sp, 1);
99ab892b 11965 ST(0) = sv;
beab0874
JT		 11966 XSRETURN(1);
11967}
4946a0fa
NC		 11968
11969/*
11970 * Local variables:
11971 * c-indentation-style: bsd
11972 * c-basic-offset: 4
14d04a33 11973 * indent-tabs-mode: nil
4946a0fa
NC		 11974 * End:
11975 *
14d04a33 11976 * ex: set ts=8 sts=4 sw=4 et:
37442d52 11977 */
Unnamed repository; edit this file 'description' to name the repository.