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