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
Compile-time checking for %$obj{"key"} under ‘use fields’
[perl5.git] / op.c
CommitLineData
4b88f280 1#line 2 "op.c"
a0d0e21e 2/* op.c
79072805 3 *
1129b882
NC		 4 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
5 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
79072805
LW		 6 *
7 * You may distribute under the terms of either the GNU General Public
8 * License or the Artistic License, as specified in the README file.
9 *
a0d0e21e
LW		 10 */
11
12/*
4ac71550
TC		 13 * 'You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
14 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
15 * youngest of the Old Took's daughters); and Mr. Drogo was his second
16 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
17 * either way, as the saying is, if you follow me.' --the Gaffer
18 *
19 * [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
79072805
LW		 20 */
21
166f8a29
DM		 22/* This file contains the functions that create, manipulate and optimize
23 * the OP structures that hold a compiled perl program.
24 *
25 * A Perl program is compiled into a tree of OPs. Each op contains
26 * structural pointers (eg to its siblings and the next op in the
27 * execution sequence), a pointer to the function that would execute the
28 * op, plus any data specific to that op. For example, an OP_CONST op
29 * points to the pp_const() function and to an SV containing the constant
30 * value. When pp_const() is executed, its job is to push that SV onto the
31 * stack.
32 *
33 * OPs are mainly created by the newFOO() functions, which are mainly
34 * called from the parser (in perly.y) as the code is parsed. For example
35 * the Perl code $a + $b * $c would cause the equivalent of the following
36 * to be called (oversimplifying a bit):
37 *
38 * newBINOP(OP_ADD, flags,
39 * newSVREF($a),
40 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
41 * )
42 *
43 * Note that during the build of miniperl, a temporary copy of this file
44 * is made, called opmini.c.
45 */
ccfc67b7 46
61b743bb
DM		 47/*
48Perl's compiler is essentially a 3-pass compiler with interleaved phases:
49
50 A bottom-up pass
51 A top-down pass
52 An execution-order pass
53
54The bottom-up pass is represented by all the "newOP" routines and
55the ck_ routines. The bottom-upness is actually driven by yacc.
56So at the point that a ck_ routine fires, we have no idea what the
57context is, either upward in the syntax tree, or either forward or
58backward in the execution order. (The bottom-up parser builds that
59part of the execution order it knows about, but if you follow the "next"
60links around, you'll find it's actually a closed loop through the
ef9da979 61top level node.)
61b743bb
DM		 62
63Whenever the bottom-up parser gets to a node that supplies context to
64its components, it invokes that portion of the top-down pass that applies
65to that part of the subtree (and marks the top node as processed, so
66if a node further up supplies context, it doesn't have to take the
67plunge again). As a particular subcase of this, as the new node is
68built, it takes all the closed execution loops of its subcomponents
69and links them into a new closed loop for the higher level node. But
70it's still not the real execution order.
71
72The actual execution order is not known till we get a grammar reduction
73to a top-level unit like a subroutine or file that will be called by
74"name" rather than via a "next" pointer. At that point, we can call
75into peep() to do that code's portion of the 3rd pass. It has to be
76recursive, but it's recursive on basic blocks, not on tree nodes.
77*/
78
06e0342d 79/* To implement user lexical pragmas, there needs to be a way at run time to
b3ca2e83
NC		 80 get the compile time state of %^H for that block. Storing %^H in every
81 block (or even COP) would be very expensive, so a different approach is
82 taken. The (running) state of %^H is serialised into a tree of HE-like
83 structs. Stores into %^H are chained onto the current leaf as a struct
84 refcounted_he * with the key and the value. Deletes from %^H are saved
85 with a value of PL_sv_placeholder. The state of %^H at any point can be
86 turned back into a regular HV by walking back up the tree from that point's
06e0342d 87 leaf, ignoring any key you've already seen (placeholder or not), storing
b3ca2e83
NC		 88 the rest into the HV structure, then removing the placeholders. Hence
89 memory is only used to store the %^H deltas from the enclosing COP, rather
90 than the entire %^H on each COP.
91
92 To cause actions on %^H to write out the serialisation records, it has
93 magic type 'H'. This magic (itself) does nothing, but its presence causes
94 the values to gain magic type 'h', which has entries for set and clear.
c28fe1ec 95 C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
34795b44 96 record, with deletes written by C<Perl_magic_clearhint>. C<SAVEHINTS>
c28fe1ec
NC		 97 saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
98 it will be correctly restored when any inner compiling scope is exited.
b3ca2e83
NC		 99*/
100
79072805 101#include "EXTERN.h"
864dbfa3 102#define PERL_IN_OP_C
79072805 103#include "perl.h"
77ca0c92 104#include "keywords.h"
2846acbf 105#include "feature.h"
74529a43 106#include "regcomp.h"
79072805 107
16c91539 108#define CALL_PEEP(o) PL_peepp(aTHX_ o)
1a0a2ba9 109#define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
16c91539 110#define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
a2efc822 111
8be227ab
FC		 112/* See the explanatory comments above struct opslab in op.h. */
113
7aef8e5b 114#ifdef PERL_DEBUG_READONLY_OPS
3107b51f
FC		 115# define PERL_SLAB_SIZE 128
116# define PERL_MAX_SLAB_SIZE 4096
117# include <sys/mman.h>
7aef8e5b 118#endif
3107b51f 119
7aef8e5b 120#ifndef PERL_SLAB_SIZE
8be227ab 121# define PERL_SLAB_SIZE 64
7aef8e5b
FC		 122#endif
123#ifndef PERL_MAX_SLAB_SIZE
e6cee8c0 124# define PERL_MAX_SLAB_SIZE 2048
7aef8e5b 125#endif
8be227ab
FC		 126
127/* rounds up to nearest pointer */
7aef8e5b
FC		 128#define SIZE_TO_PSIZE(x) (((x) + sizeof(I32 *) - 1)/sizeof(I32 *))
129#define DIFF(o,p) ((size_t)((I32 **)(p) - (I32**)(o)))
8be227ab
FC		 130
131static OPSLAB *
132S_new_slab(pTHX_ size_t sz)
133{
7aef8e5b 134#ifdef PERL_DEBUG_READONLY_OPS
3107b51f
FC		 135 OPSLAB *slab = (OPSLAB *) mmap(0, sz * sizeof(I32 *),
136 PROT_READ|PROT_WRITE,
137 MAP_ANON|MAP_PRIVATE, -1, 0);
138 DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
139 (unsigned long) sz, slab));
140 if (slab == MAP_FAILED) {
141 perror("mmap failed");
142 abort();
143 }
144 slab->opslab_size = (U16)sz;
7aef8e5b 145#else
8be227ab 146 OPSLAB *slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *));
7aef8e5b 147#endif
8be227ab
FC		 148 slab->opslab_first = (OPSLOT *)((I32 **)slab + sz - 1);
149 return slab;
150}
151
e7372881
FC		 152/* requires double parens and aTHX_ */
153#define DEBUG_S_warn(args) \
154 DEBUG_S( \
155 PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \
156 )
157
8be227ab
FC		 158void *
159Perl_Slab_Alloc(pTHX_ size_t sz)
160{
161 dVAR;
162 OPSLAB *slab;
163 OPSLAB *slab2;
164 OPSLOT *slot;
165 OP *o;
5cb52f30 166 size_t opsz, space;
8be227ab 167
2073970f
NC		 168 /* We only allocate ops from the slab during subroutine compilation.
169 We find the slab via PL_compcv, hence that must be non-NULL. It could
170 also be pointing to a subroutine which is now fully set up (CvROOT()
171 pointing to the top of the optree for that sub), or a subroutine
172 which isn't using the slab allocator. If our sanity checks aren't met,
173 don't use a slab, but allocate the OP directly from the heap. */
8be227ab
FC		 174 if (!PL_compcv || CvROOT(PL_compcv)
175 || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv)))
176 return PerlMemShared_calloc(1, sz);
177
2073970f
NC		 178 /* While the subroutine is under construction, the slabs are accessed via
179 CvSTART(), to avoid needing to expand PVCV by one pointer for something
180 unneeded at runtime. Once a subroutine is constructed, the slabs are
181 accessed via CvROOT(). So if CvSTART() is NULL, no slab has been
182 allocated yet. See the commit message for 8be227ab5eaa23f2 for more
183 details. */
184 if (!CvSTART(PL_compcv)) {
8be227ab
FC		 185 CvSTART(PL_compcv) =
186 (OP *)(slab = S_new_slab(aTHX_ PERL_SLAB_SIZE));
187 CvSLABBED_on(PL_compcv);
188 slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */
189 }
190 else ++(slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
191
5cb52f30
FC		 192 opsz = SIZE_TO_PSIZE(sz);
193 sz = opsz + OPSLOT_HEADER_P;
8be227ab 194
2073970f
NC		 195 /* The slabs maintain a free list of OPs. In particular, constant folding
196 will free up OPs, so it makes sense to re-use them where possible. A
197 freed up slot is used in preference to a new allocation. */
8be227ab
FC		 198 if (slab->opslab_freed) {
199 OP **too = &slab->opslab_freed;
200 o = *too;
e7372881 201 DEBUG_S_warn((aTHX_ "found free op at %p, slab %p", o, slab));
8be227ab 202 while (o && DIFF(OpSLOT(o), OpSLOT(o)->opslot_next) < sz) {
e7372881 203 DEBUG_S_warn((aTHX_ "Alas! too small"));
8be227ab 204 o = *(too = &o->op_next);
94b67eb2 205 if (o) { DEBUG_S_warn((aTHX_ "found another free op at %p", o)); }
8be227ab
FC		 206 }
207 if (o) {
208 *too = o->op_next;
5cb52f30 209 Zero(o, opsz, I32 *);
8be227ab
FC		 210 o->op_slabbed = 1;
211 return (void *)o;
212 }
213 }
214
7aef8e5b 215#define INIT_OPSLOT \
8be227ab
FC		 216 slot->opslot_slab = slab; \
217 slot->opslot_next = slab2->opslab_first; \
218 slab2->opslab_first = slot; \
219 o = &slot->opslot_op; \
220 o->op_slabbed = 1
221
222 /* The partially-filled slab is next in the chain. */
223 slab2 = slab->opslab_next ? slab->opslab_next : slab;
224 if ((space = DIFF(&slab2->opslab_slots, slab2->opslab_first)) < sz) {
225 /* Remaining space is too small. */
226
8be227ab
FC		 227 /* If we can fit a BASEOP, add it to the free chain, so as not
228 to waste it. */
229 if (space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) {
230 slot = &slab2->opslab_slots;
231 INIT_OPSLOT;
232 o->op_type = OP_FREED;
233 o->op_next = slab->opslab_freed;
234 slab->opslab_freed = o;
235 }
236
237 /* Create a new slab. Make this one twice as big. */
238 slot = slab2->opslab_first;
239 while (slot->opslot_next) slot = slot->opslot_next;
af7751f6
FC		 240 slab2 = S_new_slab(aTHX_
241 (DIFF(slab2, slot)+1)*2 > PERL_MAX_SLAB_SIZE
e6cee8c0 242 ? PERL_MAX_SLAB_SIZE
af7751f6 243 : (DIFF(slab2, slot)+1)*2);
9963ffa2
FC		 244 slab2->opslab_next = slab->opslab_next;
245 slab->opslab_next = slab2;
8be227ab
FC		 246 }
247 assert(DIFF(&slab2->opslab_slots, slab2->opslab_first) >= sz);
248
249 /* Create a new op slot */
250 slot = (OPSLOT *)((I32 **)slab2->opslab_first - sz);
251 assert(slot >= &slab2->opslab_slots);
51c777ca
FC		 252 if (DIFF(&slab2->opslab_slots, slot)
253 < SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P)
254 slot = &slab2->opslab_slots;
8be227ab 255 INIT_OPSLOT;
e7372881 256 DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", o, slab));
8be227ab
FC		 257 return (void *)o;
258}
259
7aef8e5b 260#undef INIT_OPSLOT
8be227ab 261
7aef8e5b 262#ifdef PERL_DEBUG_READONLY_OPS
3107b51f
FC		 263void
264Perl_Slab_to_ro(pTHX_ OPSLAB *slab)
265{
266 PERL_ARGS_ASSERT_SLAB_TO_RO;
267
268 if (slab->opslab_readonly) return;
269 slab->opslab_readonly = 1;
270 for (; slab; slab = slab->opslab_next) {
271 /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->ro %lu at %p\n",
272 (unsigned long) slab->opslab_size, slab));*/
273 if (mprotect(slab, slab->opslab_size * sizeof(I32 *), PROT_READ))
274 Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", slab,
275 (unsigned long)slab->opslab_size, errno);
276 }
277}
278
7bbbc3c0
NC		 279void
280Perl_Slab_to_rw(pTHX_ OPSLAB *const slab)
3107b51f 281{
3107b51f
FC		 282 OPSLAB *slab2;
283
284 PERL_ARGS_ASSERT_SLAB_TO_RW;
285
3107b51f
FC		 286 if (!slab->opslab_readonly) return;
287 slab2 = slab;
288 for (; slab2; slab2 = slab2->opslab_next) {
289 /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n",
290 (unsigned long) size, slab2));*/
291 if (mprotect((void *)slab2, slab2->opslab_size * sizeof(I32 *),
292 PROT_READ|PROT_WRITE)) {
293 Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", slab,
294 (unsigned long)slab2->opslab_size, errno);
295 }
296 }
297 slab->opslab_readonly = 0;
298}
299
300#else
9e4d7a13 301# define Slab_to_rw(op) NOOP
3107b51f
FC		 302#endif
303
8be227ab
FC		 304/* This cannot possibly be right, but it was copied from the old slab
305 allocator, to which it was originally added, without explanation, in
306 commit 083fcd5. */
7aef8e5b 307#ifdef NETWARE
8be227ab 308# define PerlMemShared PerlMem
7aef8e5b 309#endif
8be227ab
FC		 310
311void
312Perl_Slab_Free(pTHX_ void *op)
313{
20429ba0 314 dVAR;
8be227ab
FC		 315 OP * const o = (OP *)op;
316 OPSLAB *slab;
317
318 PERL_ARGS_ASSERT_SLAB_FREE;
319
320 if (!o->op_slabbed) {
90840c5d
RU		 321 if (!o->op_static)
322 PerlMemShared_free(op);
8be227ab
FC		 323 return;
324 }
325
326 slab = OpSLAB(o);
327 /* If this op is already freed, our refcount will get screwy. */
328 assert(o->op_type != OP_FREED);
329 o->op_type = OP_FREED;
330 o->op_next = slab->opslab_freed;
331 slab->opslab_freed = o;
e7372881 332 DEBUG_S_warn((aTHX_ "free op at %p, recorded in slab %p", o, slab));
8be227ab
FC		 333 OpslabREFCNT_dec_padok(slab);
334}
335
336void
337Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
338{
339 dVAR;
340 const bool havepad = !!PL_comppad;
341 PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD;
342 if (havepad) {
343 ENTER;
344 PAD_SAVE_SETNULLPAD();
345 }
346 opslab_free(slab);
347 if (havepad) LEAVE;
348}
349
350void
351Perl_opslab_free(pTHX_ OPSLAB *slab)
352{
20429ba0 353 dVAR;
8be227ab
FC		 354 OPSLAB *slab2;
355 PERL_ARGS_ASSERT_OPSLAB_FREE;
e7372881 356 DEBUG_S_warn((aTHX_ "freeing slab %p", slab));
8be227ab
FC		 357 assert(slab->opslab_refcnt == 1);
358 for (; slab; slab = slab2) {
359 slab2 = slab->opslab_next;
7aef8e5b 360#ifdef DEBUGGING
8be227ab 361 slab->opslab_refcnt = ~(size_t)0;
7aef8e5b
FC		 362#endif
363#ifdef PERL_DEBUG_READONLY_OPS
3107b51f
FC		 364 DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
365 slab));
366 if (munmap(slab, slab->opslab_size * sizeof(I32 *))) {
367 perror("munmap failed");
368 abort();
369 }
7aef8e5b 370#else
8be227ab 371 PerlMemShared_free(slab);
7aef8e5b 372#endif
8be227ab
FC		 373 }
374}
375
376void
377Perl_opslab_force_free(pTHX_ OPSLAB *slab)
378{
379 OPSLAB *slab2;
380 OPSLOT *slot;
7aef8e5b 381#ifdef DEBUGGING
8be227ab 382 size_t savestack_count = 0;
7aef8e5b 383#endif
8be227ab
FC		 384 PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
385 slab2 = slab;
386 do {
387 for (slot = slab2->opslab_first;
388 slot->opslot_next;
389 slot = slot->opslot_next) {
390 if (slot->opslot_op.op_type != OP_FREED
391 && !(slot->opslot_op.op_savefree
7aef8e5b 392#ifdef DEBUGGING
8be227ab 393 && ++savestack_count
7aef8e5b 394#endif
8be227ab
FC		 395 )
396 ) {
397 assert(slot->opslot_op.op_slabbed);
8be227ab 398 op_free(&slot->opslot_op);
3bf28c7e 399 if (slab->opslab_refcnt == 1) goto free;
8be227ab
FC		 400 }
401 }
402 } while ((slab2 = slab2->opslab_next));
403 /* > 1 because the CV still holds a reference count. */
404 if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */
7aef8e5b 405#ifdef DEBUGGING
8be227ab 406 assert(savestack_count == slab->opslab_refcnt-1);
7aef8e5b 407#endif
ee5ee853
FC		 408 /* Remove the CV’s reference count. */
409 slab->opslab_refcnt--;
8be227ab
FC		 410 return;
411 }
412 free:
413 opslab_free(slab);
414}
415
3107b51f
FC		 416#ifdef PERL_DEBUG_READONLY_OPS
417OP *
418Perl_op_refcnt_inc(pTHX_ OP *o)
419{
420 if(o) {
372eab01
NC		 421 OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
422 if (slab && slab->opslab_readonly) {
83519873 423 Slab_to_rw(slab);
372eab01
NC		 424 ++o->op_targ;
425 Slab_to_ro(slab);
426 } else {
427 ++o->op_targ;
428 }
3107b51f
FC		 429 }
430 return o;
431
432}
433
434PADOFFSET
435Perl_op_refcnt_dec(pTHX_ OP *o)
436{
372eab01
NC		 437 PADOFFSET result;
438 OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
439
3107b51f 440 PERL_ARGS_ASSERT_OP_REFCNT_DEC;
372eab01
NC		 441
442 if (slab && slab->opslab_readonly) {
83519873 443 Slab_to_rw(slab);
372eab01
NC		 444 result = --o->op_targ;
445 Slab_to_ro(slab);
446 } else {
447 result = --o->op_targ;
448 }
449 return result;
3107b51f
FC		 450}
451#endif
e50aee73 452/*
ce6f1cbc 453 * In the following definition, the ", (OP*)0" is just to make the compiler
a5f75d66 454 * think the expression is of the right type: croak actually does a Siglongjmp.
e50aee73 455 */
11343788 456#define CHECKOP(type,o) \
ce6f1cbc 457 ((PL_op_mask && PL_op_mask[type]) \
5dc0d613 458 ? ( op_free((OP*)o), \
cb77fdf0 459 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
ce6f1cbc 460 (OP*)0 ) \
16c91539 461 : PL_check[type](aTHX_ (OP*)o))
e50aee73 462
e6438c1a 463#define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
c53d7c7d 464
cba5a3b0
DG		 465#define CHANGE_TYPE(o,type) \
466 STMT_START { \
467 o->op_type = (OPCODE)type; \
468 o->op_ppaddr = PL_ppaddr[type]; \
469 } STMT_END
470
ce16c625 471STATIC SV*
cea2e8a9 472S_gv_ename(pTHX_ GV *gv)
4633a7c4 473{
46c461b5 474 SV* const tmpsv = sv_newmortal();
7918f24d
NC		 475
476 PERL_ARGS_ASSERT_GV_ENAME;
477
bd61b366 478 gv_efullname3(tmpsv, gv, NULL);
ce16c625 479 return tmpsv;
4633a7c4
LW		 480}
481
76e3520e 482STATIC OP *
cea2e8a9 483S_no_fh_allowed(pTHX_ OP *o)
79072805 484{
7918f24d
NC		 485 PERL_ARGS_ASSERT_NO_FH_ALLOWED;
486
cea2e8a9 487 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
53e06cf0 488 OP_DESC(o)));
11343788 489 return o;
79072805
LW		 490}
491
76e3520e 492STATIC OP *
ce16c625 493S_too_few_arguments_sv(pTHX_ OP *o, SV *namesv, U32 flags)
79072805 494{
ce16c625
BF		 495 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_SV;
496 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf, namesv),
497 SvUTF8(namesv) | flags);
498 return o;
499}
500
501STATIC OP *
502S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
503{
504 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
505 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
506 return o;
507}
508
509STATIC OP *
510S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
511{
512 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
7918f24d 513
ce16c625 514 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
11343788 515 return o;
79072805
LW		 516}
517
76e3520e 518STATIC OP *
ce16c625 519S_too_many_arguments_sv(pTHX_ OP *o, SV *namesv, U32 flags)
79072805 520{
ce16c625 521 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_SV;
7918f24d 522
ce16c625
BF		 523 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %"SVf, SVfARG(namesv)),
524 SvUTF8(namesv) | flags);
11343788 525 return o;
79072805
LW		 526}
527
76e3520e 528STATIC void
ce16c625 529S_bad_type_pv(pTHX_ I32 n, const char *t, const char *name, U32 flags, const OP *kid)
8990e307 530{
ce16c625
BF		 531 PERL_ARGS_ASSERT_BAD_TYPE_PV;
532
533 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
534 (int)n, name, t, OP_DESC(kid)), flags);
535}
7918f24d 536
ce16c625 537STATIC void
7b3b0904 538S_bad_type_gv(pTHX_ I32 n, const char *t, GV *gv, U32 flags, const OP *kid)
ce16c625 539{
7b3b0904
FC		 540 SV * const namesv = gv_ename(gv);
541 PERL_ARGS_ASSERT_BAD_TYPE_GV;
ce16c625
BF		 542
543 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %"SVf" must be %s (not %s)",
544 (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv) | flags);
8990e307
LW		 545}
546
7a52d87a 547STATIC void
eb796c7f 548S_no_bareword_allowed(pTHX_ OP *o)
7a52d87a 549{
7918f24d
NC		 550 PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
551
eb8433b7
NC		 552 if (PL_madskills)
553 return; /* various ok barewords are hidden in extra OP_NULL */
5a844595 554 qerror(Perl_mess(aTHX_
35c1215d 555 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
be2597df 556 SVfARG(cSVOPo_sv)));
eb796c7f 557 o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
7a52d87a
GS		 558}
559
79072805
LW		 560/* "register" allocation */
561
562PADOFFSET
d6447115 563Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
93a17b20 564{
97aff369 565 dVAR;
a0d0e21e 566 PADOFFSET off;
12bd6ede 567 const bool is_our = (PL_parser->in_my == KEY_our);
a0d0e21e 568
7918f24d
NC		 569 PERL_ARGS_ASSERT_ALLOCMY;
570
48d0d1be 571 if (flags & ~SVf_UTF8)
d6447115
NC		 572 Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
573 (UV)flags);
574
575 /* Until we're using the length for real, cross check that we're being
576 told the truth. */
577 assert(strlen(name) == len);
578
59f00321 579 /* complain about "my $<special_var>" etc etc */
d6447115 580 if (len &&
3edf23ff 581 !(is_our ||
155aba94 582 isALPHA(name[1]) ||
b14845b4 583 ((flags & SVf_UTF8) && isIDFIRST_utf8((U8 *)name+1)) ||
d6447115 584 (name[1] == '_' && (*name == '$' || len > 2))))
834a4ddd 585 {
6b58708b 586 /* name[2] is true if strlen(name) > 2 */
b14845b4
FC		 587 if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
588 && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
d6447115
NC		 589 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
590 name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
aab6a793 591 PL_parser->in_my == KEY_state ? "state" : "my"));
d1544d85 592 } else {
ce16c625
BF		 593 yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
594 PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
46fc3d4c 595 }
a0d0e21e 596 }
4055dbce
RS		 597 else if (len == 2 && name[1] == '_' && !is_our)
598 /* diag_listed_as: Use of my $_ is experimental */
599 Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__LEXICAL_TOPIC),
600 "Use of %s $_ is experimental",
601 PL_parser->in_my == KEY_state
602 ? "state"
603 : "my");
748a9306 604
dd2155a4 605 /* allocate a spare slot and store the name in that slot */
93a17b20 606
cc76b5cc 607 off = pad_add_name_pvn(name, len,
48d0d1be
BF		 608 (is_our ? padadd_OUR :
609 PL_parser->in_my == KEY_state ? padadd_STATE : 0)
610 | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 ),
12bd6ede 611 PL_parser->in_my_stash,
3edf23ff 612 (is_our
133706a6
RGS		 613 /* $_ is always in main::, even with our */
614 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
5c284bb0 615 : NULL
cca43f78 616 )
dd2155a4 617 );
a74073ad
DM		 618 /* anon sub prototypes contains state vars should always be cloned,
619 * otherwise the state var would be shared between anon subs */
620
621 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
622 CvCLONE_on(PL_compcv);
623
dd2155a4 624 return off;
79072805
LW		 625}
626
c0b8aebd
FC		 627/*
628=for apidoc alloccopstash
629
630Available only under threaded builds, this function allocates an entry in
631C<PL_stashpad> for the stash passed to it.
632
633=cut
634*/
635
d4d03940
FC		 636#ifdef USE_ITHREADS
637PADOFFSET
1dc74fdb 638Perl_alloccopstash(pTHX_ HV *hv)
d4d03940
FC		 639{
640 PADOFFSET off = 0, o = 1;
641 bool found_slot = FALSE;
642
1dc74fdb
FC		 643 PERL_ARGS_ASSERT_ALLOCCOPSTASH;
644
645 if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
d4d03940 646
1dc74fdb
FC		 647 for (; o < PL_stashpadmax; ++o) {
648 if (PL_stashpad[o] == hv) return PL_stashpadix = o;
649 if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
d4d03940
FC		 650 found_slot = TRUE, off = o;
651 }
652 if (!found_slot) {
1dc74fdb
FC		 653 Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
654 Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
655 off = PL_stashpadmax;
656 PL_stashpadmax += 10;
d4d03940
FC		 657 }
658
1dc74fdb 659 PL_stashpad[PL_stashpadix = off] = hv;
d4d03940
FC		 660 return off;
661}
662#endif
663
d2c837a0
DM		 664/* free the body of an op without examining its contents.
665 * Always use this rather than FreeOp directly */
666
4136a0f7 667static void
d2c837a0
DM		 668S_op_destroy(pTHX_ OP *o)
669{
d2c837a0
DM		 670 FreeOp(o);
671}
672
79072805
LW		 673/* Destructor */
674
675void
864dbfa3 676Perl_op_free(pTHX_ OP *o)
79072805 677{
27da23d5 678 dVAR;
acb36ea4 679 OPCODE type;
79072805 680
8be227ab
FC		 681 /* Though ops may be freed twice, freeing the op after its slab is a
682 big no-no. */
683 assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
8be227ab
FC		 684 /* During the forced freeing of ops after compilation failure, kidops
685 may be freed before their parents. */
686 if (!o || o->op_type == OP_FREED)
79072805
LW		 687 return;
688
67566ccd 689 type = o->op_type;
7934575e 690 if (o->op_private & OPpREFCOUNTED) {
67566ccd 691 switch (type) {
7934575e
GS		 692 case OP_LEAVESUB:
693 case OP_LEAVESUBLV:
694 case OP_LEAVEEVAL:
695 case OP_LEAVE:
696 case OP_SCOPE:
697 case OP_LEAVEWRITE:
67566ccd
AL		 698 {
699 PADOFFSET refcnt;
7934575e 700 OP_REFCNT_LOCK;
4026c95a 701 refcnt = OpREFCNT_dec(o);
7934575e 702 OP_REFCNT_UNLOCK;
bfd0ff22
NC		 703 if (refcnt) {
704 /* Need to find and remove any pattern match ops from the list
705 we maintain for reset(). */
706 find_and_forget_pmops(o);
4026c95a 707 return;
67566ccd 708 }
bfd0ff22 709 }
7934575e
GS		 710 break;
711 default:
712 break;
713 }
714 }
715
f37b8c3f
VP		 716 /* Call the op_free hook if it has been set. Do it now so that it's called
717 * at the right time for refcounted ops, but still before all of the kids
718 * are freed. */
719 CALL_OPFREEHOOK(o);
720
11343788 721 if (o->op_flags & OPf_KIDS) {
eb578fdb 722 OP *kid, *nextkid;
11343788 723 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
85e6fe83 724 nextkid = kid->op_sibling; /* Get before next freeing kid */
79072805 725 op_free(kid);
85e6fe83 726 }
79072805 727 }
513f78f7
FC		 728 if (type == OP_NULL)
729 type = (OPCODE)o->op_targ;
acb36ea4 730
9e4d7a13
NC		 731 if (o->op_slabbed)
732 Slab_to_rw(OpSLAB(o));
fc97af9c 733
acb36ea4
GS		 734 /* COP* is not cleared by op_clear() so that we may track line
735 * numbers etc even after null() */
513f78f7 736 if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
acb36ea4 737 cop_free((COP*)o);
3235b7a3 738 }
acb36ea4
GS		 739
740 op_clear(o);
238a4c30 741 FreeOp(o);
4d494880
DM		 742#ifdef DEBUG_LEAKING_SCALARS
743 if (PL_op == o)
5f66b61c 744 PL_op = NULL;
4d494880 745#endif
acb36ea4 746}
79072805 747
93c66552
DM		 748void
749Perl_op_clear(pTHX_ OP *o)
acb36ea4 750{
13137afc 751
27da23d5 752 dVAR;
7918f24d
NC		 753
754 PERL_ARGS_ASSERT_OP_CLEAR;
755
eb8433b7 756#ifdef PERL_MAD
df31c78c
NC		 757 mad_free(o->op_madprop);
758 o->op_madprop = 0;
eb8433b7
NC		 759#endif
760
761 retry:
11343788 762 switch (o->op_type) {
acb36ea4 763 case OP_NULL: /* Was holding old type, if any. */
eb8433b7 764 if (PL_madskills && o->op_targ != OP_NULL) {
61a59f30 765 o->op_type = (Optype)o->op_targ;
eb8433b7
NC		 766 o->op_targ = 0;
767 goto retry;
768 }
4d193d44 769 case OP_ENTERTRY:
acb36ea4 770 case OP_ENTEREVAL: /* Was holding hints. */
acb36ea4 771 o->op_targ = 0;
a0d0e21e 772 break;
a6006777 773 default:
ac4c12e7 774 if (!(o->op_flags & OPf_REF)
ef69c8fc 775 || (PL_check[o->op_type] != Perl_ck_ftst))
a6006777 776 break;
777 /* FALL THROUGH */
463ee0b2 778 case OP_GVSV:
79072805 779 case OP_GV:
a6006777 780 case OP_AELEMFAST:
93bad3fd 781 {
f7461760
Z		 782 GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV)
783#ifdef USE_ITHREADS
784 && PL_curpad
785#endif
786 ? cGVOPo_gv : NULL;
b327b36f
NC		 787 /* It's possible during global destruction that the GV is freed
788 before the optree. Whilst the SvREFCNT_inc is happy to bump from
789 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
790 will trigger an assertion failure, because the entry to sv_clear
791 checks that the scalar is not already freed. A check of for
792 !SvIS_FREED(gv) turns out to be invalid, because during global
793 destruction the reference count can be forced down to zero
794 (with SVf_BREAK set). In which case raising to 1 and then
795 dropping to 0 triggers cleanup before it should happen. I
796 *think* that this might actually be a general, systematic,
797 weakness of the whole idea of SVf_BREAK, in that code *is*
798 allowed to raise and lower references during global destruction,
799 so any *valid* code that happens to do this during global
800 destruction might well trigger premature cleanup. */
801 bool still_valid = gv && SvREFCNT(gv);
802
803 if (still_valid)
804 SvREFCNT_inc_simple_void(gv);
350de78d 805#ifdef USE_ITHREADS
6a077020
DM		 806 if (cPADOPo->op_padix > 0) {
807 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
808 * may still exist on the pad */
809 pad_swipe(cPADOPo->op_padix, TRUE);
810 cPADOPo->op_padix = 0;
811 }
350de78d 812#else
6a077020 813 SvREFCNT_dec(cSVOPo->op_sv);
a0714e2c 814 cSVOPo->op_sv = NULL;
350de78d 815#endif
b327b36f 816 if (still_valid) {
f7461760 817 int try_downgrade = SvREFCNT(gv) == 2;
fc2b2dca 818 SvREFCNT_dec_NN(gv);
f7461760
Z		 819 if (try_downgrade)
820 gv_try_downgrade(gv);
821 }
6a077020 822 }
79072805 823 break;
a1ae71d2 824 case OP_METHOD_NAMED:
79072805 825 case OP_CONST:
996c9baa 826 case OP_HINTSEVAL:
11343788 827 SvREFCNT_dec(cSVOPo->op_sv);
a0714e2c 828 cSVOPo->op_sv = NULL;
3b1c21fa
AB		 829#ifdef USE_ITHREADS
830 /** Bug #15654
831 Even if op_clear does a pad_free for the target of the op,
6a077020 832 pad_free doesn't actually remove the sv that exists in the pad;
3b1c21fa
AB		 833 instead it lives on. This results in that it could be reused as
834 a target later on when the pad was reallocated.
835 **/
836 if(o->op_targ) {
837 pad_swipe(o->op_targ,1);
838 o->op_targ = 0;
839 }
840#endif
79072805 841 break;
c9df4fda 842 case OP_DUMP:
748a9306
LW		 843 case OP_GOTO:
844 case OP_NEXT:
845 case OP_LAST:
846 case OP_REDO:
11343788 847 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
748a9306
LW		 848 break;
849 /* FALL THROUGH */
a0d0e21e 850 case OP_TRANS:
bb16bae8 851 case OP_TRANSR:
acb36ea4 852 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
99a1d0d1 853 assert(o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
043e41b8
DM		 854#ifdef USE_ITHREADS
855 if (cPADOPo->op_padix > 0) {
856 pad_swipe(cPADOPo->op_padix, TRUE);
857 cPADOPo->op_padix = 0;
858 }
859#else
a0ed51b3 860 SvREFCNT_dec(cSVOPo->op_sv);
a0714e2c 861 cSVOPo->op_sv = NULL;
043e41b8 862#endif
acb36ea4
GS		 863 }
864 else {
ea71c68d 865 PerlMemShared_free(cPVOPo->op_pv);
bd61b366 866 cPVOPo->op_pv = NULL;
acb36ea4 867 }
a0d0e21e
LW		 868 break;
869 case OP_SUBST:
20e98b0f 870 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
971a9dd3 871 goto clear_pmop;
748a9306 872 case OP_PUSHRE:
971a9dd3 873#ifdef USE_ITHREADS
20e98b0f 874 if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
dd2155a4
DM		 875 /* No GvIN_PAD_off here, because other references may still
876 * exist on the pad */
20e98b0f 877 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
971a9dd3
GS		 878 }
879#else
ad64d0ec 880 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
971a9dd3
GS		 881#endif
882 /* FALL THROUGH */
a0d0e21e 883 case OP_MATCH:
8782bef2 884 case OP_QR:
971a9dd3 885clear_pmop:
867940b8
DM		 886 if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
887 op_free(cPMOPo->op_code_list);
68e2671b 888 cPMOPo->op_code_list = NULL;
23083432 889 forget_pmop(cPMOPo);
20e98b0f 890 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
9cddf794
NC		 891 /* we use the same protection as the "SAFE" version of the PM_ macros
892 * here since sv_clean_all might release some PMOPs
5f8cb046
DM		 893 * after PL_regex_padav has been cleared
894 * and the clearing of PL_regex_padav needs to
895 * happen before sv_clean_all
896 */
13137afc
AB		 897#ifdef USE_ITHREADS
898 if(PL_regex_pad) { /* We could be in destruction */
402d2eb1 899 const IV offset = (cPMOPo)->op_pmoffset;
9cddf794 900 ReREFCNT_dec(PM_GETRE(cPMOPo));
402d2eb1
NC		 901 PL_regex_pad[offset] = &PL_sv_undef;
902 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
903 sizeof(offset));
13137afc 904 }
9cddf794
NC		 905#else
906 ReREFCNT_dec(PM_GETRE(cPMOPo));
907 PM_SETRE(cPMOPo, NULL);
1eb1540c 908#endif
13137afc 909
a0d0e21e 910 break;
79072805
LW		 911 }
912
743e66e6 913 if (o->op_targ > 0) {
11343788 914 pad_free(o->op_targ);
743e66e6
GS		 915 o->op_targ = 0;
916 }
79072805
LW		 917}
918
76e3520e 919STATIC void
3eb57f73
HS		 920S_cop_free(pTHX_ COP* cop)
921{
7918f24d
NC		 922 PERL_ARGS_ASSERT_COP_FREE;
923
05ec9bb3 924 CopFILE_free(cop);
0453d815 925 if (! specialWARN(cop->cop_warnings))
72dc9ed5 926 PerlMemShared_free(cop->cop_warnings);
20439bc7 927 cophh_free(CopHINTHASH_get(cop));
515abc43
FC		 928 if (PL_curcop == cop)
929 PL_curcop = NULL;
3eb57f73
HS		 930}
931
c2b1997a 932STATIC void
c4bd3ae5 933S_forget_pmop(pTHX_ PMOP *const o
c4bd3ae5 934 )
c2b1997a
NC		 935{
936 HV * const pmstash = PmopSTASH(o);
7918f24d
NC		 937
938 PERL_ARGS_ASSERT_FORGET_PMOP;
939
e39a6381 940 if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
ad64d0ec 941 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
c2b1997a
NC		 942 if (mg) {
943 PMOP **const array = (PMOP**) mg->mg_ptr;
944 U32 count = mg->mg_len / sizeof(PMOP**);
945 U32 i = count;
946
947 while (i--) {
948 if (array[i] == o) {
949 /* Found it. Move the entry at the end to overwrite it. */
950 array[i] = array[--count];
951 mg->mg_len = count * sizeof(PMOP**);
952 /* Could realloc smaller at this point always, but probably
953 not worth it. Probably worth free()ing if we're the
954 last. */
955 if(!count) {
956 Safefree(mg->mg_ptr);
957 mg->mg_ptr = NULL;
958 }
959 break;
960 }
961 }
962 }
963 }
1cdf7faf
NC		 964 if (PL_curpm == o)
965 PL_curpm = NULL;
c2b1997a
NC		 966}
967
bfd0ff22
NC		 968STATIC void
969S_find_and_forget_pmops(pTHX_ OP *o)
970{
7918f24d
NC		 971 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
972
bfd0ff22
NC		 973 if (o->op_flags & OPf_KIDS) {
974 OP *kid = cUNOPo->op_first;
975 while (kid) {
976 switch (kid->op_type) {
977 case OP_SUBST:
978 case OP_PUSHRE:
979 case OP_MATCH:
980 case OP_QR:
23083432 981 forget_pmop((PMOP*)kid);
bfd0ff22
NC		 982 }
983 find_and_forget_pmops(kid);
984 kid = kid->op_sibling;
985 }
986 }
987}
988
93c66552
DM		 989void
990Perl_op_null(pTHX_ OP *o)
8990e307 991{
27da23d5 992 dVAR;
7918f24d
NC		 993
994 PERL_ARGS_ASSERT_OP_NULL;
995
acb36ea4
GS		 996 if (o->op_type == OP_NULL)
997 return;
eb8433b7
NC		 998 if (!PL_madskills)
999 op_clear(o);
11343788
MB		 1000 o->op_targ = o->op_type;
1001 o->op_type = OP_NULL;
22c35a8c 1002 o->op_ppaddr = PL_ppaddr[OP_NULL];
8990e307
LW		 1003}
1004
4026c95a
SH		 1005void
1006Perl_op_refcnt_lock(pTHX)
1007{
27da23d5 1008 dVAR;
96a5add6 1009 PERL_UNUSED_CONTEXT;
4026c95a
SH		 1010 OP_REFCNT_LOCK;
1011}
1012
1013void
1014Perl_op_refcnt_unlock(pTHX)
1015{
27da23d5 1016 dVAR;
96a5add6 1017 PERL_UNUSED_CONTEXT;
4026c95a
SH		 1018 OP_REFCNT_UNLOCK;
1019}
1020
79072805
LW		 1021/* Contextualizers */
1022
d9088386
Z		 1023/*
1024=for apidoc Am|OP *|op_contextualize|OP *o|I32 context
1025
1026Applies a syntactic context to an op tree representing an expression.
1027I<o> is the op tree, and I<context> must be C<G_SCALAR>, C<G_ARRAY>,
1028or C<G_VOID> to specify the context to apply. The modified op tree
1029is returned.
1030
1031=cut
1032*/
1033
1034OP *
1035Perl_op_contextualize(pTHX_ OP *o, I32 context)
1036{
1037 PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1038 switch (context) {
1039 case G_SCALAR: return scalar(o);
1040 case G_ARRAY: return list(o);
1041 case G_VOID: return scalarvoid(o);
1042 default:
5637ef5b
NC		 1043 Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1044 (long) context);
d9088386
Z		 1045 return o;
1046 }
1047}
1048
5983a79d
BM		 1049/*
1050=head1 Optree Manipulation Functions
79072805 1051
5983a79d
BM		 1052=for apidoc Am|OP*|op_linklist|OP *o
1053This function is the implementation of the L</LINKLIST> macro. It should
1054not be called directly.
1055
1056=cut
1057*/
1058
1059OP *
1060Perl_op_linklist(pTHX_ OP *o)
79072805 1061{
3edf23ff 1062 OP *first;
79072805 1063
5983a79d 1064 PERL_ARGS_ASSERT_OP_LINKLIST;
7918f24d 1065
11343788
MB		 1066 if (o->op_next)
1067 return o->op_next;
79072805
LW		 1068
1069 /* establish postfix order */
3edf23ff
AL		 1070 first = cUNOPo->op_first;
1071 if (first) {
eb578fdb 1072 OP *kid;
3edf23ff
AL		 1073 o->op_next = LINKLIST(first);
1074 kid = first;
1075 for (;;) {
1076 if (kid->op_sibling) {
79072805 1077 kid->op_next = LINKLIST(kid->op_sibling);
3edf23ff
AL		 1078 kid = kid->op_sibling;
1079 } else {
11343788 1080 kid->op_next = o;
3edf23ff
AL		 1081 break;
1082 }
79072805
LW		 1083 }
1084 }
1085 else
11343788 1086 o->op_next = o;
79072805 1087
11343788 1088 return o->op_next;
79072805
LW		 1089}
1090
1f676739 1091static OP *
2dd5337b 1092S_scalarkids(pTHX_ OP *o)
79072805 1093{
11343788 1094 if (o && o->op_flags & OPf_KIDS) {
bfed75c6 1095 OP *kid;
11343788 1096 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW		 1097 scalar(kid);
1098 }
11343788 1099 return o;
79072805
LW		 1100}
1101
76e3520e 1102STATIC OP *
cea2e8a9 1103S_scalarboolean(pTHX_ OP *o)
8990e307 1104{
97aff369 1105 dVAR;
7918f24d
NC		 1106
1107 PERL_ARGS_ASSERT_SCALARBOOLEAN;
1108
6b7c6d95
FC		 1109 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST
1110 && !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) {
d008e5eb 1111 if (ckWARN(WARN_SYNTAX)) {
6867be6d 1112 const line_t oldline = CopLINE(PL_curcop);
a0d0e21e 1113
2b7cddde
NC		 1114 if (PL_parser && PL_parser->copline != NOLINE) {
1115 /* This ensures that warnings are reported at the first line
1116 of the conditional, not the last. */
53a7735b 1117 CopLINE_set(PL_curcop, PL_parser->copline);
2b7cddde 1118 }
9014280d 1119 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
57843af0 1120 CopLINE_set(PL_curcop, oldline);
d008e5eb 1121 }
a0d0e21e 1122 }
11343788 1123 return scalar(o);
8990e307
LW		 1124}
1125
0920b7fa
FC		 1126static SV *
1127S_op_varname(pTHX_ const OP *o)
1128{
1129 assert(o);
1130 assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1131 o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1132 {
1133 const char funny = o->op_type == OP_PADAV
1134 || o->op_type == OP_RV2AV ? '@' : '%';
1135 if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1136 GV *gv;
1137 if (cUNOPo->op_first->op_type != OP_GV
1138 || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1139 return NULL;
1140 return varname(gv, funny, 0, NULL, 0, 1);
1141 }
1142 return
1143 varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, 1);
1144 }
1145}
1146
429a2555 1147static void
2186f873
FC		 1148S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1149{ /* or not so pretty :-) */
2186f873
FC		 1150 if (o->op_type == OP_CONST) {
1151 *retsv = cSVOPo_sv;
1152 if (SvPOK(*retsv)) {
1153 SV *sv = *retsv;
1154 *retsv = sv_newmortal();
1155 pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1156 PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1157 }
1158 else if (!SvOK(*retsv))
1159 *retpv = "undef";
1160 }
1161 else *retpv = "...";
1162}
1163
1164static void
429a2555
FC		 1165S_scalar_slice_warning(pTHX_ const OP *o)
1166{
1167 OP *kid;
1168 const char lbrack =
2186f873 1169 o->op_type == OP_HSLICE ? '{' : '[';
429a2555 1170 const char rbrack =
2186f873 1171 o->op_type == OP_HSLICE ? '}' : ']';
429a2555 1172 SV *name;
32e9ec8f 1173 SV *keysv = NULL; /* just to silence compiler warnings */
429a2555
FC		 1174 const char *key = NULL;
1175
1176 if (!(o->op_private & OPpSLICEWARNING))
1177 return;
1178 if (PL_parser && PL_parser->error_count)
1179 /* This warning can be nonsensical when there is a syntax error. */
1180 return;
1181
1182 kid = cLISTOPo->op_first;
1183 kid = kid->op_sibling; /* get past pushmark */
1184 /* weed out false positives: any ops that can return lists */
1185 switch (kid->op_type) {
1186 case OP_BACKTICK:
1187 case OP_GLOB:
1188 case OP_READLINE:
1189 case OP_MATCH:
1190 case OP_RV2AV:
1191 case OP_EACH:
1192 case OP_VALUES:
1193 case OP_KEYS:
1194 case OP_SPLIT:
1195 case OP_LIST:
1196 case OP_SORT:
1197 case OP_REVERSE:
1198 case OP_ENTERSUB:
1199 case OP_CALLER:
1200 case OP_LSTAT:
1201 case OP_STAT:
1202 case OP_READDIR:
1203 case OP_SYSTEM:
1204 case OP_TMS:
1205 case OP_LOCALTIME:
1206 case OP_GMTIME:
1207 case OP_ENTEREVAL:
1208 case OP_REACH:
1209 case OP_RKEYS:
1210 case OP_RVALUES:
1211 return;
1212 }
1213 assert(kid->op_sibling);
1214 name = S_op_varname(aTHX_ kid->op_sibling);
1215 if (!name) /* XS module fiddling with the op tree */
1216 return;
2186f873 1217 S_op_pretty(aTHX_ kid, &keysv, &key);
429a2555
FC		 1218 assert(SvPOK(name));
1219 sv_chop(name,SvPVX(name)+1);
1220 if (key)
2186f873 1221 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
429a2555 1222 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
2186f873 1223 "Scalar value @%"SVf"%c%s%c better written as $%"SVf
429a2555 1224 "%c%s%c",
2186f873 1225 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
429a2555
FC		 1226 lbrack, key, rbrack);
1227 else
2186f873 1228 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
429a2555 1229 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
2186f873 1230 "Scalar value @%"SVf"%c%"SVf"%c better written as $%"
429a2555 1231 SVf"%c%"SVf"%c",
2186f873 1232 SVfARG(name), lbrack, keysv, rbrack,
429a2555
FC		 1233 SVfARG(name), lbrack, keysv, rbrack);
1234}
1235
8990e307 1236OP *
864dbfa3 1237Perl_scalar(pTHX_ OP *o)
79072805 1238{
27da23d5 1239 dVAR;
79072805
LW		 1240 OP *kid;
1241
a0d0e21e 1242 /* assumes no premature commitment */
13765c85
DM		 1243 if (!o || (PL_parser && PL_parser->error_count)
1244 || (o->op_flags & OPf_WANT)
5dc0d613 1245 || o->op_type == OP_RETURN)
7e363e51 1246 {
11343788 1247 return o;
7e363e51 1248 }
79072805 1249
5dc0d613 1250 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
79072805 1251
11343788 1252 switch (o->op_type) {
79072805 1253 case OP_REPEAT:
11343788 1254 scalar(cBINOPo->op_first);
8990e307 1255 break;
79072805
LW		 1256 case OP_OR:
1257 case OP_AND:
1258 case OP_COND_EXPR:
11343788 1259 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
8990e307 1260 scalar(kid);
79072805 1261 break;
a0d0e21e 1262 /* FALL THROUGH */
a6d8037e 1263 case OP_SPLIT:
79072805 1264 case OP_MATCH:
8782bef2 1265 case OP_QR:
79072805
LW		 1266 case OP_SUBST:
1267 case OP_NULL:
8990e307 1268 default:
11343788
MB		 1269 if (o->op_flags & OPf_KIDS) {
1270 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
8990e307
LW		 1271 scalar(kid);
1272 }
79072805
LW		 1273 break;
1274 case OP_LEAVE:
1275 case OP_LEAVETRY:
5dc0d613 1276 kid = cLISTOPo->op_first;
54310121 1277 scalar(kid);
25b991bf
VP		 1278 kid = kid->op_sibling;
1279 do_kids:
1280 while (kid) {
1281 OP *sib = kid->op_sibling;
c08f093b
VP		 1282 if (sib && kid->op_type != OP_LEAVEWHEN)
1283 scalarvoid(kid);
1284 else
54310121 1285 scalar(kid);
25b991bf 1286 kid = sib;
54310121 1287 }
11206fdd 1288 PL_curcop = &PL_compiling;
54310121 1289 break;
748a9306 1290 case OP_SCOPE:
79072805 1291 case OP_LINESEQ:
8990e307 1292 case OP_LIST:
25b991bf
VP		 1293 kid = cLISTOPo->op_first;
1294 goto do_kids;
a801c63c 1295 case OP_SORT:
a2a5de95 1296 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
553e7bb0 1297 break;
95a31aad
FC		 1298 case OP_KVHSLICE:
1299 case OP_KVASLICE:
2186f873
FC		 1300 {
1301 /* Warn about scalar context */
1302 const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
1303 const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
1304 SV *name;
1305 SV *keysv;
1306 const char *key = NULL;
1307
1308 /* This warning can be nonsensical when there is a syntax error. */
1309 if (PL_parser && PL_parser->error_count)
1310 break;
1311
1312 if (!ckWARN(WARN_SYNTAX)) break;
1313
1314 kid = cLISTOPo->op_first;
1315 kid = kid->op_sibling; /* get past pushmark */
1316 assert(kid->op_sibling);
1317 name = S_op_varname(aTHX_ kid->op_sibling);
1318 if (!name) /* XS module fiddling with the op tree */
1319 break;
1320 S_op_pretty(aTHX_ kid, &keysv, &key);
1321 assert(SvPOK(name));
1322 sv_chop(name,SvPVX(name)+1);
1323 if (key)
1324 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1325 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1326 "%%%"SVf"%c%s%c in scalar context better written "
1327 "as $%"SVf"%c%s%c",
1328 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1329 lbrack, key, rbrack);
1330 else
1331 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1332 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1333 "%%%"SVf"%c%"SVf"%c in scalar context better "
1334 "written as $%"SVf"%c%"SVf"%c",
1335 SVfARG(name), lbrack, keysv, rbrack,
1336 SVfARG(name), lbrack, keysv, rbrack);
1337 }
79072805 1338 }
11343788 1339 return o;
79072805
LW		 1340}
1341
1342OP *
864dbfa3 1343Perl_scalarvoid(pTHX_ OP *o)
79072805 1344{
27da23d5 1345 dVAR;
79072805 1346 OP *kid;
095b19d1 1347 SV *useless_sv = NULL;
c445ea15 1348 const char* useless = NULL;
8990e307 1349 SV* sv;
2ebea0a1
GS		 1350 U8 want;
1351
7918f24d
NC		 1352 PERL_ARGS_ASSERT_SCALARVOID;
1353
eb8433b7
NC		 1354 /* trailing mad null ops don't count as "there" for void processing */
1355 if (PL_madskills &&
1356 o->op_type != OP_NULL &&
1357 o->op_sibling &&
1358 o->op_sibling->op_type == OP_NULL)
1359 {
1360 OP *sib;
1361 for (sib = o->op_sibling;
1362 sib && sib->op_type == OP_NULL;
1363 sib = sib->op_sibling) ;
1364
1365 if (!sib)
1366 return o;
1367 }
1368
acb36ea4 1369 if (o->op_type == OP_NEXTSTATE
acb36ea4
GS		 1370 || o->op_type == OP_DBSTATE
1371 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
acb36ea4 1372 || o->op_targ == OP_DBSTATE)))
2ebea0a1 1373 PL_curcop = (COP*)o; /* for warning below */
79072805 1374
54310121 1375 /* assumes no premature commitment */
2ebea0a1 1376 want = o->op_flags & OPf_WANT;
13765c85
DM		 1377 if ((want && want != OPf_WANT_SCALAR)
1378 || (PL_parser && PL_parser->error_count)
25b991bf 1379 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
7e363e51 1380 {
11343788 1381 return o;
7e363e51 1382 }
79072805 1383
b162f9ea 1384 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS		 1385 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1386 {
b162f9ea 1387 return scalar(o); /* As if inside SASSIGN */
7e363e51 1388 }
1c846c1f 1389
5dc0d613 1390 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
79072805 1391
11343788 1392 switch (o->op_type) {
79072805 1393 default:
22c35a8c 1394 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
8990e307 1395 break;
36477c24 1396 /* FALL THROUGH */
1397 case OP_REPEAT:
11343788 1398 if (o->op_flags & OPf_STACKED)
8990e307 1399 break;
5d82c453
GA		 1400 goto func_ops;
1401 case OP_SUBSTR:
1402 if (o->op_private == 4)
1403 break;
8990e307
LW		 1404 /* FALL THROUGH */
1405 case OP_GVSV:
1406 case OP_WANTARRAY:
1407 case OP_GV:
74295f0b 1408 case OP_SMARTMATCH:
8990e307
LW		 1409 case OP_PADSV:
1410 case OP_PADAV:
1411 case OP_PADHV:
1412 case OP_PADANY:
1413 case OP_AV2ARYLEN:
8990e307 1414 case OP_REF:
a0d0e21e
LW		 1415 case OP_REFGEN:
1416 case OP_SREFGEN:
8990e307
LW		 1417 case OP_DEFINED:
1418 case OP_HEX:
1419 case OP_OCT:
1420 case OP_LENGTH:
8990e307
LW		 1421 case OP_VEC:
1422 case OP_INDEX:
1423 case OP_RINDEX:
1424 case OP_SPRINTF:
1425 case OP_AELEM:
1426 case OP_AELEMFAST:
93bad3fd 1427 case OP_AELEMFAST_LEX:
8990e307 1428 case OP_ASLICE:
6dd3e0f2 1429 case OP_KVASLICE:
8990e307
LW		 1430 case OP_HELEM:
1431 case OP_HSLICE:
5cae3edb 1432 case OP_KVHSLICE:
8990e307
LW		 1433 case OP_UNPACK:
1434 case OP_PACK:
8990e307
LW		 1435 case OP_JOIN:
1436 case OP_LSLICE:
1437 case OP_ANONLIST:
1438 case OP_ANONHASH:
1439 case OP_SORT:
1440 case OP_REVERSE:
1441 case OP_RANGE:
1442 case OP_FLIP:
1443 case OP_FLOP:
1444 case OP_CALLER:
1445 case OP_FILENO:
1446 case OP_EOF:
1447 case OP_TELL:
1448 case OP_GETSOCKNAME:
1449 case OP_GETPEERNAME:
1450 case OP_READLINK:
1451 case OP_TELLDIR:
1452 case OP_GETPPID:
1453 case OP_GETPGRP:
1454 case OP_GETPRIORITY:
1455 case OP_TIME:
1456 case OP_TMS:
1457 case OP_LOCALTIME:
1458 case OP_GMTIME:
1459 case OP_GHBYNAME:
1460 case OP_GHBYADDR:
1461 case OP_GHOSTENT:
1462 case OP_GNBYNAME:
1463 case OP_GNBYADDR:
1464 case OP_GNETENT:
1465 case OP_GPBYNAME:
1466 case OP_GPBYNUMBER:
1467 case OP_GPROTOENT:
1468 case OP_GSBYNAME:
1469 case OP_GSBYPORT:
1470 case OP_GSERVENT:
1471 case OP_GPWNAM:
1472 case OP_GPWUID:
1473 case OP_GGRNAM:
1474 case OP_GGRGID:
1475 case OP_GETLOGIN:
78e1b766 1476 case OP_PROTOTYPE:
703227f5 1477 case OP_RUNCV:
5d82c453 1478 func_ops:
64aac5a9 1479 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
74295f0b 1480 /* Otherwise it's "Useless use of grep iterator" */
f5df4782 1481 useless = OP_DESC(o);
75068674
RGS		 1482 break;
1483
1484 case OP_SPLIT:
1485 kid = cLISTOPo->op_first;
1486 if (kid && kid->op_type == OP_PUSHRE
1487#ifdef USE_ITHREADS
1488 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff)
1489#else
1490 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv)
1491#endif
1492 useless = OP_DESC(o);
8990e307
LW		 1493 break;
1494
9f82cd5f
YST		 1495 case OP_NOT:
1496 kid = cUNOPo->op_first;
1497 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
bb16bae8 1498 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
9f82cd5f
YST		 1499 goto func_ops;
1500 }
1501 useless = "negative pattern binding (!~)";
1502 break;
1503
4f4d7508
DC		 1504 case OP_SUBST:
1505 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
8db9069c 1506 useless = "non-destructive substitution (s///r)";
4f4d7508
DC		 1507 break;
1508
bb16bae8
FC		 1509 case OP_TRANSR:
1510 useless = "non-destructive transliteration (tr///r)";
1511 break;
1512
8990e307
LW		 1513 case OP_RV2GV:
1514 case OP_RV2SV:
1515 case OP_RV2AV:
1516 case OP_RV2HV:
192587c2 1517 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
11343788 1518 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
8990e307
LW		 1519 useless = "a variable";
1520 break;
79072805
LW		 1521
1522 case OP_CONST:
7766f137 1523 sv = cSVOPo_sv;
7a52d87a
GS		 1524 if (cSVOPo->op_private & OPpCONST_STRICT)
1525 no_bareword_allowed(o);
1526 else {
d008e5eb 1527 if (ckWARN(WARN_VOID)) {
e7fec78e 1528 /* don't warn on optimised away booleans, eg
b5a930ec 1529 * use constant Foo, 5; Foo || print; */
e7fec78e 1530 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
d4c19fe8 1531 useless = NULL;
960b4253
MG		 1532 /* the constants 0 and 1 are permitted as they are
1533 conventionally used as dummies in constructs like
1534 1 while some_condition_with_side_effects; */
c279c455
DM		 1535 else if (SvNIOK(sv) && (NV_eq_nowarn(SvNV(sv), 0.0) ||
1536 NV_eq_nowarn(SvNV(sv), 1.0)))
d4c19fe8 1537 useless = NULL;
d008e5eb 1538 else if (SvPOK(sv)) {
1e3f3188
KW		 1539 SV * const dsv = newSVpvs("");
1540 useless_sv
1541 = Perl_newSVpvf(aTHX_
1542 "a constant (%s)",
1543 pv_pretty(dsv, SvPVX_const(sv),
1544 SvCUR(sv), 32, NULL, NULL,
1545 PERL_PV_PRETTY_DUMP
1546 | PERL_PV_ESCAPE_NOCLEAR
1547 | PERL_PV_ESCAPE_UNI_DETECT));
1548 SvREFCNT_dec_NN(dsv);
d008e5eb 1549 }
919f76a3 1550 else if (SvOK(sv)) {
095b19d1 1551 useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", sv);
919f76a3
RGS		 1552 }
1553 else
1554 useless = "a constant (undef)";
8990e307
LW		 1555 }
1556 }
93c66552 1557 op_null(o); /* don't execute or even remember it */
79072805
LW		 1558 break;
1559
1560 case OP_POSTINC:
11343788 1561 o->op_type = OP_PREINC; /* pre-increment is faster */
22c35a8c 1562 o->op_ppaddr = PL_ppaddr[OP_PREINC];
79072805
LW		 1563 break;
1564
1565 case OP_POSTDEC:
11343788 1566 o->op_type = OP_PREDEC; /* pre-decrement is faster */
22c35a8c 1567 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
79072805
LW		 1568 break;
1569
679d6c4e
HS		 1570 case OP_I_POSTINC:
1571 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1572 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1573 break;
1574
1575 case OP_I_POSTDEC:
1576 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1577 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1578 break;
1579
f2f8fd84
GG		 1580 case OP_SASSIGN: {
1581 OP *rv2gv;
1582 UNOP *refgen, *rv2cv;
1583 LISTOP *exlist;
1584
1585 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
1586 break;
1587
1588 rv2gv = ((BINOP *)o)->op_last;
1589 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
1590 break;
1591
1592 refgen = (UNOP *)((BINOP *)o)->op_first;
1593
1594 if (!refgen || refgen->op_type != OP_REFGEN)
1595 break;
1596
1597 exlist = (LISTOP *)refgen->op_first;
1598 if (!exlist || exlist->op_type != OP_NULL
1599 || exlist->op_targ != OP_LIST)
1600 break;
1601
1602 if (exlist->op_first->op_type != OP_PUSHMARK)
1603 break;
1604
1605 rv2cv = (UNOP*)exlist->op_last;
1606
1607 if (rv2cv->op_type != OP_RV2CV)
1608 break;
1609
1610 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
1611 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
1612 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
1613
1614 o->op_private |= OPpASSIGN_CV_TO_GV;
1615 rv2gv->op_private |= OPpDONT_INIT_GV;
1616 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
1617
1618 break;
1619 }
1620
540dd770
GG		 1621 case OP_AASSIGN: {
1622 inplace_aassign(o);
1623 break;
1624 }
1625
79072805
LW		 1626 case OP_OR:
1627 case OP_AND:
edbe35ea
VP		 1628 kid = cLOGOPo->op_first;
1629 if (kid->op_type == OP_NOT
1630 && (kid->op_flags & OPf_KIDS)
1631 && !PL_madskills) {
1632 if (o->op_type == OP_AND) {
1633 o->op_type = OP_OR;
1634 o->op_ppaddr = PL_ppaddr[OP_OR];
1635 } else {
1636 o->op_type = OP_AND;
1637 o->op_ppaddr = PL_ppaddr[OP_AND];
1638 }
1639 op_null(kid);
1640 }
1641
c963b151 1642 case OP_DOR:
79072805 1643 case OP_COND_EXPR:
0d863452
RH		 1644 case OP_ENTERGIVEN:
1645 case OP_ENTERWHEN:
11343788 1646 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
79072805
LW		 1647 scalarvoid(kid);
1648 break;
5aabfad6 1649
a0d0e21e 1650 case OP_NULL:
11343788 1651 if (o->op_flags & OPf_STACKED)
a0d0e21e 1652 break;
5aabfad6 1653 /* FALL THROUGH */
2ebea0a1
GS		 1654 case OP_NEXTSTATE:
1655 case OP_DBSTATE:
79072805
LW		 1656 case OP_ENTERTRY:
1657 case OP_ENTER:
11343788 1658 if (!(o->op_flags & OPf_KIDS))
79072805 1659 break;
54310121 1660 /* FALL THROUGH */
463ee0b2 1661 case OP_SCOPE:
79072805
LW		 1662 case OP_LEAVE:
1663 case OP_LEAVETRY:
a0d0e21e 1664 case OP_LEAVELOOP:
79072805 1665 case OP_LINESEQ:
79072805 1666 case OP_LIST:
0d863452
RH		 1667 case OP_LEAVEGIVEN:
1668 case OP_LEAVEWHEN:
11343788 1669 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW		 1670 scalarvoid(kid);
1671 break;
c90c0ff4 1672 case OP_ENTEREVAL:
5196be3e 1673 scalarkids(o);
c90c0ff4 1674 break;
d6483035 1675 case OP_SCALAR:
5196be3e 1676 return scalar(o);
79072805 1677 }
095b19d1
NC		 1678
1679 if (useless_sv) {
1680 /* mortalise it, in case warnings are fatal. */
1681 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
1682 "Useless use of %"SVf" in void context",
1683 sv_2mortal(useless_sv));
1684 }
1685 else if (useless) {
1686 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
1687 "Useless use of %s in void context",
1688 useless);
1689 }
11343788 1690 return o;
79072805
LW		 1691}
1692
1f676739 1693static OP *
412da003 1694S_listkids(pTHX_ OP *o)
79072805 1695{
11343788 1696 if (o && o->op_flags & OPf_KIDS) {
6867be6d 1697 OP *kid;
11343788 1698 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW		 1699 list(kid);
1700 }
11343788 1701 return o;
79072805
LW		 1702}
1703
1704OP *
864dbfa3 1705Perl_list(pTHX_ OP *o)
79072805 1706{
27da23d5 1707 dVAR;
79072805
LW		 1708 OP *kid;
1709
a0d0e21e 1710 /* assumes no premature commitment */
13765c85
DM		 1711 if (!o || (o->op_flags & OPf_WANT)
1712 || (PL_parser && PL_parser->error_count)
5dc0d613 1713 || o->op_type == OP_RETURN)
7e363e51 1714 {
11343788 1715 return o;
7e363e51 1716 }
79072805 1717
b162f9ea 1718 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS		 1719 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1720 {
b162f9ea 1721 return o; /* As if inside SASSIGN */
7e363e51 1722 }
1c846c1f 1723
5dc0d613 1724 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
79072805 1725
11343788 1726 switch (o->op_type) {
79072805
LW		 1727 case OP_FLOP:
1728 case OP_REPEAT:
11343788 1729 list(cBINOPo->op_first);
79072805
LW		 1730 break;
1731 case OP_OR:
1732 case OP_AND:
1733 case OP_COND_EXPR:
11343788 1734 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
79072805
LW		 1735 list(kid);
1736 break;
1737 default:
1738 case OP_MATCH:
8782bef2 1739 case OP_QR:
79072805
LW		 1740 case OP_SUBST:
1741 case OP_NULL:
11343788 1742 if (!(o->op_flags & OPf_KIDS))
79072805 1743 break;
11343788
MB		 1744 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1745 list(cBINOPo->op_first);
1746 return gen_constant_list(o);
79072805
LW		 1747 }
1748 case OP_LIST:
11343788 1749 listkids(o);
79072805
LW		 1750 break;
1751 case OP_LEAVE:
1752 case OP_LEAVETRY:
5dc0d613 1753 kid = cLISTOPo->op_first;
54310121 1754 list(kid);
25b991bf
VP		 1755 kid = kid->op_sibling;
1756 do_kids:
1757 while (kid) {
1758 OP *sib = kid->op_sibling;
c08f093b
VP		 1759 if (sib && kid->op_type != OP_LEAVEWHEN)
1760 scalarvoid(kid);
1761 else
54310121 1762 list(kid);
25b991bf 1763 kid = sib;
54310121 1764 }
11206fdd 1765 PL_curcop = &PL_compiling;
54310121 1766 break;
748a9306 1767 case OP_SCOPE:
79072805 1768 case OP_LINESEQ:
25b991bf
VP		 1769 kid = cLISTOPo->op_first;
1770 goto do_kids;
79072805 1771 }
11343788 1772 return o;
79072805
LW		 1773}
1774
1f676739 1775static OP *
2dd5337b 1776S_scalarseq(pTHX_ OP *o)
79072805 1777{
97aff369 1778 dVAR;
11343788 1779 if (o) {
1496a290
AL		 1780 const OPCODE type = o->op_type;
1781
1782 if (type == OP_LINESEQ || type == OP_SCOPE ||
1783 type == OP_LEAVE || type == OP_LEAVETRY)
463ee0b2 1784 {
6867be6d 1785 OP *kid;
11343788 1786 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
ed6116ce 1787 if (kid->op_sibling) {
463ee0b2 1788 scalarvoid(kid);
ed6116ce 1789 }
463ee0b2 1790 }
3280af22 1791 PL_curcop = &PL_compiling;
79072805 1792 }
11343788 1793 o->op_flags &= ~OPf_PARENS;
3280af22 1794 if (PL_hints & HINT_BLOCK_SCOPE)
11343788 1795 o->op_flags |= OPf_PARENS;
79072805 1796 }
8990e307 1797 else
11343788
MB		 1798 o = newOP(OP_STUB, 0);
1799 return o;
79072805
LW		 1800}
1801
76e3520e 1802STATIC OP *
cea2e8a9 1803S_modkids(pTHX_ OP *o, I32 type)
79072805 1804{
11343788 1805 if (o && o->op_flags & OPf_KIDS) {
6867be6d 1806 OP *kid;
11343788 1807 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
3ad73efd 1808 op_lvalue(kid, type);
79072805 1809 }
11343788 1810 return o;
79072805
LW		 1811}
1812
3ad73efd 1813/*
d164302a
GG		 1814=for apidoc finalize_optree
1815
1816This function finalizes the optree. Should be called directly after
1817the complete optree is built. It does some additional
1818checking which can't be done in the normal ck_xxx functions and makes
1819the tree thread-safe.
1820
1821=cut
1822*/
1823void
1824Perl_finalize_optree(pTHX_ OP* o)
1825{
1826 PERL_ARGS_ASSERT_FINALIZE_OPTREE;
1827
1828 ENTER;
1829 SAVEVPTR(PL_curcop);
1830
1831 finalize_op(o);
1832
1833 LEAVE;
1834}
1835
60dde6b2 1836STATIC void
d164302a
GG		 1837S_finalize_op(pTHX_ OP* o)
1838{
1839 PERL_ARGS_ASSERT_FINALIZE_OP;
1840
1841#if defined(PERL_MAD) && defined(USE_ITHREADS)
1842 {
1843 /* Make sure mad ops are also thread-safe */
1844 MADPROP *mp = o->op_madprop;
1845 while (mp) {
1846 if (mp->mad_type == MAD_OP && mp->mad_vlen) {
1847 OP *prop_op = (OP *) mp->mad_val;
1848 /* We only need "Relocate sv to the pad for thread safety.", but this
1849 easiest way to make sure it traverses everything */
4dc304e0
FC		 1850 if (prop_op->op_type == OP_CONST)
1851 cSVOPx(prop_op)->op_private &= ~OPpCONST_STRICT;
d164302a
GG		 1852 finalize_op(prop_op);
1853 }
1854 mp = mp->mad_next;
1855 }
1856 }
1857#endif
1858
1859 switch (o->op_type) {
1860 case OP_NEXTSTATE:
1861 case OP_DBSTATE:
1862 PL_curcop = ((COP*)o); /* for warnings */
1863 break;
1864 case OP_EXEC:
ea31ed66
GG		 1865 if ( o->op_sibling
1866 && (o->op_sibling->op_type == OP_NEXTSTATE || o->op_sibling->op_type == OP_DBSTATE)
573d2b1a 1867 && ckWARN(WARN_EXEC))
d164302a 1868 {
ea31ed66
GG		 1869 if (o->op_sibling->op_sibling) {
1870 const OPCODE type = o->op_sibling->op_sibling->op_type;
d164302a
GG		 1871 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
1872 const line_t oldline = CopLINE(PL_curcop);
ea31ed66 1873 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_sibling));
d164302a
GG		 1874 Perl_warner(aTHX_ packWARN(WARN_EXEC),
1875 "Statement unlikely to be reached");
1876 Perl_warner(aTHX_ packWARN(WARN_EXEC),
1877 "\t(Maybe you meant system() when you said exec()?)\n");
1878 CopLINE_set(PL_curcop, oldline);
1879 }
1880 }
1881 }
1882 break;
1883
1884 case OP_GV:
1885 if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
1886 GV * const gv = cGVOPo_gv;
1887 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
1888 /* XXX could check prototype here instead of just carping */
1889 SV * const sv = sv_newmortal();
1890 gv_efullname3(sv, gv, NULL);
1891 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
1892 "%"SVf"() called too early to check prototype",
1893 SVfARG(sv));
1894 }
1895 }
1896 break;
1897
1898 case OP_CONST:
eb796c7f
GG		 1899 if (cSVOPo->op_private & OPpCONST_STRICT)
1900 no_bareword_allowed(o);
1901 /* FALLTHROUGH */
d164302a
GG		 1902#ifdef USE_ITHREADS
1903 case OP_HINTSEVAL:
1904 case OP_METHOD_NAMED:
1905 /* Relocate sv to the pad for thread safety.
1906 * Despite being a "constant", the SV is written to,
1907 * for reference counts, sv_upgrade() etc. */
1908 if (cSVOPo->op_sv) {
325e1816 1909 const PADOFFSET ix = pad_alloc(OP_CONST, SVf_READONLY);
d054cdb0
FC		 1910 SvREFCNT_dec(PAD_SVl(ix));
1911 PAD_SETSV(ix, cSVOPo->op_sv);
1912 /* XXX I don't know how this isn't readonly already. */
1913 if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
d164302a
GG		 1914 cSVOPo->op_sv = NULL;
1915 o->op_targ = ix;
1916 }
1917#endif
1918 break;
1919
1920 case OP_HELEM: {
1921 UNOP *rop;
1922 SV *lexname;
1923 GV **fields;
565e6f7e
FC		 1924 SVOP *key_op;
1925 OP *kid;
1926 bool check_fields;
d164302a 1927
565e6f7e 1928 if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
d164302a
GG		 1929 break;
1930
1931 rop = (UNOP*)((BINOP*)o)->op_first;
e6307ed0 1932
565e6f7e 1933 goto check_keys;
d164302a 1934
565e6f7e 1935 case OP_HSLICE:
429a2555
FC		 1936 S_scalar_slice_warning(aTHX_ o);
1937
c5f75dba 1938 case OP_KVHSLICE:
71323522
FC		 1939 if (/* I bet there's always a pushmark... */
1940 (kid = cLISTOPo->op_first->op_sibling)->op_type != OP_LIST
0e706dd4 1941 && kid->op_type != OP_CONST)
d164302a 1942 break;
565e6f7e
FC		 1943
1944 key_op = (SVOP*)(kid->op_type == OP_CONST
1945 ? kid
1946 : kLISTOP->op_first->op_sibling);
1947
1948 rop = (UNOP*)((LISTOP*)o)->op_last;
1949
1950 check_keys:
1951 if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
71323522 1952 rop = NULL;
565e6f7e 1953 else if (rop->op_first->op_type == OP_PADSV)
d164302a
GG		 1954 /* @$hash{qw(keys here)} */
1955 rop = (UNOP*)rop->op_first;
565e6f7e 1956 else {
d164302a
GG		 1957 /* @{$hash}{qw(keys here)} */
1958 if (rop->op_first->op_type == OP_SCOPE
1959 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
1960 {
1961 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
1962 }
1963 else
71323522 1964 rop = NULL;
d164302a 1965 }
71323522 1966
32e9ec8f 1967 lexname = NULL; /* just to silence compiler warnings */
03acb648
DM		 1968 fields = NULL; /* just to silence compiler warnings */
1969
71323522
FC		 1970 check_fields =
1971 rop
1972 && (lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE),
1973 SvPAD_TYPED(lexname))
1974 && (fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE))
1975 && isGV(*fields) && GvHV(*fields);
0e706dd4 1976 for (; key_op;
d164302a 1977 key_op = (SVOP*)key_op->op_sibling) {
565e6f7e 1978 SV **svp, *sv;
d164302a
GG		 1979 if (key_op->op_type != OP_CONST)
1980 continue;
1981 svp = cSVOPx_svp(key_op);
71323522
FC		 1982
1983 /* Make the CONST have a shared SV */
1984 if ((!SvIsCOW_shared_hash(sv = *svp))
1985 && SvTYPE(sv) < SVt_PVMG && SvOK(sv) && !SvROK(sv)) {
1986 SSize_t keylen;
1987 const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
1988 SV *nsv = newSVpvn_share(key,
1989 SvUTF8(sv) ? -keylen : keylen, 0);
1990 SvREFCNT_dec_NN(sv);
1991 *svp = nsv;
1992 }
1993
1994 if (check_fields
1995 && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0)) {
ce16c625 1996 Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
84cf752c 1997 "in variable %"SVf" of type %"HEKf,
ce16c625 1998 SVfARG(*svp), SVfARG(lexname),
84cf752c 1999 HEKfARG(HvNAME_HEK(SvSTASH(lexname))));
d164302a
GG		 2000 }
2001 }
2002 break;
2003 }
429a2555
FC		 2004 case OP_ASLICE:
2005 S_scalar_slice_warning(aTHX_ o);
2006 break;
a7fd8ef6 2007
d164302a
GG		 2008 case OP_SUBST: {
2009 if (cPMOPo->op_pmreplrootu.op_pmreplroot)
2010 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
2011 break;
2012 }
2013 default:
2014 break;
2015 }
2016
2017 if (o->op_flags & OPf_KIDS) {
2018 OP *kid;
2019 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
2020 finalize_op(kid);
2021 }
2022}
2023
2024/*
3ad73efd
Z		 2025=for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
2026
2027Propagate lvalue ("modifiable") context to an op and its children.
2028I<type> represents the context type, roughly based on the type of op that
2029would do the modifying, although C<local()> is represented by OP_NULL,
2030because it has no op type of its own (it is signalled by a flag on
001c3c51
FC		 2031the lvalue op).
2032
2033This function detects things that can't be modified, such as C<$x+1>, and
2034generates errors for them. For example, C<$x+1 = 2> would cause it to be
2035called with an op of type OP_ADD and a C<type> argument of OP_SASSIGN.
2036
2037It also flags things that need to behave specially in an lvalue context,
2038such as C<$$x = 5> which might have to vivify a reference in C<$x>.
3ad73efd
Z		 2039
2040=cut
2041*/
ddeae0f1 2042
79072805 2043OP *
d3d7d28f 2044Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
79072805 2045{
27da23d5 2046 dVAR;
79072805 2047 OP *kid;
ddeae0f1
DM		 2048 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
2049 int localize = -1;
79072805 2050
13765c85 2051 if (!o || (PL_parser && PL_parser->error_count))
11343788 2052 return o;
79072805 2053
b162f9ea 2054 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS		 2055 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2056 {
b162f9ea 2057 return o;
7e363e51 2058 }
1c846c1f 2059
5c906035
GG		 2060 assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
2061
69974ce6
FC		 2062 if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
2063
11343788 2064 switch (o->op_type) {
68dc0745 2065 case OP_UNDEF:
3280af22 2066 PL_modcount++;
5dc0d613 2067 return o;
5f05dabc 2068 case OP_STUB:
58bde88d 2069 if ((o->op_flags & OPf_PARENS) || PL_madskills)
5f05dabc 2070 break;
2071 goto nomod;
a0d0e21e 2072 case OP_ENTERSUB:
f79aa60b 2073 if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
11343788
MB		 2074 !(o->op_flags & OPf_STACKED)) {
2075 o->op_type = OP_RV2CV; /* entersub => rv2cv */
767eda44
FC		 2076 /* Both ENTERSUB and RV2CV use this bit, but for different pur-
2077 poses, so we need it clear. */
e26df76a 2078 o->op_private &= ~1;
22c35a8c 2079 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
11343788 2080 assert(cUNOPo->op_first->op_type == OP_NULL);
93c66552 2081 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
79072805
LW		 2082 break;
2083 }
cd06dffe 2084 else { /* lvalue subroutine call */
777d9014
FC		 2085 o->op_private |= OPpLVAL_INTRO
2086 |(OPpENTERSUB_INARGS * (type == OP_LEAVESUBLV));
e6438c1a 2087 PL_modcount = RETURN_UNLIMITED_NUMBER;
4978d6d9 2088 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
d0887bf3 2089 /* Potential lvalue context: */
cd06dffe
GS		 2090 o->op_private |= OPpENTERSUB_INARGS;
2091 break;
2092 }
2093 else { /* Compile-time error message: */
2094 OP *kid = cUNOPo->op_first;
2095 CV *cv;
cd06dffe 2096
3ea285d1
AL		 2097 if (kid->op_type != OP_PUSHMARK) {
2098 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
2099 Perl_croak(aTHX_
2100 "panic: unexpected lvalue entersub "
2101 "args: type/targ %ld:%"UVuf,
2102 (long)kid->op_type, (UV)kid->op_targ);
2103 kid = kLISTOP->op_first;
2104 }
cd06dffe
GS		 2105 while (kid->op_sibling)
2106 kid = kid->op_sibling;
2107 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
cd06dffe
GS		 2108 break; /* Postpone until runtime */
2109 }
b2ffa427 2110
cd06dffe
GS		 2111 kid = kUNOP->op_first;
2112 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
2113 kid = kUNOP->op_first;
b2ffa427 2114 if (kid->op_type == OP_NULL)
cd06dffe
GS		 2115 Perl_croak(aTHX_
2116 "Unexpected constant lvalue entersub "
55140b79 2117 "entry via type/targ %ld:%"UVuf,
3d811634 2118 (long)kid->op_type, (UV)kid->op_targ);
cd06dffe 2119 if (kid->op_type != OP_GV) {
cd06dffe
GS		 2120 break;
2121 }
b2ffa427 2122
638eceb6 2123 cv = GvCV(kGVOP_gv);
1c846c1f 2124 if (!cv)
da1dff94 2125 break;
cd06dffe
GS		 2126 if (CvLVALUE(cv))
2127 break;
2128 }
2129 }
79072805
LW		 2130 /* FALL THROUGH */
2131 default:
a0d0e21e 2132 nomod:
f5d552b4 2133 if (flags & OP_LVALUE_NO_CROAK) return NULL;
6fbb66d6 2134 /* grep, foreach, subcalls, refgen */
145b2bbb
FC		 2135 if (type == OP_GREPSTART || type == OP_ENTERSUB
2136 || type == OP_REFGEN || type == OP_LEAVESUBLV)
a0d0e21e 2137 break;
cea2e8a9 2138 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
638bc118 2139 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
cd06dffe
GS		 2140 ? "do block"
2141 : (o->op_type == OP_ENTERSUB
2142 ? "non-lvalue subroutine call"
53e06cf0 2143 : OP_DESC(o))),
22c35a8c 2144 type ? PL_op_desc[type] : "local"));
11343788 2145 return o;
79072805 2146
a0d0e21e
LW		 2147 case OP_PREINC:
2148 case OP_PREDEC:
2149 case OP_POW:
2150 case OP_MULTIPLY:
2151 case OP_DIVIDE:
2152 case OP_MODULO:
2153 case OP_REPEAT:
2154 case OP_ADD:
2155 case OP_SUBTRACT:
2156 case OP_CONCAT:
2157 case OP_LEFT_SHIFT:
2158 case OP_RIGHT_SHIFT:
2159 case OP_BIT_AND:
2160 case OP_BIT_XOR:
2161 case OP_BIT_OR:
2162 case OP_I_MULTIPLY:
2163 case OP_I_DIVIDE:
2164 case OP_I_MODULO:
2165 case OP_I_ADD:
2166 case OP_I_SUBTRACT:
11343788 2167 if (!(o->op_flags & OPf_STACKED))
a0d0e21e 2168 goto nomod;
3280af22 2169 PL_modcount++;
a0d0e21e 2170 break;
b2ffa427 2171
79072805 2172 case OP_COND_EXPR:
ddeae0f1 2173 localize = 1;
11343788 2174 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
3ad73efd 2175 op_lvalue(kid, type);
79072805
LW		 2176 break;
2177
2178 case OP_RV2AV:
2179 case OP_RV2HV:
11343788 2180 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
e6438c1a 2181 PL_modcount = RETURN_UNLIMITED_NUMBER;
11343788 2182 return o; /* Treat \(@foo) like ordinary list. */
748a9306
LW		 2183 }
2184 /* FALL THROUGH */
79072805 2185 case OP_RV2GV:
5dc0d613 2186 if (scalar_mod_type(o, type))
3fe9a6f1 2187 goto nomod;
11343788 2188 ref(cUNOPo->op_first, o->op_type);
79072805 2189 /* FALL THROUGH */
79072805
LW		 2190 case OP_ASLICE:
2191 case OP_HSLICE:
ddeae0f1 2192 localize = 1;
78f9721b
SM		 2193 /* FALL THROUGH */
2194 case OP_AASSIGN:
32cbae3f
FC		 2195 /* Do not apply the lvsub flag for rv2[ah]v in scalar context. */
2196 if (type == OP_LEAVESUBLV && (
2197 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
2198 || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
2199 ))
631dbaa2
FC		 2200 o->op_private |= OPpMAYBE_LVSUB;
2201 /* FALL THROUGH */
93a17b20
LW		 2202 case OP_NEXTSTATE:
2203 case OP_DBSTATE:
e6438c1a 2204 PL_modcount = RETURN_UNLIMITED_NUMBER;
79072805 2205 break;
5cae3edb 2206 case OP_KVHSLICE:
6dd3e0f2 2207 case OP_KVASLICE:
5cae3edb
RZ		 2208 if (type == OP_LEAVESUBLV)
2209 o->op_private |= OPpMAYBE_LVSUB;
2210 goto nomod;
28c5b5bc
RGS		 2211 case OP_AV2ARYLEN:
2212 PL_hints |= HINT_BLOCK_SCOPE;
2213 if (type == OP_LEAVESUBLV)
2214 o->op_private |= OPpMAYBE_LVSUB;
2215 PL_modcount++;
2216 break;
463ee0b2 2217 case OP_RV2SV:
aeea060c 2218 ref(cUNOPo->op_first, o->op_type);
ddeae0f1 2219 localize = 1;
463ee0b2 2220 /* FALL THROUGH */
79072805 2221 case OP_GV:
3280af22 2222 PL_hints |= HINT_BLOCK_SCOPE;
463ee0b2 2223 case OP_SASSIGN:
bf4b1e52
GS		 2224 case OP_ANDASSIGN:
2225 case OP_ORASSIGN:
c963b151 2226 case OP_DORASSIGN:
ddeae0f1
DM		 2227 PL_modcount++;
2228 break;
2229
8990e307 2230 case OP_AELEMFAST:
93bad3fd 2231 case OP_AELEMFAST_LEX:
6a077020 2232 localize = -1;
3280af22 2233 PL_modcount++;
8990e307
LW		 2234 break;
2235
748a9306
LW		 2236 case OP_PADAV:
2237 case OP_PADHV:
e6438c1a 2238 PL_modcount = RETURN_UNLIMITED_NUMBER;
5196be3e
MB		 2239 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
2240 return o; /* Treat \(@foo) like ordinary list. */
2241 if (scalar_mod_type(o, type))
3fe9a6f1 2242 goto nomod;
32cbae3f
FC		 2243 if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
2244 && type == OP_LEAVESUBLV)
78f9721b 2245 o->op_private |= OPpMAYBE_LVSUB;
748a9306
LW		 2246 /* FALL THROUGH */
2247 case OP_PADSV:
3280af22 2248 PL_modcount++;
ddeae0f1 2249 if (!type) /* local() */
5ede95a0
BF		 2250 Perl_croak(aTHX_ "Can't localize lexical variable %"SVf,
2251 PAD_COMPNAME_SV(o->op_targ));
463ee0b2
LW		 2252 break;
2253
748a9306 2254 case OP_PUSHMARK:
ddeae0f1 2255 localize = 0;
748a9306 2256 break;
b2ffa427 2257
69969c6f 2258 case OP_KEYS:
d8065907 2259 case OP_RKEYS:
fad4a2e4 2260 if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
69969c6f 2261 goto nomod;
5d82c453
GA		 2262 goto lvalue_func;
2263 case OP_SUBSTR:
2264 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
2265 goto nomod;
5f05dabc 2266 /* FALL THROUGH */
a0d0e21e 2267 case OP_POS:
463ee0b2 2268 case OP_VEC:
fad4a2e4 2269 lvalue_func:
78f9721b
SM		 2270 if (type == OP_LEAVESUBLV)
2271 o->op_private |= OPpMAYBE_LVSUB;
11343788 2272 if (o->op_flags & OPf_KIDS)
3ad73efd 2273 op_lvalue(cBINOPo->op_first->op_sibling, type);
463ee0b2 2274 break;
a0d0e21e 2275
463ee0b2
LW		 2276 case OP_AELEM:
2277 case OP_HELEM:
11343788 2278 ref(cBINOPo->op_first, o->op_type);
68dc0745 2279 if (type == OP_ENTERSUB &&
5dc0d613
MB		 2280 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
2281 o->op_private |= OPpLVAL_DEFER;
78f9721b
SM		 2282 if (type == OP_LEAVESUBLV)
2283 o->op_private |= OPpMAYBE_LVSUB;
ddeae0f1 2284 localize = 1;
3280af22 2285 PL_modcount++;
463ee0b2
LW		 2286 break;
2287
463ee0b2 2288 case OP_LEAVE:
a373464f 2289 case OP_LEAVELOOP:
2ec7f6f2
FC		 2290 o->op_private |= OPpLVALUE;
2291 case OP_SCOPE:
463ee0b2 2292 case OP_ENTER:
78f9721b 2293 case OP_LINESEQ:
ddeae0f1 2294 localize = 0;
11343788 2295 if (o->op_flags & OPf_KIDS)
3ad73efd 2296 op_lvalue(cLISTOPo->op_last, type);
a0d0e21e
LW		 2297 break;
2298
2299 case OP_NULL:
ddeae0f1 2300 localize = 0;
638bc118
GS		 2301 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
2302 goto nomod;
2303 else if (!(o->op_flags & OPf_KIDS))
463ee0b2 2304 break;
11343788 2305 if (o->op_targ != OP_LIST) {
3ad73efd 2306 op_lvalue(cBINOPo->op_first, type);
a0d0e21e
LW		 2307 break;
2308 }
2309 /* FALL THROUGH */
463ee0b2 2310 case OP_LIST:
ddeae0f1 2311 localize = 0;
11343788 2312 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
5c906035
GG		 2313 /* elements might be in void context because the list is
2314 in scalar context or because they are attribute sub calls */
2315 if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
2316 op_lvalue(kid, type);
463ee0b2 2317 break;
78f9721b
SM		 2318
2319 case OP_RETURN:
2320 if (type != OP_LEAVESUBLV)
2321 goto nomod;
3ad73efd 2322 break; /* op_lvalue()ing was handled by ck_return() */
1efec5ed
FC		 2323
2324 case OP_COREARGS:
2325 return o;
2ec7f6f2
FC		 2326
2327 case OP_AND:
2328 case OP_OR:
2e73d70e
FC		 2329 op_lvalue(cLOGOPo->op_first, type);
2330 op_lvalue(cLOGOPo->op_first->op_sibling, type);
2ec7f6f2 2331 goto nomod;
463ee0b2 2332 }
58d95175 2333
8be1be90
AMS		 2334 /* [20011101.069] File test operators interpret OPf_REF to mean that
2335 their argument is a filehandle; thus \stat(".") should not set
2336 it. AMS 20011102 */
2337 if (type == OP_REFGEN &&
ef69c8fc 2338 PL_check[o->op_type] == Perl_ck_ftst)
8be1be90
AMS		 2339 return o;
2340
2341 if (type != OP_LEAVESUBLV)
2342 o->op_flags |= OPf_MOD;
2343
2344 if (type == OP_AASSIGN || type == OP_SASSIGN)
2345 o->op_flags |= OPf_SPECIAL|OPf_REF;
ddeae0f1
DM		 2346 else if (!type) { /* local() */
2347 switch (localize) {
2348 case 1:
2349 o->op_private |= OPpLVAL_INTRO;
2350 o->op_flags &= ~OPf_SPECIAL;
2351 PL_hints |= HINT_BLOCK_SCOPE;
2352 break;
2353 case 0:
2354 break;
2355 case -1:
a2a5de95
NC		 2356 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
2357 "Useless localization of %s", OP_DESC(o));
ddeae0f1 2358 }
463ee0b2 2359 }
8be1be90
AMS		 2360 else if (type != OP_GREPSTART && type != OP_ENTERSUB
2361 && type != OP_LEAVESUBLV)
2362 o->op_flags |= OPf_REF;
11343788 2363 return o;
463ee0b2
LW		 2364}
2365
864dbfa3 2366STATIC bool
5f66b61c 2367S_scalar_mod_type(const OP *o, I32 type)
3fe9a6f1 2368{
2369 switch (type) {
32a60974 2370 case OP_POS:
3fe9a6f1 2371 case OP_SASSIGN:
1efec5ed 2372 if (o && o->op_type == OP_RV2GV)
3fe9a6f1 2373 return FALSE;
2374 /* FALL THROUGH */
2375 case OP_PREINC:
2376 case OP_PREDEC:
2377 case OP_POSTINC:
2378 case OP_POSTDEC:
2379 case OP_I_PREINC:
2380 case OP_I_PREDEC:
2381 case OP_I_POSTINC:
2382 case OP_I_POSTDEC:
2383 case OP_POW:
2384 case OP_MULTIPLY:
2385 case OP_DIVIDE:
2386 case OP_MODULO:
2387 case OP_REPEAT:
2388 case OP_ADD:
2389 case OP_SUBTRACT:
2390 case OP_I_MULTIPLY:
2391 case OP_I_DIVIDE:
2392 case OP_I_MODULO:
2393 case OP_I_ADD:
2394 case OP_I_SUBTRACT:
2395 case OP_LEFT_SHIFT:
2396 case OP_RIGHT_SHIFT:
2397 case OP_BIT_AND:
2398 case OP_BIT_XOR:
2399 case OP_BIT_OR:
2400 case OP_CONCAT:
2401 case OP_SUBST:
2402 case OP_TRANS:
bb16bae8 2403 case OP_TRANSR:
49e9fbe6
GS		 2404 case OP_READ:
2405 case OP_SYSREAD:
2406 case OP_RECV:
bf4b1e52
GS		 2407 case OP_ANDASSIGN:
2408 case OP_ORASSIGN:
410d09fe 2409 case OP_DORASSIGN:
3fe9a6f1 2410 return TRUE;
2411 default:
2412 return FALSE;
2413 }
2414}
2415
35cd451c 2416STATIC bool
5f66b61c 2417S_is_handle_constructor(const OP *o, I32 numargs)
35cd451c 2418{
7918f24d
NC		 2419 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
2420
35cd451c
GS		 2421 switch (o->op_type) {
2422 case OP_PIPE_OP:
2423 case OP_SOCKPAIR:
504618e9 2424 if (numargs == 2)
35cd451c
GS		 2425 return TRUE;
2426 /* FALL THROUGH */
2427 case OP_SYSOPEN:
2428 case OP_OPEN:
ded8aa31 2429 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
35cd451c
GS		 2430 case OP_SOCKET:
2431 case OP_OPEN_DIR:
2432 case OP_ACCEPT:
504618e9 2433 if (numargs == 1)
35cd451c 2434 return TRUE;
5f66b61c 2435 /* FALLTHROUGH */
35cd451c
GS		 2436 default:
2437 return FALSE;
2438 }
2439}
2440
0d86688d
NC		 2441static OP *
2442S_refkids(pTHX_ OP *o, I32 type)
463ee0b2 2443{
11343788 2444 if (o && o->op_flags & OPf_KIDS) {
6867be6d 2445 OP *kid;
11343788 2446 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
463ee0b2
LW		 2447 ref(kid, type);
2448 }
11343788 2449 return o;
463ee0b2
LW		 2450}
2451
2452OP *
e4c5ccf3 2453Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
463ee0b2 2454{
27da23d5 2455 dVAR;
463ee0b2 2456 OP *kid;
463ee0b2 2457
7918f24d
NC		 2458 PERL_ARGS_ASSERT_DOREF;
2459
13765c85 2460 if (!o || (PL_parser && PL_parser->error_count))
11343788 2461 return o;
463ee0b2 2462
11343788 2463 switch (o->op_type) {
a0d0e21e 2464 case OP_ENTERSUB:
f4df43b5 2465 if ((type == OP_EXISTS || type == OP_DEFINED) &&
11343788
MB		 2466 !(o->op_flags & OPf_STACKED)) {
2467 o->op_type = OP_RV2CV; /* entersub => rv2cv */
22c35a8c 2468 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
11343788 2469 assert(cUNOPo->op_first->op_type == OP_NULL);
93c66552 2470 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
11343788 2471 o->op_flags |= OPf_SPECIAL;
e26df76a 2472 o->op_private &= ~1;
8990e307 2473 }
767eda44 2474 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
0e9700df
GG		 2475 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2476 : type == OP_RV2HV ? OPpDEREF_HV
2477 : OPpDEREF_SV);
767eda44
FC		 2478 o->op_flags |= OPf_MOD;
2479 }
2480
8990e307 2481 break;
aeea060c 2482
463ee0b2 2483 case OP_COND_EXPR:
11343788 2484 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
e4c5ccf3 2485 doref(kid, type, set_op_ref);
463ee0b2 2486 break;
8990e307 2487 case OP_RV2SV:
35cd451c
GS		 2488 if (type == OP_DEFINED)
2489 o->op_flags |= OPf_SPECIAL; /* don't create GV */
e4c5ccf3 2490 doref(cUNOPo->op_first, o->op_type, set_op_ref);
4633a7c4
LW		 2491 /* FALL THROUGH */
2492 case OP_PADSV:
5f05dabc 2493 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5dc0d613
MB		 2494 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2495 : type == OP_RV2HV ? OPpDEREF_HV
2496 : OPpDEREF_SV);
11343788 2497 o->op_flags |= OPf_MOD;
a0d0e21e 2498 }
8990e307 2499 break;
1c846c1f 2500
463ee0b2
LW		 2501 case OP_RV2AV:
2502 case OP_RV2HV:
e4c5ccf3
RH		 2503 if (set_op_ref)
2504 o->op_flags |= OPf_REF;
8990e307 2505 /* FALL THROUGH */
463ee0b2 2506 case OP_RV2GV:
35cd451c
GS		 2507 if (type == OP_DEFINED)
2508 o->op_flags |= OPf_SPECIAL; /* don't create GV */
e4c5ccf3 2509 doref(cUNOPo->op_first, o->op_type, set_op_ref);
463ee0b2 2510 break;
8990e307 2511
463ee0b2
LW		 2512 case OP_PADAV:
2513 case OP_PADHV:
e4c5ccf3
RH		 2514 if (set_op_ref)
2515 o->op_flags |= OPf_REF;
79072805 2516 break;
aeea060c 2517
8990e307 2518 case OP_SCALAR:
79072805 2519 case OP_NULL:
518618af 2520 if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
463ee0b2 2521 break;
e4c5ccf3 2522 doref(cBINOPo->op_first, type, set_op_ref);
79072805
LW		 2523 break;
2524 case OP_AELEM:
2525 case OP_HELEM:
e4c5ccf3 2526 doref(cBINOPo->op_first, o->op_type, set_op_ref);
5f05dabc 2527 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5dc0d613
MB		 2528 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2529 : type == OP_RV2HV ? OPpDEREF_HV
2530 : OPpDEREF_SV);
11343788 2531 o->op_flags |= OPf_MOD;
8990e307 2532 }
79072805
LW		 2533 break;
2534
463ee0b2 2535 case OP_SCOPE:
79072805 2536 case OP_LEAVE:
e4c5ccf3
RH		 2537 set_op_ref = FALSE;
2538 /* FALL THROUGH */
79072805 2539 case OP_ENTER:
8990e307 2540 case OP_LIST:
11343788 2541 if (!(o->op_flags & OPf_KIDS))
79072805 2542 break;
e4c5ccf3 2543 doref(cLISTOPo->op_last, type, set_op_ref);
79072805 2544 break;
a0d0e21e
LW		 2545 default:
2546 break;
79072805 2547 }
11343788 2548 return scalar(o);
8990e307 2549
79072805
LW		 2550}
2551
09bef843
SB		 2552STATIC OP *
2553S_dup_attrlist(pTHX_ OP *o)
2554{
97aff369 2555 dVAR;
0bd48802 2556 OP *rop;
09bef843 2557
7918f24d
NC		 2558 PERL_ARGS_ASSERT_DUP_ATTRLIST;
2559
09bef843
SB		 2560 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
2561 * where the first kid is OP_PUSHMARK and the remaining ones
2562 * are OP_CONST. We need to push the OP_CONST values.
2563 */
2564 if (o->op_type == OP_CONST)
b37c2d43 2565 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
eb8433b7
NC		 2566#ifdef PERL_MAD
2567 else if (o->op_type == OP_NULL)
1d866c12 2568 rop = NULL;
eb8433b7 2569#endif
09bef843
SB		 2570 else {
2571 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
5f66b61c 2572 rop = NULL;
09bef843
SB		 2573 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
2574 if (o->op_type == OP_CONST)
2fcb4757 2575 rop = op_append_elem(OP_LIST, rop,
09bef843 2576 newSVOP(OP_CONST, o->op_flags,
b37c2d43 2577 SvREFCNT_inc_NN(cSVOPo->op_sv)));
09bef843
SB		 2578 }
2579 }
2580 return rop;
2581}
2582
2583STATIC void
ad0dc73b 2584S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
09bef843 2585{
27da23d5 2586 dVAR;
ad0dc73b 2587 SV * const stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
09bef843 2588
7918f24d
NC		 2589 PERL_ARGS_ASSERT_APPLY_ATTRS;
2590
09bef843
SB		 2591 /* fake up C<use attributes $pkg,$rv,@attrs> */
2592 ENTER; /* need to protect against side-effects of 'use' */
e4783991 2593
09bef843 2594#define ATTRSMODULE "attributes"
95f0a2f1
SB		 2595#define ATTRSMODULE_PM "attributes.pm"
2596
ad0dc73b 2597 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
6136c704
AL		 2598 newSVpvs(ATTRSMODULE),
2599 NULL,
2fcb4757 2600 op_prepend_elem(OP_LIST,
95f0a2f1 2601 newSVOP(OP_CONST, 0, stashsv),
2fcb4757 2602 op_prepend_elem(OP_LIST,
95f0a2f1
SB		 2603 newSVOP(OP_CONST, 0,
2604 newRV(target)),
2605 dup_attrlist(attrs))));
09bef843
SB		 2606 LEAVE;
2607}
2608
95f0a2f1
SB		 2609STATIC void
2610S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
2611{
97aff369 2612 dVAR;
95f0a2f1 2613 OP *pack, *imop, *arg;
ad0dc73b 2614 SV *meth, *stashsv, **svp;
95f0a2f1 2615
7918f24d
NC		 2616 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
2617
95f0a2f1
SB		 2618 if (!attrs)
2619 return;
2620
2621 assert(target->op_type == OP_PADSV ||
2622 target->op_type == OP_PADHV ||
2623 target->op_type == OP_PADAV);
2624
2625 /* Ensure that attributes.pm is loaded. */
ad0dc73b
FC		 2626 ENTER; /* need to protect against side-effects of 'use' */
2627 /* Don't force the C<use> if we don't need it. */
2628 svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
2629 if (svp && *svp != &PL_sv_undef)
2630 NOOP; /* already in %INC */
2631 else
2632 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
2633 newSVpvs(ATTRSMODULE), NULL);
2634 LEAVE;
95f0a2f1
SB		 2635
2636 /* Need package name for method call. */
6136c704 2637 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
95f0a2f1
SB		 2638
2639 /* Build up the real arg-list. */
5aaec2b4
NC		 2640 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2641
95f0a2f1
SB		 2642 arg = newOP(OP_PADSV, 0);
2643 arg->op_targ = target->op_targ;
2fcb4757 2644 arg = op_prepend_elem(OP_LIST,
95f0a2f1 2645 newSVOP(OP_CONST, 0, stashsv),
2fcb4757 2646 op_prepend_elem(OP_LIST,
95f0a2f1 2647 newUNOP(OP_REFGEN, 0,
3ad73efd 2648 op_lvalue(arg, OP_REFGEN)),
95f0a2f1
SB		 2649 dup_attrlist(attrs)));
2650
2651 /* Fake up a method call to import */
18916d0d 2652 meth = newSVpvs_share("import");
95f0a2f1 2653 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2fcb4757
Z		 2654 op_append_elem(OP_LIST,
2655 op_prepend_elem(OP_LIST, pack, list(arg)),
95f0a2f1 2656 newSVOP(OP_METHOD_NAMED, 0, meth)));
95f0a2f1
SB		 2657
2658 /* Combine the ops. */
2fcb4757 2659 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
95f0a2f1
SB		 2660}
2661
2662/*
2663=notfor apidoc apply_attrs_string
2664
2665Attempts to apply a list of attributes specified by the C<attrstr> and
2666C<len> arguments to the subroutine identified by the C<cv> argument which
2667is expected to be associated with the package identified by the C<stashpv>
2668argument (see L<attributes>). It gets this wrong, though, in that it
2669does not correctly identify the boundaries of the individual attribute
2670specifications within C<attrstr>. This is not really intended for the
2671public API, but has to be listed here for systems such as AIX which
2672need an explicit export list for symbols. (It's called from XS code
2673in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
2674to respect attribute syntax properly would be welcome.
2675
2676=cut
2677*/
2678
be3174d2 2679void
6867be6d
AL		 2680Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
2681 const char *attrstr, STRLEN len)
be3174d2 2682{
5f66b61c 2683 OP *attrs = NULL;
be3174d2 2684
7918f24d
NC		 2685 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2686
be3174d2
GS		 2687 if (!len) {
2688 len = strlen(attrstr);
2689 }
2690
2691 while (len) {
2692 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2693 if (len) {
890ce7af 2694 const char * const sstr = attrstr;
be3174d2 2695 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2fcb4757 2696 attrs = op_append_elem(OP_LIST, attrs,
be3174d2
GS		 2697 newSVOP(OP_CONST, 0,
2698 newSVpvn(sstr, attrstr-sstr)));
2699 }
2700 }
2701
2702 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
6136c704 2703 newSVpvs(ATTRSMODULE),
2fcb4757 2704 NULL, op_prepend_elem(OP_LIST,
be3174d2 2705 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2fcb4757 2706 op_prepend_elem(OP_LIST,
be3174d2 2707 newSVOP(OP_CONST, 0,
ad64d0ec 2708 newRV(MUTABLE_SV(cv))),
be3174d2
GS		 2709 attrs)));
2710}
2711
eedb00fa
PM		 2712STATIC void
2713S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name)
2714{
2715 OP *new_proto = NULL;
2716 STRLEN pvlen;
2717 char *pv;
2718 OP *o;
2719
2720 PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
2721
2722 if (!*attrs)
2723 return;
2724
2725 o = *attrs;
2726 if (o->op_type == OP_CONST) {
2727 pv = SvPV(cSVOPo_sv, pvlen);
2728 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
2729 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
2730 SV ** const tmpo = cSVOPx_svp(o);
2731 SvREFCNT_dec(cSVOPo_sv);
2732 *tmpo = tmpsv;
2733 new_proto = o;
2734 *attrs = NULL;
2735 }
2736 } else if (o->op_type == OP_LIST) {
2737 OP * lasto = NULL;
2738 assert(o->op_flags & OPf_KIDS);
2739 assert(cLISTOPo->op_first->op_type == OP_PUSHMARK);
2740 /* Counting on the first op to hit the lasto = o line */
2741 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
2742 if (o->op_type == OP_CONST) {
2743 pv = SvPV(cSVOPo_sv, pvlen);
2744 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
2745 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
2746 SV ** const tmpo = cSVOPx_svp(o);
2747 SvREFCNT_dec(cSVOPo_sv);
2748 *tmpo = tmpsv;
2749 if (new_proto && ckWARN(WARN_MISC)) {
2750 STRLEN new_len;
2751 const char * newp = SvPV(cSVOPo_sv, new_len);
2752 Perl_warner(aTHX_ packWARN(WARN_MISC),
2753 "Attribute prototype(%"UTF8f") discards earlier prototype attribute in same sub",
2754 UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
2755 op_free(new_proto);
2756 }
2757 else if (new_proto)
2758 op_free(new_proto);
2759 new_proto = o;
2760 lasto->op_sibling = o->op_sibling;
2761 continue;
2762 }
2763 }
2764 lasto = o;
2765 }
2766 /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
2767 would get pulled in with no real need */
2768 if (!cLISTOPx(*attrs)->op_first->op_sibling) {
2769 op_free(*attrs);
2770 *attrs = NULL;
2771 }
2772 }
2773
2774 if (new_proto) {
2775 SV *svname;
2776 if (isGV(name)) {
2777 svname = sv_newmortal();
2778 gv_efullname3(svname, name, NULL);
2779 }
2780 else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
2781 svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
2782 else
2783 svname = (SV *)name;
2784 if (ckWARN(WARN_ILLEGALPROTO))
2785 (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE);
2786 if (*proto && ckWARN(WARN_PROTOTYPE)) {
2787 STRLEN old_len, new_len;
2788 const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
2789 const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
2790
2791 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
2792 "Prototype '%"UTF8f"' overridden by attribute 'prototype(%"UTF8f")'"
2793 " in %"SVf,
2794 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
2795 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
2796 SVfARG(svname));
2797 }
2798 if (*proto)
2799 op_free(*proto);
2800 *proto = new_proto;
2801 }
2802}
2803
09bef843 2804STATIC OP *
95f0a2f1 2805S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
93a17b20 2806{
97aff369 2807 dVAR;
93a17b20 2808 I32 type;
a1fba7eb 2809 const bool stately = PL_parser && PL_parser->in_my == KEY_state;
93a17b20 2810
7918f24d
NC		 2811 PERL_ARGS_ASSERT_MY_KID;
2812
13765c85 2813 if (!o || (PL_parser && PL_parser->error_count))
11343788 2814 return o;
93a17b20 2815
bc61e325 2816 type = o->op_type;
eb8433b7
NC		 2817 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2818 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2819 return o;
2820 }
2821
93a17b20 2822 if (type == OP_LIST) {
6867be6d 2823 OP *kid;
11343788 2824 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
95f0a2f1 2825 my_kid(kid, attrs, imopsp);
0865059d 2826 return o;
8b8c1fb9 2827 } else if (type == OP_UNDEF || type == OP_STUB) {
7766148a 2828 return o;
77ca0c92
LW		 2829 } else if (type == OP_RV2SV || /* "our" declaration */
2830 type == OP_RV2AV ||
2831 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1ce0b88c 2832 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
fab01b8e 2833 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
952306ac 2834 OP_DESC(o),
12bd6ede
DM		 2835 PL_parser->in_my == KEY_our
2836 ? "our"
2837 : PL_parser->in_my == KEY_state ? "state" : "my"));
1ce0b88c 2838 } else if (attrs) {
551405c4 2839 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
12bd6ede
DM		 2840 PL_parser->in_my = FALSE;
2841 PL_parser->in_my_stash = NULL;
1ce0b88c
RGS		 2842 apply_attrs(GvSTASH(gv),
2843 (type == OP_RV2SV ? GvSV(gv) :
ad64d0ec
NC		 2844 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2845 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
ad0dc73b 2846 attrs);
1ce0b88c 2847 }
192587c2 2848 o->op_private |= OPpOUR_INTRO;
77ca0c92 2849 return o;
95f0a2f1
SB		 2850 }
2851 else if (type != OP_PADSV &&
93a17b20
LW		 2852 type != OP_PADAV &&
2853 type != OP_PADHV &&
2854 type != OP_PUSHMARK)
2855 {
eb64745e 2856 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
53e06cf0 2857 OP_DESC(o),
12bd6ede
DM		 2858 PL_parser->in_my == KEY_our
2859 ? "our"
2860 : PL_parser->in_my == KEY_state ? "state" : "my"));
11343788 2861 return o;
93a17b20 2862 }
09bef843
SB		 2863 else if (attrs && type != OP_PUSHMARK) {
2864 HV *stash;
09bef843 2865
12bd6ede
DM		 2866 PL_parser->in_my = FALSE;
2867 PL_parser->in_my_stash = NULL;
eb64745e 2868
09bef843 2869 /* check for C<my Dog $spot> when deciding package */
dd2155a4
DM		 2870 stash = PAD_COMPNAME_TYPE(o->op_targ);
2871 if (!stash)
09bef843 2872 stash = PL_curstash;
95f0a2f1 2873 apply_attrs_my(stash, o, attrs, imopsp);
09bef843 2874 }
11343788
MB		 2875 o->op_flags |= OPf_MOD;
2876 o->op_private |= OPpLVAL_INTRO;
a1fba7eb 2877 if (stately)
952306ac 2878 o->op_private |= OPpPAD_STATE;
11343788 2879 return o;
93a17b20
LW		 2880}
2881
2882OP *
09bef843
SB		 2883Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2884{
97aff369 2885 dVAR;
0bd48802 2886 OP *rops;
95f0a2f1
SB		 2887 int maybe_scalar = 0;
2888
7918f24d
NC		 2889 PERL_ARGS_ASSERT_MY_ATTRS;
2890
d2be0de5 2891/* [perl #17376]: this appears to be premature, and results in code such as
c754c3d7 2892 C< our(%x); > executing in list mode rather than void mode */
d2be0de5 2893#if 0
09bef843
SB		 2894 if (o->op_flags & OPf_PARENS)
2895 list(o);
95f0a2f1
SB		 2896 else
2897 maybe_scalar = 1;
d2be0de5
YST		 2898#else
2899 maybe_scalar = 1;
2900#endif
09bef843
SB		 2901 if (attrs)
2902 SAVEFREEOP(attrs);
5f66b61c 2903 rops = NULL;
95f0a2f1
SB		 2904 o = my_kid(o, attrs, &rops);
2905 if (rops) {
2906 if (maybe_scalar && o->op_type == OP_PADSV) {
2fcb4757 2907 o = scalar(op_append_list(OP_LIST, rops, o));
95f0a2f1
SB		 2908 o->op_private |= OPpLVAL_INTRO;
2909 }
f5d1ed10
FC		 2910 else {
2911 /* The listop in rops might have a pushmark at the beginning,
2912 which will mess up list assignment. */
2913 LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
2914 if (rops->op_type == OP_LIST &&
2915 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
2916 {
2917 OP * const pushmark = lrops->op_first;
2918 lrops->op_first = pushmark->op_sibling;
2919 op_free(pushmark);
2920 }
2fcb4757 2921 o = op_append_list(OP_LIST, o, rops);
f5d1ed10 2922 }
95f0a2f1 2923 }
12bd6ede
DM		 2924 PL_parser->in_my = FALSE;
2925 PL_parser->in_my_stash = NULL;
eb64745e 2926 return o;
09bef843
SB		 2927}
2928
2929OP *
864dbfa3 2930Perl_sawparens(pTHX_ OP *o)
79072805 2931{
96a5add6 2932 PERL_UNUSED_CONTEXT;
79072805
LW		 2933 if (o)
2934 o->op_flags |= OPf_PARENS;
2935 return o;
2936}
2937
2938OP *
864dbfa3 2939Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
79072805 2940{
11343788 2941 OP *o;
59f00321 2942 bool ismatchop = 0;
1496a290
AL		 2943 const OPCODE ltype = left->op_type;
2944 const OPCODE rtype = right->op_type;
79072805 2945
7918f24d
NC		 2946 PERL_ARGS_ASSERT_BIND_MATCH;
2947
1496a290
AL		 2948 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2949 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
041457d9 2950 {
1496a290 2951 const char * const desc
bb16bae8
FC		 2952 = PL_op_desc[(
2953 rtype == OP_SUBST || rtype == OP_TRANS
2954 || rtype == OP_TRANSR
2955 )
666ea192 2956 ? (int)rtype : OP_MATCH];
c6771ab6 2957 const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
c6771ab6 2958 SV * const name =
0920b7fa 2959 S_op_varname(aTHX_ left);
c6771ab6
FC		 2960 if (name)
2961 Perl_warner(aTHX_ packWARN(WARN_MISC),
2962 "Applying %s to %"SVf" will act on scalar(%"SVf")",
2963 desc, name, name);
2964 else {
2965 const char * const sample = (isary
666ea192 2966 ? "@array" : "%hash");
c6771ab6 2967 Perl_warner(aTHX_ packWARN(WARN_MISC),
1c846c1f 2968 "Applying %s to %s will act on scalar(%s)",
599cee73 2969 desc, sample, sample);
c6771ab6 2970 }
2ae324a7 2971 }
2972
1496a290 2973 if (rtype == OP_CONST &&
5cc9e5c9
RH		 2974 cSVOPx(right)->op_private & OPpCONST_BARE &&
2975 cSVOPx(right)->op_private & OPpCONST_STRICT)
2976 {
2977 no_bareword_allowed(right);
2978 }
2979
bb16bae8 2980 /* !~ doesn't make sense with /r, so error on it for now */
4f4d7508
DC		 2981 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
2982 type == OP_NOT)
2983 yyerror("Using !~ with s///r doesn't make sense");
bb16bae8
FC		 2984 if (rtype == OP_TRANSR && type == OP_NOT)
2985 yyerror("Using !~ with tr///r doesn't make sense");
4f4d7508 2986
2474a784
FC		 2987 ismatchop = (rtype == OP_MATCH ||
2988 rtype == OP_SUBST ||
bb16bae8 2989 rtype == OP_TRANS || rtype == OP_TRANSR)
2474a784 2990 && !(right->op_flags & OPf_SPECIAL);
59f00321
RGS		 2991 if (ismatchop && right->op_private & OPpTARGET_MY) {
2992 right->op_targ = 0;
2993 right->op_private &= ~OPpTARGET_MY;
2994 }
2995 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1496a290
AL		 2996 OP *newleft;
2997
79072805 2998 right->op_flags |= OPf_STACKED;
bb16bae8 2999 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
1496a290 3000 ! (rtype == OP_TRANS &&
4f4d7508
DC		 3001 right->op_private & OPpTRANS_IDENTICAL) &&
3002 ! (rtype == OP_SUBST &&
3003 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
3ad73efd 3004 newleft = op_lvalue(left, rtype);
1496a290
AL		 3005 else
3006 newleft = left;
bb16bae8 3007 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
1496a290 3008 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
79072805 3009 else
2fcb4757 3010 o = op_prepend_elem(rtype, scalar(newleft), right);
79072805 3011 if (type == OP_NOT)
11343788
MB		 3012 return newUNOP(OP_NOT, 0, scalar(o));
3013 return o;
79072805
LW		 3014 }
3015 else
3016 return bind_match(type, left,
d63c20f2 3017 pmruntime(newPMOP(OP_MATCH, 0), right, 0, 0));
79072805
LW		 3018}
3019
3020OP *
864dbfa3 3021Perl_invert(pTHX_ OP *o)
79072805 3022{
11343788 3023 if (!o)
1d866c12 3024 return NULL;
11343788 3025 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
79072805
LW		 3026}
3027
3ad73efd
Z		 3028/*
3029=for apidoc Amx|OP *|op_scope|OP *o
3030
3031Wraps up an op tree with some additional ops so that at runtime a dynamic
3032scope will be created. The original ops run in the new dynamic scope,
3033and then, provided that they exit normally, the scope will be unwound.
3034The additional ops used to create and unwind the dynamic scope will
3035normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
3036instead if the ops are simple enough to not need the full dynamic scope
3037structure.
3038
3039=cut
3040*/
3041
79072805 3042OP *
3ad73efd 3043Perl_op_scope(pTHX_ OP *o)
79072805 3044{
27da23d5 3045 dVAR;
79072805 3046 if (o) {
284167a5 3047 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
2fcb4757 3048 o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
463ee0b2 3049 o->op_type = OP_LEAVE;
22c35a8c 3050 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
463ee0b2 3051 }
fdb22418
HS		 3052 else if (o->op_type == OP_LINESEQ) {
3053 OP *kid;
3054 o->op_type = OP_SCOPE;
3055 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
3056 kid = ((LISTOP*)o)->op_first;
59110972 3057 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
fdb22418 3058 op_null(kid);
59110972
RH		 3059
3060 /* The following deals with things like 'do {1 for 1}' */
3061 kid = kid->op_sibling;
3062 if (kid &&
3063 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
3064 op_null(kid);
3065 }
463ee0b2 3066 }
fdb22418 3067 else
5f66b61c 3068 o = newLISTOP(OP_SCOPE, 0, o, NULL);
79072805
LW		 3069 }
3070 return o;
3071}
1930840b 3072
705fe0e5
FC		 3073OP *
3074Perl_op_unscope(pTHX_ OP *o)
3075{
3076 if (o && o->op_type == OP_LINESEQ) {
3077 OP *kid = cLISTOPo->op_first;
3078 for(; kid; kid = kid->op_sibling)
3079 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
3080 op_null(kid);
3081 }
3082 return o;
3083}
3084
a0d0e21e 3085int
864dbfa3 3086Perl_block_start(pTHX_ int full)
79072805 3087{
97aff369 3088 dVAR;
73d840c0 3089 const int retval = PL_savestack_ix;
1930840b 3090
dd2155a4 3091 pad_block_start(full);
b3ac6de7 3092 SAVEHINTS();
3280af22 3093 PL_hints &= ~HINT_BLOCK_SCOPE;
68da3b2f 3094 SAVECOMPILEWARNINGS();
72dc9ed5 3095 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
1930840b 3096
a88d97bf 3097 CALL_BLOCK_HOOKS(bhk_start, full);
1930840b 3098
a0d0e21e
LW		 3099 return retval;
3100}
3101
3102OP*
864dbfa3 3103Perl_block_end(pTHX_ I32 floor, OP *seq)
a0d0e21e 3104{
97aff369 3105 dVAR;
6867be6d 3106 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1930840b 3107 OP* retval = scalarseq(seq);
6d5c2147 3108 OP *o;
1930840b 3109
a88d97bf 3110 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
1930840b 3111
e9818f4e 3112 LEAVE_SCOPE(floor);
a0d0e21e 3113 if (needblockscope)
3280af22 3114 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
6d5c2147
FC		 3115 o = pad_leavemy();
3116
3117 if (o) {
3118 /* pad_leavemy has created a sequence of introcv ops for all my
3119 subs declared in the block. We have to replicate that list with
3120 clonecv ops, to deal with this situation:
3121
3122 sub {
3123 my sub s1;
3124 my sub s2;
3125 sub s1 { state sub foo { \&s2 } }
3126 }->()
3127
3128 Originally, I was going to have introcv clone the CV and turn
3129 off the stale flag. Since &s1 is declared before &s2, the
3130 introcv op for &s1 is executed (on sub entry) before the one for
3131 &s2. But the &foo sub inside &s1 (which is cloned when &s1 is
3132 cloned, since it is a state sub) closes over &s2 and expects
3133 to see it in its outer CV’s pad. If the introcv op clones &s1,
3134 then &s2 is still marked stale. Since &s1 is not active, and
3135 &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
3136 ble will not stay shared’ warning. Because it is the same stub
3137 that will be used when the introcv op for &s2 is executed, clos-
3138 ing over it is safe. Hence, we have to turn off the stale flag
3139 on all lexical subs in the block before we clone any of them.
3140 Hence, having introcv clone the sub cannot work. So we create a
3141 list of ops like this:
3142
3143 lineseq
3144 |
3145 +-- introcv
3146 |
3147 +-- introcv
3148 |
3149 +-- introcv
3150 |
3151 .
3152 .
3153 .
3154 |
3155 +-- clonecv
3156 |
3157 +-- clonecv
3158 |
3159 +-- clonecv
3160 |
3161 .
3162 .
3163 .
3164 */
3165 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
3166 OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
3167 for (;; kid = kid->op_sibling) {
3168 OP *newkid = newOP(OP_CLONECV, 0);
3169 newkid->op_targ = kid->op_targ;
3170 o = op_append_elem(OP_LINESEQ, o, newkid);
3171 if (kid == last) break;
3172 }
3173 retval = op_prepend_elem(OP_LINESEQ, o, retval);
3174 }
1930840b 3175
a88d97bf 3176 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
1930840b 3177
a0d0e21e
LW		 3178 return retval;
3179}
3180
fd85fad2
BM		 3181/*
3182=head1 Compile-time scope hooks
3183
3e4ddde5 3184=for apidoc Aox||blockhook_register
fd85fad2
BM		 3185
3186Register a set of hooks to be called when the Perl lexical scope changes
3187at compile time. See L<perlguts/"Compile-time scope hooks">.
3188
3189=cut
3190*/
3191
bb6c22e7
BM		 3192void
3193Perl_blockhook_register(pTHX_ BHK *hk)
3194{
3195 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
3196
3197 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
3198}
3199
76e3520e 3200STATIC OP *
cea2e8a9 3201S_newDEFSVOP(pTHX)
54b9620d 3202{
97aff369 3203 dVAR;
cc76b5cc 3204 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
00b1698f 3205 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
59f00321
RGS		 3206 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
3207 }
3208 else {
551405c4 3209 OP * const o = newOP(OP_PADSV, 0);
59f00321
RGS		 3210 o->op_targ = offset;
3211 return o;
3212 }
54b9620d
MB		 3213}
3214
a0d0e21e 3215void
864dbfa3 3216Perl_newPROG(pTHX_ OP *o)
a0d0e21e 3217{
97aff369 3218 dVAR;
7918f24d
NC		 3219
3220 PERL_ARGS_ASSERT_NEWPROG;
3221
3280af22 3222 if (PL_in_eval) {
86a64801 3223 PERL_CONTEXT *cx;
63429d50 3224 I32 i;
b295d113
TH		 3225 if (PL_eval_root)
3226 return;
faef0170
HS		 3227 PL_eval_root = newUNOP(OP_LEAVEEVAL,
3228 ((PL_in_eval & EVAL_KEEPERR)
3229 ? OPf_SPECIAL : 0), o);
86a64801
GG		 3230
3231 cx = &cxstack[cxstack_ix];
3232 assert(CxTYPE(cx) == CXt_EVAL);
3233
3234 if ((cx->blk_gimme & G_WANT) == G_VOID)
3235 scalarvoid(PL_eval_root);
3236 else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
3237 list(PL_eval_root);
3238 else
3239 scalar(PL_eval_root);
3240
5983a79d 3241 PL_eval_start = op_linklist(PL_eval_root);
7934575e
GS		 3242 PL_eval_root->op_private |= OPpREFCOUNTED;
3243 OpREFCNT_set(PL_eval_root, 1);
3280af22 3244 PL_eval_root->op_next = 0;
63429d50
FC		 3245 i = PL_savestack_ix;
3246 SAVEFREEOP(o);
3247 ENTER;
a2efc822 3248 CALL_PEEP(PL_eval_start);
86a64801 3249 finalize_optree(PL_eval_root);
63429d50
FC		 3250 LEAVE;
3251 PL_savestack_ix = i;
a0d0e21e
LW		 3252 }
3253 else {
6be89cf9 3254 if (o->op_type == OP_STUB) {
22e660b4
NC		 3255 /* This block is entered if nothing is compiled for the main
3256 program. This will be the case for an genuinely empty main
3257 program, or one which only has BEGIN blocks etc, so already
3258 run and freed.
3259
3260 Historically (5.000) the guard above was !o. However, commit
3261 f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
3262 c71fccf11fde0068, changed perly.y so that newPROG() is now
3263 called with the output of block_end(), which returns a new
3264 OP_STUB for the case of an empty optree. ByteLoader (and
3265 maybe other things) also take this path, because they set up
3266 PL_main_start and PL_main_root directly, without generating an
3267 optree.
8b31d4e4
NC		 3268
3269 If the parsing the main program aborts (due to parse errors,
3270 or due to BEGIN or similar calling exit), then newPROG()
3271 isn't even called, and hence this code path and its cleanups
3272 are skipped. This shouldn't make a make a difference:
3273 * a non-zero return from perl_parse is a failure, and
3274 perl_destruct() should be called immediately.
3275 * however, if exit(0) is called during the parse, then
3276 perl_parse() returns 0, and perl_run() is called. As
3277 PL_main_start will be NULL, perl_run() will return
3278 promptly, and the exit code will remain 0.
22e660b4
NC		 3279 */
3280
6be89cf9
AE		 3281 PL_comppad_name = 0;
3282 PL_compcv = 0;
d2c837a0 3283 S_op_destroy(aTHX_ o);
a0d0e21e 3284 return;
6be89cf9 3285 }
3ad73efd 3286 PL_main_root = op_scope(sawparens(scalarvoid(o)));
3280af22
NIS		 3287 PL_curcop = &PL_compiling;
3288 PL_main_start = LINKLIST(PL_main_root);
7934575e
GS		 3289 PL_main_root->op_private |= OPpREFCOUNTED;
3290 OpREFCNT_set(PL_main_root, 1);
3280af22 3291 PL_main_root->op_next = 0;
a2efc822 3292 CALL_PEEP(PL_main_start);
d164302a 3293 finalize_optree(PL_main_root);
8be227ab 3294 cv_forget_slab(PL_compcv);
3280af22 3295 PL_compcv = 0;
3841441e 3296
4fdae800 3297 /* Register with debugger */
84902520 3298 if (PERLDB_INTER) {
b96d8cd9 3299 CV * const cv = get_cvs("DB::postponed", 0);
3841441e
CS		 3300 if (cv) {
3301 dSP;
924508f0 3302 PUSHMARK(SP);
ad64d0ec 3303 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3841441e 3304 PUTBACK;
ad64d0ec 3305 call_sv(MUTABLE_SV(cv), G_DISCARD);
3841441e
CS		 3306 }
3307 }
79072805 3308 }
79072805
LW		 3309}
3310
3311OP *
864dbfa3 3312Perl_localize(pTHX_ OP *o, I32 lex)
79072805 3313{
97aff369 3314 dVAR;
7918f24d
NC		 3315
3316 PERL_ARGS_ASSERT_LOCALIZE;
3317
79072805 3318 if (o->op_flags & OPf_PARENS)
d2be0de5
YST		 3319/* [perl #17376]: this appears to be premature, and results in code such as
3320 C< our(%x); > executing in list mode rather than void mode */
3321#if 0
79072805 3322 list(o);
d2be0de5 3323#else
6f207bd3 3324 NOOP;
d2be0de5 3325#endif
8990e307 3326 else {
f06b5848
DM		 3327 if ( PL_parser->bufptr > PL_parser->oldbufptr
3328 && PL_parser->bufptr[-1] == ','
041457d9 3329 && ckWARN(WARN_PARENTHESIS))
64420d0d 3330 {
f06b5848 3331 char *s = PL_parser->bufptr;
bac662ee 3332 bool sigil = FALSE;
64420d0d 3333
8473848f 3334 /* some heuristics to detect a potential error */
bac662ee 3335 while (*s && (strchr(", \t\n", *s)))
64420d0d 3336 s++;
8473848f 3337
bac662ee
TS		 3338 while (1) {
3339 if (*s && strchr("@$%*", *s) && *++s
0eb30aeb 3340 && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
bac662ee
TS		 3341 s++;
3342 sigil = TRUE;
0eb30aeb 3343 while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
bac662ee
TS		 3344 s++;
3345 while (*s && (strchr(", \t\n", *s)))
3346 s++;
3347 }
3348 else
3349 break;
3350 }
3351 if (sigil && (*s == ';' || *s == '=')) {
3352 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
8473848f 3353 "Parentheses missing around \"%s\" list",
12bd6ede
DM		 3354 lex
3355 ? (PL_parser->in_my == KEY_our
3356 ? "our"
3357 : PL_parser->in_my == KEY_state
3358 ? "state"
3359 : "my")
3360 : "local");
8473848f 3361 }
8990e307
LW		 3362 }
3363 }
93a17b20 3364 if (lex)
eb64745e 3365 o = my(o);
93a17b20 3366 else
3ad73efd 3367 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
12bd6ede
DM		 3368 PL_parser->in_my = FALSE;
3369 PL_parser->in_my_stash = NULL;
eb64745e 3370 return o;
79072805
LW		 3371}
3372
3373OP *
864dbfa3 3374Perl_jmaybe(pTHX_ OP *o)
79072805 3375{
7918f24d
NC		 3376 PERL_ARGS_ASSERT_JMAYBE;
3377
79072805 3378 if (o->op_type == OP_LIST) {
fafc274c 3379 OP * const o2
d4c19fe8 3380 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2fcb4757 3381 o = convert(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
79072805
LW		 3382 }
3383 return o;
3384}
3385
985b9e54
GG		 3386PERL_STATIC_INLINE OP *
3387S_op_std_init(pTHX_ OP *o)
3388{
3389 I32 type = o->op_type;
3390
3391 PERL_ARGS_ASSERT_OP_STD_INIT;
3392
3393 if (PL_opargs[type] & OA_RETSCALAR)
3394 scalar(o);
3395 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
3396 o->op_targ = pad_alloc(type, SVs_PADTMP);
3397
3398 return o;
3399}
3400
3401PERL_STATIC_INLINE OP *
3402S_op_integerize(pTHX_ OP *o)
3403{
3404 I32 type = o->op_type;
3405
3406 PERL_ARGS_ASSERT_OP_INTEGERIZE;
3407
077da62f
FC		 3408 /* integerize op. */
3409 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
985b9e54 3410 {
f5f19483 3411 dVAR;
fcbc518d 3412 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
985b9e54
GG		 3413 }
3414
3415 if (type == OP_NEGATE)
3416 /* XXX might want a ck_negate() for this */
3417 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
3418
3419 return o;
3420}
3421
1f676739 3422static OP *
5aaab254 3423S_fold_constants(pTHX_ OP *o)
79072805 3424{
27da23d5 3425 dVAR;
eb578fdb 3426 OP * VOL curop;
eb8433b7 3427 OP *newop;
8ea43dc8 3428 VOL I32 type = o->op_type;
e3cbe32f 3429 SV * VOL sv = NULL;
b7f7fd0b
NC		 3430 int ret = 0;
3431 I32 oldscope;
3432 OP *old_next;
5f2d9966
DM		 3433 SV * const oldwarnhook = PL_warnhook;
3434 SV * const olddiehook = PL_diehook;
c427f4d2 3435 COP not_compiling;
b7f7fd0b 3436 dJMPENV;
79072805 3437
7918f24d
NC		 3438 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
3439
22c35a8c 3440 if (!(PL_opargs[type] & OA_FOLDCONST))
79072805
LW		 3441 goto nope;
3442
de939608 3443 switch (type) {
de939608
CS		 3444 case OP_UCFIRST:
3445 case OP_LCFIRST:
3446 case OP_UC:
3447 case OP_LC:
7ccde120 3448 case OP_FC:
69dcf70c
MB		 3449 case OP_SLT:
3450 case OP_SGT:
3451 case OP_SLE:
3452 case OP_SGE:
3453 case OP_SCMP:
b3fd6149 3454 case OP_SPRINTF:
2de3dbcc 3455 /* XXX what about the numeric ops? */
82ad65bb 3456 if (IN_LOCALE_COMPILETIME)
de939608 3457 goto nope;
553e7bb0 3458 break;
dd9a6ccf
FC		 3459 case OP_PACK:
3460 if (!cLISTOPo->op_first->op_sibling
3461 || cLISTOPo->op_first->op_sibling->op_type != OP_CONST)
3462 goto nope;
3463 {
3464 SV * const sv = cSVOPx_sv(cLISTOPo->op_first->op_sibling);
3465 if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
3466 {
3467 const char *s = SvPVX_const(sv);
3468 while (s < SvEND(sv)) {
3469 if (*s == 'p' || *s == 'P') goto nope;
3470 s++;
3471 }
3472 }
3473 }
3474 break;
baed7faa
FC		 3475 case OP_REPEAT:
3476 if (o->op_private & OPpREPEAT_DOLIST) goto nope;
acb34050
FC		 3477 break;
3478 case OP_SREFGEN:
3479 if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
3480 || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
3481 goto nope;
de939608
CS		 3482 }
3483
13765c85 3484 if (PL_parser && PL_parser->error_count)
a0d0e21e
LW		 3485 goto nope; /* Don't try to run w/ errors */
3486
79072805 3487 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
1496a290
AL		 3488 const OPCODE type = curop->op_type;
3489 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
3490 type != OP_LIST &&
3491 type != OP_SCALAR &&
3492 type != OP_NULL &&
3493 type != OP_PUSHMARK)
7a52d87a 3494 {
79072805
LW		 3495 goto nope;
3496 }
3497 }
3498
3499 curop = LINKLIST(o);
b7f7fd0b 3500 old_next = o->op_next;
79072805 3501 o->op_next = 0;
533c011a 3502 PL_op = curop;
b7f7fd0b
NC		 3503
3504 oldscope = PL_scopestack_ix;
edb2152a 3505 create_eval_scope(G_FAKINGEVAL);
b7f7fd0b 3506
c427f4d2
NC		 3507 /* Verify that we don't need to save it: */
3508 assert(PL_curcop == &PL_compiling);
3509 StructCopy(&PL_compiling, &not_compiling, COP);
3510 PL_curcop = &not_compiling;
3511 /* The above ensures that we run with all the correct hints of the
3512 currently compiling COP, but that IN_PERL_RUNTIME is not true. */
3513 assert(IN_PERL_RUNTIME);
5f2d9966
DM		 3514 PL_warnhook = PERL_WARNHOOK_FATAL;
3515 PL_diehook = NULL;
b7f7fd0b
NC		 3516 JMPENV_PUSH(ret);
3517
3518 switch (ret) {
3519 case 0:
3520 CALLRUNOPS(aTHX);
3521 sv = *(PL_stack_sp--);
523a0f0c
NC		 3522 if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
3523#ifdef PERL_MAD
3524 /* Can't simply swipe the SV from the pad, because that relies on
3525 the op being freed "real soon now". Under MAD, this doesn't
3526 happen (see the #ifdef below). */
3527 sv = newSVsv(sv);
3528#else
b7f7fd0b 3529 pad_swipe(o->op_targ, FALSE);
523a0f0c
NC		 3530#endif
3531 }
b7f7fd0b
NC		 3532 else if (SvTEMP(sv)) { /* grab mortal temp? */
3533 SvREFCNT_inc_simple_void(sv);
3534 SvTEMP_off(sv);
3535 }
ba610af8 3536 else { assert(SvIMMORTAL(sv)); }
b7f7fd0b
NC		 3537 break;
3538 case 3:
3539 /* Something tried to die. Abandon constant folding. */
3540 /* Pretend the error never happened. */
ab69dbc2 3541 CLEAR_ERRSV();
b7f7fd0b
NC		 3542 o->op_next = old_next;
3543 break;
3544 default:
3545 JMPENV_POP;
5f2d9966
DM		 3546 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
3547 PL_warnhook = oldwarnhook;
3548 PL_diehook = olddiehook;
3549 /* XXX note that this croak may fail as we've already blown away
3550 * the stack - eg any nested evals */
b7f7fd0b
NC		 3551 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
3552 }
b7f7fd0b 3553 JMPENV_POP;
5f2d9966
DM		 3554 PL_warnhook = oldwarnhook;
3555 PL_diehook = olddiehook;
c427f4d2 3556 PL_curcop = &PL_compiling;
edb2152a
NC		 3557
3558 if (PL_scopestack_ix > oldscope)
3559 delete_eval_scope();
eb8433b7 3560
b7f7fd0b
NC		 3561 if (ret)
3562 goto nope;
3563
eb8433b7 3564#ifndef PERL_MAD
79072805 3565 op_free(o);
eb8433b7 3566#endif
de5e01c2 3567 assert(sv);
07a05c08
FC		 3568 if (type == OP_STRINGIFY) SvPADTMP_off(sv);
3569 else if (!SvIMMORTAL(sv)) SvPADTMP_on(sv);
79072805 3570 if (type == OP_RV2GV)
159b6efe 3571 newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
eb8433b7 3572 else
3513c740 3573 {
51bed69a 3574 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
437463ee 3575 if (type != OP_STRINGIFY) newop->op_folded = 1;
3513c740 3576 }
eb8433b7
NC		 3577 op_getmad(o,newop,'f');
3578 return newop;
aeea060c 3579
b7f7fd0b 3580 nope:
79072805
LW		 3581 return o;
3582}
3583
1f676739 3584static OP *
5aaab254 3585S_gen_constant_list(pTHX_ OP *o)
79072805 3586{
27da23d5 3587 dVAR;
eb578fdb 3588 OP *curop;
e8eb279c 3589 const SSize_t oldtmps_floor = PL_tmps_floor;
5608dcc6
FC		 3590 SV **svp;
3591 AV *av;
79072805 3592
a0d0e21e 3593 list(o);
13765c85 3594 if (PL_parser && PL_parser->error_count)
a0d0e21e
LW		 3595 return o; /* Don't attempt to run with errors */
3596
533c011a 3597 PL_op = curop = LINKLIST(o);
a0d0e21e 3598 o->op_next = 0;
a2efc822 3599 CALL_PEEP(curop);
897d3989 3600 Perl_pp_pushmark(aTHX);
cea2e8a9 3601 CALLRUNOPS(aTHX);
533c011a 3602 PL_op = curop;
78c72037
NC		 3603 assert (!(curop->op_flags & OPf_SPECIAL));
3604 assert(curop->op_type == OP_RANGE);
897d3989 3605 Perl_pp_anonlist(aTHX);
3280af22 3606 PL_tmps_floor = oldtmps_floor;
79072805
LW		 3607
3608 o->op_type = OP_RV2AV;
22c35a8c 3609 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
fb53bbb2
SG		 3610 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
3611 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
1a0a2ba9 3612 o->op_opt = 0; /* needs to be revisited in rpeep() */
79072805 3613 curop = ((UNOP*)o)->op_first;
5608dcc6
FC		 3614 av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
3615 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, (SV *)av);
3616 if (AvFILLp(av) != -1)
3617 for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
3618 SvPADTMP_on(*svp);
eb8433b7
NC		 3619#ifdef PERL_MAD
3620 op_getmad(curop,o,'O');
3621#else
79072805 3622 op_free(curop);
eb8433b7 3623#endif
5983a79d 3624 LINKLIST(o);
79072805
LW		 3625 return list(o);
3626}
3627
3628OP *
864dbfa3 3629Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
79072805 3630{
27da23d5 3631 dVAR;
d67594ff 3632 if (type < 0) type = -type, flags |= OPf_SPECIAL;
11343788 3633 if (!o || o->op_type != OP_LIST)
5f66b61c 3634 o = newLISTOP(OP_LIST, 0, o, NULL);
748a9306 3635 else
5dc0d613 3636 o->op_flags &= ~OPf_WANT;
79072805 3637
22c35a8c 3638 if (!(PL_opargs[type] & OA_MARK))
93c66552 3639 op_null(cLISTOPo->op_first);
bf0571fd
FC		 3640 else {
3641 OP * const kid2 = cLISTOPo->op_first->op_sibling;
3642 if (kid2 && kid2->op_type == OP_COREARGS) {
3643 op_null(cLISTOPo->op_first);
3644 kid2->op_private |= OPpCOREARGS_PUSHMARK;
3645 }
3646 }
8990e307 3647
eb160463 3648 o->op_type = (OPCODE)type;
22c35a8c 3649 o->op_ppaddr = PL_ppaddr[type];
11343788 3650 o->op_flags |= flags;
79072805 3651
11343788 3652 o = CHECKOP(type, o);
fe2774ed 3653 if (o->op_type != (unsigned)type)
11343788 3654 return o;
79072805 3655
985b9e54 3656 return fold_constants(op_integerize(op_std_init(o)));
79072805
LW		 3657}
3658
2fcb4757
Z		 3659/*
3660=head1 Optree Manipulation Functions
3661*/
3662
79072805
LW		 3663/* List constructors */
3664
2fcb4757
Z		 3665/*
3666=for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
3667
3668Append an item to the list of ops contained directly within a list-type
3669op, returning the lengthened list. I<first> is the list-type op,
3670and I<last> is the op to append to the list. I<optype> specifies the
3671intended opcode for the list. If I<first> is not already a list of the
3672right type, it will be upgraded into one. If either I<first> or I<last>
3673is null, the other is returned unchanged.
3674
3675=cut
3676*/
3677
79072805 3678OP *
2fcb4757 3679Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW		 3680{
3681 if (!first)
3682 return last;
8990e307
LW		 3683
3684 if (!last)
79072805 3685 return first;
8990e307 3686
fe2774ed 3687 if (first->op_type != (unsigned)type
155aba94
GS		 3688 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
3689 {
3690 return newLISTOP(type, 0, first, last);
3691 }
79072805 3692
a0d0e21e
LW		 3693 if (first->op_flags & OPf_KIDS)
3694 ((LISTOP*)first)->op_last->op_sibling = last;
3695 else {
3696 first->op_flags |= OPf_KIDS;
3697 ((LISTOP*)first)->op_first = last;
3698 }
3699 ((LISTOP*)first)->op_last = last;
a0d0e21e 3700 return first;
79072805
LW		 3701}
3702
2fcb4757
Z		 3703/*
3704=for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
3705
3706Concatenate the lists of ops contained directly within two list-type ops,
3707returning the combined list. I<first> and I<last> are the list-type ops
3708to concatenate. I<optype> specifies the intended opcode for the list.
3709If either I<first> or I<last> is not already a list of the right type,
3710it will be upgraded into one. If either I<first> or I<last> is null,
3711the other is returned unchanged.
3712
3713=cut
3714*/
3715
79072805 3716OP *
2fcb4757 3717Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
79072805
LW		 3718{
3719 if (!first)
2fcb4757 3720 return last;
8990e307
LW		 3721
3722 if (!last)
2fcb4757 3723 return first;
8990e307 3724
fe2774ed 3725 if (first->op_type != (unsigned)type)
2fcb4757 3726 return op_prepend_elem(type, first, last);
8990e307 3727
fe2774ed 3728 if (last->op_type != (unsigned)type)
2fcb4757 3729 return op_append_elem(type, first, last);
79072805 3730
2fcb4757
Z		 3731 ((LISTOP*)first)->op_last->op_sibling = ((LISTOP*)last)->op_first;
3732 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
117dada2 3733 first->op_flags |= (last->op_flags & OPf_KIDS);
1c846c1f 3734
eb8433b7 3735#ifdef PERL_MAD
2fcb4757
Z		 3736 if (((LISTOP*)last)->op_first && first->op_madprop) {
3737 MADPROP *mp = ((LISTOP*)last)->op_first->op_madprop;
eb8433b7
NC		 3738 if (mp) {
3739 while (mp->mad_next)
3740 mp = mp->mad_next;
3741 mp->mad_next = first->op_madprop;
3742 }
3743 else {
2fcb4757 3744 ((LISTOP*)last)->op_first->op_madprop = first->op_madprop;
eb8433b7
NC		 3745 }
3746 }
3747 first->op_madprop = last->op_madprop;
3748 last->op_madprop = 0;
3749#endif
3750
2fcb4757 3751 S_op_destroy(aTHX_ last);
238a4c30 3752
2fcb4757 3753 return first;
79072805
LW		 3754}
3755
2fcb4757
Z		 3756/*
3757=for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
3758
3759Prepend an item to the list of ops contained directly within a list-type
3760op, returning the lengthened list. I<first> is the op to prepend to the
3761list, and I<last> is the list-type op. I<optype> specifies the intended
3762opcode for the list. If I<last> is not already a list of the right type,
3763it will be upgraded into one. If either I<first> or I<last> is null,
3764the other is returned unchanged.
3765
3766=cut
3767*/
3768
79072805 3769OP *
2fcb4757 3770Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW		 3771{
3772 if (!first)
3773 return last;
8990e307
LW		 3774
3775 if (!last)
79072805 3776 return first;
8990e307 3777
fe2774ed 3778 if (last->op_type == (unsigned)type) {
8990e307
LW		 3779 if (type == OP_LIST) { /* already a PUSHMARK there */
3780 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
3781 ((LISTOP*)last)->op_first->op_sibling = first;
36a5d4ba
DC		 3782 if (!(first->op_flags & OPf_PARENS))
3783 last->op_flags &= ~OPf_PARENS;
8990e307
LW		 3784 }
3785 else {
3786 if (!(last->op_flags & OPf_KIDS)) {
3787 ((LISTOP*)last)->op_last = first;
3788 last->op_flags |= OPf_KIDS;
3789 }
3790 first->op_sibling = ((LISTOP*)last)->op_first;
3791 ((LISTOP*)last)->op_first = first;
79072805 3792 }
117dada2 3793 last->op_flags |= OPf_KIDS;
79072805
LW		 3794 return last;
3795 }
3796
3797 return newLISTOP(type, 0, first, last);
3798}
3799
3800/* Constructors */
3801
eb8433b7
NC		 3802#ifdef PERL_MAD
3803
3804TOKEN *
3805Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
3806{
3807 TOKEN *tk;
99129197 3808 Newxz(tk, 1, TOKEN);
eb8433b7
NC		 3809 tk->tk_type = (OPCODE)optype;
3810 tk->tk_type = 12345;
3811 tk->tk_lval = lval;
3812 tk->tk_mad = madprop;
3813 return tk;
3814}
3815
3816void
3817Perl_token_free(pTHX_ TOKEN* tk)
3818{
7918f24d
NC		 3819 PERL_ARGS_ASSERT_TOKEN_FREE;
3820
eb8433b7
NC		 3821 if (tk->tk_type != 12345)
3822 return;
3823 mad_free(tk->tk_mad);
3824 Safefree(tk);
3825}
3826
3827void
3828Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
3829{
3830 MADPROP* mp;
3831 MADPROP* tm;
7918f24d
NC		 3832
3833 PERL_ARGS_ASSERT_TOKEN_GETMAD;
3834
eb8433b7
NC		 3835 if (tk->tk_type != 12345) {
3836 Perl_warner(aTHX_ packWARN(WARN_MISC),
3837 "Invalid TOKEN object ignored");
3838 return;
3839 }
3840 tm = tk->tk_mad;
3841 if (!tm)
3842 return;
3843
3844 /* faked up qw list? */
3845 if (slot == '(' &&
3846 tm->mad_type == MAD_SV &&
d503a9ba 3847 SvPVX((SV *)tm->mad_val)[0] == 'q')
eb8433b7
NC		 3848 slot = 'x';
3849
3850 if (o) {
3851 mp = o->op_madprop;
3852 if (mp) {
3853 for (;;) {
3854 /* pretend constant fold didn't happen? */
3855 if (mp->mad_key == 'f' &&
3856 (o->op_type == OP_CONST ||
3857 o->op_type == OP_GV) )
3858 {
3859 token_getmad(tk,(OP*)mp->mad_val,slot);
3860 return;
3861 }
3862 if (!mp->mad_next)
3863 break;
3864 mp = mp->mad_next;
3865 }
3866 mp->mad_next = tm;
3867 mp = mp->mad_next;
3868 }
3869 else {
3870 o->op_madprop = tm;
3871 mp = o->op_madprop;
3872 }
3873 if (mp->mad_key == 'X')
3874 mp->mad_key = slot; /* just change the first one */
3875
3876 tk->tk_mad = 0;
3877 }
3878 else
3879 mad_free(tm);
3880 Safefree(tk);
3881}
3882
3883void
3884Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
3885{
3886 MADPROP* mp;
3887 if (!from)
3888 return;
3889 if (o) {
3890 mp = o->op_madprop;
3891 if (mp) {
3892 for (;;) {
3893 /* pretend constant fold didn't happen? */
3894 if (mp->mad_key == 'f' &&
3895 (o->op_type == OP_CONST ||
3896 o->op_type == OP_GV) )
3897 {
3898 op_getmad(from,(OP*)mp->mad_val,slot);
3899 return;
3900 }
3901 if (!mp->mad_next)
3902 break;
3903 mp = mp->mad_next;
3904 }
3905 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
3906 }
3907 else {
3908 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
3909 }
3910 }
3911}
3912
3913void
3914Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
3915{
3916 MADPROP* mp;
3917 if (!from)
3918 return;
3919 if (o) {
3920 mp = o->op_madprop;
3921 if (mp) {
3922 for (;;) {
3923 /* pretend constant fold didn't happen? */
3924 if (mp->mad_key == 'f' &&
3925 (o->op_type == OP_CONST ||
3926 o->op_type == OP_GV) )
3927 {
3928 op_getmad(from,(OP*)mp->mad_val,slot);
3929 return;
3930 }
3931 if (!mp->mad_next)
3932 break;
3933 mp = mp->mad_next;
3934 }
3935 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
3936 }
3937 else {
3938 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
3939 }
3940 }
3941 else {
99129197
NC		 3942 PerlIO_printf(PerlIO_stderr(),
3943 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
eb8433b7
NC		 3944 op_free(from);
3945 }
3946}
3947
3948void
3949Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
3950{
3951 MADPROP* tm;
3952 if (!mp || !o)
3953 return;
3954 if (slot)
3955 mp->mad_key = slot;
3956 tm = o->op_madprop;
3957 o->op_madprop = mp;
3958 for (;;) {
3959 if (!mp->mad_next)
3960 break;
3961 mp = mp->mad_next;
3962 }
3963 mp->mad_next = tm;
3964}
3965
3966void
3967Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
3968{
3969 if (!o)
3970 return;
3971 addmad(tm, &(o->op_madprop), slot);
3972}
3973
3974void
3975Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
3976{
3977 MADPROP* mp;
3978 if (!tm || !root)
3979 return;
3980 if (slot)
3981 tm->mad_key = slot;
3982 mp = *root;
3983 if (!mp) {
3984 *root = tm;
3985 return;
3986 }
3987 for (;;) {
3988 if (!mp->mad_next)
3989 break;
3990 mp = mp->mad_next;
3991 }
3992 mp->mad_next = tm;
3993}
3994
3995MADPROP *
3996Perl_newMADsv(pTHX_ char key, SV* sv)
3997{
7918f24d
NC		 3998 PERL_ARGS_ASSERT_NEWMADSV;
3999
eb8433b7
NC		 4000 return newMADPROP(key, MAD_SV, sv, 0);
4001}
4002
4003MADPROP *
d503a9ba 4004Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
eb8433b7 4005{
c111d5f1 4006 MADPROP *const mp = (MADPROP *) PerlMemShared_malloc(sizeof(MADPROP));
eb8433b7
NC		 4007 mp->mad_next = 0;
4008 mp->mad_key = key;
4009 mp->mad_vlen = vlen;
4010 mp->mad_type = type;
4011 mp->mad_val = val;
4012/* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
4013 return mp;
4014}
4015
4016void
4017Perl_mad_free(pTHX_ MADPROP* mp)
4018{
4019/* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
4020 if (!mp)
4021 return;
4022 if (mp->mad_next)
4023 mad_free(mp->mad_next);
bc177e6b 4024/* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
eb8433b7
NC		 4025 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
4026 switch (mp->mad_type) {
4027 case MAD_NULL:
4028 break;
4029 case MAD_PV:
04d1a275 4030 Safefree(mp->mad_val);
eb8433b7
NC		 4031 break;
4032 case MAD_OP:
4033 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
4034 op_free((OP*)mp->mad_val);
4035 break;
4036 case MAD_SV:
ad64d0ec 4037 sv_free(MUTABLE_SV(mp->mad_val));
eb8433b7
NC		 4038 break;
4039 default:
4040 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
4041 break;
4042 }
c111d5f1 4043 PerlMemShared_free(mp);
eb8433b7
NC		 4044}
4045
4046#endif
4047
d67eb5f4
Z		 4048/*
4049=head1 Optree construction
4050
4051=for apidoc Am|OP *|newNULLLIST
4052
4053Constructs, checks, and returns a new C<stub> op, which represents an
4054empty list expression.
4055
4056=cut
4057*/
4058
79072805 4059OP *
864dbfa3 4060Perl_newNULLLIST(pTHX)
79072805 4061{
8990e307
LW		 4062 return newOP(OP_STUB, 0);
4063}
4064
1f676739 4065static OP *
b7783a12 4066S_force_list(pTHX_ OP *o)
8990e307 4067{
11343788 4068 if (!o || o->op_type != OP_LIST)
5f66b61c 4069 o = newLISTOP(OP_LIST, 0, o, NULL);
93c66552 4070 op_null(o);
11343788 4071 return o;
79072805
LW		 4072}
4073
d67eb5f4
Z		 4074/*
4075=for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
4076
4077Constructs, checks, and returns an op of any list type. I<type> is
4078the opcode. I<flags> gives the eight bits of C<op_flags>, except that
4079C<OPf_KIDS> will be set automatically if required. I<first> and I<last>
4080supply up to two ops to be direct children of the list op; they are
4081consumed by this function and become part of the constructed op tree.
4082
4083=cut
4084*/
4085
79072805 4086OP *
864dbfa3 4087Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
79072805 4088{
27da23d5 4089 dVAR;
79072805
LW		 4090 LISTOP *listop;
4091
e69777c1
GG		 4092 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
4093
b7dc083c 4094 NewOp(1101, listop, 1, LISTOP);
79072805 4095
eb160463 4096 listop->op_type = (OPCODE)type;
22c35a8c 4097 listop->op_ppaddr = PL_ppaddr[type];
117dada2
SM		 4098 if (first || last)
4099 flags |= OPf_KIDS;
eb160463 4100 listop->op_flags = (U8)flags;
79072805
LW		 4101
4102 if (!last && first)
4103 last = first;
4104 else if (!first && last)
4105 first = last;
8990e307
LW		 4106 else if (first)
4107 first->op_sibling = last;
79072805
LW		 4108 listop->op_first = first;
4109 listop->op_last = last;
8990e307 4110 if (type == OP_LIST) {
551405c4 4111 OP* const pushop = newOP(OP_PUSHMARK, 0);
8990e307
LW		 4112 pushop->op_sibling = first;
4113 listop->op_first = pushop;
4114 listop->op_flags |= OPf_KIDS;
4115 if (!last)
4116 listop->op_last = pushop;
4117 }
79072805 4118
463d09e6 4119 return CHECKOP(type, listop);
79072805
LW		 4120}
4121
d67eb5f4
Z		 4122/*
4123=for apidoc Am|OP *|newOP|I32 type|I32 flags
4124
4125Constructs, checks, and returns an op of any base type (any type that
4126has no extra fields). I<type> is the opcode. I<flags> gives the
4127eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
4128of C<op_private>.
4129
4130=cut
4131*/
4132
79072805 4133OP *
864dbfa3 4134Perl_newOP(pTHX_ I32 type, I32 flags)
79072805 4135{
27da23d5 4136 dVAR;
11343788 4137 OP *o;
e69777c1 4138
7d789282
FC		 4139 if (type == -OP_ENTEREVAL) {
4140 type = OP_ENTEREVAL;
4141 flags |= OPpEVAL_BYTES<<8;
4142 }
4143
e69777c1
GG		 4144 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
4145 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4146 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4147 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4148
b7dc083c 4149 NewOp(1101, o, 1, OP);
eb160463 4150 o->op_type = (OPCODE)type;
22c35a8c 4151 o->op_ppaddr = PL_ppaddr[type];
eb160463 4152 o->op_flags = (U8)flags;
79072805 4153
11343788 4154 o->op_next = o;
eb160463 4155 o->op_private = (U8)(0 | (flags >> 8));
22c35a8c 4156 if (PL_opargs[type] & OA_RETSCALAR)
11343788 4157 scalar(o);
22c35a8c 4158 if (PL_opargs[type] & OA_TARGET)
11343788
MB		 4159 o->op_targ = pad_alloc(type, SVs_PADTMP);
4160 return CHECKOP(type, o);
79072805
LW		 4161}
4162
d67eb5f4
Z		 4163/*
4164=for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
4165
4166Constructs, checks, and returns an op of any unary type. I<type> is
4167the opcode. I<flags> gives the eight bits of C<op_flags>, except that
4168C<OPf_KIDS> will be set automatically if required, and, shifted up eight
4169bits, the eight bits of C<op_private>, except that the bit with value 1
4170is automatically set. I<first> supplies an optional op to be the direct
4171child of the unary op; it is consumed by this function and become part
4172of the constructed op tree.
4173
4174=cut
4175*/
4176
79072805 4177OP *
864dbfa3 4178Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
79072805 4179{
27da23d5 4180 dVAR;
79072805
LW		 4181 UNOP *unop;
4182
7d789282
FC		 4183 if (type == -OP_ENTEREVAL) {
4184 type = OP_ENTEREVAL;
4185 flags |= OPpEVAL_BYTES<<8;
4186 }
4187
e69777c1
GG		 4188 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
4189 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4190 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4191 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
4192 || type == OP_SASSIGN
32e2a35d 4193 || type == OP_ENTERTRY
e69777c1
GG		 4194 || type == OP_NULL );
4195
93a17b20 4196 if (!first)
aeea060c 4197 first = newOP(OP_STUB, 0);
22c35a8c 4198 if (PL_opargs[type] & OA_MARK)
8990e307 4199 first = force_list(first);
93a17b20 4200
b7dc083c 4201 NewOp(1101, unop, 1, UNOP);
eb160463 4202 unop->op_type = (OPCODE)type;
22c35a8c 4203 unop->op_ppaddr = PL_ppaddr[type];
79072805 4204 unop->op_first = first;
585ec06d 4205 unop->op_flags = (U8)(flags | OPf_KIDS);
eb160463 4206 unop->op_private = (U8)(1 | (flags >> 8));
e50aee73 4207 unop = (UNOP*) CHECKOP(type, unop);
79072805
LW		 4208 if (unop->op_next)
4209 return (OP*)unop;
4210
985b9e54 4211 return fold_constants(op_integerize(op_std_init((OP *) unop)));
79072805
LW		 4212}
4213
d67eb5f4
Z		 4214/*
4215=for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
4216
4217Constructs, checks, and returns an op of any binary type. I<type>
4218is the opcode. I<flags> gives the eight bits of C<op_flags>, except
4219that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
4220the eight bits of C<op_private>, except that the bit with value 1 or
42212 is automatically set as required. I<first> and I<last> supply up to
4222two ops to be the direct children of the binary op; they are consumed
4223by this function and become part of the constructed op tree.
4224
4225=cut
4226*/
4227
79072805 4228OP *
864dbfa3 4229Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
79072805 4230{
27da23d5 4231 dVAR;
79072805 4232 BINOP *binop;
e69777c1
GG		 4233
4234 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
4235 || type == OP_SASSIGN || type == OP_NULL );
4236
b7dc083c 4237 NewOp(1101, binop, 1, BINOP);
79072805
LW		 4238
4239 if (!first)
4240 first = newOP(OP_NULL, 0);
4241
eb160463 4242 binop->op_type = (OPCODE)type;
22c35a8c 4243 binop->op_ppaddr = PL_ppaddr[type];
79072805 4244 binop->op_first = first;
585ec06d 4245 binop->op_flags = (U8)(flags | OPf_KIDS);
79072805
LW		 4246 if (!last) {
4247 last = first;
eb160463 4248 binop->op_private = (U8)(1 | (flags >> 8));
79072805
LW		 4249 }
4250 else {
eb160463 4251 binop->op_private = (U8)(2 | (flags >> 8));
79072805
LW		 4252 first->op_sibling = last;
4253 }
4254
e50aee73 4255 binop = (BINOP*)CHECKOP(type, binop);
eb160463 4256 if (binop->op_next || binop->op_type != (OPCODE)type)
79072805
LW		 4257 return (OP*)binop;
4258
7284ab6f 4259 binop->op_last = binop->op_first->op_sibling;
79072805 4260
985b9e54 4261 return fold_constants(op_integerize(op_std_init((OP *)binop)));
79072805
LW		 4262}
4263
5f66b61c
AL		 4264static int uvcompare(const void *a, const void *b)
4265 __attribute__nonnull__(1)
4266 __attribute__nonnull__(2)
4267 __attribute__pure__;
abb2c242 4268static int uvcompare(const void *a, const void *b)
2b9d42f0 4269{
e1ec3a88 4270 if (*((const UV *)a) < (*(const UV *)b))
2b9d42f0 4271 return -1;
e1ec3a88 4272 if (*((const UV *)a) > (*(const UV *)b))
2b9d42f0 4273 return 1;
e1ec3a88 4274 if (*((const UV *)a+1) < (*(const UV *)b+1))
2b9d42f0 4275 return -1;
e1ec3a88 4276 if (*((const UV *)a+1) > (*(const UV *)b+1))
2b9d42f0 4277 return 1;
a0ed51b3
LW		 4278 return 0;
4279}
4280
0d86688d
NC		 4281static OP *
4282S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
79072805 4283{
97aff369 4284 dVAR;
2d03de9c 4285 SV * const tstr = ((SVOP*)expr)->op_sv;
fbbb0949
DM		 4286 SV * const rstr =
4287#ifdef PERL_MAD
4288 (repl->op_type == OP_NULL)
4289 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
4290#endif
4291 ((SVOP*)repl)->op_sv;
463ee0b2
LW		 4292 STRLEN tlen;
4293 STRLEN rlen;
5c144d81
NC		 4294 const U8 *t = (U8*)SvPV_const(tstr, tlen);
4295 const U8 *r = (U8*)SvPV_const(rstr, rlen);
eb578fdb
KW		 4296 I32 i;
4297 I32 j;
9b877dbb 4298 I32 grows = 0;
eb578fdb 4299 short *tbl;
79072805 4300
551405c4
AL		 4301 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
4302 const I32 squash = o->op_private & OPpTRANS_SQUASH;
4303 I32 del = o->op_private & OPpTRANS_DELETE;
043e41b8 4304 SV* swash;
7918f24d
NC		 4305
4306 PERL_ARGS_ASSERT_PMTRANS;
4307
800b4dc4 4308 PL_hints |= HINT_BLOCK_SCOPE;
1c846c1f 4309
036b4402
GS		 4310 if (SvUTF8(tstr))
4311 o->op_private |= OPpTRANS_FROM_UTF;
1c846c1f
NIS		 4312
4313 if (SvUTF8(rstr))
036b4402 4314 o->op_private |= OPpTRANS_TO_UTF;
79072805 4315
a0ed51b3 4316 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
396482e1 4317 SV* const listsv = newSVpvs("# comment\n");
c445ea15 4318 SV* transv = NULL;
5c144d81
NC		 4319 const U8* tend = t + tlen;
4320 const U8* rend = r + rlen;
ba210ebe 4321 STRLEN ulen;
84c133a0
RB		 4322 UV tfirst = 1;
4323 UV tlast = 0;
4324 IV tdiff;
4325 UV rfirst = 1;
4326 UV rlast = 0;
4327 IV rdiff;
4328 IV diff;
a0ed51b3
LW		 4329 I32 none = 0;
4330 U32 max = 0;
4331 I32 bits;
a0ed51b3 4332 I32 havefinal = 0;
9c5ffd7c 4333 U32 final = 0;
551405c4
AL		 4334 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
4335 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
bf4a1e57
JH		 4336 U8* tsave = NULL;
4337 U8* rsave = NULL;
9f7f3913 4338 const U32 flags = UTF8_ALLOW_DEFAULT;
bf4a1e57
JH		 4339
4340 if (!from_utf) {
4341 STRLEN len = tlen;
5c144d81 4342 t = tsave = bytes_to_utf8(t, &len);
bf4a1e57
JH		 4343 tend = t + len;
4344 }
4345 if (!to_utf && rlen) {
4346 STRLEN len = rlen;
5c144d81 4347 r = rsave = bytes_to_utf8(r, &len);
bf4a1e57
JH		 4348 rend = r + len;
4349 }
a0ed51b3 4350
e7214ce8
KW		 4351/* There is a snag with this code on EBCDIC: scan_const() in toke.c has
4352 * encoded chars in native encoding which makes ranges in the EBCDIC 0..255
4353 * odd. */
2b9d42f0 4354
a0ed51b3 4355 if (complement) {
89ebb4a3 4356 U8 tmpbuf[UTF8_MAXBYTES+1];
2b9d42f0 4357 UV *cp;
a0ed51b3 4358 UV nextmin = 0;
a02a5408 4359 Newx(cp, 2*tlen, UV);
a0ed51b3 4360 i = 0;
396482e1 4361 transv = newSVpvs("");
a0ed51b3 4362 while (t < tend) {
c80e42f3 4363 cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
2b9d42f0 4364 t += ulen;
e7214ce8 4365 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {
a0ed51b3 4366 t++;
c80e42f3 4367 cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
2b9d42f0 4368 t += ulen;
a0ed51b3 4369 }
2b9d42f0
NIS		 4370 else {
4371 cp[2*i+1] = cp[2*i];
4372 }
4373 i++;
a0ed51b3 4374 }
2b9d42f0 4375 qsort(cp, i, 2*sizeof(UV), uvcompare);
a0ed51b3 4376 for (j = 0; j < i; j++) {
2b9d42f0 4377 UV val = cp[2*j];
a0ed51b3
LW		 4378 diff = val - nextmin;
4379 if (diff > 0) {
c80e42f3 4380 t = uvchr_to_utf8(tmpbuf,nextmin);
dfe13c55 4381 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
a0ed51b3 4382 if (diff > 1) {
e7214ce8 4383 U8 range_mark = ILLEGAL_UTF8_BYTE;
c80e42f3 4384 t = uvchr_to_utf8(tmpbuf, val - 1);
2b9d42f0 4385 sv_catpvn(transv, (char *)&range_mark, 1);
dfe13c55 4386 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
a0ed51b3
LW		 4387 }
4388 }
2b9d42f0 4389 val = cp[2*j+1];
a0ed51b3
LW		 4390 if (val >= nextmin)
4391 nextmin = val + 1;
4392 }
c80e42f3 4393 t = uvchr_to_utf8(tmpbuf,nextmin);
dfe13c55 4394 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2b9d42f0 4395 {
e7214ce8 4396 U8 range_mark = ILLEGAL_UTF8_BYTE;
2b9d42f0
NIS		 4397 sv_catpvn(transv, (char *)&range_mark, 1);
4398 }
c80e42f3 4399 t = uvchr_to_utf8(tmpbuf, 0x7fffffff);
dfe13c55 4400 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
93524f2b 4401 t = (const U8*)SvPVX_const(transv);
a0ed51b3
LW		 4402 tlen = SvCUR(transv);
4403 tend = t + tlen;
455d824a 4404 Safefree(cp);
a0ed51b3
LW		 4405 }
4406 else if (!rlen && !del) {
4407 r = t; rlen = tlen; rend = tend;
4757a243
LW		 4408 }
4409 if (!squash) {
05d340b8 4410 if ((!rlen && !del) || t == r ||
12ae5dfc 4411 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
01ec43d0 4412 {
4757a243 4413 o->op_private |= OPpTRANS_IDENTICAL;
01ec43d0 4414 }
a0ed51b3
LW		 4415 }
4416
4417 while (t < tend || tfirst <= tlast) {
4418 /* see if we need more "t" chars */
4419 if (tfirst > tlast) {
c80e42f3 4420 tfirst = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
a0ed51b3 4421 t += ulen;
e7214ce8 4422 if (t < tend && *t == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */
ba210ebe 4423 t++;
c80e42f3 4424 tlast = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
a0ed51b3
LW		 4425 t += ulen;
4426 }
4427 else
4428 tlast = tfirst;
4429 }
4430
4431 /* now see if we need more "r" chars */
4432 if (rfirst > rlast) {
4433 if (r < rend) {
c80e42f3 4434 rfirst = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
a0ed51b3 4435 r += ulen;
e7214ce8 4436 if (r < rend && *r == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */
ba210ebe 4437 r++;
c80e42f3 4438 rlast = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
a0ed51b3
LW		 4439 r += ulen;
4440 }
4441 else
4442 rlast = rfirst;
4443 }
4444 else {
4445 if (!havefinal++)
4446 final = rlast;
4447 rfirst = rlast = 0xffffffff;
4448 }
4449 }
4450
4451 /* now see which range will peter our first, if either. */
4452 tdiff = tlast - tfirst;
4453 rdiff = rlast - rfirst;
4454
4455 if (tdiff <= rdiff)
4456 diff = tdiff;
4457 else
4458 diff = rdiff;
4459
4460 if (rfirst == 0xffffffff) {
4461 diff = tdiff; /* oops, pretend rdiff is infinite */
4462 if (diff > 0)
894356b3
GS		 4463 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
4464 (long)tfirst, (long)tlast);
a0ed51b3 4465 else
894356b3 4466 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
a0ed51b3
LW		 4467 }
4468 else {
4469 if (diff > 0)
894356b3
GS		 4470 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
4471 (long)tfirst, (long)(tfirst + diff),
4472 (long)rfirst);
a0ed51b3 4473 else
894356b3
GS		 4474 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
4475 (long)tfirst, (long)rfirst);
a0ed51b3
LW		 4476
4477 if (rfirst + diff > max)
4478 max = rfirst + diff;
9b877dbb 4479 if (!grows)
45005bfb
JH		 4480 grows = (tfirst < rfirst &&
4481 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
4482 rfirst += diff + 1;
a0ed51b3
LW		 4483 }
4484 tfirst += diff + 1;
4485 }
4486
4487 none = ++max;
4488 if (del)
4489 del = ++max;
4490
4491 if (max > 0xffff)
4492 bits = 32;
4493 else if (max > 0xff)
4494 bits = 16;
4495 else
4496 bits = 8;
4497
ad64d0ec 4498 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
043e41b8 4499#ifdef USE_ITHREADS
3a6ce63a 4500 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
043e41b8
DM		 4501 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
4502 PAD_SETSV(cPADOPo->op_padix, swash);
4503 SvPADTMP_on(swash);
a5446a64 4504 SvREADONLY_on(swash);
043e41b8
DM		 4505#else
4506 cSVOPo->op_sv = swash;
4507#endif
a0ed51b3 4508 SvREFCNT_dec(listsv);
b37c2d43 4509 SvREFCNT_dec(transv);
a0ed51b3 4510
45005bfb 4511 if (!del && havefinal && rlen)
85fbaab2 4512 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
b448e4fe 4513 newSVuv((UV)final), 0);
a0ed51b3 4514
9b877dbb 4515 if (grows)
a0ed51b3
LW		 4516 o->op_private |= OPpTRANS_GROWS;
4517
b37c2d43
AL		 4518 Safefree(tsave);
4519 Safefree(rsave);
9b877dbb 4520
eb8433b7
NC		 4521#ifdef PERL_MAD
4522 op_getmad(expr,o,'e');
4523 op_getmad(repl,o,'r');
4524#else
a0ed51b3
LW		 4525 op_free(expr);
4526 op_free(repl);
eb8433b7 4527#endif
a0ed51b3
LW		 4528 return o;
4529 }
4530
9100eeb1
Z		 4531 tbl = (short*)PerlMemShared_calloc(
4532 (o->op_private & OPpTRANS_COMPLEMENT) &&
4533 !(o->op_private & OPpTRANS_DELETE) ? 258 : 256,
4534 sizeof(short));
4535 cPVOPo->op_pv = (char*)tbl;
79072805 4536 if (complement) {
eb160463 4537 for (i = 0; i < (I32)tlen; i++)
ec49126f 4538 tbl[t[i]] = -1;
79072805
LW		 4539 for (i = 0, j = 0; i < 256; i++) {
4540 if (!tbl[i]) {
eb160463 4541 if (j >= (I32)rlen) {
a0ed51b3 4542 if (del)
79072805
LW		 4543 tbl[i] = -2;
4544 else if (rlen)
ec49126f 4545 tbl[i] = r[j-1];
79072805 4546 else
eb160463 4547 tbl[i] = (short)i;
79072805 4548 }
9b877dbb
IH		 4549 else {
4550 if (i < 128 && r[j] >= 128)
4551 grows = 1;
ec49126f 4552 tbl[i] = r[j++];
9b877dbb 4553 }
79072805
LW		 4554 }
4555 }
05d340b8
JH		 4556 if (!del) {
4557 if (!rlen) {
4558 j = rlen;
4559 if (!squash)
4560 o->op_private |= OPpTRANS_IDENTICAL;
4561 }
eb160463 4562 else if (j >= (I32)rlen)
05d340b8 4563 j = rlen - 1;
10db182f 4564 else {
aa1f7c5b
JH		 4565 tbl =
4566 (short *)
4567 PerlMemShared_realloc(tbl,
4568 (0x101+rlen-j) * sizeof(short));
10db182f
YO		 4569 cPVOPo->op_pv = (char*)tbl;
4570 }
585ec06d 4571 tbl[0x100] = (short)(rlen - j);
eb160463 4572 for (i=0; i < (I32)rlen - j; i++)
8973db79
JH		 4573 tbl[0x101+i] = r[j+i];
4574 }
79072805
LW		 4575 }
4576 else {
a0ed51b3 4577 if (!rlen && !del) {
79072805 4578 r = t; rlen = tlen;
5d06d08e 4579 if (!squash)
4757a243 4580 o->op_private |= OPpTRANS_IDENTICAL;
79072805 4581 }
94bfe852
RGS		 4582 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
4583 o->op_private |= OPpTRANS_IDENTICAL;
4584 }
79072805
LW		 4585 for (i = 0; i < 256; i++)
4586 tbl[i] = -1;
eb160463
GS		 4587 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
4588 if (j >= (I32)rlen) {
a0ed51b3 4589 if (del) {
ec49126f 4590 if (tbl[t[i]] == -1)
4591 tbl[t[i]] = -2;
79072805
LW		 4592 continue;
4593 }
4594 --j;
4595 }
9b877dbb
IH		 4596 if (tbl[t[i]] == -1) {
4597 if (t[i] < 128 && r[j] >= 128)
4598 grows = 1;
ec49126f 4599 tbl[t[i]] = r[j];
9b877dbb 4600 }
79072805
LW		 4601 }
4602 }
b08e453b 4603
a2a5de95
NC		 4604 if(del && rlen == tlen) {
4605 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
b8c388a9 4606 } else if(rlen > tlen && !complement) {
a2a5de95 4607 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
b08e453b
RB		 4608 }
4609
9b877dbb
IH		 4610 if (grows)
4611 o->op_private |= OPpTRANS_GROWS;
eb8433b7
NC		 4612#ifdef PERL_MAD
4613 op_getmad(expr,o,'e');
4614 op_getmad(repl,o,'r');
4615#else
79072805
LW		 4616 op_free(expr);
4617 op_free(repl);
eb8433b7 4618#endif
79072805 4619
11343788 4620 return o;
79072805
LW		 4621}
4622
d67eb5f4
Z		 4623/*
4624=for apidoc Am|OP *|newPMOP|I32 type|I32 flags
4625
4626Constructs, checks, and returns an op of any pattern matching type.
4627I<type> is the opcode. I<flags> gives the eight bits of C<op_flags>
4628and, shifted up eight bits, the eight bits of C<op_private>.
4629
4630=cut
4631*/
4632
79072805 4633OP *
864dbfa3 4634Perl_newPMOP(pTHX_ I32 type, I32 flags)
79072805 4635{
27da23d5 4636 dVAR;
79072805
LW		 4637 PMOP *pmop;
4638
e69777c1
GG		 4639 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
4640
b7dc083c 4641 NewOp(1101, pmop, 1, PMOP);
eb160463 4642 pmop->op_type = (OPCODE)type;
22c35a8c 4643 pmop->op_ppaddr = PL_ppaddr[type];
eb160463
GS		 4644 pmop->op_flags = (U8)flags;
4645 pmop->op_private = (U8)(0 | (flags >> 8));
79072805 4646
3280af22 4647 if (PL_hints & HINT_RE_TAINT)
c737faaf 4648 pmop->op_pmflags |= PMf_RETAINT;
82ad65bb 4649 if (IN_LOCALE_COMPILETIME) {
a62b1201 4650 set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
9de15fec 4651 }
66cbab2c
KW		 4652 else if ((! (PL_hints & HINT_BYTES))
4653 /* Both UNI_8_BIT and locale :not_characters imply Unicode */
4654 && (PL_hints & (HINT_UNI_8_BIT|HINT_LOCALE_NOT_CHARS)))
4655 {
a62b1201 4656 set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
9de15fec 4657 }
1e215989 4658 if (PL_hints & HINT_RE_FLAGS) {
20439bc7
Z		 4659 SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4660 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
1e215989
FC		 4661 );
4662 if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
20439bc7 4663 reflags = Perl_refcounted_he_fetch_pvn(aTHX_
6320bfaf 4664 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
1e215989
FC		 4665 );
4666 if (reflags && SvOK(reflags)) {
dabded94 4667 set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
1e215989
FC		 4668 }
4669 }
c737faaf 4670
36477c24 4671
debc9467 4672#ifdef USE_ITHREADS
402d2eb1
NC		 4673 assert(SvPOK(PL_regex_pad[0]));
4674 if (SvCUR(PL_regex_pad[0])) {
4675 /* Pop off the "packed" IV from the end. */
4676 SV *const repointer_list = PL_regex_pad[0];
4677 const char *p = SvEND(repointer_list) - sizeof(IV);
4678 const IV offset = *((IV*)p);
4679
4680 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
4681
4682 SvEND_set(repointer_list, p);
4683
110f3028 4684 pmop->op_pmoffset = offset;
14a49a24
NC		 4685 /* This slot should be free, so assert this: */
4686 assert(PL_regex_pad[offset] == &PL_sv_undef);
551405c4 4687 } else {
14a49a24 4688 SV * const repointer = &PL_sv_undef;
9a8b6709 4689 av_push(PL_regex_padav, repointer);
551405c4
AL		 4690 pmop->op_pmoffset = av_len(PL_regex_padav);
4691 PL_regex_pad = AvARRAY(PL_regex_padav);
13137afc 4692 }
debc9467 4693#endif
1eb1540c 4694
463d09e6 4695 return CHECKOP(type, pmop);
79072805
LW		 4696}
4697
131b3ad0
DM		 4698/* Given some sort of match op o, and an expression expr containing a
4699 * pattern, either compile expr into a regex and attach it to o (if it's
4700 * constant), or convert expr into a runtime regcomp op sequence (if it's
4701 * not)
4702 *
4703 * isreg indicates that the pattern is part of a regex construct, eg
4704 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
4705 * split "pattern", which aren't. In the former case, expr will be a list
4706 * if the pattern contains more than one term (eg /a$b/) or if it contains
4707 * a replacement, ie s/// or tr///.
d63c20f2
DM		 4708 *
4709 * When the pattern has been compiled within a new anon CV (for
4710 * qr/(?{...})/ ), then floor indicates the savestack level just before
4711 * the new sub was created
131b3ad0
DM		 4712 */
4713
79072805 4714OP *
d63c20f2 4715Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor)
79072805 4716{
27da23d5 4717 dVAR;
79072805
LW		 4718 PMOP *pm;
4719 LOGOP *rcop;
ce862d02 4720 I32 repl_has_vars = 0;
5f66b61c 4721 OP* repl = NULL;
74529a43
DM		 4722 bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
4723 bool is_compiletime;
4724 bool has_code;
131b3ad0 4725
7918f24d
NC		 4726 PERL_ARGS_ASSERT_PMRUNTIME;
4727
74529a43
DM		 4728 /* for s/// and tr///, last element in list is the replacement; pop it */
4729
4730 if (is_trans || o->op_type == OP_SUBST) {
131b3ad0
DM		 4731 OP* kid;
4732 repl = cLISTOPx(expr)->op_last;
4733 kid = cLISTOPx(expr)->op_first;
4734 while (kid->op_sibling != repl)
4735 kid = kid->op_sibling;
5f66b61c 4736 kid->op_sibling = NULL;
131b3ad0
DM		 4737 cLISTOPx(expr)->op_last = kid;
4738 }
79072805 4739
74529a43
DM		 4740 /* for TRANS, convert LIST/PUSH/CONST into CONST, and pass to pmtrans() */
4741
4742 if (is_trans) {
4743 OP* const oe = expr;
4744 assert(expr->op_type == OP_LIST);
4745 assert(cLISTOPx(expr)->op_first->op_type == OP_PUSHMARK);
4746 assert(cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last);
4747 expr = cLISTOPx(oe)->op_last;
4748 cLISTOPx(oe)->op_first->op_sibling = NULL;
4749 cLISTOPx(oe)->op_last = NULL;
4750 op_free(oe);
4751
4752 return pmtrans(o, expr, repl);
4753 }
4754
8a45afe5
DM		 4755 /* find whether we have any runtime or code elements;
4756 * at the same time, temporarily set the op_next of each DO block;
4757 * then when we LINKLIST, this will cause the DO blocks to be excluded
4758 * from the op_next chain (and from having LINKLIST recursively
4759 * applied to them). We fix up the DOs specially later */
74529a43
DM		 4760
4761 is_compiletime = 1;
4762 has_code = 0;
4763 if (expr->op_type == OP_LIST) {
4764 OP *o;
4765 for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) {
8a45afe5 4766 if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
74529a43 4767 has_code = 1;
8a45afe5
DM		 4768 assert(!o->op_next && o->op_sibling);
4769 o->op_next = o->op_sibling;
4770 }
74529a43
DM		 4771 else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
4772 is_compiletime = 0;
4773 }
4774 }
68e2671b 4775 else if (expr->op_type != OP_CONST)
74529a43 4776 is_compiletime = 0;
74529a43 4777
8a45afe5
DM		 4778 LINKLIST(expr);
4779
491453ba
DM		 4780 /* fix up DO blocks; treat each one as a separate little sub;
4781 * also, mark any arrays as LIST/REF */
74529a43 4782
68e2671b 4783 if (expr->op_type == OP_LIST) {
8a45afe5
DM		 4784 OP *o;
4785 for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) {
491453ba
DM		 4786
4787 if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) {
4788 assert( !(o->op_flags & OPf_WANT));
4789 /* push the array rather than its contents. The regex
4790 * engine will retrieve and join the elements later */
4791 o->op_flags |= (OPf_WANT_LIST | OPf_REF);
4792 continue;
4793 }
4794
8a45afe5
DM		 4795 if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
4796 continue;
4797 o->op_next = NULL; /* undo temporary hack from above */
4798 scalar(o);
4799 LINKLIST(o);
4800 if (cLISTOPo->op_first->op_type == OP_LEAVE) {
106d2451 4801 LISTOP *leaveop = cLISTOPx(cLISTOPo->op_first);
8a45afe5 4802 /* skip ENTER */
106d2451
DM		 4803 assert(leaveop->op_first->op_type == OP_ENTER);
4804 assert(leaveop->op_first->op_sibling);
4805 o->op_next = leaveop->op_first->op_sibling;
4806 /* skip leave */
4807 assert(leaveop->op_flags & OPf_KIDS);
35431808 4808 assert(leaveop->op_last->op_next == (OP*)leaveop);
106d2451
DM		 4809 leaveop->op_next = NULL; /* stop on last op */
4810 op_null((OP*)leaveop);
9da1dd8f 4811 }
8a45afe5
DM		 4812 else {
4813 /* skip SCOPE */
4814 OP *scope = cLISTOPo->op_first;
4815 assert(scope->op_type == OP_SCOPE);
4816 assert(scope->op_flags & OPf_KIDS);
4817 scope->op_next = NULL; /* stop on last op */
4818 op_null(scope);
9da1dd8f 4819 }
8a45afe5
DM		 4820 /* have to peep the DOs individually as we've removed it from
4821 * the op_next chain */
4822 CALL_PEEP(o);
4823 if (is_compiletime)
4824 /* runtime finalizes as part of finalizing whole tree */
4825 finalize_optree(o);
9da1dd8f 4826 }
9da1dd8f 4827 }
491453ba
DM		 4828 else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
4829 assert( !(expr->op_flags & OPf_WANT));
4830 /* push the array rather than its contents. The regex
4831 * engine will retrieve and join the elements later */
4832 expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
4833 }
9da1dd8f 4834
3280af22 4835 PL_hints |= HINT_BLOCK_SCOPE;
11343788 4836 pm = (PMOP*)o;
d63c20f2 4837 assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
79072805 4838
74529a43 4839 if (is_compiletime) {
514a91f1 4840 U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
3c13cae6 4841 regexp_engine const *eng = current_re_engine();
5c144d81 4842
dbc200c5
YO		 4843 if (o->op_flags & OPf_SPECIAL)
4844 rx_flags |= RXf_SPLIT;
4845
3c13cae6 4846 if (!has_code || !eng->op_comp) {
d63c20f2 4847 /* compile-time simple constant pattern */
d63c20f2
DM		 4848
4849 if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
4850 /* whoops! we guessed that a qr// had a code block, but we
4851 * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
4852 * that isn't required now. Note that we have to be pretty
4853 * confident that nothing used that CV's pad while the
4854 * regex was parsed */
4855 assert(AvFILLp(PL_comppad) == 0); /* just @_ */
8be227ab
FC		 4856 /* But we know that one op is using this CV's slab. */
4857 cv_forget_slab(PL_compcv);
d63c20f2
DM		 4858 LEAVE_SCOPE(floor);
4859 pm->op_pmflags &= ~PMf_HAS_CV;
4860 }
4861
e485beb8
DM		 4862 PM_SETRE(pm,
4863 eng->op_comp
4864 ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
4865 rx_flags, pm->op_pmflags)
4866 : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
4867 rx_flags, pm->op_pmflags)
4868 );
eb8433b7 4869#ifdef PERL_MAD
68e2671b 4870 op_getmad(expr,(OP*)pm,'e');
eb8433b7 4871#else
68e2671b 4872 op_free(expr);
eb8433b7 4873#endif
68e2671b
DM		 4874 }
4875 else {
d63c20f2 4876 /* compile-time pattern that includes literal code blocks */
3c13cae6 4877 REGEXP* re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
732caac7
DM		 4878 rx_flags,
4879 (pm->op_pmflags |
4880 ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
4881 );
d63c20f2
DM		 4882 PM_SETRE(pm, re);
4883 if (pm->op_pmflags & PMf_HAS_CV) {
4884 CV *cv;
4885 /* this QR op (and the anon sub we embed it in) is never
4886 * actually executed. It's just a placeholder where we can
4887 * squirrel away expr in op_code_list without the peephole
4888 * optimiser etc processing it for a second time */
4889 OP *qr = newPMOP(OP_QR, 0);
4890 ((PMOP*)qr)->op_code_list = expr;
4891
4892 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
4893 SvREFCNT_inc_simple_void(PL_compcv);
4894 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
8d919b0a 4895 ReANY(re)->qr_anoncv = cv;
d63c20f2
DM		 4896
4897 /* attach the anon CV to the pad so that
4898 * pad_fixup_inner_anons() can find it */
4d2dfd15 4899 (void)pad_add_anon(cv, o->op_type);
d63c20f2
DM		 4900 SvREFCNT_inc_simple_void(cv);
4901 }
4902 else {
4903 pm->op_code_list = expr;
4904 }
68e2671b 4905 }
79072805
LW		 4906 }
4907 else {
d63c20f2 4908 /* runtime pattern: build chain of regcomp etc ops */
74529a43 4909 bool reglist;
346d3070 4910 PADOFFSET cv_targ = 0;
74529a43
DM		 4911
4912 reglist = isreg && expr->op_type == OP_LIST;
4913 if (reglist)
4914 op_null(expr);
4915
867940b8
DM		 4916 if (has_code) {
4917 pm->op_code_list = expr;
4918 /* don't free op_code_list; its ops are embedded elsewhere too */
4919 pm->op_pmflags |= PMf_CODELIST_PRIVATE;
4920 }
4921
dbc200c5
YO		 4922 if (o->op_flags & OPf_SPECIAL)
4923 pm->op_pmflags |= PMf_SPLIT;
4924
7fb31b92
DM		 4925 /* the OP_REGCMAYBE is a placeholder in the non-threaded case
4926 * to allow its op_next to be pointed past the regcomp and
4927 * preceding stacking ops;
4928 * OP_REGCRESET is there to reset taint before executing the
4929 * stacking ops */
284167a5
S		 4930 if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
4931 expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
463ee0b2 4932
d63c20f2
DM		 4933 if (pm->op_pmflags & PMf_HAS_CV) {
4934 /* we have a runtime qr with literal code. This means
4935 * that the qr// has been wrapped in a new CV, which
4936 * means that runtime consts, vars etc will have been compiled
4937 * against a new pad. So... we need to execute those ops
4938 * within the environment of the new CV. So wrap them in a call
4939 * to a new anon sub. i.e. for
4940 *
4941 * qr/a$b(?{...})/,
4942 *
4943 * we build an anon sub that looks like
4944 *
4945 * sub { "a", $b, '(?{...})' }
4946 *
4947 * and call it, passing the returned list to regcomp.
4948 * Or to put it another way, the list of ops that get executed
4949 * are:
4950 *
4951 * normal PMf_HAS_CV
4952 * ------ -------------------
4953 * pushmark (for regcomp)
4954 * pushmark (for entersub)
4955 * pushmark (for refgen)
4956 * anoncode
4957 * refgen
4958 * entersub
4959 * regcreset regcreset
4960 * pushmark pushmark
4961 * const("a") const("a")
4962 * gvsv(b) gvsv(b)
4963 * const("(?{...})") const("(?{...})")
4964 * leavesub
4965 * regcomp regcomp
4966 */
4967
4968 SvREFCNT_inc_simple_void(PL_compcv);
346d3070
DM		 4969 /* these lines are just an unrolled newANONATTRSUB */
4970 expr = newSVOP(OP_ANONCODE, 0,
4971 MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
4972 cv_targ = expr->op_targ;
4973 expr = newUNOP(OP_REFGEN, 0, expr);
4974
4975 expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr))));
d63c20f2
DM		 4976 }
4977
b7dc083c 4978 NewOp(1101, rcop, 1, LOGOP);
79072805 4979 rcop->op_type = OP_REGCOMP;
22c35a8c 4980 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
79072805 4981 rcop->op_first = scalar(expr);
131b3ad0
DM		 4982 rcop->op_flags |= OPf_KIDS
4983 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
4984 | (reglist ? OPf_STACKED : 0);
188c1910 4985 rcop->op_private = 0;
11343788 4986 rcop->op_other = o;
346d3070 4987 rcop->op_targ = cv_targ;
131b3ad0 4988
b5c19bd7 4989 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
ec192197 4990 if (PL_hints & HINT_RE_EVAL) PL_cv_has_eval = 1;
79072805
LW		 4991
4992 /* establish postfix order */
d63c20f2 4993 if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
463ee0b2
LW		 4994 LINKLIST(expr);
4995 rcop->op_next = expr;
4996 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
4997 }
4998 else {
4999 rcop->op_next = LINKLIST(expr);
5000 expr->op_next = (OP*)rcop;
5001 }
79072805 5002
2fcb4757 5003 op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
79072805
LW		 5004 }
5005
5006 if (repl) {
ef90d20a 5007 OP *curop = repl;
bb933b9b 5008 bool konst;
ef90d20a
FC		 5009 /* If we are looking at s//.../e with a single statement, get past
5010 the implicit do{}. */
5011 if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
5012 && cUNOPx(curop)->op_first->op_type == OP_SCOPE
5013 && cUNOPx(curop)->op_first->op_flags & OPf_KIDS) {
5014 OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
5015 if (kid->op_type == OP_NULL && kid->op_sibling
5016 && !kid->op_sibling->op_sibling)
5017 curop = kid->op_sibling;
5018 }
5019 if (curop->op_type == OP_CONST)
bb933b9b 5020 konst = TRUE;
ef90d20a
FC		 5021 else if (( (curop->op_type == OP_RV2SV ||
5022 curop->op_type == OP_RV2AV ||
5023 curop->op_type == OP_RV2HV ||
5024 curop->op_type == OP_RV2GV)
5025 && cUNOPx(curop)->op_first
5026 && cUNOPx(curop)->op_first->op_type == OP_GV )
5027 || curop->op_type == OP_PADSV
5028 || curop->op_type == OP_PADAV
5029 || curop->op_type == OP_PADHV
5030 || curop->op_type == OP_PADANY) {
bb933b9b
FC		 5031 repl_has_vars = 1;
5032 konst = TRUE;
748a9306 5033 }
bb933b9b
FC		 5034 else konst = FALSE;
5035 if (konst
e80b829c
RGS		 5036 && !(repl_has_vars
5037 && (!PM_GETRE(pm)
b97b7b69 5038 || !RX_PRELEN(PM_GETRE(pm))
07bc277f 5039 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
3be69782 5040 {
748a9306 5041 pm->op_pmflags |= PMf_CONST; /* const for long enough */
2fcb4757 5042 op_prepend_elem(o->op_type, scalar(repl), o);
748a9306
LW		 5043 }
5044 else {
b7dc083c 5045 NewOp(1101, rcop, 1, LOGOP);
748a9306 5046 rcop->op_type = OP_SUBSTCONT;
22c35a8c 5047 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
748a9306
LW		 5048 rcop->op_first = scalar(repl);
5049 rcop->op_flags |= OPf_KIDS;
5050 rcop->op_private = 1;
11343788 5051 rcop->op_other = o;
748a9306
LW		 5052
5053 /* establish postfix order */
5054 rcop->op_next = LINKLIST(repl);
5055 repl->op_next = (OP*)rcop;
5056
20e98b0f 5057 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
29f2e912
NC		 5058 assert(!(pm->op_pmflags & PMf_ONCE));
5059 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
748a9306 5060 rcop->op_next = 0;
79072805
LW		 5061 }
5062 }
5063
5064 return (OP*)pm;
5065}
5066
d67eb5f4
Z		 5067/*
5068=for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
5069
5070Constructs, checks, and returns an op of any type that involves an
5071embedded SV. I<type> is the opcode. I<flags> gives the eight bits
5072of C<op_flags>. I<sv> gives the SV to embed in the op; this function
5073takes ownership of one reference to it.
5074
5075=cut
5076*/
5077
79072805 5078OP *
864dbfa3 5079Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
79072805 5080{
27da23d5 5081 dVAR;
79072805 5082 SVOP *svop;
7918f24d
NC		 5083
5084 PERL_ARGS_ASSERT_NEWSVOP;
5085
e69777c1
GG		 5086 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
5087 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5088 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
5089
b7dc083c 5090 NewOp(1101, svop, 1, SVOP);
eb160463 5091 svop->op_type = (OPCODE)type;
22c35a8c 5092 svop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 5093 svop->op_sv = sv;
5094 svop->op_next = (OP*)svop;
eb160463 5095 svop->op_flags = (U8)flags;
cc2ebcd7 5096 svop->op_private = (U8)(0 | (flags >> 8));
22c35a8c 5097 if (PL_opargs[type] & OA_RETSCALAR)
463ee0b2 5098 scalar((OP*)svop);
22c35a8c 5099 if (PL_opargs[type] & OA_TARGET)
ed6116ce 5100 svop->op_targ = pad_alloc(type, SVs_PADTMP);
e50aee73 5101 return CHECKOP(type, svop);
79072805
LW		 5102}
5103
392d04bb 5104#ifdef USE_ITHREADS
d67eb5f4
Z		 5105
5106/*
5107=for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
5108
5109Constructs, checks, and returns an op of any type that involves a
5110reference to a pad element. I<type> is the opcode. I<flags> gives the
5111eight bits of C<op_flags>. A pad slot is automatically allocated, and
5112is populated with I<sv>; this function takes ownership of one reference
5113to it.
5114
5115This function only exists if Perl has been compiled to use ithreads.
5116
5117=cut
5118*/
5119
79072805 5120OP *
350de78d
GS		 5121Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
5122{
27da23d5 5123 dVAR;
350de78d 5124 PADOP *padop;
7918f24d
NC		 5125
5126 PERL_ARGS_ASSERT_NEWPADOP;
5127
e69777c1
GG		 5128 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
5129 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5130 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
5131
350de78d 5132 NewOp(1101, padop, 1, PADOP);
eb160463 5133 padop->op_type = (OPCODE)type;
350de78d
GS		 5134 padop->op_ppaddr = PL_ppaddr[type];
5135 padop->op_padix = pad_alloc(type, SVs_PADTMP);
dd2155a4
DM		 5136 SvREFCNT_dec(PAD_SVl(padop->op_padix));
5137 PAD_SETSV(padop->op_padix, sv);
58182927
NC		 5138 assert(sv);
5139 SvPADTMP_on(sv);
350de78d 5140 padop->op_next = (OP*)padop;
eb160463 5141 padop->op_flags = (U8)flags;
350de78d
GS		 5142 if (PL_opargs[type] & OA_RETSCALAR)
5143 scalar((OP*)padop);
5144 if (PL_opargs[type] & OA_TARGET)
5145 padop->op_targ = pad_alloc(type, SVs_PADTMP);
5146 return CHECKOP(type, padop);
5147}
d67eb5f4 5148
a9fc22f0 5149#endif /* USE_ITHREADS */
d67eb5f4
Z		 5150
5151/*
5152=for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
5153
5154Constructs, checks, and returns an op of any type that involves an
5155embedded reference to a GV. I<type> is the opcode. I<flags> gives the
5156eight bits of C<op_flags>. I<gv> identifies the GV that the op should
5157reference; calling this function does not transfer ownership of any
5158reference to it.
5159
5160=cut
5161*/
350de78d
GS		 5162
5163OP *
864dbfa3 5164Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
79072805 5165{
27da23d5 5166 dVAR;
7918f24d
NC		 5167
5168 PERL_ARGS_ASSERT_NEWGVOP;
5169
350de78d 5170#ifdef USE_ITHREADS
58182927 5171 GvIN_PAD_on(gv);
ff8997d7 5172 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
350de78d 5173#else
ff8997d7 5174 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
350de78d 5175#endif
79072805
LW		 5176}
5177
d67eb5f4
Z		 5178/*
5179=for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
5180
5181Constructs, checks, and returns an op of any type that involves an
5182embedded C-level pointer (PV). I<type> is the opcode. I<flags> gives
5183the eight bits of C<op_flags>. I<pv> supplies the C-level pointer, which
3d6c5fec 5184must have been allocated using C<PerlMemShared_malloc>; the memory will
d67eb5f4
Z		 5185be freed when the op is destroyed.
5186
5187=cut
5188*/
5189
79072805 5190OP *
864dbfa3 5191Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
79072805 5192{
27da23d5 5193 dVAR;
5db1eb8d 5194 const bool utf8 = cBOOL(flags & SVf_UTF8);
79072805 5195 PVOP *pvop;
e69777c1 5196
5db1eb8d
BF		 5197 flags &= ~SVf_UTF8;
5198
e69777c1 5199 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
1a35f9ff 5200 || type == OP_RUNCV
e69777c1
GG		 5201 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
5202
b7dc083c 5203 NewOp(1101, pvop, 1, PVOP);
eb160463 5204 pvop->op_type = (OPCODE)type;
22c35a8c 5205 pvop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 5206 pvop->op_pv = pv;
5207 pvop->op_next = (OP*)pvop;
eb160463 5208 pvop->op_flags = (U8)flags;
5db1eb8d 5209 pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
22c35a8c 5210 if (PL_opargs[type] & OA_RETSCALAR)
463ee0b2 5211 scalar((OP*)pvop);
22c35a8c 5212 if (PL_opargs[type] & OA_TARGET)
ed6116ce 5213 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
e50aee73 5214 return CHECKOP(type, pvop);
79072805
LW		 5215}
5216
eb8433b7
NC		 5217#ifdef PERL_MAD
5218OP*
5219#else
79072805 5220void
eb8433b7 5221#endif
864dbfa3 5222Perl_package(pTHX_ OP *o)
79072805 5223{
97aff369 5224 dVAR;
bf070237 5225 SV *const sv = cSVOPo->op_sv;
eb8433b7
NC		 5226#ifdef PERL_MAD
5227 OP *pegop;
5228#endif
79072805 5229
7918f24d
NC		 5230 PERL_ARGS_ASSERT_PACKAGE;
5231
03d9f026 5232 SAVEGENERICSV(PL_curstash);
3280af22 5233 save_item(PL_curstname);
de11ba31 5234
03d9f026 5235 PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
e1a479c5 5236
bf070237 5237 sv_setsv(PL_curstname, sv);
de11ba31 5238
7ad382f4 5239 PL_hints |= HINT_BLOCK_SCOPE;
53a7735b
DM		 5240 PL_parser->copline = NOLINE;
5241 PL_parser->expect = XSTATE;
eb8433b7
NC		 5242
5243#ifndef PERL_MAD
5244 op_free(o);
5245#else
5246 if (!PL_madskills) {
5247 op_free(o);
1d866c12 5248 return NULL;
eb8433b7
NC		 5249 }
5250
5251 pegop = newOP(OP_NULL,0);
5252 op_getmad(o,pegop,'P');
5253 return pegop;
5254#endif
79072805
LW		 5255}
5256
6fa4d285
DG		 5257void
5258Perl_package_version( pTHX_ OP *v )
5259{
5260 dVAR;
458818ec 5261 U32 savehints = PL_hints;
6fa4d285 5262 PERL_ARGS_ASSERT_PACKAGE_VERSION;
458818ec 5263 PL_hints &= ~HINT_STRICT_VARS;
e92f586b 5264 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
458818ec 5265 PL_hints = savehints;
6fa4d285
DG		 5266 op_free(v);
5267}
5268
eb8433b7
NC		 5269#ifdef PERL_MAD
5270OP*
5271#else
85e6fe83 5272void
eb8433b7 5273#endif
88d95a4d 5274Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
85e6fe83 5275{
97aff369 5276 dVAR;
a0d0e21e 5277 OP *pack;
a0d0e21e 5278 OP *imop;
b1cb66bf 5279 OP *veop;
eb8433b7 5280#ifdef PERL_MAD
d8842ae9 5281 OP *pegop = PL_madskills ? newOP(OP_NULL,0) : NULL;
eb8433b7 5282#endif
88e9444c 5283 SV *use_version = NULL;
85e6fe83 5284
7918f24d
NC		 5285 PERL_ARGS_ASSERT_UTILIZE;
5286
88d95a4d 5287 if (idop->op_type != OP_CONST)
cea2e8a9 5288 Perl_croak(aTHX_ "Module name must be constant");
85e6fe83 5289
eb8433b7
NC		 5290 if (PL_madskills)
5291 op_getmad(idop,pegop,'U');
5292
5f66b61c 5293 veop = NULL;
b1cb66bf 5294
aec46f14 5295 if (version) {
551405c4 5296 SV * const vesv = ((SVOP*)version)->op_sv;
b1cb66bf 5297
eb8433b7
NC		 5298 if (PL_madskills)
5299 op_getmad(version,pegop,'V');
aec46f14 5300 if (!arg && !SvNIOKp(vesv)) {
b1cb66bf 5301 arg = version;
5302 }
5303 else {
5304 OP *pack;
0f79a09d 5305 SV *meth;
b1cb66bf 5306
44dcb63b 5307 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
fe13d51d 5308 Perl_croak(aTHX_ "Version number must be a constant number");
b1cb66bf 5309
88d95a4d
JH		 5310 /* Make copy of idop so we don't free it twice */
5311 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
b1cb66bf 5312
5313 /* Fake up a method call to VERSION */
18916d0d 5314 meth = newSVpvs_share("VERSION");
b1cb66bf 5315 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2fcb4757
Z		 5316 op_append_elem(OP_LIST,
5317 op_prepend_elem(OP_LIST, pack, list(version)),
0f79a09d 5318 newSVOP(OP_METHOD_NAMED, 0, meth)));
b1cb66bf 5319 }
5320 }
aeea060c 5321
a0d0e21e 5322 /* Fake up an import/unimport */
eb8433b7
NC		 5323 if (arg && arg->op_type == OP_STUB) {
5324 if (PL_madskills)
5325 op_getmad(arg,pegop,'S');
4633a7c4 5326 imop = arg; /* no import on explicit () */
eb8433b7 5327 }
88d95a4d 5328 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
5f66b61c 5329 imop = NULL; /* use 5.0; */
88e9444c
NC		 5330 if (aver)
5331 use_version = ((SVOP*)idop)->op_sv;
5332 else
468aa647 5333 idop->op_private |= OPpCONST_NOVER;
b1cb66bf 5334 }
4633a7c4 5335 else {
0f79a09d
GS		 5336 SV *meth;
5337
eb8433b7
NC		 5338 if (PL_madskills)
5339 op_getmad(arg,pegop,'A');
5340
88d95a4d
JH		 5341 /* Make copy of idop so we don't free it twice */
5342 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
0f79a09d
GS		 5343
5344 /* Fake up a method call to import/unimport */
427d62a4 5345 meth = aver
18916d0d 5346 ? newSVpvs_share("import") : newSVpvs_share("unimport");
4633a7c4 5347 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2fcb4757
Z		 5348 op_append_elem(OP_LIST,
5349 op_prepend_elem(OP_LIST, pack, list(arg)),
0f79a09d 5350 newSVOP(OP_METHOD_NAMED, 0, meth)));
4633a7c4
LW		 5351 }
5352
a0d0e21e 5353 /* Fake up the BEGIN {}, which does its thing immediately. */
09bef843 5354 newATTRSUB(floor,
18916d0d 5355 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
5f66b61c
AL		 5356 NULL,
5357 NULL,
2fcb4757
Z		 5358 op_append_elem(OP_LINESEQ,
5359 op_append_elem(OP_LINESEQ,
bd61b366
SS		 5360 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
5361 newSTATEOP(0, NULL, veop)),
5362 newSTATEOP(0, NULL, imop) ));
85e6fe83 5363
88e9444c 5364 if (use_version) {
6634bb9d 5365 /* Enable the
88e9444c
NC		 5366 * feature bundle that corresponds to the required version. */
5367 use_version = sv_2mortal(new_version(use_version));
6634bb9d 5368 S_enable_feature_bundle(aTHX_ use_version);
88e9444c 5369
88e9444c
NC		 5370 /* If a version >= 5.11.0 is requested, strictures are on by default! */
5371 if (vcmp(use_version,
5372 sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
d1718a7c 5373 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
b50b2058 5374 PL_hints |= HINT_STRICT_REFS;
d1718a7c 5375 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
b50b2058 5376 PL_hints |= HINT_STRICT_SUBS;
d1718a7c 5377 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
b50b2058
FC		 5378 PL_hints |= HINT_STRICT_VARS;
5379 }
5380 /* otherwise they are off */
5381 else {
d1718a7c 5382 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
b50b2058 5383 PL_hints &= ~HINT_STRICT_REFS;
d1718a7c 5384 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
b50b2058 5385 PL_hints &= ~HINT_STRICT_SUBS;
d1718a7c 5386 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
b50b2058 5387 PL_hints &= ~HINT_STRICT_VARS;
88e9444c
NC		 5388 }
5389 }
5390
70f5e4ed
JH		 5391 /* The "did you use incorrect case?" warning used to be here.
5392 * The problem is that on case-insensitive filesystems one
5393 * might get false positives for "use" (and "require"):
5394 * "use Strict" or "require CARP" will work. This causes
5395 * portability problems for the script: in case-strict
5396 * filesystems the script will stop working.
5397 *
5398 * The "incorrect case" warning checked whether "use Foo"
5399 * imported "Foo" to your namespace, but that is wrong, too:
5400 * there is no requirement nor promise in the language that
5401 * a Foo.pm should or would contain anything in package "Foo".
5402 *
5403 * There is very little Configure-wise that can be done, either:
5404 * the case-sensitivity of the build filesystem of Perl does not
5405 * help in guessing the case-sensitivity of the runtime environment.
5406 */
18fc9488 5407
c305c6a0 5408 PL_hints |= HINT_BLOCK_SCOPE;
53a7735b
DM		 5409 PL_parser->copline = NOLINE;
5410 PL_parser->expect = XSTATE;
8ec8fbef 5411 PL_cop_seqmax++; /* Purely for B::*'s benefit */
6012dc80
DM		 5412 if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
5413 PL_cop_seqmax++;
eb8433b7
NC		 5414
5415#ifdef PERL_MAD
eb8433b7
NC		 5416 return pegop;
5417#endif
85e6fe83
LW		 5418}
5419
7d3fb230 5420/*
ccfc67b7
JH		 5421=head1 Embedding Functions
5422
7d3fb230
BS		 5423=for apidoc load_module
5424
5425Loads the module whose name is pointed to by the string part of name.
5426Note that the actual module name, not its filename, should be given.
5427Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
5428PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
d9f23c72 5429(or 0 for no flags). ver, if specified and not NULL, provides version semantics
7d3fb230
BS		 5430similar to C<use Foo::Bar VERSION>. The optional trailing SV*
5431arguments can be used to specify arguments to the module's import()
76f108ac
JD		 5432method, similar to C<use Foo::Bar VERSION LIST>. They must be
5433terminated with a final NULL pointer. Note that this list can only
5434be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
5435Otherwise at least a single NULL pointer to designate the default
5436import list is required.
7d3fb230 5437
d9f23c72
KW		 5438The reference count for each specified C<SV*> parameter is decremented.
5439
7d3fb230
BS		 5440=cut */
5441
e4783991
GS		 5442void
5443Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
5444{
5445 va_list args;
7918f24d
NC		 5446
5447 PERL_ARGS_ASSERT_LOAD_MODULE;
5448
e4783991
GS		 5449 va_start(args, ver);
5450 vload_module(flags, name, ver, &args);
5451 va_end(args);
5452}
5453
5454#ifdef PERL_IMPLICIT_CONTEXT
5455void
5456Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
5457{
5458 dTHX;
5459 va_list args;
7918f24d 5460 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
e4783991
GS		 5461 va_start(args, ver);
5462 vload_module(flags, name, ver, &args);
5463 va_end(args);
5464}
5465#endif
5466
5467void
5468Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
5469{
97aff369 5470 dVAR;
551405c4 5471 OP *veop, *imop;
551405c4 5472 OP * const modname = newSVOP(OP_CONST, 0, name);
7918f24d
NC		 5473
5474 PERL_ARGS_ASSERT_VLOAD_MODULE;
5475
e4783991
GS		 5476 modname->op_private |= OPpCONST_BARE;
5477 if (ver) {
5478 veop = newSVOP(OP_CONST, 0, ver);
5479 }
5480 else
5f66b61c 5481 veop = NULL;
e4783991
GS		 5482 if (flags & PERL_LOADMOD_NOIMPORT) {
5483 imop = sawparens(newNULLLIST());
5484 }
5485 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
5486 imop = va_arg(*args, OP*);
5487 }
5488 else {
5489 SV *sv;
5f66b61c 5490 imop = NULL;
e4783991
GS		 5491 sv = va_arg(*args, SV*);
5492 while (sv) {
2fcb4757 5493 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
e4783991
GS		 5494 sv = va_arg(*args, SV*);
5495 }
5496 }
81885997 5497
53a7735b
DM		 5498 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
5499 * that it has a PL_parser to play with while doing that, and also
5500 * that it doesn't mess with any existing parser, by creating a tmp
5501 * new parser with lex_start(). This won't actually be used for much,
5502 * since pp_require() will create another parser for the real work. */
5503
5504 ENTER;
5505 SAVEVPTR(PL_curcop);
27fcb6ee 5506 lex_start(NULL, NULL, LEX_START_SAME_FILTER);
53a7735b
DM		 5507 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
5508 veop, modname, imop);
5509 LEAVE;
e4783991
GS		 5510}
5511
aff26e98
FC		 5512PERL_STATIC_INLINE OP *
5513S_new_entersubop(pTHX_ GV *gv, OP *arg)
5514{
5515 return newUNOP(OP_ENTERSUB, OPf_STACKED,
5516 newLISTOP(OP_LIST, 0, arg,
5517 newUNOP(OP_RV2CV, 0,
5518 newGVOP(OP_GV, 0, gv))));
5519}
5520
79072805 5521OP *
850e8516 5522Perl_dofile(pTHX_ OP *term, I32 force_builtin)
78ca652e 5523{
97aff369 5524 dVAR;
78ca652e 5525 OP *doop;
c62c138b 5526 GV *gv;
78ca652e 5527
7918f24d
NC		 5528 PERL_ARGS_ASSERT_DOFILE;
5529
9e3fb20c 5530 if (!force_builtin && (gv = gv_override("do", 2))) {
aff26e98 5531 doop = S_new_entersubop(aTHX_ gv, term);
78ca652e
GS		 5532 }
5533 else {
5534 doop = newUNOP(OP_DOFILE, 0, scalar(term));
5535 }
5536 return doop;
5537}
5538
d67eb5f4
Z		 5539/*
5540=head1 Optree construction
5541
5542=for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
5543
5544Constructs, checks, and returns an C<lslice> (list slice) op. I<flags>
5545gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
5546be set automatically, and, shifted up eight bits, the eight bits of
5547C<op_private>, except that the bit with value 1 or 2 is automatically
5548set as required. I<listval> and I<subscript> supply the parameters of
5549the slice; they are consumed by this function and become part of the
5550constructed op tree.
5551
5552=cut
5553*/
5554
78ca652e 5555OP *
864dbfa3 5556Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
79072805
LW		 5557{
5558 return newBINOP(OP_LSLICE, flags,
8990e307
LW		 5559 list(force_list(subscript)),
5560 list(force_list(listval)) );
79072805
LW		 5561}
5562
76e3520e 5563STATIC I32
5aaab254 5564S_is_list_assignment(pTHX_ const OP *o)
79072805 5565{
1496a290
AL		 5566 unsigned type;
5567 U8 flags;
5568
11343788 5569 if (!o)
79072805
LW		 5570 return TRUE;
5571
1496a290 5572 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
11343788 5573 o = cUNOPo->op_first;
79072805 5574
1496a290
AL		 5575 flags = o->op_flags;
5576 type = o->op_type;
5577 if (type == OP_COND_EXPR) {
504618e9
AL		 5578 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
5579 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
79072805
LW		 5580
5581 if (t && f)
5582 return TRUE;
5583 if (t || f)
5584 yyerror("Assignment to both a list and a scalar");
5585 return FALSE;
5586 }
5587
1496a290
AL		 5588 if (type == OP_LIST &&
5589 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
95f0a2f1
SB		 5590 o->op_private & OPpLVAL_INTRO)
5591 return FALSE;
5592
1496a290
AL		 5593 if (type == OP_LIST || flags & OPf_PARENS ||
5594 type == OP_RV2AV || type == OP_RV2HV ||
6dd3e0f2
RZ		 5595 type == OP_ASLICE || type == OP_HSLICE ||
5596 type == OP_KVASLICE || type == OP_KVHSLICE)
79072805
LW		 5597 return TRUE;
5598
1496a290 5599 if (type == OP_PADAV || type == OP_PADHV)
93a17b20
LW		 5600 return TRUE;
5601
1496a290 5602 if (type == OP_RV2SV)
79072805
LW		 5603 return FALSE;
5604
5605 return FALSE;
5606}
5607
d67eb5f4 5608/*
83f9fced
GG		 5609 Helper function for newASSIGNOP to detection commonality between the
5610 lhs and the rhs. Marks all variables with PL_generation. If it
5611 returns TRUE the assignment must be able to handle common variables.
5612*/
5613PERL_STATIC_INLINE bool
5614S_aassign_common_vars(pTHX_ OP* o)
5615{
83f9fced 5616 OP *curop;
3023b5f3 5617 for (curop = cUNOPo->op_first; curop; curop=curop->op_sibling) {
83f9fced
GG		 5618 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
5619 if (curop->op_type == OP_GV) {
5620 GV *gv = cGVOPx_gv(curop);
5621 if (gv == PL_defgv
5622 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
5623 return TRUE;
5624 GvASSIGN_GENERATION_set(gv, PL_generation);
5625 }
5626 else if (curop->op_type == OP_PADSV ||
5627 curop->op_type == OP_PADAV ||
5628 curop->op_type == OP_PADHV ||
5629 curop->op_type == OP_PADANY)
5630 {
5631 if (PAD_COMPNAME_GEN(curop->op_targ)
5632 == (STRLEN)PL_generation)
5633 return TRUE;
5634 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
5635
5636 }
5637 else if (curop->op_type == OP_RV2CV)
5638 return TRUE;
5639 else if (curop->op_type == OP_RV2SV ||
5640 curop->op_type == OP_RV2AV ||
5641 curop->op_type == OP_RV2HV ||
5642 curop->op_type == OP_RV2GV) {
3023b5f3 5643 if (cUNOPx(curop)->op_first->op_type != OP_GV) /* funny deref? */
83f9fced
GG		 5644 return TRUE;
5645 }
5646 else if (curop->op_type == OP_PUSHRE) {
18c95846 5647 GV *const gv =
83f9fced 5648#ifdef USE_ITHREADS
18c95846
FC		 5649 ((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff
5650 ? MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff))
5651 : NULL;
83f9fced 5652#else
18c95846
FC		 5653 ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
5654#endif
83f9fced
GG		 5655 if (gv) {
5656 if (gv == PL_defgv
5657 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
5658 return TRUE;
5659 GvASSIGN_GENERATION_set(gv, PL_generation);
5660 }
83f9fced
GG		 5661 }
5662 else
5663 return TRUE;
5664 }
3023b5f3
GG		 5665
5666 if (curop->op_flags & OPf_KIDS) {
5667 if (aassign_common_vars(curop))
5668 return TRUE;
5669 }
83f9fced
GG		 5670 }
5671 return FALSE;
5672}
5673
5674/*
d67eb5f4
Z		 5675=for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
5676
5677Constructs, checks, and returns an assignment op. I<left> and I<right>
5678supply the parameters of the assignment; they are consumed by this
5679function and become part of the constructed op tree.
5680
5681If I<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
5682a suitable conditional optree is constructed. If I<optype> is the opcode
5683of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
5684performs the binary operation and assigns the result to the left argument.
5685Either way, if I<optype> is non-zero then I<flags> has no effect.
5686
5687If I<optype> is zero, then a plain scalar or list assignment is
5688constructed. Which type of assignment it is is automatically determined.
5689I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
5690will be set automatically, and, shifted up eight bits, the eight bits
5691of C<op_private>, except that the bit with value 1 or 2 is automatically
5692set as required.
5693
5694=cut
5695*/
5696
79072805 5697OP *
864dbfa3 5698Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
79072805 5699{
97aff369 5700 dVAR;
11343788 5701 OP *o;
79072805 5702
a0d0e21e 5703 if (optype) {
c963b151 5704 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
a0d0e21e 5705 return newLOGOP(optype, 0,
3ad73efd 5706 op_lvalue(scalar(left), optype),
a0d0e21e
LW		 5707 newUNOP(OP_SASSIGN, 0, scalar(right)));
5708 }
5709 else {
5710 return newBINOP(optype, OPf_STACKED,
3ad73efd 5711 op_lvalue(scalar(left), optype), scalar(right));
a0d0e21e
LW		 5712 }
5713 }
5714
504618e9 5715 if (is_list_assignment(left)) {
6dbe9451
NC		 5716 static const char no_list_state[] = "Initialization of state variables"
5717 " in list context currently forbidden";
10c8fecd 5718 OP *curop;
fafafbaf 5719 bool maybe_common_vars = TRUE;
10c8fecd 5720
429a2555
FC		 5721 if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
5722 left->op_private &= ~ OPpSLICEWARNING;
5723
3280af22 5724 PL_modcount = 0;
3ad73efd 5725 left = op_lvalue(left, OP_AASSIGN);
10c8fecd
GS		 5726 curop = list(force_list(left));
5727 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
eb160463 5728 o->op_private = (U8)(0 | (flags >> 8));
dd2155a4 5729
fafafbaf
RD		 5730 if ((left->op_type == OP_LIST
5731 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
5732 {
5733 OP* lop = ((LISTOP*)left)->op_first;
5734 maybe_common_vars = FALSE;
5735 while (lop) {
5736 if (lop->op_type == OP_PADSV ||
5737 lop->op_type == OP_PADAV ||
5738 lop->op_type == OP_PADHV ||
5739 lop->op_type == OP_PADANY) {
5740 if (!(lop->op_private & OPpLVAL_INTRO))
5741 maybe_common_vars = TRUE;
5742
5743 if (lop->op_private & OPpPAD_STATE) {
5744 if (left->op_private & OPpLVAL_INTRO) {
5745 /* Each variable in state($a, $b, $c) = ... */
5746 }
5747 else {
5748 /* Each state variable in
5749 (state $a, my $b, our $c, $d, undef) = ... */
5750 }
5751 yyerror(no_list_state);
5752 } else {
5753 /* Each my variable in
5754 (state $a, my $b, our $c, $d, undef) = ... */
5755 }
5756 } else if (lop->op_type == OP_UNDEF ||
5757 lop->op_type == OP_PUSHMARK) {
5758 /* undef may be interesting in
5759 (state $a, undef, state $c) */
5760 } else {
5761 /* Other ops in the list. */
5762 maybe_common_vars = TRUE;
5763 }
5764 lop = lop->op_sibling;
5765 }
5766 }
5767 else if ((left->op_private & OPpLVAL_INTRO)
5768 && ( left->op_type == OP_PADSV
5769 || left->op_type == OP_PADAV
5770 || left->op_type == OP_PADHV
5771 || left->op_type == OP_PADANY))
5772 {
0f907b96 5773 if (left->op_type == OP_PADSV) maybe_common_vars = FALSE;
fafafbaf
RD		 5774 if (left->op_private & OPpPAD_STATE) {
5775 /* All single variable list context state assignments, hence
5776 state ($a) = ...
5777 (state $a) = ...
5778 state @a = ...
5779 state (@a) = ...
5780 (state @a) = ...
5781 state %a = ...
5782 state (%a) = ...
5783 (state %a) = ...
5784 */
5785 yyerror(no_list_state);
5786 }
5787 }
5788
dd2155a4
DM		 5789 /* PL_generation sorcery:
5790 * an assignment like ($a,$b) = ($c,$d) is easier than
5791 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
5792 * To detect whether there are common vars, the global var
5793 * PL_generation is incremented for each assign op we compile.
5794 * Then, while compiling the assign op, we run through all the
5795 * variables on both sides of the assignment, setting a spare slot
5796 * in each of them to PL_generation. If any of them already have
5797 * that value, we know we've got commonality. We could use a
5798 * single bit marker, but then we'd have to make 2 passes, first
5799 * to clear the flag, then to test and set it. To find somewhere
931b58fb 5800 * to store these values, evil chicanery is done with SvUVX().
dd2155a4
DM		 5801 */
5802
fafafbaf 5803 if (maybe_common_vars) {
3280af22 5804 PL_generation++;
83f9fced 5805 if (aassign_common_vars(o))
10c8fecd 5806 o->op_private |= OPpASSIGN_COMMON;
3023b5f3 5807 LINKLIST(o);
461824dc 5808 }
9fdc7570 5809
e9cc17ba 5810 if (right && right->op_type == OP_SPLIT && !PL_madskills) {
1496a290
AL		 5811 OP* tmpop = ((LISTOP*)right)->op_first;
5812 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
551405c4 5813 PMOP * const pm = (PMOP*)tmpop;
c07a80fd 5814 if (left->op_type == OP_RV2AV &&
5815 !(left->op_private & OPpLVAL_INTRO) &&
11343788 5816 !(o->op_private & OPpASSIGN_COMMON) )
c07a80fd 5817 {
5818 tmpop = ((UNOP*)left)->op_first;
20e98b0f
NC		 5819 if (tmpop->op_type == OP_GV
5820#ifdef USE_ITHREADS
5821 && !pm->op_pmreplrootu.op_pmtargetoff
5822#else
5823 && !pm->op_pmreplrootu.op_pmtargetgv
5824#endif
5825 ) {
971a9dd3 5826#ifdef USE_ITHREADS
20e98b0f
NC		 5827 pm->op_pmreplrootu.op_pmtargetoff
5828 = cPADOPx(tmpop)->op_padix;
971a9dd3
GS		 5829 cPADOPx(tmpop)->op_padix = 0; /* steal it */
5830#else
20e98b0f 5831 pm->op_pmreplrootu.op_pmtargetgv
159b6efe 5832 = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
a0714e2c 5833 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
971a9dd3 5834#endif
11343788 5835 tmpop = cUNOPo->op_first; /* to list (nulled) */
c07a80fd 5836 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
5f66b61c 5837 tmpop->op_sibling = NULL; /* don't free split */
c07a80fd 5838 right->op_next = tmpop->op_next; /* fix starting loc */
11343788 5839 op_free(o); /* blow off assign */
54310121 5840 right->op_flags &= ~OPf_WANT;
a5f75d66 5841 /* "I don't know and I don't care." */
c07a80fd 5842 return right;
5843 }
5844 }
5845 else {
e6438c1a 5846 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
c07a80fd 5847 ((LISTOP*)right)->op_last->op_type == OP_CONST)
5848 {
60041a09
FC		 5849 SV ** const svp =
5850 &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
5851 SV * const sv = *svp;
b8de32d5 5852 if (SvIOK(sv) && SvIVX(sv) == 0)
60041a09
FC		 5853 {
5854 if (right->op_private & OPpSPLIT_IMPLIM) {
5855 /* our own SV, created in ck_split */
5856 SvREADONLY_off(sv);
3280af22 5857 sv_setiv(sv, PL_modcount+1);
60041a09
FC		 5858 }
5859 else {
5860 /* SV may belong to someone else */
5861 SvREFCNT_dec(sv);
5862 *svp = newSViv(PL_modcount+1);
5863 }
5864 }
c07a80fd 5865 }
5866 }
5867 }
5868 }
11343788 5869 return o;
79072805
LW		 5870 }
5871 if (!right)
5872 right = newOP(OP_UNDEF, 0);
5873 if (right->op_type == OP_READLINE) {
5874 right->op_flags |= OPf_STACKED;
3ad73efd
Z		 5875 return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
5876 scalar(right));
79072805 5877 }
a0d0e21e 5878 else {
11343788 5879 o = newBINOP(OP_SASSIGN, flags,
3ad73efd 5880 scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
a0d0e21e 5881 }
11343788 5882 return o;
79072805
LW		 5883}
5884
d67eb5f4
Z		 5885/*
5886=for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
5887
5888Constructs a state op (COP). The state op is normally a C<nextstate> op,
5889but will be a C<dbstate> op if debugging is enabled for currently-compiled
3d6c5fec 5890code. The state op is populated from C<PL_curcop> (or C<PL_compiling>).
d67eb5f4
Z		 5891If I<label> is non-null, it supplies the name of a label to attach to
5892the state op; this function takes ownership of the memory pointed at by
5893I<label>, and will free it. I<flags> gives the eight bits of C<op_flags>
5894for the state op.
5895
5896If I<o> is null, the state op is returned. Otherwise the state op is
5897combined with I<o> into a C<lineseq> list op, which is returned. I<o>
5898is consumed by this function and becomes part of the returned op tree.
5899
5900=cut
5901*/
5902
79072805 5903OP *
864dbfa3 5904Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
79072805 5905{
27da23d5 5906 dVAR;
e1ec3a88 5907 const U32 seq = intro_my();
5db1eb8d 5908 const U32 utf8 = flags & SVf_UTF8;
eb578fdb 5909 COP *cop;
79072805 5910
5db1eb8d
BF		 5911 flags &= ~SVf_UTF8;
5912
b7dc083c 5913 NewOp(1101, cop, 1, COP);
57843af0 5914 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
8990e307 5915 cop->op_type = OP_DBSTATE;
22c35a8c 5916 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
8990e307
LW		 5917 }
5918 else {
5919 cop->op_type = OP_NEXTSTATE;
22c35a8c 5920 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
8990e307 5921 }
eb160463 5922 cop->op_flags = (U8)flags;
623e6609 5923 CopHINTS_set(cop, PL_hints);
ff0cee69 5924#ifdef NATIVE_HINTS
5925 cop->op_private |= NATIVE_HINTS;
5926#endif
97124ef6
FC		 5927#ifdef VMS
5928 if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
5929#endif
79072805
LW		 5930 cop->op_next = (OP*)cop;
5931
bbce6d69 5932 cop->cop_seq = seq;
72dc9ed5 5933 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
20439bc7 5934 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
dca6062a 5935 if (label) {
5db1eb8d
BF		 5936 Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
5937
dca6062a
NC		 5938 PL_hints |= HINT_BLOCK_SCOPE;
5939 /* It seems that we need to defer freeing this pointer, as other parts
5940 of the grammar end up wanting to copy it after this op has been
5941 created. */
5942 SAVEFREEPV(label);
dca6062a 5943 }
79072805 5944
7f1c3e8c
FC		 5945 if (PL_parser->preambling != NOLINE) {
5946 CopLINE_set(cop, PL_parser->preambling);
5947 PL_parser->copline = NOLINE;
5948 }
5949 else if (PL_parser->copline == NOLINE)
57843af0 5950 CopLINE_set(cop, CopLINE(PL_curcop));
79072805 5951 else {
53a7735b 5952 CopLINE_set(cop, PL_parser->copline);
4b1709c8 5953 PL_parser->copline = NOLINE;
79072805 5954 }
57843af0 5955#ifdef USE_ITHREADS
1dc74fdb 5956 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
57843af0 5957#else
f4dd75d9 5958 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
57843af0 5959#endif
11faa288 5960 CopSTASH_set(cop, PL_curstash);
79072805 5961
5a72d597 5962 if (cop->op_type == OP_DBSTATE) {
65269a95 5963 /* this line can have a breakpoint - store the cop in IV */
80a702cd
RGS		 5964 AV *av = CopFILEAVx(PL_curcop);
5965 if (av) {
c70927a6 5966 SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
80a702cd
RGS		 5967 if (svp && *svp != &PL_sv_undef ) {
5968 (void)SvIOK_on(*svp);
5969 SvIV_set(*svp, PTR2IV(cop));
5970 }
1eb1540c 5971 }
93a17b20
LW		 5972 }
5973
f6f3a1fe
RGS		 5974 if (flags & OPf_SPECIAL)
5975 op_null((OP*)cop);
2fcb4757 5976 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
79072805
LW		 5977}
5978
d67eb5f4
Z		 5979/*
5980=for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
5981
5982Constructs, checks, and returns a logical (flow control) op. I<type>
5983is the opcode. I<flags> gives the eight bits of C<op_flags>, except
5984that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
5985the eight bits of C<op_private>, except that the bit with value 1 is
5986automatically set. I<first> supplies the expression controlling the
5987flow, and I<other> supplies the side (alternate) chain of ops; they are
5988consumed by this function and become part of the constructed op tree.
5989
5990=cut
5991*/
bbce6d69 5992
79072805 5993OP *
864dbfa3 5994Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
79072805 5995{
27da23d5 5996 dVAR;
7918f24d
NC		 5997
5998 PERL_ARGS_ASSERT_NEWLOGOP;
5999
883ffac3
CS		 6000 return new_logop(type, flags, &first, &other);
6001}
6002
3bd495df 6003STATIC OP *
71c4dbc3
VP		 6004S_search_const(pTHX_ OP *o)
6005{
6006 PERL_ARGS_ASSERT_SEARCH_CONST;
6007
6008 switch (o->op_type) {
6009 case OP_CONST:
6010 return o;
6011 case OP_NULL:
6012 if (o->op_flags & OPf_KIDS)
6013 return search_const(cUNOPo->op_first);
6014 break;
6015 case OP_LEAVE:
6016 case OP_SCOPE:
6017 case OP_LINESEQ:
6018 {
6019 OP *kid;
6020 if (!(o->op_flags & OPf_KIDS))
6021 return NULL;
6022 kid = cLISTOPo->op_first;
6023 do {
6024 switch (kid->op_type) {
6025 case OP_ENTER:
6026 case OP_NULL:
6027 case OP_NEXTSTATE:
6028 kid = kid->op_sibling;
6029 break;
6030 default:
6031 if (kid != cLISTOPo->op_last)
6032 return NULL;
6033 goto last;
6034 }
6035 } while (kid);
6036 if (!kid)
6037 kid = cLISTOPo->op_last;
6038last:
6039 return search_const(kid);
6040 }
6041 }
6042
6043 return NULL;
6044}
6045
6046STATIC OP *
cea2e8a9 6047S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
883ffac3 6048{
27da23d5 6049 dVAR;
79072805 6050 LOGOP *logop;
11343788 6051 OP *o;
71c4dbc3
VP		 6052 OP *first;
6053 OP *other;
6054 OP *cstop = NULL;
edbe35ea 6055 int prepend_not = 0;
79072805 6056
7918f24d
NC		 6057 PERL_ARGS_ASSERT_NEW_LOGOP;
6058
71c4dbc3
VP		 6059 first = *firstp;
6060 other = *otherp;
6061
9da2d046
NT		 6062 /* [perl #59802]: Warn about things like "return $a or $b", which
6063 is parsed as "(return $a) or $b" rather than "return ($a or
6064 $b)". NB: This also applies to xor, which is why we do it
6065 here.
6066 */
6067 switch (first->op_type) {
6068 case OP_NEXT:
6069 case OP_LAST:
6070 case OP_REDO:
6071 /* XXX: Perhaps we should emit a stronger warning for these.
6072 Even with the high-precedence operator they don't seem to do
6073 anything sensible.
6074
6075 But until we do, fall through here.
6076 */
6077 case OP_RETURN:
6078 case OP_EXIT:
6079 case OP_DIE:
6080 case OP_GOTO:
6081 /* XXX: Currently we allow people to "shoot themselves in the
6082 foot" by explicitly writing "(return $a) or $b".
6083
6084 Warn unless we are looking at the result from folding or if
6085 the programmer explicitly grouped the operators like this.
6086 The former can occur with e.g.
6087
6088 use constant FEATURE => ( $] >= ... );
6089 sub { not FEATURE and return or do_stuff(); }
6090 */
6091 if (!first->op_folded && !(first->op_flags & OPf_PARENS))
6092 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
6093 "Possible precedence issue with control flow operator");
6094 /* XXX: Should we optimze this to "return $a;" (i.e. remove
6095 the "or $b" part)?
6096 */
6097 break;
6098 }
6099
a0d0e21e
LW		 6100 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
6101 return newBINOP(type, flags, scalar(first), scalar(other));
6102
e69777c1
GG		 6103 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP);
6104
8990e307 6105 scalarboolean(first);
edbe35ea 6106 /* optimize AND and OR ops that have NOTs as children */
68726e16 6107 if (first->op_type == OP_NOT
b6214b80 6108 && (first->op_flags & OPf_KIDS)
edbe35ea
VP		 6109 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
6110 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
b6214b80 6111 && !PL_madskills) {
79072805
LW		 6112 if (type == OP_AND || type == OP_OR) {
6113 if (type == OP_AND)
6114 type = OP_OR;
6115 else
6116 type = OP_AND;
07f3cdf5 6117 op_null(first);
edbe35ea 6118 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
07f3cdf5 6119 op_null(other);
edbe35ea
VP		 6120 prepend_not = 1; /* prepend a NOT op later */
6121 }
79072805
LW		 6122 }
6123 }
71c4dbc3
VP		 6124 /* search for a constant op that could let us fold the test */
6125 if ((cstop = search_const(first))) {
6126 if (cstop->op_private & OPpCONST_STRICT)
6127 no_bareword_allowed(cstop);
a2a5de95
NC		 6128 else if ((cstop->op_private & OPpCONST_BARE))
6129 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
71c4dbc3
VP		 6130 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
6131 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
6132 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
5f66b61c 6133 *firstp = NULL;
d6fee5c7
DM		 6134 if (other->op_type == OP_CONST)
6135 other->op_private |= OPpCONST_SHORTCIRCUIT;
eb8433b7
NC		 6136 if (PL_madskills) {
6137 OP *newop = newUNOP(OP_NULL, 0, other);
6138 op_getmad(first, newop, '1');
6139 newop->op_targ = type; /* set "was" field */
6140 return newop;
6141 }
6142 op_free(first);
dd3e51dc
VP		 6143 if (other->op_type == OP_LEAVE)
6144 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
2474a784
FC		 6145 else if (other->op_type == OP_MATCH
6146 || other->op_type == OP_SUBST
bb16bae8 6147 || other->op_type == OP_TRANSR
2474a784
FC		 6148 || other->op_type == OP_TRANS)
6149 /* Mark the op as being unbindable with =~ */
6150 other->op_flags |= OPf_SPECIAL;
3513c740
NT		 6151
6152 other->op_folded = 1;
79072805
LW		 6153 return other;
6154 }
6155 else {
7921d0f2 6156 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
6867be6d 6157 const OP *o2 = other;
7921d0f2
DM		 6158 if ( ! (o2->op_type == OP_LIST
6159 && (( o2 = cUNOPx(o2)->op_first))
6160 && o2->op_type == OP_PUSHMARK
6161 && (( o2 = o2->op_sibling)) )
6162 )
6163 o2 = other;
6164 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
6165 || o2->op_type == OP_PADHV)
6166 && o2->op_private & OPpLVAL_INTRO
a2a5de95 6167 && !(o2->op_private & OPpPAD_STATE))
7921d0f2 6168 {
d1d15184
NC		 6169 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6170 "Deprecated use of my() in false conditional");
7921d0f2
DM		 6171 }
6172
5f66b61c 6173 *otherp = NULL;
1b268608
FC		 6174 if (cstop->op_type == OP_CONST)
6175 cstop->op_private |= OPpCONST_SHORTCIRCUIT;
eb8433b7
NC		 6176 if (PL_madskills) {
6177 first = newUNOP(OP_NULL, 0, first);
6178 op_getmad(other, first, '2');
6179 first->op_targ = type; /* set "was" field */
6180 }
6181 else
6182 op_free(other);
79072805
LW		 6183 return first;
6184 }
6185 }
041457d9
DM		 6186 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
6187 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
59e10468 6188 {
b22e6366
AL		 6189 const OP * const k1 = ((UNOP*)first)->op_first;
6190 const OP * const k2 = k1->op_sibling;
a6006777 6191 OPCODE warnop = 0;
6192 switch (first->op_type)
6193 {
6194 case OP_NULL:
6195 if (k2 && k2->op_type == OP_READLINE
6196 && (k2->op_flags & OPf_STACKED)
1c846c1f 6197 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
72b16652 6198 {
a6006777 6199 warnop = k2->op_type;
72b16652 6200 }
a6006777 6201 break;
6202
6203 case OP_SASSIGN:
68dc0745 6204 if (k1->op_type == OP_READDIR
6205 || k1->op_type == OP_GLOB
72b16652 6206 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
459b64da
HY		 6207 || k1->op_type == OP_EACH
6208 || k1->op_type == OP_AEACH)
72b16652
GS		 6209 {
6210 warnop = ((k1->op_type == OP_NULL)
eb160463 6211 ? (OPCODE)k1->op_targ : k1->op_type);
72b16652 6212 }
a6006777 6213 break;
6214 }
8ebc5c01 6215 if (warnop) {
6867be6d 6216 const line_t oldline = CopLINE(PL_curcop);
502e5101
NC		 6217 /* This ensures that warnings are reported at the first line
6218 of the construction, not the last. */
53a7735b 6219 CopLINE_set(PL_curcop, PL_parser->copline);
9014280d 6220 Perl_warner(aTHX_ packWARN(WARN_MISC),
599cee73 6221 "Value of %s%s can be \"0\"; test with defined()",
22c35a8c 6222 PL_op_desc[warnop],
68dc0745 6223 ((warnop == OP_READLINE || warnop == OP_GLOB)
6224 ? " construct" : "() operator"));
57843af0 6225 CopLINE_set(PL_curcop, oldline);
8ebc5c01 6226 }
a6006777 6227 }
79072805
LW		 6228
6229 if (!other)
6230 return first;
6231
c963b151 6232 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
a0d0e21e
LW		 6233 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
6234
b7dc083c 6235 NewOp(1101, logop, 1, LOGOP);
79072805 6236
eb160463 6237 logop->op_type = (OPCODE)type;
22c35a8c 6238 logop->op_ppaddr = PL_ppaddr[type];
79072805 6239 logop->op_first = first;
585ec06d 6240 logop->op_flags = (U8)(flags | OPf_KIDS);
79072805 6241 logop->op_other = LINKLIST(other);
eb160463 6242 logop->op_private = (U8)(1 | (flags >> 8));
79072805
LW		 6243
6244 /* establish postfix order */
6245 logop->op_next = LINKLIST(first);
6246 first->op_next = (OP*)logop;
6247 first->op_sibling = other;
6248
463d09e6
RGS		 6249 CHECKOP(type,logop);
6250
edbe35ea 6251 o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
11343788 6252 other->op_next = o;
79072805 6253
11343788 6254 return o;
79072805
LW		 6255}
6256
d67eb5f4
Z		 6257/*
6258=for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
6259
6260Constructs, checks, and returns a conditional-expression (C<cond_expr>)
6261op. I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
6262will be set automatically, and, shifted up eight bits, the eight bits of
6263C<op_private>, except that the bit with value 1 is automatically set.
6264I<first> supplies the expression selecting between the two branches,
6265and I<trueop> and I<falseop> supply the branches; they are consumed by
6266this function and become part of the constructed op tree.
6267
6268=cut
6269*/
6270
79072805 6271OP *
864dbfa3 6272Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
79072805 6273{
27da23d5 6274 dVAR;
1a67a97c
SM		 6275 LOGOP *logop;
6276 OP *start;
11343788 6277 OP *o;
71c4dbc3 6278 OP *cstop;
79072805 6279
7918f24d
NC		 6280 PERL_ARGS_ASSERT_NEWCONDOP;
6281
b1cb66bf 6282 if (!falseop)
6283 return newLOGOP(OP_AND, 0, first, trueop);
6284 if (!trueop)
6285 return newLOGOP(OP_OR, 0, first, falseop);
79072805 6286
8990e307 6287 scalarboolean(first);
71c4dbc3 6288 if ((cstop = search_const(first))) {
5b6782b2 6289 /* Left or right arm of the conditional? */
71c4dbc3 6290 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
5b6782b2
NC		 6291 OP *live = left ? trueop : falseop;
6292 OP *const dead = left ? falseop : trueop;
71c4dbc3
VP		 6293 if (cstop->op_private & OPpCONST_BARE &&
6294 cstop->op_private & OPpCONST_STRICT) {
6295 no_bareword_allowed(cstop);
b22e6366 6296 }
5b6782b2
NC		 6297 if (PL_madskills) {
6298 /* This is all dead code when PERL_MAD is not defined. */
6299 live = newUNOP(OP_NULL, 0, live);
6300 op_getmad(first, live, 'C');
6301 op_getmad(dead, live, left ? 'e' : 't');
6302 } else {
6303 op_free(first);
6304 op_free(dead);
79072805 6305 }
ef9da979
FC		 6306 if (live->op_type == OP_LEAVE)
6307 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
2474a784 6308 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
bb16bae8 6309 || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
2474a784
FC		 6310 /* Mark the op as being unbindable with =~ */
6311 live->op_flags |= OPf_SPECIAL;
3513c740 6312 live->op_folded = 1;
5b6782b2 6313 return live;
79072805 6314 }
1a67a97c
SM		 6315 NewOp(1101, logop, 1, LOGOP);
6316 logop->op_type = OP_COND_EXPR;
6317 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
6318 logop->op_first = first;
585ec06d 6319 logop->op_flags = (U8)(flags | OPf_KIDS);
eb160463 6320 logop->op_private = (U8)(1 | (flags >> 8));
1a67a97c
SM		 6321 logop->op_other = LINKLIST(trueop);
6322 logop->op_next = LINKLIST(falseop);
79072805 6323
463d09e6
RGS		 6324 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
6325 logop);
79072805
LW		 6326
6327 /* establish postfix order */
1a67a97c
SM		 6328 start = LINKLIST(first);
6329 first->op_next = (OP*)logop;
79072805 6330
b1cb66bf 6331 first->op_sibling = trueop;
6332 trueop->op_sibling = falseop;
1a67a97c 6333 o = newUNOP(OP_NULL, 0, (OP*)logop);
79072805 6334
1a67a97c 6335 trueop->op_next = falseop->op_next = o;
79072805 6336
1a67a97c 6337 o->op_next = start;
11343788 6338 return o;
79072805
LW		 6339}
6340
d67eb5f4
Z		 6341/*
6342=for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
6343
6344Constructs and returns a C<range> op, with subordinate C<flip> and
6345C<flop> ops. I<flags> gives the eight bits of C<op_flags> for the
6346C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
6347for both the C<flip> and C<range> ops, except that the bit with value
63481 is automatically set. I<left> and I<right> supply the expressions
6349controlling the endpoints of the range; they are consumed by this function
6350and become part of the constructed op tree.
6351
6352=cut
6353*/
6354
79072805 6355OP *
864dbfa3 6356Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
79072805 6357{
27da23d5 6358 dVAR;
1a67a97c 6359 LOGOP *range;
79072805
LW		 6360 OP *flip;
6361 OP *flop;
1a67a97c 6362 OP *leftstart;
11343788 6363 OP *o;
79072805 6364
7918f24d
NC		 6365 PERL_ARGS_ASSERT_NEWRANGE;
6366
1a67a97c 6367 NewOp(1101, range, 1, LOGOP);
79072805 6368
1a67a97c
SM		 6369 range->op_type = OP_RANGE;
6370 range->op_ppaddr = PL_ppaddr[OP_RANGE];
6371 range->op_first = left;
6372 range->op_flags = OPf_KIDS;
6373 leftstart = LINKLIST(left);
6374 range->op_other = LINKLIST(right);
eb160463 6375 range->op_private = (U8)(1 | (flags >> 8));
79072805
LW		 6376
6377 left->op_sibling = right;
6378
1a67a97c
SM		 6379 range->op_next = (OP*)range;
6380 flip = newUNOP(OP_FLIP, flags, (OP*)range);
79072805 6381 flop = newUNOP(OP_FLOP, 0, flip);
11343788 6382 o = newUNOP(OP_NULL, 0, flop);
5983a79d 6383 LINKLIST(flop);
1a67a97c 6384 range->op_next = leftstart;
79072805
LW		 6385
6386 left->op_next = flip;
6387 right->op_next = flop;
6388
1a67a97c
SM		 6389 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
6390 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
ed6116ce 6391 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
79072805
LW		 6392 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
6393
6394 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
6395 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
6396
eb796c7f
GG		 6397 /* check barewords before they might be optimized aways */
6398 if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
6399 no_bareword_allowed(left);
6400 if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
6401 no_bareword_allowed(right);
6402
11343788 6403 flip->op_next = o;
79072805 6404 if (!flip->op_private || !flop->op_private)
5983a79d 6405 LINKLIST(o); /* blow off optimizer unless constant */
79072805 6406
11343788 6407 return o;
79072805
LW		 6408}
6409
d67eb5f4
Z		 6410/*
6411=for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
6412
6413Constructs, checks, and returns an op tree expressing a loop. This is
6414only a loop in the control flow through the op tree; it does not have
6415the heavyweight loop structure that allows exiting the loop by C<last>
6416and suchlike. I<flags> gives the eight bits of C<op_flags> for the
6417top-level op, except that some bits will be set automatically as required.
6418I<expr> supplies the expression controlling loop iteration, and I<block>
6419supplies the body of the loop; they are consumed by this function and
6420become part of the constructed op tree. I<debuggable> is currently
6421unused and should always be 1.
6422
6423=cut
6424*/
6425
79072805 6426OP *
864dbfa3 6427Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
79072805 6428{
97aff369 6429 dVAR;
463ee0b2 6430 OP* listop;
11343788 6431 OP* o;
73d840c0 6432 const bool once = block && block->op_flags & OPf_SPECIAL &&
a0d0e21e 6433 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
46c461b5
AL		 6434
6435 PERL_UNUSED_ARG(debuggable);
93a17b20 6436
463ee0b2
LW		 6437 if (expr) {
6438 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
6439 return block; /* do {} while 0 does once */
114c60ec
BG		 6440 if (expr->op_type == OP_READLINE
6441 || expr->op_type == OP_READDIR
6442 || expr->op_type == OP_GLOB
8ae39f60 6443 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
fb73857a 6444 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
774d564b 6445 expr = newUNOP(OP_DEFINED, 0,
54b9620d 6446 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
55d729e4 6447 } else if (expr->op_flags & OPf_KIDS) {
46c461b5
AL		 6448 const OP * const k1 = ((UNOP*)expr)->op_first;
6449 const OP * const k2 = k1 ? k1->op_sibling : NULL;
55d729e4 6450 switch (expr->op_type) {
1c846c1f 6451 case OP_NULL:
114c60ec 6452 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
55d729e4 6453 && (k2->op_flags & OPf_STACKED)
1c846c1f 6454 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
55d729e4 6455 expr = newUNOP(OP_DEFINED, 0, expr);
1c846c1f 6456 break;
55d729e4
GS		 6457
6458 case OP_SASSIGN:
06dc7ac6 6459 if (k1 && (k1->op_type == OP_READDIR
55d729e4 6460 || k1->op_type == OP_GLOB
6531c3e6 6461 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
459b64da
HY		 6462 || k1->op_type == OP_EACH
6463 || k1->op_type == OP_AEACH))
55d729e4
GS		 6464 expr = newUNOP(OP_DEFINED, 0, expr);
6465 break;
6466 }
774d564b 6467 }
463ee0b2 6468 }
93a17b20 6469
2fcb4757 6470 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
e1548254
RGS		 6471 * op, in listop. This is wrong. [perl #27024] */
6472 if (!block)
6473 block = newOP(OP_NULL, 0);
2fcb4757 6474 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
883ffac3 6475 o = new_logop(OP_AND, 0, &expr, &listop);
463ee0b2 6476
883ffac3
CS		 6477 if (listop)
6478 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
79072805 6479
11343788
MB		 6480 if (once && o != listop)
6481 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
79072805 6482
11343788
MB		 6483 if (o == listop)
6484 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
748a9306 6485
11343788 6486 o->op_flags |= flags;
3ad73efd 6487 o = op_scope(o);
11343788
MB		 6488 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
6489 return o;
79072805
LW		 6490}
6491
d67eb5f4 6492/*
94bf0465 6493=for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
d67eb5f4
Z		 6494
6495Constructs, checks, and returns an op tree expressing a C<while> loop.
6496This is a heavyweight loop, with structure that allows exiting the loop
6497by C<last> and suchlike.
6498
6499I<loop> is an optional preconstructed C<enterloop> op to use in the
6500loop; if it is null then a suitable op will be constructed automatically.
6501I<expr> supplies the loop's controlling expression. I<block> supplies the
6502main body of the loop, and I<cont> optionally supplies a C<continue> block
6503that operates as a second half of the body. All of these optree inputs
6504are consumed by this function and become part of the constructed op tree.
6505
6506I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
6507op and, shifted up eight bits, the eight bits of C<op_private> for
6508the C<leaveloop> op, except that (in both cases) some bits will be set
6509automatically. I<debuggable> is currently unused and should always be 1.
94bf0465 6510I<has_my> can be supplied as true to force the
d67eb5f4
Z		 6511loop body to be enclosed in its own scope.
6512
6513=cut
6514*/
6515
79072805 6516OP *
94bf0465
Z		 6517Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
6518 OP *expr, OP *block, OP *cont, I32 has_my)
79072805 6519{
27da23d5 6520 dVAR;
79072805 6521 OP *redo;
c445ea15 6522 OP *next = NULL;
79072805 6523 OP *listop;
11343788 6524 OP *o;
1ba6ee2b 6525 U8 loopflags = 0;
46c461b5
AL		 6526
6527 PERL_UNUSED_ARG(debuggable);
79072805 6528
2d03de9c 6529 if (expr) {
114c60ec
BG		 6530 if (expr->op_type == OP_READLINE
6531 || expr->op_type == OP_READDIR
6532 || expr->op_type == OP_GLOB
8ae39f60 6533 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
2d03de9c
AL		 6534 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
6535 expr = newUNOP(OP_DEFINED, 0,
6536 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
6537 } else if (expr->op_flags & OPf_KIDS) {
6538 const OP * const k1 = ((UNOP*)expr)->op_first;
6539 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
6540 switch (expr->op_type) {
6541 case OP_NULL:
114c60ec 6542 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
2d03de9c
AL		 6543 && (k2->op_flags & OPf_STACKED)
6544 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
6545 expr = newUNOP(OP_DEFINED, 0, expr);
6546 break;
55d729e4 6547
2d03de9c 6548 case OP_SASSIGN:
72c8de1a 6549 if (k1 && (k1->op_type == OP_READDIR
2d03de9c
AL		 6550 || k1->op_type == OP_GLOB
6551 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
459b64da
HY		 6552 || k1->op_type == OP_EACH
6553 || k1->op_type == OP_AEACH))
2d03de9c
AL		 6554 expr = newUNOP(OP_DEFINED, 0, expr);
6555 break;
6556 }
55d729e4 6557 }
748a9306 6558 }
79072805
LW		 6559
6560 if (!block)
6561 block = newOP(OP_NULL, 0);
a034e688 6562 else if (cont || has_my) {
3ad73efd 6563 block = op_scope(block);
87246558 6564 }
79072805 6565
1ba6ee2b 6566 if (cont) {
79072805 6567 next = LINKLIST(cont);
1ba6ee2b 6568 }
fb73857a 6569 if (expr) {
551405c4 6570 OP * const unstack = newOP(OP_UNSTACK, 0);
85538317
GS		 6571 if (!next)
6572 next = unstack;
2fcb4757 6573 cont = op_append_elem(OP_LINESEQ, cont, unstack);
fb73857a 6574 }
79072805 6575
ce3e5c45 6576 assert(block);
2fcb4757 6577 listop = op_append_list(OP_LINESEQ, block, cont);
ce3e5c45 6578 assert(listop);
79072805
LW		 6579 redo = LINKLIST(listop);
6580
6581 if (expr) {
883ffac3
CS		 6582 scalar(listop);
6583 o = new_logop(OP_AND, 0, &expr, &listop);
11343788 6584 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
463ee0b2 6585 op_free((OP*)loop);
317f3b66 6586 return expr; /* listop already freed by new_logop */
463ee0b2 6587 }
883ffac3 6588 if (listop)
497b47a8 6589 ((LISTOP*)listop)->op_last->op_next =
883ffac3 6590 (o == listop ? redo : LINKLIST(o));
79072805
LW		 6591 }
6592 else
11343788 6593 o = listop;
79072805
LW		 6594
6595 if (!loop) {
b7dc083c 6596 NewOp(1101,loop,1,LOOP);
79072805 6597 loop->op_type = OP_ENTERLOOP;
22c35a8c 6598 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
79072805
LW		 6599 loop->op_private = 0;
6600 loop->op_next = (OP*)loop;
6601 }
6602
11343788 6603 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
79072805
LW		 6604
6605 loop->op_redoop = redo;
11343788 6606 loop->op_lastop = o;
1ba6ee2b 6607 o->op_private |= loopflags;
79072805
LW		 6608
6609 if (next)
6610 loop->op_nextop = next;
6611 else
11343788 6612 loop->op_nextop = o;
79072805 6613
11343788
MB		 6614 o->op_flags |= flags;
6615 o->op_private |= (flags >> 8);
6616 return o;
79072805
LW		 6617}
6618
d67eb5f4 6619/*
94bf0465 6620=for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
d67eb5f4
Z		 6621
6622Constructs, checks, and returns an op tree expressing a C<foreach>
6623loop (iteration through a list of values). This is a heavyweight loop,
6624with structure that allows exiting the loop by C<last> and suchlike.
6625
6626I<sv> optionally supplies the variable that will be aliased to each
6627item in turn; if null, it defaults to C<$_> (either lexical or global).
6628I<expr> supplies the list of values to iterate over. I<block> supplies
6629the main body of the loop, and I<cont> optionally supplies a C<continue>
6630block that operates as a second half of the body. All of these optree
6631inputs are consumed by this function and become part of the constructed
6632op tree.
6633
6634I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
6635op and, shifted up eight bits, the eight bits of C<op_private> for
6636the C<leaveloop> op, except that (in both cases) some bits will be set
94bf0465 6637automatically.
d67eb5f4
Z		 6638
6639=cut
6640*/
6641
79072805 6642OP *
94bf0465 6643Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
79072805 6644{
27da23d5 6645 dVAR;
79072805 6646 LOOP *loop;
fb73857a 6647 OP *wop;
4bbc6d12 6648 PADOFFSET padoff = 0;
4633a7c4 6649 I32 iterflags = 0;
241416b8 6650 I32 iterpflags = 0;
d4c19fe8 6651 OP *madsv = NULL;
79072805 6652
7918f24d
NC		 6653 PERL_ARGS_ASSERT_NEWFOROP;
6654
79072805 6655 if (sv) {
85e6fe83 6656 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
241416b8 6657 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
748a9306 6658 sv->op_type = OP_RV2GV;
22c35a8c 6659 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
0be9a6bb
RH		 6660
6661 /* The op_type check is needed to prevent a possible segfault
6662 * if the loop variable is undeclared and 'strict vars' is in
6663 * effect. This is illegal but is nonetheless parsed, so we
6664 * may reach this point with an OP_CONST where we're expecting
6665 * an OP_GV.
6666 */
6667 if (cUNOPx(sv)->op_first->op_type == OP_GV
6668 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
0d863452 6669 iterpflags |= OPpITER_DEF;
79072805 6670 }
85e6fe83 6671 else if (sv->op_type == OP_PADSV) { /* private variable */
241416b8 6672 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
85e6fe83 6673 padoff = sv->op_targ;
eb8433b7
NC		 6674 if (PL_madskills)
6675 madsv = sv;
6676 else {
6677 sv->op_targ = 0;
6678 op_free(sv);
6679 }
5f66b61c 6680 sv = NULL;
85e6fe83 6681 }
79072805 6682 else
cea2e8a9 6683 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
f8503592
NC		 6684 if (padoff) {
6685 SV *const namesv = PAD_COMPNAME_SV(padoff);
6686 STRLEN len;
6687 const char *const name = SvPV_const(namesv, len);
6688
6689 if (len == 2 && name[0] == '$' && name[1] == '_')
6690 iterpflags |= OPpITER_DEF;
6691 }
79072805
LW		 6692 }
6693 else {
cc76b5cc 6694 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
00b1698f 6695 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
aabe9514
RGS		 6696 sv = newGVOP(OP_GV, 0, PL_defgv);
6697 }
6698 else {
6699 padoff = offset;
aabe9514 6700 }
0d863452 6701 iterpflags |= OPpITER_DEF;
79072805 6702 }
5f05dabc 6703 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3ad73efd 6704 expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4633a7c4
LW		 6705 iterflags |= OPf_STACKED;
6706 }
89ea2908
GA		 6707 else if (expr->op_type == OP_NULL &&
6708 (expr->op_flags & OPf_KIDS) &&
6709 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
6710 {
6711 /* Basically turn for($x..$y) into the same as for($x,$y), but we
6712 * set the STACKED flag to indicate that these values are to be
08bf00be 6713 * treated as min/max values by 'pp_enteriter'.
89ea2908 6714 */
d4c19fe8 6715 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
551405c4 6716 LOGOP* const range = (LOGOP*) flip->op_first;
66a1b24b
AL		 6717 OP* const left = range->op_first;
6718 OP* const right = left->op_sibling;
5152d7c7 6719 LISTOP* listop;
89ea2908
GA		 6720
6721 range->op_flags &= ~OPf_KIDS;
5f66b61c 6722 range->op_first = NULL;
89ea2908 6723
5152d7c7 6724 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
1a67a97c
SM		 6725 listop->op_first->op_next = range->op_next;
6726 left->op_next = range->op_other;
5152d7c7
GS		 6727 right->op_next = (OP*)listop;
6728 listop->op_next = listop->op_first;
89ea2908 6729
eb8433b7
NC		 6730#ifdef PERL_MAD
6731 op_getmad(expr,(OP*)listop,'O');
6732#else
89ea2908 6733 op_free(expr);
eb8433b7 6734#endif
5152d7c7 6735 expr = (OP*)(listop);
93c66552 6736 op_null(expr);
89ea2908
GA		 6737 iterflags |= OPf_STACKED;
6738 }
6739 else {
3ad73efd 6740 expr = op_lvalue(force_list(expr), OP_GREPSTART);
89ea2908
GA		 6741 }
6742
4633a7c4 6743 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
2fcb4757 6744 op_append_elem(OP_LIST, expr, scalar(sv))));
85e6fe83 6745 assert(!loop->op_next);
241416b8 6746 /* for my $x () sets OPpLVAL_INTRO;
14f338dc 6747 * for our $x () sets OPpOUR_INTRO */
c5661c80 6748 loop->op_private = (U8)iterpflags;
b448305b
FC		 6749 if (loop->op_slabbed
6750 && DIFF(loop, OpSLOT(loop)->opslot_next)
8be227ab 6751 < SIZE_TO_PSIZE(sizeof(LOOP)))
155aba94
GS		 6752 {
6753 LOOP *tmp;
6754 NewOp(1234,tmp,1,LOOP);
bd5f3bc4 6755 Copy(loop,tmp,1,LISTOP);
bfafaa29 6756 S_op_destroy(aTHX_ (OP*)loop);
155aba94
GS		 6757 loop = tmp;
6758 }
b448305b
FC		 6759 else if (!loop->op_slabbed)
6760 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
85e6fe83 6761 loop->op_targ = padoff;
94bf0465 6762 wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
eb8433b7
NC		 6763 if (madsv)
6764 op_getmad(madsv, (OP*)loop, 'v');
eae48c89 6765 return wop;
79072805
LW		 6766}
6767
d67eb5f4
Z		 6768/*
6769=for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
6770
6771Constructs, checks, and returns a loop-exiting op (such as C<goto>
6772or C<last>). I<type> is the opcode. I<label> supplies the parameter
6773determining the target of the op; it is consumed by this function and
d001e19d 6774becomes part of the constructed op tree.
d67eb5f4
Z		 6775
6776=cut
6777*/
6778
8990e307 6779OP*
864dbfa3 6780Perl_newLOOPEX(pTHX_ I32 type, OP *label)
8990e307 6781{
97aff369 6782 dVAR;
1ec4f607 6783 OP *o = NULL;
2d8e6c8d 6784
7918f24d
NC		 6785 PERL_ARGS_ASSERT_NEWLOOPEX;
6786
e69777c1
GG		 6787 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
6788
3532f34a 6789 if (type != OP_GOTO) {
cdaebead 6790 /* "last()" means "last" */
1f039d60 6791 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
cdaebead 6792 o = newOP(type, OPf_SPECIAL);
cdaebead 6793 }
8990e307
LW		 6794 }
6795 else {
e3aba57a
RGS		 6796 /* Check whether it's going to be a goto &function */
6797 if (label->op_type == OP_ENTERSUB
6798 && !(label->op_flags & OPf_STACKED))
3ad73efd 6799 label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
1f039d60
FC		 6800 }
6801
6802 /* Check for a constant argument */
6803 if (label->op_type == OP_CONST) {
3532f34a
FC		 6804 SV * const sv = ((SVOP *)label)->op_sv;
6805 STRLEN l;
6806 const char *s = SvPV_const(sv,l);
1f039d60
FC		 6807 if (l == strlen(s)) {
6808 o = newPVOP(type,
6809 SvUTF8(((SVOP*)label)->op_sv),
6810 savesharedpv(
6811 SvPV_nolen_const(((SVOP*)label)->op_sv)));
1ec4f607
FC		 6812 }
6813 }
6814
6815 /* If we have already created an op, we do not need the label. */
6816 if (o)
1f039d60
FC		 6817#ifdef PERL_MAD
6818 op_getmad(label,o,'L');
6819#else
6820 op_free(label);
6821#endif
1ec4f607 6822 else o = newUNOP(type, OPf_STACKED, label);
1f039d60 6823
3280af22 6824 PL_hints |= HINT_BLOCK_SCOPE;
11343788 6825 return o;
8990e307
LW		 6826}
6827
0d863452
RH		 6828/* if the condition is a literal array or hash
6829 (or @{ ... } etc), make a reference to it.
6830 */
6831STATIC OP *
6832S_ref_array_or_hash(pTHX_ OP *cond)
6833{
6834 if (cond
6835 && (cond->op_type == OP_RV2AV
6836 || cond->op_type == OP_PADAV
6837 || cond->op_type == OP_RV2HV
6838 || cond->op_type == OP_PADHV))
6839
3ad73efd 6840 return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
0d863452 6841
329a333e
DL		 6842 else if(cond
6843 && (cond->op_type == OP_ASLICE
6dd3e0f2 6844 || cond->op_type == OP_KVASLICE
5cae3edb
RZ		 6845 || cond->op_type == OP_HSLICE
6846 || cond->op_type == OP_KVHSLICE)) {
329a333e
DL		 6847
6848 /* anonlist now needs a list from this op, was previously used in
6849 * scalar context */
6850 cond->op_flags |= ~(OPf_WANT_SCALAR | OPf_REF);
6851 cond->op_flags |= OPf_WANT_LIST;
6852
3ad73efd 6853 return newANONLIST(op_lvalue(cond, OP_ANONLIST));
329a333e
DL		 6854 }
6855
0d863452
RH		 6856 else
6857 return cond;
6858}
6859
6860/* These construct the optree fragments representing given()
6861 and when() blocks.
6862
6863 entergiven and enterwhen are LOGOPs; the op_other pointer
6864 points up to the associated leave op. We need this so we
6865 can put it in the context and make break/continue work.
6866 (Also, of course, pp_enterwhen will jump straight to
6867 op_other if the match fails.)
6868 */
6869
4136a0f7 6870STATIC OP *
0d863452
RH		 6871S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
6872 I32 enter_opcode, I32 leave_opcode,
6873 PADOFFSET entertarg)
6874{
97aff369 6875 dVAR;
0d863452
RH		 6876 LOGOP *enterop;
6877 OP *o;
6878
7918f24d
NC		 6879 PERL_ARGS_ASSERT_NEWGIVWHENOP;
6880
0d863452 6881 NewOp(1101, enterop, 1, LOGOP);
61a59f30 6882 enterop->op_type = (Optype)enter_opcode;
0d863452
RH		 6883 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
6884 enterop->op_flags = (U8) OPf_KIDS;
6885 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
6886 enterop->op_private = 0;
6887
6888 o = newUNOP(leave_opcode, 0, (OP *) enterop);
6889
6890 if (cond) {
6891 enterop->op_first = scalar(cond);
6892 cond->op_sibling = block;
6893
6894 o->op_next = LINKLIST(cond);
6895 cond->op_next = (OP *) enterop;
6896 }
6897 else {
6898 /* This is a default {} block */
6899 enterop->op_first = block;
6900 enterop->op_flags |= OPf_SPECIAL;
fc7debfb 6901 o ->op_flags |= OPf_SPECIAL;
0d863452
RH		 6902
6903 o->op_next = (OP *) enterop;
6904 }
6905
6906 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
6907 entergiven and enterwhen both
6908 use ck_null() */
6909
6910 enterop->op_next = LINKLIST(block);
6911 block->op_next = enterop->op_other = o;
6912
6913 return o;
6914}
6915
6916/* Does this look like a boolean operation? For these purposes
6917 a boolean operation is:
6918 - a subroutine call [*]
6919 - a logical connective
6920 - a comparison operator
6921 - a filetest operator, with the exception of -s -M -A -C
6922 - defined(), exists() or eof()
6923 - /$re/ or $foo =~ /$re/
6924
6925 [*] possibly surprising
6926 */
4136a0f7 6927STATIC bool
ef519e13 6928S_looks_like_bool(pTHX_ const OP *o)
0d863452 6929{
97aff369 6930 dVAR;
7918f24d
NC		 6931
6932 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
6933
0d863452
RH		 6934 switch(o->op_type) {
6935 case OP_OR:
f92e1a16 6936 case OP_DOR:
0d863452
RH		 6937 return looks_like_bool(cLOGOPo->op_first);
6938
6939 case OP_AND:
6940 return (
6941 looks_like_bool(cLOGOPo->op_first)
6942 && looks_like_bool(cLOGOPo->op_first->op_sibling));
6943
1e1d4b91 6944 case OP_NULL:
08fe1c44 6945 case OP_SCALAR:
1e1d4b91
JJ		 6946 return (
6947 o->op_flags & OPf_KIDS
6948 && looks_like_bool(cUNOPo->op_first));
6949
0d863452
RH		 6950 case OP_ENTERSUB:
6951
6952 case OP_NOT: case OP_XOR:
0d863452
RH		 6953
6954 case OP_EQ: case OP_NE: case OP_LT:
6955 case OP_GT: case OP_LE: case OP_GE:
6956
6957 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
6958 case OP_I_GT: case OP_I_LE: case OP_I_GE:
6959
6960 case OP_SEQ: case OP_SNE: case OP_SLT:
6961 case OP_SGT: case OP_SLE: case OP_SGE:
6962
6963 case OP_SMARTMATCH:
6964
6965 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
6966 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
6967 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
6968 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
6969 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
6970 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
6971 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
6972 case OP_FTTEXT: case OP_FTBINARY:
6973
6974 case OP_DEFINED: case OP_EXISTS:
6975 case OP_MATCH: case OP_EOF:
6976
f118ea0d
RGS		 6977 case OP_FLOP:
6978
0d863452
RH		 6979 return TRUE;
6980
6981 case OP_CONST:
6982 /* Detect comparisons that have been optimized away */
6983 if (cSVOPo->op_sv == &PL_sv_yes
6984 || cSVOPo->op_sv == &PL_sv_no)
6985
6986 return TRUE;
6e03d743
RGS		 6987 else
6988 return FALSE;
6e03d743 6989
0d863452
RH		 6990 /* FALL THROUGH */
6991 default:
6992 return FALSE;
6993 }
6994}
6995
d67eb5f4
Z		 6996/*
6997=for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
6998
6999Constructs, checks, and returns an op tree expressing a C<given> block.
7000I<cond> supplies the expression that will be locally assigned to a lexical
7001variable, and I<block> supplies the body of the C<given> construct; they
7002are consumed by this function and become part of the constructed op tree.
7003I<defsv_off> is the pad offset of the scalar lexical variable that will
a8bd1c84 7004be affected. If it is 0, the global $_ will be used.
d67eb5f4
Z		 7005
7006=cut
7007*/
7008
0d863452
RH		 7009OP *
7010Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
7011{
97aff369 7012 dVAR;
7918f24d 7013 PERL_ARGS_ASSERT_NEWGIVENOP;
0d863452
RH		 7014 return newGIVWHENOP(
7015 ref_array_or_hash(cond),
7016 block,
7017 OP_ENTERGIVEN, OP_LEAVEGIVEN,
7018 defsv_off);
7019}
7020
d67eb5f4
Z		 7021/*
7022=for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
7023
7024Constructs, checks, and returns an op tree expressing a C<when> block.
7025I<cond> supplies the test expression, and I<block> supplies the block
7026that will be executed if the test evaluates to true; they are consumed
7027by this function and become part of the constructed op tree. I<cond>
7028will be interpreted DWIMically, often as a comparison against C<$_>,
7029and may be null to generate a C<default> block.
7030
7031=cut
7032*/
7033
0d863452
RH		 7034OP *
7035Perl_newWHENOP(pTHX_ OP *cond, OP *block)
7036{
ef519e13 7037 const bool cond_llb = (!cond || looks_like_bool(cond));
0d863452
RH		 7038 OP *cond_op;
7039
7918f24d
NC		 7040 PERL_ARGS_ASSERT_NEWWHENOP;
7041
0d863452
RH		 7042 if (cond_llb)
7043 cond_op = cond;
7044 else {
7045 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
7046 newDEFSVOP(),
7047 scalar(ref_array_or_hash(cond)));
7048 }
7049
c08f093b 7050 return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
0d863452
RH		 7051}
7052
3fe9a6f1 7053void
dab1c735
BF		 7054Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
7055 const STRLEN len, const U32 flags)
cbf82dd0 7056{
7a2f0b06
PM		 7057 SV *name = NULL, *msg;
7058 const char * cvp = SvROK(cv) ? "" : CvPROTO(cv);
7059 STRLEN clen = CvPROTOLEN(cv), plen = len;
8fa6a409 7060
dab1c735 7061 PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
8fa6a409 7062
38d27505 7063 if (p == NULL && cvp == NULL)
7a2f0b06 7064 return;
3fe9a6f1 7065
38d27505 7066 if (!ckWARN_d(WARN_PROTOTYPE))
7a2f0b06
PM		 7067 return;
7068
7069 if (p && cvp) {
7070 p = S_strip_spaces(aTHX_ p, &plen);
7071 cvp = S_strip_spaces(aTHX_ cvp, &clen);
7072 if ((flags & SVf_UTF8) == SvUTF8(cv)) {
7073 if (plen == clen && memEQ(cvp, p, plen))
7074 return;
7075 } else {
7076 if (flags & SVf_UTF8) {
7077 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
7078 return;
7079 }
7080 else {
7081 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
7082 return;
7083 }
105ff74c 7084 }
3fe9a6f1 7085 }
7a2f0b06
PM		 7086
7087 msg = sv_newmortal();
7088
7089 if (gv)
7090 {
7091 if (isGV(gv))
7092 gv_efullname3(name = sv_newmortal(), gv, NULL);
7093 else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
7094 name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
7095 else name = (SV *)gv;
7096 }
7097 sv_setpvs(msg, "Prototype mismatch:");
7098 if (name)
7099 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
7100 if (cvp)
b17a0679
FC		 7101 Perl_sv_catpvf(aTHX_ msg, " (%"UTF8f")",
7102 UTF8fARG(SvUTF8(cv),clen,cvp)
7a2f0b06
PM		 7103 );
7104 else
7105 sv_catpvs(msg, ": none");
7106 sv_catpvs(msg, " vs ");
7107 if (p)
b17a0679 7108 Perl_sv_catpvf(aTHX_ msg, "(%"UTF8f")", UTF8fARG(flags & SVf_UTF8,len,p));
7a2f0b06
PM		 7109 else
7110 sv_catpvs(msg, "none");
7111 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
3fe9a6f1 7112}
7113
35f1c1c7 7114static void const_sv_xsub(pTHX_ CV* cv);
6f1b3ab0 7115static void const_av_xsub(pTHX_ CV* cv);
35f1c1c7 7116
beab0874 7117/*
ccfc67b7
JH		 7118
7119=head1 Optree Manipulation Functions
7120
beab0874
JT		 7121=for apidoc cv_const_sv
7122
7123If C<cv> is a constant sub eligible for inlining. returns the constant
7124value returned by the sub. Otherwise, returns NULL.
7125
7126Constant subs can be created with C<newCONSTSUB> or as described in
7127L<perlsub/"Constant Functions">.
7128
7129=cut
7130*/
760ac839 7131SV *
d45f5b30 7132Perl_cv_const_sv(pTHX_ const CV *const cv)
760ac839 7133{
6f1b3ab0 7134 SV *sv;
96a5add6 7135 PERL_UNUSED_CONTEXT;
5069cc75
NC		 7136 if (!cv)
7137 return NULL;
7138 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
7139 return NULL;
6f1b3ab0
FC		 7140 sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
7141 if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
7142 return sv;
fe5e78ed 7143}
760ac839 7144
f815dc14
FC		 7145SV *
7146Perl_cv_const_sv_or_av(pTHX_ const CV * const cv)
7147{
7148 PERL_UNUSED_CONTEXT;
7149 if (!cv)
7150 return NULL;
7151 assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
7152 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
7153}
7154
b5c19bd7 7155/* op_const_sv: examine an optree to determine whether it's in-lineable.
b5c19bd7
DM		 7156 */
7157
fe5e78ed 7158SV *
137da2b0 7159Perl_op_const_sv(pTHX_ const OP *o)
fe5e78ed 7160{
97aff369 7161 dVAR;
a0714e2c 7162 SV *sv = NULL;
fe5e78ed 7163
c631f32b
GG		 7164 if (PL_madskills)
7165 return NULL;
7166
0f79a09d 7167 if (!o)
a0714e2c 7168 return NULL;
1c846c1f
NIS		 7169
7170 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
fe5e78ed
GS		 7171 o = cLISTOPo->op_first->op_sibling;
7172
7173 for (; o; o = o->op_next) {
890ce7af 7174 const OPCODE type = o->op_type;
fe5e78ed 7175
1c846c1f 7176 if (sv && o->op_next == o)
fe5e78ed 7177 return sv;
e576b457 7178 if (o->op_next != o) {
dbe92b04
FC		 7179 if (type == OP_NEXTSTATE
7180 || (type == OP_NULL && !(o->op_flags & OPf_KIDS))
7181 || type == OP_PUSHMARK)
e576b457
JT		 7182 continue;
7183 if (type == OP_DBSTATE)
7184 continue;
7185 }
54310121 7186 if (type == OP_LEAVESUB || type == OP_RETURN)
7187 break;
7188 if (sv)
a0714e2c 7189 return NULL;
7766f137 7190 if (type == OP_CONST && cSVOPo->op_sv)
5dc0d613 7191 sv = cSVOPo->op_sv;
b5c19bd7 7192 else {
a0714e2c 7193 return NULL;
b5c19bd7 7194 }
760ac839
LW		 7195 }
7196 return sv;
7197}
7198
2b141370
FC		 7199static bool
7200S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
a6181857
FC		 7201 PADNAME * const name, SV ** const const_svp,
7202 GV * const gv)
2b141370
FC		 7203{
7204 assert (cv);
7205 assert (o || name);
7206 assert (const_svp);
7207 if ((!block
7208#ifdef PERL_MAD
7209 || block->op_type == OP_NULL
7210#endif
7211 )) {
7212 if (CvFLAGS(PL_compcv)) {
7213 /* might have had built-in attrs applied */
7214 const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
7215 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
7216 && ckWARN(WARN_MISC))
7217 {
7218 /* protect against fatal warnings leaking compcv */
7219 SAVEFREESV(PL_compcv);
7220 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
7221 SvREFCNT_inc_simple_void_NN(PL_compcv);
7222 }
7223 CvFLAGS(cv) |=
7224 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
7225 & ~(CVf_LVALUE * pureperl));
7226 }
7227 return FALSE;
7228 }
7229
7230 /* redundant check for speed: */
7231 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
7232 const line_t oldline = CopLINE(PL_curcop);
7233 SV *namesv = o
7234 ? cSVOPo->op_sv
7235 : sv_2mortal(newSVpvn_utf8(
7236 PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name)
7237 ));
7238 if (PL_parser && PL_parser->copline != NOLINE)
7239 /* This ensures that warnings are reported at the first
7240 line of a redefinition, not the last. */
7241 CopLINE_set(PL_curcop, PL_parser->copline);
d0761305
FC		 7242 /* protect against fatal warnings leaking compcv */
7243 SAVEFREESV(PL_compcv);
2b141370 7244 report_redefined_cv(namesv, cv, const_svp);
d0761305 7245 SvREFCNT_inc_simple_void_NN(PL_compcv);
2b141370
FC		 7246 CopLINE_set(PL_curcop, oldline);
7247 }
7248#ifdef PERL_MAD
7249 if (!PL_minus_c) /* keep old one around for madskills */
7250#endif
7251 {
7252 /* (PL_madskills unset in used file.) */
a6181857 7253 if (gv) GvCV_set(gv,NULL);
2b141370
FC		 7254 SvREFCNT_dec(cv);
7255 }
7256 return TRUE;
7257}
7258
50278755 7259CV *
09bef843
SB		 7260Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
7261{
50278755 7262 dVAR;
50278755
FC		 7263 CV **spot;
7264 SV **svspot;
7265 const char *ps;
7266 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
7267 U32 ps_utf8 = 0;
5aaab254
KW		 7268 CV *cv = NULL;
7269 CV *compcv = PL_compcv;
50278755 7270 SV *const_sv;
50278755 7271 PADNAME *name;
10342479
FC		 7272 PADOFFSET pax = o->op_targ;
7273 CV *outcv = CvOUTSIDE(PL_compcv);
a70c2d56 7274 CV *clonee = NULL;
6d5c2147 7275 HEK *hek = NULL;
a70c2d56 7276 bool reusable = FALSE;
50278755
FC		 7277
7278 PERL_ARGS_ASSERT_NEWMYSUB;
7279
10342479
FC		 7280 /* Find the pad slot for storing the new sub.
7281 We cannot use PL_comppad, as it is the pad owned by the new sub. We
7282 need to look in CvOUTSIDE and find the pad belonging to the enclos-
7283 ing sub. And then we need to dig deeper if this is a lexical from
7284 outside, as in:
7285 my sub foo; sub { sub foo { } }
7286 */
7287 redo:
7288 name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
7289 if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
7290 pax = PARENT_PAD_INDEX(name);
7291 outcv = CvOUTSIDE(outcv);
7292 assert(outcv);
7293 goto redo;
7294 }
2435fbd5 7295 svspot =
a70c2d56
FC		 7296 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
7297 [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
50278755
FC		 7298 spot = (CV **)svspot;
7299
eedb00fa
PM		 7300 if (!(PL_parser && PL_parser->error_count))
7301 move_proto_attr(&proto, &attrs, (GV *)name);
7302
50278755
FC		 7303 if (proto) {
7304 assert(proto->op_type == OP_CONST);
7305 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
7306 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
7307 }
7308 else
7309 ps = NULL;
7310
50278755 7311 if (!PL_madskills) {
50278755
FC		 7312 if (proto)
7313 SAVEFREEOP(proto);
7314 if (attrs)
7315 SAVEFREEOP(attrs);
7316 }
7317
b0305fa3 7318 if (PL_parser && PL_parser->error_count) {
50278755 7319 op_free(block);
8ca8859f
FC		 7320 SvREFCNT_dec(PL_compcv);
7321 PL_compcv = 0;
50278755
FC		 7322 goto done;
7323 }
7324
a70c2d56
FC		 7325 if (CvDEPTH(outcv) && CvCLONE(compcv)) {
7326 cv = *spot;
7327 svspot = (SV **)(spot = &clonee);
7328 }
7329 else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
6d5c2147
FC		 7330 cv = *spot;
7331 else {
7332 MAGIC *mg;
81df9f6f
FC		 7333 SvUPGRADE(name, SVt_PVMG);
7334 mg = mg_find(name, PERL_MAGIC_proto);
6d5c2147 7335 assert (SvTYPE(*spot) == SVt_PVCV);
6d5c2147
FC		 7336 if (CvNAMED(*spot))
7337 hek = CvNAME_HEK(*spot);
7338 else {
2e800d79 7339 CvNAME_HEK_set(*spot, hek =
6d5c2147
FC		 7340 share_hek(
7341 PadnamePV(name)+1,
7342 PadnameLEN(name)-1 * (PadnameUTF8(name) ? -1 : 1), 0
2e800d79
FC		 7343 )
7344 );
6d5c2147 7345 }
6d5c2147
FC		 7346 if (mg) {
7347 assert(mg->mg_obj);
7348 cv = (CV *)mg->mg_obj;
7349 }
7350 else {
81df9f6f
FC		 7351 sv_magic(name, &PL_sv_undef, PERL_MAGIC_proto, NULL, 0);
7352 mg = mg_find(name, PERL_MAGIC_proto);
6d5c2147
FC		 7353 }
7354 spot = (CV **)(svspot = &mg->mg_obj);
50278755
FC		 7355 }
7356
50278755
FC		 7357 if (!block || !ps || *ps || attrs
7358 || (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS)
7359#ifdef PERL_MAD
7360 || block->op_type == OP_NULL
eb8433b7 7361#endif
50278755
FC		 7362 )
7363 const_sv = NULL;
7364 else
137da2b0 7365 const_sv = op_const_sv(block);
eb8433b7 7366
50278755
FC		 7367 if (cv) {
7368 const bool exists = CvROOT(cv) || CvXSUB(cv);
46c461b5 7369
50278755
FC		 7370 /* if the subroutine doesn't exist and wasn't pre-declared
7371 * with a prototype, assume it will be AUTOLOADed,
7372 * skipping the prototype check
7373 */
7374 if (exists || SvPOK(cv))
2435fbd5 7375 cv_ckproto_len_flags(cv, (GV *)name, ps, ps_len, ps_utf8);
50278755
FC		 7376 /* already defined? */
7377 if (exists) {
a6181857 7378 if (S_already_defined(aTHX_ cv,block,NULL,name,&const_sv,NULL))
2b141370
FC		 7379 cv = NULL;
7380 else {
50278755
FC		 7381 if (attrs) goto attrs;
7382 /* just a "sub foo;" when &foo is already defined */
7383 SAVEFREESV(compcv);
7384 goto done;
7385 }
50278755 7386 }
a70c2d56
FC		 7387 else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
7388 cv = NULL;
7389 reusable = TRUE;
7390 }
50278755
FC		 7391 }
7392 if (const_sv) {
7393 SvREFCNT_inc_simple_void_NN(const_sv);
d2440203 7394 SvFLAGS(const_sv) = (SvFLAGS(const_sv) & ~SVs_PADMY) | SVs_PADTMP;
50278755
FC		 7395 if (cv) {
7396 assert(!CvROOT(cv) && !CvCONST(cv));
7397 cv_forget_slab(cv);
7398 }
7399 else {
7400 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
7401 CvFILE_set_from_cop(cv, PL_curcop);
7402 CvSTASH_set(cv, PL_curstash);
7403 *spot = cv;
7404 }
7405 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
7406 CvXSUBANY(cv).any_ptr = const_sv;
7407 CvXSUB(cv) = const_sv_xsub;
7408 CvCONST_on(cv);
7409 CvISXSUB_on(cv);
7410 if (PL_madskills)
7411 goto install_block;
7412 op_free(block);
7413 SvREFCNT_dec(compcv);
2435fbd5 7414 PL_compcv = NULL;
83a72a15 7415 goto setname;
50278755 7416 }
1f122f9b
FC		 7417 /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
7418 determine whether this sub definition is in the same scope as its
7419 declaration. If this sub definition is inside an inner named pack-
7420 age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
7421 the package sub. So check PadnameOUTER(name) too.
7422 */
7423 if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
10342479
FC		 7424 assert(!CvWEAKOUTSIDE(compcv));
7425 SvREFCNT_dec(CvOUTSIDE(compcv));
7426 CvWEAKOUTSIDE_on(compcv);
7427 }
7428 /* XXX else do we have a circular reference? */
50278755
FC		 7429 if (cv) { /* must reuse cv in case stub is referenced elsewhere */
7430 /* transfer PL_compcv to cv */
7431 if (block
eb8433b7 7432#ifdef PERL_MAD
50278755 7433 && block->op_type != OP_NULL
eb8433b7 7434#endif
50278755 7435 ) {
6d5c2147
FC		 7436 cv_flags_t preserved_flags =
7437 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
50278755
FC		 7438 PADLIST *const temp_padl = CvPADLIST(cv);
7439 CV *const temp_cv = CvOUTSIDE(cv);
10342479
FC		 7440 const cv_flags_t other_flags =
7441 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
50278755
FC		 7442 OP * const cvstart = CvSTART(cv);
7443
50278755
FC		 7444 SvPOK_off(cv);
7445 CvFLAGS(cv) =
6d5c2147 7446 CvFLAGS(compcv) | preserved_flags;
50278755
FC		 7447 CvOUTSIDE(cv) = CvOUTSIDE(compcv);
7448 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
7449 CvPADLIST(cv) = CvPADLIST(compcv);
7450 CvOUTSIDE(compcv) = temp_cv;
7451 CvPADLIST(compcv) = temp_padl;
7452 CvSTART(cv) = CvSTART(compcv);
7453 CvSTART(compcv) = cvstart;
10342479
FC		 7454 CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
7455 CvFLAGS(compcv) |= other_flags;
50278755
FC		 7456
7457 if (CvFILE(cv) && CvDYNFILE(cv)) {
7458 Safefree(CvFILE(cv));
7459 }
7460
7461 /* inner references to compcv must be fixed up ... */
7462 pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
7463 if (PERLDB_INTER)/* Advice debugger on the new sub. */
7464 ++PL_sub_generation;
7465 }
7466 else {
7467 /* Might have had built-in attributes applied -- propagate them. */
7468 CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
7469 }
7470 /* ... before we throw it away */
7471 SvREFCNT_dec(compcv);
2435fbd5 7472 PL_compcv = compcv = cv;
50278755
FC		 7473 }
7474 else {
7475 cv = compcv;
7476 *spot = cv;
6d5c2147 7477 }
83a72a15 7478 setname:
6d5c2147 7479 if (!CvNAME_HEK(cv)) {
2e800d79 7480 CvNAME_HEK_set(cv,
6d5c2147
FC		 7481 hek
7482 ? share_hek_hek(hek)
7483 : share_hek(PadnamePV(name)+1,
2435fbd5 7484 PadnameLEN(name)-1 * (PadnameUTF8(name) ? -1 : 1),
2e800d79
FC		 7485 0)
7486 );
50278755 7487 }
83a72a15
FC		 7488 if (const_sv) goto clone;
7489
50278755
FC		 7490 CvFILE_set_from_cop(cv, PL_curcop);
7491 CvSTASH_set(cv, PL_curstash);
7492
7493 if (ps) {
7494 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
7495 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
7496 }
7497
7498 install_block:
7499 if (!block)
7500 goto attrs;
7501
7502 /* If we assign an optree to a PVCV, then we've defined a subroutine that
7503 the debugger could be able to set a breakpoint in, so signal to
7504 pp_entereval that it should not throw away any saved lines at scope
7505 exit. */
7506
7507 PL_breakable_sub_gen++;
7508 /* This makes sub {}; work as expected. */
7509 if (block->op_type == OP_STUB) {
7510 OP* const newblock = newSTATEOP(0, NULL, 0);
7511#ifdef PERL_MAD
7512 op_getmad(block,newblock,'B');
7513#else
7514 op_free(block);
7515#endif
7516 block = newblock;
7517 }
7518 CvROOT(cv) = CvLVALUE(cv)
7519 ? newUNOP(OP_LEAVESUBLV, 0,
7520 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
7521 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
7522 CvROOT(cv)->op_private |= OPpREFCOUNTED;
7523 OpREFCNT_set(CvROOT(cv), 1);
7524 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
7525 itself has a refcount. */
7526 CvSLABBED_off(cv);
7527 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
7528 CvSTART(cv) = LINKLIST(CvROOT(cv));
7529 CvROOT(cv)->op_next = 0;
7530 CALL_PEEP(CvSTART(cv));
7531 finalize_optree(CvROOT(cv));
7532
7533 /* now that optimizer has done its work, adjust pad values */
7534
50278755 7535 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
50278755 7536
50278755
FC		 7537 attrs:
7538 if (attrs) {
7539 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
ad0dc73b 7540 apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
50278755
FC		 7541 }
7542
7543 if (block) {
7544 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
7545 SV * const tmpstr = sv_newmortal();
7546 GV * const db_postponed = gv_fetchpvs("DB::postponed",
7547 GV_ADDMULTI, SVt_PVHV);
7548 HV *hv;
7549 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
7550 CopFILE(PL_curcop),
7551 (long)PL_subline,
7552 (long)CopLINE(PL_curcop));
a56613a9
FC		 7553 if (HvNAME_HEK(PL_curstash)) {
7554 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
7555 sv_catpvs(tmpstr, "::");
7556 }
7557 else sv_setpvs(tmpstr, "__ANON__::");
2435fbd5
FC		 7558 sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
7559 PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
50278755
FC		 7560 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
7561 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
7562 hv = GvHVn(db_postponed);
7563 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
7564 CV * const pcv = GvCV(db_postponed);
7565 if (pcv) {
7566 dSP;
7567 PUSHMARK(SP);
7568 XPUSHs(tmpstr);
7569 PUTBACK;
7570 call_sv(MUTABLE_SV(pcv), G_DISCARD);
7571 }
7572 }
7573 }
7574 }
7575
a70c2d56
FC		 7576 clone:
7577 if (clonee) {
7578 assert(CvDEPTH(outcv));
7579 spot = (CV **)
7580 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
7581 if (reusable) cv_clone_into(clonee, *spot);
7582 else *spot = cv_clone(clonee);
fc2b2dca 7583 SvREFCNT_dec_NN(clonee);
a70c2d56
FC		 7584 cv = *spot;
7585 SvPADMY_on(cv);
7586 }
7587 if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
7588 PADOFFSET depth = CvDEPTH(outcv);
7589 while (--depth) {
7590 SV *oldcv;
7591 svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
7592 oldcv = *svspot;
7593 *svspot = SvREFCNT_inc_simple_NN(cv);
7594 SvREFCNT_dec(oldcv);
7595 }
7596 }
7597
50278755
FC		 7598 done:
7599 if (PL_parser)
7600 PL_parser->copline = NOLINE;
2435fbd5
FC		 7601 LEAVE_SCOPE(floor);
7602 if (o) op_free(o);
50278755 7603 return cv;
09bef843
SB		 7604}
7605
748a9306 7606CV *
09bef843
SB		 7607Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
7608{
7e68c38b
FC		 7609 return newATTRSUB_flags(floor, o, proto, attrs, block, 0);
7610}
7611
7612CV *
7613Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
7614 OP *block, U32 flags)
7615{
27da23d5 7616 dVAR;
83ee9e09 7617 GV *gv;
5c144d81 7618 const char *ps;
52a9a866 7619 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
e0260a5b 7620 U32 ps_utf8 = 0;
eb578fdb 7621 CV *cv = NULL;
beab0874 7622 SV *const_sv;
a73ef99b 7623 const bool ec = PL_parser && PL_parser->error_count;
b48b272a
NC		 7624 /* If the subroutine has no body, no attributes, and no builtin attributes
7625 then it's just a sub declaration, and we may be able to get away with
7626 storing with a placeholder scalar in the symbol table, rather than a
7627 full GV and CV. If anything is present then it will take a full CV to
7628 store it. */
7629 const I32 gv_fetch_flags
a73ef99b
FC		 7630 = ec ? GV_NOADD_NOINIT :
7631 (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
eb8433b7 7632 || PL_madskills)
b48b272a 7633 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
6e948d54 7634 STRLEN namlen = 0;
7e68c38b
FC		 7635 const bool o_is_gv = flags & 1;
7636 const char * const name =
7637 o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
ed4a8a9b 7638 bool has_name;
7e68c38b 7639 bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
7aef8e5b 7640#ifdef PERL_DEBUG_READONLY_OPS
3107b51f
FC		 7641 OPSLAB *slab = NULL;
7642#endif
8e742a20 7643
7e68c38b
FC		 7644 if (o_is_gv) {
7645 gv = (GV*)o;
7646 o = NULL;
7647 has_name = TRUE;
7648 } else if (name) {
7649 gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
ed4a8a9b
NC		 7650 has_name = TRUE;
7651 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
aec46f14 7652 SV * const sv = sv_newmortal();
c99da370
JH		 7653 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
7654 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
83ee9e09 7655 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
ed4a8a9b
NC		 7656 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
7657 has_name = TRUE;
c1754fce
NC		 7658 } else if (PL_curstash) {
7659 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
ed4a8a9b 7660 has_name = FALSE;
c1754fce
NC		 7661 } else {
7662 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
ed4a8a9b 7663 has_name = FALSE;
c1754fce 7664 }
83ee9e09 7665
eedb00fa
PM		 7666 if (!ec)
7667 move_proto_attr(&proto, &attrs, gv);
7668
7669 if (proto) {
7670 assert(proto->op_type == OP_CONST);
7671 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
7672 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
7673 }
7674 else
7675 ps = NULL;
7676
eb8433b7
NC		 7677 if (!PL_madskills) {
7678 if (o)
7679 SAVEFREEOP(o);
7680 if (proto)
7681 SAVEFREEOP(proto);
7682 if (attrs)
7683 SAVEFREEOP(attrs);
7684 }
3fe9a6f1 7685
a73ef99b
FC		 7686 if (ec) {
7687 op_free(block);
4d2dfd15
FC		 7688 if (name) SvREFCNT_dec(PL_compcv);
7689 else cv = PL_compcv;
9ffcdca1 7690 PL_compcv = 0;
a73ef99b
FC		 7691 if (name && block) {
7692 const char *s = strrchr(name, ':');
7693 s = s ? s+1 : name;
7694 if (strEQ(s, "BEGIN")) {
a73ef99b 7695 if (PL_in_eval & EVAL_KEEPERR)
eed484f9 7696 Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
a73ef99b 7697 else {
eed484f9 7698 SV * const errsv = ERRSV;
a73ef99b 7699 /* force display of errors found but not reported */
eed484f9
DD		 7700 sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
7701 Perl_croak_nocontext("%"SVf, SVfARG(errsv));
a73ef99b
FC		 7702 }
7703 }
7704 }
a73ef99b
FC		 7705 goto done;
7706 }
7707
09bef843 7708 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
55d729e4
GS		 7709 maximum a prototype before. */
7710 if (SvTYPE(gv) > SVt_NULL) {
105ff74c
FC		 7711 cv_ckproto_len_flags((const CV *)gv,
7712 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
7713 ps_len, ps_utf8);
55d729e4 7714 }
e0260a5b 7715 if (ps) {
ad64d0ec 7716 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
e0260a5b
BF		 7717 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(gv));
7718 }
55d729e4 7719 else
ad64d0ec 7720 sv_setiv(MUTABLE_SV(gv), -1);
e1a479c5 7721
3280af22
NIS		 7722 SvREFCNT_dec(PL_compcv);
7723 cv = PL_compcv = NULL;
beab0874 7724 goto done;
55d729e4
GS		 7725 }
7726
601f1833 7727 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
beab0874 7728
eb8433b7
NC		 7729 if (!block || !ps || *ps || attrs
7730 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
7731#ifdef PERL_MAD
7732 || block->op_type == OP_NULL
7733#endif
7734 )
a0714e2c 7735 const_sv = NULL;
beab0874 7736 else
137da2b0 7737 const_sv = op_const_sv(block);
beab0874
JT		 7738
7739 if (cv) {
6867be6d 7740 const bool exists = CvROOT(cv) || CvXSUB(cv);
5bd07a3d 7741
60ed1d8c
GS		 7742 /* if the subroutine doesn't exist and wasn't pre-declared
7743 * with a prototype, assume it will be AUTOLOADed,
7744 * skipping the prototype check
7745 */
7746 if (exists || SvPOK(cv))
dab1c735 7747 cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
68dc0745 7748 /* already defined (or promised)? */
60ed1d8c 7749 if (exists || GvASSUMECV(gv)) {
a6181857 7750 if (S_already_defined(aTHX_ cv, block, o, NULL, &const_sv, gv))
2b141370
FC		 7751 cv = NULL;
7752 else {
fff96ff7 7753 if (attrs) goto attrs;
aa689395 7754 /* just a "sub foo;" when &foo is already defined */
3280af22 7755 SAVEFREESV(PL_compcv);
aa689395 7756 goto done;
7757 }
79072805
LW		 7758 }
7759 }
beab0874 7760 if (const_sv) {
f84c484e 7761 SvREFCNT_inc_simple_void_NN(const_sv);
d2440203 7762 SvFLAGS(const_sv) = (SvFLAGS(const_sv) & ~SVs_PADMY) | SVs_PADTMP;
beab0874 7763 if (cv) {
0768512c 7764 assert(!CvROOT(cv) && !CvCONST(cv));
8be227ab 7765 cv_forget_slab(cv);
ad64d0ec 7766 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
beab0874
JT		 7767 CvXSUBANY(cv).any_ptr = const_sv;
7768 CvXSUB(cv) = const_sv_xsub;
7769 CvCONST_on(cv);
d04ba589 7770 CvISXSUB_on(cv);
beab0874
JT		 7771 }
7772 else {
c43ae56f 7773 GvCV_set(gv, NULL);
9c0a6090 7774 cv = newCONSTSUB_flags(
6e948d54 7775 NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
9c0a6090
FC		 7776 const_sv
7777 );
7ad40bcb 7778 }
eb8433b7
NC		 7779 if (PL_madskills)
7780 goto install_block;
beab0874
JT		 7781 op_free(block);
7782 SvREFCNT_dec(PL_compcv);
7783 PL_compcv = NULL;
beab0874
JT		 7784 goto done;
7785 }
09330df8
Z		 7786 if (cv) { /* must reuse cv if autoloaded */
7787 /* transfer PL_compcv to cv */
7788 if (block
eb8433b7 7789#ifdef PERL_MAD
09330df8 7790 && block->op_type != OP_NULL
eb8433b7 7791#endif
09330df8 7792 ) {
eac910c8 7793 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
b70d5558 7794 PADLIST *const temp_av = CvPADLIST(cv);
437388a9 7795 CV *const temp_cv = CvOUTSIDE(cv);
e52de15a
FC		 7796 const cv_flags_t other_flags =
7797 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
8be227ab 7798 OP * const cvstart = CvSTART(cv);
437388a9 7799
f6894bc8 7800 CvGV_set(cv,gv);
437388a9
NC		 7801 assert(!CvCVGV_RC(cv));
7802 assert(CvGV(cv) == gv);
7803
7804 SvPOK_off(cv);
eac910c8 7805 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs;
09330df8
Z		 7806 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
7807 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
09330df8 7808 CvPADLIST(cv) = CvPADLIST(PL_compcv);
437388a9
NC		 7809 CvOUTSIDE(PL_compcv) = temp_cv;
7810 CvPADLIST(PL_compcv) = temp_av;
8be227ab
FC		 7811 CvSTART(cv) = CvSTART(PL_compcv);
7812 CvSTART(PL_compcv) = cvstart;
e52de15a
FC		 7813 CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
7814 CvFLAGS(PL_compcv) |= other_flags;
437388a9 7815
bad4ae38 7816 if (CvFILE(cv) && CvDYNFILE(cv)) {
437388a9
NC		 7817 Safefree(CvFILE(cv));
7818 }
437388a9
NC		 7819 CvFILE_set_from_cop(cv, PL_curcop);
7820 CvSTASH_set(cv, PL_curstash);
7821
09330df8
Z		 7822 /* inner references to PL_compcv must be fixed up ... */
7823 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
7824 if (PERLDB_INTER)/* Advice debugger on the new sub. */
7825 ++PL_sub_generation;
09bef843
SB		 7826 }
7827 else {
09330df8
Z		 7828 /* Might have had built-in attributes applied -- propagate them. */
7829 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
09bef843 7830 }
282f25c9 7831 /* ... before we throw it away */
3280af22 7832 SvREFCNT_dec(PL_compcv);
b5c19bd7 7833 PL_compcv = cv;
a0d0e21e
LW		 7834 }
7835 else {
3280af22 7836 cv = PL_compcv;
44a8e56a 7837 if (name) {
c43ae56f 7838 GvCV_set(gv, cv);
44a8e56a 7839 GvCVGEN(gv) = 0;
03d9f026
FC		 7840 if (HvENAME_HEK(GvSTASH(gv)))
7841 /* sub Foo::bar { (shift)+1 } */
978a498e 7842 gv_method_changed(gv);
44a8e56a 7843 }
a0d0e21e 7844 }
09330df8 7845 if (!CvGV(cv)) {
b3f91e91 7846 CvGV_set(cv, gv);
09330df8 7847 CvFILE_set_from_cop(cv, PL_curcop);
c68d9564 7848 CvSTASH_set(cv, PL_curstash);
09330df8 7849 }
8990e307 7850
e0260a5b 7851 if (ps) {
ad64d0ec 7852 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
e0260a5b
BF		 7853 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
7854 }
4633a7c4 7855
eb8433b7 7856 install_block:
beab0874 7857 if (!block)
fb834abd 7858 goto attrs;
a0d0e21e 7859
aac018bb
NC		 7860 /* If we assign an optree to a PVCV, then we've defined a subroutine that
7861 the debugger could be able to set a breakpoint in, so signal to
7862 pp_entereval that it should not throw away any saved lines at scope
7863 exit. */
7864
fd06b02c 7865 PL_breakable_sub_gen++;
69b22cd1
FC		 7866 /* This makes sub {}; work as expected. */
7867 if (block->op_type == OP_STUB) {
1496a290 7868 OP* const newblock = newSTATEOP(0, NULL, 0);
eb8433b7
NC		 7869#ifdef PERL_MAD
7870 op_getmad(block,newblock,'B');
7871#else
09c2fd24 7872 op_free(block);
eb8433b7
NC		 7873#endif
7874 block = newblock;
7766f137 7875 }
69b22cd1
FC		 7876 CvROOT(cv) = CvLVALUE(cv)
7877 ? newUNOP(OP_LEAVESUBLV, 0,
7878 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
7879 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
7766f137
GS		 7880 CvROOT(cv)->op_private |= OPpREFCOUNTED;
7881 OpREFCNT_set(CvROOT(cv), 1);
8be227ab
FC		 7882 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
7883 itself has a refcount. */
7884 CvSLABBED_off(cv);
7885 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
7aef8e5b 7886#ifdef PERL_DEBUG_READONLY_OPS
3107b51f 7887 slab = (OPSLAB *)CvSTART(cv);
8be227ab 7888#endif
7766f137
GS		 7889 CvSTART(cv) = LINKLIST(CvROOT(cv));
7890 CvROOT(cv)->op_next = 0;
a2efc822 7891 CALL_PEEP(CvSTART(cv));
d164302a 7892 finalize_optree(CvROOT(cv));
7766f137
GS		 7893
7894 /* now that optimizer has done its work, adjust pad values */
54310121 7895
dd2155a4
DM		 7896 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
7897
fb834abd
FC		 7898 attrs:
7899 if (attrs) {
7900 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
7901 HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
12d3c230 7902 if (!name) SAVEFREESV(cv);
ad0dc73b 7903 apply_attrs(stash, MUTABLE_SV(cv), attrs);
12d3c230 7904 if (!name) SvREFCNT_inc_simple_void_NN(cv);
fb834abd
FC		 7905 }
7906
7907 if (block && has_name) {
3280af22 7908 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
c4420975 7909 SV * const tmpstr = sv_newmortal();
5c1737d1
NC		 7910 GV * const db_postponed = gv_fetchpvs("DB::postponed",
7911 GV_ADDMULTI, SVt_PVHV);
44a8e56a 7912 HV *hv;
b081dd7e
NC		 7913 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
7914 CopFILE(PL_curcop),
7915 (long)PL_subline,
7916 (long)CopLINE(PL_curcop));
bd61b366 7917 gv_efullname3(tmpstr, gv, NULL);
04fe65b0 7918 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
c60dbbc3 7919 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
44a8e56a 7920 hv = GvHVn(db_postponed);
c60dbbc3 7921 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
551405c4
AL		 7922 CV * const pcv = GvCV(db_postponed);
7923 if (pcv) {
7924 dSP;
7925 PUSHMARK(SP);
7926 XPUSHs(tmpstr);
7927 PUTBACK;
ad64d0ec 7928 call_sv(MUTABLE_SV(pcv), G_DISCARD);
551405c4 7929 }
44a8e56a 7930 }
7931 }
79072805 7932
13765c85 7933 if (name && ! (PL_parser && PL_parser->error_count))
d699ecb7 7934 process_special_blocks(floor, name, gv, cv);
33fb7a6e 7935 }
ed094faf 7936
33fb7a6e 7937 done:
53a7735b
DM		 7938 if (PL_parser)
7939 PL_parser->copline = NOLINE;
33fb7a6e 7940 LEAVE_SCOPE(floor);
7aef8e5b 7941#ifdef PERL_DEBUG_READONLY_OPS
3107b51f
FC		 7942 /* Watch out for BEGIN blocks */
7943 if (slab && gv && isGV(gv) && GvCV(gv)) Slab_to_ro(slab);
7944#endif
33fb7a6e
NC		 7945 return cv;
7946}
ed094faf 7947
33fb7a6e 7948STATIC void
d699ecb7
FC		 7949S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
7950 GV *const gv,
33fb7a6e
NC		 7951 CV *const cv)
7952{
7953 const char *const colon = strrchr(fullname,':');
7954 const char *const name = colon ? colon + 1 : fullname;
7955
7918f24d
NC		 7956 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
7957
33fb7a6e 7958 if (*name == 'B') {
6952d67e 7959 if (strEQ(name, "BEGIN")) {
6867be6d 7960 const I32 oldscope = PL_scopestack_ix;
d699ecb7 7961 if (floor) LEAVE_SCOPE(floor);
28757baa 7962 ENTER;
57843af0
GS		 7963 SAVECOPFILE(&PL_compiling);
7964 SAVECOPLINE(&PL_compiling);
16c63275 7965 SAVEVPTR(PL_curcop);
28757baa 7966
a58fb6f9 7967 DEBUG_x( dump_sub(gv) );
ad64d0ec 7968 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
c43ae56f 7969 GvCV_set(gv,0); /* cv has been hijacked */
3280af22 7970 call_list(oldscope, PL_beginav);
a6006777 7971
28757baa 7972 LEAVE;
7973 }
33fb7a6e
NC		 7974 else
7975 return;
7976 } else {
7977 if (*name == 'E') {
7978 if strEQ(name, "END") {
a58fb6f9 7979 DEBUG_x( dump_sub(gv) );
ad64d0ec 7980 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
33fb7a6e
NC		 7981 } else
7982 return;
7983 } else if (*name == 'U') {
7984 if (strEQ(name, "UNITCHECK")) {
7985 /* It's never too late to run a unitcheck block */
ad64d0ec 7986 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
33fb7a6e
NC		 7987 }
7988 else
7989 return;
7990 } else if (*name == 'C') {
7991 if (strEQ(name, "CHECK")) {
a2a5de95 7992 if (PL_main_start)
dcbac5bb 7993 /* diag_listed_as: Too late to run %s block */
a2a5de95
NC		 7994 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
7995 "Too late to run CHECK block");
ad64d0ec 7996 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
33fb7a6e
NC		 7997 }
7998 else
7999 return;
8000 } else if (*name == 'I') {
8001 if (strEQ(name, "INIT")) {
a2a5de95 8002 if (PL_main_start)
dcbac5bb 8003 /* diag_listed_as: Too late to run %s block */
a2a5de95
NC		 8004 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
8005 "Too late to run INIT block");
ad64d0ec 8006 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
33fb7a6e
NC		 8007 }
8008 else
8009 return;
8010 } else
8011 return;
a58fb6f9 8012 DEBUG_x( dump_sub(gv) );
c43ae56f 8013 GvCV_set(gv,0); /* cv has been hijacked */
79072805 8014 }
79072805
LW		 8015}
8016
954c1994
GS		 8017/*
8018=for apidoc newCONSTSUB
8019
3453414d
BF		 8020See L</newCONSTSUB_flags>.
8021
8022=cut
8023*/
8024
8025CV *
8026Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
8027{
9c0a6090 8028 return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
3453414d
BF		 8029}
8030
8031/*
8032=for apidoc newCONSTSUB_flags
8033
954c1994
GS		 8034Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
8035eligible for inlining at compile-time.
8036
3453414d
BF		 8037Currently, the only useful value for C<flags> is SVf_UTF8.
8038
be8851fc
NC		 8039The newly created subroutine takes ownership of a reference to the passed in
8040SV.
8041
99ab892b
NC		 8042Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
8043which won't be called if used as a destructor, but will suppress the overhead
8044of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
8045compile time.)
8046
954c1994
GS		 8047=cut
8048*/
8049
beab0874 8050CV *
9c0a6090
FC		 8051Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
8052 U32 flags, SV *sv)
5476c433 8053{
27da23d5 8054 dVAR;
beab0874 8055 CV* cv;
54d012c6 8056 const char *const file = CopFILE(PL_curcop);
5476c433 8057
11faa288 8058 ENTER;
11faa288 8059
401667e9
DM		 8060 if (IN_PERL_RUNTIME) {
8061 /* at runtime, it's not safe to manipulate PL_curcop: it may be
8062 * an op shared between threads. Use a non-shared COP for our
8063 * dirty work */
8064 SAVEVPTR(PL_curcop);
08f1b312
FC		 8065 SAVECOMPILEWARNINGS();
8066 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
401667e9
DM		 8067 PL_curcop = &PL_compiling;
8068 }
f4dd75d9 8069 SAVECOPLINE(PL_curcop);
53a7735b 8070 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
f4dd75d9
GS		 8071
8072 SAVEHINTS();
3280af22 8073 PL_hints &= ~HINT_BLOCK_SCOPE;
11faa288
GS		 8074
8075 if (stash) {
03d9f026 8076 SAVEGENERICSV(PL_curstash);
03d9f026 8077 PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
11faa288 8078 }
5476c433 8079
95934569
FC		 8080 /* Protect sv against leakage caused by fatal warnings. */
8081 if (sv) SAVEFREESV(sv);
8082
bad4ae38 8083 /* file becomes the CvFILE. For an XS, it's usually static storage,
cbf82dd0
NC		 8084 and so doesn't get free()d. (It's expected to be from the C pre-
8085 processor __FILE__ directive). But we need a dynamically allocated one,
77004dee 8086 and we need it to get freed. */
6f1b3ab0
FC		 8087 cv = newXS_len_flags(name, len,
8088 sv && SvTYPE(sv) == SVt_PVAV
8089 ? const_av_xsub
8090 : const_sv_xsub,
8091 file ? file : "", "",
8f82b567 8092 &sv, XS_DYNAMIC_FILENAME | flags);
95934569 8093 CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
beab0874 8094 CvCONST_on(cv);
5476c433 8095
11faa288 8096 LEAVE;
beab0874
JT		 8097
8098 return cv;
5476c433
JD		 8099}
8100
77004dee
NC		 8101CV *
8102Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
8103 const char *const filename, const char *const proto,
8104 U32 flags)
8105{
032a0447
FC		 8106 PERL_ARGS_ASSERT_NEWXS_FLAGS;
8107 return newXS_len_flags(
8f82b567 8108 name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
032a0447
FC		 8109 );
8110}
8111
8112CV *
8113Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
8114 XSUBADDR_t subaddr, const char *const filename,
8f82b567
FC		 8115 const char *const proto, SV **const_svp,
8116 U32 flags)
032a0447 8117{
3453414d 8118 CV *cv;
77004dee 8119
032a0447 8120 PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
7918f24d 8121
3453414d 8122 {
9b566a5e
DD		 8123 GV * const gv = gv_fetchpvn(
8124 name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
8125 name ? len : PL_curstash ? sizeof("__ANON__") - 1:
8126 sizeof("__ANON__::__ANON__") - 1,
8127 GV_ADDMULTI | flags, SVt_PVCV);
3453414d
BF		 8128
8129 if (!subaddr)
8130 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
8131
8132 if ((cv = (name ? GvCV(gv) : NULL))) {
8133 if (GvCVGEN(gv)) {
8134 /* just a cached method */
8135 SvREFCNT_dec(cv);
8136 cv = NULL;
8137 }
8138 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
8139 /* already defined (or promised) */
18225a01 8140 /* Redundant check that allows us to avoid creating an SV
156d738f
FC		 8141 most of the time: */
8142 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
156d738f 8143 report_redefined_cv(newSVpvn_flags(
46538741 8144 name,len,(flags&SVf_UTF8)|SVs_TEMP
156d738f
FC		 8145 ),
8146 cv, const_svp);
3453414d 8147 }
7004ee49 8148 GvCV_set(gv,NULL);
fc2b2dca 8149 SvREFCNT_dec_NN(cv);
3453414d
BF		 8150 cv = NULL;
8151 }
8152 }
8153
8154 if (cv) /* must reuse cv if autoloaded */
8155 cv_undef(cv);
8156 else {
8157 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
8158 if (name) {
8159 GvCV_set(gv,cv);
8160 GvCVGEN(gv) = 0;
03d9f026 8161 if (HvENAME_HEK(GvSTASH(gv)))
978a498e 8162 gv_method_changed(gv); /* newXS */
3453414d
BF		 8163 }
8164 }
8165 if (!name)
8166 CvANON_on(cv);
8167 CvGV_set(cv, gv);
8168 (void)gv_fetchfile(filename);
8169 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
8170 an external constant string */
8171 assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
8172 CvISXSUB_on(cv);
8173 CvXSUB(cv) = subaddr;
8174
8175 if (name)
d699ecb7 8176 process_special_blocks(0, name, gv, cv);
3453414d
BF		 8177 }
8178
77004dee 8179 if (flags & XS_DYNAMIC_FILENAME) {
bad4ae38
FC		 8180 CvFILE(cv) = savepv(filename);
8181 CvDYNFILE_on(cv);
77004dee 8182 }
bad4ae38 8183 sv_setpv(MUTABLE_SV(cv), proto);
77004dee
NC		 8184 return cv;
8185}
8186
186a5ba8
FC		 8187CV *
8188Perl_newSTUB(pTHX_ GV *gv, bool fake)
8189{
eb578fdb 8190 CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
2f222bbd 8191 GV *cvgv;
186a5ba8
FC		 8192 PERL_ARGS_ASSERT_NEWSTUB;
8193 assert(!GvCVu(gv));
8194 GvCV_set(gv, cv);
8195 GvCVGEN(gv) = 0;
8196 if (!fake && HvENAME_HEK(GvSTASH(gv)))
978a498e 8197 gv_method_changed(gv);
2f222bbd
FC		 8198 if (SvFAKE(gv)) {
8199 cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
8200 SvFAKE_off(cvgv);
8201 }
8202 else cvgv = gv;
8203 CvGV_set(cv, cvgv);
186a5ba8
FC		 8204 CvFILE_set_from_cop(cv, PL_curcop);
8205 CvSTASH_set(cv, PL_curstash);
8206 GvMULTI_on(gv);
8207 return cv;
8208}
8209
954c1994
GS		 8210/*
8211=for apidoc U||newXS
8212
77004dee
NC		 8213Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
8214static storage, as it is used directly as CvFILE(), without a copy being made.
954c1994
GS		 8215
8216=cut
8217*/
8218
57d3b86d 8219CV *
bfed75c6 8220Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
a0d0e21e 8221{
7918f24d 8222 PERL_ARGS_ASSERT_NEWXS;
ce9f52ad
FC		 8223 return newXS_len_flags(
8224 name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
8225 );
79072805
LW		 8226}
8227
eb8433b7
NC		 8228#ifdef PERL_MAD
8229OP *
8230#else
79072805 8231void
eb8433b7 8232#endif
864dbfa3 8233Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
79072805 8234{
97aff369 8235 dVAR;
eb578fdb 8236 CV *cv;
eb8433b7
NC		 8237#ifdef PERL_MAD
8238 OP* pegop = newOP(OP_NULL, 0);
8239#endif
79072805 8240
2c658e55
FC		 8241 GV *gv;
8242
8243 if (PL_parser && PL_parser->error_count) {
8244 op_free(block);
8245 goto finish;
8246 }
8247
8248 gv = o
f776e3cd 8249 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
fafc274c 8250 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
0bd48802 8251
a5f75d66 8252 GvMULTI_on(gv);
155aba94 8253 if ((cv = GvFORM(gv))) {
599cee73 8254 if (ckWARN(WARN_REDEFINE)) {
6867be6d 8255 const line_t oldline = CopLINE(PL_curcop);
53a7735b
DM		 8256 if (PL_parser && PL_parser->copline != NOLINE)
8257 CopLINE_set(PL_curcop, PL_parser->copline);
ee6d2783
NC		 8258 if (o) {
8259 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
8260 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
8261 } else {
dcbac5bb 8262 /* diag_listed_as: Format %s redefined */
ee6d2783
NC		 8263 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
8264 "Format STDOUT redefined");
8265 }
57843af0 8266 CopLINE_set(PL_curcop, oldline);
79072805 8267 }
8990e307 8268 SvREFCNT_dec(cv);
79072805 8269 }
3280af22 8270 cv = PL_compcv;
2c658e55 8271 GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
b3f91e91 8272 CvGV_set(cv, gv);
a636914a 8273 CvFILE_set_from_cop(cv, PL_curcop);
79072805 8274
a0d0e21e 8275
dd2155a4 8276 pad_tidy(padtidy_FORMAT);
79072805 8277 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
7934575e
GS		 8278 CvROOT(cv)->op_private |= OPpREFCOUNTED;
8279 OpREFCNT_set(CvROOT(cv), 1);
79072805
LW		 8280 CvSTART(cv) = LINKLIST(CvROOT(cv));
8281 CvROOT(cv)->op_next = 0;
a2efc822 8282 CALL_PEEP(CvSTART(cv));
aee4f072 8283 finalize_optree(CvROOT(cv));
2c658e55
FC		 8284 cv_forget_slab(cv);
8285
8286 finish:
eb8433b7
NC		 8287#ifdef PERL_MAD
8288 op_getmad(o,pegop,'n');
8289 op_getmad_weak(block, pegop, 'b');
8290#else
11343788 8291 op_free(o);
eb8433b7 8292#endif
53a7735b
DM		 8293 if (PL_parser)
8294 PL_parser->copline = NOLINE;
8990e307 8295 LEAVE_SCOPE(floor);
eb8433b7
NC		 8296#ifdef PERL_MAD
8297 return pegop;
8298#endif
79072805
LW		 8299}
8300
8301OP *
864dbfa3 8302Perl_newANONLIST(pTHX_ OP *o)
79072805 8303{
78c72037 8304 return convert(OP_ANONLIST, OPf_SPECIAL, o);
79072805
LW		 8305}
8306
8307OP *
864dbfa3 8308Perl_newANONHASH(pTHX_ OP *o)
79072805 8309{
78c72037 8310 return convert(OP_ANONHASH, OPf_SPECIAL, o);
a0d0e21e
LW		 8311}
8312
8313OP *
864dbfa3 8314Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
a0d0e21e 8315{
5f66b61c 8316 return newANONATTRSUB(floor, proto, NULL, block);
09bef843
SB		 8317}
8318
8319OP *
8320Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
8321{
a0d0e21e 8322 return newUNOP(OP_REFGEN, 0,
09bef843 8323 newSVOP(OP_ANONCODE, 0,
ad64d0ec 8324 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
79072805
LW		 8325}
8326
8327OP *
864dbfa3 8328Perl_oopsAV(pTHX_ OP *o)
79072805 8329{
27da23d5 8330 dVAR;
7918f24d
NC		 8331
8332 PERL_ARGS_ASSERT_OOPSAV;
8333
ed6116ce
LW		 8334 switch (o->op_type) {
8335 case OP_PADSV:
6dd3e0f2 8336 case OP_PADHV:
ed6116ce 8337 o->op_type = OP_PADAV;
22c35a8c 8338 o->op_ppaddr = PL_ppaddr[OP_PADAV];
51e247a3 8339 return ref(o, OP_RV2AV);
b2ffa427 8340
ed6116ce 8341 case OP_RV2SV:
6dd3e0f2 8342 case OP_RV2HV:
79072805 8343 o->op_type = OP_RV2AV;
22c35a8c 8344 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
79072805 8345 ref(o, OP_RV2AV);
ed6116ce
LW		 8346 break;
8347
8348 default:
9b387841 8349 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
ed6116ce
LW		 8350 break;
8351 }
79072805
LW		 8352 return o;
8353}
8354
8355OP *
864dbfa3 8356Perl_oopsHV(pTHX_ OP *o)
79072805 8357{
27da23d5 8358 dVAR;
7918f24d
NC		 8359
8360 PERL_ARGS_ASSERT_OOPSHV;
8361
ed6116ce
LW		 8362 switch (o->op_type) {
8363 case OP_PADSV:
8364 case OP_PADAV:
8365 o->op_type = OP_PADHV;
22c35a8c 8366 o->op_ppaddr = PL_ppaddr[OP_PADHV];
51e247a3 8367 return ref(o, OP_RV2HV);
ed6116ce
LW		 8368
8369 case OP_RV2SV:
8370 case OP_RV2AV:
79072805 8371 o->op_type = OP_RV2HV;
22c35a8c 8372 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
79072805 8373 ref(o, OP_RV2HV);
ed6116ce
LW		 8374 break;
8375
8376 default:
9b387841 8377 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
ed6116ce
LW		 8378 break;
8379 }
79072805
LW		 8380 return o;
8381}
8382
8383OP *
864dbfa3 8384Perl_newAVREF(pTHX_ OP *o)
79072805 8385{
27da23d5 8386 dVAR;
7918f24d
NC		 8387
8388 PERL_ARGS_ASSERT_NEWAVREF;
8389
ed6116ce
LW		 8390 if (o->op_type == OP_PADANY) {
8391 o->op_type = OP_PADAV;
22c35a8c 8392 o->op_ppaddr = PL_ppaddr[OP_PADAV];
93a17b20 8393 return o;
ed6116ce 8394 }
a2a5de95 8395 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
d1d15184 8396 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
a2a5de95 8397 "Using an array as a reference is deprecated");
a1063b2d 8398 }
79072805
LW		 8399 return newUNOP(OP_RV2AV, 0, scalar(o));
8400}
8401
8402OP *
864dbfa3 8403Perl_newGVREF(pTHX_ I32 type, OP *o)
79072805 8404{
82092f1d 8405 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
a0d0e21e 8406 return newUNOP(OP_NULL, 0, o);
748a9306 8407 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
79072805
LW		 8408}
8409
8410OP *
864dbfa3 8411Perl_newHVREF(pTHX_ OP *o)
79072805 8412{
27da23d5 8413 dVAR;
7918f24d
NC		 8414
8415 PERL_ARGS_ASSERT_NEWHVREF;
8416
ed6116ce
LW		 8417 if (o->op_type == OP_PADANY) {
8418 o->op_type = OP_PADHV;
22c35a8c 8419 o->op_ppaddr = PL_ppaddr[OP_PADHV];
93a17b20 8420 return o;
ed6116ce 8421 }
a2a5de95 8422 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
d1d15184 8423 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
a2a5de95 8424 "Using a hash as a reference is deprecated");
a1063b2d 8425 }
79072805
LW		 8426 return newUNOP(OP_RV2HV, 0, scalar(o));
8427}
8428
8429OP *
864dbfa3 8430Perl_newCVREF(pTHX_ I32 flags, OP *o)
79072805 8431{
97b03d64 8432 if (o->op_type == OP_PADANY) {
c04ef36e 8433 dVAR;
97b03d64
FC		 8434 o->op_type = OP_PADCV;
8435 o->op_ppaddr = PL_ppaddr[OP_PADCV];
8436 }
c07a80fd 8437 return newUNOP(OP_RV2CV, flags, scalar(o));
79072805
LW		 8438}
8439
8440OP *
864dbfa3 8441Perl_newSVREF(pTHX_ OP *o)
79072805 8442{
27da23d5 8443 dVAR;
7918f24d
NC		 8444
8445 PERL_ARGS_ASSERT_NEWSVREF;
8446
ed6116ce
LW		 8447 if (o->op_type == OP_PADANY) {
8448 o->op_type = OP_PADSV;
22c35a8c 8449 o->op_ppaddr = PL_ppaddr[OP_PADSV];
93a17b20 8450 return o;
ed6116ce 8451 }
79072805
LW		 8452 return newUNOP(OP_RV2SV, 0, scalar(o));
8453}
8454
61b743bb
DM		 8455/* Check routines. See the comments at the top of this file for details
8456 * on when these are called */
79072805
LW		 8457
8458OP *
cea2e8a9 8459Perl_ck_anoncode(pTHX_ OP *o)
5f05dabc 8460{
7918f24d
NC		 8461 PERL_ARGS_ASSERT_CK_ANONCODE;
8462
cc76b5cc 8463 cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
eb8433b7 8464 if (!PL_madskills)
1d866c12 8465 cSVOPo->op_sv = NULL;
5dc0d613 8466 return o;
5f05dabc 8467}
8468
9ce1fb7d
FC		 8469static void
8470S_io_hints(pTHX_ OP *o)
8471{
8472 HV * const table =
8473 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
8474 if (table) {
8475 SV **svp = hv_fetchs(table, "open_IN", FALSE);
8476 if (svp && *svp) {
8477 STRLEN len = 0;
8478 const char *d = SvPV_const(*svp, len);
8479 const I32 mode = mode_from_discipline(d, len);
8480 if (mode & O_BINARY)
8481 o->op_private |= OPpOPEN_IN_RAW;
8482 else if (mode & O_TEXT)
8483 o->op_private |= OPpOPEN_IN_CRLF;
8484 }
8485
8486 svp = hv_fetchs(table, "open_OUT", FALSE);
8487 if (svp && *svp) {
8488 STRLEN len = 0;
8489 const char *d = SvPV_const(*svp, len);
8490 const I32 mode = mode_from_discipline(d, len);
8491 if (mode & O_BINARY)
8492 o->op_private |= OPpOPEN_OUT_RAW;
8493 else if (mode & O_TEXT)
8494 o->op_private |= OPpOPEN_OUT_CRLF;
8495 }
8496 }
8497}
8498
8499OP *
8500Perl_ck_backtick(pTHX_ OP *o)
8501{
6a5c965b
FC		 8502 GV *gv;
8503 OP *newop = NULL;
9ce1fb7d 8504 PERL_ARGS_ASSERT_CK_BACKTICK;
6a5c965b
FC		 8505 /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
8506 if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_sibling
8507 && (gv = gv_override("readpipe",8))) {
aff26e98 8508 newop = S_new_entersubop(aTHX_ gv, cUNOPo->op_first->op_sibling);
6a5c965b
FC		 8509 cUNOPo->op_first->op_sibling = NULL;
8510 }
8511 else if (!(o->op_flags & OPf_KIDS))
8512 newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
8513 if (newop) {
9ce1fb7d
FC		 8514#ifdef PERL_MAD
8515 op_getmad(o,newop,'O');
8516#else
8517 op_free(o);
8518#endif
8519 return newop;
8520 }
6a5c965b 8521 S_io_hints(aTHX_ o);
9ce1fb7d
FC		 8522 return o;
8523}
8524
5f05dabc 8525OP *
cea2e8a9 8526Perl_ck_bitop(pTHX_ OP *o)
55497cff 8527{
97aff369 8528 dVAR;
7918f24d
NC		 8529
8530 PERL_ARGS_ASSERT_CK_BITOP;
8531
d5ec2987 8532 o->op_private = (U8)(PL_hints & HINT_INTEGER);
2b84528b
RGS		 8533 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
8534 && (o->op_type == OP_BIT_OR
8535 || o->op_type == OP_BIT_AND
8536 || o->op_type == OP_BIT_XOR))
276b2a0c 8537 {
1df70142
AL		 8538 const OP * const left = cBINOPo->op_first;
8539 const OP * const right = left->op_sibling;
96a925ab
YST		 8540 if ((OP_IS_NUMCOMPARE(left->op_type) &&
8541 (left->op_flags & OPf_PARENS) == 0) ||
8542 (OP_IS_NUMCOMPARE(right->op_type) &&
8543 (right->op_flags & OPf_PARENS) == 0))
a2a5de95
NC		 8544 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
8545 "Possible precedence problem on bitwise %c operator",
8546 o->op_type == OP_BIT_OR ? '|'
8547 : o->op_type == OP_BIT_AND ? '&' : '^'
8548 );
276b2a0c 8549 }
5dc0d613 8550 return o;
55497cff 8551}
8552
89474f50
FC		 8553PERL_STATIC_INLINE bool
8554is_dollar_bracket(pTHX_ const OP * const o)
8555{
8556 const OP *kid;
8557 return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
8558 && (kid = cUNOPx(o)->op_first)
8559 && kid->op_type == OP_GV
8560 && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
8561}
8562
8563OP *
8564Perl_ck_cmp(pTHX_ OP *o)
8565{
8566 PERL_ARGS_ASSERT_CK_CMP;
8567 if (ckWARN(WARN_SYNTAX)) {
8568 const OP *kid = cUNOPo->op_first;
8569 if (kid && (
7c2b3c78
FC		 8570 (
8571 is_dollar_bracket(aTHX_ kid)
8572 && kid->op_sibling && kid->op_sibling->op_type == OP_CONST
8573 )
8574 || ( kid->op_type == OP_CONST
8575 && (kid = kid->op_sibling) && is_dollar_bracket(aTHX_ kid))
89474f50
FC		 8576 ))
8577 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
8578 "$[ used in %s (did you mean $] ?)", OP_DESC(o));
8579 }
8580 return o;
8581}
8582
55497cff 8583OP *
cea2e8a9 8584Perl_ck_concat(pTHX_ OP *o)
79072805 8585{
0bd48802 8586 const OP * const kid = cUNOPo->op_first;
7918f24d
NC		 8587
8588 PERL_ARGS_ASSERT_CK_CONCAT;
96a5add6 8589 PERL_UNUSED_CONTEXT;
7918f24d 8590
df91b2c5
AE		 8591 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
8592 !(kUNOP->op_first->op_flags & OPf_MOD))
0165acc7 8593 o->op_flags |= OPf_STACKED;
11343788 8594 return o;
79072805
LW		 8595}
8596
8597OP *
cea2e8a9 8598Perl_ck_spair(pTHX_ OP *o)
79072805 8599{
27da23d5 8600 dVAR;
7918f24d
NC		 8601
8602 PERL_ARGS_ASSERT_CK_SPAIR;
8603
11343788 8604 if (o->op_flags & OPf_KIDS) {
79072805 8605 OP* newop;
a0d0e21e 8606 OP* kid;
6867be6d 8607 const OPCODE type = o->op_type;
5dc0d613 8608 o = modkids(ck_fun(o), type);
11343788 8609 kid = cUNOPo->op_first;
a0d0e21e 8610 newop = kUNOP->op_first->op_sibling;
1496a290
AL		 8611 if (newop) {
8612 const OPCODE type = newop->op_type;
8613 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
8614 type == OP_PADAV || type == OP_PADHV ||
8615 type == OP_RV2AV || type == OP_RV2HV)
8616 return o;
a0d0e21e 8617 }
eb8433b7
NC		 8618#ifdef PERL_MAD
8619 op_getmad(kUNOP->op_first,newop,'K');
8620#else
a0d0e21e 8621 op_free(kUNOP->op_first);
eb8433b7 8622#endif
a0d0e21e
LW		 8623 kUNOP->op_first = newop;
8624 }
707b805e
RGS		 8625 /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
8626 * and OP_CHOMP into OP_SCHOMP */
22c35a8c 8627 o->op_ppaddr = PL_ppaddr[++o->op_type];
11343788 8628 return ck_fun(o);
a0d0e21e
LW		 8629}
8630
8631OP *
cea2e8a9 8632Perl_ck_delete(pTHX_ OP *o)
a0d0e21e 8633{
7918f24d
NC		 8634 PERL_ARGS_ASSERT_CK_DELETE;
8635
11343788 8636 o = ck_fun(o);
5dc0d613 8637 o->op_private = 0;
11343788 8638 if (o->op_flags & OPf_KIDS) {
551405c4 8639 OP * const kid = cUNOPo->op_first;
01020589
GS		 8640 switch (kid->op_type) {
8641 case OP_ASLICE:
8642 o->op_flags |= OPf_SPECIAL;
8643 /* FALL THROUGH */
8644 case OP_HSLICE:
5dc0d613 8645 o->op_private |= OPpSLICE;
01020589
GS		 8646 break;
8647 case OP_AELEM:
8648 o->op_flags |= OPf_SPECIAL;
8649 /* FALL THROUGH */
8650 case OP_HELEM:
8651 break;
6dd3e0f2 8652 case OP_KVASLICE:
0ffcbc25
FC		 8653 Perl_croak(aTHX_ "delete argument is index/value array slice,"
8654 " use array slice");
5cae3edb 8655 case OP_KVHSLICE:
0ffcbc25
FC		 8656 Perl_croak(aTHX_ "delete argument is key/value hash slice, use"
8657 " hash slice");
01020589 8658 default:
0ffcbc25
FC		 8659 Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
8660 "element or slice");
01020589 8661 }
7332a6c4
VP		 8662 if (kid->op_private & OPpLVAL_INTRO)
8663 o->op_private |= OPpLVAL_INTRO;
93c66552 8664 op_null(kid);
79072805 8665 }
11343788 8666 return o;
79072805
LW		 8667}
8668
8669OP *
cea2e8a9 8670Perl_ck_eof(pTHX_ OP *o)
79072805 8671{
97aff369 8672 dVAR;
79072805 8673
7918f24d
NC		 8674 PERL_ARGS_ASSERT_CK_EOF;
8675
11343788 8676 if (o->op_flags & OPf_KIDS) {
3500db16 8677 OP *kid;
11343788 8678 if (cLISTOPo->op_first->op_type == OP_STUB) {
1d866c12
AL		 8679 OP * const newop
8680 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
eb8433b7
NC		 8681#ifdef PERL_MAD
8682 op_getmad(o,newop,'O');
8683#else
11343788 8684 op_free(o);
eb8433b7
NC		 8685#endif
8686 o = newop;
8990e307 8687 }
3500db16
FC		 8688 o = ck_fun(o);
8689 kid = cLISTOPo->op_first;
8690 if (kid->op_type == OP_RV2GV)
8691 kid->op_private |= OPpALLOW_FAKE;
79072805 8692 }
11343788 8693 return o;
79072805
LW		 8694}
8695
8696OP *
cea2e8a9 8697Perl_ck_eval(pTHX_ OP *o)
79072805 8698{
27da23d5 8699 dVAR;
7918f24d
NC		 8700
8701 PERL_ARGS_ASSERT_CK_EVAL;
8702
3280af22 8703 PL_hints |= HINT_BLOCK_SCOPE;
11343788 8704 if (o->op_flags & OPf_KIDS) {
46c461b5 8705 SVOP * const kid = (SVOP*)cUNOPo->op_first;
cb2dcfb2 8706 assert(kid);
79072805 8707
cb2dcfb2 8708 if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
79072805 8709 LOGOP *enter;
eb8433b7 8710#ifdef PERL_MAD
1d866c12 8711 OP* const oldo = o;
eb8433b7 8712#endif
79072805 8713
11343788 8714 cUNOPo->op_first = 0;
eb8433b7 8715#ifndef PERL_MAD
11343788 8716 op_free(o);
eb8433b7 8717#endif
79072805 8718
b7dc083c 8719 NewOp(1101, enter, 1, LOGOP);
79072805 8720 enter->op_type = OP_ENTERTRY;
22c35a8c 8721 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
79072805
LW		 8722 enter->op_private = 0;
8723
8724 /* establish postfix order */
8725 enter->op_next = (OP*)enter;
8726
2fcb4757 8727 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
11343788 8728 o->op_type = OP_LEAVETRY;
22c35a8c 8729 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
11343788 8730 enter->op_other = o;
eb8433b7 8731 op_getmad(oldo,o,'O');
11343788 8732 return o;
79072805 8733 }
b5c19bd7 8734 else {
473986ff 8735 scalar((OP*)kid);
b5c19bd7
DM		 8736 PL_cv_has_eval = 1;
8737 }
79072805
LW		 8738 }
8739 else {
a4a3cf74 8740 const U8 priv = o->op_private;
eb8433b7 8741#ifdef PERL_MAD
1d866c12 8742 OP* const oldo = o;
eb8433b7 8743#else
11343788 8744 op_free(o);
eb8433b7 8745#endif
7d789282 8746 o = newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
eb8433b7 8747 op_getmad(oldo,o,'O');
79072805 8748 }
3280af22 8749 o->op_targ = (PADOFFSET)PL_hints;
547ae129 8750 if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
7d789282
FC		 8751 if ((PL_hints & HINT_LOCALIZE_HH) != 0
8752 && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
996c9baa
VP		 8753 /* Store a copy of %^H that pp_entereval can pick up. */
8754 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
defdfed5 8755 MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
0d863452
RH		 8756 cUNOPo->op_first->op_sibling = hhop;
8757 o->op_private |= OPpEVAL_HAS_HH;
915a83fe
FC		 8758 }
8759 if (!(o->op_private & OPpEVAL_BYTES)
2846acbf 8760 && FEATURE_UNIEVAL_IS_ENABLED)
802a15e9 8761 o->op_private |= OPpEVAL_UNICODE;
11343788 8762 return o;
79072805
LW		 8763}
8764
8765OP *
cea2e8a9 8766Perl_ck_exec(pTHX_ OP *o)
79072805 8767{
7918f24d
NC		 8768 PERL_ARGS_ASSERT_CK_EXEC;
8769
11343788 8770 if (o->op_flags & OPf_STACKED) {
6867be6d 8771 OP *kid;
11343788
MB		 8772 o = ck_fun(o);
8773 kid = cUNOPo->op_first->op_sibling;
8990e307 8774 if (kid->op_type == OP_RV2GV)
93c66552 8775 op_null(kid);
79072805 8776 }
463ee0b2 8777 else
11343788
MB		 8778 o = listkids(o);
8779 return o;
79072805
LW		 8780}
8781
8782OP *
cea2e8a9 8783Perl_ck_exists(pTHX_ OP *o)
5f05dabc 8784{
97aff369 8785 dVAR;
7918f24d
NC		 8786
8787 PERL_ARGS_ASSERT_CK_EXISTS;
8788
5196be3e
MB		 8789 o = ck_fun(o);
8790 if (o->op_flags & OPf_KIDS) {
46c461b5 8791 OP * const kid = cUNOPo->op_first;
afebc493
GS		 8792 if (kid->op_type == OP_ENTERSUB) {
8793 (void) ref(kid, o->op_type);
13765c85
DM		 8794 if (kid->op_type != OP_RV2CV
8795 && !(PL_parser && PL_parser->error_count))
0ffcbc25
FC		 8796 Perl_croak(aTHX_
8797 "exists argument is not a subroutine name");
afebc493
GS		 8798 o->op_private |= OPpEXISTS_SUB;
8799 }
8800 else if (kid->op_type == OP_AELEM)
01020589
GS		 8801 o->op_flags |= OPf_SPECIAL;
8802 else if (kid->op_type != OP_HELEM)
0ffcbc25
FC		 8803 Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
8804 "element or a subroutine");
93c66552 8805 op_null(kid);
5f05dabc 8806 }
5196be3e 8807 return o;
5f05dabc 8808}
8809
79072805 8810OP *
5aaab254 8811Perl_ck_rvconst(pTHX_ OP *o)
79072805 8812{
27da23d5 8813 dVAR;
0bd48802 8814 SVOP * const kid = (SVOP*)cUNOPo->op_first;
85e6fe83 8815
7918f24d
NC		 8816 PERL_ARGS_ASSERT_CK_RVCONST;
8817
3280af22 8818 o->op_private |= (PL_hints & HINT_STRICT_REFS);
e26df76a
NC		 8819 if (o->op_type == OP_RV2CV)
8820 o->op_private &= ~1;
8821
79072805 8822 if (kid->op_type == OP_CONST) {
44a8e56a 8823 int iscv;
8824 GV *gv;
504618e9 8825 SV * const kidsv = kid->op_sv;
44a8e56a 8826
779c5bc9
GS		 8827 /* Is it a constant from cv_const_sv()? */
8828 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
0bd48802 8829 SV * const rsv = SvRV(kidsv);
42d0e0b7 8830 const svtype type = SvTYPE(rsv);
bd61b366 8831 const char *badtype = NULL;
779c5bc9
GS		 8832
8833 switch (o->op_type) {
8834 case OP_RV2SV:
42d0e0b7 8835 if (type > SVt_PVMG)
779c5bc9
GS		 8836 badtype = "a SCALAR";
8837 break;
8838 case OP_RV2AV:
42d0e0b7 8839 if (type != SVt_PVAV)
779c5bc9
GS		 8840 badtype = "an ARRAY";
8841 break;
8842 case OP_RV2HV:
42d0e0b7 8843 if (type != SVt_PVHV)
779c5bc9 8844 badtype = "a HASH";
779c5bc9
GS		 8845 break;
8846 case OP_RV2CV:
42d0e0b7 8847 if (type != SVt_PVCV)
779c5bc9
GS		 8848 badtype = "a CODE";
8849 break;
8850 }
8851 if (badtype)
cea2e8a9 8852 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
779c5bc9
GS		 8853 return o;
8854 }
f815dc14 8855 if (SvTYPE(kidsv) == SVt_PVAV) return o;
ce10b5d1 8856 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5f66b61c 8857 const char *badthing;
5dc0d613 8858 switch (o->op_type) {
44a8e56a 8859 case OP_RV2SV:
8860 badthing = "a SCALAR";
8861 break;
8862 case OP_RV2AV:
8863 badthing = "an ARRAY";
8864 break;
8865 case OP_RV2HV:
8866 badthing = "a HASH";
8867 break;
5f66b61c
AL		 8868 default:
8869 badthing = NULL;
8870 break;
44a8e56a 8871 }
8872 if (badthing)
1c846c1f 8873 Perl_croak(aTHX_
95b63a38 8874 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
be2597df 8875 SVfARG(kidsv), badthing);
44a8e56a 8876 }
93233ece
CS		 8877 /*
8878 * This is a little tricky. We only want to add the symbol if we
8879 * didn't add it in the lexer. Otherwise we get duplicate strict
8880 * warnings. But if we didn't add it in the lexer, we must at
8881 * least pretend like we wanted to add it even if it existed before,
8882 * or we get possible typo warnings. OPpCONST_ENTERED says
8883 * whether the lexer already added THIS instance of this symbol.
8884 */
5196be3e 8885 iscv = (o->op_type == OP_RV2CV) * 2;
93233ece 8886 do {
7a5fd60d 8887 gv = gv_fetchsv(kidsv,
748a9306 8888 iscv | !(kid->op_private & OPpCONST_ENTERED),
a0d0e21e
LW		 8889 iscv
8890 ? SVt_PVCV
11343788 8891 : o->op_type == OP_RV2SV
a0d0e21e 8892 ? SVt_PV
11343788 8893 : o->op_type == OP_RV2AV
a0d0e21e 8894 ? SVt_PVAV
11343788 8895 : o->op_type == OP_RV2HV
a0d0e21e
LW		 8896 ? SVt_PVHV
8897 : SVt_PVGV);
93233ece
CS		 8898 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
8899 if (gv) {
8900 kid->op_type = OP_GV;
8901 SvREFCNT_dec(kid->op_sv);
350de78d 8902#ifdef USE_ITHREADS
638eceb6 8903 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
653e8c97 8904 assert (sizeof(PADOP) <= sizeof(SVOP));
350de78d 8905 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
dd2155a4 8906 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
743e66e6 8907 GvIN_PAD_on(gv);
ad64d0ec 8908 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
350de78d 8909#else
b37c2d43 8910 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
350de78d 8911#endif
23f1ca44 8912 kid->op_private = 0;
76cd736e 8913 kid->op_ppaddr = PL_ppaddr[OP_GV];
2acc3314
FC		 8914 /* FAKE globs in the symbol table cause weird bugs (#77810) */
8915 SvFAKE_off(gv);
a0d0e21e 8916 }
79072805 8917 }
11343788 8918 return o;
79072805
LW		 8919}
8920
8921OP *
cea2e8a9 8922Perl_ck_ftst(pTHX_ OP *o)
79072805 8923{
27da23d5 8924 dVAR;
6867be6d 8925 const I32 type = o->op_type;
79072805 8926
7918f24d
NC		 8927 PERL_ARGS_ASSERT_CK_FTST;
8928
d0dca557 8929 if (o->op_flags & OPf_REF) {
6f207bd3 8930 NOOP;
d0dca557
JD		 8931 }
8932 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
551405c4 8933 SVOP * const kid = (SVOP*)cUNOPo->op_first;
1496a290 8934 const OPCODE kidtype = kid->op_type;
79072805 8935
9a0c9949 8936 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
3513c740 8937 && !kid->op_folded) {
551405c4 8938 OP * const newop = newGVOP(type, OPf_REF,
f776e3cd 8939 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
eb8433b7
NC		 8940#ifdef PERL_MAD
8941 op_getmad(o,newop,'O');
8942#else
11343788 8943 op_free(o);
eb8433b7 8944#endif
1d866c12 8945 return newop;
79072805 8946 }
6ecf81d6 8947 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
1af34c76 8948 o->op_private |= OPpFT_ACCESS;
ef69c8fc 8949 if (PL_check[kidtype] == Perl_ck_ftst
bbd91306 8950 && kidtype != OP_STAT && kidtype != OP_LSTAT) {
fbb0b3b3 8951 o->op_private |= OPpFT_STACKED;
bbd91306 8952 kid->op_private |= OPpFT_STACKING;
8db8f6b6
FC		 8953 if (kidtype == OP_FTTTY && (
8954 !(kid->op_private & OPpFT_STACKED)
8955 || kid->op_private & OPpFT_AFTER_t
8956 ))
8957 o->op_private |= OPpFT_AFTER_t;
bbd91306 8958 }
79072805
LW		 8959 }
8960 else {
eb8433b7 8961#ifdef PERL_MAD
1d866c12 8962 OP* const oldo = o;
eb8433b7 8963#else
11343788 8964 op_free(o);
eb8433b7 8965#endif
79072805 8966 if (type == OP_FTTTY)
8fde6460 8967 o = newGVOP(type, OPf_REF, PL_stdingv);
79072805 8968 else
d0dca557 8969 o = newUNOP(type, 0, newDEFSVOP());
eb8433b7 8970 op_getmad(oldo,o,'O');
79072805 8971 }
11343788 8972 return o;
79072805
LW		 8973}
8974
8975OP *
cea2e8a9 8976Perl_ck_fun(pTHX_ OP *o)
79072805 8977{
97aff369 8978 dVAR;
6867be6d 8979 const int type = o->op_type;
eb578fdb 8980 I32 oa = PL_opargs[type] >> OASHIFT;
aeea060c 8981
7918f24d
NC		 8982 PERL_ARGS_ASSERT_CK_FUN;
8983
11343788 8984 if (o->op_flags & OPf_STACKED) {
79072805
LW		 8985 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
8986 oa &= ~OA_OPTIONAL;
8987 else
11343788 8988 return no_fh_allowed(o);
79072805
LW		 8989 }
8990
11343788 8991 if (o->op_flags & OPf_KIDS) {
6867be6d 8992 OP **tokid = &cLISTOPo->op_first;
eb578fdb 8993 OP *kid = cLISTOPo->op_first;
6867be6d
AL		 8994 OP *sibl;
8995 I32 numargs = 0;
ea5703f4 8996 bool seen_optional = FALSE;
6867be6d 8997
8990e307 8998 if (kid->op_type == OP_PUSHMARK ||
155aba94 8999 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
8990e307 9000 {
79072805
LW		 9001 tokid = &kid->op_sibling;
9002 kid = kid->op_sibling;
9003 }
f6a16869
FC		 9004 if (kid && kid->op_type == OP_COREARGS) {
9005 bool optional = FALSE;
9006 while (oa) {
9007 numargs++;
9008 if (oa & OA_OPTIONAL) optional = TRUE;
9009 oa = oa >> 4;
9010 }
9011 if (optional) o->op_private |= numargs;
9012 return o;
9013 }
79072805 9014
ea5703f4 9015 while (oa) {
72ec8a82 9016 if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
ea5703f4
FC		 9017 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV)
9018 *tokid = kid = newDEFSVOP();
9019 seen_optional = TRUE;
9020 }
9021 if (!kid) break;
9022
79072805
LW		 9023 numargs++;
9024 sibl = kid->op_sibling;
eb8433b7
NC		 9025#ifdef PERL_MAD
9026 if (!sibl && kid->op_type == OP_STUB) {
9027 numargs--;
9028 break;
9029 }
9030#endif
79072805
LW		 9031 switch (oa & 7) {
9032 case OA_SCALAR:
62c18ce2
GS		 9033 /* list seen where single (scalar) arg expected? */
9034 if (numargs == 1 && !(oa >> 4)
9035 && kid->op_type == OP_LIST && type != OP_SCALAR)
9036 {
ce16c625 9037 return too_many_arguments_pv(o,PL_op_desc[type], 0);
62c18ce2 9038 }
2186f873 9039 if (type != OP_DELETE) scalar(kid);
79072805
LW		 9040 break;
9041 case OA_LIST:
9042 if (oa < 16) {
9043 kid = 0;
9044 continue;
9045 }
9046 else
9047 list(kid);
9048 break;
9049 case OA_AVREF:
936edb8b 9050 if ((type == OP_PUSH || type == OP_UNSHIFT)
a2a5de95
NC		 9051 && !kid->op_sibling)
9052 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
9053 "Useless use of %s with no values",
9054 PL_op_desc[type]);
b2ffa427 9055
79072805 9056 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 9057 (kid->op_private & OPpCONST_BARE))
9058 {
551405c4 9059 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
f776e3cd 9060 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
d1d15184 9061 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
a2a5de95
NC		 9062 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
9063 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
eb8433b7
NC		 9064#ifdef PERL_MAD
9065 op_getmad(kid,newop,'K');
9066#else
79072805 9067 op_free(kid);
eb8433b7 9068#endif
79072805
LW		 9069 kid = newop;
9070 kid->op_sibling = sibl;
9071 *tokid = kid;
9072 }
d4fc4415
FC		 9073 else if (kid->op_type == OP_CONST
9074 && ( !SvROK(cSVOPx_sv(kid))
9075 || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
9076 )
ce16c625 9077 bad_type_pv(numargs, "array", PL_op_desc[type], 0, kid);
d4fc4415
FC		 9078 /* Defer checks to run-time if we have a scalar arg */
9079 if (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV)
9080 op_lvalue(kid, type);
9081 else scalar(kid);
79072805
LW		 9082 break;
9083 case OA_HVREF:
9084 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 9085 (kid->op_private & OPpCONST_BARE))
9086 {
551405c4 9087 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
f776e3cd 9088 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
d1d15184 9089 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
a2a5de95
NC		 9090 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
9091 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
eb8433b7
NC		 9092#ifdef PERL_MAD
9093 op_getmad(kid,newop,'K');
9094#else
79072805 9095 op_free(kid);
eb8433b7 9096#endif
79072805
LW		 9097 kid = newop;
9098 kid->op_sibling = sibl;
9099 *tokid = kid;
9100 }
8990e307 9101 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
ce16c625 9102 bad_type_pv(numargs, "hash", PL_op_desc[type], 0, kid);
3ad73efd 9103 op_lvalue(kid, type);
79072805
LW		 9104 break;
9105 case OA_CVREF:
9106 {
551405c4 9107 OP * const newop = newUNOP(OP_NULL, 0, kid);
79072805 9108 kid->op_sibling = 0;
79072805
LW		 9109 newop->op_next = newop;
9110 kid = newop;
9111 kid->op_sibling = sibl;
9112 *tokid = kid;
9113 }
9114 break;
9115 case OA_FILEREF:
c340be78 9116 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
79072805 9117 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 9118 (kid->op_private & OPpCONST_BARE))
9119 {
0bd48802 9120 OP * const newop = newGVOP(OP_GV, 0,
f776e3cd 9121 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
afbdacea 9122 if (!(o->op_private & 1) && /* if not unop */
8a996ce8 9123 kid == cLISTOPo->op_last)
364daeac 9124 cLISTOPo->op_last = newop;
eb8433b7
NC		 9125#ifdef PERL_MAD
9126 op_getmad(kid,newop,'K');
9127#else
79072805 9128 op_free(kid);
eb8433b7 9129#endif
79072805
LW		 9130 kid = newop;
9131 }
1ea32a52
GS		 9132 else if (kid->op_type == OP_READLINE) {
9133 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
ce16c625 9134 bad_type_pv(numargs, "HANDLE", OP_DESC(o), 0, kid);
1ea32a52 9135 }
79072805 9136 else {
35cd451c 9137 I32 flags = OPf_SPECIAL;
a6c40364 9138 I32 priv = 0;
2c8ac474
GS		 9139 PADOFFSET targ = 0;
9140
35cd451c 9141 /* is this op a FH constructor? */
853846ea 9142 if (is_handle_constructor(o,numargs)) {
bd61b366 9143 const char *name = NULL;
dd2155a4 9144 STRLEN len = 0;
2dc9cdca 9145 U32 name_utf8 = 0;
885f468a 9146 bool want_dollar = TRUE;
2c8ac474
GS		 9147
9148 flags = 0;
9149 /* Set a flag to tell rv2gv to vivify
853846ea
NIS		 9150 * need to "prove" flag does not mean something
9151 * else already - NI-S 1999/05/07
2c8ac474
GS		 9152 */
9153 priv = OPpDEREF;
9154 if (kid->op_type == OP_PADSV) {
f8503592
NC		 9155 SV *const namesv
9156 = PAD_COMPNAME_SV(kid->op_targ);
9157 name = SvPV_const(namesv, len);
2dc9cdca 9158 name_utf8 = SvUTF8(namesv);
2c8ac474
GS		 9159 }
9160 else if (kid->op_type == OP_RV2SV
9161 && kUNOP->op_first->op_type == OP_GV)
9162 {
0bd48802 9163 GV * const gv = cGVOPx_gv(kUNOP->op_first);
2c8ac474
GS		 9164 name = GvNAME(gv);
9165 len = GvNAMELEN(gv);
2dc9cdca 9166 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
2c8ac474 9167 }
afd1915d
GS		 9168 else if (kid->op_type == OP_AELEM
9169 || kid->op_type == OP_HELEM)
9170 {
735fec84 9171 OP *firstop;
551405c4 9172 OP *op = ((BINOP*)kid)->op_first;
a4fc7abc 9173 name = NULL;
551405c4 9174 if (op) {
a0714e2c 9175 SV *tmpstr = NULL;
551405c4 9176 const char * const a =
666ea192
JH		 9177 kid->op_type == OP_AELEM ?
9178 "[]" : "{}";
0c4b0a3f
JH		 9179 if (((op->op_type == OP_RV2AV) ||
9180 (op->op_type == OP_RV2HV)) &&
735fec84
RGS		 9181 (firstop = ((UNOP*)op)->op_first) &&
9182 (firstop->op_type == OP_GV)) {
0c4b0a3f 9183 /* packagevar $a[] or $h{} */
735fec84 9184 GV * const gv = cGVOPx_gv(firstop);
0c4b0a3f
JH		 9185 if (gv)
9186 tmpstr =
9187 Perl_newSVpvf(aTHX_
9188 "%s%c...%c",
9189 GvNAME(gv),
9190 a[0], a[1]);
9191 }
9192 else if (op->op_type == OP_PADAV
9193 || op->op_type == OP_PADHV) {
9194 /* lexicalvar $a[] or $h{} */
551405c4 9195 const char * const padname =
0c4b0a3f
JH		 9196 PAD_COMPNAME_PV(op->op_targ);
9197 if (padname)
9198 tmpstr =
9199 Perl_newSVpvf(aTHX_
9200 "%s%c...%c",
9201 padname + 1,
9202 a[0], a[1]);
0c4b0a3f
JH		 9203 }
9204 if (tmpstr) {
93524f2b 9205 name = SvPV_const(tmpstr, len);
2dc9cdca 9206 name_utf8 = SvUTF8(tmpstr);
0c4b0a3f
JH		 9207 sv_2mortal(tmpstr);
9208 }
9209 }
9210 if (!name) {
9211 name = "__ANONIO__";
9212 len = 10;
885f468a 9213 want_dollar = FALSE;
0c4b0a3f 9214 }
3ad73efd 9215 op_lvalue(kid, type);
afd1915d 9216 }
2c8ac474
GS		 9217 if (name) {
9218 SV *namesv;
25451cef 9219 targ = pad_alloc(OP_RV2GV, SVf_READONLY);
dd2155a4 9220 namesv = PAD_SVl(targ);
885f468a 9221 if (want_dollar && *name != '$')
76f68e9b 9222 sv_setpvs(namesv, "$");
4f62cd62
FC		 9223 else
9224 sv_setpvs(namesv, "");
2c8ac474 9225 sv_catpvn(namesv, name, len);
2dc9cdca 9226 if ( name_utf8 ) SvUTF8_on(namesv);
2c8ac474 9227 }
853846ea 9228 }
79072805 9229 kid->op_sibling = 0;
35cd451c 9230 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
2c8ac474
GS		 9231 kid->op_targ = targ;
9232 kid->op_private |= priv;
79072805
LW		 9233 }
9234 kid->op_sibling = sibl;
9235 *tokid = kid;
9236 }
9237 scalar(kid);
9238 break;
9239 case OA_SCALARREF:
1efec5ed
FC		 9240 if ((type == OP_UNDEF || type == OP_POS)
9241 && numargs == 1 && !(oa >> 4)
89c5c07e
FC		 9242 && kid->op_type == OP_LIST)
9243 return too_many_arguments_pv(o,PL_op_desc[type], 0);
3ad73efd 9244 op_lvalue(scalar(kid), type);
79072805
LW		 9245 break;
9246 }
9247 oa >>= 4;
9248 tokid = &kid->op_sibling;
9249 kid = kid->op_sibling;
9250 }
eb8433b7
NC		 9251#ifdef PERL_MAD
9252 if (kid && kid->op_type != OP_STUB)
ce16c625 9253 return too_many_arguments_pv(o,OP_DESC(o), 0);
eb8433b7
NC		 9254 o->op_private |= numargs;
9255#else
9256 /* FIXME - should the numargs move as for the PERL_MAD case? */
11343788 9257 o->op_private |= numargs;
79072805 9258 if (kid)
ce16c625 9259 return too_many_arguments_pv(o,OP_DESC(o), 0);
eb8433b7 9260#endif
11343788 9261 listkids(o);
79072805 9262 }
22c35a8c 9263 else if (PL_opargs[type] & OA_DEFGV) {
c56915e3 9264#ifdef PERL_MAD
c7fe699d 9265 OP *newop = newUNOP(type, 0, newDEFSVOP());
c56915e3 9266 op_getmad(o,newop,'O');
c7fe699d 9267 return newop;
c56915e3 9268#else
c7fe699d 9269 /* Ordering of these two is important to keep f_map.t passing. */
11343788 9270 op_free(o);
c7fe699d 9271 return newUNOP(type, 0, newDEFSVOP());
c56915e3 9272#endif
a0d0e21e
LW		 9273 }
9274
79072805
LW		 9275 if (oa) {
9276 while (oa & OA_OPTIONAL)
9277 oa >>= 4;
9278 if (oa && oa != OA_LIST)
ce16c625 9279 return too_few_arguments_pv(o,OP_DESC(o), 0);
79072805 9280 }
11343788 9281 return o;
79072805
LW		 9282}
9283
9284OP *
cea2e8a9 9285Perl_ck_glob(pTHX_ OP *o)
79072805 9286{
27da23d5 9287 dVAR;
fb73857a 9288 GV *gv;
9289
7918f24d
NC		 9290 PERL_ARGS_ASSERT_CK_GLOB;
9291
649da076 9292 o = ck_fun(o);
1f2bfc8a 9293 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
bd31915d 9294 op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
fb73857a 9295
9e3fb20c 9296 if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
b9f751c0 9297 {
d1bea3d8
DM		 9298 /* convert
9299 * glob
9300 * \ null - const(wildcard)
9301 * into
9302 * null
9303 * \ enter
9304 * \ list
9305 * \ mark - glob - rv2cv
9306 * | \ gv(CORE::GLOBAL::glob)
9307 * |
9423a867 9308 * \ null - const(wildcard)
d1bea3d8
DM		 9309 */
9310 o->op_flags |= OPf_SPECIAL;
9426e1a5 9311 o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
aff26e98 9312 o = S_new_entersubop(aTHX_ gv, o);
7ae76aaa 9313 o = newUNOP(OP_NULL, 0, o);
d1bea3d8 9314 o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
d58bf5aa 9315 return o;
b1cb66bf 9316 }
d67594ff 9317 else o->op_flags &= ~OPf_SPECIAL;
39e3b1bc
FC		 9318#if !defined(PERL_EXTERNAL_GLOB)
9319 if (!PL_globhook) {
9320 ENTER;
9321 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
9322 newSVpvs("File::Glob"), NULL, NULL, NULL);
9323 LEAVE;
9324 }
9325#endif /* !PERL_EXTERNAL_GLOB */
e88567f2
FC		 9326 gv = (GV *)newSV(0);
9327 gv_init(gv, 0, "", 0, 0);
a0d0e21e 9328 gv_IOadd(gv);
2fcb4757 9329 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
fc2b2dca 9330 SvREFCNT_dec_NN(gv); /* newGVOP increased it */
11343788 9331 scalarkids(o);
649da076 9332 return o;
79072805
LW		 9333}
9334
9335OP *
cea2e8a9 9336Perl_ck_grep(pTHX_ OP *o)
79072805 9337{
27da23d5 9338 dVAR;
2471236a 9339 LOGOP *gwop;
79072805 9340 OP *kid;
6867be6d 9341 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
9f7d9405 9342 PADOFFSET offset;
79072805 9343
7918f24d
NC		 9344 PERL_ARGS_ASSERT_CK_GREP;
9345
22c35a8c 9346 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
13765c85 9347 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
aeea060c 9348
11343788 9349 if (o->op_flags & OPf_STACKED) {
2471236a 9350 kid = cUNOPx(cLISTOPo->op_first->op_sibling)->op_first;
f6435df3
GG		 9351 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
9352 return no_fh_allowed(o);
11343788 9353 o->op_flags &= ~OPf_STACKED;
93a17b20 9354 }
11343788 9355 kid = cLISTOPo->op_first->op_sibling;
a0d0e21e
LW		 9356 if (type == OP_MAPWHILE)
9357 list(kid);
9358 else
9359 scalar(kid);
11343788 9360 o = ck_fun(o);
13765c85 9361 if (PL_parser && PL_parser->error_count)
11343788 9362 return o;
aeea060c 9363 kid = cLISTOPo->op_first->op_sibling;
79072805 9364 if (kid->op_type != OP_NULL)
5637ef5b 9365 Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
79072805
LW		 9366 kid = kUNOP->op_first;
9367
2471236a 9368 NewOp(1101, gwop, 1, LOGOP);
a0d0e21e 9369 gwop->op_type = type;
22c35a8c 9370 gwop->op_ppaddr = PL_ppaddr[type];
09fe0e74 9371 gwop->op_first = o;
79072805 9372 gwop->op_flags |= OPf_KIDS;
79072805 9373 gwop->op_other = LINKLIST(kid);
79072805 9374 kid->op_next = (OP*)gwop;
cc76b5cc 9375 offset = pad_findmy_pvs("$_", 0);
00b1698f 9376 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
59f00321
RGS		 9377 o->op_private = gwop->op_private = 0;
9378 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
9379 }
9380 else {
9381 o->op_private = gwop->op_private = OPpGREP_LEX;
9382 gwop->op_targ = o->op_targ = offset;
9383 }
79072805 9384
11343788 9385 kid = cLISTOPo->op_first->op_sibling;
a0d0e21e 9386 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
3ad73efd 9387 op_lvalue(kid, OP_GREPSTART);
a0d0e21e 9388
79072805
LW		 9389 return (OP*)gwop;
9390}
9391
9392OP *
cea2e8a9 9393Perl_ck_index(pTHX_ OP *o)
79072805 9394{
7918f24d
NC		 9395 PERL_ARGS_ASSERT_CK_INDEX;
9396
11343788
MB		 9397 if (o->op_flags & OPf_KIDS) {
9398 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
0b71040e
LW		 9399 if (kid)
9400 kid = kid->op_sibling; /* get past "big" */
3b36395d 9401 if (kid && kid->op_type == OP_CONST) {
9a9b5ec9 9402 const bool save_taint = TAINT_get;
310f4fdb
FC		 9403 SV *sv = kSVOP->op_sv;
9404 if ((!SvPOK(sv) || SvNIOKp(sv)) && SvOK(sv) && !SvROK(sv)) {
9405 sv = newSV(0);
9406 sv_copypv(sv, kSVOP->op_sv);
9407 SvREFCNT_dec_NN(kSVOP->op_sv);
9408 kSVOP->op_sv = sv;
9409 }
9410 if (SvOK(sv)) fbm_compile(sv, 0);
284167a5 9411 TAINT_set(save_taint);
9a9b5ec9
DM		 9412#ifdef NO_TAINT_SUPPORT
9413 PERL_UNUSED_VAR(save_taint);
9414#endif
3b36395d 9415 }
79072805 9416 }
11343788 9417 return ck_fun(o);
79072805
LW		 9418}
9419
9420OP *
cea2e8a9 9421Perl_ck_lfun(pTHX_ OP *o)
79072805 9422{
6867be6d 9423 const OPCODE type = o->op_type;
7918f24d
NC		 9424
9425 PERL_ARGS_ASSERT_CK_LFUN;
9426
5dc0d613 9427 return modkids(ck_fun(o), type);
79072805
LW		 9428}
9429
9430OP *
cea2e8a9 9431Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
69794302 9432{
7918f24d
NC		 9433 PERL_ARGS_ASSERT_CK_DEFINED;
9434
a2a5de95 9435 if ((o->op_flags & OPf_KIDS)) {
d0334bed
GS		 9436 switch (cUNOPo->op_first->op_type) {
9437 case OP_RV2AV:
9438 case OP_PADAV:
9439 case OP_AASSIGN: /* Is this a good idea? */
d1d15184 9440 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
a2a5de95 9441 "defined(@array) is deprecated");
d1d15184 9442 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
a2a5de95 9443 "\t(Maybe you should just omit the defined()?)\n");
69794302 9444 break;
d0334bed
GS		 9445 case OP_RV2HV:
9446 case OP_PADHV:
d1d15184 9447 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
a2a5de95 9448 "defined(%%hash) is deprecated");
d1d15184 9449 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
a2a5de95 9450 "\t(Maybe you should just omit the defined()?)\n");
d0334bed
GS		 9451 break;
9452 default:
9453 /* no warning */
9454 break;
9455 }
69794302
MJD		 9456 }
9457 return ck_rfun(o);
9458}
9459
9460OP *
e4b7ebf3
RGS		 9461Perl_ck_readline(pTHX_ OP *o)
9462{
7918f24d
NC		 9463 PERL_ARGS_ASSERT_CK_READLINE;
9464
b73e5385
FC		 9465 if (o->op_flags & OPf_KIDS) {
9466 OP *kid = cLISTOPo->op_first;
9467 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
9468 }
9469 else {
e4b7ebf3
RGS		 9470 OP * const newop
9471 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
9472#ifdef PERL_MAD
9473 op_getmad(o,newop,'O');
9474#else
9475 op_free(o);
9476#endif
9477 return newop;
9478 }
9479 return o;
9480}
9481
9482OP *
cea2e8a9 9483Perl_ck_rfun(pTHX_ OP *o)
8990e307 9484{
6867be6d 9485 const OPCODE type = o->op_type;
7918f24d
NC		 9486
9487 PERL_ARGS_ASSERT_CK_RFUN;
9488
5dc0d613 9489 return refkids(ck_fun(o), type);
8990e307
LW		 9490}
9491
9492OP *
cea2e8a9 9493Perl_ck_listiob(pTHX_ OP *o)
79072805 9494{
eb578fdb 9495 OP *kid;
aeea060c 9496
7918f24d
NC		 9497 PERL_ARGS_ASSERT_CK_LISTIOB;
9498
11343788 9499 kid = cLISTOPo->op_first;
79072805 9500 if (!kid) {
11343788
MB		 9501 o = force_list(o);
9502 kid = cLISTOPo->op_first;
79072805
LW		 9503 }
9504 if (kid->op_type == OP_PUSHMARK)
9505 kid = kid->op_sibling;
11343788 9506 if (kid && o->op_flags & OPf_STACKED)
79072805
LW		 9507 kid = kid->op_sibling;
9508 else if (kid && !kid->op_sibling) { /* print HANDLE; */
01050d49 9509 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
3513c740 9510 && !kid->op_folded) {
11343788 9511 o->op_flags |= OPf_STACKED; /* make it a filehandle */
748a9306 9512 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
11343788
MB		 9513 cLISTOPo->op_first->op_sibling = kid;
9514 cLISTOPo->op_last = kid;
79072805
LW		 9515 kid = kid->op_sibling;
9516 }
9517 }
b2ffa427 9518
79072805 9519 if (!kid)
2fcb4757 9520 op_append_elem(o->op_type, o, newDEFSVOP());
79072805 9521
69974ce6 9522 if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
2de3dbcc 9523 return listkids(o);
bbce6d69 9524}
9525
9526OP *
0d863452
RH		 9527Perl_ck_smartmatch(pTHX_ OP *o)
9528{
97aff369 9529 dVAR;
a4e74480 9530 PERL_ARGS_ASSERT_CK_SMARTMATCH;
0d863452
RH		 9531 if (0 == (o->op_flags & OPf_SPECIAL)) {
9532 OP *first = cBINOPo->op_first;
9533 OP *second = first->op_sibling;
9534
9535 /* Implicitly take a reference to an array or hash */
5f66b61c 9536 first->op_sibling = NULL;
0d863452
RH		 9537 first = cBINOPo->op_first = ref_array_or_hash(first);
9538 second = first->op_sibling = ref_array_or_hash(second);
9539
9540 /* Implicitly take a reference to a regular expression */
9541 if (first->op_type == OP_MATCH) {
9542 first->op_type = OP_QR;
9543 first->op_ppaddr = PL_ppaddr[OP_QR];
9544 }
9545 if (second->op_type == OP_MATCH) {
9546 second->op_type = OP_QR;
9547 second->op_ppaddr = PL_ppaddr[OP_QR];
9548 }
9549 }
9550
9551 return o;
9552}
9553
9554
9555OP *
b162f9ea
IZ		 9556Perl_ck_sassign(pTHX_ OP *o)
9557{
3088bf26 9558 dVAR;
1496a290 9559 OP * const kid = cLISTOPo->op_first;
7918f24d
NC		 9560
9561 PERL_ARGS_ASSERT_CK_SASSIGN;
9562
b162f9ea
IZ		 9563 /* has a disposable target? */
9564 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6b66af17
GS		 9565 && !(kid->op_flags & OPf_STACKED)
9566 /* Cannot steal the second time! */
1b438339
GG		 9567 && !(kid->op_private & OPpTARGET_MY)
9568 /* Keep the full thing for madskills */
9569 && !PL_madskills
9570 )
b162f9ea 9571 {
551405c4 9572 OP * const kkid = kid->op_sibling;
b162f9ea
IZ		 9573
9574 /* Can just relocate the target. */
2c2d71f5
JH		 9575 if (kkid && kkid->op_type == OP_PADSV
9576 && !(kkid->op_private & OPpLVAL_INTRO))
9577 {
b162f9ea 9578 kid->op_targ = kkid->op_targ;
743e66e6 9579 kkid->op_targ = 0;
b162f9ea
IZ		 9580 /* Now we do not need PADSV and SASSIGN. */
9581 kid->op_sibling = o->op_sibling; /* NULL */
9582 cLISTOPo->op_first = NULL;
9583 op_free(o);
9584 op_free(kkid);
9585 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
9586 return kid;
9587 }
9588 }
c5917253
NC		 9589 if (kid->op_sibling) {
9590 OP *kkid = kid->op_sibling;
a1fba7eb
FC		 9591 /* For state variable assignment, kkid is a list op whose op_last
9592 is a padsv. */
9593 if ((kkid->op_type == OP_PADSV ||
9594 (kkid->op_type == OP_LIST &&
9595 (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
9596 )
9597 )
c5917253
NC		 9598 && (kkid->op_private & OPpLVAL_INTRO)
9599 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
9600 const PADOFFSET target = kkid->op_targ;
9601 OP *const other = newOP(OP_PADSV,
9602 kkid->op_flags
9603 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
9604 OP *const first = newOP(OP_NULL, 0);
9605 OP *const nullop = newCONDOP(0, first, o, other);
9606 OP *const condop = first->op_next;
9607 /* hijacking PADSTALE for uninitialized state variables */
9608 SvPADSTALE_on(PAD_SVl(target));
9609
9610 condop->op_type = OP_ONCE;
9611 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
9612 condop->op_targ = target;
9613 other->op_targ = target;
9614
95562366 9615 /* Because we change the type of the op here, we will skip the
486ec47a 9616 assignment binop->op_last = binop->op_first->op_sibling; at the
95562366
NC		 9617 end of Perl_newBINOP(). So need to do it here. */
9618 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
9619
c5917253
NC		 9620 return nullop;
9621 }
9622 }
b162f9ea
IZ		 9623 return o;
9624}
9625
9626OP *
cea2e8a9 9627Perl_ck_match(pTHX_ OP *o)
79072805 9628{
97aff369 9629 dVAR;
7918f24d
NC		 9630
9631 PERL_ARGS_ASSERT_CK_MATCH;
9632
0d863452 9633 if (o->op_type != OP_QR && PL_compcv) {
cc76b5cc 9634 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
00b1698f 9635 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
59f00321
RGS		 9636 o->op_targ = offset;
9637 o->op_private |= OPpTARGET_MY;
9638 }
9639 }
9640 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
9641 o->op_private |= OPpRUNTIME;
11343788 9642 return o;
79072805
LW		 9643}
9644
9645OP *
f5d5a27c
CS		 9646Perl_ck_method(pTHX_ OP *o)
9647{
551405c4 9648 OP * const kid = cUNOPo->op_first;
7918f24d
NC		 9649
9650 PERL_ARGS_ASSERT_CK_METHOD;
9651
f5d5a27c
CS		 9652 if (kid->op_type == OP_CONST) {
9653 SV* sv = kSVOP->op_sv;
a4fc7abc
AL		 9654 const char * const method = SvPVX_const(sv);
9655 if (!(strchr(method, ':') || strchr(method, '\''))) {
f5d5a27c 9656 OP *cmop;
54ac81a4 9657 if (!SvIsCOW_shared_hash(sv)) {
c60dbbc3 9658 sv = newSVpvn_share(method, SvUTF8(sv) ? -(I32)SvCUR(sv) : (I32)SvCUR(sv), 0);
1c846c1f
NIS		 9659 }
9660 else {
a0714e2c 9661 kSVOP->op_sv = NULL;
1c846c1f 9662 }
f5d5a27c 9663 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
eb8433b7
NC		 9664#ifdef PERL_MAD
9665 op_getmad(o,cmop,'O');
9666#else
f5d5a27c 9667 op_free(o);
eb8433b7 9668#endif
f5d5a27c
CS		 9669 return cmop;
9670 }
9671 }
9672 return o;
9673}
9674
9675OP *
cea2e8a9 9676Perl_ck_null(pTHX_ OP *o)
79072805 9677{
7918f24d 9678 PERL_ARGS_ASSERT_CK_NULL;
96a5add6 9679 PERL_UNUSED_CONTEXT;
11343788 9680 return o;
79072805
LW		 9681}
9682
9683OP *
16fe6d59
GS		 9684Perl_ck_open(pTHX_ OP *o)
9685{
97aff369 9686 dVAR;
7918f24d
NC		 9687
9688 PERL_ARGS_ASSERT_CK_OPEN;
9689
9ce1fb7d 9690 S_io_hints(aTHX_ o);
3b82e551
JH		 9691 {
9692 /* In case of three-arg dup open remove strictness
9693 * from the last arg if it is a bareword. */
551405c4
AL		 9694 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
9695 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
3b82e551 9696 OP *oa;
b15aece3 9697 const char *mode;
3b82e551
JH		 9698
9699 if ((last->op_type == OP_CONST) && /* The bareword. */
9700 (last->op_private & OPpCONST_BARE) &&
9701 (last->op_private & OPpCONST_STRICT) &&
9702 (oa = first->op_sibling) && /* The fh. */
9703 (oa = oa->op_sibling) && /* The mode. */
ea1d064a 9704 (oa->op_type == OP_CONST) &&
3b82e551 9705 SvPOK(((SVOP*)oa)->op_sv) &&
b15aece3 9706 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
3b82e551
JH		 9707 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
9708 (last == oa->op_sibling)) /* The bareword. */
9709 last->op_private &= ~OPpCONST_STRICT;
9710 }
16fe6d59
GS		 9711 return ck_fun(o);
9712}
9713
9714OP *
cea2e8a9 9715Perl_ck_repeat(pTHX_ OP *o)
79072805 9716{
7918f24d
NC		 9717 PERL_ARGS_ASSERT_CK_REPEAT;
9718
11343788
MB		 9719 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
9720 o->op_private |= OPpREPEAT_DOLIST;
9721 cBINOPo->op_first = force_list(cBINOPo->op_first);
79072805
LW		 9722 }
9723 else
11343788
MB		 9724 scalar(o);
9725 return o;
79072805
LW		 9726}
9727
9728OP *
cea2e8a9 9729Perl_ck_require(pTHX_ OP *o)
8990e307 9730{
97aff369 9731 dVAR;
c62c138b 9732 GV* gv;
ec4ab249 9733
7918f24d
NC		 9734 PERL_ARGS_ASSERT_CK_REQUIRE;
9735
11343788 9736 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
551405c4 9737 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8990e307
LW		 9738
9739 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
551405c4 9740 SV * const sv = kid->op_sv;
5c144d81 9741 U32 was_readonly = SvREADONLY(sv);
8990e307 9742 char *s;
cfff9797
NC		 9743 STRLEN len;
9744 const char *end;
5c144d81
NC		 9745
9746 if (was_readonly) {
5c144d81 9747 SvREADONLY_off(sv);
5c144d81 9748 }
e3918bb7 9749 if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
5c144d81 9750
cfff9797
NC		 9751 s = SvPVX(sv);
9752 len = SvCUR(sv);
9753 end = s + len;
9754 for (; s < end; s++) {
a0d0e21e
LW		 9755 if (*s == ':' && s[1] == ':') {
9756 *s = '/';
5c6b2528 9757 Move(s+2, s+1, end - s - 1, char);
cfff9797 9758 --end;
a0d0e21e 9759 }
8990e307 9760 }
cfff9797 9761 SvEND_set(sv, end);
396482e1 9762 sv_catpvs(sv, ".pm");
5c144d81 9763 SvFLAGS(sv) |= was_readonly;
8990e307
LW		 9764 }
9765 }
ec4ab249 9766
c62c138b 9767 if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */
a72a1c8b 9768 /* handle override, if any */
9e3fb20c 9769 && (gv = gv_override("require", 7))) {
7c864bb3
VP		 9770 OP *kid, *newop;
9771 if (o->op_flags & OPf_KIDS) {
9772 kid = cUNOPo->op_first;
9773 cUNOPo->op_first = NULL;
9774 }
9775 else {
9776 kid = newDEFSVOP();
9777 }
f11453cb 9778#ifndef PERL_MAD
ec4ab249 9779 op_free(o);
eb8433b7 9780#endif
aff26e98 9781 newop = S_new_entersubop(aTHX_ gv, kid);
f11453cb 9782 op_getmad(o,newop,'O');
eb8433b7 9783 return newop;
ec4ab249
GA		 9784 }
9785
021f53de 9786 return scalar(ck_fun(o));
8990e307
LW		 9787}
9788
78f9721b
SM		 9789OP *
9790Perl_ck_return(pTHX_ OP *o)
9791{
97aff369 9792 dVAR;
e91684bf 9793 OP *kid;
7918f24d
NC		 9794
9795 PERL_ARGS_ASSERT_CK_RETURN;
9796
e91684bf 9797 kid = cLISTOPo->op_first->op_sibling;
78f9721b 9798 if (CvLVALUE(PL_compcv)) {
e91684bf 9799 for (; kid; kid = kid->op_sibling)
3ad73efd 9800 op_lvalue(kid, OP_LEAVESUBLV);
78f9721b 9801 }
e91684bf 9802
78f9721b
SM		 9803 return o;
9804}
9805
79072805 9806OP *
cea2e8a9 9807Perl_ck_select(pTHX_ OP *o)
79072805 9808{
27da23d5 9809 dVAR;
c07a80fd 9810 OP* kid;
7918f24d
NC		 9811
9812 PERL_ARGS_ASSERT_CK_SELECT;
9813
11343788
MB		 9814 if (o->op_flags & OPf_KIDS) {
9815 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
2304df62 9816 if (kid && kid->op_sibling) {
11343788 9817 o->op_type = OP_SSELECT;
22c35a8c 9818 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
11343788 9819 o = ck_fun(o);
985b9e54 9820 return fold_constants(op_integerize(op_std_init(o)));
79072805
LW		 9821 }
9822 }
11343788
MB		 9823 o = ck_fun(o);
9824 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
c07a80fd 9825 if (kid && kid->op_type == OP_RV2GV)
9826 kid->op_private &= ~HINT_STRICT_REFS;
11343788 9827 return o;
79072805
LW		 9828}
9829
9830OP *
cea2e8a9 9831Perl_ck_shift(pTHX_ OP *o)
79072805 9832{
97aff369 9833 dVAR;
6867be6d 9834 const I32 type = o->op_type;
79072805 9835
7918f24d
NC		 9836 PERL_ARGS_ASSERT_CK_SHIFT;
9837
11343788 9838 if (!(o->op_flags & OPf_KIDS)) {
538f5756
RZ		 9839 OP *argop;
9840
9841 if (!CvUNIQUE(PL_compcv)) {
9842 o->op_flags |= OPf_SPECIAL;
9843 return o;
9844 }
9845
9846 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
eb8433b7 9847#ifdef PERL_MAD
790427a5
DM		 9848 {
9849 OP * const oldo = o;
9850 o = newUNOP(type, 0, scalar(argop));
9851 op_getmad(oldo,o,'O');
9852 return o;
9853 }
eb8433b7 9854#else
821005df 9855 op_free(o);
6d4ff0d2 9856 return newUNOP(type, 0, scalar(argop));
eb8433b7 9857#endif
79072805 9858 }
d4fc4415 9859 return scalar(ck_fun(o));
79072805
LW		 9860}
9861
9862OP *
cea2e8a9 9863Perl_ck_sort(pTHX_ OP *o)
79072805 9864{
97aff369 9865 dVAR;
8e3f9bdf 9866 OP *firstkid;
f65493df 9867 OP *kid;
c3258369
FC		 9868 HV * const hinthv =
9869 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;
f65493df 9870 U8 stacked;
bbce6d69 9871
7918f24d
NC		 9872 PERL_ARGS_ASSERT_CK_SORT;
9873
354dd559 9874 if (hinthv) {
a4fc7abc 9875 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7b9ef140 9876 if (svp) {
a4fc7abc 9877 const I32 sorthints = (I32)SvIV(*svp);
7b9ef140
RH		 9878 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
9879 o->op_private |= OPpSORT_QSORT;
9880 if ((sorthints & HINT_SORT_STABLE) != 0)
9881 o->op_private |= OPpSORT_STABLE;
9882 }
7b9ef140
RH		 9883 }
9884
354dd559 9885 if (o->op_flags & OPf_STACKED)
51a19bc0 9886 simplify_sort(o);
8e3f9bdf 9887 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
f65493df 9888 if ((stacked = o->op_flags & OPf_STACKED)) { /* may have been cleared */
8e3f9bdf 9889 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
79072805 9890
463ee0b2 9891 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
5983a79d 9892 LINKLIST(kid);
c650d697 9893 if (kid->op_type == OP_LEAVE)
93c66552 9894 op_null(kid); /* wipe out leave */
c650d697
FC		 9895 /* Prevent execution from escaping out of the sort block. */
9896 kid->op_next = 0;
a0d0e21e 9897
354dd559
FC		 9898 /* provide scalar context for comparison function/block */
9899 kid = scalar(firstkid);
9900 kid->op_next = kid;
11343788 9901 o->op_flags |= OPf_SPECIAL;
79072805 9902 }
8e3f9bdf
GS		 9903
9904 firstkid = firstkid->op_sibling;
79072805 9905 }
bbce6d69 9906
f65493df 9907 for (kid = firstkid; kid; kid = kid->op_sibling) {
e9d9e6f3
FC		 9908 /* provide list context for arguments */
9909 list(kid);
f65493df
FC		 9910 if (stacked)
9911 op_lvalue(kid, OP_GREPSTART);
9912 }
8e3f9bdf 9913
11343788 9914 return o;
79072805 9915}
bda4119b
GS		 9916
9917STATIC void
cea2e8a9 9918S_simplify_sort(pTHX_ OP *o)
9c007264 9919{
97aff369 9920 dVAR;
eb578fdb 9921 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
9c007264 9922 OP *k;
eb209983 9923 int descending;
350de78d 9924 GV *gv;
770526c1 9925 const char *gvname;
8023b711 9926 bool have_scopeop;
7918f24d
NC		 9927
9928 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
9929
82092f1d 9930 kid = kUNOP->op_first; /* get past null */
8023b711
FC		 9931 if (!(have_scopeop = kid->op_type == OP_SCOPE)
9932 && kid->op_type != OP_LEAVE)
9c007264
JH		 9933 return;
9934 kid = kLISTOP->op_last; /* get past scope */
9935 switch(kid->op_type) {
9936 case OP_NCMP:
9937 case OP_I_NCMP:
9938 case OP_SCMP:
8023b711 9939 if (!have_scopeop) goto padkids;
9c007264
JH		 9940 break;
9941 default:
9942 return;
9943 }
9944 k = kid; /* remember this node*/
271c8bde
FC		 9945 if (kBINOP->op_first->op_type != OP_RV2SV
9946 || kBINOP->op_last ->op_type != OP_RV2SV)
9947 {
9948 /*
9949 Warn about my($a) or my($b) in a sort block, *if* $a or $b is
9950 then used in a comparison. This catches most, but not
9951 all cases. For instance, it catches
9952 sort { my($a); $a <=> $b }
9953 but not
9954 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
9955 (although why you'd do that is anyone's guess).
9956 */
9957
9958 padkids:
9959 if (!ckWARN(WARN_SYNTAX)) return;
9960 kid = kBINOP->op_first;
9961 do {
9962 if (kid->op_type == OP_PADSV) {
9963 SV * const name = AvARRAY(PL_comppad_name)[kid->op_targ];
9964 if (SvCUR(name) == 2 && *SvPVX(name) == '$'
9965 && (SvPVX(name)[1] == 'a' || SvPVX(name)[1] == 'b'))
a2e39214 9966 /* diag_listed_as: "my %s" used in sort comparison */
271c8bde 9967 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
a2e39214
FC		 9968 "\"%s %s\" used in sort comparison",
9969 SvPAD_STATE(name) ? "state" : "my",
271c8bde
FC		 9970 SvPVX(name));
9971 }
9972 } while ((kid = kid->op_sibling));
9c007264 9973 return;
271c8bde 9974 }
9c007264
JH		 9975 kid = kBINOP->op_first; /* get past cmp */
9976 if (kUNOP->op_first->op_type != OP_GV)
9977 return;
9978 kid = kUNOP->op_first; /* get past rv2sv */
638eceb6 9979 gv = kGVOP_gv;
350de78d 9980 if (GvSTASH(gv) != PL_curstash)
9c007264 9981 return;
770526c1
NC		 9982 gvname = GvNAME(gv);
9983 if (*gvname == 'a' && gvname[1] == '\0')
eb209983 9984 descending = 0;
770526c1 9985 else if (*gvname == 'b' && gvname[1] == '\0')
eb209983 9986 descending = 1;
9c007264
JH		 9987 else
9988 return;
eb209983 9989
9c007264 9990 kid = k; /* back to cmp */
271c8bde 9991 /* already checked above that it is rv2sv */
9c007264
JH		 9992 kid = kBINOP->op_last; /* down to 2nd arg */
9993 if (kUNOP->op_first->op_type != OP_GV)
9994 return;
9995 kid = kUNOP->op_first; /* get past rv2sv */
638eceb6 9996 gv = kGVOP_gv;
770526c1
NC		 9997 if (GvSTASH(gv) != PL_curstash)
9998 return;
9999 gvname = GvNAME(gv);
10000 if ( descending
10001 ? !(*gvname == 'a' && gvname[1] == '\0')
10002 : !(*gvname == 'b' && gvname[1] == '\0'))
9c007264
JH		 10003 return;
10004 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
eb209983
NC		 10005 if (descending)
10006 o->op_private |= OPpSORT_DESCEND;
9c007264
JH		 10007 if (k->op_type == OP_NCMP)
10008 o->op_private |= OPpSORT_NUMERIC;
10009 if (k->op_type == OP_I_NCMP)
10010 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
e507f050
SM		 10011 kid = cLISTOPo->op_first->op_sibling;
10012 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
eb8433b7
NC		 10013#ifdef PERL_MAD
10014 op_getmad(kid,o,'S'); /* then delete it */
10015#else
e507f050 10016 op_free(kid); /* then delete it */
eb8433b7 10017#endif
9c007264 10018}
79072805
LW		 10019
10020OP *
cea2e8a9 10021Perl_ck_split(pTHX_ OP *o)
79072805 10022{
27da23d5 10023 dVAR;
eb578fdb 10024 OP *kid;
aeea060c 10025
7918f24d
NC		 10026 PERL_ARGS_ASSERT_CK_SPLIT;
10027
11343788
MB		 10028 if (o->op_flags & OPf_STACKED)
10029 return no_fh_allowed(o);
79072805 10030
11343788 10031 kid = cLISTOPo->op_first;
8990e307 10032 if (kid->op_type != OP_NULL)
5637ef5b 10033 Perl_croak(aTHX_ "panic: ck_split, type=%u", (unsigned) kid->op_type);
8990e307 10034 kid = kid->op_sibling;
11343788 10035 op_free(cLISTOPo->op_first);
f126b75f
MW		 10036 if (kid)
10037 cLISTOPo->op_first = kid;
10038 else {
396482e1 10039 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
11343788 10040 cLISTOPo->op_last = kid; /* There was only one element previously */
85e6fe83 10041 }
79072805 10042
de4bf5b3 10043 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
551405c4 10044 OP * const sibl = kid->op_sibling;
463ee0b2 10045 kid->op_sibling = 0;
dbc200c5 10046 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0, 0); /* OPf_SPECIAL is used to trigger split " " behavior */
11343788
MB		 10047 if (cLISTOPo->op_first == cLISTOPo->op_last)
10048 cLISTOPo->op_last = kid;
10049 cLISTOPo->op_first = kid;
79072805
LW		 10050 kid->op_sibling = sibl;
10051 }
10052
10053 kid->op_type = OP_PUSHRE;
22c35a8c 10054 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
79072805 10055 scalar(kid);
a2a5de95
NC		 10056 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
10057 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
10058 "Use of /g modifier is meaningless in split");
f34840d8 10059 }
79072805
LW		 10060
10061 if (!kid->op_sibling)
2fcb4757 10062 op_append_elem(OP_SPLIT, o, newDEFSVOP());
79072805
LW		 10063
10064 kid = kid->op_sibling;
10065 scalar(kid);
10066
10067 if (!kid->op_sibling)
60041a09 10068 {
2fcb4757 10069 op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
60041a09
FC		 10070 o->op_private |= OPpSPLIT_IMPLIM;
10071 }
ce3e5c45 10072 assert(kid->op_sibling);
79072805
LW		 10073
10074 kid = kid->op_sibling;
10075 scalar(kid);
10076
10077 if (kid->op_sibling)
ce16c625 10078 return too_many_arguments_pv(o,OP_DESC(o), 0);
79072805 10079
11343788 10080 return o;
79072805
LW		 10081}
10082
10083OP *
1c846c1f 10084Perl_ck_join(pTHX_ OP *o)
eb6e2d6f 10085{
551405c4 10086 const OP * const kid = cLISTOPo->op_first->op_sibling;
7918f24d
NC		 10087
10088 PERL_ARGS_ASSERT_CK_JOIN;
10089
041457d9
DM		 10090 if (kid && kid->op_type == OP_MATCH) {
10091 if (ckWARN(WARN_SYNTAX)) {
6867be6d 10092 const REGEXP *re = PM_GETRE(kPMOP);
ce16c625
BF		 10093 const SV *msg = re
10094 ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
10095 SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
10096 : newSVpvs_flags( "STRING", SVs_TEMP );
9014280d 10097 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
ce16c625
BF		 10098 "/%"SVf"/ should probably be written as \"%"SVf"\"",
10099 SVfARG(msg), SVfARG(msg));
eb6e2d6f
GS		 10100 }
10101 }
10102 return ck_fun(o);
10103}
10104
d9088386
Z		 10105/*
10106=for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
10107
10108Examines an op, which is expected to identify a subroutine at runtime,
10109and attempts to determine at compile time which subroutine it identifies.
10110This is normally used during Perl compilation to determine whether
10111a prototype can be applied to a function call. I<cvop> is the op
10112being considered, normally an C<rv2cv> op. A pointer to the identified
10113subroutine is returned, if it could be determined statically, and a null
10114pointer is returned if it was not possible to determine statically.
10115
10116Currently, the subroutine can be identified statically if the RV that the
10117C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
10118A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
10119suitable if the constant value must be an RV pointing to a CV. Details of
10120this process may change in future versions of Perl. If the C<rv2cv> op
10121has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
10122the subroutine statically: this flag is used to suppress compile-time
10123magic on a subroutine call, forcing it to use default runtime behaviour.
10124
10125If I<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
10126of a GV reference is modified. If a GV was examined and its CV slot was
10127found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
10128If the op is not optimised away, and the CV slot is later populated with
10129a subroutine having a prototype, that flag eventually triggers the warning
10130"called too early to check prototype".
10131
10132If I<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
10133of returning a pointer to the subroutine it returns a pointer to the
10134GV giving the most appropriate name for the subroutine in this context.
10135Normally this is just the C<CvGV> of the subroutine, but for an anonymous
10136(C<CvANON>) subroutine that is referenced through a GV it will be the
10137referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
10138A null pointer is returned as usual if there is no statically-determinable
10139subroutine.
7918f24d 10140
d9088386
Z		 10141=cut
10142*/
9d88f058 10143
9a5e6f3c
FC		 10144/* shared by toke.c:yylex */
10145CV *
10146Perl_find_lexical_cv(pTHX_ PADOFFSET off)
10147{
10148 PADNAME *name = PAD_COMPNAME(off);
10149 CV *compcv = PL_compcv;
10150 while (PadnameOUTER(name)) {
10151 assert(PARENT_PAD_INDEX(name));
10152 compcv = CvOUTSIDE(PL_compcv);
10153 name = PadlistNAMESARRAY(CvPADLIST(compcv))
10154 [off = PARENT_PAD_INDEX(name)];
10155 }
10156 assert(!PadnameIsOUR(name));
3a74e0e2 10157 if (!PadnameIsSTATE(name) && SvMAGICAL(name)) {
9a5e6f3c
FC		 10158 MAGIC * mg = mg_find(name, PERL_MAGIC_proto);
10159 assert(mg);
10160 assert(mg->mg_obj);
10161 return (CV *)mg->mg_obj;
10162 }
10163 return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
10164}
10165
d9088386
Z		 10166CV *
10167Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
10168{
10169 OP *rvop;
10170 CV *cv;
10171 GV *gv;
10172 PERL_ARGS_ASSERT_RV2CV_OP_CV;
10173 if (flags & ~(RV2CVOPCV_MARK_EARLY|RV2CVOPCV_RETURN_NAME_GV))
10174 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
10175 if (cvop->op_type != OP_RV2CV)
10176 return NULL;
10177 if (cvop->op_private & OPpENTERSUB_AMPER)
10178 return NULL;
10179 if (!(cvop->op_flags & OPf_KIDS))
10180 return NULL;
10181 rvop = cUNOPx(cvop)->op_first;
10182 switch (rvop->op_type) {
10183 case OP_GV: {
10184 gv = cGVOPx_gv(rvop);
10185 cv = GvCVu(gv);
10186 if (!cv) {
10187 if (flags & RV2CVOPCV_MARK_EARLY)
10188 rvop->op_private |= OPpEARLY_CV;
10189 return NULL;
46fc3d4c 10190 }
d9088386
Z		 10191 } break;
10192 case OP_CONST: {
10193 SV *rv = cSVOPx_sv(rvop);
10194 if (!SvROK(rv))
10195 return NULL;
10196 cv = (CV*)SvRV(rv);
10197 gv = NULL;
10198 } break;
279d09bf 10199 case OP_PADCV: {
9a5e6f3c 10200 cv = find_lexical_cv(rvop->op_targ);
279d09bf
FC		 10201 gv = NULL;
10202 } break;
d9088386
Z		 10203 default: {
10204 return NULL;
10205 } break;
4633a7c4 10206 }
d9088386
Z		 10207 if (SvTYPE((SV*)cv) != SVt_PVCV)
10208 return NULL;
10209 if (flags & RV2CVOPCV_RETURN_NAME_GV) {
10210 if (!CvANON(cv) || !gv)
10211 gv = CvGV(cv);
10212 return (CV*)gv;
10213 } else {
10214 return cv;
7a52d87a 10215 }
d9088386 10216}
9d88f058 10217
d9088386
Z		 10218/*
10219=for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
824afba1 10220
d9088386
Z		 10221Performs the default fixup of the arguments part of an C<entersub>
10222op tree. This consists of applying list context to each of the
10223argument ops. This is the standard treatment used on a call marked
10224with C<&>, or a method call, or a call through a subroutine reference,
10225or any other call where the callee can't be identified at compile time,
10226or a call where the callee has no prototype.
824afba1 10227
d9088386
Z		 10228=cut
10229*/
340458b5 10230
d9088386
Z		 10231OP *
10232Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
10233{
10234 OP *aop;
10235 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
10236 aop = cUNOPx(entersubop)->op_first;
10237 if (!aop->op_sibling)
10238 aop = cUNOPx(aop)->op_first;
10239 for (aop = aop->op_sibling; aop->op_sibling; aop = aop->op_sibling) {
10240 if (!(PL_madskills && aop->op_type == OP_STUB)) {
10241 list(aop);
3ad73efd 10242 op_lvalue(aop, OP_ENTERSUB);
d9088386
Z		 10243 }
10244 }
10245 return entersubop;
10246}
340458b5 10247
d9088386
Z		 10248/*
10249=for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
10250
10251Performs the fixup of the arguments part of an C<entersub> op tree
10252based on a subroutine prototype. This makes various modifications to
10253the argument ops, from applying context up to inserting C<refgen> ops,
10254and checking the number and syntactic types of arguments, as directed by
10255the prototype. This is the standard treatment used on a subroutine call,
10256not marked with C<&>, where the callee can be identified at compile time
10257and has a prototype.
10258
10259I<protosv> supplies the subroutine prototype to be applied to the call.
10260It may be a normal defined scalar, of which the string value will be used.
10261Alternatively, for convenience, it may be a subroutine object (a C<CV*>
10262that has been cast to C<SV*>) which has a prototype. The prototype
10263supplied, in whichever form, does not need to match the actual callee
10264referenced by the op tree.
10265
10266If the argument ops disagree with the prototype, for example by having
10267an unacceptable number of arguments, a valid op tree is returned anyway.
10268The error is reflected in the parser state, normally resulting in a single
10269exception at the top level of parsing which covers all the compilation
10270errors that occurred. In the error message, the callee is referred to
10271by the name defined by the I<namegv> parameter.
cbf82dd0 10272
d9088386
Z		 10273=cut
10274*/
10275
10276OP *
10277Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
10278{
10279 STRLEN proto_len;
10280 const char *proto, *proto_end;
10281 OP *aop, *prev, *cvop;
10282 int optional = 0;
10283 I32 arg = 0;
10284 I32 contextclass = 0;
10285 const char *e = NULL;
10286 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
10287 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
cb197492 10288 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
5637ef5b 10289 "flags=%lx", (unsigned long) SvFLAGS(protosv));
8fa6a409
FC		 10290 if (SvTYPE(protosv) == SVt_PVCV)
10291 proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
10292 else proto = SvPV(protosv, proto_len);
d16269d8 10293 proto = S_strip_spaces(aTHX_ proto, &proto_len);
d9088386
Z		 10294 proto_end = proto + proto_len;
10295 aop = cUNOPx(entersubop)->op_first;
10296 if (!aop->op_sibling)
10297 aop = cUNOPx(aop)->op_first;
10298 prev = aop;
10299 aop = aop->op_sibling;
10300 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
10301 while (aop != cvop) {
10302 OP* o3;
10303 if (PL_madskills && aop->op_type == OP_STUB) {
10304 aop = aop->op_sibling;
10305 continue;
10306 }
10307 if (PL_madskills && aop->op_type == OP_NULL)
10308 o3 = ((UNOP*)aop)->op_first;
10309 else
10310 o3 = aop;
10311
10312 if (proto >= proto_end)
ce16c625 10313 return too_many_arguments_sv(entersubop, gv_ename(namegv), 0);
d9088386
Z		 10314
10315 switch (*proto) {
597dcb2b
DG		 10316 case ';':
10317 optional = 1;
10318 proto++;
10319 continue;
10320 case '_':
10321 /* _ must be at the end */
34daab0f 10322 if (proto[1] && !strchr(";@%", proto[1]))
597dcb2b
DG		 10323 goto oops;
10324 case '$':
10325 proto++;
10326 arg++;
10327 scalar(aop);
10328 break;
10329 case '%':
10330 case '@':
10331 list(aop);
10332 arg++;
10333 break;
10334 case '&':
10335 proto++;
10336 arg++;
10337 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
7b3b0904 10338 bad_type_gv(arg,
597dcb2b 10339 arg == 1 ? "block or sub {}" : "sub {}",
7b3b0904 10340 namegv, 0, o3);
597dcb2b
DG		 10341 break;
10342 case '*':
10343 /* '*' allows any scalar type, including bareword */
10344 proto++;
10345 arg++;
10346 if (o3->op_type == OP_RV2GV)
10347 goto wrapref; /* autoconvert GLOB -> GLOBref */
10348 else if (o3->op_type == OP_CONST)
10349 o3->op_private &= ~OPpCONST_STRICT;
10350 else if (o3->op_type == OP_ENTERSUB) {
10351 /* accidental subroutine, revert to bareword */
10352 OP *gvop = ((UNOP*)o3)->op_first;
10353 if (gvop && gvop->op_type == OP_NULL) {
10354 gvop = ((UNOP*)gvop)->op_first;
10355 if (gvop) {
10356 for (; gvop->op_sibling; gvop = gvop->op_sibling)
10357 ;
10358 if (gvop &&
10359 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
10360 (gvop = ((UNOP*)gvop)->op_first) &&
10361 gvop->op_type == OP_GV)
10362 {
10363 GV * const gv = cGVOPx_gv(gvop);
10364 OP * const sibling = aop->op_sibling;
10365 SV * const n = newSVpvs("");
eb8433b7 10366#ifdef PERL_MAD
597dcb2b 10367 OP * const oldaop = aop;
eb8433b7 10368#else
597dcb2b 10369 op_free(aop);
eb8433b7 10370#endif
597dcb2b
DG		 10371 gv_fullname4(n, gv, "", FALSE);
10372 aop = newSVOP(OP_CONST, 0, n);
10373 op_getmad(oldaop,aop,'O');
10374 prev->op_sibling = aop;
10375 aop->op_sibling = sibling;
10376 }
9675f7ac
GS		 10377 }
10378 }
10379 }
597dcb2b 10380 scalar(aop);
c035a075
DG		 10381 break;
10382 case '+':
10383 proto++;
10384 arg++;
10385 if (o3->op_type == OP_RV2AV ||
10386 o3->op_type == OP_PADAV ||
10387 o3->op_type == OP_RV2HV ||
10388 o3->op_type == OP_PADHV
10389 ) {
10390 goto wrapref;
10391 }
10392 scalar(aop);
d9088386 10393 break;
597dcb2b
DG		 10394 case '[': case ']':
10395 goto oops;
d9088386 10396 break;
597dcb2b
DG		 10397 case '\\':
10398 proto++;
10399 arg++;
10400 again:
10401 switch (*proto++) {
10402 case '[':
10403 if (contextclass++ == 0) {
10404 e = strchr(proto, ']');
10405 if (!e || e == proto)
10406 goto oops;
10407 }
10408 else
10409 goto oops;
10410 goto again;
10411 break;
10412 case ']':
10413 if (contextclass) {
10414 const char *p = proto;
10415 const char *const end = proto;
10416 contextclass = 0;
062678b2
FC		 10417 while (*--p != '[')
10418 /* \[$] accepts any scalar lvalue */
10419 if (*p == '$'
10420 && Perl_op_lvalue_flags(aTHX_
10421 scalar(o3),
10422 OP_READ, /* not entersub */
10423 OP_LVALUE_NO_CROAK
10424 )) goto wrapref;
7b3b0904 10425 bad_type_gv(arg, Perl_form(aTHX_ "one of %.*s",
597dcb2b 10426 (int)(end - p), p),
7b3b0904 10427 namegv, 0, o3);
597dcb2b
DG		 10428 } else
10429 goto oops;
10430 break;
10431 case '*':
10432 if (o3->op_type == OP_RV2GV)
10433 goto wrapref;
10434 if (!contextclass)
7b3b0904 10435 bad_type_gv(arg, "symbol", namegv, 0, o3);
597dcb2b
DG		 10436 break;
10437 case '&':
10438 if (o3->op_type == OP_ENTERSUB)
10439 goto wrapref;
10440 if (!contextclass)
7b3b0904 10441 bad_type_gv(arg, "subroutine entry", namegv, 0,
597dcb2b
DG		 10442 o3);
10443 break;
10444 case '$':
10445 if (o3->op_type == OP_RV2SV ||
10446 o3->op_type == OP_PADSV ||
10447 o3->op_type == OP_HELEM ||
10448 o3->op_type == OP_AELEM)
10449 goto wrapref;
062678b2
FC		 10450 if (!contextclass) {
10451 /* \$ accepts any scalar lvalue */
10452 if (Perl_op_lvalue_flags(aTHX_
10453 scalar(o3),
10454 OP_READ, /* not entersub */
10455 OP_LVALUE_NO_CROAK
10456 )) goto wrapref;
7b3b0904 10457 bad_type_gv(arg, "scalar", namegv, 0, o3);
062678b2 10458 }
597dcb2b
DG		 10459 break;
10460 case '@':
10461 if (o3->op_type == OP_RV2AV ||
10462 o3->op_type == OP_PADAV)
10463 goto wrapref;
10464 if (!contextclass)
7b3b0904 10465 bad_type_gv(arg, "array", namegv, 0, o3);
597dcb2b
DG		 10466 break;
10467 case '%':
10468 if (o3->op_type == OP_RV2HV ||
10469 o3->op_type == OP_PADHV)
10470 goto wrapref;
10471 if (!contextclass)
7b3b0904 10472 bad_type_gv(arg, "hash", namegv, 0, o3);
597dcb2b
DG		 10473 break;
10474 wrapref:
10475 {
10476 OP* const kid = aop;
10477 OP* const sib = kid->op_sibling;
10478 kid->op_sibling = 0;
10479 aop = newUNOP(OP_REFGEN, 0, kid);
10480 aop->op_sibling = sib;
10481 prev->op_sibling = aop;
10482 }
10483 if (contextclass && e) {
10484 proto = e + 1;
10485 contextclass = 0;
10486 }
10487 break;
10488 default: goto oops;
4633a7c4 10489 }
597dcb2b
DG		 10490 if (contextclass)
10491 goto again;
4633a7c4 10492 break;
597dcb2b
DG		 10493 case ' ':
10494 proto++;
10495 continue;
10496 default:
108f32a5
BF		 10497 oops: {
10498 SV* const tmpsv = sv_newmortal();
10499 gv_efullname3(tmpsv, namegv, NULL);
10500 Perl_croak(aTHX_ "Malformed prototype for %"SVf": %"SVf,
10501 SVfARG(tmpsv), SVfARG(protosv));
10502 }
d9088386
Z		 10503 }
10504
3ad73efd 10505 op_lvalue(aop, OP_ENTERSUB);
d9088386
Z		 10506 prev = aop;
10507 aop = aop->op_sibling;
10508 }
10509 if (aop == cvop && *proto == '_') {
10510 /* generate an access to $_ */
10511 aop = newDEFSVOP();
10512 aop->op_sibling = prev->op_sibling;
10513 prev->op_sibling = aop; /* instead of cvop */
10514 }
10515 if (!optional && proto_end > proto &&
10516 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
ce16c625 10517 return too_few_arguments_sv(entersubop, gv_ename(namegv), 0);
d9088386
Z		 10518 return entersubop;
10519}
10520
10521/*
10522=for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
10523
10524Performs the fixup of the arguments part of an C<entersub> op tree either
10525based on a subroutine prototype or using default list-context processing.
10526This is the standard treatment used on a subroutine call, not marked
10527with C<&>, where the callee can be identified at compile time.
10528
10529I<protosv> supplies the subroutine prototype to be applied to the call,
10530or indicates that there is no prototype. It may be a normal scalar,
10531in which case if it is defined then the string value will be used
10532as a prototype, and if it is undefined then there is no prototype.
10533Alternatively, for convenience, it may be a subroutine object (a C<CV*>
10534that has been cast to C<SV*>), of which the prototype will be used if it
10535has one. The prototype (or lack thereof) supplied, in whichever form,
10536does not need to match the actual callee referenced by the op tree.
10537
10538If the argument ops disagree with the prototype, for example by having
10539an unacceptable number of arguments, a valid op tree is returned anyway.
10540The error is reflected in the parser state, normally resulting in a single
10541exception at the top level of parsing which covers all the compilation
10542errors that occurred. In the error message, the callee is referred to
10543by the name defined by the I<namegv> parameter.
10544
10545=cut
10546*/
10547
10548OP *
10549Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
10550 GV *namegv, SV *protosv)
10551{
10552 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
10553 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
10554 return ck_entersub_args_proto(entersubop, namegv, protosv);
10555 else
10556 return ck_entersub_args_list(entersubop);
10557}
10558
4aaa4757
FC		 10559OP *
10560Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
10561{
10562 int opnum = SvTYPE(protosv) == SVt_PVCV ? 0 : (int)SvUV(protosv);
10563 OP *aop = cUNOPx(entersubop)->op_first;
10564
10565 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
10566
10567 if (!opnum) {
14f0f125 10568 OP *cvop;
4aaa4757
FC		 10569 if (!aop->op_sibling)
10570 aop = cUNOPx(aop)->op_first;
4aaa4757
FC		 10571 aop = aop->op_sibling;
10572 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
10573 if (PL_madskills) while (aop != cvop && aop->op_type == OP_STUB) {
10574 aop = aop->op_sibling;
4aaa4757
FC		 10575 }
10576 if (aop != cvop)
ce16c625 10577 (void)too_many_arguments_pv(entersubop, GvNAME(namegv), 0);
4aaa4757
FC		 10578
10579 op_free(entersubop);
10580 switch(GvNAME(namegv)[2]) {
10581 case 'F': return newSVOP(OP_CONST, 0,
10582 newSVpv(CopFILE(PL_curcop),0));
10583 case 'L': return newSVOP(
10584 OP_CONST, 0,
10585 Perl_newSVpvf(aTHX_
10586 "%"IVdf, (IV)CopLINE(PL_curcop)
10587 )
10588 );
10589 case 'P': return newSVOP(OP_CONST, 0,
10590 (PL_curstash
10591 ? newSVhek(HvNAME_HEK(PL_curstash))
10592 : &PL_sv_undef
10593 )
10594 );
10595 }
10596 assert(0);
10597 }
10598 else {
10599 OP *prev, *cvop;
7d789282 10600 U32 flags;
4aaa4757
FC		 10601#ifdef PERL_MAD
10602 bool seenarg = FALSE;
10603#endif
10604 if (!aop->op_sibling)
10605 aop = cUNOPx(aop)->op_first;
10606
10607 prev = aop;
10608 aop = aop->op_sibling;
10609 prev->op_sibling = NULL;
10610 for (cvop = aop;
10611 cvop->op_sibling;
10612 prev=cvop, cvop = cvop->op_sibling)
10613#ifdef PERL_MAD
10614 if (PL_madskills && cvop->op_sibling
10615 && cvop->op_type != OP_STUB) seenarg = TRUE
10616#endif
10617 ;
10618 prev->op_sibling = NULL;
7d789282 10619 flags = OPf_SPECIAL * !(cvop->op_private & OPpENTERSUB_NOPAREN);
4aaa4757
FC		 10620 op_free(cvop);
10621 if (aop == cvop) aop = NULL;
10622 op_free(entersubop);
10623
7d789282
FC		 10624 if (opnum == OP_ENTEREVAL
10625 && GvNAMELEN(namegv)==9 && strnEQ(GvNAME(namegv), "evalbytes", 9))
10626 flags |= OPpEVAL_BYTES <<8;
10627
4aaa4757
FC		 10628 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
10629 case OA_UNOP:
10630 case OA_BASEOP_OR_UNOP:
10631 case OA_FILESTATOP:
7d789282 10632 return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
4aaa4757
FC		 10633 case OA_BASEOP:
10634 if (aop) {
10635#ifdef PERL_MAD
10636 if (!PL_madskills || seenarg)
10637#endif
ce16c625 10638 (void)too_many_arguments_pv(aop, GvNAME(namegv), 0);
4aaa4757
FC		 10639 op_free(aop);
10640 }
98be9964
FC		 10641 return opnum == OP_RUNCV
10642 ? newPVOP(OP_RUNCV,0,NULL)
10643 : newOP(opnum,0);
4aaa4757
FC		 10644 default:
10645 return convert(opnum,0,aop);
10646 }
10647 }
10648 assert(0);
10649 return entersubop;
10650}
10651
d9088386
Z		 10652/*
10653=for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
10654
10655Retrieves the function that will be used to fix up a call to I<cv>.
10656Specifically, the function is applied to an C<entersub> op tree for a
10657subroutine call, not marked with C<&>, where the callee can be identified
10658at compile time as I<cv>.
10659
10660The C-level function pointer is returned in I<*ckfun_p>, and an SV
10661argument for it is returned in I<*ckobj_p>. The function is intended
10662to be called in this manner:
10663
10664 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
10665
10666In this call, I<entersubop> is a pointer to the C<entersub> op,
10667which may be replaced by the check function, and I<namegv> is a GV
10668supplying the name that should be used by the check function to refer
10669to the callee of the C<entersub> op if it needs to emit any diagnostics.
10670It is permitted to apply the check function in non-standard situations,
10671such as to a call to a different subroutine or to a method call.
340458b5 10672
d9088386
Z		 10673By default, the function is
10674L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
10675and the SV parameter is I<cv> itself. This implements standard
10676prototype processing. It can be changed, for a particular subroutine,
10677by L</cv_set_call_checker>.
74735042 10678
d9088386
Z		 10679=cut
10680*/
10681
10682void
10683Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
10684{
10685 MAGIC *callmg;
10686 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
10687 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
10688 if (callmg) {
10689 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
10690 *ckobj_p = callmg->mg_obj;
10691 } else {
10692 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
10693 *ckobj_p = (SV*)cv;
10694 }
10695}
10696
10697/*
10698=for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
10699
10700Sets the function that will be used to fix up a call to I<cv>.
10701Specifically, the function is applied to an C<entersub> op tree for a
10702subroutine call, not marked with C<&>, where the callee can be identified
10703at compile time as I<cv>.
10704
10705The C-level function pointer is supplied in I<ckfun>, and an SV argument
10706for it is supplied in I<ckobj>. The function is intended to be called
10707in this manner:
10708
10709 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
10710
10711In this call, I<entersubop> is a pointer to the C<entersub> op,
10712which may be replaced by the check function, and I<namegv> is a GV
10713supplying the name that should be used by the check function to refer
10714to the callee of the C<entersub> op if it needs to emit any diagnostics.
10715It is permitted to apply the check function in non-standard situations,
10716such as to a call to a different subroutine or to a method call.
10717
10718The current setting for a particular CV can be retrieved by
10719L</cv_get_call_checker>.
10720
10721=cut
10722*/
10723
10724void
10725Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
10726{
10727 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
10728 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
10729 if (SvMAGICAL((SV*)cv))
10730 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
10731 } else {
10732 MAGIC *callmg;
10733 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
10734 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
10735 if (callmg->mg_flags & MGf_REFCOUNTED) {
10736 SvREFCNT_dec(callmg->mg_obj);
10737 callmg->mg_flags &= ~MGf_REFCOUNTED;
10738 }
10739 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
10740 callmg->mg_obj = ckobj;
10741 if (ckobj != (SV*)cv) {
10742 SvREFCNT_inc_simple_void_NN(ckobj);
10743 callmg->mg_flags |= MGf_REFCOUNTED;
74735042 10744 }
09fb282d 10745 callmg->mg_flags |= MGf_COPY;
340458b5 10746 }
d9088386
Z		 10747}
10748
10749OP *
10750Perl_ck_subr(pTHX_ OP *o)
10751{
10752 OP *aop, *cvop;
10753 CV *cv;
10754 GV *namegv;
10755
10756 PERL_ARGS_ASSERT_CK_SUBR;
10757
10758 aop = cUNOPx(o)->op_first;
10759 if (!aop->op_sibling)
10760 aop = cUNOPx(aop)->op_first;
10761 aop = aop->op_sibling;
10762 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
10763 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
10764 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_RETURN_NAME_GV) : NULL;
10765
767eda44 10766 o->op_private &= ~1;
d9088386
Z		 10767 o->op_private |= OPpENTERSUB_HASTARG;
10768 o->op_private |= (PL_hints & HINT_STRICT_REFS);
10769 if (PERLDB_SUB && PL_curstash != PL_debstash)
10770 o->op_private |= OPpENTERSUB_DB;
10771 if (cvop->op_type == OP_RV2CV) {
10772 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
10773 op_null(cvop);
10774 } else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
10775 if (aop->op_type == OP_CONST)
10776 aop->op_private &= ~OPpCONST_STRICT;
10777 else if (aop->op_type == OP_LIST) {
10778 OP * const sib = ((UNOP*)aop)->op_first->op_sibling;
10779 if (sib && sib->op_type == OP_CONST)
10780 sib->op_private &= ~OPpCONST_STRICT;
10781 }
10782 }
10783
10784 if (!cv) {
10785 return ck_entersub_args_list(o);
10786 } else {
10787 Perl_call_checker ckfun;
10788 SV *ckobj;
10789 cv_get_call_checker(cv, &ckfun, &ckobj);
279d09bf
FC		 10790 if (!namegv) { /* expletive! */
10791 /* XXX The call checker API is public. And it guarantees that
10792 a GV will be provided with the right name. So we have
10793 to create a GV. But it is still not correct, as its
10794 stringification will include the package. What we
10795 really need is a new call checker API that accepts a
10796 GV or string (or GV or CV). */
10797 HEK * const hek = CvNAME_HEK(cv);
3a74e0e2
FC		 10798 /* After a syntax error in a lexical sub, the cv that
10799 rv2cv_op_cv returns may be a nameless stub. */
10800 if (!hek) return ck_entersub_args_list(o);;
279d09bf
FC		 10801 namegv = (GV *)sv_newmortal();
10802 gv_init_pvn(namegv, PL_curstash, HEK_KEY(hek), HEK_LEN(hek),
10803 SVf_UTF8 * !!HEK_UTF8(hek));
10804 }
d9088386
Z		 10805 return ckfun(aTHX_ o, namegv, ckobj);
10806 }
79072805
LW		 10807}
10808
10809OP *
cea2e8a9 10810Perl_ck_svconst(pTHX_ OP *o)
8990e307 10811{
7fa949d0 10812 SV * const sv = cSVOPo->op_sv;
7918f24d 10813 PERL_ARGS_ASSERT_CK_SVCONST;
96a5add6 10814 PERL_UNUSED_CONTEXT;
56e04a76 10815#ifdef PERL_OLD_COPY_ON_WRITE
7fa949d0
FC		 10816 if (SvIsCOW(sv)) sv_force_normal(sv);
10817#elif defined(PERL_NEW_COPY_ON_WRITE)
10818 /* Since the read-only flag may be used to protect a string buffer, we
10819 cannot do copy-on-write with existing read-only scalars that are not
10820 already copy-on-write scalars. To allow $_ = "hello" to do COW with
10821 that constant, mark the constant as COWable here, if it is not
10822 already read-only. */
10823 if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
10824 SvIsCOW_on(sv);
10825 CowREFCNT(sv) = 0;
10826 }
56e04a76 10827#endif
7fa949d0 10828 SvREADONLY_on(sv);
11343788 10829 return o;
8990e307
LW		 10830}
10831
10832OP *
cea2e8a9 10833Perl_ck_trunc(pTHX_ OP *o)
79072805 10834{
7918f24d
NC		 10835 PERL_ARGS_ASSERT_CK_TRUNC;
10836
11343788
MB		 10837 if (o->op_flags & OPf_KIDS) {
10838 SVOP *kid = (SVOP*)cUNOPo->op_first;
79072805 10839
a0d0e21e
LW		 10840 if (kid->op_type == OP_NULL)
10841 kid = (SVOP*)kid->op_sibling;
bb53490d 10842 if (kid && kid->op_type == OP_CONST &&
3513c740
NT		 10843 (kid->op_private & OPpCONST_BARE) &&
10844 !kid->op_folded)
bb53490d 10845 {
11343788 10846 o->op_flags |= OPf_SPECIAL;
bb53490d
GS		 10847 kid->op_private &= ~OPpCONST_STRICT;
10848 }
79072805 10849 }
11343788 10850 return ck_fun(o);
79072805
LW		 10851}
10852
35fba0d9
RG		 10853OP *
10854Perl_ck_substr(pTHX_ OP *o)
10855{
7918f24d
NC		 10856 PERL_ARGS_ASSERT_CK_SUBSTR;
10857
35fba0d9 10858 o = ck_fun(o);
1d866c12 10859 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
35fba0d9
RG		 10860 OP *kid = cLISTOPo->op_first;
10861
10862 if (kid->op_type == OP_NULL)
10863 kid = kid->op_sibling;
10864 if (kid)
10865 kid->op_flags |= OPf_MOD;
10866
10867 }
10868 return o;
10869}
10870
878d132a 10871OP *
8dc99089
FC		 10872Perl_ck_tell(pTHX_ OP *o)
10873{
8dc99089
FC		 10874 PERL_ARGS_ASSERT_CK_TELL;
10875 o = ck_fun(o);
e9d7a483
FC		 10876 if (o->op_flags & OPf_KIDS) {
10877 OP *kid = cLISTOPo->op_first;
423e8af5 10878 if (kid->op_type == OP_NULL && kid->op_sibling) kid = kid->op_sibling;
e9d7a483
FC		 10879 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
10880 }
8dc99089
FC		 10881 return o;
10882}
10883
10884OP *
cba5a3b0
DG		 10885Perl_ck_each(pTHX_ OP *o)
10886{
10887 dVAR;
10888 OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
10889 const unsigned orig_type = o->op_type;
10890 const unsigned array_type = orig_type == OP_EACH ? OP_AEACH
10891 : orig_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
10892 const unsigned ref_type = orig_type == OP_EACH ? OP_REACH
10893 : orig_type == OP_KEYS ? OP_RKEYS : OP_RVALUES;
10894
10895 PERL_ARGS_ASSERT_CK_EACH;
10896
10897 if (kid) {
10898 switch (kid->op_type) {
10899 case OP_PADHV:
10900 case OP_RV2HV:
10901 break;
10902 case OP_PADAV:
10903 case OP_RV2AV:
10904 CHANGE_TYPE(o, array_type);
10905 break;
10906 case OP_CONST:
7ac5715b
FC		 10907 if (kid->op_private == OPpCONST_BARE
10908 || !SvROK(cSVOPx_sv(kid))
10909 || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
10910 && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV )
10911 )
10912 /* we let ck_fun handle it */
cba5a3b0
DG		 10913 break;
10914 default:
10915 CHANGE_TYPE(o, ref_type);
7ac5715b 10916 scalar(kid);
cba5a3b0
DG		 10917 }
10918 }
10919 /* if treating as a reference, defer additional checks to runtime */
10920 return o->op_type == ref_type ? o : ck_fun(o);
10921}
10922
e508c8a4
MH		 10923OP *
10924Perl_ck_length(pTHX_ OP *o)
10925{
10926 PERL_ARGS_ASSERT_CK_LENGTH;
10927
10928 o = ck_fun(o);
10929
10930 if (ckWARN(WARN_SYNTAX)) {
10931 const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
10932
10933 if (kid) {
579333ee
FC		 10934 SV *name = NULL;
10935 const bool hash = kid->op_type == OP_PADHV
10936 || kid->op_type == OP_RV2HV;
e508c8a4
MH		 10937 switch (kid->op_type) {
10938 case OP_PADHV:
e508c8a4 10939 case OP_PADAV:
579333ee 10940 case OP_RV2HV:
e508c8a4 10941 case OP_RV2AV:
0920b7fa 10942 name = S_op_varname(aTHX_ kid);
e508c8a4 10943 break;
e508c8a4 10944 default:
579333ee 10945 return o;
e508c8a4 10946 }
579333ee
FC		 10947 if (name)
10948 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10949 "length() used on %"SVf" (did you mean \"scalar(%s%"SVf
10950 ")\"?)",
10951 name, hash ? "keys " : "", name
10952 );
10953 else if (hash)
25e26107 10954 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
579333ee
FC		 10955 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10956 "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
10957 else
25e26107 10958 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
579333ee
FC		 10959 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10960 "length() used on @array (did you mean \"scalar(@array)\"?)");
e508c8a4
MH		 10961 }
10962 }
10963
10964 return o;
10965}
10966
540dd770
GG		 10967/* Check for in place reverse and sort assignments like "@a = reverse @a"
10968 and modify the optree to make them work inplace */
e52d58aa 10969
540dd770
GG		 10970STATIC void
10971S_inplace_aassign(pTHX_ OP *o) {
e52d58aa 10972
540dd770
GG		 10973 OP *modop, *modop_pushmark;
10974 OP *oright;
10975 OP *oleft, *oleft_pushmark;
e52d58aa 10976
540dd770 10977 PERL_ARGS_ASSERT_INPLACE_AASSIGN;
e52d58aa 10978
540dd770 10979 assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
e52d58aa 10980
540dd770
GG		 10981 assert(cUNOPo->op_first->op_type == OP_NULL);
10982 modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
10983 assert(modop_pushmark->op_type == OP_PUSHMARK);
10984 modop = modop_pushmark->op_sibling;
e92f843d 10985
540dd770
GG		 10986 if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
10987 return;
10988
10989 /* no other operation except sort/reverse */
10990 if (modop->op_sibling)
10991 return;
10992
10993 assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
a46b39a8 10994 if (!(oright = cUNOPx(modop)->op_first->op_sibling)) return;
540dd770
GG		 10995
10996 if (modop->op_flags & OPf_STACKED) {
10997 /* skip sort subroutine/block */
10998 assert(oright->op_type == OP_NULL);
10999 oright = oright->op_sibling;
11000 }
11001
11002 assert(cUNOPo->op_first->op_sibling->op_type == OP_NULL);
11003 oleft_pushmark = cUNOPx(cUNOPo->op_first->op_sibling)->op_first;
11004 assert(oleft_pushmark->op_type == OP_PUSHMARK);
11005 oleft = oleft_pushmark->op_sibling;
11006
11007 /* Check the lhs is an array */
11008 if (!oleft ||
11009 (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
11010 || oleft->op_sibling
11011 || (oleft->op_private & OPpLVAL_INTRO)
11012 )
11013 return;
11014
11015 /* Only one thing on the rhs */
11016 if (oright->op_sibling)
11017 return;
2f9e2db0
VP		 11018
11019 /* check the array is the same on both sides */
11020 if (oleft->op_type == OP_RV2AV) {
11021 if (oright->op_type != OP_RV2AV
11022 || !cUNOPx(oright)->op_first
11023 || cUNOPx(oright)->op_first->op_type != OP_GV
18e3e9ce 11024 || cUNOPx(oleft )->op_first->op_type != OP_GV
2f9e2db0
VP		 11025 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
11026 cGVOPx_gv(cUNOPx(oright)->op_first)
11027 )
540dd770 11028 return;
2f9e2db0
VP		 11029 }
11030 else if (oright->op_type != OP_PADAV
11031 || oright->op_targ != oleft->op_targ
11032 )
540dd770
GG		 11033 return;
11034
11035 /* This actually is an inplace assignment */
e52d58aa 11036
540dd770
GG		 11037 modop->op_private |= OPpSORT_INPLACE;
11038
11039 /* transfer MODishness etc from LHS arg to RHS arg */
11040 oright->op_flags = oleft->op_flags;
11041
11042 /* remove the aassign op and the lhs */
11043 op_null(o);
11044 op_null(oleft_pushmark);
11045 if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
11046 op_null(cUNOPx(oleft)->op_first);
11047 op_null(oleft);
2f9e2db0
VP		 11048}
11049
3c78429c
DM		 11050#define MAX_DEFERRED 4
11051
11052#define DEFER(o) \
d7ab38e8 11053 STMT_START { \
3c78429c
DM		 11054 if (defer_ix == (MAX_DEFERRED-1)) { \
11055 CALL_RPEEP(defer_queue[defer_base]); \
11056 defer_base = (defer_base + 1) % MAX_DEFERRED; \
11057 defer_ix--; \
11058 } \
d7ab38e8
FC		 11059 defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = o; \
11060 } STMT_END
3c78429c 11061
61b743bb
DM		 11062/* A peephole optimizer. We visit the ops in the order they're to execute.
11063 * See the comments at the top of this file for more details about when
11064 * peep() is called */
463ee0b2 11065
79072805 11066void
5aaab254 11067Perl_rpeep(pTHX_ OP *o)
79072805 11068{
27da23d5 11069 dVAR;
eb578fdb 11070 OP* oldop = NULL;
4774ee0a 11071 OP* oldoldop = NULL;
3c78429c
DM		 11072 OP* defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
11073 int defer_base = 0;
11074 int defer_ix = -1;
2d8e6c8d 11075
2814eb74 11076 if (!o || o->op_opt)
79072805 11077 return;
a0d0e21e 11078 ENTER;
462e5cf6 11079 SAVEOP();
7766f137 11080 SAVEVPTR(PL_curcop);
3c78429c
DM		 11081 for (;; o = o->op_next) {
11082 if (o && o->op_opt)
11083 o = NULL;
cd197e1e
VP		 11084 if (!o) {
11085 while (defer_ix >= 0)
11086 CALL_RPEEP(defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED]);
3c78429c 11087 break;
cd197e1e 11088 }
3c78429c 11089
6d7dd4a5
NC		 11090 /* By default, this op has now been optimised. A couple of cases below
11091 clear this again. */
11092 o->op_opt = 1;
533c011a 11093 PL_op = o;
a0d0e21e 11094 switch (o->op_type) {
a0d0e21e 11095 case OP_DBSTATE:
3280af22 11096 PL_curcop = ((COP*)o); /* for warnings */
a0d0e21e 11097 break;
ac56e7de
NC		 11098 case OP_NEXTSTATE:
11099 PL_curcop = ((COP*)o); /* for warnings */
11100
11101 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
11102 to carry two labels. For now, take the easier option, and skip
11103 this optimisation if the first NEXTSTATE has a label. */
bcc76ee3 11104 if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
ac56e7de
NC		 11105 OP *nextop = o->op_next;
11106 while (nextop && nextop->op_type == OP_NULL)
11107 nextop = nextop->op_next;
11108
11109 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
11110 COP *firstcop = (COP *)o;
11111 COP *secondcop = (COP *)nextop;
11112 /* We want the COP pointed to by o (and anything else) to
11113 become the next COP down the line. */
11114 cop_free(firstcop);
11115
11116 firstcop->op_next = secondcop->op_next;
11117
11118 /* Now steal all its pointers, and duplicate the other
11119 data. */
11120 firstcop->cop_line = secondcop->cop_line;
11121#ifdef USE_ITHREADS
d4d03940 11122 firstcop->cop_stashoff = secondcop->cop_stashoff;
1dc74fdb 11123 firstcop->cop_file = secondcop->cop_file;
ac56e7de
NC		 11124#else
11125 firstcop->cop_stash = secondcop->cop_stash;
11126 firstcop->cop_filegv = secondcop->cop_filegv;
11127#endif
11128 firstcop->cop_hints = secondcop->cop_hints;
11129 firstcop->cop_seq = secondcop->cop_seq;
11130 firstcop->cop_warnings = secondcop->cop_warnings;
11131 firstcop->cop_hints_hash = secondcop->cop_hints_hash;
11132
11133#ifdef USE_ITHREADS
647688d8 11134 secondcop->cop_stashoff = 0;
1dc74fdb 11135 secondcop->cop_file = NULL;
ac56e7de
NC		 11136#else
11137 secondcop->cop_stash = NULL;
11138 secondcop->cop_filegv = NULL;
11139#endif
11140 secondcop->cop_warnings = NULL;
11141 secondcop->cop_hints_hash = NULL;
11142
11143 /* If we use op_null(), and hence leave an ex-COP, some
11144 warnings are misreported. For example, the compile-time
11145 error in 'use strict; no strict refs;' */
11146 secondcop->op_type = OP_NULL;
11147 secondcop->op_ppaddr = PL_ppaddr[OP_NULL];
11148 }
11149 }
11150 break;
a0d0e21e 11151
df91b2c5
AE		 11152 case OP_CONCAT:
11153 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
11154 if (o->op_next->op_private & OPpTARGET_MY) {
11155 if (o->op_flags & OPf_STACKED) /* chained concats */
a6aa0b75 11156 break; /* ignore_optimization */
df91b2c5
AE		 11157 else {
11158 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
11159 o->op_targ = o->op_next->op_targ;
11160 o->op_next->op_targ = 0;
11161 o->op_private |= OPpTARGET_MY;
11162 }
11163 }
11164 op_null(o->op_next);
11165 }
df91b2c5 11166 break;
6d7dd4a5
NC		 11167 case OP_STUB:
11168 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
11169 break; /* Scalar stub must produce undef. List stub is noop */
11170 }
11171 goto nothin;
79072805 11172 case OP_NULL:
acb36ea4 11173 if (o->op_targ == OP_NEXTSTATE
5edb5b2a 11174 || o->op_targ == OP_DBSTATE)
acb36ea4 11175 {
3280af22 11176 PL_curcop = ((COP*)o);
acb36ea4 11177 }
dad75012 11178 /* XXX: We avoid setting op_seq here to prevent later calls
1a0a2ba9 11179 to rpeep() from mistakenly concluding that optimisation
dad75012
AMS		 11180 has already occurred. This doesn't fix the real problem,
11181 though (See 20010220.007). AMS 20010719 */
2814eb74 11182 /* op_seq functionality is now replaced by op_opt */
6d7dd4a5 11183 o->op_opt = 0;
f46f2f82 11184 /* FALL THROUGH */
79072805 11185 case OP_SCALAR:
93a17b20 11186 case OP_LINESEQ:
463ee0b2 11187 case OP_SCOPE:
6d7dd4a5 11188 nothin:
a0d0e21e
LW		 11189 if (oldop && o->op_next) {
11190 oldop->op_next = o->op_next;
6d7dd4a5 11191 o->op_opt = 0;
79072805
LW		 11192 continue;
11193 }
79072805
LW		 11194 break;
11195
a7fd8ef6
DM		 11196 case OP_PUSHMARK:
11197
11198 /* Convert a series of PAD ops for my vars plus support into a
11199 * single padrange op. Basically
11200 *
11201 * pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
11202 *
11203 * becomes, depending on circumstances, one of
11204 *
11205 * padrange ----------------------------------> (list) -> rest
11206 * padrange --------------------------------------------> rest
11207 *
11208 * where all the pad indexes are sequential and of the same type
11209 * (INTRO or not).
11210 * We convert the pushmark into a padrange op, then skip
11211 * any other pad ops, and possibly some trailing ops.
11212 * Note that we don't null() the skipped ops, to make it
11213 * easier for Deparse to undo this optimisation (and none of
11214 * the skipped ops are holding any resourses). It also makes
11215 * it easier for find_uninit_var(), as it can just ignore
11216 * padrange, and examine the original pad ops.
11217 */
11218 {
11219 OP *p;
11220 OP *followop = NULL; /* the op that will follow the padrange op */
11221 U8 count = 0;
11222 U8 intro = 0;
11223 PADOFFSET base = 0; /* init only to stop compiler whining */
11224 U8 gimme = 0; /* init only to stop compiler whining */
d5524600 11225 bool defav = 0; /* seen (...) = @_ */
fd3cc9e5 11226 bool reuse = 0; /* reuse an existing padrange op */
d5524600
DM		 11227
11228 /* look for a pushmark -> gv[_] -> rv2av */
11229
11230 {
11231 GV *gv;
11232 OP *rv2av, *q;
11233 p = o->op_next;
11234 if ( p->op_type == OP_GV
11235 && (gv = cGVOPx_gv(p))
11236 && GvNAMELEN_get(gv) == 1
11237 && *GvNAME_get(gv) == '_'
11238 && GvSTASH(gv) == PL_defstash
11239 && (rv2av = p->op_next)
11240 && rv2av->op_type == OP_RV2AV
11241 && !(rv2av->op_flags & OPf_REF)
11242 && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
11243 && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
11244 && o->op_sibling == rv2av /* these two for Deparse */
11245 && cUNOPx(rv2av)->op_first == p
11246 ) {
11247 q = rv2av->op_next;
11248 if (q->op_type == OP_NULL)
11249 q = q->op_next;
11250 if (q->op_type == OP_PUSHMARK) {
11251 defav = 1;
11252 p = q;
11253 }
11254 }
11255 }
11256 if (!defav) {
11257 /* To allow Deparse to pessimise this, it needs to be able
11258 * to restore the pushmark's original op_next, which it
11259 * will assume to be the same as op_sibling. */
11260 if (o->op_next != o->op_sibling)
11261 break;
11262 p = o;
11263 }
a7fd8ef6
DM		 11264
11265 /* scan for PAD ops */
11266
d5524600 11267 for (p = p->op_next; p; p = p->op_next) {
a7fd8ef6
DM		 11268 if (p->op_type == OP_NULL)
11269 continue;
11270
11271 if (( p->op_type != OP_PADSV
11272 && p->op_type != OP_PADAV
11273 && p->op_type != OP_PADHV
11274 )
11275 /* any private flag other than INTRO? e.g. STATE */
11276 || (p->op_private & ~OPpLVAL_INTRO)
11277 )
11278 break;
11279
11280 /* let $a[N] potentially be optimised into ALEMFAST_LEX
11281 * instead */
11282 if ( p->op_type == OP_PADAV
11283 && p->op_next
11284 && p->op_next->op_type == OP_CONST
11285 && p->op_next->op_next
11286 && p->op_next->op_next->op_type == OP_AELEM
11287 )
11288 break;
11289
11290 /* for 1st padop, note what type it is and the range
11291 * start; for the others, check that it's the same type
11292 * and that the targs are contiguous */
11293 if (count == 0) {
11294 intro = (p->op_private & OPpLVAL_INTRO);
11295 base = p->op_targ;
11296 gimme = (p->op_flags & OPf_WANT);
11297 }
11298 else {
11299 if ((p->op_private & OPpLVAL_INTRO) != intro)
11300 break;
18c931a3
DM		 11301 /* Note that you'd normally expect targs to be
11302 * contiguous in my($a,$b,$c), but that's not the case
11303 * when external modules start doing things, e.g.
11304 i* Function::Parameters */
11305 if (p->op_targ != base + count)
a7fd8ef6
DM		 11306 break;
11307 assert(p->op_targ == base + count);
11308 /* all the padops should be in the same context */
11309 if (gimme != (p->op_flags & OPf_WANT))
11310 break;
11311 }
11312
11313 /* for AV, HV, only when we're not flattening */
11314 if ( p->op_type != OP_PADSV
11315 && gimme != OPf_WANT_VOID
11316 && !(p->op_flags & OPf_REF)
11317 )
11318 break;
11319
11320 if (count >= OPpPADRANGE_COUNTMASK)
11321 break;
11322
4e09461c
DM		 11323 /* there's a biggest base we can fit into a
11324 * SAVEt_CLEARPADRANGE in pp_padrange */
11325 if (intro && base >
11326 (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT)))
11327 break;
11328
a7fd8ef6
DM		 11329 /* Success! We've got another valid pad op to optimise away */
11330 count++;
11331 followop = p->op_next;
11332 }
11333
11334 if (count < 1)
11335 break;
11336
4774ee0a 11337 /* pp_padrange in specifically compile-time void context
a7fd8ef6
DM		 11338 * skips pushing a mark and lexicals; in all other contexts
11339 * (including unknown till runtime) it pushes a mark and the
11340 * lexicals. We must be very careful then, that the ops we
11341 * optimise away would have exactly the same effect as the
11342 * padrange.
11343 * In particular in void context, we can only optimise to
11344 * a padrange if see see the complete sequence
11345 * pushmark, pad*v, ...., list, nextstate
11346 * which has the net effect of of leaving the stack empty
11347 * (for now we leave the nextstate in the execution chain, for
11348 * its other side-effects).
11349 */
11350 assert(followop);
11351 if (gimme == OPf_WANT_VOID) {
11352 if (followop->op_type == OP_LIST
11353 && gimme == (followop->op_flags & OPf_WANT)
11354 && ( followop->op_next->op_type == OP_NEXTSTATE
11355 || followop->op_next->op_type == OP_DBSTATE))
4774ee0a 11356 {
a7fd8ef6 11357 followop = followop->op_next; /* skip OP_LIST */
4774ee0a
DM		 11358
11359 /* consolidate two successive my(...);'s */
fd3cc9e5 11360
4774ee0a
DM		 11361 if ( oldoldop
11362 && oldoldop->op_type == OP_PADRANGE
11363 && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
11364 && (oldoldop->op_private & OPpLVAL_INTRO) == intro
fd3cc9e5 11365 && !(oldoldop->op_flags & OPf_SPECIAL)
4774ee0a
DM		 11366 ) {
11367 U8 old_count;
11368 assert(oldoldop->op_next == oldop);
11369 assert( oldop->op_type == OP_NEXTSTATE
11370 || oldop->op_type == OP_DBSTATE);
11371 assert(oldop->op_next == o);
11372
11373 old_count
11374 = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
4774ee0a 11375
aa033da5
FC		 11376 /* Do not assume pad offsets for $c and $d are con-
11377 tiguous in
11378 my ($a,$b,$c);
11379 my ($d,$e,$f);
11380 */
11381 if ( oldoldop->op_targ + old_count == base
11382 && old_count < OPpPADRANGE_COUNTMASK - count) {
fd3cc9e5
DM		 11383 base = oldoldop->op_targ;
11384 count += old_count;
11385 reuse = 1;
4774ee0a
DM		 11386 }
11387 }
fd3cc9e5
DM		 11388
11389 /* if there's any immediately following singleton
11390 * my var's; then swallow them and the associated
11391 * nextstates; i.e.
11392 * my ($a,$b); my $c; my $d;
11393 * is treated as
11394 * my ($a,$b,$c,$d);
11395 */
11396
11397 while ( ((p = followop->op_next))
11398 && ( p->op_type == OP_PADSV
11399 || p->op_type == OP_PADAV
11400 || p->op_type == OP_PADHV)
11401 && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
11402 && (p->op_private & OPpLVAL_INTRO) == intro
11403 && p->op_next
11404 && ( p->op_next->op_type == OP_NEXTSTATE
11405 || p->op_next->op_type == OP_DBSTATE)
11406 && count < OPpPADRANGE_COUNTMASK
7601007b 11407 && base + count == p->op_targ
fd3cc9e5 11408 ) {
fd3cc9e5
DM		 11409 count++;
11410 followop = p->op_next;
11411 }
4774ee0a 11412 }
a7fd8ef6
DM		 11413 else
11414 break;
11415 }
11416
fd3cc9e5
DM		 11417 if (reuse) {
11418 assert(oldoldop->op_type == OP_PADRANGE);
11419 oldoldop->op_next = followop;
11420 oldoldop->op_private = (intro | count);
11421 o = oldoldop;
11422 oldop = NULL;
11423 oldoldop = NULL;
11424 }
11425 else {
11426 /* Convert the pushmark into a padrange.
11427 * To make Deparse easier, we guarantee that a padrange was
11428 * *always* formerly a pushmark */
11429 assert(o->op_type == OP_PUSHMARK);
11430 o->op_next = followop;
11431 o->op_type = OP_PADRANGE;
11432 o->op_ppaddr = PL_ppaddr[OP_PADRANGE];
11433 o->op_targ = base;
11434 /* bit 7: INTRO; bit 6..0: count */
11435 o->op_private = (intro | count);
11436 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
11437 | gimme | (defav ? OPf_SPECIAL : 0));
11438 }
a7fd8ef6
DM		 11439 break;
11440 }
11441
6a077020 11442 case OP_PADAV:
79072805 11443 case OP_GV:
6a077020 11444 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
0bd48802 11445 OP* const pop = (o->op_type == OP_PADAV) ?
6a077020 11446 o->op_next : o->op_next->op_next;
a0d0e21e 11447 IV i;
f9dc862f 11448 if (pop && pop->op_type == OP_CONST &&
af5acbb4 11449 ((PL_op = pop->op_next)) &&
8990e307 11450 pop->op_next->op_type == OP_AELEM &&
a0d0e21e 11451 !(pop->op_next->op_private &
78f9721b 11452 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
e1dccc0d 11453 (i = SvIV(((SVOP*)pop)->op_sv)) <= 255 && i >= 0)
8990e307 11454 {
350de78d 11455 GV *gv;
af5acbb4
DM		 11456 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
11457 no_bareword_allowed(pop);
6a077020
DM		 11458 if (o->op_type == OP_GV)
11459 op_null(o->op_next);
93c66552
DM		 11460 op_null(pop->op_next);
11461 op_null(pop);
a0d0e21e
LW		 11462 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
11463 o->op_next = pop->op_next->op_next;
22c35a8c 11464 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
a0d0e21e 11465 o->op_private = (U8)i;
6a077020
DM		 11466 if (o->op_type == OP_GV) {
11467 gv = cGVOPo_gv;
11468 GvAVn(gv);
93bad3fd 11469 o->op_type = OP_AELEMFAST;
6a077020
DM		 11470 }
11471 else
93bad3fd 11472 o->op_type = OP_AELEMFAST_LEX;
6a077020 11473 }
6a077020
DM		 11474 break;
11475 }
11476
11477 if (o->op_next->op_type == OP_RV2SV) {
11478 if (!(o->op_next->op_private & OPpDEREF)) {
11479 op_null(o->op_next);
11480 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
11481 | OPpOUR_INTRO);
11482 o->op_next = o->op_next->op_next;
11483 o->op_type = OP_GVSV;
11484 o->op_ppaddr = PL_ppaddr[OP_GVSV];
8990e307 11485 }
79072805 11486 }
89de2904
AMS		 11487 else if (o->op_next->op_type == OP_READLINE
11488 && o->op_next->op_next->op_type == OP_CONCAT
11489 && (o->op_next->op_next->op_flags & OPf_STACKED))
11490 {
d2c45030
AMS		 11491 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
11492 o->op_type = OP_RCATLINE;
11493 o->op_flags |= OPf_STACKED;
11494 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
89de2904 11495 op_null(o->op_next->op_next);
d2c45030 11496 op_null(o->op_next);
89de2904 11497 }
76cd736e 11498
79072805 11499 break;
867fa1e2
YO		 11500
11501 {
11502 OP *fop;
11503 OP *sop;
11504
9e7f031c
FC		 11505#define HV_OR_SCALARHV(op) \
11506 ( (op)->op_type == OP_PADHV || (op)->op_type == OP_RV2HV \
11507 ? (op) \
11508 : (op)->op_type == OP_SCALAR && (op)->op_flags & OPf_KIDS \
11509 && ( cUNOPx(op)->op_first->op_type == OP_PADHV \
11510 || cUNOPx(op)->op_first->op_type == OP_RV2HV) \
11511 ? cUNOPx(op)->op_first \
11512 : NULL)
11513
867fa1e2 11514 case OP_NOT:
9e7f031c
FC		 11515 if ((fop = HV_OR_SCALARHV(cUNOP->op_first)))
11516 fop->op_private |= OPpTRUEBOOL;
867fa1e2
YO		 11517 break;
11518
11519 case OP_AND:
79072805 11520 case OP_OR:
c963b151 11521 case OP_DOR:
867fa1e2
YO		 11522 fop = cLOGOP->op_first;
11523 sop = fop->op_sibling;
11524 while (cLOGOP->op_other->op_type == OP_NULL)
11525 cLOGOP->op_other = cLOGOP->op_other->op_next;
db4d68cf
DM		 11526 while (o->op_next && ( o->op_type == o->op_next->op_type
11527 || o->op_next->op_type == OP_NULL))
11528 o->op_next = o->op_next->op_next;
3c78429c 11529 DEFER(cLOGOP->op_other);
867fa1e2 11530
867fa1e2 11531 o->op_opt = 1;
c8fe3bdf
FC		 11532 fop = HV_OR_SCALARHV(fop);
11533 if (sop) sop = HV_OR_SCALARHV(sop);
11534 if (fop || sop
867fa1e2
YO		 11535 ){
11536 OP * nop = o;
11537 OP * lop = o;
aaf643ce 11538 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
867fa1e2
YO		 11539 while (nop && nop->op_next) {
11540 switch (nop->op_next->op_type) {
11541 case OP_NOT:
11542 case OP_AND:
11543 case OP_OR:
11544 case OP_DOR:
11545 lop = nop = nop->op_next;
11546 break;
11547 case OP_NULL:
11548 nop = nop->op_next;
11549 break;
11550 default:
11551 nop = NULL;
11552 break;
11553 }
11554 }
11555 }
c8fe3bdf
FC		 11556 if (fop) {
11557 if ( (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
20e53f5f 11558 || o->op_type == OP_AND )
c8fe3bdf
FC		 11559 fop->op_private |= OPpTRUEBOOL;
11560 else if (!(lop->op_flags & OPf_WANT))
adc42c31 11561 fop->op_private |= OPpMAYBE_TRUEBOOL;
6ea72b3a 11562 }
20e53f5f 11563 if ( (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
c8fe3bdf
FC		 11564 && sop)
11565 sop->op_private |= OPpTRUEBOOL;
867fa1e2
YO		 11566 }
11567
11568
11569 break;
867fa1e2 11570
a8b106e9 11571 case OP_COND_EXPR:
c8fe3bdf 11572 if ((fop = HV_OR_SCALARHV(cLOGOP->op_first)))
9e7f031c 11573 fop->op_private |= OPpTRUEBOOL;
a8b106e9
FC		 11574#undef HV_OR_SCALARHV
11575 /* GERONIMO! */
c8fe3bdf 11576 }
a8b106e9 11577
867fa1e2
YO		 11578 case OP_MAPWHILE:
11579 case OP_GREPWHILE:
2c2d71f5
JH		 11580 case OP_ANDASSIGN:
11581 case OP_ORASSIGN:
c963b151 11582 case OP_DORASSIGN:
1a67a97c 11583 case OP_RANGE:
c5917253 11584 case OP_ONCE:
fd4d1407
IZ		 11585 while (cLOGOP->op_other->op_type == OP_NULL)
11586 cLOGOP->op_other = cLOGOP->op_other->op_next;
3c78429c 11587 DEFER(cLOGOP->op_other);
79072805
LW		 11588 break;
11589
79072805 11590 case OP_ENTERLOOP:
9c2ca71a 11591 case OP_ENTERITER:
58cccf98
SM		 11592 while (cLOOP->op_redoop->op_type == OP_NULL)
11593 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
58cccf98
SM		 11594 while (cLOOP->op_nextop->op_type == OP_NULL)
11595 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
58cccf98
SM		 11596 while (cLOOP->op_lastop->op_type == OP_NULL)
11597 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
3c78429c
DM		 11598 /* a while(1) loop doesn't have an op_next that escapes the
11599 * loop, so we have to explicitly follow the op_lastop to
11600 * process the rest of the code */
11601 DEFER(cLOOP->op_lastop);
79072805
LW		 11602 break;
11603
79072805 11604 case OP_SUBST:
29f2e912
NC		 11605 assert(!(cPMOP->op_pmflags & PMf_ONCE));
11606 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
11607 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
11608 cPMOP->op_pmstashstartu.op_pmreplstart
11609 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
3c78429c 11610 DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
79072805
LW		 11611 break;
11612
fe1bc4cf 11613 case OP_SORT: {
d7ab38e8
FC		 11614 OP *oright;
11615
11616 if (o->op_flags & OPf_STACKED) {
11617 OP * const kid =
11618 cUNOPx(cLISTOP->op_first->op_sibling)->op_first;
11619 if (kid->op_type == OP_SCOPE
08fdcd99
FC		 11620 || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE))
11621 DEFER(kLISTOP->op_first);
d7ab38e8
FC		 11622 }
11623
fe1bc4cf 11624 /* check that RHS of sort is a single plain array */
d7ab38e8 11625 oright = cUNOPo->op_first;
fe1bc4cf
DM		 11626 if (!oright || oright->op_type != OP_PUSHMARK)
11627 break;
471178c0 11628
540dd770
GG		 11629 if (o->op_private & OPpSORT_INPLACE)
11630 break;
11631
471178c0
NC		 11632 /* reverse sort ... can be optimised. */
11633 if (!cUNOPo->op_sibling) {
11634 /* Nothing follows us on the list. */
551405c4 11635 OP * const reverse = o->op_next;
471178c0
NC		 11636
11637 if (reverse->op_type == OP_REVERSE &&
11638 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
551405c4 11639 OP * const pushmark = cUNOPx(reverse)->op_first;
471178c0
NC		 11640 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
11641 && (cUNOPx(pushmark)->op_sibling == o)) {
11642 /* reverse -> pushmark -> sort */
11643 o->op_private |= OPpSORT_REVERSE;
11644 op_null(reverse);
11645 pushmark->op_next = oright->op_next;
11646 op_null(oright);
11647 }
11648 }
11649 }
11650
fe1bc4cf
DM		 11651 break;
11652 }
ef3e5ea9
NC		 11653
11654 case OP_REVERSE: {
e682d7b7 11655 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
ce335f37 11656 OP *gvop = NULL;
ef3e5ea9 11657 LISTOP *enter, *exlist;
ef3e5ea9 11658
540dd770 11659 if (o->op_private & OPpSORT_INPLACE)
484c818f 11660 break;
484c818f 11661
ef3e5ea9
NC		 11662 enter = (LISTOP *) o->op_next;
11663 if (!enter)
11664 break;
11665 if (enter->op_type == OP_NULL) {
11666 enter = (LISTOP *) enter->op_next;
11667 if (!enter)
11668 break;
11669 }
d46f46af
NC		 11670 /* for $a (...) will have OP_GV then OP_RV2GV here.
11671 for (...) just has an OP_GV. */
ce335f37
NC		 11672 if (enter->op_type == OP_GV) {
11673 gvop = (OP *) enter;
11674 enter = (LISTOP *) enter->op_next;
11675 if (!enter)
11676 break;
d46f46af
NC		 11677 if (enter->op_type == OP_RV2GV) {
11678 enter = (LISTOP *) enter->op_next;
11679 if (!enter)
ce335f37 11680 break;
d46f46af 11681 }
ce335f37
NC		 11682 }
11683
ef3e5ea9
NC		 11684 if (enter->op_type != OP_ENTERITER)
11685 break;
11686
11687 iter = enter->op_next;
11688 if (!iter || iter->op_type != OP_ITER)
11689 break;
11690
ce335f37
NC		 11691 expushmark = enter->op_first;
11692 if (!expushmark || expushmark->op_type != OP_NULL
11693 || expushmark->op_targ != OP_PUSHMARK)
11694 break;
11695
11696 exlist = (LISTOP *) expushmark->op_sibling;
ef3e5ea9
NC		 11697 if (!exlist || exlist->op_type != OP_NULL
11698 || exlist->op_targ != OP_LIST)
11699 break;
11700
11701 if (exlist->op_last != o) {
11702 /* Mmm. Was expecting to point back to this op. */
11703 break;
11704 }
11705 theirmark = exlist->op_first;
11706 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
11707 break;
11708
c491ecac 11709 if (theirmark->op_sibling != o) {
ef3e5ea9
NC		 11710 /* There's something between the mark and the reverse, eg
11711 for (1, reverse (...))
11712 so no go. */
11713 break;
11714 }
11715
c491ecac
NC		 11716 ourmark = ((LISTOP *)o)->op_first;
11717 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
11718 break;
11719
ef3e5ea9
NC		 11720 ourlast = ((LISTOP *)o)->op_last;
11721 if (!ourlast || ourlast->op_next != o)
11722 break;
11723
e682d7b7
NC		 11724 rv2av = ourmark->op_sibling;
11725 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
11726 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
11727 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
11728 /* We're just reversing a single array. */
11729 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
11730 enter->op_flags |= OPf_STACKED;
11731 }
11732
ef3e5ea9
NC		 11733 /* We don't have control over who points to theirmark, so sacrifice
11734 ours. */
11735 theirmark->op_next = ourmark->op_next;
11736 theirmark->op_flags = ourmark->op_flags;
ce335f37 11737 ourlast->op_next = gvop ? gvop : (OP *) enter;
ef3e5ea9
NC		 11738 op_null(ourmark);
11739 op_null(o);
11740 enter->op_private |= OPpITER_REVERSED;
11741 iter->op_private |= OPpITER_REVERSED;
11742
11743 break;
11744 }
e26df76a 11745
0477511c
NC		 11746 case OP_QR:
11747 case OP_MATCH:
29f2e912
NC		 11748 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
11749 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
11750 }
79072805 11751 break;
1830b3d9 11752
1a35f9ff
FC		 11753 case OP_RUNCV:
11754 if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)) {
11755 SV *sv;
e157a82b 11756 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
1a35f9ff
FC		 11757 else {
11758 sv = newRV((SV *)PL_compcv);
11759 sv_rvweaken(sv);
11760 SvREADONLY_on(sv);
11761 }
11762 o->op_type = OP_CONST;
11763 o->op_ppaddr = PL_ppaddr[OP_CONST];
11764 o->op_flags |= OPf_SPECIAL;
11765 cSVOPo->op_sv = sv;
11766 }
11767 break;
11768
24fcb59f
FC		 11769 case OP_SASSIGN:
11770 if (OP_GIMME(o,0) == G_VOID) {
11771 OP *right = cBINOP->op_first;
11772 if (right) {
11773 OP *left = right->op_sibling;
11774 if (left->op_type == OP_SUBSTR
11775 && (left->op_private & 7) < 4) {
11776 op_null(o);
11777 cBINOP->op_first = left;
11778 right->op_sibling =
11779 cBINOPx(left)->op_first->op_sibling;
11780 cBINOPx(left)->op_first->op_sibling = right;
11781 left->op_private |= OPpSUBSTR_REPL_FIRST;
d72a08ce
FC		 11782 left->op_flags =
11783 (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
24fcb59f
FC		 11784 }
11785 }
11786 }
11787 break;
11788
1830b3d9
BM		 11789 case OP_CUSTOM: {
11790 Perl_cpeep_t cpeep =
ae103e09 11791 XopENTRYCUSTOM(o, xop_peep);
1830b3d9
BM		 11792 if (cpeep)
11793 cpeep(aTHX_ o, oldop);
11794 break;
11795 }
11796
79072805 11797 }
4774ee0a 11798 oldoldop = oldop;
a0d0e21e 11799 oldop = o;
79072805 11800 }
a0d0e21e 11801 LEAVE;
79072805 11802}
beab0874 11803
1a0a2ba9 11804void
5aaab254 11805Perl_peep(pTHX_ OP *o)
1a0a2ba9
Z		 11806{
11807 CALL_RPEEP(o);
11808}
11809
9733086d
BM		 11810/*
11811=head1 Custom Operators
11812
11813=for apidoc Ao||custom_op_xop
ae103e09 11814Return the XOP structure for a given custom op. This macro should be
9733086d 11815considered internal to OP_NAME and the other access macros: use them instead.
ae103e09
DD		 11816This macro does call a function. Prior to 5.19.6, this was implemented as a
11817function.
9733086d
BM		 11818
11819=cut
11820*/
11821
ae103e09
DD		 11822XOPRETANY
11823Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
53e06cf0 11824{
1830b3d9
BM		 11825 SV *keysv;
11826 HE *he = NULL;
11827 XOP *xop;
11828
11829 static const XOP xop_null = { 0, 0, 0, 0, 0 };
53e06cf0 11830
ae103e09 11831 PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
1830b3d9 11832 assert(o->op_type == OP_CUSTOM);
7918f24d 11833
1830b3d9
BM		 11834 /* This is wrong. It assumes a function pointer can be cast to IV,
11835 * which isn't guaranteed, but this is what the old custom OP code
11836 * did. In principle it should be safer to Copy the bytes of the
11837 * pointer into a PV: since the new interface is hidden behind
11838 * functions, this can be changed later if necessary. */
11839 /* Change custom_op_xop if this ever happens */
11840 keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
53e06cf0 11841
1830b3d9
BM		 11842 if (PL_custom_ops)
11843 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
11844
11845 /* assume noone will have just registered a desc */
11846 if (!he && PL_custom_op_names &&
11847 (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
11848 ) {
11849 const char *pv;
11850 STRLEN l;
11851
11852 /* XXX does all this need to be shared mem? */
aca83993 11853 Newxz(xop, 1, XOP);
1830b3d9
BM		 11854 pv = SvPV(HeVAL(he), l);
11855 XopENTRY_set(xop, xop_name, savepvn(pv, l));
11856 if (PL_custom_op_descs &&
11857 (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
11858 ) {
11859 pv = SvPV(HeVAL(he), l);
11860 XopENTRY_set(xop, xop_desc, savepvn(pv, l));
11861 }
11862 Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
1830b3d9 11863 }
ae103e09
DD		 11864 else {
11865 if (!he)
11866 xop = (XOP *)&xop_null;
11867 else
11868 xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
11869 }
11870 {
11871 XOPRETANY any;
11872 if(field == XOPe_xop_ptr) {
11873 any.xop_ptr = xop;
11874 } else {
11875 const U32 flags = XopFLAGS(xop);
11876 if(flags & field) {
11877 switch(field) {
11878 case XOPe_xop_name:
11879 any.xop_name = xop->xop_name;
11880 break;
11881 case XOPe_xop_desc:
11882 any.xop_desc = xop->xop_desc;
11883 break;
11884 case XOPe_xop_class:
11885 any.xop_class = xop->xop_class;
11886 break;
11887 case XOPe_xop_peep:
11888 any.xop_peep = xop->xop_peep;
11889 break;
11890 default:
11891 NOT_REACHED;
11892 break;
11893 }
11894 } else {
11895 switch(field) {
11896 case XOPe_xop_name:
11897 any.xop_name = XOPd_xop_name;
11898 break;
11899 case XOPe_xop_desc:
11900 any.xop_desc = XOPd_xop_desc;
11901 break;
11902 case XOPe_xop_class:
11903 any.xop_class = XOPd_xop_class;
11904 break;
11905 case XOPe_xop_peep:
11906 any.xop_peep = XOPd_xop_peep;
11907 break;
11908 default:
11909 NOT_REACHED;
11910 break;
11911 }
11912 }
11913 }
11914 return any;
11915 }
53e06cf0
SC		 11916}
11917
9733086d
BM		 11918/*
11919=for apidoc Ao||custom_op_register
11920Register a custom op. See L<perlguts/"Custom Operators">.
53e06cf0 11921
9733086d
BM		 11922=cut
11923*/
7918f24d 11924
1830b3d9
BM		 11925void
11926Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
11927{
11928 SV *keysv;
11929
11930 PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
53e06cf0 11931
1830b3d9
BM		 11932 /* see the comment in custom_op_xop */
11933 keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
53e06cf0 11934
1830b3d9
BM		 11935 if (!PL_custom_ops)
11936 PL_custom_ops = newHV();
53e06cf0 11937
1830b3d9
BM		 11938 if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
11939 Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
53e06cf0 11940}
19e8ce8e 11941
b8c38f0a
FC		 11942/*
11943=head1 Functions in file op.c
11944
11945=for apidoc core_prototype
11946This function assigns the prototype of the named core function to C<sv>, or
11947to a new mortal SV if C<sv> is NULL. It returns the modified C<sv>, or
a051f6c4 11948NULL if the core function has no prototype. C<code> is a code as returned
a96df643 11949by C<keyword()>. It must not be equal to 0.
b8c38f0a
FC		 11950
11951=cut
11952*/
11953
11954SV *
be1b855b 11955Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
b66130dd 11956 int * const opnum)
b8c38f0a 11957{
b8c38f0a
FC		 11958 int i = 0, n = 0, seen_question = 0, defgv = 0;
11959 I32 oa;
11960#define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
11961 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
9927957a 11962 bool nullret = FALSE;
b8c38f0a
FC		 11963
11964 PERL_ARGS_ASSERT_CORE_PROTOTYPE;
11965
a96df643 11966 assert (code);
b8c38f0a
FC		 11967
11968 if (!sv) sv = sv_newmortal();
11969
9927957a 11970#define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
b8c38f0a 11971
4e338c21 11972 switch (code < 0 ? -code : code) {
b8c38f0a 11973 case KEY_and : case KEY_chop: case KEY_chomp:
4e338c21
FC		 11974 case KEY_cmp : case KEY_defined: case KEY_delete: case KEY_exec :
11975 case KEY_exists: case KEY_eq : case KEY_ge : case KEY_goto :
11976 case KEY_grep : case KEY_gt : case KEY_last : case KEY_le :
11977 case KEY_lt : case KEY_map : case KEY_ne : case KEY_next :
11978 case KEY_or : case KEY_print : case KEY_printf: case KEY_qr :
11979 case KEY_redo : case KEY_require: case KEY_return: case KEY_say :
11980 case KEY_select: case KEY_sort : case KEY_split : case KEY_system:
11981 case KEY_x : case KEY_xor :
9927957a 11982 if (!opnum) return NULL; nullret = TRUE; goto findopnum;
4e338c21 11983 case KEY_glob: retsetpvs("_;", OP_GLOB);
9927957a
FC		 11984 case KEY_keys: retsetpvs("+", OP_KEYS);
11985 case KEY_values: retsetpvs("+", OP_VALUES);
11986 case KEY_each: retsetpvs("+", OP_EACH);
11987 case KEY_push: retsetpvs("+@", OP_PUSH);
11988 case KEY_unshift: retsetpvs("+@", OP_UNSHIFT);
11989 case KEY_pop: retsetpvs(";+", OP_POP);
11990 case KEY_shift: retsetpvs(";+", OP_SHIFT);
4e338c21 11991 case KEY_pos: retsetpvs(";\\[$*]", OP_POS);
b8c38f0a 11992 case KEY_splice:
9927957a 11993 retsetpvs("+;$$@", OP_SPLICE);
b8c38f0a 11994 case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
9927957a 11995 retsetpvs("", 0);
7d789282
FC		 11996 case KEY_evalbytes:
11997 name = "entereval"; break;
b8c38f0a
FC		 11998 case KEY_readpipe:
11999 name = "backtick";
12000 }
12001
12002#undef retsetpvs
12003
9927957a 12004 findopnum:
b8c38f0a
FC		 12005 while (i < MAXO) { /* The slow way. */
12006 if (strEQ(name, PL_op_name[i])
12007 || strEQ(name, PL_op_desc[i]))
12008 {
9927957a 12009 if (nullret) { assert(opnum); *opnum = i; return NULL; }
b8c38f0a
FC		 12010 goto found;
12011 }
12012 i++;
12013 }
4e338c21 12014 return NULL;
b8c38f0a
FC		 12015 found:
12016 defgv = PL_opargs[i] & OA_DEFGV;
12017 oa = PL_opargs[i] >> OASHIFT;
12018 while (oa) {
465bc0f5 12019 if (oa & OA_OPTIONAL && !seen_question && (
ea5703f4 12020 !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
465bc0f5 12021 )) {
b8c38f0a
FC		 12022 seen_question = 1;
12023 str[n++] = ';';
12024 }
12025 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
12026 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
12027 /* But globs are already references (kinda) */
12028 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
12029 ) {
12030 str[n++] = '\\';
12031 }
1ecbeecf
FC		 12032 if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
12033 && !scalar_mod_type(NULL, i)) {
12034 str[n++] = '[';
12035 str[n++] = '$';
12036 str[n++] = '@';
12037 str[n++] = '%';
89c5c07e 12038 if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
1ecbeecf
FC		 12039 str[n++] = '*';
12040 str[n++] = ']';
12041 }
12042 else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
ea5703f4
FC		 12043 if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
12044 str[n-1] = '_'; defgv = 0;
12045 }
b8c38f0a
FC		 12046 oa = oa >> 4;
12047 }
dcbdef25 12048 if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
b8c38f0a
FC		 12049 str[n++] = '\0';
12050 sv_setpvn(sv, str, n - 1);
9927957a 12051 if (opnum) *opnum = i;
b8c38f0a
FC		 12052 return sv;
12053}
12054
1e4b6aa1
FC		 12055OP *
12056Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
12057 const int opnum)
12058{
12059 OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
c931b036 12060 OP *o;
1e4b6aa1
FC		 12061
12062 PERL_ARGS_ASSERT_CORESUB_OP;
12063
12064 switch(opnum) {
12065 case 0:
c2f605db 12066 return op_append_elem(OP_LINESEQ,
1e4b6aa1
FC		 12067 argop,
12068 newSLICEOP(0,
c2f605db 12069 newSVOP(OP_CONST, 0, newSViv(-code % 3)),
1e4b6aa1
FC		 12070 newOP(OP_CALLER,0)
12071 )
c2f605db 12072 );
720d5b2f
FC		 12073 case OP_SELECT: /* which represents OP_SSELECT as well */
12074 if (code)
12075 return newCONDOP(
12076 0,
12077 newBINOP(OP_GT, 0,
12078 newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
12079 newSVOP(OP_CONST, 0, newSVuv(1))
12080 ),
12081 coresub_op(newSVuv((UV)OP_SSELECT), 0,
12082 OP_SSELECT),
12083 coresub_op(coreargssv, 0, OP_SELECT)
12084 );
12085 /* FALL THROUGH */
1e4b6aa1
FC		 12086 default:
12087 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
12088 case OA_BASEOP:
12089 return op_append_elem(
12090 OP_LINESEQ, argop,
12091 newOP(opnum,
84ed0108
FC		 12092 opnum == OP_WANTARRAY || opnum == OP_RUNCV
12093 ? OPpOFFBYONE << 8 : 0)
1e4b6aa1 12094 );
527d644b 12095 case OA_BASEOP_OR_UNOP:
7d789282
FC		 12096 if (opnum == OP_ENTEREVAL) {
12097 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
12098 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
12099 }
12100 else o = newUNOP(opnum,0,argop);
ce0b554b
FC		 12101 if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
12102 else {
c931b036 12103 onearg:
ce0b554b 12104 if (is_handle_constructor(o, 1))
c931b036 12105 argop->op_private |= OPpCOREARGS_DEREF1;
1efec5ed
FC		 12106 if (scalar_mod_type(NULL, opnum))
12107 argop->op_private |= OPpCOREARGS_SCALARMOD;
ce0b554b 12108 }
c931b036 12109 return o;
527d644b 12110 default:
498a02d8 12111 o = convert(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
c931b036
FC		 12112 if (is_handle_constructor(o, 2))
12113 argop->op_private |= OPpCOREARGS_DEREF2;
7bc95ae1
FC		 12114 if (opnum == OP_SUBSTR) {
12115 o->op_private |= OPpMAYBE_LVSUB;
12116 return o;
12117 }
12118 else goto onearg;
1e4b6aa1
FC		 12119 }
12120 }
12121}
12122
156d738f
FC		 12123void
12124Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
12125 SV * const *new_const_svp)
12126{
12127 const char *hvname;
12128 bool is_const = !!CvCONST(old_cv);
12129 SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
12130
12131 PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
12132
12133 if (is_const && new_const_svp && old_const_sv == *new_const_svp)
12134 return;
12135 /* They are 2 constant subroutines generated from
12136 the same constant. This probably means that
12137 they are really the "same" proxy subroutine
12138 instantiated in 2 places. Most likely this is
12139 when a constant is exported twice. Don't warn.
12140 */
12141 if (
12142 (ckWARN(WARN_REDEFINE)
12143 && !(
12144 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
12145 && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
12146 && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
12147 strEQ(hvname, "autouse"))
12148 )
12149 )
12150 || (is_const
12151 && ckWARN_d(WARN_REDEFINE)
12152 && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
12153 )
12154 )
12155 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
12156 is_const
12157 ? "Constant subroutine %"SVf" redefined"
12158 : "Subroutine %"SVf" redefined",
12159 name);
12160}
12161
e8570548
Z		 12162/*
12163=head1 Hook manipulation
12164
12165These functions provide convenient and thread-safe means of manipulating
12166hook variables.
12167
12168=cut
12169*/
12170
12171/*
12172=for apidoc Am|void|wrap_op_checker|Optype opcode|Perl_check_t new_checker|Perl_check_t *old_checker_p
12173
12174Puts a C function into the chain of check functions for a specified op
12175type. This is the preferred way to manipulate the L</PL_check> array.
12176I<opcode> specifies which type of op is to be affected. I<new_checker>
12177is a pointer to the C function that is to be added to that opcode's
12178check chain, and I<old_checker_p> points to the storage location where a
12179pointer to the next function in the chain will be stored. The value of
12180I<new_pointer> is written into the L</PL_check> array, while the value
12181previously stored there is written to I<*old_checker_p>.
12182
12183L</PL_check> is global to an entire process, and a module wishing to
12184hook op checking may find itself invoked more than once per process,
12185typically in different threads. To handle that situation, this function
12186is idempotent. The location I<*old_checker_p> must initially (once
12187per process) contain a null pointer. A C variable of static duration
12188(declared at file scope, typically also marked C<static> to give
12189it internal linkage) will be implicitly initialised appropriately,
12190if it does not have an explicit initialiser. This function will only
12191actually modify the check chain if it finds I<*old_checker_p> to be null.
12192This function is also thread safe on the small scale. It uses appropriate
12193locking to avoid race conditions in accessing L</PL_check>.
12194
12195When this function is called, the function referenced by I<new_checker>
12196must be ready to be called, except for I<*old_checker_p> being unfilled.
12197In a threading situation, I<new_checker> may be called immediately,
12198even before this function has returned. I<*old_checker_p> will always
12199be appropriately set before I<new_checker> is called. If I<new_checker>
12200decides not to do anything special with an op that it is given (which
12201is the usual case for most uses of op check hooking), it must chain the
12202check function referenced by I<*old_checker_p>.
12203
12204If you want to influence compilation of calls to a specific subroutine,
12205then use L</cv_set_call_checker> rather than hooking checking of all
12206C<entersub> ops.
12207
12208=cut
12209*/
12210
12211void
12212Perl_wrap_op_checker(pTHX_ Optype opcode,
12213 Perl_check_t new_checker, Perl_check_t *old_checker_p)
12214{
9b11155f
TC		 12215 dVAR;
12216
e8570548
Z		 12217 PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
12218 if (*old_checker_p) return;
12219 OP_CHECK_MUTEX_LOCK;
12220 if (!*old_checker_p) {
12221 *old_checker_p = PL_check[opcode];
12222 PL_check[opcode] = new_checker;
12223 }
12224 OP_CHECK_MUTEX_UNLOCK;
12225}
12226
beab0874
JT		 12227#include "XSUB.h"
12228
12229/* Efficient sub that returns a constant scalar value. */
12230static void
acfe0abc 12231const_sv_xsub(pTHX_ CV* cv)
beab0874 12232{
97aff369 12233 dVAR;
beab0874 12234 dXSARGS;
99ab892b 12235 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
fcfc2536 12236 PERL_UNUSED_ARG(items);
99ab892b
NC		 12237 if (!sv) {
12238 XSRETURN(0);
12239 }
9a049f1c 12240 EXTEND(sp, 1);
99ab892b 12241 ST(0) = sv;
beab0874
JT		 12242 XSRETURN(1);
12243}
4946a0fa 12244
6f1b3ab0
FC		 12245static void
12246const_av_xsub(pTHX_ CV* cv)
12247{
12248 dVAR;
12249 dXSARGS;
12250 AV * const av = MUTABLE_AV(XSANY.any_ptr);
12251 SP -= items;
12252 assert(av);
12253#ifndef DEBUGGING
12254 if (!av) {
12255 XSRETURN(0);
12256 }
12257#endif
12258 if (SvRMAGICAL(av))
12259 Perl_croak(aTHX_ "Magical list constants are not supported");
12260 if (GIMME_V != G_ARRAY) {
12261 EXTEND(SP, 1);
12262 ST(0) = newSViv((IV)AvFILLp(av)+1);
12263 XSRETURN(1);
12264 }
12265 EXTEND(SP, AvFILLp(av)+1);
12266 Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
12267 XSRETURN(AvFILLp(av)+1);
12268}
12269
4946a0fa
NC		 12270/*
12271 * Local variables:
12272 * c-indentation-style: bsd
12273 * c-basic-offset: 4
14d04a33 12274 * indent-tabs-mode: nil
4946a0fa
NC		 12275 * End:
12276 *
14d04a33 12277 * ex: set ts=8 sts=4 sw=4 et:
37442d52 12278 */
Unnamed repository; edit this file 'description' to name the repository.