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
Deprecate calling isFOO_utf8() with malformed
[perl5.git] / op.c
CommitLineData
4b88f280 1#line 2 "op.c"
a0d0e21e 2/* op.c
79072805 3 *
1129b882
NC		 4 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
5 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
79072805
LW		 6 *
7 * You may distribute under the terms of either the GNU General Public
8 * License or the Artistic License, as specified in the README file.
9 *
a0d0e21e
LW		 10 */
11
12/*
4ac71550
TC		 13 * 'You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
14 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
15 * youngest of the Old Took's daughters); and Mr. Drogo was his second
16 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
17 * either way, as the saying is, if you follow me.' --the Gaffer
18 *
19 * [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
79072805
LW		 20 */
21
166f8a29
DM		 22/* This file contains the functions that create, manipulate and optimize
23 * the OP structures that hold a compiled perl program.
24 *
25 * A Perl program is compiled into a tree of OPs. Each op contains
26 * structural pointers (eg to its siblings and the next op in the
27 * execution sequence), a pointer to the function that would execute the
28 * op, plus any data specific to that op. For example, an OP_CONST op
29 * points to the pp_const() function and to an SV containing the constant
30 * value. When pp_const() is executed, its job is to push that SV onto the
31 * stack.
32 *
33 * OPs are mainly created by the newFOO() functions, which are mainly
34 * called from the parser (in perly.y) as the code is parsed. For example
35 * the Perl code $a + $b * $c would cause the equivalent of the following
36 * to be called (oversimplifying a bit):
37 *
38 * newBINOP(OP_ADD, flags,
39 * newSVREF($a),
40 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
41 * )
42 *
43 * Note that during the build of miniperl, a temporary copy of this file
44 * is made, called opmini.c.
45 */
ccfc67b7 46
61b743bb
DM		 47/*
48Perl's compiler is essentially a 3-pass compiler with interleaved phases:
49
50 A bottom-up pass
51 A top-down pass
52 An execution-order pass
53
54The bottom-up pass is represented by all the "newOP" routines and
55the ck_ routines. The bottom-upness is actually driven by yacc.
56So at the point that a ck_ routine fires, we have no idea what the
57context is, either upward in the syntax tree, or either forward or
58backward in the execution order. (The bottom-up parser builds that
59part of the execution order it knows about, but if you follow the "next"
60links around, you'll find it's actually a closed loop through the
ef9da979 61top level node.)
61b743bb
DM		 62
63Whenever the bottom-up parser gets to a node that supplies context to
64its components, it invokes that portion of the top-down pass that applies
65to that part of the subtree (and marks the top node as processed, so
66if a node further up supplies context, it doesn't have to take the
67plunge again). As a particular subcase of this, as the new node is
68built, it takes all the closed execution loops of its subcomponents
69and links them into a new closed loop for the higher level node. But
70it's still not the real execution order.
71
72The actual execution order is not known till we get a grammar reduction
73to a top-level unit like a subroutine or file that will be called by
74"name" rather than via a "next" pointer. At that point, we can call
75into peep() to do that code's portion of the 3rd pass. It has to be
76recursive, but it's recursive on basic blocks, not on tree nodes.
77*/
78
06e0342d 79/* To implement user lexical pragmas, there needs to be a way at run time to
b3ca2e83
NC		 80 get the compile time state of %^H for that block. Storing %^H in every
81 block (or even COP) would be very expensive, so a different approach is
82 taken. The (running) state of %^H is serialised into a tree of HE-like
83 structs. Stores into %^H are chained onto the current leaf as a struct
84 refcounted_he * with the key and the value. Deletes from %^H are saved
85 with a value of PL_sv_placeholder. The state of %^H at any point can be
86 turned back into a regular HV by walking back up the tree from that point's
06e0342d 87 leaf, ignoring any key you've already seen (placeholder or not), storing
b3ca2e83
NC		 88 the rest into the HV structure, then removing the placeholders. Hence
89 memory is only used to store the %^H deltas from the enclosing COP, rather
90 than the entire %^H on each COP.
91
92 To cause actions on %^H to write out the serialisation records, it has
93 magic type 'H'. This magic (itself) does nothing, but its presence causes
94 the values to gain magic type 'h', which has entries for set and clear.
c28fe1ec 95 C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
34795b44 96 record, with deletes written by C<Perl_magic_clearhint>. C<SAVEHINTS>
c28fe1ec
NC		 97 saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
98 it will be correctly restored when any inner compiling scope is exited.
b3ca2e83
NC		 99*/
100
79072805 101#include "EXTERN.h"
864dbfa3 102#define PERL_IN_OP_C
79072805 103#include "perl.h"
77ca0c92 104#include "keywords.h"
2846acbf 105#include "feature.h"
74529a43 106#include "regcomp.h"
79072805 107
16c91539 108#define CALL_PEEP(o) PL_peepp(aTHX_ o)
1a0a2ba9 109#define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
16c91539 110#define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
a2efc822 111
8be227ab
FC		 112/* See the explanatory comments above struct opslab in op.h. */
113
7aef8e5b 114#ifdef PERL_DEBUG_READONLY_OPS
3107b51f
FC		 115# define PERL_SLAB_SIZE 128
116# define PERL_MAX_SLAB_SIZE 4096
117# include <sys/mman.h>
7aef8e5b 118#endif
3107b51f 119
7aef8e5b 120#ifndef PERL_SLAB_SIZE
8be227ab 121# define PERL_SLAB_SIZE 64
7aef8e5b
FC		 122#endif
123#ifndef PERL_MAX_SLAB_SIZE
e6cee8c0 124# define PERL_MAX_SLAB_SIZE 2048
7aef8e5b 125#endif
8be227ab
FC		 126
127/* rounds up to nearest pointer */
7aef8e5b
FC		 128#define SIZE_TO_PSIZE(x) (((x) + sizeof(I32 *) - 1)/sizeof(I32 *))
129#define DIFF(o,p) ((size_t)((I32 **)(p) - (I32**)(o)))
8be227ab
FC		 130
131static OPSLAB *
132S_new_slab(pTHX_ size_t sz)
133{
7aef8e5b 134#ifdef PERL_DEBUG_READONLY_OPS
3107b51f
FC		 135 OPSLAB *slab = (OPSLAB *) mmap(0, sz * sizeof(I32 *),
136 PROT_READ|PROT_WRITE,
137 MAP_ANON|MAP_PRIVATE, -1, 0);
138 DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
139 (unsigned long) sz, slab));
140 if (slab == MAP_FAILED) {
141 perror("mmap failed");
142 abort();
143 }
144 slab->opslab_size = (U16)sz;
7aef8e5b 145#else
8be227ab 146 OPSLAB *slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *));
7aef8e5b 147#endif
8be227ab
FC		 148 slab->opslab_first = (OPSLOT *)((I32 **)slab + sz - 1);
149 return slab;
150}
151
e7372881
FC		 152/* requires double parens and aTHX_ */
153#define DEBUG_S_warn(args) \
154 DEBUG_S( \
155 PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \
156 )
157
8be227ab
FC		 158void *
159Perl_Slab_Alloc(pTHX_ size_t sz)
160{
161 dVAR;
162 OPSLAB *slab;
163 OPSLAB *slab2;
164 OPSLOT *slot;
165 OP *o;
5cb52f30 166 size_t opsz, space;
8be227ab
FC		 167
168 if (!PL_compcv || CvROOT(PL_compcv)
169 || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv)))
170 return PerlMemShared_calloc(1, sz);
171
172 if (!CvSTART(PL_compcv)) { /* sneak it in here */
173 CvSTART(PL_compcv) =
174 (OP *)(slab = S_new_slab(aTHX_ PERL_SLAB_SIZE));
175 CvSLABBED_on(PL_compcv);
176 slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */
177 }
178 else ++(slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
179
5cb52f30
FC		 180 opsz = SIZE_TO_PSIZE(sz);
181 sz = opsz + OPSLOT_HEADER_P;
8be227ab
FC		 182
183 if (slab->opslab_freed) {
184 OP **too = &slab->opslab_freed;
185 o = *too;
e7372881 186 DEBUG_S_warn((aTHX_ "found free op at %p, slab %p", o, slab));
8be227ab 187 while (o && DIFF(OpSLOT(o), OpSLOT(o)->opslot_next) < sz) {
e7372881 188 DEBUG_S_warn((aTHX_ "Alas! too small"));
8be227ab 189 o = *(too = &o->op_next);
94b67eb2 190 if (o) { DEBUG_S_warn((aTHX_ "found another free op at %p", o)); }
8be227ab
FC		 191 }
192 if (o) {
193 *too = o->op_next;
5cb52f30 194 Zero(o, opsz, I32 *);
8be227ab
FC		 195 o->op_slabbed = 1;
196 return (void *)o;
197 }
198 }
199
7aef8e5b 200#define INIT_OPSLOT \
8be227ab
FC		 201 slot->opslot_slab = slab; \
202 slot->opslot_next = slab2->opslab_first; \
203 slab2->opslab_first = slot; \
204 o = &slot->opslot_op; \
205 o->op_slabbed = 1
206
207 /* The partially-filled slab is next in the chain. */
208 slab2 = slab->opslab_next ? slab->opslab_next : slab;
209 if ((space = DIFF(&slab2->opslab_slots, slab2->opslab_first)) < sz) {
210 /* Remaining space is too small. */
211
8be227ab
FC		 212 /* If we can fit a BASEOP, add it to the free chain, so as not
213 to waste it. */
214 if (space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) {
215 slot = &slab2->opslab_slots;
216 INIT_OPSLOT;
217 o->op_type = OP_FREED;
218 o->op_next = slab->opslab_freed;
219 slab->opslab_freed = o;
220 }
221
222 /* Create a new slab. Make this one twice as big. */
223 slot = slab2->opslab_first;
224 while (slot->opslot_next) slot = slot->opslot_next;
af7751f6
FC		 225 slab2 = S_new_slab(aTHX_
226 (DIFF(slab2, slot)+1)*2 > PERL_MAX_SLAB_SIZE
e6cee8c0 227 ? PERL_MAX_SLAB_SIZE
af7751f6 228 : (DIFF(slab2, slot)+1)*2);
9963ffa2
FC		 229 slab2->opslab_next = slab->opslab_next;
230 slab->opslab_next = slab2;
8be227ab
FC		 231 }
232 assert(DIFF(&slab2->opslab_slots, slab2->opslab_first) >= sz);
233
234 /* Create a new op slot */
235 slot = (OPSLOT *)((I32 **)slab2->opslab_first - sz);
236 assert(slot >= &slab2->opslab_slots);
51c777ca
FC		 237 if (DIFF(&slab2->opslab_slots, slot)
238 < SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P)
239 slot = &slab2->opslab_slots;
8be227ab 240 INIT_OPSLOT;
e7372881 241 DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", o, slab));
8be227ab
FC		 242 return (void *)o;
243}
244
7aef8e5b 245#undef INIT_OPSLOT
8be227ab 246
7aef8e5b 247#ifdef PERL_DEBUG_READONLY_OPS
3107b51f
FC		 248void
249Perl_Slab_to_ro(pTHX_ OPSLAB *slab)
250{
251 PERL_ARGS_ASSERT_SLAB_TO_RO;
252
253 if (slab->opslab_readonly) return;
254 slab->opslab_readonly = 1;
255 for (; slab; slab = slab->opslab_next) {
256 /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->ro %lu at %p\n",
257 (unsigned long) slab->opslab_size, slab));*/
258 if (mprotect(slab, slab->opslab_size * sizeof(I32 *), PROT_READ))
259 Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", slab,
260 (unsigned long)slab->opslab_size, errno);
261 }
262}
263
7bbbc3c0
NC		 264void
265Perl_Slab_to_rw(pTHX_ OPSLAB *const slab)
3107b51f 266{
3107b51f
FC		 267 OPSLAB *slab2;
268
269 PERL_ARGS_ASSERT_SLAB_TO_RW;
270
3107b51f
FC		 271 if (!slab->opslab_readonly) return;
272 slab2 = slab;
273 for (; slab2; slab2 = slab2->opslab_next) {
274 /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n",
275 (unsigned long) size, slab2));*/
276 if (mprotect((void *)slab2, slab2->opslab_size * sizeof(I32 *),
277 PROT_READ|PROT_WRITE)) {
278 Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", slab,
279 (unsigned long)slab2->opslab_size, errno);
280 }
281 }
282 slab->opslab_readonly = 0;
283}
284
285#else
286# define Slab_to_rw(op)
287#endif
288
8be227ab
FC		 289/* This cannot possibly be right, but it was copied from the old slab
290 allocator, to which it was originally added, without explanation, in
291 commit 083fcd5. */
7aef8e5b 292#ifdef NETWARE
8be227ab 293# define PerlMemShared PerlMem
7aef8e5b 294#endif
8be227ab
FC		 295
296void
297Perl_Slab_Free(pTHX_ void *op)
298{
20429ba0 299 dVAR;
8be227ab
FC		 300 OP * const o = (OP *)op;
301 OPSLAB *slab;
302
303 PERL_ARGS_ASSERT_SLAB_FREE;
304
305 if (!o->op_slabbed) {
90840c5d
RU		 306 if (!o->op_static)
307 PerlMemShared_free(op);
8be227ab
FC		 308 return;
309 }
310
311 slab = OpSLAB(o);
312 /* If this op is already freed, our refcount will get screwy. */
313 assert(o->op_type != OP_FREED);
314 o->op_type = OP_FREED;
315 o->op_next = slab->opslab_freed;
316 slab->opslab_freed = o;
e7372881 317 DEBUG_S_warn((aTHX_ "free op at %p, recorded in slab %p", o, slab));
8be227ab
FC		 318 OpslabREFCNT_dec_padok(slab);
319}
320
321void
322Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
323{
324 dVAR;
325 const bool havepad = !!PL_comppad;
326 PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD;
327 if (havepad) {
328 ENTER;
329 PAD_SAVE_SETNULLPAD();
330 }
331 opslab_free(slab);
332 if (havepad) LEAVE;
333}
334
335void
336Perl_opslab_free(pTHX_ OPSLAB *slab)
337{
20429ba0 338 dVAR;
8be227ab
FC		 339 OPSLAB *slab2;
340 PERL_ARGS_ASSERT_OPSLAB_FREE;
e7372881 341 DEBUG_S_warn((aTHX_ "freeing slab %p", slab));
8be227ab
FC		 342 assert(slab->opslab_refcnt == 1);
343 for (; slab; slab = slab2) {
344 slab2 = slab->opslab_next;
7aef8e5b 345#ifdef DEBUGGING
8be227ab 346 slab->opslab_refcnt = ~(size_t)0;
7aef8e5b
FC		 347#endif
348#ifdef PERL_DEBUG_READONLY_OPS
3107b51f
FC		 349 DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
350 slab));
351 if (munmap(slab, slab->opslab_size * sizeof(I32 *))) {
352 perror("munmap failed");
353 abort();
354 }
7aef8e5b 355#else
8be227ab 356 PerlMemShared_free(slab);
7aef8e5b 357#endif
8be227ab
FC		 358 }
359}
360
361void
362Perl_opslab_force_free(pTHX_ OPSLAB *slab)
363{
364 OPSLAB *slab2;
365 OPSLOT *slot;
7aef8e5b 366#ifdef DEBUGGING
8be227ab 367 size_t savestack_count = 0;
7aef8e5b 368#endif
8be227ab
FC		 369 PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
370 slab2 = slab;
371 do {
372 for (slot = slab2->opslab_first;
373 slot->opslot_next;
374 slot = slot->opslot_next) {
375 if (slot->opslot_op.op_type != OP_FREED
376 && !(slot->opslot_op.op_savefree
7aef8e5b 377#ifdef DEBUGGING
8be227ab 378 && ++savestack_count
7aef8e5b 379#endif
8be227ab
FC		 380 )
381 ) {
382 assert(slot->opslot_op.op_slabbed);
8be227ab 383 op_free(&slot->opslot_op);
3bf28c7e 384 if (slab->opslab_refcnt == 1) goto free;
8be227ab
FC		 385 }
386 }
387 } while ((slab2 = slab2->opslab_next));
388 /* > 1 because the CV still holds a reference count. */
389 if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */
7aef8e5b 390#ifdef DEBUGGING
8be227ab 391 assert(savestack_count == slab->opslab_refcnt-1);
7aef8e5b 392#endif
ee5ee853
FC		 393 /* Remove the CV’s reference count. */
394 slab->opslab_refcnt--;
8be227ab
FC		 395 return;
396 }
397 free:
398 opslab_free(slab);
399}
400
3107b51f
FC		 401#ifdef PERL_DEBUG_READONLY_OPS
402OP *
403Perl_op_refcnt_inc(pTHX_ OP *o)
404{
405 if(o) {
372eab01
NC		 406 OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
407 if (slab && slab->opslab_readonly) {
83519873 408 Slab_to_rw(slab);
372eab01
NC		 409 ++o->op_targ;
410 Slab_to_ro(slab);
411 } else {
412 ++o->op_targ;
413 }
3107b51f
FC		 414 }
415 return o;
416
417}
418
419PADOFFSET
420Perl_op_refcnt_dec(pTHX_ OP *o)
421{
372eab01
NC		 422 PADOFFSET result;
423 OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
424
3107b51f 425 PERL_ARGS_ASSERT_OP_REFCNT_DEC;
372eab01
NC		 426
427 if (slab && slab->opslab_readonly) {
83519873 428 Slab_to_rw(slab);
372eab01
NC		 429 result = --o->op_targ;
430 Slab_to_ro(slab);
431 } else {
432 result = --o->op_targ;
433 }
434 return result;
3107b51f
FC		 435}
436#endif
e50aee73 437/*
ce6f1cbc 438 * In the following definition, the ", (OP*)0" is just to make the compiler
a5f75d66 439 * think the expression is of the right type: croak actually does a Siglongjmp.
e50aee73 440 */
11343788 441#define CHECKOP(type,o) \
ce6f1cbc 442 ((PL_op_mask && PL_op_mask[type]) \
5dc0d613 443 ? ( op_free((OP*)o), \
cb77fdf0 444 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
ce6f1cbc 445 (OP*)0 ) \
16c91539 446 : PL_check[type](aTHX_ (OP*)o))
e50aee73 447
e6438c1a 448#define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
c53d7c7d 449
cba5a3b0
DG		 450#define CHANGE_TYPE(o,type) \
451 STMT_START { \
452 o->op_type = (OPCODE)type; \
453 o->op_ppaddr = PL_ppaddr[type]; \
454 } STMT_END
455
ce16c625 456STATIC SV*
cea2e8a9 457S_gv_ename(pTHX_ GV *gv)
4633a7c4 458{
46c461b5 459 SV* const tmpsv = sv_newmortal();
7918f24d
NC		 460
461 PERL_ARGS_ASSERT_GV_ENAME;
462
bd61b366 463 gv_efullname3(tmpsv, gv, NULL);
ce16c625 464 return tmpsv;
4633a7c4
LW		 465}
466
76e3520e 467STATIC OP *
cea2e8a9 468S_no_fh_allowed(pTHX_ OP *o)
79072805 469{
7918f24d
NC		 470 PERL_ARGS_ASSERT_NO_FH_ALLOWED;
471
cea2e8a9 472 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
53e06cf0 473 OP_DESC(o)));
11343788 474 return o;
79072805
LW		 475}
476
76e3520e 477STATIC OP *
ce16c625 478S_too_few_arguments_sv(pTHX_ OP *o, SV *namesv, U32 flags)
79072805 479{
ce16c625
BF		 480 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_SV;
481 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf, namesv),
482 SvUTF8(namesv) | flags);
483 return o;
484}
485
486STATIC OP *
487S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
488{
489 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
490 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
491 return o;
492}
493
494STATIC OP *
495S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
496{
497 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
7918f24d 498
ce16c625 499 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
11343788 500 return o;
79072805
LW		 501}
502
76e3520e 503STATIC OP *
ce16c625 504S_too_many_arguments_sv(pTHX_ OP *o, SV *namesv, U32 flags)
79072805 505{
ce16c625 506 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_SV;
7918f24d 507
ce16c625
BF		 508 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %"SVf, SVfARG(namesv)),
509 SvUTF8(namesv) | flags);
11343788 510 return o;
79072805
LW		 511}
512
76e3520e 513STATIC void
ce16c625 514S_bad_type_pv(pTHX_ I32 n, const char *t, const char *name, U32 flags, const OP *kid)
8990e307 515{
ce16c625
BF		 516 PERL_ARGS_ASSERT_BAD_TYPE_PV;
517
518 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
519 (int)n, name, t, OP_DESC(kid)), flags);
520}
7918f24d 521
ce16c625
BF		 522STATIC void
523S_bad_type_sv(pTHX_ I32 n, const char *t, SV *namesv, U32 flags, const OP *kid)
524{
525 PERL_ARGS_ASSERT_BAD_TYPE_SV;
526
527 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %"SVf" must be %s (not %s)",
528 (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv) | flags);
8990e307
LW		 529}
530
7a52d87a 531STATIC void
eb796c7f 532S_no_bareword_allowed(pTHX_ OP *o)
7a52d87a 533{
7918f24d
NC		 534 PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
535
eb8433b7
NC		 536 if (PL_madskills)
537 return; /* various ok barewords are hidden in extra OP_NULL */
5a844595 538 qerror(Perl_mess(aTHX_
35c1215d 539 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
be2597df 540 SVfARG(cSVOPo_sv)));
eb796c7f 541 o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
7a52d87a
GS		 542}
543
79072805
LW		 544/* "register" allocation */
545
546PADOFFSET
d6447115 547Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
93a17b20 548{
97aff369 549 dVAR;
a0d0e21e 550 PADOFFSET off;
12bd6ede 551 const bool is_our = (PL_parser->in_my == KEY_our);
a0d0e21e 552
7918f24d
NC		 553 PERL_ARGS_ASSERT_ALLOCMY;
554
48d0d1be 555 if (flags & ~SVf_UTF8)
d6447115
NC		 556 Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
557 (UV)flags);
558
559 /* Until we're using the length for real, cross check that we're being
560 told the truth. */
561 assert(strlen(name) == len);
562
59f00321 563 /* complain about "my $<special_var>" etc etc */
d6447115 564 if (len &&
3edf23ff 565 !(is_our ||
155aba94 566 isALPHA(name[1]) ||
b14845b4 567 ((flags & SVf_UTF8) && isIDFIRST_utf8((U8 *)name+1)) ||
d6447115 568 (name[1] == '_' && (*name == '$' || len > 2))))
834a4ddd 569 {
6b58708b 570 /* name[2] is true if strlen(name) > 2 */
b14845b4
FC		 571 if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
572 && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
d6447115
NC		 573 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
574 name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
aab6a793 575 PL_parser->in_my == KEY_state ? "state" : "my"));
d1544d85 576 } else {
ce16c625
BF		 577 yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
578 PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
46fc3d4c 579 }
a0d0e21e 580 }
90b58ec9
FC		 581 else if (len == 2 && name[1] == '_' && !is_our)
582 /* diag_listed_as: Use of my $_ is deprecated */
583 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
584 "Use of %s $_ is deprecated",
585 PL_parser->in_my == KEY_state
586 ? "state"
587 : "my");
748a9306 588
dd2155a4 589 /* allocate a spare slot and store the name in that slot */
93a17b20 590
cc76b5cc 591 off = pad_add_name_pvn(name, len,
48d0d1be
BF		 592 (is_our ? padadd_OUR :
593 PL_parser->in_my == KEY_state ? padadd_STATE : 0)
594 | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 ),
12bd6ede 595 PL_parser->in_my_stash,
3edf23ff 596 (is_our
133706a6
RGS		 597 /* $_ is always in main::, even with our */
598 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
5c284bb0 599 : NULL
cca43f78 600 )
dd2155a4 601 );
a74073ad
DM		 602 /* anon sub prototypes contains state vars should always be cloned,
603 * otherwise the state var would be shared between anon subs */
604
605 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
606 CvCLONE_on(PL_compcv);
607
dd2155a4 608 return off;
79072805
LW		 609}
610
c0b8aebd
FC		 611/*
612=for apidoc alloccopstash
613
614Available only under threaded builds, this function allocates an entry in
615C<PL_stashpad> for the stash passed to it.
616
617=cut
618*/
619
d4d03940
FC		 620#ifdef USE_ITHREADS
621PADOFFSET
622Perl_alloccopstash(pTHX_ HV *hv)
623{
624 PADOFFSET off = 0, o = 1;
625 bool found_slot = FALSE;
626
627 PERL_ARGS_ASSERT_ALLOCCOPSTASH;
628
629 if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
630
631 for (; o < PL_stashpadmax; ++o) {
632 if (PL_stashpad[o] == hv) return PL_stashpadix = o;
633 if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
634 found_slot = TRUE, off = o;
635 }
636 if (!found_slot) {
637 Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
638 Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
639 off = PL_stashpadmax;
640 PL_stashpadmax += 10;
641 }
642
643 PL_stashpad[PL_stashpadix = off] = hv;
644 return off;
645}
646#endif
647
d2c837a0
DM		 648/* free the body of an op without examining its contents.
649 * Always use this rather than FreeOp directly */
650
4136a0f7 651static void
d2c837a0
DM		 652S_op_destroy(pTHX_ OP *o)
653{
d2c837a0
DM		 654 FreeOp(o);
655}
656
79072805
LW		 657/* Destructor */
658
659void
864dbfa3 660Perl_op_free(pTHX_ OP *o)
79072805 661{
27da23d5 662 dVAR;
acb36ea4 663 OPCODE type;
79072805 664
8be227ab
FC		 665 /* Though ops may be freed twice, freeing the op after its slab is a
666 big no-no. */
667 assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
8be227ab
FC		 668 /* During the forced freeing of ops after compilation failure, kidops
669 may be freed before their parents. */
670 if (!o || o->op_type == OP_FREED)
79072805
LW		 671 return;
672
67566ccd 673 type = o->op_type;
7934575e 674 if (o->op_private & OPpREFCOUNTED) {
67566ccd 675 switch (type) {
7934575e
GS		 676 case OP_LEAVESUB:
677 case OP_LEAVESUBLV:
678 case OP_LEAVEEVAL:
679 case OP_LEAVE:
680 case OP_SCOPE:
681 case OP_LEAVEWRITE:
67566ccd
AL		 682 {
683 PADOFFSET refcnt;
7934575e 684 OP_REFCNT_LOCK;
4026c95a 685 refcnt = OpREFCNT_dec(o);
7934575e 686 OP_REFCNT_UNLOCK;
bfd0ff22
NC		 687 if (refcnt) {
688 /* Need to find and remove any pattern match ops from the list
689 we maintain for reset(). */
690 find_and_forget_pmops(o);
4026c95a 691 return;
67566ccd 692 }
bfd0ff22 693 }
7934575e
GS		 694 break;
695 default:
696 break;
697 }
698 }
699
f37b8c3f
VP		 700 /* Call the op_free hook if it has been set. Do it now so that it's called
701 * at the right time for refcounted ops, but still before all of the kids
702 * are freed. */
703 CALL_OPFREEHOOK(o);
704
11343788 705 if (o->op_flags & OPf_KIDS) {
eb578fdb 706 OP *kid, *nextkid;
11343788 707 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
85e6fe83 708 nextkid = kid->op_sibling; /* Get before next freeing kid */
79072805 709 op_free(kid);
85e6fe83 710 }
79072805 711 }
513f78f7
FC		 712 if (type == OP_NULL)
713 type = (OPCODE)o->op_targ;
acb36ea4 714
9bcdb3dd
JH		 715 if (o->op_slabbed) {
716 Slab_to_rw(OpSLAB(o));
717 }
fc97af9c 718
acb36ea4
GS		 719 /* COP* is not cleared by op_clear() so that we may track line
720 * numbers etc even after null() */
513f78f7 721 if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
acb36ea4 722 cop_free((COP*)o);
3235b7a3 723 }
acb36ea4
GS		 724
725 op_clear(o);
238a4c30 726 FreeOp(o);
4d494880
DM		 727#ifdef DEBUG_LEAKING_SCALARS
728 if (PL_op == o)
5f66b61c 729 PL_op = NULL;
4d494880 730#endif
acb36ea4 731}
79072805 732
93c66552
DM		 733void
734Perl_op_clear(pTHX_ OP *o)
acb36ea4 735{
13137afc 736
27da23d5 737 dVAR;
7918f24d
NC		 738
739 PERL_ARGS_ASSERT_OP_CLEAR;
740
eb8433b7 741#ifdef PERL_MAD
df31c78c
NC		 742 mad_free(o->op_madprop);
743 o->op_madprop = 0;
eb8433b7
NC		 744#endif
745
746 retry:
11343788 747 switch (o->op_type) {
acb36ea4 748 case OP_NULL: /* Was holding old type, if any. */
eb8433b7 749 if (PL_madskills && o->op_targ != OP_NULL) {
61a59f30 750 o->op_type = (Optype)o->op_targ;
eb8433b7
NC		 751 o->op_targ = 0;
752 goto retry;
753 }
4d193d44 754 case OP_ENTERTRY:
acb36ea4 755 case OP_ENTEREVAL: /* Was holding hints. */
acb36ea4 756 o->op_targ = 0;
a0d0e21e 757 break;
a6006777 758 default:
ac4c12e7 759 if (!(o->op_flags & OPf_REF)
ef69c8fc 760 || (PL_check[o->op_type] != Perl_ck_ftst))
a6006777 761 break;
762 /* FALL THROUGH */
463ee0b2 763 case OP_GVSV:
79072805 764 case OP_GV:
a6006777 765 case OP_AELEMFAST:
93bad3fd 766 {
f7461760
Z		 767 GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV)
768#ifdef USE_ITHREADS
769 && PL_curpad
770#endif
771 ? cGVOPo_gv : NULL;
b327b36f
NC		 772 /* It's possible during global destruction that the GV is freed
773 before the optree. Whilst the SvREFCNT_inc is happy to bump from
774 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
775 will trigger an assertion failure, because the entry to sv_clear
776 checks that the scalar is not already freed. A check of for
777 !SvIS_FREED(gv) turns out to be invalid, because during global
778 destruction the reference count can be forced down to zero
779 (with SVf_BREAK set). In which case raising to 1 and then
780 dropping to 0 triggers cleanup before it should happen. I
781 *think* that this might actually be a general, systematic,
782 weakness of the whole idea of SVf_BREAK, in that code *is*
783 allowed to raise and lower references during global destruction,
784 so any *valid* code that happens to do this during global
785 destruction might well trigger premature cleanup. */
786 bool still_valid = gv && SvREFCNT(gv);
787
788 if (still_valid)
789 SvREFCNT_inc_simple_void(gv);
350de78d 790#ifdef USE_ITHREADS
6a077020
DM		 791 if (cPADOPo->op_padix > 0) {
792 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
793 * may still exist on the pad */
794 pad_swipe(cPADOPo->op_padix, TRUE);
795 cPADOPo->op_padix = 0;
796 }
350de78d 797#else
6a077020 798 SvREFCNT_dec(cSVOPo->op_sv);
a0714e2c 799 cSVOPo->op_sv = NULL;
350de78d 800#endif
b327b36f 801 if (still_valid) {
f7461760 802 int try_downgrade = SvREFCNT(gv) == 2;
fc2b2dca 803 SvREFCNT_dec_NN(gv);
f7461760
Z		 804 if (try_downgrade)
805 gv_try_downgrade(gv);
806 }
6a077020 807 }
79072805 808 break;
a1ae71d2 809 case OP_METHOD_NAMED:
79072805 810 case OP_CONST:
996c9baa 811 case OP_HINTSEVAL:
11343788 812 SvREFCNT_dec(cSVOPo->op_sv);
a0714e2c 813 cSVOPo->op_sv = NULL;
3b1c21fa
AB		 814#ifdef USE_ITHREADS
815 /** Bug #15654
816 Even if op_clear does a pad_free for the target of the op,
6a077020 817 pad_free doesn't actually remove the sv that exists in the pad;
3b1c21fa
AB		 818 instead it lives on. This results in that it could be reused as
819 a target later on when the pad was reallocated.
820 **/
821 if(o->op_targ) {
822 pad_swipe(o->op_targ,1);
823 o->op_targ = 0;
824 }
825#endif
79072805 826 break;
c9df4fda 827 case OP_DUMP:
748a9306
LW		 828 case OP_GOTO:
829 case OP_NEXT:
830 case OP_LAST:
831 case OP_REDO:
11343788 832 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
748a9306
LW		 833 break;
834 /* FALL THROUGH */
a0d0e21e 835 case OP_TRANS:
bb16bae8 836 case OP_TRANSR:
acb36ea4 837 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
99a1d0d1 838 assert(o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
043e41b8
DM		 839#ifdef USE_ITHREADS
840 if (cPADOPo->op_padix > 0) {
841 pad_swipe(cPADOPo->op_padix, TRUE);
842 cPADOPo->op_padix = 0;
843 }
844#else
a0ed51b3 845 SvREFCNT_dec(cSVOPo->op_sv);
a0714e2c 846 cSVOPo->op_sv = NULL;
043e41b8 847#endif
acb36ea4
GS		 848 }
849 else {
ea71c68d 850 PerlMemShared_free(cPVOPo->op_pv);
bd61b366 851 cPVOPo->op_pv = NULL;
acb36ea4 852 }
a0d0e21e
LW		 853 break;
854 case OP_SUBST:
20e98b0f 855 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
971a9dd3 856 goto clear_pmop;
748a9306 857 case OP_PUSHRE:
971a9dd3 858#ifdef USE_ITHREADS
20e98b0f 859 if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
dd2155a4
DM		 860 /* No GvIN_PAD_off here, because other references may still
861 * exist on the pad */
20e98b0f 862 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
971a9dd3
GS		 863 }
864#else
ad64d0ec 865 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
971a9dd3
GS		 866#endif
867 /* FALL THROUGH */
a0d0e21e 868 case OP_MATCH:
8782bef2 869 case OP_QR:
971a9dd3 870clear_pmop:
867940b8
DM		 871 if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
872 op_free(cPMOPo->op_code_list);
68e2671b 873 cPMOPo->op_code_list = NULL;
23083432 874 forget_pmop(cPMOPo);
20e98b0f 875 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
9cddf794
NC		 876 /* we use the same protection as the "SAFE" version of the PM_ macros
877 * here since sv_clean_all might release some PMOPs
5f8cb046
DM		 878 * after PL_regex_padav has been cleared
879 * and the clearing of PL_regex_padav needs to
880 * happen before sv_clean_all
881 */
13137afc
AB		 882#ifdef USE_ITHREADS
883 if(PL_regex_pad) { /* We could be in destruction */
402d2eb1 884 const IV offset = (cPMOPo)->op_pmoffset;
9cddf794 885 ReREFCNT_dec(PM_GETRE(cPMOPo));
402d2eb1
NC		 886 PL_regex_pad[offset] = &PL_sv_undef;
887 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
888 sizeof(offset));
13137afc 889 }
9cddf794
NC		 890#else
891 ReREFCNT_dec(PM_GETRE(cPMOPo));
892 PM_SETRE(cPMOPo, NULL);
1eb1540c 893#endif
13137afc 894
a0d0e21e 895 break;
79072805
LW		 896 }
897
743e66e6 898 if (o->op_targ > 0) {
11343788 899 pad_free(o->op_targ);
743e66e6
GS		 900 o->op_targ = 0;
901 }
79072805
LW		 902}
903
76e3520e 904STATIC void
3eb57f73
HS		 905S_cop_free(pTHX_ COP* cop)
906{
7918f24d
NC		 907 PERL_ARGS_ASSERT_COP_FREE;
908
05ec9bb3 909 CopFILE_free(cop);
0453d815 910 if (! specialWARN(cop->cop_warnings))
72dc9ed5 911 PerlMemShared_free(cop->cop_warnings);
20439bc7 912 cophh_free(CopHINTHASH_get(cop));
3eb57f73
HS		 913}
914
c2b1997a 915STATIC void
c4bd3ae5 916S_forget_pmop(pTHX_ PMOP *const o
c4bd3ae5 917 )
c2b1997a
NC		 918{
919 HV * const pmstash = PmopSTASH(o);
7918f24d
NC		 920
921 PERL_ARGS_ASSERT_FORGET_PMOP;
922
e39a6381 923 if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
ad64d0ec 924 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
c2b1997a
NC		 925 if (mg) {
926 PMOP **const array = (PMOP**) mg->mg_ptr;
927 U32 count = mg->mg_len / sizeof(PMOP**);
928 U32 i = count;
929
930 while (i--) {
931 if (array[i] == o) {
932 /* Found it. Move the entry at the end to overwrite it. */
933 array[i] = array[--count];
934 mg->mg_len = count * sizeof(PMOP**);
935 /* Could realloc smaller at this point always, but probably
936 not worth it. Probably worth free()ing if we're the
937 last. */
938 if(!count) {
939 Safefree(mg->mg_ptr);
940 mg->mg_ptr = NULL;
941 }
942 break;
943 }
944 }
945 }
946 }
1cdf7faf
NC		 947 if (PL_curpm == o)
948 PL_curpm = NULL;
c2b1997a
NC		 949}
950
bfd0ff22
NC		 951STATIC void
952S_find_and_forget_pmops(pTHX_ OP *o)
953{
7918f24d
NC		 954 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
955
bfd0ff22
NC		 956 if (o->op_flags & OPf_KIDS) {
957 OP *kid = cUNOPo->op_first;
958 while (kid) {
959 switch (kid->op_type) {
960 case OP_SUBST:
961 case OP_PUSHRE:
962 case OP_MATCH:
963 case OP_QR:
23083432 964 forget_pmop((PMOP*)kid);
bfd0ff22
NC		 965 }
966 find_and_forget_pmops(kid);
967 kid = kid->op_sibling;
968 }
969 }
970}
971
93c66552
DM		 972void
973Perl_op_null(pTHX_ OP *o)
8990e307 974{
27da23d5 975 dVAR;
7918f24d
NC		 976
977 PERL_ARGS_ASSERT_OP_NULL;
978
acb36ea4
GS		 979 if (o->op_type == OP_NULL)
980 return;
eb8433b7
NC		 981 if (!PL_madskills)
982 op_clear(o);
11343788
MB		 983 o->op_targ = o->op_type;
984 o->op_type = OP_NULL;
22c35a8c 985 o->op_ppaddr = PL_ppaddr[OP_NULL];
8990e307
LW		 986}
987
4026c95a
SH		 988void
989Perl_op_refcnt_lock(pTHX)
990{
27da23d5 991 dVAR;
96a5add6 992 PERL_UNUSED_CONTEXT;
4026c95a
SH		 993 OP_REFCNT_LOCK;
994}
995
996void
997Perl_op_refcnt_unlock(pTHX)
998{
27da23d5 999 dVAR;
96a5add6 1000 PERL_UNUSED_CONTEXT;
4026c95a
SH		 1001 OP_REFCNT_UNLOCK;
1002}
1003
79072805
LW		 1004/* Contextualizers */
1005
d9088386
Z		 1006/*
1007=for apidoc Am|OP *|op_contextualize|OP *o|I32 context
1008
1009Applies a syntactic context to an op tree representing an expression.
1010I<o> is the op tree, and I<context> must be C<G_SCALAR>, C<G_ARRAY>,
1011or C<G_VOID> to specify the context to apply. The modified op tree
1012is returned.
1013
1014=cut
1015*/
1016
1017OP *
1018Perl_op_contextualize(pTHX_ OP *o, I32 context)
1019{
1020 PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1021 switch (context) {
1022 case G_SCALAR: return scalar(o);
1023 case G_ARRAY: return list(o);
1024 case G_VOID: return scalarvoid(o);
1025 default:
5637ef5b
NC		 1026 Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1027 (long) context);
d9088386
Z		 1028 return o;
1029 }
1030}
1031
5983a79d
BM		 1032/*
1033=head1 Optree Manipulation Functions
79072805 1034
5983a79d
BM		 1035=for apidoc Am|OP*|op_linklist|OP *o
1036This function is the implementation of the L</LINKLIST> macro. It should
1037not be called directly.
1038
1039=cut
1040*/
1041
1042OP *
1043Perl_op_linklist(pTHX_ OP *o)
79072805 1044{
3edf23ff 1045 OP *first;
79072805 1046
5983a79d 1047 PERL_ARGS_ASSERT_OP_LINKLIST;
7918f24d 1048
11343788
MB		 1049 if (o->op_next)
1050 return o->op_next;
79072805
LW		 1051
1052 /* establish postfix order */
3edf23ff
AL		 1053 first = cUNOPo->op_first;
1054 if (first) {
eb578fdb 1055 OP *kid;
3edf23ff
AL		 1056 o->op_next = LINKLIST(first);
1057 kid = first;
1058 for (;;) {
1059 if (kid->op_sibling) {
79072805 1060 kid->op_next = LINKLIST(kid->op_sibling);
3edf23ff
AL		 1061 kid = kid->op_sibling;
1062 } else {
11343788 1063 kid->op_next = o;
3edf23ff
AL		 1064 break;
1065 }
79072805
LW		 1066 }
1067 }
1068 else
11343788 1069 o->op_next = o;
79072805 1070
11343788 1071 return o->op_next;
79072805
LW		 1072}
1073
1f676739 1074static OP *
2dd5337b 1075S_scalarkids(pTHX_ OP *o)
79072805 1076{
11343788 1077 if (o && o->op_flags & OPf_KIDS) {
bfed75c6 1078 OP *kid;
11343788 1079 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW		 1080 scalar(kid);
1081 }
11343788 1082 return o;
79072805
LW		 1083}
1084
76e3520e 1085STATIC OP *
cea2e8a9 1086S_scalarboolean(pTHX_ OP *o)
8990e307 1087{
97aff369 1088 dVAR;
7918f24d
NC		 1089
1090 PERL_ARGS_ASSERT_SCALARBOOLEAN;
1091
6b7c6d95
FC		 1092 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST
1093 && !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) {
d008e5eb 1094 if (ckWARN(WARN_SYNTAX)) {
6867be6d 1095 const line_t oldline = CopLINE(PL_curcop);
a0d0e21e 1096
2b7cddde
NC		 1097 if (PL_parser && PL_parser->copline != NOLINE) {
1098 /* This ensures that warnings are reported at the first line
1099 of the conditional, not the last. */
53a7735b 1100 CopLINE_set(PL_curcop, PL_parser->copline);
2b7cddde 1101 }
9014280d 1102 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
57843af0 1103 CopLINE_set(PL_curcop, oldline);
d008e5eb 1104 }
a0d0e21e 1105 }
11343788 1106 return scalar(o);
8990e307
LW		 1107}
1108
1109OP *
864dbfa3 1110Perl_scalar(pTHX_ OP *o)
79072805 1111{
27da23d5 1112 dVAR;
79072805
LW		 1113 OP *kid;
1114
a0d0e21e 1115 /* assumes no premature commitment */
13765c85
DM		 1116 if (!o || (PL_parser && PL_parser->error_count)
1117 || (o->op_flags & OPf_WANT)
5dc0d613 1118 || o->op_type == OP_RETURN)
7e363e51 1119 {
11343788 1120 return o;
7e363e51 1121 }
79072805 1122
5dc0d613 1123 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
79072805 1124
11343788 1125 switch (o->op_type) {
79072805 1126 case OP_REPEAT:
11343788 1127 scalar(cBINOPo->op_first);
8990e307 1128 break;
79072805
LW		 1129 case OP_OR:
1130 case OP_AND:
1131 case OP_COND_EXPR:
11343788 1132 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
8990e307 1133 scalar(kid);
79072805 1134 break;
a0d0e21e 1135 /* FALL THROUGH */
a6d8037e 1136 case OP_SPLIT:
79072805 1137 case OP_MATCH:
8782bef2 1138 case OP_QR:
79072805
LW		 1139 case OP_SUBST:
1140 case OP_NULL:
8990e307 1141 default:
11343788
MB		 1142 if (o->op_flags & OPf_KIDS) {
1143 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
8990e307
LW		 1144 scalar(kid);
1145 }
79072805
LW		 1146 break;
1147 case OP_LEAVE:
1148 case OP_LEAVETRY:
5dc0d613 1149 kid = cLISTOPo->op_first;
54310121 1150 scalar(kid);
25b991bf
VP		 1151 kid = kid->op_sibling;
1152 do_kids:
1153 while (kid) {
1154 OP *sib = kid->op_sibling;
c08f093b
VP		 1155 if (sib && kid->op_type != OP_LEAVEWHEN)
1156 scalarvoid(kid);
1157 else
54310121 1158 scalar(kid);
25b991bf 1159 kid = sib;
54310121 1160 }
11206fdd 1161 PL_curcop = &PL_compiling;
54310121 1162 break;
748a9306 1163 case OP_SCOPE:
79072805 1164 case OP_LINESEQ:
8990e307 1165 case OP_LIST:
25b991bf
VP		 1166 kid = cLISTOPo->op_first;
1167 goto do_kids;
a801c63c 1168 case OP_SORT:
a2a5de95 1169 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
553e7bb0 1170 break;
79072805 1171 }
11343788 1172 return o;
79072805
LW		 1173}
1174
1175OP *
864dbfa3 1176Perl_scalarvoid(pTHX_ OP *o)
79072805 1177{
27da23d5 1178 dVAR;
79072805 1179 OP *kid;
095b19d1 1180 SV *useless_sv = NULL;
c445ea15 1181 const char* useless = NULL;
8990e307 1182 SV* sv;
2ebea0a1
GS		 1183 U8 want;
1184
7918f24d
NC		 1185 PERL_ARGS_ASSERT_SCALARVOID;
1186
eb8433b7
NC		 1187 /* trailing mad null ops don't count as "there" for void processing */
1188 if (PL_madskills &&
1189 o->op_type != OP_NULL &&
1190 o->op_sibling &&
1191 o->op_sibling->op_type == OP_NULL)
1192 {
1193 OP *sib;
1194 for (sib = o->op_sibling;
1195 sib && sib->op_type == OP_NULL;
1196 sib = sib->op_sibling) ;
1197
1198 if (!sib)
1199 return o;
1200 }
1201
acb36ea4 1202 if (o->op_type == OP_NEXTSTATE
acb36ea4
GS		 1203 || o->op_type == OP_DBSTATE
1204 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
acb36ea4 1205 || o->op_targ == OP_DBSTATE)))
2ebea0a1 1206 PL_curcop = (COP*)o; /* for warning below */
79072805 1207
54310121 1208 /* assumes no premature commitment */
2ebea0a1 1209 want = o->op_flags & OPf_WANT;
13765c85
DM		 1210 if ((want && want != OPf_WANT_SCALAR)
1211 || (PL_parser && PL_parser->error_count)
25b991bf 1212 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
7e363e51 1213 {
11343788 1214 return o;
7e363e51 1215 }
79072805 1216
b162f9ea 1217 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS		 1218 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1219 {
b162f9ea 1220 return scalar(o); /* As if inside SASSIGN */
7e363e51 1221 }
1c846c1f 1222
5dc0d613 1223 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
79072805 1224
11343788 1225 switch (o->op_type) {
79072805 1226 default:
22c35a8c 1227 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
8990e307 1228 break;
36477c24 1229 /* FALL THROUGH */
1230 case OP_REPEAT:
11343788 1231 if (o->op_flags & OPf_STACKED)
8990e307 1232 break;
5d82c453
GA		 1233 goto func_ops;
1234 case OP_SUBSTR:
1235 if (o->op_private == 4)
1236 break;
8990e307
LW		 1237 /* FALL THROUGH */
1238 case OP_GVSV:
1239 case OP_WANTARRAY:
1240 case OP_GV:
74295f0b 1241 case OP_SMARTMATCH:
8990e307
LW		 1242 case OP_PADSV:
1243 case OP_PADAV:
1244 case OP_PADHV:
1245 case OP_PADANY:
1246 case OP_AV2ARYLEN:
8990e307 1247 case OP_REF:
a0d0e21e
LW		 1248 case OP_REFGEN:
1249 case OP_SREFGEN:
8990e307
LW		 1250 case OP_DEFINED:
1251 case OP_HEX:
1252 case OP_OCT:
1253 case OP_LENGTH:
8990e307
LW		 1254 case OP_VEC:
1255 case OP_INDEX:
1256 case OP_RINDEX:
1257 case OP_SPRINTF:
1258 case OP_AELEM:
1259 case OP_AELEMFAST:
93bad3fd 1260 case OP_AELEMFAST_LEX:
8990e307 1261 case OP_ASLICE:
8990e307
LW		 1262 case OP_HELEM:
1263 case OP_HSLICE:
1264 case OP_UNPACK:
1265 case OP_PACK:
8990e307
LW		 1266 case OP_JOIN:
1267 case OP_LSLICE:
1268 case OP_ANONLIST:
1269 case OP_ANONHASH:
1270 case OP_SORT:
1271 case OP_REVERSE:
1272 case OP_RANGE:
1273 case OP_FLIP:
1274 case OP_FLOP:
1275 case OP_CALLER:
1276 case OP_FILENO:
1277 case OP_EOF:
1278 case OP_TELL:
1279 case OP_GETSOCKNAME:
1280 case OP_GETPEERNAME:
1281 case OP_READLINK:
1282 case OP_TELLDIR:
1283 case OP_GETPPID:
1284 case OP_GETPGRP:
1285 case OP_GETPRIORITY:
1286 case OP_TIME:
1287 case OP_TMS:
1288 case OP_LOCALTIME:
1289 case OP_GMTIME:
1290 case OP_GHBYNAME:
1291 case OP_GHBYADDR:
1292 case OP_GHOSTENT:
1293 case OP_GNBYNAME:
1294 case OP_GNBYADDR:
1295 case OP_GNETENT:
1296 case OP_GPBYNAME:
1297 case OP_GPBYNUMBER:
1298 case OP_GPROTOENT:
1299 case OP_GSBYNAME:
1300 case OP_GSBYPORT:
1301 case OP_GSERVENT:
1302 case OP_GPWNAM:
1303 case OP_GPWUID:
1304 case OP_GGRNAM:
1305 case OP_GGRGID:
1306 case OP_GETLOGIN:
78e1b766 1307 case OP_PROTOTYPE:
703227f5 1308 case OP_RUNCV:
5d82c453 1309 func_ops:
64aac5a9 1310 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
74295f0b 1311 /* Otherwise it's "Useless use of grep iterator" */
f5df4782 1312 useless = OP_DESC(o);
75068674
RGS		 1313 break;
1314
1315 case OP_SPLIT:
1316 kid = cLISTOPo->op_first;
1317 if (kid && kid->op_type == OP_PUSHRE
1318#ifdef USE_ITHREADS
1319 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff)
1320#else
1321 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv)
1322#endif
1323 useless = OP_DESC(o);
8990e307
LW		 1324 break;
1325
9f82cd5f
YST		 1326 case OP_NOT:
1327 kid = cUNOPo->op_first;
1328 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
bb16bae8 1329 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
9f82cd5f
YST		 1330 goto func_ops;
1331 }
1332 useless = "negative pattern binding (!~)";
1333 break;
1334
4f4d7508
DC		 1335 case OP_SUBST:
1336 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
8db9069c 1337 useless = "non-destructive substitution (s///r)";
4f4d7508
DC		 1338 break;
1339
bb16bae8
FC		 1340 case OP_TRANSR:
1341 useless = "non-destructive transliteration (tr///r)";
1342 break;
1343
8990e307
LW		 1344 case OP_RV2GV:
1345 case OP_RV2SV:
1346 case OP_RV2AV:
1347 case OP_RV2HV:
192587c2 1348 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
11343788 1349 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
8990e307
LW		 1350 useless = "a variable";
1351 break;
79072805
LW		 1352
1353 case OP_CONST:
7766f137 1354 sv = cSVOPo_sv;
7a52d87a
GS		 1355 if (cSVOPo->op_private & OPpCONST_STRICT)
1356 no_bareword_allowed(o);
1357 else {
d008e5eb 1358 if (ckWARN(WARN_VOID)) {
e7fec78e 1359 /* don't warn on optimised away booleans, eg
b5a930ec 1360 * use constant Foo, 5; Foo || print; */
e7fec78e 1361 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
d4c19fe8 1362 useless = NULL;
960b4253
MG		 1363 /* the constants 0 and 1 are permitted as they are
1364 conventionally used as dummies in constructs like
1365 1 while some_condition_with_side_effects; */
e7fec78e 1366 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
d4c19fe8 1367 useless = NULL;
d008e5eb 1368 else if (SvPOK(sv)) {
a52fe3ac
A		 1369 /* perl4's way of mixing documentation and code
1370 (before the invention of POD) was based on a
1371 trick to mix nroff and perl code. The trick was
1372 built upon these three nroff macros being used in
1373 void context. The pink camel has the details in
1374 the script wrapman near page 319. */
6136c704
AL		 1375 const char * const maybe_macro = SvPVX_const(sv);
1376 if (strnEQ(maybe_macro, "di", 2) ||
1377 strnEQ(maybe_macro, "ds", 2) ||
1378 strnEQ(maybe_macro, "ig", 2))
d4c19fe8 1379 useless = NULL;
919f76a3 1380 else {
d3bcd21f 1381 SV * const dsv = newSVpvs("");
095b19d1
NC		 1382 useless_sv
1383 = Perl_newSVpvf(aTHX_
1384 "a constant (%s)",
1385 pv_pretty(dsv, maybe_macro,
1386 SvCUR(sv), 32, NULL, NULL,
1387 PERL_PV_PRETTY_DUMP
1388 | PERL_PV_ESCAPE_NOCLEAR
1389 | PERL_PV_ESCAPE_UNI_DETECT));
fc2b2dca 1390 SvREFCNT_dec_NN(dsv);
919f76a3 1391 }
d008e5eb 1392 }
919f76a3 1393 else if (SvOK(sv)) {
095b19d1 1394 useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", sv);
919f76a3
RGS		 1395 }
1396 else
1397 useless = "a constant (undef)";
8990e307
LW		 1398 }
1399 }
93c66552 1400 op_null(o); /* don't execute or even remember it */
79072805
LW		 1401 break;
1402
1403 case OP_POSTINC:
11343788 1404 o->op_type = OP_PREINC; /* pre-increment is faster */
22c35a8c 1405 o->op_ppaddr = PL_ppaddr[OP_PREINC];
79072805
LW		 1406 break;
1407
1408 case OP_POSTDEC:
11343788 1409 o->op_type = OP_PREDEC; /* pre-decrement is faster */
22c35a8c 1410 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
79072805
LW		 1411 break;
1412
679d6c4e
HS		 1413 case OP_I_POSTINC:
1414 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1415 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1416 break;
1417
1418 case OP_I_POSTDEC:
1419 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1420 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1421 break;
1422
f2f8fd84
GG		 1423 case OP_SASSIGN: {
1424 OP *rv2gv;
1425 UNOP *refgen, *rv2cv;
1426 LISTOP *exlist;
1427
1428 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
1429 break;
1430
1431 rv2gv = ((BINOP *)o)->op_last;
1432 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
1433 break;
1434
1435 refgen = (UNOP *)((BINOP *)o)->op_first;
1436
1437 if (!refgen || refgen->op_type != OP_REFGEN)
1438 break;
1439
1440 exlist = (LISTOP *)refgen->op_first;
1441 if (!exlist || exlist->op_type != OP_NULL
1442 || exlist->op_targ != OP_LIST)
1443 break;
1444
1445 if (exlist->op_first->op_type != OP_PUSHMARK)
1446 break;
1447
1448 rv2cv = (UNOP*)exlist->op_last;
1449
1450 if (rv2cv->op_type != OP_RV2CV)
1451 break;
1452
1453 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
1454 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
1455 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
1456
1457 o->op_private |= OPpASSIGN_CV_TO_GV;
1458 rv2gv->op_private |= OPpDONT_INIT_GV;
1459 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
1460
1461 break;
1462 }
1463
540dd770
GG		 1464 case OP_AASSIGN: {
1465 inplace_aassign(o);
1466 break;
1467 }
1468
79072805
LW		 1469 case OP_OR:
1470 case OP_AND:
edbe35ea
VP		 1471 kid = cLOGOPo->op_first;
1472 if (kid->op_type == OP_NOT
1473 && (kid->op_flags & OPf_KIDS)
1474 && !PL_madskills) {
1475 if (o->op_type == OP_AND) {
1476 o->op_type = OP_OR;
1477 o->op_ppaddr = PL_ppaddr[OP_OR];
1478 } else {
1479 o->op_type = OP_AND;
1480 o->op_ppaddr = PL_ppaddr[OP_AND];
1481 }
1482 op_null(kid);
1483 }
1484
c963b151 1485 case OP_DOR:
79072805 1486 case OP_COND_EXPR:
0d863452
RH		 1487 case OP_ENTERGIVEN:
1488 case OP_ENTERWHEN:
11343788 1489 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
79072805
LW		 1490 scalarvoid(kid);
1491 break;
5aabfad6 1492
a0d0e21e 1493 case OP_NULL:
11343788 1494 if (o->op_flags & OPf_STACKED)
a0d0e21e 1495 break;
5aabfad6 1496 /* FALL THROUGH */
2ebea0a1
GS		 1497 case OP_NEXTSTATE:
1498 case OP_DBSTATE:
79072805
LW		 1499 case OP_ENTERTRY:
1500 case OP_ENTER:
11343788 1501 if (!(o->op_flags & OPf_KIDS))
79072805 1502 break;
54310121 1503 /* FALL THROUGH */
463ee0b2 1504 case OP_SCOPE:
79072805
LW		 1505 case OP_LEAVE:
1506 case OP_LEAVETRY:
a0d0e21e 1507 case OP_LEAVELOOP:
79072805 1508 case OP_LINESEQ:
79072805 1509 case OP_LIST:
0d863452
RH		 1510 case OP_LEAVEGIVEN:
1511 case OP_LEAVEWHEN:
11343788 1512 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW		 1513 scalarvoid(kid);
1514 break;
c90c0ff4 1515 case OP_ENTEREVAL:
5196be3e 1516 scalarkids(o);
c90c0ff4 1517 break;
d6483035 1518 case OP_SCALAR:
5196be3e 1519 return scalar(o);
79072805 1520 }
095b19d1
NC		 1521
1522 if (useless_sv) {
1523 /* mortalise it, in case warnings are fatal. */
1524 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
1525 "Useless use of %"SVf" in void context",
1526 sv_2mortal(useless_sv));
1527 }
1528 else if (useless) {
1529 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
1530 "Useless use of %s in void context",
1531 useless);
1532 }
11343788 1533 return o;
79072805
LW		 1534}
1535
1f676739 1536static OP *
412da003 1537S_listkids(pTHX_ OP *o)
79072805 1538{
11343788 1539 if (o && o->op_flags & OPf_KIDS) {
6867be6d 1540 OP *kid;
11343788 1541 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW		 1542 list(kid);
1543 }
11343788 1544 return o;
79072805
LW		 1545}
1546
1547OP *
864dbfa3 1548Perl_list(pTHX_ OP *o)
79072805 1549{
27da23d5 1550 dVAR;
79072805
LW		 1551 OP *kid;
1552
a0d0e21e 1553 /* assumes no premature commitment */
13765c85
DM		 1554 if (!o || (o->op_flags & OPf_WANT)
1555 || (PL_parser && PL_parser->error_count)
5dc0d613 1556 || o->op_type == OP_RETURN)
7e363e51 1557 {
11343788 1558 return o;
7e363e51 1559 }
79072805 1560
b162f9ea 1561 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS		 1562 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1563 {
b162f9ea 1564 return o; /* As if inside SASSIGN */
7e363e51 1565 }
1c846c1f 1566
5dc0d613 1567 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
79072805 1568
11343788 1569 switch (o->op_type) {
79072805
LW		 1570 case OP_FLOP:
1571 case OP_REPEAT:
11343788 1572 list(cBINOPo->op_first);
79072805
LW		 1573 break;
1574 case OP_OR:
1575 case OP_AND:
1576 case OP_COND_EXPR:
11343788 1577 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
79072805
LW		 1578 list(kid);
1579 break;
1580 default:
1581 case OP_MATCH:
8782bef2 1582 case OP_QR:
79072805
LW		 1583 case OP_SUBST:
1584 case OP_NULL:
11343788 1585 if (!(o->op_flags & OPf_KIDS))
79072805 1586 break;
11343788
MB		 1587 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1588 list(cBINOPo->op_first);
1589 return gen_constant_list(o);
79072805
LW		 1590 }
1591 case OP_LIST:
11343788 1592 listkids(o);
79072805
LW		 1593 break;
1594 case OP_LEAVE:
1595 case OP_LEAVETRY:
5dc0d613 1596 kid = cLISTOPo->op_first;
54310121 1597 list(kid);
25b991bf
VP		 1598 kid = kid->op_sibling;
1599 do_kids:
1600 while (kid) {
1601 OP *sib = kid->op_sibling;
c08f093b
VP		 1602 if (sib && kid->op_type != OP_LEAVEWHEN)
1603 scalarvoid(kid);
1604 else
54310121 1605 list(kid);
25b991bf 1606 kid = sib;
54310121 1607 }
11206fdd 1608 PL_curcop = &PL_compiling;
54310121 1609 break;
748a9306 1610 case OP_SCOPE:
79072805 1611 case OP_LINESEQ:
25b991bf
VP		 1612 kid = cLISTOPo->op_first;
1613 goto do_kids;
79072805 1614 }
11343788 1615 return o;
79072805
LW		 1616}
1617
1f676739 1618static OP *
2dd5337b 1619S_scalarseq(pTHX_ OP *o)
79072805 1620{
97aff369 1621 dVAR;
11343788 1622 if (o) {
1496a290
AL		 1623 const OPCODE type = o->op_type;
1624
1625 if (type == OP_LINESEQ || type == OP_SCOPE ||
1626 type == OP_LEAVE || type == OP_LEAVETRY)
463ee0b2 1627 {
6867be6d 1628 OP *kid;
11343788 1629 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
ed6116ce 1630 if (kid->op_sibling) {
463ee0b2 1631 scalarvoid(kid);
ed6116ce 1632 }
463ee0b2 1633 }
3280af22 1634 PL_curcop = &PL_compiling;
79072805 1635 }
11343788 1636 o->op_flags &= ~OPf_PARENS;
3280af22 1637 if (PL_hints & HINT_BLOCK_SCOPE)
11343788 1638 o->op_flags |= OPf_PARENS;
79072805 1639 }
8990e307 1640 else
11343788
MB		 1641 o = newOP(OP_STUB, 0);
1642 return o;
79072805
LW		 1643}
1644
76e3520e 1645STATIC OP *
cea2e8a9 1646S_modkids(pTHX_ OP *o, I32 type)
79072805 1647{
11343788 1648 if (o && o->op_flags & OPf_KIDS) {
6867be6d 1649 OP *kid;
11343788 1650 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
3ad73efd 1651 op_lvalue(kid, type);
79072805 1652 }
11343788 1653 return o;
79072805
LW		 1654}
1655
3ad73efd 1656/*
d164302a
GG		 1657=for apidoc finalize_optree
1658
1659This function finalizes the optree. Should be called directly after
1660the complete optree is built. It does some additional
1661checking which can't be done in the normal ck_xxx functions and makes
1662the tree thread-safe.
1663
1664=cut
1665*/
1666void
1667Perl_finalize_optree(pTHX_ OP* o)
1668{
1669 PERL_ARGS_ASSERT_FINALIZE_OPTREE;
1670
1671 ENTER;
1672 SAVEVPTR(PL_curcop);
1673
1674 finalize_op(o);
1675
1676 LEAVE;
1677}
1678
60dde6b2 1679STATIC void
d164302a
GG		 1680S_finalize_op(pTHX_ OP* o)
1681{
1682 PERL_ARGS_ASSERT_FINALIZE_OP;
1683
1684#if defined(PERL_MAD) && defined(USE_ITHREADS)
1685 {
1686 /* Make sure mad ops are also thread-safe */
1687 MADPROP *mp = o->op_madprop;
1688 while (mp) {
1689 if (mp->mad_type == MAD_OP && mp->mad_vlen) {
1690 OP *prop_op = (OP *) mp->mad_val;
1691 /* We only need "Relocate sv to the pad for thread safety.", but this
1692 easiest way to make sure it traverses everything */
4dc304e0
FC		 1693 if (prop_op->op_type == OP_CONST)
1694 cSVOPx(prop_op)->op_private &= ~OPpCONST_STRICT;
d164302a
GG		 1695 finalize_op(prop_op);
1696 }
1697 mp = mp->mad_next;
1698 }
1699 }
1700#endif
1701
1702 switch (o->op_type) {
1703 case OP_NEXTSTATE:
1704 case OP_DBSTATE:
1705 PL_curcop = ((COP*)o); /* for warnings */
1706 break;
1707 case OP_EXEC:
ea31ed66
GG		 1708 if ( o->op_sibling
1709 && (o->op_sibling->op_type == OP_NEXTSTATE || o->op_sibling->op_type == OP_DBSTATE)
d164302a
GG		 1710 && ckWARN(WARN_SYNTAX))
1711 {
ea31ed66
GG		 1712 if (o->op_sibling->op_sibling) {
1713 const OPCODE type = o->op_sibling->op_sibling->op_type;
d164302a
GG		 1714 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
1715 const line_t oldline = CopLINE(PL_curcop);
ea31ed66 1716 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_sibling));
d164302a
GG		 1717 Perl_warner(aTHX_ packWARN(WARN_EXEC),
1718 "Statement unlikely to be reached");
1719 Perl_warner(aTHX_ packWARN(WARN_EXEC),
1720 "\t(Maybe you meant system() when you said exec()?)\n");
1721 CopLINE_set(PL_curcop, oldline);
1722 }
1723 }
1724 }
1725 break;
1726
1727 case OP_GV:
1728 if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
1729 GV * const gv = cGVOPo_gv;
1730 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
1731 /* XXX could check prototype here instead of just carping */
1732 SV * const sv = sv_newmortal();
1733 gv_efullname3(sv, gv, NULL);
1734 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
1735 "%"SVf"() called too early to check prototype",
1736 SVfARG(sv));
1737 }
1738 }
1739 break;
1740
1741 case OP_CONST:
eb796c7f
GG		 1742 if (cSVOPo->op_private & OPpCONST_STRICT)
1743 no_bareword_allowed(o);
1744 /* FALLTHROUGH */
d164302a
GG		 1745#ifdef USE_ITHREADS
1746 case OP_HINTSEVAL:
1747 case OP_METHOD_NAMED:
1748 /* Relocate sv to the pad for thread safety.
1749 * Despite being a "constant", the SV is written to,
1750 * for reference counts, sv_upgrade() etc. */
1751 if (cSVOPo->op_sv) {
1752 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
1753 if (o->op_type != OP_METHOD_NAMED &&
1754 (SvPADTMP(cSVOPo->op_sv) || SvPADMY(cSVOPo->op_sv)))
1755 {
1756 /* If op_sv is already a PADTMP/MY then it is being used by
1757 * some pad, so make a copy. */
1758 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
e3918bb7 1759 if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
d164302a
GG		 1760 SvREFCNT_dec(cSVOPo->op_sv);
1761 }
1762 else if (o->op_type != OP_METHOD_NAMED
1763 && cSVOPo->op_sv == &PL_sv_undef) {
1764 /* PL_sv_undef is hack - it's unsafe to store it in the
1765 AV that is the pad, because av_fetch treats values of
1766 PL_sv_undef as a "free" AV entry and will merrily
1767 replace them with a new SV, causing pad_alloc to think
1768 that this pad slot is free. (When, clearly, it is not)
1769 */
1770 SvOK_off(PAD_SVl(ix));
1771 SvPADTMP_on(PAD_SVl(ix));
1772 SvREADONLY_on(PAD_SVl(ix));
1773 }
1774 else {
1775 SvREFCNT_dec(PAD_SVl(ix));
1776 SvPADTMP_on(cSVOPo->op_sv);
1777 PAD_SETSV(ix, cSVOPo->op_sv);
1778 /* XXX I don't know how this isn't readonly already. */
e3918bb7 1779 if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
d164302a
GG		 1780 }
1781 cSVOPo->op_sv = NULL;
1782 o->op_targ = ix;
1783 }
1784#endif
1785 break;
1786
1787 case OP_HELEM: {
1788 UNOP *rop;
1789 SV *lexname;
1790 GV **fields;
1791 SV **svp, *sv;
1792 const char *key = NULL;
1793 STRLEN keylen;
1794
1795 if (((BINOP*)o)->op_last->op_type != OP_CONST)
1796 break;
1797
1798 /* Make the CONST have a shared SV */
1799 svp = cSVOPx_svp(((BINOP*)o)->op_last);
e3918bb7 1800 if ((!SvIsCOW(sv = *svp))
d164302a
GG		 1801 && SvTYPE(sv) < SVt_PVMG && !SvROK(sv)) {
1802 key = SvPV_const(sv, keylen);
1803 lexname = newSVpvn_share(key,
1804 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
1805 0);
fc2b2dca 1806 SvREFCNT_dec_NN(sv);
d164302a
GG		 1807 *svp = lexname;
1808 }
1809
1810 if ((o->op_private & (OPpLVAL_INTRO)))
1811 break;
1812
1813 rop = (UNOP*)((BINOP*)o)->op_first;
1814 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
1815 break;
1816 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
1817 if (!SvPAD_TYPED(lexname))
1818 break;
1819 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
1820 if (!fields || !GvHV(*fields))
1821 break;
1822 key = SvPV_const(*svp, keylen);
1823 if (!hv_fetch(GvHV(*fields), key,
1824 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) {
ce16c625 1825 Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
84cf752c 1826 "in variable %"SVf" of type %"HEKf,
ce16c625 1827 SVfARG(*svp), SVfARG(lexname),
84cf752c 1828 HEKfARG(HvNAME_HEK(SvSTASH(lexname))));
d164302a
GG		 1829 }
1830 break;
1831 }
1832
1833 case OP_HSLICE: {
1834 UNOP *rop;
1835 SV *lexname;
1836 GV **fields;
1837 SV **svp;
1838 const char *key;
1839 STRLEN keylen;
1840 SVOP *first_key_op, *key_op;
1841
1842 if ((o->op_private & (OPpLVAL_INTRO))
1843 /* I bet there's always a pushmark... */
1844 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
1845 /* hmmm, no optimization if list contains only one key. */
1846 break;
1847 rop = (UNOP*)((LISTOP*)o)->op_last;
1848 if (rop->op_type != OP_RV2HV)
1849 break;
1850 if (rop->op_first->op_type == OP_PADSV)
1851 /* @$hash{qw(keys here)} */
1852 rop = (UNOP*)rop->op_first;
1853 else {
1854 /* @{$hash}{qw(keys here)} */
1855 if (rop->op_first->op_type == OP_SCOPE
1856 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
1857 {
1858 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
1859 }
1860 else
1861 break;
1862 }
1863
1864 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
1865 if (!SvPAD_TYPED(lexname))
1866 break;
1867 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
1868 if (!fields || !GvHV(*fields))
1869 break;
1870 /* Again guessing that the pushmark can be jumped over.... */
1871 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
1872 ->op_first->op_sibling;
1873 for (key_op = first_key_op; key_op;
1874 key_op = (SVOP*)key_op->op_sibling) {
1875 if (key_op->op_type != OP_CONST)
1876 continue;
1877 svp = cSVOPx_svp(key_op);
1878 key = SvPV_const(*svp, keylen);
1879 if (!hv_fetch(GvHV(*fields), key,
1880 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) {
ce16c625 1881 Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
84cf752c 1882 "in variable %"SVf" of type %"HEKf,
ce16c625 1883 SVfARG(*svp), SVfARG(lexname),
84cf752c 1884 HEKfARG(HvNAME_HEK(SvSTASH(lexname))));
d164302a
GG		 1885 }
1886 }
1887 break;
1888 }
a7fd8ef6 1889
d164302a
GG		 1890 case OP_SUBST: {
1891 if (cPMOPo->op_pmreplrootu.op_pmreplroot)
1892 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
1893 break;
1894 }
1895 default:
1896 break;
1897 }
1898
1899 if (o->op_flags & OPf_KIDS) {
1900 OP *kid;
1901 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1902 finalize_op(kid);
1903 }
1904}
1905
1906/*
3ad73efd
Z		 1907=for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
1908
1909Propagate lvalue ("modifiable") context to an op and its children.
1910I<type> represents the context type, roughly based on the type of op that
1911would do the modifying, although C<local()> is represented by OP_NULL,
1912because it has no op type of its own (it is signalled by a flag on
001c3c51
FC		 1913the lvalue op).
1914
1915This function detects things that can't be modified, such as C<$x+1>, and
1916generates errors for them. For example, C<$x+1 = 2> would cause it to be
1917called with an op of type OP_ADD and a C<type> argument of OP_SASSIGN.
1918
1919It also flags things that need to behave specially in an lvalue context,
1920such as C<$$x = 5> which might have to vivify a reference in C<$x>.
3ad73efd
Z		 1921
1922=cut
1923*/
ddeae0f1 1924
79072805 1925OP *
d3d7d28f 1926Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
79072805 1927{
27da23d5 1928 dVAR;
79072805 1929 OP *kid;
ddeae0f1
DM		 1930 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1931 int localize = -1;
79072805 1932
13765c85 1933 if (!o || (PL_parser && PL_parser->error_count))
11343788 1934 return o;
79072805 1935
b162f9ea 1936 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS		 1937 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1938 {
b162f9ea 1939 return o;
7e363e51 1940 }
1c846c1f 1941
5c906035
GG		 1942 assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
1943
69974ce6
FC		 1944 if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
1945
11343788 1946 switch (o->op_type) {
68dc0745 1947 case OP_UNDEF:
3280af22 1948 PL_modcount++;
5dc0d613 1949 return o;
5f05dabc 1950 case OP_STUB:
58bde88d 1951 if ((o->op_flags & OPf_PARENS) || PL_madskills)
5f05dabc 1952 break;
1953 goto nomod;
a0d0e21e 1954 case OP_ENTERSUB:
f79aa60b 1955 if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
11343788
MB		 1956 !(o->op_flags & OPf_STACKED)) {
1957 o->op_type = OP_RV2CV; /* entersub => rv2cv */
767eda44
FC		 1958 /* Both ENTERSUB and RV2CV use this bit, but for different pur-
1959 poses, so we need it clear. */
e26df76a 1960 o->op_private &= ~1;
22c35a8c 1961 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
11343788 1962 assert(cUNOPo->op_first->op_type == OP_NULL);
93c66552 1963 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
79072805
LW		 1964 break;
1965 }
cd06dffe 1966 else { /* lvalue subroutine call */
777d9014
FC		 1967 o->op_private |= OPpLVAL_INTRO
1968 |(OPpENTERSUB_INARGS * (type == OP_LEAVESUBLV));
e6438c1a 1969 PL_modcount = RETURN_UNLIMITED_NUMBER;
4978d6d9 1970 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
d0887bf3 1971 /* Potential lvalue context: */
cd06dffe
GS		 1972 o->op_private |= OPpENTERSUB_INARGS;
1973 break;
1974 }
1975 else { /* Compile-time error message: */
1976 OP *kid = cUNOPo->op_first;
1977 CV *cv;
cd06dffe 1978
3ea285d1
AL		 1979 if (kid->op_type != OP_PUSHMARK) {
1980 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1981 Perl_croak(aTHX_
1982 "panic: unexpected lvalue entersub "
1983 "args: type/targ %ld:%"UVuf,
1984 (long)kid->op_type, (UV)kid->op_targ);
1985 kid = kLISTOP->op_first;
1986 }
cd06dffe
GS		 1987 while (kid->op_sibling)
1988 kid = kid->op_sibling;
1989 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
cd06dffe
GS		 1990 break; /* Postpone until runtime */
1991 }
b2ffa427 1992
cd06dffe
GS		 1993 kid = kUNOP->op_first;
1994 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1995 kid = kUNOP->op_first;
b2ffa427 1996 if (kid->op_type == OP_NULL)
cd06dffe
GS		 1997 Perl_croak(aTHX_
1998 "Unexpected constant lvalue entersub "
55140b79 1999 "entry via type/targ %ld:%"UVuf,
3d811634 2000 (long)kid->op_type, (UV)kid->op_targ);
cd06dffe 2001 if (kid->op_type != OP_GV) {
cd06dffe
GS		 2002 break;
2003 }
b2ffa427 2004
638eceb6 2005 cv = GvCV(kGVOP_gv);
1c846c1f 2006 if (!cv)
da1dff94 2007 break;
cd06dffe
GS		 2008 if (CvLVALUE(cv))
2009 break;
2010 }
2011 }
79072805
LW		 2012 /* FALL THROUGH */
2013 default:
a0d0e21e 2014 nomod:
f5d552b4 2015 if (flags & OP_LVALUE_NO_CROAK) return NULL;
6fbb66d6 2016 /* grep, foreach, subcalls, refgen */
145b2bbb
FC		 2017 if (type == OP_GREPSTART || type == OP_ENTERSUB
2018 || type == OP_REFGEN || type == OP_LEAVESUBLV)
a0d0e21e 2019 break;
cea2e8a9 2020 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
638bc118 2021 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
cd06dffe
GS		 2022 ? "do block"
2023 : (o->op_type == OP_ENTERSUB
2024 ? "non-lvalue subroutine call"
53e06cf0 2025 : OP_DESC(o))),
22c35a8c 2026 type ? PL_op_desc[type] : "local"));
11343788 2027 return o;
79072805 2028
a0d0e21e
LW		 2029 case OP_PREINC:
2030 case OP_PREDEC:
2031 case OP_POW:
2032 case OP_MULTIPLY:
2033 case OP_DIVIDE:
2034 case OP_MODULO:
2035 case OP_REPEAT:
2036 case OP_ADD:
2037 case OP_SUBTRACT:
2038 case OP_CONCAT:
2039 case OP_LEFT_SHIFT:
2040 case OP_RIGHT_SHIFT:
2041 case OP_BIT_AND:
2042 case OP_BIT_XOR:
2043 case OP_BIT_OR:
2044 case OP_I_MULTIPLY:
2045 case OP_I_DIVIDE:
2046 case OP_I_MODULO:
2047 case OP_I_ADD:
2048 case OP_I_SUBTRACT:
11343788 2049 if (!(o->op_flags & OPf_STACKED))
a0d0e21e 2050 goto nomod;
3280af22 2051 PL_modcount++;
a0d0e21e 2052 break;
b2ffa427 2053
79072805 2054 case OP_COND_EXPR:
ddeae0f1 2055 localize = 1;
11343788 2056 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
3ad73efd 2057 op_lvalue(kid, type);
79072805
LW		 2058 break;
2059
2060 case OP_RV2AV:
2061 case OP_RV2HV:
11343788 2062 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
e6438c1a 2063 PL_modcount = RETURN_UNLIMITED_NUMBER;
11343788 2064 return o; /* Treat \(@foo) like ordinary list. */
748a9306
LW		 2065 }
2066 /* FALL THROUGH */
79072805 2067 case OP_RV2GV:
5dc0d613 2068 if (scalar_mod_type(o, type))
3fe9a6f1 2069 goto nomod;
11343788 2070 ref(cUNOPo->op_first, o->op_type);
79072805 2071 /* FALL THROUGH */
79072805
LW		 2072 case OP_ASLICE:
2073 case OP_HSLICE:
ddeae0f1 2074 localize = 1;
78f9721b
SM		 2075 /* FALL THROUGH */
2076 case OP_AASSIGN:
631dbaa2
FC		 2077 if (type == OP_LEAVESUBLV)
2078 o->op_private |= OPpMAYBE_LVSUB;
2079 /* FALL THROUGH */
93a17b20
LW		 2080 case OP_NEXTSTATE:
2081 case OP_DBSTATE:
e6438c1a 2082 PL_modcount = RETURN_UNLIMITED_NUMBER;
79072805 2083 break;
28c5b5bc
RGS		 2084 case OP_AV2ARYLEN:
2085 PL_hints |= HINT_BLOCK_SCOPE;
2086 if (type == OP_LEAVESUBLV)
2087 o->op_private |= OPpMAYBE_LVSUB;
2088 PL_modcount++;
2089 break;
463ee0b2 2090 case OP_RV2SV:
aeea060c 2091 ref(cUNOPo->op_first, o->op_type);
ddeae0f1 2092 localize = 1;
463ee0b2 2093 /* FALL THROUGH */
79072805 2094 case OP_GV:
3280af22 2095 PL_hints |= HINT_BLOCK_SCOPE;
463ee0b2 2096 case OP_SASSIGN:
bf4b1e52
GS		 2097 case OP_ANDASSIGN:
2098 case OP_ORASSIGN:
c963b151 2099 case OP_DORASSIGN:
ddeae0f1
DM		 2100 PL_modcount++;
2101 break;
2102
8990e307 2103 case OP_AELEMFAST:
93bad3fd 2104 case OP_AELEMFAST_LEX:
6a077020 2105 localize = -1;
3280af22 2106 PL_modcount++;
8990e307
LW		 2107 break;
2108
748a9306
LW		 2109 case OP_PADAV:
2110 case OP_PADHV:
e6438c1a 2111 PL_modcount = RETURN_UNLIMITED_NUMBER;
5196be3e
MB		 2112 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
2113 return o; /* Treat \(@foo) like ordinary list. */
2114 if (scalar_mod_type(o, type))
3fe9a6f1 2115 goto nomod;
78f9721b
SM		 2116 if (type == OP_LEAVESUBLV)
2117 o->op_private |= OPpMAYBE_LVSUB;
748a9306
LW		 2118 /* FALL THROUGH */
2119 case OP_PADSV:
3280af22 2120 PL_modcount++;
ddeae0f1 2121 if (!type) /* local() */
5ede95a0
BF		 2122 Perl_croak(aTHX_ "Can't localize lexical variable %"SVf,
2123 PAD_COMPNAME_SV(o->op_targ));
463ee0b2
LW		 2124 break;
2125
748a9306 2126 case OP_PUSHMARK:
ddeae0f1 2127 localize = 0;
748a9306 2128 break;
b2ffa427 2129
69969c6f 2130 case OP_KEYS:
d8065907 2131 case OP_RKEYS:
fad4a2e4 2132 if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
69969c6f 2133 goto nomod;
5d82c453
GA		 2134 goto lvalue_func;
2135 case OP_SUBSTR:
2136 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
2137 goto nomod;
5f05dabc 2138 /* FALL THROUGH */
a0d0e21e 2139 case OP_POS:
463ee0b2 2140 case OP_VEC:
fad4a2e4 2141 lvalue_func:
78f9721b
SM		 2142 if (type == OP_LEAVESUBLV)
2143 o->op_private |= OPpMAYBE_LVSUB;
11343788
MB		 2144 pad_free(o->op_targ);
2145 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
5dc0d613 2146 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
11343788 2147 if (o->op_flags & OPf_KIDS)
3ad73efd 2148 op_lvalue(cBINOPo->op_first->op_sibling, type);
463ee0b2 2149 break;
a0d0e21e 2150
463ee0b2
LW		 2151 case OP_AELEM:
2152 case OP_HELEM:
11343788 2153 ref(cBINOPo->op_first, o->op_type);
68dc0745 2154 if (type == OP_ENTERSUB &&
5dc0d613
MB		 2155 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
2156 o->op_private |= OPpLVAL_DEFER;
78f9721b
SM		 2157 if (type == OP_LEAVESUBLV)
2158 o->op_private |= OPpMAYBE_LVSUB;
ddeae0f1 2159 localize = 1;
3280af22 2160 PL_modcount++;
463ee0b2
LW		 2161 break;
2162
2163 case OP_SCOPE:
2164 case OP_LEAVE:
2165 case OP_ENTER:
78f9721b 2166 case OP_LINESEQ:
ddeae0f1 2167 localize = 0;
11343788 2168 if (o->op_flags & OPf_KIDS)
3ad73efd 2169 op_lvalue(cLISTOPo->op_last, type);
a0d0e21e
LW		 2170 break;
2171
2172 case OP_NULL:
ddeae0f1 2173 localize = 0;
638bc118
GS		 2174 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
2175 goto nomod;
2176 else if (!(o->op_flags & OPf_KIDS))
463ee0b2 2177 break;
11343788 2178 if (o->op_targ != OP_LIST) {
3ad73efd 2179 op_lvalue(cBINOPo->op_first, type);
a0d0e21e
LW		 2180 break;
2181 }
2182 /* FALL THROUGH */
463ee0b2 2183 case OP_LIST:
ddeae0f1 2184 localize = 0;
11343788 2185 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
5c906035
GG		 2186 /* elements might be in void context because the list is
2187 in scalar context or because they are attribute sub calls */
2188 if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
2189 op_lvalue(kid, type);
463ee0b2 2190 break;
78f9721b
SM		 2191
2192 case OP_RETURN:
2193 if (type != OP_LEAVESUBLV)
2194 goto nomod;
3ad73efd 2195 break; /* op_lvalue()ing was handled by ck_return() */
1efec5ed
FC		 2196
2197 case OP_COREARGS:
2198 return o;
463ee0b2 2199 }
58d95175 2200
8be1be90
AMS		 2201 /* [20011101.069] File test operators interpret OPf_REF to mean that
2202 their argument is a filehandle; thus \stat(".") should not set
2203 it. AMS 20011102 */
2204 if (type == OP_REFGEN &&
ef69c8fc 2205 PL_check[o->op_type] == Perl_ck_ftst)
8be1be90
AMS		 2206 return o;
2207
2208 if (type != OP_LEAVESUBLV)
2209 o->op_flags |= OPf_MOD;
2210
2211 if (type == OP_AASSIGN || type == OP_SASSIGN)
2212 o->op_flags |= OPf_SPECIAL|OPf_REF;
ddeae0f1
DM		 2213 else if (!type) { /* local() */
2214 switch (localize) {
2215 case 1:
2216 o->op_private |= OPpLVAL_INTRO;
2217 o->op_flags &= ~OPf_SPECIAL;
2218 PL_hints |= HINT_BLOCK_SCOPE;
2219 break;
2220 case 0:
2221 break;
2222 case -1:
a2a5de95
NC		 2223 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
2224 "Useless localization of %s", OP_DESC(o));
ddeae0f1 2225 }
463ee0b2 2226 }
8be1be90
AMS		 2227 else if (type != OP_GREPSTART && type != OP_ENTERSUB
2228 && type != OP_LEAVESUBLV)
2229 o->op_flags |= OPf_REF;
11343788 2230 return o;
463ee0b2
LW		 2231}
2232
864dbfa3 2233STATIC bool
5f66b61c 2234S_scalar_mod_type(const OP *o, I32 type)
3fe9a6f1 2235{
2236 switch (type) {
32a60974 2237 case OP_POS:
3fe9a6f1 2238 case OP_SASSIGN:
1efec5ed 2239 if (o && o->op_type == OP_RV2GV)
3fe9a6f1 2240 return FALSE;
2241 /* FALL THROUGH */
2242 case OP_PREINC:
2243 case OP_PREDEC:
2244 case OP_POSTINC:
2245 case OP_POSTDEC:
2246 case OP_I_PREINC:
2247 case OP_I_PREDEC:
2248 case OP_I_POSTINC:
2249 case OP_I_POSTDEC:
2250 case OP_POW:
2251 case OP_MULTIPLY:
2252 case OP_DIVIDE:
2253 case OP_MODULO:
2254 case OP_REPEAT:
2255 case OP_ADD:
2256 case OP_SUBTRACT:
2257 case OP_I_MULTIPLY:
2258 case OP_I_DIVIDE:
2259 case OP_I_MODULO:
2260 case OP_I_ADD:
2261 case OP_I_SUBTRACT:
2262 case OP_LEFT_SHIFT:
2263 case OP_RIGHT_SHIFT:
2264 case OP_BIT_AND:
2265 case OP_BIT_XOR:
2266 case OP_BIT_OR:
2267 case OP_CONCAT:
2268 case OP_SUBST:
2269 case OP_TRANS:
bb16bae8 2270 case OP_TRANSR:
49e9fbe6
GS		 2271 case OP_READ:
2272 case OP_SYSREAD:
2273 case OP_RECV:
bf4b1e52
GS		 2274 case OP_ANDASSIGN:
2275 case OP_ORASSIGN:
410d09fe 2276 case OP_DORASSIGN:
3fe9a6f1 2277 return TRUE;
2278 default:
2279 return FALSE;
2280 }
2281}
2282
35cd451c 2283STATIC bool
5f66b61c 2284S_is_handle_constructor(const OP *o, I32 numargs)
35cd451c 2285{
7918f24d
NC		 2286 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
2287
35cd451c
GS		 2288 switch (o->op_type) {
2289 case OP_PIPE_OP:
2290 case OP_SOCKPAIR:
504618e9 2291 if (numargs == 2)
35cd451c
GS		 2292 return TRUE;
2293 /* FALL THROUGH */
2294 case OP_SYSOPEN:
2295 case OP_OPEN:
ded8aa31 2296 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
35cd451c
GS		 2297 case OP_SOCKET:
2298 case OP_OPEN_DIR:
2299 case OP_ACCEPT:
504618e9 2300 if (numargs == 1)
35cd451c 2301 return TRUE;
5f66b61c 2302 /* FALLTHROUGH */
35cd451c
GS		 2303 default:
2304 return FALSE;
2305 }
2306}
2307
0d86688d
NC		 2308static OP *
2309S_refkids(pTHX_ OP *o, I32 type)
463ee0b2 2310{
11343788 2311 if (o && o->op_flags & OPf_KIDS) {
6867be6d 2312 OP *kid;
11343788 2313 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
463ee0b2
LW		 2314 ref(kid, type);
2315 }
11343788 2316 return o;
463ee0b2
LW		 2317}
2318
2319OP *
e4c5ccf3 2320Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
463ee0b2 2321{
27da23d5 2322 dVAR;
463ee0b2 2323 OP *kid;
463ee0b2 2324
7918f24d
NC		 2325 PERL_ARGS_ASSERT_DOREF;
2326
13765c85 2327 if (!o || (PL_parser && PL_parser->error_count))
11343788 2328 return o;
463ee0b2 2329
11343788 2330 switch (o->op_type) {
a0d0e21e 2331 case OP_ENTERSUB:
f4df43b5 2332 if ((type == OP_EXISTS || type == OP_DEFINED) &&
11343788
MB		 2333 !(o->op_flags & OPf_STACKED)) {
2334 o->op_type = OP_RV2CV; /* entersub => rv2cv */
22c35a8c 2335 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
11343788 2336 assert(cUNOPo->op_first->op_type == OP_NULL);
93c66552 2337 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
11343788 2338 o->op_flags |= OPf_SPECIAL;
e26df76a 2339 o->op_private &= ~1;
8990e307 2340 }
767eda44 2341 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
0e9700df
GG		 2342 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2343 : type == OP_RV2HV ? OPpDEREF_HV
2344 : OPpDEREF_SV);
767eda44
FC		 2345 o->op_flags |= OPf_MOD;
2346 }
2347
8990e307 2348 break;
aeea060c 2349
463ee0b2 2350 case OP_COND_EXPR:
11343788 2351 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
e4c5ccf3 2352 doref(kid, type, set_op_ref);
463ee0b2 2353 break;
8990e307 2354 case OP_RV2SV:
35cd451c
GS		 2355 if (type == OP_DEFINED)
2356 o->op_flags |= OPf_SPECIAL; /* don't create GV */
e4c5ccf3 2357 doref(cUNOPo->op_first, o->op_type, set_op_ref);
4633a7c4
LW		 2358 /* FALL THROUGH */
2359 case OP_PADSV:
5f05dabc 2360 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5dc0d613
MB		 2361 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2362 : type == OP_RV2HV ? OPpDEREF_HV
2363 : OPpDEREF_SV);
11343788 2364 o->op_flags |= OPf_MOD;
a0d0e21e 2365 }
8990e307 2366 break;
1c846c1f 2367
463ee0b2
LW		 2368 case OP_RV2AV:
2369 case OP_RV2HV:
e4c5ccf3
RH		 2370 if (set_op_ref)
2371 o->op_flags |= OPf_REF;
8990e307 2372 /* FALL THROUGH */
463ee0b2 2373 case OP_RV2GV:
35cd451c
GS		 2374 if (type == OP_DEFINED)
2375 o->op_flags |= OPf_SPECIAL; /* don't create GV */
e4c5ccf3 2376 doref(cUNOPo->op_first, o->op_type, set_op_ref);
463ee0b2 2377 break;
8990e307 2378
463ee0b2
LW		 2379 case OP_PADAV:
2380 case OP_PADHV:
e4c5ccf3
RH		 2381 if (set_op_ref)
2382 o->op_flags |= OPf_REF;
79072805 2383 break;
aeea060c 2384
8990e307 2385 case OP_SCALAR:
79072805 2386 case OP_NULL:
518618af 2387 if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
463ee0b2 2388 break;
e4c5ccf3 2389 doref(cBINOPo->op_first, type, set_op_ref);
79072805
LW		 2390 break;
2391 case OP_AELEM:
2392 case OP_HELEM:
e4c5ccf3 2393 doref(cBINOPo->op_first, o->op_type, set_op_ref);
5f05dabc 2394 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5dc0d613
MB		 2395 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2396 : type == OP_RV2HV ? OPpDEREF_HV
2397 : OPpDEREF_SV);
11343788 2398 o->op_flags |= OPf_MOD;
8990e307 2399 }
79072805
LW		 2400 break;
2401
463ee0b2 2402 case OP_SCOPE:
79072805 2403 case OP_LEAVE:
e4c5ccf3
RH		 2404 set_op_ref = FALSE;
2405 /* FALL THROUGH */
79072805 2406 case OP_ENTER:
8990e307 2407 case OP_LIST:
11343788 2408 if (!(o->op_flags & OPf_KIDS))
79072805 2409 break;
e4c5ccf3 2410 doref(cLISTOPo->op_last, type, set_op_ref);
79072805 2411 break;
a0d0e21e
LW		 2412 default:
2413 break;
79072805 2414 }
11343788 2415 return scalar(o);
8990e307 2416
79072805
LW		 2417}
2418
09bef843
SB		 2419STATIC OP *
2420S_dup_attrlist(pTHX_ OP *o)
2421{
97aff369 2422 dVAR;
0bd48802 2423 OP *rop;
09bef843 2424
7918f24d
NC		 2425 PERL_ARGS_ASSERT_DUP_ATTRLIST;
2426
09bef843
SB		 2427 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
2428 * where the first kid is OP_PUSHMARK and the remaining ones
2429 * are OP_CONST. We need to push the OP_CONST values.
2430 */
2431 if (o->op_type == OP_CONST)
b37c2d43 2432 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
eb8433b7
NC		 2433#ifdef PERL_MAD
2434 else if (o->op_type == OP_NULL)
1d866c12 2435 rop = NULL;
eb8433b7 2436#endif
09bef843
SB		 2437 else {
2438 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
5f66b61c 2439 rop = NULL;
09bef843
SB		 2440 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
2441 if (o->op_type == OP_CONST)
2fcb4757 2442 rop = op_append_elem(OP_LIST, rop,
09bef843 2443 newSVOP(OP_CONST, o->op_flags,
b37c2d43 2444 SvREFCNT_inc_NN(cSVOPo->op_sv)));
09bef843
SB		 2445 }
2446 }
2447 return rop;
2448}
2449
2450STATIC void
ad0dc73b 2451S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
09bef843 2452{
27da23d5 2453 dVAR;
ad0dc73b 2454 SV * const stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
09bef843 2455
7918f24d
NC		 2456 PERL_ARGS_ASSERT_APPLY_ATTRS;
2457
09bef843
SB		 2458 /* fake up C<use attributes $pkg,$rv,@attrs> */
2459 ENTER; /* need to protect against side-effects of 'use' */
e4783991 2460
09bef843 2461#define ATTRSMODULE "attributes"
95f0a2f1
SB		 2462#define ATTRSMODULE_PM "attributes.pm"
2463
ad0dc73b 2464 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
6136c704
AL		 2465 newSVpvs(ATTRSMODULE),
2466 NULL,
2fcb4757 2467 op_prepend_elem(OP_LIST,
95f0a2f1 2468 newSVOP(OP_CONST, 0, stashsv),
2fcb4757 2469 op_prepend_elem(OP_LIST,
95f0a2f1
SB		 2470 newSVOP(OP_CONST, 0,
2471 newRV(target)),
2472 dup_attrlist(attrs))));
09bef843
SB		 2473 LEAVE;
2474}
2475
95f0a2f1
SB		 2476STATIC void
2477S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
2478{
97aff369 2479 dVAR;
95f0a2f1 2480 OP *pack, *imop, *arg;
ad0dc73b 2481 SV *meth, *stashsv, **svp;
95f0a2f1 2482
7918f24d
NC		 2483 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
2484
95f0a2f1
SB		 2485 if (!attrs)
2486 return;
2487
2488 assert(target->op_type == OP_PADSV ||
2489 target->op_type == OP_PADHV ||
2490 target->op_type == OP_PADAV);
2491
2492 /* Ensure that attributes.pm is loaded. */
ad0dc73b
FC		 2493 ENTER; /* need to protect against side-effects of 'use' */
2494 /* Don't force the C<use> if we don't need it. */
2495 svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
2496 if (svp && *svp != &PL_sv_undef)
2497 NOOP; /* already in %INC */
2498 else
2499 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
2500 newSVpvs(ATTRSMODULE), NULL);
2501 LEAVE;
95f0a2f1
SB		 2502
2503 /* Need package name for method call. */
6136c704 2504 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
95f0a2f1
SB		 2505
2506 /* Build up the real arg-list. */
5aaec2b4
NC		 2507 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2508
95f0a2f1
SB		 2509 arg = newOP(OP_PADSV, 0);
2510 arg->op_targ = target->op_targ;
2fcb4757 2511 arg = op_prepend_elem(OP_LIST,
95f0a2f1 2512 newSVOP(OP_CONST, 0, stashsv),
2fcb4757 2513 op_prepend_elem(OP_LIST,
95f0a2f1 2514 newUNOP(OP_REFGEN, 0,
3ad73efd 2515 op_lvalue(arg, OP_REFGEN)),
95f0a2f1
SB		 2516 dup_attrlist(attrs)));
2517
2518 /* Fake up a method call to import */
18916d0d 2519 meth = newSVpvs_share("import");
95f0a2f1 2520 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2fcb4757
Z		 2521 op_append_elem(OP_LIST,
2522 op_prepend_elem(OP_LIST, pack, list(arg)),
95f0a2f1 2523 newSVOP(OP_METHOD_NAMED, 0, meth)));
95f0a2f1
SB		 2524
2525 /* Combine the ops. */
2fcb4757 2526 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
95f0a2f1
SB		 2527}
2528
2529/*
2530=notfor apidoc apply_attrs_string
2531
2532Attempts to apply a list of attributes specified by the C<attrstr> and
2533C<len> arguments to the subroutine identified by the C<cv> argument which
2534is expected to be associated with the package identified by the C<stashpv>
2535argument (see L<attributes>). It gets this wrong, though, in that it
2536does not correctly identify the boundaries of the individual attribute
2537specifications within C<attrstr>. This is not really intended for the
2538public API, but has to be listed here for systems such as AIX which
2539need an explicit export list for symbols. (It's called from XS code
2540in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
2541to respect attribute syntax properly would be welcome.
2542
2543=cut
2544*/
2545
be3174d2 2546void
6867be6d
AL		 2547Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
2548 const char *attrstr, STRLEN len)
be3174d2 2549{
5f66b61c 2550 OP *attrs = NULL;
be3174d2 2551
7918f24d
NC		 2552 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2553
be3174d2
GS		 2554 if (!len) {
2555 len = strlen(attrstr);
2556 }
2557
2558 while (len) {
2559 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2560 if (len) {
890ce7af 2561 const char * const sstr = attrstr;
be3174d2 2562 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2fcb4757 2563 attrs = op_append_elem(OP_LIST, attrs,
be3174d2
GS		 2564 newSVOP(OP_CONST, 0,
2565 newSVpvn(sstr, attrstr-sstr)));
2566 }
2567 }
2568
2569 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
6136c704 2570 newSVpvs(ATTRSMODULE),
2fcb4757 2571 NULL, op_prepend_elem(OP_LIST,
be3174d2 2572 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2fcb4757 2573 op_prepend_elem(OP_LIST,
be3174d2 2574 newSVOP(OP_CONST, 0,
ad64d0ec 2575 newRV(MUTABLE_SV(cv))),
be3174d2
GS		 2576 attrs)));
2577}
2578
09bef843 2579STATIC OP *
95f0a2f1 2580S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
93a17b20 2581{
97aff369 2582 dVAR;
93a17b20 2583 I32 type;
a1fba7eb 2584 const bool stately = PL_parser && PL_parser->in_my == KEY_state;
93a17b20 2585
7918f24d
NC		 2586 PERL_ARGS_ASSERT_MY_KID;
2587
13765c85 2588 if (!o || (PL_parser && PL_parser->error_count))
11343788 2589 return o;
93a17b20 2590
bc61e325 2591 type = o->op_type;
eb8433b7
NC		 2592 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2593 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2594 return o;
2595 }
2596
93a17b20 2597 if (type == OP_LIST) {
6867be6d 2598 OP *kid;
11343788 2599 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
95f0a2f1 2600 my_kid(kid, attrs, imopsp);
0865059d 2601 return o;
8b8c1fb9 2602 } else if (type == OP_UNDEF || type == OP_STUB) {
7766148a 2603 return o;
77ca0c92
LW		 2604 } else if (type == OP_RV2SV || /* "our" declaration */
2605 type == OP_RV2AV ||
2606 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1ce0b88c 2607 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
fab01b8e 2608 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
952306ac 2609 OP_DESC(o),
12bd6ede
DM		 2610 PL_parser->in_my == KEY_our
2611 ? "our"
2612 : PL_parser->in_my == KEY_state ? "state" : "my"));
1ce0b88c 2613 } else if (attrs) {
551405c4 2614 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
12bd6ede
DM		 2615 PL_parser->in_my = FALSE;
2616 PL_parser->in_my_stash = NULL;
1ce0b88c
RGS		 2617 apply_attrs(GvSTASH(gv),
2618 (type == OP_RV2SV ? GvSV(gv) :
ad64d0ec
NC		 2619 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2620 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
ad0dc73b 2621 attrs);
1ce0b88c 2622 }
192587c2 2623 o->op_private |= OPpOUR_INTRO;
77ca0c92 2624 return o;
95f0a2f1
SB		 2625 }
2626 else if (type != OP_PADSV &&
93a17b20
LW		 2627 type != OP_PADAV &&
2628 type != OP_PADHV &&
2629 type != OP_PUSHMARK)
2630 {
eb64745e 2631 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
53e06cf0 2632 OP_DESC(o),
12bd6ede
DM		 2633 PL_parser->in_my == KEY_our
2634 ? "our"
2635 : PL_parser->in_my == KEY_state ? "state" : "my"));
11343788 2636 return o;
93a17b20 2637 }
09bef843
SB		 2638 else if (attrs && type != OP_PUSHMARK) {
2639 HV *stash;
09bef843 2640
12bd6ede
DM		 2641 PL_parser->in_my = FALSE;
2642 PL_parser->in_my_stash = NULL;
eb64745e 2643
09bef843 2644 /* check for C<my Dog $spot> when deciding package */
dd2155a4
DM		 2645 stash = PAD_COMPNAME_TYPE(o->op_targ);
2646 if (!stash)
09bef843 2647 stash = PL_curstash;
95f0a2f1 2648 apply_attrs_my(stash, o, attrs, imopsp);
09bef843 2649 }
11343788
MB		 2650 o->op_flags |= OPf_MOD;
2651 o->op_private |= OPpLVAL_INTRO;
a1fba7eb 2652 if (stately)
952306ac 2653 o->op_private |= OPpPAD_STATE;
11343788 2654 return o;
93a17b20
LW		 2655}
2656
2657OP *
09bef843
SB		 2658Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2659{
97aff369 2660 dVAR;
0bd48802 2661 OP *rops;
95f0a2f1
SB		 2662 int maybe_scalar = 0;
2663
7918f24d
NC		 2664 PERL_ARGS_ASSERT_MY_ATTRS;
2665
d2be0de5 2666/* [perl #17376]: this appears to be premature, and results in code such as
c754c3d7 2667 C< our(%x); > executing in list mode rather than void mode */
d2be0de5 2668#if 0
09bef843
SB		 2669 if (o->op_flags & OPf_PARENS)
2670 list(o);
95f0a2f1
SB		 2671 else
2672 maybe_scalar = 1;
d2be0de5
YST		 2673#else
2674 maybe_scalar = 1;
2675#endif
09bef843
SB		 2676 if (attrs)
2677 SAVEFREEOP(attrs);
5f66b61c 2678 rops = NULL;
95f0a2f1
SB		 2679 o = my_kid(o, attrs, &rops);
2680 if (rops) {
2681 if (maybe_scalar && o->op_type == OP_PADSV) {
2fcb4757 2682 o = scalar(op_append_list(OP_LIST, rops, o));
95f0a2f1
SB		 2683 o->op_private |= OPpLVAL_INTRO;
2684 }
f5d1ed10
FC		 2685 else {
2686 /* The listop in rops might have a pushmark at the beginning,
2687 which will mess up list assignment. */
2688 LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
2689 if (rops->op_type == OP_LIST &&
2690 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
2691 {
2692 OP * const pushmark = lrops->op_first;
2693 lrops->op_first = pushmark->op_sibling;
2694 op_free(pushmark);
2695 }
2fcb4757 2696 o = op_append_list(OP_LIST, o, rops);
f5d1ed10 2697 }
95f0a2f1 2698 }
12bd6ede
DM		 2699 PL_parser->in_my = FALSE;
2700 PL_parser->in_my_stash = NULL;
eb64745e 2701 return o;
09bef843
SB		 2702}
2703
2704OP *
864dbfa3 2705Perl_sawparens(pTHX_ OP *o)
79072805 2706{
96a5add6 2707 PERL_UNUSED_CONTEXT;
79072805
LW		 2708 if (o)
2709 o->op_flags |= OPf_PARENS;
2710 return o;
2711}
2712
2713OP *
864dbfa3 2714Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
79072805 2715{
11343788 2716 OP *o;
59f00321 2717 bool ismatchop = 0;
1496a290
AL		 2718 const OPCODE ltype = left->op_type;
2719 const OPCODE rtype = right->op_type;
79072805 2720
7918f24d
NC		 2721 PERL_ARGS_ASSERT_BIND_MATCH;
2722
1496a290
AL		 2723 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2724 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
041457d9 2725 {
1496a290 2726 const char * const desc
bb16bae8
FC		 2727 = PL_op_desc[(
2728 rtype == OP_SUBST || rtype == OP_TRANS
2729 || rtype == OP_TRANSR
2730 )
666ea192 2731 ? (int)rtype : OP_MATCH];
c6771ab6
FC		 2732 const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
2733 GV *gv;
2734 SV * const name =
2735 (ltype == OP_RV2AV || ltype == OP_RV2HV)
2736 ? cUNOPx(left)->op_first->op_type == OP_GV
2737 && (gv = cGVOPx_gv(cUNOPx(left)->op_first))
2738 ? varname(gv, isary ? '@' : '%', 0, NULL, 0, 1)
2739 : NULL
ba510004
FC		 2740 : varname(
2741 (GV *)PL_compcv, isary ? '@' : '%', left->op_targ, NULL, 0, 1
2742 );
c6771ab6
FC		 2743 if (name)
2744 Perl_warner(aTHX_ packWARN(WARN_MISC),
2745 "Applying %s to %"SVf" will act on scalar(%"SVf")",
2746 desc, name, name);
2747 else {
2748 const char * const sample = (isary
666ea192 2749 ? "@array" : "%hash");
c6771ab6 2750 Perl_warner(aTHX_ packWARN(WARN_MISC),
1c846c1f 2751 "Applying %s to %s will act on scalar(%s)",
599cee73 2752 desc, sample, sample);
c6771ab6 2753 }
2ae324a7 2754 }
2755
1496a290 2756 if (rtype == OP_CONST &&
5cc9e5c9
RH		 2757 cSVOPx(right)->op_private & OPpCONST_BARE &&
2758 cSVOPx(right)->op_private & OPpCONST_STRICT)
2759 {
2760 no_bareword_allowed(right);
2761 }
2762
bb16bae8 2763 /* !~ doesn't make sense with /r, so error on it for now */
4f4d7508
DC		 2764 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
2765 type == OP_NOT)
2766 yyerror("Using !~ with s///r doesn't make sense");
bb16bae8
FC		 2767 if (rtype == OP_TRANSR && type == OP_NOT)
2768 yyerror("Using !~ with tr///r doesn't make sense");
4f4d7508 2769
2474a784
FC		 2770 ismatchop = (rtype == OP_MATCH ||
2771 rtype == OP_SUBST ||
bb16bae8 2772 rtype == OP_TRANS || rtype == OP_TRANSR)
2474a784 2773 && !(right->op_flags & OPf_SPECIAL);
59f00321
RGS		 2774 if (ismatchop && right->op_private & OPpTARGET_MY) {
2775 right->op_targ = 0;
2776 right->op_private &= ~OPpTARGET_MY;
2777 }
2778 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1496a290
AL		 2779 OP *newleft;
2780
79072805 2781 right->op_flags |= OPf_STACKED;
bb16bae8 2782 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
1496a290 2783 ! (rtype == OP_TRANS &&
4f4d7508
DC		 2784 right->op_private & OPpTRANS_IDENTICAL) &&
2785 ! (rtype == OP_SUBST &&
2786 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
3ad73efd 2787 newleft = op_lvalue(left, rtype);
1496a290
AL		 2788 else
2789 newleft = left;
bb16bae8 2790 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
1496a290 2791 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
79072805 2792 else
2fcb4757 2793 o = op_prepend_elem(rtype, scalar(newleft), right);
79072805 2794 if (type == OP_NOT)
11343788
MB		 2795 return newUNOP(OP_NOT, 0, scalar(o));
2796 return o;
79072805
LW		 2797 }
2798 else
2799 return bind_match(type, left,
d63c20f2 2800 pmruntime(newPMOP(OP_MATCH, 0), right, 0, 0));
79072805
LW		 2801}
2802
2803OP *
864dbfa3 2804Perl_invert(pTHX_ OP *o)
79072805 2805{
11343788 2806 if (!o)
1d866c12 2807 return NULL;
11343788 2808 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
79072805
LW		 2809}
2810
3ad73efd
Z		 2811/*
2812=for apidoc Amx|OP *|op_scope|OP *o
2813
2814Wraps up an op tree with some additional ops so that at runtime a dynamic
2815scope will be created. The original ops run in the new dynamic scope,
2816and then, provided that they exit normally, the scope will be unwound.
2817The additional ops used to create and unwind the dynamic scope will
2818normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
2819instead if the ops are simple enough to not need the full dynamic scope
2820structure.
2821
2822=cut
2823*/
2824
79072805 2825OP *
3ad73efd 2826Perl_op_scope(pTHX_ OP *o)
79072805 2827{
27da23d5 2828 dVAR;
79072805 2829 if (o) {
284167a5 2830 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
2fcb4757 2831 o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
463ee0b2 2832 o->op_type = OP_LEAVE;
22c35a8c 2833 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
463ee0b2 2834 }
fdb22418
HS		 2835 else if (o->op_type == OP_LINESEQ) {
2836 OP *kid;
2837 o->op_type = OP_SCOPE;
2838 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2839 kid = ((LISTOP*)o)->op_first;
59110972 2840 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
fdb22418 2841 op_null(kid);
59110972
RH		 2842
2843 /* The following deals with things like 'do {1 for 1}' */
2844 kid = kid->op_sibling;
2845 if (kid &&
2846 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2847 op_null(kid);
2848 }
463ee0b2 2849 }
fdb22418 2850 else
5f66b61c 2851 o = newLISTOP(OP_SCOPE, 0, o, NULL);
79072805
LW		 2852 }
2853 return o;
2854}
1930840b 2855
705fe0e5
FC		 2856OP *
2857Perl_op_unscope(pTHX_ OP *o)
2858{
2859 if (o && o->op_type == OP_LINESEQ) {
2860 OP *kid = cLISTOPo->op_first;
2861 for(; kid; kid = kid->op_sibling)
2862 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
2863 op_null(kid);
2864 }
2865 return o;
2866}
2867
a0d0e21e 2868int
864dbfa3 2869Perl_block_start(pTHX_ int full)
79072805 2870{
97aff369 2871 dVAR;
73d840c0 2872 const int retval = PL_savestack_ix;
1930840b 2873
dd2155a4 2874 pad_block_start(full);
b3ac6de7 2875 SAVEHINTS();
3280af22 2876 PL_hints &= ~HINT_BLOCK_SCOPE;
68da3b2f 2877 SAVECOMPILEWARNINGS();
72dc9ed5 2878 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
1930840b 2879
a88d97bf 2880 CALL_BLOCK_HOOKS(bhk_start, full);
1930840b 2881
a0d0e21e
LW		 2882 return retval;
2883}
2884
2885OP*
864dbfa3 2886Perl_block_end(pTHX_ I32 floor, OP *seq)
a0d0e21e 2887{
97aff369 2888 dVAR;
6867be6d 2889 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1930840b 2890 OP* retval = scalarseq(seq);
6d5c2147 2891 OP *o;
1930840b 2892
a88d97bf 2893 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
1930840b 2894
e9818f4e 2895 LEAVE_SCOPE(floor);
623e6609 2896 CopHINTS_set(&PL_compiling, PL_hints);
a0d0e21e 2897 if (needblockscope)
3280af22 2898 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
6d5c2147
FC		 2899 o = pad_leavemy();
2900
2901 if (o) {
2902 /* pad_leavemy has created a sequence of introcv ops for all my
2903 subs declared in the block. We have to replicate that list with
2904 clonecv ops, to deal with this situation:
2905
2906 sub {
2907 my sub s1;
2908 my sub s2;
2909 sub s1 { state sub foo { \&s2 } }
2910 }->()
2911
2912 Originally, I was going to have introcv clone the CV and turn
2913 off the stale flag. Since &s1 is declared before &s2, the
2914 introcv op for &s1 is executed (on sub entry) before the one for
2915 &s2. But the &foo sub inside &s1 (which is cloned when &s1 is
2916 cloned, since it is a state sub) closes over &s2 and expects
2917 to see it in its outer CV’s pad. If the introcv op clones &s1,
2918 then &s2 is still marked stale. Since &s1 is not active, and
2919 &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
2920 ble will not stay shared’ warning. Because it is the same stub
2921 that will be used when the introcv op for &s2 is executed, clos-
2922 ing over it is safe. Hence, we have to turn off the stale flag
2923 on all lexical subs in the block before we clone any of them.
2924 Hence, having introcv clone the sub cannot work. So we create a
2925 list of ops like this:
2926
2927 lineseq
2928 |
2929 +-- introcv
2930 |
2931 +-- introcv
2932 |
2933 +-- introcv
2934 |
2935 .
2936 .
2937 .
2938 |
2939 +-- clonecv
2940 |
2941 +-- clonecv
2942 |
2943 +-- clonecv
2944 |
2945 .
2946 .
2947 .
2948 */
2949 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
2950 OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
2951 for (;; kid = kid->op_sibling) {
2952 OP *newkid = newOP(OP_CLONECV, 0);
2953 newkid->op_targ = kid->op_targ;
2954 o = op_append_elem(OP_LINESEQ, o, newkid);
2955 if (kid == last) break;
2956 }
2957 retval = op_prepend_elem(OP_LINESEQ, o, retval);
2958 }
1930840b 2959
a88d97bf 2960 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
1930840b 2961
a0d0e21e
LW		 2962 return retval;
2963}
2964
fd85fad2
BM		 2965/*
2966=head1 Compile-time scope hooks
2967
3e4ddde5 2968=for apidoc Aox||blockhook_register
fd85fad2
BM		 2969
2970Register a set of hooks to be called when the Perl lexical scope changes
2971at compile time. See L<perlguts/"Compile-time scope hooks">.
2972
2973=cut
2974*/
2975
bb6c22e7
BM		 2976void
2977Perl_blockhook_register(pTHX_ BHK *hk)
2978{
2979 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
2980
2981 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
2982}
2983
76e3520e 2984STATIC OP *
cea2e8a9 2985S_newDEFSVOP(pTHX)
54b9620d 2986{
97aff369 2987 dVAR;
cc76b5cc 2988 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
00b1698f 2989 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
59f00321
RGS		 2990 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2991 }
2992 else {
551405c4 2993 OP * const o = newOP(OP_PADSV, 0);
59f00321
RGS		 2994 o->op_targ = offset;
2995 return o;
2996 }
54b9620d
MB		 2997}
2998
a0d0e21e 2999void
864dbfa3 3000Perl_newPROG(pTHX_ OP *o)
a0d0e21e 3001{
97aff369 3002 dVAR;
7918f24d
NC		 3003
3004 PERL_ARGS_ASSERT_NEWPROG;
3005
3280af22 3006 if (PL_in_eval) {
86a64801 3007 PERL_CONTEXT *cx;
63429d50 3008 I32 i;
b295d113
TH		 3009 if (PL_eval_root)
3010 return;
faef0170
HS		 3011 PL_eval_root = newUNOP(OP_LEAVEEVAL,
3012 ((PL_in_eval & EVAL_KEEPERR)
3013 ? OPf_SPECIAL : 0), o);
86a64801
GG		 3014
3015 cx = &cxstack[cxstack_ix];
3016 assert(CxTYPE(cx) == CXt_EVAL);
3017
3018 if ((cx->blk_gimme & G_WANT) == G_VOID)
3019 scalarvoid(PL_eval_root);
3020 else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
3021 list(PL_eval_root);
3022 else
3023 scalar(PL_eval_root);
3024
5983a79d 3025 PL_eval_start = op_linklist(PL_eval_root);
7934575e
GS		 3026 PL_eval_root->op_private |= OPpREFCOUNTED;
3027 OpREFCNT_set(PL_eval_root, 1);
3280af22 3028 PL_eval_root->op_next = 0;
63429d50
FC		 3029 i = PL_savestack_ix;
3030 SAVEFREEOP(o);
3031 ENTER;
a2efc822 3032 CALL_PEEP(PL_eval_start);
86a64801 3033 finalize_optree(PL_eval_root);
63429d50
FC		 3034 LEAVE;
3035 PL_savestack_ix = i;
a0d0e21e
LW		 3036 }
3037 else {
6be89cf9 3038 if (o->op_type == OP_STUB) {
22e660b4
NC		 3039 /* This block is entered if nothing is compiled for the main
3040 program. This will be the case for an genuinely empty main
3041 program, or one which only has BEGIN blocks etc, so already
3042 run and freed.
3043
3044 Historically (5.000) the guard above was !o. However, commit
3045 f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
3046 c71fccf11fde0068, changed perly.y so that newPROG() is now
3047 called with the output of block_end(), which returns a new
3048 OP_STUB for the case of an empty optree. ByteLoader (and
3049 maybe other things) also take this path, because they set up
3050 PL_main_start and PL_main_root directly, without generating an
3051 optree.
8b31d4e4
NC		 3052
3053 If the parsing the main program aborts (due to parse errors,
3054 or due to BEGIN or similar calling exit), then newPROG()
3055 isn't even called, and hence this code path and its cleanups
3056 are skipped. This shouldn't make a make a difference:
3057 * a non-zero return from perl_parse is a failure, and
3058 perl_destruct() should be called immediately.
3059 * however, if exit(0) is called during the parse, then
3060 perl_parse() returns 0, and perl_run() is called. As
3061 PL_main_start will be NULL, perl_run() will return
3062 promptly, and the exit code will remain 0.
22e660b4
NC		 3063 */
3064
6be89cf9
AE		 3065 PL_comppad_name = 0;
3066 PL_compcv = 0;
d2c837a0 3067 S_op_destroy(aTHX_ o);
a0d0e21e 3068 return;
6be89cf9 3069 }
3ad73efd 3070 PL_main_root = op_scope(sawparens(scalarvoid(o)));
3280af22
NIS		 3071 PL_curcop = &PL_compiling;
3072 PL_main_start = LINKLIST(PL_main_root);
7934575e
GS		 3073 PL_main_root->op_private |= OPpREFCOUNTED;
3074 OpREFCNT_set(PL_main_root, 1);
3280af22 3075 PL_main_root->op_next = 0;
a2efc822 3076 CALL_PEEP(PL_main_start);
d164302a 3077 finalize_optree(PL_main_root);
8be227ab 3078 cv_forget_slab(PL_compcv);
3280af22 3079 PL_compcv = 0;
3841441e 3080
4fdae800 3081 /* Register with debugger */
84902520 3082 if (PERLDB_INTER) {
b96d8cd9 3083 CV * const cv = get_cvs("DB::postponed", 0);
3841441e
CS		 3084 if (cv) {
3085 dSP;
924508f0 3086 PUSHMARK(SP);
ad64d0ec 3087 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3841441e 3088 PUTBACK;
ad64d0ec 3089 call_sv(MUTABLE_SV(cv), G_DISCARD);
3841441e
CS		 3090 }
3091 }
79072805 3092 }
79072805
LW		 3093}
3094
3095OP *
864dbfa3 3096Perl_localize(pTHX_ OP *o, I32 lex)
79072805 3097{
97aff369 3098 dVAR;
7918f24d
NC		 3099
3100 PERL_ARGS_ASSERT_LOCALIZE;
3101
79072805 3102 if (o->op_flags & OPf_PARENS)
d2be0de5
YST		 3103/* [perl #17376]: this appears to be premature, and results in code such as
3104 C< our(%x); > executing in list mode rather than void mode */
3105#if 0
79072805 3106 list(o);
d2be0de5 3107#else
6f207bd3 3108 NOOP;
d2be0de5 3109#endif
8990e307 3110 else {
f06b5848
DM		 3111 if ( PL_parser->bufptr > PL_parser->oldbufptr
3112 && PL_parser->bufptr[-1] == ','
041457d9 3113 && ckWARN(WARN_PARENTHESIS))
64420d0d 3114 {
f06b5848 3115 char *s = PL_parser->bufptr;
bac662ee 3116 bool sigil = FALSE;
64420d0d 3117
8473848f 3118 /* some heuristics to detect a potential error */
bac662ee 3119 while (*s && (strchr(", \t\n", *s)))
64420d0d 3120 s++;
8473848f 3121
bac662ee
TS		 3122 while (1) {
3123 if (*s && strchr("@$%*", *s) && *++s
3124 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
3125 s++;
3126 sigil = TRUE;
3127 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
3128 s++;
3129 while (*s && (strchr(", \t\n", *s)))
3130 s++;
3131 }
3132 else
3133 break;
3134 }
3135 if (sigil && (*s == ';' || *s == '=')) {
3136 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
8473848f 3137 "Parentheses missing around \"%s\" list",
12bd6ede
DM		 3138 lex
3139 ? (PL_parser->in_my == KEY_our
3140 ? "our"
3141 : PL_parser->in_my == KEY_state
3142 ? "state"
3143 : "my")
3144 : "local");
8473848f 3145 }
8990e307
LW		 3146 }
3147 }
93a17b20 3148 if (lex)
eb64745e 3149 o = my(o);
93a17b20 3150 else
3ad73efd 3151 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
12bd6ede
DM		 3152 PL_parser->in_my = FALSE;
3153 PL_parser->in_my_stash = NULL;
eb64745e 3154 return o;
79072805
LW		 3155}
3156
3157OP *
864dbfa3 3158Perl_jmaybe(pTHX_ OP *o)
79072805 3159{
7918f24d
NC		 3160 PERL_ARGS_ASSERT_JMAYBE;
3161
79072805 3162 if (o->op_type == OP_LIST) {
fafc274c 3163 OP * const o2
d4c19fe8 3164 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2fcb4757 3165 o = convert(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
79072805
LW		 3166 }
3167 return o;
3168}
3169
985b9e54
GG		 3170PERL_STATIC_INLINE OP *
3171S_op_std_init(pTHX_ OP *o)
3172{
3173 I32 type = o->op_type;
3174
3175 PERL_ARGS_ASSERT_OP_STD_INIT;
3176
3177 if (PL_opargs[type] & OA_RETSCALAR)
3178 scalar(o);
3179 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
3180 o->op_targ = pad_alloc(type, SVs_PADTMP);
3181
3182 return o;
3183}
3184
3185PERL_STATIC_INLINE OP *
3186S_op_integerize(pTHX_ OP *o)
3187{
3188 I32 type = o->op_type;
3189
3190 PERL_ARGS_ASSERT_OP_INTEGERIZE;
3191
077da62f
FC		 3192 /* integerize op. */
3193 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
985b9e54 3194 {
f5f19483 3195 dVAR;
985b9e54
GG		 3196 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
3197 }
3198
3199 if (type == OP_NEGATE)
3200 /* XXX might want a ck_negate() for this */
3201 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
3202
3203 return o;
3204}
3205
1f676739 3206static OP *
5aaab254 3207S_fold_constants(pTHX_ OP *o)
79072805 3208{
27da23d5 3209 dVAR;
eb578fdb 3210 OP * VOL curop;
eb8433b7 3211 OP *newop;
8ea43dc8 3212 VOL I32 type = o->op_type;
e3cbe32f 3213 SV * VOL sv = NULL;
b7f7fd0b
NC		 3214 int ret = 0;
3215 I32 oldscope;
3216 OP *old_next;
5f2d9966
DM		 3217 SV * const oldwarnhook = PL_warnhook;
3218 SV * const olddiehook = PL_diehook;
c427f4d2 3219 COP not_compiling;
b7f7fd0b 3220 dJMPENV;
79072805 3221
7918f24d
NC		 3222 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
3223
22c35a8c 3224 if (!(PL_opargs[type] & OA_FOLDCONST))
79072805
LW		 3225 goto nope;
3226
de939608 3227 switch (type) {
de939608
CS		 3228 case OP_UCFIRST:
3229 case OP_LCFIRST:
3230 case OP_UC:
3231 case OP_LC:
69dcf70c
MB		 3232 case OP_SLT:
3233 case OP_SGT:
3234 case OP_SLE:
3235 case OP_SGE:
3236 case OP_SCMP:
b3fd6149 3237 case OP_SPRINTF:
2de3dbcc 3238 /* XXX what about the numeric ops? */
82ad65bb 3239 if (IN_LOCALE_COMPILETIME)
de939608 3240 goto nope;
553e7bb0 3241 break;
dd9a6ccf
FC		 3242 case OP_PACK:
3243 if (!cLISTOPo->op_first->op_sibling
3244 || cLISTOPo->op_first->op_sibling->op_type != OP_CONST)
3245 goto nope;
3246 {
3247 SV * const sv = cSVOPx_sv(cLISTOPo->op_first->op_sibling);
3248 if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
3249 {
3250 const char *s = SvPVX_const(sv);
3251 while (s < SvEND(sv)) {
3252 if (*s == 'p' || *s == 'P') goto nope;
3253 s++;
3254 }
3255 }
3256 }
3257 break;
baed7faa
FC		 3258 case OP_REPEAT:
3259 if (o->op_private & OPpREPEAT_DOLIST) goto nope;
de939608
CS		 3260 }
3261
13765c85 3262 if (PL_parser && PL_parser->error_count)
a0d0e21e
LW		 3263 goto nope; /* Don't try to run w/ errors */
3264
79072805 3265 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
1496a290
AL		 3266 const OPCODE type = curop->op_type;
3267 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
3268 type != OP_LIST &&
3269 type != OP_SCALAR &&
3270 type != OP_NULL &&
3271 type != OP_PUSHMARK)
7a52d87a 3272 {
79072805
LW		 3273 goto nope;
3274 }
3275 }
3276
3277 curop = LINKLIST(o);
b7f7fd0b 3278 old_next = o->op_next;
79072805 3279 o->op_next = 0;
533c011a 3280 PL_op = curop;
b7f7fd0b
NC		 3281
3282 oldscope = PL_scopestack_ix;
edb2152a 3283 create_eval_scope(G_FAKINGEVAL);
b7f7fd0b 3284
c427f4d2
NC		 3285 /* Verify that we don't need to save it: */
3286 assert(PL_curcop == &PL_compiling);
3287 StructCopy(&PL_compiling, &not_compiling, COP);
3288 PL_curcop = &not_compiling;
3289 /* The above ensures that we run with all the correct hints of the
3290 currently compiling COP, but that IN_PERL_RUNTIME is not true. */
3291 assert(IN_PERL_RUNTIME);
5f2d9966
DM		 3292 PL_warnhook = PERL_WARNHOOK_FATAL;
3293 PL_diehook = NULL;
b7f7fd0b
NC		 3294 JMPENV_PUSH(ret);
3295
3296 switch (ret) {
3297 case 0:
3298 CALLRUNOPS(aTHX);
3299 sv = *(PL_stack_sp--);
523a0f0c
NC		 3300 if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
3301#ifdef PERL_MAD
3302 /* Can't simply swipe the SV from the pad, because that relies on
3303 the op being freed "real soon now". Under MAD, this doesn't
3304 happen (see the #ifdef below). */
3305 sv = newSVsv(sv);
3306#else
b7f7fd0b 3307 pad_swipe(o->op_targ, FALSE);
523a0f0c
NC		 3308#endif
3309 }
b7f7fd0b
NC		 3310 else if (SvTEMP(sv)) { /* grab mortal temp? */
3311 SvREFCNT_inc_simple_void(sv);
3312 SvTEMP_off(sv);
3313 }
3314 break;
3315 case 3:
3316 /* Something tried to die. Abandon constant folding. */
3317 /* Pretend the error never happened. */
ab69dbc2 3318 CLEAR_ERRSV();
b7f7fd0b
NC		 3319 o->op_next = old_next;
3320 break;
3321 default:
3322 JMPENV_POP;
5f2d9966
DM		 3323 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
3324 PL_warnhook = oldwarnhook;
3325 PL_diehook = olddiehook;
3326 /* XXX note that this croak may fail as we've already blown away
3327 * the stack - eg any nested evals */
b7f7fd0b
NC		 3328 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
3329 }
b7f7fd0b 3330 JMPENV_POP;
5f2d9966
DM		 3331 PL_warnhook = oldwarnhook;
3332 PL_diehook = olddiehook;
c427f4d2 3333 PL_curcop = &PL_compiling;
edb2152a
NC		 3334
3335 if (PL_scopestack_ix > oldscope)
3336 delete_eval_scope();
eb8433b7 3337
b7f7fd0b
NC		 3338 if (ret)
3339 goto nope;
3340
eb8433b7 3341#ifndef PERL_MAD
79072805 3342 op_free(o);
eb8433b7 3343#endif
de5e01c2 3344 assert(sv);
79072805 3345 if (type == OP_RV2GV)
159b6efe 3346 newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
eb8433b7 3347 else
cc2ebcd7 3348 newop = newSVOP(OP_CONST, OPpCONST_FOLDED<<8, MUTABLE_SV(sv));
eb8433b7
NC		 3349 op_getmad(o,newop,'f');
3350 return newop;
aeea060c 3351
b7f7fd0b 3352 nope:
79072805
LW		 3353 return o;
3354}
3355
1f676739 3356static OP *
5aaab254 3357S_gen_constant_list(pTHX_ OP *o)
79072805 3358{
27da23d5 3359 dVAR;
eb578fdb 3360 OP *curop;
6867be6d 3361 const I32 oldtmps_floor = PL_tmps_floor;
79072805 3362
a0d0e21e 3363 list(o);
13765c85 3364 if (PL_parser && PL_parser->error_count)
a0d0e21e
LW		 3365 return o; /* Don't attempt to run with errors */
3366
533c011a 3367 PL_op = curop = LINKLIST(o);
a0d0e21e 3368 o->op_next = 0;
a2efc822 3369 CALL_PEEP(curop);
897d3989 3370 Perl_pp_pushmark(aTHX);
cea2e8a9 3371 CALLRUNOPS(aTHX);
533c011a 3372 PL_op = curop;
78c72037
NC		 3373 assert (!(curop->op_flags & OPf_SPECIAL));
3374 assert(curop->op_type == OP_RANGE);
897d3989 3375 Perl_pp_anonlist(aTHX);
3280af22 3376 PL_tmps_floor = oldtmps_floor;
79072805
LW		 3377
3378 o->op_type = OP_RV2AV;
22c35a8c 3379 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
fb53bbb2
SG		 3380 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
3381 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
1a0a2ba9 3382 o->op_opt = 0; /* needs to be revisited in rpeep() */
79072805 3383 curop = ((UNOP*)o)->op_first;
b37c2d43 3384 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
eb8433b7
NC		 3385#ifdef PERL_MAD
3386 op_getmad(curop,o,'O');
3387#else
79072805 3388 op_free(curop);
eb8433b7 3389#endif
5983a79d 3390 LINKLIST(o);
79072805
LW		 3391 return list(o);
3392}
3393
3394OP *
864dbfa3 3395Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
79072805 3396{
27da23d5 3397 dVAR;
d67594ff 3398 if (type < 0) type = -type, flags |= OPf_SPECIAL;
11343788 3399 if (!o || o->op_type != OP_LIST)
5f66b61c 3400 o = newLISTOP(OP_LIST, 0, o, NULL);
748a9306 3401 else
5dc0d613 3402 o->op_flags &= ~OPf_WANT;
79072805 3403
22c35a8c 3404 if (!(PL_opargs[type] & OA_MARK))
93c66552 3405 op_null(cLISTOPo->op_first);
bf0571fd
FC		 3406 else {
3407 OP * const kid2 = cLISTOPo->op_first->op_sibling;
3408 if (kid2 && kid2->op_type == OP_COREARGS) {
3409 op_null(cLISTOPo->op_first);
3410 kid2->op_private |= OPpCOREARGS_PUSHMARK;
3411 }
3412 }
8990e307 3413
eb160463 3414 o->op_type = (OPCODE)type;
22c35a8c 3415 o->op_ppaddr = PL_ppaddr[type];
11343788 3416 o->op_flags |= flags;
79072805 3417
11343788 3418 o = CHECKOP(type, o);
fe2774ed 3419 if (o->op_type != (unsigned)type)
11343788 3420 return o;
79072805 3421
985b9e54 3422 return fold_constants(op_integerize(op_std_init(o)));
79072805
LW		 3423}
3424
2fcb4757
Z		 3425/*
3426=head1 Optree Manipulation Functions
3427*/
3428
79072805
LW		 3429/* List constructors */
3430
2fcb4757
Z		 3431/*
3432=for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
3433
3434Append an item to the list of ops contained directly within a list-type
3435op, returning the lengthened list. I<first> is the list-type op,
3436and I<last> is the op to append to the list. I<optype> specifies the
3437intended opcode for the list. If I<first> is not already a list of the
3438right type, it will be upgraded into one. If either I<first> or I<last>
3439is null, the other is returned unchanged.
3440
3441=cut
3442*/
3443
79072805 3444OP *
2fcb4757 3445Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW		 3446{
3447 if (!first)
3448 return last;
8990e307
LW		 3449
3450 if (!last)
79072805 3451 return first;
8990e307 3452
fe2774ed 3453 if (first->op_type != (unsigned)type
155aba94
GS		 3454 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
3455 {
3456 return newLISTOP(type, 0, first, last);
3457 }
79072805 3458
a0d0e21e
LW		 3459 if (first->op_flags & OPf_KIDS)
3460 ((LISTOP*)first)->op_last->op_sibling = last;
3461 else {
3462 first->op_flags |= OPf_KIDS;
3463 ((LISTOP*)first)->op_first = last;
3464 }
3465 ((LISTOP*)first)->op_last = last;
a0d0e21e 3466 return first;
79072805
LW		 3467}
3468
2fcb4757
Z		 3469/*
3470=for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
3471
3472Concatenate the lists of ops contained directly within two list-type ops,
3473returning the combined list. I<first> and I<last> are the list-type ops
3474to concatenate. I<optype> specifies the intended opcode for the list.
3475If either I<first> or I<last> is not already a list of the right type,
3476it will be upgraded into one. If either I<first> or I<last> is null,
3477the other is returned unchanged.
3478
3479=cut
3480*/
3481
79072805 3482OP *
2fcb4757 3483Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
79072805
LW		 3484{
3485 if (!first)
2fcb4757 3486 return last;
8990e307
LW		 3487
3488 if (!last)
2fcb4757 3489 return first;
8990e307 3490
fe2774ed 3491 if (first->op_type != (unsigned)type)
2fcb4757 3492 return op_prepend_elem(type, first, last);
8990e307 3493
fe2774ed 3494 if (last->op_type != (unsigned)type)
2fcb4757 3495 return op_append_elem(type, first, last);
79072805 3496
2fcb4757
Z		 3497 ((LISTOP*)first)->op_last->op_sibling = ((LISTOP*)last)->op_first;
3498 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
117dada2 3499 first->op_flags |= (last->op_flags & OPf_KIDS);
1c846c1f 3500
eb8433b7 3501#ifdef PERL_MAD
2fcb4757
Z		 3502 if (((LISTOP*)last)->op_first && first->op_madprop) {
3503 MADPROP *mp = ((LISTOP*)last)->op_first->op_madprop;
eb8433b7
NC		 3504 if (mp) {
3505 while (mp->mad_next)
3506 mp = mp->mad_next;
3507 mp->mad_next = first->op_madprop;
3508 }
3509 else {
2fcb4757 3510 ((LISTOP*)last)->op_first->op_madprop = first->op_madprop;
eb8433b7
NC		 3511 }
3512 }
3513 first->op_madprop = last->op_madprop;
3514 last->op_madprop = 0;
3515#endif
3516
2fcb4757 3517 S_op_destroy(aTHX_ last);
238a4c30 3518
2fcb4757 3519 return first;
79072805
LW		 3520}
3521
2fcb4757
Z		 3522/*
3523=for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
3524
3525Prepend an item to the list of ops contained directly within a list-type
3526op, returning the lengthened list. I<first> is the op to prepend to the
3527list, and I<last> is the list-type op. I<optype> specifies the intended
3528opcode for the list. If I<last> is not already a list of the right type,
3529it will be upgraded into one. If either I<first> or I<last> is null,
3530the other is returned unchanged.
3531
3532=cut
3533*/
3534
79072805 3535OP *
2fcb4757 3536Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW		 3537{
3538 if (!first)
3539 return last;
8990e307
LW		 3540
3541 if (!last)
79072805 3542 return first;
8990e307 3543
fe2774ed 3544 if (last->op_type == (unsigned)type) {
8990e307
LW		 3545 if (type == OP_LIST) { /* already a PUSHMARK there */
3546 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
3547 ((LISTOP*)last)->op_first->op_sibling = first;
36a5d4ba
DC		 3548 if (!(first->op_flags & OPf_PARENS))
3549 last->op_flags &= ~OPf_PARENS;
8990e307
LW		 3550 }
3551 else {
3552 if (!(last->op_flags & OPf_KIDS)) {
3553 ((LISTOP*)last)->op_last = first;
3554 last->op_flags |= OPf_KIDS;
3555 }
3556 first->op_sibling = ((LISTOP*)last)->op_first;
3557 ((LISTOP*)last)->op_first = first;
79072805 3558 }
117dada2 3559 last->op_flags |= OPf_KIDS;
79072805
LW		 3560 return last;
3561 }
3562
3563 return newLISTOP(type, 0, first, last);
3564}
3565
3566/* Constructors */
3567
eb8433b7
NC		 3568#ifdef PERL_MAD
3569
3570TOKEN *
3571Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
3572{
3573 TOKEN *tk;
99129197 3574 Newxz(tk, 1, TOKEN);
eb8433b7
NC		 3575 tk->tk_type = (OPCODE)optype;
3576 tk->tk_type = 12345;
3577 tk->tk_lval = lval;
3578 tk->tk_mad = madprop;
3579 return tk;
3580}
3581
3582void
3583Perl_token_free(pTHX_ TOKEN* tk)
3584{
7918f24d
NC		 3585 PERL_ARGS_ASSERT_TOKEN_FREE;
3586
eb8433b7
NC		 3587 if (tk->tk_type != 12345)
3588 return;
3589 mad_free(tk->tk_mad);
3590 Safefree(tk);
3591}
3592
3593void
3594Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
3595{
3596 MADPROP* mp;
3597 MADPROP* tm;
7918f24d
NC		 3598
3599 PERL_ARGS_ASSERT_TOKEN_GETMAD;
3600
eb8433b7
NC		 3601 if (tk->tk_type != 12345) {
3602 Perl_warner(aTHX_ packWARN(WARN_MISC),
3603 "Invalid TOKEN object ignored");
3604 return;
3605 }
3606 tm = tk->tk_mad;
3607 if (!tm)
3608 return;
3609
3610 /* faked up qw list? */
3611 if (slot == '(' &&
3612 tm->mad_type == MAD_SV &&
d503a9ba 3613 SvPVX((SV *)tm->mad_val)[0] == 'q')
eb8433b7
NC		 3614 slot = 'x';
3615
3616 if (o) {
3617 mp = o->op_madprop;
3618 if (mp) {
3619 for (;;) {
3620 /* pretend constant fold didn't happen? */
3621 if (mp->mad_key == 'f' &&
3622 (o->op_type == OP_CONST ||
3623 o->op_type == OP_GV) )
3624 {
3625 token_getmad(tk,(OP*)mp->mad_val,slot);
3626 return;
3627 }
3628 if (!mp->mad_next)
3629 break;
3630 mp = mp->mad_next;
3631 }
3632 mp->mad_next = tm;
3633 mp = mp->mad_next;
3634 }
3635 else {
3636 o->op_madprop = tm;
3637 mp = o->op_madprop;
3638 }
3639 if (mp->mad_key == 'X')
3640 mp->mad_key = slot; /* just change the first one */
3641
3642 tk->tk_mad = 0;
3643 }
3644 else
3645 mad_free(tm);
3646 Safefree(tk);
3647}
3648
3649void
3650Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
3651{
3652 MADPROP* mp;
3653 if (!from)
3654 return;
3655 if (o) {
3656 mp = o->op_madprop;
3657 if (mp) {
3658 for (;;) {
3659 /* pretend constant fold didn't happen? */
3660 if (mp->mad_key == 'f' &&
3661 (o->op_type == OP_CONST ||
3662 o->op_type == OP_GV) )
3663 {
3664 op_getmad(from,(OP*)mp->mad_val,slot);
3665 return;
3666 }
3667 if (!mp->mad_next)
3668 break;
3669 mp = mp->mad_next;
3670 }
3671 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
3672 }
3673 else {
3674 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
3675 }
3676 }
3677}
3678
3679void
3680Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
3681{
3682 MADPROP* mp;
3683 if (!from)
3684 return;
3685 if (o) {
3686 mp = o->op_madprop;
3687 if (mp) {
3688 for (;;) {
3689 /* pretend constant fold didn't happen? */
3690 if (mp->mad_key == 'f' &&
3691 (o->op_type == OP_CONST ||
3692 o->op_type == OP_GV) )
3693 {
3694 op_getmad(from,(OP*)mp->mad_val,slot);
3695 return;
3696 }
3697 if (!mp->mad_next)
3698 break;
3699 mp = mp->mad_next;
3700 }
3701 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
3702 }
3703 else {
3704 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
3705 }
3706 }
3707 else {
99129197
NC		 3708 PerlIO_printf(PerlIO_stderr(),
3709 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
eb8433b7
NC		 3710 op_free(from);
3711 }
3712}
3713
3714void
3715Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
3716{
3717 MADPROP* tm;
3718 if (!mp || !o)
3719 return;
3720 if (slot)
3721 mp->mad_key = slot;
3722 tm = o->op_madprop;
3723 o->op_madprop = mp;
3724 for (;;) {
3725 if (!mp->mad_next)
3726 break;
3727 mp = mp->mad_next;
3728 }
3729 mp->mad_next = tm;
3730}
3731
3732void
3733Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
3734{
3735 if (!o)
3736 return;
3737 addmad(tm, &(o->op_madprop), slot);
3738}
3739
3740void
3741Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
3742{
3743 MADPROP* mp;
3744 if (!tm || !root)
3745 return;
3746 if (slot)
3747 tm->mad_key = slot;
3748 mp = *root;
3749 if (!mp) {
3750 *root = tm;
3751 return;
3752 }
3753 for (;;) {
3754 if (!mp->mad_next)
3755 break;
3756 mp = mp->mad_next;
3757 }
3758 mp->mad_next = tm;
3759}
3760
3761MADPROP *
3762Perl_newMADsv(pTHX_ char key, SV* sv)
3763{
7918f24d
NC		 3764 PERL_ARGS_ASSERT_NEWMADSV;
3765
eb8433b7
NC		 3766 return newMADPROP(key, MAD_SV, sv, 0);
3767}
3768
3769MADPROP *
d503a9ba 3770Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
eb8433b7 3771{
c111d5f1 3772 MADPROP *const mp = (MADPROP *) PerlMemShared_malloc(sizeof(MADPROP));
eb8433b7
NC		 3773 mp->mad_next = 0;
3774 mp->mad_key = key;
3775 mp->mad_vlen = vlen;
3776 mp->mad_type = type;
3777 mp->mad_val = val;
3778/* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
3779 return mp;
3780}
3781
3782void
3783Perl_mad_free(pTHX_ MADPROP* mp)
3784{
3785/* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
3786 if (!mp)
3787 return;
3788 if (mp->mad_next)
3789 mad_free(mp->mad_next);
bc177e6b 3790/* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
eb8433b7
NC		 3791 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
3792 switch (mp->mad_type) {
3793 case MAD_NULL:
3794 break;
3795 case MAD_PV:
04d1a275 3796 Safefree(mp->mad_val);
eb8433b7
NC		 3797 break;
3798 case MAD_OP:
3799 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
3800 op_free((OP*)mp->mad_val);
3801 break;
3802 case MAD_SV:
ad64d0ec 3803 sv_free(MUTABLE_SV(mp->mad_val));
eb8433b7
NC		 3804 break;
3805 default:
3806 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
3807 break;
3808 }
c111d5f1 3809 PerlMemShared_free(mp);
eb8433b7
NC		 3810}
3811
3812#endif
3813
d67eb5f4
Z		 3814/*
3815=head1 Optree construction
3816
3817=for apidoc Am|OP *|newNULLLIST
3818
3819Constructs, checks, and returns a new C<stub> op, which represents an
3820empty list expression.
3821
3822=cut
3823*/
3824
79072805 3825OP *
864dbfa3 3826Perl_newNULLLIST(pTHX)
79072805 3827{
8990e307
LW		 3828 return newOP(OP_STUB, 0);
3829}
3830
1f676739 3831static OP *
b7783a12 3832S_force_list(pTHX_ OP *o)
8990e307 3833{
11343788 3834 if (!o || o->op_type != OP_LIST)
5f66b61c 3835 o = newLISTOP(OP_LIST, 0, o, NULL);
93c66552 3836 op_null(o);
11343788 3837 return o;
79072805
LW		 3838}
3839
d67eb5f4
Z		 3840/*
3841=for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
3842
3843Constructs, checks, and returns an op of any list type. I<type> is
3844the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3845C<OPf_KIDS> will be set automatically if required. I<first> and I<last>
3846supply up to two ops to be direct children of the list op; they are
3847consumed by this function and become part of the constructed op tree.
3848
3849=cut
3850*/
3851
79072805 3852OP *
864dbfa3 3853Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
79072805 3854{
27da23d5 3855 dVAR;
79072805
LW		 3856 LISTOP *listop;
3857
e69777c1
GG		 3858 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
3859
b7dc083c 3860 NewOp(1101, listop, 1, LISTOP);
79072805 3861
eb160463 3862 listop->op_type = (OPCODE)type;
22c35a8c 3863 listop->op_ppaddr = PL_ppaddr[type];
117dada2
SM		 3864 if (first || last)
3865 flags |= OPf_KIDS;
eb160463 3866 listop->op_flags = (U8)flags;
79072805
LW		 3867
3868 if (!last && first)
3869 last = first;
3870 else if (!first && last)
3871 first = last;
8990e307
LW		 3872 else if (first)
3873 first->op_sibling = last;
79072805
LW		 3874 listop->op_first = first;
3875 listop->op_last = last;
8990e307 3876 if (type == OP_LIST) {
551405c4 3877 OP* const pushop = newOP(OP_PUSHMARK, 0);
8990e307
LW		 3878 pushop->op_sibling = first;
3879 listop->op_first = pushop;
3880 listop->op_flags |= OPf_KIDS;
3881 if (!last)
3882 listop->op_last = pushop;
3883 }
79072805 3884
463d09e6 3885 return CHECKOP(type, listop);
79072805
LW		 3886}
3887
d67eb5f4
Z		 3888/*
3889=for apidoc Am|OP *|newOP|I32 type|I32 flags
3890
3891Constructs, checks, and returns an op of any base type (any type that
3892has no extra fields). I<type> is the opcode. I<flags> gives the
3893eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
3894of C<op_private>.
3895
3896=cut
3897*/
3898
79072805 3899OP *
864dbfa3 3900Perl_newOP(pTHX_ I32 type, I32 flags)
79072805 3901{
27da23d5 3902 dVAR;
11343788 3903 OP *o;
e69777c1 3904
7d789282
FC		 3905 if (type == -OP_ENTEREVAL) {
3906 type = OP_ENTEREVAL;
3907 flags |= OPpEVAL_BYTES<<8;
3908 }
3909
e69777c1
GG		 3910 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
3911 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3912 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3913 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
3914
b7dc083c 3915 NewOp(1101, o, 1, OP);
eb160463 3916 o->op_type = (OPCODE)type;
22c35a8c 3917 o->op_ppaddr = PL_ppaddr[type];
eb160463 3918 o->op_flags = (U8)flags;
79072805 3919
11343788 3920 o->op_next = o;
eb160463 3921 o->op_private = (U8)(0 | (flags >> 8));
22c35a8c 3922 if (PL_opargs[type] & OA_RETSCALAR)
11343788 3923 scalar(o);
22c35a8c 3924 if (PL_opargs[type] & OA_TARGET)
11343788
MB		 3925 o->op_targ = pad_alloc(type, SVs_PADTMP);
3926 return CHECKOP(type, o);
79072805
LW		 3927}
3928
d67eb5f4
Z		 3929/*
3930=for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
3931
3932Constructs, checks, and returns an op of any unary type. I<type> is
3933the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3934C<OPf_KIDS> will be set automatically if required, and, shifted up eight
3935bits, the eight bits of C<op_private>, except that the bit with value 1
3936is automatically set. I<first> supplies an optional op to be the direct
3937child of the unary op; it is consumed by this function and become part
3938of the constructed op tree.
3939
3940=cut
3941*/
3942
79072805 3943OP *
864dbfa3 3944Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
79072805 3945{
27da23d5 3946 dVAR;
79072805
LW		 3947 UNOP *unop;
3948
7d789282
FC		 3949 if (type == -OP_ENTEREVAL) {
3950 type = OP_ENTEREVAL;
3951 flags |= OPpEVAL_BYTES<<8;
3952 }
3953
e69777c1
GG		 3954 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
3955 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3956 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3957 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
3958 || type == OP_SASSIGN
32e2a35d 3959 || type == OP_ENTERTRY
e69777c1
GG		 3960 || type == OP_NULL );
3961
93a17b20 3962 if (!first)
aeea060c 3963 first = newOP(OP_STUB, 0);
22c35a8c 3964 if (PL_opargs[type] & OA_MARK)
8990e307 3965 first = force_list(first);
93a17b20 3966
b7dc083c 3967 NewOp(1101, unop, 1, UNOP);
eb160463 3968 unop->op_type = (OPCODE)type;
22c35a8c 3969 unop->op_ppaddr = PL_ppaddr[type];
79072805 3970 unop->op_first = first;
585ec06d 3971 unop->op_flags = (U8)(flags | OPf_KIDS);
eb160463 3972 unop->op_private = (U8)(1 | (flags >> 8));
e50aee73 3973 unop = (UNOP*) CHECKOP(type, unop);
79072805
LW		 3974 if (unop->op_next)
3975 return (OP*)unop;
3976
985b9e54 3977 return fold_constants(op_integerize(op_std_init((OP *) unop)));
79072805
LW		 3978}
3979
d67eb5f4
Z		 3980/*
3981=for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
3982
3983Constructs, checks, and returns an op of any binary type. I<type>
3984is the opcode. I<flags> gives the eight bits of C<op_flags>, except
3985that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
3986the eight bits of C<op_private>, except that the bit with value 1 or
39872 is automatically set as required. I<first> and I<last> supply up to
3988two ops to be the direct children of the binary op; they are consumed
3989by this function and become part of the constructed op tree.
3990
3991=cut
3992*/
3993
79072805 3994OP *
864dbfa3 3995Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
79072805 3996{
27da23d5 3997 dVAR;
79072805 3998 BINOP *binop;
e69777c1
GG		 3999
4000 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
4001 || type == OP_SASSIGN || type == OP_NULL );
4002
b7dc083c 4003 NewOp(1101, binop, 1, BINOP);
79072805
LW		 4004
4005 if (!first)
4006 first = newOP(OP_NULL, 0);
4007
eb160463 4008 binop->op_type = (OPCODE)type;
22c35a8c 4009 binop->op_ppaddr = PL_ppaddr[type];
79072805 4010 binop->op_first = first;
585ec06d 4011 binop->op_flags = (U8)(flags | OPf_KIDS);
79072805
LW		 4012 if (!last) {
4013 last = first;
eb160463 4014 binop->op_private = (U8)(1 | (flags >> 8));
79072805
LW		 4015 }
4016 else {
eb160463 4017 binop->op_private = (U8)(2 | (flags >> 8));
79072805
LW		 4018 first->op_sibling = last;
4019 }
4020
e50aee73 4021 binop = (BINOP*)CHECKOP(type, binop);
eb160463 4022 if (binop->op_next || binop->op_type != (OPCODE)type)
79072805
LW		 4023 return (OP*)binop;
4024
7284ab6f 4025 binop->op_last = binop->op_first->op_sibling;
79072805 4026
985b9e54 4027 return fold_constants(op_integerize(op_std_init((OP *)binop)));
79072805
LW		 4028}
4029
5f66b61c
AL		 4030static int uvcompare(const void *a, const void *b)
4031 __attribute__nonnull__(1)
4032 __attribute__nonnull__(2)
4033 __attribute__pure__;
abb2c242 4034static int uvcompare(const void *a, const void *b)
2b9d42f0 4035{
e1ec3a88 4036 if (*((const UV *)a) < (*(const UV *)b))
2b9d42f0 4037 return -1;
e1ec3a88 4038 if (*((const UV *)a) > (*(const UV *)b))
2b9d42f0 4039 return 1;
e1ec3a88 4040 if (*((const UV *)a+1) < (*(const UV *)b+1))
2b9d42f0 4041 return -1;
e1ec3a88 4042 if (*((const UV *)a+1) > (*(const UV *)b+1))
2b9d42f0 4043 return 1;
a0ed51b3
LW		 4044 return 0;
4045}
4046
0d86688d
NC		 4047static OP *
4048S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
79072805 4049{
97aff369 4050 dVAR;
2d03de9c 4051 SV * const tstr = ((SVOP*)expr)->op_sv;
fbbb0949
DM		 4052 SV * const rstr =
4053#ifdef PERL_MAD
4054 (repl->op_type == OP_NULL)
4055 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
4056#endif
4057 ((SVOP*)repl)->op_sv;
463ee0b2
LW		 4058 STRLEN tlen;
4059 STRLEN rlen;
5c144d81
NC		 4060 const U8 *t = (U8*)SvPV_const(tstr, tlen);
4061 const U8 *r = (U8*)SvPV_const(rstr, rlen);
eb578fdb
KW		 4062 I32 i;
4063 I32 j;
9b877dbb 4064 I32 grows = 0;
eb578fdb 4065 short *tbl;
79072805 4066
551405c4
AL		 4067 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
4068 const I32 squash = o->op_private & OPpTRANS_SQUASH;
4069 I32 del = o->op_private & OPpTRANS_DELETE;
043e41b8 4070 SV* swash;
7918f24d
NC		 4071
4072 PERL_ARGS_ASSERT_PMTRANS;
4073
800b4dc4 4074 PL_hints |= HINT_BLOCK_SCOPE;
1c846c1f 4075
036b4402
GS		 4076 if (SvUTF8(tstr))
4077 o->op_private |= OPpTRANS_FROM_UTF;
1c846c1f
NIS		 4078
4079 if (SvUTF8(rstr))
036b4402 4080 o->op_private |= OPpTRANS_TO_UTF;
79072805 4081
a0ed51b3 4082 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
396482e1 4083 SV* const listsv = newSVpvs("# comment\n");
c445ea15 4084 SV* transv = NULL;
5c144d81
NC		 4085 const U8* tend = t + tlen;
4086 const U8* rend = r + rlen;
ba210ebe 4087 STRLEN ulen;
84c133a0
RB		 4088 UV tfirst = 1;
4089 UV tlast = 0;
4090 IV tdiff;
4091 UV rfirst = 1;
4092 UV rlast = 0;
4093 IV rdiff;
4094 IV diff;
a0ed51b3
LW		 4095 I32 none = 0;
4096 U32 max = 0;
4097 I32 bits;
a0ed51b3 4098 I32 havefinal = 0;
9c5ffd7c 4099 U32 final = 0;
551405c4
AL		 4100 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
4101 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
bf4a1e57
JH		 4102 U8* tsave = NULL;
4103 U8* rsave = NULL;
9f7f3913 4104 const U32 flags = UTF8_ALLOW_DEFAULT;
bf4a1e57
JH		 4105
4106 if (!from_utf) {
4107 STRLEN len = tlen;
5c144d81 4108 t = tsave = bytes_to_utf8(t, &len);
bf4a1e57
JH		 4109 tend = t + len;
4110 }
4111 if (!to_utf && rlen) {
4112 STRLEN len = rlen;
5c144d81 4113 r = rsave = bytes_to_utf8(r, &len);
bf4a1e57
JH		 4114 rend = r + len;
4115 }
a0ed51b3 4116
2b9d42f0
NIS		 4117/* There are several snags with this code on EBCDIC:
4118 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
4119 2. scan_const() in toke.c has encoded chars in native encoding which makes
4120 ranges at least in EBCDIC 0..255 range the bottom odd.
4121*/
4122
a0ed51b3 4123 if (complement) {
89ebb4a3 4124 U8 tmpbuf[UTF8_MAXBYTES+1];
2b9d42f0 4125 UV *cp;
a0ed51b3 4126 UV nextmin = 0;
a02a5408 4127 Newx(cp, 2*tlen, UV);
a0ed51b3 4128 i = 0;
396482e1 4129 transv = newSVpvs("");
a0ed51b3 4130 while (t < tend) {
9f7f3913 4131 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
2b9d42f0
NIS		 4132 t += ulen;
4133 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
a0ed51b3 4134 t++;
9f7f3913 4135 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
2b9d42f0 4136 t += ulen;
a0ed51b3 4137 }
2b9d42f0
NIS		 4138 else {
4139 cp[2*i+1] = cp[2*i];
4140 }
4141 i++;
a0ed51b3 4142 }
2b9d42f0 4143 qsort(cp, i, 2*sizeof(UV), uvcompare);
a0ed51b3 4144 for (j = 0; j < i; j++) {
2b9d42f0 4145 UV val = cp[2*j];
a0ed51b3
LW		 4146 diff = val - nextmin;
4147 if (diff > 0) {
9041c2e3 4148 t = uvuni_to_utf8(tmpbuf,nextmin);
dfe13c55 4149 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
a0ed51b3 4150 if (diff > 1) {
2b9d42f0 4151 U8 range_mark = UTF_TO_NATIVE(0xff);
9041c2e3 4152 t = uvuni_to_utf8(tmpbuf, val - 1);
2b9d42f0 4153 sv_catpvn(transv, (char *)&range_mark, 1);
dfe13c55 4154 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
a0ed51b3
LW		 4155 }
4156 }
2b9d42f0 4157 val = cp[2*j+1];
a0ed51b3
LW		 4158 if (val >= nextmin)
4159 nextmin = val + 1;
4160 }
9041c2e3 4161 t = uvuni_to_utf8(tmpbuf,nextmin);
dfe13c55 4162 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2b9d42f0
NIS		 4163 {
4164 U8 range_mark = UTF_TO_NATIVE(0xff);
4165 sv_catpvn(transv, (char *)&range_mark, 1);
4166 }
6247ead0 4167 t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
dfe13c55 4168 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
93524f2b 4169 t = (const U8*)SvPVX_const(transv);
a0ed51b3
LW		 4170 tlen = SvCUR(transv);
4171 tend = t + tlen;
455d824a 4172 Safefree(cp);
a0ed51b3
LW		 4173 }
4174 else if (!rlen && !del) {
4175 r = t; rlen = tlen; rend = tend;
4757a243
LW		 4176 }
4177 if (!squash) {
05d340b8 4178 if ((!rlen && !del) || t == r ||
12ae5dfc 4179 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
01ec43d0 4180 {
4757a243 4181 o->op_private |= OPpTRANS_IDENTICAL;
01ec43d0 4182 }
a0ed51b3
LW		 4183 }
4184
4185 while (t < tend || tfirst <= tlast) {
4186 /* see if we need more "t" chars */
4187 if (tfirst > tlast) {
9f7f3913 4188 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
a0ed51b3 4189 t += ulen;
2b9d42f0 4190 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
ba210ebe 4191 t++;
9f7f3913 4192 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
a0ed51b3
LW		 4193 t += ulen;
4194 }
4195 else
4196 tlast = tfirst;
4197 }
4198
4199 /* now see if we need more "r" chars */
4200 if (rfirst > rlast) {
4201 if (r < rend) {
9f7f3913 4202 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
a0ed51b3 4203 r += ulen;
2b9d42f0 4204 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
ba210ebe 4205 r++;
9f7f3913 4206 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
a0ed51b3
LW		 4207 r += ulen;
4208 }
4209 else
4210 rlast = rfirst;
4211 }
4212 else {
4213 if (!havefinal++)
4214 final = rlast;
4215 rfirst = rlast = 0xffffffff;
4216 }
4217 }
4218
4219 /* now see which range will peter our first, if either. */
4220 tdiff = tlast - tfirst;
4221 rdiff = rlast - rfirst;
4222
4223 if (tdiff <= rdiff)
4224 diff = tdiff;
4225 else
4226 diff = rdiff;
4227
4228 if (rfirst == 0xffffffff) {
4229 diff = tdiff; /* oops, pretend rdiff is infinite */
4230 if (diff > 0)
894356b3
GS		 4231 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
4232 (long)tfirst, (long)tlast);
a0ed51b3 4233 else
894356b3 4234 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
a0ed51b3
LW		 4235 }
4236 else {
4237 if (diff > 0)
894356b3
GS		 4238 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
4239 (long)tfirst, (long)(tfirst + diff),
4240 (long)rfirst);
a0ed51b3 4241 else
894356b3
GS		 4242 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
4243 (long)tfirst, (long)rfirst);
a0ed51b3
LW		 4244
4245 if (rfirst + diff > max)
4246 max = rfirst + diff;
9b877dbb 4247 if (!grows)
45005bfb
JH		 4248 grows = (tfirst < rfirst &&
4249 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
4250 rfirst += diff + 1;
a0ed51b3
LW		 4251 }
4252 tfirst += diff + 1;
4253 }
4254
4255 none = ++max;
4256 if (del)
4257 del = ++max;
4258
4259 if (max > 0xffff)
4260 bits = 32;
4261 else if (max > 0xff)
4262 bits = 16;
4263 else
4264 bits = 8;
4265
ad64d0ec 4266 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
043e41b8
DM		 4267#ifdef USE_ITHREADS
4268 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
4269 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
4270 PAD_SETSV(cPADOPo->op_padix, swash);
4271 SvPADTMP_on(swash);
a5446a64 4272 SvREADONLY_on(swash);
043e41b8
DM		 4273#else
4274 cSVOPo->op_sv = swash;
4275#endif
a0ed51b3 4276 SvREFCNT_dec(listsv);
b37c2d43 4277 SvREFCNT_dec(transv);
a0ed51b3 4278
45005bfb 4279 if (!del && havefinal && rlen)
85fbaab2 4280 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
b448e4fe 4281 newSVuv((UV)final), 0);
a0ed51b3 4282
9b877dbb 4283 if (grows)
a0ed51b3
LW		 4284 o->op_private |= OPpTRANS_GROWS;
4285
b37c2d43
AL		 4286 Safefree(tsave);
4287 Safefree(rsave);
9b877dbb 4288
eb8433b7
NC		 4289#ifdef PERL_MAD
4290 op_getmad(expr,o,'e');
4291 op_getmad(repl,o,'r');
4292#else
a0ed51b3
LW		 4293 op_free(expr);
4294 op_free(repl);
eb8433b7 4295#endif
a0ed51b3
LW		 4296 return o;
4297 }
4298
9100eeb1
Z		 4299 tbl = (short*)PerlMemShared_calloc(
4300 (o->op_private & OPpTRANS_COMPLEMENT) &&
4301 !(o->op_private & OPpTRANS_DELETE) ? 258 : 256,
4302 sizeof(short));
4303 cPVOPo->op_pv = (char*)tbl;
79072805 4304 if (complement) {
eb160463 4305 for (i = 0; i < (I32)tlen; i++)
ec49126f 4306 tbl[t[i]] = -1;
79072805
LW		 4307 for (i = 0, j = 0; i < 256; i++) {
4308 if (!tbl[i]) {
eb160463 4309 if (j >= (I32)rlen) {
a0ed51b3 4310 if (del)
79072805
LW		 4311 tbl[i] = -2;
4312 else if (rlen)
ec49126f 4313 tbl[i] = r[j-1];
79072805 4314 else
eb160463 4315 tbl[i] = (short)i;
79072805 4316 }
9b877dbb
IH		 4317 else {
4318 if (i < 128 && r[j] >= 128)
4319 grows = 1;
ec49126f 4320 tbl[i] = r[j++];
9b877dbb 4321 }
79072805
LW		 4322 }
4323 }
05d340b8
JH		 4324 if (!del) {
4325 if (!rlen) {
4326 j = rlen;
4327 if (!squash)
4328 o->op_private |= OPpTRANS_IDENTICAL;
4329 }
eb160463 4330 else if (j >= (I32)rlen)
05d340b8 4331 j = rlen - 1;
10db182f 4332 else {
aa1f7c5b
JH		 4333 tbl =
4334 (short *)
4335 PerlMemShared_realloc(tbl,
4336 (0x101+rlen-j) * sizeof(short));
10db182f
YO		 4337 cPVOPo->op_pv = (char*)tbl;
4338 }
585ec06d 4339 tbl[0x100] = (short)(rlen - j);
eb160463 4340 for (i=0; i < (I32)rlen - j; i++)
8973db79
JH		 4341 tbl[0x101+i] = r[j+i];
4342 }
79072805
LW		 4343 }
4344 else {
a0ed51b3 4345 if (!rlen && !del) {
79072805 4346 r = t; rlen = tlen;
5d06d08e 4347 if (!squash)
4757a243 4348 o->op_private |= OPpTRANS_IDENTICAL;
79072805 4349 }
94bfe852
RGS		 4350 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
4351 o->op_private |= OPpTRANS_IDENTICAL;
4352 }
79072805
LW		 4353 for (i = 0; i < 256; i++)
4354 tbl[i] = -1;
eb160463
GS		 4355 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
4356 if (j >= (I32)rlen) {
a0ed51b3 4357 if (del) {
ec49126f 4358 if (tbl[t[i]] == -1)
4359 tbl[t[i]] = -2;
79072805
LW		 4360 continue;
4361 }
4362 --j;
4363 }
9b877dbb
IH		 4364 if (tbl[t[i]] == -1) {
4365 if (t[i] < 128 && r[j] >= 128)
4366 grows = 1;
ec49126f 4367 tbl[t[i]] = r[j];
9b877dbb 4368 }
79072805
LW		 4369 }
4370 }
b08e453b 4371
a2a5de95
NC		 4372 if(del && rlen == tlen) {
4373 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
4374 } else if(rlen > tlen) {
4375 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
b08e453b
RB		 4376 }
4377
9b877dbb
IH		 4378 if (grows)
4379 o->op_private |= OPpTRANS_GROWS;
eb8433b7
NC		 4380#ifdef PERL_MAD
4381 op_getmad(expr,o,'e');
4382 op_getmad(repl,o,'r');
4383#else
79072805
LW		 4384 op_free(expr);
4385 op_free(repl);
eb8433b7 4386#endif
79072805 4387
11343788 4388 return o;
79072805
LW		 4389}
4390
d67eb5f4
Z		 4391/*
4392=for apidoc Am|OP *|newPMOP|I32 type|I32 flags
4393
4394Constructs, checks, and returns an op of any pattern matching type.
4395I<type> is the opcode. I<flags> gives the eight bits of C<op_flags>
4396and, shifted up eight bits, the eight bits of C<op_private>.
4397
4398=cut
4399*/
4400
79072805 4401OP *
864dbfa3 4402Perl_newPMOP(pTHX_ I32 type, I32 flags)
79072805 4403{
27da23d5 4404 dVAR;
79072805
LW		 4405 PMOP *pmop;
4406
e69777c1
GG		 4407 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
4408
b7dc083c 4409 NewOp(1101, pmop, 1, PMOP);
eb160463 4410 pmop->op_type = (OPCODE)type;
22c35a8c 4411 pmop->op_ppaddr = PL_ppaddr[type];
eb160463
GS		 4412 pmop->op_flags = (U8)flags;
4413 pmop->op_private = (U8)(0 | (flags >> 8));
79072805 4414
3280af22 4415 if (PL_hints & HINT_RE_TAINT)
c737faaf 4416 pmop->op_pmflags |= PMf_RETAINT;
82ad65bb 4417 if (IN_LOCALE_COMPILETIME) {
a62b1201 4418 set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
9de15fec 4419 }
66cbab2c
KW		 4420 else if ((! (PL_hints & HINT_BYTES))
4421 /* Both UNI_8_BIT and locale :not_characters imply Unicode */
4422 && (PL_hints & (HINT_UNI_8_BIT|HINT_LOCALE_NOT_CHARS)))
4423 {
a62b1201 4424 set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
9de15fec 4425 }
1e215989 4426 if (PL_hints & HINT_RE_FLAGS) {
20439bc7
Z		 4427 SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4428 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
1e215989
FC		 4429 );
4430 if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
20439bc7 4431 reflags = Perl_refcounted_he_fetch_pvn(aTHX_
6320bfaf 4432 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
1e215989
FC		 4433 );
4434 if (reflags && SvOK(reflags)) {
dabded94 4435 set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
1e215989
FC		 4436 }
4437 }
c737faaf 4438
36477c24 4439
debc9467 4440#ifdef USE_ITHREADS
402d2eb1
NC		 4441 assert(SvPOK(PL_regex_pad[0]));
4442 if (SvCUR(PL_regex_pad[0])) {
4443 /* Pop off the "packed" IV from the end. */
4444 SV *const repointer_list = PL_regex_pad[0];
4445 const char *p = SvEND(repointer_list) - sizeof(IV);
4446 const IV offset = *((IV*)p);
4447
4448 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
4449
4450 SvEND_set(repointer_list, p);
4451
110f3028 4452 pmop->op_pmoffset = offset;
14a49a24
NC		 4453 /* This slot should be free, so assert this: */
4454 assert(PL_regex_pad[offset] == &PL_sv_undef);
551405c4 4455 } else {
14a49a24 4456 SV * const repointer = &PL_sv_undef;
9a8b6709 4457 av_push(PL_regex_padav, repointer);
551405c4
AL		 4458 pmop->op_pmoffset = av_len(PL_regex_padav);
4459 PL_regex_pad = AvARRAY(PL_regex_padav);
13137afc 4460 }
debc9467 4461#endif
1eb1540c 4462
463d09e6 4463 return CHECKOP(type, pmop);
79072805
LW		 4464}
4465
131b3ad0
DM		 4466/* Given some sort of match op o, and an expression expr containing a
4467 * pattern, either compile expr into a regex and attach it to o (if it's
4468 * constant), or convert expr into a runtime regcomp op sequence (if it's
4469 * not)
4470 *
4471 * isreg indicates that the pattern is part of a regex construct, eg
4472 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
4473 * split "pattern", which aren't. In the former case, expr will be a list
4474 * if the pattern contains more than one term (eg /a$b/) or if it contains
4475 * a replacement, ie s/// or tr///.
d63c20f2
DM		 4476 *
4477 * When the pattern has been compiled within a new anon CV (for
4478 * qr/(?{...})/ ), then floor indicates the savestack level just before
4479 * the new sub was created
131b3ad0
DM		 4480 */
4481
79072805 4482OP *
d63c20f2 4483Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor)
79072805 4484{
27da23d5 4485 dVAR;
79072805
LW		 4486 PMOP *pm;
4487 LOGOP *rcop;
ce862d02 4488 I32 repl_has_vars = 0;
5f66b61c 4489 OP* repl = NULL;
74529a43
DM		 4490 bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
4491 bool is_compiletime;
4492 bool has_code;
131b3ad0 4493
7918f24d
NC		 4494 PERL_ARGS_ASSERT_PMRUNTIME;
4495
74529a43
DM		 4496 /* for s/// and tr///, last element in list is the replacement; pop it */
4497
4498 if (is_trans || o->op_type == OP_SUBST) {
131b3ad0
DM		 4499 OP* kid;
4500 repl = cLISTOPx(expr)->op_last;
4501 kid = cLISTOPx(expr)->op_first;
4502 while (kid->op_sibling != repl)
4503 kid = kid->op_sibling;
5f66b61c 4504 kid->op_sibling = NULL;
131b3ad0
DM		 4505 cLISTOPx(expr)->op_last = kid;
4506 }
79072805 4507
74529a43
DM		 4508 /* for TRANS, convert LIST/PUSH/CONST into CONST, and pass to pmtrans() */
4509
4510 if (is_trans) {
4511 OP* const oe = expr;
4512 assert(expr->op_type == OP_LIST);
4513 assert(cLISTOPx(expr)->op_first->op_type == OP_PUSHMARK);
4514 assert(cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last);
4515 expr = cLISTOPx(oe)->op_last;
4516 cLISTOPx(oe)->op_first->op_sibling = NULL;
4517 cLISTOPx(oe)->op_last = NULL;
4518 op_free(oe);
4519
4520 return pmtrans(o, expr, repl);
4521 }
4522
8a45afe5
DM		 4523 /* find whether we have any runtime or code elements;
4524 * at the same time, temporarily set the op_next of each DO block;
4525 * then when we LINKLIST, this will cause the DO blocks to be excluded
4526 * from the op_next chain (and from having LINKLIST recursively
4527 * applied to them). We fix up the DOs specially later */
74529a43
DM		 4528
4529 is_compiletime = 1;
4530 has_code = 0;
4531 if (expr->op_type == OP_LIST) {
4532 OP *o;
4533 for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) {
8a45afe5 4534 if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
74529a43 4535 has_code = 1;
8a45afe5
DM		 4536 assert(!o->op_next && o->op_sibling);
4537 o->op_next = o->op_sibling;
4538 }
74529a43
DM		 4539 else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
4540 is_compiletime = 0;
4541 }
4542 }
68e2671b 4543 else if (expr->op_type != OP_CONST)
74529a43 4544 is_compiletime = 0;
74529a43 4545
8a45afe5
DM		 4546 LINKLIST(expr);
4547
8a45afe5 4548 /* fix up DO blocks; treat each one as a separate little sub */
74529a43 4549
68e2671b 4550 if (expr->op_type == OP_LIST) {
8a45afe5
DM		 4551 OP *o;
4552 for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) {
4553 if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
4554 continue;
4555 o->op_next = NULL; /* undo temporary hack from above */
4556 scalar(o);
4557 LINKLIST(o);
4558 if (cLISTOPo->op_first->op_type == OP_LEAVE) {
4559 LISTOP *leave = cLISTOPx(cLISTOPo->op_first);
4560 /* skip ENTER */
4561 assert(leave->op_first->op_type == OP_ENTER);
4562 assert(leave->op_first->op_sibling);
4563 o->op_next = leave->op_first->op_sibling;
4564 /* skip LEAVE */
4565 assert(leave->op_flags & OPf_KIDS);
4566 assert(leave->op_last->op_next = (OP*)leave);
4567 leave->op_next = NULL; /* stop on last op */
4568 op_null((OP*)leave);
9da1dd8f 4569 }
8a45afe5
DM		 4570 else {
4571 /* skip SCOPE */
4572 OP *scope = cLISTOPo->op_first;
4573 assert(scope->op_type == OP_SCOPE);
4574 assert(scope->op_flags & OPf_KIDS);
4575 scope->op_next = NULL; /* stop on last op */
4576 op_null(scope);
9da1dd8f 4577 }
8a45afe5
DM		 4578 /* have to peep the DOs individually as we've removed it from
4579 * the op_next chain */
4580 CALL_PEEP(o);
4581 if (is_compiletime)
4582 /* runtime finalizes as part of finalizing whole tree */
4583 finalize_optree(o);
9da1dd8f 4584 }
9da1dd8f
DM		 4585 }
4586
3280af22 4587 PL_hints |= HINT_BLOCK_SCOPE;
11343788 4588 pm = (PMOP*)o;
d63c20f2 4589 assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
79072805 4590
74529a43 4591 if (is_compiletime) {
514a91f1 4592 U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
3c13cae6 4593 regexp_engine const *eng = current_re_engine();
5c144d81 4594
3c13cae6 4595 if (!has_code || !eng->op_comp) {
d63c20f2 4596 /* compile-time simple constant pattern */
d63c20f2
DM		 4597
4598 if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
4599 /* whoops! we guessed that a qr// had a code block, but we
4600 * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
4601 * that isn't required now. Note that we have to be pretty
4602 * confident that nothing used that CV's pad while the
4603 * regex was parsed */
4604 assert(AvFILLp(PL_comppad) == 0); /* just @_ */
8be227ab
FC		 4605 /* But we know that one op is using this CV's slab. */
4606 cv_forget_slab(PL_compcv);
d63c20f2
DM		 4607 LEAVE_SCOPE(floor);
4608 pm->op_pmflags &= ~PMf_HAS_CV;
4609 }
4610
e485beb8
DM		 4611 PM_SETRE(pm,
4612 eng->op_comp
4613 ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
4614 rx_flags, pm->op_pmflags)
4615 : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
4616 rx_flags, pm->op_pmflags)
4617 );
eb8433b7 4618#ifdef PERL_MAD
68e2671b 4619 op_getmad(expr,(OP*)pm,'e');
eb8433b7 4620#else
68e2671b 4621 op_free(expr);
eb8433b7 4622#endif
68e2671b
DM		 4623 }
4624 else {
d63c20f2 4625 /* compile-time pattern that includes literal code blocks */
3c13cae6 4626 REGEXP* re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
732caac7
DM		 4627 rx_flags,
4628 (pm->op_pmflags |
4629 ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
4630 );
d63c20f2
DM		 4631 PM_SETRE(pm, re);
4632 if (pm->op_pmflags & PMf_HAS_CV) {
4633 CV *cv;
4634 /* this QR op (and the anon sub we embed it in) is never
4635 * actually executed. It's just a placeholder where we can
4636 * squirrel away expr in op_code_list without the peephole
4637 * optimiser etc processing it for a second time */
4638 OP *qr = newPMOP(OP_QR, 0);
4639 ((PMOP*)qr)->op_code_list = expr;
4640
4641 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
4642 SvREFCNT_inc_simple_void(PL_compcv);
4643 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
8d919b0a 4644 ReANY(re)->qr_anoncv = cv;
d63c20f2
DM		 4645
4646 /* attach the anon CV to the pad so that
4647 * pad_fixup_inner_anons() can find it */
4d2dfd15 4648 (void)pad_add_anon(cv, o->op_type);
d63c20f2
DM		 4649 SvREFCNT_inc_simple_void(cv);
4650 }
4651 else {
4652 pm->op_code_list = expr;
4653 }
68e2671b 4654 }
79072805
LW		 4655 }
4656 else {
d63c20f2 4657 /* runtime pattern: build chain of regcomp etc ops */
74529a43 4658 bool reglist;
346d3070 4659 PADOFFSET cv_targ = 0;
74529a43
DM		 4660
4661 reglist = isreg && expr->op_type == OP_LIST;
4662 if (reglist)
4663 op_null(expr);
4664
867940b8
DM		 4665 if (has_code) {
4666 pm->op_code_list = expr;
4667 /* don't free op_code_list; its ops are embedded elsewhere too */
4668 pm->op_pmflags |= PMf_CODELIST_PRIVATE;
4669 }
4670
7fb31b92
DM		 4671 /* the OP_REGCMAYBE is a placeholder in the non-threaded case
4672 * to allow its op_next to be pointed past the regcomp and
4673 * preceding stacking ops;
4674 * OP_REGCRESET is there to reset taint before executing the
4675 * stacking ops */
284167a5
S		 4676 if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
4677 expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
463ee0b2 4678
d63c20f2
DM		 4679 if (pm->op_pmflags & PMf_HAS_CV) {
4680 /* we have a runtime qr with literal code. This means
4681 * that the qr// has been wrapped in a new CV, which
4682 * means that runtime consts, vars etc will have been compiled
4683 * against a new pad. So... we need to execute those ops
4684 * within the environment of the new CV. So wrap them in a call
4685 * to a new anon sub. i.e. for
4686 *
4687 * qr/a$b(?{...})/,
4688 *
4689 * we build an anon sub that looks like
4690 *
4691 * sub { "a", $b, '(?{...})' }
4692 *
4693 * and call it, passing the returned list to regcomp.
4694 * Or to put it another way, the list of ops that get executed
4695 * are:
4696 *
4697 * normal PMf_HAS_CV
4698 * ------ -------------------
4699 * pushmark (for regcomp)
4700 * pushmark (for entersub)
4701 * pushmark (for refgen)
4702 * anoncode
4703 * refgen
4704 * entersub
4705 * regcreset regcreset
4706 * pushmark pushmark
4707 * const("a") const("a")
4708 * gvsv(b) gvsv(b)
4709 * const("(?{...})") const("(?{...})")
4710 * leavesub
4711 * regcomp regcomp
4712 */
4713
4714 SvREFCNT_inc_simple_void(PL_compcv);
346d3070
DM		 4715 /* these lines are just an unrolled newANONATTRSUB */
4716 expr = newSVOP(OP_ANONCODE, 0,
4717 MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
4718 cv_targ = expr->op_targ;
4719 expr = newUNOP(OP_REFGEN, 0, expr);
4720
4721 expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr))));
d63c20f2
DM		 4722 }
4723
b7dc083c 4724 NewOp(1101, rcop, 1, LOGOP);
79072805 4725 rcop->op_type = OP_REGCOMP;
22c35a8c 4726 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
79072805 4727 rcop->op_first = scalar(expr);
131b3ad0
DM		 4728 rcop->op_flags |= OPf_KIDS
4729 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
4730 | (reglist ? OPf_STACKED : 0);
188c1910 4731 rcop->op_private = 0;
11343788 4732 rcop->op_other = o;
346d3070 4733 rcop->op_targ = cv_targ;
131b3ad0 4734
b5c19bd7 4735 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
ec192197 4736 if (PL_hints & HINT_RE_EVAL) PL_cv_has_eval = 1;
79072805
LW		 4737
4738 /* establish postfix order */
d63c20f2 4739 if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
463ee0b2
LW		 4740 LINKLIST(expr);
4741 rcop->op_next = expr;
4742 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
4743 }
4744 else {
4745 rcop->op_next = LINKLIST(expr);
4746 expr->op_next = (OP*)rcop;
4747 }
79072805 4748
2fcb4757 4749 op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
79072805
LW		 4750 }
4751
4752 if (repl) {
ef90d20a 4753 OP *curop = repl;
bb933b9b 4754 bool konst;
0244c3a4 4755 if (pm->op_pmflags & PMf_EVAL) {
670a9cb2
DM		 4756 if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
4757 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
0244c3a4 4758 }
ef90d20a
FC		 4759 /* If we are looking at s//.../e with a single statement, get past
4760 the implicit do{}. */
4761 if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
4762 && cUNOPx(curop)->op_first->op_type == OP_SCOPE
4763 && cUNOPx(curop)->op_first->op_flags & OPf_KIDS) {
4764 OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
4765 if (kid->op_type == OP_NULL && kid->op_sibling
4766 && !kid->op_sibling->op_sibling)
4767 curop = kid->op_sibling;
4768 }
4769 if (curop->op_type == OP_CONST)
bb933b9b 4770 konst = TRUE;
ef90d20a
FC		 4771 else if (( (curop->op_type == OP_RV2SV ||
4772 curop->op_type == OP_RV2AV ||
4773 curop->op_type == OP_RV2HV ||
4774 curop->op_type == OP_RV2GV)
4775 && cUNOPx(curop)->op_first
4776 && cUNOPx(curop)->op_first->op_type == OP_GV )
4777 || curop->op_type == OP_PADSV
4778 || curop->op_type == OP_PADAV
4779 || curop->op_type == OP_PADHV
4780 || curop->op_type == OP_PADANY) {
bb933b9b
FC		 4781 repl_has_vars = 1;
4782 konst = TRUE;
748a9306 4783 }
bb933b9b
FC		 4784 else konst = FALSE;
4785 if (konst
e80b829c
RGS		 4786 && !(repl_has_vars
4787 && (!PM_GETRE(pm)
b97b7b69 4788 || !RX_PRELEN(PM_GETRE(pm))
07bc277f 4789 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
3be69782 4790 {
748a9306 4791 pm->op_pmflags |= PMf_CONST; /* const for long enough */
2fcb4757 4792 op_prepend_elem(o->op_type, scalar(repl), o);
748a9306
LW		 4793 }
4794 else {
b7dc083c 4795 NewOp(1101, rcop, 1, LOGOP);
748a9306 4796 rcop->op_type = OP_SUBSTCONT;
22c35a8c 4797 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
748a9306
LW		 4798 rcop->op_first = scalar(repl);
4799 rcop->op_flags |= OPf_KIDS;
4800 rcop->op_private = 1;
11343788 4801 rcop->op_other = o;
748a9306
LW		 4802
4803 /* establish postfix order */
4804 rcop->op_next = LINKLIST(repl);
4805 repl->op_next = (OP*)rcop;
4806
20e98b0f 4807 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
29f2e912
NC		 4808 assert(!(pm->op_pmflags & PMf_ONCE));
4809 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
748a9306 4810 rcop->op_next = 0;
79072805
LW		 4811 }
4812 }
4813
4814 return (OP*)pm;
4815}
4816
d67eb5f4
Z		 4817/*
4818=for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
4819
4820Constructs, checks, and returns an op of any type that involves an
4821embedded SV. I<type> is the opcode. I<flags> gives the eight bits
4822of C<op_flags>. I<sv> gives the SV to embed in the op; this function
4823takes ownership of one reference to it.
4824
4825=cut
4826*/
4827
79072805 4828OP *
864dbfa3 4829Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
79072805 4830{
27da23d5 4831 dVAR;
79072805 4832 SVOP *svop;
7918f24d
NC		 4833
4834 PERL_ARGS_ASSERT_NEWSVOP;
4835
e69777c1
GG		 4836 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4837 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4838 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4839
b7dc083c 4840 NewOp(1101, svop, 1, SVOP);
eb160463 4841 svop->op_type = (OPCODE)type;
22c35a8c 4842 svop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 4843 svop->op_sv = sv;
4844 svop->op_next = (OP*)svop;
eb160463 4845 svop->op_flags = (U8)flags;
cc2ebcd7 4846 svop->op_private = (U8)(0 | (flags >> 8));
22c35a8c 4847 if (PL_opargs[type] & OA_RETSCALAR)
463ee0b2 4848 scalar((OP*)svop);
22c35a8c 4849 if (PL_opargs[type] & OA_TARGET)
ed6116ce 4850 svop->op_targ = pad_alloc(type, SVs_PADTMP);
e50aee73 4851 return CHECKOP(type, svop);
79072805
LW		 4852}
4853
392d04bb 4854#ifdef USE_ITHREADS
d67eb5f4
Z		 4855
4856/*
4857=for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
4858
4859Constructs, checks, and returns an op of any type that involves a
4860reference to a pad element. I<type> is the opcode. I<flags> gives the
4861eight bits of C<op_flags>. A pad slot is automatically allocated, and
4862is populated with I<sv>; this function takes ownership of one reference
4863to it.
4864
4865This function only exists if Perl has been compiled to use ithreads.
4866
4867=cut
4868*/
4869
79072805 4870OP *
350de78d
GS		 4871Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
4872{
27da23d5 4873 dVAR;
350de78d 4874 PADOP *padop;
7918f24d
NC		 4875
4876 PERL_ARGS_ASSERT_NEWPADOP;
4877
e69777c1
GG		 4878 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4879 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4880 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4881
350de78d 4882 NewOp(1101, padop, 1, PADOP);
eb160463 4883 padop->op_type = (OPCODE)type;
350de78d
GS		 4884 padop->op_ppaddr = PL_ppaddr[type];
4885 padop->op_padix = pad_alloc(type, SVs_PADTMP);
dd2155a4
DM		 4886 SvREFCNT_dec(PAD_SVl(padop->op_padix));
4887 PAD_SETSV(padop->op_padix, sv);
58182927
NC		 4888 assert(sv);
4889 SvPADTMP_on(sv);
350de78d 4890 padop->op_next = (OP*)padop;
eb160463 4891 padop->op_flags = (U8)flags;
350de78d
GS		 4892 if (PL_opargs[type] & OA_RETSCALAR)
4893 scalar((OP*)padop);
4894 if (PL_opargs[type] & OA_TARGET)
4895 padop->op_targ = pad_alloc(type, SVs_PADTMP);
4896 return CHECKOP(type, padop);
4897}
d67eb5f4
Z		 4898
4899#endif /* !USE_ITHREADS */
4900
4901/*
4902=for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
4903
4904Constructs, checks, and returns an op of any type that involves an
4905embedded reference to a GV. I<type> is the opcode. I<flags> gives the
4906eight bits of C<op_flags>. I<gv> identifies the GV that the op should
4907reference; calling this function does not transfer ownership of any
4908reference to it.
4909
4910=cut
4911*/
350de78d
GS		 4912
4913OP *
864dbfa3 4914Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
79072805 4915{
27da23d5 4916 dVAR;
7918f24d
NC		 4917
4918 PERL_ARGS_ASSERT_NEWGVOP;
4919
350de78d 4920#ifdef USE_ITHREADS
58182927 4921 GvIN_PAD_on(gv);
ff8997d7 4922 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
350de78d 4923#else
ff8997d7 4924 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
350de78d 4925#endif
79072805
LW		 4926}
4927
d67eb5f4
Z		 4928/*
4929=for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
4930
4931Constructs, checks, and returns an op of any type that involves an
4932embedded C-level pointer (PV). I<type> is the opcode. I<flags> gives
4933the eight bits of C<op_flags>. I<pv> supplies the C-level pointer, which
4934must have been allocated using L</PerlMemShared_malloc>; the memory will
4935be freed when the op is destroyed.
4936
4937=cut
4938*/
4939
79072805 4940OP *
864dbfa3 4941Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
79072805 4942{
27da23d5 4943 dVAR;
5db1eb8d 4944 const bool utf8 = cBOOL(flags & SVf_UTF8);
79072805 4945 PVOP *pvop;
e69777c1 4946
5db1eb8d
BF		 4947 flags &= ~SVf_UTF8;
4948
e69777c1 4949 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
1a35f9ff 4950 || type == OP_RUNCV
e69777c1
GG		 4951 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4952
b7dc083c 4953 NewOp(1101, pvop, 1, PVOP);
eb160463 4954 pvop->op_type = (OPCODE)type;
22c35a8c 4955 pvop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 4956 pvop->op_pv = pv;
4957 pvop->op_next = (OP*)pvop;
eb160463 4958 pvop->op_flags = (U8)flags;
5db1eb8d 4959 pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
22c35a8c 4960 if (PL_opargs[type] & OA_RETSCALAR)
463ee0b2 4961 scalar((OP*)pvop);
22c35a8c 4962 if (PL_opargs[type] & OA_TARGET)
ed6116ce 4963 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
e50aee73 4964 return CHECKOP(type, pvop);
79072805
LW		 4965}
4966
eb8433b7
NC		 4967#ifdef PERL_MAD
4968OP*
4969#else
79072805 4970void
eb8433b7 4971#endif
864dbfa3 4972Perl_package(pTHX_ OP *o)
79072805 4973{
97aff369 4974 dVAR;
bf070237 4975 SV *const sv = cSVOPo->op_sv;
eb8433b7
NC		 4976#ifdef PERL_MAD
4977 OP *pegop;
4978#endif
79072805 4979
7918f24d
NC		 4980 PERL_ARGS_ASSERT_PACKAGE;
4981
03d9f026 4982 SAVEGENERICSV(PL_curstash);
3280af22 4983 save_item(PL_curstname);
de11ba31 4984
03d9f026 4985 PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
e1a479c5 4986
bf070237 4987 sv_setsv(PL_curstname, sv);
de11ba31 4988
7ad382f4 4989 PL_hints |= HINT_BLOCK_SCOPE;
53a7735b
DM		 4990 PL_parser->copline = NOLINE;
4991 PL_parser->expect = XSTATE;
eb8433b7
NC		 4992
4993#ifndef PERL_MAD
4994 op_free(o);
4995#else
4996 if (!PL_madskills) {
4997 op_free(o);
1d866c12 4998 return NULL;
eb8433b7
NC		 4999 }
5000
5001 pegop = newOP(OP_NULL,0);
5002 op_getmad(o,pegop,'P');
5003 return pegop;
5004#endif
79072805
LW		 5005}
5006
6fa4d285
DG		 5007void
5008Perl_package_version( pTHX_ OP *v )
5009{
5010 dVAR;
458818ec 5011 U32 savehints = PL_hints;
6fa4d285 5012 PERL_ARGS_ASSERT_PACKAGE_VERSION;
458818ec 5013 PL_hints &= ~HINT_STRICT_VARS;
e92f586b 5014 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
458818ec 5015 PL_hints = savehints;
6fa4d285
DG		 5016 op_free(v);
5017}
5018
eb8433b7
NC		 5019#ifdef PERL_MAD
5020OP*
5021#else
85e6fe83 5022void
eb8433b7 5023#endif
88d95a4d 5024Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
85e6fe83 5025{
97aff369 5026 dVAR;
a0d0e21e 5027 OP *pack;
a0d0e21e 5028 OP *imop;
b1cb66bf 5029 OP *veop;
eb8433b7 5030#ifdef PERL_MAD
d8842ae9 5031 OP *pegop = PL_madskills ? newOP(OP_NULL,0) : NULL;
eb8433b7 5032#endif
88e9444c 5033 SV *use_version = NULL;
85e6fe83 5034
7918f24d
NC		 5035 PERL_ARGS_ASSERT_UTILIZE;
5036
88d95a4d 5037 if (idop->op_type != OP_CONST)
cea2e8a9 5038 Perl_croak(aTHX_ "Module name must be constant");
85e6fe83 5039
eb8433b7
NC		 5040 if (PL_madskills)
5041 op_getmad(idop,pegop,'U');
5042
5f66b61c 5043 veop = NULL;
b1cb66bf 5044
aec46f14 5045 if (version) {
551405c4 5046 SV * const vesv = ((SVOP*)version)->op_sv;
b1cb66bf 5047
eb8433b7
NC		 5048 if (PL_madskills)
5049 op_getmad(version,pegop,'V');
aec46f14 5050 if (!arg && !SvNIOKp(vesv)) {
b1cb66bf 5051 arg = version;
5052 }
5053 else {
5054 OP *pack;
0f79a09d 5055 SV *meth;
b1cb66bf 5056
44dcb63b 5057 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
fe13d51d 5058 Perl_croak(aTHX_ "Version number must be a constant number");
b1cb66bf 5059
88d95a4d
JH		 5060 /* Make copy of idop so we don't free it twice */
5061 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
b1cb66bf 5062
5063 /* Fake up a method call to VERSION */
18916d0d 5064 meth = newSVpvs_share("VERSION");
b1cb66bf 5065 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2fcb4757
Z		 5066 op_append_elem(OP_LIST,
5067 op_prepend_elem(OP_LIST, pack, list(version)),
0f79a09d 5068 newSVOP(OP_METHOD_NAMED, 0, meth)));
b1cb66bf 5069 }
5070 }
aeea060c 5071
a0d0e21e 5072 /* Fake up an import/unimport */
eb8433b7
NC		 5073 if (arg && arg->op_type == OP_STUB) {
5074 if (PL_madskills)
5075 op_getmad(arg,pegop,'S');
4633a7c4 5076 imop = arg; /* no import on explicit () */
eb8433b7 5077 }
88d95a4d 5078 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
5f66b61c 5079 imop = NULL; /* use 5.0; */
88e9444c
NC		 5080 if (aver)
5081 use_version = ((SVOP*)idop)->op_sv;
5082 else
468aa647 5083 idop->op_private |= OPpCONST_NOVER;
b1cb66bf 5084 }
4633a7c4 5085 else {
0f79a09d
GS		 5086 SV *meth;
5087
eb8433b7
NC		 5088 if (PL_madskills)
5089 op_getmad(arg,pegop,'A');
5090
88d95a4d
JH		 5091 /* Make copy of idop so we don't free it twice */
5092 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
0f79a09d
GS		 5093
5094 /* Fake up a method call to import/unimport */
427d62a4 5095 meth = aver
18916d0d 5096 ? newSVpvs_share("import") : newSVpvs_share("unimport");
4633a7c4 5097 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2fcb4757
Z		 5098 op_append_elem(OP_LIST,
5099 op_prepend_elem(OP_LIST, pack, list(arg)),
0f79a09d 5100 newSVOP(OP_METHOD_NAMED, 0, meth)));
4633a7c4
LW		 5101 }
5102
a0d0e21e 5103 /* Fake up the BEGIN {}, which does its thing immediately. */
09bef843 5104 newATTRSUB(floor,
18916d0d 5105 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
5f66b61c
AL		 5106 NULL,
5107 NULL,
2fcb4757
Z		 5108 op_append_elem(OP_LINESEQ,
5109 op_append_elem(OP_LINESEQ,
bd61b366
SS		 5110 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
5111 newSTATEOP(0, NULL, veop)),
5112 newSTATEOP(0, NULL, imop) ));
85e6fe83 5113
88e9444c 5114 if (use_version) {
6634bb9d 5115 /* Enable the
88e9444c
NC		 5116 * feature bundle that corresponds to the required version. */
5117 use_version = sv_2mortal(new_version(use_version));
6634bb9d 5118 S_enable_feature_bundle(aTHX_ use_version);
88e9444c 5119
88e9444c
NC		 5120 /* If a version >= 5.11.0 is requested, strictures are on by default! */
5121 if (vcmp(use_version,
5122 sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
d1718a7c 5123 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
b50b2058 5124 PL_hints |= HINT_STRICT_REFS;
d1718a7c 5125 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
b50b2058 5126 PL_hints |= HINT_STRICT_SUBS;
d1718a7c 5127 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
b50b2058
FC		 5128 PL_hints |= HINT_STRICT_VARS;
5129 }
5130 /* otherwise they are off */
5131 else {
d1718a7c 5132 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
b50b2058 5133 PL_hints &= ~HINT_STRICT_REFS;
d1718a7c 5134 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
b50b2058 5135 PL_hints &= ~HINT_STRICT_SUBS;
d1718a7c 5136 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
b50b2058 5137 PL_hints &= ~HINT_STRICT_VARS;
88e9444c
NC		 5138 }
5139 }
5140
70f5e4ed
JH		 5141 /* The "did you use incorrect case?" warning used to be here.
5142 * The problem is that on case-insensitive filesystems one
5143 * might get false positives for "use" (and "require"):
5144 * "use Strict" or "require CARP" will work. This causes
5145 * portability problems for the script: in case-strict
5146 * filesystems the script will stop working.
5147 *
5148 * The "incorrect case" warning checked whether "use Foo"
5149 * imported "Foo" to your namespace, but that is wrong, too:
5150 * there is no requirement nor promise in the language that
5151 * a Foo.pm should or would contain anything in package "Foo".
5152 *
5153 * There is very little Configure-wise that can be done, either:
5154 * the case-sensitivity of the build filesystem of Perl does not
5155 * help in guessing the case-sensitivity of the runtime environment.
5156 */
18fc9488 5157
c305c6a0 5158 PL_hints |= HINT_BLOCK_SCOPE;
53a7735b
DM		 5159 PL_parser->copline = NOLINE;
5160 PL_parser->expect = XSTATE;
8ec8fbef 5161 PL_cop_seqmax++; /* Purely for B::*'s benefit */
6012dc80
DM		 5162 if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
5163 PL_cop_seqmax++;
eb8433b7
NC		 5164
5165#ifdef PERL_MAD
eb8433b7
NC		 5166 return pegop;
5167#endif
85e6fe83
LW		 5168}
5169
7d3fb230 5170/*
ccfc67b7
JH		 5171=head1 Embedding Functions
5172
7d3fb230
BS		 5173=for apidoc load_module
5174
5175Loads the module whose name is pointed to by the string part of name.
5176Note that the actual module name, not its filename, should be given.
5177Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
5178PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
d9f23c72 5179(or 0 for no flags). ver, if specified and not NULL, provides version semantics
7d3fb230
BS		 5180similar to C<use Foo::Bar VERSION>. The optional trailing SV*
5181arguments can be used to specify arguments to the module's import()
76f108ac
JD		 5182method, similar to C<use Foo::Bar VERSION LIST>. They must be
5183terminated with a final NULL pointer. Note that this list can only
5184be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
5185Otherwise at least a single NULL pointer to designate the default
5186import list is required.
7d3fb230 5187
d9f23c72
KW		 5188The reference count for each specified C<SV*> parameter is decremented.
5189
7d3fb230
BS		 5190=cut */
5191
e4783991
GS		 5192void
5193Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
5194{
5195 va_list args;
7918f24d
NC		 5196
5197 PERL_ARGS_ASSERT_LOAD_MODULE;
5198
e4783991
GS		 5199 va_start(args, ver);
5200 vload_module(flags, name, ver, &args);
5201 va_end(args);
5202}
5203
5204#ifdef PERL_IMPLICIT_CONTEXT
5205void
5206Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
5207{
5208 dTHX;
5209 va_list args;
7918f24d 5210 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
e4783991
GS		 5211 va_start(args, ver);
5212 vload_module(flags, name, ver, &args);
5213 va_end(args);
5214}
5215#endif
5216
5217void
5218Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
5219{
97aff369 5220 dVAR;
551405c4 5221 OP *veop, *imop;
551405c4 5222 OP * const modname = newSVOP(OP_CONST, 0, name);
7918f24d
NC		 5223
5224 PERL_ARGS_ASSERT_VLOAD_MODULE;
5225
e4783991
GS		 5226 modname->op_private |= OPpCONST_BARE;
5227 if (ver) {
5228 veop = newSVOP(OP_CONST, 0, ver);
5229 }
5230 else
5f66b61c 5231 veop = NULL;
e4783991
GS		 5232 if (flags & PERL_LOADMOD_NOIMPORT) {
5233 imop = sawparens(newNULLLIST());
5234 }
5235 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
5236 imop = va_arg(*args, OP*);
5237 }
5238 else {
5239 SV *sv;
5f66b61c 5240 imop = NULL;
e4783991
GS		 5241 sv = va_arg(*args, SV*);
5242 while (sv) {
2fcb4757 5243 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
e4783991
GS		 5244 sv = va_arg(*args, SV*);
5245 }
5246 }
81885997 5247
53a7735b
DM		 5248 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
5249 * that it has a PL_parser to play with while doing that, and also
5250 * that it doesn't mess with any existing parser, by creating a tmp
5251 * new parser with lex_start(). This won't actually be used for much,
5252 * since pp_require() will create another parser for the real work. */
5253
5254 ENTER;
5255 SAVEVPTR(PL_curcop);
27fcb6ee 5256 lex_start(NULL, NULL, LEX_START_SAME_FILTER);
53a7735b
DM		 5257 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
5258 veop, modname, imop);
5259 LEAVE;
e4783991
GS		 5260}
5261
79072805 5262OP *
850e8516 5263Perl_dofile(pTHX_ OP *term, I32 force_builtin)
78ca652e 5264{
97aff369 5265 dVAR;
78ca652e 5266 OP *doop;
a0714e2c 5267 GV *gv = NULL;
78ca652e 5268
7918f24d
NC		 5269 PERL_ARGS_ASSERT_DOFILE;
5270
850e8516 5271 if (!force_builtin) {
fafc274c 5272 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
850e8516 5273 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
a4fc7abc 5274 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
a0714e2c 5275 gv = gvp ? *gvp : NULL;
850e8516
RGS		 5276 }
5277 }
78ca652e 5278
b9f751c0 5279 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
213aa87d 5280 doop = newUNOP(OP_ENTERSUB, OPf_STACKED,
2fcb4757 5281 op_append_elem(OP_LIST, term,
78ca652e 5282 scalar(newUNOP(OP_RV2CV, 0,
213aa87d 5283 newGVOP(OP_GV, 0, gv)))));
78ca652e
GS		 5284 }
5285 else {
5286 doop = newUNOP(OP_DOFILE, 0, scalar(term));
5287 }
5288 return doop;
5289}
5290
d67eb5f4
Z		 5291/*
5292=head1 Optree construction
5293
5294=for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
5295
5296Constructs, checks, and returns an C<lslice> (list slice) op. I<flags>
5297gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
5298be set automatically, and, shifted up eight bits, the eight bits of
5299C<op_private>, except that the bit with value 1 or 2 is automatically
5300set as required. I<listval> and I<subscript> supply the parameters of
5301the slice; they are consumed by this function and become part of the
5302constructed op tree.
5303
5304=cut
5305*/
5306
78ca652e 5307OP *
864dbfa3 5308Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
79072805
LW		 5309{
5310 return newBINOP(OP_LSLICE, flags,
8990e307
LW		 5311 list(force_list(subscript)),
5312 list(force_list(listval)) );
79072805
LW		 5313}
5314
76e3520e 5315STATIC I32
5aaab254 5316S_is_list_assignment(pTHX_ const OP *o)
79072805 5317{
1496a290
AL		 5318 unsigned type;
5319 U8 flags;
5320
11343788 5321 if (!o)
79072805
LW		 5322 return TRUE;
5323
1496a290 5324 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
11343788 5325 o = cUNOPo->op_first;
79072805 5326
1496a290
AL		 5327 flags = o->op_flags;
5328 type = o->op_type;
5329 if (type == OP_COND_EXPR) {
504618e9
AL		 5330 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
5331 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
79072805
LW		 5332
5333 if (t && f)
5334 return TRUE;
5335 if (t || f)
5336 yyerror("Assignment to both a list and a scalar");
5337 return FALSE;
5338 }
5339
1496a290
AL		 5340 if (type == OP_LIST &&
5341 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
95f0a2f1
SB		 5342 o->op_private & OPpLVAL_INTRO)
5343 return FALSE;
5344
1496a290
AL		 5345 if (type == OP_LIST || flags & OPf_PARENS ||
5346 type == OP_RV2AV || type == OP_RV2HV ||
5347 type == OP_ASLICE || type == OP_HSLICE)
79072805
LW		 5348 return TRUE;
5349
1496a290 5350 if (type == OP_PADAV || type == OP_PADHV)
93a17b20
LW		 5351 return TRUE;
5352
1496a290 5353 if (type == OP_RV2SV)
79072805
LW		 5354 return FALSE;
5355
5356 return FALSE;
5357}
5358
d67eb5f4 5359/*
83f9fced
GG		 5360 Helper function for newASSIGNOP to detection commonality between the
5361 lhs and the rhs. Marks all variables with PL_generation. If it
5362 returns TRUE the assignment must be able to handle common variables.
5363*/
5364PERL_STATIC_INLINE bool
5365S_aassign_common_vars(pTHX_ OP* o)
5366{
83f9fced 5367 OP *curop;
3023b5f3 5368 for (curop = cUNOPo->op_first; curop; curop=curop->op_sibling) {
83f9fced
GG		 5369 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
5370 if (curop->op_type == OP_GV) {
5371 GV *gv = cGVOPx_gv(curop);
5372 if (gv == PL_defgv
5373 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
5374 return TRUE;
5375 GvASSIGN_GENERATION_set(gv, PL_generation);
5376 }
5377 else if (curop->op_type == OP_PADSV ||
5378 curop->op_type == OP_PADAV ||
5379 curop->op_type == OP_PADHV ||
5380 curop->op_type == OP_PADANY)
5381 {
5382 if (PAD_COMPNAME_GEN(curop->op_targ)
5383 == (STRLEN)PL_generation)
5384 return TRUE;
5385 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
5386
5387 }
5388 else if (curop->op_type == OP_RV2CV)
5389 return TRUE;
5390 else if (curop->op_type == OP_RV2SV ||
5391 curop->op_type == OP_RV2AV ||
5392 curop->op_type == OP_RV2HV ||
5393 curop->op_type == OP_RV2GV) {
3023b5f3 5394 if (cUNOPx(curop)->op_first->op_type != OP_GV) /* funny deref? */
83f9fced
GG		 5395 return TRUE;
5396 }
5397 else if (curop->op_type == OP_PUSHRE) {
5398#ifdef USE_ITHREADS
5399 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
5400 GV *const gv = MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff));
5401 if (gv == PL_defgv
5402 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
5403 return TRUE;
5404 GvASSIGN_GENERATION_set(gv, PL_generation);
5405 }
5406#else
5407 GV *const gv
5408 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
5409 if (gv) {
5410 if (gv == PL_defgv
5411 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
5412 return TRUE;
5413 GvASSIGN_GENERATION_set(gv, PL_generation);
5414 }
5415#endif
5416 }
5417 else
5418 return TRUE;
5419 }
3023b5f3
GG		 5420
5421 if (curop->op_flags & OPf_KIDS) {
5422 if (aassign_common_vars(curop))
5423 return TRUE;
5424 }
83f9fced
GG		 5425 }
5426 return FALSE;
5427}
5428
5429/*
d67eb5f4
Z		 5430=for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
5431
5432Constructs, checks, and returns an assignment op. I<left> and I<right>
5433supply the parameters of the assignment; they are consumed by this
5434function and become part of the constructed op tree.
5435
5436If I<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
5437a suitable conditional optree is constructed. If I<optype> is the opcode
5438of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
5439performs the binary operation and assigns the result to the left argument.
5440Either way, if I<optype> is non-zero then I<flags> has no effect.
5441
5442If I<optype> is zero, then a plain scalar or list assignment is
5443constructed. Which type of assignment it is is automatically determined.
5444I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
5445will be set automatically, and, shifted up eight bits, the eight bits
5446of C<op_private>, except that the bit with value 1 or 2 is automatically
5447set as required.
5448
5449=cut
5450*/
5451
79072805 5452OP *
864dbfa3 5453Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
79072805 5454{
97aff369 5455 dVAR;
11343788 5456 OP *o;
79072805 5457
a0d0e21e 5458 if (optype) {
c963b151 5459 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
a0d0e21e 5460 return newLOGOP(optype, 0,
3ad73efd 5461 op_lvalue(scalar(left), optype),
a0d0e21e
LW		 5462 newUNOP(OP_SASSIGN, 0, scalar(right)));
5463 }
5464 else {
5465 return newBINOP(optype, OPf_STACKED,
3ad73efd 5466 op_lvalue(scalar(left), optype), scalar(right));
a0d0e21e
LW		 5467 }
5468 }
5469
504618e9 5470 if (is_list_assignment(left)) {
6dbe9451
NC		 5471 static const char no_list_state[] = "Initialization of state variables"
5472 " in list context currently forbidden";
10c8fecd 5473 OP *curop;
fafafbaf 5474 bool maybe_common_vars = TRUE;
10c8fecd 5475
3280af22 5476 PL_modcount = 0;
3ad73efd 5477 left = op_lvalue(left, OP_AASSIGN);
10c8fecd
GS		 5478 curop = list(force_list(left));
5479 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
eb160463 5480 o->op_private = (U8)(0 | (flags >> 8));
dd2155a4 5481
fafafbaf
RD		 5482 if ((left->op_type == OP_LIST
5483 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
5484 {
5485 OP* lop = ((LISTOP*)left)->op_first;
5486 maybe_common_vars = FALSE;
5487 while (lop) {
5488 if (lop->op_type == OP_PADSV ||
5489 lop->op_type == OP_PADAV ||
5490 lop->op_type == OP_PADHV ||
5491 lop->op_type == OP_PADANY) {
5492 if (!(lop->op_private & OPpLVAL_INTRO))
5493 maybe_common_vars = TRUE;
5494
5495 if (lop->op_private & OPpPAD_STATE) {
5496 if (left->op_private & OPpLVAL_INTRO) {
5497 /* Each variable in state($a, $b, $c) = ... */
5498 }
5499 else {
5500 /* Each state variable in
5501 (state $a, my $b, our $c, $d, undef) = ... */
5502 }
5503 yyerror(no_list_state);
5504 } else {
5505 /* Each my variable in
5506 (state $a, my $b, our $c, $d, undef) = ... */
5507 }
5508 } else if (lop->op_type == OP_UNDEF ||
5509 lop->op_type == OP_PUSHMARK) {
5510 /* undef may be interesting in
5511 (state $a, undef, state $c) */
5512 } else {
5513 /* Other ops in the list. */
5514 maybe_common_vars = TRUE;
5515 }
5516 lop = lop->op_sibling;
5517 }
5518 }
5519 else if ((left->op_private & OPpLVAL_INTRO)
5520 && ( left->op_type == OP_PADSV
5521 || left->op_type == OP_PADAV
5522 || left->op_type == OP_PADHV
5523 || left->op_type == OP_PADANY))
5524 {
0f907b96 5525 if (left->op_type == OP_PADSV) maybe_common_vars = FALSE;
fafafbaf
RD		 5526 if (left->op_private & OPpPAD_STATE) {
5527 /* All single variable list context state assignments, hence
5528 state ($a) = ...
5529 (state $a) = ...
5530 state @a = ...
5531 state (@a) = ...
5532 (state @a) = ...
5533 state %a = ...
5534 state (%a) = ...
5535 (state %a) = ...
5536 */
5537 yyerror(no_list_state);
5538 }
5539 }
5540
dd2155a4
DM		 5541 /* PL_generation sorcery:
5542 * an assignment like ($a,$b) = ($c,$d) is easier than
5543 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
5544 * To detect whether there are common vars, the global var
5545 * PL_generation is incremented for each assign op we compile.
5546 * Then, while compiling the assign op, we run through all the
5547 * variables on both sides of the assignment, setting a spare slot
5548 * in each of them to PL_generation. If any of them already have
5549 * that value, we know we've got commonality. We could use a
5550 * single bit marker, but then we'd have to make 2 passes, first
5551 * to clear the flag, then to test and set it. To find somewhere
931b58fb 5552 * to store these values, evil chicanery is done with SvUVX().
dd2155a4
DM		 5553 */
5554
fafafbaf 5555 if (maybe_common_vars) {
3280af22 5556 PL_generation++;
83f9fced 5557 if (aassign_common_vars(o))
10c8fecd 5558 o->op_private |= OPpASSIGN_COMMON;
3023b5f3 5559 LINKLIST(o);
461824dc 5560 }
9fdc7570 5561
e9cc17ba 5562 if (right && right->op_type == OP_SPLIT && !PL_madskills) {
1496a290
AL		 5563 OP* tmpop = ((LISTOP*)right)->op_first;
5564 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
551405c4 5565 PMOP * const pm = (PMOP*)tmpop;
c07a80fd 5566 if (left->op_type == OP_RV2AV &&
5567 !(left->op_private & OPpLVAL_INTRO) &&
11343788 5568 !(o->op_private & OPpASSIGN_COMMON) )
c07a80fd 5569 {
5570 tmpop = ((UNOP*)left)->op_first;
20e98b0f
NC		 5571 if (tmpop->op_type == OP_GV
5572#ifdef USE_ITHREADS
5573 && !pm->op_pmreplrootu.op_pmtargetoff
5574#else
5575 && !pm->op_pmreplrootu.op_pmtargetgv
5576#endif
5577 ) {
971a9dd3 5578#ifdef USE_ITHREADS
20e98b0f
NC		 5579 pm->op_pmreplrootu.op_pmtargetoff
5580 = cPADOPx(tmpop)->op_padix;
971a9dd3
GS		 5581 cPADOPx(tmpop)->op_padix = 0; /* steal it */
5582#else
20e98b0f 5583 pm->op_pmreplrootu.op_pmtargetgv
159b6efe 5584 = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
a0714e2c 5585 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
971a9dd3 5586#endif
11343788 5587 tmpop = cUNOPo->op_first; /* to list (nulled) */
c07a80fd 5588 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
5f66b61c 5589 tmpop->op_sibling = NULL; /* don't free split */
c07a80fd 5590 right->op_next = tmpop->op_next; /* fix starting loc */
11343788 5591 op_free(o); /* blow off assign */
54310121 5592 right->op_flags &= ~OPf_WANT;
a5f75d66 5593 /* "I don't know and I don't care." */
c07a80fd 5594 return right;
5595 }
5596 }
5597 else {
e6438c1a 5598 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
c07a80fd 5599 ((LISTOP*)right)->op_last->op_type == OP_CONST)
5600 {
5601 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
b8de32d5 5602 if (SvIOK(sv) && SvIVX(sv) == 0)
3280af22 5603 sv_setiv(sv, PL_modcount+1);
c07a80fd 5604 }
5605 }
5606 }
5607 }
11343788 5608 return o;
79072805
LW		 5609 }
5610 if (!right)
5611 right = newOP(OP_UNDEF, 0);
5612 if (right->op_type == OP_READLINE) {
5613 right->op_flags |= OPf_STACKED;
3ad73efd
Z		 5614 return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
5615 scalar(right));
79072805 5616 }
a0d0e21e 5617 else {
11343788 5618 o = newBINOP(OP_SASSIGN, flags,
3ad73efd 5619 scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
a0d0e21e 5620 }
11343788 5621 return o;
79072805
LW		 5622}
5623
d67eb5f4
Z		 5624/*
5625=for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
5626
5627Constructs a state op (COP). The state op is normally a C<nextstate> op,
5628but will be a C<dbstate> op if debugging is enabled for currently-compiled
5629code. The state op is populated from L</PL_curcop> (or L</PL_compiling>).
5630If I<label> is non-null, it supplies the name of a label to attach to
5631the state op; this function takes ownership of the memory pointed at by
5632I<label>, and will free it. I<flags> gives the eight bits of C<op_flags>
5633for the state op.
5634
5635If I<o> is null, the state op is returned. Otherwise the state op is
5636combined with I<o> into a C<lineseq> list op, which is returned. I<o>
5637is consumed by this function and becomes part of the returned op tree.
5638
5639=cut
5640*/
5641
79072805 5642OP *
864dbfa3 5643Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
79072805 5644{
27da23d5 5645 dVAR;
e1ec3a88 5646 const U32 seq = intro_my();
5db1eb8d 5647 const U32 utf8 = flags & SVf_UTF8;
eb578fdb 5648 COP *cop;
79072805 5649
5db1eb8d
BF		 5650 flags &= ~SVf_UTF8;
5651
b7dc083c 5652 NewOp(1101, cop, 1, COP);
57843af0 5653 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
8990e307 5654 cop->op_type = OP_DBSTATE;
22c35a8c 5655 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
8990e307
LW		 5656 }
5657 else {
5658 cop->op_type = OP_NEXTSTATE;
22c35a8c 5659 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
8990e307 5660 }
eb160463 5661 cop->op_flags = (U8)flags;
623e6609 5662 CopHINTS_set(cop, PL_hints);
ff0cee69 5663#ifdef NATIVE_HINTS
5664 cop->op_private |= NATIVE_HINTS;
5665#endif
623e6609 5666 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
79072805
LW		 5667 cop->op_next = (OP*)cop;
5668
bbce6d69 5669 cop->cop_seq = seq;
72dc9ed5 5670 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
20439bc7 5671 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
dca6062a 5672 if (label) {
5db1eb8d
BF		 5673 Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
5674
dca6062a
NC		 5675 PL_hints |= HINT_BLOCK_SCOPE;
5676 /* It seems that we need to defer freeing this pointer, as other parts
5677 of the grammar end up wanting to copy it after this op has been
5678 created. */
5679 SAVEFREEPV(label);
dca6062a 5680 }
79072805 5681
53a7735b 5682 if (PL_parser && PL_parser->copline == NOLINE)
57843af0 5683 CopLINE_set(cop, CopLINE(PL_curcop));
79072805 5684 else {
53a7735b 5685 CopLINE_set(cop, PL_parser->copline);
4b1709c8 5686 PL_parser->copline = NOLINE;
79072805 5687 }
57843af0 5688#ifdef USE_ITHREADS
f4dd75d9 5689 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
57843af0 5690#else
f4dd75d9 5691 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
57843af0 5692#endif
11faa288 5693 CopSTASH_set(cop, PL_curstash);
79072805 5694
65269a95
TB		 5695 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) {
5696 /* this line can have a breakpoint - store the cop in IV */
80a702cd
RGS		 5697 AV *av = CopFILEAVx(PL_curcop);
5698 if (av) {
5699 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
5700 if (svp && *svp != &PL_sv_undef ) {
5701 (void)SvIOK_on(*svp);
5702 SvIV_set(*svp, PTR2IV(cop));
5703 }
1eb1540c 5704 }
93a17b20
LW		 5705 }
5706
f6f3a1fe
RGS		 5707 if (flags & OPf_SPECIAL)
5708 op_null((OP*)cop);
2fcb4757 5709 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
79072805
LW		 5710}
5711
d67eb5f4
Z		 5712/*
5713=for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
5714
5715Constructs, checks, and returns a logical (flow control) op. I<type>
5716is the opcode. I<flags> gives the eight bits of C<op_flags>, except
5717that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
5718the eight bits of C<op_private>, except that the bit with value 1 is
5719automatically set. I<first> supplies the expression controlling the
5720flow, and I<other> supplies the side (alternate) chain of ops; they are
5721consumed by this function and become part of the constructed op tree.
5722
5723=cut
5724*/
bbce6d69 5725
79072805 5726OP *
864dbfa3 5727Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
79072805 5728{
27da23d5 5729 dVAR;
7918f24d
NC		 5730
5731 PERL_ARGS_ASSERT_NEWLOGOP;
5732
883ffac3
CS		 5733 return new_logop(type, flags, &first, &other);
5734}
5735
3bd495df 5736STATIC OP *
71c4dbc3
VP		 5737S_search_const(pTHX_ OP *o)
5738{
5739 PERL_ARGS_ASSERT_SEARCH_CONST;
5740
5741 switch (o->op_type) {
5742 case OP_CONST:
5743 return o;
5744 case OP_NULL:
5745 if (o->op_flags & OPf_KIDS)
5746 return search_const(cUNOPo->op_first);
5747 break;
5748 case OP_LEAVE:
5749 case OP_SCOPE:
5750 case OP_LINESEQ:
5751 {
5752 OP *kid;
5753 if (!(o->op_flags & OPf_KIDS))
5754 return NULL;
5755 kid = cLISTOPo->op_first;
5756 do {
5757 switch (kid->op_type) {
5758 case OP_ENTER:
5759 case OP_NULL:
5760 case OP_NEXTSTATE:
5761 kid = kid->op_sibling;
5762 break;
5763 default:
5764 if (kid != cLISTOPo->op_last)
5765 return NULL;
5766 goto last;
5767 }
5768 } while (kid);
5769 if (!kid)
5770 kid = cLISTOPo->op_last;
5771last:
5772 return search_const(kid);
5773 }
5774 }
5775
5776 return NULL;
5777}
5778
5779STATIC OP *
cea2e8a9 5780S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
883ffac3 5781{
27da23d5 5782 dVAR;
79072805 5783 LOGOP *logop;
11343788 5784 OP *o;
71c4dbc3
VP		 5785 OP *first;
5786 OP *other;
5787 OP *cstop = NULL;
edbe35ea 5788 int prepend_not = 0;
79072805 5789
7918f24d
NC		 5790 PERL_ARGS_ASSERT_NEW_LOGOP;
5791
71c4dbc3
VP		 5792 first = *firstp;
5793 other = *otherp;
5794
a0d0e21e
LW		 5795 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
5796 return newBINOP(type, flags, scalar(first), scalar(other));
5797
e69777c1
GG		 5798 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP);
5799
8990e307 5800 scalarboolean(first);
edbe35ea 5801 /* optimize AND and OR ops that have NOTs as children */
68726e16 5802 if (first->op_type == OP_NOT
b6214b80 5803 && (first->op_flags & OPf_KIDS)
edbe35ea
VP		 5804 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
5805 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
b6214b80 5806 && !PL_madskills) {
79072805
LW		 5807 if (type == OP_AND || type == OP_OR) {
5808 if (type == OP_AND)
5809 type = OP_OR;
5810 else
5811 type = OP_AND;
07f3cdf5 5812 op_null(first);
edbe35ea 5813 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
07f3cdf5 5814 op_null(other);
edbe35ea
VP		 5815 prepend_not = 1; /* prepend a NOT op later */
5816 }
79072805
LW		 5817 }
5818 }
71c4dbc3
VP		 5819 /* search for a constant op that could let us fold the test */
5820 if ((cstop = search_const(first))) {
5821 if (cstop->op_private & OPpCONST_STRICT)
5822 no_bareword_allowed(cstop);
a2a5de95
NC		 5823 else if ((cstop->op_private & OPpCONST_BARE))
5824 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
71c4dbc3
VP		 5825 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
5826 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
5827 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
5f66b61c 5828 *firstp = NULL;
d6fee5c7
DM		 5829 if (other->op_type == OP_CONST)
5830 other->op_private |= OPpCONST_SHORTCIRCUIT;
eb8433b7
NC		 5831 if (PL_madskills) {
5832 OP *newop = newUNOP(OP_NULL, 0, other);
5833 op_getmad(first, newop, '1');
5834 newop->op_targ = type; /* set "was" field */
5835 return newop;
5836 }
5837 op_free(first);
dd3e51dc
VP		 5838 if (other->op_type == OP_LEAVE)
5839 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
2474a784
FC		 5840 else if (other->op_type == OP_MATCH
5841 || other->op_type == OP_SUBST
bb16bae8 5842 || other->op_type == OP_TRANSR
2474a784
FC		 5843 || other->op_type == OP_TRANS)
5844 /* Mark the op as being unbindable with =~ */
5845 other->op_flags |= OPf_SPECIAL;
cc2ebcd7
FC		 5846 else if (other->op_type == OP_CONST)
5847 other->op_private |= OPpCONST_FOLDED;
79072805
LW		 5848 return other;
5849 }
5850 else {
7921d0f2 5851 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
6867be6d 5852 const OP *o2 = other;
7921d0f2
DM		 5853 if ( ! (o2->op_type == OP_LIST
5854 && (( o2 = cUNOPx(o2)->op_first))
5855 && o2->op_type == OP_PUSHMARK
5856 && (( o2 = o2->op_sibling)) )
5857 )
5858 o2 = other;
5859 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
5860 || o2->op_type == OP_PADHV)
5861 && o2->op_private & OPpLVAL_INTRO
a2a5de95 5862 && !(o2->op_private & OPpPAD_STATE))
7921d0f2 5863 {
d1d15184
NC		 5864 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
5865 "Deprecated use of my() in false conditional");
7921d0f2
DM		 5866 }
5867
5f66b61c 5868 *otherp = NULL;
d6fee5c7
DM		 5869 if (first->op_type == OP_CONST)
5870 first->op_private |= OPpCONST_SHORTCIRCUIT;
eb8433b7
NC		 5871 if (PL_madskills) {
5872 first = newUNOP(OP_NULL, 0, first);
5873 op_getmad(other, first, '2');
5874 first->op_targ = type; /* set "was" field */
5875 }
5876 else
5877 op_free(other);
79072805
LW		 5878 return first;
5879 }
5880 }
041457d9
DM		 5881 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
5882 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
59e10468 5883 {
b22e6366
AL		 5884 const OP * const k1 = ((UNOP*)first)->op_first;
5885 const OP * const k2 = k1->op_sibling;
a6006777 5886 OPCODE warnop = 0;
5887 switch (first->op_type)
5888 {
5889 case OP_NULL:
5890 if (k2 && k2->op_type == OP_READLINE
5891 && (k2->op_flags & OPf_STACKED)
1c846c1f 5892 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
72b16652 5893 {
a6006777 5894 warnop = k2->op_type;
72b16652 5895 }
a6006777 5896 break;
5897
5898 case OP_SASSIGN:
68dc0745 5899 if (k1->op_type == OP_READDIR
5900 || k1->op_type == OP_GLOB
72b16652 5901 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
459b64da
HY		 5902 || k1->op_type == OP_EACH
5903 || k1->op_type == OP_AEACH)
72b16652
GS		 5904 {
5905 warnop = ((k1->op_type == OP_NULL)
eb160463 5906 ? (OPCODE)k1->op_targ : k1->op_type);
72b16652 5907 }
a6006777 5908 break;
5909 }
8ebc5c01 5910 if (warnop) {
6867be6d 5911 const line_t oldline = CopLINE(PL_curcop);
502e5101
NC		 5912 /* This ensures that warnings are reported at the first line
5913 of the construction, not the last. */
53a7735b 5914 CopLINE_set(PL_curcop, PL_parser->copline);
9014280d 5915 Perl_warner(aTHX_ packWARN(WARN_MISC),
599cee73 5916 "Value of %s%s can be \"0\"; test with defined()",
22c35a8c 5917 PL_op_desc[warnop],
68dc0745 5918 ((warnop == OP_READLINE || warnop == OP_GLOB)
5919 ? " construct" : "() operator"));
57843af0 5920 CopLINE_set(PL_curcop, oldline);
8ebc5c01 5921 }
a6006777 5922 }
79072805
LW		 5923
5924 if (!other)
5925 return first;
5926
c963b151 5927 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
a0d0e21e
LW		 5928 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
5929
b7dc083c 5930 NewOp(1101, logop, 1, LOGOP);
79072805 5931
eb160463 5932 logop->op_type = (OPCODE)type;
22c35a8c 5933 logop->op_ppaddr = PL_ppaddr[type];
79072805 5934 logop->op_first = first;
585ec06d 5935 logop->op_flags = (U8)(flags | OPf_KIDS);
79072805 5936 logop->op_other = LINKLIST(other);
eb160463 5937 logop->op_private = (U8)(1 | (flags >> 8));
79072805
LW		 5938
5939 /* establish postfix order */
5940 logop->op_next = LINKLIST(first);
5941 first->op_next = (OP*)logop;
5942 first->op_sibling = other;
5943
463d09e6
RGS		 5944 CHECKOP(type,logop);
5945
edbe35ea 5946 o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
11343788 5947 other->op_next = o;
79072805 5948
11343788 5949 return o;
79072805
LW		 5950}
5951
d67eb5f4
Z		 5952/*
5953=for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
5954
5955Constructs, checks, and returns a conditional-expression (C<cond_expr>)
5956op. I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
5957will be set automatically, and, shifted up eight bits, the eight bits of
5958C<op_private>, except that the bit with value 1 is automatically set.
5959I<first> supplies the expression selecting between the two branches,
5960and I<trueop> and I<falseop> supply the branches; they are consumed by
5961this function and become part of the constructed op tree.
5962
5963=cut
5964*/
5965
79072805 5966OP *
864dbfa3 5967Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
79072805 5968{
27da23d5 5969 dVAR;
1a67a97c
SM		 5970 LOGOP *logop;
5971 OP *start;
11343788 5972 OP *o;
71c4dbc3 5973 OP *cstop;
79072805 5974
7918f24d
NC		 5975 PERL_ARGS_ASSERT_NEWCONDOP;
5976
b1cb66bf 5977 if (!falseop)
5978 return newLOGOP(OP_AND, 0, first, trueop);
5979 if (!trueop)
5980 return newLOGOP(OP_OR, 0, first, falseop);
79072805 5981
8990e307 5982 scalarboolean(first);
71c4dbc3 5983 if ((cstop = search_const(first))) {
5b6782b2 5984 /* Left or right arm of the conditional? */
71c4dbc3 5985 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
5b6782b2
NC		 5986 OP *live = left ? trueop : falseop;
5987 OP *const dead = left ? falseop : trueop;
71c4dbc3
VP		 5988 if (cstop->op_private & OPpCONST_BARE &&
5989 cstop->op_private & OPpCONST_STRICT) {
5990 no_bareword_allowed(cstop);
b22e6366 5991 }
5b6782b2
NC		 5992 if (PL_madskills) {
5993 /* This is all dead code when PERL_MAD is not defined. */
5994 live = newUNOP(OP_NULL, 0, live);
5995 op_getmad(first, live, 'C');
5996 op_getmad(dead, live, left ? 'e' : 't');
5997 } else {
5998 op_free(first);
5999 op_free(dead);
79072805 6000 }
ef9da979
FC		 6001 if (live->op_type == OP_LEAVE)
6002 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
2474a784 6003 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
bb16bae8 6004 || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
2474a784
FC		 6005 /* Mark the op as being unbindable with =~ */
6006 live->op_flags |= OPf_SPECIAL;
cc2ebcd7
FC		 6007 else if (live->op_type == OP_CONST)
6008 live->op_private |= OPpCONST_FOLDED;
5b6782b2 6009 return live;
79072805 6010 }
1a67a97c
SM		 6011 NewOp(1101, logop, 1, LOGOP);
6012 logop->op_type = OP_COND_EXPR;
6013 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
6014 logop->op_first = first;
585ec06d 6015 logop->op_flags = (U8)(flags | OPf_KIDS);
eb160463 6016 logop->op_private = (U8)(1 | (flags >> 8));
1a67a97c
SM		 6017 logop->op_other = LINKLIST(trueop);
6018 logop->op_next = LINKLIST(falseop);
79072805 6019
463d09e6
RGS		 6020 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
6021 logop);
79072805
LW		 6022
6023 /* establish postfix order */
1a67a97c
SM		 6024 start = LINKLIST(first);
6025 first->op_next = (OP*)logop;
79072805 6026
b1cb66bf 6027 first->op_sibling = trueop;
6028 trueop->op_sibling = falseop;
1a67a97c 6029 o = newUNOP(OP_NULL, 0, (OP*)logop);
79072805 6030
1a67a97c 6031 trueop->op_next = falseop->op_next = o;
79072805 6032
1a67a97c 6033 o->op_next = start;
11343788 6034 return o;
79072805
LW		 6035}
6036
d67eb5f4
Z		 6037/*
6038=for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
6039
6040Constructs and returns a C<range> op, with subordinate C<flip> and
6041C<flop> ops. I<flags> gives the eight bits of C<op_flags> for the
6042C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
6043for both the C<flip> and C<range> ops, except that the bit with value
60441 is automatically set. I<left> and I<right> supply the expressions
6045controlling the endpoints of the range; they are consumed by this function
6046and become part of the constructed op tree.
6047
6048=cut
6049*/
6050
79072805 6051OP *
864dbfa3 6052Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
79072805 6053{
27da23d5 6054 dVAR;
1a67a97c 6055 LOGOP *range;
79072805
LW		 6056 OP *flip;
6057 OP *flop;
1a67a97c 6058 OP *leftstart;
11343788 6059 OP *o;
79072805 6060
7918f24d
NC		 6061 PERL_ARGS_ASSERT_NEWRANGE;
6062
1a67a97c 6063 NewOp(1101, range, 1, LOGOP);
79072805 6064
1a67a97c
SM		 6065 range->op_type = OP_RANGE;
6066 range->op_ppaddr = PL_ppaddr[OP_RANGE];
6067 range->op_first = left;
6068 range->op_flags = OPf_KIDS;
6069 leftstart = LINKLIST(left);
6070 range->op_other = LINKLIST(right);
eb160463 6071 range->op_private = (U8)(1 | (flags >> 8));
79072805
LW		 6072
6073 left->op_sibling = right;
6074
1a67a97c
SM		 6075 range->op_next = (OP*)range;
6076 flip = newUNOP(OP_FLIP, flags, (OP*)range);
79072805 6077 flop = newUNOP(OP_FLOP, 0, flip);
11343788 6078 o = newUNOP(OP_NULL, 0, flop);
5983a79d 6079 LINKLIST(flop);
1a67a97c 6080 range->op_next = leftstart;
79072805
LW		 6081
6082 left->op_next = flip;
6083 right->op_next = flop;
6084
1a67a97c
SM		 6085 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
6086 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
ed6116ce 6087 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
79072805
LW		 6088 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
6089
6090 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
6091 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
6092
eb796c7f
GG		 6093 /* check barewords before they might be optimized aways */
6094 if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
6095 no_bareword_allowed(left);
6096 if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
6097 no_bareword_allowed(right);
6098
11343788 6099 flip->op_next = o;
79072805 6100 if (!flip->op_private || !flop->op_private)
5983a79d 6101 LINKLIST(o); /* blow off optimizer unless constant */
79072805 6102
11343788 6103 return o;
79072805
LW		 6104}
6105
d67eb5f4
Z		 6106/*
6107=for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
6108
6109Constructs, checks, and returns an op tree expressing a loop. This is
6110only a loop in the control flow through the op tree; it does not have
6111the heavyweight loop structure that allows exiting the loop by C<last>
6112and suchlike. I<flags> gives the eight bits of C<op_flags> for the
6113top-level op, except that some bits will be set automatically as required.
6114I<expr> supplies the expression controlling loop iteration, and I<block>
6115supplies the body of the loop; they are consumed by this function and
6116become part of the constructed op tree. I<debuggable> is currently
6117unused and should always be 1.
6118
6119=cut
6120*/
6121
79072805 6122OP *
864dbfa3 6123Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
79072805 6124{
97aff369 6125 dVAR;
463ee0b2 6126 OP* listop;
11343788 6127 OP* o;
73d840c0 6128 const bool once = block && block->op_flags & OPf_SPECIAL &&
a0d0e21e 6129 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
46c461b5
AL		 6130
6131 PERL_UNUSED_ARG(debuggable);
93a17b20 6132
463ee0b2
LW		 6133 if (expr) {
6134 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
6135 return block; /* do {} while 0 does once */
114c60ec
BG		 6136 if (expr->op_type == OP_READLINE
6137 || expr->op_type == OP_READDIR
6138 || expr->op_type == OP_GLOB
8ae39f60 6139 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
fb73857a 6140 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
774d564b 6141 expr = newUNOP(OP_DEFINED, 0,
54b9620d 6142 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
55d729e4 6143 } else if (expr->op_flags & OPf_KIDS) {
46c461b5
AL		 6144 const OP * const k1 = ((UNOP*)expr)->op_first;
6145 const OP * const k2 = k1 ? k1->op_sibling : NULL;
55d729e4 6146 switch (expr->op_type) {
1c846c1f 6147 case OP_NULL:
114c60ec 6148 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
55d729e4 6149 && (k2->op_flags & OPf_STACKED)
1c846c1f 6150 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
55d729e4 6151 expr = newUNOP(OP_DEFINED, 0, expr);
1c846c1f 6152 break;
55d729e4
GS		 6153
6154 case OP_SASSIGN:
06dc7ac6 6155 if (k1 && (k1->op_type == OP_READDIR
55d729e4 6156 || k1->op_type == OP_GLOB
6531c3e6 6157 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
459b64da
HY		 6158 || k1->op_type == OP_EACH
6159 || k1->op_type == OP_AEACH))
55d729e4
GS		 6160 expr = newUNOP(OP_DEFINED, 0, expr);
6161 break;
6162 }
774d564b 6163 }
463ee0b2 6164 }
93a17b20 6165
2fcb4757 6166 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
e1548254
RGS		 6167 * op, in listop. This is wrong. [perl #27024] */
6168 if (!block)
6169 block = newOP(OP_NULL, 0);
2fcb4757 6170 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
883ffac3 6171 o = new_logop(OP_AND, 0, &expr, &listop);
463ee0b2 6172
883ffac3
CS		 6173 if (listop)
6174 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
79072805 6175
11343788
MB		 6176 if (once && o != listop)
6177 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
79072805 6178
11343788
MB		 6179 if (o == listop)
6180 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
748a9306 6181
11343788 6182 o->op_flags |= flags;
3ad73efd 6183 o = op_scope(o);
11343788
MB		 6184 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
6185 return o;
79072805
LW		 6186}
6187
d67eb5f4 6188/*
94bf0465 6189=for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
d67eb5f4
Z		 6190
6191Constructs, checks, and returns an op tree expressing a C<while> loop.
6192This is a heavyweight loop, with structure that allows exiting the loop
6193by C<last> and suchlike.
6194
6195I<loop> is an optional preconstructed C<enterloop> op to use in the
6196loop; if it is null then a suitable op will be constructed automatically.
6197I<expr> supplies the loop's controlling expression. I<block> supplies the
6198main body of the loop, and I<cont> optionally supplies a C<continue> block
6199that operates as a second half of the body. All of these optree inputs
6200are consumed by this function and become part of the constructed op tree.
6201
6202I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
6203op and, shifted up eight bits, the eight bits of C<op_private> for
6204the C<leaveloop> op, except that (in both cases) some bits will be set
6205automatically. I<debuggable> is currently unused and should always be 1.
94bf0465 6206I<has_my> can be supplied as true to force the
d67eb5f4
Z		 6207loop body to be enclosed in its own scope.
6208
6209=cut
6210*/
6211
79072805 6212OP *
94bf0465
Z		 6213Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
6214 OP *expr, OP *block, OP *cont, I32 has_my)
79072805 6215{
27da23d5 6216 dVAR;
79072805 6217 OP *redo;
c445ea15 6218 OP *next = NULL;
79072805 6219 OP *listop;
11343788 6220 OP *o;
1ba6ee2b 6221 U8 loopflags = 0;
46c461b5
AL		 6222
6223 PERL_UNUSED_ARG(debuggable);
79072805 6224
2d03de9c 6225 if (expr) {
114c60ec
BG		 6226 if (expr->op_type == OP_READLINE
6227 || expr->op_type == OP_READDIR
6228 || expr->op_type == OP_GLOB
8ae39f60 6229 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
2d03de9c
AL		 6230 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
6231 expr = newUNOP(OP_DEFINED, 0,
6232 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
6233 } else if (expr->op_flags & OPf_KIDS) {
6234 const OP * const k1 = ((UNOP*)expr)->op_first;
6235 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
6236 switch (expr->op_type) {
6237 case OP_NULL:
114c60ec 6238 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
2d03de9c
AL		 6239 && (k2->op_flags & OPf_STACKED)
6240 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
6241 expr = newUNOP(OP_DEFINED, 0, expr);
6242 break;
55d729e4 6243
2d03de9c 6244 case OP_SASSIGN:
72c8de1a 6245 if (k1 && (k1->op_type == OP_READDIR
2d03de9c
AL		 6246 || k1->op_type == OP_GLOB
6247 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
459b64da
HY		 6248 || k1->op_type == OP_EACH
6249 || k1->op_type == OP_AEACH))
2d03de9c
AL		 6250 expr = newUNOP(OP_DEFINED, 0, expr);
6251 break;
6252 }
55d729e4 6253 }
748a9306 6254 }
79072805
LW		 6255
6256 if (!block)
6257 block = newOP(OP_NULL, 0);
a034e688 6258 else if (cont || has_my) {
3ad73efd 6259 block = op_scope(block);
87246558 6260 }
79072805 6261
1ba6ee2b 6262 if (cont) {
79072805 6263 next = LINKLIST(cont);
1ba6ee2b 6264 }
fb73857a 6265 if (expr) {
551405c4 6266 OP * const unstack = newOP(OP_UNSTACK, 0);
85538317
GS		 6267 if (!next)
6268 next = unstack;
2fcb4757 6269 cont = op_append_elem(OP_LINESEQ, cont, unstack);
fb73857a 6270 }
79072805 6271
ce3e5c45 6272 assert(block);
2fcb4757 6273 listop = op_append_list(OP_LINESEQ, block, cont);
ce3e5c45 6274 assert(listop);
79072805
LW		 6275 redo = LINKLIST(listop);
6276
6277 if (expr) {
883ffac3
CS		 6278 scalar(listop);
6279 o = new_logop(OP_AND, 0, &expr, &listop);
11343788 6280 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
463ee0b2 6281 op_free((OP*)loop);
317f3b66 6282 return expr; /* listop already freed by new_logop */
463ee0b2 6283 }
883ffac3 6284 if (listop)
497b47a8 6285 ((LISTOP*)listop)->op_last->op_next =
883ffac3 6286 (o == listop ? redo : LINKLIST(o));
79072805
LW		 6287 }
6288 else
11343788 6289 o = listop;
79072805
LW		 6290
6291 if (!loop) {
b7dc083c 6292 NewOp(1101,loop,1,LOOP);
79072805 6293 loop->op_type = OP_ENTERLOOP;
22c35a8c 6294 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
79072805
LW		 6295 loop->op_private = 0;
6296 loop->op_next = (OP*)loop;
6297 }
6298
11343788 6299 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
79072805
LW		 6300
6301 loop->op_redoop = redo;
11343788 6302 loop->op_lastop = o;
1ba6ee2b 6303 o->op_private |= loopflags;
79072805
LW		 6304
6305 if (next)
6306 loop->op_nextop = next;
6307 else
11343788 6308 loop->op_nextop = o;
79072805 6309
11343788
MB		 6310 o->op_flags |= flags;
6311 o->op_private |= (flags >> 8);
6312 return o;
79072805
LW		 6313}
6314
d67eb5f4 6315/*
94bf0465 6316=for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
d67eb5f4
Z		 6317
6318Constructs, checks, and returns an op tree expressing a C<foreach>
6319loop (iteration through a list of values). This is a heavyweight loop,
6320with structure that allows exiting the loop by C<last> and suchlike.
6321
6322I<sv> optionally supplies the variable that will be aliased to each
6323item in turn; if null, it defaults to C<$_> (either lexical or global).
6324I<expr> supplies the list of values to iterate over. I<block> supplies
6325the main body of the loop, and I<cont> optionally supplies a C<continue>
6326block that operates as a second half of the body. All of these optree
6327inputs are consumed by this function and become part of the constructed
6328op tree.
6329
6330I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
6331op and, shifted up eight bits, the eight bits of C<op_private> for
6332the C<leaveloop> op, except that (in both cases) some bits will be set
94bf0465 6333automatically.
d67eb5f4
Z		 6334
6335=cut
6336*/
6337
79072805 6338OP *
94bf0465 6339Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
79072805 6340{
27da23d5 6341 dVAR;
79072805 6342 LOOP *loop;
fb73857a 6343 OP *wop;
4bbc6d12 6344 PADOFFSET padoff = 0;
4633a7c4 6345 I32 iterflags = 0;
241416b8 6346 I32 iterpflags = 0;
d4c19fe8 6347 OP *madsv = NULL;
79072805 6348
7918f24d
NC		 6349 PERL_ARGS_ASSERT_NEWFOROP;
6350
79072805 6351 if (sv) {
85e6fe83 6352 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
241416b8 6353 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
748a9306 6354 sv->op_type = OP_RV2GV;
22c35a8c 6355 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
0be9a6bb
RH		 6356
6357 /* The op_type check is needed to prevent a possible segfault
6358 * if the loop variable is undeclared and 'strict vars' is in
6359 * effect. This is illegal but is nonetheless parsed, so we
6360 * may reach this point with an OP_CONST where we're expecting
6361 * an OP_GV.
6362 */
6363 if (cUNOPx(sv)->op_first->op_type == OP_GV
6364 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
0d863452 6365 iterpflags |= OPpITER_DEF;
79072805 6366 }
85e6fe83 6367 else if (sv->op_type == OP_PADSV) { /* private variable */
241416b8 6368 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
85e6fe83 6369 padoff = sv->op_targ;
eb8433b7
NC		 6370 if (PL_madskills)
6371 madsv = sv;
6372 else {
6373 sv->op_targ = 0;
6374 op_free(sv);
6375 }
5f66b61c 6376 sv = NULL;
85e6fe83 6377 }
79072805 6378 else
cea2e8a9 6379 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
f8503592
NC		 6380 if (padoff) {
6381 SV *const namesv = PAD_COMPNAME_SV(padoff);
6382 STRLEN len;
6383 const char *const name = SvPV_const(namesv, len);
6384
6385 if (len == 2 && name[0] == '$' && name[1] == '_')
6386 iterpflags |= OPpITER_DEF;
6387 }
79072805
LW		 6388 }
6389 else {
cc76b5cc 6390 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
00b1698f 6391 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
aabe9514
RGS		 6392 sv = newGVOP(OP_GV, 0, PL_defgv);
6393 }
6394 else {
6395 padoff = offset;
aabe9514 6396 }
0d863452 6397 iterpflags |= OPpITER_DEF;
79072805 6398 }
5f05dabc 6399 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3ad73efd 6400 expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4633a7c4
LW		 6401 iterflags |= OPf_STACKED;
6402 }
89ea2908
GA		 6403 else if (expr->op_type == OP_NULL &&
6404 (expr->op_flags & OPf_KIDS) &&
6405 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
6406 {
6407 /* Basically turn for($x..$y) into the same as for($x,$y), but we
6408 * set the STACKED flag to indicate that these values are to be
08bf00be 6409 * treated as min/max values by 'pp_enteriter'.
89ea2908 6410 */
d4c19fe8 6411 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
551405c4 6412 LOGOP* const range = (LOGOP*) flip->op_first;
66a1b24b
AL		 6413 OP* const left = range->op_first;
6414 OP* const right = left->op_sibling;
5152d7c7 6415 LISTOP* listop;
89ea2908
GA		 6416
6417 range->op_flags &= ~OPf_KIDS;
5f66b61c 6418 range->op_first = NULL;
89ea2908 6419
5152d7c7 6420 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
1a67a97c
SM		 6421 listop->op_first->op_next = range->op_next;
6422 left->op_next = range->op_other;
5152d7c7
GS		 6423 right->op_next = (OP*)listop;
6424 listop->op_next = listop->op_first;
89ea2908 6425
eb8433b7
NC		 6426#ifdef PERL_MAD
6427 op_getmad(expr,(OP*)listop,'O');
6428#else
89ea2908 6429 op_free(expr);
eb8433b7 6430#endif
5152d7c7 6431 expr = (OP*)(listop);
93c66552 6432 op_null(expr);
89ea2908
GA		 6433 iterflags |= OPf_STACKED;
6434 }
6435 else {
3ad73efd 6436 expr = op_lvalue(force_list(expr), OP_GREPSTART);
89ea2908
GA		 6437 }
6438
4633a7c4 6439 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
2fcb4757 6440 op_append_elem(OP_LIST, expr, scalar(sv))));
85e6fe83 6441 assert(!loop->op_next);
241416b8 6442 /* for my $x () sets OPpLVAL_INTRO;
14f338dc 6443 * for our $x () sets OPpOUR_INTRO */
c5661c80 6444 loop->op_private = (U8)iterpflags;
b448305b
FC		 6445 if (loop->op_slabbed
6446 && DIFF(loop, OpSLOT(loop)->opslot_next)
8be227ab 6447 < SIZE_TO_PSIZE(sizeof(LOOP)))
155aba94
GS		 6448 {
6449 LOOP *tmp;
6450 NewOp(1234,tmp,1,LOOP);
bd5f3bc4 6451 Copy(loop,tmp,1,LISTOP);
bfafaa29 6452 S_op_destroy(aTHX_ (OP*)loop);
155aba94
GS		 6453 loop = tmp;
6454 }
b448305b
FC		 6455 else if (!loop->op_slabbed)
6456 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
85e6fe83 6457 loop->op_targ = padoff;
94bf0465 6458 wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
eb8433b7
NC		 6459 if (madsv)
6460 op_getmad(madsv, (OP*)loop, 'v');
eae48c89 6461 return wop;
79072805
LW		 6462}
6463
d67eb5f4
Z		 6464/*
6465=for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
6466
6467Constructs, checks, and returns a loop-exiting op (such as C<goto>
6468or C<last>). I<type> is the opcode. I<label> supplies the parameter
6469determining the target of the op; it is consumed by this function and
d001e19d 6470becomes part of the constructed op tree.
d67eb5f4
Z		 6471
6472=cut
6473*/
6474
8990e307 6475OP*
864dbfa3 6476Perl_newLOOPEX(pTHX_ I32 type, OP *label)
8990e307 6477{
97aff369 6478 dVAR;
1ec4f607 6479 OP *o = NULL;
2d8e6c8d 6480
7918f24d
NC		 6481 PERL_ARGS_ASSERT_NEWLOOPEX;
6482
e69777c1
GG		 6483 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
6484
3532f34a 6485 if (type != OP_GOTO) {
cdaebead 6486 /* "last()" means "last" */
1f039d60 6487 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
cdaebead 6488 o = newOP(type, OPf_SPECIAL);
cdaebead 6489 }
8990e307
LW		 6490 }
6491 else {
e3aba57a
RGS		 6492 /* Check whether it's going to be a goto &function */
6493 if (label->op_type == OP_ENTERSUB
6494 && !(label->op_flags & OPf_STACKED))
3ad73efd 6495 label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
1f039d60
FC		 6496 }
6497
6498 /* Check for a constant argument */
6499 if (label->op_type == OP_CONST) {
3532f34a
FC		 6500 SV * const sv = ((SVOP *)label)->op_sv;
6501 STRLEN l;
6502 const char *s = SvPV_const(sv,l);
1f039d60
FC		 6503 if (l == strlen(s)) {
6504 o = newPVOP(type,
6505 SvUTF8(((SVOP*)label)->op_sv),
6506 savesharedpv(
6507 SvPV_nolen_const(((SVOP*)label)->op_sv)));
1ec4f607
FC		 6508 }
6509 }
6510
6511 /* If we have already created an op, we do not need the label. */
6512 if (o)
1f039d60
FC		 6513#ifdef PERL_MAD
6514 op_getmad(label,o,'L');
6515#else
6516 op_free(label);
6517#endif
1ec4f607 6518 else o = newUNOP(type, OPf_STACKED, label);
1f039d60 6519
3280af22 6520 PL_hints |= HINT_BLOCK_SCOPE;
11343788 6521 return o;
8990e307
LW		 6522}
6523
0d863452
RH		 6524/* if the condition is a literal array or hash
6525 (or @{ ... } etc), make a reference to it.
6526 */
6527STATIC OP *
6528S_ref_array_or_hash(pTHX_ OP *cond)
6529{
6530 if (cond
6531 && (cond->op_type == OP_RV2AV
6532 || cond->op_type == OP_PADAV
6533 || cond->op_type == OP_RV2HV
6534 || cond->op_type == OP_PADHV))
6535
3ad73efd 6536 return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
0d863452 6537
329a333e
DL		 6538 else if(cond
6539 && (cond->op_type == OP_ASLICE
6540 || cond->op_type == OP_HSLICE)) {
6541
6542 /* anonlist now needs a list from this op, was previously used in
6543 * scalar context */
6544 cond->op_flags |= ~(OPf_WANT_SCALAR | OPf_REF);
6545 cond->op_flags |= OPf_WANT_LIST;
6546
3ad73efd 6547 return newANONLIST(op_lvalue(cond, OP_ANONLIST));
329a333e
DL		 6548 }
6549
0d863452
RH		 6550 else
6551 return cond;
6552}
6553
6554/* These construct the optree fragments representing given()
6555 and when() blocks.
6556
6557 entergiven and enterwhen are LOGOPs; the op_other pointer
6558 points up to the associated leave op. We need this so we
6559 can put it in the context and make break/continue work.
6560 (Also, of course, pp_enterwhen will jump straight to
6561 op_other if the match fails.)
6562 */
6563
4136a0f7 6564STATIC OP *
0d863452
RH		 6565S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
6566 I32 enter_opcode, I32 leave_opcode,
6567 PADOFFSET entertarg)
6568{
97aff369 6569 dVAR;
0d863452
RH		 6570 LOGOP *enterop;
6571 OP *o;
6572
7918f24d
NC		 6573 PERL_ARGS_ASSERT_NEWGIVWHENOP;
6574
0d863452 6575 NewOp(1101, enterop, 1, LOGOP);
61a59f30 6576 enterop->op_type = (Optype)enter_opcode;
0d863452
RH		 6577 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
6578 enterop->op_flags = (U8) OPf_KIDS;
6579 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
6580 enterop->op_private = 0;
6581
6582 o = newUNOP(leave_opcode, 0, (OP *) enterop);
6583
6584 if (cond) {
6585 enterop->op_first = scalar(cond);
6586 cond->op_sibling = block;
6587
6588 o->op_next = LINKLIST(cond);
6589 cond->op_next = (OP *) enterop;
6590 }
6591 else {
6592 /* This is a default {} block */
6593 enterop->op_first = block;
6594 enterop->op_flags |= OPf_SPECIAL;
fc7debfb 6595 o ->op_flags |= OPf_SPECIAL;
0d863452
RH		 6596
6597 o->op_next = (OP *) enterop;
6598 }
6599
6600 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
6601 entergiven and enterwhen both
6602 use ck_null() */
6603
6604 enterop->op_next = LINKLIST(block);
6605 block->op_next = enterop->op_other = o;
6606
6607 return o;
6608}
6609
6610/* Does this look like a boolean operation? For these purposes
6611 a boolean operation is:
6612 - a subroutine call [*]
6613 - a logical connective
6614 - a comparison operator
6615 - a filetest operator, with the exception of -s -M -A -C
6616 - defined(), exists() or eof()
6617 - /$re/ or $foo =~ /$re/
6618
6619 [*] possibly surprising
6620 */
4136a0f7 6621STATIC bool
ef519e13 6622S_looks_like_bool(pTHX_ const OP *o)
0d863452 6623{
97aff369 6624 dVAR;
7918f24d
NC		 6625
6626 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
6627
0d863452
RH		 6628 switch(o->op_type) {
6629 case OP_OR:
f92e1a16 6630 case OP_DOR:
0d863452
RH		 6631 return looks_like_bool(cLOGOPo->op_first);
6632
6633 case OP_AND:
6634 return (
6635 looks_like_bool(cLOGOPo->op_first)
6636 && looks_like_bool(cLOGOPo->op_first->op_sibling));
6637
1e1d4b91 6638 case OP_NULL:
08fe1c44 6639 case OP_SCALAR:
1e1d4b91
JJ		 6640 return (
6641 o->op_flags & OPf_KIDS
6642 && looks_like_bool(cUNOPo->op_first));
6643
0d863452
RH		 6644 case OP_ENTERSUB:
6645
6646 case OP_NOT: case OP_XOR:
0d863452
RH		 6647
6648 case OP_EQ: case OP_NE: case OP_LT:
6649 case OP_GT: case OP_LE: case OP_GE:
6650
6651 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
6652 case OP_I_GT: case OP_I_LE: case OP_I_GE:
6653
6654 case OP_SEQ: case OP_SNE: case OP_SLT:
6655 case OP_SGT: case OP_SLE: case OP_SGE:
6656
6657 case OP_SMARTMATCH:
6658
6659 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
6660 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
6661 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
6662 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
6663 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
6664 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
6665 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
6666 case OP_FTTEXT: case OP_FTBINARY:
6667
6668 case OP_DEFINED: case OP_EXISTS:
6669 case OP_MATCH: case OP_EOF:
6670
f118ea0d
RGS		 6671 case OP_FLOP:
6672
0d863452
RH		 6673 return TRUE;
6674
6675 case OP_CONST:
6676 /* Detect comparisons that have been optimized away */
6677 if (cSVOPo->op_sv == &PL_sv_yes
6678 || cSVOPo->op_sv == &PL_sv_no)
6679
6680 return TRUE;
6e03d743
RGS		 6681 else
6682 return FALSE;
6e03d743 6683
0d863452
RH		 6684 /* FALL THROUGH */
6685 default:
6686 return FALSE;
6687 }
6688}
6689
d67eb5f4
Z		 6690/*
6691=for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
6692
6693Constructs, checks, and returns an op tree expressing a C<given> block.
6694I<cond> supplies the expression that will be locally assigned to a lexical
6695variable, and I<block> supplies the body of the C<given> construct; they
6696are consumed by this function and become part of the constructed op tree.
6697I<defsv_off> is the pad offset of the scalar lexical variable that will
a8bd1c84 6698be affected. If it is 0, the global $_ will be used.
d67eb5f4
Z		 6699
6700=cut
6701*/
6702
0d863452
RH		 6703OP *
6704Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
6705{
97aff369 6706 dVAR;
7918f24d 6707 PERL_ARGS_ASSERT_NEWGIVENOP;
0d863452
RH		 6708 return newGIVWHENOP(
6709 ref_array_or_hash(cond),
6710 block,
6711 OP_ENTERGIVEN, OP_LEAVEGIVEN,
6712 defsv_off);
6713}
6714
d67eb5f4
Z		 6715/*
6716=for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
6717
6718Constructs, checks, and returns an op tree expressing a C<when> block.
6719I<cond> supplies the test expression, and I<block> supplies the block
6720that will be executed if the test evaluates to true; they are consumed
6721by this function and become part of the constructed op tree. I<cond>
6722will be interpreted DWIMically, often as a comparison against C<$_>,
6723and may be null to generate a C<default> block.
6724
6725=cut
6726*/
6727
0d863452
RH		 6728OP *
6729Perl_newWHENOP(pTHX_ OP *cond, OP *block)
6730{
ef519e13 6731 const bool cond_llb = (!cond || looks_like_bool(cond));
0d863452
RH		 6732 OP *cond_op;
6733
7918f24d
NC		 6734 PERL_ARGS_ASSERT_NEWWHENOP;
6735
0d863452
RH		 6736 if (cond_llb)
6737 cond_op = cond;
6738 else {
6739 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
6740 newDEFSVOP(),
6741 scalar(ref_array_or_hash(cond)));
6742 }
6743
c08f093b 6744 return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
0d863452
RH		 6745}
6746
3fe9a6f1 6747void
dab1c735
BF		 6748Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
6749 const STRLEN len, const U32 flags)
cbf82dd0 6750{
105ff74c 6751 const char * const cvp = SvROK(cv) ? "" : CvPROTO(cv);
8fa6a409
FC		 6752 const STRLEN clen = CvPROTOLEN(cv);
6753
dab1c735 6754 PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
8fa6a409
FC		 6755
6756 if (((!p != !cvp) /* One has prototype, one has not. */
6757 || (p && (
6758 (flags & SVf_UTF8) == SvUTF8(cv)
6759 ? len != clen || memNE(cvp, p, len)
6760 : flags & SVf_UTF8
6761 ? bytes_cmp_utf8((const U8 *)cvp, clen,
6762 (const U8 *)p, len)
6763 : bytes_cmp_utf8((const U8 *)p, len,
6764 (const U8 *)cvp, clen)
6765 )
6766 )
6767 )
cbf82dd0 6768 && ckWARN_d(WARN_PROTOTYPE)) {
2d03de9c 6769 SV* const msg = sv_newmortal();
a0714e2c 6770 SV* name = NULL;
3fe9a6f1 6771
6772 if (gv)
105ff74c
FC		 6773 {
6774 if (isGV(gv))
bd61b366 6775 gv_efullname3(name = sv_newmortal(), gv, NULL);
a56613a9
FC		 6776 else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
6777 name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1,
6778 SvUTF8(gv)|SVs_TEMP);
105ff74c
FC		 6779 else name = (SV *)gv;
6780 }
6502358f 6781 sv_setpvs(msg, "Prototype mismatch:");
46fc3d4c 6782 if (name)
be2597df 6783 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
105ff74c 6784 if (cvp)
8fa6a409
FC		 6785 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")",
6786 SVfARG(newSVpvn_flags(cvp,clen, SvUTF8(cv)|SVs_TEMP))
6787 );
ebe643b9 6788 else
396482e1
GA		 6789 sv_catpvs(msg, ": none");
6790 sv_catpvs(msg, " vs ");
46fc3d4c 6791 if (p)
dab1c735 6792 Perl_sv_catpvf(aTHX_ msg, "(%"SVf")", SVfARG(newSVpvn_flags(p, len, flags | SVs_TEMP)));
46fc3d4c 6793 else
396482e1 6794 sv_catpvs(msg, "none");
be2597df 6795 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
3fe9a6f1 6796 }
6797}
6798
35f1c1c7
SB		 6799static void const_sv_xsub(pTHX_ CV* cv);
6800
beab0874 6801/*
ccfc67b7
JH		 6802
6803=head1 Optree Manipulation Functions
6804
beab0874
JT		 6805=for apidoc cv_const_sv
6806
6807If C<cv> is a constant sub eligible for inlining. returns the constant
6808value returned by the sub. Otherwise, returns NULL.
6809
6810Constant subs can be created with C<newCONSTSUB> or as described in
6811L<perlsub/"Constant Functions">.
6812
6813=cut
6814*/
760ac839 6815SV *
d45f5b30 6816Perl_cv_const_sv(pTHX_ const CV *const cv)
760ac839 6817{
96a5add6 6818 PERL_UNUSED_CONTEXT;
5069cc75
NC		 6819 if (!cv)
6820 return NULL;
6821 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
6822 return NULL;
ad64d0ec 6823 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
fe5e78ed 6824}
760ac839 6825
b5c19bd7
DM		 6826/* op_const_sv: examine an optree to determine whether it's in-lineable.
6827 * Can be called in 3 ways:
6828 *
6829 * !cv
6830 * look for a single OP_CONST with attached value: return the value
6831 *
6832 * cv && CvCLONE(cv) && !CvCONST(cv)
6833 *
6834 * examine the clone prototype, and if contains only a single
6835 * OP_CONST referencing a pad const, or a single PADSV referencing
6836 * an outer lexical, return a non-zero value to indicate the CV is
6837 * a candidate for "constizing" at clone time
6838 *
6839 * cv && CvCONST(cv)
6840 *
6841 * We have just cloned an anon prototype that was marked as a const
486ec47a 6842 * candidate. Try to grab the current value, and in the case of
be8851fc
NC		 6843 * PADSV, ignore it if it has multiple references. In this case we
6844 * return a newly created *copy* of the value.
b5c19bd7
DM		 6845 */
6846
fe5e78ed 6847SV *
6867be6d 6848Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
fe5e78ed 6849{
97aff369 6850 dVAR;
a0714e2c 6851 SV *sv = NULL;
fe5e78ed 6852
c631f32b
GG		 6853 if (PL_madskills)
6854 return NULL;
6855
0f79a09d 6856 if (!o)
a0714e2c 6857 return NULL;
1c846c1f
NIS		 6858
6859 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
fe5e78ed
GS		 6860 o = cLISTOPo->op_first->op_sibling;
6861
6862 for (; o; o = o->op_next) {
890ce7af 6863 const OPCODE type = o->op_type;
fe5e78ed 6864
1c846c1f 6865 if (sv && o->op_next == o)
fe5e78ed 6866 return sv;
e576b457 6867 if (o->op_next != o) {
dbe92b04
FC		 6868 if (type == OP_NEXTSTATE
6869 || (type == OP_NULL && !(o->op_flags & OPf_KIDS))
6870 || type == OP_PUSHMARK)
e576b457
JT		 6871 continue;
6872 if (type == OP_DBSTATE)
6873 continue;
6874 }
54310121 6875 if (type == OP_LEAVESUB || type == OP_RETURN)
6876 break;
6877 if (sv)
a0714e2c 6878 return NULL;
7766f137 6879 if (type == OP_CONST && cSVOPo->op_sv)
5dc0d613 6880 sv = cSVOPo->op_sv;
b5c19bd7 6881 else if (cv && type == OP_CONST) {
dd2155a4 6882 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
beab0874 6883 if (!sv)
a0714e2c 6884 return NULL;
b5c19bd7
DM		 6885 }
6886 else if (cv && type == OP_PADSV) {
6887 if (CvCONST(cv)) { /* newly cloned anon */
6888 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
6889 /* the candidate should have 1 ref from this pad and 1 ref
6890 * from the parent */
6891 if (!sv || SvREFCNT(sv) != 2)
a0714e2c 6892 return NULL;
beab0874 6893 sv = newSVsv(sv);
b5c19bd7
DM		 6894 SvREADONLY_on(sv);
6895 return sv;
6896 }
6897 else {
6898 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
6899 sv = &PL_sv_undef; /* an arbitrary non-null value */
beab0874 6900 }
760ac839 6901 }
b5c19bd7 6902 else {
a0714e2c 6903 return NULL;
b5c19bd7 6904 }
760ac839
LW		 6905 }
6906 return sv;
6907}
6908
2b141370
FC		 6909static bool
6910S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
6911 PADNAME * const name, SV ** const const_svp)
6912{
6913 assert (cv);
6914 assert (o || name);
6915 assert (const_svp);
6916 if ((!block
6917#ifdef PERL_MAD
6918 || block->op_type == OP_NULL
6919#endif
6920 )) {
6921 if (CvFLAGS(PL_compcv)) {
6922 /* might have had built-in attrs applied */
6923 const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
6924 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
6925 && ckWARN(WARN_MISC))
6926 {
6927 /* protect against fatal warnings leaking compcv */
6928 SAVEFREESV(PL_compcv);
6929 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
6930 SvREFCNT_inc_simple_void_NN(PL_compcv);
6931 }
6932 CvFLAGS(cv) |=
6933 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
6934 & ~(CVf_LVALUE * pureperl));
6935 }
6936 return FALSE;
6937 }
6938
6939 /* redundant check for speed: */
6940 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
6941 const line_t oldline = CopLINE(PL_curcop);
6942 SV *namesv = o
6943 ? cSVOPo->op_sv
6944 : sv_2mortal(newSVpvn_utf8(
6945 PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name)
6946 ));
6947 if (PL_parser && PL_parser->copline != NOLINE)
6948 /* This ensures that warnings are reported at the first
6949 line of a redefinition, not the last. */
6950 CopLINE_set(PL_curcop, PL_parser->copline);
d0761305
FC		 6951 /* protect against fatal warnings leaking compcv */
6952 SAVEFREESV(PL_compcv);
2b141370 6953 report_redefined_cv(namesv, cv, const_svp);
d0761305 6954 SvREFCNT_inc_simple_void_NN(PL_compcv);
2b141370
FC		 6955 CopLINE_set(PL_curcop, oldline);
6956 }
6957#ifdef PERL_MAD
6958 if (!PL_minus_c) /* keep old one around for madskills */
6959#endif
6960 {
6961 /* (PL_madskills unset in used file.) */
6962 SvREFCNT_dec(cv);
6963 }
6964 return TRUE;
6965}
6966
50278755 6967CV *
09bef843
SB		 6968Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
6969{
50278755 6970 dVAR;
50278755
FC		 6971 CV **spot;
6972 SV **svspot;
6973 const char *ps;
6974 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
6975 U32 ps_utf8 = 0;
5aaab254
KW		 6976 CV *cv = NULL;
6977 CV *compcv = PL_compcv;
50278755 6978 SV *const_sv;
50278755 6979 PADNAME *name;
10342479
FC		 6980 PADOFFSET pax = o->op_targ;
6981 CV *outcv = CvOUTSIDE(PL_compcv);
a70c2d56 6982 CV *clonee = NULL;
6d5c2147 6983 HEK *hek = NULL;
a70c2d56 6984 bool reusable = FALSE;
50278755
FC		 6985
6986 PERL_ARGS_ASSERT_NEWMYSUB;
6987
10342479
FC		 6988 /* Find the pad slot for storing the new sub.
6989 We cannot use PL_comppad, as it is the pad owned by the new sub. We
6990 need to look in CvOUTSIDE and find the pad belonging to the enclos-
6991 ing sub. And then we need to dig deeper if this is a lexical from
6992 outside, as in:
6993 my sub foo; sub { sub foo { } }
6994 */
6995 redo:
6996 name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
6997 if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
6998 pax = PARENT_PAD_INDEX(name);
6999 outcv = CvOUTSIDE(outcv);
7000 assert(outcv);
7001 goto redo;
7002 }
2435fbd5 7003 svspot =
a70c2d56
FC		 7004 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
7005 [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
50278755
FC		 7006 spot = (CV **)svspot;
7007
7008 if (proto) {
7009 assert(proto->op_type == OP_CONST);
7010 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
7011 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
7012 }
7013 else
7014 ps = NULL;
7015
50278755 7016 if (!PL_madskills) {
50278755
FC		 7017 if (proto)
7018 SAVEFREEOP(proto);
7019 if (attrs)
7020 SAVEFREEOP(attrs);
7021 }
7022
b0305fa3 7023 if (PL_parser && PL_parser->error_count) {
50278755 7024 op_free(block);
8ca8859f
FC		 7025 SvREFCNT_dec(PL_compcv);
7026 PL_compcv = 0;
50278755
FC		 7027 goto done;
7028 }
7029
a70c2d56
FC		 7030 if (CvDEPTH(outcv) && CvCLONE(compcv)) {
7031 cv = *spot;
7032 svspot = (SV **)(spot = &clonee);
7033 }
7034 else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
6d5c2147
FC		 7035 cv = *spot;
7036 else {
7037 MAGIC *mg;
81df9f6f
FC		 7038 SvUPGRADE(name, SVt_PVMG);
7039 mg = mg_find(name, PERL_MAGIC_proto);
6d5c2147 7040 assert (SvTYPE(*spot) == SVt_PVCV);
6d5c2147
FC		 7041 if (CvNAMED(*spot))
7042 hek = CvNAME_HEK(*spot);
7043 else {
2e800d79 7044 CvNAME_HEK_set(*spot, hek =
6d5c2147
FC		 7045 share_hek(
7046 PadnamePV(name)+1,
7047 PadnameLEN(name)-1 * (PadnameUTF8(name) ? -1 : 1), 0
2e800d79
FC		 7048 )
7049 );
6d5c2147 7050 }
6d5c2147
FC		 7051 if (mg) {
7052 assert(mg->mg_obj);
7053 cv = (CV *)mg->mg_obj;
7054 }
7055 else {
81df9f6f
FC		 7056 sv_magic(name, &PL_sv_undef, PERL_MAGIC_proto, NULL, 0);
7057 mg = mg_find(name, PERL_MAGIC_proto);
6d5c2147
FC		 7058 }
7059 spot = (CV **)(svspot = &mg->mg_obj);
50278755
FC		 7060 }
7061
50278755
FC		 7062 if (!block || !ps || *ps || attrs
7063 || (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS)
7064#ifdef PERL_MAD
7065 || block->op_type == OP_NULL
eb8433b7 7066#endif
50278755
FC		 7067 )
7068 const_sv = NULL;
7069 else
7070 const_sv = op_const_sv(block, NULL);
eb8433b7 7071
50278755
FC		 7072 if (cv) {
7073 const bool exists = CvROOT(cv) || CvXSUB(cv);
46c461b5 7074
50278755
FC		 7075 /* if the subroutine doesn't exist and wasn't pre-declared
7076 * with a prototype, assume it will be AUTOLOADed,
7077 * skipping the prototype check
7078 */
7079 if (exists || SvPOK(cv))
2435fbd5 7080 cv_ckproto_len_flags(cv, (GV *)name, ps, ps_len, ps_utf8);
50278755
FC		 7081 /* already defined? */
7082 if (exists) {
2b141370
FC		 7083 if (S_already_defined(aTHX_ cv, block, NULL, name, &const_sv))
7084 cv = NULL;
7085 else {
50278755
FC		 7086 if (attrs) goto attrs;
7087 /* just a "sub foo;" when &foo is already defined */
7088 SAVEFREESV(compcv);
7089 goto done;
7090 }
50278755 7091 }
a70c2d56
FC		 7092 else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
7093 cv = NULL;
7094 reusable = TRUE;
7095 }
50278755
FC		 7096 }
7097 if (const_sv) {
7098 SvREFCNT_inc_simple_void_NN(const_sv);
7099 if (cv) {
7100 assert(!CvROOT(cv) && !CvCONST(cv));
7101 cv_forget_slab(cv);
7102 }
7103 else {
7104 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
7105 CvFILE_set_from_cop(cv, PL_curcop);
7106 CvSTASH_set(cv, PL_curstash);
7107 *spot = cv;
7108 }
7109 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
7110 CvXSUBANY(cv).any_ptr = const_sv;
7111 CvXSUB(cv) = const_sv_xsub;
7112 CvCONST_on(cv);
7113 CvISXSUB_on(cv);
7114 if (PL_madskills)
7115 goto install_block;
7116 op_free(block);
7117 SvREFCNT_dec(compcv);
2435fbd5 7118 PL_compcv = NULL;
a70c2d56 7119 goto clone;
50278755 7120 }
1f122f9b
FC		 7121 /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
7122 determine whether this sub definition is in the same scope as its
7123 declaration. If this sub definition is inside an inner named pack-
7124 age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
7125 the package sub. So check PadnameOUTER(name) too.
7126 */
7127 if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
10342479
FC		 7128 assert(!CvWEAKOUTSIDE(compcv));
7129 SvREFCNT_dec(CvOUTSIDE(compcv));
7130 CvWEAKOUTSIDE_on(compcv);
7131 }
7132 /* XXX else do we have a circular reference? */
50278755
FC		 7133 if (cv) { /* must reuse cv in case stub is referenced elsewhere */
7134 /* transfer PL_compcv to cv */
7135 if (block
eb8433b7 7136#ifdef PERL_MAD
50278755 7137 && block->op_type != OP_NULL
eb8433b7 7138#endif
50278755 7139 ) {
6d5c2147
FC		 7140 cv_flags_t preserved_flags =
7141 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
50278755
FC		 7142 PADLIST *const temp_padl = CvPADLIST(cv);
7143 CV *const temp_cv = CvOUTSIDE(cv);
10342479
FC		 7144 const cv_flags_t other_flags =
7145 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
50278755
FC		 7146 OP * const cvstart = CvSTART(cv);
7147
50278755
FC		 7148 SvPOK_off(cv);
7149 CvFLAGS(cv) =
6d5c2147 7150 CvFLAGS(compcv) | preserved_flags;
50278755
FC		 7151 CvOUTSIDE(cv) = CvOUTSIDE(compcv);
7152 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
7153 CvPADLIST(cv) = CvPADLIST(compcv);
7154 CvOUTSIDE(compcv) = temp_cv;
7155 CvPADLIST(compcv) = temp_padl;
7156 CvSTART(cv) = CvSTART(compcv);
7157 CvSTART(compcv) = cvstart;
10342479
FC		 7158 CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
7159 CvFLAGS(compcv) |= other_flags;
50278755
FC		 7160
7161 if (CvFILE(cv) && CvDYNFILE(cv)) {
7162 Safefree(CvFILE(cv));
7163 }
7164
7165 /* inner references to compcv must be fixed up ... */
7166 pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
7167 if (PERLDB_INTER)/* Advice debugger on the new sub. */
7168 ++PL_sub_generation;
7169 }
7170 else {
7171 /* Might have had built-in attributes applied -- propagate them. */
7172 CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
7173 }
7174 /* ... before we throw it away */
7175 SvREFCNT_dec(compcv);
2435fbd5 7176 PL_compcv = compcv = cv;
50278755
FC		 7177 }
7178 else {
7179 cv = compcv;
7180 *spot = cv;
6d5c2147
FC		 7181 }
7182 if (!CvNAME_HEK(cv)) {
2e800d79 7183 CvNAME_HEK_set(cv,
6d5c2147
FC		 7184 hek
7185 ? share_hek_hek(hek)
7186 : share_hek(PadnamePV(name)+1,
2435fbd5 7187 PadnameLEN(name)-1 * (PadnameUTF8(name) ? -1 : 1),
2e800d79
FC		 7188 0)
7189 );
50278755
FC		 7190 }
7191 CvFILE_set_from_cop(cv, PL_curcop);
7192 CvSTASH_set(cv, PL_curstash);
7193
7194 if (ps) {
7195 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
7196 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
7197 }
7198
7199 install_block:
7200 if (!block)
7201 goto attrs;
7202
7203 /* If we assign an optree to a PVCV, then we've defined a subroutine that
7204 the debugger could be able to set a breakpoint in, so signal to
7205 pp_entereval that it should not throw away any saved lines at scope
7206 exit. */
7207
7208 PL_breakable_sub_gen++;
7209 /* This makes sub {}; work as expected. */
7210 if (block->op_type == OP_STUB) {
7211 OP* const newblock = newSTATEOP(0, NULL, 0);
7212#ifdef PERL_MAD
7213 op_getmad(block,newblock,'B');
7214#else
7215 op_free(block);
7216#endif
7217 block = newblock;
7218 }
7219 CvROOT(cv) = CvLVALUE(cv)
7220 ? newUNOP(OP_LEAVESUBLV, 0,
7221 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
7222 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
7223 CvROOT(cv)->op_private |= OPpREFCOUNTED;
7224 OpREFCNT_set(CvROOT(cv), 1);
7225 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
7226 itself has a refcount. */
7227 CvSLABBED_off(cv);
7228 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
7229 CvSTART(cv) = LINKLIST(CvROOT(cv));
7230 CvROOT(cv)->op_next = 0;
7231 CALL_PEEP(CvSTART(cv));
7232 finalize_optree(CvROOT(cv));
7233
7234 /* now that optimizer has done its work, adjust pad values */
7235
50278755 7236 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
50278755
FC		 7237
7238 if (CvCLONE(cv)) {
7239 assert(!CvCONST(cv));
7240 if (ps && !*ps && op_const_sv(block, cv))
7241 CvCONST_on(cv);
7242 }
7243
7244 attrs:
7245 if (attrs) {
7246 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
ad0dc73b 7247 apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
50278755
FC		 7248 }
7249
7250 if (block) {
7251 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
7252 SV * const tmpstr = sv_newmortal();
7253 GV * const db_postponed = gv_fetchpvs("DB::postponed",
7254 GV_ADDMULTI, SVt_PVHV);
7255 HV *hv;
7256 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
7257 CopFILE(PL_curcop),
7258 (long)PL_subline,
7259 (long)CopLINE(PL_curcop));
a56613a9
FC		 7260 if (HvNAME_HEK(PL_curstash)) {
7261 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
7262 sv_catpvs(tmpstr, "::");
7263 }
7264 else sv_setpvs(tmpstr, "__ANON__::");
2435fbd5
FC		 7265 sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
7266 PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
50278755
FC		 7267 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
7268 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
7269 hv = GvHVn(db_postponed);
7270 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
7271 CV * const pcv = GvCV(db_postponed);
7272 if (pcv) {
7273 dSP;
7274 PUSHMARK(SP);
7275 XPUSHs(tmpstr);
7276 PUTBACK;
7277 call_sv(MUTABLE_SV(pcv), G_DISCARD);
7278 }
7279 }
7280 }
7281 }
7282
a70c2d56
FC		 7283 clone:
7284 if (clonee) {
7285 assert(CvDEPTH(outcv));
7286 spot = (CV **)
7287 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
7288 if (reusable) cv_clone_into(clonee, *spot);
7289 else *spot = cv_clone(clonee);
fc2b2dca 7290 SvREFCNT_dec_NN(clonee);
a70c2d56
FC		 7291 cv = *spot;
7292 SvPADMY_on(cv);
7293 }
7294 if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
7295 PADOFFSET depth = CvDEPTH(outcv);
7296 while (--depth) {
7297 SV *oldcv;
7298 svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
7299 oldcv = *svspot;
7300 *svspot = SvREFCNT_inc_simple_NN(cv);
7301 SvREFCNT_dec(oldcv);
7302 }
7303 }
7304
50278755
FC		 7305 done:
7306 if (PL_parser)
7307 PL_parser->copline = NOLINE;
2435fbd5
FC		 7308 LEAVE_SCOPE(floor);
7309 if (o) op_free(o);
50278755 7310 return cv;
09bef843
SB		 7311}
7312
748a9306 7313CV *
09bef843
SB		 7314Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
7315{
7e68c38b
FC		 7316 return newATTRSUB_flags(floor, o, proto, attrs, block, 0);
7317}
7318
7319CV *
7320Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
7321 OP *block, U32 flags)
7322{
27da23d5 7323 dVAR;
83ee9e09 7324 GV *gv;
5c144d81 7325 const char *ps;
52a9a866 7326 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
e0260a5b 7327 U32 ps_utf8 = 0;
eb578fdb 7328 CV *cv = NULL;
beab0874 7329 SV *const_sv;
a73ef99b 7330 const bool ec = PL_parser && PL_parser->error_count;
b48b272a
NC		 7331 /* If the subroutine has no body, no attributes, and no builtin attributes
7332 then it's just a sub declaration, and we may be able to get away with
7333 storing with a placeholder scalar in the symbol table, rather than a
7334 full GV and CV. If anything is present then it will take a full CV to
7335 store it. */
7336 const I32 gv_fetch_flags
a73ef99b
FC		 7337 = ec ? GV_NOADD_NOINIT :
7338 (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
eb8433b7 7339 || PL_madskills)
b48b272a 7340 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
6e948d54 7341 STRLEN namlen = 0;
7e68c38b
FC		 7342 const bool o_is_gv = flags & 1;
7343 const char * const name =
7344 o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
ed4a8a9b 7345 bool has_name;
7e68c38b 7346 bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
7aef8e5b 7347#ifdef PERL_DEBUG_READONLY_OPS
3107b51f
FC		 7348 OPSLAB *slab = NULL;
7349#endif
8e742a20
MHM		 7350
7351 if (proto) {
7352 assert(proto->op_type == OP_CONST);
4ea561bc 7353 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
e0260a5b 7354 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
8e742a20
MHM		 7355 }
7356 else
bd61b366 7357 ps = NULL;
8e742a20 7358
7e68c38b
FC		 7359 if (o_is_gv) {
7360 gv = (GV*)o;
7361 o = NULL;
7362 has_name = TRUE;
7363 } else if (name) {
7364 gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
ed4a8a9b
NC		 7365 has_name = TRUE;
7366 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
aec46f14 7367 SV * const sv = sv_newmortal();
c99da370
JH		 7368 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
7369 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
83ee9e09 7370 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
ed4a8a9b
NC		 7371 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
7372 has_name = TRUE;
c1754fce
NC		 7373 } else if (PL_curstash) {
7374 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
ed4a8a9b 7375 has_name = FALSE;
c1754fce
NC		 7376 } else {
7377 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
ed4a8a9b 7378 has_name = FALSE;
c1754fce 7379 }
83ee9e09 7380
eb8433b7
NC		 7381 if (!PL_madskills) {
7382 if (o)
7383 SAVEFREEOP(o);
7384 if (proto)
7385 SAVEFREEOP(proto);
7386 if (attrs)
7387 SAVEFREEOP(attrs);
7388 }
3fe9a6f1 7389
a73ef99b
FC		 7390 if (ec) {
7391 op_free(block);
4d2dfd15
FC		 7392 if (name) SvREFCNT_dec(PL_compcv);
7393 else cv = PL_compcv;
9ffcdca1 7394 PL_compcv = 0;
a73ef99b
FC		 7395 if (name && block) {
7396 const char *s = strrchr(name, ':');
7397 s = s ? s+1 : name;
7398 if (strEQ(s, "BEGIN")) {
a73ef99b 7399 if (PL_in_eval & EVAL_KEEPERR)
eed484f9 7400 Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
a73ef99b 7401 else {
eed484f9 7402 SV * const errsv = ERRSV;
a73ef99b 7403 /* force display of errors found but not reported */
eed484f9
DD		 7404 sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
7405 Perl_croak_nocontext("%"SVf, SVfARG(errsv));
a73ef99b
FC		 7406 }
7407 }
7408 }
a73ef99b
FC		 7409 goto done;
7410 }
7411
09bef843 7412 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
55d729e4
GS		 7413 maximum a prototype before. */
7414 if (SvTYPE(gv) > SVt_NULL) {
105ff74c
FC		 7415 cv_ckproto_len_flags((const CV *)gv,
7416 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
7417 ps_len, ps_utf8);
55d729e4 7418 }
e0260a5b 7419 if (ps) {
ad64d0ec 7420 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
e0260a5b
BF		 7421 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(gv));
7422 }
55d729e4 7423 else
ad64d0ec 7424 sv_setiv(MUTABLE_SV(gv), -1);
e1a479c5 7425
3280af22
NIS		 7426 SvREFCNT_dec(PL_compcv);
7427 cv = PL_compcv = NULL;
beab0874 7428 goto done;
55d729e4
GS		 7429 }
7430
601f1833 7431 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
beab0874 7432
eb8433b7
NC		 7433 if (!block || !ps || *ps || attrs
7434 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
7435#ifdef PERL_MAD
7436 || block->op_type == OP_NULL
7437#endif
7438 )
a0714e2c 7439 const_sv = NULL;
beab0874 7440 else
601f1833 7441 const_sv = op_const_sv(block, NULL);
beab0874
JT		 7442
7443 if (cv) {
6867be6d 7444 const bool exists = CvROOT(cv) || CvXSUB(cv);
5bd07a3d 7445
60ed1d8c
GS		 7446 /* if the subroutine doesn't exist and wasn't pre-declared
7447 * with a prototype, assume it will be AUTOLOADed,
7448 * skipping the prototype check
7449 */
7450 if (exists || SvPOK(cv))
dab1c735 7451 cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
68dc0745 7452 /* already defined (or promised)? */
60ed1d8c 7453 if (exists || GvASSUMECV(gv)) {
2b141370
FC		 7454 if (S_already_defined(aTHX_ cv, block, o, NULL, &const_sv))
7455 cv = NULL;
7456 else {
fff96ff7 7457 if (attrs) goto attrs;
aa689395 7458 /* just a "sub foo;" when &foo is already defined */
3280af22 7459 SAVEFREESV(PL_compcv);
aa689395 7460 goto done;
7461 }
79072805
LW		 7462 }
7463 }
beab0874 7464 if (const_sv) {
f84c484e 7465 SvREFCNT_inc_simple_void_NN(const_sv);
beab0874 7466 if (cv) {
0768512c 7467 assert(!CvROOT(cv) && !CvCONST(cv));
8be227ab 7468 cv_forget_slab(cv);
ad64d0ec 7469 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
beab0874
JT		 7470 CvXSUBANY(cv).any_ptr = const_sv;
7471 CvXSUB(cv) = const_sv_xsub;
7472 CvCONST_on(cv);
d04ba589 7473 CvISXSUB_on(cv);
beab0874
JT		 7474 }
7475 else {
c43ae56f 7476 GvCV_set(gv, NULL);
9c0a6090 7477 cv = newCONSTSUB_flags(
6e948d54 7478 NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
9c0a6090
FC		 7479 const_sv
7480 );
7ad40bcb 7481 }
eb8433b7
NC		 7482 if (PL_madskills)
7483 goto install_block;
beab0874
JT		 7484 op_free(block);
7485 SvREFCNT_dec(PL_compcv);
7486 PL_compcv = NULL;
beab0874
JT		 7487 goto done;
7488 }
09330df8
Z		 7489 if (cv) { /* must reuse cv if autoloaded */
7490 /* transfer PL_compcv to cv */
7491 if (block
eb8433b7 7492#ifdef PERL_MAD
09330df8 7493 && block->op_type != OP_NULL
eb8433b7 7494#endif
09330df8 7495 ) {
eac910c8 7496 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
b70d5558 7497 PADLIST *const temp_av = CvPADLIST(cv);
437388a9 7498 CV *const temp_cv = CvOUTSIDE(cv);
e52de15a
FC		 7499 const cv_flags_t other_flags =
7500 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
8be227ab 7501 OP * const cvstart = CvSTART(cv);
437388a9 7502
f6894bc8 7503 CvGV_set(cv,gv);
437388a9
NC		 7504 assert(!CvCVGV_RC(cv));
7505 assert(CvGV(cv) == gv);
7506
7507 SvPOK_off(cv);
eac910c8 7508 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs;
09330df8
Z		 7509 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
7510 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
09330df8 7511 CvPADLIST(cv) = CvPADLIST(PL_compcv);
437388a9
NC		 7512 CvOUTSIDE(PL_compcv) = temp_cv;
7513 CvPADLIST(PL_compcv) = temp_av;
8be227ab
FC		 7514 CvSTART(cv) = CvSTART(PL_compcv);
7515 CvSTART(PL_compcv) = cvstart;
e52de15a
FC		 7516 CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
7517 CvFLAGS(PL_compcv) |= other_flags;
437388a9 7518
bad4ae38 7519 if (CvFILE(cv) && CvDYNFILE(cv)) {
437388a9
NC		 7520 Safefree(CvFILE(cv));
7521 }
437388a9
NC		 7522 CvFILE_set_from_cop(cv, PL_curcop);
7523 CvSTASH_set(cv, PL_curstash);
7524
09330df8
Z		 7525 /* inner references to PL_compcv must be fixed up ... */
7526 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
7527 if (PERLDB_INTER)/* Advice debugger on the new sub. */
7528 ++PL_sub_generation;
09bef843
SB		 7529 }
7530 else {
09330df8
Z		 7531 /* Might have had built-in attributes applied -- propagate them. */
7532 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
09bef843 7533 }
282f25c9 7534 /* ... before we throw it away */
3280af22 7535 SvREFCNT_dec(PL_compcv);
b5c19bd7 7536 PL_compcv = cv;
a0d0e21e
LW		 7537 }
7538 else {
3280af22 7539 cv = PL_compcv;
44a8e56a 7540 if (name) {
c43ae56f 7541 GvCV_set(gv, cv);
44a8e56a 7542 GvCVGEN(gv) = 0;
03d9f026
FC		 7543 if (HvENAME_HEK(GvSTASH(gv)))
7544 /* sub Foo::bar { (shift)+1 } */
978a498e 7545 gv_method_changed(gv);
44a8e56a 7546 }
a0d0e21e 7547 }
09330df8 7548 if (!CvGV(cv)) {
b3f91e91 7549 CvGV_set(cv, gv);
09330df8 7550 CvFILE_set_from_cop(cv, PL_curcop);
c68d9564 7551 CvSTASH_set(cv, PL_curstash);
09330df8 7552 }
8990e307 7553
e0260a5b 7554 if (ps) {
ad64d0ec 7555 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
e0260a5b
BF		 7556 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
7557 }
4633a7c4 7558
eb8433b7 7559 install_block:
beab0874 7560 if (!block)
fb834abd 7561 goto attrs;
a0d0e21e 7562
aac018bb
NC		 7563 /* If we assign an optree to a PVCV, then we've defined a subroutine that
7564 the debugger could be able to set a breakpoint in, so signal to
7565 pp_entereval that it should not throw away any saved lines at scope
7566 exit. */
7567
fd06b02c 7568 PL_breakable_sub_gen++;
69b22cd1
FC		 7569 /* This makes sub {}; work as expected. */
7570 if (block->op_type == OP_STUB) {
1496a290 7571 OP* const newblock = newSTATEOP(0, NULL, 0);
eb8433b7
NC		 7572#ifdef PERL_MAD
7573 op_getmad(block,newblock,'B');
7574#else
09c2fd24 7575 op_free(block);
eb8433b7
NC		 7576#endif
7577 block = newblock;
7766f137 7578 }
69b22cd1
FC		 7579 CvROOT(cv) = CvLVALUE(cv)
7580 ? newUNOP(OP_LEAVESUBLV, 0,
7581 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
7582 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
7766f137
GS		 7583 CvROOT(cv)->op_private |= OPpREFCOUNTED;
7584 OpREFCNT_set(CvROOT(cv), 1);
8be227ab
FC		 7585 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
7586 itself has a refcount. */
7587 CvSLABBED_off(cv);
7588 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
7aef8e5b 7589#ifdef PERL_DEBUG_READONLY_OPS
3107b51f 7590 slab = (OPSLAB *)CvSTART(cv);
8be227ab 7591#endif
7766f137
GS		 7592 CvSTART(cv) = LINKLIST(CvROOT(cv));
7593 CvROOT(cv)->op_next = 0;
a2efc822 7594 CALL_PEEP(CvSTART(cv));
d164302a 7595 finalize_optree(CvROOT(cv));
7766f137
GS		 7596
7597 /* now that optimizer has done its work, adjust pad values */
54310121 7598
dd2155a4
DM		 7599 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
7600
7601 if (CvCLONE(cv)) {
beab0874
JT		 7602 assert(!CvCONST(cv));
7603 if (ps && !*ps && op_const_sv(block, cv))
7604 CvCONST_on(cv);
a0d0e21e 7605 }
79072805 7606
fb834abd
FC		 7607 attrs:
7608 if (attrs) {
7609 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
7610 HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
12d3c230 7611 if (!name) SAVEFREESV(cv);
ad0dc73b 7612 apply_attrs(stash, MUTABLE_SV(cv), attrs);
12d3c230 7613 if (!name) SvREFCNT_inc_simple_void_NN(cv);
fb834abd
FC		 7614 }
7615
7616 if (block && has_name) {
3280af22 7617 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
c4420975 7618 SV * const tmpstr = sv_newmortal();
5c1737d1
NC		 7619 GV * const db_postponed = gv_fetchpvs("DB::postponed",
7620 GV_ADDMULTI, SVt_PVHV);
44a8e56a 7621 HV *hv;
b081dd7e
NC		 7622 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
7623 CopFILE(PL_curcop),
7624 (long)PL_subline,
7625 (long)CopLINE(PL_curcop));
bd61b366 7626 gv_efullname3(tmpstr, gv, NULL);
04fe65b0 7627 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
c60dbbc3 7628 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
44a8e56a 7629 hv = GvHVn(db_postponed);
c60dbbc3 7630 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
551405c4
AL		 7631 CV * const pcv = GvCV(db_postponed);
7632 if (pcv) {
7633 dSP;
7634 PUSHMARK(SP);
7635 XPUSHs(tmpstr);
7636 PUTBACK;
ad64d0ec 7637 call_sv(MUTABLE_SV(pcv), G_DISCARD);
551405c4 7638 }
44a8e56a 7639 }
7640 }
79072805 7641
13765c85 7642 if (name && ! (PL_parser && PL_parser->error_count))
d699ecb7 7643 process_special_blocks(floor, name, gv, cv);
33fb7a6e 7644 }
ed094faf 7645
33fb7a6e 7646 done:
53a7735b
DM		 7647 if (PL_parser)
7648 PL_parser->copline = NOLINE;
33fb7a6e 7649 LEAVE_SCOPE(floor);
7aef8e5b 7650#ifdef PERL_DEBUG_READONLY_OPS
3107b51f
FC		 7651 /* Watch out for BEGIN blocks */
7652 if (slab && gv && isGV(gv) && GvCV(gv)) Slab_to_ro(slab);
7653#endif
33fb7a6e
NC		 7654 return cv;
7655}
ed094faf 7656
33fb7a6e 7657STATIC void
d699ecb7
FC		 7658S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
7659 GV *const gv,
33fb7a6e
NC		 7660 CV *const cv)
7661{
7662 const char *const colon = strrchr(fullname,':');
7663 const char *const name = colon ? colon + 1 : fullname;
7664
7918f24d
NC		 7665 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
7666
33fb7a6e 7667 if (*name == 'B') {
6952d67e 7668 if (strEQ(name, "BEGIN")) {
6867be6d 7669 const I32 oldscope = PL_scopestack_ix;
d699ecb7 7670 if (floor) LEAVE_SCOPE(floor);
28757baa 7671 ENTER;
57843af0
GS		 7672 SAVECOPFILE(&PL_compiling);
7673 SAVECOPLINE(&PL_compiling);
16c63275 7674 SAVEVPTR(PL_curcop);
28757baa 7675
a58fb6f9 7676 DEBUG_x( dump_sub(gv) );
ad64d0ec 7677 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
c43ae56f 7678 GvCV_set(gv,0); /* cv has been hijacked */
3280af22 7679 call_list(oldscope, PL_beginav);
a6006777 7680
623e6609 7681 CopHINTS_set(&PL_compiling, PL_hints);
28757baa 7682 LEAVE;
7683 }
33fb7a6e
NC		 7684 else
7685 return;
7686 } else {
7687 if (*name == 'E') {
7688 if strEQ(name, "END") {
a58fb6f9 7689 DEBUG_x( dump_sub(gv) );
ad64d0ec 7690 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
33fb7a6e
NC		 7691 } else
7692 return;
7693 } else if (*name == 'U') {
7694 if (strEQ(name, "UNITCHECK")) {
7695 /* It's never too late to run a unitcheck block */
ad64d0ec 7696 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
33fb7a6e
NC		 7697 }
7698 else
7699 return;
7700 } else if (*name == 'C') {
7701 if (strEQ(name, "CHECK")) {
a2a5de95 7702 if (PL_main_start)
dcbac5bb 7703 /* diag_listed_as: Too late to run %s block */
a2a5de95
NC		 7704 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
7705 "Too late to run CHECK block");
ad64d0ec 7706 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
33fb7a6e
NC		 7707 }
7708 else
7709 return;
7710 } else if (*name == 'I') {
7711 if (strEQ(name, "INIT")) {
a2a5de95 7712 if (PL_main_start)
dcbac5bb 7713 /* diag_listed_as: Too late to run %s block */
a2a5de95
NC		 7714 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
7715 "Too late to run INIT block");
ad64d0ec 7716 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
33fb7a6e
NC		 7717 }
7718 else
7719 return;
7720 } else
7721 return;
a58fb6f9 7722 DEBUG_x( dump_sub(gv) );
c43ae56f 7723 GvCV_set(gv,0); /* cv has been hijacked */
79072805 7724 }
79072805
LW		 7725}
7726
954c1994
GS		 7727/*
7728=for apidoc newCONSTSUB
7729
3453414d
BF		 7730See L</newCONSTSUB_flags>.
7731
7732=cut
7733*/
7734
7735CV *
7736Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
7737{
9c0a6090 7738 return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
3453414d
BF		 7739}
7740
7741/*
7742=for apidoc newCONSTSUB_flags
7743
954c1994
GS		 7744Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
7745eligible for inlining at compile-time.
7746
3453414d
BF		 7747Currently, the only useful value for C<flags> is SVf_UTF8.
7748
be8851fc
NC		 7749The newly created subroutine takes ownership of a reference to the passed in
7750SV.
7751
99ab892b
NC		 7752Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
7753which won't be called if used as a destructor, but will suppress the overhead
7754of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
7755compile time.)
7756
954c1994
GS		 7757=cut
7758*/
7759
beab0874 7760CV *
9c0a6090
FC		 7761Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
7762 U32 flags, SV *sv)
5476c433 7763{
27da23d5 7764 dVAR;
beab0874 7765 CV* cv;
cbf82dd0 7766#ifdef USE_ITHREADS
54d012c6 7767 const char *const file = CopFILE(PL_curcop);
cbf82dd0
NC		 7768#else
7769 SV *const temp_sv = CopFILESV(PL_curcop);
def18e4c 7770 const char *const file = temp_sv ? SvPV_nolen_const(temp_sv) : NULL;
cbf82dd0 7771#endif
5476c433 7772
11faa288 7773 ENTER;
11faa288 7774
401667e9
DM		 7775 if (IN_PERL_RUNTIME) {
7776 /* at runtime, it's not safe to manipulate PL_curcop: it may be
7777 * an op shared between threads. Use a non-shared COP for our
7778 * dirty work */
7779 SAVEVPTR(PL_curcop);
08f1b312
FC		 7780 SAVECOMPILEWARNINGS();
7781 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
401667e9
DM		 7782 PL_curcop = &PL_compiling;
7783 }
f4dd75d9 7784 SAVECOPLINE(PL_curcop);
53a7735b 7785 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
f4dd75d9
GS		 7786
7787 SAVEHINTS();
3280af22 7788 PL_hints &= ~HINT_BLOCK_SCOPE;
11faa288
GS		 7789
7790 if (stash) {
03d9f026 7791 SAVEGENERICSV(PL_curstash);
03d9f026 7792 PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
11faa288 7793 }
5476c433 7794
95934569
FC		 7795 /* Protect sv against leakage caused by fatal warnings. */
7796 if (sv) SAVEFREESV(sv);
7797
bad4ae38 7798 /* file becomes the CvFILE. For an XS, it's usually static storage,
cbf82dd0
NC		 7799 and so doesn't get free()d. (It's expected to be from the C pre-
7800 processor __FILE__ directive). But we need a dynamically allocated one,
77004dee 7801 and we need it to get freed. */
8e1fa37c 7802 cv = newXS_len_flags(name, len, const_sv_xsub, file ? file : "", "",
8f82b567 7803 &sv, XS_DYNAMIC_FILENAME | flags);
95934569 7804 CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
beab0874 7805 CvCONST_on(cv);
5476c433 7806
11faa288 7807 LEAVE;
beab0874
JT		 7808
7809 return cv;
5476c433
JD		 7810}
7811
77004dee
NC		 7812CV *
7813Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
7814 const char *const filename, const char *const proto,
7815 U32 flags)
7816{
032a0447
FC		 7817 PERL_ARGS_ASSERT_NEWXS_FLAGS;
7818 return newXS_len_flags(
8f82b567 7819 name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
032a0447
FC		 7820 );
7821}
7822
7823CV *
7824Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
7825 XSUBADDR_t subaddr, const char *const filename,
8f82b567
FC		 7826 const char *const proto, SV **const_svp,
7827 U32 flags)
032a0447 7828{
3453414d 7829 CV *cv;
77004dee 7830
032a0447 7831 PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
7918f24d 7832
3453414d 7833 {
9b566a5e
DD		 7834 GV * const gv = gv_fetchpvn(
7835 name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
7836 name ? len : PL_curstash ? sizeof("__ANON__") - 1:
7837 sizeof("__ANON__::__ANON__") - 1,
7838 GV_ADDMULTI | flags, SVt_PVCV);
3453414d
BF		 7839
7840 if (!subaddr)
7841 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
7842
7843 if ((cv = (name ? GvCV(gv) : NULL))) {
7844 if (GvCVGEN(gv)) {
7845 /* just a cached method */
7846 SvREFCNT_dec(cv);
7847 cv = NULL;
7848 }
7849 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
7850 /* already defined (or promised) */
18225a01 7851 /* Redundant check that allows us to avoid creating an SV
156d738f
FC		 7852 most of the time: */
7853 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
156d738f 7854 report_redefined_cv(newSVpvn_flags(
46538741 7855 name,len,(flags&SVf_UTF8)|SVs_TEMP
156d738f
FC		 7856 ),
7857 cv, const_svp);
3453414d 7858 }
fc2b2dca 7859 SvREFCNT_dec_NN(cv);
3453414d
BF		 7860 cv = NULL;
7861 }
7862 }
7863
7864 if (cv) /* must reuse cv if autoloaded */
7865 cv_undef(cv);
7866 else {
7867 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
7868 if (name) {
7869 GvCV_set(gv,cv);
7870 GvCVGEN(gv) = 0;
03d9f026 7871 if (HvENAME_HEK(GvSTASH(gv)))
978a498e 7872 gv_method_changed(gv); /* newXS */
3453414d
BF		 7873 }
7874 }
7875 if (!name)
7876 CvANON_on(cv);
7877 CvGV_set(cv, gv);
7878 (void)gv_fetchfile(filename);
7879 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
7880 an external constant string */
7881 assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
7882 CvISXSUB_on(cv);
7883 CvXSUB(cv) = subaddr;
7884
7885 if (name)
d699ecb7 7886 process_special_blocks(0, name, gv, cv);
3453414d
BF		 7887 }
7888
77004dee 7889 if (flags & XS_DYNAMIC_FILENAME) {
bad4ae38
FC		 7890 CvFILE(cv) = savepv(filename);
7891 CvDYNFILE_on(cv);
77004dee 7892 }
bad4ae38 7893 sv_setpv(MUTABLE_SV(cv), proto);
77004dee
NC		 7894 return cv;
7895}
7896
186a5ba8
FC		 7897CV *
7898Perl_newSTUB(pTHX_ GV *gv, bool fake)
7899{
eb578fdb 7900 CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
186a5ba8
FC		 7901 PERL_ARGS_ASSERT_NEWSTUB;
7902 assert(!GvCVu(gv));
7903 GvCV_set(gv, cv);
7904 GvCVGEN(gv) = 0;
7905 if (!fake && HvENAME_HEK(GvSTASH(gv)))
978a498e 7906 gv_method_changed(gv);
186a5ba8
FC		 7907 CvGV_set(cv, gv);
7908 CvFILE_set_from_cop(cv, PL_curcop);
7909 CvSTASH_set(cv, PL_curstash);
7910 GvMULTI_on(gv);
7911 return cv;
7912}
7913
954c1994
GS		 7914/*
7915=for apidoc U||newXS
7916
77004dee
NC		 7917Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
7918static storage, as it is used directly as CvFILE(), without a copy being made.
954c1994
GS		 7919
7920=cut
7921*/
7922
57d3b86d 7923CV *
bfed75c6 7924Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
a0d0e21e 7925{
7918f24d 7926 PERL_ARGS_ASSERT_NEWXS;
ce9f52ad
FC		 7927 return newXS_len_flags(
7928 name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
7929 );
79072805
LW		 7930}
7931
eb8433b7
NC		 7932#ifdef PERL_MAD
7933OP *
7934#else
79072805 7935void
eb8433b7 7936#endif
864dbfa3 7937Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
79072805 7938{
97aff369 7939 dVAR;
eb578fdb 7940 CV *cv;
eb8433b7
NC		 7941#ifdef PERL_MAD
7942 OP* pegop = newOP(OP_NULL, 0);
7943#endif
79072805 7944
2c658e55
FC		 7945 GV *gv;
7946
7947 if (PL_parser && PL_parser->error_count) {
7948 op_free(block);
7949 goto finish;
7950 }
7951
7952 gv = o
f776e3cd 7953 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
fafc274c 7954 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
0bd48802 7955
a5f75d66 7956 GvMULTI_on(gv);
155aba94 7957 if ((cv = GvFORM(gv))) {
599cee73 7958 if (ckWARN(WARN_REDEFINE)) {
6867be6d 7959 const line_t oldline = CopLINE(PL_curcop);
53a7735b
DM		 7960 if (PL_parser && PL_parser->copline != NOLINE)
7961 CopLINE_set(PL_curcop, PL_parser->copline);
ee6d2783
NC		 7962 if (o) {
7963 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
7964 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
7965 } else {
dcbac5bb 7966 /* diag_listed_as: Format %s redefined */
ee6d2783
NC		 7967 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
7968 "Format STDOUT redefined");
7969 }
57843af0 7970 CopLINE_set(PL_curcop, oldline);
79072805 7971 }
8990e307 7972 SvREFCNT_dec(cv);
79072805 7973 }
3280af22 7974 cv = PL_compcv;
2c658e55 7975 GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
b3f91e91 7976 CvGV_set(cv, gv);
a636914a 7977 CvFILE_set_from_cop(cv, PL_curcop);
79072805 7978
a0d0e21e 7979
dd2155a4 7980 pad_tidy(padtidy_FORMAT);
79072805 7981 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
7934575e
GS		 7982 CvROOT(cv)->op_private |= OPpREFCOUNTED;
7983 OpREFCNT_set(CvROOT(cv), 1);
79072805
LW		 7984 CvSTART(cv) = LINKLIST(CvROOT(cv));
7985 CvROOT(cv)->op_next = 0;
a2efc822 7986 CALL_PEEP(CvSTART(cv));
aee4f072 7987 finalize_optree(CvROOT(cv));
2c658e55
FC		 7988 cv_forget_slab(cv);
7989
7990 finish:
eb8433b7
NC		 7991#ifdef PERL_MAD
7992 op_getmad(o,pegop,'n');
7993 op_getmad_weak(block, pegop, 'b');
7994#else
11343788 7995 op_free(o);
eb8433b7 7996#endif
53a7735b
DM		 7997 if (PL_parser)
7998 PL_parser->copline = NOLINE;
8990e307 7999 LEAVE_SCOPE(floor);
eb8433b7
NC		 8000#ifdef PERL_MAD
8001 return pegop;
8002#endif
79072805
LW		 8003}
8004
8005OP *
864dbfa3 8006Perl_newANONLIST(pTHX_ OP *o)
79072805 8007{
78c72037 8008 return convert(OP_ANONLIST, OPf_SPECIAL, o);
79072805
LW		 8009}
8010
8011OP *
864dbfa3 8012Perl_newANONHASH(pTHX_ OP *o)
79072805 8013{
78c72037 8014 return convert(OP_ANONHASH, OPf_SPECIAL, o);
a0d0e21e
LW		 8015}
8016
8017OP *
864dbfa3 8018Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
a0d0e21e 8019{
5f66b61c 8020 return newANONATTRSUB(floor, proto, NULL, block);
09bef843
SB		 8021}
8022
8023OP *
8024Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
8025{
a0d0e21e 8026 return newUNOP(OP_REFGEN, 0,
09bef843 8027 newSVOP(OP_ANONCODE, 0,
ad64d0ec 8028 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
79072805
LW		 8029}
8030
8031OP *
864dbfa3 8032Perl_oopsAV(pTHX_ OP *o)
79072805 8033{
27da23d5 8034 dVAR;
7918f24d
NC		 8035
8036 PERL_ARGS_ASSERT_OOPSAV;
8037
ed6116ce
LW		 8038 switch (o->op_type) {
8039 case OP_PADSV:
8040 o->op_type = OP_PADAV;
22c35a8c 8041 o->op_ppaddr = PL_ppaddr[OP_PADAV];
51e247a3 8042 return ref(o, OP_RV2AV);
b2ffa427 8043
ed6116ce 8044 case OP_RV2SV:
79072805 8045 o->op_type = OP_RV2AV;
22c35a8c 8046 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
79072805 8047 ref(o, OP_RV2AV);
ed6116ce
LW		 8048 break;
8049
8050 default:
9b387841 8051 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
ed6116ce
LW		 8052 break;
8053 }
79072805
LW		 8054 return o;
8055}
8056
8057OP *
864dbfa3 8058Perl_oopsHV(pTHX_ OP *o)
79072805 8059{
27da23d5 8060 dVAR;
7918f24d
NC		 8061
8062 PERL_ARGS_ASSERT_OOPSHV;
8063
ed6116ce
LW		 8064 switch (o->op_type) {
8065 case OP_PADSV:
8066 case OP_PADAV:
8067 o->op_type = OP_PADHV;
22c35a8c 8068 o->op_ppaddr = PL_ppaddr[OP_PADHV];
51e247a3 8069 return ref(o, OP_RV2HV);
ed6116ce
LW		 8070
8071 case OP_RV2SV:
8072 case OP_RV2AV:
79072805 8073 o->op_type = OP_RV2HV;
22c35a8c 8074 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
79072805 8075 ref(o, OP_RV2HV);
ed6116ce
LW		 8076 break;
8077
8078 default:
9b387841 8079 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
ed6116ce
LW		 8080 break;
8081 }
79072805
LW		 8082 return o;
8083}
8084
8085OP *
864dbfa3 8086Perl_newAVREF(pTHX_ OP *o)
79072805 8087{
27da23d5 8088 dVAR;
7918f24d
NC		 8089
8090 PERL_ARGS_ASSERT_NEWAVREF;
8091
ed6116ce
LW		 8092 if (o->op_type == OP_PADANY) {
8093 o->op_type = OP_PADAV;
22c35a8c 8094 o->op_ppaddr = PL_ppaddr[OP_PADAV];
93a17b20 8095 return o;
ed6116ce 8096 }
a2a5de95 8097 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
d1d15184 8098 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
a2a5de95 8099 "Using an array as a reference is deprecated");
a1063b2d 8100 }
79072805
LW		 8101 return newUNOP(OP_RV2AV, 0, scalar(o));
8102}
8103
8104OP *
864dbfa3 8105Perl_newGVREF(pTHX_ I32 type, OP *o)
79072805 8106{
82092f1d 8107 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
a0d0e21e 8108 return newUNOP(OP_NULL, 0, o);
748a9306 8109 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
79072805
LW		 8110}
8111
8112OP *
864dbfa3 8113Perl_newHVREF(pTHX_ OP *o)
79072805 8114{
27da23d5 8115 dVAR;
7918f24d
NC		 8116
8117 PERL_ARGS_ASSERT_NEWHVREF;
8118
ed6116ce
LW		 8119 if (o->op_type == OP_PADANY) {
8120 o->op_type = OP_PADHV;
22c35a8c 8121 o->op_ppaddr = PL_ppaddr[OP_PADHV];
93a17b20 8122 return o;
ed6116ce 8123 }
a2a5de95 8124 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
d1d15184 8125 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
a2a5de95 8126 "Using a hash as a reference is deprecated");
a1063b2d 8127 }
79072805
LW		 8128 return newUNOP(OP_RV2HV, 0, scalar(o));
8129}
8130
8131OP *
864dbfa3 8132Perl_newCVREF(pTHX_ I32 flags, OP *o)
79072805 8133{
97b03d64 8134 if (o->op_type == OP_PADANY) {
c04ef36e 8135 dVAR;
97b03d64
FC		 8136 o->op_type = OP_PADCV;
8137 o->op_ppaddr = PL_ppaddr[OP_PADCV];
279d09bf 8138 return o;
97b03d64 8139 }
c07a80fd 8140 return newUNOP(OP_RV2CV, flags, scalar(o));
79072805
LW		 8141}
8142
8143OP *
864dbfa3 8144Perl_newSVREF(pTHX_ OP *o)
79072805 8145{
27da23d5 8146 dVAR;
7918f24d
NC		 8147
8148 PERL_ARGS_ASSERT_NEWSVREF;
8149
ed6116ce
LW		 8150 if (o->op_type == OP_PADANY) {
8151 o->op_type = OP_PADSV;
22c35a8c 8152 o->op_ppaddr = PL_ppaddr[OP_PADSV];
93a17b20 8153 return o;
ed6116ce 8154 }
79072805
LW		 8155 return newUNOP(OP_RV2SV, 0, scalar(o));
8156}
8157
61b743bb
DM		 8158/* Check routines. See the comments at the top of this file for details
8159 * on when these are called */
79072805
LW		 8160
8161OP *
cea2e8a9 8162Perl_ck_anoncode(pTHX_ OP *o)
5f05dabc 8163{
7918f24d
NC		 8164 PERL_ARGS_ASSERT_CK_ANONCODE;
8165
cc76b5cc 8166 cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
eb8433b7 8167 if (!PL_madskills)
1d866c12 8168 cSVOPo->op_sv = NULL;
5dc0d613 8169 return o;
5f05dabc 8170}
8171
8172OP *
cea2e8a9 8173Perl_ck_bitop(pTHX_ OP *o)
55497cff 8174{
97aff369 8175 dVAR;
7918f24d
NC		 8176
8177 PERL_ARGS_ASSERT_CK_BITOP;
8178
d5ec2987 8179 o->op_private = (U8)(PL_hints & HINT_INTEGER);
2b84528b
RGS		 8180 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
8181 && (o->op_type == OP_BIT_OR
8182 || o->op_type == OP_BIT_AND
8183 || o->op_type == OP_BIT_XOR))
276b2a0c 8184 {
1df70142
AL		 8185 const OP * const left = cBINOPo->op_first;
8186 const OP * const right = left->op_sibling;
96a925ab
YST		 8187 if ((OP_IS_NUMCOMPARE(left->op_type) &&
8188 (left->op_flags & OPf_PARENS) == 0) ||
8189 (OP_IS_NUMCOMPARE(right->op_type) &&
8190 (right->op_flags & OPf_PARENS) == 0))
a2a5de95
NC		 8191 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
8192 "Possible precedence problem on bitwise %c operator",
8193 o->op_type == OP_BIT_OR ? '|'
8194 : o->op_type == OP_BIT_AND ? '&' : '^'
8195 );
276b2a0c 8196 }
5dc0d613 8197 return o;
55497cff 8198}
8199
89474f50
FC		 8200PERL_STATIC_INLINE bool
8201is_dollar_bracket(pTHX_ const OP * const o)
8202{
8203 const OP *kid;
8204 return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
8205 && (kid = cUNOPx(o)->op_first)
8206 && kid->op_type == OP_GV
8207 && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
8208}
8209
8210OP *
8211Perl_ck_cmp(pTHX_ OP *o)
8212{
8213 PERL_ARGS_ASSERT_CK_CMP;
8214 if (ckWARN(WARN_SYNTAX)) {
8215 const OP *kid = cUNOPo->op_first;
8216 if (kid && (
7c2b3c78
FC		 8217 (
8218 is_dollar_bracket(aTHX_ kid)
8219 && kid->op_sibling && kid->op_sibling->op_type == OP_CONST
8220 )
8221 || ( kid->op_type == OP_CONST
8222 && (kid = kid->op_sibling) && is_dollar_bracket(aTHX_ kid))
89474f50
FC		 8223 ))
8224 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
8225 "$[ used in %s (did you mean $] ?)", OP_DESC(o));
8226 }
8227 return o;
8228}
8229
55497cff 8230OP *
cea2e8a9 8231Perl_ck_concat(pTHX_ OP *o)
79072805 8232{
0bd48802 8233 const OP * const kid = cUNOPo->op_first;
7918f24d
NC		 8234
8235 PERL_ARGS_ASSERT_CK_CONCAT;
96a5add6 8236 PERL_UNUSED_CONTEXT;
7918f24d 8237
df91b2c5
AE		 8238 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
8239 !(kUNOP->op_first->op_flags & OPf_MOD))
0165acc7 8240 o->op_flags |= OPf_STACKED;
11343788 8241 return o;
79072805
LW		 8242}
8243
8244OP *
cea2e8a9 8245Perl_ck_spair(pTHX_ OP *o)
79072805 8246{
27da23d5 8247 dVAR;
7918f24d
NC		 8248
8249 PERL_ARGS_ASSERT_CK_SPAIR;
8250
11343788 8251 if (o->op_flags & OPf_KIDS) {
79072805 8252 OP* newop;
a0d0e21e 8253 OP* kid;
6867be6d 8254 const OPCODE type = o->op_type;
5dc0d613 8255 o = modkids(ck_fun(o), type);
11343788 8256 kid = cUNOPo->op_first;
a0d0e21e 8257 newop = kUNOP->op_first->op_sibling;
1496a290
AL		 8258 if (newop) {
8259 const OPCODE type = newop->op_type;
8260 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
8261 type == OP_PADAV || type == OP_PADHV ||
8262 type == OP_RV2AV || type == OP_RV2HV)
8263 return o;
a0d0e21e 8264 }
eb8433b7
NC		 8265#ifdef PERL_MAD
8266 op_getmad(kUNOP->op_first,newop,'K');
8267#else
a0d0e21e 8268 op_free(kUNOP->op_first);
eb8433b7 8269#endif
a0d0e21e
LW		 8270 kUNOP->op_first = newop;
8271 }
22c35a8c 8272 o->op_ppaddr = PL_ppaddr[++o->op_type];
11343788 8273 return ck_fun(o);
a0d0e21e
LW		 8274}
8275
8276OP *
cea2e8a9 8277Perl_ck_delete(pTHX_ OP *o)
a0d0e21e 8278{
7918f24d
NC		 8279 PERL_ARGS_ASSERT_CK_DELETE;
8280
11343788 8281 o = ck_fun(o);
5dc0d613 8282 o->op_private = 0;
11343788 8283 if (o->op_flags & OPf_KIDS) {
551405c4 8284 OP * const kid = cUNOPo->op_first;
01020589
GS		 8285 switch (kid->op_type) {
8286 case OP_ASLICE:
8287 o->op_flags |= OPf_SPECIAL;
8288 /* FALL THROUGH */
8289 case OP_HSLICE:
5dc0d613 8290 o->op_private |= OPpSLICE;
01020589
GS		 8291 break;
8292 case OP_AELEM:
8293 o->op_flags |= OPf_SPECIAL;
8294 /* FALL THROUGH */
8295 case OP_HELEM:
8296 break;
8297 default:
8298 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
53e06cf0 8299 OP_DESC(o));
01020589 8300 }
7332a6c4
VP		 8301 if (kid->op_private & OPpLVAL_INTRO)
8302 o->op_private |= OPpLVAL_INTRO;
93c66552 8303 op_null(kid);
79072805 8304 }
11343788 8305 return o;
79072805
LW		 8306}
8307
8308OP *
96e176bf
CL		 8309Perl_ck_die(pTHX_ OP *o)
8310{
7918f24d
NC		 8311 PERL_ARGS_ASSERT_CK_DIE;
8312
96e176bf
CL		 8313#ifdef VMS
8314 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
8315#endif
8316 return ck_fun(o);
8317}
8318
8319OP *
cea2e8a9 8320Perl_ck_eof(pTHX_ OP *o)
79072805 8321{
97aff369 8322 dVAR;
79072805 8323
7918f24d
NC		 8324 PERL_ARGS_ASSERT_CK_EOF;
8325
11343788 8326 if (o->op_flags & OPf_KIDS) {
3500db16 8327 OP *kid;
11343788 8328 if (cLISTOPo->op_first->op_type == OP_STUB) {
1d866c12
AL		 8329 OP * const newop
8330 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
eb8433b7
NC		 8331#ifdef PERL_MAD
8332 op_getmad(o,newop,'O');
8333#else
11343788 8334 op_free(o);
eb8433b7
NC		 8335#endif
8336 o = newop;
8990e307 8337 }
3500db16
FC		 8338 o = ck_fun(o);
8339 kid = cLISTOPo->op_first;
8340 if (kid->op_type == OP_RV2GV)
8341 kid->op_private |= OPpALLOW_FAKE;
79072805 8342 }
11343788 8343 return o;
79072805
LW		 8344}
8345
8346OP *
cea2e8a9 8347Perl_ck_eval(pTHX_ OP *o)
79072805 8348{
27da23d5 8349 dVAR;
7918f24d
NC		 8350
8351 PERL_ARGS_ASSERT_CK_EVAL;
8352
3280af22 8353 PL_hints |= HINT_BLOCK_SCOPE;
11343788 8354 if (o->op_flags & OPf_KIDS) {
46c461b5 8355 SVOP * const kid = (SVOP*)cUNOPo->op_first;
79072805 8356
93a17b20 8357 if (!kid) {
11343788 8358 o->op_flags &= ~OPf_KIDS;
93c66552 8359 op_null(o);
79072805 8360 }
b14574b4 8361 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
79072805 8362 LOGOP *enter;
eb8433b7 8363#ifdef PERL_MAD
1d866c12 8364 OP* const oldo = o;
eb8433b7 8365#endif
79072805 8366
11343788 8367 cUNOPo->op_first = 0;
eb8433b7 8368#ifndef PERL_MAD
11343788 8369 op_free(o);
eb8433b7 8370#endif
79072805 8371
b7dc083c 8372 NewOp(1101, enter, 1, LOGOP);
79072805 8373 enter->op_type = OP_ENTERTRY;
22c35a8c 8374 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
79072805
LW		 8375 enter->op_private = 0;
8376
8377 /* establish postfix order */
8378 enter->op_next = (OP*)enter;
8379
2fcb4757 8380 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
11343788 8381 o->op_type = OP_LEAVETRY;
22c35a8c 8382 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
11343788 8383 enter->op_other = o;
eb8433b7 8384 op_getmad(oldo,o,'O');
11343788 8385 return o;
79072805 8386 }
b5c19bd7 8387 else {
473986ff 8388 scalar((OP*)kid);
b5c19bd7
DM		 8389 PL_cv_has_eval = 1;
8390 }
79072805
LW		 8391 }
8392 else {
a4a3cf74 8393 const U8 priv = o->op_private;
eb8433b7 8394#ifdef PERL_MAD
1d866c12 8395 OP* const oldo = o;
eb8433b7 8396#else
11343788 8397 op_free(o);
eb8433b7 8398#endif
7d789282 8399 o = newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
eb8433b7 8400 op_getmad(oldo,o,'O');
79072805 8401 }
3280af22 8402 o->op_targ = (PADOFFSET)PL_hints;
547ae129 8403 if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
7d789282
FC		 8404 if ((PL_hints & HINT_LOCALIZE_HH) != 0
8405 && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
996c9baa
VP		 8406 /* Store a copy of %^H that pp_entereval can pick up. */
8407 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
defdfed5 8408 MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
0d863452
RH		 8409 cUNOPo->op_first->op_sibling = hhop;
8410 o->op_private |= OPpEVAL_HAS_HH;
915a83fe
FC		 8411 }
8412 if (!(o->op_private & OPpEVAL_BYTES)
2846acbf 8413 && FEATURE_UNIEVAL_IS_ENABLED)
802a15e9 8414 o->op_private |= OPpEVAL_UNICODE;
11343788 8415 return o;
79072805
LW		 8416}
8417
8418OP *
d98f61e7
GS		 8419Perl_ck_exit(pTHX_ OP *o)
8420{
7918f24d
NC		 8421 PERL_ARGS_ASSERT_CK_EXIT;
8422
d98f61e7 8423#ifdef VMS
551405c4 8424 HV * const table = GvHV(PL_hintgv);
d98f61e7 8425 if (table) {
a4fc7abc 8426 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
d98f61e7
GS		 8427 if (svp && *svp && SvTRUE(*svp))
8428 o->op_private |= OPpEXIT_VMSISH;
8429 }
96e176bf 8430 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
d98f61e7
GS		 8431#endif
8432 return ck_fun(o);
8433}
8434
8435OP *
cea2e8a9 8436Perl_ck_exec(pTHX_ OP *o)
79072805 8437{
7918f24d
NC		 8438 PERL_ARGS_ASSERT_CK_EXEC;
8439
11343788 8440 if (o->op_flags & OPf_STACKED) {
6867be6d 8441 OP *kid;
11343788
MB		 8442 o = ck_fun(o);
8443 kid = cUNOPo->op_first->op_sibling;
8990e307 8444 if (kid->op_type == OP_RV2GV)
93c66552 8445 op_null(kid);
79072805 8446 }
463ee0b2 8447 else
11343788
MB		 8448 o = listkids(o);
8449 return o;
79072805
LW		 8450}
8451
8452OP *
cea2e8a9 8453Perl_ck_exists(pTHX_ OP *o)
5f05dabc 8454{
97aff369 8455 dVAR;
7918f24d
NC		 8456
8457 PERL_ARGS_ASSERT_CK_EXISTS;
8458
5196be3e
MB		 8459 o = ck_fun(o);
8460 if (o->op_flags & OPf_KIDS) {
46c461b5 8461 OP * const kid = cUNOPo->op_first;
afebc493
GS		 8462 if (kid->op_type == OP_ENTERSUB) {
8463 (void) ref(kid, o->op_type);
13765c85
DM		 8464 if (kid->op_type != OP_RV2CV
8465 && !(PL_parser && PL_parser->error_count))
afebc493 8466 Perl_croak(aTHX_ "%s argument is not a subroutine name",
53e06cf0 8467 OP_DESC(o));
afebc493
GS		 8468 o->op_private |= OPpEXISTS_SUB;
8469 }
8470 else if (kid->op_type == OP_AELEM)
01020589
GS		 8471 o->op_flags |= OPf_SPECIAL;
8472 else if (kid->op_type != OP_HELEM)
b0fdf69e 8473 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine",
53e06cf0 8474 OP_DESC(o));
93c66552 8475 op_null(kid);
5f05dabc 8476 }
5196be3e 8477 return o;
5f05dabc 8478}
8479
79072805 8480OP *
5aaab254 8481Perl_ck_rvconst(pTHX_ OP *o)
79072805 8482{
27da23d5 8483 dVAR;
0bd48802 8484 SVOP * const kid = (SVOP*)cUNOPo->op_first;
85e6fe83 8485
7918f24d
NC		 8486 PERL_ARGS_ASSERT_CK_RVCONST;
8487
3280af22 8488 o->op_private |= (PL_hints & HINT_STRICT_REFS);
e26df76a
NC		 8489 if (o->op_type == OP_RV2CV)
8490 o->op_private &= ~1;
8491
79072805 8492 if (kid->op_type == OP_CONST) {
44a8e56a 8493 int iscv;
8494 GV *gv;
504618e9 8495 SV * const kidsv = kid->op_sv;
44a8e56a 8496
779c5bc9
GS		 8497 /* Is it a constant from cv_const_sv()? */
8498 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
0bd48802 8499 SV * const rsv = SvRV(kidsv);
42d0e0b7 8500 const svtype type = SvTYPE(rsv);
bd61b366 8501 const char *badtype = NULL;
779c5bc9
GS		 8502
8503 switch (o->op_type) {
8504 case OP_RV2SV:
42d0e0b7 8505 if (type > SVt_PVMG)
779c5bc9
GS		 8506 badtype = "a SCALAR";
8507 break;
8508 case OP_RV2AV:
42d0e0b7 8509 if (type != SVt_PVAV)
779c5bc9
GS		 8510 badtype = "an ARRAY";
8511 break;
8512 case OP_RV2HV:
42d0e0b7 8513 if (type != SVt_PVHV)
779c5bc9 8514 badtype = "a HASH";
779c5bc9
GS		 8515 break;
8516 case OP_RV2CV:
42d0e0b7 8517 if (type != SVt_PVCV)
779c5bc9
GS		 8518 badtype = "a CODE";
8519 break;
8520 }
8521 if (badtype)
cea2e8a9 8522 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
779c5bc9
GS		 8523 return o;
8524 }
ce10b5d1 8525 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5f66b61c 8526 const char *badthing;
5dc0d613 8527 switch (o->op_type) {
44a8e56a 8528 case OP_RV2SV:
8529 badthing = "a SCALAR";
8530 break;
8531 case OP_RV2AV:
8532 badthing = "an ARRAY";
8533 break;
8534 case OP_RV2HV:
8535 badthing = "a HASH";
8536 break;
5f66b61c
AL		 8537 default:
8538 badthing = NULL;
8539 break;
44a8e56a 8540 }
8541 if (badthing)
1c846c1f 8542 Perl_croak(aTHX_
95b63a38 8543 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
be2597df 8544 SVfARG(kidsv), badthing);
44a8e56a 8545 }
93233ece
CS		 8546 /*
8547 * This is a little tricky. We only want to add the symbol if we
8548 * didn't add it in the lexer. Otherwise we get duplicate strict
8549 * warnings. But if we didn't add it in the lexer, we must at
8550 * least pretend like we wanted to add it even if it existed before,
8551 * or we get possible typo warnings. OPpCONST_ENTERED says
8552 * whether the lexer already added THIS instance of this symbol.
8553 */
5196be3e 8554 iscv = (o->op_type == OP_RV2CV) * 2;
93233ece 8555 do {
7a5fd60d 8556 gv = gv_fetchsv(kidsv,
748a9306 8557 iscv | !(kid->op_private & OPpCONST_ENTERED),
a0d0e21e
LW		 8558 iscv
8559 ? SVt_PVCV
11343788 8560 : o->op_type == OP_RV2SV
a0d0e21e 8561 ? SVt_PV
11343788 8562 : o->op_type == OP_RV2AV
a0d0e21e 8563 ? SVt_PVAV
11343788 8564 : o->op_type == OP_RV2HV
a0d0e21e
LW		 8565 ? SVt_PVHV
8566 : SVt_PVGV);
93233ece
CS		 8567 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
8568 if (gv) {
8569 kid->op_type = OP_GV;
8570 SvREFCNT_dec(kid->op_sv);
350de78d 8571#ifdef USE_ITHREADS
638eceb6 8572 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
350de78d 8573 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
dd2155a4 8574 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
743e66e6 8575 GvIN_PAD_on(gv);
ad64d0ec 8576 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
350de78d 8577#else
b37c2d43 8578 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
350de78d 8579#endif
23f1ca44 8580 kid->op_private = 0;
76cd736e 8581 kid->op_ppaddr = PL_ppaddr[OP_GV];
2acc3314
FC		 8582 /* FAKE globs in the symbol table cause weird bugs (#77810) */
8583 SvFAKE_off(gv);
a0d0e21e 8584 }
79072805 8585 }
11343788 8586 return o;
79072805
LW		 8587}
8588
8589OP *
cea2e8a9 8590Perl_ck_ftst(pTHX_ OP *o)
79072805 8591{
27da23d5 8592 dVAR;
6867be6d 8593 const I32 type = o->op_type;
79072805 8594
7918f24d
NC		 8595 PERL_ARGS_ASSERT_CK_FTST;
8596
d0dca557 8597 if (o->op_flags & OPf_REF) {
6f207bd3 8598 NOOP;
d0dca557
JD		 8599 }
8600 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
551405c4 8601 SVOP * const kid = (SVOP*)cUNOPo->op_first;
1496a290 8602 const OPCODE kidtype = kid->op_type;
79072805 8603
9a0c9949
FC		 8604 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
8605 && !(kid->op_private & OPpCONST_FOLDED)) {
551405c4 8606 OP * const newop = newGVOP(type, OPf_REF,
f776e3cd 8607 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
eb8433b7
NC		 8608#ifdef PERL_MAD
8609 op_getmad(o,newop,'O');
8610#else
11343788 8611 op_free(o);
eb8433b7 8612#endif
1d866c12 8613 return newop;
79072805 8614 }
6ecf81d6 8615 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
1af34c76 8616 o->op_private |= OPpFT_ACCESS;
ef69c8fc 8617 if (PL_check[kidtype] == Perl_ck_ftst
bbd91306 8618 && kidtype != OP_STAT && kidtype != OP_LSTAT) {
fbb0b3b3 8619 o->op_private |= OPpFT_STACKED;
bbd91306 8620 kid->op_private |= OPpFT_STACKING;
8db8f6b6
FC		 8621 if (kidtype == OP_FTTTY && (
8622 !(kid->op_private & OPpFT_STACKED)
8623 || kid->op_private & OPpFT_AFTER_t
8624 ))
8625 o->op_private |= OPpFT_AFTER_t;
bbd91306 8626 }
79072805
LW		 8627 }
8628 else {
eb8433b7 8629#ifdef PERL_MAD
1d866c12 8630 OP* const oldo = o;
eb8433b7 8631#else
11343788 8632 op_free(o);
eb8433b7 8633#endif
79072805 8634 if (type == OP_FTTTY)
8fde6460 8635 o = newGVOP(type, OPf_REF, PL_stdingv);
79072805 8636 else
d0dca557 8637 o = newUNOP(type, 0, newDEFSVOP());
eb8433b7 8638 op_getmad(oldo,o,'O');
79072805 8639 }
11343788 8640 return o;
79072805
LW		 8641}
8642
8643OP *
cea2e8a9 8644Perl_ck_fun(pTHX_ OP *o)
79072805 8645{
97aff369 8646 dVAR;
6867be6d 8647 const int type = o->op_type;
eb578fdb 8648 I32 oa = PL_opargs[type] >> OASHIFT;
aeea060c 8649
7918f24d
NC		 8650 PERL_ARGS_ASSERT_CK_FUN;
8651
11343788 8652 if (o->op_flags & OPf_STACKED) {
79072805
LW		 8653 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
8654 oa &= ~OA_OPTIONAL;
8655 else
11343788 8656 return no_fh_allowed(o);
79072805
LW		 8657 }
8658
11343788 8659 if (o->op_flags & OPf_KIDS) {
6867be6d 8660 OP **tokid = &cLISTOPo->op_first;
eb578fdb 8661 OP *kid = cLISTOPo->op_first;
6867be6d
AL		 8662 OP *sibl;
8663 I32 numargs = 0;
ea5703f4 8664 bool seen_optional = FALSE;
6867be6d 8665
8990e307 8666 if (kid->op_type == OP_PUSHMARK ||
155aba94 8667 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
8990e307 8668 {
79072805
LW		 8669 tokid = &kid->op_sibling;
8670 kid = kid->op_sibling;
8671 }
f6a16869
FC		 8672 if (kid && kid->op_type == OP_COREARGS) {
8673 bool optional = FALSE;
8674 while (oa) {
8675 numargs++;
8676 if (oa & OA_OPTIONAL) optional = TRUE;
8677 oa = oa >> 4;
8678 }
8679 if (optional) o->op_private |= numargs;
8680 return o;
8681 }
79072805 8682
ea5703f4 8683 while (oa) {
72ec8a82 8684 if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
ea5703f4
FC		 8685 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV)
8686 *tokid = kid = newDEFSVOP();
8687 seen_optional = TRUE;
8688 }
8689 if (!kid) break;
8690
79072805
LW		 8691 numargs++;
8692 sibl = kid->op_sibling;
eb8433b7
NC		 8693#ifdef PERL_MAD
8694 if (!sibl && kid->op_type == OP_STUB) {
8695 numargs--;
8696 break;
8697 }
8698#endif
79072805
LW		 8699 switch (oa & 7) {
8700 case OA_SCALAR:
62c18ce2
GS		 8701 /* list seen where single (scalar) arg expected? */
8702 if (numargs == 1 && !(oa >> 4)
8703 && kid->op_type == OP_LIST && type != OP_SCALAR)
8704 {
ce16c625 8705 return too_many_arguments_pv(o,PL_op_desc[type], 0);
62c18ce2 8706 }
79072805
LW		 8707 scalar(kid);
8708 break;
8709 case OA_LIST:
8710 if (oa < 16) {
8711 kid = 0;
8712 continue;
8713 }
8714 else
8715 list(kid);
8716 break;
8717 case OA_AVREF:
936edb8b 8718 if ((type == OP_PUSH || type == OP_UNSHIFT)
a2a5de95
NC		 8719 && !kid->op_sibling)
8720 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
8721 "Useless use of %s with no values",
8722 PL_op_desc[type]);
b2ffa427 8723
79072805 8724 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 8725 (kid->op_private & OPpCONST_BARE))
8726 {
551405c4 8727 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
f776e3cd 8728 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
d1d15184 8729 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
a2a5de95
NC		 8730 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
8731 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
eb8433b7
NC		 8732#ifdef PERL_MAD
8733 op_getmad(kid,newop,'K');
8734#else
79072805 8735 op_free(kid);
eb8433b7 8736#endif
79072805
LW		 8737 kid = newop;
8738 kid->op_sibling = sibl;
8739 *tokid = kid;
8740 }
d4fc4415
FC		 8741 else if (kid->op_type == OP_CONST
8742 && ( !SvROK(cSVOPx_sv(kid))
8743 || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
8744 )
ce16c625 8745 bad_type_pv(numargs, "array", PL_op_desc[type], 0, kid);
d4fc4415
FC		 8746 /* Defer checks to run-time if we have a scalar arg */
8747 if (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV)
8748 op_lvalue(kid, type);
8749 else scalar(kid);
79072805
LW		 8750 break;
8751 case OA_HVREF:
8752 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 8753 (kid->op_private & OPpCONST_BARE))
8754 {
551405c4 8755 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
f776e3cd 8756 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
d1d15184 8757 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
a2a5de95
NC		 8758 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
8759 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
eb8433b7
NC		 8760#ifdef PERL_MAD
8761 op_getmad(kid,newop,'K');
8762#else
79072805 8763 op_free(kid);
eb8433b7 8764#endif
79072805
LW		 8765 kid = newop;
8766 kid->op_sibling = sibl;
8767 *tokid = kid;
8768 }
8990e307 8769 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
ce16c625 8770 bad_type_pv(numargs, "hash", PL_op_desc[type], 0, kid);
3ad73efd 8771 op_lvalue(kid, type);
79072805
LW		 8772 break;
8773 case OA_CVREF:
8774 {
551405c4 8775 OP * const newop = newUNOP(OP_NULL, 0, kid);
79072805 8776 kid->op_sibling = 0;
79072805
LW		 8777 newop->op_next = newop;
8778 kid = newop;
8779 kid->op_sibling = sibl;
8780 *tokid = kid;
8781 }
8782 break;
8783 case OA_FILEREF:
c340be78 8784 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
79072805 8785 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 8786 (kid->op_private & OPpCONST_BARE))
8787 {
0bd48802 8788 OP * const newop = newGVOP(OP_GV, 0,
f776e3cd 8789 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
afbdacea 8790 if (!(o->op_private & 1) && /* if not unop */
8a996ce8 8791 kid == cLISTOPo->op_last)
364daeac 8792 cLISTOPo->op_last = newop;
eb8433b7
NC		 8793#ifdef PERL_MAD
8794 op_getmad(kid,newop,'K');
8795#else
79072805 8796 op_free(kid);
eb8433b7 8797#endif
79072805
LW		 8798 kid = newop;
8799 }
1ea32a52
GS		 8800 else if (kid->op_type == OP_READLINE) {
8801 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
ce16c625 8802 bad_type_pv(numargs, "HANDLE", OP_DESC(o), 0, kid);
1ea32a52 8803 }
79072805 8804 else {
35cd451c 8805 I32 flags = OPf_SPECIAL;
a6c40364 8806 I32 priv = 0;
2c8ac474
GS		 8807 PADOFFSET targ = 0;
8808
35cd451c 8809 /* is this op a FH constructor? */
853846ea 8810 if (is_handle_constructor(o,numargs)) {
bd61b366 8811 const char *name = NULL;
dd2155a4 8812 STRLEN len = 0;
2dc9cdca 8813 U32 name_utf8 = 0;
885f468a 8814 bool want_dollar = TRUE;
2c8ac474
GS		 8815
8816 flags = 0;
8817 /* Set a flag to tell rv2gv to vivify
853846ea
NIS		 8818 * need to "prove" flag does not mean something
8819 * else already - NI-S 1999/05/07
2c8ac474
GS		 8820 */
8821 priv = OPpDEREF;
8822 if (kid->op_type == OP_PADSV) {
f8503592
NC		 8823 SV *const namesv
8824 = PAD_COMPNAME_SV(kid->op_targ);
8825 name = SvPV_const(namesv, len);
2dc9cdca 8826 name_utf8 = SvUTF8(namesv);
2c8ac474
GS		 8827 }
8828 else if (kid->op_type == OP_RV2SV
8829 && kUNOP->op_first->op_type == OP_GV)
8830 {
0bd48802 8831 GV * const gv = cGVOPx_gv(kUNOP->op_first);
2c8ac474
GS		 8832 name = GvNAME(gv);
8833 len = GvNAMELEN(gv);
2dc9cdca 8834 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
2c8ac474 8835 }
afd1915d
GS		 8836 else if (kid->op_type == OP_AELEM
8837 || kid->op_type == OP_HELEM)
8838 {
735fec84 8839 OP *firstop;
551405c4 8840 OP *op = ((BINOP*)kid)->op_first;
a4fc7abc 8841 name = NULL;
551405c4 8842 if (op) {
a0714e2c 8843 SV *tmpstr = NULL;
551405c4 8844 const char * const a =
666ea192
JH		 8845 kid->op_type == OP_AELEM ?
8846 "[]" : "{}";
0c4b0a3f
JH		 8847 if (((op->op_type == OP_RV2AV) ||
8848 (op->op_type == OP_RV2HV)) &&
735fec84
RGS		 8849 (firstop = ((UNOP*)op)->op_first) &&
8850 (firstop->op_type == OP_GV)) {
0c4b0a3f 8851 /* packagevar $a[] or $h{} */
735fec84 8852 GV * const gv = cGVOPx_gv(firstop);
0c4b0a3f
JH		 8853 if (gv)
8854 tmpstr =
8855 Perl_newSVpvf(aTHX_
8856 "%s%c...%c",
8857 GvNAME(gv),
8858 a[0], a[1]);
8859 }
8860 else if (op->op_type == OP_PADAV
8861 || op->op_type == OP_PADHV) {
8862 /* lexicalvar $a[] or $h{} */
551405c4 8863 const char * const padname =
0c4b0a3f
JH		 8864 PAD_COMPNAME_PV(op->op_targ);
8865 if (padname)
8866 tmpstr =
8867 Perl_newSVpvf(aTHX_
8868 "%s%c...%c",
8869 padname + 1,
8870 a[0], a[1]);
0c4b0a3f
JH		 8871 }
8872 if (tmpstr) {
93524f2b 8873 name = SvPV_const(tmpstr, len);
2dc9cdca 8874 name_utf8 = SvUTF8(tmpstr);
0c4b0a3f
JH		 8875 sv_2mortal(tmpstr);
8876 }
8877 }
8878 if (!name) {
8879 name = "__ANONIO__";
8880 len = 10;
885f468a 8881 want_dollar = FALSE;
0c4b0a3f 8882 }
3ad73efd 8883 op_lvalue(kid, type);
afd1915d 8884 }
2c8ac474
GS		 8885 if (name) {
8886 SV *namesv;
8887 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
dd2155a4 8888 namesv = PAD_SVl(targ);
862a34c6 8889 SvUPGRADE(namesv, SVt_PV);
885f468a 8890 if (want_dollar && *name != '$')
76f68e9b 8891 sv_setpvs(namesv, "$");
2c8ac474 8892 sv_catpvn(namesv, name, len);
2dc9cdca 8893 if ( name_utf8 ) SvUTF8_on(namesv);
2c8ac474 8894 }
853846ea 8895 }
79072805 8896 kid->op_sibling = 0;
35cd451c 8897 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
2c8ac474
GS		 8898 kid->op_targ = targ;
8899 kid->op_private |= priv;
79072805
LW		 8900 }
8901 kid->op_sibling = sibl;
8902 *tokid = kid;
8903 }
8904 scalar(kid);
8905 break;
8906 case OA_SCALARREF:
1efec5ed
FC		 8907 if ((type == OP_UNDEF || type == OP_POS)
8908 && numargs == 1 && !(oa >> 4)
89c5c07e
FC		 8909 && kid->op_type == OP_LIST)
8910 return too_many_arguments_pv(o,PL_op_desc[type], 0);
3ad73efd 8911 op_lvalue(scalar(kid), type);
79072805
LW		 8912 break;
8913 }
8914 oa >>= 4;
8915 tokid = &kid->op_sibling;
8916 kid = kid->op_sibling;
8917 }
eb8433b7
NC		 8918#ifdef PERL_MAD
8919 if (kid && kid->op_type != OP_STUB)
ce16c625 8920 return too_many_arguments_pv(o,OP_DESC(o), 0);
eb8433b7
NC		 8921 o->op_private |= numargs;
8922#else
8923 /* FIXME - should the numargs move as for the PERL_MAD case? */
11343788 8924 o->op_private |= numargs;
79072805 8925 if (kid)
ce16c625 8926 return too_many_arguments_pv(o,OP_DESC(o), 0);
eb8433b7 8927#endif
11343788 8928 listkids(o);
79072805 8929 }
22c35a8c 8930 else if (PL_opargs[type] & OA_DEFGV) {
c56915e3 8931#ifdef PERL_MAD
c7fe699d 8932 OP *newop = newUNOP(type, 0, newDEFSVOP());
c56915e3 8933 op_getmad(o,newop,'O');
c7fe699d 8934 return newop;
c56915e3 8935#else
c7fe699d 8936 /* Ordering of these two is important to keep f_map.t passing. */
11343788 8937 op_free(o);
c7fe699d 8938 return newUNOP(type, 0, newDEFSVOP());
c56915e3 8939#endif
a0d0e21e
LW		 8940 }
8941
79072805
LW		 8942 if (oa) {
8943 while (oa & OA_OPTIONAL)
8944 oa >>= 4;
8945 if (oa && oa != OA_LIST)
ce16c625 8946 return too_few_arguments_pv(o,OP_DESC(o), 0);
79072805 8947 }
11343788 8948 return o;
79072805
LW		 8949}
8950
8951OP *
cea2e8a9 8952Perl_ck_glob(pTHX_ OP *o)
79072805 8953{
27da23d5 8954 dVAR;
fb73857a 8955 GV *gv;
d67594ff 8956 const bool core = o->op_flags & OPf_SPECIAL;
fb73857a 8957
7918f24d
NC		 8958 PERL_ARGS_ASSERT_CK_GLOB;
8959
649da076 8960 o = ck_fun(o);
1f2bfc8a 8961 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
bd31915d 8962 op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
fb73857a 8963
d67594ff
FC		 8964 if (core) gv = NULL;
8965 else if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
b9f751c0
GS		 8966 && GvCVu(gv) && GvIMPORTED_CV(gv)))
8967 {
8113e1cc
FC		 8968 GV * const * const gvp =
8969 (GV **)hv_fetchs(PL_globalstash, "glob", FALSE);
8970 gv = gvp ? *gvp : NULL;
b9f751c0 8971 }
b1cb66bf 8972
b9f751c0 8973 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
d1bea3d8
DM		 8974 /* convert
8975 * glob
8976 * \ null - const(wildcard)
8977 * into
8978 * null
8979 * \ enter
8980 * \ list
8981 * \ mark - glob - rv2cv
8982 * | \ gv(CORE::GLOBAL::glob)
8983 * |
9423a867 8984 * \ null - const(wildcard)
d1bea3d8
DM		 8985 */
8986 o->op_flags |= OPf_SPECIAL;
9426e1a5 8987 o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
d1bea3d8 8988 o = newLISTOP(OP_LIST, 0, o, NULL);
1f2bfc8a 8989 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
2fcb4757 8990 op_append_elem(OP_LIST, o,
1f2bfc8a
MB		 8991 scalar(newUNOP(OP_RV2CV, 0,
8992 newGVOP(OP_GV, 0, gv)))));
7ae76aaa 8993 o = newUNOP(OP_NULL, 0, o);
d1bea3d8 8994 o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
d58bf5aa 8995 return o;
b1cb66bf 8996 }
d67594ff 8997 else o->op_flags &= ~OPf_SPECIAL;
39e3b1bc
FC		 8998#if !defined(PERL_EXTERNAL_GLOB)
8999 if (!PL_globhook) {
9000 ENTER;
9001 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
9002 newSVpvs("File::Glob"), NULL, NULL, NULL);
9003 LEAVE;
9004 }
9005#endif /* !PERL_EXTERNAL_GLOB */
e88567f2
FC		 9006 gv = (GV *)newSV(0);
9007 gv_init(gv, 0, "", 0, 0);
a0d0e21e 9008 gv_IOadd(gv);
2fcb4757 9009 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
fc2b2dca 9010 SvREFCNT_dec_NN(gv); /* newGVOP increased it */
11343788 9011 scalarkids(o);
649da076 9012 return o;
79072805
LW		 9013}
9014
9015OP *
cea2e8a9 9016Perl_ck_grep(pTHX_ OP *o)
79072805 9017{
27da23d5 9018 dVAR;
2471236a 9019 LOGOP *gwop;
79072805 9020 OP *kid;
6867be6d 9021 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
9f7d9405 9022 PADOFFSET offset;
79072805 9023
7918f24d
NC		 9024 PERL_ARGS_ASSERT_CK_GREP;
9025
22c35a8c 9026 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
13765c85 9027 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
aeea060c 9028
11343788 9029 if (o->op_flags & OPf_STACKED) {
2471236a 9030 kid = cUNOPx(cLISTOPo->op_first->op_sibling)->op_first;
f6435df3
GG		 9031 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
9032 return no_fh_allowed(o);
11343788 9033 o->op_flags &= ~OPf_STACKED;
93a17b20 9034 }
11343788 9035 kid = cLISTOPo->op_first->op_sibling;
a0d0e21e
LW		 9036 if (type == OP_MAPWHILE)
9037 list(kid);
9038 else
9039 scalar(kid);
11343788 9040 o = ck_fun(o);
13765c85 9041 if (PL_parser && PL_parser->error_count)
11343788 9042 return o;
aeea060c 9043 kid = cLISTOPo->op_first->op_sibling;
79072805 9044 if (kid->op_type != OP_NULL)
5637ef5b 9045 Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
79072805
LW		 9046 kid = kUNOP->op_first;
9047
2471236a 9048 NewOp(1101, gwop, 1, LOGOP);
a0d0e21e 9049 gwop->op_type = type;
22c35a8c 9050 gwop->op_ppaddr = PL_ppaddr[type];
09fe0e74 9051 gwop->op_first = o;
79072805 9052 gwop->op_flags |= OPf_KIDS;
79072805 9053 gwop->op_other = LINKLIST(kid);
79072805 9054 kid->op_next = (OP*)gwop;
cc76b5cc 9055 offset = pad_findmy_pvs("$_", 0);
00b1698f 9056 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
59f00321
RGS		 9057 o->op_private = gwop->op_private = 0;
9058 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
9059 }
9060 else {
9061 o->op_private = gwop->op_private = OPpGREP_LEX;
9062 gwop->op_targ = o->op_targ = offset;
9063 }
79072805 9064
11343788 9065 kid = cLISTOPo->op_first->op_sibling;
a0d0e21e 9066 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
3ad73efd 9067 op_lvalue(kid, OP_GREPSTART);
a0d0e21e 9068
79072805
LW		 9069 return (OP*)gwop;
9070}
9071
9072OP *
cea2e8a9 9073Perl_ck_index(pTHX_ OP *o)
79072805 9074{
7918f24d
NC		 9075 PERL_ARGS_ASSERT_CK_INDEX;
9076
11343788
MB		 9077 if (o->op_flags & OPf_KIDS) {
9078 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
0b71040e
LW		 9079 if (kid)
9080 kid = kid->op_sibling; /* get past "big" */
3b36395d 9081 if (kid && kid->op_type == OP_CONST) {
284167a5 9082 const bool save_taint = TAINT_get; /* accepted unused var warning if NO_TAINT_SUPPORT */
2779dcf1 9083 fbm_compile(((SVOP*)kid)->op_sv, 0);
284167a5 9084 TAINT_set(save_taint);
3b36395d 9085 }
79072805 9086 }
11343788 9087 return ck_fun(o);
79072805
LW		 9088}
9089
9090OP *
cea2e8a9 9091Perl_ck_lfun(pTHX_ OP *o)
79072805 9092{
6867be6d 9093 const OPCODE type = o->op_type;
7918f24d
NC		 9094
9095 PERL_ARGS_ASSERT_CK_LFUN;
9096
5dc0d613 9097 return modkids(ck_fun(o), type);
79072805
LW		 9098}
9099
9100OP *
cea2e8a9 9101Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
69794302 9102{
7918f24d
NC		 9103 PERL_ARGS_ASSERT_CK_DEFINED;
9104
a2a5de95 9105 if ((o->op_flags & OPf_KIDS)) {
d0334bed
GS		 9106 switch (cUNOPo->op_first->op_type) {
9107 case OP_RV2AV:
9108 case OP_PADAV:
9109 case OP_AASSIGN: /* Is this a good idea? */
d1d15184 9110 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
a2a5de95 9111 "defined(@array) is deprecated");
d1d15184 9112 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
a2a5de95 9113 "\t(Maybe you should just omit the defined()?)\n");
69794302 9114 break;
d0334bed
GS		 9115 case OP_RV2HV:
9116 case OP_PADHV:
d1d15184 9117 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
a2a5de95 9118 "defined(%%hash) is deprecated");
d1d15184 9119 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
a2a5de95 9120 "\t(Maybe you should just omit the defined()?)\n");
d0334bed
GS		 9121 break;
9122 default:
9123 /* no warning */
9124 break;
9125 }
69794302
MJD		 9126 }
9127 return ck_rfun(o);
9128}
9129
9130OP *
e4b7ebf3
RGS		 9131Perl_ck_readline(pTHX_ OP *o)
9132{
7918f24d
NC		 9133 PERL_ARGS_ASSERT_CK_READLINE;
9134
b73e5385
FC		 9135 if (o->op_flags & OPf_KIDS) {
9136 OP *kid = cLISTOPo->op_first;
9137 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
9138 }
9139 else {
e4b7ebf3
RGS		 9140 OP * const newop
9141 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
9142#ifdef PERL_MAD
9143 op_getmad(o,newop,'O');
9144#else
9145 op_free(o);
9146#endif
9147 return newop;
9148 }
9149 return o;
9150}
9151
9152OP *
cea2e8a9 9153Perl_ck_rfun(pTHX_ OP *o)
8990e307 9154{
6867be6d 9155 const OPCODE type = o->op_type;
7918f24d
NC		 9156
9157 PERL_ARGS_ASSERT_CK_RFUN;
9158
5dc0d613 9159 return refkids(ck_fun(o), type);
8990e307
LW		 9160}
9161
9162OP *
cea2e8a9 9163Perl_ck_listiob(pTHX_ OP *o)
79072805 9164{
eb578fdb 9165 OP *kid;
aeea060c 9166
7918f24d
NC		 9167 PERL_ARGS_ASSERT_CK_LISTIOB;
9168
11343788 9169 kid = cLISTOPo->op_first;
79072805 9170 if (!kid) {
11343788
MB		 9171 o = force_list(o);
9172 kid = cLISTOPo->op_first;
79072805
LW		 9173 }
9174 if (kid->op_type == OP_PUSHMARK)
9175 kid = kid->op_sibling;
11343788 9176 if (kid && o->op_flags & OPf_STACKED)
79072805
LW		 9177 kid = kid->op_sibling;
9178 else if (kid && !kid->op_sibling) { /* print HANDLE; */
01050d49
FC		 9179 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
9180 && !(kid->op_private & OPpCONST_FOLDED)) {
11343788 9181 o->op_flags |= OPf_STACKED; /* make it a filehandle */
748a9306 9182 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
11343788
MB		 9183 cLISTOPo->op_first->op_sibling = kid;
9184 cLISTOPo->op_last = kid;
79072805
LW		 9185 kid = kid->op_sibling;
9186 }
9187 }
b2ffa427 9188
79072805 9189 if (!kid)
2fcb4757 9190 op_append_elem(o->op_type, o, newDEFSVOP());
79072805 9191
69974ce6 9192 if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
2de3dbcc 9193 return listkids(o);
bbce6d69 9194}
9195
9196OP *
0d863452
RH		 9197Perl_ck_smartmatch(pTHX_ OP *o)
9198{
97aff369 9199 dVAR;
a4e74480 9200 PERL_ARGS_ASSERT_CK_SMARTMATCH;
0d863452
RH		 9201 if (0 == (o->op_flags & OPf_SPECIAL)) {
9202 OP *first = cBINOPo->op_first;
9203 OP *second = first->op_sibling;
9204
9205 /* Implicitly take a reference to an array or hash */
5f66b61c 9206 first->op_sibling = NULL;
0d863452
RH		 9207 first = cBINOPo->op_first = ref_array_or_hash(first);
9208 second = first->op_sibling = ref_array_or_hash(second);
9209
9210 /* Implicitly take a reference to a regular expression */
9211 if (first->op_type == OP_MATCH) {
9212 first->op_type = OP_QR;
9213 first->op_ppaddr = PL_ppaddr[OP_QR];
9214 }
9215 if (second->op_type == OP_MATCH) {
9216 second->op_type = OP_QR;
9217 second->op_ppaddr = PL_ppaddr[OP_QR];
9218 }
9219 }
9220
9221 return o;
9222}
9223
9224
9225OP *
b162f9ea
IZ		 9226Perl_ck_sassign(pTHX_ OP *o)
9227{
3088bf26 9228 dVAR;
1496a290 9229 OP * const kid = cLISTOPo->op_first;
7918f24d
NC		 9230
9231 PERL_ARGS_ASSERT_CK_SASSIGN;
9232
b162f9ea
IZ		 9233 /* has a disposable target? */
9234 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6b66af17
GS		 9235 && !(kid->op_flags & OPf_STACKED)
9236 /* Cannot steal the second time! */
1b438339
GG		 9237 && !(kid->op_private & OPpTARGET_MY)
9238 /* Keep the full thing for madskills */
9239 && !PL_madskills
9240 )
b162f9ea 9241 {
551405c4 9242 OP * const kkid = kid->op_sibling;
b162f9ea
IZ		 9243
9244 /* Can just relocate the target. */
2c2d71f5
JH		 9245 if (kkid && kkid->op_type == OP_PADSV
9246 && !(kkid->op_private & OPpLVAL_INTRO))
9247 {
b162f9ea 9248 kid->op_targ = kkid->op_targ;
743e66e6 9249 kkid->op_targ = 0;
b162f9ea
IZ		 9250 /* Now we do not need PADSV and SASSIGN. */
9251 kid->op_sibling = o->op_sibling; /* NULL */
9252 cLISTOPo->op_first = NULL;
9253 op_free(o);
9254 op_free(kkid);
9255 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
9256 return kid;
9257 }
9258 }
c5917253
NC		 9259 if (kid->op_sibling) {
9260 OP *kkid = kid->op_sibling;
a1fba7eb
FC		 9261 /* For state variable assignment, kkid is a list op whose op_last
9262 is a padsv. */
9263 if ((kkid->op_type == OP_PADSV ||
9264 (kkid->op_type == OP_LIST &&
9265 (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
9266 )
9267 )
c5917253
NC		 9268 && (kkid->op_private & OPpLVAL_INTRO)
9269 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
9270 const PADOFFSET target = kkid->op_targ;
9271 OP *const other = newOP(OP_PADSV,
9272 kkid->op_flags
9273 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
9274 OP *const first = newOP(OP_NULL, 0);
9275 OP *const nullop = newCONDOP(0, first, o, other);
9276 OP *const condop = first->op_next;
9277 /* hijacking PADSTALE for uninitialized state variables */
9278 SvPADSTALE_on(PAD_SVl(target));
9279
9280 condop->op_type = OP_ONCE;
9281 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
9282 condop->op_targ = target;
9283 other->op_targ = target;
9284
95562366 9285 /* Because we change the type of the op here, we will skip the
486ec47a 9286 assignment binop->op_last = binop->op_first->op_sibling; at the
95562366
NC		 9287 end of Perl_newBINOP(). So need to do it here. */
9288 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
9289
c5917253
NC		 9290 return nullop;
9291 }
9292 }
b162f9ea
IZ		 9293 return o;
9294}
9295
9296OP *
cea2e8a9 9297Perl_ck_match(pTHX_ OP *o)
79072805 9298{
97aff369 9299 dVAR;
7918f24d
NC		 9300
9301 PERL_ARGS_ASSERT_CK_MATCH;
9302
0d863452 9303 if (o->op_type != OP_QR && PL_compcv) {
cc76b5cc 9304 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
00b1698f 9305 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
59f00321
RGS		 9306 o->op_targ = offset;
9307 o->op_private |= OPpTARGET_MY;
9308 }
9309 }
9310 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
9311 o->op_private |= OPpRUNTIME;
11343788 9312 return o;
79072805
LW		 9313}
9314
9315OP *
f5d5a27c
CS		 9316Perl_ck_method(pTHX_ OP *o)
9317{
551405c4 9318 OP * const kid = cUNOPo->op_first;
7918f24d
NC		 9319
9320 PERL_ARGS_ASSERT_CK_METHOD;
9321
f5d5a27c
CS		 9322 if (kid->op_type == OP_CONST) {
9323 SV* sv = kSVOP->op_sv;
a4fc7abc
AL		 9324 const char * const method = SvPVX_const(sv);
9325 if (!(strchr(method, ':') || strchr(method, '\''))) {
f5d5a27c 9326 OP *cmop;
e3918bb7 9327 if (!SvIsCOW(sv)) {
c60dbbc3 9328 sv = newSVpvn_share(method, SvUTF8(sv) ? -(I32)SvCUR(sv) : (I32)SvCUR(sv), 0);
1c846c1f
NIS		 9329 }
9330 else {
a0714e2c 9331 kSVOP->op_sv = NULL;
1c846c1f 9332 }
f5d5a27c 9333 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
eb8433b7
NC		 9334#ifdef PERL_MAD
9335 op_getmad(o,cmop,'O');
9336#else
f5d5a27c 9337 op_free(o);
eb8433b7 9338#endif
f5d5a27c
CS		 9339 return cmop;
9340 }
9341 }
9342 return o;
9343}
9344
9345OP *
cea2e8a9 9346Perl_ck_null(pTHX_ OP *o)
79072805 9347{
7918f24d 9348 PERL_ARGS_ASSERT_CK_NULL;
96a5add6 9349 PERL_UNUSED_CONTEXT;
11343788 9350 return o;
79072805
LW		 9351}
9352
9353OP *
16fe6d59
GS		 9354Perl_ck_open(pTHX_ OP *o)
9355{
97aff369 9356 dVAR;
551405c4 9357 HV * const table = GvHV(PL_hintgv);
7918f24d
NC		 9358
9359 PERL_ARGS_ASSERT_CK_OPEN;
9360
16fe6d59 9361 if (table) {
a4fc7abc 9362 SV **svp = hv_fetchs(table, "open_IN", FALSE);
16fe6d59 9363 if (svp && *svp) {
a79b25b7
VP		 9364 STRLEN len = 0;
9365 const char *d = SvPV_const(*svp, len);
9366 const I32 mode = mode_from_discipline(d, len);
16fe6d59
GS		 9367 if (mode & O_BINARY)
9368 o->op_private |= OPpOPEN_IN_RAW;
9369 else if (mode & O_TEXT)
9370 o->op_private |= OPpOPEN_IN_CRLF;
9371 }
9372
a4fc7abc 9373 svp = hv_fetchs(table, "open_OUT", FALSE);
16fe6d59 9374 if (svp && *svp) {
a79b25b7
VP		 9375 STRLEN len = 0;
9376 const char *d = SvPV_const(*svp, len);
9377 const I32 mode = mode_from_discipline(d, len);
16fe6d59
GS		 9378 if (mode & O_BINARY)
9379 o->op_private |= OPpOPEN_OUT_RAW;
9380 else if (mode & O_TEXT)
9381 o->op_private |= OPpOPEN_OUT_CRLF;
9382 }
9383 }
8d7403e6
RGS		 9384 if (o->op_type == OP_BACKTICK) {
9385 if (!(o->op_flags & OPf_KIDS)) {
e4b7ebf3
RGS		 9386 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
9387#ifdef PERL_MAD
9388 op_getmad(o,newop,'O');
9389#else
8d7403e6 9390 op_free(o);
e4b7ebf3
RGS		 9391#endif
9392 return newop;
8d7403e6 9393 }
16fe6d59 9394 return o;
8d7403e6 9395 }
3b82e551
JH		 9396 {
9397 /* In case of three-arg dup open remove strictness
9398 * from the last arg if it is a bareword. */
551405c4
AL		 9399 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
9400 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
3b82e551 9401 OP *oa;
b15aece3 9402 const char *mode;
3b82e551
JH		 9403
9404 if ((last->op_type == OP_CONST) && /* The bareword. */
9405 (last->op_private & OPpCONST_BARE) &&
9406 (last->op_private & OPpCONST_STRICT) &&
9407 (oa = first->op_sibling) && /* The fh. */
9408 (oa = oa->op_sibling) && /* The mode. */
ea1d064a 9409 (oa->op_type == OP_CONST) &&
3b82e551 9410 SvPOK(((SVOP*)oa)->op_sv) &&
b15aece3 9411 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
3b82e551
JH		 9412 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
9413 (last == oa->op_sibling)) /* The bareword. */
9414 last->op_private &= ~OPpCONST_STRICT;
9415 }
16fe6d59
GS		 9416 return ck_fun(o);
9417}
9418
9419OP *
cea2e8a9 9420Perl_ck_repeat(pTHX_ OP *o)
79072805 9421{
7918f24d
NC		 9422 PERL_ARGS_ASSERT_CK_REPEAT;
9423
11343788
MB		 9424 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
9425 o->op_private |= OPpREPEAT_DOLIST;
9426 cBINOPo->op_first = force_list(cBINOPo->op_first);
79072805
LW		 9427 }
9428 else
11343788
MB		 9429 scalar(o);
9430 return o;
79072805
LW		 9431}
9432
9433OP *
cea2e8a9 9434Perl_ck_require(pTHX_ OP *o)
8990e307 9435{
97aff369 9436 dVAR;
a0714e2c 9437 GV* gv = NULL;
ec4ab249 9438
7918f24d
NC		 9439 PERL_ARGS_ASSERT_CK_REQUIRE;
9440
11343788 9441 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
551405c4 9442 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8990e307
LW		 9443
9444 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
551405c4 9445 SV * const sv = kid->op_sv;
5c144d81 9446 U32 was_readonly = SvREADONLY(sv);
8990e307 9447 char *s;
cfff9797
NC		 9448 STRLEN len;
9449 const char *end;
5c144d81
NC		 9450
9451 if (was_readonly) {
5c144d81 9452 SvREADONLY_off(sv);
5c144d81 9453 }
e3918bb7 9454 if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
5c144d81 9455
cfff9797
NC		 9456 s = SvPVX(sv);
9457 len = SvCUR(sv);
9458 end = s + len;
9459 for (; s < end; s++) {
a0d0e21e
LW		 9460 if (*s == ':' && s[1] == ':') {
9461 *s = '/';
5c6b2528 9462 Move(s+2, s+1, end - s - 1, char);
cfff9797 9463 --end;
a0d0e21e 9464 }
8990e307 9465 }
cfff9797 9466 SvEND_set(sv, end);
396482e1 9467 sv_catpvs(sv, ".pm");
5c144d81 9468 SvFLAGS(sv) |= was_readonly;
8990e307
LW		 9469 }
9470 }
ec4ab249 9471
a72a1c8b
RGS		 9472 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
9473 /* handle override, if any */
fafc274c 9474 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
d6a985f2 9475 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
a4fc7abc 9476 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
a0714e2c 9477 gv = gvp ? *gvp : NULL;
d6a985f2 9478 }
a72a1c8b 9479 }
ec4ab249 9480
b9f751c0 9481 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7c864bb3
VP		 9482 OP *kid, *newop;
9483 if (o->op_flags & OPf_KIDS) {
9484 kid = cUNOPo->op_first;
9485 cUNOPo->op_first = NULL;
9486 }
9487 else {
9488 kid = newDEFSVOP();
9489 }
f11453cb 9490#ifndef PERL_MAD
ec4ab249 9491 op_free(o);
eb8433b7 9492#endif
d1bef648 9493 newop = newUNOP(OP_ENTERSUB, OPf_STACKED,
2fcb4757 9494 op_append_elem(OP_LIST, kid,
f11453cb
NC		 9495 scalar(newUNOP(OP_RV2CV, 0,
9496 newGVOP(OP_GV, 0,
d1bef648 9497 gv)))));
f11453cb 9498 op_getmad(o,newop,'O');
eb8433b7 9499 return newop;
ec4ab249
GA		 9500 }
9501
021f53de 9502 return scalar(ck_fun(o));
8990e307
LW		 9503}
9504
78f9721b
SM		 9505OP *
9506Perl_ck_return(pTHX_ OP *o)
9507{
97aff369 9508 dVAR;
e91684bf 9509 OP *kid;
7918f24d
NC		 9510
9511 PERL_ARGS_ASSERT_CK_RETURN;
9512
e91684bf 9513 kid = cLISTOPo->op_first->op_sibling;
78f9721b 9514 if (CvLVALUE(PL_compcv)) {
e91684bf 9515 for (; kid; kid = kid->op_sibling)
3ad73efd 9516 op_lvalue(kid, OP_LEAVESUBLV);
78f9721b 9517 }
e91684bf 9518
78f9721b
SM		 9519 return o;
9520}
9521
79072805 9522OP *
cea2e8a9 9523Perl_ck_select(pTHX_ OP *o)
79072805 9524{
27da23d5 9525 dVAR;
c07a80fd 9526 OP* kid;
7918f24d
NC		 9527
9528 PERL_ARGS_ASSERT_CK_SELECT;
9529
11343788
MB		 9530 if (o->op_flags & OPf_KIDS) {
9531 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
2304df62 9532 if (kid && kid->op_sibling) {
11343788 9533 o->op_type = OP_SSELECT;
22c35a8c 9534 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
11343788 9535 o = ck_fun(o);
985b9e54 9536 return fold_constants(op_integerize(op_std_init(o)));
79072805
LW		 9537 }
9538 }
11343788
MB		 9539 o = ck_fun(o);
9540 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
c07a80fd 9541 if (kid && kid->op_type == OP_RV2GV)
9542 kid->op_private &= ~HINT_STRICT_REFS;
11343788 9543 return o;
79072805
LW		 9544}
9545
9546OP *
cea2e8a9 9547Perl_ck_shift(pTHX_ OP *o)
79072805 9548{
97aff369 9549 dVAR;
6867be6d 9550 const I32 type = o->op_type;
79072805 9551
7918f24d
NC		 9552 PERL_ARGS_ASSERT_CK_SHIFT;
9553
11343788 9554 if (!(o->op_flags & OPf_KIDS)) {
538f5756
RZ		 9555 OP *argop;
9556
9557 if (!CvUNIQUE(PL_compcv)) {
9558 o->op_flags |= OPf_SPECIAL;
9559 return o;
9560 }
9561
9562 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
eb8433b7 9563#ifdef PERL_MAD
790427a5
DM		 9564 {
9565 OP * const oldo = o;
9566 o = newUNOP(type, 0, scalar(argop));
9567 op_getmad(oldo,o,'O');
9568 return o;
9569 }
eb8433b7 9570#else
821005df 9571 op_free(o);
6d4ff0d2 9572 return newUNOP(type, 0, scalar(argop));
eb8433b7 9573#endif
79072805 9574 }
d4fc4415 9575 return scalar(ck_fun(o));
79072805
LW		 9576}
9577
9578OP *
cea2e8a9 9579Perl_ck_sort(pTHX_ OP *o)
79072805 9580{
97aff369 9581 dVAR;
8e3f9bdf 9582 OP *firstkid;
354dd559 9583 HV * const hinthv = GvHV(PL_hintgv);
bbce6d69 9584
7918f24d
NC		 9585 PERL_ARGS_ASSERT_CK_SORT;
9586
354dd559 9587 if (hinthv) {
a4fc7abc 9588 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7b9ef140 9589 if (svp) {
a4fc7abc 9590 const I32 sorthints = (I32)SvIV(*svp);
7b9ef140
RH		 9591 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
9592 o->op_private |= OPpSORT_QSORT;
9593 if ((sorthints & HINT_SORT_STABLE) != 0)
9594 o->op_private |= OPpSORT_STABLE;
9595 }
7b9ef140
RH		 9596 }
9597
354dd559 9598 if (o->op_flags & OPf_STACKED)
51a19bc0 9599 simplify_sort(o);
8e3f9bdf
GS		 9600 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
9601 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
8e3f9bdf 9602 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
79072805 9603
463ee0b2 9604 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
5983a79d 9605 LINKLIST(kid);
c650d697 9606 if (kid->op_type == OP_LEAVE)
93c66552 9607 op_null(kid); /* wipe out leave */
c650d697
FC		 9608 /* Prevent execution from escaping out of the sort block. */
9609 kid->op_next = 0;
a0d0e21e 9610
354dd559
FC		 9611 /* provide scalar context for comparison function/block */
9612 kid = scalar(firstkid);
9613 kid->op_next = kid;
11343788 9614 o->op_flags |= OPf_SPECIAL;
79072805 9615 }
8e3f9bdf
GS		 9616
9617 firstkid = firstkid->op_sibling;
79072805 9618 }
bbce6d69 9619
8e3f9bdf 9620 /* provide list context for arguments */
354dd559 9621 list(firstkid);
8e3f9bdf 9622
11343788 9623 return o;
79072805 9624}
bda4119b
GS		 9625
9626STATIC void
cea2e8a9 9627S_simplify_sort(pTHX_ OP *o)
9c007264 9628{
97aff369 9629 dVAR;
eb578fdb 9630 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
9c007264 9631 OP *k;
eb209983 9632 int descending;
350de78d 9633 GV *gv;
770526c1 9634 const char *gvname;
8023b711 9635 bool have_scopeop;
7918f24d
NC		 9636
9637 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
9638
9c007264
JH		 9639 if (!(o->op_flags & OPf_STACKED))
9640 return;
fafc274c
NC		 9641 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
9642 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
82092f1d 9643 kid = kUNOP->op_first; /* get past null */
8023b711
FC		 9644 if (!(have_scopeop = kid->op_type == OP_SCOPE)
9645 && kid->op_type != OP_LEAVE)
9c007264
JH		 9646 return;
9647 kid = kLISTOP->op_last; /* get past scope */
9648 switch(kid->op_type) {
9649 case OP_NCMP:
9650 case OP_I_NCMP:
9651 case OP_SCMP:
8023b711 9652 if (!have_scopeop) goto padkids;
9c007264
JH		 9653 break;
9654 default:
9655 return;
9656 }
9657 k = kid; /* remember this node*/
271c8bde
FC		 9658 if (kBINOP->op_first->op_type != OP_RV2SV
9659 || kBINOP->op_last ->op_type != OP_RV2SV)
9660 {
9661 /*
9662 Warn about my($a) or my($b) in a sort block, *if* $a or $b is
9663 then used in a comparison. This catches most, but not
9664 all cases. For instance, it catches
9665 sort { my($a); $a <=> $b }
9666 but not
9667 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
9668 (although why you'd do that is anyone's guess).
9669 */
9670
9671 padkids:
9672 if (!ckWARN(WARN_SYNTAX)) return;
9673 kid = kBINOP->op_first;
9674 do {
9675 if (kid->op_type == OP_PADSV) {
9676 SV * const name = AvARRAY(PL_comppad_name)[kid->op_targ];
9677 if (SvCUR(name) == 2 && *SvPVX(name) == '$'
9678 && (SvPVX(name)[1] == 'a' || SvPVX(name)[1] == 'b'))
a2e39214 9679 /* diag_listed_as: "my %s" used in sort comparison */
271c8bde 9680 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
a2e39214
FC		 9681 "\"%s %s\" used in sort comparison",
9682 SvPAD_STATE(name) ? "state" : "my",
271c8bde
FC		 9683 SvPVX(name));
9684 }
9685 } while ((kid = kid->op_sibling));
9c007264 9686 return;
271c8bde 9687 }
9c007264
JH		 9688 kid = kBINOP->op_first; /* get past cmp */
9689 if (kUNOP->op_first->op_type != OP_GV)
9690 return;
9691 kid = kUNOP->op_first; /* get past rv2sv */
638eceb6 9692 gv = kGVOP_gv;
350de78d 9693 if (GvSTASH(gv) != PL_curstash)
9c007264 9694 return;
770526c1
NC		 9695 gvname = GvNAME(gv);
9696 if (*gvname == 'a' && gvname[1] == '\0')
eb209983 9697 descending = 0;
770526c1 9698 else if (*gvname == 'b' && gvname[1] == '\0')
eb209983 9699 descending = 1;
9c007264
JH		 9700 else
9701 return;
eb209983 9702
9c007264 9703 kid = k; /* back to cmp */
271c8bde 9704 /* already checked above that it is rv2sv */
9c007264
JH		 9705 kid = kBINOP->op_last; /* down to 2nd arg */
9706 if (kUNOP->op_first->op_type != OP_GV)
9707 return;
9708 kid = kUNOP->op_first; /* get past rv2sv */
638eceb6 9709 gv = kGVOP_gv;
770526c1
NC		 9710 if (GvSTASH(gv) != PL_curstash)
9711 return;
9712 gvname = GvNAME(gv);
9713 if ( descending
9714 ? !(*gvname == 'a' && gvname[1] == '\0')
9715 : !(*gvname == 'b' && gvname[1] == '\0'))
9c007264
JH		 9716 return;
9717 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
eb209983
NC		 9718 if (descending)
9719 o->op_private |= OPpSORT_DESCEND;
9c007264
JH		 9720 if (k->op_type == OP_NCMP)
9721 o->op_private |= OPpSORT_NUMERIC;
9722 if (k->op_type == OP_I_NCMP)
9723 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
e507f050
SM		 9724 kid = cLISTOPo->op_first->op_sibling;
9725 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
eb8433b7
NC		 9726#ifdef PERL_MAD
9727 op_getmad(kid,o,'S'); /* then delete it */
9728#else
e507f050 9729 op_free(kid); /* then delete it */
eb8433b7 9730#endif
9c007264 9731}
79072805
LW		 9732
9733OP *
cea2e8a9 9734Perl_ck_split(pTHX_ OP *o)
79072805 9735{
27da23d5 9736 dVAR;
eb578fdb 9737 OP *kid;
aeea060c 9738
7918f24d
NC		 9739 PERL_ARGS_ASSERT_CK_SPLIT;
9740
11343788
MB		 9741 if (o->op_flags & OPf_STACKED)
9742 return no_fh_allowed(o);
79072805 9743
11343788 9744 kid = cLISTOPo->op_first;
8990e307 9745 if (kid->op_type != OP_NULL)
5637ef5b 9746 Perl_croak(aTHX_ "panic: ck_split, type=%u", (unsigned) kid->op_type);
8990e307 9747 kid = kid->op_sibling;
11343788 9748 op_free(cLISTOPo->op_first);
f126b75f
MW		 9749 if (kid)
9750 cLISTOPo->op_first = kid;
9751 else {
396482e1 9752 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
11343788 9753 cLISTOPo->op_last = kid; /* There was only one element previously */
85e6fe83 9754 }
79072805 9755
5255171e
FC		 9756 if (kid->op_type == OP_CONST && !(kid->op_private & OPpCONST_FOLDED)) {
9757 SV * const sv = kSVOP->op_sv;
9758 if (SvPOK(sv) && SvCUR(sv) == 1 && *SvPVX(sv) == ' ')
9759 o->op_flags |= OPf_SPECIAL;
9760 }
de4bf5b3 9761 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
551405c4 9762 OP * const sibl = kid->op_sibling;
463ee0b2 9763 kid->op_sibling = 0;
5255171e 9764 kid = pmruntime( newPMOP(OP_MATCH, 0), kid, 0, 0);
11343788
MB		 9765 if (cLISTOPo->op_first == cLISTOPo->op_last)
9766 cLISTOPo->op_last = kid;
9767 cLISTOPo->op_first = kid;
79072805
LW		 9768 kid->op_sibling = sibl;
9769 }
9770
9771 kid->op_type = OP_PUSHRE;
22c35a8c 9772 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
79072805 9773 scalar(kid);
a2a5de95
NC		 9774 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
9775 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
9776 "Use of /g modifier is meaningless in split");
f34840d8 9777 }
79072805
LW		 9778
9779 if (!kid->op_sibling)
2fcb4757 9780 op_append_elem(OP_SPLIT, o, newDEFSVOP());
79072805
LW		 9781
9782 kid = kid->op_sibling;
9783 scalar(kid);
9784
9785 if (!kid->op_sibling)
2fcb4757 9786 op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
ce3e5c45 9787 assert(kid->op_sibling);
79072805
LW		 9788
9789 kid = kid->op_sibling;
9790 scalar(kid);
9791
9792 if (kid->op_sibling)
ce16c625 9793 return too_many_arguments_pv(o,OP_DESC(o), 0);
79072805 9794
11343788 9795 return o;
79072805
LW		 9796}
9797
9798OP *
1c846c1f 9799Perl_ck_join(pTHX_ OP *o)
eb6e2d6f 9800{
551405c4 9801 const OP * const kid = cLISTOPo->op_first->op_sibling;
7918f24d
NC		 9802
9803 PERL_ARGS_ASSERT_CK_JOIN;
9804
041457d9
DM		 9805 if (kid && kid->op_type == OP_MATCH) {
9806 if (ckWARN(WARN_SYNTAX)) {
6867be6d 9807 const REGEXP *re = PM_GETRE(kPMOP);
ce16c625
BF		 9808 const SV *msg = re
9809 ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
9810 SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
9811 : newSVpvs_flags( "STRING", SVs_TEMP );
9014280d 9812 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
ce16c625
BF		 9813 "/%"SVf"/ should probably be written as \"%"SVf"\"",
9814 SVfARG(msg), SVfARG(msg));
eb6e2d6f
GS		 9815 }
9816 }
9817 return ck_fun(o);
9818}
9819
d9088386
Z		 9820/*
9821=for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
9822
9823Examines an op, which is expected to identify a subroutine at runtime,
9824and attempts to determine at compile time which subroutine it identifies.
9825This is normally used during Perl compilation to determine whether
9826a prototype can be applied to a function call. I<cvop> is the op
9827being considered, normally an C<rv2cv> op. A pointer to the identified
9828subroutine is returned, if it could be determined statically, and a null
9829pointer is returned if it was not possible to determine statically.
9830
9831Currently, the subroutine can be identified statically if the RV that the
9832C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
9833A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
9834suitable if the constant value must be an RV pointing to a CV. Details of
9835this process may change in future versions of Perl. If the C<rv2cv> op
9836has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
9837the subroutine statically: this flag is used to suppress compile-time
9838magic on a subroutine call, forcing it to use default runtime behaviour.
9839
9840If I<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
9841of a GV reference is modified. If a GV was examined and its CV slot was
9842found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
9843If the op is not optimised away, and the CV slot is later populated with
9844a subroutine having a prototype, that flag eventually triggers the warning
9845"called too early to check prototype".
9846
9847If I<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
9848of returning a pointer to the subroutine it returns a pointer to the
9849GV giving the most appropriate name for the subroutine in this context.
9850Normally this is just the C<CvGV> of the subroutine, but for an anonymous
9851(C<CvANON>) subroutine that is referenced through a GV it will be the
9852referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
9853A null pointer is returned as usual if there is no statically-determinable
9854subroutine.
7918f24d 9855
d9088386
Z		 9856=cut
9857*/
9d88f058 9858
d9088386
Z		 9859CV *
9860Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
9861{
9862 OP *rvop;
9863 CV *cv;
9864 GV *gv;
9865 PERL_ARGS_ASSERT_RV2CV_OP_CV;
9866 if (flags & ~(RV2CVOPCV_MARK_EARLY|RV2CVOPCV_RETURN_NAME_GV))
9867 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
9868 if (cvop->op_type != OP_RV2CV)
9869 return NULL;
9870 if (cvop->op_private & OPpENTERSUB_AMPER)
9871 return NULL;
9872 if (!(cvop->op_flags & OPf_KIDS))
9873 return NULL;
9874 rvop = cUNOPx(cvop)->op_first;
9875 switch (rvop->op_type) {
9876 case OP_GV: {
9877 gv = cGVOPx_gv(rvop);
9878 cv = GvCVu(gv);
9879 if (!cv) {
9880 if (flags & RV2CVOPCV_MARK_EARLY)
9881 rvop->op_private |= OPpEARLY_CV;
9882 return NULL;
46fc3d4c 9883 }
d9088386
Z		 9884 } break;
9885 case OP_CONST: {
9886 SV *rv = cSVOPx_sv(rvop);
9887 if (!SvROK(rv))
9888 return NULL;
9889 cv = (CV*)SvRV(rv);
9890 gv = NULL;
9891 } break;
279d09bf
FC		 9892 case OP_PADCV: {
9893 PADNAME *name = PAD_COMPNAME(rvop->op_targ);
9894 CV *compcv = PL_compcv;
81df9f6f
FC		 9895 PADOFFSET off = rvop->op_targ;
9896 while (PadnameOUTER(name)) {
279d09bf
FC		 9897 assert(PARENT_PAD_INDEX(name));
9898 compcv = CvOUTSIDE(PL_compcv);
279d09bf 9899 name = PadlistNAMESARRAY(CvPADLIST(compcv))
81df9f6f 9900 [off = PARENT_PAD_INDEX(name)];
279d09bf 9901 }
81df9f6f
FC		 9902 assert(!PadnameIsOUR(name));
9903 if (!PadnameIsSTATE(name)) {
9904 MAGIC * mg = mg_find(name, PERL_MAGIC_proto);
279d09bf
FC		 9905 assert(mg);
9906 assert(mg->mg_obj);
9907 cv = (CV *)mg->mg_obj;
9908 }
81df9f6f
FC		 9909 else cv =
9910 (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
279d09bf
FC		 9911 gv = NULL;
9912 } break;
d9088386
Z		 9913 default: {
9914 return NULL;
9915 } break;
4633a7c4 9916 }
d9088386
Z		 9917 if (SvTYPE((SV*)cv) != SVt_PVCV)
9918 return NULL;
9919 if (flags & RV2CVOPCV_RETURN_NAME_GV) {
9920 if (!CvANON(cv) || !gv)
9921 gv = CvGV(cv);
9922 return (CV*)gv;
9923 } else {
9924 return cv;
7a52d87a 9925 }
d9088386 9926}
9d88f058 9927
d9088386
Z		 9928/*
9929=for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
824afba1 9930
d9088386
Z		 9931Performs the default fixup of the arguments part of an C<entersub>
9932op tree. This consists of applying list context to each of the
9933argument ops. This is the standard treatment used on a call marked
9934with C<&>, or a method call, or a call through a subroutine reference,
9935or any other call where the callee can't be identified at compile time,
9936or a call where the callee has no prototype.
824afba1 9937
d9088386
Z		 9938=cut
9939*/
340458b5 9940
d9088386
Z		 9941OP *
9942Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
9943{
9944 OP *aop;
9945 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
9946 aop = cUNOPx(entersubop)->op_first;
9947 if (!aop->op_sibling)
9948 aop = cUNOPx(aop)->op_first;
9949 for (aop = aop->op_sibling; aop->op_sibling; aop = aop->op_sibling) {
9950 if (!(PL_madskills && aop->op_type == OP_STUB)) {
9951 list(aop);
3ad73efd 9952 op_lvalue(aop, OP_ENTERSUB);
d9088386
Z		 9953 }
9954 }
9955 return entersubop;
9956}
340458b5 9957
d9088386
Z		 9958/*
9959=for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
9960
9961Performs the fixup of the arguments part of an C<entersub> op tree
9962based on a subroutine prototype. This makes various modifications to
9963the argument ops, from applying context up to inserting C<refgen> ops,
9964and checking the number and syntactic types of arguments, as directed by
9965the prototype. This is the standard treatment used on a subroutine call,
9966not marked with C<&>, where the callee can be identified at compile time
9967and has a prototype.
9968
9969I<protosv> supplies the subroutine prototype to be applied to the call.
9970It may be a normal defined scalar, of which the string value will be used.
9971Alternatively, for convenience, it may be a subroutine object (a C<CV*>
9972that has been cast to C<SV*>) which has a prototype. The prototype
9973supplied, in whichever form, does not need to match the actual callee
9974referenced by the op tree.
9975
9976If the argument ops disagree with the prototype, for example by having
9977an unacceptable number of arguments, a valid op tree is returned anyway.
9978The error is reflected in the parser state, normally resulting in a single
9979exception at the top level of parsing which covers all the compilation
9980errors that occurred. In the error message, the callee is referred to
9981by the name defined by the I<namegv> parameter.
cbf82dd0 9982
d9088386
Z		 9983=cut
9984*/
9985
9986OP *
9987Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
9988{
9989 STRLEN proto_len;
9990 const char *proto, *proto_end;
9991 OP *aop, *prev, *cvop;
9992 int optional = 0;
9993 I32 arg = 0;
9994 I32 contextclass = 0;
9995 const char *e = NULL;
9996 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
9997 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
cb197492 9998 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
5637ef5b 9999 "flags=%lx", (unsigned long) SvFLAGS(protosv));
8fa6a409
FC		 10000 if (SvTYPE(protosv) == SVt_PVCV)
10001 proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
10002 else proto = SvPV(protosv, proto_len);
d9088386
Z		 10003 proto_end = proto + proto_len;
10004 aop = cUNOPx(entersubop)->op_first;
10005 if (!aop->op_sibling)
10006 aop = cUNOPx(aop)->op_first;
10007 prev = aop;
10008 aop = aop->op_sibling;
10009 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
10010 while (aop != cvop) {
10011 OP* o3;
10012 if (PL_madskills && aop->op_type == OP_STUB) {
10013 aop = aop->op_sibling;
10014 continue;
10015 }
10016 if (PL_madskills && aop->op_type == OP_NULL)
10017 o3 = ((UNOP*)aop)->op_first;
10018 else
10019 o3 = aop;
10020
10021 if (proto >= proto_end)
ce16c625 10022 return too_many_arguments_sv(entersubop, gv_ename(namegv), 0);
d9088386
Z		 10023
10024 switch (*proto) {
597dcb2b
DG		 10025 case ';':
10026 optional = 1;
10027 proto++;
10028 continue;
10029 case '_':
10030 /* _ must be at the end */
34daab0f 10031 if (proto[1] && !strchr(";@%", proto[1]))
597dcb2b
DG		 10032 goto oops;
10033 case '$':
10034 proto++;
10035 arg++;
10036 scalar(aop);
10037 break;
10038 case '%':
10039 case '@':
10040 list(aop);
10041 arg++;
10042 break;
10043 case '&':
10044 proto++;
10045 arg++;
10046 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
ce16c625 10047 bad_type_sv(arg,
597dcb2b 10048 arg == 1 ? "block or sub {}" : "sub {}",
ce16c625 10049 gv_ename(namegv), 0, o3);
597dcb2b
DG		 10050 break;
10051 case '*':
10052 /* '*' allows any scalar type, including bareword */
10053 proto++;
10054 arg++;
10055 if (o3->op_type == OP_RV2GV)
10056 goto wrapref; /* autoconvert GLOB -> GLOBref */
10057 else if (o3->op_type == OP_CONST)
10058 o3->op_private &= ~OPpCONST_STRICT;
10059 else if (o3->op_type == OP_ENTERSUB) {
10060 /* accidental subroutine, revert to bareword */
10061 OP *gvop = ((UNOP*)o3)->op_first;
10062 if (gvop && gvop->op_type == OP_NULL) {
10063 gvop = ((UNOP*)gvop)->op_first;
10064 if (gvop) {
10065 for (; gvop->op_sibling; gvop = gvop->op_sibling)
10066 ;
10067 if (gvop &&
10068 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
10069 (gvop = ((UNOP*)gvop)->op_first) &&
10070 gvop->op_type == OP_GV)
10071 {
10072 GV * const gv = cGVOPx_gv(gvop);
10073 OP * const sibling = aop->op_sibling;
10074 SV * const n = newSVpvs("");
eb8433b7 10075#ifdef PERL_MAD
597dcb2b 10076 OP * const oldaop = aop;
eb8433b7 10077#else
597dcb2b 10078 op_free(aop);
eb8433b7 10079#endif
597dcb2b
DG		 10080 gv_fullname4(n, gv, "", FALSE);
10081 aop = newSVOP(OP_CONST, 0, n);
10082 op_getmad(oldaop,aop,'O');
10083 prev->op_sibling = aop;
10084 aop->op_sibling = sibling;
10085 }
9675f7ac
GS		 10086 }
10087 }
10088 }
597dcb2b 10089 scalar(aop);
c035a075
DG		 10090 break;
10091 case '+':
10092 proto++;
10093 arg++;
10094 if (o3->op_type == OP_RV2AV ||
10095 o3->op_type == OP_PADAV ||
10096 o3->op_type == OP_RV2HV ||
10097 o3->op_type == OP_PADHV
10098 ) {
10099 goto wrapref;
10100 }
10101 scalar(aop);
d9088386 10102 break;
597dcb2b
DG		 10103 case '[': case ']':
10104 goto oops;
d9088386 10105 break;
597dcb2b
DG		 10106 case '\\':
10107 proto++;
10108 arg++;
10109 again:
10110 switch (*proto++) {
10111 case '[':
10112 if (contextclass++ == 0) {
10113 e = strchr(proto, ']');
10114 if (!e || e == proto)
10115 goto oops;
10116 }
10117 else
10118 goto oops;
10119 goto again;
10120 break;
10121 case ']':
10122 if (contextclass) {
10123 const char *p = proto;
10124 const char *const end = proto;
10125 contextclass = 0;
062678b2
FC		 10126 while (*--p != '[')
10127 /* \[$] accepts any scalar lvalue */
10128 if (*p == '$'
10129 && Perl_op_lvalue_flags(aTHX_
10130 scalar(o3),
10131 OP_READ, /* not entersub */
10132 OP_LVALUE_NO_CROAK
10133 )) goto wrapref;
ce16c625 10134 bad_type_sv(arg, Perl_form(aTHX_ "one of %.*s",
597dcb2b 10135 (int)(end - p), p),
ce16c625 10136 gv_ename(namegv), 0, o3);
597dcb2b
DG		 10137 } else
10138 goto oops;
10139 break;
10140 case '*':
10141 if (o3->op_type == OP_RV2GV)
10142 goto wrapref;
10143 if (!contextclass)
ce16c625 10144 bad_type_sv(arg, "symbol", gv_ename(namegv), 0, o3);
597dcb2b
DG		 10145 break;
10146 case '&':
10147 if (o3->op_type == OP_ENTERSUB)
10148 goto wrapref;
10149 if (!contextclass)
ce16c625 10150 bad_type_sv(arg, "subroutine entry", gv_ename(namegv), 0,
597dcb2b
DG		 10151 o3);
10152 break;
10153 case '$':
10154 if (o3->op_type == OP_RV2SV ||
10155 o3->op_type == OP_PADSV ||
10156 o3->op_type == OP_HELEM ||
10157 o3->op_type == OP_AELEM)
10158 goto wrapref;
062678b2
FC		 10159 if (!contextclass) {
10160 /* \$ accepts any scalar lvalue */
10161 if (Perl_op_lvalue_flags(aTHX_
10162 scalar(o3),
10163 OP_READ, /* not entersub */
10164 OP_LVALUE_NO_CROAK
10165 )) goto wrapref;
ce16c625 10166 bad_type_sv(arg, "scalar", gv_ename(namegv), 0, o3);
062678b2 10167 }
597dcb2b
DG		 10168 break;
10169 case '@':
10170 if (o3->op_type == OP_RV2AV ||
10171 o3->op_type == OP_PADAV)
10172 goto wrapref;
10173 if (!contextclass)
ce16c625 10174 bad_type_sv(arg, "array", gv_ename(namegv), 0, o3);
597dcb2b
DG		 10175 break;
10176 case '%':
10177 if (o3->op_type == OP_RV2HV ||
10178 o3->op_type == OP_PADHV)
10179 goto wrapref;
10180 if (!contextclass)
ce16c625 10181 bad_type_sv(arg, "hash", gv_ename(namegv), 0, o3);
597dcb2b
DG		 10182 break;
10183 wrapref:
10184 {
10185 OP* const kid = aop;
10186 OP* const sib = kid->op_sibling;
10187 kid->op_sibling = 0;
10188 aop = newUNOP(OP_REFGEN, 0, kid);
10189 aop->op_sibling = sib;
10190 prev->op_sibling = aop;
10191 }
10192 if (contextclass && e) {
10193 proto = e + 1;
10194 contextclass = 0;
10195 }
10196 break;
10197 default: goto oops;
4633a7c4 10198 }
597dcb2b
DG		 10199 if (contextclass)
10200 goto again;
4633a7c4 10201 break;
597dcb2b
DG		 10202 case ' ':
10203 proto++;
10204 continue;
10205 default:
108f32a5
BF		 10206 oops: {
10207 SV* const tmpsv = sv_newmortal();
10208 gv_efullname3(tmpsv, namegv, NULL);
10209 Perl_croak(aTHX_ "Malformed prototype for %"SVf": %"SVf,
10210 SVfARG(tmpsv), SVfARG(protosv));
10211 }
d9088386
Z		 10212 }
10213
3ad73efd 10214 op_lvalue(aop, OP_ENTERSUB);
d9088386
Z		 10215 prev = aop;
10216 aop = aop->op_sibling;
10217 }
10218 if (aop == cvop && *proto == '_') {
10219 /* generate an access to $_ */
10220 aop = newDEFSVOP();
10221 aop->op_sibling = prev->op_sibling;
10222 prev->op_sibling = aop; /* instead of cvop */
10223 }
10224 if (!optional && proto_end > proto &&
10225 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
ce16c625 10226 return too_few_arguments_sv(entersubop, gv_ename(namegv), 0);
d9088386
Z		 10227 return entersubop;
10228}
10229
10230/*
10231=for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
10232
10233Performs the fixup of the arguments part of an C<entersub> op tree either
10234based on a subroutine prototype or using default list-context processing.
10235This is the standard treatment used on a subroutine call, not marked
10236with C<&>, where the callee can be identified at compile time.
10237
10238I<protosv> supplies the subroutine prototype to be applied to the call,
10239or indicates that there is no prototype. It may be a normal scalar,
10240in which case if it is defined then the string value will be used
10241as a prototype, and if it is undefined then there is no prototype.
10242Alternatively, for convenience, it may be a subroutine object (a C<CV*>
10243that has been cast to C<SV*>), of which the prototype will be used if it
10244has one. The prototype (or lack thereof) supplied, in whichever form,
10245does not need to match the actual callee referenced by the op tree.
10246
10247If the argument ops disagree with the prototype, for example by having
10248an unacceptable number of arguments, a valid op tree is returned anyway.
10249The error is reflected in the parser state, normally resulting in a single
10250exception at the top level of parsing which covers all the compilation
10251errors that occurred. In the error message, the callee is referred to
10252by the name defined by the I<namegv> parameter.
10253
10254=cut
10255*/
10256
10257OP *
10258Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
10259 GV *namegv, SV *protosv)
10260{
10261 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
10262 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
10263 return ck_entersub_args_proto(entersubop, namegv, protosv);
10264 else
10265 return ck_entersub_args_list(entersubop);
10266}
10267
4aaa4757
FC		 10268OP *
10269Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
10270{
10271 int opnum = SvTYPE(protosv) == SVt_PVCV ? 0 : (int)SvUV(protosv);
10272 OP *aop = cUNOPx(entersubop)->op_first;
10273
10274 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
10275
10276 if (!opnum) {
14f0f125 10277 OP *cvop;
4aaa4757
FC		 10278 if (!aop->op_sibling)
10279 aop = cUNOPx(aop)->op_first;
4aaa4757
FC		 10280 aop = aop->op_sibling;
10281 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
10282 if (PL_madskills) while (aop != cvop && aop->op_type == OP_STUB) {
10283 aop = aop->op_sibling;
4aaa4757
FC		 10284 }
10285 if (aop != cvop)
ce16c625 10286 (void)too_many_arguments_pv(entersubop, GvNAME(namegv), 0);
4aaa4757
FC		 10287
10288 op_free(entersubop);
10289 switch(GvNAME(namegv)[2]) {
10290 case 'F': return newSVOP(OP_CONST, 0,
10291 newSVpv(CopFILE(PL_curcop),0));
10292 case 'L': return newSVOP(
10293 OP_CONST, 0,
10294 Perl_newSVpvf(aTHX_
10295 "%"IVdf, (IV)CopLINE(PL_curcop)
10296 )
10297 );
10298 case 'P': return newSVOP(OP_CONST, 0,
10299 (PL_curstash
10300 ? newSVhek(HvNAME_HEK(PL_curstash))
10301 : &PL_sv_undef
10302 )
10303 );
10304 }
10305 assert(0);
10306 }
10307 else {
10308 OP *prev, *cvop;
7d789282 10309 U32 flags;
4aaa4757
FC		 10310#ifdef PERL_MAD
10311 bool seenarg = FALSE;
10312#endif
10313 if (!aop->op_sibling)
10314 aop = cUNOPx(aop)->op_first;
10315
10316 prev = aop;
10317 aop = aop->op_sibling;
10318 prev->op_sibling = NULL;
10319 for (cvop = aop;
10320 cvop->op_sibling;
10321 prev=cvop, cvop = cvop->op_sibling)
10322#ifdef PERL_MAD
10323 if (PL_madskills && cvop->op_sibling
10324 && cvop->op_type != OP_STUB) seenarg = TRUE
10325#endif
10326 ;
10327 prev->op_sibling = NULL;
7d789282 10328 flags = OPf_SPECIAL * !(cvop->op_private & OPpENTERSUB_NOPAREN);
4aaa4757
FC		 10329 op_free(cvop);
10330 if (aop == cvop) aop = NULL;
10331 op_free(entersubop);
10332
7d789282
FC		 10333 if (opnum == OP_ENTEREVAL
10334 && GvNAMELEN(namegv)==9 && strnEQ(GvNAME(namegv), "evalbytes", 9))
10335 flags |= OPpEVAL_BYTES <<8;
10336
4aaa4757
FC		 10337 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
10338 case OA_UNOP:
10339 case OA_BASEOP_OR_UNOP:
10340 case OA_FILESTATOP:
7d789282 10341 return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
4aaa4757
FC		 10342 case OA_BASEOP:
10343 if (aop) {
10344#ifdef PERL_MAD
10345 if (!PL_madskills || seenarg)
10346#endif
ce16c625 10347 (void)too_many_arguments_pv(aop, GvNAME(namegv), 0);
4aaa4757
FC		 10348 op_free(aop);
10349 }
98be9964
FC		 10350 return opnum == OP_RUNCV
10351 ? newPVOP(OP_RUNCV,0,NULL)
10352 : newOP(opnum,0);
4aaa4757
FC		 10353 default:
10354 return convert(opnum,0,aop);
10355 }
10356 }
10357 assert(0);
10358 return entersubop;
10359}
10360
d9088386
Z		 10361/*
10362=for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
10363
10364Retrieves the function that will be used to fix up a call to I<cv>.
10365Specifically, the function is applied to an C<entersub> op tree for a
10366subroutine call, not marked with C<&>, where the callee can be identified
10367at compile time as I<cv>.
10368
10369The C-level function pointer is returned in I<*ckfun_p>, and an SV
10370argument for it is returned in I<*ckobj_p>. The function is intended
10371to be called in this manner:
10372
10373 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
10374
10375In this call, I<entersubop> is a pointer to the C<entersub> op,
10376which may be replaced by the check function, and I<namegv> is a GV
10377supplying the name that should be used by the check function to refer
10378to the callee of the C<entersub> op if it needs to emit any diagnostics.
10379It is permitted to apply the check function in non-standard situations,
10380such as to a call to a different subroutine or to a method call.
340458b5 10381
d9088386
Z		 10382By default, the function is
10383L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
10384and the SV parameter is I<cv> itself. This implements standard
10385prototype processing. It can be changed, for a particular subroutine,
10386by L</cv_set_call_checker>.
74735042 10387
d9088386
Z		 10388=cut
10389*/
10390
10391void
10392Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
10393{
10394 MAGIC *callmg;
10395 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
10396 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
10397 if (callmg) {
10398 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
10399 *ckobj_p = callmg->mg_obj;
10400 } else {
10401 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
10402 *ckobj_p = (SV*)cv;
10403 }
10404}
10405
10406/*
10407=for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
10408
10409Sets the function that will be used to fix up a call to I<cv>.
10410Specifically, the function is applied to an C<entersub> op tree for a
10411subroutine call, not marked with C<&>, where the callee can be identified
10412at compile time as I<cv>.
10413
10414The C-level function pointer is supplied in I<ckfun>, and an SV argument
10415for it is supplied in I<ckobj>. The function is intended to be called
10416in this manner:
10417
10418 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
10419
10420In this call, I<entersubop> is a pointer to the C<entersub> op,
10421which may be replaced by the check function, and I<namegv> is a GV
10422supplying the name that should be used by the check function to refer
10423to the callee of the C<entersub> op if it needs to emit any diagnostics.
10424It is permitted to apply the check function in non-standard situations,
10425such as to a call to a different subroutine or to a method call.
10426
10427The current setting for a particular CV can be retrieved by
10428L</cv_get_call_checker>.
10429
10430=cut
10431*/
10432
10433void
10434Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
10435{
10436 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
10437 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
10438 if (SvMAGICAL((SV*)cv))
10439 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
10440 } else {
10441 MAGIC *callmg;
10442 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
10443 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
10444 if (callmg->mg_flags & MGf_REFCOUNTED) {
10445 SvREFCNT_dec(callmg->mg_obj);
10446 callmg->mg_flags &= ~MGf_REFCOUNTED;
10447 }
10448 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
10449 callmg->mg_obj = ckobj;
10450 if (ckobj != (SV*)cv) {
10451 SvREFCNT_inc_simple_void_NN(ckobj);
10452 callmg->mg_flags |= MGf_REFCOUNTED;
74735042 10453 }
09fb282d 10454 callmg->mg_flags |= MGf_COPY;
340458b5 10455 }
d9088386
Z		 10456}
10457
10458OP *
10459Perl_ck_subr(pTHX_ OP *o)
10460{
10461 OP *aop, *cvop;
10462 CV *cv;
10463 GV *namegv;
10464
10465 PERL_ARGS_ASSERT_CK_SUBR;
10466
10467 aop = cUNOPx(o)->op_first;
10468 if (!aop->op_sibling)
10469 aop = cUNOPx(aop)->op_first;
10470 aop = aop->op_sibling;
10471 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
10472 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
10473 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_RETURN_NAME_GV) : NULL;
10474
767eda44 10475 o->op_private &= ~1;
d9088386
Z		 10476 o->op_private |= OPpENTERSUB_HASTARG;
10477 o->op_private |= (PL_hints & HINT_STRICT_REFS);
10478 if (PERLDB_SUB && PL_curstash != PL_debstash)
10479 o->op_private |= OPpENTERSUB_DB;
10480 if (cvop->op_type == OP_RV2CV) {
10481 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
10482 op_null(cvop);
10483 } else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
10484 if (aop->op_type == OP_CONST)
10485 aop->op_private &= ~OPpCONST_STRICT;
10486 else if (aop->op_type == OP_LIST) {
10487 OP * const sib = ((UNOP*)aop)->op_first->op_sibling;
10488 if (sib && sib->op_type == OP_CONST)
10489 sib->op_private &= ~OPpCONST_STRICT;
10490 }
10491 }
10492
10493 if (!cv) {
10494 return ck_entersub_args_list(o);
10495 } else {
10496 Perl_call_checker ckfun;
10497 SV *ckobj;
10498 cv_get_call_checker(cv, &ckfun, &ckobj);
279d09bf
FC		 10499 if (!namegv) { /* expletive! */
10500 /* XXX The call checker API is public. And it guarantees that
10501 a GV will be provided with the right name. So we have
10502 to create a GV. But it is still not correct, as its
10503 stringification will include the package. What we
10504 really need is a new call checker API that accepts a
10505 GV or string (or GV or CV). */
10506 HEK * const hek = CvNAME_HEK(cv);
10507 assert(hek);
10508 namegv = (GV *)sv_newmortal();
10509 gv_init_pvn(namegv, PL_curstash, HEK_KEY(hek), HEK_LEN(hek),
10510 SVf_UTF8 * !!HEK_UTF8(hek));
10511 }
d9088386
Z		 10512 return ckfun(aTHX_ o, namegv, ckobj);
10513 }
79072805
LW		 10514}
10515
10516OP *
cea2e8a9 10517Perl_ck_svconst(pTHX_ OP *o)
8990e307 10518{
7918f24d 10519 PERL_ARGS_ASSERT_CK_SVCONST;
96a5add6 10520 PERL_UNUSED_CONTEXT;
e3918bb7 10521 if (!SvIsCOW(cSVOPo->op_sv)) SvREADONLY_on(cSVOPo->op_sv);
11343788 10522 return o;
8990e307
LW		 10523}
10524
10525OP *
cea2e8a9 10526Perl_ck_trunc(pTHX_ OP *o)
79072805 10527{
7918f24d
NC		 10528 PERL_ARGS_ASSERT_CK_TRUNC;
10529
11343788
MB		 10530 if (o->op_flags & OPf_KIDS) {
10531 SVOP *kid = (SVOP*)cUNOPo->op_first;
79072805 10532
a0d0e21e
LW		 10533 if (kid->op_type == OP_NULL)
10534 kid = (SVOP*)kid->op_sibling;
bb53490d 10535 if (kid && kid->op_type == OP_CONST &&
06b58b76
FC		 10536 (kid->op_private & (OPpCONST_BARE|OPpCONST_FOLDED))
10537 == OPpCONST_BARE)
bb53490d 10538 {
11343788 10539 o->op_flags |= OPf_SPECIAL;
bb53490d
GS		 10540 kid->op_private &= ~OPpCONST_STRICT;
10541 }
79072805 10542 }
11343788 10543 return ck_fun(o);
79072805
LW		 10544}
10545
35fba0d9
RG		 10546OP *
10547Perl_ck_substr(pTHX_ OP *o)
10548{
7918f24d
NC		 10549 PERL_ARGS_ASSERT_CK_SUBSTR;
10550
35fba0d9 10551 o = ck_fun(o);
1d866c12 10552 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
35fba0d9
RG		 10553 OP *kid = cLISTOPo->op_first;
10554
10555 if (kid->op_type == OP_NULL)
10556 kid = kid->op_sibling;
10557 if (kid)
10558 kid->op_flags |= OPf_MOD;
10559
10560 }
10561 return o;
10562}
10563
878d132a 10564OP *
8dc99089
FC		 10565Perl_ck_tell(pTHX_ OP *o)
10566{
8dc99089
FC		 10567 PERL_ARGS_ASSERT_CK_TELL;
10568 o = ck_fun(o);
e9d7a483
FC		 10569 if (o->op_flags & OPf_KIDS) {
10570 OP *kid = cLISTOPo->op_first;
423e8af5 10571 if (kid->op_type == OP_NULL && kid->op_sibling) kid = kid->op_sibling;
e9d7a483
FC		 10572 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
10573 }
8dc99089
FC		 10574 return o;
10575}
10576
10577OP *
cba5a3b0
DG		 10578Perl_ck_each(pTHX_ OP *o)
10579{
10580 dVAR;
10581 OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
10582 const unsigned orig_type = o->op_type;
10583 const unsigned array_type = orig_type == OP_EACH ? OP_AEACH
10584 : orig_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
10585 const unsigned ref_type = orig_type == OP_EACH ? OP_REACH
10586 : orig_type == OP_KEYS ? OP_RKEYS : OP_RVALUES;
10587
10588 PERL_ARGS_ASSERT_CK_EACH;
10589
10590 if (kid) {
10591 switch (kid->op_type) {
10592 case OP_PADHV:
10593 case OP_RV2HV:
10594 break;
10595 case OP_PADAV:
10596 case OP_RV2AV:
10597 CHANGE_TYPE(o, array_type);
10598 break;
10599 case OP_CONST:
7ac5715b
FC		 10600 if (kid->op_private == OPpCONST_BARE
10601 || !SvROK(cSVOPx_sv(kid))
10602 || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
10603 && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV )
10604 )
10605 /* we let ck_fun handle it */
cba5a3b0
DG		 10606 break;
10607 default:
10608 CHANGE_TYPE(o, ref_type);
7ac5715b 10609 scalar(kid);
cba5a3b0
DG		 10610 }
10611 }
10612 /* if treating as a reference, defer additional checks to runtime */
10613 return o->op_type == ref_type ? o : ck_fun(o);
10614}
10615
e508c8a4
MH		 10616OP *
10617Perl_ck_length(pTHX_ OP *o)
10618{
10619 PERL_ARGS_ASSERT_CK_LENGTH;
10620
10621 o = ck_fun(o);
10622
10623 if (ckWARN(WARN_SYNTAX)) {
10624 const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
10625
10626 if (kid) {
579333ee
FC		 10627 SV *name = NULL;
10628 const bool hash = kid->op_type == OP_PADHV
10629 || kid->op_type == OP_RV2HV;
e508c8a4
MH		 10630 switch (kid->op_type) {
10631 case OP_PADHV:
e508c8a4 10632 case OP_PADAV:
579333ee 10633 name = varname(
c6fb3f6e
FC		 10634 (GV *)PL_compcv, hash ? '%' : '@', kid->op_targ,
10635 NULL, 0, 1
579333ee
FC		 10636 );
10637 break;
10638 case OP_RV2HV:
e508c8a4 10639 case OP_RV2AV:
579333ee
FC		 10640 if (cUNOPx(kid)->op_first->op_type != OP_GV) break;
10641 {
10642 GV *gv = cGVOPx_gv(cUNOPx(kid)->op_first);
10643 if (!gv) break;
10644 name = varname(gv, hash?'%':'@', 0, NULL, 0, 1);
10645 }
e508c8a4 10646 break;
e508c8a4 10647 default:
579333ee 10648 return o;
e508c8a4 10649 }
579333ee
FC		 10650 if (name)
10651 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10652 "length() used on %"SVf" (did you mean \"scalar(%s%"SVf
10653 ")\"?)",
10654 name, hash ? "keys " : "", name
10655 );
10656 else if (hash)
10657 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10658 "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
10659 else
10660 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10661 "length() used on @array (did you mean \"scalar(@array)\"?)");
e508c8a4
MH		 10662 }
10663 }
10664
10665 return o;
10666}
10667
540dd770
GG		 10668/* Check for in place reverse and sort assignments like "@a = reverse @a"
10669 and modify the optree to make them work inplace */
e52d58aa 10670
540dd770
GG		 10671STATIC void
10672S_inplace_aassign(pTHX_ OP *o) {
e52d58aa 10673
540dd770
GG		 10674 OP *modop, *modop_pushmark;
10675 OP *oright;
10676 OP *oleft, *oleft_pushmark;
e52d58aa 10677
540dd770 10678 PERL_ARGS_ASSERT_INPLACE_AASSIGN;
e52d58aa 10679
540dd770 10680 assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
e52d58aa 10681
540dd770
GG		 10682 assert(cUNOPo->op_first->op_type == OP_NULL);
10683 modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
10684 assert(modop_pushmark->op_type == OP_PUSHMARK);
10685 modop = modop_pushmark->op_sibling;
e92f843d 10686
540dd770
GG		 10687 if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
10688 return;
10689
10690 /* no other operation except sort/reverse */
10691 if (modop->op_sibling)
10692 return;
10693
10694 assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
a46b39a8 10695 if (!(oright = cUNOPx(modop)->op_first->op_sibling)) return;
540dd770
GG		 10696
10697 if (modop->op_flags & OPf_STACKED) {
10698 /* skip sort subroutine/block */
10699 assert(oright->op_type == OP_NULL);
10700 oright = oright->op_sibling;
10701 }
10702
10703 assert(cUNOPo->op_first->op_sibling->op_type == OP_NULL);
10704 oleft_pushmark = cUNOPx(cUNOPo->op_first->op_sibling)->op_first;
10705 assert(oleft_pushmark->op_type == OP_PUSHMARK);
10706 oleft = oleft_pushmark->op_sibling;
10707
10708 /* Check the lhs is an array */
10709 if (!oleft ||
10710 (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
10711 || oleft->op_sibling
10712 || (oleft->op_private & OPpLVAL_INTRO)
10713 )
10714 return;
10715
10716 /* Only one thing on the rhs */
10717 if (oright->op_sibling)
10718 return;
2f9e2db0
VP		 10719
10720 /* check the array is the same on both sides */
10721 if (oleft->op_type == OP_RV2AV) {
10722 if (oright->op_type != OP_RV2AV
10723 || !cUNOPx(oright)->op_first
10724 || cUNOPx(oright)->op_first->op_type != OP_GV
18e3e9ce 10725 || cUNOPx(oleft )->op_first->op_type != OP_GV
2f9e2db0
VP		 10726 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
10727 cGVOPx_gv(cUNOPx(oright)->op_first)
10728 )
540dd770 10729 return;
2f9e2db0
VP		 10730 }
10731 else if (oright->op_type != OP_PADAV
10732 || oright->op_targ != oleft->op_targ
10733 )
540dd770
GG		 10734 return;
10735
10736 /* This actually is an inplace assignment */
e52d58aa 10737
540dd770
GG		 10738 modop->op_private |= OPpSORT_INPLACE;
10739
10740 /* transfer MODishness etc from LHS arg to RHS arg */
10741 oright->op_flags = oleft->op_flags;
10742
10743 /* remove the aassign op and the lhs */
10744 op_null(o);
10745 op_null(oleft_pushmark);
10746 if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
10747 op_null(cUNOPx(oleft)->op_first);
10748 op_null(oleft);
2f9e2db0
VP		 10749}
10750
3c78429c
DM		 10751#define MAX_DEFERRED 4
10752
10753#define DEFER(o) \
d7ab38e8 10754 STMT_START { \
3c78429c
DM		 10755 if (defer_ix == (MAX_DEFERRED-1)) { \
10756 CALL_RPEEP(defer_queue[defer_base]); \
10757 defer_base = (defer_base + 1) % MAX_DEFERRED; \
10758 defer_ix--; \
10759 } \
d7ab38e8
FC		 10760 defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = o; \
10761 } STMT_END
3c78429c 10762
61b743bb
DM		 10763/* A peephole optimizer. We visit the ops in the order they're to execute.
10764 * See the comments at the top of this file for more details about when
10765 * peep() is called */
463ee0b2 10766
79072805 10767void
5aaab254 10768Perl_rpeep(pTHX_ OP *o)
79072805 10769{
27da23d5 10770 dVAR;
eb578fdb 10771 OP* oldop = NULL;
4774ee0a 10772 OP* oldoldop = NULL;
3c78429c
DM		 10773 OP* defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
10774 int defer_base = 0;
10775 int defer_ix = -1;
2d8e6c8d 10776
2814eb74 10777 if (!o || o->op_opt)
79072805 10778 return;
a0d0e21e 10779 ENTER;
462e5cf6 10780 SAVEOP();
7766f137 10781 SAVEVPTR(PL_curcop);
3c78429c
DM		 10782 for (;; o = o->op_next) {
10783 if (o && o->op_opt)
10784 o = NULL;
cd197e1e
VP		 10785 if (!o) {
10786 while (defer_ix >= 0)
10787 CALL_RPEEP(defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED]);
3c78429c 10788 break;
cd197e1e 10789 }
3c78429c 10790
6d7dd4a5
NC		 10791 /* By default, this op has now been optimised. A couple of cases below
10792 clear this again. */
10793 o->op_opt = 1;
533c011a 10794 PL_op = o;
a0d0e21e 10795 switch (o->op_type) {
a0d0e21e 10796 case OP_DBSTATE:
3280af22 10797 PL_curcop = ((COP*)o); /* for warnings */
a0d0e21e 10798 break;
ac56e7de
NC		 10799 case OP_NEXTSTATE:
10800 PL_curcop = ((COP*)o); /* for warnings */
10801
10802 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
10803 to carry two labels. For now, take the easier option, and skip
10804 this optimisation if the first NEXTSTATE has a label. */
bcc76ee3 10805 if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
ac56e7de
NC		 10806 OP *nextop = o->op_next;
10807 while (nextop && nextop->op_type == OP_NULL)
10808 nextop = nextop->op_next;
10809
10810 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
10811 COP *firstcop = (COP *)o;
10812 COP *secondcop = (COP *)nextop;
10813 /* We want the COP pointed to by o (and anything else) to
10814 become the next COP down the line. */
10815 cop_free(firstcop);
10816
10817 firstcop->op_next = secondcop->op_next;
10818
10819 /* Now steal all its pointers, and duplicate the other
10820 data. */
10821 firstcop->cop_line = secondcop->cop_line;
10822#ifdef USE_ITHREADS
d4d03940 10823 firstcop->cop_stashoff = secondcop->cop_stashoff;
ac56e7de
NC		 10824 firstcop->cop_file = secondcop->cop_file;
10825#else
10826 firstcop->cop_stash = secondcop->cop_stash;
10827 firstcop->cop_filegv = secondcop->cop_filegv;
10828#endif
10829 firstcop->cop_hints = secondcop->cop_hints;
10830 firstcop->cop_seq = secondcop->cop_seq;
10831 firstcop->cop_warnings = secondcop->cop_warnings;
10832 firstcop->cop_hints_hash = secondcop->cop_hints_hash;
10833
10834#ifdef USE_ITHREADS
647688d8 10835 secondcop->cop_stashoff = 0;
ac56e7de
NC		 10836 secondcop->cop_file = NULL;
10837#else
10838 secondcop->cop_stash = NULL;
10839 secondcop->cop_filegv = NULL;
10840#endif
10841 secondcop->cop_warnings = NULL;
10842 secondcop->cop_hints_hash = NULL;
10843
10844 /* If we use op_null(), and hence leave an ex-COP, some
10845 warnings are misreported. For example, the compile-time
10846 error in 'use strict; no strict refs;' */
10847 secondcop->op_type = OP_NULL;
10848 secondcop->op_ppaddr = PL_ppaddr[OP_NULL];
10849 }
10850 }
10851 break;
a0d0e21e 10852
df91b2c5
AE		 10853 case OP_CONCAT:
10854 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
10855 if (o->op_next->op_private & OPpTARGET_MY) {
10856 if (o->op_flags & OPf_STACKED) /* chained concats */
a6aa0b75 10857 break; /* ignore_optimization */
df91b2c5
AE		 10858 else {
10859 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
10860 o->op_targ = o->op_next->op_targ;
10861 o->op_next->op_targ = 0;
10862 o->op_private |= OPpTARGET_MY;
10863 }
10864 }
10865 op_null(o->op_next);
10866 }
df91b2c5 10867 break;
6d7dd4a5
NC		 10868 case OP_STUB:
10869 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
10870 break; /* Scalar stub must produce undef. List stub is noop */
10871 }
10872 goto nothin;
79072805 10873 case OP_NULL:
acb36ea4 10874 if (o->op_targ == OP_NEXTSTATE
5edb5b2a 10875 || o->op_targ == OP_DBSTATE)
acb36ea4 10876 {
3280af22 10877 PL_curcop = ((COP*)o);
acb36ea4 10878 }
dad75012 10879 /* XXX: We avoid setting op_seq here to prevent later calls
1a0a2ba9 10880 to rpeep() from mistakenly concluding that optimisation
dad75012
AMS		 10881 has already occurred. This doesn't fix the real problem,
10882 though (See 20010220.007). AMS 20010719 */
2814eb74 10883 /* op_seq functionality is now replaced by op_opt */
6d7dd4a5 10884 o->op_opt = 0;
f46f2f82 10885 /* FALL THROUGH */
79072805 10886 case OP_SCALAR:
93a17b20 10887 case OP_LINESEQ:
463ee0b2 10888 case OP_SCOPE:
6d7dd4a5 10889 nothin:
a0d0e21e
LW		 10890 if (oldop && o->op_next) {
10891 oldop->op_next = o->op_next;
6d7dd4a5 10892 o->op_opt = 0;
79072805
LW		 10893 continue;
10894 }
79072805
LW		 10895 break;
10896
a7fd8ef6
DM		 10897 case OP_PUSHMARK:
10898
10899 /* Convert a series of PAD ops for my vars plus support into a
10900 * single padrange op. Basically
10901 *
10902 * pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
10903 *
10904 * becomes, depending on circumstances, one of
10905 *
10906 * padrange ----------------------------------> (list) -> rest
10907 * padrange --------------------------------------------> rest
10908 *
10909 * where all the pad indexes are sequential and of the same type
10910 * (INTRO or not).
10911 * We convert the pushmark into a padrange op, then skip
10912 * any other pad ops, and possibly some trailing ops.
10913 * Note that we don't null() the skipped ops, to make it
10914 * easier for Deparse to undo this optimisation (and none of
10915 * the skipped ops are holding any resourses). It also makes
10916 * it easier for find_uninit_var(), as it can just ignore
10917 * padrange, and examine the original pad ops.
10918 */
10919 {
10920 OP *p;
10921 OP *followop = NULL; /* the op that will follow the padrange op */
10922 U8 count = 0;
10923 U8 intro = 0;
10924 PADOFFSET base = 0; /* init only to stop compiler whining */
10925 U8 gimme = 0; /* init only to stop compiler whining */
d5524600 10926 bool defav = 0; /* seen (...) = @_ */
fd3cc9e5 10927 bool reuse = 0; /* reuse an existing padrange op */
d5524600
DM		 10928
10929 /* look for a pushmark -> gv[_] -> rv2av */
10930
10931 {
10932 GV *gv;
10933 OP *rv2av, *q;
10934 p = o->op_next;
10935 if ( p->op_type == OP_GV
10936 && (gv = cGVOPx_gv(p))
10937 && GvNAMELEN_get(gv) == 1
10938 && *GvNAME_get(gv) == '_'
10939 && GvSTASH(gv) == PL_defstash
10940 && (rv2av = p->op_next)
10941 && rv2av->op_type == OP_RV2AV
10942 && !(rv2av->op_flags & OPf_REF)
10943 && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
10944 && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
10945 && o->op_sibling == rv2av /* these two for Deparse */
10946 && cUNOPx(rv2av)->op_first == p
10947 ) {
10948 q = rv2av->op_next;
10949 if (q->op_type == OP_NULL)
10950 q = q->op_next;
10951 if (q->op_type == OP_PUSHMARK) {
10952 defav = 1;
10953 p = q;
10954 }
10955 }
10956 }
10957 if (!defav) {
10958 /* To allow Deparse to pessimise this, it needs to be able
10959 * to restore the pushmark's original op_next, which it
10960 * will assume to be the same as op_sibling. */
10961 if (o->op_next != o->op_sibling)
10962 break;
10963 p = o;
10964 }
a7fd8ef6
DM		 10965
10966 /* scan for PAD ops */
10967
d5524600 10968 for (p = p->op_next; p; p = p->op_next) {
a7fd8ef6
DM		 10969 if (p->op_type == OP_NULL)
10970 continue;
10971
10972 if (( p->op_type != OP_PADSV
10973 && p->op_type != OP_PADAV
10974 && p->op_type != OP_PADHV
10975 )
10976 /* any private flag other than INTRO? e.g. STATE */
10977 || (p->op_private & ~OPpLVAL_INTRO)
10978 )
10979 break;
10980
10981 /* let $a[N] potentially be optimised into ALEMFAST_LEX
10982 * instead */
10983 if ( p->op_type == OP_PADAV
10984 && p->op_next
10985 && p->op_next->op_type == OP_CONST
10986 && p->op_next->op_next
10987 && p->op_next->op_next->op_type == OP_AELEM
10988 )
10989 break;
10990
10991 /* for 1st padop, note what type it is and the range
10992 * start; for the others, check that it's the same type
10993 * and that the targs are contiguous */
10994 if (count == 0) {
10995 intro = (p->op_private & OPpLVAL_INTRO);
10996 base = p->op_targ;
10997 gimme = (p->op_flags & OPf_WANT);
10998 }
10999 else {
11000 if ((p->op_private & OPpLVAL_INTRO) != intro)
11001 break;
18c931a3
DM		 11002 /* Note that you'd normally expect targs to be
11003 * contiguous in my($a,$b,$c), but that's not the case
11004 * when external modules start doing things, e.g.
11005 i* Function::Parameters */
11006 if (p->op_targ != base + count)
a7fd8ef6
DM		 11007 break;
11008 assert(p->op_targ == base + count);
11009 /* all the padops should be in the same context */
11010 if (gimme != (p->op_flags & OPf_WANT))
11011 break;
11012 }
11013
11014 /* for AV, HV, only when we're not flattening */
11015 if ( p->op_type != OP_PADSV
11016 && gimme != OPf_WANT_VOID
11017 && !(p->op_flags & OPf_REF)
11018 )
11019 break;
11020
11021 if (count >= OPpPADRANGE_COUNTMASK)
11022 break;
11023
4e09461c
DM		 11024 /* there's a biggest base we can fit into a
11025 * SAVEt_CLEARPADRANGE in pp_padrange */
11026 if (intro && base >
11027 (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT)))
11028 break;
11029
a7fd8ef6
DM		 11030 /* Success! We've got another valid pad op to optimise away */
11031 count++;
11032 followop = p->op_next;
11033 }
11034
11035 if (count < 1)
11036 break;
11037
4774ee0a 11038 /* pp_padrange in specifically compile-time void context
a7fd8ef6
DM		 11039 * skips pushing a mark and lexicals; in all other contexts
11040 * (including unknown till runtime) it pushes a mark and the
11041 * lexicals. We must be very careful then, that the ops we
11042 * optimise away would have exactly the same effect as the
11043 * padrange.
11044 * In particular in void context, we can only optimise to
11045 * a padrange if see see the complete sequence
11046 * pushmark, pad*v, ...., list, nextstate
11047 * which has the net effect of of leaving the stack empty
11048 * (for now we leave the nextstate in the execution chain, for
11049 * its other side-effects).
11050 */
11051 assert(followop);
11052 if (gimme == OPf_WANT_VOID) {
11053 if (followop->op_type == OP_LIST
11054 && gimme == (followop->op_flags & OPf_WANT)
11055 && ( followop->op_next->op_type == OP_NEXTSTATE
11056 || followop->op_next->op_type == OP_DBSTATE))
4774ee0a 11057 {
a7fd8ef6 11058 followop = followop->op_next; /* skip OP_LIST */
4774ee0a
DM		 11059
11060 /* consolidate two successive my(...);'s */
fd3cc9e5 11061
4774ee0a
DM		 11062 if ( oldoldop
11063 && oldoldop->op_type == OP_PADRANGE
11064 && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
11065 && (oldoldop->op_private & OPpLVAL_INTRO) == intro
fd3cc9e5 11066 && !(oldoldop->op_flags & OPf_SPECIAL)
4774ee0a
DM		 11067 ) {
11068 U8 old_count;
11069 assert(oldoldop->op_next == oldop);
11070 assert( oldop->op_type == OP_NEXTSTATE
11071 || oldop->op_type == OP_DBSTATE);
11072 assert(oldop->op_next == o);
11073
11074 old_count
11075 = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
11076 assert(oldoldop->op_targ + old_count == base);
11077
11078 if (old_count < OPpPADRANGE_COUNTMASK - count) {
fd3cc9e5
DM		 11079 base = oldoldop->op_targ;
11080 count += old_count;
11081 reuse = 1;
4774ee0a
DM		 11082 }
11083 }
fd3cc9e5
DM		 11084
11085 /* if there's any immediately following singleton
11086 * my var's; then swallow them and the associated
11087 * nextstates; i.e.
11088 * my ($a,$b); my $c; my $d;
11089 * is treated as
11090 * my ($a,$b,$c,$d);
11091 */
11092
11093 while ( ((p = followop->op_next))
11094 && ( p->op_type == OP_PADSV
11095 || p->op_type == OP_PADAV
11096 || p->op_type == OP_PADHV)
11097 && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
11098 && (p->op_private & OPpLVAL_INTRO) == intro
11099 && p->op_next
11100 && ( p->op_next->op_type == OP_NEXTSTATE
11101 || p->op_next->op_type == OP_DBSTATE)
11102 && count < OPpPADRANGE_COUNTMASK
11103 ) {
11104 assert(base + count == p->op_targ);
11105 count++;
11106 followop = p->op_next;
11107 }
4774ee0a 11108 }
a7fd8ef6
DM		 11109 else
11110 break;
11111 }
11112
fd3cc9e5
DM		 11113 if (reuse) {
11114 assert(oldoldop->op_type == OP_PADRANGE);
11115 oldoldop->op_next = followop;
11116 oldoldop->op_private = (intro | count);
11117 o = oldoldop;
11118 oldop = NULL;
11119 oldoldop = NULL;
11120 }
11121 else {
11122 /* Convert the pushmark into a padrange.
11123 * To make Deparse easier, we guarantee that a padrange was
11124 * *always* formerly a pushmark */
11125 assert(o->op_type == OP_PUSHMARK);
11126 o->op_next = followop;
11127 o->op_type = OP_PADRANGE;
11128 o->op_ppaddr = PL_ppaddr[OP_PADRANGE];
11129 o->op_targ = base;
11130 /* bit 7: INTRO; bit 6..0: count */
11131 o->op_private = (intro | count);
11132 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
11133 | gimme | (defav ? OPf_SPECIAL : 0));
11134 }
a7fd8ef6
DM		 11135 break;
11136 }
11137
6a077020 11138 case OP_PADAV:
79072805 11139 case OP_GV:
6a077020 11140 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
0bd48802 11141 OP* const pop = (o->op_type == OP_PADAV) ?
6a077020 11142 o->op_next : o->op_next->op_next;
a0d0e21e 11143 IV i;
f9dc862f 11144 if (pop && pop->op_type == OP_CONST &&
af5acbb4 11145 ((PL_op = pop->op_next)) &&
8990e307 11146 pop->op_next->op_type == OP_AELEM &&
a0d0e21e 11147 !(pop->op_next->op_private &
78f9721b 11148 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
e1dccc0d 11149 (i = SvIV(((SVOP*)pop)->op_sv)) <= 255 && i >= 0)
8990e307 11150 {
350de78d 11151 GV *gv;
af5acbb4
DM		 11152 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
11153 no_bareword_allowed(pop);
6a077020
DM		 11154 if (o->op_type == OP_GV)
11155 op_null(o->op_next);
93c66552
DM		 11156 op_null(pop->op_next);
11157 op_null(pop);
a0d0e21e
LW		 11158 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
11159 o->op_next = pop->op_next->op_next;
22c35a8c 11160 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
a0d0e21e 11161 o->op_private = (U8)i;
6a077020
DM		 11162 if (o->op_type == OP_GV) {
11163 gv = cGVOPo_gv;
11164 GvAVn(gv);
93bad3fd 11165 o->op_type = OP_AELEMFAST;
6a077020
DM		 11166 }
11167 else
93bad3fd 11168 o->op_type = OP_AELEMFAST_LEX;
6a077020 11169 }
6a077020
DM		 11170 break;
11171 }
11172
11173 if (o->op_next->op_type == OP_RV2SV) {
11174 if (!(o->op_next->op_private & OPpDEREF)) {
11175 op_null(o->op_next);
11176 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
11177 | OPpOUR_INTRO);
11178 o->op_next = o->op_next->op_next;
11179 o->op_type = OP_GVSV;
11180 o->op_ppaddr = PL_ppaddr[OP_GVSV];
8990e307 11181 }
79072805 11182 }
89de2904
AMS		 11183 else if (o->op_next->op_type == OP_READLINE
11184 && o->op_next->op_next->op_type == OP_CONCAT
11185 && (o->op_next->op_next->op_flags & OPf_STACKED))
11186 {
d2c45030
AMS		 11187 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
11188 o->op_type = OP_RCATLINE;
11189 o->op_flags |= OPf_STACKED;
11190 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
89de2904 11191 op_null(o->op_next->op_next);
d2c45030 11192 op_null(o->op_next);
89de2904 11193 }
76cd736e 11194
79072805 11195 break;
867fa1e2
YO		 11196
11197 {
11198 OP *fop;
11199 OP *sop;
11200
9e7f031c
FC		 11201#define HV_OR_SCALARHV(op) \
11202 ( (op)->op_type == OP_PADHV || (op)->op_type == OP_RV2HV \
11203 ? (op) \
11204 : (op)->op_type == OP_SCALAR && (op)->op_flags & OPf_KIDS \
11205 && ( cUNOPx(op)->op_first->op_type == OP_PADHV \
11206 || cUNOPx(op)->op_first->op_type == OP_RV2HV) \
11207 ? cUNOPx(op)->op_first \
11208 : NULL)
11209
867fa1e2 11210 case OP_NOT:
9e7f031c
FC		 11211 if ((fop = HV_OR_SCALARHV(cUNOP->op_first)))
11212 fop->op_private |= OPpTRUEBOOL;
867fa1e2
YO		 11213 break;
11214
11215 case OP_AND:
79072805 11216 case OP_OR:
c963b151 11217 case OP_DOR:
867fa1e2
YO		 11218 fop = cLOGOP->op_first;
11219 sop = fop->op_sibling;
11220 while (cLOGOP->op_other->op_type == OP_NULL)
11221 cLOGOP->op_other = cLOGOP->op_other->op_next;
db4d68cf
DM		 11222 while (o->op_next && ( o->op_type == o->op_next->op_type
11223 || o->op_next->op_type == OP_NULL))
11224 o->op_next = o->op_next->op_next;
3c78429c 11225 DEFER(cLOGOP->op_other);
867fa1e2 11226
867fa1e2 11227 o->op_opt = 1;
c8fe3bdf
FC		 11228 fop = HV_OR_SCALARHV(fop);
11229 if (sop) sop = HV_OR_SCALARHV(sop);
11230 if (fop || sop
867fa1e2
YO		 11231 ){
11232 OP * nop = o;
11233 OP * lop = o;
aaf643ce 11234 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
867fa1e2
YO		 11235 while (nop && nop->op_next) {
11236 switch (nop->op_next->op_type) {
11237 case OP_NOT:
11238 case OP_AND:
11239 case OP_OR:
11240 case OP_DOR:
11241 lop = nop = nop->op_next;
11242 break;
11243 case OP_NULL:
11244 nop = nop->op_next;
11245 break;
11246 default:
11247 nop = NULL;
11248 break;
11249 }
11250 }
11251 }
c8fe3bdf
FC		 11252 if (fop) {
11253 if ( (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
20e53f5f 11254 || o->op_type == OP_AND )
c8fe3bdf
FC		 11255 fop->op_private |= OPpTRUEBOOL;
11256 else if (!(lop->op_flags & OPf_WANT))
adc42c31 11257 fop->op_private |= OPpMAYBE_TRUEBOOL;
6ea72b3a 11258 }
20e53f5f 11259 if ( (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
c8fe3bdf
FC		 11260 && sop)
11261 sop->op_private |= OPpTRUEBOOL;
867fa1e2
YO		 11262 }
11263
11264
11265 break;
867fa1e2 11266
a8b106e9 11267 case OP_COND_EXPR:
c8fe3bdf 11268 if ((fop = HV_OR_SCALARHV(cLOGOP->op_first)))
9e7f031c 11269 fop->op_private |= OPpTRUEBOOL;
a8b106e9
FC		 11270#undef HV_OR_SCALARHV
11271 /* GERONIMO! */
c8fe3bdf 11272 }
a8b106e9 11273
867fa1e2
YO		 11274 case OP_MAPWHILE:
11275 case OP_GREPWHILE:
2c2d71f5
JH		 11276 case OP_ANDASSIGN:
11277 case OP_ORASSIGN:
c963b151 11278 case OP_DORASSIGN:
1a67a97c 11279 case OP_RANGE:
c5917253 11280 case OP_ONCE:
fd4d1407
IZ		 11281 while (cLOGOP->op_other->op_type == OP_NULL)
11282 cLOGOP->op_other = cLOGOP->op_other->op_next;
3c78429c 11283 DEFER(cLOGOP->op_other);
79072805
LW		 11284 break;
11285
79072805 11286 case OP_ENTERLOOP:
9c2ca71a 11287 case OP_ENTERITER:
58cccf98
SM		 11288 while (cLOOP->op_redoop->op_type == OP_NULL)
11289 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
58cccf98
SM		 11290 while (cLOOP->op_nextop->op_type == OP_NULL)
11291 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
58cccf98
SM		 11292 while (cLOOP->op_lastop->op_type == OP_NULL)
11293 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
3c78429c
DM		 11294 /* a while(1) loop doesn't have an op_next that escapes the
11295 * loop, so we have to explicitly follow the op_lastop to
11296 * process the rest of the code */
11297 DEFER(cLOOP->op_lastop);
79072805
LW		 11298 break;
11299
79072805 11300 case OP_SUBST:
29f2e912
NC		 11301 assert(!(cPMOP->op_pmflags & PMf_ONCE));
11302 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
11303 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
11304 cPMOP->op_pmstashstartu.op_pmreplstart
11305 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
3c78429c 11306 DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
79072805
LW		 11307 break;
11308
fe1bc4cf 11309 case OP_SORT: {
d7ab38e8
FC		 11310 OP *oright;
11311
11312 if (o->op_flags & OPf_STACKED) {
11313 OP * const kid =
11314 cUNOPx(cLISTOP->op_first->op_sibling)->op_first;
11315 if (kid->op_type == OP_SCOPE
08fdcd99
FC		 11316 || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE))
11317 DEFER(kLISTOP->op_first);
d7ab38e8
FC		 11318 }
11319
fe1bc4cf 11320 /* check that RHS of sort is a single plain array */
d7ab38e8 11321 oright = cUNOPo->op_first;
fe1bc4cf
DM		 11322 if (!oright || oright->op_type != OP_PUSHMARK)
11323 break;
471178c0 11324
540dd770
GG		 11325 if (o->op_private & OPpSORT_INPLACE)
11326 break;
11327
471178c0
NC		 11328 /* reverse sort ... can be optimised. */
11329 if (!cUNOPo->op_sibling) {
11330 /* Nothing follows us on the list. */
551405c4 11331 OP * const reverse = o->op_next;
471178c0
NC		 11332
11333 if (reverse->op_type == OP_REVERSE &&
11334 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
551405c4 11335 OP * const pushmark = cUNOPx(reverse)->op_first;
471178c0
NC		 11336 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
11337 && (cUNOPx(pushmark)->op_sibling == o)) {
11338 /* reverse -> pushmark -> sort */
11339 o->op_private |= OPpSORT_REVERSE;
11340 op_null(reverse);
11341 pushmark->op_next = oright->op_next;
11342 op_null(oright);
11343 }
11344 }
11345 }
11346
fe1bc4cf
DM		 11347 break;
11348 }
ef3e5ea9
NC		 11349
11350 case OP_REVERSE: {
e682d7b7 11351 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
ce335f37 11352 OP *gvop = NULL;
ef3e5ea9 11353 LISTOP *enter, *exlist;
ef3e5ea9 11354
540dd770 11355 if (o->op_private & OPpSORT_INPLACE)
484c818f 11356 break;
484c818f 11357
ef3e5ea9
NC		 11358 enter = (LISTOP *) o->op_next;
11359 if (!enter)
11360 break;
11361 if (enter->op_type == OP_NULL) {
11362 enter = (LISTOP *) enter->op_next;
11363 if (!enter)
11364 break;
11365 }
d46f46af
NC		 11366 /* for $a (...) will have OP_GV then OP_RV2GV here.
11367 for (...) just has an OP_GV. */
ce335f37
NC		 11368 if (enter->op_type == OP_GV) {
11369 gvop = (OP *) enter;
11370 enter = (LISTOP *) enter->op_next;
11371 if (!enter)
11372 break;
d46f46af
NC		 11373 if (enter->op_type == OP_RV2GV) {
11374 enter = (LISTOP *) enter->op_next;
11375 if (!enter)
ce335f37 11376 break;
d46f46af 11377 }
ce335f37
NC		 11378 }
11379
ef3e5ea9
NC		 11380 if (enter->op_type != OP_ENTERITER)
11381 break;
11382
11383 iter = enter->op_next;
11384 if (!iter || iter->op_type != OP_ITER)
11385 break;
11386
ce335f37
NC		 11387 expushmark = enter->op_first;
11388 if (!expushmark || expushmark->op_type != OP_NULL
11389 || expushmark->op_targ != OP_PUSHMARK)
11390 break;
11391
11392 exlist = (LISTOP *) expushmark->op_sibling;
ef3e5ea9
NC		 11393 if (!exlist || exlist->op_type != OP_NULL
11394 || exlist->op_targ != OP_LIST)
11395 break;
11396
11397 if (exlist->op_last != o) {
11398 /* Mmm. Was expecting to point back to this op. */
11399 break;
11400 }
11401 theirmark = exlist->op_first;
11402 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
11403 break;
11404
c491ecac 11405 if (theirmark->op_sibling != o) {
ef3e5ea9
NC		 11406 /* There's something between the mark and the reverse, eg
11407 for (1, reverse (...))
11408 so no go. */
11409 break;
11410 }
11411
c491ecac
NC		 11412 ourmark = ((LISTOP *)o)->op_first;
11413 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
11414 break;
11415
ef3e5ea9
NC		 11416 ourlast = ((LISTOP *)o)->op_last;
11417 if (!ourlast || ourlast->op_next != o)
11418 break;
11419
e682d7b7
NC		 11420 rv2av = ourmark->op_sibling;
11421 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
11422 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
11423 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
11424 /* We're just reversing a single array. */
11425 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
11426 enter->op_flags |= OPf_STACKED;
11427 }
11428
ef3e5ea9
NC		 11429 /* We don't have control over who points to theirmark, so sacrifice
11430 ours. */
11431 theirmark->op_next = ourmark->op_next;
11432 theirmark->op_flags = ourmark->op_flags;
ce335f37 11433 ourlast->op_next = gvop ? gvop : (OP *) enter;
ef3e5ea9
NC		 11434 op_null(ourmark);
11435 op_null(o);
11436 enter->op_private |= OPpITER_REVERSED;
11437 iter->op_private |= OPpITER_REVERSED;
11438
11439 break;
11440 }
e26df76a 11441
0477511c
NC		 11442 case OP_QR:
11443 case OP_MATCH:
29f2e912
NC		 11444 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
11445 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
11446 }
79072805 11447 break;
1830b3d9 11448
1a35f9ff
FC		 11449 case OP_RUNCV:
11450 if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)) {
11451 SV *sv;
e157a82b 11452 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
1a35f9ff
FC		 11453 else {
11454 sv = newRV((SV *)PL_compcv);
11455 sv_rvweaken(sv);
11456 SvREADONLY_on(sv);
11457 }
11458 o->op_type = OP_CONST;
11459 o->op_ppaddr = PL_ppaddr[OP_CONST];
11460 o->op_flags |= OPf_SPECIAL;
11461 cSVOPo->op_sv = sv;
11462 }
11463 break;
11464
24fcb59f
FC		 11465 case OP_SASSIGN:
11466 if (OP_GIMME(o,0) == G_VOID) {
11467 OP *right = cBINOP->op_first;
11468 if (right) {
11469 OP *left = right->op_sibling;
11470 if (left->op_type == OP_SUBSTR
11471 && (left->op_private & 7) < 4) {
11472 op_null(o);
11473 cBINOP->op_first = left;
11474 right->op_sibling =
11475 cBINOPx(left)->op_first->op_sibling;
11476 cBINOPx(left)->op_first->op_sibling = right;
11477 left->op_private |= OPpSUBSTR_REPL_FIRST;
d72a08ce
FC		 11478 left->op_flags =
11479 (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
24fcb59f
FC		 11480 }
11481 }
11482 }
11483 break;
11484
1830b3d9
BM		 11485 case OP_CUSTOM: {
11486 Perl_cpeep_t cpeep =
11487 XopENTRY(Perl_custom_op_xop(aTHX_ o), xop_peep);
11488 if (cpeep)
11489 cpeep(aTHX_ o, oldop);
11490 break;
11491 }
11492
79072805 11493 }
4774ee0a 11494 oldoldop = oldop;
a0d0e21e 11495 oldop = o;
79072805 11496 }
a0d0e21e 11497 LEAVE;
79072805 11498}
beab0874 11499
1a0a2ba9 11500void
5aaab254 11501Perl_peep(pTHX_ OP *o)
1a0a2ba9
Z		 11502{
11503 CALL_RPEEP(o);
11504}
11505
9733086d
BM		 11506/*
11507=head1 Custom Operators
11508
11509=for apidoc Ao||custom_op_xop
11510Return the XOP structure for a given custom op. This function should be
11511considered internal to OP_NAME and the other access macros: use them instead.
11512
11513=cut
11514*/
11515
1830b3d9
BM		 11516const XOP *
11517Perl_custom_op_xop(pTHX_ const OP *o)
53e06cf0 11518{
1830b3d9
BM		 11519 SV *keysv;
11520 HE *he = NULL;
11521 XOP *xop;
11522
11523 static const XOP xop_null = { 0, 0, 0, 0, 0 };
53e06cf0 11524
1830b3d9
BM		 11525 PERL_ARGS_ASSERT_CUSTOM_OP_XOP;
11526 assert(o->op_type == OP_CUSTOM);
7918f24d 11527
1830b3d9
BM		 11528 /* This is wrong. It assumes a function pointer can be cast to IV,
11529 * which isn't guaranteed, but this is what the old custom OP code
11530 * did. In principle it should be safer to Copy the bytes of the
11531 * pointer into a PV: since the new interface is hidden behind
11532 * functions, this can be changed later if necessary. */
11533 /* Change custom_op_xop if this ever happens */
11534 keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
53e06cf0 11535
1830b3d9
BM		 11536 if (PL_custom_ops)
11537 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
11538
11539 /* assume noone will have just registered a desc */
11540 if (!he && PL_custom_op_names &&
11541 (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
11542 ) {
11543 const char *pv;
11544 STRLEN l;
11545
11546 /* XXX does all this need to be shared mem? */
aca83993 11547 Newxz(xop, 1, XOP);
1830b3d9
BM		 11548 pv = SvPV(HeVAL(he), l);
11549 XopENTRY_set(xop, xop_name, savepvn(pv, l));
11550 if (PL_custom_op_descs &&
11551 (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
11552 ) {
11553 pv = SvPV(HeVAL(he), l);
11554 XopENTRY_set(xop, xop_desc, savepvn(pv, l));
11555 }
11556 Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
11557 return xop;
11558 }
53e06cf0 11559
1830b3d9 11560 if (!he) return &xop_null;
53e06cf0 11561
1830b3d9
BM		 11562 xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
11563 return xop;
53e06cf0
SC		 11564}
11565
9733086d
BM		 11566/*
11567=for apidoc Ao||custom_op_register
11568Register a custom op. See L<perlguts/"Custom Operators">.
53e06cf0 11569
9733086d
BM		 11570=cut
11571*/
7918f24d 11572
1830b3d9
BM		 11573void
11574Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
11575{
11576 SV *keysv;
11577
11578 PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
53e06cf0 11579
1830b3d9
BM		 11580 /* see the comment in custom_op_xop */
11581 keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
53e06cf0 11582
1830b3d9
BM		 11583 if (!PL_custom_ops)
11584 PL_custom_ops = newHV();
53e06cf0 11585
1830b3d9
BM		 11586 if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
11587 Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
53e06cf0 11588}
19e8ce8e 11589
b8c38f0a
FC		 11590/*
11591=head1 Functions in file op.c
11592
11593=for apidoc core_prototype
11594This function assigns the prototype of the named core function to C<sv>, or
11595to a new mortal SV if C<sv> is NULL. It returns the modified C<sv>, or
a051f6c4 11596NULL if the core function has no prototype. C<code> is a code as returned
4e338c21 11597by C<keyword()>. It must not be equal to 0 or -KEY_CORE.
b8c38f0a
FC		 11598
11599=cut
11600*/
11601
11602SV *
be1b855b 11603Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
b66130dd 11604 int * const opnum)
b8c38f0a 11605{
b8c38f0a
FC		 11606 int i = 0, n = 0, seen_question = 0, defgv = 0;
11607 I32 oa;
11608#define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
11609 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
9927957a 11610 bool nullret = FALSE;
b8c38f0a
FC		 11611
11612 PERL_ARGS_ASSERT_CORE_PROTOTYPE;
11613
4e338c21 11614 assert (code && code != -KEY_CORE);
b8c38f0a
FC		 11615
11616 if (!sv) sv = sv_newmortal();
11617
9927957a 11618#define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
b8c38f0a 11619
4e338c21 11620 switch (code < 0 ? -code : code) {
b8c38f0a 11621 case KEY_and : case KEY_chop: case KEY_chomp:
4e338c21
FC		 11622 case KEY_cmp : case KEY_defined: case KEY_delete: case KEY_exec :
11623 case KEY_exists: case KEY_eq : case KEY_ge : case KEY_goto :
11624 case KEY_grep : case KEY_gt : case KEY_last : case KEY_le :
11625 case KEY_lt : case KEY_map : case KEY_ne : case KEY_next :
11626 case KEY_or : case KEY_print : case KEY_printf: case KEY_qr :
11627 case KEY_redo : case KEY_require: case KEY_return: case KEY_say :
11628 case KEY_select: case KEY_sort : case KEY_split : case KEY_system:
11629 case KEY_x : case KEY_xor :
9927957a 11630 if (!opnum) return NULL; nullret = TRUE; goto findopnum;
4e338c21 11631 case KEY_glob: retsetpvs("_;", OP_GLOB);
9927957a
FC		 11632 case KEY_keys: retsetpvs("+", OP_KEYS);
11633 case KEY_values: retsetpvs("+", OP_VALUES);
11634 case KEY_each: retsetpvs("+", OP_EACH);
11635 case KEY_push: retsetpvs("+@", OP_PUSH);
11636 case KEY_unshift: retsetpvs("+@", OP_UNSHIFT);
11637 case KEY_pop: retsetpvs(";+", OP_POP);
11638 case KEY_shift: retsetpvs(";+", OP_SHIFT);
4e338c21 11639 case KEY_pos: retsetpvs(";\\[$*]", OP_POS);
b8c38f0a 11640 case KEY_splice:
9927957a 11641 retsetpvs("+;$$@", OP_SPLICE);
b8c38f0a 11642 case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
9927957a 11643 retsetpvs("", 0);
7d789282
FC		 11644 case KEY_evalbytes:
11645 name = "entereval"; break;
b8c38f0a
FC		 11646 case KEY_readpipe:
11647 name = "backtick";
11648 }
11649
11650#undef retsetpvs
11651
9927957a 11652 findopnum:
b8c38f0a
FC		 11653 while (i < MAXO) { /* The slow way. */
11654 if (strEQ(name, PL_op_name[i])
11655 || strEQ(name, PL_op_desc[i]))
11656 {
9927957a 11657 if (nullret) { assert(opnum); *opnum = i; return NULL; }
b8c38f0a
FC		 11658 goto found;
11659 }
11660 i++;
11661 }
4e338c21 11662 return NULL;
b8c38f0a
FC		 11663 found:
11664 defgv = PL_opargs[i] & OA_DEFGV;
11665 oa = PL_opargs[i] >> OASHIFT;
11666 while (oa) {
465bc0f5 11667 if (oa & OA_OPTIONAL && !seen_question && (
ea5703f4 11668 !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
465bc0f5 11669 )) {
b8c38f0a
FC		 11670 seen_question = 1;
11671 str[n++] = ';';
11672 }
11673 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
11674 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
11675 /* But globs are already references (kinda) */
11676 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
11677 ) {
11678 str[n++] = '\\';
11679 }
1ecbeecf
FC		 11680 if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
11681 && !scalar_mod_type(NULL, i)) {
11682 str[n++] = '[';
11683 str[n++] = '$';
11684 str[n++] = '@';
11685 str[n++] = '%';
89c5c07e 11686 if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
1ecbeecf
FC		 11687 str[n++] = '*';
11688 str[n++] = ']';
11689 }
11690 else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
ea5703f4
FC		 11691 if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
11692 str[n-1] = '_'; defgv = 0;
11693 }
b8c38f0a
FC		 11694 oa = oa >> 4;
11695 }
dcbdef25 11696 if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
b8c38f0a
FC		 11697 str[n++] = '\0';
11698 sv_setpvn(sv, str, n - 1);
9927957a 11699 if (opnum) *opnum = i;
b8c38f0a
FC		 11700 return sv;
11701}
11702
1e4b6aa1
FC		 11703OP *
11704Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
11705 const int opnum)
11706{
11707 OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
c931b036 11708 OP *o;
1e4b6aa1
FC		 11709
11710 PERL_ARGS_ASSERT_CORESUB_OP;
11711
11712 switch(opnum) {
11713 case 0:
c2f605db 11714 return op_append_elem(OP_LINESEQ,
1e4b6aa1
FC		 11715 argop,
11716 newSLICEOP(0,
c2f605db 11717 newSVOP(OP_CONST, 0, newSViv(-code % 3)),
1e4b6aa1
FC		 11718 newOP(OP_CALLER,0)
11719 )
c2f605db 11720 );
720d5b2f
FC		 11721 case OP_SELECT: /* which represents OP_SSELECT as well */
11722 if (code)
11723 return newCONDOP(
11724 0,
11725 newBINOP(OP_GT, 0,
11726 newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
11727 newSVOP(OP_CONST, 0, newSVuv(1))
11728 ),
11729 coresub_op(newSVuv((UV)OP_SSELECT), 0,
11730 OP_SSELECT),
11731 coresub_op(coreargssv, 0, OP_SELECT)
11732 );
11733 /* FALL THROUGH */
1e4b6aa1
FC		 11734 default:
11735 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
11736 case OA_BASEOP:
11737 return op_append_elem(
11738 OP_LINESEQ, argop,
11739 newOP(opnum,
84ed0108
FC		 11740 opnum == OP_WANTARRAY || opnum == OP_RUNCV
11741 ? OPpOFFBYONE << 8 : 0)
1e4b6aa1 11742 );
527d644b 11743 case OA_BASEOP_OR_UNOP:
7d789282
FC		 11744 if (opnum == OP_ENTEREVAL) {
11745 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
11746 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
11747 }
11748 else o = newUNOP(opnum,0,argop);
ce0b554b
FC		 11749 if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
11750 else {
c931b036 11751 onearg:
ce0b554b 11752 if (is_handle_constructor(o, 1))
c931b036 11753 argop->op_private |= OPpCOREARGS_DEREF1;
1efec5ed
FC		 11754 if (scalar_mod_type(NULL, opnum))
11755 argop->op_private |= OPpCOREARGS_SCALARMOD;
ce0b554b 11756 }
c931b036 11757 return o;
527d644b 11758 default:
498a02d8 11759 o = convert(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
c931b036
FC		 11760 if (is_handle_constructor(o, 2))
11761 argop->op_private |= OPpCOREARGS_DEREF2;
7bc95ae1
FC		 11762 if (opnum == OP_SUBSTR) {
11763 o->op_private |= OPpMAYBE_LVSUB;
11764 return o;
11765 }
11766 else goto onearg;
1e4b6aa1
FC		 11767 }
11768 }
11769}
11770
156d738f
FC		 11771void
11772Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
11773 SV * const *new_const_svp)
11774{
11775 const char *hvname;
11776 bool is_const = !!CvCONST(old_cv);
11777 SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
11778
11779 PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
11780
11781 if (is_const && new_const_svp && old_const_sv == *new_const_svp)
11782 return;
11783 /* They are 2 constant subroutines generated from
11784 the same constant. This probably means that
11785 they are really the "same" proxy subroutine
11786 instantiated in 2 places. Most likely this is
11787 when a constant is exported twice. Don't warn.
11788 */
11789 if (
11790 (ckWARN(WARN_REDEFINE)
11791 && !(
11792 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
11793 && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
11794 && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
11795 strEQ(hvname, "autouse"))
11796 )
11797 )
11798 || (is_const
11799 && ckWARN_d(WARN_REDEFINE)
11800 && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
11801 )
11802 )
11803 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
11804 is_const
11805 ? "Constant subroutine %"SVf" redefined"
11806 : "Subroutine %"SVf" redefined",
11807 name);
11808}
11809
e8570548
Z		 11810/*
11811=head1 Hook manipulation
11812
11813These functions provide convenient and thread-safe means of manipulating
11814hook variables.
11815
11816=cut
11817*/
11818
11819/*
11820=for apidoc Am|void|wrap_op_checker|Optype opcode|Perl_check_t new_checker|Perl_check_t *old_checker_p
11821
11822Puts a C function into the chain of check functions for a specified op
11823type. This is the preferred way to manipulate the L</PL_check> array.
11824I<opcode> specifies which type of op is to be affected. I<new_checker>
11825is a pointer to the C function that is to be added to that opcode's
11826check chain, and I<old_checker_p> points to the storage location where a
11827pointer to the next function in the chain will be stored. The value of
11828I<new_pointer> is written into the L</PL_check> array, while the value
11829previously stored there is written to I<*old_checker_p>.
11830
11831L</PL_check> is global to an entire process, and a module wishing to
11832hook op checking may find itself invoked more than once per process,
11833typically in different threads. To handle that situation, this function
11834is idempotent. The location I<*old_checker_p> must initially (once
11835per process) contain a null pointer. A C variable of static duration
11836(declared at file scope, typically also marked C<static> to give
11837it internal linkage) will be implicitly initialised appropriately,
11838if it does not have an explicit initialiser. This function will only
11839actually modify the check chain if it finds I<*old_checker_p> to be null.
11840This function is also thread safe on the small scale. It uses appropriate
11841locking to avoid race conditions in accessing L</PL_check>.
11842
11843When this function is called, the function referenced by I<new_checker>
11844must be ready to be called, except for I<*old_checker_p> being unfilled.
11845In a threading situation, I<new_checker> may be called immediately,
11846even before this function has returned. I<*old_checker_p> will always
11847be appropriately set before I<new_checker> is called. If I<new_checker>
11848decides not to do anything special with an op that it is given (which
11849is the usual case for most uses of op check hooking), it must chain the
11850check function referenced by I<*old_checker_p>.
11851
11852If you want to influence compilation of calls to a specific subroutine,
11853then use L</cv_set_call_checker> rather than hooking checking of all
11854C<entersub> ops.
11855
11856=cut
11857*/
11858
11859void
11860Perl_wrap_op_checker(pTHX_ Optype opcode,
11861 Perl_check_t new_checker, Perl_check_t *old_checker_p)
11862{
9b11155f
TC		 11863 dVAR;
11864
e8570548
Z		 11865 PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
11866 if (*old_checker_p) return;
11867 OP_CHECK_MUTEX_LOCK;
11868 if (!*old_checker_p) {
11869 *old_checker_p = PL_check[opcode];
11870 PL_check[opcode] = new_checker;
11871 }
11872 OP_CHECK_MUTEX_UNLOCK;
11873}
11874
beab0874
JT		 11875#include "XSUB.h"
11876
11877/* Efficient sub that returns a constant scalar value. */
11878static void
acfe0abc 11879const_sv_xsub(pTHX_ CV* cv)
beab0874 11880{
97aff369 11881 dVAR;
beab0874 11882 dXSARGS;
99ab892b 11883 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
9cbac4c7 11884 if (items != 0) {
6f207bd3 11885 NOOP;
9cbac4c7 11886#if 0
fe13d51d 11887 /* diag_listed_as: SKIPME */
9cbac4c7 11888 Perl_croak(aTHX_ "usage: %s::%s()",
bfcb3514 11889 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
9cbac4c7
DM		 11890#endif
11891 }
99ab892b
NC		 11892 if (!sv) {
11893 XSRETURN(0);
11894 }
9a049f1c 11895 EXTEND(sp, 1);
99ab892b 11896 ST(0) = sv;
beab0874
JT		 11897 XSRETURN(1);
11898}
4946a0fa
NC		 11899
11900/*
11901 * Local variables:
11902 * c-indentation-style: bsd
11903 * c-basic-offset: 4
14d04a33 11904 * indent-tabs-mode: nil
4946a0fa
NC		 11905 * End:
11906 *
14d04a33 11907 * ex: set ts=8 sts=4 sw=4 et:
37442d52 11908 */
Unnamed repository; edit this file 'description' to name the repository.