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
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.
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
19 * [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
22 /* This file contains the functions that create, manipulate and optimize
23 * the OP structures that hold a compiled perl program.
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
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):
38 * newBINOP(OP_ADD, flags,
40 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
43 * Note that during the build of miniperl, a temporary copy of this file
44 * is made, called opmini.c.
48 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
52 An execution-order pass
54 The bottom-up pass is represented by all the "newOP" routines and
55 the ck_ routines. The bottom-upness is actually driven by yacc.
56 So at the point that a ck_ routine fires, we have no idea what the
57 context is, either upward in the syntax tree, or either forward or
58 backward in the execution order. (The bottom-up parser builds that
59 part of the execution order it knows about, but if you follow the "next"
60 links around, you'll find it's actually a closed loop through the
63 Whenever the bottom-up parser gets to a node that supplies context to
64 its components, it invokes that portion of the top-down pass that applies
65 to that part of the subtree (and marks the top node as processed, so
66 if a node further up supplies context, it doesn't have to take the
67 plunge again). As a particular subcase of this, as the new node is
68 built, it takes all the closed execution loops of its subcomponents
69 and links them into a new closed loop for the higher level node. But
70 it's still not the real execution order.
72 The actual execution order is not known till we get a grammar reduction
73 to 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
75 into peep() to do that code's portion of the 3rd pass. It has to be
76 recursive, but it's recursive on basic blocks, not on tree nodes.
79 /* To implement user lexical pragmas, there needs to be a way at run time to
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
87 leaf, ignoring any key you've already seen (placeholder or not), storing
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.
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.
95 C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
96 record, with deletes written by C<Perl_magic_clearhint>. C<SAVEHINTS>
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.
104 #include "keywords.h"
108 #define CALL_PEEP(o) PL_peepp(aTHX_ o)
109 #define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
110 #define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
112 /* See the explanatory comments above struct opslab in op.h. */
114 #ifdef PERL_DEBUG_READONLY_OPS
115 # define PERL_SLAB_SIZE 128
116 # define PERL_MAX_SLAB_SIZE 4096
117 # include <sys/mman.h>
120 #ifndef PERL_SLAB_SIZE
121 # define PERL_SLAB_SIZE 64
123 #ifndef PERL_MAX_SLAB_SIZE
124 # define PERL_MAX_SLAB_SIZE 2048
127 /* rounds up to nearest pointer */
128 #define SIZE_TO_PSIZE(x) (((x) + sizeof(I32 *) - 1)/sizeof(I32 *))
129 #define DIFF(o,p) ((size_t)((I32 **)(p) - (I32**)(o)))
132 S_new_slab(pTHX_ size_t sz)
134 #ifdef PERL_DEBUG_READONLY_OPS
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");
144 slab->opslab_size = (U16)sz;
146 OPSLAB *slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *));
148 slab->opslab_first = (OPSLOT *)((I32 **)slab + sz - 1);
152 /* requires double parens and aTHX_ */
153 #define DEBUG_S_warn(args) \
155 PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \
159 Perl_Slab_Alloc(pTHX_ size_t sz)
168 if (!PL_compcv || CvROOT(PL_compcv)
169 || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv)))
170 return PerlMemShared_calloc(1, sz);
172 if (!CvSTART(PL_compcv)) { /* sneak it in here */
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 */
178 else ++(slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
180 opsz = SIZE_TO_PSIZE(sz);
181 sz = opsz + OPSLOT_HEADER_P;
183 if (slab->opslab_freed) {
184 OP **too = &slab->opslab_freed;
186 DEBUG_S_warn((aTHX_ "found free op at %p, slab %p", o, slab));
187 while (o && DIFF(OpSLOT(o), OpSLOT(o)->opslot_next) < sz) {
188 DEBUG_S_warn((aTHX_ "Alas! too small"));
189 o = *(too = &o->op_next);
190 if (o) { DEBUG_S_warn((aTHX_ "found another free op at %p", o)); }
194 Zero(o, opsz, I32 *);
200 #define INIT_OPSLOT \
201 slot->opslot_slab = slab; \
202 slot->opslot_next = slab2->opslab_first; \
203 slab2->opslab_first = slot; \
204 o = &slot->opslot_op; \
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. */
212 /* If we can fit a BASEOP, add it to the free chain, so as not
214 if (space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) {
215 slot = &slab2->opslab_slots;
217 o->op_type = OP_FREED;
218 o->op_next = slab->opslab_freed;
219 slab->opslab_freed = o;
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;
225 slab2 = S_new_slab(aTHX_
226 (DIFF(slab2, slot)+1)*2 > PERL_MAX_SLAB_SIZE
228 : (DIFF(slab2, slot)+1)*2);
229 slab2->opslab_next = slab->opslab_next;
230 slab->opslab_next = slab2;
232 assert(DIFF(&slab2->opslab_slots, slab2->opslab_first) >= sz);
234 /* Create a new op slot */
235 slot = (OPSLOT *)((I32 **)slab2->opslab_first - sz);
236 assert(slot >= &slab2->opslab_slots);
237 if (DIFF(&slab2->opslab_slots, slot)
238 < SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P)
239 slot = &slab2->opslab_slots;
241 DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", o, slab));
247 #ifdef PERL_DEBUG_READONLY_OPS
249 Perl_Slab_to_ro(pTHX_ OPSLAB *slab)
251 PERL_ARGS_ASSERT_SLAB_TO_RO;
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);
265 S_Slab_to_rw(pTHX_ void *op)
267 OP * const o = (OP *)op;
271 PERL_ARGS_ASSERT_SLAB_TO_RW;
273 if (!o->op_slabbed) return;
276 if (!slab->opslab_readonly) return;
278 for (; slab2; slab2 = slab2->opslab_next) {
279 /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n",
280 (unsigned long) size, slab2));*/
281 if (mprotect((void *)slab2, slab2->opslab_size * sizeof(I32 *),
282 PROT_READ|PROT_WRITE)) {
283 Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", slab,
284 (unsigned long)slab2->opslab_size, errno);
287 slab->opslab_readonly = 0;
291 # define Slab_to_rw(op)
294 /* This cannot possibly be right, but it was copied from the old slab
295 allocator, to which it was originally added, without explanation, in
298 # define PerlMemShared PerlMem
302 Perl_Slab_Free(pTHX_ void *op)
305 OP * const o = (OP *)op;
308 PERL_ARGS_ASSERT_SLAB_FREE;
310 if (!o->op_slabbed) {
311 PerlMemShared_free(op);
316 /* If this op is already freed, our refcount will get screwy. */
317 assert(o->op_type != OP_FREED);
318 o->op_type = OP_FREED;
319 o->op_next = slab->opslab_freed;
320 slab->opslab_freed = o;
321 DEBUG_S_warn((aTHX_ "free op at %p, recorded in slab %p", o, slab));
322 OpslabREFCNT_dec_padok(slab);
326 Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
329 const bool havepad = !!PL_comppad;
330 PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD;
333 PAD_SAVE_SETNULLPAD();
340 Perl_opslab_free(pTHX_ OPSLAB *slab)
344 PERL_ARGS_ASSERT_OPSLAB_FREE;
345 DEBUG_S_warn((aTHX_ "freeing slab %p", slab));
346 assert(slab->opslab_refcnt == 1);
347 for (; slab; slab = slab2) {
348 slab2 = slab->opslab_next;
350 slab->opslab_refcnt = ~(size_t)0;
352 #ifdef PERL_DEBUG_READONLY_OPS
353 DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
355 if (munmap(slab, slab->opslab_size * sizeof(I32 *))) {
356 perror("munmap failed");
360 PerlMemShared_free(slab);
366 Perl_opslab_force_free(pTHX_ OPSLAB *slab)
371 size_t savestack_count = 0;
373 PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
376 for (slot = slab2->opslab_first;
378 slot = slot->opslot_next) {
379 if (slot->opslot_op.op_type != OP_FREED
380 && !(slot->opslot_op.op_savefree
386 assert(slot->opslot_op.op_slabbed);
387 slab->opslab_refcnt++; /* op_free may free slab */
388 op_free(&slot->opslot_op);
389 if (!--slab->opslab_refcnt) goto free;
392 } while ((slab2 = slab2->opslab_next));
393 /* > 1 because the CV still holds a reference count. */
394 if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */
396 assert(savestack_count == slab->opslab_refcnt-1);
404 #ifdef PERL_DEBUG_READONLY_OPS
406 Perl_op_refcnt_inc(pTHX_ OP *o)
417 Perl_op_refcnt_dec(pTHX_ OP *o)
419 PERL_ARGS_ASSERT_OP_REFCNT_DEC;
425 * In the following definition, the ", (OP*)0" is just to make the compiler
426 * think the expression is of the right type: croak actually does a Siglongjmp.
428 #define CHECKOP(type,o) \
429 ((PL_op_mask && PL_op_mask[type]) \
430 ? ( op_free((OP*)o), \
431 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
433 : PL_check[type](aTHX_ (OP*)o))
435 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
437 #define CHANGE_TYPE(o,type) \
439 o->op_type = (OPCODE)type; \
440 o->op_ppaddr = PL_ppaddr[type]; \
444 S_gv_ename(pTHX_ GV *gv)
446 SV* const tmpsv = sv_newmortal();
448 PERL_ARGS_ASSERT_GV_ENAME;
450 gv_efullname3(tmpsv, gv, NULL);
455 S_no_fh_allowed(pTHX_ OP *o)
457 PERL_ARGS_ASSERT_NO_FH_ALLOWED;
459 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
465 S_too_few_arguments_sv(pTHX_ OP *o, SV *namesv, U32 flags)
467 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_SV;
468 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf, namesv),
469 SvUTF8(namesv) | flags);
474 S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
476 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
477 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
482 S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
484 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
486 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
491 S_too_many_arguments_sv(pTHX_ OP *o, SV *namesv, U32 flags)
493 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_SV;
495 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %"SVf, SVfARG(namesv)),
496 SvUTF8(namesv) | flags);
501 S_bad_type_pv(pTHX_ I32 n, const char *t, const char *name, U32 flags, const OP *kid)
503 PERL_ARGS_ASSERT_BAD_TYPE_PV;
505 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
506 (int)n, name, t, OP_DESC(kid)), flags);
510 S_bad_type_sv(pTHX_ I32 n, const char *t, SV *namesv, U32 flags, const OP *kid)
512 PERL_ARGS_ASSERT_BAD_TYPE_SV;
514 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %"SVf" must be %s (not %s)",
515 (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv) | flags);
519 S_no_bareword_allowed(pTHX_ OP *o)
521 PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
524 return; /* various ok barewords are hidden in extra OP_NULL */
525 qerror(Perl_mess(aTHX_
526 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
528 o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
531 /* "register" allocation */
534 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
538 const bool is_our = (PL_parser->in_my == KEY_our);
540 PERL_ARGS_ASSERT_ALLOCMY;
542 if (flags & ~SVf_UTF8)
543 Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
546 /* Until we're using the length for real, cross check that we're being
548 assert(strlen(name) == len);
550 /* complain about "my $<special_var>" etc etc */
554 ((flags & SVf_UTF8) && isIDFIRST_utf8((U8 *)name+1)) ||
555 (name[1] == '_' && (*name == '$' || len > 2))))
557 /* name[2] is true if strlen(name) > 2 */
558 if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
559 && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
560 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
561 name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
562 PL_parser->in_my == KEY_state ? "state" : "my"));
564 yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
565 PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
569 /* allocate a spare slot and store the name in that slot */
571 off = pad_add_name_pvn(name, len,
572 (is_our ? padadd_OUR :
573 PL_parser->in_my == KEY_state ? padadd_STATE : 0)
574 | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 ),
575 PL_parser->in_my_stash,
577 /* $_ is always in main::, even with our */
578 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
582 /* anon sub prototypes contains state vars should always be cloned,
583 * otherwise the state var would be shared between anon subs */
585 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
586 CvCLONE_on(PL_compcv);
592 =for apidoc alloccopstash
594 Available only under threaded builds, this function allocates an entry in
595 C<PL_stashpad> for the stash passed to it.
602 Perl_alloccopstash(pTHX_ HV *hv)
604 PADOFFSET off = 0, o = 1;
605 bool found_slot = FALSE;
607 PERL_ARGS_ASSERT_ALLOCCOPSTASH;
609 if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
611 for (; o < PL_stashpadmax; ++o) {
612 if (PL_stashpad[o] == hv) return PL_stashpadix = o;
613 if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
614 found_slot = TRUE, off = o;
617 Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
618 Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
619 off = PL_stashpadmax;
620 PL_stashpadmax += 10;
623 PL_stashpad[PL_stashpadix = off] = hv;
628 /* free the body of an op without examining its contents.
629 * Always use this rather than FreeOp directly */
632 S_op_destroy(pTHX_ OP *o)
638 # define forget_pmop(a,b) S_forget_pmop(aTHX_ a,b)
640 # define forget_pmop(a,b) S_forget_pmop(aTHX_ a)
646 Perl_op_free(pTHX_ OP *o)
651 /* Though ops may be freed twice, freeing the op after its slab is a
653 assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
654 /* During the forced freeing of ops after compilation failure, kidops
655 may be freed before their parents. */
656 if (!o || o->op_type == OP_FREED)
660 if (o->op_private & OPpREFCOUNTED) {
671 refcnt = OpREFCNT_dec(o);
674 /* Need to find and remove any pattern match ops from the list
675 we maintain for reset(). */
676 find_and_forget_pmops(o);
686 /* Call the op_free hook if it has been set. Do it now so that it's called
687 * at the right time for refcounted ops, but still before all of the kids
691 if (o->op_flags & OPf_KIDS) {
692 register OP *kid, *nextkid;
693 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
694 nextkid = kid->op_sibling; /* Get before next freeing kid */
699 type = (OPCODE)o->op_targ;
703 /* COP* is not cleared by op_clear() so that we may track line
704 * numbers etc even after null() */
705 if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
711 #ifdef DEBUG_LEAKING_SCALARS
718 Perl_op_clear(pTHX_ OP *o)
723 PERL_ARGS_ASSERT_OP_CLEAR;
726 mad_free(o->op_madprop);
731 switch (o->op_type) {
732 case OP_NULL: /* Was holding old type, if any. */
733 if (PL_madskills && o->op_targ != OP_NULL) {
734 o->op_type = (Optype)o->op_targ;
739 case OP_ENTEREVAL: /* Was holding hints. */
743 if (!(o->op_flags & OPf_REF)
744 || (PL_check[o->op_type] != Perl_ck_ftst))
751 GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV)
756 /* It's possible during global destruction that the GV is freed
757 before the optree. Whilst the SvREFCNT_inc is happy to bump from
758 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
759 will trigger an assertion failure, because the entry to sv_clear
760 checks that the scalar is not already freed. A check of for
761 !SvIS_FREED(gv) turns out to be invalid, because during global
762 destruction the reference count can be forced down to zero
763 (with SVf_BREAK set). In which case raising to 1 and then
764 dropping to 0 triggers cleanup before it should happen. I
765 *think* that this might actually be a general, systematic,
766 weakness of the whole idea of SVf_BREAK, in that code *is*
767 allowed to raise and lower references during global destruction,
768 so any *valid* code that happens to do this during global
769 destruction might well trigger premature cleanup. */
770 bool still_valid = gv && SvREFCNT(gv);
773 SvREFCNT_inc_simple_void(gv);
775 if (cPADOPo->op_padix > 0) {
776 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
777 * may still exist on the pad */
778 pad_swipe(cPADOPo->op_padix, TRUE);
779 cPADOPo->op_padix = 0;
782 SvREFCNT_dec(cSVOPo->op_sv);
783 cSVOPo->op_sv = NULL;
786 int try_downgrade = SvREFCNT(gv) == 2;
789 gv_try_downgrade(gv);
793 case OP_METHOD_NAMED:
796 SvREFCNT_dec(cSVOPo->op_sv);
797 cSVOPo->op_sv = NULL;
800 Even if op_clear does a pad_free for the target of the op,
801 pad_free doesn't actually remove the sv that exists in the pad;
802 instead it lives on. This results in that it could be reused as
803 a target later on when the pad was reallocated.
806 pad_swipe(o->op_targ,1);
816 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
821 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
822 assert(o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
824 if (cPADOPo->op_padix > 0) {
825 pad_swipe(cPADOPo->op_padix, TRUE);
826 cPADOPo->op_padix = 0;
829 SvREFCNT_dec(cSVOPo->op_sv);
830 cSVOPo->op_sv = NULL;
834 PerlMemShared_free(cPVOPo->op_pv);
835 cPVOPo->op_pv = NULL;
839 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
843 if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
844 /* No GvIN_PAD_off here, because other references may still
845 * exist on the pad */
846 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
849 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
855 if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
856 op_free(cPMOPo->op_code_list);
857 cPMOPo->op_code_list = NULL;
858 forget_pmop(cPMOPo, 1);
859 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
860 /* we use the same protection as the "SAFE" version of the PM_ macros
861 * here since sv_clean_all might release some PMOPs
862 * after PL_regex_padav has been cleared
863 * and the clearing of PL_regex_padav needs to
864 * happen before sv_clean_all
867 if(PL_regex_pad) { /* We could be in destruction */
868 const IV offset = (cPMOPo)->op_pmoffset;
869 ReREFCNT_dec(PM_GETRE(cPMOPo));
870 PL_regex_pad[offset] = &PL_sv_undef;
871 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
875 ReREFCNT_dec(PM_GETRE(cPMOPo));
876 PM_SETRE(cPMOPo, NULL);
882 if (o->op_targ > 0) {
883 pad_free(o->op_targ);
889 S_cop_free(pTHX_ COP* cop)
891 PERL_ARGS_ASSERT_COP_FREE;
894 if (! specialWARN(cop->cop_warnings))
895 PerlMemShared_free(cop->cop_warnings);
896 cophh_free(CopHINTHASH_get(cop));
900 S_forget_pmop(pTHX_ PMOP *const o
906 HV * const pmstash = PmopSTASH(o);
908 PERL_ARGS_ASSERT_FORGET_PMOP;
910 if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
911 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
913 PMOP **const array = (PMOP**) mg->mg_ptr;
914 U32 count = mg->mg_len / sizeof(PMOP**);
919 /* Found it. Move the entry at the end to overwrite it. */
920 array[i] = array[--count];
921 mg->mg_len = count * sizeof(PMOP**);
922 /* Could realloc smaller at this point always, but probably
923 not worth it. Probably worth free()ing if we're the
926 Safefree(mg->mg_ptr);
943 S_find_and_forget_pmops(pTHX_ OP *o)
945 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
947 if (o->op_flags & OPf_KIDS) {
948 OP *kid = cUNOPo->op_first;
950 switch (kid->op_type) {
955 forget_pmop((PMOP*)kid, 0);
957 find_and_forget_pmops(kid);
958 kid = kid->op_sibling;
964 Perl_op_null(pTHX_ OP *o)
968 PERL_ARGS_ASSERT_OP_NULL;
970 if (o->op_type == OP_NULL)
974 o->op_targ = o->op_type;
975 o->op_type = OP_NULL;
976 o->op_ppaddr = PL_ppaddr[OP_NULL];
980 Perl_op_refcnt_lock(pTHX)
988 Perl_op_refcnt_unlock(pTHX)
995 /* Contextualizers */
998 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
1000 Applies a syntactic context to an op tree representing an expression.
1001 I<o> is the op tree, and I<context> must be C<G_SCALAR>, C<G_ARRAY>,
1002 or C<G_VOID> to specify the context to apply. The modified op tree
1009 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1011 PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1013 case G_SCALAR: return scalar(o);
1014 case G_ARRAY: return list(o);
1015 case G_VOID: return scalarvoid(o);
1017 Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1024 =head1 Optree Manipulation Functions
1026 =for apidoc Am|OP*|op_linklist|OP *o
1027 This function is the implementation of the L</LINKLIST> macro. It should
1028 not be called directly.
1034 Perl_op_linklist(pTHX_ OP *o)
1038 PERL_ARGS_ASSERT_OP_LINKLIST;
1043 /* establish postfix order */
1044 first = cUNOPo->op_first;
1047 o->op_next = LINKLIST(first);
1050 if (kid->op_sibling) {
1051 kid->op_next = LINKLIST(kid->op_sibling);
1052 kid = kid->op_sibling;
1066 S_scalarkids(pTHX_ OP *o)
1068 if (o && o->op_flags & OPf_KIDS) {
1070 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1077 S_scalarboolean(pTHX_ OP *o)
1081 PERL_ARGS_ASSERT_SCALARBOOLEAN;
1083 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST
1084 && !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) {
1085 if (ckWARN(WARN_SYNTAX)) {
1086 const line_t oldline = CopLINE(PL_curcop);
1088 if (PL_parser && PL_parser->copline != NOLINE)
1089 CopLINE_set(PL_curcop, PL_parser->copline);
1090 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1091 CopLINE_set(PL_curcop, oldline);
1098 Perl_scalar(pTHX_ OP *o)
1103 /* assumes no premature commitment */
1104 if (!o || (PL_parser && PL_parser->error_count)
1105 || (o->op_flags & OPf_WANT)
1106 || o->op_type == OP_RETURN)
1111 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1113 switch (o->op_type) {
1115 scalar(cBINOPo->op_first);
1120 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1130 if (o->op_flags & OPf_KIDS) {
1131 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1137 kid = cLISTOPo->op_first;
1139 kid = kid->op_sibling;
1142 OP *sib = kid->op_sibling;
1143 if (sib && kid->op_type != OP_LEAVEWHEN)
1149 PL_curcop = &PL_compiling;
1154 kid = cLISTOPo->op_first;
1157 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1164 Perl_scalarvoid(pTHX_ OP *o)
1168 const char* useless = NULL;
1169 U32 useless_is_utf8 = 0;
1173 PERL_ARGS_ASSERT_SCALARVOID;
1175 /* trailing mad null ops don't count as "there" for void processing */
1177 o->op_type != OP_NULL &&
1179 o->op_sibling->op_type == OP_NULL)
1182 for (sib = o->op_sibling;
1183 sib && sib->op_type == OP_NULL;
1184 sib = sib->op_sibling) ;
1190 if (o->op_type == OP_NEXTSTATE
1191 || o->op_type == OP_DBSTATE
1192 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1193 || o->op_targ == OP_DBSTATE)))
1194 PL_curcop = (COP*)o; /* for warning below */
1196 /* assumes no premature commitment */
1197 want = o->op_flags & OPf_WANT;
1198 if ((want && want != OPf_WANT_SCALAR)
1199 || (PL_parser && PL_parser->error_count)
1200 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1205 if ((o->op_private & OPpTARGET_MY)
1206 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1208 return scalar(o); /* As if inside SASSIGN */
1211 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1213 switch (o->op_type) {
1215 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1219 if (o->op_flags & OPf_STACKED)
1223 if (o->op_private == 4)
1248 case OP_AELEMFAST_LEX:
1267 case OP_GETSOCKNAME:
1268 case OP_GETPEERNAME:
1273 case OP_GETPRIORITY:
1298 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1299 /* Otherwise it's "Useless use of grep iterator" */
1300 useless = OP_DESC(o);
1304 kid = cLISTOPo->op_first;
1305 if (kid && kid->op_type == OP_PUSHRE
1307 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff)
1309 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv)
1311 useless = OP_DESC(o);
1315 kid = cUNOPo->op_first;
1316 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1317 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
1320 useless = "negative pattern binding (!~)";
1324 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
1325 useless = "non-destructive substitution (s///r)";
1329 useless = "non-destructive transliteration (tr///r)";
1336 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1337 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1338 useless = "a variable";
1343 if (cSVOPo->op_private & OPpCONST_STRICT)
1344 no_bareword_allowed(o);
1346 if (ckWARN(WARN_VOID)) {
1347 /* don't warn on optimised away booleans, eg
1348 * use constant Foo, 5; Foo || print; */
1349 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1351 /* the constants 0 and 1 are permitted as they are
1352 conventionally used as dummies in constructs like
1353 1 while some_condition_with_side_effects; */
1354 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1356 else if (SvPOK(sv)) {
1357 /* perl4's way of mixing documentation and code
1358 (before the invention of POD) was based on a
1359 trick to mix nroff and perl code. The trick was
1360 built upon these three nroff macros being used in
1361 void context. The pink camel has the details in
1362 the script wrapman near page 319. */
1363 const char * const maybe_macro = SvPVX_const(sv);
1364 if (strnEQ(maybe_macro, "di", 2) ||
1365 strnEQ(maybe_macro, "ds", 2) ||
1366 strnEQ(maybe_macro, "ig", 2))
1369 SV * const dsv = newSVpvs("");
1370 SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
1372 pv_pretty(dsv, maybe_macro, SvCUR(sv), 32, NULL, NULL,
1373 PERL_PV_PRETTY_DUMP | PERL_PV_ESCAPE_NOCLEAR | PERL_PV_ESCAPE_UNI_DETECT )));
1375 useless = SvPV_nolen(msv);
1376 useless_is_utf8 = SvUTF8(msv);
1379 else if (SvOK(sv)) {
1380 SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
1381 "a constant (%"SVf")", sv));
1382 useless = SvPV_nolen(msv);
1385 useless = "a constant (undef)";
1388 op_null(o); /* don't execute or even remember it */
1392 o->op_type = OP_PREINC; /* pre-increment is faster */
1393 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1397 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1398 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1402 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1403 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1407 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1408 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1413 UNOP *refgen, *rv2cv;
1416 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
1419 rv2gv = ((BINOP *)o)->op_last;
1420 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
1423 refgen = (UNOP *)((BINOP *)o)->op_first;
1425 if (!refgen || refgen->op_type != OP_REFGEN)
1428 exlist = (LISTOP *)refgen->op_first;
1429 if (!exlist || exlist->op_type != OP_NULL
1430 || exlist->op_targ != OP_LIST)
1433 if (exlist->op_first->op_type != OP_PUSHMARK)
1436 rv2cv = (UNOP*)exlist->op_last;
1438 if (rv2cv->op_type != OP_RV2CV)
1441 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
1442 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
1443 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
1445 o->op_private |= OPpASSIGN_CV_TO_GV;
1446 rv2gv->op_private |= OPpDONT_INIT_GV;
1447 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
1459 kid = cLOGOPo->op_first;
1460 if (kid->op_type == OP_NOT
1461 && (kid->op_flags & OPf_KIDS)
1463 if (o->op_type == OP_AND) {
1465 o->op_ppaddr = PL_ppaddr[OP_OR];
1467 o->op_type = OP_AND;
1468 o->op_ppaddr = PL_ppaddr[OP_AND];
1477 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1482 if (o->op_flags & OPf_STACKED)
1489 if (!(o->op_flags & OPf_KIDS))
1500 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1510 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %"SVf" in void context",
1511 newSVpvn_flags(useless, strlen(useless),
1512 SVs_TEMP | ( useless_is_utf8 ? SVf_UTF8 : 0 )));
1517 S_listkids(pTHX_ OP *o)
1519 if (o && o->op_flags & OPf_KIDS) {
1521 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1528 Perl_list(pTHX_ OP *o)
1533 /* assumes no premature commitment */
1534 if (!o || (o->op_flags & OPf_WANT)
1535 || (PL_parser && PL_parser->error_count)
1536 || o->op_type == OP_RETURN)
1541 if ((o->op_private & OPpTARGET_MY)
1542 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1544 return o; /* As if inside SASSIGN */
1547 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1549 switch (o->op_type) {
1552 list(cBINOPo->op_first);
1557 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1565 if (!(o->op_flags & OPf_KIDS))
1567 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1568 list(cBINOPo->op_first);
1569 return gen_constant_list(o);
1576 kid = cLISTOPo->op_first;
1578 kid = kid->op_sibling;
1581 OP *sib = kid->op_sibling;
1582 if (sib && kid->op_type != OP_LEAVEWHEN)
1588 PL_curcop = &PL_compiling;
1592 kid = cLISTOPo->op_first;
1599 S_scalarseq(pTHX_ OP *o)
1603 const OPCODE type = o->op_type;
1605 if (type == OP_LINESEQ || type == OP_SCOPE ||
1606 type == OP_LEAVE || type == OP_LEAVETRY)
1609 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1610 if (kid->op_sibling) {
1614 PL_curcop = &PL_compiling;
1616 o->op_flags &= ~OPf_PARENS;
1617 if (PL_hints & HINT_BLOCK_SCOPE)
1618 o->op_flags |= OPf_PARENS;
1621 o = newOP(OP_STUB, 0);
1626 S_modkids(pTHX_ OP *o, I32 type)
1628 if (o && o->op_flags & OPf_KIDS) {
1630 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1631 op_lvalue(kid, type);
1637 =for apidoc finalize_optree
1639 This function finalizes the optree. Should be called directly after
1640 the complete optree is built. It does some additional
1641 checking which can't be done in the normal ck_xxx functions and makes
1642 the tree thread-safe.
1647 Perl_finalize_optree(pTHX_ OP* o)
1649 PERL_ARGS_ASSERT_FINALIZE_OPTREE;
1652 SAVEVPTR(PL_curcop);
1660 S_finalize_op(pTHX_ OP* o)
1662 PERL_ARGS_ASSERT_FINALIZE_OP;
1664 #if defined(PERL_MAD) && defined(USE_ITHREADS)
1666 /* Make sure mad ops are also thread-safe */
1667 MADPROP *mp = o->op_madprop;
1669 if (mp->mad_type == MAD_OP && mp->mad_vlen) {
1670 OP *prop_op = (OP *) mp->mad_val;
1671 /* We only need "Relocate sv to the pad for thread safety.", but this
1672 easiest way to make sure it traverses everything */
1673 if (prop_op->op_type == OP_CONST)
1674 cSVOPx(prop_op)->op_private &= ~OPpCONST_STRICT;
1675 finalize_op(prop_op);
1682 switch (o->op_type) {
1685 PL_curcop = ((COP*)o); /* for warnings */
1689 && (o->op_sibling->op_type == OP_NEXTSTATE || o->op_sibling->op_type == OP_DBSTATE)
1690 && ckWARN(WARN_SYNTAX))
1692 if (o->op_sibling->op_sibling) {
1693 const OPCODE type = o->op_sibling->op_sibling->op_type;
1694 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
1695 const line_t oldline = CopLINE(PL_curcop);
1696 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_sibling));
1697 Perl_warner(aTHX_ packWARN(WARN_EXEC),
1698 "Statement unlikely to be reached");
1699 Perl_warner(aTHX_ packWARN(WARN_EXEC),
1700 "\t(Maybe you meant system() when you said exec()?)\n");
1701 CopLINE_set(PL_curcop, oldline);
1708 if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
1709 GV * const gv = cGVOPo_gv;
1710 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
1711 /* XXX could check prototype here instead of just carping */
1712 SV * const sv = sv_newmortal();
1713 gv_efullname3(sv, gv, NULL);
1714 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
1715 "%"SVf"() called too early to check prototype",
1722 if (cSVOPo->op_private & OPpCONST_STRICT)
1723 no_bareword_allowed(o);
1727 case OP_METHOD_NAMED:
1728 /* Relocate sv to the pad for thread safety.
1729 * Despite being a "constant", the SV is written to,
1730 * for reference counts, sv_upgrade() etc. */
1731 if (cSVOPo->op_sv) {
1732 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
1733 if (o->op_type != OP_METHOD_NAMED &&
1734 (SvPADTMP(cSVOPo->op_sv) || SvPADMY(cSVOPo->op_sv)))
1736 /* If op_sv is already a PADTMP/MY then it is being used by
1737 * some pad, so make a copy. */
1738 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
1739 SvREADONLY_on(PAD_SVl(ix));
1740 SvREFCNT_dec(cSVOPo->op_sv);
1742 else if (o->op_type != OP_METHOD_NAMED
1743 && cSVOPo->op_sv == &PL_sv_undef) {
1744 /* PL_sv_undef is hack - it's unsafe to store it in the
1745 AV that is the pad, because av_fetch treats values of
1746 PL_sv_undef as a "free" AV entry and will merrily
1747 replace them with a new SV, causing pad_alloc to think
1748 that this pad slot is free. (When, clearly, it is not)
1750 SvOK_off(PAD_SVl(ix));
1751 SvPADTMP_on(PAD_SVl(ix));
1752 SvREADONLY_on(PAD_SVl(ix));
1755 SvREFCNT_dec(PAD_SVl(ix));
1756 SvPADTMP_on(cSVOPo->op_sv);
1757 PAD_SETSV(ix, cSVOPo->op_sv);
1758 /* XXX I don't know how this isn't readonly already. */
1759 SvREADONLY_on(PAD_SVl(ix));
1761 cSVOPo->op_sv = NULL;
1772 const char *key = NULL;
1775 if (((BINOP*)o)->op_last->op_type != OP_CONST)
1778 /* Make the CONST have a shared SV */
1779 svp = cSVOPx_svp(((BINOP*)o)->op_last);
1780 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv))
1781 && SvTYPE(sv) < SVt_PVMG && !SvROK(sv)) {
1782 key = SvPV_const(sv, keylen);
1783 lexname = newSVpvn_share(key,
1784 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
1790 if ((o->op_private & (OPpLVAL_INTRO)))
1793 rop = (UNOP*)((BINOP*)o)->op_first;
1794 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
1796 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
1797 if (!SvPAD_TYPED(lexname))
1799 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
1800 if (!fields || !GvHV(*fields))
1802 key = SvPV_const(*svp, keylen);
1803 if (!hv_fetch(GvHV(*fields), key,
1804 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) {
1805 Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
1806 "in variable %"SVf" of type %"HEKf,
1807 SVfARG(*svp), SVfARG(lexname),
1808 HEKfARG(HvNAME_HEK(SvSTASH(lexname))));
1820 SVOP *first_key_op, *key_op;
1822 if ((o->op_private & (OPpLVAL_INTRO))
1823 /* I bet there's always a pushmark... */
1824 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
1825 /* hmmm, no optimization if list contains only one key. */
1827 rop = (UNOP*)((LISTOP*)o)->op_last;
1828 if (rop->op_type != OP_RV2HV)
1830 if (rop->op_first->op_type == OP_PADSV)
1831 /* @$hash{qw(keys here)} */
1832 rop = (UNOP*)rop->op_first;
1834 /* @{$hash}{qw(keys here)} */
1835 if (rop->op_first->op_type == OP_SCOPE
1836 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
1838 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
1844 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
1845 if (!SvPAD_TYPED(lexname))
1847 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
1848 if (!fields || !GvHV(*fields))
1850 /* Again guessing that the pushmark can be jumped over.... */
1851 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
1852 ->op_first->op_sibling;
1853 for (key_op = first_key_op; key_op;
1854 key_op = (SVOP*)key_op->op_sibling) {
1855 if (key_op->op_type != OP_CONST)
1857 svp = cSVOPx_svp(key_op);
1858 key = SvPV_const(*svp, keylen);
1859 if (!hv_fetch(GvHV(*fields), key,
1860 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) {
1861 Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
1862 "in variable %"SVf" of type %"HEKf,
1863 SVfARG(*svp), SVfARG(lexname),
1864 HEKfARG(HvNAME_HEK(SvSTASH(lexname))));
1870 if (cPMOPo->op_pmreplrootu.op_pmreplroot)
1871 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
1878 if (o->op_flags & OPf_KIDS) {
1880 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1886 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
1888 Propagate lvalue ("modifiable") context to an op and its children.
1889 I<type> represents the context type, roughly based on the type of op that
1890 would do the modifying, although C<local()> is represented by OP_NULL,
1891 because it has no op type of its own (it is signalled by a flag on
1894 This function detects things that can't be modified, such as C<$x+1>, and
1895 generates errors for them. For example, C<$x+1 = 2> would cause it to be
1896 called with an op of type OP_ADD and a C<type> argument of OP_SASSIGN.
1898 It also flags things that need to behave specially in an lvalue context,
1899 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
1905 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
1909 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1912 if (!o || (PL_parser && PL_parser->error_count))
1915 if ((o->op_private & OPpTARGET_MY)
1916 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1921 assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
1923 if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
1925 switch (o->op_type) {
1930 if ((o->op_flags & OPf_PARENS) || PL_madskills)
1934 if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
1935 !(o->op_flags & OPf_STACKED)) {
1936 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1937 /* Both ENTERSUB and RV2CV use this bit, but for different pur-
1938 poses, so we need it clear. */
1939 o->op_private &= ~1;
1940 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1941 assert(cUNOPo->op_first->op_type == OP_NULL);
1942 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1945 else { /* lvalue subroutine call */
1946 o->op_private |= OPpLVAL_INTRO
1947 |(OPpENTERSUB_INARGS * (type == OP_LEAVESUBLV));
1948 PL_modcount = RETURN_UNLIMITED_NUMBER;
1949 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1950 /* Potential lvalue context: */
1951 o->op_private |= OPpENTERSUB_INARGS;
1954 else { /* Compile-time error message: */
1955 OP *kid = cUNOPo->op_first;
1958 if (kid->op_type != OP_PUSHMARK) {
1959 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1961 "panic: unexpected lvalue entersub "
1962 "args: type/targ %ld:%"UVuf,
1963 (long)kid->op_type, (UV)kid->op_targ);
1964 kid = kLISTOP->op_first;
1966 while (kid->op_sibling)
1967 kid = kid->op_sibling;
1968 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1969 break; /* Postpone until runtime */
1972 kid = kUNOP->op_first;
1973 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1974 kid = kUNOP->op_first;
1975 if (kid->op_type == OP_NULL)
1977 "Unexpected constant lvalue entersub "
1978 "entry via type/targ %ld:%"UVuf,
1979 (long)kid->op_type, (UV)kid->op_targ);
1980 if (kid->op_type != OP_GV) {
1984 cv = GvCV(kGVOP_gv);
1994 if (flags & OP_LVALUE_NO_CROAK) return NULL;
1995 /* grep, foreach, subcalls, refgen */
1996 if (type == OP_GREPSTART || type == OP_ENTERSUB
1997 || type == OP_REFGEN || type == OP_LEAVESUBLV)
1999 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
2000 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
2002 : (o->op_type == OP_ENTERSUB
2003 ? "non-lvalue subroutine call"
2005 type ? PL_op_desc[type] : "local"));
2019 case OP_RIGHT_SHIFT:
2028 if (!(o->op_flags & OPf_STACKED))
2035 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
2036 op_lvalue(kid, type);
2041 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
2042 PL_modcount = RETURN_UNLIMITED_NUMBER;
2043 return o; /* Treat \(@foo) like ordinary list. */
2047 if (scalar_mod_type(o, type))
2049 ref(cUNOPo->op_first, o->op_type);
2053 if (type == OP_LEAVESUBLV)
2054 o->op_private |= OPpMAYBE_LVSUB;
2060 PL_modcount = RETURN_UNLIMITED_NUMBER;
2063 PL_hints |= HINT_BLOCK_SCOPE;
2064 if (type == OP_LEAVESUBLV)
2065 o->op_private |= OPpMAYBE_LVSUB;
2069 ref(cUNOPo->op_first, o->op_type);
2073 PL_hints |= HINT_BLOCK_SCOPE;
2082 case OP_AELEMFAST_LEX:
2089 PL_modcount = RETURN_UNLIMITED_NUMBER;
2090 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
2091 return o; /* Treat \(@foo) like ordinary list. */
2092 if (scalar_mod_type(o, type))
2094 if (type == OP_LEAVESUBLV)
2095 o->op_private |= OPpMAYBE_LVSUB;
2099 if (!type) /* local() */
2100 Perl_croak(aTHX_ "Can't localize lexical variable %"SVf,
2101 PAD_COMPNAME_SV(o->op_targ));
2110 if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
2114 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
2120 if (type == OP_LEAVESUBLV)
2121 o->op_private |= OPpMAYBE_LVSUB;
2122 pad_free(o->op_targ);
2123 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
2124 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
2125 if (o->op_flags & OPf_KIDS)
2126 op_lvalue(cBINOPo->op_first->op_sibling, type);
2131 ref(cBINOPo->op_first, o->op_type);
2132 if (type == OP_ENTERSUB &&
2133 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
2134 o->op_private |= OPpLVAL_DEFER;
2135 if (type == OP_LEAVESUBLV)
2136 o->op_private |= OPpMAYBE_LVSUB;
2146 if (o->op_flags & OPf_KIDS)
2147 op_lvalue(cLISTOPo->op_last, type);
2152 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
2154 else if (!(o->op_flags & OPf_KIDS))
2156 if (o->op_targ != OP_LIST) {
2157 op_lvalue(cBINOPo->op_first, type);
2163 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2164 /* elements might be in void context because the list is
2165 in scalar context or because they are attribute sub calls */
2166 if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
2167 op_lvalue(kid, type);
2171 if (type != OP_LEAVESUBLV)
2173 break; /* op_lvalue()ing was handled by ck_return() */
2179 /* [20011101.069] File test operators interpret OPf_REF to mean that
2180 their argument is a filehandle; thus \stat(".") should not set
2182 if (type == OP_REFGEN &&
2183 PL_check[o->op_type] == Perl_ck_ftst)
2186 if (type != OP_LEAVESUBLV)
2187 o->op_flags |= OPf_MOD;
2189 if (type == OP_AASSIGN || type == OP_SASSIGN)
2190 o->op_flags |= OPf_SPECIAL|OPf_REF;
2191 else if (!type) { /* local() */
2194 o->op_private |= OPpLVAL_INTRO;
2195 o->op_flags &= ~OPf_SPECIAL;
2196 PL_hints |= HINT_BLOCK_SCOPE;
2201 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
2202 "Useless localization of %s", OP_DESC(o));
2205 else if (type != OP_GREPSTART && type != OP_ENTERSUB
2206 && type != OP_LEAVESUBLV)
2207 o->op_flags |= OPf_REF;
2212 S_scalar_mod_type(const OP *o, I32 type)
2217 if (o && o->op_type == OP_RV2GV)
2241 case OP_RIGHT_SHIFT:
2262 S_is_handle_constructor(const OP *o, I32 numargs)
2264 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
2266 switch (o->op_type) {
2274 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
2287 S_refkids(pTHX_ OP *o, I32 type)
2289 if (o && o->op_flags & OPf_KIDS) {
2291 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2298 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
2303 PERL_ARGS_ASSERT_DOREF;
2305 if (!o || (PL_parser && PL_parser->error_count))
2308 switch (o->op_type) {
2310 if ((type == OP_EXISTS || type == OP_DEFINED) &&
2311 !(o->op_flags & OPf_STACKED)) {
2312 o->op_type = OP_RV2CV; /* entersub => rv2cv */
2313 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
2314 assert(cUNOPo->op_first->op_type == OP_NULL);
2315 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
2316 o->op_flags |= OPf_SPECIAL;
2317 o->op_private &= ~1;
2319 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
2320 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2321 : type == OP_RV2HV ? OPpDEREF_HV
2323 o->op_flags |= OPf_MOD;
2329 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
2330 doref(kid, type, set_op_ref);
2333 if (type == OP_DEFINED)
2334 o->op_flags |= OPf_SPECIAL; /* don't create GV */
2335 doref(cUNOPo->op_first, o->op_type, set_op_ref);
2338 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2339 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2340 : type == OP_RV2HV ? OPpDEREF_HV
2342 o->op_flags |= OPf_MOD;
2349 o->op_flags |= OPf_REF;
2352 if (type == OP_DEFINED)
2353 o->op_flags |= OPf_SPECIAL; /* don't create GV */
2354 doref(cUNOPo->op_first, o->op_type, set_op_ref);
2360 o->op_flags |= OPf_REF;
2365 if (!(o->op_flags & OPf_KIDS))
2367 doref(cBINOPo->op_first, type, set_op_ref);
2371 doref(cBINOPo->op_first, o->op_type, set_op_ref);
2372 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2373 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2374 : type == OP_RV2HV ? OPpDEREF_HV
2376 o->op_flags |= OPf_MOD;
2386 if (!(o->op_flags & OPf_KIDS))
2388 doref(cLISTOPo->op_last, type, set_op_ref);
2398 S_dup_attrlist(pTHX_ OP *o)
2403 PERL_ARGS_ASSERT_DUP_ATTRLIST;
2405 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
2406 * where the first kid is OP_PUSHMARK and the remaining ones
2407 * are OP_CONST. We need to push the OP_CONST values.
2409 if (o->op_type == OP_CONST)
2410 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
2412 else if (o->op_type == OP_NULL)
2416 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
2418 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
2419 if (o->op_type == OP_CONST)
2420 rop = op_append_elem(OP_LIST, rop,
2421 newSVOP(OP_CONST, o->op_flags,
2422 SvREFCNT_inc_NN(cSVOPo->op_sv)));
2429 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
2434 PERL_ARGS_ASSERT_APPLY_ATTRS;
2436 /* fake up C<use attributes $pkg,$rv,@attrs> */
2437 ENTER; /* need to protect against side-effects of 'use' */
2438 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2440 #define ATTRSMODULE "attributes"
2441 #define ATTRSMODULE_PM "attributes.pm"
2444 /* Don't force the C<use> if we don't need it. */
2445 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
2446 if (svp && *svp != &PL_sv_undef)
2447 NOOP; /* already in %INC */
2449 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
2450 newSVpvs(ATTRSMODULE), NULL);
2453 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2454 newSVpvs(ATTRSMODULE),
2456 op_prepend_elem(OP_LIST,
2457 newSVOP(OP_CONST, 0, stashsv),
2458 op_prepend_elem(OP_LIST,
2459 newSVOP(OP_CONST, 0,
2461 dup_attrlist(attrs))));
2467 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
2470 OP *pack, *imop, *arg;
2473 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
2478 assert(target->op_type == OP_PADSV ||
2479 target->op_type == OP_PADHV ||
2480 target->op_type == OP_PADAV);
2482 /* Ensure that attributes.pm is loaded. */
2483 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
2485 /* Need package name for method call. */
2486 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
2488 /* Build up the real arg-list. */
2489 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2491 arg = newOP(OP_PADSV, 0);
2492 arg->op_targ = target->op_targ;
2493 arg = op_prepend_elem(OP_LIST,
2494 newSVOP(OP_CONST, 0, stashsv),
2495 op_prepend_elem(OP_LIST,
2496 newUNOP(OP_REFGEN, 0,
2497 op_lvalue(arg, OP_REFGEN)),
2498 dup_attrlist(attrs)));
2500 /* Fake up a method call to import */
2501 meth = newSVpvs_share("import");
2502 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2503 op_append_elem(OP_LIST,
2504 op_prepend_elem(OP_LIST, pack, list(arg)),
2505 newSVOP(OP_METHOD_NAMED, 0, meth)));
2507 /* Combine the ops. */
2508 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
2512 =notfor apidoc apply_attrs_string
2514 Attempts to apply a list of attributes specified by the C<attrstr> and
2515 C<len> arguments to the subroutine identified by the C<cv> argument which
2516 is expected to be associated with the package identified by the C<stashpv>
2517 argument (see L<attributes>). It gets this wrong, though, in that it
2518 does not correctly identify the boundaries of the individual attribute
2519 specifications within C<attrstr>. This is not really intended for the
2520 public API, but has to be listed here for systems such as AIX which
2521 need an explicit export list for symbols. (It's called from XS code
2522 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
2523 to respect attribute syntax properly would be welcome.
2529 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
2530 const char *attrstr, STRLEN len)
2534 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2537 len = strlen(attrstr);
2541 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2543 const char * const sstr = attrstr;
2544 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2545 attrs = op_append_elem(OP_LIST, attrs,
2546 newSVOP(OP_CONST, 0,
2547 newSVpvn(sstr, attrstr-sstr)));
2551 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2552 newSVpvs(ATTRSMODULE),
2553 NULL, op_prepend_elem(OP_LIST,
2554 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2555 op_prepend_elem(OP_LIST,
2556 newSVOP(OP_CONST, 0,
2557 newRV(MUTABLE_SV(cv))),
2562 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2566 const bool stately = PL_parser && PL_parser->in_my == KEY_state;
2568 PERL_ARGS_ASSERT_MY_KID;
2570 if (!o || (PL_parser && PL_parser->error_count))
2574 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2575 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2579 if (type == OP_LIST) {
2581 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2582 my_kid(kid, attrs, imopsp);
2584 } else if (type == OP_UNDEF || type == OP_STUB) {
2586 } else if (type == OP_RV2SV || /* "our" declaration */
2588 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2589 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2590 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2592 PL_parser->in_my == KEY_our
2594 : PL_parser->in_my == KEY_state ? "state" : "my"));
2596 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
2597 PL_parser->in_my = FALSE;
2598 PL_parser->in_my_stash = NULL;
2599 apply_attrs(GvSTASH(gv),
2600 (type == OP_RV2SV ? GvSV(gv) :
2601 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2602 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
2605 o->op_private |= OPpOUR_INTRO;
2608 else if (type != OP_PADSV &&
2611 type != OP_PUSHMARK)
2613 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2615 PL_parser->in_my == KEY_our
2617 : PL_parser->in_my == KEY_state ? "state" : "my"));
2620 else if (attrs && type != OP_PUSHMARK) {
2623 PL_parser->in_my = FALSE;
2624 PL_parser->in_my_stash = NULL;
2626 /* check for C<my Dog $spot> when deciding package */
2627 stash = PAD_COMPNAME_TYPE(o->op_targ);
2629 stash = PL_curstash;
2630 apply_attrs_my(stash, o, attrs, imopsp);
2632 o->op_flags |= OPf_MOD;
2633 o->op_private |= OPpLVAL_INTRO;
2635 o->op_private |= OPpPAD_STATE;
2640 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2644 int maybe_scalar = 0;
2646 PERL_ARGS_ASSERT_MY_ATTRS;
2648 /* [perl #17376]: this appears to be premature, and results in code such as
2649 C< our(%x); > executing in list mode rather than void mode */
2651 if (o->op_flags & OPf_PARENS)
2661 o = my_kid(o, attrs, &rops);
2663 if (maybe_scalar && o->op_type == OP_PADSV) {
2664 o = scalar(op_append_list(OP_LIST, rops, o));
2665 o->op_private |= OPpLVAL_INTRO;
2668 /* The listop in rops might have a pushmark at the beginning,
2669 which will mess up list assignment. */
2670 LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
2671 if (rops->op_type == OP_LIST &&
2672 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
2674 OP * const pushmark = lrops->op_first;
2675 lrops->op_first = pushmark->op_sibling;
2678 o = op_append_list(OP_LIST, o, rops);
2681 PL_parser->in_my = FALSE;
2682 PL_parser->in_my_stash = NULL;
2687 Perl_sawparens(pTHX_ OP *o)
2689 PERL_UNUSED_CONTEXT;
2691 o->op_flags |= OPf_PARENS;
2696 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2700 const OPCODE ltype = left->op_type;
2701 const OPCODE rtype = right->op_type;
2703 PERL_ARGS_ASSERT_BIND_MATCH;
2705 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2706 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2708 const char * const desc
2710 rtype == OP_SUBST || rtype == OP_TRANS
2711 || rtype == OP_TRANSR
2713 ? (int)rtype : OP_MATCH];
2714 const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
2717 (ltype == OP_RV2AV || ltype == OP_RV2HV)
2718 ? cUNOPx(left)->op_first->op_type == OP_GV
2719 && (gv = cGVOPx_gv(cUNOPx(left)->op_first))
2720 ? varname(gv, isary ? '@' : '%', 0, NULL, 0, 1)
2723 (GV *)PL_compcv, isary ? '@' : '%', left->op_targ, NULL, 0, 1
2726 Perl_warner(aTHX_ packWARN(WARN_MISC),
2727 "Applying %s to %"SVf" will act on scalar(%"SVf")",
2730 const char * const sample = (isary
2731 ? "@array" : "%hash");
2732 Perl_warner(aTHX_ packWARN(WARN_MISC),
2733 "Applying %s to %s will act on scalar(%s)",
2734 desc, sample, sample);
2738 if (rtype == OP_CONST &&
2739 cSVOPx(right)->op_private & OPpCONST_BARE &&
2740 cSVOPx(right)->op_private & OPpCONST_STRICT)
2742 no_bareword_allowed(right);
2745 /* !~ doesn't make sense with /r, so error on it for now */
2746 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
2748 yyerror("Using !~ with s///r doesn't make sense");
2749 if (rtype == OP_TRANSR && type == OP_NOT)
2750 yyerror("Using !~ with tr///r doesn't make sense");
2752 ismatchop = (rtype == OP_MATCH ||
2753 rtype == OP_SUBST ||
2754 rtype == OP_TRANS || rtype == OP_TRANSR)
2755 && !(right->op_flags & OPf_SPECIAL);
2756 if (ismatchop && right->op_private & OPpTARGET_MY) {
2758 right->op_private &= ~OPpTARGET_MY;
2760 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2763 right->op_flags |= OPf_STACKED;
2764 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
2765 ! (rtype == OP_TRANS &&
2766 right->op_private & OPpTRANS_IDENTICAL) &&
2767 ! (rtype == OP_SUBST &&
2768 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
2769 newleft = op_lvalue(left, rtype);
2772 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
2773 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2775 o = op_prepend_elem(rtype, scalar(newleft), right);
2777 return newUNOP(OP_NOT, 0, scalar(o));
2781 return bind_match(type, left,
2782 pmruntime(newPMOP(OP_MATCH, 0), right, 0, 0));
2786 Perl_invert(pTHX_ OP *o)
2790 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2794 =for apidoc Amx|OP *|op_scope|OP *o
2796 Wraps up an op tree with some additional ops so that at runtime a dynamic
2797 scope will be created. The original ops run in the new dynamic scope,
2798 and then, provided that they exit normally, the scope will be unwound.
2799 The additional ops used to create and unwind the dynamic scope will
2800 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
2801 instead if the ops are simple enough to not need the full dynamic scope
2808 Perl_op_scope(pTHX_ OP *o)
2812 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2813 o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2814 o->op_type = OP_LEAVE;
2815 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2817 else if (o->op_type == OP_LINESEQ) {
2819 o->op_type = OP_SCOPE;
2820 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2821 kid = ((LISTOP*)o)->op_first;
2822 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2825 /* The following deals with things like 'do {1 for 1}' */
2826 kid = kid->op_sibling;
2828 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2833 o = newLISTOP(OP_SCOPE, 0, o, NULL);
2839 Perl_block_start(pTHX_ int full)
2842 const int retval = PL_savestack_ix;
2844 pad_block_start(full);
2846 PL_hints &= ~HINT_BLOCK_SCOPE;
2847 SAVECOMPILEWARNINGS();
2848 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2850 CALL_BLOCK_HOOKS(bhk_start, full);
2856 Perl_block_end(pTHX_ I32 floor, OP *seq)
2859 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2860 OP* retval = scalarseq(seq);
2862 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
2865 CopHINTS_set(&PL_compiling, PL_hints);
2867 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2870 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
2876 =head1 Compile-time scope hooks
2878 =for apidoc Aox||blockhook_register
2880 Register a set of hooks to be called when the Perl lexical scope changes
2881 at compile time. See L<perlguts/"Compile-time scope hooks">.
2887 Perl_blockhook_register(pTHX_ BHK *hk)
2889 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
2891 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
2898 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
2899 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2900 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2903 OP * const o = newOP(OP_PADSV, 0);
2904 o->op_targ = offset;
2910 Perl_newPROG(pTHX_ OP *o)
2914 PERL_ARGS_ASSERT_NEWPROG;
2921 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2922 ((PL_in_eval & EVAL_KEEPERR)
2923 ? OPf_SPECIAL : 0), o);
2925 cx = &cxstack[cxstack_ix];
2926 assert(CxTYPE(cx) == CXt_EVAL);
2928 if ((cx->blk_gimme & G_WANT) == G_VOID)
2929 scalarvoid(PL_eval_root);
2930 else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
2933 scalar(PL_eval_root);
2935 PL_eval_start = op_linklist(PL_eval_root);
2936 PL_eval_root->op_private |= OPpREFCOUNTED;
2937 OpREFCNT_set(PL_eval_root, 1);
2938 PL_eval_root->op_next = 0;
2939 i = PL_savestack_ix;
2942 CALL_PEEP(PL_eval_start);
2943 finalize_optree(PL_eval_root);
2945 PL_savestack_ix = i;
2948 if (o->op_type == OP_STUB) {
2949 PL_comppad_name = 0;
2951 S_op_destroy(aTHX_ o);
2954 PL_main_root = op_scope(sawparens(scalarvoid(o)));
2955 PL_curcop = &PL_compiling;
2956 PL_main_start = LINKLIST(PL_main_root);
2957 PL_main_root->op_private |= OPpREFCOUNTED;
2958 OpREFCNT_set(PL_main_root, 1);
2959 PL_main_root->op_next = 0;
2960 CALL_PEEP(PL_main_start);
2961 finalize_optree(PL_main_root);
2962 cv_forget_slab(PL_compcv);
2965 /* Register with debugger */
2967 CV * const cv = get_cvs("DB::postponed", 0);
2971 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
2973 call_sv(MUTABLE_SV(cv), G_DISCARD);
2980 Perl_localize(pTHX_ OP *o, I32 lex)
2984 PERL_ARGS_ASSERT_LOCALIZE;
2986 if (o->op_flags & OPf_PARENS)
2987 /* [perl #17376]: this appears to be premature, and results in code such as
2988 C< our(%x); > executing in list mode rather than void mode */
2995 if ( PL_parser->bufptr > PL_parser->oldbufptr
2996 && PL_parser->bufptr[-1] == ','
2997 && ckWARN(WARN_PARENTHESIS))
2999 char *s = PL_parser->bufptr;
3002 /* some heuristics to detect a potential error */
3003 while (*s && (strchr(", \t\n", *s)))
3007 if (*s && strchr("@$%*", *s) && *++s
3008 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
3011 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
3013 while (*s && (strchr(", \t\n", *s)))
3019 if (sigil && (*s == ';' || *s == '=')) {
3020 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
3021 "Parentheses missing around \"%s\" list",
3023 ? (PL_parser->in_my == KEY_our
3025 : PL_parser->in_my == KEY_state
3035 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
3036 PL_parser->in_my = FALSE;
3037 PL_parser->in_my_stash = NULL;
3042 Perl_jmaybe(pTHX_ OP *o)
3044 PERL_ARGS_ASSERT_JMAYBE;
3046 if (o->op_type == OP_LIST) {
3048 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
3049 o = convert(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
3054 PERL_STATIC_INLINE OP *
3055 S_op_std_init(pTHX_ OP *o)
3057 I32 type = o->op_type;
3059 PERL_ARGS_ASSERT_OP_STD_INIT;
3061 if (PL_opargs[type] & OA_RETSCALAR)
3063 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
3064 o->op_targ = pad_alloc(type, SVs_PADTMP);
3069 PERL_STATIC_INLINE OP *
3070 S_op_integerize(pTHX_ OP *o)
3072 I32 type = o->op_type;
3074 PERL_ARGS_ASSERT_OP_INTEGERIZE;
3076 /* integerize op. */
3077 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
3080 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
3083 if (type == OP_NEGATE)
3084 /* XXX might want a ck_negate() for this */
3085 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
3091 S_fold_constants(pTHX_ register OP *o)
3094 register OP * VOL curop;
3096 VOL I32 type = o->op_type;
3101 SV * const oldwarnhook = PL_warnhook;
3102 SV * const olddiehook = PL_diehook;
3106 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
3108 if (!(PL_opargs[type] & OA_FOLDCONST))
3122 /* XXX what about the numeric ops? */
3123 if (IN_LOCALE_COMPILETIME)
3127 if (!cLISTOPo->op_first->op_sibling
3128 || cLISTOPo->op_first->op_sibling->op_type != OP_CONST)
3131 SV * const sv = cSVOPx_sv(cLISTOPo->op_first->op_sibling);
3132 if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
3134 const char *s = SvPVX_const(sv);
3135 while (s < SvEND(sv)) {
3136 if (*s == 'p' || *s == 'P') goto nope;
3143 if (o->op_private & OPpREPEAT_DOLIST) goto nope;
3146 if (PL_parser && PL_parser->error_count)
3147 goto nope; /* Don't try to run w/ errors */
3149 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3150 const OPCODE type = curop->op_type;
3151 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
3153 type != OP_SCALAR &&
3155 type != OP_PUSHMARK)
3161 curop = LINKLIST(o);
3162 old_next = o->op_next;
3166 oldscope = PL_scopestack_ix;
3167 create_eval_scope(G_FAKINGEVAL);
3169 /* Verify that we don't need to save it: */
3170 assert(PL_curcop == &PL_compiling);
3171 StructCopy(&PL_compiling, ¬_compiling, COP);
3172 PL_curcop = ¬_compiling;
3173 /* The above ensures that we run with all the correct hints of the
3174 currently compiling COP, but that IN_PERL_RUNTIME is not true. */
3175 assert(IN_PERL_RUNTIME);
3176 PL_warnhook = PERL_WARNHOOK_FATAL;
3183 sv = *(PL_stack_sp--);
3184 if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
3186 /* Can't simply swipe the SV from the pad, because that relies on
3187 the op being freed "real soon now". Under MAD, this doesn't
3188 happen (see the #ifdef below). */
3191 pad_swipe(o->op_targ, FALSE);
3194 else if (SvTEMP(sv)) { /* grab mortal temp? */
3195 SvREFCNT_inc_simple_void(sv);
3200 /* Something tried to die. Abandon constant folding. */
3201 /* Pretend the error never happened. */
3203 o->op_next = old_next;
3207 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
3208 PL_warnhook = oldwarnhook;
3209 PL_diehook = olddiehook;
3210 /* XXX note that this croak may fail as we've already blown away
3211 * the stack - eg any nested evals */
3212 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
3215 PL_warnhook = oldwarnhook;
3216 PL_diehook = olddiehook;
3217 PL_curcop = &PL_compiling;
3219 if (PL_scopestack_ix > oldscope)
3220 delete_eval_scope();
3229 if (type == OP_RV2GV)
3230 newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
3232 newop = newSVOP(OP_CONST, OPpCONST_FOLDED<<8, MUTABLE_SV(sv));
3233 op_getmad(o,newop,'f');
3241 S_gen_constant_list(pTHX_ register OP *o)
3245 const I32 oldtmps_floor = PL_tmps_floor;
3248 if (PL_parser && PL_parser->error_count)
3249 return o; /* Don't attempt to run with errors */
3251 PL_op = curop = LINKLIST(o);
3254 Perl_pp_pushmark(aTHX);
3257 assert (!(curop->op_flags & OPf_SPECIAL));
3258 assert(curop->op_type == OP_RANGE);
3259 Perl_pp_anonlist(aTHX);
3260 PL_tmps_floor = oldtmps_floor;
3262 o->op_type = OP_RV2AV;
3263 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
3264 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
3265 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
3266 o->op_opt = 0; /* needs to be revisited in rpeep() */
3267 curop = ((UNOP*)o)->op_first;
3268 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
3270 op_getmad(curop,o,'O');
3279 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
3282 if (type < 0) type = -type, flags |= OPf_SPECIAL;
3283 if (!o || o->op_type != OP_LIST)
3284 o = newLISTOP(OP_LIST, 0, o, NULL);
3286 o->op_flags &= ~OPf_WANT;
3288 if (!(PL_opargs[type] & OA_MARK))
3289 op_null(cLISTOPo->op_first);
3291 OP * const kid2 = cLISTOPo->op_first->op_sibling;
3292 if (kid2 && kid2->op_type == OP_COREARGS) {
3293 op_null(cLISTOPo->op_first);
3294 kid2->op_private |= OPpCOREARGS_PUSHMARK;
3298 o->op_type = (OPCODE)type;
3299 o->op_ppaddr = PL_ppaddr[type];
3300 o->op_flags |= flags;
3302 o = CHECKOP(type, o);
3303 if (o->op_type != (unsigned)type)
3306 return fold_constants(op_integerize(op_std_init(o)));
3310 =head1 Optree Manipulation Functions
3313 /* List constructors */
3316 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
3318 Append an item to the list of ops contained directly within a list-type
3319 op, returning the lengthened list. I<first> is the list-type op,
3320 and I<last> is the op to append to the list. I<optype> specifies the
3321 intended opcode for the list. If I<first> is not already a list of the
3322 right type, it will be upgraded into one. If either I<first> or I<last>
3323 is null, the other is returned unchanged.
3329 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
3337 if (first->op_type != (unsigned)type
3338 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
3340 return newLISTOP(type, 0, first, last);
3343 if (first->op_flags & OPf_KIDS)
3344 ((LISTOP*)first)->op_last->op_sibling = last;
3346 first->op_flags |= OPf_KIDS;
3347 ((LISTOP*)first)->op_first = last;
3349 ((LISTOP*)first)->op_last = last;
3354 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
3356 Concatenate the lists of ops contained directly within two list-type ops,
3357 returning the combined list. I<first> and I<last> are the list-type ops
3358 to concatenate. I<optype> specifies the intended opcode for the list.
3359 If either I<first> or I<last> is not already a list of the right type,
3360 it will be upgraded into one. If either I<first> or I<last> is null,
3361 the other is returned unchanged.
3367 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
3375 if (first->op_type != (unsigned)type)
3376 return op_prepend_elem(type, first, last);
3378 if (last->op_type != (unsigned)type)
3379 return op_append_elem(type, first, last);
3381 ((LISTOP*)first)->op_last->op_sibling = ((LISTOP*)last)->op_first;
3382 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
3383 first->op_flags |= (last->op_flags & OPf_KIDS);
3386 if (((LISTOP*)last)->op_first && first->op_madprop) {
3387 MADPROP *mp = ((LISTOP*)last)->op_first->op_madprop;
3389 while (mp->mad_next)
3391 mp->mad_next = first->op_madprop;
3394 ((LISTOP*)last)->op_first->op_madprop = first->op_madprop;
3397 first->op_madprop = last->op_madprop;
3398 last->op_madprop = 0;
3401 S_op_destroy(aTHX_ last);
3407 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
3409 Prepend an item to the list of ops contained directly within a list-type
3410 op, returning the lengthened list. I<first> is the op to prepend to the
3411 list, and I<last> is the list-type op. I<optype> specifies the intended
3412 opcode for the list. If I<last> is not already a list of the right type,
3413 it will be upgraded into one. If either I<first> or I<last> is null,
3414 the other is returned unchanged.
3420 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
3428 if (last->op_type == (unsigned)type) {
3429 if (type == OP_LIST) { /* already a PUSHMARK there */
3430 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
3431 ((LISTOP*)last)->op_first->op_sibling = first;
3432 if (!(first->op_flags & OPf_PARENS))
3433 last->op_flags &= ~OPf_PARENS;
3436 if (!(last->op_flags & OPf_KIDS)) {
3437 ((LISTOP*)last)->op_last = first;
3438 last->op_flags |= OPf_KIDS;
3440 first->op_sibling = ((LISTOP*)last)->op_first;
3441 ((LISTOP*)last)->op_first = first;
3443 last->op_flags |= OPf_KIDS;
3447 return newLISTOP(type, 0, first, last);
3455 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
3458 Newxz(tk, 1, TOKEN);
3459 tk->tk_type = (OPCODE)optype;
3460 tk->tk_type = 12345;
3462 tk->tk_mad = madprop;
3467 Perl_token_free(pTHX_ TOKEN* tk)
3469 PERL_ARGS_ASSERT_TOKEN_FREE;
3471 if (tk->tk_type != 12345)
3473 mad_free(tk->tk_mad);
3478 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
3483 PERL_ARGS_ASSERT_TOKEN_GETMAD;
3485 if (tk->tk_type != 12345) {
3486 Perl_warner(aTHX_ packWARN(WARN_MISC),
3487 "Invalid TOKEN object ignored");
3494 /* faked up qw list? */
3496 tm->mad_type == MAD_SV &&
3497 SvPVX((SV *)tm->mad_val)[0] == 'q')
3504 /* pretend constant fold didn't happen? */
3505 if (mp->mad_key == 'f' &&
3506 (o->op_type == OP_CONST ||
3507 o->op_type == OP_GV) )
3509 token_getmad(tk,(OP*)mp->mad_val,slot);
3523 if (mp->mad_key == 'X')
3524 mp->mad_key = slot; /* just change the first one */
3534 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
3543 /* pretend constant fold didn't happen? */
3544 if (mp->mad_key == 'f' &&
3545 (o->op_type == OP_CONST ||
3546 o->op_type == OP_GV) )
3548 op_getmad(from,(OP*)mp->mad_val,slot);
3555 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
3558 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
3564 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
3573 /* pretend constant fold didn't happen? */
3574 if (mp->mad_key == 'f' &&
3575 (o->op_type == OP_CONST ||
3576 o->op_type == OP_GV) )
3578 op_getmad(from,(OP*)mp->mad_val,slot);
3585 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
3588 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
3592 PerlIO_printf(PerlIO_stderr(),
3593 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
3599 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
3617 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
3621 addmad(tm, &(o->op_madprop), slot);
3625 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
3646 Perl_newMADsv(pTHX_ char key, SV* sv)
3648 PERL_ARGS_ASSERT_NEWMADSV;
3650 return newMADPROP(key, MAD_SV, sv, 0);
3654 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
3656 MADPROP *const mp = (MADPROP *) PerlMemShared_malloc(sizeof(MADPROP));
3659 mp->mad_vlen = vlen;
3660 mp->mad_type = type;
3662 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
3667 Perl_mad_free(pTHX_ MADPROP* mp)
3669 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
3673 mad_free(mp->mad_next);
3674 /* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
3675 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
3676 switch (mp->mad_type) {
3680 Safefree((char*)mp->mad_val);
3683 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
3684 op_free((OP*)mp->mad_val);
3687 sv_free(MUTABLE_SV(mp->mad_val));
3690 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
3693 PerlMemShared_free(mp);
3699 =head1 Optree construction
3701 =for apidoc Am|OP *|newNULLLIST
3703 Constructs, checks, and returns a new C<stub> op, which represents an
3704 empty list expression.
3710 Perl_newNULLLIST(pTHX)
3712 return newOP(OP_STUB, 0);
3716 S_force_list(pTHX_ OP *o)
3718 if (!o || o->op_type != OP_LIST)
3719 o = newLISTOP(OP_LIST, 0, o, NULL);
3725 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
3727 Constructs, checks, and returns an op of any list type. I<type> is
3728 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3729 C<OPf_KIDS> will be set automatically if required. I<first> and I<last>
3730 supply up to two ops to be direct children of the list op; they are
3731 consumed by this function and become part of the constructed op tree.
3737 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3742 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
3744 NewOp(1101, listop, 1, LISTOP);
3746 listop->op_type = (OPCODE)type;
3747 listop->op_ppaddr = PL_ppaddr[type];
3750 listop->op_flags = (U8)flags;
3754 else if (!first && last)
3757 first->op_sibling = last;
3758 listop->op_first = first;
3759 listop->op_last = last;
3760 if (type == OP_LIST) {
3761 OP* const pushop = newOP(OP_PUSHMARK, 0);
3762 pushop->op_sibling = first;
3763 listop->op_first = pushop;
3764 listop->op_flags |= OPf_KIDS;
3766 listop->op_last = pushop;
3769 return CHECKOP(type, listop);
3773 =for apidoc Am|OP *|newOP|I32 type|I32 flags
3775 Constructs, checks, and returns an op of any base type (any type that
3776 has no extra fields). I<type> is the opcode. I<flags> gives the
3777 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
3784 Perl_newOP(pTHX_ I32 type, I32 flags)
3789 if (type == -OP_ENTEREVAL) {
3790 type = OP_ENTEREVAL;
3791 flags |= OPpEVAL_BYTES<<8;
3794 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
3795 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3796 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3797 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
3799 NewOp(1101, o, 1, OP);
3800 o->op_type = (OPCODE)type;
3801 o->op_ppaddr = PL_ppaddr[type];
3802 o->op_flags = (U8)flags;
3805 o->op_private = (U8)(0 | (flags >> 8));
3806 if (PL_opargs[type] & OA_RETSCALAR)
3808 if (PL_opargs[type] & OA_TARGET)
3809 o->op_targ = pad_alloc(type, SVs_PADTMP);
3810 return CHECKOP(type, o);
3814 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
3816 Constructs, checks, and returns an op of any unary type. I<type> is
3817 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3818 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
3819 bits, the eight bits of C<op_private>, except that the bit with value 1
3820 is automatically set. I<first> supplies an optional op to be the direct
3821 child of the unary op; it is consumed by this function and become part
3822 of the constructed op tree.
3828 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
3833 if (type == -OP_ENTEREVAL) {
3834 type = OP_ENTEREVAL;
3835 flags |= OPpEVAL_BYTES<<8;
3838 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
3839 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3840 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3841 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
3842 || type == OP_SASSIGN
3843 || type == OP_ENTERTRY
3844 || type == OP_NULL );
3847 first = newOP(OP_STUB, 0);
3848 if (PL_opargs[type] & OA_MARK)
3849 first = force_list(first);
3851 NewOp(1101, unop, 1, UNOP);
3852 unop->op_type = (OPCODE)type;
3853 unop->op_ppaddr = PL_ppaddr[type];
3854 unop->op_first = first;
3855 unop->op_flags = (U8)(flags | OPf_KIDS);
3856 unop->op_private = (U8)(1 | (flags >> 8));
3857 unop = (UNOP*) CHECKOP(type, unop);
3861 return fold_constants(op_integerize(op_std_init((OP *) unop)));
3865 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
3867 Constructs, checks, and returns an op of any binary type. I<type>
3868 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
3869 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
3870 the eight bits of C<op_private>, except that the bit with value 1 or
3871 2 is automatically set as required. I<first> and I<last> supply up to
3872 two ops to be the direct children of the binary op; they are consumed
3873 by this function and become part of the constructed op tree.
3879 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3884 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
3885 || type == OP_SASSIGN || type == OP_NULL );
3887 NewOp(1101, binop, 1, BINOP);
3890 first = newOP(OP_NULL, 0);
3892 binop->op_type = (OPCODE)type;
3893 binop->op_ppaddr = PL_ppaddr[type];
3894 binop->op_first = first;
3895 binop->op_flags = (U8)(flags | OPf_KIDS);
3898 binop->op_private = (U8)(1 | (flags >> 8));
3901 binop->op_private = (U8)(2 | (flags >> 8));
3902 first->op_sibling = last;
3905 binop = (BINOP*)CHECKOP(type, binop);
3906 if (binop->op_next || binop->op_type != (OPCODE)type)
3909 binop->op_last = binop->op_first->op_sibling;
3911 return fold_constants(op_integerize(op_std_init((OP *)binop)));
3914 static int uvcompare(const void *a, const void *b)
3915 __attribute__nonnull__(1)
3916 __attribute__nonnull__(2)
3917 __attribute__pure__;
3918 static int uvcompare(const void *a, const void *b)
3920 if (*((const UV *)a) < (*(const UV *)b))
3922 if (*((const UV *)a) > (*(const UV *)b))
3924 if (*((const UV *)a+1) < (*(const UV *)b+1))
3926 if (*((const UV *)a+1) > (*(const UV *)b+1))
3932 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3935 SV * const tstr = ((SVOP*)expr)->op_sv;
3938 (repl->op_type == OP_NULL)
3939 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3941 ((SVOP*)repl)->op_sv;
3944 const U8 *t = (U8*)SvPV_const(tstr, tlen);
3945 const U8 *r = (U8*)SvPV_const(rstr, rlen);
3949 register short *tbl;
3951 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3952 const I32 squash = o->op_private & OPpTRANS_SQUASH;
3953 I32 del = o->op_private & OPpTRANS_DELETE;
3956 PERL_ARGS_ASSERT_PMTRANS;
3958 PL_hints |= HINT_BLOCK_SCOPE;
3961 o->op_private |= OPpTRANS_FROM_UTF;
3964 o->op_private |= OPpTRANS_TO_UTF;
3966 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3967 SV* const listsv = newSVpvs("# comment\n");
3969 const U8* tend = t + tlen;
3970 const U8* rend = r + rlen;
3984 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
3985 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
3988 const U32 flags = UTF8_ALLOW_DEFAULT;
3992 t = tsave = bytes_to_utf8(t, &len);
3995 if (!to_utf && rlen) {
3997 r = rsave = bytes_to_utf8(r, &len);
4001 /* There are several snags with this code on EBCDIC:
4002 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
4003 2. scan_const() in toke.c has encoded chars in native encoding which makes
4004 ranges at least in EBCDIC 0..255 range the bottom odd.
4008 U8 tmpbuf[UTF8_MAXBYTES+1];
4011 Newx(cp, 2*tlen, UV);
4013 transv = newSVpvs("");
4015 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
4017 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
4019 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
4023 cp[2*i+1] = cp[2*i];
4027 qsort(cp, i, 2*sizeof(UV), uvcompare);
4028 for (j = 0; j < i; j++) {
4030 diff = val - nextmin;
4032 t = uvuni_to_utf8(tmpbuf,nextmin);
4033 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4035 U8 range_mark = UTF_TO_NATIVE(0xff);
4036 t = uvuni_to_utf8(tmpbuf, val - 1);
4037 sv_catpvn(transv, (char *)&range_mark, 1);
4038 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4045 t = uvuni_to_utf8(tmpbuf,nextmin);
4046 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4048 U8 range_mark = UTF_TO_NATIVE(0xff);
4049 sv_catpvn(transv, (char *)&range_mark, 1);
4051 t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
4052 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4053 t = (const U8*)SvPVX_const(transv);
4054 tlen = SvCUR(transv);
4058 else if (!rlen && !del) {
4059 r = t; rlen = tlen; rend = tend;
4062 if ((!rlen && !del) || t == r ||
4063 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
4065 o->op_private |= OPpTRANS_IDENTICAL;
4069 while (t < tend || tfirst <= tlast) {
4070 /* see if we need more "t" chars */
4071 if (tfirst > tlast) {
4072 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
4074 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
4076 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
4083 /* now see if we need more "r" chars */
4084 if (rfirst > rlast) {
4086 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
4088 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
4090 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
4099 rfirst = rlast = 0xffffffff;
4103 /* now see which range will peter our first, if either. */
4104 tdiff = tlast - tfirst;
4105 rdiff = rlast - rfirst;
4112 if (rfirst == 0xffffffff) {
4113 diff = tdiff; /* oops, pretend rdiff is infinite */
4115 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
4116 (long)tfirst, (long)tlast);
4118 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
4122 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
4123 (long)tfirst, (long)(tfirst + diff),
4126 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
4127 (long)tfirst, (long)rfirst);
4129 if (rfirst + diff > max)
4130 max = rfirst + diff;
4132 grows = (tfirst < rfirst &&
4133 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
4145 else if (max > 0xff)
4150 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
4152 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
4153 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
4154 PAD_SETSV(cPADOPo->op_padix, swash);
4156 SvREADONLY_on(swash);
4158 cSVOPo->op_sv = swash;
4160 SvREFCNT_dec(listsv);
4161 SvREFCNT_dec(transv);
4163 if (!del && havefinal && rlen)
4164 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
4165 newSVuv((UV)final), 0);
4168 o->op_private |= OPpTRANS_GROWS;
4174 op_getmad(expr,o,'e');
4175 op_getmad(repl,o,'r');
4183 tbl = (short*)PerlMemShared_calloc(
4184 (o->op_private & OPpTRANS_COMPLEMENT) &&
4185 !(o->op_private & OPpTRANS_DELETE) ? 258 : 256,
4187 cPVOPo->op_pv = (char*)tbl;
4189 for (i = 0; i < (I32)tlen; i++)
4191 for (i = 0, j = 0; i < 256; i++) {
4193 if (j >= (I32)rlen) {
4202 if (i < 128 && r[j] >= 128)
4212 o->op_private |= OPpTRANS_IDENTICAL;
4214 else if (j >= (I32)rlen)
4219 PerlMemShared_realloc(tbl,
4220 (0x101+rlen-j) * sizeof(short));
4221 cPVOPo->op_pv = (char*)tbl;
4223 tbl[0x100] = (short)(rlen - j);
4224 for (i=0; i < (I32)rlen - j; i++)
4225 tbl[0x101+i] = r[j+i];
4229 if (!rlen && !del) {
4232 o->op_private |= OPpTRANS_IDENTICAL;
4234 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
4235 o->op_private |= OPpTRANS_IDENTICAL;
4237 for (i = 0; i < 256; i++)
4239 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
4240 if (j >= (I32)rlen) {
4242 if (tbl[t[i]] == -1)
4248 if (tbl[t[i]] == -1) {
4249 if (t[i] < 128 && r[j] >= 128)
4256 if(del && rlen == tlen) {
4257 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
4258 } else if(rlen > tlen) {
4259 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
4263 o->op_private |= OPpTRANS_GROWS;
4265 op_getmad(expr,o,'e');
4266 op_getmad(repl,o,'r');
4276 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
4278 Constructs, checks, and returns an op of any pattern matching type.
4279 I<type> is the opcode. I<flags> gives the eight bits of C<op_flags>
4280 and, shifted up eight bits, the eight bits of C<op_private>.
4286 Perl_newPMOP(pTHX_ I32 type, I32 flags)
4291 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
4293 NewOp(1101, pmop, 1, PMOP);
4294 pmop->op_type = (OPCODE)type;
4295 pmop->op_ppaddr = PL_ppaddr[type];
4296 pmop->op_flags = (U8)flags;
4297 pmop->op_private = (U8)(0 | (flags >> 8));
4299 if (PL_hints & HINT_RE_TAINT)
4300 pmop->op_pmflags |= PMf_RETAINT;
4301 if (IN_LOCALE_COMPILETIME) {
4302 set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
4304 else if ((! (PL_hints & HINT_BYTES))
4305 /* Both UNI_8_BIT and locale :not_characters imply Unicode */
4306 && (PL_hints & (HINT_UNI_8_BIT|HINT_LOCALE_NOT_CHARS)))
4308 set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
4310 if (PL_hints & HINT_RE_FLAGS) {
4311 SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4312 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
4314 if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
4315 reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4316 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
4318 if (reflags && SvOK(reflags)) {
4319 set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
4325 assert(SvPOK(PL_regex_pad[0]));
4326 if (SvCUR(PL_regex_pad[0])) {
4327 /* Pop off the "packed" IV from the end. */
4328 SV *const repointer_list = PL_regex_pad[0];
4329 const char *p = SvEND(repointer_list) - sizeof(IV);
4330 const IV offset = *((IV*)p);
4332 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
4334 SvEND_set(repointer_list, p);
4336 pmop->op_pmoffset = offset;
4337 /* This slot should be free, so assert this: */
4338 assert(PL_regex_pad[offset] == &PL_sv_undef);
4340 SV * const repointer = &PL_sv_undef;
4341 av_push(PL_regex_padav, repointer);
4342 pmop->op_pmoffset = av_len(PL_regex_padav);
4343 PL_regex_pad = AvARRAY(PL_regex_padav);
4347 return CHECKOP(type, pmop);
4350 /* Given some sort of match op o, and an expression expr containing a
4351 * pattern, either compile expr into a regex and attach it to o (if it's
4352 * constant), or convert expr into a runtime regcomp op sequence (if it's
4355 * isreg indicates that the pattern is part of a regex construct, eg
4356 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
4357 * split "pattern", which aren't. In the former case, expr will be a list
4358 * if the pattern contains more than one term (eg /a$b/) or if it contains
4359 * a replacement, ie s/// or tr///.
4361 * When the pattern has been compiled within a new anon CV (for
4362 * qr/(?{...})/ ), then floor indicates the savestack level just before
4363 * the new sub was created
4367 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor)
4372 I32 repl_has_vars = 0;
4374 bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
4375 bool is_compiletime;
4378 PERL_ARGS_ASSERT_PMRUNTIME;
4380 /* for s/// and tr///, last element in list is the replacement; pop it */
4382 if (is_trans || o->op_type == OP_SUBST) {
4384 repl = cLISTOPx(expr)->op_last;
4385 kid = cLISTOPx(expr)->op_first;
4386 while (kid->op_sibling != repl)
4387 kid = kid->op_sibling;
4388 kid->op_sibling = NULL;
4389 cLISTOPx(expr)->op_last = kid;
4392 /* for TRANS, convert LIST/PUSH/CONST into CONST, and pass to pmtrans() */
4395 OP* const oe = expr;
4396 assert(expr->op_type == OP_LIST);
4397 assert(cLISTOPx(expr)->op_first->op_type == OP_PUSHMARK);
4398 assert(cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last);
4399 expr = cLISTOPx(oe)->op_last;
4400 cLISTOPx(oe)->op_first->op_sibling = NULL;
4401 cLISTOPx(oe)->op_last = NULL;
4404 return pmtrans(o, expr, repl);
4407 /* find whether we have any runtime or code elements;
4408 * at the same time, temporarily set the op_next of each DO block;
4409 * then when we LINKLIST, this will cause the DO blocks to be excluded
4410 * from the op_next chain (and from having LINKLIST recursively
4411 * applied to them). We fix up the DOs specially later */
4415 if (expr->op_type == OP_LIST) {
4417 for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) {
4418 if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
4420 assert(!o->op_next && o->op_sibling);
4421 o->op_next = o->op_sibling;
4423 else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
4427 else if (expr->op_type != OP_CONST)
4432 /* fix up DO blocks; treat each one as a separate little sub */
4434 if (expr->op_type == OP_LIST) {
4436 for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) {
4437 if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
4439 o->op_next = NULL; /* undo temporary hack from above */
4442 if (cLISTOPo->op_first->op_type == OP_LEAVE) {
4443 LISTOP *leave = cLISTOPx(cLISTOPo->op_first);
4445 assert(leave->op_first->op_type == OP_ENTER);
4446 assert(leave->op_first->op_sibling);
4447 o->op_next = leave->op_first->op_sibling;
4449 assert(leave->op_flags & OPf_KIDS);
4450 assert(leave->op_last->op_next = (OP*)leave);
4451 leave->op_next = NULL; /* stop on last op */
4452 op_null((OP*)leave);
4456 OP *scope = cLISTOPo->op_first;
4457 assert(scope->op_type == OP_SCOPE);
4458 assert(scope->op_flags & OPf_KIDS);
4459 scope->op_next = NULL; /* stop on last op */
4462 /* have to peep the DOs individually as we've removed it from
4463 * the op_next chain */
4466 /* runtime finalizes as part of finalizing whole tree */
4471 PL_hints |= HINT_BLOCK_SCOPE;
4473 assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
4475 if (is_compiletime) {
4476 U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
4477 regexp_engine const *eng = current_re_engine();
4479 if (o->op_flags & OPf_SPECIAL)
4480 rx_flags |= RXf_SPLIT;
4482 if (!has_code || !eng->op_comp) {
4483 /* compile-time simple constant pattern */
4485 if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
4486 /* whoops! we guessed that a qr// had a code block, but we
4487 * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
4488 * that isn't required now. Note that we have to be pretty
4489 * confident that nothing used that CV's pad while the
4490 * regex was parsed */
4491 assert(AvFILLp(PL_comppad) == 0); /* just @_ */
4492 /* But we know that one op is using this CV's slab. */
4493 cv_forget_slab(PL_compcv);
4495 pm->op_pmflags &= ~PMf_HAS_CV;
4500 ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
4501 rx_flags, pm->op_pmflags)
4502 : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
4503 rx_flags, pm->op_pmflags)
4506 op_getmad(expr,(OP*)pm,'e');
4512 /* compile-time pattern that includes literal code blocks */
4513 REGEXP* re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
4516 ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
4519 if (pm->op_pmflags & PMf_HAS_CV) {
4521 /* this QR op (and the anon sub we embed it in) is never
4522 * actually executed. It's just a placeholder where we can
4523 * squirrel away expr in op_code_list without the peephole
4524 * optimiser etc processing it for a second time */
4525 OP *qr = newPMOP(OP_QR, 0);
4526 ((PMOP*)qr)->op_code_list = expr;
4528 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
4529 SvREFCNT_inc_simple_void(PL_compcv);
4530 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
4531 ((struct regexp *)SvANY(re))->qr_anoncv = cv;
4533 /* attach the anon CV to the pad so that
4534 * pad_fixup_inner_anons() can find it */
4535 (void)pad_add_anon(cv, o->op_type);
4536 SvREFCNT_inc_simple_void(cv);
4539 pm->op_code_list = expr;
4544 /* runtime pattern: build chain of regcomp etc ops */
4546 PADOFFSET cv_targ = 0;
4548 reglist = isreg && expr->op_type == OP_LIST;
4553 pm->op_code_list = expr;
4554 /* don't free op_code_list; its ops are embedded elsewhere too */
4555 pm->op_pmflags |= PMf_CODELIST_PRIVATE;
4558 /* the OP_REGCMAYBE is a placeholder in the non-threaded case
4559 * to allow its op_next to be pointed past the regcomp and
4560 * preceding stacking ops;
4561 * OP_REGCRESET is there to reset taint before executing the
4563 if (pm->op_pmflags & PMf_KEEP || PL_tainting)
4564 expr = newUNOP((PL_tainting ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
4566 if (pm->op_pmflags & PMf_HAS_CV) {
4567 /* we have a runtime qr with literal code. This means
4568 * that the qr// has been wrapped in a new CV, which
4569 * means that runtime consts, vars etc will have been compiled
4570 * against a new pad. So... we need to execute those ops
4571 * within the environment of the new CV. So wrap them in a call
4572 * to a new anon sub. i.e. for
4576 * we build an anon sub that looks like
4578 * sub { "a", $b, '(?{...})' }
4580 * and call it, passing the returned list to regcomp.
4581 * Or to put it another way, the list of ops that get executed
4585 * ------ -------------------
4586 * pushmark (for regcomp)
4587 * pushmark (for entersub)
4588 * pushmark (for refgen)
4592 * regcreset regcreset
4594 * const("a") const("a")
4596 * const("(?{...})") const("(?{...})")
4601 SvREFCNT_inc_simple_void(PL_compcv);
4602 /* these lines are just an unrolled newANONATTRSUB */
4603 expr = newSVOP(OP_ANONCODE, 0,
4604 MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
4605 cv_targ = expr->op_targ;
4606 expr = newUNOP(OP_REFGEN, 0, expr);
4608 expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr))));
4611 NewOp(1101, rcop, 1, LOGOP);
4612 rcop->op_type = OP_REGCOMP;
4613 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
4614 rcop->op_first = scalar(expr);
4615 rcop->op_flags |= OPf_KIDS
4616 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
4617 | (reglist ? OPf_STACKED : 0);
4618 rcop->op_private = 0;
4620 rcop->op_targ = cv_targ;
4622 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
4623 if (PL_hints & HINT_RE_EVAL) PL_cv_has_eval = 1;
4625 /* establish postfix order */
4626 if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
4628 rcop->op_next = expr;
4629 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
4632 rcop->op_next = LINKLIST(expr);
4633 expr->op_next = (OP*)rcop;
4636 op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
4641 if (pm->op_pmflags & PMf_EVAL) {
4643 if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
4644 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
4646 else if (repl->op_type == OP_CONST)
4650 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
4651 if (curop->op_type == OP_SCOPE
4652 || curop->op_type == OP_LEAVE
4653 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
4654 if (curop->op_type == OP_GV) {
4655 GV * const gv = cGVOPx_gv(curop);
4657 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
4660 else if (curop->op_type == OP_RV2CV)
4662 else if (curop->op_type == OP_RV2SV ||
4663 curop->op_type == OP_RV2AV ||
4664 curop->op_type == OP_RV2HV ||
4665 curop->op_type == OP_RV2GV) {
4666 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
4669 else if (curop->op_type == OP_PADSV ||
4670 curop->op_type == OP_PADAV ||
4671 curop->op_type == OP_PADHV ||
4672 curop->op_type == OP_PADANY)
4676 else if (curop->op_type == OP_PUSHRE)
4677 NOOP; /* Okay here, dangerous in newASSIGNOP */
4687 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
4689 pm->op_pmflags |= PMf_CONST; /* const for long enough */
4690 op_prepend_elem(o->op_type, scalar(repl), o);
4693 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
4694 pm->op_pmflags |= PMf_MAYBE_CONST;
4696 NewOp(1101, rcop, 1, LOGOP);
4697 rcop->op_type = OP_SUBSTCONT;
4698 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
4699 rcop->op_first = scalar(repl);
4700 rcop->op_flags |= OPf_KIDS;
4701 rcop->op_private = 1;
4704 /* establish postfix order */
4705 rcop->op_next = LINKLIST(repl);
4706 repl->op_next = (OP*)rcop;
4708 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
4709 assert(!(pm->op_pmflags & PMf_ONCE));
4710 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
4719 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
4721 Constructs, checks, and returns an op of any type that involves an
4722 embedded SV. I<type> is the opcode. I<flags> gives the eight bits
4723 of C<op_flags>. I<sv> gives the SV to embed in the op; this function
4724 takes ownership of one reference to it.
4730 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
4735 PERL_ARGS_ASSERT_NEWSVOP;
4737 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4738 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4739 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4741 NewOp(1101, svop, 1, SVOP);
4742 svop->op_type = (OPCODE)type;
4743 svop->op_ppaddr = PL_ppaddr[type];
4745 svop->op_next = (OP*)svop;
4746 svop->op_flags = (U8)flags;
4747 svop->op_private = (U8)(0 | (flags >> 8));
4748 if (PL_opargs[type] & OA_RETSCALAR)
4750 if (PL_opargs[type] & OA_TARGET)
4751 svop->op_targ = pad_alloc(type, SVs_PADTMP);
4752 return CHECKOP(type, svop);
4758 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
4760 Constructs, checks, and returns an op of any type that involves a
4761 reference to a pad element. I<type> is the opcode. I<flags> gives the
4762 eight bits of C<op_flags>. A pad slot is automatically allocated, and
4763 is populated with I<sv>; this function takes ownership of one reference
4766 This function only exists if Perl has been compiled to use ithreads.
4772 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
4777 PERL_ARGS_ASSERT_NEWPADOP;
4779 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4780 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4781 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4783 NewOp(1101, padop, 1, PADOP);
4784 padop->op_type = (OPCODE)type;
4785 padop->op_ppaddr = PL_ppaddr[type];
4786 padop->op_padix = pad_alloc(type, SVs_PADTMP);
4787 SvREFCNT_dec(PAD_SVl(padop->op_padix));
4788 PAD_SETSV(padop->op_padix, sv);
4791 padop->op_next = (OP*)padop;
4792 padop->op_flags = (U8)flags;
4793 if (PL_opargs[type] & OA_RETSCALAR)
4795 if (PL_opargs[type] & OA_TARGET)
4796 padop->op_targ = pad_alloc(type, SVs_PADTMP);
4797 return CHECKOP(type, padop);
4800 #endif /* !USE_ITHREADS */
4803 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
4805 Constructs, checks, and returns an op of any type that involves an
4806 embedded reference to a GV. I<type> is the opcode. I<flags> gives the
4807 eight bits of C<op_flags>. I<gv> identifies the GV that the op should
4808 reference; calling this function does not transfer ownership of any
4815 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
4819 PERL_ARGS_ASSERT_NEWGVOP;
4823 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
4825 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
4830 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
4832 Constructs, checks, and returns an op of any type that involves an
4833 embedded C-level pointer (PV). I<type> is the opcode. I<flags> gives
4834 the eight bits of C<op_flags>. I<pv> supplies the C-level pointer, which
4835 must have been allocated using L</PerlMemShared_malloc>; the memory will
4836 be freed when the op is destroyed.
4842 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
4845 const bool utf8 = cBOOL(flags & SVf_UTF8);
4850 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4852 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4854 NewOp(1101, pvop, 1, PVOP);
4855 pvop->op_type = (OPCODE)type;
4856 pvop->op_ppaddr = PL_ppaddr[type];
4858 pvop->op_next = (OP*)pvop;
4859 pvop->op_flags = (U8)flags;
4860 pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
4861 if (PL_opargs[type] & OA_RETSCALAR)
4863 if (PL_opargs[type] & OA_TARGET)
4864 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
4865 return CHECKOP(type, pvop);
4873 Perl_package(pTHX_ OP *o)
4876 SV *const sv = cSVOPo->op_sv;
4881 PERL_ARGS_ASSERT_PACKAGE;
4883 SAVEGENERICSV(PL_curstash);
4884 save_item(PL_curstname);
4886 PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
4888 sv_setsv(PL_curstname, sv);
4890 PL_hints |= HINT_BLOCK_SCOPE;
4891 PL_parser->copline = NOLINE;
4892 PL_parser->expect = XSTATE;
4897 if (!PL_madskills) {
4902 pegop = newOP(OP_NULL,0);
4903 op_getmad(o,pegop,'P');
4909 Perl_package_version( pTHX_ OP *v )
4912 U32 savehints = PL_hints;
4913 PERL_ARGS_ASSERT_PACKAGE_VERSION;
4914 PL_hints &= ~HINT_STRICT_VARS;
4915 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
4916 PL_hints = savehints;
4925 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
4932 OP *pegop = PL_madskills ? newOP(OP_NULL,0) : NULL;
4934 SV *use_version = NULL;
4936 PERL_ARGS_ASSERT_UTILIZE;
4938 if (idop->op_type != OP_CONST)
4939 Perl_croak(aTHX_ "Module name must be constant");
4942 op_getmad(idop,pegop,'U');
4947 SV * const vesv = ((SVOP*)version)->op_sv;
4950 op_getmad(version,pegop,'V');
4951 if (!arg && !SvNIOKp(vesv)) {
4958 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
4959 Perl_croak(aTHX_ "Version number must be a constant number");
4961 /* Make copy of idop so we don't free it twice */
4962 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
4964 /* Fake up a method call to VERSION */
4965 meth = newSVpvs_share("VERSION");
4966 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
4967 op_append_elem(OP_LIST,
4968 op_prepend_elem(OP_LIST, pack, list(version)),
4969 newSVOP(OP_METHOD_NAMED, 0, meth)));
4973 /* Fake up an import/unimport */
4974 if (arg && arg->op_type == OP_STUB) {
4976 op_getmad(arg,pegop,'S');
4977 imop = arg; /* no import on explicit () */
4979 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
4980 imop = NULL; /* use 5.0; */
4982 use_version = ((SVOP*)idop)->op_sv;
4984 idop->op_private |= OPpCONST_NOVER;
4990 op_getmad(arg,pegop,'A');
4992 /* Make copy of idop so we don't free it twice */
4993 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
4995 /* Fake up a method call to import/unimport */
4997 ? newSVpvs_share("import") : newSVpvs_share("unimport");
4998 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
4999 op_append_elem(OP_LIST,
5000 op_prepend_elem(OP_LIST, pack, list(arg)),
5001 newSVOP(OP_METHOD_NAMED, 0, meth)));
5004 /* Fake up the BEGIN {}, which does its thing immediately. */
5006 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
5009 op_append_elem(OP_LINESEQ,
5010 op_append_elem(OP_LINESEQ,
5011 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
5012 newSTATEOP(0, NULL, veop)),
5013 newSTATEOP(0, NULL, imop) ));
5017 * feature bundle that corresponds to the required version. */
5018 use_version = sv_2mortal(new_version(use_version));
5019 S_enable_feature_bundle(aTHX_ use_version);
5021 /* If a version >= 5.11.0 is requested, strictures are on by default! */
5022 if (vcmp(use_version,
5023 sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
5024 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
5025 PL_hints |= HINT_STRICT_REFS;
5026 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
5027 PL_hints |= HINT_STRICT_SUBS;
5028 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
5029 PL_hints |= HINT_STRICT_VARS;
5031 /* otherwise they are off */
5033 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
5034 PL_hints &= ~HINT_STRICT_REFS;
5035 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
5036 PL_hints &= ~HINT_STRICT_SUBS;
5037 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
5038 PL_hints &= ~HINT_STRICT_VARS;
5042 /* The "did you use incorrect case?" warning used to be here.
5043 * The problem is that on case-insensitive filesystems one
5044 * might get false positives for "use" (and "require"):
5045 * "use Strict" or "require CARP" will work. This causes
5046 * portability problems for the script: in case-strict
5047 * filesystems the script will stop working.
5049 * The "incorrect case" warning checked whether "use Foo"
5050 * imported "Foo" to your namespace, but that is wrong, too:
5051 * there is no requirement nor promise in the language that
5052 * a Foo.pm should or would contain anything in package "Foo".
5054 * There is very little Configure-wise that can be done, either:
5055 * the case-sensitivity of the build filesystem of Perl does not
5056 * help in guessing the case-sensitivity of the runtime environment.
5059 PL_hints |= HINT_BLOCK_SCOPE;
5060 PL_parser->copline = NOLINE;
5061 PL_parser->expect = XSTATE;
5062 PL_cop_seqmax++; /* Purely for B::*'s benefit */
5063 if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
5072 =head1 Embedding Functions
5074 =for apidoc load_module
5076 Loads the module whose name is pointed to by the string part of name.
5077 Note that the actual module name, not its filename, should be given.
5078 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
5079 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
5080 (or 0 for no flags). ver, if specified and not NULL, provides version semantics
5081 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
5082 arguments can be used to specify arguments to the module's import()
5083 method, similar to C<use Foo::Bar VERSION LIST>. They must be
5084 terminated with a final NULL pointer. Note that this list can only
5085 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
5086 Otherwise at least a single NULL pointer to designate the default
5087 import list is required.
5089 The reference count for each specified C<SV*> parameter is decremented.
5094 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
5098 PERL_ARGS_ASSERT_LOAD_MODULE;
5100 va_start(args, ver);
5101 vload_module(flags, name, ver, &args);
5105 #ifdef PERL_IMPLICIT_CONTEXT
5107 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
5111 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
5112 va_start(args, ver);
5113 vload_module(flags, name, ver, &args);
5119 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
5123 OP * const modname = newSVOP(OP_CONST, 0, name);
5125 PERL_ARGS_ASSERT_VLOAD_MODULE;
5127 modname->op_private |= OPpCONST_BARE;
5129 veop = newSVOP(OP_CONST, 0, ver);
5133 if (flags & PERL_LOADMOD_NOIMPORT) {
5134 imop = sawparens(newNULLLIST());
5136 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
5137 imop = va_arg(*args, OP*);
5142 sv = va_arg(*args, SV*);
5144 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
5145 sv = va_arg(*args, SV*);
5149 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
5150 * that it has a PL_parser to play with while doing that, and also
5151 * that it doesn't mess with any existing parser, by creating a tmp
5152 * new parser with lex_start(). This won't actually be used for much,
5153 * since pp_require() will create another parser for the real work. */
5156 SAVEVPTR(PL_curcop);
5157 lex_start(NULL, NULL, LEX_START_SAME_FILTER);
5158 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
5159 veop, modname, imop);
5164 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
5170 PERL_ARGS_ASSERT_DOFILE;
5172 if (!force_builtin) {
5173 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
5174 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5175 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
5176 gv = gvp ? *gvp : NULL;
5180 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5181 doop = newUNOP(OP_ENTERSUB, OPf_STACKED,
5182 op_append_elem(OP_LIST, term,
5183 scalar(newUNOP(OP_RV2CV, 0,
5184 newGVOP(OP_GV, 0, gv)))));
5187 doop = newUNOP(OP_DOFILE, 0, scalar(term));
5193 =head1 Optree construction
5195 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
5197 Constructs, checks, and returns an C<lslice> (list slice) op. I<flags>
5198 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
5199 be set automatically, and, shifted up eight bits, the eight bits of
5200 C<op_private>, except that the bit with value 1 or 2 is automatically
5201 set as required. I<listval> and I<subscript> supply the parameters of
5202 the slice; they are consumed by this function and become part of the
5203 constructed op tree.
5209 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
5211 return newBINOP(OP_LSLICE, flags,
5212 list(force_list(subscript)),
5213 list(force_list(listval)) );
5217 S_is_list_assignment(pTHX_ register const OP *o)
5225 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
5226 o = cUNOPo->op_first;
5228 flags = o->op_flags;
5230 if (type == OP_COND_EXPR) {
5231 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
5232 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
5237 yyerror("Assignment to both a list and a scalar");
5241 if (type == OP_LIST &&
5242 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
5243 o->op_private & OPpLVAL_INTRO)
5246 if (type == OP_LIST || flags & OPf_PARENS ||
5247 type == OP_RV2AV || type == OP_RV2HV ||
5248 type == OP_ASLICE || type == OP_HSLICE)
5251 if (type == OP_PADAV || type == OP_PADHV)
5254 if (type == OP_RV2SV)
5261 Helper function for newASSIGNOP to detection commonality between the
5262 lhs and the rhs. Marks all variables with PL_generation. If it
5263 returns TRUE the assignment must be able to handle common variables.
5265 PERL_STATIC_INLINE bool
5266 S_aassign_common_vars(pTHX_ OP* o)
5269 for (curop = cUNOPo->op_first; curop; curop=curop->op_sibling) {
5270 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
5271 if (curop->op_type == OP_GV) {
5272 GV *gv = cGVOPx_gv(curop);
5274 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
5276 GvASSIGN_GENERATION_set(gv, PL_generation);
5278 else if (curop->op_type == OP_PADSV ||
5279 curop->op_type == OP_PADAV ||
5280 curop->op_type == OP_PADHV ||
5281 curop->op_type == OP_PADANY)
5283 if (PAD_COMPNAME_GEN(curop->op_targ)
5284 == (STRLEN)PL_generation)
5286 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
5289 else if (curop->op_type == OP_RV2CV)
5291 else if (curop->op_type == OP_RV2SV ||
5292 curop->op_type == OP_RV2AV ||
5293 curop->op_type == OP_RV2HV ||
5294 curop->op_type == OP_RV2GV) {
5295 if (cUNOPx(curop)->op_first->op_type != OP_GV) /* funny deref? */
5298 else if (curop->op_type == OP_PUSHRE) {
5300 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
5301 GV *const gv = MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff));
5303 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
5305 GvASSIGN_GENERATION_set(gv, PL_generation);
5309 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
5312 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
5314 GvASSIGN_GENERATION_set(gv, PL_generation);
5322 if (curop->op_flags & OPf_KIDS) {
5323 if (aassign_common_vars(curop))
5331 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
5333 Constructs, checks, and returns an assignment op. I<left> and I<right>
5334 supply the parameters of the assignment; they are consumed by this
5335 function and become part of the constructed op tree.
5337 If I<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
5338 a suitable conditional optree is constructed. If I<optype> is the opcode
5339 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
5340 performs the binary operation and assigns the result to the left argument.
5341 Either way, if I<optype> is non-zero then I<flags> has no effect.
5343 If I<optype> is zero, then a plain scalar or list assignment is
5344 constructed. Which type of assignment it is is automatically determined.
5345 I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
5346 will be set automatically, and, shifted up eight bits, the eight bits
5347 of C<op_private>, except that the bit with value 1 or 2 is automatically
5354 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
5360 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
5361 return newLOGOP(optype, 0,
5362 op_lvalue(scalar(left), optype),
5363 newUNOP(OP_SASSIGN, 0, scalar(right)));
5366 return newBINOP(optype, OPf_STACKED,
5367 op_lvalue(scalar(left), optype), scalar(right));
5371 if (is_list_assignment(left)) {
5372 static const char no_list_state[] = "Initialization of state variables"
5373 " in list context currently forbidden";
5375 bool maybe_common_vars = TRUE;
5378 left = op_lvalue(left, OP_AASSIGN);
5379 curop = list(force_list(left));
5380 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
5381 o->op_private = (U8)(0 | (flags >> 8));
5383 if ((left->op_type == OP_LIST
5384 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
5386 OP* lop = ((LISTOP*)left)->op_first;
5387 maybe_common_vars = FALSE;
5389 if (lop->op_type == OP_PADSV ||
5390 lop->op_type == OP_PADAV ||
5391 lop->op_type == OP_PADHV ||
5392 lop->op_type == OP_PADANY) {
5393 if (!(lop->op_private & OPpLVAL_INTRO))
5394 maybe_common_vars = TRUE;
5396 if (lop->op_private & OPpPAD_STATE) {
5397 if (left->op_private & OPpLVAL_INTRO) {
5398 /* Each variable in state($a, $b, $c) = ... */
5401 /* Each state variable in
5402 (state $a, my $b, our $c, $d, undef) = ... */
5404 yyerror(no_list_state);
5406 /* Each my variable in
5407 (state $a, my $b, our $c, $d, undef) = ... */
5409 } else if (lop->op_type == OP_UNDEF ||
5410 lop->op_type == OP_PUSHMARK) {
5411 /* undef may be interesting in
5412 (state $a, undef, state $c) */
5414 /* Other ops in the list. */
5415 maybe_common_vars = TRUE;
5417 lop = lop->op_sibling;
5420 else if ((left->op_private & OPpLVAL_INTRO)
5421 && ( left->op_type == OP_PADSV
5422 || left->op_type == OP_PADAV
5423 || left->op_type == OP_PADHV
5424 || left->op_type == OP_PADANY))
5426 if (left->op_type == OP_PADSV) maybe_common_vars = FALSE;
5427 if (left->op_private & OPpPAD_STATE) {
5428 /* All single variable list context state assignments, hence
5438 yyerror(no_list_state);
5442 /* PL_generation sorcery:
5443 * an assignment like ($a,$b) = ($c,$d) is easier than
5444 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
5445 * To detect whether there are common vars, the global var
5446 * PL_generation is incremented for each assign op we compile.
5447 * Then, while compiling the assign op, we run through all the
5448 * variables on both sides of the assignment, setting a spare slot
5449 * in each of them to PL_generation. If any of them already have
5450 * that value, we know we've got commonality. We could use a
5451 * single bit marker, but then we'd have to make 2 passes, first
5452 * to clear the flag, then to test and set it. To find somewhere
5453 * to store these values, evil chicanery is done with SvUVX().
5456 if (maybe_common_vars) {
5458 if (aassign_common_vars(o))
5459 o->op_private |= OPpASSIGN_COMMON;
5463 if (right && right->op_type == OP_SPLIT && !PL_madskills) {
5464 OP* tmpop = ((LISTOP*)right)->op_first;
5465 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
5466 PMOP * const pm = (PMOP*)tmpop;
5467 if (left->op_type == OP_RV2AV &&
5468 !(left->op_private & OPpLVAL_INTRO) &&
5469 !(o->op_private & OPpASSIGN_COMMON) )
5471 tmpop = ((UNOP*)left)->op_first;
5472 if (tmpop->op_type == OP_GV
5474 && !pm->op_pmreplrootu.op_pmtargetoff
5476 && !pm->op_pmreplrootu.op_pmtargetgv
5480 pm->op_pmreplrootu.op_pmtargetoff
5481 = cPADOPx(tmpop)->op_padix;
5482 cPADOPx(tmpop)->op_padix = 0; /* steal it */
5484 pm->op_pmreplrootu.op_pmtargetgv
5485 = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
5486 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
5488 pm->op_pmflags |= PMf_ONCE;
5489 tmpop = cUNOPo->op_first; /* to list (nulled) */
5490 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
5491 tmpop->op_sibling = NULL; /* don't free split */
5492 right->op_next = tmpop->op_next; /* fix starting loc */
5493 op_free(o); /* blow off assign */
5494 right->op_flags &= ~OPf_WANT;
5495 /* "I don't know and I don't care." */
5500 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
5501 ((LISTOP*)right)->op_last->op_type == OP_CONST)
5503 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
5504 if (SvIOK(sv) && SvIVX(sv) == 0)
5505 sv_setiv(sv, PL_modcount+1);
5513 right = newOP(OP_UNDEF, 0);
5514 if (right->op_type == OP_READLINE) {
5515 right->op_flags |= OPf_STACKED;
5516 return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
5520 o = newBINOP(OP_SASSIGN, flags,
5521 scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
5527 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
5529 Constructs a state op (COP). The state op is normally a C<nextstate> op,
5530 but will be a C<dbstate> op if debugging is enabled for currently-compiled
5531 code. The state op is populated from L</PL_curcop> (or L</PL_compiling>).
5532 If I<label> is non-null, it supplies the name of a label to attach to
5533 the state op; this function takes ownership of the memory pointed at by
5534 I<label>, and will free it. I<flags> gives the eight bits of C<op_flags>
5537 If I<o> is null, the state op is returned. Otherwise the state op is
5538 combined with I<o> into a C<lineseq> list op, which is returned. I<o>
5539 is consumed by this function and becomes part of the returned op tree.
5545 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
5548 const U32 seq = intro_my();
5549 const U32 utf8 = flags & SVf_UTF8;
5554 NewOp(1101, cop, 1, COP);
5555 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
5556 cop->op_type = OP_DBSTATE;
5557 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
5560 cop->op_type = OP_NEXTSTATE;
5561 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
5563 cop->op_flags = (U8)flags;
5564 CopHINTS_set(cop, PL_hints);
5566 cop->op_private |= NATIVE_HINTS;
5568 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
5569 cop->op_next = (OP*)cop;
5572 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
5573 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
5575 Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
5577 PL_hints |= HINT_BLOCK_SCOPE;
5578 /* It seems that we need to defer freeing this pointer, as other parts
5579 of the grammar end up wanting to copy it after this op has been
5584 if (PL_parser && PL_parser->copline == NOLINE)
5585 CopLINE_set(cop, CopLINE(PL_curcop));
5587 CopLINE_set(cop, PL_parser->copline);
5589 PL_parser->copline = NOLINE;
5592 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
5594 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
5596 CopSTASH_set(cop, PL_curstash);
5598 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) {
5599 /* this line can have a breakpoint - store the cop in IV */
5600 AV *av = CopFILEAVx(PL_curcop);
5602 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
5603 if (svp && *svp != &PL_sv_undef ) {
5604 (void)SvIOK_on(*svp);
5605 SvIV_set(*svp, PTR2IV(cop));
5610 if (flags & OPf_SPECIAL)
5612 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
5616 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
5618 Constructs, checks, and returns a logical (flow control) op. I<type>
5619 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
5620 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
5621 the eight bits of C<op_private>, except that the bit with value 1 is
5622 automatically set. I<first> supplies the expression controlling the
5623 flow, and I<other> supplies the side (alternate) chain of ops; they are
5624 consumed by this function and become part of the constructed op tree.
5630 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
5634 PERL_ARGS_ASSERT_NEWLOGOP;
5636 return new_logop(type, flags, &first, &other);
5640 S_search_const(pTHX_ OP *o)
5642 PERL_ARGS_ASSERT_SEARCH_CONST;
5644 switch (o->op_type) {
5648 if (o->op_flags & OPf_KIDS)
5649 return search_const(cUNOPo->op_first);
5656 if (!(o->op_flags & OPf_KIDS))
5658 kid = cLISTOPo->op_first;
5660 switch (kid->op_type) {
5664 kid = kid->op_sibling;
5667 if (kid != cLISTOPo->op_last)
5673 kid = cLISTOPo->op_last;
5675 return search_const(kid);
5683 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
5691 int prepend_not = 0;
5693 PERL_ARGS_ASSERT_NEW_LOGOP;
5698 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
5699 return newBINOP(type, flags, scalar(first), scalar(other));
5701 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP);
5703 scalarboolean(first);
5704 /* optimize AND and OR ops that have NOTs as children */
5705 if (first->op_type == OP_NOT
5706 && (first->op_flags & OPf_KIDS)
5707 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
5708 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
5710 if (type == OP_AND || type == OP_OR) {
5716 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
5718 prepend_not = 1; /* prepend a NOT op later */
5722 /* search for a constant op that could let us fold the test */
5723 if ((cstop = search_const(first))) {
5724 if (cstop->op_private & OPpCONST_STRICT)
5725 no_bareword_allowed(cstop);
5726 else if ((cstop->op_private & OPpCONST_BARE))
5727 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
5728 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
5729 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
5730 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
5732 if (other->op_type == OP_CONST)
5733 other->op_private |= OPpCONST_SHORTCIRCUIT;
5735 OP *newop = newUNOP(OP_NULL, 0, other);
5736 op_getmad(first, newop, '1');
5737 newop->op_targ = type; /* set "was" field */
5741 if (other->op_type == OP_LEAVE)
5742 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
5743 else if (other->op_type == OP_MATCH
5744 || other->op_type == OP_SUBST
5745 || other->op_type == OP_TRANSR
5746 || other->op_type == OP_TRANS)
5747 /* Mark the op as being unbindable with =~ */
5748 other->op_flags |= OPf_SPECIAL;
5749 else if (other->op_type == OP_CONST)
5750 other->op_private |= OPpCONST_FOLDED;
5754 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
5755 const OP *o2 = other;
5756 if ( ! (o2->op_type == OP_LIST
5757 && (( o2 = cUNOPx(o2)->op_first))
5758 && o2->op_type == OP_PUSHMARK
5759 && (( o2 = o2->op_sibling)) )
5762 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
5763 || o2->op_type == OP_PADHV)
5764 && o2->op_private & OPpLVAL_INTRO
5765 && !(o2->op_private & OPpPAD_STATE))
5767 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
5768 "Deprecated use of my() in false conditional");
5772 if (first->op_type == OP_CONST)
5773 first->op_private |= OPpCONST_SHORTCIRCUIT;
5775 first = newUNOP(OP_NULL, 0, first);
5776 op_getmad(other, first, '2');
5777 first->op_targ = type; /* set "was" field */
5784 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
5785 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
5787 const OP * const k1 = ((UNOP*)first)->op_first;
5788 const OP * const k2 = k1->op_sibling;
5790 switch (first->op_type)
5793 if (k2 && k2->op_type == OP_READLINE
5794 && (k2->op_flags & OPf_STACKED)
5795 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5797 warnop = k2->op_type;
5802 if (k1->op_type == OP_READDIR
5803 || k1->op_type == OP_GLOB
5804 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5805 || k1->op_type == OP_EACH
5806 || k1->op_type == OP_AEACH)
5808 warnop = ((k1->op_type == OP_NULL)
5809 ? (OPCODE)k1->op_targ : k1->op_type);
5814 const line_t oldline = CopLINE(PL_curcop);
5815 CopLINE_set(PL_curcop, PL_parser->copline);
5816 Perl_warner(aTHX_ packWARN(WARN_MISC),
5817 "Value of %s%s can be \"0\"; test with defined()",
5819 ((warnop == OP_READLINE || warnop == OP_GLOB)
5820 ? " construct" : "() operator"));
5821 CopLINE_set(PL_curcop, oldline);
5828 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
5829 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
5831 NewOp(1101, logop, 1, LOGOP);
5833 logop->op_type = (OPCODE)type;
5834 logop->op_ppaddr = PL_ppaddr[type];
5835 logop->op_first = first;
5836 logop->op_flags = (U8)(flags | OPf_KIDS);
5837 logop->op_other = LINKLIST(other);
5838 logop->op_private = (U8)(1 | (flags >> 8));
5840 /* establish postfix order */
5841 logop->op_next = LINKLIST(first);
5842 first->op_next = (OP*)logop;
5843 first->op_sibling = other;
5845 CHECKOP(type,logop);
5847 o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
5854 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
5856 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
5857 op. I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
5858 will be set automatically, and, shifted up eight bits, the eight bits of
5859 C<op_private>, except that the bit with value 1 is automatically set.
5860 I<first> supplies the expression selecting between the two branches,
5861 and I<trueop> and I<falseop> supply the branches; they are consumed by
5862 this function and become part of the constructed op tree.
5868 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
5876 PERL_ARGS_ASSERT_NEWCONDOP;
5879 return newLOGOP(OP_AND, 0, first, trueop);
5881 return newLOGOP(OP_OR, 0, first, falseop);
5883 scalarboolean(first);
5884 if ((cstop = search_const(first))) {
5885 /* Left or right arm of the conditional? */
5886 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
5887 OP *live = left ? trueop : falseop;
5888 OP *const dead = left ? falseop : trueop;
5889 if (cstop->op_private & OPpCONST_BARE &&
5890 cstop->op_private & OPpCONST_STRICT) {
5891 no_bareword_allowed(cstop);
5894 /* This is all dead code when PERL_MAD is not defined. */
5895 live = newUNOP(OP_NULL, 0, live);
5896 op_getmad(first, live, 'C');
5897 op_getmad(dead, live, left ? 'e' : 't');
5902 if (live->op_type == OP_LEAVE)
5903 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
5904 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
5905 || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
5906 /* Mark the op as being unbindable with =~ */
5907 live->op_flags |= OPf_SPECIAL;
5908 else if (live->op_type == OP_CONST)
5909 live->op_private |= OPpCONST_FOLDED;
5912 NewOp(1101, logop, 1, LOGOP);
5913 logop->op_type = OP_COND_EXPR;
5914 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
5915 logop->op_first = first;
5916 logop->op_flags = (U8)(flags | OPf_KIDS);
5917 logop->op_private = (U8)(1 | (flags >> 8));
5918 logop->op_other = LINKLIST(trueop);
5919 logop->op_next = LINKLIST(falseop);
5921 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
5924 /* establish postfix order */
5925 start = LINKLIST(first);
5926 first->op_next = (OP*)logop;
5928 first->op_sibling = trueop;
5929 trueop->op_sibling = falseop;
5930 o = newUNOP(OP_NULL, 0, (OP*)logop);
5932 trueop->op_next = falseop->op_next = o;
5939 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
5941 Constructs and returns a C<range> op, with subordinate C<flip> and
5942 C<flop> ops. I<flags> gives the eight bits of C<op_flags> for the
5943 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
5944 for both the C<flip> and C<range> ops, except that the bit with value
5945 1 is automatically set. I<left> and I<right> supply the expressions
5946 controlling the endpoints of the range; they are consumed by this function
5947 and become part of the constructed op tree.
5953 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
5962 PERL_ARGS_ASSERT_NEWRANGE;
5964 NewOp(1101, range, 1, LOGOP);
5966 range->op_type = OP_RANGE;
5967 range->op_ppaddr = PL_ppaddr[OP_RANGE];
5968 range->op_first = left;
5969 range->op_flags = OPf_KIDS;
5970 leftstart = LINKLIST(left);
5971 range->op_other = LINKLIST(right);
5972 range->op_private = (U8)(1 | (flags >> 8));
5974 left->op_sibling = right;
5976 range->op_next = (OP*)range;
5977 flip = newUNOP(OP_FLIP, flags, (OP*)range);
5978 flop = newUNOP(OP_FLOP, 0, flip);
5979 o = newUNOP(OP_NULL, 0, flop);
5981 range->op_next = leftstart;
5983 left->op_next = flip;
5984 right->op_next = flop;
5986 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
5987 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
5988 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
5989 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
5991 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
5992 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
5994 /* check barewords before they might be optimized aways */
5995 if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
5996 no_bareword_allowed(left);
5997 if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
5998 no_bareword_allowed(right);
6001 if (!flip->op_private || !flop->op_private)
6002 LINKLIST(o); /* blow off optimizer unless constant */
6008 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
6010 Constructs, checks, and returns an op tree expressing a loop. This is
6011 only a loop in the control flow through the op tree; it does not have
6012 the heavyweight loop structure that allows exiting the loop by C<last>
6013 and suchlike. I<flags> gives the eight bits of C<op_flags> for the
6014 top-level op, except that some bits will be set automatically as required.
6015 I<expr> supplies the expression controlling loop iteration, and I<block>
6016 supplies the body of the loop; they are consumed by this function and
6017 become part of the constructed op tree. I<debuggable> is currently
6018 unused and should always be 1.
6024 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
6029 const bool once = block && block->op_flags & OPf_SPECIAL &&
6030 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
6032 PERL_UNUSED_ARG(debuggable);
6035 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
6036 return block; /* do {} while 0 does once */
6037 if (expr->op_type == OP_READLINE
6038 || expr->op_type == OP_READDIR
6039 || expr->op_type == OP_GLOB
6040 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
6041 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
6042 expr = newUNOP(OP_DEFINED, 0,
6043 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
6044 } else if (expr->op_flags & OPf_KIDS) {
6045 const OP * const k1 = ((UNOP*)expr)->op_first;
6046 const OP * const k2 = k1 ? k1->op_sibling : NULL;
6047 switch (expr->op_type) {
6049 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
6050 && (k2->op_flags & OPf_STACKED)
6051 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
6052 expr = newUNOP(OP_DEFINED, 0, expr);
6056 if (k1 && (k1->op_type == OP_READDIR
6057 || k1->op_type == OP_GLOB
6058 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
6059 || k1->op_type == OP_EACH
6060 || k1->op_type == OP_AEACH))
6061 expr = newUNOP(OP_DEFINED, 0, expr);
6067 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
6068 * op, in listop. This is wrong. [perl #27024] */
6070 block = newOP(OP_NULL, 0);
6071 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
6072 o = new_logop(OP_AND, 0, &expr, &listop);
6075 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
6077 if (once && o != listop)
6078 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
6081 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
6083 o->op_flags |= flags;
6085 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
6090 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
6092 Constructs, checks, and returns an op tree expressing a C<while> loop.
6093 This is a heavyweight loop, with structure that allows exiting the loop
6094 by C<last> and suchlike.
6096 I<loop> is an optional preconstructed C<enterloop> op to use in the
6097 loop; if it is null then a suitable op will be constructed automatically.
6098 I<expr> supplies the loop's controlling expression. I<block> supplies the
6099 main body of the loop, and I<cont> optionally supplies a C<continue> block
6100 that operates as a second half of the body. All of these optree inputs
6101 are consumed by this function and become part of the constructed op tree.
6103 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
6104 op and, shifted up eight bits, the eight bits of C<op_private> for
6105 the C<leaveloop> op, except that (in both cases) some bits will be set
6106 automatically. I<debuggable> is currently unused and should always be 1.
6107 I<has_my> can be supplied as true to force the
6108 loop body to be enclosed in its own scope.
6114 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
6115 OP *expr, OP *block, OP *cont, I32 has_my)
6124 PERL_UNUSED_ARG(debuggable);
6127 if (expr->op_type == OP_READLINE
6128 || expr->op_type == OP_READDIR
6129 || expr->op_type == OP_GLOB
6130 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
6131 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
6132 expr = newUNOP(OP_DEFINED, 0,
6133 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
6134 } else if (expr->op_flags & OPf_KIDS) {
6135 const OP * const k1 = ((UNOP*)expr)->op_first;
6136 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
6137 switch (expr->op_type) {
6139 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
6140 && (k2->op_flags & OPf_STACKED)
6141 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
6142 expr = newUNOP(OP_DEFINED, 0, expr);
6146 if (k1 && (k1->op_type == OP_READDIR
6147 || k1->op_type == OP_GLOB
6148 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
6149 || k1->op_type == OP_EACH
6150 || k1->op_type == OP_AEACH))
6151 expr = newUNOP(OP_DEFINED, 0, expr);
6158 block = newOP(OP_NULL, 0);
6159 else if (cont || has_my) {
6160 block = op_scope(block);
6164 next = LINKLIST(cont);
6167 OP * const unstack = newOP(OP_UNSTACK, 0);
6170 cont = op_append_elem(OP_LINESEQ, cont, unstack);
6174 listop = op_append_list(OP_LINESEQ, block, cont);
6176 redo = LINKLIST(listop);
6180 o = new_logop(OP_AND, 0, &expr, &listop);
6181 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
6183 return expr; /* listop already freed by new_logop */
6186 ((LISTOP*)listop)->op_last->op_next =
6187 (o == listop ? redo : LINKLIST(o));
6193 NewOp(1101,loop,1,LOOP);
6194 loop->op_type = OP_ENTERLOOP;
6195 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
6196 loop->op_private = 0;
6197 loop->op_next = (OP*)loop;
6200 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
6202 loop->op_redoop = redo;
6203 loop->op_lastop = o;
6204 o->op_private |= loopflags;
6207 loop->op_nextop = next;
6209 loop->op_nextop = o;
6211 o->op_flags |= flags;
6212 o->op_private |= (flags >> 8);
6217 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
6219 Constructs, checks, and returns an op tree expressing a C<foreach>
6220 loop (iteration through a list of values). This is a heavyweight loop,
6221 with structure that allows exiting the loop by C<last> and suchlike.
6223 I<sv> optionally supplies the variable that will be aliased to each
6224 item in turn; if null, it defaults to C<$_> (either lexical or global).
6225 I<expr> supplies the list of values to iterate over. I<block> supplies
6226 the main body of the loop, and I<cont> optionally supplies a C<continue>
6227 block that operates as a second half of the body. All of these optree
6228 inputs are consumed by this function and become part of the constructed
6231 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
6232 op and, shifted up eight bits, the eight bits of C<op_private> for
6233 the C<leaveloop> op, except that (in both cases) some bits will be set
6240 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
6245 PADOFFSET padoff = 0;
6250 PERL_ARGS_ASSERT_NEWFOROP;
6253 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
6254 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
6255 sv->op_type = OP_RV2GV;
6256 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
6258 /* The op_type check is needed to prevent a possible segfault
6259 * if the loop variable is undeclared and 'strict vars' is in
6260 * effect. This is illegal but is nonetheless parsed, so we
6261 * may reach this point with an OP_CONST where we're expecting
6264 if (cUNOPx(sv)->op_first->op_type == OP_GV
6265 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
6266 iterpflags |= OPpITER_DEF;
6268 else if (sv->op_type == OP_PADSV) { /* private variable */
6269 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
6270 padoff = sv->op_targ;
6280 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
6282 SV *const namesv = PAD_COMPNAME_SV(padoff);
6284 const char *const name = SvPV_const(namesv, len);
6286 if (len == 2 && name[0] == '$' && name[1] == '_')
6287 iterpflags |= OPpITER_DEF;
6291 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
6292 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
6293 sv = newGVOP(OP_GV, 0, PL_defgv);
6298 iterpflags |= OPpITER_DEF;
6300 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
6301 expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
6302 iterflags |= OPf_STACKED;
6304 else if (expr->op_type == OP_NULL &&
6305 (expr->op_flags & OPf_KIDS) &&
6306 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
6308 /* Basically turn for($x..$y) into the same as for($x,$y), but we
6309 * set the STACKED flag to indicate that these values are to be
6310 * treated as min/max values by 'pp_iterinit'.
6312 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
6313 LOGOP* const range = (LOGOP*) flip->op_first;
6314 OP* const left = range->op_first;
6315 OP* const right = left->op_sibling;
6318 range->op_flags &= ~OPf_KIDS;
6319 range->op_first = NULL;
6321 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
6322 listop->op_first->op_next = range->op_next;
6323 left->op_next = range->op_other;
6324 right->op_next = (OP*)listop;
6325 listop->op_next = listop->op_first;
6328 op_getmad(expr,(OP*)listop,'O');
6332 expr = (OP*)(listop);
6334 iterflags |= OPf_STACKED;
6337 expr = op_lvalue(force_list(expr), OP_GREPSTART);
6340 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
6341 op_append_elem(OP_LIST, expr, scalar(sv))));
6342 assert(!loop->op_next);
6343 /* for my $x () sets OPpLVAL_INTRO;
6344 * for our $x () sets OPpOUR_INTRO */
6345 loop->op_private = (U8)iterpflags;
6346 if (loop->op_slabbed
6347 && DIFF(loop, OpSLOT(loop)->opslot_next)
6348 < SIZE_TO_PSIZE(sizeof(LOOP)))
6351 NewOp(1234,tmp,1,LOOP);
6352 Copy(loop,tmp,1,LISTOP);
6353 S_op_destroy(aTHX_ (OP*)loop);
6356 else if (!loop->op_slabbed)
6357 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
6358 loop->op_targ = padoff;
6359 wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
6361 op_getmad(madsv, (OP*)loop, 'v');
6366 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
6368 Constructs, checks, and returns a loop-exiting op (such as C<goto>
6369 or C<last>). I<type> is the opcode. I<label> supplies the parameter
6370 determining the target of the op; it is consumed by this function and
6371 becomes part of the constructed op tree.
6377 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
6382 PERL_ARGS_ASSERT_NEWLOOPEX;
6384 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
6386 if (type != OP_GOTO) {
6387 /* "last()" means "last" */
6388 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
6389 o = newOP(type, OPf_SPECIAL);
6394 /* Check whether it's going to be a goto &function */
6395 if (label->op_type == OP_ENTERSUB
6396 && !(label->op_flags & OPf_STACKED))
6397 label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
6400 /* Check for a constant argument */
6401 if (label->op_type == OP_CONST) {
6402 SV * const sv = ((SVOP *)label)->op_sv;
6404 const char *s = SvPV_const(sv,l);
6405 if (l == strlen(s)) {
6407 SvUTF8(((SVOP*)label)->op_sv),
6409 SvPV_nolen_const(((SVOP*)label)->op_sv)));
6412 op_getmad(label,o,'L');
6420 /* If we still have a label op, we need to create a stacked unop. */
6421 if (label) o = newUNOP(type, OPf_STACKED, label);
6423 PL_hints |= HINT_BLOCK_SCOPE;
6427 /* if the condition is a literal array or hash
6428 (or @{ ... } etc), make a reference to it.
6431 S_ref_array_or_hash(pTHX_ OP *cond)
6434 && (cond->op_type == OP_RV2AV
6435 || cond->op_type == OP_PADAV
6436 || cond->op_type == OP_RV2HV
6437 || cond->op_type == OP_PADHV))
6439 return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
6442 && (cond->op_type == OP_ASLICE
6443 || cond->op_type == OP_HSLICE)) {
6445 /* anonlist now needs a list from this op, was previously used in
6447 cond->op_flags |= ~(OPf_WANT_SCALAR | OPf_REF);
6448 cond->op_flags |= OPf_WANT_LIST;
6450 return newANONLIST(op_lvalue(cond, OP_ANONLIST));
6457 /* These construct the optree fragments representing given()
6460 entergiven and enterwhen are LOGOPs; the op_other pointer
6461 points up to the associated leave op. We need this so we
6462 can put it in the context and make break/continue work.
6463 (Also, of course, pp_enterwhen will jump straight to
6464 op_other if the match fails.)
6468 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
6469 I32 enter_opcode, I32 leave_opcode,
6470 PADOFFSET entertarg)
6476 PERL_ARGS_ASSERT_NEWGIVWHENOP;
6478 NewOp(1101, enterop, 1, LOGOP);
6479 enterop->op_type = (Optype)enter_opcode;
6480 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
6481 enterop->op_flags = (U8) OPf_KIDS;
6482 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
6483 enterop->op_private = 0;
6485 o = newUNOP(leave_opcode, 0, (OP *) enterop);
6488 enterop->op_first = scalar(cond);
6489 cond->op_sibling = block;
6491 o->op_next = LINKLIST(cond);
6492 cond->op_next = (OP *) enterop;
6495 /* This is a default {} block */
6496 enterop->op_first = block;
6497 enterop->op_flags |= OPf_SPECIAL;
6498 o ->op_flags |= OPf_SPECIAL;
6500 o->op_next = (OP *) enterop;
6503 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
6504 entergiven and enterwhen both
6507 enterop->op_next = LINKLIST(block);
6508 block->op_next = enterop->op_other = o;
6513 /* Does this look like a boolean operation? For these purposes
6514 a boolean operation is:
6515 - a subroutine call [*]
6516 - a logical connective
6517 - a comparison operator
6518 - a filetest operator, with the exception of -s -M -A -C
6519 - defined(), exists() or eof()
6520 - /$re/ or $foo =~ /$re/
6522 [*] possibly surprising
6525 S_looks_like_bool(pTHX_ const OP *o)
6529 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
6531 switch(o->op_type) {
6534 return looks_like_bool(cLOGOPo->op_first);
6538 looks_like_bool(cLOGOPo->op_first)
6539 && looks_like_bool(cLOGOPo->op_first->op_sibling));
6544 o->op_flags & OPf_KIDS
6545 && looks_like_bool(cUNOPo->op_first));
6549 case OP_NOT: case OP_XOR:
6551 case OP_EQ: case OP_NE: case OP_LT:
6552 case OP_GT: case OP_LE: case OP_GE:
6554 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
6555 case OP_I_GT: case OP_I_LE: case OP_I_GE:
6557 case OP_SEQ: case OP_SNE: case OP_SLT:
6558 case OP_SGT: case OP_SLE: case OP_SGE:
6562 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
6563 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
6564 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
6565 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
6566 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
6567 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
6568 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
6569 case OP_FTTEXT: case OP_FTBINARY:
6571 case OP_DEFINED: case OP_EXISTS:
6572 case OP_MATCH: case OP_EOF:
6579 /* Detect comparisons that have been optimized away */
6580 if (cSVOPo->op_sv == &PL_sv_yes
6581 || cSVOPo->op_sv == &PL_sv_no)
6594 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
6596 Constructs, checks, and returns an op tree expressing a C<given> block.
6597 I<cond> supplies the expression that will be locally assigned to a lexical
6598 variable, and I<block> supplies the body of the C<given> construct; they
6599 are consumed by this function and become part of the constructed op tree.
6600 I<defsv_off> is the pad offset of the scalar lexical variable that will
6607 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
6610 PERL_ARGS_ASSERT_NEWGIVENOP;
6611 return newGIVWHENOP(
6612 ref_array_or_hash(cond),
6614 OP_ENTERGIVEN, OP_LEAVEGIVEN,
6619 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
6621 Constructs, checks, and returns an op tree expressing a C<when> block.
6622 I<cond> supplies the test expression, and I<block> supplies the block
6623 that will be executed if the test evaluates to true; they are consumed
6624 by this function and become part of the constructed op tree. I<cond>
6625 will be interpreted DWIMically, often as a comparison against C<$_>,
6626 and may be null to generate a C<default> block.
6632 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
6634 const bool cond_llb = (!cond || looks_like_bool(cond));
6637 PERL_ARGS_ASSERT_NEWWHENOP;
6642 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
6644 scalar(ref_array_or_hash(cond)));
6647 return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
6651 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
6652 const STRLEN len, const U32 flags)
6654 const char * const cvp = CvPROTO(cv);
6655 const STRLEN clen = CvPROTOLEN(cv);
6657 PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
6659 if (((!p != !cvp) /* One has prototype, one has not. */
6661 (flags & SVf_UTF8) == SvUTF8(cv)
6662 ? len != clen || memNE(cvp, p, len)
6664 ? bytes_cmp_utf8((const U8 *)cvp, clen,
6666 : bytes_cmp_utf8((const U8 *)p, len,
6667 (const U8 *)cvp, clen)
6671 && ckWARN_d(WARN_PROTOTYPE)) {
6672 SV* const msg = sv_newmortal();
6676 gv_efullname3(name = sv_newmortal(), gv, NULL);
6677 sv_setpvs(msg, "Prototype mismatch:");
6679 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
6681 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")",
6682 SVfARG(newSVpvn_flags(cvp,clen, SvUTF8(cv)|SVs_TEMP))
6685 sv_catpvs(msg, ": none");
6686 sv_catpvs(msg, " vs ");
6688 Perl_sv_catpvf(aTHX_ msg, "(%"SVf")", SVfARG(newSVpvn_flags(p, len, flags | SVs_TEMP)));
6690 sv_catpvs(msg, "none");
6691 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
6695 static void const_sv_xsub(pTHX_ CV* cv);
6699 =head1 Optree Manipulation Functions
6701 =for apidoc cv_const_sv
6703 If C<cv> is a constant sub eligible for inlining. returns the constant
6704 value returned by the sub. Otherwise, returns NULL.
6706 Constant subs can be created with C<newCONSTSUB> or as described in
6707 L<perlsub/"Constant Functions">.
6712 Perl_cv_const_sv(pTHX_ const CV *const cv)
6714 PERL_UNUSED_CONTEXT;
6717 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
6719 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
6722 /* op_const_sv: examine an optree to determine whether it's in-lineable.
6723 * Can be called in 3 ways:
6726 * look for a single OP_CONST with attached value: return the value
6728 * cv && CvCLONE(cv) && !CvCONST(cv)
6730 * examine the clone prototype, and if contains only a single
6731 * OP_CONST referencing a pad const, or a single PADSV referencing
6732 * an outer lexical, return a non-zero value to indicate the CV is
6733 * a candidate for "constizing" at clone time
6737 * We have just cloned an anon prototype that was marked as a const
6738 * candidate. Try to grab the current value, and in the case of
6739 * PADSV, ignore it if it has multiple references. Return the value.
6743 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
6754 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
6755 o = cLISTOPo->op_first->op_sibling;
6757 for (; o; o = o->op_next) {
6758 const OPCODE type = o->op_type;
6760 if (sv && o->op_next == o)
6762 if (o->op_next != o) {
6763 if (type == OP_NEXTSTATE
6764 || (type == OP_NULL && !(o->op_flags & OPf_KIDS))
6765 || type == OP_PUSHMARK)
6767 if (type == OP_DBSTATE)
6770 if (type == OP_LEAVESUB || type == OP_RETURN)
6774 if (type == OP_CONST && cSVOPo->op_sv)
6776 else if (cv && type == OP_CONST) {
6777 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
6781 else if (cv && type == OP_PADSV) {
6782 if (CvCONST(cv)) { /* newly cloned anon */
6783 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
6784 /* the candidate should have 1 ref from this pad and 1 ref
6785 * from the parent */
6786 if (!sv || SvREFCNT(sv) != 2)
6793 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
6794 sv = &PL_sv_undef; /* an arbitrary non-null value */
6809 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
6812 /* This would be the return value, but the return cannot be reached. */
6813 OP* pegop = newOP(OP_NULL, 0);
6816 PERL_UNUSED_ARG(floor);
6826 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
6828 NORETURN_FUNCTION_END;
6833 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
6835 return newATTRSUB_flags(floor, o, proto, attrs, block, 0);
6839 Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
6840 OP *block, U32 flags)
6845 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
6847 register CV *cv = NULL;
6849 const bool ec = PL_parser && PL_parser->error_count;
6850 /* If the subroutine has no body, no attributes, and no builtin attributes
6851 then it's just a sub declaration, and we may be able to get away with
6852 storing with a placeholder scalar in the symbol table, rather than a
6853 full GV and CV. If anything is present then it will take a full CV to
6855 const I32 gv_fetch_flags
6856 = ec ? GV_NOADD_NOINIT :
6857 (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
6859 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
6861 const bool o_is_gv = flags & 1;
6862 const char * const name =
6863 o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
6865 bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
6866 #ifdef PERL_DEBUG_READONLY_OPS
6867 OPSLAB *slab = NULL;
6871 assert(proto->op_type == OP_CONST);
6872 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
6873 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
6883 gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
6885 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
6886 SV * const sv = sv_newmortal();
6887 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
6888 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
6889 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
6890 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
6892 } else if (PL_curstash) {
6893 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
6896 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
6900 if (!PL_madskills) {
6911 if (name && block) {
6912 const char *s = strrchr(name, ':');
6914 if (strEQ(s, "BEGIN")) {
6915 const char not_safe[] =
6916 "BEGIN not safe after errors--compilation aborted";
6917 if (PL_in_eval & EVAL_KEEPERR)
6918 Perl_croak(aTHX_ not_safe);
6920 /* force display of errors found but not reported */
6921 sv_catpv(ERRSV, not_safe);
6922 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
6930 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
6931 maximum a prototype before. */
6932 if (SvTYPE(gv) > SVt_NULL) {
6933 cv_ckproto_len_flags((const CV *)gv, NULL, ps, ps_len, ps_utf8);
6936 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
6937 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(gv));
6940 sv_setiv(MUTABLE_SV(gv), -1);
6942 SvREFCNT_dec(PL_compcv);
6943 cv = PL_compcv = NULL;
6947 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
6949 if (!block || !ps || *ps || attrs
6950 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
6952 || block->op_type == OP_NULL
6957 const_sv = op_const_sv(block, NULL);
6960 const bool exists = CvROOT(cv) || CvXSUB(cv);
6962 /* if the subroutine doesn't exist and wasn't pre-declared
6963 * with a prototype, assume it will be AUTOLOADed,
6964 * skipping the prototype check
6966 if (exists || SvPOK(cv))
6967 cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
6968 /* already defined (or promised)? */
6969 if (exists || GvASSUMECV(gv)) {
6972 || block->op_type == OP_NULL
6975 if (CvFLAGS(PL_compcv)) {
6976 /* might have had built-in attrs applied */
6977 const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
6978 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
6979 && ckWARN(WARN_MISC))
6980 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
6982 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
6983 & ~(CVf_LVALUE * pureperl));
6985 if (attrs) goto attrs;
6986 /* just a "sub foo;" when &foo is already defined */
6987 SAVEFREESV(PL_compcv);
6992 && block->op_type != OP_NULL
6995 const line_t oldline = CopLINE(PL_curcop);
6996 if (PL_parser && PL_parser->copline != NOLINE)
6997 CopLINE_set(PL_curcop, PL_parser->copline);
6998 report_redefined_cv(cSVOPo->op_sv, cv, &const_sv);
6999 CopLINE_set(PL_curcop, oldline);
7001 if (!PL_minus_c) /* keep old one around for madskills */
7004 /* (PL_madskills unset in used file.) */
7012 SvREFCNT_inc_simple_void_NN(const_sv);
7014 assert(!CvROOT(cv) && !CvCONST(cv));
7016 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
7017 CvXSUBANY(cv).any_ptr = const_sv;
7018 CvXSUB(cv) = const_sv_xsub;
7024 cv = newCONSTSUB_flags(
7025 NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
7032 SvREFCNT_dec(PL_compcv);
7036 if (cv) { /* must reuse cv if autoloaded */
7037 /* transfer PL_compcv to cv */
7040 && block->op_type != OP_NULL
7043 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
7044 AV *const temp_av = CvPADLIST(cv);
7045 CV *const temp_cv = CvOUTSIDE(cv);
7046 const cv_flags_t other_flags =
7047 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
7048 OP * const cvstart = CvSTART(cv);
7051 assert(!CvCVGV_RC(cv));
7052 assert(CvGV(cv) == gv);
7055 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs;
7056 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
7057 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
7058 CvPADLIST(cv) = CvPADLIST(PL_compcv);
7059 CvOUTSIDE(PL_compcv) = temp_cv;
7060 CvPADLIST(PL_compcv) = temp_av;
7061 CvSTART(cv) = CvSTART(PL_compcv);
7062 CvSTART(PL_compcv) = cvstart;
7063 CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
7064 CvFLAGS(PL_compcv) |= other_flags;
7066 if (CvFILE(cv) && CvDYNFILE(cv)) {
7067 Safefree(CvFILE(cv));
7069 CvFILE_set_from_cop(cv, PL_curcop);
7070 CvSTASH_set(cv, PL_curstash);
7072 /* inner references to PL_compcv must be fixed up ... */
7073 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
7074 if (PERLDB_INTER)/* Advice debugger on the new sub. */
7075 ++PL_sub_generation;
7078 /* Might have had built-in attributes applied -- propagate them. */
7079 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
7081 /* ... before we throw it away */
7082 SvREFCNT_dec(PL_compcv);
7090 if (strEQ(name, "import")) {
7091 PL_formfeed = MUTABLE_SV(cv);
7092 /* diag_listed_as: SKIPME */
7093 Perl_warner(aTHX_ packWARN(WARN_VOID), "0x%"UVxf"\n", PTR2UV(cv));
7097 if (HvENAME_HEK(GvSTASH(gv)))
7098 /* sub Foo::bar { (shift)+1 } */
7099 mro_method_changed_in(GvSTASH(gv));
7104 CvFILE_set_from_cop(cv, PL_curcop);
7105 CvSTASH_set(cv, PL_curstash);
7109 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
7110 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
7117 /* If we assign an optree to a PVCV, then we've defined a subroutine that
7118 the debugger could be able to set a breakpoint in, so signal to
7119 pp_entereval that it should not throw away any saved lines at scope
7122 PL_breakable_sub_gen++;
7123 /* This makes sub {}; work as expected. */
7124 if (block->op_type == OP_STUB) {
7125 OP* const newblock = newSTATEOP(0, NULL, 0);
7127 op_getmad(block,newblock,'B');
7133 CvROOT(cv) = CvLVALUE(cv)
7134 ? newUNOP(OP_LEAVESUBLV, 0,
7135 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
7136 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
7137 CvROOT(cv)->op_private |= OPpREFCOUNTED;
7138 OpREFCNT_set(CvROOT(cv), 1);
7139 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
7140 itself has a refcount. */
7142 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
7143 #ifdef PERL_DEBUG_READONLY_OPS
7144 slab = (OPSLAB *)CvSTART(cv);
7146 CvSTART(cv) = LINKLIST(CvROOT(cv));
7147 CvROOT(cv)->op_next = 0;
7148 CALL_PEEP(CvSTART(cv));
7149 finalize_optree(CvROOT(cv));
7151 /* now that optimizer has done its work, adjust pad values */
7153 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
7156 assert(!CvCONST(cv));
7157 if (ps && !*ps && op_const_sv(block, cv))
7163 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
7164 HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
7165 apply_attrs(stash, MUTABLE_SV(cv), attrs, FALSE);
7168 if (block && has_name) {
7169 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
7170 SV * const tmpstr = sv_newmortal();
7171 GV * const db_postponed = gv_fetchpvs("DB::postponed",
7172 GV_ADDMULTI, SVt_PVHV);
7174 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
7177 (long)CopLINE(PL_curcop));
7178 gv_efullname3(tmpstr, gv, NULL);
7179 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
7180 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
7181 hv = GvHVn(db_postponed);
7182 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
7183 CV * const pcv = GvCV(db_postponed);
7189 call_sv(MUTABLE_SV(pcv), G_DISCARD);
7194 if (name && ! (PL_parser && PL_parser->error_count))
7195 process_special_blocks(name, gv, cv);
7200 PL_parser->copline = NOLINE;
7202 #ifdef PERL_DEBUG_READONLY_OPS
7203 /* Watch out for BEGIN blocks */
7204 if (slab && gv && isGV(gv) && GvCV(gv)) Slab_to_ro(slab);
7210 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
7213 const char *const colon = strrchr(fullname,':');
7214 const char *const name = colon ? colon + 1 : fullname;
7216 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
7219 if (strEQ(name, "BEGIN")) {
7220 const I32 oldscope = PL_scopestack_ix;
7222 SAVECOPFILE(&PL_compiling);
7223 SAVECOPLINE(&PL_compiling);
7224 SAVEVPTR(PL_curcop);
7226 DEBUG_x( dump_sub(gv) );
7227 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
7228 GvCV_set(gv,0); /* cv has been hijacked */
7229 call_list(oldscope, PL_beginav);
7231 CopHINTS_set(&PL_compiling, PL_hints);
7238 if strEQ(name, "END") {
7239 DEBUG_x( dump_sub(gv) );
7240 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
7243 } else if (*name == 'U') {
7244 if (strEQ(name, "UNITCHECK")) {
7245 /* It's never too late to run a unitcheck block */
7246 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
7250 } else if (*name == 'C') {
7251 if (strEQ(name, "CHECK")) {
7253 /* diag_listed_as: Too late to run %s block */
7254 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
7255 "Too late to run CHECK block");
7256 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
7260 } else if (*name == 'I') {
7261 if (strEQ(name, "INIT")) {
7263 /* diag_listed_as: Too late to run %s block */
7264 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
7265 "Too late to run INIT block");
7266 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
7272 DEBUG_x( dump_sub(gv) );
7273 GvCV_set(gv,0); /* cv has been hijacked */
7278 =for apidoc newCONSTSUB
7280 See L</newCONSTSUB_flags>.
7286 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
7288 return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
7292 =for apidoc newCONSTSUB_flags
7294 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
7295 eligible for inlining at compile-time.
7297 Currently, the only useful value for C<flags> is SVf_UTF8.
7299 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
7300 which won't be called if used as a destructor, but will suppress the overhead
7301 of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
7308 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
7314 const char *const file = CopFILE(PL_curcop);
7316 SV *const temp_sv = CopFILESV(PL_curcop);
7317 const char *const file = temp_sv ? SvPV_nolen_const(temp_sv) : NULL;
7322 if (IN_PERL_RUNTIME) {
7323 /* at runtime, it's not safe to manipulate PL_curcop: it may be
7324 * an op shared between threads. Use a non-shared COP for our
7326 SAVEVPTR(PL_curcop);
7327 SAVECOMPILEWARNINGS();
7328 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
7329 PL_curcop = &PL_compiling;
7331 SAVECOPLINE(PL_curcop);
7332 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
7335 PL_hints &= ~HINT_BLOCK_SCOPE;
7338 SAVEGENERICSV(PL_curstash);
7339 PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
7342 /* file becomes the CvFILE. For an XS, it's usually static storage,
7343 and so doesn't get free()d. (It's expected to be from the C pre-
7344 processor __FILE__ directive). But we need a dynamically allocated one,
7345 and we need it to get freed. */
7346 cv = newXS_len_flags(name, len, const_sv_xsub, file ? file : "", "",
7347 &sv, XS_DYNAMIC_FILENAME | flags);
7348 CvXSUBANY(cv).any_ptr = sv;
7357 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
7358 const char *const filename, const char *const proto,
7361 PERL_ARGS_ASSERT_NEWXS_FLAGS;
7362 return newXS_len_flags(
7363 name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
7368 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
7369 XSUBADDR_t subaddr, const char *const filename,
7370 const char *const proto, SV **const_svp,
7375 PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
7378 GV * const gv = name
7380 name,len,GV_ADDMULTI|flags,SVt_PVCV
7383 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
7384 GV_ADDMULTI | flags, SVt_PVCV);
7387 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
7389 if ((cv = (name ? GvCV(gv) : NULL))) {
7391 /* just a cached method */
7395 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
7396 /* already defined (or promised) */
7397 /* Redundant check that allows us to avoid creating an SV
7398 most of the time: */
7399 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
7400 const line_t oldline = CopLINE(PL_curcop);
7401 if (PL_parser && PL_parser->copline != NOLINE)
7402 CopLINE_set(PL_curcop, PL_parser->copline);
7403 report_redefined_cv(newSVpvn_flags(
7404 name,len,(flags&SVf_UTF8)|SVs_TEMP
7407 CopLINE_set(PL_curcop, oldline);
7414 if (cv) /* must reuse cv if autoloaded */
7417 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
7421 if (HvENAME_HEK(GvSTASH(gv)))
7422 mro_method_changed_in(GvSTASH(gv)); /* newXS */
7428 (void)gv_fetchfile(filename);
7429 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
7430 an external constant string */
7431 assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
7433 CvXSUB(cv) = subaddr;
7436 process_special_blocks(name, gv, cv);
7439 if (flags & XS_DYNAMIC_FILENAME) {
7440 CvFILE(cv) = savepv(filename);
7443 sv_setpv(MUTABLE_SV(cv), proto);
7448 Perl_newSTUB(pTHX_ GV *gv, bool fake)
7450 register CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
7451 PERL_ARGS_ASSERT_NEWSTUB;
7455 if (!fake && HvENAME_HEK(GvSTASH(gv)))
7456 mro_method_changed_in(GvSTASH(gv));
7458 CvFILE_set_from_cop(cv, PL_curcop);
7459 CvSTASH_set(cv, PL_curstash);
7465 =for apidoc U||newXS
7467 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
7468 static storage, as it is used directly as CvFILE(), without a copy being made.
7474 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
7476 PERL_ARGS_ASSERT_NEWXS;
7477 return newXS_len_flags(
7478 name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
7487 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
7492 OP* pegop = newOP(OP_NULL, 0);
7496 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
7497 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
7500 if ((cv = GvFORM(gv))) {
7501 if (ckWARN(WARN_REDEFINE)) {
7502 const line_t oldline = CopLINE(PL_curcop);
7503 if (PL_parser && PL_parser->copline != NOLINE)
7504 CopLINE_set(PL_curcop, PL_parser->copline);
7506 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
7507 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
7509 /* diag_listed_as: Format %s redefined */
7510 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
7511 "Format STDOUT redefined");
7513 CopLINE_set(PL_curcop, oldline);
7520 CvFILE_set_from_cop(cv, PL_curcop);
7523 pad_tidy(padtidy_FORMAT);
7524 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
7525 CvROOT(cv)->op_private |= OPpREFCOUNTED;
7526 OpREFCNT_set(CvROOT(cv), 1);
7527 CvSTART(cv) = LINKLIST(CvROOT(cv));
7528 CvROOT(cv)->op_next = 0;
7529 CALL_PEEP(CvSTART(cv));
7530 finalize_optree(CvROOT(cv));
7532 op_getmad(o,pegop,'n');
7533 op_getmad_weak(block, pegop, 'b');
7539 PL_parser->copline = NOLINE;
7547 Perl_newANONLIST(pTHX_ OP *o)
7549 return convert(OP_ANONLIST, OPf_SPECIAL, o);
7553 Perl_newANONHASH(pTHX_ OP *o)
7555 return convert(OP_ANONHASH, OPf_SPECIAL, o);
7559 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
7561 return newANONATTRSUB(floor, proto, NULL, block);
7565 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
7567 return newUNOP(OP_REFGEN, 0,
7568 newSVOP(OP_ANONCODE, 0,
7569 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
7573 Perl_oopsAV(pTHX_ OP *o)
7577 PERL_ARGS_ASSERT_OOPSAV;
7579 switch (o->op_type) {
7581 o->op_type = OP_PADAV;
7582 o->op_ppaddr = PL_ppaddr[OP_PADAV];
7583 return ref(o, OP_RV2AV);
7586 o->op_type = OP_RV2AV;
7587 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
7592 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
7599 Perl_oopsHV(pTHX_ OP *o)
7603 PERL_ARGS_ASSERT_OOPSHV;
7605 switch (o->op_type) {
7608 o->op_type = OP_PADHV;
7609 o->op_ppaddr = PL_ppaddr[OP_PADHV];
7610 return ref(o, OP_RV2HV);
7614 o->op_type = OP_RV2HV;
7615 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
7620 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
7627 Perl_newAVREF(pTHX_ OP *o)
7631 PERL_ARGS_ASSERT_NEWAVREF;
7633 if (o->op_type == OP_PADANY) {
7634 o->op_type = OP_PADAV;
7635 o->op_ppaddr = PL_ppaddr[OP_PADAV];
7638 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
7639 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7640 "Using an array as a reference is deprecated");
7642 return newUNOP(OP_RV2AV, 0, scalar(o));
7646 Perl_newGVREF(pTHX_ I32 type, OP *o)
7648 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
7649 return newUNOP(OP_NULL, 0, o);
7650 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
7654 Perl_newHVREF(pTHX_ OP *o)
7658 PERL_ARGS_ASSERT_NEWHVREF;
7660 if (o->op_type == OP_PADANY) {
7661 o->op_type = OP_PADHV;
7662 o->op_ppaddr = PL_ppaddr[OP_PADHV];
7665 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
7666 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7667 "Using a hash as a reference is deprecated");
7669 return newUNOP(OP_RV2HV, 0, scalar(o));
7673 Perl_newCVREF(pTHX_ I32 flags, OP *o)
7675 return newUNOP(OP_RV2CV, flags, scalar(o));
7679 Perl_newSVREF(pTHX_ OP *o)
7683 PERL_ARGS_ASSERT_NEWSVREF;
7685 if (o->op_type == OP_PADANY) {
7686 o->op_type = OP_PADSV;
7687 o->op_ppaddr = PL_ppaddr[OP_PADSV];
7690 return newUNOP(OP_RV2SV, 0, scalar(o));
7693 /* Check routines. See the comments at the top of this file for details
7694 * on when these are called */
7697 Perl_ck_anoncode(pTHX_ OP *o)
7699 PERL_ARGS_ASSERT_CK_ANONCODE;
7701 cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
7703 cSVOPo->op_sv = NULL;
7708 Perl_ck_bitop(pTHX_ OP *o)
7712 PERL_ARGS_ASSERT_CK_BITOP;
7714 o->op_private = (U8)(PL_hints & HINT_INTEGER);
7715 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
7716 && (o->op_type == OP_BIT_OR
7717 || o->op_type == OP_BIT_AND
7718 || o->op_type == OP_BIT_XOR))
7720 const OP * const left = cBINOPo->op_first;
7721 const OP * const right = left->op_sibling;
7722 if ((OP_IS_NUMCOMPARE(left->op_type) &&
7723 (left->op_flags & OPf_PARENS) == 0) ||
7724 (OP_IS_NUMCOMPARE(right->op_type) &&
7725 (right->op_flags & OPf_PARENS) == 0))
7726 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
7727 "Possible precedence problem on bitwise %c operator",
7728 o->op_type == OP_BIT_OR ? '|'
7729 : o->op_type == OP_BIT_AND ? '&' : '^'
7735 PERL_STATIC_INLINE bool
7736 is_dollar_bracket(pTHX_ const OP * const o)
7739 return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
7740 && (kid = cUNOPx(o)->op_first)
7741 && kid->op_type == OP_GV
7742 && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
7746 Perl_ck_cmp(pTHX_ OP *o)
7748 PERL_ARGS_ASSERT_CK_CMP;
7749 if (ckWARN(WARN_SYNTAX)) {
7750 const OP *kid = cUNOPo->op_first;
7753 is_dollar_bracket(aTHX_ kid)
7754 && kid->op_sibling && kid->op_sibling->op_type == OP_CONST
7756 || ( kid->op_type == OP_CONST
7757 && (kid = kid->op_sibling) && is_dollar_bracket(aTHX_ kid))
7759 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7760 "$[ used in %s (did you mean $] ?)", OP_DESC(o));
7766 Perl_ck_concat(pTHX_ OP *o)
7768 const OP * const kid = cUNOPo->op_first;
7770 PERL_ARGS_ASSERT_CK_CONCAT;
7771 PERL_UNUSED_CONTEXT;
7773 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
7774 !(kUNOP->op_first->op_flags & OPf_MOD))
7775 o->op_flags |= OPf_STACKED;
7780 Perl_ck_spair(pTHX_ OP *o)
7784 PERL_ARGS_ASSERT_CK_SPAIR;
7786 if (o->op_flags & OPf_KIDS) {
7789 const OPCODE type = o->op_type;
7790 o = modkids(ck_fun(o), type);
7791 kid = cUNOPo->op_first;
7792 newop = kUNOP->op_first->op_sibling;
7794 const OPCODE type = newop->op_type;
7795 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
7796 type == OP_PADAV || type == OP_PADHV ||
7797 type == OP_RV2AV || type == OP_RV2HV)
7801 op_getmad(kUNOP->op_first,newop,'K');
7803 op_free(kUNOP->op_first);
7805 kUNOP->op_first = newop;
7807 o->op_ppaddr = PL_ppaddr[++o->op_type];
7812 Perl_ck_delete(pTHX_ OP *o)
7814 PERL_ARGS_ASSERT_CK_DELETE;
7818 if (o->op_flags & OPf_KIDS) {
7819 OP * const kid = cUNOPo->op_first;
7820 switch (kid->op_type) {
7822 o->op_flags |= OPf_SPECIAL;
7825 o->op_private |= OPpSLICE;
7828 o->op_flags |= OPf_SPECIAL;
7833 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
7836 if (kid->op_private & OPpLVAL_INTRO)
7837 o->op_private |= OPpLVAL_INTRO;
7844 Perl_ck_die(pTHX_ OP *o)
7846 PERL_ARGS_ASSERT_CK_DIE;
7849 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
7855 Perl_ck_eof(pTHX_ OP *o)
7859 PERL_ARGS_ASSERT_CK_EOF;
7861 if (o->op_flags & OPf_KIDS) {
7863 if (cLISTOPo->op_first->op_type == OP_STUB) {
7865 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
7867 op_getmad(o,newop,'O');
7874 kid = cLISTOPo->op_first;
7875 if (kid->op_type == OP_RV2GV)
7876 kid->op_private |= OPpALLOW_FAKE;
7882 Perl_ck_eval(pTHX_ OP *o)
7886 PERL_ARGS_ASSERT_CK_EVAL;
7888 PL_hints |= HINT_BLOCK_SCOPE;
7889 if (o->op_flags & OPf_KIDS) {
7890 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7893 o->op_flags &= ~OPf_KIDS;
7896 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
7902 cUNOPo->op_first = 0;
7907 NewOp(1101, enter, 1, LOGOP);
7908 enter->op_type = OP_ENTERTRY;
7909 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
7910 enter->op_private = 0;
7912 /* establish postfix order */
7913 enter->op_next = (OP*)enter;
7915 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
7916 o->op_type = OP_LEAVETRY;
7917 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
7918 enter->op_other = o;
7919 op_getmad(oldo,o,'O');
7928 const U8 priv = o->op_private;
7934 o = newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
7935 op_getmad(oldo,o,'O');
7937 o->op_targ = (PADOFFSET)PL_hints;
7938 if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
7939 if ((PL_hints & HINT_LOCALIZE_HH) != 0
7940 && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
7941 /* Store a copy of %^H that pp_entereval can pick up. */
7942 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
7943 MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
7944 cUNOPo->op_first->op_sibling = hhop;
7945 o->op_private |= OPpEVAL_HAS_HH;
7947 if (!(o->op_private & OPpEVAL_BYTES)
7948 && FEATURE_UNIEVAL_IS_ENABLED)
7949 o->op_private |= OPpEVAL_UNICODE;
7954 Perl_ck_exit(pTHX_ OP *o)
7956 PERL_ARGS_ASSERT_CK_EXIT;
7959 HV * const table = GvHV(PL_hintgv);
7961 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
7962 if (svp && *svp && SvTRUE(*svp))
7963 o->op_private |= OPpEXIT_VMSISH;
7965 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
7971 Perl_ck_exec(pTHX_ OP *o)
7973 PERL_ARGS_ASSERT_CK_EXEC;
7975 if (o->op_flags & OPf_STACKED) {
7978 kid = cUNOPo->op_first->op_sibling;
7979 if (kid->op_type == OP_RV2GV)
7988 Perl_ck_exists(pTHX_ OP *o)
7992 PERL_ARGS_ASSERT_CK_EXISTS;
7995 if (o->op_flags & OPf_KIDS) {
7996 OP * const kid = cUNOPo->op_first;
7997 if (kid->op_type == OP_ENTERSUB) {
7998 (void) ref(kid, o->op_type);
7999 if (kid->op_type != OP_RV2CV
8000 && !(PL_parser && PL_parser->error_count))
8001 Perl_croak(aTHX_ "%s argument is not a subroutine name",
8003 o->op_private |= OPpEXISTS_SUB;
8005 else if (kid->op_type == OP_AELEM)
8006 o->op_flags |= OPf_SPECIAL;
8007 else if (kid->op_type != OP_HELEM)
8008 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine",
8016 Perl_ck_rvconst(pTHX_ register OP *o)
8019 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8021 PERL_ARGS_ASSERT_CK_RVCONST;
8023 o->op_private |= (PL_hints & HINT_STRICT_REFS);
8024 if (o->op_type == OP_RV2CV)
8025 o->op_private &= ~1;
8027 if (kid->op_type == OP_CONST) {
8030 SV * const kidsv = kid->op_sv;
8032 /* Is it a constant from cv_const_sv()? */
8033 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
8034 SV * const rsv = SvRV(kidsv);
8035 const svtype type = SvTYPE(rsv);
8036 const char *badtype = NULL;
8038 switch (o->op_type) {
8040 if (type > SVt_PVMG)
8041 badtype = "a SCALAR";
8044 if (type != SVt_PVAV)
8045 badtype = "an ARRAY";
8048 if (type != SVt_PVHV)
8052 if (type != SVt_PVCV)
8057 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
8060 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
8061 const char *badthing;
8062 switch (o->op_type) {
8064 badthing = "a SCALAR";
8067 badthing = "an ARRAY";
8070 badthing = "a HASH";
8078 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
8079 SVfARG(kidsv), badthing);
8082 * This is a little tricky. We only want to add the symbol if we
8083 * didn't add it in the lexer. Otherwise we get duplicate strict
8084 * warnings. But if we didn't add it in the lexer, we must at
8085 * least pretend like we wanted to add it even if it existed before,
8086 * or we get possible typo warnings. OPpCONST_ENTERED says
8087 * whether the lexer already added THIS instance of this symbol.
8089 iscv = (o->op_type == OP_RV2CV) * 2;
8091 gv = gv_fetchsv(kidsv,
8092 iscv | !(kid->op_private & OPpCONST_ENTERED),
8095 : o->op_type == OP_RV2SV
8097 : o->op_type == OP_RV2AV
8099 : o->op_type == OP_RV2HV
8102 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
8104 kid->op_type = OP_GV;
8105 SvREFCNT_dec(kid->op_sv);
8107 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
8108 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
8109 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
8111 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
8113 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
8115 kid->op_private = 0;
8116 kid->op_ppaddr = PL_ppaddr[OP_GV];
8117 /* FAKE globs in the symbol table cause weird bugs (#77810) */
8125 Perl_ck_ftst(pTHX_ OP *o)
8128 const I32 type = o->op_type;
8130 PERL_ARGS_ASSERT_CK_FTST;
8132 if (o->op_flags & OPf_REF) {
8135 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
8136 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8137 const OPCODE kidtype = kid->op_type;
8139 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
8140 && !(kid->op_private & OPpCONST_FOLDED)) {
8141 OP * const newop = newGVOP(type, OPf_REF,
8142 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
8144 op_getmad(o,newop,'O');
8150 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
8151 o->op_private |= OPpFT_ACCESS;
8152 if (PL_check[kidtype] == Perl_ck_ftst
8153 && kidtype != OP_STAT && kidtype != OP_LSTAT) {
8154 o->op_private |= OPpFT_STACKED;
8155 kid->op_private |= OPpFT_STACKING;
8156 if (kidtype == OP_FTTTY && (
8157 !(kid->op_private & OPpFT_STACKED)
8158 || kid->op_private & OPpFT_AFTER_t
8160 o->op_private |= OPpFT_AFTER_t;
8169 if (type == OP_FTTTY)
8170 o = newGVOP(type, OPf_REF, PL_stdingv);
8172 o = newUNOP(type, 0, newDEFSVOP());
8173 op_getmad(oldo,o,'O');
8179 Perl_ck_fun(pTHX_ OP *o)
8182 const int type = o->op_type;
8183 register I32 oa = PL_opargs[type] >> OASHIFT;
8185 PERL_ARGS_ASSERT_CK_FUN;
8187 if (o->op_flags & OPf_STACKED) {
8188 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
8191 return no_fh_allowed(o);
8194 if (o->op_flags & OPf_KIDS) {
8195 OP **tokid = &cLISTOPo->op_first;
8196 register OP *kid = cLISTOPo->op_first;
8199 bool seen_optional = FALSE;
8201 if (kid->op_type == OP_PUSHMARK ||
8202 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
8204 tokid = &kid->op_sibling;
8205 kid = kid->op_sibling;
8207 if (kid && kid->op_type == OP_COREARGS) {
8208 bool optional = FALSE;
8211 if (oa & OA_OPTIONAL) optional = TRUE;
8214 if (optional) o->op_private |= numargs;
8219 if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
8220 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV)
8221 *tokid = kid = newDEFSVOP();
8222 seen_optional = TRUE;
8227 sibl = kid->op_sibling;
8229 if (!sibl && kid->op_type == OP_STUB) {
8236 /* list seen where single (scalar) arg expected? */
8237 if (numargs == 1 && !(oa >> 4)
8238 && kid->op_type == OP_LIST && type != OP_SCALAR)
8240 return too_many_arguments_pv(o,PL_op_desc[type], 0);
8253 if ((type == OP_PUSH || type == OP_UNSHIFT)
8254 && !kid->op_sibling)
8255 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
8256 "Useless use of %s with no values",
8259 if (kid->op_type == OP_CONST &&
8260 (kid->op_private & OPpCONST_BARE))
8262 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
8263 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
8264 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8265 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
8266 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
8268 op_getmad(kid,newop,'K');
8273 kid->op_sibling = sibl;
8276 else if (kid->op_type == OP_CONST
8277 && ( !SvROK(cSVOPx_sv(kid))
8278 || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
8280 bad_type_pv(numargs, "array", PL_op_desc[type], 0, kid);
8281 /* Defer checks to run-time if we have a scalar arg */
8282 if (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV)
8283 op_lvalue(kid, type);
8287 if (kid->op_type == OP_CONST &&
8288 (kid->op_private & OPpCONST_BARE))
8290 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
8291 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
8292 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8293 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
8294 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
8296 op_getmad(kid,newop,'K');
8301 kid->op_sibling = sibl;
8304 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
8305 bad_type_pv(numargs, "hash", PL_op_desc[type], 0, kid);
8306 op_lvalue(kid, type);
8310 OP * const newop = newUNOP(OP_NULL, 0, kid);
8311 kid->op_sibling = 0;
8312 newop->op_next = newop;
8314 kid->op_sibling = sibl;
8319 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
8320 if (kid->op_type == OP_CONST &&
8321 (kid->op_private & OPpCONST_BARE))
8323 OP * const newop = newGVOP(OP_GV, 0,
8324 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
8325 if (!(o->op_private & 1) && /* if not unop */
8326 kid == cLISTOPo->op_last)
8327 cLISTOPo->op_last = newop;
8329 op_getmad(kid,newop,'K');
8335 else if (kid->op_type == OP_READLINE) {
8336 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
8337 bad_type_pv(numargs, "HANDLE", OP_DESC(o), 0, kid);
8340 I32 flags = OPf_SPECIAL;
8344 /* is this op a FH constructor? */
8345 if (is_handle_constructor(o,numargs)) {
8346 const char *name = NULL;
8349 bool want_dollar = TRUE;
8352 /* Set a flag to tell rv2gv to vivify
8353 * need to "prove" flag does not mean something
8354 * else already - NI-S 1999/05/07
8357 if (kid->op_type == OP_PADSV) {
8359 = PAD_COMPNAME_SV(kid->op_targ);
8360 name = SvPV_const(namesv, len);
8361 name_utf8 = SvUTF8(namesv);
8363 else if (kid->op_type == OP_RV2SV
8364 && kUNOP->op_first->op_type == OP_GV)
8366 GV * const gv = cGVOPx_gv(kUNOP->op_first);
8368 len = GvNAMELEN(gv);
8369 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
8371 else if (kid->op_type == OP_AELEM
8372 || kid->op_type == OP_HELEM)
8375 OP *op = ((BINOP*)kid)->op_first;
8379 const char * const a =
8380 kid->op_type == OP_AELEM ?
8382 if (((op->op_type == OP_RV2AV) ||
8383 (op->op_type == OP_RV2HV)) &&
8384 (firstop = ((UNOP*)op)->op_first) &&
8385 (firstop->op_type == OP_GV)) {
8386 /* packagevar $a[] or $h{} */
8387 GV * const gv = cGVOPx_gv(firstop);
8395 else if (op->op_type == OP_PADAV
8396 || op->op_type == OP_PADHV) {
8397 /* lexicalvar $a[] or $h{} */
8398 const char * const padname =
8399 PAD_COMPNAME_PV(op->op_targ);
8408 name = SvPV_const(tmpstr, len);
8409 name_utf8 = SvUTF8(tmpstr);
8414 name = "__ANONIO__";
8416 want_dollar = FALSE;
8418 op_lvalue(kid, type);
8422 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
8423 namesv = PAD_SVl(targ);
8424 SvUPGRADE(namesv, SVt_PV);
8425 if (want_dollar && *name != '$')
8426 sv_setpvs(namesv, "$");
8427 sv_catpvn(namesv, name, len);
8428 if ( name_utf8 ) SvUTF8_on(namesv);
8431 kid->op_sibling = 0;
8432 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
8433 kid->op_targ = targ;
8434 kid->op_private |= priv;
8436 kid->op_sibling = sibl;
8442 if ((type == OP_UNDEF || type == OP_POS)
8443 && numargs == 1 && !(oa >> 4)
8444 && kid->op_type == OP_LIST)
8445 return too_many_arguments_pv(o,PL_op_desc[type], 0);
8446 op_lvalue(scalar(kid), type);
8450 tokid = &kid->op_sibling;
8451 kid = kid->op_sibling;
8454 if (kid && kid->op_type != OP_STUB)
8455 return too_many_arguments_pv(o,OP_DESC(o), 0);
8456 o->op_private |= numargs;
8458 /* FIXME - should the numargs move as for the PERL_MAD case? */
8459 o->op_private |= numargs;
8461 return too_many_arguments_pv(o,OP_DESC(o), 0);
8465 else if (PL_opargs[type] & OA_DEFGV) {
8467 OP *newop = newUNOP(type, 0, newDEFSVOP());
8468 op_getmad(o,newop,'O');
8471 /* Ordering of these two is important to keep f_map.t passing. */
8473 return newUNOP(type, 0, newDEFSVOP());
8478 while (oa & OA_OPTIONAL)
8480 if (oa && oa != OA_LIST)
8481 return too_few_arguments_pv(o,OP_DESC(o), 0);
8487 Perl_ck_glob(pTHX_ OP *o)
8491 const bool core = o->op_flags & OPf_SPECIAL;
8493 PERL_ARGS_ASSERT_CK_GLOB;
8496 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
8497 op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
8499 if (core) gv = NULL;
8500 else if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
8501 && GvCVu(gv) && GvIMPORTED_CV(gv)))
8503 GV * const * const gvp =
8504 (GV **)hv_fetchs(PL_globalstash, "glob", FALSE);
8505 gv = gvp ? *gvp : NULL;
8508 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
8511 * \ null - const(wildcard)
8516 * \ mark - glob - rv2cv
8517 * | \ gv(CORE::GLOBAL::glob)
8519 * \ null - const(wildcard) - const(ix)
8521 o->op_flags |= OPf_SPECIAL;
8522 o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
8523 op_append_elem(OP_GLOB, o,
8524 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
8525 o = newLISTOP(OP_LIST, 0, o, NULL);
8526 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
8527 op_append_elem(OP_LIST, o,
8528 scalar(newUNOP(OP_RV2CV, 0,
8529 newGVOP(OP_GV, 0, gv)))));
8530 o = newUNOP(OP_NULL, 0, o);
8531 o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
8534 else o->op_flags &= ~OPf_SPECIAL;
8535 #if !defined(PERL_EXTERNAL_GLOB)
8538 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
8539 newSVpvs("File::Glob"), NULL, NULL, NULL);
8542 #endif /* !PERL_EXTERNAL_GLOB */
8543 gv = newGVgen("main");
8545 #ifndef PERL_EXTERNAL_GLOB
8546 sv_setiv(GvSVn(gv),PL_glob_index++);
8548 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
8554 Perl_ck_grep(pTHX_ OP *o)
8559 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
8562 PERL_ARGS_ASSERT_CK_GREP;
8564 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
8565 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
8567 if (o->op_flags & OPf_STACKED) {
8568 kid = cUNOPx(cLISTOPo->op_first->op_sibling)->op_first;
8569 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
8570 return no_fh_allowed(o);
8571 o->op_flags &= ~OPf_STACKED;
8573 kid = cLISTOPo->op_first->op_sibling;
8574 if (type == OP_MAPWHILE)
8579 if (PL_parser && PL_parser->error_count)
8581 kid = cLISTOPo->op_first->op_sibling;
8582 if (kid->op_type != OP_NULL)
8583 Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
8584 kid = kUNOP->op_first;
8586 NewOp(1101, gwop, 1, LOGOP);
8587 gwop->op_type = type;
8588 gwop->op_ppaddr = PL_ppaddr[type];
8590 gwop->op_flags |= OPf_KIDS;
8591 gwop->op_other = LINKLIST(kid);
8592 kid->op_next = (OP*)gwop;
8593 offset = pad_findmy_pvs("$_", 0);
8594 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
8595 o->op_private = gwop->op_private = 0;
8596 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
8599 o->op_private = gwop->op_private = OPpGREP_LEX;
8600 gwop->op_targ = o->op_targ = offset;
8603 kid = cLISTOPo->op_first->op_sibling;
8604 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
8605 op_lvalue(kid, OP_GREPSTART);
8611 Perl_ck_index(pTHX_ OP *o)
8613 PERL_ARGS_ASSERT_CK_INDEX;
8615 if (o->op_flags & OPf_KIDS) {
8616 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8618 kid = kid->op_sibling; /* get past "big" */
8619 if (kid && kid->op_type == OP_CONST) {
8620 const bool save_taint = PL_tainted;
8621 fbm_compile(((SVOP*)kid)->op_sv, 0);
8622 PL_tainted = save_taint;
8629 Perl_ck_lfun(pTHX_ OP *o)
8631 const OPCODE type = o->op_type;
8633 PERL_ARGS_ASSERT_CK_LFUN;
8635 return modkids(ck_fun(o), type);
8639 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
8641 PERL_ARGS_ASSERT_CK_DEFINED;
8643 if ((o->op_flags & OPf_KIDS)) {
8644 switch (cUNOPo->op_first->op_type) {
8647 case OP_AASSIGN: /* Is this a good idea? */
8648 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8649 "defined(@array) is deprecated");
8650 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8651 "\t(Maybe you should just omit the defined()?)\n");
8655 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8656 "defined(%%hash) is deprecated");
8657 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8658 "\t(Maybe you should just omit the defined()?)\n");
8669 Perl_ck_readline(pTHX_ OP *o)
8671 PERL_ARGS_ASSERT_CK_READLINE;
8673 if (o->op_flags & OPf_KIDS) {
8674 OP *kid = cLISTOPo->op_first;
8675 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
8679 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
8681 op_getmad(o,newop,'O');
8691 Perl_ck_rfun(pTHX_ OP *o)
8693 const OPCODE type = o->op_type;
8695 PERL_ARGS_ASSERT_CK_RFUN;
8697 return refkids(ck_fun(o), type);
8701 Perl_ck_listiob(pTHX_ OP *o)
8705 PERL_ARGS_ASSERT_CK_LISTIOB;
8707 kid = cLISTOPo->op_first;
8710 kid = cLISTOPo->op_first;
8712 if (kid->op_type == OP_PUSHMARK)
8713 kid = kid->op_sibling;
8714 if (kid && o->op_flags & OPf_STACKED)
8715 kid = kid->op_sibling;
8716 else if (kid && !kid->op_sibling) { /* print HANDLE; */
8717 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
8718 && !(kid->op_private & OPpCONST_FOLDED)) {
8719 o->op_flags |= OPf_STACKED; /* make it a filehandle */
8720 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
8721 cLISTOPo->op_first->op_sibling = kid;
8722 cLISTOPo->op_last = kid;
8723 kid = kid->op_sibling;
8728 op_append_elem(o->op_type, o, newDEFSVOP());
8730 if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
8735 Perl_ck_smartmatch(pTHX_ OP *o)
8738 PERL_ARGS_ASSERT_CK_SMARTMATCH;
8739 if (0 == (o->op_flags & OPf_SPECIAL)) {
8740 OP *first = cBINOPo->op_first;
8741 OP *second = first->op_sibling;
8743 /* Implicitly take a reference to an array or hash */
8744 first->op_sibling = NULL;
8745 first = cBINOPo->op_first = ref_array_or_hash(first);
8746 second = first->op_sibling = ref_array_or_hash(second);
8748 /* Implicitly take a reference to a regular expression */
8749 if (first->op_type == OP_MATCH) {
8750 first->op_type = OP_QR;
8751 first->op_ppaddr = PL_ppaddr[OP_QR];
8753 if (second->op_type == OP_MATCH) {
8754 second->op_type = OP_QR;
8755 second->op_ppaddr = PL_ppaddr[OP_QR];
8764 Perl_ck_sassign(pTHX_ OP *o)
8767 OP * const kid = cLISTOPo->op_first;
8769 PERL_ARGS_ASSERT_CK_SASSIGN;
8771 /* has a disposable target? */
8772 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
8773 && !(kid->op_flags & OPf_STACKED)
8774 /* Cannot steal the second time! */
8775 && !(kid->op_private & OPpTARGET_MY)
8776 /* Keep the full thing for madskills */
8780 OP * const kkid = kid->op_sibling;
8782 /* Can just relocate the target. */
8783 if (kkid && kkid->op_type == OP_PADSV
8784 && !(kkid->op_private & OPpLVAL_INTRO))
8786 kid->op_targ = kkid->op_targ;
8788 /* Now we do not need PADSV and SASSIGN. */
8789 kid->op_sibling = o->op_sibling; /* NULL */
8790 cLISTOPo->op_first = NULL;
8793 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
8797 if (kid->op_sibling) {
8798 OP *kkid = kid->op_sibling;
8799 /* For state variable assignment, kkid is a list op whose op_last
8801 if ((kkid->op_type == OP_PADSV ||
8802 (kkid->op_type == OP_LIST &&
8803 (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
8806 && (kkid->op_private & OPpLVAL_INTRO)
8807 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
8808 const PADOFFSET target = kkid->op_targ;
8809 OP *const other = newOP(OP_PADSV,
8811 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
8812 OP *const first = newOP(OP_NULL, 0);
8813 OP *const nullop = newCONDOP(0, first, o, other);
8814 OP *const condop = first->op_next;
8815 /* hijacking PADSTALE for uninitialized state variables */
8816 SvPADSTALE_on(PAD_SVl(target));
8818 condop->op_type = OP_ONCE;
8819 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
8820 condop->op_targ = target;
8821 other->op_targ = target;
8823 /* Because we change the type of the op here, we will skip the
8824 assignment binop->op_last = binop->op_first->op_sibling; at the
8825 end of Perl_newBINOP(). So need to do it here. */
8826 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
8835 Perl_ck_match(pTHX_ OP *o)
8839 PERL_ARGS_ASSERT_CK_MATCH;
8841 if (o->op_type != OP_QR && PL_compcv) {
8842 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
8843 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
8844 o->op_targ = offset;
8845 o->op_private |= OPpTARGET_MY;
8848 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
8849 o->op_private |= OPpRUNTIME;
8854 Perl_ck_method(pTHX_ OP *o)
8856 OP * const kid = cUNOPo->op_first;
8858 PERL_ARGS_ASSERT_CK_METHOD;
8860 if (kid->op_type == OP_CONST) {
8861 SV* sv = kSVOP->op_sv;
8862 const char * const method = SvPVX_const(sv);
8863 if (!(strchr(method, ':') || strchr(method, '\''))) {
8865 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
8866 sv = newSVpvn_share(method, SvUTF8(sv) ? -(I32)SvCUR(sv) : (I32)SvCUR(sv), 0);
8869 kSVOP->op_sv = NULL;
8871 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
8873 op_getmad(o,cmop,'O');
8884 Perl_ck_null(pTHX_ OP *o)
8886 PERL_ARGS_ASSERT_CK_NULL;
8887 PERL_UNUSED_CONTEXT;
8892 Perl_ck_open(pTHX_ OP *o)
8895 HV * const table = GvHV(PL_hintgv);
8897 PERL_ARGS_ASSERT_CK_OPEN;
8900 SV **svp = hv_fetchs(table, "open_IN", FALSE);
8903 const char *d = SvPV_const(*svp, len);
8904 const I32 mode = mode_from_discipline(d, len);
8905 if (mode & O_BINARY)
8906 o->op_private |= OPpOPEN_IN_RAW;
8907 else if (mode & O_TEXT)
8908 o->op_private |= OPpOPEN_IN_CRLF;
8911 svp = hv_fetchs(table, "open_OUT", FALSE);
8914 const char *d = SvPV_const(*svp, len);
8915 const I32 mode = mode_from_discipline(d, len);
8916 if (mode & O_BINARY)
8917 o->op_private |= OPpOPEN_OUT_RAW;
8918 else if (mode & O_TEXT)
8919 o->op_private |= OPpOPEN_OUT_CRLF;
8922 if (o->op_type == OP_BACKTICK) {
8923 if (!(o->op_flags & OPf_KIDS)) {
8924 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
8926 op_getmad(o,newop,'O');
8935 /* In case of three-arg dup open remove strictness
8936 * from the last arg if it is a bareword. */
8937 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
8938 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
8942 if ((last->op_type == OP_CONST) && /* The bareword. */
8943 (last->op_private & OPpCONST_BARE) &&
8944 (last->op_private & OPpCONST_STRICT) &&
8945 (oa = first->op_sibling) && /* The fh. */
8946 (oa = oa->op_sibling) && /* The mode. */
8947 (oa->op_type == OP_CONST) &&
8948 SvPOK(((SVOP*)oa)->op_sv) &&
8949 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
8950 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
8951 (last == oa->op_sibling)) /* The bareword. */
8952 last->op_private &= ~OPpCONST_STRICT;
8958 Perl_ck_repeat(pTHX_ OP *o)
8960 PERL_ARGS_ASSERT_CK_REPEAT;
8962 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
8963 o->op_private |= OPpREPEAT_DOLIST;
8964 cBINOPo->op_first = force_list(cBINOPo->op_first);
8972 Perl_ck_require(pTHX_ OP *o)
8977 PERL_ARGS_ASSERT_CK_REQUIRE;
8979 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
8980 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8982 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
8983 SV * const sv = kid->op_sv;
8984 U32 was_readonly = SvREADONLY(sv);
8991 sv_force_normal_flags(sv, 0);
8992 assert(!SvREADONLY(sv));
9002 for (; s < end; s++) {
9003 if (*s == ':' && s[1] == ':') {
9005 Move(s+2, s+1, end - s - 1, char);
9010 sv_catpvs(sv, ".pm");
9011 SvFLAGS(sv) |= was_readonly;
9015 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
9016 /* handle override, if any */
9017 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
9018 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
9019 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
9020 gv = gvp ? *gvp : NULL;
9024 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
9026 if (o->op_flags & OPf_KIDS) {
9027 kid = cUNOPo->op_first;
9028 cUNOPo->op_first = NULL;
9036 newop = newUNOP(OP_ENTERSUB, OPf_STACKED,
9037 op_append_elem(OP_LIST, kid,
9038 scalar(newUNOP(OP_RV2CV, 0,
9041 op_getmad(o,newop,'O');
9045 return scalar(ck_fun(o));
9049 Perl_ck_return(pTHX_ OP *o)
9054 PERL_ARGS_ASSERT_CK_RETURN;
9056 kid = cLISTOPo->op_first->op_sibling;
9057 if (CvLVALUE(PL_compcv)) {
9058 for (; kid; kid = kid->op_sibling)
9059 op_lvalue(kid, OP_LEAVESUBLV);
9066 Perl_ck_select(pTHX_ OP *o)
9071 PERL_ARGS_ASSERT_CK_SELECT;
9073 if (o->op_flags & OPf_KIDS) {
9074 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
9075 if (kid && kid->op_sibling) {
9076 o->op_type = OP_SSELECT;
9077 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
9079 return fold_constants(op_integerize(op_std_init(o)));
9083 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
9084 if (kid && kid->op_type == OP_RV2GV)
9085 kid->op_private &= ~HINT_STRICT_REFS;
9090 Perl_ck_shift(pTHX_ OP *o)
9093 const I32 type = o->op_type;
9095 PERL_ARGS_ASSERT_CK_SHIFT;
9097 if (!(o->op_flags & OPf_KIDS)) {
9100 if (!CvUNIQUE(PL_compcv)) {
9101 o->op_flags |= OPf_SPECIAL;
9105 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
9108 OP * const oldo = o;
9109 o = newUNOP(type, 0, scalar(argop));
9110 op_getmad(oldo,o,'O');
9115 return newUNOP(type, 0, scalar(argop));
9118 return scalar(ck_fun(o));
9122 Perl_ck_sort(pTHX_ OP *o)
9126 HV * const hinthv = GvHV(PL_hintgv);
9128 PERL_ARGS_ASSERT_CK_SORT;
9131 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
9133 const I32 sorthints = (I32)SvIV(*svp);
9134 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
9135 o->op_private |= OPpSORT_QSORT;
9136 if ((sorthints & HINT_SORT_STABLE) != 0)
9137 o->op_private |= OPpSORT_STABLE;
9141 if (o->op_flags & OPf_STACKED)
9143 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
9144 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
9145 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
9147 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
9149 if (kid->op_type == OP_LEAVE)
9150 op_null(kid); /* wipe out leave */
9151 /* Prevent execution from escaping out of the sort block. */
9154 /* provide scalar context for comparison function/block */
9155 kid = scalar(firstkid);
9157 o->op_flags |= OPf_SPECIAL;
9160 firstkid = firstkid->op_sibling;
9163 /* provide list context for arguments */
9170 S_simplify_sort(pTHX_ OP *o)
9173 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
9180 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
9182 if (!(o->op_flags & OPf_STACKED))
9184 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
9185 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
9186 kid = kUNOP->op_first; /* get past null */
9187 if (!(have_scopeop = kid->op_type == OP_SCOPE)
9188 && kid->op_type != OP_LEAVE)
9190 kid = kLISTOP->op_last; /* get past scope */
9191 switch(kid->op_type) {
9195 if (!have_scopeop) goto padkids;
9200 k = kid; /* remember this node*/
9201 if (kBINOP->op_first->op_type != OP_RV2SV
9202 || kBINOP->op_last ->op_type != OP_RV2SV)
9205 Warn about my($a) or my($b) in a sort block, *if* $a or $b is
9206 then used in a comparison. This catches most, but not
9207 all cases. For instance, it catches
9208 sort { my($a); $a <=> $b }
9210 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
9211 (although why you'd do that is anyone's guess).
9215 if (!ckWARN(WARN_SYNTAX)) return;
9216 kid = kBINOP->op_first;
9218 if (kid->op_type == OP_PADSV) {
9219 SV * const name = AvARRAY(PL_comppad_name)[kid->op_targ];
9220 if (SvCUR(name) == 2 && *SvPVX(name) == '$'
9221 && (SvPVX(name)[1] == 'a' || SvPVX(name)[1] == 'b'))
9222 /* diag_listed_as: "my %s" used in sort comparison */
9223 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9224 "\"%s %s\" used in sort comparison",
9225 SvPAD_STATE(name) ? "state" : "my",
9228 } while ((kid = kid->op_sibling));
9231 kid = kBINOP->op_first; /* get past cmp */
9232 if (kUNOP->op_first->op_type != OP_GV)
9234 kid = kUNOP->op_first; /* get past rv2sv */
9236 if (GvSTASH(gv) != PL_curstash)
9238 gvname = GvNAME(gv);
9239 if (*gvname == 'a' && gvname[1] == '\0')
9241 else if (*gvname == 'b' && gvname[1] == '\0')
9246 kid = k; /* back to cmp */
9247 /* already checked above that it is rv2sv */
9248 kid = kBINOP->op_last; /* down to 2nd arg */
9249 if (kUNOP->op_first->op_type != OP_GV)
9251 kid = kUNOP->op_first; /* get past rv2sv */
9253 if (GvSTASH(gv) != PL_curstash)
9255 gvname = GvNAME(gv);
9257 ? !(*gvname == 'a' && gvname[1] == '\0')
9258 : !(*gvname == 'b' && gvname[1] == '\0'))
9260 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
9262 o->op_private |= OPpSORT_DESCEND;
9263 if (k->op_type == OP_NCMP)
9264 o->op_private |= OPpSORT_NUMERIC;
9265 if (k->op_type == OP_I_NCMP)
9266 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
9267 kid = cLISTOPo->op_first->op_sibling;
9268 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
9270 op_getmad(kid,o,'S'); /* then delete it */
9272 op_free(kid); /* then delete it */
9277 Perl_ck_split(pTHX_ OP *o)
9282 PERL_ARGS_ASSERT_CK_SPLIT;
9284 if (o->op_flags & OPf_STACKED)
9285 return no_fh_allowed(o);
9287 kid = cLISTOPo->op_first;
9288 if (kid->op_type != OP_NULL)
9289 Perl_croak(aTHX_ "panic: ck_split, type=%u", (unsigned) kid->op_type);
9290 kid = kid->op_sibling;
9291 op_free(cLISTOPo->op_first);
9293 cLISTOPo->op_first = kid;
9295 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
9296 cLISTOPo->op_last = kid; /* There was only one element previously */
9299 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
9300 OP * const sibl = kid->op_sibling;
9301 kid->op_sibling = 0;
9302 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0, 0);
9303 if (cLISTOPo->op_first == cLISTOPo->op_last)
9304 cLISTOPo->op_last = kid;
9305 cLISTOPo->op_first = kid;
9306 kid->op_sibling = sibl;
9309 kid->op_type = OP_PUSHRE;
9310 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
9312 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
9313 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
9314 "Use of /g modifier is meaningless in split");
9317 if (!kid->op_sibling)
9318 op_append_elem(OP_SPLIT, o, newDEFSVOP());
9320 kid = kid->op_sibling;
9323 if (!kid->op_sibling)
9324 op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
9325 assert(kid->op_sibling);
9327 kid = kid->op_sibling;
9330 if (kid->op_sibling)
9331 return too_many_arguments_pv(o,OP_DESC(o), 0);
9337 Perl_ck_join(pTHX_ OP *o)
9339 const OP * const kid = cLISTOPo->op_first->op_sibling;
9341 PERL_ARGS_ASSERT_CK_JOIN;
9343 if (kid && kid->op_type == OP_MATCH) {
9344 if (ckWARN(WARN_SYNTAX)) {
9345 const REGEXP *re = PM_GETRE(kPMOP);
9347 ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
9348 SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
9349 : newSVpvs_flags( "STRING", SVs_TEMP );
9350 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9351 "/%"SVf"/ should probably be written as \"%"SVf"\"",
9352 SVfARG(msg), SVfARG(msg));
9359 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
9361 Examines an op, which is expected to identify a subroutine at runtime,
9362 and attempts to determine at compile time which subroutine it identifies.
9363 This is normally used during Perl compilation to determine whether
9364 a prototype can be applied to a function call. I<cvop> is the op
9365 being considered, normally an C<rv2cv> op. A pointer to the identified
9366 subroutine is returned, if it could be determined statically, and a null
9367 pointer is returned if it was not possible to determine statically.
9369 Currently, the subroutine can be identified statically if the RV that the
9370 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
9371 A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
9372 suitable if the constant value must be an RV pointing to a CV. Details of
9373 this process may change in future versions of Perl. If the C<rv2cv> op
9374 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
9375 the subroutine statically: this flag is used to suppress compile-time
9376 magic on a subroutine call, forcing it to use default runtime behaviour.
9378 If I<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
9379 of a GV reference is modified. If a GV was examined and its CV slot was
9380 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
9381 If the op is not optimised away, and the CV slot is later populated with
9382 a subroutine having a prototype, that flag eventually triggers the warning
9383 "called too early to check prototype".
9385 If I<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
9386 of returning a pointer to the subroutine it returns a pointer to the
9387 GV giving the most appropriate name for the subroutine in this context.
9388 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
9389 (C<CvANON>) subroutine that is referenced through a GV it will be the
9390 referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
9391 A null pointer is returned as usual if there is no statically-determinable
9398 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
9403 PERL_ARGS_ASSERT_RV2CV_OP_CV;
9404 if (flags & ~(RV2CVOPCV_MARK_EARLY|RV2CVOPCV_RETURN_NAME_GV))
9405 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
9406 if (cvop->op_type != OP_RV2CV)
9408 if (cvop->op_private & OPpENTERSUB_AMPER)
9410 if (!(cvop->op_flags & OPf_KIDS))
9412 rvop = cUNOPx(cvop)->op_first;
9413 switch (rvop->op_type) {
9415 gv = cGVOPx_gv(rvop);
9418 if (flags & RV2CVOPCV_MARK_EARLY)
9419 rvop->op_private |= OPpEARLY_CV;
9424 SV *rv = cSVOPx_sv(rvop);
9434 if (SvTYPE((SV*)cv) != SVt_PVCV)
9436 if (flags & RV2CVOPCV_RETURN_NAME_GV) {
9437 if (!CvANON(cv) || !gv)
9446 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
9448 Performs the default fixup of the arguments part of an C<entersub>
9449 op tree. This consists of applying list context to each of the
9450 argument ops. This is the standard treatment used on a call marked
9451 with C<&>, or a method call, or a call through a subroutine reference,
9452 or any other call where the callee can't be identified at compile time,
9453 or a call where the callee has no prototype.
9459 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
9462 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
9463 aop = cUNOPx(entersubop)->op_first;
9464 if (!aop->op_sibling)
9465 aop = cUNOPx(aop)->op_first;
9466 for (aop = aop->op_sibling; aop->op_sibling; aop = aop->op_sibling) {
9467 if (!(PL_madskills && aop->op_type == OP_STUB)) {
9469 op_lvalue(aop, OP_ENTERSUB);
9476 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
9478 Performs the fixup of the arguments part of an C<entersub> op tree
9479 based on a subroutine prototype. This makes various modifications to
9480 the argument ops, from applying context up to inserting C<refgen> ops,
9481 and checking the number and syntactic types of arguments, as directed by
9482 the prototype. This is the standard treatment used on a subroutine call,
9483 not marked with C<&>, where the callee can be identified at compile time
9484 and has a prototype.
9486 I<protosv> supplies the subroutine prototype to be applied to the call.
9487 It may be a normal defined scalar, of which the string value will be used.
9488 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
9489 that has been cast to C<SV*>) which has a prototype. The prototype
9490 supplied, in whichever form, does not need to match the actual callee
9491 referenced by the op tree.
9493 If the argument ops disagree with the prototype, for example by having
9494 an unacceptable number of arguments, a valid op tree is returned anyway.
9495 The error is reflected in the parser state, normally resulting in a single
9496 exception at the top level of parsing which covers all the compilation
9497 errors that occurred. In the error message, the callee is referred to
9498 by the name defined by the I<namegv> parameter.
9504 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
9507 const char *proto, *proto_end;
9508 OP *aop, *prev, *cvop;
9511 I32 contextclass = 0;
9512 const char *e = NULL;
9513 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
9514 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
9515 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
9516 "flags=%lx", (unsigned long) SvFLAGS(protosv));
9517 if (SvTYPE(protosv) == SVt_PVCV)
9518 proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
9519 else proto = SvPV(protosv, proto_len);
9520 proto_end = proto + proto_len;
9521 aop = cUNOPx(entersubop)->op_first;
9522 if (!aop->op_sibling)
9523 aop = cUNOPx(aop)->op_first;
9525 aop = aop->op_sibling;
9526 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
9527 while (aop != cvop) {
9529 if (PL_madskills && aop->op_type == OP_STUB) {
9530 aop = aop->op_sibling;
9533 if (PL_madskills && aop->op_type == OP_NULL)
9534 o3 = ((UNOP*)aop)->op_first;
9538 if (proto >= proto_end)
9539 return too_many_arguments_sv(entersubop, gv_ename(namegv), 0);
9547 /* _ must be at the end */
9548 if (proto[1] && !strchr(";@%", proto[1]))
9563 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
9565 arg == 1 ? "block or sub {}" : "sub {}",
9566 gv_ename(namegv), 0, o3);
9569 /* '*' allows any scalar type, including bareword */
9572 if (o3->op_type == OP_RV2GV)
9573 goto wrapref; /* autoconvert GLOB -> GLOBref */
9574 else if (o3->op_type == OP_CONST)
9575 o3->op_private &= ~OPpCONST_STRICT;
9576 else if (o3->op_type == OP_ENTERSUB) {
9577 /* accidental subroutine, revert to bareword */
9578 OP *gvop = ((UNOP*)o3)->op_first;
9579 if (gvop && gvop->op_type == OP_NULL) {
9580 gvop = ((UNOP*)gvop)->op_first;
9582 for (; gvop->op_sibling; gvop = gvop->op_sibling)
9585 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
9586 (gvop = ((UNOP*)gvop)->op_first) &&
9587 gvop->op_type == OP_GV)
9589 GV * const gv = cGVOPx_gv(gvop);
9590 OP * const sibling = aop->op_sibling;
9591 SV * const n = newSVpvs("");
9593 OP * const oldaop = aop;
9597 gv_fullname4(n, gv, "", FALSE);
9598 aop = newSVOP(OP_CONST, 0, n);
9599 op_getmad(oldaop,aop,'O');
9600 prev->op_sibling = aop;
9601 aop->op_sibling = sibling;
9611 if (o3->op_type == OP_RV2AV ||
9612 o3->op_type == OP_PADAV ||
9613 o3->op_type == OP_RV2HV ||
9614 o3->op_type == OP_PADHV
9629 if (contextclass++ == 0) {
9630 e = strchr(proto, ']');
9631 if (!e || e == proto)
9640 const char *p = proto;
9641 const char *const end = proto;
9644 /* \[$] accepts any scalar lvalue */
9646 && Perl_op_lvalue_flags(aTHX_
9648 OP_READ, /* not entersub */
9651 bad_type_sv(arg, Perl_form(aTHX_ "one of %.*s",
9653 gv_ename(namegv), 0, o3);
9658 if (o3->op_type == OP_RV2GV)
9661 bad_type_sv(arg, "symbol", gv_ename(namegv), 0, o3);
9664 if (o3->op_type == OP_ENTERSUB)
9667 bad_type_sv(arg, "subroutine entry", gv_ename(namegv), 0,
9671 if (o3->op_type == OP_RV2SV ||
9672 o3->op_type == OP_PADSV ||
9673 o3->op_type == OP_HELEM ||
9674 o3->op_type == OP_AELEM)
9676 if (!contextclass) {
9677 /* \$ accepts any scalar lvalue */
9678 if (Perl_op_lvalue_flags(aTHX_
9680 OP_READ, /* not entersub */
9683 bad_type_sv(arg, "scalar", gv_ename(namegv), 0, o3);
9687 if (o3->op_type == OP_RV2AV ||
9688 o3->op_type == OP_PADAV)
9691 bad_type_sv(arg, "array", gv_ename(namegv), 0, o3);
9694 if (o3->op_type == OP_RV2HV ||
9695 o3->op_type == OP_PADHV)
9698 bad_type_sv(arg, "hash", gv_ename(namegv), 0, o3);
9702 OP* const kid = aop;
9703 OP* const sib = kid->op_sibling;
9704 kid->op_sibling = 0;
9705 aop = newUNOP(OP_REFGEN, 0, kid);
9706 aop->op_sibling = sib;
9707 prev->op_sibling = aop;
9709 if (contextclass && e) {
9724 SV* const tmpsv = sv_newmortal();
9725 gv_efullname3(tmpsv, namegv, NULL);
9726 Perl_croak(aTHX_ "Malformed prototype for %"SVf": %"SVf,
9727 SVfARG(tmpsv), SVfARG(protosv));
9731 op_lvalue(aop, OP_ENTERSUB);
9733 aop = aop->op_sibling;
9735 if (aop == cvop && *proto == '_') {
9736 /* generate an access to $_ */
9738 aop->op_sibling = prev->op_sibling;
9739 prev->op_sibling = aop; /* instead of cvop */
9741 if (!optional && proto_end > proto &&
9742 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
9743 return too_few_arguments_sv(entersubop, gv_ename(namegv), 0);
9748 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
9750 Performs the fixup of the arguments part of an C<entersub> op tree either
9751 based on a subroutine prototype or using default list-context processing.
9752 This is the standard treatment used on a subroutine call, not marked
9753 with C<&>, where the callee can be identified at compile time.
9755 I<protosv> supplies the subroutine prototype to be applied to the call,
9756 or indicates that there is no prototype. It may be a normal scalar,
9757 in which case if it is defined then the string value will be used
9758 as a prototype, and if it is undefined then there is no prototype.
9759 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
9760 that has been cast to C<SV*>), of which the prototype will be used if it
9761 has one. The prototype (or lack thereof) supplied, in whichever form,
9762 does not need to match the actual callee referenced by the op tree.
9764 If the argument ops disagree with the prototype, for example by having
9765 an unacceptable number of arguments, a valid op tree is returned anyway.
9766 The error is reflected in the parser state, normally resulting in a single
9767 exception at the top level of parsing which covers all the compilation
9768 errors that occurred. In the error message, the callee is referred to
9769 by the name defined by the I<namegv> parameter.
9775 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
9776 GV *namegv, SV *protosv)
9778 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
9779 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
9780 return ck_entersub_args_proto(entersubop, namegv, protosv);
9782 return ck_entersub_args_list(entersubop);
9786 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
9788 int opnum = SvTYPE(protosv) == SVt_PVCV ? 0 : (int)SvUV(protosv);
9789 OP *aop = cUNOPx(entersubop)->op_first;
9791 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
9795 if (!aop->op_sibling)
9796 aop = cUNOPx(aop)->op_first;
9797 aop = aop->op_sibling;
9798 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
9799 if (PL_madskills) while (aop != cvop && aop->op_type == OP_STUB) {
9800 aop = aop->op_sibling;
9803 (void)too_many_arguments_pv(entersubop, GvNAME(namegv), 0);
9805 op_free(entersubop);
9806 switch(GvNAME(namegv)[2]) {
9807 case 'F': return newSVOP(OP_CONST, 0,
9808 newSVpv(CopFILE(PL_curcop),0));
9809 case 'L': return newSVOP(
9812 "%"IVdf, (IV)CopLINE(PL_curcop)
9815 case 'P': return newSVOP(OP_CONST, 0,
9817 ? newSVhek(HvNAME_HEK(PL_curstash))
9828 bool seenarg = FALSE;
9830 if (!aop->op_sibling)
9831 aop = cUNOPx(aop)->op_first;
9834 aop = aop->op_sibling;
9835 prev->op_sibling = NULL;
9838 prev=cvop, cvop = cvop->op_sibling)
9840 if (PL_madskills && cvop->op_sibling
9841 && cvop->op_type != OP_STUB) seenarg = TRUE
9844 prev->op_sibling = NULL;
9845 flags = OPf_SPECIAL * !(cvop->op_private & OPpENTERSUB_NOPAREN);
9847 if (aop == cvop) aop = NULL;
9848 op_free(entersubop);
9850 if (opnum == OP_ENTEREVAL
9851 && GvNAMELEN(namegv)==9 && strnEQ(GvNAME(namegv), "evalbytes", 9))
9852 flags |= OPpEVAL_BYTES <<8;
9854 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
9856 case OA_BASEOP_OR_UNOP:
9858 return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
9862 if (!PL_madskills || seenarg)
9864 (void)too_many_arguments_pv(aop, GvNAME(namegv), 0);
9867 return opnum == OP_RUNCV
9868 ? newPVOP(OP_RUNCV,0,NULL)
9871 return convert(opnum,0,aop);
9879 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
9881 Retrieves the function that will be used to fix up a call to I<cv>.
9882 Specifically, the function is applied to an C<entersub> op tree for a
9883 subroutine call, not marked with C<&>, where the callee can be identified
9884 at compile time as I<cv>.
9886 The C-level function pointer is returned in I<*ckfun_p>, and an SV
9887 argument for it is returned in I<*ckobj_p>. The function is intended
9888 to be called in this manner:
9890 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
9892 In this call, I<entersubop> is a pointer to the C<entersub> op,
9893 which may be replaced by the check function, and I<namegv> is a GV
9894 supplying the name that should be used by the check function to refer
9895 to the callee of the C<entersub> op if it needs to emit any diagnostics.
9896 It is permitted to apply the check function in non-standard situations,
9897 such as to a call to a different subroutine or to a method call.
9899 By default, the function is
9900 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
9901 and the SV parameter is I<cv> itself. This implements standard
9902 prototype processing. It can be changed, for a particular subroutine,
9903 by L</cv_set_call_checker>.
9909 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
9912 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
9913 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
9915 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
9916 *ckobj_p = callmg->mg_obj;
9918 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
9924 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
9926 Sets the function that will be used to fix up a call to I<cv>.
9927 Specifically, the function is applied to an C<entersub> op tree for a
9928 subroutine call, not marked with C<&>, where the callee can be identified
9929 at compile time as I<cv>.
9931 The C-level function pointer is supplied in I<ckfun>, and an SV argument
9932 for it is supplied in I<ckobj>. The function is intended to be called
9935 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
9937 In this call, I<entersubop> is a pointer to the C<entersub> op,
9938 which may be replaced by the check function, and I<namegv> is a GV
9939 supplying the name that should be used by the check function to refer
9940 to the callee of the C<entersub> op if it needs to emit any diagnostics.
9941 It is permitted to apply the check function in non-standard situations,
9942 such as to a call to a different subroutine or to a method call.
9944 The current setting for a particular CV can be retrieved by
9945 L</cv_get_call_checker>.
9951 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
9953 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
9954 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
9955 if (SvMAGICAL((SV*)cv))
9956 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
9959 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
9960 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
9961 if (callmg->mg_flags & MGf_REFCOUNTED) {
9962 SvREFCNT_dec(callmg->mg_obj);
9963 callmg->mg_flags &= ~MGf_REFCOUNTED;
9965 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
9966 callmg->mg_obj = ckobj;
9967 if (ckobj != (SV*)cv) {
9968 SvREFCNT_inc_simple_void_NN(ckobj);
9969 callmg->mg_flags |= MGf_REFCOUNTED;
9971 callmg->mg_flags |= MGf_COPY;
9976 Perl_ck_subr(pTHX_ OP *o)
9982 PERL_ARGS_ASSERT_CK_SUBR;
9984 aop = cUNOPx(o)->op_first;
9985 if (!aop->op_sibling)
9986 aop = cUNOPx(aop)->op_first;
9987 aop = aop->op_sibling;
9988 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
9989 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
9990 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_RETURN_NAME_GV) : NULL;
9992 o->op_private &= ~1;
9993 o->op_private |= OPpENTERSUB_HASTARG;
9994 o->op_private |= (PL_hints & HINT_STRICT_REFS);
9995 if (PERLDB_SUB && PL_curstash != PL_debstash)
9996 o->op_private |= OPpENTERSUB_DB;
9997 if (cvop->op_type == OP_RV2CV) {
9998 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
10000 } else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
10001 if (aop->op_type == OP_CONST)
10002 aop->op_private &= ~OPpCONST_STRICT;
10003 else if (aop->op_type == OP_LIST) {
10004 OP * const sib = ((UNOP*)aop)->op_first->op_sibling;
10005 if (sib && sib->op_type == OP_CONST)
10006 sib->op_private &= ~OPpCONST_STRICT;
10011 return ck_entersub_args_list(o);
10013 Perl_call_checker ckfun;
10015 cv_get_call_checker(cv, &ckfun, &ckobj);
10016 return ckfun(aTHX_ o, namegv, ckobj);
10021 Perl_ck_svconst(pTHX_ OP *o)
10023 PERL_ARGS_ASSERT_CK_SVCONST;
10024 PERL_UNUSED_CONTEXT;
10025 SvREADONLY_on(cSVOPo->op_sv);
10030 Perl_ck_trunc(pTHX_ OP *o)
10032 PERL_ARGS_ASSERT_CK_TRUNC;
10034 if (o->op_flags & OPf_KIDS) {
10035 SVOP *kid = (SVOP*)cUNOPo->op_first;
10037 if (kid->op_type == OP_NULL)
10038 kid = (SVOP*)kid->op_sibling;
10039 if (kid && kid->op_type == OP_CONST &&
10040 (kid->op_private & (OPpCONST_BARE|OPpCONST_FOLDED))
10043 o->op_flags |= OPf_SPECIAL;
10044 kid->op_private &= ~OPpCONST_STRICT;
10051 Perl_ck_substr(pTHX_ OP *o)
10053 PERL_ARGS_ASSERT_CK_SUBSTR;
10056 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
10057 OP *kid = cLISTOPo->op_first;
10059 if (kid->op_type == OP_NULL)
10060 kid = kid->op_sibling;
10062 kid->op_flags |= OPf_MOD;
10069 Perl_ck_tell(pTHX_ OP *o)
10071 PERL_ARGS_ASSERT_CK_TELL;
10073 if (o->op_flags & OPf_KIDS) {
10074 OP *kid = cLISTOPo->op_first;
10075 if (kid->op_type == OP_NULL && kid->op_sibling) kid = kid->op_sibling;
10076 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
10082 Perl_ck_each(pTHX_ OP *o)
10085 OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
10086 const unsigned orig_type = o->op_type;
10087 const unsigned array_type = orig_type == OP_EACH ? OP_AEACH
10088 : orig_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
10089 const unsigned ref_type = orig_type == OP_EACH ? OP_REACH
10090 : orig_type == OP_KEYS ? OP_RKEYS : OP_RVALUES;
10092 PERL_ARGS_ASSERT_CK_EACH;
10095 switch (kid->op_type) {
10101 CHANGE_TYPE(o, array_type);
10104 if (kid->op_private == OPpCONST_BARE
10105 || !SvROK(cSVOPx_sv(kid))
10106 || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
10107 && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV )
10109 /* we let ck_fun handle it */
10112 CHANGE_TYPE(o, ref_type);
10116 /* if treating as a reference, defer additional checks to runtime */
10117 return o->op_type == ref_type ? o : ck_fun(o);
10121 Perl_ck_length(pTHX_ OP *o)
10123 PERL_ARGS_ASSERT_CK_LENGTH;
10127 if (ckWARN(WARN_SYNTAX)) {
10128 const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
10132 const bool hash = kid->op_type == OP_PADHV
10133 || kid->op_type == OP_RV2HV;
10134 switch (kid->op_type) {
10138 (GV *)PL_compcv, hash ? '%' : '@', kid->op_targ,
10144 if (cUNOPx(kid)->op_first->op_type != OP_GV) break;
10146 GV *gv = cGVOPx_gv(cUNOPx(kid)->op_first);
10148 name = varname(gv, hash?'%':'@', 0, NULL, 0, 1);
10155 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10156 "length() used on %"SVf" (did you mean \"scalar(%s%"SVf
10158 name, hash ? "keys " : "", name
10161 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10162 "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
10164 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10165 "length() used on @array (did you mean \"scalar(@array)\"?)");
10172 /* caller is supposed to assign the return to the
10173 container of the rep_op var */
10175 S_opt_scalarhv(pTHX_ OP *rep_op) {
10179 PERL_ARGS_ASSERT_OPT_SCALARHV;
10181 NewOp(1101, unop, 1, UNOP);
10182 unop->op_type = (OPCODE)OP_BOOLKEYS;
10183 unop->op_ppaddr = PL_ppaddr[OP_BOOLKEYS];
10184 unop->op_flags = (U8)(OPf_WANT_SCALAR | OPf_KIDS );
10185 unop->op_private = (U8)(1 | ((OPf_WANT_SCALAR | OPf_KIDS) >> 8));
10186 unop->op_first = rep_op;
10187 unop->op_next = rep_op->op_next;
10188 rep_op->op_next = (OP*)unop;
10189 rep_op->op_flags|=(OPf_REF | OPf_MOD);
10190 unop->op_sibling = rep_op->op_sibling;
10191 rep_op->op_sibling = NULL;
10192 /* unop->op_targ = pad_alloc(OP_BOOLKEYS, SVs_PADTMP); */
10193 if (rep_op->op_type == OP_PADHV) {
10194 rep_op->op_flags &= ~OPf_WANT_SCALAR;
10195 rep_op->op_flags |= OPf_WANT_LIST;
10200 /* Check for in place reverse and sort assignments like "@a = reverse @a"
10201 and modify the optree to make them work inplace */
10204 S_inplace_aassign(pTHX_ OP *o) {
10206 OP *modop, *modop_pushmark;
10208 OP *oleft, *oleft_pushmark;
10210 PERL_ARGS_ASSERT_INPLACE_AASSIGN;
10212 assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
10214 assert(cUNOPo->op_first->op_type == OP_NULL);
10215 modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
10216 assert(modop_pushmark->op_type == OP_PUSHMARK);
10217 modop = modop_pushmark->op_sibling;
10219 if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
10222 /* no other operation except sort/reverse */
10223 if (modop->op_sibling)
10226 assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
10227 if (!(oright = cUNOPx(modop)->op_first->op_sibling)) return;
10229 if (modop->op_flags & OPf_STACKED) {
10230 /* skip sort subroutine/block */
10231 assert(oright->op_type == OP_NULL);
10232 oright = oright->op_sibling;
10235 assert(cUNOPo->op_first->op_sibling->op_type == OP_NULL);
10236 oleft_pushmark = cUNOPx(cUNOPo->op_first->op_sibling)->op_first;
10237 assert(oleft_pushmark->op_type == OP_PUSHMARK);
10238 oleft = oleft_pushmark->op_sibling;
10240 /* Check the lhs is an array */
10242 (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
10243 || oleft->op_sibling
10244 || (oleft->op_private & OPpLVAL_INTRO)
10248 /* Only one thing on the rhs */
10249 if (oright->op_sibling)
10252 /* check the array is the same on both sides */
10253 if (oleft->op_type == OP_RV2AV) {
10254 if (oright->op_type != OP_RV2AV
10255 || !cUNOPx(oright)->op_first
10256 || cUNOPx(oright)->op_first->op_type != OP_GV
10257 || cUNOPx(oleft )->op_first->op_type != OP_GV
10258 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
10259 cGVOPx_gv(cUNOPx(oright)->op_first)
10263 else if (oright->op_type != OP_PADAV
10264 || oright->op_targ != oleft->op_targ
10268 /* This actually is an inplace assignment */
10270 modop->op_private |= OPpSORT_INPLACE;
10272 /* transfer MODishness etc from LHS arg to RHS arg */
10273 oright->op_flags = oleft->op_flags;
10275 /* remove the aassign op and the lhs */
10277 op_null(oleft_pushmark);
10278 if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
10279 op_null(cUNOPx(oleft)->op_first);
10283 #define MAX_DEFERRED 4
10287 if (defer_ix == (MAX_DEFERRED-1)) { \
10288 CALL_RPEEP(defer_queue[defer_base]); \
10289 defer_base = (defer_base + 1) % MAX_DEFERRED; \
10292 defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = o; \
10295 /* A peephole optimizer. We visit the ops in the order they're to execute.
10296 * See the comments at the top of this file for more details about when
10297 * peep() is called */
10300 Perl_rpeep(pTHX_ register OP *o)
10303 register OP* oldop = NULL;
10304 OP* defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
10305 int defer_base = 0;
10308 if (!o || o->op_opt)
10312 SAVEVPTR(PL_curcop);
10313 for (;; o = o->op_next) {
10314 if (o && o->op_opt)
10317 while (defer_ix >= 0)
10318 CALL_RPEEP(defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED]);
10322 /* By default, this op has now been optimised. A couple of cases below
10323 clear this again. */
10326 switch (o->op_type) {
10328 PL_curcop = ((COP*)o); /* for warnings */
10331 PL_curcop = ((COP*)o); /* for warnings */
10333 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
10334 to carry two labels. For now, take the easier option, and skip
10335 this optimisation if the first NEXTSTATE has a label. */
10336 if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
10337 OP *nextop = o->op_next;
10338 while (nextop && nextop->op_type == OP_NULL)
10339 nextop = nextop->op_next;
10341 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
10342 COP *firstcop = (COP *)o;
10343 COP *secondcop = (COP *)nextop;
10344 /* We want the COP pointed to by o (and anything else) to
10345 become the next COP down the line. */
10346 cop_free(firstcop);
10348 firstcop->op_next = secondcop->op_next;
10350 /* Now steal all its pointers, and duplicate the other
10352 firstcop->cop_line = secondcop->cop_line;
10353 #ifdef USE_ITHREADS
10354 firstcop->cop_stashoff = secondcop->cop_stashoff;
10355 firstcop->cop_file = secondcop->cop_file;
10357 firstcop->cop_stash = secondcop->cop_stash;
10358 firstcop->cop_filegv = secondcop->cop_filegv;
10360 firstcop->cop_hints = secondcop->cop_hints;
10361 firstcop->cop_seq = secondcop->cop_seq;
10362 firstcop->cop_warnings = secondcop->cop_warnings;
10363 firstcop->cop_hints_hash = secondcop->cop_hints_hash;
10365 #ifdef USE_ITHREADS
10366 secondcop->cop_stashoff = 0;
10367 secondcop->cop_file = NULL;
10369 secondcop->cop_stash = NULL;
10370 secondcop->cop_filegv = NULL;
10372 secondcop->cop_warnings = NULL;
10373 secondcop->cop_hints_hash = NULL;
10375 /* If we use op_null(), and hence leave an ex-COP, some
10376 warnings are misreported. For example, the compile-time
10377 error in 'use strict; no strict refs;' */
10378 secondcop->op_type = OP_NULL;
10379 secondcop->op_ppaddr = PL_ppaddr[OP_NULL];
10385 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
10386 if (o->op_next->op_private & OPpTARGET_MY) {
10387 if (o->op_flags & OPf_STACKED) /* chained concats */
10388 break; /* ignore_optimization */
10390 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
10391 o->op_targ = o->op_next->op_targ;
10392 o->op_next->op_targ = 0;
10393 o->op_private |= OPpTARGET_MY;
10396 op_null(o->op_next);
10400 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
10401 break; /* Scalar stub must produce undef. List stub is noop */
10405 if (o->op_targ == OP_NEXTSTATE
10406 || o->op_targ == OP_DBSTATE)
10408 PL_curcop = ((COP*)o);
10410 /* XXX: We avoid setting op_seq here to prevent later calls
10411 to rpeep() from mistakenly concluding that optimisation
10412 has already occurred. This doesn't fix the real problem,
10413 though (See 20010220.007). AMS 20010719 */
10414 /* op_seq functionality is now replaced by op_opt */
10421 if (oldop && o->op_next) {
10422 oldop->op_next = o->op_next;
10430 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
10431 OP* const pop = (o->op_type == OP_PADAV) ?
10432 o->op_next : o->op_next->op_next;
10434 if (pop && pop->op_type == OP_CONST &&
10435 ((PL_op = pop->op_next)) &&
10436 pop->op_next->op_type == OP_AELEM &&
10437 !(pop->op_next->op_private &
10438 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
10439 (i = SvIV(((SVOP*)pop)->op_sv)) <= 255 && i >= 0)
10442 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
10443 no_bareword_allowed(pop);
10444 if (o->op_type == OP_GV)
10445 op_null(o->op_next);
10446 op_null(pop->op_next);
10448 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
10449 o->op_next = pop->op_next->op_next;
10450 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
10451 o->op_private = (U8)i;
10452 if (o->op_type == OP_GV) {
10455 o->op_type = OP_AELEMFAST;
10458 o->op_type = OP_AELEMFAST_LEX;
10463 if (o->op_next->op_type == OP_RV2SV) {
10464 if (!(o->op_next->op_private & OPpDEREF)) {
10465 op_null(o->op_next);
10466 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
10468 o->op_next = o->op_next->op_next;
10469 o->op_type = OP_GVSV;
10470 o->op_ppaddr = PL_ppaddr[OP_GVSV];
10473 else if (o->op_next->op_type == OP_READLINE
10474 && o->op_next->op_next->op_type == OP_CONCAT
10475 && (o->op_next->op_next->op_flags & OPf_STACKED))
10477 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
10478 o->op_type = OP_RCATLINE;
10479 o->op_flags |= OPf_STACKED;
10480 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
10481 op_null(o->op_next->op_next);
10482 op_null(o->op_next);
10492 fop = cUNOP->op_first;
10500 fop = cLOGOP->op_first;
10501 sop = fop->op_sibling;
10502 while (cLOGOP->op_other->op_type == OP_NULL)
10503 cLOGOP->op_other = cLOGOP->op_other->op_next;
10504 while (o->op_next && ( o->op_type == o->op_next->op_type
10505 || o->op_next->op_type == OP_NULL))
10506 o->op_next = o->op_next->op_next;
10507 DEFER(cLOGOP->op_other);
10511 if ((fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
10513 (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV)
10518 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
10519 while (nop && nop->op_next) {
10520 switch (nop->op_next->op_type) {
10525 lop = nop = nop->op_next;
10528 nop = nop->op_next;
10536 if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
10537 if (fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
10538 cLOGOP->op_first = opt_scalarhv(fop);
10539 if (sop && (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV))
10540 cLOGOP->op_first->op_sibling = opt_scalarhv(sop);
10556 while (cLOGOP->op_other->op_type == OP_NULL)
10557 cLOGOP->op_other = cLOGOP->op_other->op_next;
10558 DEFER(cLOGOP->op_other);
10563 while (cLOOP->op_redoop->op_type == OP_NULL)
10564 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
10565 while (cLOOP->op_nextop->op_type == OP_NULL)
10566 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
10567 while (cLOOP->op_lastop->op_type == OP_NULL)
10568 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
10569 /* a while(1) loop doesn't have an op_next that escapes the
10570 * loop, so we have to explicitly follow the op_lastop to
10571 * process the rest of the code */
10572 DEFER(cLOOP->op_lastop);
10576 assert(!(cPMOP->op_pmflags & PMf_ONCE));
10577 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
10578 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
10579 cPMOP->op_pmstashstartu.op_pmreplstart
10580 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
10581 DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
10587 if (o->op_flags & OPf_STACKED) {
10589 cUNOPx(cLISTOP->op_first->op_sibling)->op_first;
10590 if (kid->op_type == OP_SCOPE
10591 || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE))
10592 DEFER(kLISTOP->op_first);
10595 /* check that RHS of sort is a single plain array */
10596 oright = cUNOPo->op_first;
10597 if (!oright || oright->op_type != OP_PUSHMARK)
10600 if (o->op_private & OPpSORT_INPLACE)
10603 /* reverse sort ... can be optimised. */
10604 if (!cUNOPo->op_sibling) {
10605 /* Nothing follows us on the list. */
10606 OP * const reverse = o->op_next;
10608 if (reverse->op_type == OP_REVERSE &&
10609 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
10610 OP * const pushmark = cUNOPx(reverse)->op_first;
10611 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
10612 && (cUNOPx(pushmark)->op_sibling == o)) {
10613 /* reverse -> pushmark -> sort */
10614 o->op_private |= OPpSORT_REVERSE;
10616 pushmark->op_next = oright->op_next;
10626 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
10628 LISTOP *enter, *exlist;
10630 if (o->op_private & OPpSORT_INPLACE)
10633 enter = (LISTOP *) o->op_next;
10636 if (enter->op_type == OP_NULL) {
10637 enter = (LISTOP *) enter->op_next;
10641 /* for $a (...) will have OP_GV then OP_RV2GV here.
10642 for (...) just has an OP_GV. */
10643 if (enter->op_type == OP_GV) {
10644 gvop = (OP *) enter;
10645 enter = (LISTOP *) enter->op_next;
10648 if (enter->op_type == OP_RV2GV) {
10649 enter = (LISTOP *) enter->op_next;
10655 if (enter->op_type != OP_ENTERITER)
10658 iter = enter->op_next;
10659 if (!iter || iter->op_type != OP_ITER)
10662 expushmark = enter->op_first;
10663 if (!expushmark || expushmark->op_type != OP_NULL
10664 || expushmark->op_targ != OP_PUSHMARK)
10667 exlist = (LISTOP *) expushmark->op_sibling;
10668 if (!exlist || exlist->op_type != OP_NULL
10669 || exlist->op_targ != OP_LIST)
10672 if (exlist->op_last != o) {
10673 /* Mmm. Was expecting to point back to this op. */
10676 theirmark = exlist->op_first;
10677 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
10680 if (theirmark->op_sibling != o) {
10681 /* There's something between the mark and the reverse, eg
10682 for (1, reverse (...))
10687 ourmark = ((LISTOP *)o)->op_first;
10688 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
10691 ourlast = ((LISTOP *)o)->op_last;
10692 if (!ourlast || ourlast->op_next != o)
10695 rv2av = ourmark->op_sibling;
10696 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
10697 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
10698 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
10699 /* We're just reversing a single array. */
10700 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
10701 enter->op_flags |= OPf_STACKED;
10704 /* We don't have control over who points to theirmark, so sacrifice
10706 theirmark->op_next = ourmark->op_next;
10707 theirmark->op_flags = ourmark->op_flags;
10708 ourlast->op_next = gvop ? gvop : (OP *) enter;
10711 enter->op_private |= OPpITER_REVERSED;
10712 iter->op_private |= OPpITER_REVERSED;
10719 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
10720 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
10725 if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)) {
10727 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
10729 sv = newRV((SV *)PL_compcv);
10733 o->op_type = OP_CONST;
10734 o->op_ppaddr = PL_ppaddr[OP_CONST];
10735 o->op_flags |= OPf_SPECIAL;
10736 cSVOPo->op_sv = sv;
10741 if (OP_GIMME(o,0) == G_VOID) {
10742 OP *right = cBINOP->op_first;
10744 OP *left = right->op_sibling;
10745 if (left->op_type == OP_SUBSTR
10746 && (left->op_private & 7) < 4) {
10748 cBINOP->op_first = left;
10749 right->op_sibling =
10750 cBINOPx(left)->op_first->op_sibling;
10751 cBINOPx(left)->op_first->op_sibling = right;
10752 left->op_private |= OPpSUBSTR_REPL_FIRST;
10754 (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
10761 Perl_cpeep_t cpeep =
10762 XopENTRY(Perl_custom_op_xop(aTHX_ o), xop_peep);
10764 cpeep(aTHX_ o, oldop);
10775 Perl_peep(pTHX_ register OP *o)
10781 =head1 Custom Operators
10783 =for apidoc Ao||custom_op_xop
10784 Return the XOP structure for a given custom op. This function should be
10785 considered internal to OP_NAME and the other access macros: use them instead.
10791 Perl_custom_op_xop(pTHX_ const OP *o)
10797 static const XOP xop_null = { 0, 0, 0, 0, 0 };
10799 PERL_ARGS_ASSERT_CUSTOM_OP_XOP;
10800 assert(o->op_type == OP_CUSTOM);
10802 /* This is wrong. It assumes a function pointer can be cast to IV,
10803 * which isn't guaranteed, but this is what the old custom OP code
10804 * did. In principle it should be safer to Copy the bytes of the
10805 * pointer into a PV: since the new interface is hidden behind
10806 * functions, this can be changed later if necessary. */
10807 /* Change custom_op_xop if this ever happens */
10808 keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
10811 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
10813 /* assume noone will have just registered a desc */
10814 if (!he && PL_custom_op_names &&
10815 (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
10820 /* XXX does all this need to be shared mem? */
10821 Newxz(xop, 1, XOP);
10822 pv = SvPV(HeVAL(he), l);
10823 XopENTRY_set(xop, xop_name, savepvn(pv, l));
10824 if (PL_custom_op_descs &&
10825 (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
10827 pv = SvPV(HeVAL(he), l);
10828 XopENTRY_set(xop, xop_desc, savepvn(pv, l));
10830 Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
10834 if (!he) return &xop_null;
10836 xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
10841 =for apidoc Ao||custom_op_register
10842 Register a custom op. See L<perlguts/"Custom Operators">.
10848 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
10852 PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
10854 /* see the comment in custom_op_xop */
10855 keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
10857 if (!PL_custom_ops)
10858 PL_custom_ops = newHV();
10860 if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
10861 Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
10865 =head1 Functions in file op.c
10867 =for apidoc core_prototype
10868 This function assigns the prototype of the named core function to C<sv>, or
10869 to a new mortal SV if C<sv> is NULL. It returns the modified C<sv>, or
10870 NULL if the core function has no prototype. C<code> is a code as returned
10871 by C<keyword()>. It must not be equal to 0 or -KEY_CORE.
10877 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
10880 int i = 0, n = 0, seen_question = 0, defgv = 0;
10882 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
10883 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
10884 bool nullret = FALSE;
10886 PERL_ARGS_ASSERT_CORE_PROTOTYPE;
10888 assert (code && code != -KEY_CORE);
10890 if (!sv) sv = sv_newmortal();
10892 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
10894 switch (code < 0 ? -code : code) {
10895 case KEY_and : case KEY_chop: case KEY_chomp:
10896 case KEY_cmp : case KEY_defined: case KEY_delete: case KEY_exec :
10897 case KEY_exists: case KEY_eq : case KEY_ge : case KEY_goto :
10898 case KEY_grep : case KEY_gt : case KEY_last : case KEY_le :
10899 case KEY_lt : case KEY_map : case KEY_ne : case KEY_next :
10900 case KEY_or : case KEY_print : case KEY_printf: case KEY_qr :
10901 case KEY_redo : case KEY_require: case KEY_return: case KEY_say :
10902 case KEY_select: case KEY_sort : case KEY_split : case KEY_system:
10903 case KEY_x : case KEY_xor :
10904 if (!opnum) return NULL; nullret = TRUE; goto findopnum;
10905 case KEY_glob: retsetpvs("_;", OP_GLOB);
10906 case KEY_keys: retsetpvs("+", OP_KEYS);
10907 case KEY_values: retsetpvs("+", OP_VALUES);
10908 case KEY_each: retsetpvs("+", OP_EACH);
10909 case KEY_push: retsetpvs("+@", OP_PUSH);
10910 case KEY_unshift: retsetpvs("+@", OP_UNSHIFT);
10911 case KEY_pop: retsetpvs(";+", OP_POP);
10912 case KEY_shift: retsetpvs(";+", OP_SHIFT);
10913 case KEY_pos: retsetpvs(";\\[$*]", OP_POS);
10915 retsetpvs("+;$$@", OP_SPLICE);
10916 case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
10918 case KEY_evalbytes:
10919 name = "entereval"; break;
10927 while (i < MAXO) { /* The slow way. */
10928 if (strEQ(name, PL_op_name[i])
10929 || strEQ(name, PL_op_desc[i]))
10931 if (nullret) { assert(opnum); *opnum = i; return NULL; }
10938 defgv = PL_opargs[i] & OA_DEFGV;
10939 oa = PL_opargs[i] >> OASHIFT;
10941 if (oa & OA_OPTIONAL && !seen_question && (
10942 !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
10947 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
10948 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
10949 /* But globs are already references (kinda) */
10950 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
10954 if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
10955 && !scalar_mod_type(NULL, i)) {
10960 if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
10964 else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
10965 if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
10966 str[n-1] = '_'; defgv = 0;
10970 if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
10972 sv_setpvn(sv, str, n - 1);
10973 if (opnum) *opnum = i;
10978 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
10981 OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
10984 PERL_ARGS_ASSERT_CORESUB_OP;
10988 return op_append_elem(OP_LINESEQ,
10991 newSVOP(OP_CONST, 0, newSViv(-code % 3)),
10995 case OP_SELECT: /* which represents OP_SSELECT as well */
11000 newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
11001 newSVOP(OP_CONST, 0, newSVuv(1))
11003 coresub_op(newSVuv((UV)OP_SSELECT), 0,
11005 coresub_op(coreargssv, 0, OP_SELECT)
11009 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
11011 return op_append_elem(
11014 opnum == OP_WANTARRAY || opnum == OP_RUNCV
11015 ? OPpOFFBYONE << 8 : 0)
11017 case OA_BASEOP_OR_UNOP:
11018 if (opnum == OP_ENTEREVAL) {
11019 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
11020 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
11022 else o = newUNOP(opnum,0,argop);
11023 if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
11026 if (is_handle_constructor(o, 1))
11027 argop->op_private |= OPpCOREARGS_DEREF1;
11028 if (scalar_mod_type(NULL, opnum))
11029 argop->op_private |= OPpCOREARGS_SCALARMOD;
11033 o = convert(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
11034 if (is_handle_constructor(o, 2))
11035 argop->op_private |= OPpCOREARGS_DEREF2;
11036 if (opnum == OP_SUBSTR) {
11037 o->op_private |= OPpMAYBE_LVSUB;
11046 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
11047 SV * const *new_const_svp)
11049 const char *hvname;
11050 bool is_const = !!CvCONST(old_cv);
11051 SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
11053 PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
11055 if (is_const && new_const_svp && old_const_sv == *new_const_svp)
11057 /* They are 2 constant subroutines generated from
11058 the same constant. This probably means that
11059 they are really the "same" proxy subroutine
11060 instantiated in 2 places. Most likely this is
11061 when a constant is exported twice. Don't warn.
11064 (ckWARN(WARN_REDEFINE)
11066 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
11067 && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
11068 && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
11069 strEQ(hvname, "autouse"))
11073 && ckWARN_d(WARN_REDEFINE)
11074 && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
11077 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
11079 ? "Constant subroutine %"SVf" redefined"
11080 : "Subroutine %"SVf" redefined",
11085 =head1 Hook manipulation
11087 These functions provide convenient and thread-safe means of manipulating
11094 =for apidoc Am|void|wrap_op_checker|Optype opcode|Perl_check_t new_checker|Perl_check_t *old_checker_p
11096 Puts a C function into the chain of check functions for a specified op
11097 type. This is the preferred way to manipulate the L</PL_check> array.
11098 I<opcode> specifies which type of op is to be affected. I<new_checker>
11099 is a pointer to the C function that is to be added to that opcode's
11100 check chain, and I<old_checker_p> points to the storage location where a
11101 pointer to the next function in the chain will be stored. The value of
11102 I<new_pointer> is written into the L</PL_check> array, while the value
11103 previously stored there is written to I<*old_checker_p>.
11105 L</PL_check> is global to an entire process, and a module wishing to
11106 hook op checking may find itself invoked more than once per process,
11107 typically in different threads. To handle that situation, this function
11108 is idempotent. The location I<*old_checker_p> must initially (once
11109 per process) contain a null pointer. A C variable of static duration
11110 (declared at file scope, typically also marked C<static> to give
11111 it internal linkage) will be implicitly initialised appropriately,
11112 if it does not have an explicit initialiser. This function will only
11113 actually modify the check chain if it finds I<*old_checker_p> to be null.
11114 This function is also thread safe on the small scale. It uses appropriate
11115 locking to avoid race conditions in accessing L</PL_check>.
11117 When this function is called, the function referenced by I<new_checker>
11118 must be ready to be called, except for I<*old_checker_p> being unfilled.
11119 In a threading situation, I<new_checker> may be called immediately,
11120 even before this function has returned. I<*old_checker_p> will always
11121 be appropriately set before I<new_checker> is called. If I<new_checker>
11122 decides not to do anything special with an op that it is given (which
11123 is the usual case for most uses of op check hooking), it must chain the
11124 check function referenced by I<*old_checker_p>.
11126 If you want to influence compilation of calls to a specific subroutine,
11127 then use L</cv_set_call_checker> rather than hooking checking of all
11134 Perl_wrap_op_checker(pTHX_ Optype opcode,
11135 Perl_check_t new_checker, Perl_check_t *old_checker_p)
11139 PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
11140 if (*old_checker_p) return;
11141 OP_CHECK_MUTEX_LOCK;
11142 if (!*old_checker_p) {
11143 *old_checker_p = PL_check[opcode];
11144 PL_check[opcode] = new_checker;
11146 OP_CHECK_MUTEX_UNLOCK;
11151 /* Efficient sub that returns a constant scalar value. */
11153 const_sv_xsub(pTHX_ CV* cv)
11157 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
11161 /* diag_listed_as: SKIPME */
11162 Perl_croak(aTHX_ "usage: %s::%s()",
11163 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
11176 * c-indentation-style: bsd
11177 * c-basic-offset: 4
11178 * indent-tabs-mode: nil
11181 * ex: set ts=8 sts=4 sw=4 et: