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