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) {
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 SV *useless_sv = NULL;
1169 const char* useless = NULL;
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("");
1371 = Perl_newSVpvf(aTHX_
1373 pv_pretty(dsv, maybe_macro,
1374 SvCUR(sv), 32, NULL, NULL,
1376 | PERL_PV_ESCAPE_NOCLEAR
1377 | PERL_PV_ESCAPE_UNI_DETECT));
1381 else if (SvOK(sv)) {
1382 useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", sv);
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)
1511 /* mortalise it, in case warnings are fatal. */
1512 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
1513 "Useless use of %"SVf" in void context",
1514 sv_2mortal(useless_sv));
1517 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
1518 "Useless use of %s in void context",
1525 S_listkids(pTHX_ OP *o)
1527 if (o && o->op_flags & OPf_KIDS) {
1529 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1536 Perl_list(pTHX_ OP *o)
1541 /* assumes no premature commitment */
1542 if (!o || (o->op_flags & OPf_WANT)
1543 || (PL_parser && PL_parser->error_count)
1544 || o->op_type == OP_RETURN)
1549 if ((o->op_private & OPpTARGET_MY)
1550 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1552 return o; /* As if inside SASSIGN */
1555 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1557 switch (o->op_type) {
1560 list(cBINOPo->op_first);
1565 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1573 if (!(o->op_flags & OPf_KIDS))
1575 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1576 list(cBINOPo->op_first);
1577 return gen_constant_list(o);
1584 kid = cLISTOPo->op_first;
1586 kid = kid->op_sibling;
1589 OP *sib = kid->op_sibling;
1590 if (sib && kid->op_type != OP_LEAVEWHEN)
1596 PL_curcop = &PL_compiling;
1600 kid = cLISTOPo->op_first;
1607 S_scalarseq(pTHX_ OP *o)
1611 const OPCODE type = o->op_type;
1613 if (type == OP_LINESEQ || type == OP_SCOPE ||
1614 type == OP_LEAVE || type == OP_LEAVETRY)
1617 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1618 if (kid->op_sibling) {
1622 PL_curcop = &PL_compiling;
1624 o->op_flags &= ~OPf_PARENS;
1625 if (PL_hints & HINT_BLOCK_SCOPE)
1626 o->op_flags |= OPf_PARENS;
1629 o = newOP(OP_STUB, 0);
1634 S_modkids(pTHX_ OP *o, I32 type)
1636 if (o && o->op_flags & OPf_KIDS) {
1638 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1639 op_lvalue(kid, type);
1645 =for apidoc finalize_optree
1647 This function finalizes the optree. Should be called directly after
1648 the complete optree is built. It does some additional
1649 checking which can't be done in the normal ck_xxx functions and makes
1650 the tree thread-safe.
1655 Perl_finalize_optree(pTHX_ OP* o)
1657 PERL_ARGS_ASSERT_FINALIZE_OPTREE;
1660 SAVEVPTR(PL_curcop);
1668 S_finalize_op(pTHX_ OP* o)
1670 PERL_ARGS_ASSERT_FINALIZE_OP;
1672 #if defined(PERL_MAD) && defined(USE_ITHREADS)
1674 /* Make sure mad ops are also thread-safe */
1675 MADPROP *mp = o->op_madprop;
1677 if (mp->mad_type == MAD_OP && mp->mad_vlen) {
1678 OP *prop_op = (OP *) mp->mad_val;
1679 /* We only need "Relocate sv to the pad for thread safety.", but this
1680 easiest way to make sure it traverses everything */
1681 if (prop_op->op_type == OP_CONST)
1682 cSVOPx(prop_op)->op_private &= ~OPpCONST_STRICT;
1683 finalize_op(prop_op);
1690 switch (o->op_type) {
1693 PL_curcop = ((COP*)o); /* for warnings */
1697 && (o->op_sibling->op_type == OP_NEXTSTATE || o->op_sibling->op_type == OP_DBSTATE)
1698 && ckWARN(WARN_SYNTAX))
1700 if (o->op_sibling->op_sibling) {
1701 const OPCODE type = o->op_sibling->op_sibling->op_type;
1702 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
1703 const line_t oldline = CopLINE(PL_curcop);
1704 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_sibling));
1705 Perl_warner(aTHX_ packWARN(WARN_EXEC),
1706 "Statement unlikely to be reached");
1707 Perl_warner(aTHX_ packWARN(WARN_EXEC),
1708 "\t(Maybe you meant system() when you said exec()?)\n");
1709 CopLINE_set(PL_curcop, oldline);
1716 if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
1717 GV * const gv = cGVOPo_gv;
1718 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
1719 /* XXX could check prototype here instead of just carping */
1720 SV * const sv = sv_newmortal();
1721 gv_efullname3(sv, gv, NULL);
1722 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
1723 "%"SVf"() called too early to check prototype",
1730 if (cSVOPo->op_private & OPpCONST_STRICT)
1731 no_bareword_allowed(o);
1735 case OP_METHOD_NAMED:
1736 /* Relocate sv to the pad for thread safety.
1737 * Despite being a "constant", the SV is written to,
1738 * for reference counts, sv_upgrade() etc. */
1739 if (cSVOPo->op_sv) {
1740 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
1741 if (o->op_type != OP_METHOD_NAMED &&
1742 (SvPADTMP(cSVOPo->op_sv) || SvPADMY(cSVOPo->op_sv)))
1744 /* If op_sv is already a PADTMP/MY then it is being used by
1745 * some pad, so make a copy. */
1746 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
1747 SvREADONLY_on(PAD_SVl(ix));
1748 SvREFCNT_dec(cSVOPo->op_sv);
1750 else if (o->op_type != OP_METHOD_NAMED
1751 && cSVOPo->op_sv == &PL_sv_undef) {
1752 /* PL_sv_undef is hack - it's unsafe to store it in the
1753 AV that is the pad, because av_fetch treats values of
1754 PL_sv_undef as a "free" AV entry and will merrily
1755 replace them with a new SV, causing pad_alloc to think
1756 that this pad slot is free. (When, clearly, it is not)
1758 SvOK_off(PAD_SVl(ix));
1759 SvPADTMP_on(PAD_SVl(ix));
1760 SvREADONLY_on(PAD_SVl(ix));
1763 SvREFCNT_dec(PAD_SVl(ix));
1764 SvPADTMP_on(cSVOPo->op_sv);
1765 PAD_SETSV(ix, cSVOPo->op_sv);
1766 /* XXX I don't know how this isn't readonly already. */
1767 SvREADONLY_on(PAD_SVl(ix));
1769 cSVOPo->op_sv = NULL;
1780 const char *key = NULL;
1783 if (((BINOP*)o)->op_last->op_type != OP_CONST)
1786 /* Make the CONST have a shared SV */
1787 svp = cSVOPx_svp(((BINOP*)o)->op_last);
1788 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv))
1789 && SvTYPE(sv) < SVt_PVMG && !SvROK(sv)) {
1790 key = SvPV_const(sv, keylen);
1791 lexname = newSVpvn_share(key,
1792 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
1798 if ((o->op_private & (OPpLVAL_INTRO)))
1801 rop = (UNOP*)((BINOP*)o)->op_first;
1802 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
1804 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
1805 if (!SvPAD_TYPED(lexname))
1807 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
1808 if (!fields || !GvHV(*fields))
1810 key = SvPV_const(*svp, keylen);
1811 if (!hv_fetch(GvHV(*fields), key,
1812 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) {
1813 Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
1814 "in variable %"SVf" of type %"HEKf,
1815 SVfARG(*svp), SVfARG(lexname),
1816 HEKfARG(HvNAME_HEK(SvSTASH(lexname))));
1828 SVOP *first_key_op, *key_op;
1830 if ((o->op_private & (OPpLVAL_INTRO))
1831 /* I bet there's always a pushmark... */
1832 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
1833 /* hmmm, no optimization if list contains only one key. */
1835 rop = (UNOP*)((LISTOP*)o)->op_last;
1836 if (rop->op_type != OP_RV2HV)
1838 if (rop->op_first->op_type == OP_PADSV)
1839 /* @$hash{qw(keys here)} */
1840 rop = (UNOP*)rop->op_first;
1842 /* @{$hash}{qw(keys here)} */
1843 if (rop->op_first->op_type == OP_SCOPE
1844 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
1846 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
1852 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
1853 if (!SvPAD_TYPED(lexname))
1855 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
1856 if (!fields || !GvHV(*fields))
1858 /* Again guessing that the pushmark can be jumped over.... */
1859 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
1860 ->op_first->op_sibling;
1861 for (key_op = first_key_op; key_op;
1862 key_op = (SVOP*)key_op->op_sibling) {
1863 if (key_op->op_type != OP_CONST)
1865 svp = cSVOPx_svp(key_op);
1866 key = SvPV_const(*svp, keylen);
1867 if (!hv_fetch(GvHV(*fields), key,
1868 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) {
1869 Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
1870 "in variable %"SVf" of type %"HEKf,
1871 SVfARG(*svp), SVfARG(lexname),
1872 HEKfARG(HvNAME_HEK(SvSTASH(lexname))));
1878 if (cPMOPo->op_pmreplrootu.op_pmreplroot)
1879 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
1886 if (o->op_flags & OPf_KIDS) {
1888 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1894 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
1896 Propagate lvalue ("modifiable") context to an op and its children.
1897 I<type> represents the context type, roughly based on the type of op that
1898 would do the modifying, although C<local()> is represented by OP_NULL,
1899 because it has no op type of its own (it is signalled by a flag on
1902 This function detects things that can't be modified, such as C<$x+1>, and
1903 generates errors for them. For example, C<$x+1 = 2> would cause it to be
1904 called with an op of type OP_ADD and a C<type> argument of OP_SASSIGN.
1906 It also flags things that need to behave specially in an lvalue context,
1907 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
1913 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
1917 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1920 if (!o || (PL_parser && PL_parser->error_count))
1923 if ((o->op_private & OPpTARGET_MY)
1924 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1929 assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
1931 if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
1933 switch (o->op_type) {
1938 if ((o->op_flags & OPf_PARENS) || PL_madskills)
1942 if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
1943 !(o->op_flags & OPf_STACKED)) {
1944 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1945 /* Both ENTERSUB and RV2CV use this bit, but for different pur-
1946 poses, so we need it clear. */
1947 o->op_private &= ~1;
1948 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1949 assert(cUNOPo->op_first->op_type == OP_NULL);
1950 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1953 else { /* lvalue subroutine call */
1954 o->op_private |= OPpLVAL_INTRO
1955 |(OPpENTERSUB_INARGS * (type == OP_LEAVESUBLV));
1956 PL_modcount = RETURN_UNLIMITED_NUMBER;
1957 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1958 /* Potential lvalue context: */
1959 o->op_private |= OPpENTERSUB_INARGS;
1962 else { /* Compile-time error message: */
1963 OP *kid = cUNOPo->op_first;
1966 if (kid->op_type != OP_PUSHMARK) {
1967 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1969 "panic: unexpected lvalue entersub "
1970 "args: type/targ %ld:%"UVuf,
1971 (long)kid->op_type, (UV)kid->op_targ);
1972 kid = kLISTOP->op_first;
1974 while (kid->op_sibling)
1975 kid = kid->op_sibling;
1976 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1977 break; /* Postpone until runtime */
1980 kid = kUNOP->op_first;
1981 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1982 kid = kUNOP->op_first;
1983 if (kid->op_type == OP_NULL)
1985 "Unexpected constant lvalue entersub "
1986 "entry via type/targ %ld:%"UVuf,
1987 (long)kid->op_type, (UV)kid->op_targ);
1988 if (kid->op_type != OP_GV) {
1992 cv = GvCV(kGVOP_gv);
2002 if (flags & OP_LVALUE_NO_CROAK) return NULL;
2003 /* grep, foreach, subcalls, refgen */
2004 if (type == OP_GREPSTART || type == OP_ENTERSUB
2005 || type == OP_REFGEN || type == OP_LEAVESUBLV)
2007 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
2008 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
2010 : (o->op_type == OP_ENTERSUB
2011 ? "non-lvalue subroutine call"
2013 type ? PL_op_desc[type] : "local"));
2027 case OP_RIGHT_SHIFT:
2036 if (!(o->op_flags & OPf_STACKED))
2043 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
2044 op_lvalue(kid, type);
2049 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
2050 PL_modcount = RETURN_UNLIMITED_NUMBER;
2051 return o; /* Treat \(@foo) like ordinary list. */
2055 if (scalar_mod_type(o, type))
2057 ref(cUNOPo->op_first, o->op_type);
2061 if (type == OP_LEAVESUBLV)
2062 o->op_private |= OPpMAYBE_LVSUB;
2068 PL_modcount = RETURN_UNLIMITED_NUMBER;
2071 PL_hints |= HINT_BLOCK_SCOPE;
2072 if (type == OP_LEAVESUBLV)
2073 o->op_private |= OPpMAYBE_LVSUB;
2077 ref(cUNOPo->op_first, o->op_type);
2081 PL_hints |= HINT_BLOCK_SCOPE;
2090 case OP_AELEMFAST_LEX:
2097 PL_modcount = RETURN_UNLIMITED_NUMBER;
2098 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
2099 return o; /* Treat \(@foo) like ordinary list. */
2100 if (scalar_mod_type(o, type))
2102 if (type == OP_LEAVESUBLV)
2103 o->op_private |= OPpMAYBE_LVSUB;
2107 if (!type) /* local() */
2108 Perl_croak(aTHX_ "Can't localize lexical variable %"SVf,
2109 PAD_COMPNAME_SV(o->op_targ));
2118 if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
2122 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
2128 if (type == OP_LEAVESUBLV)
2129 o->op_private |= OPpMAYBE_LVSUB;
2130 pad_free(o->op_targ);
2131 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
2132 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
2133 if (o->op_flags & OPf_KIDS)
2134 op_lvalue(cBINOPo->op_first->op_sibling, type);
2139 ref(cBINOPo->op_first, o->op_type);
2140 if (type == OP_ENTERSUB &&
2141 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
2142 o->op_private |= OPpLVAL_DEFER;
2143 if (type == OP_LEAVESUBLV)
2144 o->op_private |= OPpMAYBE_LVSUB;
2154 if (o->op_flags & OPf_KIDS)
2155 op_lvalue(cLISTOPo->op_last, type);
2160 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
2162 else if (!(o->op_flags & OPf_KIDS))
2164 if (o->op_targ != OP_LIST) {
2165 op_lvalue(cBINOPo->op_first, type);
2171 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2172 /* elements might be in void context because the list is
2173 in scalar context or because they are attribute sub calls */
2174 if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
2175 op_lvalue(kid, type);
2179 if (type != OP_LEAVESUBLV)
2181 break; /* op_lvalue()ing was handled by ck_return() */
2187 /* [20011101.069] File test operators interpret OPf_REF to mean that
2188 their argument is a filehandle; thus \stat(".") should not set
2190 if (type == OP_REFGEN &&
2191 PL_check[o->op_type] == Perl_ck_ftst)
2194 if (type != OP_LEAVESUBLV)
2195 o->op_flags |= OPf_MOD;
2197 if (type == OP_AASSIGN || type == OP_SASSIGN)
2198 o->op_flags |= OPf_SPECIAL|OPf_REF;
2199 else if (!type) { /* local() */
2202 o->op_private |= OPpLVAL_INTRO;
2203 o->op_flags &= ~OPf_SPECIAL;
2204 PL_hints |= HINT_BLOCK_SCOPE;
2209 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
2210 "Useless localization of %s", OP_DESC(o));
2213 else if (type != OP_GREPSTART && type != OP_ENTERSUB
2214 && type != OP_LEAVESUBLV)
2215 o->op_flags |= OPf_REF;
2220 S_scalar_mod_type(const OP *o, I32 type)
2225 if (o && o->op_type == OP_RV2GV)
2249 case OP_RIGHT_SHIFT:
2270 S_is_handle_constructor(const OP *o, I32 numargs)
2272 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
2274 switch (o->op_type) {
2282 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
2295 S_refkids(pTHX_ OP *o, I32 type)
2297 if (o && o->op_flags & OPf_KIDS) {
2299 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2306 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
2311 PERL_ARGS_ASSERT_DOREF;
2313 if (!o || (PL_parser && PL_parser->error_count))
2316 switch (o->op_type) {
2318 if ((type == OP_EXISTS || type == OP_DEFINED) &&
2319 !(o->op_flags & OPf_STACKED)) {
2320 o->op_type = OP_RV2CV; /* entersub => rv2cv */
2321 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
2322 assert(cUNOPo->op_first->op_type == OP_NULL);
2323 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
2324 o->op_flags |= OPf_SPECIAL;
2325 o->op_private &= ~1;
2327 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
2328 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2329 : type == OP_RV2HV ? OPpDEREF_HV
2331 o->op_flags |= OPf_MOD;
2337 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
2338 doref(kid, type, set_op_ref);
2341 if (type == OP_DEFINED)
2342 o->op_flags |= OPf_SPECIAL; /* don't create GV */
2343 doref(cUNOPo->op_first, o->op_type, set_op_ref);
2346 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2347 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2348 : type == OP_RV2HV ? OPpDEREF_HV
2350 o->op_flags |= OPf_MOD;
2357 o->op_flags |= OPf_REF;
2360 if (type == OP_DEFINED)
2361 o->op_flags |= OPf_SPECIAL; /* don't create GV */
2362 doref(cUNOPo->op_first, o->op_type, set_op_ref);
2368 o->op_flags |= OPf_REF;
2373 if (!(o->op_flags & OPf_KIDS))
2375 doref(cBINOPo->op_first, type, set_op_ref);
2379 doref(cBINOPo->op_first, o->op_type, set_op_ref);
2380 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2381 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2382 : type == OP_RV2HV ? OPpDEREF_HV
2384 o->op_flags |= OPf_MOD;
2394 if (!(o->op_flags & OPf_KIDS))
2396 doref(cLISTOPo->op_last, type, set_op_ref);
2406 S_dup_attrlist(pTHX_ OP *o)
2411 PERL_ARGS_ASSERT_DUP_ATTRLIST;
2413 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
2414 * where the first kid is OP_PUSHMARK and the remaining ones
2415 * are OP_CONST. We need to push the OP_CONST values.
2417 if (o->op_type == OP_CONST)
2418 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
2420 else if (o->op_type == OP_NULL)
2424 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
2426 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
2427 if (o->op_type == OP_CONST)
2428 rop = op_append_elem(OP_LIST, rop,
2429 newSVOP(OP_CONST, o->op_flags,
2430 SvREFCNT_inc_NN(cSVOPo->op_sv)));
2437 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
2442 PERL_ARGS_ASSERT_APPLY_ATTRS;
2444 /* fake up C<use attributes $pkg,$rv,@attrs> */
2445 ENTER; /* need to protect against side-effects of 'use' */
2446 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2448 #define ATTRSMODULE "attributes"
2449 #define ATTRSMODULE_PM "attributes.pm"
2452 /* Don't force the C<use> if we don't need it. */
2453 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
2454 if (svp && *svp != &PL_sv_undef)
2455 NOOP; /* already in %INC */
2457 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
2458 newSVpvs(ATTRSMODULE), NULL);
2461 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2462 newSVpvs(ATTRSMODULE),
2464 op_prepend_elem(OP_LIST,
2465 newSVOP(OP_CONST, 0, stashsv),
2466 op_prepend_elem(OP_LIST,
2467 newSVOP(OP_CONST, 0,
2469 dup_attrlist(attrs))));
2475 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
2478 OP *pack, *imop, *arg;
2481 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
2486 assert(target->op_type == OP_PADSV ||
2487 target->op_type == OP_PADHV ||
2488 target->op_type == OP_PADAV);
2490 /* Ensure that attributes.pm is loaded. */
2491 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
2493 /* Need package name for method call. */
2494 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
2496 /* Build up the real arg-list. */
2497 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2499 arg = newOP(OP_PADSV, 0);
2500 arg->op_targ = target->op_targ;
2501 arg = op_prepend_elem(OP_LIST,
2502 newSVOP(OP_CONST, 0, stashsv),
2503 op_prepend_elem(OP_LIST,
2504 newUNOP(OP_REFGEN, 0,
2505 op_lvalue(arg, OP_REFGEN)),
2506 dup_attrlist(attrs)));
2508 /* Fake up a method call to import */
2509 meth = newSVpvs_share("import");
2510 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2511 op_append_elem(OP_LIST,
2512 op_prepend_elem(OP_LIST, pack, list(arg)),
2513 newSVOP(OP_METHOD_NAMED, 0, meth)));
2515 /* Combine the ops. */
2516 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
2520 =notfor apidoc apply_attrs_string
2522 Attempts to apply a list of attributes specified by the C<attrstr> and
2523 C<len> arguments to the subroutine identified by the C<cv> argument which
2524 is expected to be associated with the package identified by the C<stashpv>
2525 argument (see L<attributes>). It gets this wrong, though, in that it
2526 does not correctly identify the boundaries of the individual attribute
2527 specifications within C<attrstr>. This is not really intended for the
2528 public API, but has to be listed here for systems such as AIX which
2529 need an explicit export list for symbols. (It's called from XS code
2530 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
2531 to respect attribute syntax properly would be welcome.
2537 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
2538 const char *attrstr, STRLEN len)
2542 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2545 len = strlen(attrstr);
2549 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2551 const char * const sstr = attrstr;
2552 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2553 attrs = op_append_elem(OP_LIST, attrs,
2554 newSVOP(OP_CONST, 0,
2555 newSVpvn(sstr, attrstr-sstr)));
2559 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2560 newSVpvs(ATTRSMODULE),
2561 NULL, op_prepend_elem(OP_LIST,
2562 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2563 op_prepend_elem(OP_LIST,
2564 newSVOP(OP_CONST, 0,
2565 newRV(MUTABLE_SV(cv))),
2570 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2574 const bool stately = PL_parser && PL_parser->in_my == KEY_state;
2576 PERL_ARGS_ASSERT_MY_KID;
2578 if (!o || (PL_parser && PL_parser->error_count))
2582 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2583 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2587 if (type == OP_LIST) {
2589 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2590 my_kid(kid, attrs, imopsp);
2592 } else if (type == OP_UNDEF || type == OP_STUB) {
2594 } else if (type == OP_RV2SV || /* "our" declaration */
2596 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2597 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2598 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2600 PL_parser->in_my == KEY_our
2602 : PL_parser->in_my == KEY_state ? "state" : "my"));
2604 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
2605 PL_parser->in_my = FALSE;
2606 PL_parser->in_my_stash = NULL;
2607 apply_attrs(GvSTASH(gv),
2608 (type == OP_RV2SV ? GvSV(gv) :
2609 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2610 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
2613 o->op_private |= OPpOUR_INTRO;
2616 else if (type != OP_PADSV &&
2619 type != OP_PUSHMARK)
2621 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2623 PL_parser->in_my == KEY_our
2625 : PL_parser->in_my == KEY_state ? "state" : "my"));
2628 else if (attrs && type != OP_PUSHMARK) {
2631 PL_parser->in_my = FALSE;
2632 PL_parser->in_my_stash = NULL;
2634 /* check for C<my Dog $spot> when deciding package */
2635 stash = PAD_COMPNAME_TYPE(o->op_targ);
2637 stash = PL_curstash;
2638 apply_attrs_my(stash, o, attrs, imopsp);
2640 o->op_flags |= OPf_MOD;
2641 o->op_private |= OPpLVAL_INTRO;
2643 o->op_private |= OPpPAD_STATE;
2648 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2652 int maybe_scalar = 0;
2654 PERL_ARGS_ASSERT_MY_ATTRS;
2656 /* [perl #17376]: this appears to be premature, and results in code such as
2657 C< our(%x); > executing in list mode rather than void mode */
2659 if (o->op_flags & OPf_PARENS)
2669 o = my_kid(o, attrs, &rops);
2671 if (maybe_scalar && o->op_type == OP_PADSV) {
2672 o = scalar(op_append_list(OP_LIST, rops, o));
2673 o->op_private |= OPpLVAL_INTRO;
2676 /* The listop in rops might have a pushmark at the beginning,
2677 which will mess up list assignment. */
2678 LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
2679 if (rops->op_type == OP_LIST &&
2680 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
2682 OP * const pushmark = lrops->op_first;
2683 lrops->op_first = pushmark->op_sibling;
2686 o = op_append_list(OP_LIST, o, rops);
2689 PL_parser->in_my = FALSE;
2690 PL_parser->in_my_stash = NULL;
2695 Perl_sawparens(pTHX_ OP *o)
2697 PERL_UNUSED_CONTEXT;
2699 o->op_flags |= OPf_PARENS;
2704 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2708 const OPCODE ltype = left->op_type;
2709 const OPCODE rtype = right->op_type;
2711 PERL_ARGS_ASSERT_BIND_MATCH;
2713 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2714 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2716 const char * const desc
2718 rtype == OP_SUBST || rtype == OP_TRANS
2719 || rtype == OP_TRANSR
2721 ? (int)rtype : OP_MATCH];
2722 const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
2725 (ltype == OP_RV2AV || ltype == OP_RV2HV)
2726 ? cUNOPx(left)->op_first->op_type == OP_GV
2727 && (gv = cGVOPx_gv(cUNOPx(left)->op_first))
2728 ? varname(gv, isary ? '@' : '%', 0, NULL, 0, 1)
2731 (GV *)PL_compcv, isary ? '@' : '%', left->op_targ, NULL, 0, 1
2734 Perl_warner(aTHX_ packWARN(WARN_MISC),
2735 "Applying %s to %"SVf" will act on scalar(%"SVf")",
2738 const char * const sample = (isary
2739 ? "@array" : "%hash");
2740 Perl_warner(aTHX_ packWARN(WARN_MISC),
2741 "Applying %s to %s will act on scalar(%s)",
2742 desc, sample, sample);
2746 if (rtype == OP_CONST &&
2747 cSVOPx(right)->op_private & OPpCONST_BARE &&
2748 cSVOPx(right)->op_private & OPpCONST_STRICT)
2750 no_bareword_allowed(right);
2753 /* !~ doesn't make sense with /r, so error on it for now */
2754 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
2756 yyerror("Using !~ with s///r doesn't make sense");
2757 if (rtype == OP_TRANSR && type == OP_NOT)
2758 yyerror("Using !~ with tr///r doesn't make sense");
2760 ismatchop = (rtype == OP_MATCH ||
2761 rtype == OP_SUBST ||
2762 rtype == OP_TRANS || rtype == OP_TRANSR)
2763 && !(right->op_flags & OPf_SPECIAL);
2764 if (ismatchop && right->op_private & OPpTARGET_MY) {
2766 right->op_private &= ~OPpTARGET_MY;
2768 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2771 right->op_flags |= OPf_STACKED;
2772 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
2773 ! (rtype == OP_TRANS &&
2774 right->op_private & OPpTRANS_IDENTICAL) &&
2775 ! (rtype == OP_SUBST &&
2776 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
2777 newleft = op_lvalue(left, rtype);
2780 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
2781 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2783 o = op_prepend_elem(rtype, scalar(newleft), right);
2785 return newUNOP(OP_NOT, 0, scalar(o));
2789 return bind_match(type, left,
2790 pmruntime(newPMOP(OP_MATCH, 0), right, 0, 0));
2794 Perl_invert(pTHX_ OP *o)
2798 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2802 =for apidoc Amx|OP *|op_scope|OP *o
2804 Wraps up an op tree with some additional ops so that at runtime a dynamic
2805 scope will be created. The original ops run in the new dynamic scope,
2806 and then, provided that they exit normally, the scope will be unwound.
2807 The additional ops used to create and unwind the dynamic scope will
2808 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
2809 instead if the ops are simple enough to not need the full dynamic scope
2816 Perl_op_scope(pTHX_ OP *o)
2820 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2821 o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2822 o->op_type = OP_LEAVE;
2823 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2825 else if (o->op_type == OP_LINESEQ) {
2827 o->op_type = OP_SCOPE;
2828 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2829 kid = ((LISTOP*)o)->op_first;
2830 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2833 /* The following deals with things like 'do {1 for 1}' */
2834 kid = kid->op_sibling;
2836 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2841 o = newLISTOP(OP_SCOPE, 0, o, NULL);
2847 Perl_op_unscope(pTHX_ OP *o)
2849 if (o && o->op_type == OP_LINESEQ) {
2850 OP *kid = cLISTOPo->op_first;
2851 for(; kid; kid = kid->op_sibling)
2852 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
2859 Perl_block_start(pTHX_ int full)
2862 const int retval = PL_savestack_ix;
2864 pad_block_start(full);
2866 PL_hints &= ~HINT_BLOCK_SCOPE;
2867 SAVECOMPILEWARNINGS();
2868 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2870 CALL_BLOCK_HOOKS(bhk_start, full);
2876 Perl_block_end(pTHX_ I32 floor, OP *seq)
2879 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2880 OP* retval = scalarseq(seq);
2882 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
2885 CopHINTS_set(&PL_compiling, PL_hints);
2887 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2890 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
2896 =head1 Compile-time scope hooks
2898 =for apidoc Aox||blockhook_register
2900 Register a set of hooks to be called when the Perl lexical scope changes
2901 at compile time. See L<perlguts/"Compile-time scope hooks">.
2907 Perl_blockhook_register(pTHX_ BHK *hk)
2909 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
2911 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
2918 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
2919 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2920 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2923 OP * const o = newOP(OP_PADSV, 0);
2924 o->op_targ = offset;
2930 Perl_newPROG(pTHX_ OP *o)
2934 PERL_ARGS_ASSERT_NEWPROG;
2941 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2942 ((PL_in_eval & EVAL_KEEPERR)
2943 ? OPf_SPECIAL : 0), o);
2945 cx = &cxstack[cxstack_ix];
2946 assert(CxTYPE(cx) == CXt_EVAL);
2948 if ((cx->blk_gimme & G_WANT) == G_VOID)
2949 scalarvoid(PL_eval_root);
2950 else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
2953 scalar(PL_eval_root);
2955 PL_eval_start = op_linklist(PL_eval_root);
2956 PL_eval_root->op_private |= OPpREFCOUNTED;
2957 OpREFCNT_set(PL_eval_root, 1);
2958 PL_eval_root->op_next = 0;
2959 i = PL_savestack_ix;
2962 CALL_PEEP(PL_eval_start);
2963 finalize_optree(PL_eval_root);
2965 PL_savestack_ix = i;
2968 if (o->op_type == OP_STUB) {
2969 PL_comppad_name = 0;
2971 S_op_destroy(aTHX_ o);
2974 PL_main_root = op_scope(sawparens(scalarvoid(o)));
2975 PL_curcop = &PL_compiling;
2976 PL_main_start = LINKLIST(PL_main_root);
2977 PL_main_root->op_private |= OPpREFCOUNTED;
2978 OpREFCNT_set(PL_main_root, 1);
2979 PL_main_root->op_next = 0;
2980 CALL_PEEP(PL_main_start);
2981 finalize_optree(PL_main_root);
2982 cv_forget_slab(PL_compcv);
2985 /* Register with debugger */
2987 CV * const cv = get_cvs("DB::postponed", 0);
2991 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
2993 call_sv(MUTABLE_SV(cv), G_DISCARD);
3000 Perl_localize(pTHX_ OP *o, I32 lex)
3004 PERL_ARGS_ASSERT_LOCALIZE;
3006 if (o->op_flags & OPf_PARENS)
3007 /* [perl #17376]: this appears to be premature, and results in code such as
3008 C< our(%x); > executing in list mode rather than void mode */
3015 if ( PL_parser->bufptr > PL_parser->oldbufptr
3016 && PL_parser->bufptr[-1] == ','
3017 && ckWARN(WARN_PARENTHESIS))
3019 char *s = PL_parser->bufptr;
3022 /* some heuristics to detect a potential error */
3023 while (*s && (strchr(", \t\n", *s)))
3027 if (*s && strchr("@$%*", *s) && *++s
3028 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
3031 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
3033 while (*s && (strchr(", \t\n", *s)))
3039 if (sigil && (*s == ';' || *s == '=')) {
3040 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
3041 "Parentheses missing around \"%s\" list",
3043 ? (PL_parser->in_my == KEY_our
3045 : PL_parser->in_my == KEY_state
3055 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
3056 PL_parser->in_my = FALSE;
3057 PL_parser->in_my_stash = NULL;
3062 Perl_jmaybe(pTHX_ OP *o)
3064 PERL_ARGS_ASSERT_JMAYBE;
3066 if (o->op_type == OP_LIST) {
3068 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
3069 o = convert(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
3074 PERL_STATIC_INLINE OP *
3075 S_op_std_init(pTHX_ OP *o)
3077 I32 type = o->op_type;
3079 PERL_ARGS_ASSERT_OP_STD_INIT;
3081 if (PL_opargs[type] & OA_RETSCALAR)
3083 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
3084 o->op_targ = pad_alloc(type, SVs_PADTMP);
3089 PERL_STATIC_INLINE OP *
3090 S_op_integerize(pTHX_ OP *o)
3092 I32 type = o->op_type;
3094 PERL_ARGS_ASSERT_OP_INTEGERIZE;
3096 /* integerize op. */
3097 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
3100 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
3103 if (type == OP_NEGATE)
3104 /* XXX might want a ck_negate() for this */
3105 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
3111 S_fold_constants(pTHX_ register OP *o)
3116 VOL I32 type = o->op_type;
3121 SV * const oldwarnhook = PL_warnhook;
3122 SV * const olddiehook = PL_diehook;
3126 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
3128 if (!(PL_opargs[type] & OA_FOLDCONST))
3142 /* XXX what about the numeric ops? */
3143 if (IN_LOCALE_COMPILETIME)
3147 if (!cLISTOPo->op_first->op_sibling
3148 || cLISTOPo->op_first->op_sibling->op_type != OP_CONST)
3151 SV * const sv = cSVOPx_sv(cLISTOPo->op_first->op_sibling);
3152 if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
3154 const char *s = SvPVX_const(sv);
3155 while (s < SvEND(sv)) {
3156 if (*s == 'p' || *s == 'P') goto nope;
3163 if (o->op_private & OPpREPEAT_DOLIST) goto nope;
3166 if (PL_parser && PL_parser->error_count)
3167 goto nope; /* Don't try to run w/ errors */
3169 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3170 const OPCODE type = curop->op_type;
3171 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
3173 type != OP_SCALAR &&
3175 type != OP_PUSHMARK)
3181 curop = LINKLIST(o);
3182 old_next = o->op_next;
3186 oldscope = PL_scopestack_ix;
3187 create_eval_scope(G_FAKINGEVAL);
3189 /* Verify that we don't need to save it: */
3190 assert(PL_curcop == &PL_compiling);
3191 StructCopy(&PL_compiling, ¬_compiling, COP);
3192 PL_curcop = ¬_compiling;
3193 /* The above ensures that we run with all the correct hints of the
3194 currently compiling COP, but that IN_PERL_RUNTIME is not true. */
3195 assert(IN_PERL_RUNTIME);
3196 PL_warnhook = PERL_WARNHOOK_FATAL;
3203 sv = *(PL_stack_sp--);
3204 if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
3206 /* Can't simply swipe the SV from the pad, because that relies on
3207 the op being freed "real soon now". Under MAD, this doesn't
3208 happen (see the #ifdef below). */
3211 pad_swipe(o->op_targ, FALSE);
3214 else if (SvTEMP(sv)) { /* grab mortal temp? */
3215 SvREFCNT_inc_simple_void(sv);
3220 /* Something tried to die. Abandon constant folding. */
3221 /* Pretend the error never happened. */
3223 o->op_next = old_next;
3227 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
3228 PL_warnhook = oldwarnhook;
3229 PL_diehook = olddiehook;
3230 /* XXX note that this croak may fail as we've already blown away
3231 * the stack - eg any nested evals */
3232 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
3235 PL_warnhook = oldwarnhook;
3236 PL_diehook = olddiehook;
3237 PL_curcop = &PL_compiling;
3239 if (PL_scopestack_ix > oldscope)
3240 delete_eval_scope();
3249 if (type == OP_RV2GV)
3250 newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
3252 newop = newSVOP(OP_CONST, OPpCONST_FOLDED<<8, MUTABLE_SV(sv));
3253 op_getmad(o,newop,'f');
3261 S_gen_constant_list(pTHX_ register OP *o)
3265 const I32 oldtmps_floor = PL_tmps_floor;
3268 if (PL_parser && PL_parser->error_count)
3269 return o; /* Don't attempt to run with errors */
3271 PL_op = curop = LINKLIST(o);
3274 Perl_pp_pushmark(aTHX);
3277 assert (!(curop->op_flags & OPf_SPECIAL));
3278 assert(curop->op_type == OP_RANGE);
3279 Perl_pp_anonlist(aTHX);
3280 PL_tmps_floor = oldtmps_floor;
3282 o->op_type = OP_RV2AV;
3283 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
3284 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
3285 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
3286 o->op_opt = 0; /* needs to be revisited in rpeep() */
3287 curop = ((UNOP*)o)->op_first;
3288 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
3290 op_getmad(curop,o,'O');
3299 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
3302 if (type < 0) type = -type, flags |= OPf_SPECIAL;
3303 if (!o || o->op_type != OP_LIST)
3304 o = newLISTOP(OP_LIST, 0, o, NULL);
3306 o->op_flags &= ~OPf_WANT;
3308 if (!(PL_opargs[type] & OA_MARK))
3309 op_null(cLISTOPo->op_first);
3311 OP * const kid2 = cLISTOPo->op_first->op_sibling;
3312 if (kid2 && kid2->op_type == OP_COREARGS) {
3313 op_null(cLISTOPo->op_first);
3314 kid2->op_private |= OPpCOREARGS_PUSHMARK;
3318 o->op_type = (OPCODE)type;
3319 o->op_ppaddr = PL_ppaddr[type];
3320 o->op_flags |= flags;
3322 o = CHECKOP(type, o);
3323 if (o->op_type != (unsigned)type)
3326 return fold_constants(op_integerize(op_std_init(o)));
3330 =head1 Optree Manipulation Functions
3333 /* List constructors */
3336 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
3338 Append an item to the list of ops contained directly within a list-type
3339 op, returning the lengthened list. I<first> is the list-type op,
3340 and I<last> is the op to append to the list. I<optype> specifies the
3341 intended opcode for the list. If I<first> is not already a list of the
3342 right type, it will be upgraded into one. If either I<first> or I<last>
3343 is null, the other is returned unchanged.
3349 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
3357 if (first->op_type != (unsigned)type
3358 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
3360 return newLISTOP(type, 0, first, last);
3363 if (first->op_flags & OPf_KIDS)
3364 ((LISTOP*)first)->op_last->op_sibling = last;
3366 first->op_flags |= OPf_KIDS;
3367 ((LISTOP*)first)->op_first = last;
3369 ((LISTOP*)first)->op_last = last;
3374 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
3376 Concatenate the lists of ops contained directly within two list-type ops,
3377 returning the combined list. I<first> and I<last> are the list-type ops
3378 to concatenate. I<optype> specifies the intended opcode for the list.
3379 If either I<first> or I<last> is not already a list of the right type,
3380 it will be upgraded into one. If either I<first> or I<last> is null,
3381 the other is returned unchanged.
3387 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
3395 if (first->op_type != (unsigned)type)
3396 return op_prepend_elem(type, first, last);
3398 if (last->op_type != (unsigned)type)
3399 return op_append_elem(type, first, last);
3401 ((LISTOP*)first)->op_last->op_sibling = ((LISTOP*)last)->op_first;
3402 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
3403 first->op_flags |= (last->op_flags & OPf_KIDS);
3406 if (((LISTOP*)last)->op_first && first->op_madprop) {
3407 MADPROP *mp = ((LISTOP*)last)->op_first->op_madprop;
3409 while (mp->mad_next)
3411 mp->mad_next = first->op_madprop;
3414 ((LISTOP*)last)->op_first->op_madprop = first->op_madprop;
3417 first->op_madprop = last->op_madprop;
3418 last->op_madprop = 0;
3421 S_op_destroy(aTHX_ last);
3427 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
3429 Prepend an item to the list of ops contained directly within a list-type
3430 op, returning the lengthened list. I<first> is the op to prepend to the
3431 list, and I<last> is the list-type op. I<optype> specifies the intended
3432 opcode for the list. If I<last> is not already a list of the right type,
3433 it will be upgraded into one. If either I<first> or I<last> is null,
3434 the other is returned unchanged.
3440 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
3448 if (last->op_type == (unsigned)type) {
3449 if (type == OP_LIST) { /* already a PUSHMARK there */
3450 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
3451 ((LISTOP*)last)->op_first->op_sibling = first;
3452 if (!(first->op_flags & OPf_PARENS))
3453 last->op_flags &= ~OPf_PARENS;
3456 if (!(last->op_flags & OPf_KIDS)) {
3457 ((LISTOP*)last)->op_last = first;
3458 last->op_flags |= OPf_KIDS;
3460 first->op_sibling = ((LISTOP*)last)->op_first;
3461 ((LISTOP*)last)->op_first = first;
3463 last->op_flags |= OPf_KIDS;
3467 return newLISTOP(type, 0, first, last);
3475 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
3478 Newxz(tk, 1, TOKEN);
3479 tk->tk_type = (OPCODE)optype;
3480 tk->tk_type = 12345;
3482 tk->tk_mad = madprop;
3487 Perl_token_free(pTHX_ TOKEN* tk)
3489 PERL_ARGS_ASSERT_TOKEN_FREE;
3491 if (tk->tk_type != 12345)
3493 mad_free(tk->tk_mad);
3498 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
3503 PERL_ARGS_ASSERT_TOKEN_GETMAD;
3505 if (tk->tk_type != 12345) {
3506 Perl_warner(aTHX_ packWARN(WARN_MISC),
3507 "Invalid TOKEN object ignored");
3514 /* faked up qw list? */
3516 tm->mad_type == MAD_SV &&
3517 SvPVX((SV *)tm->mad_val)[0] == 'q')
3524 /* pretend constant fold didn't happen? */
3525 if (mp->mad_key == 'f' &&
3526 (o->op_type == OP_CONST ||
3527 o->op_type == OP_GV) )
3529 token_getmad(tk,(OP*)mp->mad_val,slot);
3543 if (mp->mad_key == 'X')
3544 mp->mad_key = slot; /* just change the first one */
3554 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
3563 /* pretend constant fold didn't happen? */
3564 if (mp->mad_key == 'f' &&
3565 (o->op_type == OP_CONST ||
3566 o->op_type == OP_GV) )
3568 op_getmad(from,(OP*)mp->mad_val,slot);
3575 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
3578 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
3584 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
3593 /* pretend constant fold didn't happen? */
3594 if (mp->mad_key == 'f' &&
3595 (o->op_type == OP_CONST ||
3596 o->op_type == OP_GV) )
3598 op_getmad(from,(OP*)mp->mad_val,slot);
3605 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
3608 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
3612 PerlIO_printf(PerlIO_stderr(),
3613 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
3619 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
3637 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
3641 addmad(tm, &(o->op_madprop), slot);
3645 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
3666 Perl_newMADsv(pTHX_ char key, SV* sv)
3668 PERL_ARGS_ASSERT_NEWMADSV;
3670 return newMADPROP(key, MAD_SV, sv, 0);
3674 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
3676 MADPROP *const mp = (MADPROP *) PerlMemShared_malloc(sizeof(MADPROP));
3679 mp->mad_vlen = vlen;
3680 mp->mad_type = type;
3682 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
3687 Perl_mad_free(pTHX_ MADPROP* mp)
3689 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
3693 mad_free(mp->mad_next);
3694 /* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
3695 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
3696 switch (mp->mad_type) {
3700 Safefree((char*)mp->mad_val);
3703 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
3704 op_free((OP*)mp->mad_val);
3707 sv_free(MUTABLE_SV(mp->mad_val));
3710 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
3713 PerlMemShared_free(mp);
3719 =head1 Optree construction
3721 =for apidoc Am|OP *|newNULLLIST
3723 Constructs, checks, and returns a new C<stub> op, which represents an
3724 empty list expression.
3730 Perl_newNULLLIST(pTHX)
3732 return newOP(OP_STUB, 0);
3736 S_force_list(pTHX_ OP *o)
3738 if (!o || o->op_type != OP_LIST)
3739 o = newLISTOP(OP_LIST, 0, o, NULL);
3745 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
3747 Constructs, checks, and returns an op of any list type. I<type> is
3748 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3749 C<OPf_KIDS> will be set automatically if required. I<first> and I<last>
3750 supply up to two ops to be direct children of the list op; they are
3751 consumed by this function and become part of the constructed op tree.
3757 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3762 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
3764 NewOp(1101, listop, 1, LISTOP);
3766 listop->op_type = (OPCODE)type;
3767 listop->op_ppaddr = PL_ppaddr[type];
3770 listop->op_flags = (U8)flags;
3774 else if (!first && last)
3777 first->op_sibling = last;
3778 listop->op_first = first;
3779 listop->op_last = last;
3780 if (type == OP_LIST) {
3781 OP* const pushop = newOP(OP_PUSHMARK, 0);
3782 pushop->op_sibling = first;
3783 listop->op_first = pushop;
3784 listop->op_flags |= OPf_KIDS;
3786 listop->op_last = pushop;
3789 return CHECKOP(type, listop);
3793 =for apidoc Am|OP *|newOP|I32 type|I32 flags
3795 Constructs, checks, and returns an op of any base type (any type that
3796 has no extra fields). I<type> is the opcode. I<flags> gives the
3797 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
3804 Perl_newOP(pTHX_ I32 type, I32 flags)
3809 if (type == -OP_ENTEREVAL) {
3810 type = OP_ENTEREVAL;
3811 flags |= OPpEVAL_BYTES<<8;
3814 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
3815 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3816 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3817 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
3819 NewOp(1101, o, 1, OP);
3820 o->op_type = (OPCODE)type;
3821 o->op_ppaddr = PL_ppaddr[type];
3822 o->op_flags = (U8)flags;
3825 o->op_private = (U8)(0 | (flags >> 8));
3826 if (PL_opargs[type] & OA_RETSCALAR)
3828 if (PL_opargs[type] & OA_TARGET)
3829 o->op_targ = pad_alloc(type, SVs_PADTMP);
3830 return CHECKOP(type, o);
3834 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
3836 Constructs, checks, and returns an op of any unary type. I<type> is
3837 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3838 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
3839 bits, the eight bits of C<op_private>, except that the bit with value 1
3840 is automatically set. I<first> supplies an optional op to be the direct
3841 child of the unary op; it is consumed by this function and become part
3842 of the constructed op tree.
3848 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
3853 if (type == -OP_ENTEREVAL) {
3854 type = OP_ENTEREVAL;
3855 flags |= OPpEVAL_BYTES<<8;
3858 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
3859 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3860 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3861 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
3862 || type == OP_SASSIGN
3863 || type == OP_ENTERTRY
3864 || type == OP_NULL );
3867 first = newOP(OP_STUB, 0);
3868 if (PL_opargs[type] & OA_MARK)
3869 first = force_list(first);
3871 NewOp(1101, unop, 1, UNOP);
3872 unop->op_type = (OPCODE)type;
3873 unop->op_ppaddr = PL_ppaddr[type];
3874 unop->op_first = first;
3875 unop->op_flags = (U8)(flags | OPf_KIDS);
3876 unop->op_private = (U8)(1 | (flags >> 8));
3877 unop = (UNOP*) CHECKOP(type, unop);
3881 return fold_constants(op_integerize(op_std_init((OP *) unop)));
3885 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
3887 Constructs, checks, and returns an op of any binary type. I<type>
3888 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
3889 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
3890 the eight bits of C<op_private>, except that the bit with value 1 or
3891 2 is automatically set as required. I<first> and I<last> supply up to
3892 two ops to be the direct children of the binary op; they are consumed
3893 by this function and become part of the constructed op tree.
3899 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3904 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
3905 || type == OP_SASSIGN || type == OP_NULL );
3907 NewOp(1101, binop, 1, BINOP);
3910 first = newOP(OP_NULL, 0);
3912 binop->op_type = (OPCODE)type;
3913 binop->op_ppaddr = PL_ppaddr[type];
3914 binop->op_first = first;
3915 binop->op_flags = (U8)(flags | OPf_KIDS);
3918 binop->op_private = (U8)(1 | (flags >> 8));
3921 binop->op_private = (U8)(2 | (flags >> 8));
3922 first->op_sibling = last;
3925 binop = (BINOP*)CHECKOP(type, binop);
3926 if (binop->op_next || binop->op_type != (OPCODE)type)
3929 binop->op_last = binop->op_first->op_sibling;
3931 return fold_constants(op_integerize(op_std_init((OP *)binop)));
3934 static int uvcompare(const void *a, const void *b)
3935 __attribute__nonnull__(1)
3936 __attribute__nonnull__(2)
3937 __attribute__pure__;
3938 static int uvcompare(const void *a, const void *b)
3940 if (*((const UV *)a) < (*(const UV *)b))
3942 if (*((const UV *)a) > (*(const UV *)b))
3944 if (*((const UV *)a+1) < (*(const UV *)b+1))
3946 if (*((const UV *)a+1) > (*(const UV *)b+1))
3952 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3955 SV * const tstr = ((SVOP*)expr)->op_sv;
3958 (repl->op_type == OP_NULL)
3959 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3961 ((SVOP*)repl)->op_sv;
3964 const U8 *t = (U8*)SvPV_const(tstr, tlen);
3965 const U8 *r = (U8*)SvPV_const(rstr, rlen);
3971 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3972 const I32 squash = o->op_private & OPpTRANS_SQUASH;
3973 I32 del = o->op_private & OPpTRANS_DELETE;
3976 PERL_ARGS_ASSERT_PMTRANS;
3978 PL_hints |= HINT_BLOCK_SCOPE;
3981 o->op_private |= OPpTRANS_FROM_UTF;
3984 o->op_private |= OPpTRANS_TO_UTF;
3986 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3987 SV* const listsv = newSVpvs("# comment\n");
3989 const U8* tend = t + tlen;
3990 const U8* rend = r + rlen;
4004 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
4005 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
4008 const U32 flags = UTF8_ALLOW_DEFAULT;
4012 t = tsave = bytes_to_utf8(t, &len);
4015 if (!to_utf && rlen) {
4017 r = rsave = bytes_to_utf8(r, &len);
4021 /* There are several snags with this code on EBCDIC:
4022 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
4023 2. scan_const() in toke.c has encoded chars in native encoding which makes
4024 ranges at least in EBCDIC 0..255 range the bottom odd.
4028 U8 tmpbuf[UTF8_MAXBYTES+1];
4031 Newx(cp, 2*tlen, UV);
4033 transv = newSVpvs("");
4035 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
4037 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
4039 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
4043 cp[2*i+1] = cp[2*i];
4047 qsort(cp, i, 2*sizeof(UV), uvcompare);
4048 for (j = 0; j < i; j++) {
4050 diff = val - nextmin;
4052 t = uvuni_to_utf8(tmpbuf,nextmin);
4053 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4055 U8 range_mark = UTF_TO_NATIVE(0xff);
4056 t = uvuni_to_utf8(tmpbuf, val - 1);
4057 sv_catpvn(transv, (char *)&range_mark, 1);
4058 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4065 t = uvuni_to_utf8(tmpbuf,nextmin);
4066 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4068 U8 range_mark = UTF_TO_NATIVE(0xff);
4069 sv_catpvn(transv, (char *)&range_mark, 1);
4071 t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
4072 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4073 t = (const U8*)SvPVX_const(transv);
4074 tlen = SvCUR(transv);
4078 else if (!rlen && !del) {
4079 r = t; rlen = tlen; rend = tend;
4082 if ((!rlen && !del) || t == r ||
4083 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
4085 o->op_private |= OPpTRANS_IDENTICAL;
4089 while (t < tend || tfirst <= tlast) {
4090 /* see if we need more "t" chars */
4091 if (tfirst > tlast) {
4092 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
4094 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
4096 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
4103 /* now see if we need more "r" chars */
4104 if (rfirst > rlast) {
4106 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
4108 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
4110 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
4119 rfirst = rlast = 0xffffffff;
4123 /* now see which range will peter our first, if either. */
4124 tdiff = tlast - tfirst;
4125 rdiff = rlast - rfirst;
4132 if (rfirst == 0xffffffff) {
4133 diff = tdiff; /* oops, pretend rdiff is infinite */
4135 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
4136 (long)tfirst, (long)tlast);
4138 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
4142 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
4143 (long)tfirst, (long)(tfirst + diff),
4146 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
4147 (long)tfirst, (long)rfirst);
4149 if (rfirst + diff > max)
4150 max = rfirst + diff;
4152 grows = (tfirst < rfirst &&
4153 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
4165 else if (max > 0xff)
4170 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
4172 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
4173 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
4174 PAD_SETSV(cPADOPo->op_padix, swash);
4176 SvREADONLY_on(swash);
4178 cSVOPo->op_sv = swash;
4180 SvREFCNT_dec(listsv);
4181 SvREFCNT_dec(transv);
4183 if (!del && havefinal && rlen)
4184 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
4185 newSVuv((UV)final), 0);
4188 o->op_private |= OPpTRANS_GROWS;
4194 op_getmad(expr,o,'e');
4195 op_getmad(repl,o,'r');
4203 tbl = (short*)PerlMemShared_calloc(
4204 (o->op_private & OPpTRANS_COMPLEMENT) &&
4205 !(o->op_private & OPpTRANS_DELETE) ? 258 : 256,
4207 cPVOPo->op_pv = (char*)tbl;
4209 for (i = 0; i < (I32)tlen; i++)
4211 for (i = 0, j = 0; i < 256; i++) {
4213 if (j >= (I32)rlen) {
4222 if (i < 128 && r[j] >= 128)
4232 o->op_private |= OPpTRANS_IDENTICAL;
4234 else if (j >= (I32)rlen)
4239 PerlMemShared_realloc(tbl,
4240 (0x101+rlen-j) * sizeof(short));
4241 cPVOPo->op_pv = (char*)tbl;
4243 tbl[0x100] = (short)(rlen - j);
4244 for (i=0; i < (I32)rlen - j; i++)
4245 tbl[0x101+i] = r[j+i];
4249 if (!rlen && !del) {
4252 o->op_private |= OPpTRANS_IDENTICAL;
4254 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
4255 o->op_private |= OPpTRANS_IDENTICAL;
4257 for (i = 0; i < 256; i++)
4259 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
4260 if (j >= (I32)rlen) {
4262 if (tbl[t[i]] == -1)
4268 if (tbl[t[i]] == -1) {
4269 if (t[i] < 128 && r[j] >= 128)
4276 if(del && rlen == tlen) {
4277 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
4278 } else if(rlen > tlen) {
4279 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
4283 o->op_private |= OPpTRANS_GROWS;
4285 op_getmad(expr,o,'e');
4286 op_getmad(repl,o,'r');
4296 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
4298 Constructs, checks, and returns an op of any pattern matching type.
4299 I<type> is the opcode. I<flags> gives the eight bits of C<op_flags>
4300 and, shifted up eight bits, the eight bits of C<op_private>.
4306 Perl_newPMOP(pTHX_ I32 type, I32 flags)
4311 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
4313 NewOp(1101, pmop, 1, PMOP);
4314 pmop->op_type = (OPCODE)type;
4315 pmop->op_ppaddr = PL_ppaddr[type];
4316 pmop->op_flags = (U8)flags;
4317 pmop->op_private = (U8)(0 | (flags >> 8));
4319 if (PL_hints & HINT_RE_TAINT)
4320 pmop->op_pmflags |= PMf_RETAINT;
4321 if (IN_LOCALE_COMPILETIME) {
4322 set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
4324 else if ((! (PL_hints & HINT_BYTES))
4325 /* Both UNI_8_BIT and locale :not_characters imply Unicode */
4326 && (PL_hints & (HINT_UNI_8_BIT|HINT_LOCALE_NOT_CHARS)))
4328 set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
4330 if (PL_hints & HINT_RE_FLAGS) {
4331 SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4332 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
4334 if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
4335 reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4336 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
4338 if (reflags && SvOK(reflags)) {
4339 set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
4345 assert(SvPOK(PL_regex_pad[0]));
4346 if (SvCUR(PL_regex_pad[0])) {
4347 /* Pop off the "packed" IV from the end. */
4348 SV *const repointer_list = PL_regex_pad[0];
4349 const char *p = SvEND(repointer_list) - sizeof(IV);
4350 const IV offset = *((IV*)p);
4352 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
4354 SvEND_set(repointer_list, p);
4356 pmop->op_pmoffset = offset;
4357 /* This slot should be free, so assert this: */
4358 assert(PL_regex_pad[offset] == &PL_sv_undef);
4360 SV * const repointer = &PL_sv_undef;
4361 av_push(PL_regex_padav, repointer);
4362 pmop->op_pmoffset = av_len(PL_regex_padav);
4363 PL_regex_pad = AvARRAY(PL_regex_padav);
4367 return CHECKOP(type, pmop);
4370 /* Given some sort of match op o, and an expression expr containing a
4371 * pattern, either compile expr into a regex and attach it to o (if it's
4372 * constant), or convert expr into a runtime regcomp op sequence (if it's
4375 * isreg indicates that the pattern is part of a regex construct, eg
4376 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
4377 * split "pattern", which aren't. In the former case, expr will be a list
4378 * if the pattern contains more than one term (eg /a$b/) or if it contains
4379 * a replacement, ie s/// or tr///.
4381 * When the pattern has been compiled within a new anon CV (for
4382 * qr/(?{...})/ ), then floor indicates the savestack level just before
4383 * the new sub was created
4387 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor)
4392 I32 repl_has_vars = 0;
4394 bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
4395 bool is_compiletime;
4398 PERL_ARGS_ASSERT_PMRUNTIME;
4400 /* for s/// and tr///, last element in list is the replacement; pop it */
4402 if (is_trans || o->op_type == OP_SUBST) {
4404 repl = cLISTOPx(expr)->op_last;
4405 kid = cLISTOPx(expr)->op_first;
4406 while (kid->op_sibling != repl)
4407 kid = kid->op_sibling;
4408 kid->op_sibling = NULL;
4409 cLISTOPx(expr)->op_last = kid;
4412 /* for TRANS, convert LIST/PUSH/CONST into CONST, and pass to pmtrans() */
4415 OP* const oe = expr;
4416 assert(expr->op_type == OP_LIST);
4417 assert(cLISTOPx(expr)->op_first->op_type == OP_PUSHMARK);
4418 assert(cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last);
4419 expr = cLISTOPx(oe)->op_last;
4420 cLISTOPx(oe)->op_first->op_sibling = NULL;
4421 cLISTOPx(oe)->op_last = NULL;
4424 return pmtrans(o, expr, repl);
4427 /* find whether we have any runtime or code elements;
4428 * at the same time, temporarily set the op_next of each DO block;
4429 * then when we LINKLIST, this will cause the DO blocks to be excluded
4430 * from the op_next chain (and from having LINKLIST recursively
4431 * applied to them). We fix up the DOs specially later */
4435 if (expr->op_type == OP_LIST) {
4437 for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) {
4438 if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
4440 assert(!o->op_next && o->op_sibling);
4441 o->op_next = o->op_sibling;
4443 else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
4447 else if (expr->op_type != OP_CONST)
4452 /* fix up DO blocks; treat each one as a separate little sub */
4454 if (expr->op_type == OP_LIST) {
4456 for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) {
4457 if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
4459 o->op_next = NULL; /* undo temporary hack from above */
4462 if (cLISTOPo->op_first->op_type == OP_LEAVE) {
4463 LISTOP *leave = cLISTOPx(cLISTOPo->op_first);
4465 assert(leave->op_first->op_type == OP_ENTER);
4466 assert(leave->op_first->op_sibling);
4467 o->op_next = leave->op_first->op_sibling;
4469 assert(leave->op_flags & OPf_KIDS);
4470 assert(leave->op_last->op_next = (OP*)leave);
4471 leave->op_next = NULL; /* stop on last op */
4472 op_null((OP*)leave);
4476 OP *scope = cLISTOPo->op_first;
4477 assert(scope->op_type == OP_SCOPE);
4478 assert(scope->op_flags & OPf_KIDS);
4479 scope->op_next = NULL; /* stop on last op */
4482 /* have to peep the DOs individually as we've removed it from
4483 * the op_next chain */
4486 /* runtime finalizes as part of finalizing whole tree */
4491 PL_hints |= HINT_BLOCK_SCOPE;
4493 assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
4495 if (is_compiletime) {
4496 U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
4497 regexp_engine const *eng = current_re_engine();
4499 if (o->op_flags & OPf_SPECIAL)
4500 rx_flags |= RXf_SPLIT;
4502 if (!has_code || !eng->op_comp) {
4503 /* compile-time simple constant pattern */
4505 if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
4506 /* whoops! we guessed that a qr// had a code block, but we
4507 * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
4508 * that isn't required now. Note that we have to be pretty
4509 * confident that nothing used that CV's pad while the
4510 * regex was parsed */
4511 assert(AvFILLp(PL_comppad) == 0); /* just @_ */
4512 /* But we know that one op is using this CV's slab. */
4513 cv_forget_slab(PL_compcv);
4515 pm->op_pmflags &= ~PMf_HAS_CV;
4520 ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
4521 rx_flags, pm->op_pmflags)
4522 : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
4523 rx_flags, pm->op_pmflags)
4526 op_getmad(expr,(OP*)pm,'e');
4532 /* compile-time pattern that includes literal code blocks */
4533 REGEXP* re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
4536 ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
4539 if (pm->op_pmflags & PMf_HAS_CV) {
4541 /* this QR op (and the anon sub we embed it in) is never
4542 * actually executed. It's just a placeholder where we can
4543 * squirrel away expr in op_code_list without the peephole
4544 * optimiser etc processing it for a second time */
4545 OP *qr = newPMOP(OP_QR, 0);
4546 ((PMOP*)qr)->op_code_list = expr;
4548 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
4549 SvREFCNT_inc_simple_void(PL_compcv);
4550 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
4551 ((struct regexp *)SvANY(re))->qr_anoncv = cv;
4553 /* attach the anon CV to the pad so that
4554 * pad_fixup_inner_anons() can find it */
4555 (void)pad_add_anon(cv, o->op_type);
4556 SvREFCNT_inc_simple_void(cv);
4559 pm->op_code_list = expr;
4564 /* runtime pattern: build chain of regcomp etc ops */
4566 PADOFFSET cv_targ = 0;
4568 reglist = isreg && expr->op_type == OP_LIST;
4573 pm->op_code_list = expr;
4574 /* don't free op_code_list; its ops are embedded elsewhere too */
4575 pm->op_pmflags |= PMf_CODELIST_PRIVATE;
4578 /* the OP_REGCMAYBE is a placeholder in the non-threaded case
4579 * to allow its op_next to be pointed past the regcomp and
4580 * preceding stacking ops;
4581 * OP_REGCRESET is there to reset taint before executing the
4583 if (pm->op_pmflags & PMf_KEEP || PL_tainting)
4584 expr = newUNOP((PL_tainting ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
4586 if (pm->op_pmflags & PMf_HAS_CV) {
4587 /* we have a runtime qr with literal code. This means
4588 * that the qr// has been wrapped in a new CV, which
4589 * means that runtime consts, vars etc will have been compiled
4590 * against a new pad. So... we need to execute those ops
4591 * within the environment of the new CV. So wrap them in a call
4592 * to a new anon sub. i.e. for
4596 * we build an anon sub that looks like
4598 * sub { "a", $b, '(?{...})' }
4600 * and call it, passing the returned list to regcomp.
4601 * Or to put it another way, the list of ops that get executed
4605 * ------ -------------------
4606 * pushmark (for regcomp)
4607 * pushmark (for entersub)
4608 * pushmark (for refgen)
4612 * regcreset regcreset
4614 * const("a") const("a")
4616 * const("(?{...})") const("(?{...})")
4621 SvREFCNT_inc_simple_void(PL_compcv);
4622 /* these lines are just an unrolled newANONATTRSUB */
4623 expr = newSVOP(OP_ANONCODE, 0,
4624 MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
4625 cv_targ = expr->op_targ;
4626 expr = newUNOP(OP_REFGEN, 0, expr);
4628 expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr))));
4631 NewOp(1101, rcop, 1, LOGOP);
4632 rcop->op_type = OP_REGCOMP;
4633 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
4634 rcop->op_first = scalar(expr);
4635 rcop->op_flags |= OPf_KIDS
4636 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
4637 | (reglist ? OPf_STACKED : 0);
4638 rcop->op_private = 0;
4640 rcop->op_targ = cv_targ;
4642 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
4643 if (PL_hints & HINT_RE_EVAL) PL_cv_has_eval = 1;
4645 /* establish postfix order */
4646 if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
4648 rcop->op_next = expr;
4649 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
4652 rcop->op_next = LINKLIST(expr);
4653 expr->op_next = (OP*)rcop;
4656 op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
4661 if (pm->op_pmflags & PMf_EVAL) {
4663 if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
4664 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
4666 else if (repl->op_type == OP_CONST)
4670 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
4671 if (curop->op_type == OP_SCOPE
4672 || curop->op_type == OP_LEAVE
4673 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
4674 if (curop->op_type == OP_GV) {
4675 GV * const gv = cGVOPx_gv(curop);
4677 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
4680 else if (curop->op_type == OP_RV2CV)
4682 else if (curop->op_type == OP_RV2SV ||
4683 curop->op_type == OP_RV2AV ||
4684 curop->op_type == OP_RV2HV ||
4685 curop->op_type == OP_RV2GV) {
4686 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
4689 else if (curop->op_type == OP_PADSV ||
4690 curop->op_type == OP_PADAV ||
4691 curop->op_type == OP_PADHV ||
4692 curop->op_type == OP_PADANY)
4696 else if (curop->op_type == OP_PUSHRE)
4697 NOOP; /* Okay here, dangerous in newASSIGNOP */
4707 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
4709 pm->op_pmflags |= PMf_CONST; /* const for long enough */
4710 op_prepend_elem(o->op_type, scalar(repl), o);
4713 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
4714 pm->op_pmflags |= PMf_MAYBE_CONST;
4716 NewOp(1101, rcop, 1, LOGOP);
4717 rcop->op_type = OP_SUBSTCONT;
4718 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
4719 rcop->op_first = scalar(repl);
4720 rcop->op_flags |= OPf_KIDS;
4721 rcop->op_private = 1;
4724 /* establish postfix order */
4725 rcop->op_next = LINKLIST(repl);
4726 repl->op_next = (OP*)rcop;
4728 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
4729 assert(!(pm->op_pmflags & PMf_ONCE));
4730 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
4739 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
4741 Constructs, checks, and returns an op of any type that involves an
4742 embedded SV. I<type> is the opcode. I<flags> gives the eight bits
4743 of C<op_flags>. I<sv> gives the SV to embed in the op; this function
4744 takes ownership of one reference to it.
4750 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
4755 PERL_ARGS_ASSERT_NEWSVOP;
4757 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4758 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4759 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4761 NewOp(1101, svop, 1, SVOP);
4762 svop->op_type = (OPCODE)type;
4763 svop->op_ppaddr = PL_ppaddr[type];
4765 svop->op_next = (OP*)svop;
4766 svop->op_flags = (U8)flags;
4767 svop->op_private = (U8)(0 | (flags >> 8));
4768 if (PL_opargs[type] & OA_RETSCALAR)
4770 if (PL_opargs[type] & OA_TARGET)
4771 svop->op_targ = pad_alloc(type, SVs_PADTMP);
4772 return CHECKOP(type, svop);
4778 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
4780 Constructs, checks, and returns an op of any type that involves a
4781 reference to a pad element. I<type> is the opcode. I<flags> gives the
4782 eight bits of C<op_flags>. A pad slot is automatically allocated, and
4783 is populated with I<sv>; this function takes ownership of one reference
4786 This function only exists if Perl has been compiled to use ithreads.
4792 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
4797 PERL_ARGS_ASSERT_NEWPADOP;
4799 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4800 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4801 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4803 NewOp(1101, padop, 1, PADOP);
4804 padop->op_type = (OPCODE)type;
4805 padop->op_ppaddr = PL_ppaddr[type];
4806 padop->op_padix = pad_alloc(type, SVs_PADTMP);
4807 SvREFCNT_dec(PAD_SVl(padop->op_padix));
4808 PAD_SETSV(padop->op_padix, sv);
4811 padop->op_next = (OP*)padop;
4812 padop->op_flags = (U8)flags;
4813 if (PL_opargs[type] & OA_RETSCALAR)
4815 if (PL_opargs[type] & OA_TARGET)
4816 padop->op_targ = pad_alloc(type, SVs_PADTMP);
4817 return CHECKOP(type, padop);
4820 #endif /* !USE_ITHREADS */
4823 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
4825 Constructs, checks, and returns an op of any type that involves an
4826 embedded reference to a GV. I<type> is the opcode. I<flags> gives the
4827 eight bits of C<op_flags>. I<gv> identifies the GV that the op should
4828 reference; calling this function does not transfer ownership of any
4835 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
4839 PERL_ARGS_ASSERT_NEWGVOP;
4843 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
4845 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
4850 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
4852 Constructs, checks, and returns an op of any type that involves an
4853 embedded C-level pointer (PV). I<type> is the opcode. I<flags> gives
4854 the eight bits of C<op_flags>. I<pv> supplies the C-level pointer, which
4855 must have been allocated using L</PerlMemShared_malloc>; the memory will
4856 be freed when the op is destroyed.
4862 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
4865 const bool utf8 = cBOOL(flags & SVf_UTF8);
4870 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4872 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4874 NewOp(1101, pvop, 1, PVOP);
4875 pvop->op_type = (OPCODE)type;
4876 pvop->op_ppaddr = PL_ppaddr[type];
4878 pvop->op_next = (OP*)pvop;
4879 pvop->op_flags = (U8)flags;
4880 pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
4881 if (PL_opargs[type] & OA_RETSCALAR)
4883 if (PL_opargs[type] & OA_TARGET)
4884 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
4885 return CHECKOP(type, pvop);
4893 Perl_package(pTHX_ OP *o)
4896 SV *const sv = cSVOPo->op_sv;
4901 PERL_ARGS_ASSERT_PACKAGE;
4903 SAVEGENERICSV(PL_curstash);
4904 save_item(PL_curstname);
4906 PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
4908 sv_setsv(PL_curstname, sv);
4910 PL_hints |= HINT_BLOCK_SCOPE;
4911 PL_parser->copline = NOLINE;
4912 PL_parser->expect = XSTATE;
4917 if (!PL_madskills) {
4922 pegop = newOP(OP_NULL,0);
4923 op_getmad(o,pegop,'P');
4929 Perl_package_version( pTHX_ OP *v )
4932 U32 savehints = PL_hints;
4933 PERL_ARGS_ASSERT_PACKAGE_VERSION;
4934 PL_hints &= ~HINT_STRICT_VARS;
4935 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
4936 PL_hints = savehints;
4945 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
4952 OP *pegop = PL_madskills ? newOP(OP_NULL,0) : NULL;
4954 SV *use_version = NULL;
4956 PERL_ARGS_ASSERT_UTILIZE;
4958 if (idop->op_type != OP_CONST)
4959 Perl_croak(aTHX_ "Module name must be constant");
4962 op_getmad(idop,pegop,'U');
4967 SV * const vesv = ((SVOP*)version)->op_sv;
4970 op_getmad(version,pegop,'V');
4971 if (!arg && !SvNIOKp(vesv)) {
4978 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
4979 Perl_croak(aTHX_ "Version number must be a constant number");
4981 /* Make copy of idop so we don't free it twice */
4982 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
4984 /* Fake up a method call to VERSION */
4985 meth = newSVpvs_share("VERSION");
4986 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
4987 op_append_elem(OP_LIST,
4988 op_prepend_elem(OP_LIST, pack, list(version)),
4989 newSVOP(OP_METHOD_NAMED, 0, meth)));
4993 /* Fake up an import/unimport */
4994 if (arg && arg->op_type == OP_STUB) {
4996 op_getmad(arg,pegop,'S');
4997 imop = arg; /* no import on explicit () */
4999 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
5000 imop = NULL; /* use 5.0; */
5002 use_version = ((SVOP*)idop)->op_sv;
5004 idop->op_private |= OPpCONST_NOVER;
5010 op_getmad(arg,pegop,'A');
5012 /* Make copy of idop so we don't free it twice */
5013 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
5015 /* Fake up a method call to import/unimport */
5017 ? newSVpvs_share("import") : newSVpvs_share("unimport");
5018 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
5019 op_append_elem(OP_LIST,
5020 op_prepend_elem(OP_LIST, pack, list(arg)),
5021 newSVOP(OP_METHOD_NAMED, 0, meth)));
5024 /* Fake up the BEGIN {}, which does its thing immediately. */
5026 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
5029 op_append_elem(OP_LINESEQ,
5030 op_append_elem(OP_LINESEQ,
5031 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
5032 newSTATEOP(0, NULL, veop)),
5033 newSTATEOP(0, NULL, imop) ));
5037 * feature bundle that corresponds to the required version. */
5038 use_version = sv_2mortal(new_version(use_version));
5039 S_enable_feature_bundle(aTHX_ use_version);
5041 /* If a version >= 5.11.0 is requested, strictures are on by default! */
5042 if (vcmp(use_version,
5043 sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
5044 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
5045 PL_hints |= HINT_STRICT_REFS;
5046 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
5047 PL_hints |= HINT_STRICT_SUBS;
5048 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
5049 PL_hints |= HINT_STRICT_VARS;
5051 /* otherwise they are off */
5053 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
5054 PL_hints &= ~HINT_STRICT_REFS;
5055 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
5056 PL_hints &= ~HINT_STRICT_SUBS;
5057 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
5058 PL_hints &= ~HINT_STRICT_VARS;
5062 /* The "did you use incorrect case?" warning used to be here.
5063 * The problem is that on case-insensitive filesystems one
5064 * might get false positives for "use" (and "require"):
5065 * "use Strict" or "require CARP" will work. This causes
5066 * portability problems for the script: in case-strict
5067 * filesystems the script will stop working.
5069 * The "incorrect case" warning checked whether "use Foo"
5070 * imported "Foo" to your namespace, but that is wrong, too:
5071 * there is no requirement nor promise in the language that
5072 * a Foo.pm should or would contain anything in package "Foo".
5074 * There is very little Configure-wise that can be done, either:
5075 * the case-sensitivity of the build filesystem of Perl does not
5076 * help in guessing the case-sensitivity of the runtime environment.
5079 PL_hints |= HINT_BLOCK_SCOPE;
5080 PL_parser->copline = NOLINE;
5081 PL_parser->expect = XSTATE;
5082 PL_cop_seqmax++; /* Purely for B::*'s benefit */
5083 if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
5092 =head1 Embedding Functions
5094 =for apidoc load_module
5096 Loads the module whose name is pointed to by the string part of name.
5097 Note that the actual module name, not its filename, should be given.
5098 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
5099 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
5100 (or 0 for no flags). ver, if specified and not NULL, provides version semantics
5101 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
5102 arguments can be used to specify arguments to the module's import()
5103 method, similar to C<use Foo::Bar VERSION LIST>. They must be
5104 terminated with a final NULL pointer. Note that this list can only
5105 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
5106 Otherwise at least a single NULL pointer to designate the default
5107 import list is required.
5109 The reference count for each specified C<SV*> parameter is decremented.
5114 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
5118 PERL_ARGS_ASSERT_LOAD_MODULE;
5120 va_start(args, ver);
5121 vload_module(flags, name, ver, &args);
5125 #ifdef PERL_IMPLICIT_CONTEXT
5127 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
5131 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
5132 va_start(args, ver);
5133 vload_module(flags, name, ver, &args);
5139 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
5143 OP * const modname = newSVOP(OP_CONST, 0, name);
5145 PERL_ARGS_ASSERT_VLOAD_MODULE;
5147 modname->op_private |= OPpCONST_BARE;
5149 veop = newSVOP(OP_CONST, 0, ver);
5153 if (flags & PERL_LOADMOD_NOIMPORT) {
5154 imop = sawparens(newNULLLIST());
5156 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
5157 imop = va_arg(*args, OP*);
5162 sv = va_arg(*args, SV*);
5164 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
5165 sv = va_arg(*args, SV*);
5169 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
5170 * that it has a PL_parser to play with while doing that, and also
5171 * that it doesn't mess with any existing parser, by creating a tmp
5172 * new parser with lex_start(). This won't actually be used for much,
5173 * since pp_require() will create another parser for the real work. */
5176 SAVEVPTR(PL_curcop);
5177 lex_start(NULL, NULL, LEX_START_SAME_FILTER);
5178 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
5179 veop, modname, imop);
5184 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
5190 PERL_ARGS_ASSERT_DOFILE;
5192 if (!force_builtin) {
5193 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
5194 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5195 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
5196 gv = gvp ? *gvp : NULL;
5200 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5201 doop = newUNOP(OP_ENTERSUB, OPf_STACKED,
5202 op_append_elem(OP_LIST, term,
5203 scalar(newUNOP(OP_RV2CV, 0,
5204 newGVOP(OP_GV, 0, gv)))));
5207 doop = newUNOP(OP_DOFILE, 0, scalar(term));
5213 =head1 Optree construction
5215 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
5217 Constructs, checks, and returns an C<lslice> (list slice) op. I<flags>
5218 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
5219 be set automatically, and, shifted up eight bits, the eight bits of
5220 C<op_private>, except that the bit with value 1 or 2 is automatically
5221 set as required. I<listval> and I<subscript> supply the parameters of
5222 the slice; they are consumed by this function and become part of the
5223 constructed op tree.
5229 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
5231 return newBINOP(OP_LSLICE, flags,
5232 list(force_list(subscript)),
5233 list(force_list(listval)) );
5237 S_is_list_assignment(pTHX_ register const OP *o)
5245 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
5246 o = cUNOPo->op_first;
5248 flags = o->op_flags;
5250 if (type == OP_COND_EXPR) {
5251 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
5252 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
5257 yyerror("Assignment to both a list and a scalar");
5261 if (type == OP_LIST &&
5262 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
5263 o->op_private & OPpLVAL_INTRO)
5266 if (type == OP_LIST || flags & OPf_PARENS ||
5267 type == OP_RV2AV || type == OP_RV2HV ||
5268 type == OP_ASLICE || type == OP_HSLICE)
5271 if (type == OP_PADAV || type == OP_PADHV)
5274 if (type == OP_RV2SV)
5281 Helper function for newASSIGNOP to detection commonality between the
5282 lhs and the rhs. Marks all variables with PL_generation. If it
5283 returns TRUE the assignment must be able to handle common variables.
5285 PERL_STATIC_INLINE bool
5286 S_aassign_common_vars(pTHX_ OP* o)
5289 for (curop = cUNOPo->op_first; curop; curop=curop->op_sibling) {
5290 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
5291 if (curop->op_type == OP_GV) {
5292 GV *gv = cGVOPx_gv(curop);
5294 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
5296 GvASSIGN_GENERATION_set(gv, PL_generation);
5298 else if (curop->op_type == OP_PADSV ||
5299 curop->op_type == OP_PADAV ||
5300 curop->op_type == OP_PADHV ||
5301 curop->op_type == OP_PADANY)
5303 if (PAD_COMPNAME_GEN(curop->op_targ)
5304 == (STRLEN)PL_generation)
5306 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
5309 else if (curop->op_type == OP_RV2CV)
5311 else if (curop->op_type == OP_RV2SV ||
5312 curop->op_type == OP_RV2AV ||
5313 curop->op_type == OP_RV2HV ||
5314 curop->op_type == OP_RV2GV) {
5315 if (cUNOPx(curop)->op_first->op_type != OP_GV) /* funny deref? */
5318 else if (curop->op_type == OP_PUSHRE) {
5320 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
5321 GV *const gv = MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff));
5323 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
5325 GvASSIGN_GENERATION_set(gv, PL_generation);
5329 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
5332 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
5334 GvASSIGN_GENERATION_set(gv, PL_generation);
5342 if (curop->op_flags & OPf_KIDS) {
5343 if (aassign_common_vars(curop))
5351 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
5353 Constructs, checks, and returns an assignment op. I<left> and I<right>
5354 supply the parameters of the assignment; they are consumed by this
5355 function and become part of the constructed op tree.
5357 If I<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
5358 a suitable conditional optree is constructed. If I<optype> is the opcode
5359 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
5360 performs the binary operation and assigns the result to the left argument.
5361 Either way, if I<optype> is non-zero then I<flags> has no effect.
5363 If I<optype> is zero, then a plain scalar or list assignment is
5364 constructed. Which type of assignment it is is automatically determined.
5365 I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
5366 will be set automatically, and, shifted up eight bits, the eight bits
5367 of C<op_private>, except that the bit with value 1 or 2 is automatically
5374 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
5380 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
5381 return newLOGOP(optype, 0,
5382 op_lvalue(scalar(left), optype),
5383 newUNOP(OP_SASSIGN, 0, scalar(right)));
5386 return newBINOP(optype, OPf_STACKED,
5387 op_lvalue(scalar(left), optype), scalar(right));
5391 if (is_list_assignment(left)) {
5392 static const char no_list_state[] = "Initialization of state variables"
5393 " in list context currently forbidden";
5395 bool maybe_common_vars = TRUE;
5398 left = op_lvalue(left, OP_AASSIGN);
5399 curop = list(force_list(left));
5400 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
5401 o->op_private = (U8)(0 | (flags >> 8));
5403 if ((left->op_type == OP_LIST
5404 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
5406 OP* lop = ((LISTOP*)left)->op_first;
5407 maybe_common_vars = FALSE;
5409 if (lop->op_type == OP_PADSV ||
5410 lop->op_type == OP_PADAV ||
5411 lop->op_type == OP_PADHV ||
5412 lop->op_type == OP_PADANY) {
5413 if (!(lop->op_private & OPpLVAL_INTRO))
5414 maybe_common_vars = TRUE;
5416 if (lop->op_private & OPpPAD_STATE) {
5417 if (left->op_private & OPpLVAL_INTRO) {
5418 /* Each variable in state($a, $b, $c) = ... */
5421 /* Each state variable in
5422 (state $a, my $b, our $c, $d, undef) = ... */
5424 yyerror(no_list_state);
5426 /* Each my variable in
5427 (state $a, my $b, our $c, $d, undef) = ... */
5429 } else if (lop->op_type == OP_UNDEF ||
5430 lop->op_type == OP_PUSHMARK) {
5431 /* undef may be interesting in
5432 (state $a, undef, state $c) */
5434 /* Other ops in the list. */
5435 maybe_common_vars = TRUE;
5437 lop = lop->op_sibling;
5440 else if ((left->op_private & OPpLVAL_INTRO)
5441 && ( left->op_type == OP_PADSV
5442 || left->op_type == OP_PADAV
5443 || left->op_type == OP_PADHV
5444 || left->op_type == OP_PADANY))
5446 if (left->op_type == OP_PADSV) maybe_common_vars = FALSE;
5447 if (left->op_private & OPpPAD_STATE) {
5448 /* All single variable list context state assignments, hence
5458 yyerror(no_list_state);
5462 /* PL_generation sorcery:
5463 * an assignment like ($a,$b) = ($c,$d) is easier than
5464 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
5465 * To detect whether there are common vars, the global var
5466 * PL_generation is incremented for each assign op we compile.
5467 * Then, while compiling the assign op, we run through all the
5468 * variables on both sides of the assignment, setting a spare slot
5469 * in each of them to PL_generation. If any of them already have
5470 * that value, we know we've got commonality. We could use a
5471 * single bit marker, but then we'd have to make 2 passes, first
5472 * to clear the flag, then to test and set it. To find somewhere
5473 * to store these values, evil chicanery is done with SvUVX().
5476 if (maybe_common_vars) {
5478 if (aassign_common_vars(o))
5479 o->op_private |= OPpASSIGN_COMMON;
5483 if (right && right->op_type == OP_SPLIT && !PL_madskills) {
5484 OP* tmpop = ((LISTOP*)right)->op_first;
5485 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
5486 PMOP * const pm = (PMOP*)tmpop;
5487 if (left->op_type == OP_RV2AV &&
5488 !(left->op_private & OPpLVAL_INTRO) &&
5489 !(o->op_private & OPpASSIGN_COMMON) )
5491 tmpop = ((UNOP*)left)->op_first;
5492 if (tmpop->op_type == OP_GV
5494 && !pm->op_pmreplrootu.op_pmtargetoff
5496 && !pm->op_pmreplrootu.op_pmtargetgv
5500 pm->op_pmreplrootu.op_pmtargetoff
5501 = cPADOPx(tmpop)->op_padix;
5502 cPADOPx(tmpop)->op_padix = 0; /* steal it */
5504 pm->op_pmreplrootu.op_pmtargetgv
5505 = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
5506 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
5508 pm->op_pmflags |= PMf_ONCE;
5509 tmpop = cUNOPo->op_first; /* to list (nulled) */
5510 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
5511 tmpop->op_sibling = NULL; /* don't free split */
5512 right->op_next = tmpop->op_next; /* fix starting loc */
5513 op_free(o); /* blow off assign */
5514 right->op_flags &= ~OPf_WANT;
5515 /* "I don't know and I don't care." */
5520 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
5521 ((LISTOP*)right)->op_last->op_type == OP_CONST)
5523 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
5524 if (SvIOK(sv) && SvIVX(sv) == 0)
5525 sv_setiv(sv, PL_modcount+1);
5533 right = newOP(OP_UNDEF, 0);
5534 if (right->op_type == OP_READLINE) {
5535 right->op_flags |= OPf_STACKED;
5536 return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
5540 o = newBINOP(OP_SASSIGN, flags,
5541 scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
5547 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
5549 Constructs a state op (COP). The state op is normally a C<nextstate> op,
5550 but will be a C<dbstate> op if debugging is enabled for currently-compiled
5551 code. The state op is populated from L</PL_curcop> (or L</PL_compiling>).
5552 If I<label> is non-null, it supplies the name of a label to attach to
5553 the state op; this function takes ownership of the memory pointed at by
5554 I<label>, and will free it. I<flags> gives the eight bits of C<op_flags>
5557 If I<o> is null, the state op is returned. Otherwise the state op is
5558 combined with I<o> into a C<lineseq> list op, which is returned. I<o>
5559 is consumed by this function and becomes part of the returned op tree.
5565 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
5568 const U32 seq = intro_my();
5569 const U32 utf8 = flags & SVf_UTF8;
5574 NewOp(1101, cop, 1, COP);
5575 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
5576 cop->op_type = OP_DBSTATE;
5577 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
5580 cop->op_type = OP_NEXTSTATE;
5581 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
5583 cop->op_flags = (U8)flags;
5584 CopHINTS_set(cop, PL_hints);
5586 cop->op_private |= NATIVE_HINTS;
5588 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
5589 cop->op_next = (OP*)cop;
5592 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
5593 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
5595 Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
5597 PL_hints |= HINT_BLOCK_SCOPE;
5598 /* It seems that we need to defer freeing this pointer, as other parts
5599 of the grammar end up wanting to copy it after this op has been
5604 if (PL_parser && PL_parser->copline == NOLINE)
5605 CopLINE_set(cop, CopLINE(PL_curcop));
5607 CopLINE_set(cop, PL_parser->copline);
5608 PL_parser->copline = NOLINE;
5611 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
5613 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
5615 CopSTASH_set(cop, PL_curstash);
5617 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) {
5618 /* this line can have a breakpoint - store the cop in IV */
5619 AV *av = CopFILEAVx(PL_curcop);
5621 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
5622 if (svp && *svp != &PL_sv_undef ) {
5623 (void)SvIOK_on(*svp);
5624 SvIV_set(*svp, PTR2IV(cop));
5629 if (flags & OPf_SPECIAL)
5631 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
5635 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
5637 Constructs, checks, and returns a logical (flow control) op. I<type>
5638 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
5639 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
5640 the eight bits of C<op_private>, except that the bit with value 1 is
5641 automatically set. I<first> supplies the expression controlling the
5642 flow, and I<other> supplies the side (alternate) chain of ops; they are
5643 consumed by this function and become part of the constructed op tree.
5649 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
5653 PERL_ARGS_ASSERT_NEWLOGOP;
5655 return new_logop(type, flags, &first, &other);
5659 S_search_const(pTHX_ OP *o)
5661 PERL_ARGS_ASSERT_SEARCH_CONST;
5663 switch (o->op_type) {
5667 if (o->op_flags & OPf_KIDS)
5668 return search_const(cUNOPo->op_first);
5675 if (!(o->op_flags & OPf_KIDS))
5677 kid = cLISTOPo->op_first;
5679 switch (kid->op_type) {
5683 kid = kid->op_sibling;
5686 if (kid != cLISTOPo->op_last)
5692 kid = cLISTOPo->op_last;
5694 return search_const(kid);
5702 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
5710 int prepend_not = 0;
5712 PERL_ARGS_ASSERT_NEW_LOGOP;
5717 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
5718 return newBINOP(type, flags, scalar(first), scalar(other));
5720 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP);
5722 scalarboolean(first);
5723 /* optimize AND and OR ops that have NOTs as children */
5724 if (first->op_type == OP_NOT
5725 && (first->op_flags & OPf_KIDS)
5726 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
5727 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
5729 if (type == OP_AND || type == OP_OR) {
5735 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
5737 prepend_not = 1; /* prepend a NOT op later */
5741 /* search for a constant op that could let us fold the test */
5742 if ((cstop = search_const(first))) {
5743 if (cstop->op_private & OPpCONST_STRICT)
5744 no_bareword_allowed(cstop);
5745 else if ((cstop->op_private & OPpCONST_BARE))
5746 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
5747 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
5748 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
5749 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
5751 if (other->op_type == OP_CONST)
5752 other->op_private |= OPpCONST_SHORTCIRCUIT;
5754 OP *newop = newUNOP(OP_NULL, 0, other);
5755 op_getmad(first, newop, '1');
5756 newop->op_targ = type; /* set "was" field */
5760 if (other->op_type == OP_LEAVE)
5761 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
5762 else if (other->op_type == OP_MATCH
5763 || other->op_type == OP_SUBST
5764 || other->op_type == OP_TRANSR
5765 || other->op_type == OP_TRANS)
5766 /* Mark the op as being unbindable with =~ */
5767 other->op_flags |= OPf_SPECIAL;
5768 else if (other->op_type == OP_CONST)
5769 other->op_private |= OPpCONST_FOLDED;
5773 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
5774 const OP *o2 = other;
5775 if ( ! (o2->op_type == OP_LIST
5776 && (( o2 = cUNOPx(o2)->op_first))
5777 && o2->op_type == OP_PUSHMARK
5778 && (( o2 = o2->op_sibling)) )
5781 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
5782 || o2->op_type == OP_PADHV)
5783 && o2->op_private & OPpLVAL_INTRO
5784 && !(o2->op_private & OPpPAD_STATE))
5786 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
5787 "Deprecated use of my() in false conditional");
5791 if (first->op_type == OP_CONST)
5792 first->op_private |= OPpCONST_SHORTCIRCUIT;
5794 first = newUNOP(OP_NULL, 0, first);
5795 op_getmad(other, first, '2');
5796 first->op_targ = type; /* set "was" field */
5803 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
5804 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
5806 const OP * const k1 = ((UNOP*)first)->op_first;
5807 const OP * const k2 = k1->op_sibling;
5809 switch (first->op_type)
5812 if (k2 && k2->op_type == OP_READLINE
5813 && (k2->op_flags & OPf_STACKED)
5814 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5816 warnop = k2->op_type;
5821 if (k1->op_type == OP_READDIR
5822 || k1->op_type == OP_GLOB
5823 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5824 || k1->op_type == OP_EACH
5825 || k1->op_type == OP_AEACH)
5827 warnop = ((k1->op_type == OP_NULL)
5828 ? (OPCODE)k1->op_targ : k1->op_type);
5833 const line_t oldline = CopLINE(PL_curcop);
5834 CopLINE_set(PL_curcop, PL_parser->copline);
5835 Perl_warner(aTHX_ packWARN(WARN_MISC),
5836 "Value of %s%s can be \"0\"; test with defined()",
5838 ((warnop == OP_READLINE || warnop == OP_GLOB)
5839 ? " construct" : "() operator"));
5840 CopLINE_set(PL_curcop, oldline);
5847 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
5848 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
5850 NewOp(1101, logop, 1, LOGOP);
5852 logop->op_type = (OPCODE)type;
5853 logop->op_ppaddr = PL_ppaddr[type];
5854 logop->op_first = first;
5855 logop->op_flags = (U8)(flags | OPf_KIDS);
5856 logop->op_other = LINKLIST(other);
5857 logop->op_private = (U8)(1 | (flags >> 8));
5859 /* establish postfix order */
5860 logop->op_next = LINKLIST(first);
5861 first->op_next = (OP*)logop;
5862 first->op_sibling = other;
5864 CHECKOP(type,logop);
5866 o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
5873 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
5875 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
5876 op. I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
5877 will be set automatically, and, shifted up eight bits, the eight bits of
5878 C<op_private>, except that the bit with value 1 is automatically set.
5879 I<first> supplies the expression selecting between the two branches,
5880 and I<trueop> and I<falseop> supply the branches; they are consumed by
5881 this function and become part of the constructed op tree.
5887 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
5895 PERL_ARGS_ASSERT_NEWCONDOP;
5898 return newLOGOP(OP_AND, 0, first, trueop);
5900 return newLOGOP(OP_OR, 0, first, falseop);
5902 scalarboolean(first);
5903 if ((cstop = search_const(first))) {
5904 /* Left or right arm of the conditional? */
5905 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
5906 OP *live = left ? trueop : falseop;
5907 OP *const dead = left ? falseop : trueop;
5908 if (cstop->op_private & OPpCONST_BARE &&
5909 cstop->op_private & OPpCONST_STRICT) {
5910 no_bareword_allowed(cstop);
5913 /* This is all dead code when PERL_MAD is not defined. */
5914 live = newUNOP(OP_NULL, 0, live);
5915 op_getmad(first, live, 'C');
5916 op_getmad(dead, live, left ? 'e' : 't');
5921 if (live->op_type == OP_LEAVE)
5922 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
5923 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
5924 || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
5925 /* Mark the op as being unbindable with =~ */
5926 live->op_flags |= OPf_SPECIAL;
5927 else if (live->op_type == OP_CONST)
5928 live->op_private |= OPpCONST_FOLDED;
5931 NewOp(1101, logop, 1, LOGOP);
5932 logop->op_type = OP_COND_EXPR;
5933 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
5934 logop->op_first = first;
5935 logop->op_flags = (U8)(flags | OPf_KIDS);
5936 logop->op_private = (U8)(1 | (flags >> 8));
5937 logop->op_other = LINKLIST(trueop);
5938 logop->op_next = LINKLIST(falseop);
5940 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
5943 /* establish postfix order */
5944 start = LINKLIST(first);
5945 first->op_next = (OP*)logop;
5947 first->op_sibling = trueop;
5948 trueop->op_sibling = falseop;
5949 o = newUNOP(OP_NULL, 0, (OP*)logop);
5951 trueop->op_next = falseop->op_next = o;
5958 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
5960 Constructs and returns a C<range> op, with subordinate C<flip> and
5961 C<flop> ops. I<flags> gives the eight bits of C<op_flags> for the
5962 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
5963 for both the C<flip> and C<range> ops, except that the bit with value
5964 1 is automatically set. I<left> and I<right> supply the expressions
5965 controlling the endpoints of the range; they are consumed by this function
5966 and become part of the constructed op tree.
5972 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
5981 PERL_ARGS_ASSERT_NEWRANGE;
5983 NewOp(1101, range, 1, LOGOP);
5985 range->op_type = OP_RANGE;
5986 range->op_ppaddr = PL_ppaddr[OP_RANGE];
5987 range->op_first = left;
5988 range->op_flags = OPf_KIDS;
5989 leftstart = LINKLIST(left);
5990 range->op_other = LINKLIST(right);
5991 range->op_private = (U8)(1 | (flags >> 8));
5993 left->op_sibling = right;
5995 range->op_next = (OP*)range;
5996 flip = newUNOP(OP_FLIP, flags, (OP*)range);
5997 flop = newUNOP(OP_FLOP, 0, flip);
5998 o = newUNOP(OP_NULL, 0, flop);
6000 range->op_next = leftstart;
6002 left->op_next = flip;
6003 right->op_next = flop;
6005 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
6006 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
6007 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
6008 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
6010 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
6011 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
6013 /* check barewords before they might be optimized aways */
6014 if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
6015 no_bareword_allowed(left);
6016 if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
6017 no_bareword_allowed(right);
6020 if (!flip->op_private || !flop->op_private)
6021 LINKLIST(o); /* blow off optimizer unless constant */
6027 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
6029 Constructs, checks, and returns an op tree expressing a loop. This is
6030 only a loop in the control flow through the op tree; it does not have
6031 the heavyweight loop structure that allows exiting the loop by C<last>
6032 and suchlike. I<flags> gives the eight bits of C<op_flags> for the
6033 top-level op, except that some bits will be set automatically as required.
6034 I<expr> supplies the expression controlling loop iteration, and I<block>
6035 supplies the body of the loop; they are consumed by this function and
6036 become part of the constructed op tree. I<debuggable> is currently
6037 unused and should always be 1.
6043 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
6048 const bool once = block && block->op_flags & OPf_SPECIAL &&
6049 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
6051 PERL_UNUSED_ARG(debuggable);
6054 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
6055 return block; /* do {} while 0 does once */
6056 if (expr->op_type == OP_READLINE
6057 || expr->op_type == OP_READDIR
6058 || expr->op_type == OP_GLOB
6059 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
6060 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
6061 expr = newUNOP(OP_DEFINED, 0,
6062 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
6063 } else if (expr->op_flags & OPf_KIDS) {
6064 const OP * const k1 = ((UNOP*)expr)->op_first;
6065 const OP * const k2 = k1 ? k1->op_sibling : NULL;
6066 switch (expr->op_type) {
6068 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
6069 && (k2->op_flags & OPf_STACKED)
6070 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
6071 expr = newUNOP(OP_DEFINED, 0, expr);
6075 if (k1 && (k1->op_type == OP_READDIR
6076 || k1->op_type == OP_GLOB
6077 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
6078 || k1->op_type == OP_EACH
6079 || k1->op_type == OP_AEACH))
6080 expr = newUNOP(OP_DEFINED, 0, expr);
6086 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
6087 * op, in listop. This is wrong. [perl #27024] */
6089 block = newOP(OP_NULL, 0);
6090 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
6091 o = new_logop(OP_AND, 0, &expr, &listop);
6094 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
6096 if (once && o != listop)
6097 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
6100 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
6102 o->op_flags |= flags;
6104 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
6109 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
6111 Constructs, checks, and returns an op tree expressing a C<while> loop.
6112 This is a heavyweight loop, with structure that allows exiting the loop
6113 by C<last> and suchlike.
6115 I<loop> is an optional preconstructed C<enterloop> op to use in the
6116 loop; if it is null then a suitable op will be constructed automatically.
6117 I<expr> supplies the loop's controlling expression. I<block> supplies the
6118 main body of the loop, and I<cont> optionally supplies a C<continue> block
6119 that operates as a second half of the body. All of these optree inputs
6120 are consumed by this function and become part of the constructed op tree.
6122 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
6123 op and, shifted up eight bits, the eight bits of C<op_private> for
6124 the C<leaveloop> op, except that (in both cases) some bits will be set
6125 automatically. I<debuggable> is currently unused and should always be 1.
6126 I<has_my> can be supplied as true to force the
6127 loop body to be enclosed in its own scope.
6133 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
6134 OP *expr, OP *block, OP *cont, I32 has_my)
6143 PERL_UNUSED_ARG(debuggable);
6146 if (expr->op_type == OP_READLINE
6147 || expr->op_type == OP_READDIR
6148 || expr->op_type == OP_GLOB
6149 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
6150 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
6151 expr = newUNOP(OP_DEFINED, 0,
6152 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
6153 } else if (expr->op_flags & OPf_KIDS) {
6154 const OP * const k1 = ((UNOP*)expr)->op_first;
6155 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
6156 switch (expr->op_type) {
6158 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
6159 && (k2->op_flags & OPf_STACKED)
6160 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
6161 expr = newUNOP(OP_DEFINED, 0, expr);
6165 if (k1 && (k1->op_type == OP_READDIR
6166 || k1->op_type == OP_GLOB
6167 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
6168 || k1->op_type == OP_EACH
6169 || k1->op_type == OP_AEACH))
6170 expr = newUNOP(OP_DEFINED, 0, expr);
6177 block = newOP(OP_NULL, 0);
6178 else if (cont || has_my) {
6179 block = op_scope(block);
6183 next = LINKLIST(cont);
6186 OP * const unstack = newOP(OP_UNSTACK, 0);
6189 cont = op_append_elem(OP_LINESEQ, cont, unstack);
6193 listop = op_append_list(OP_LINESEQ, block, cont);
6195 redo = LINKLIST(listop);
6199 o = new_logop(OP_AND, 0, &expr, &listop);
6200 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
6202 return expr; /* listop already freed by new_logop */
6205 ((LISTOP*)listop)->op_last->op_next =
6206 (o == listop ? redo : LINKLIST(o));
6212 NewOp(1101,loop,1,LOOP);
6213 loop->op_type = OP_ENTERLOOP;
6214 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
6215 loop->op_private = 0;
6216 loop->op_next = (OP*)loop;
6219 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
6221 loop->op_redoop = redo;
6222 loop->op_lastop = o;
6223 o->op_private |= loopflags;
6226 loop->op_nextop = next;
6228 loop->op_nextop = o;
6230 o->op_flags |= flags;
6231 o->op_private |= (flags >> 8);
6236 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
6238 Constructs, checks, and returns an op tree expressing a C<foreach>
6239 loop (iteration through a list of values). This is a heavyweight loop,
6240 with structure that allows exiting the loop by C<last> and suchlike.
6242 I<sv> optionally supplies the variable that will be aliased to each
6243 item in turn; if null, it defaults to C<$_> (either lexical or global).
6244 I<expr> supplies the list of values to iterate over. I<block> supplies
6245 the main body of the loop, and I<cont> optionally supplies a C<continue>
6246 block that operates as a second half of the body. All of these optree
6247 inputs are consumed by this function and become part of the constructed
6250 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
6251 op and, shifted up eight bits, the eight bits of C<op_private> for
6252 the C<leaveloop> op, except that (in both cases) some bits will be set
6259 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
6264 PADOFFSET padoff = 0;
6269 PERL_ARGS_ASSERT_NEWFOROP;
6272 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
6273 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
6274 sv->op_type = OP_RV2GV;
6275 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
6277 /* The op_type check is needed to prevent a possible segfault
6278 * if the loop variable is undeclared and 'strict vars' is in
6279 * effect. This is illegal but is nonetheless parsed, so we
6280 * may reach this point with an OP_CONST where we're expecting
6283 if (cUNOPx(sv)->op_first->op_type == OP_GV
6284 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
6285 iterpflags |= OPpITER_DEF;
6287 else if (sv->op_type == OP_PADSV) { /* private variable */
6288 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
6289 padoff = sv->op_targ;
6299 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
6301 SV *const namesv = PAD_COMPNAME_SV(padoff);
6303 const char *const name = SvPV_const(namesv, len);
6305 if (len == 2 && name[0] == '$' && name[1] == '_')
6306 iterpflags |= OPpITER_DEF;
6310 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
6311 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
6312 sv = newGVOP(OP_GV, 0, PL_defgv);
6317 iterpflags |= OPpITER_DEF;
6319 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
6320 expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
6321 iterflags |= OPf_STACKED;
6323 else if (expr->op_type == OP_NULL &&
6324 (expr->op_flags & OPf_KIDS) &&
6325 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
6327 /* Basically turn for($x..$y) into the same as for($x,$y), but we
6328 * set the STACKED flag to indicate that these values are to be
6329 * treated as min/max values by 'pp_iterinit'.
6331 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
6332 LOGOP* const range = (LOGOP*) flip->op_first;
6333 OP* const left = range->op_first;
6334 OP* const right = left->op_sibling;
6337 range->op_flags &= ~OPf_KIDS;
6338 range->op_first = NULL;
6340 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
6341 listop->op_first->op_next = range->op_next;
6342 left->op_next = range->op_other;
6343 right->op_next = (OP*)listop;
6344 listop->op_next = listop->op_first;
6347 op_getmad(expr,(OP*)listop,'O');
6351 expr = (OP*)(listop);
6353 iterflags |= OPf_STACKED;
6356 expr = op_lvalue(force_list(expr), OP_GREPSTART);
6359 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
6360 op_append_elem(OP_LIST, expr, scalar(sv))));
6361 assert(!loop->op_next);
6362 /* for my $x () sets OPpLVAL_INTRO;
6363 * for our $x () sets OPpOUR_INTRO */
6364 loop->op_private = (U8)iterpflags;
6365 if (loop->op_slabbed
6366 && DIFF(loop, OpSLOT(loop)->opslot_next)
6367 < SIZE_TO_PSIZE(sizeof(LOOP)))
6370 NewOp(1234,tmp,1,LOOP);
6371 Copy(loop,tmp,1,LISTOP);
6372 S_op_destroy(aTHX_ (OP*)loop);
6375 else if (!loop->op_slabbed)
6376 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
6377 loop->op_targ = padoff;
6378 wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
6380 op_getmad(madsv, (OP*)loop, 'v');
6385 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
6387 Constructs, checks, and returns a loop-exiting op (such as C<goto>
6388 or C<last>). I<type> is the opcode. I<label> supplies the parameter
6389 determining the target of the op; it is consumed by this function and
6390 becomes part of the constructed op tree.
6396 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
6401 PERL_ARGS_ASSERT_NEWLOOPEX;
6403 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
6405 if (type != OP_GOTO) {
6406 /* "last()" means "last" */
6407 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
6408 o = newOP(type, OPf_SPECIAL);
6412 /* Check whether it's going to be a goto &function */
6413 if (label->op_type == OP_ENTERSUB
6414 && !(label->op_flags & OPf_STACKED))
6415 label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
6418 /* Check for a constant argument */
6419 if (label->op_type == OP_CONST) {
6420 SV * const sv = ((SVOP *)label)->op_sv;
6422 const char *s = SvPV_const(sv,l);
6423 if (l == strlen(s)) {
6425 SvUTF8(((SVOP*)label)->op_sv),
6427 SvPV_nolen_const(((SVOP*)label)->op_sv)));
6431 /* If we have already created an op, we do not need the label. */
6434 op_getmad(label,o,'L');
6438 else o = newUNOP(type, OPf_STACKED, label);
6440 PL_hints |= HINT_BLOCK_SCOPE;
6444 /* if the condition is a literal array or hash
6445 (or @{ ... } etc), make a reference to it.
6448 S_ref_array_or_hash(pTHX_ OP *cond)
6451 && (cond->op_type == OP_RV2AV
6452 || cond->op_type == OP_PADAV
6453 || cond->op_type == OP_RV2HV
6454 || cond->op_type == OP_PADHV))
6456 return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
6459 && (cond->op_type == OP_ASLICE
6460 || cond->op_type == OP_HSLICE)) {
6462 /* anonlist now needs a list from this op, was previously used in
6464 cond->op_flags |= ~(OPf_WANT_SCALAR | OPf_REF);
6465 cond->op_flags |= OPf_WANT_LIST;
6467 return newANONLIST(op_lvalue(cond, OP_ANONLIST));
6474 /* These construct the optree fragments representing given()
6477 entergiven and enterwhen are LOGOPs; the op_other pointer
6478 points up to the associated leave op. We need this so we
6479 can put it in the context and make break/continue work.
6480 (Also, of course, pp_enterwhen will jump straight to
6481 op_other if the match fails.)
6485 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
6486 I32 enter_opcode, I32 leave_opcode,
6487 PADOFFSET entertarg)
6493 PERL_ARGS_ASSERT_NEWGIVWHENOP;
6495 NewOp(1101, enterop, 1, LOGOP);
6496 enterop->op_type = (Optype)enter_opcode;
6497 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
6498 enterop->op_flags = (U8) OPf_KIDS;
6499 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
6500 enterop->op_private = 0;
6502 o = newUNOP(leave_opcode, 0, (OP *) enterop);
6505 enterop->op_first = scalar(cond);
6506 cond->op_sibling = block;
6508 o->op_next = LINKLIST(cond);
6509 cond->op_next = (OP *) enterop;
6512 /* This is a default {} block */
6513 enterop->op_first = block;
6514 enterop->op_flags |= OPf_SPECIAL;
6515 o ->op_flags |= OPf_SPECIAL;
6517 o->op_next = (OP *) enterop;
6520 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
6521 entergiven and enterwhen both
6524 enterop->op_next = LINKLIST(block);
6525 block->op_next = enterop->op_other = o;
6530 /* Does this look like a boolean operation? For these purposes
6531 a boolean operation is:
6532 - a subroutine call [*]
6533 - a logical connective
6534 - a comparison operator
6535 - a filetest operator, with the exception of -s -M -A -C
6536 - defined(), exists() or eof()
6537 - /$re/ or $foo =~ /$re/
6539 [*] possibly surprising
6542 S_looks_like_bool(pTHX_ const OP *o)
6546 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
6548 switch(o->op_type) {
6551 return looks_like_bool(cLOGOPo->op_first);
6555 looks_like_bool(cLOGOPo->op_first)
6556 && looks_like_bool(cLOGOPo->op_first->op_sibling));
6561 o->op_flags & OPf_KIDS
6562 && looks_like_bool(cUNOPo->op_first));
6566 case OP_NOT: case OP_XOR:
6568 case OP_EQ: case OP_NE: case OP_LT:
6569 case OP_GT: case OP_LE: case OP_GE:
6571 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
6572 case OP_I_GT: case OP_I_LE: case OP_I_GE:
6574 case OP_SEQ: case OP_SNE: case OP_SLT:
6575 case OP_SGT: case OP_SLE: case OP_SGE:
6579 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
6580 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
6581 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
6582 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
6583 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
6584 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
6585 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
6586 case OP_FTTEXT: case OP_FTBINARY:
6588 case OP_DEFINED: case OP_EXISTS:
6589 case OP_MATCH: case OP_EOF:
6596 /* Detect comparisons that have been optimized away */
6597 if (cSVOPo->op_sv == &PL_sv_yes
6598 || cSVOPo->op_sv == &PL_sv_no)
6611 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
6613 Constructs, checks, and returns an op tree expressing a C<given> block.
6614 I<cond> supplies the expression that will be locally assigned to a lexical
6615 variable, and I<block> supplies the body of the C<given> construct; they
6616 are consumed by this function and become part of the constructed op tree.
6617 I<defsv_off> is the pad offset of the scalar lexical variable that will
6624 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
6627 PERL_ARGS_ASSERT_NEWGIVENOP;
6628 return newGIVWHENOP(
6629 ref_array_or_hash(cond),
6631 OP_ENTERGIVEN, OP_LEAVEGIVEN,
6636 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
6638 Constructs, checks, and returns an op tree expressing a C<when> block.
6639 I<cond> supplies the test expression, and I<block> supplies the block
6640 that will be executed if the test evaluates to true; they are consumed
6641 by this function and become part of the constructed op tree. I<cond>
6642 will be interpreted DWIMically, often as a comparison against C<$_>,
6643 and may be null to generate a C<default> block.
6649 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
6651 const bool cond_llb = (!cond || looks_like_bool(cond));
6654 PERL_ARGS_ASSERT_NEWWHENOP;
6659 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
6661 scalar(ref_array_or_hash(cond)));
6664 return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
6668 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
6669 const STRLEN len, const U32 flags)
6671 const char * const cvp = SvROK(cv) ? "" : CvPROTO(cv);
6672 const STRLEN clen = CvPROTOLEN(cv);
6674 PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
6676 if (((!p != !cvp) /* One has prototype, one has not. */
6678 (flags & SVf_UTF8) == SvUTF8(cv)
6679 ? len != clen || memNE(cvp, p, len)
6681 ? bytes_cmp_utf8((const U8 *)cvp, clen,
6683 : bytes_cmp_utf8((const U8 *)p, len,
6684 (const U8 *)cvp, clen)
6688 && ckWARN_d(WARN_PROTOTYPE)) {
6689 SV* const msg = sv_newmortal();
6695 gv_efullname3(name = sv_newmortal(), gv, NULL);
6696 else name = (SV *)gv;
6698 sv_setpvs(msg, "Prototype mismatch:");
6700 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
6702 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")",
6703 SVfARG(newSVpvn_flags(cvp,clen, SvUTF8(cv)|SVs_TEMP))
6706 sv_catpvs(msg, ": none");
6707 sv_catpvs(msg, " vs ");
6709 Perl_sv_catpvf(aTHX_ msg, "(%"SVf")", SVfARG(newSVpvn_flags(p, len, flags | SVs_TEMP)));
6711 sv_catpvs(msg, "none");
6712 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
6716 static void const_sv_xsub(pTHX_ CV* cv);
6720 =head1 Optree Manipulation Functions
6722 =for apidoc cv_const_sv
6724 If C<cv> is a constant sub eligible for inlining. returns the constant
6725 value returned by the sub. Otherwise, returns NULL.
6727 Constant subs can be created with C<newCONSTSUB> or as described in
6728 L<perlsub/"Constant Functions">.
6733 Perl_cv_const_sv(pTHX_ const CV *const cv)
6735 PERL_UNUSED_CONTEXT;
6738 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
6740 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
6743 /* op_const_sv: examine an optree to determine whether it's in-lineable.
6744 * Can be called in 3 ways:
6747 * look for a single OP_CONST with attached value: return the value
6749 * cv && CvCLONE(cv) && !CvCONST(cv)
6751 * examine the clone prototype, and if contains only a single
6752 * OP_CONST referencing a pad const, or a single PADSV referencing
6753 * an outer lexical, return a non-zero value to indicate the CV is
6754 * a candidate for "constizing" at clone time
6758 * We have just cloned an anon prototype that was marked as a const
6759 * candidate. Try to grab the current value, and in the case of
6760 * PADSV, ignore it if it has multiple references. In this case we
6761 * return a newly created *copy* of the value.
6765 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
6776 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
6777 o = cLISTOPo->op_first->op_sibling;
6779 for (; o; o = o->op_next) {
6780 const OPCODE type = o->op_type;
6782 if (sv && o->op_next == o)
6784 if (o->op_next != o) {
6785 if (type == OP_NEXTSTATE
6786 || (type == OP_NULL && !(o->op_flags & OPf_KIDS))
6787 || type == OP_PUSHMARK)
6789 if (type == OP_DBSTATE)
6792 if (type == OP_LEAVESUB || type == OP_RETURN)
6796 if (type == OP_CONST && cSVOPo->op_sv)
6798 else if (cv && type == OP_CONST) {
6799 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
6803 else if (cv && type == OP_PADSV) {
6804 if (CvCONST(cv)) { /* newly cloned anon */
6805 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
6806 /* the candidate should have 1 ref from this pad and 1 ref
6807 * from the parent */
6808 if (!sv || SvREFCNT(sv) != 2)
6815 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
6816 sv = &PL_sv_undef; /* an arbitrary non-null value */
6831 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
6834 /* This would be the return value, but the return cannot be reached. */
6835 OP* pegop = newOP(OP_NULL, 0);
6838 PERL_UNUSED_ARG(floor);
6848 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
6850 NORETURN_FUNCTION_END;
6855 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
6857 return newATTRSUB_flags(floor, o, proto, attrs, block, 0);
6861 Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
6862 OP *block, U32 flags)
6867 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
6871 const bool ec = PL_parser && PL_parser->error_count;
6872 /* If the subroutine has no body, no attributes, and no builtin attributes
6873 then it's just a sub declaration, and we may be able to get away with
6874 storing with a placeholder scalar in the symbol table, rather than a
6875 full GV and CV. If anything is present then it will take a full CV to
6877 const I32 gv_fetch_flags
6878 = ec ? GV_NOADD_NOINIT :
6879 (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
6881 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
6883 const bool o_is_gv = flags & 1;
6884 const char * const name =
6885 o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
6887 bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
6888 #ifdef PERL_DEBUG_READONLY_OPS
6889 OPSLAB *slab = NULL;
6893 assert(proto->op_type == OP_CONST);
6894 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
6895 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
6905 gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
6907 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
6908 SV * const sv = sv_newmortal();
6909 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
6910 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
6911 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
6912 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
6914 } else if (PL_curstash) {
6915 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
6918 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
6922 if (!PL_madskills) {
6933 if (name && block) {
6934 const char *s = strrchr(name, ':');
6936 if (strEQ(s, "BEGIN")) {
6937 const char not_safe[] =
6938 "BEGIN not safe after errors--compilation aborted";
6939 if (PL_in_eval & EVAL_KEEPERR)
6940 Perl_croak(aTHX_ not_safe);
6942 /* force display of errors found but not reported */
6943 sv_catpv(ERRSV, not_safe);
6944 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
6952 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
6953 maximum a prototype before. */
6954 if (SvTYPE(gv) > SVt_NULL) {
6955 cv_ckproto_len_flags((const CV *)gv,
6956 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
6960 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
6961 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(gv));
6964 sv_setiv(MUTABLE_SV(gv), -1);
6966 SvREFCNT_dec(PL_compcv);
6967 cv = PL_compcv = NULL;
6971 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
6973 if (!block || !ps || *ps || attrs
6974 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
6976 || block->op_type == OP_NULL
6981 const_sv = op_const_sv(block, NULL);
6984 const bool exists = CvROOT(cv) || CvXSUB(cv);
6986 /* if the subroutine doesn't exist and wasn't pre-declared
6987 * with a prototype, assume it will be AUTOLOADed,
6988 * skipping the prototype check
6990 if (exists || SvPOK(cv))
6991 cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
6992 /* already defined (or promised)? */
6993 if (exists || GvASSUMECV(gv)) {
6996 || block->op_type == OP_NULL
6999 if (CvFLAGS(PL_compcv)) {
7000 /* might have had built-in attrs applied */
7001 const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
7002 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
7003 && ckWARN(WARN_MISC))
7004 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
7006 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
7007 & ~(CVf_LVALUE * pureperl));
7009 if (attrs) goto attrs;
7010 /* just a "sub foo;" when &foo is already defined */
7011 SAVEFREESV(PL_compcv);
7016 && block->op_type != OP_NULL
7019 const line_t oldline = CopLINE(PL_curcop);
7020 if (PL_parser && PL_parser->copline != NOLINE)
7021 CopLINE_set(PL_curcop, PL_parser->copline);
7022 report_redefined_cv(cSVOPo->op_sv, cv, &const_sv);
7023 CopLINE_set(PL_curcop, oldline);
7025 if (!PL_minus_c) /* keep old one around for madskills */
7028 /* (PL_madskills unset in used file.) */
7036 SvREFCNT_inc_simple_void_NN(const_sv);
7038 assert(!CvROOT(cv) && !CvCONST(cv));
7040 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
7041 CvXSUBANY(cv).any_ptr = const_sv;
7042 CvXSUB(cv) = const_sv_xsub;
7048 cv = newCONSTSUB_flags(
7049 NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
7056 SvREFCNT_dec(PL_compcv);
7060 if (cv) { /* must reuse cv if autoloaded */
7061 /* transfer PL_compcv to cv */
7064 && block->op_type != OP_NULL
7067 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
7068 PADLIST *const temp_av = CvPADLIST(cv);
7069 CV *const temp_cv = CvOUTSIDE(cv);
7070 const cv_flags_t other_flags =
7071 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
7072 OP * const cvstart = CvSTART(cv);
7075 assert(!CvCVGV_RC(cv));
7076 assert(CvGV(cv) == gv);
7079 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs;
7080 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
7081 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
7082 CvPADLIST(cv) = CvPADLIST(PL_compcv);
7083 CvOUTSIDE(PL_compcv) = temp_cv;
7084 CvPADLIST(PL_compcv) = temp_av;
7085 CvSTART(cv) = CvSTART(PL_compcv);
7086 CvSTART(PL_compcv) = cvstart;
7087 CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
7088 CvFLAGS(PL_compcv) |= other_flags;
7090 if (CvFILE(cv) && CvDYNFILE(cv)) {
7091 Safefree(CvFILE(cv));
7093 CvFILE_set_from_cop(cv, PL_curcop);
7094 CvSTASH_set(cv, PL_curstash);
7096 /* inner references to PL_compcv must be fixed up ... */
7097 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
7098 if (PERLDB_INTER)/* Advice debugger on the new sub. */
7099 ++PL_sub_generation;
7102 /* Might have had built-in attributes applied -- propagate them. */
7103 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
7105 /* ... before we throw it away */
7106 SvREFCNT_dec(PL_compcv);
7114 if (strEQ(name, "import")) {
7115 PL_formfeed = MUTABLE_SV(cv);
7116 /* diag_listed_as: SKIPME */
7117 Perl_warner(aTHX_ packWARN(WARN_VOID), "0x%"UVxf"\n", PTR2UV(cv));
7121 if (HvENAME_HEK(GvSTASH(gv)))
7122 /* sub Foo::bar { (shift)+1 } */
7123 mro_method_changed_in(GvSTASH(gv));
7128 CvFILE_set_from_cop(cv, PL_curcop);
7129 CvSTASH_set(cv, PL_curstash);
7133 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
7134 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
7141 /* If we assign an optree to a PVCV, then we've defined a subroutine that
7142 the debugger could be able to set a breakpoint in, so signal to
7143 pp_entereval that it should not throw away any saved lines at scope
7146 PL_breakable_sub_gen++;
7147 /* This makes sub {}; work as expected. */
7148 if (block->op_type == OP_STUB) {
7149 OP* const newblock = newSTATEOP(0, NULL, 0);
7151 op_getmad(block,newblock,'B');
7157 CvROOT(cv) = CvLVALUE(cv)
7158 ? newUNOP(OP_LEAVESUBLV, 0,
7159 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
7160 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
7161 CvROOT(cv)->op_private |= OPpREFCOUNTED;
7162 OpREFCNT_set(CvROOT(cv), 1);
7163 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
7164 itself has a refcount. */
7166 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
7167 #ifdef PERL_DEBUG_READONLY_OPS
7168 slab = (OPSLAB *)CvSTART(cv);
7170 CvSTART(cv) = LINKLIST(CvROOT(cv));
7171 CvROOT(cv)->op_next = 0;
7172 CALL_PEEP(CvSTART(cv));
7173 finalize_optree(CvROOT(cv));
7175 /* now that optimizer has done its work, adjust pad values */
7177 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
7180 assert(!CvCONST(cv));
7181 if (ps && !*ps && op_const_sv(block, cv))
7187 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
7188 HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
7189 apply_attrs(stash, MUTABLE_SV(cv), attrs, FALSE);
7192 if (block && has_name) {
7193 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
7194 SV * const tmpstr = sv_newmortal();
7195 GV * const db_postponed = gv_fetchpvs("DB::postponed",
7196 GV_ADDMULTI, SVt_PVHV);
7198 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
7201 (long)CopLINE(PL_curcop));
7202 gv_efullname3(tmpstr, gv, NULL);
7203 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
7204 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
7205 hv = GvHVn(db_postponed);
7206 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
7207 CV * const pcv = GvCV(db_postponed);
7213 call_sv(MUTABLE_SV(pcv), G_DISCARD);
7218 if (name && ! (PL_parser && PL_parser->error_count))
7219 process_special_blocks(name, gv, cv);
7224 PL_parser->copline = NOLINE;
7226 #ifdef PERL_DEBUG_READONLY_OPS
7227 /* Watch out for BEGIN blocks */
7228 if (slab && gv && isGV(gv) && GvCV(gv)) Slab_to_ro(slab);
7234 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
7237 const char *const colon = strrchr(fullname,':');
7238 const char *const name = colon ? colon + 1 : fullname;
7240 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
7243 if (strEQ(name, "BEGIN")) {
7244 const I32 oldscope = PL_scopestack_ix;
7246 SAVECOPFILE(&PL_compiling);
7247 SAVECOPLINE(&PL_compiling);
7248 SAVEVPTR(PL_curcop);
7250 DEBUG_x( dump_sub(gv) );
7251 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
7252 GvCV_set(gv,0); /* cv has been hijacked */
7253 call_list(oldscope, PL_beginav);
7255 CopHINTS_set(&PL_compiling, PL_hints);
7262 if strEQ(name, "END") {
7263 DEBUG_x( dump_sub(gv) );
7264 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
7267 } else if (*name == 'U') {
7268 if (strEQ(name, "UNITCHECK")) {
7269 /* It's never too late to run a unitcheck block */
7270 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
7274 } else if (*name == 'C') {
7275 if (strEQ(name, "CHECK")) {
7277 /* diag_listed_as: Too late to run %s block */
7278 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
7279 "Too late to run CHECK block");
7280 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
7284 } else if (*name == 'I') {
7285 if (strEQ(name, "INIT")) {
7287 /* diag_listed_as: Too late to run %s block */
7288 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
7289 "Too late to run INIT block");
7290 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
7296 DEBUG_x( dump_sub(gv) );
7297 GvCV_set(gv,0); /* cv has been hijacked */
7302 =for apidoc newCONSTSUB
7304 See L</newCONSTSUB_flags>.
7310 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
7312 return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
7316 =for apidoc newCONSTSUB_flags
7318 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
7319 eligible for inlining at compile-time.
7321 Currently, the only useful value for C<flags> is SVf_UTF8.
7323 The newly created subroutine takes ownership of a reference to the passed in
7326 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
7327 which won't be called if used as a destructor, but will suppress the overhead
7328 of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
7335 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
7341 const char *const file = CopFILE(PL_curcop);
7343 SV *const temp_sv = CopFILESV(PL_curcop);
7344 const char *const file = temp_sv ? SvPV_nolen_const(temp_sv) : NULL;
7349 if (IN_PERL_RUNTIME) {
7350 /* at runtime, it's not safe to manipulate PL_curcop: it may be
7351 * an op shared between threads. Use a non-shared COP for our
7353 SAVEVPTR(PL_curcop);
7354 SAVECOMPILEWARNINGS();
7355 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
7356 PL_curcop = &PL_compiling;
7358 SAVECOPLINE(PL_curcop);
7359 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
7362 PL_hints &= ~HINT_BLOCK_SCOPE;
7365 SAVEGENERICSV(PL_curstash);
7366 PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
7369 /* file becomes the CvFILE. For an XS, it's usually static storage,
7370 and so doesn't get free()d. (It's expected to be from the C pre-
7371 processor __FILE__ directive). But we need a dynamically allocated one,
7372 and we need it to get freed. */
7373 cv = newXS_len_flags(name, len, const_sv_xsub, file ? file : "", "",
7374 &sv, XS_DYNAMIC_FILENAME | flags);
7375 CvXSUBANY(cv).any_ptr = sv;
7384 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
7385 const char *const filename, const char *const proto,
7388 PERL_ARGS_ASSERT_NEWXS_FLAGS;
7389 return newXS_len_flags(
7390 name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
7395 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
7396 XSUBADDR_t subaddr, const char *const filename,
7397 const char *const proto, SV **const_svp,
7402 PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
7405 GV * const gv = name
7407 name,len,GV_ADDMULTI|flags,SVt_PVCV
7410 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
7411 GV_ADDMULTI | flags, SVt_PVCV);
7414 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
7416 if ((cv = (name ? GvCV(gv) : NULL))) {
7418 /* just a cached method */
7422 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
7423 /* already defined (or promised) */
7424 /* Redundant check that allows us to avoid creating an SV
7425 most of the time: */
7426 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
7427 const line_t oldline = CopLINE(PL_curcop);
7428 if (PL_parser && PL_parser->copline != NOLINE)
7429 CopLINE_set(PL_curcop, PL_parser->copline);
7430 report_redefined_cv(newSVpvn_flags(
7431 name,len,(flags&SVf_UTF8)|SVs_TEMP
7434 CopLINE_set(PL_curcop, oldline);
7441 if (cv) /* must reuse cv if autoloaded */
7444 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
7448 if (HvENAME_HEK(GvSTASH(gv)))
7449 mro_method_changed_in(GvSTASH(gv)); /* newXS */
7455 (void)gv_fetchfile(filename);
7456 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
7457 an external constant string */
7458 assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
7460 CvXSUB(cv) = subaddr;
7463 process_special_blocks(name, gv, cv);
7466 if (flags & XS_DYNAMIC_FILENAME) {
7467 CvFILE(cv) = savepv(filename);
7470 sv_setpv(MUTABLE_SV(cv), proto);
7475 Perl_newSTUB(pTHX_ GV *gv, bool fake)
7477 CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
7478 PERL_ARGS_ASSERT_NEWSTUB;
7482 if (!fake && HvENAME_HEK(GvSTASH(gv)))
7483 mro_method_changed_in(GvSTASH(gv));
7485 CvFILE_set_from_cop(cv, PL_curcop);
7486 CvSTASH_set(cv, PL_curstash);
7492 =for apidoc U||newXS
7494 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
7495 static storage, as it is used directly as CvFILE(), without a copy being made.
7501 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
7503 PERL_ARGS_ASSERT_NEWXS;
7504 return newXS_len_flags(
7505 name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
7514 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
7519 OP* pegop = newOP(OP_NULL, 0);
7524 if (PL_parser && PL_parser->error_count) {
7530 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
7531 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
7534 if ((cv = GvFORM(gv))) {
7535 if (ckWARN(WARN_REDEFINE)) {
7536 const line_t oldline = CopLINE(PL_curcop);
7537 if (PL_parser && PL_parser->copline != NOLINE)
7538 CopLINE_set(PL_curcop, PL_parser->copline);
7540 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
7541 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
7543 /* diag_listed_as: Format %s redefined */
7544 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
7545 "Format STDOUT redefined");
7547 CopLINE_set(PL_curcop, oldline);
7552 GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
7554 CvFILE_set_from_cop(cv, PL_curcop);
7557 pad_tidy(padtidy_FORMAT);
7558 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
7559 CvROOT(cv)->op_private |= OPpREFCOUNTED;
7560 OpREFCNT_set(CvROOT(cv), 1);
7561 CvSTART(cv) = LINKLIST(CvROOT(cv));
7562 CvROOT(cv)->op_next = 0;
7563 CALL_PEEP(CvSTART(cv));
7564 finalize_optree(CvROOT(cv));
7569 op_getmad(o,pegop,'n');
7570 op_getmad_weak(block, pegop, 'b');
7575 PL_parser->copline = NOLINE;
7583 Perl_newANONLIST(pTHX_ OP *o)
7585 return convert(OP_ANONLIST, OPf_SPECIAL, o);
7589 Perl_newANONHASH(pTHX_ OP *o)
7591 return convert(OP_ANONHASH, OPf_SPECIAL, o);
7595 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
7597 return newANONATTRSUB(floor, proto, NULL, block);
7601 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
7603 return newUNOP(OP_REFGEN, 0,
7604 newSVOP(OP_ANONCODE, 0,
7605 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
7609 Perl_oopsAV(pTHX_ OP *o)
7613 PERL_ARGS_ASSERT_OOPSAV;
7615 switch (o->op_type) {
7617 o->op_type = OP_PADAV;
7618 o->op_ppaddr = PL_ppaddr[OP_PADAV];
7619 return ref(o, OP_RV2AV);
7622 o->op_type = OP_RV2AV;
7623 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
7628 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
7635 Perl_oopsHV(pTHX_ OP *o)
7639 PERL_ARGS_ASSERT_OOPSHV;
7641 switch (o->op_type) {
7644 o->op_type = OP_PADHV;
7645 o->op_ppaddr = PL_ppaddr[OP_PADHV];
7646 return ref(o, OP_RV2HV);
7650 o->op_type = OP_RV2HV;
7651 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
7656 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
7663 Perl_newAVREF(pTHX_ OP *o)
7667 PERL_ARGS_ASSERT_NEWAVREF;
7669 if (o->op_type == OP_PADANY) {
7670 o->op_type = OP_PADAV;
7671 o->op_ppaddr = PL_ppaddr[OP_PADAV];
7674 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
7675 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7676 "Using an array as a reference is deprecated");
7678 return newUNOP(OP_RV2AV, 0, scalar(o));
7682 Perl_newGVREF(pTHX_ I32 type, OP *o)
7684 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
7685 return newUNOP(OP_NULL, 0, o);
7686 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
7690 Perl_newHVREF(pTHX_ OP *o)
7694 PERL_ARGS_ASSERT_NEWHVREF;
7696 if (o->op_type == OP_PADANY) {
7697 o->op_type = OP_PADHV;
7698 o->op_ppaddr = PL_ppaddr[OP_PADHV];
7701 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
7702 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7703 "Using a hash as a reference is deprecated");
7705 return newUNOP(OP_RV2HV, 0, scalar(o));
7709 Perl_newCVREF(pTHX_ I32 flags, OP *o)
7711 return newUNOP(OP_RV2CV, flags, scalar(o));
7715 Perl_newSVREF(pTHX_ OP *o)
7719 PERL_ARGS_ASSERT_NEWSVREF;
7721 if (o->op_type == OP_PADANY) {
7722 o->op_type = OP_PADSV;
7723 o->op_ppaddr = PL_ppaddr[OP_PADSV];
7726 return newUNOP(OP_RV2SV, 0, scalar(o));
7729 /* Check routines. See the comments at the top of this file for details
7730 * on when these are called */
7733 Perl_ck_anoncode(pTHX_ OP *o)
7735 PERL_ARGS_ASSERT_CK_ANONCODE;
7737 cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
7739 cSVOPo->op_sv = NULL;
7744 Perl_ck_bitop(pTHX_ OP *o)
7748 PERL_ARGS_ASSERT_CK_BITOP;
7750 o->op_private = (U8)(PL_hints & HINT_INTEGER);
7751 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
7752 && (o->op_type == OP_BIT_OR
7753 || o->op_type == OP_BIT_AND
7754 || o->op_type == OP_BIT_XOR))
7756 const OP * const left = cBINOPo->op_first;
7757 const OP * const right = left->op_sibling;
7758 if ((OP_IS_NUMCOMPARE(left->op_type) &&
7759 (left->op_flags & OPf_PARENS) == 0) ||
7760 (OP_IS_NUMCOMPARE(right->op_type) &&
7761 (right->op_flags & OPf_PARENS) == 0))
7762 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
7763 "Possible precedence problem on bitwise %c operator",
7764 o->op_type == OP_BIT_OR ? '|'
7765 : o->op_type == OP_BIT_AND ? '&' : '^'
7771 PERL_STATIC_INLINE bool
7772 is_dollar_bracket(pTHX_ const OP * const o)
7775 return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
7776 && (kid = cUNOPx(o)->op_first)
7777 && kid->op_type == OP_GV
7778 && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
7782 Perl_ck_cmp(pTHX_ OP *o)
7784 PERL_ARGS_ASSERT_CK_CMP;
7785 if (ckWARN(WARN_SYNTAX)) {
7786 const OP *kid = cUNOPo->op_first;
7789 is_dollar_bracket(aTHX_ kid)
7790 && kid->op_sibling && kid->op_sibling->op_type == OP_CONST
7792 || ( kid->op_type == OP_CONST
7793 && (kid = kid->op_sibling) && is_dollar_bracket(aTHX_ kid))
7795 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7796 "$[ used in %s (did you mean $] ?)", OP_DESC(o));
7802 Perl_ck_concat(pTHX_ OP *o)
7804 const OP * const kid = cUNOPo->op_first;
7806 PERL_ARGS_ASSERT_CK_CONCAT;
7807 PERL_UNUSED_CONTEXT;
7809 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
7810 !(kUNOP->op_first->op_flags & OPf_MOD))
7811 o->op_flags |= OPf_STACKED;
7816 Perl_ck_spair(pTHX_ OP *o)
7820 PERL_ARGS_ASSERT_CK_SPAIR;
7822 if (o->op_flags & OPf_KIDS) {
7825 const OPCODE type = o->op_type;
7826 o = modkids(ck_fun(o), type);
7827 kid = cUNOPo->op_first;
7828 newop = kUNOP->op_first->op_sibling;
7830 const OPCODE type = newop->op_type;
7831 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
7832 type == OP_PADAV || type == OP_PADHV ||
7833 type == OP_RV2AV || type == OP_RV2HV)
7837 op_getmad(kUNOP->op_first,newop,'K');
7839 op_free(kUNOP->op_first);
7841 kUNOP->op_first = newop;
7843 o->op_ppaddr = PL_ppaddr[++o->op_type];
7848 Perl_ck_delete(pTHX_ OP *o)
7850 PERL_ARGS_ASSERT_CK_DELETE;
7854 if (o->op_flags & OPf_KIDS) {
7855 OP * const kid = cUNOPo->op_first;
7856 switch (kid->op_type) {
7858 o->op_flags |= OPf_SPECIAL;
7861 o->op_private |= OPpSLICE;
7864 o->op_flags |= OPf_SPECIAL;
7869 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
7872 if (kid->op_private & OPpLVAL_INTRO)
7873 o->op_private |= OPpLVAL_INTRO;
7880 Perl_ck_die(pTHX_ OP *o)
7882 PERL_ARGS_ASSERT_CK_DIE;
7885 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
7891 Perl_ck_eof(pTHX_ OP *o)
7895 PERL_ARGS_ASSERT_CK_EOF;
7897 if (o->op_flags & OPf_KIDS) {
7899 if (cLISTOPo->op_first->op_type == OP_STUB) {
7901 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
7903 op_getmad(o,newop,'O');
7910 kid = cLISTOPo->op_first;
7911 if (kid->op_type == OP_RV2GV)
7912 kid->op_private |= OPpALLOW_FAKE;
7918 Perl_ck_eval(pTHX_ OP *o)
7922 PERL_ARGS_ASSERT_CK_EVAL;
7924 PL_hints |= HINT_BLOCK_SCOPE;
7925 if (o->op_flags & OPf_KIDS) {
7926 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7929 o->op_flags &= ~OPf_KIDS;
7932 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
7938 cUNOPo->op_first = 0;
7943 NewOp(1101, enter, 1, LOGOP);
7944 enter->op_type = OP_ENTERTRY;
7945 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
7946 enter->op_private = 0;
7948 /* establish postfix order */
7949 enter->op_next = (OP*)enter;
7951 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
7952 o->op_type = OP_LEAVETRY;
7953 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
7954 enter->op_other = o;
7955 op_getmad(oldo,o,'O');
7964 const U8 priv = o->op_private;
7970 o = newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
7971 op_getmad(oldo,o,'O');
7973 o->op_targ = (PADOFFSET)PL_hints;
7974 if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
7975 if ((PL_hints & HINT_LOCALIZE_HH) != 0
7976 && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
7977 /* Store a copy of %^H that pp_entereval can pick up. */
7978 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
7979 MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
7980 cUNOPo->op_first->op_sibling = hhop;
7981 o->op_private |= OPpEVAL_HAS_HH;
7983 if (!(o->op_private & OPpEVAL_BYTES)
7984 && FEATURE_UNIEVAL_IS_ENABLED)
7985 o->op_private |= OPpEVAL_UNICODE;
7990 Perl_ck_exit(pTHX_ OP *o)
7992 PERL_ARGS_ASSERT_CK_EXIT;
7995 HV * const table = GvHV(PL_hintgv);
7997 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
7998 if (svp && *svp && SvTRUE(*svp))
7999 o->op_private |= OPpEXIT_VMSISH;
8001 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
8007 Perl_ck_exec(pTHX_ OP *o)
8009 PERL_ARGS_ASSERT_CK_EXEC;
8011 if (o->op_flags & OPf_STACKED) {
8014 kid = cUNOPo->op_first->op_sibling;
8015 if (kid->op_type == OP_RV2GV)
8024 Perl_ck_exists(pTHX_ OP *o)
8028 PERL_ARGS_ASSERT_CK_EXISTS;
8031 if (o->op_flags & OPf_KIDS) {
8032 OP * const kid = cUNOPo->op_first;
8033 if (kid->op_type == OP_ENTERSUB) {
8034 (void) ref(kid, o->op_type);
8035 if (kid->op_type != OP_RV2CV
8036 && !(PL_parser && PL_parser->error_count))
8037 Perl_croak(aTHX_ "%s argument is not a subroutine name",
8039 o->op_private |= OPpEXISTS_SUB;
8041 else if (kid->op_type == OP_AELEM)
8042 o->op_flags |= OPf_SPECIAL;
8043 else if (kid->op_type != OP_HELEM)
8044 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine",
8052 Perl_ck_rvconst(pTHX_ register OP *o)
8055 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8057 PERL_ARGS_ASSERT_CK_RVCONST;
8059 o->op_private |= (PL_hints & HINT_STRICT_REFS);
8060 if (o->op_type == OP_RV2CV)
8061 o->op_private &= ~1;
8063 if (kid->op_type == OP_CONST) {
8066 SV * const kidsv = kid->op_sv;
8068 /* Is it a constant from cv_const_sv()? */
8069 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
8070 SV * const rsv = SvRV(kidsv);
8071 const svtype type = SvTYPE(rsv);
8072 const char *badtype = NULL;
8074 switch (o->op_type) {
8076 if (type > SVt_PVMG)
8077 badtype = "a SCALAR";
8080 if (type != SVt_PVAV)
8081 badtype = "an ARRAY";
8084 if (type != SVt_PVHV)
8088 if (type != SVt_PVCV)
8093 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
8096 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
8097 const char *badthing;
8098 switch (o->op_type) {
8100 badthing = "a SCALAR";
8103 badthing = "an ARRAY";
8106 badthing = "a HASH";
8114 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
8115 SVfARG(kidsv), badthing);
8118 * This is a little tricky. We only want to add the symbol if we
8119 * didn't add it in the lexer. Otherwise we get duplicate strict
8120 * warnings. But if we didn't add it in the lexer, we must at
8121 * least pretend like we wanted to add it even if it existed before,
8122 * or we get possible typo warnings. OPpCONST_ENTERED says
8123 * whether the lexer already added THIS instance of this symbol.
8125 iscv = (o->op_type == OP_RV2CV) * 2;
8127 gv = gv_fetchsv(kidsv,
8128 iscv | !(kid->op_private & OPpCONST_ENTERED),
8131 : o->op_type == OP_RV2SV
8133 : o->op_type == OP_RV2AV
8135 : o->op_type == OP_RV2HV
8138 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
8140 kid->op_type = OP_GV;
8141 SvREFCNT_dec(kid->op_sv);
8143 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
8144 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
8145 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
8147 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
8149 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
8151 kid->op_private = 0;
8152 kid->op_ppaddr = PL_ppaddr[OP_GV];
8153 /* FAKE globs in the symbol table cause weird bugs (#77810) */
8161 Perl_ck_ftst(pTHX_ OP *o)
8164 const I32 type = o->op_type;
8166 PERL_ARGS_ASSERT_CK_FTST;
8168 if (o->op_flags & OPf_REF) {
8171 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
8172 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8173 const OPCODE kidtype = kid->op_type;
8175 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
8176 && !(kid->op_private & OPpCONST_FOLDED)) {
8177 OP * const newop = newGVOP(type, OPf_REF,
8178 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
8180 op_getmad(o,newop,'O');
8186 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
8187 o->op_private |= OPpFT_ACCESS;
8188 if (PL_check[kidtype] == Perl_ck_ftst
8189 && kidtype != OP_STAT && kidtype != OP_LSTAT) {
8190 o->op_private |= OPpFT_STACKED;
8191 kid->op_private |= OPpFT_STACKING;
8192 if (kidtype == OP_FTTTY && (
8193 !(kid->op_private & OPpFT_STACKED)
8194 || kid->op_private & OPpFT_AFTER_t
8196 o->op_private |= OPpFT_AFTER_t;
8205 if (type == OP_FTTTY)
8206 o = newGVOP(type, OPf_REF, PL_stdingv);
8208 o = newUNOP(type, 0, newDEFSVOP());
8209 op_getmad(oldo,o,'O');
8215 Perl_ck_fun(pTHX_ OP *o)
8218 const int type = o->op_type;
8219 I32 oa = PL_opargs[type] >> OASHIFT;
8221 PERL_ARGS_ASSERT_CK_FUN;
8223 if (o->op_flags & OPf_STACKED) {
8224 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
8227 return no_fh_allowed(o);
8230 if (o->op_flags & OPf_KIDS) {
8231 OP **tokid = &cLISTOPo->op_first;
8232 OP *kid = cLISTOPo->op_first;
8235 bool seen_optional = FALSE;
8237 if (kid->op_type == OP_PUSHMARK ||
8238 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
8240 tokid = &kid->op_sibling;
8241 kid = kid->op_sibling;
8243 if (kid && kid->op_type == OP_COREARGS) {
8244 bool optional = FALSE;
8247 if (oa & OA_OPTIONAL) optional = TRUE;
8250 if (optional) o->op_private |= numargs;
8255 if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
8256 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV)
8257 *tokid = kid = newDEFSVOP();
8258 seen_optional = TRUE;
8263 sibl = kid->op_sibling;
8265 if (!sibl && kid->op_type == OP_STUB) {
8272 /* list seen where single (scalar) arg expected? */
8273 if (numargs == 1 && !(oa >> 4)
8274 && kid->op_type == OP_LIST && type != OP_SCALAR)
8276 return too_many_arguments_pv(o,PL_op_desc[type], 0);
8289 if ((type == OP_PUSH || type == OP_UNSHIFT)
8290 && !kid->op_sibling)
8291 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
8292 "Useless use of %s with no values",
8295 if (kid->op_type == OP_CONST &&
8296 (kid->op_private & OPpCONST_BARE))
8298 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
8299 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
8300 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8301 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
8302 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
8304 op_getmad(kid,newop,'K');
8309 kid->op_sibling = sibl;
8312 else if (kid->op_type == OP_CONST
8313 && ( !SvROK(cSVOPx_sv(kid))
8314 || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
8316 bad_type_pv(numargs, "array", PL_op_desc[type], 0, kid);
8317 /* Defer checks to run-time if we have a scalar arg */
8318 if (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV)
8319 op_lvalue(kid, type);
8323 if (kid->op_type == OP_CONST &&
8324 (kid->op_private & OPpCONST_BARE))
8326 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
8327 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
8328 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8329 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
8330 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
8332 op_getmad(kid,newop,'K');
8337 kid->op_sibling = sibl;
8340 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
8341 bad_type_pv(numargs, "hash", PL_op_desc[type], 0, kid);
8342 op_lvalue(kid, type);
8346 OP * const newop = newUNOP(OP_NULL, 0, kid);
8347 kid->op_sibling = 0;
8348 newop->op_next = newop;
8350 kid->op_sibling = sibl;
8355 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
8356 if (kid->op_type == OP_CONST &&
8357 (kid->op_private & OPpCONST_BARE))
8359 OP * const newop = newGVOP(OP_GV, 0,
8360 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
8361 if (!(o->op_private & 1) && /* if not unop */
8362 kid == cLISTOPo->op_last)
8363 cLISTOPo->op_last = newop;
8365 op_getmad(kid,newop,'K');
8371 else if (kid->op_type == OP_READLINE) {
8372 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
8373 bad_type_pv(numargs, "HANDLE", OP_DESC(o), 0, kid);
8376 I32 flags = OPf_SPECIAL;
8380 /* is this op a FH constructor? */
8381 if (is_handle_constructor(o,numargs)) {
8382 const char *name = NULL;
8385 bool want_dollar = TRUE;
8388 /* Set a flag to tell rv2gv to vivify
8389 * need to "prove" flag does not mean something
8390 * else already - NI-S 1999/05/07
8393 if (kid->op_type == OP_PADSV) {
8395 = PAD_COMPNAME_SV(kid->op_targ);
8396 name = SvPV_const(namesv, len);
8397 name_utf8 = SvUTF8(namesv);
8399 else if (kid->op_type == OP_RV2SV
8400 && kUNOP->op_first->op_type == OP_GV)
8402 GV * const gv = cGVOPx_gv(kUNOP->op_first);
8404 len = GvNAMELEN(gv);
8405 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
8407 else if (kid->op_type == OP_AELEM
8408 || kid->op_type == OP_HELEM)
8411 OP *op = ((BINOP*)kid)->op_first;
8415 const char * const a =
8416 kid->op_type == OP_AELEM ?
8418 if (((op->op_type == OP_RV2AV) ||
8419 (op->op_type == OP_RV2HV)) &&
8420 (firstop = ((UNOP*)op)->op_first) &&
8421 (firstop->op_type == OP_GV)) {
8422 /* packagevar $a[] or $h{} */
8423 GV * const gv = cGVOPx_gv(firstop);
8431 else if (op->op_type == OP_PADAV
8432 || op->op_type == OP_PADHV) {
8433 /* lexicalvar $a[] or $h{} */
8434 const char * const padname =
8435 PAD_COMPNAME_PV(op->op_targ);
8444 name = SvPV_const(tmpstr, len);
8445 name_utf8 = SvUTF8(tmpstr);
8450 name = "__ANONIO__";
8452 want_dollar = FALSE;
8454 op_lvalue(kid, type);
8458 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
8459 namesv = PAD_SVl(targ);
8460 SvUPGRADE(namesv, SVt_PV);
8461 if (want_dollar && *name != '$')
8462 sv_setpvs(namesv, "$");
8463 sv_catpvn(namesv, name, len);
8464 if ( name_utf8 ) SvUTF8_on(namesv);
8467 kid->op_sibling = 0;
8468 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
8469 kid->op_targ = targ;
8470 kid->op_private |= priv;
8472 kid->op_sibling = sibl;
8478 if ((type == OP_UNDEF || type == OP_POS)
8479 && numargs == 1 && !(oa >> 4)
8480 && kid->op_type == OP_LIST)
8481 return too_many_arguments_pv(o,PL_op_desc[type], 0);
8482 op_lvalue(scalar(kid), type);
8486 tokid = &kid->op_sibling;
8487 kid = kid->op_sibling;
8490 if (kid && kid->op_type != OP_STUB)
8491 return too_many_arguments_pv(o,OP_DESC(o), 0);
8492 o->op_private |= numargs;
8494 /* FIXME - should the numargs move as for the PERL_MAD case? */
8495 o->op_private |= numargs;
8497 return too_many_arguments_pv(o,OP_DESC(o), 0);
8501 else if (PL_opargs[type] & OA_DEFGV) {
8503 OP *newop = newUNOP(type, 0, newDEFSVOP());
8504 op_getmad(o,newop,'O');
8507 /* Ordering of these two is important to keep f_map.t passing. */
8509 return newUNOP(type, 0, newDEFSVOP());
8514 while (oa & OA_OPTIONAL)
8516 if (oa && oa != OA_LIST)
8517 return too_few_arguments_pv(o,OP_DESC(o), 0);
8523 Perl_ck_glob(pTHX_ OP *o)
8527 const bool core = o->op_flags & OPf_SPECIAL;
8529 PERL_ARGS_ASSERT_CK_GLOB;
8532 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
8533 op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
8535 if (core) gv = NULL;
8536 else if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
8537 && GvCVu(gv) && GvIMPORTED_CV(gv)))
8539 GV * const * const gvp =
8540 (GV **)hv_fetchs(PL_globalstash, "glob", FALSE);
8541 gv = gvp ? *gvp : NULL;
8544 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
8547 * \ null - const(wildcard)
8552 * \ mark - glob - rv2cv
8553 * | \ gv(CORE::GLOBAL::glob)
8555 * \ null - const(wildcard) - const(ix)
8557 o->op_flags |= OPf_SPECIAL;
8558 o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
8559 op_append_elem(OP_GLOB, o,
8560 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
8561 o = newLISTOP(OP_LIST, 0, o, NULL);
8562 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
8563 op_append_elem(OP_LIST, o,
8564 scalar(newUNOP(OP_RV2CV, 0,
8565 newGVOP(OP_GV, 0, gv)))));
8566 o = newUNOP(OP_NULL, 0, o);
8567 o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
8570 else o->op_flags &= ~OPf_SPECIAL;
8571 #if !defined(PERL_EXTERNAL_GLOB)
8574 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
8575 newSVpvs("File::Glob"), NULL, NULL, NULL);
8578 #endif /* !PERL_EXTERNAL_GLOB */
8579 gv = newGVgen("main");
8581 #ifndef PERL_EXTERNAL_GLOB
8582 sv_setiv(GvSVn(gv),PL_glob_index++);
8584 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
8590 Perl_ck_grep(pTHX_ OP *o)
8595 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
8598 PERL_ARGS_ASSERT_CK_GREP;
8600 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
8601 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
8603 if (o->op_flags & OPf_STACKED) {
8604 kid = cUNOPx(cLISTOPo->op_first->op_sibling)->op_first;
8605 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
8606 return no_fh_allowed(o);
8607 o->op_flags &= ~OPf_STACKED;
8609 kid = cLISTOPo->op_first->op_sibling;
8610 if (type == OP_MAPWHILE)
8615 if (PL_parser && PL_parser->error_count)
8617 kid = cLISTOPo->op_first->op_sibling;
8618 if (kid->op_type != OP_NULL)
8619 Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
8620 kid = kUNOP->op_first;
8622 NewOp(1101, gwop, 1, LOGOP);
8623 gwop->op_type = type;
8624 gwop->op_ppaddr = PL_ppaddr[type];
8626 gwop->op_flags |= OPf_KIDS;
8627 gwop->op_other = LINKLIST(kid);
8628 kid->op_next = (OP*)gwop;
8629 offset = pad_findmy_pvs("$_", 0);
8630 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
8631 o->op_private = gwop->op_private = 0;
8632 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
8635 o->op_private = gwop->op_private = OPpGREP_LEX;
8636 gwop->op_targ = o->op_targ = offset;
8639 kid = cLISTOPo->op_first->op_sibling;
8640 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
8641 op_lvalue(kid, OP_GREPSTART);
8647 Perl_ck_index(pTHX_ OP *o)
8649 PERL_ARGS_ASSERT_CK_INDEX;
8651 if (o->op_flags & OPf_KIDS) {
8652 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8654 kid = kid->op_sibling; /* get past "big" */
8655 if (kid && kid->op_type == OP_CONST) {
8656 const bool save_taint = PL_tainted;
8657 fbm_compile(((SVOP*)kid)->op_sv, 0);
8658 PL_tainted = save_taint;
8665 Perl_ck_lfun(pTHX_ OP *o)
8667 const OPCODE type = o->op_type;
8669 PERL_ARGS_ASSERT_CK_LFUN;
8671 return modkids(ck_fun(o), type);
8675 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
8677 PERL_ARGS_ASSERT_CK_DEFINED;
8679 if ((o->op_flags & OPf_KIDS)) {
8680 switch (cUNOPo->op_first->op_type) {
8683 case OP_AASSIGN: /* Is this a good idea? */
8684 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8685 "defined(@array) is deprecated");
8686 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8687 "\t(Maybe you should just omit the defined()?)\n");
8691 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8692 "defined(%%hash) is deprecated");
8693 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8694 "\t(Maybe you should just omit the defined()?)\n");
8705 Perl_ck_readline(pTHX_ OP *o)
8707 PERL_ARGS_ASSERT_CK_READLINE;
8709 if (o->op_flags & OPf_KIDS) {
8710 OP *kid = cLISTOPo->op_first;
8711 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
8715 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
8717 op_getmad(o,newop,'O');
8727 Perl_ck_rfun(pTHX_ OP *o)
8729 const OPCODE type = o->op_type;
8731 PERL_ARGS_ASSERT_CK_RFUN;
8733 return refkids(ck_fun(o), type);
8737 Perl_ck_listiob(pTHX_ OP *o)
8741 PERL_ARGS_ASSERT_CK_LISTIOB;
8743 kid = cLISTOPo->op_first;
8746 kid = cLISTOPo->op_first;
8748 if (kid->op_type == OP_PUSHMARK)
8749 kid = kid->op_sibling;
8750 if (kid && o->op_flags & OPf_STACKED)
8751 kid = kid->op_sibling;
8752 else if (kid && !kid->op_sibling) { /* print HANDLE; */
8753 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
8754 && !(kid->op_private & OPpCONST_FOLDED)) {
8755 o->op_flags |= OPf_STACKED; /* make it a filehandle */
8756 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
8757 cLISTOPo->op_first->op_sibling = kid;
8758 cLISTOPo->op_last = kid;
8759 kid = kid->op_sibling;
8764 op_append_elem(o->op_type, o, newDEFSVOP());
8766 if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
8771 Perl_ck_smartmatch(pTHX_ OP *o)
8774 PERL_ARGS_ASSERT_CK_SMARTMATCH;
8775 if (0 == (o->op_flags & OPf_SPECIAL)) {
8776 OP *first = cBINOPo->op_first;
8777 OP *second = first->op_sibling;
8779 /* Implicitly take a reference to an array or hash */
8780 first->op_sibling = NULL;
8781 first = cBINOPo->op_first = ref_array_or_hash(first);
8782 second = first->op_sibling = ref_array_or_hash(second);
8784 /* Implicitly take a reference to a regular expression */
8785 if (first->op_type == OP_MATCH) {
8786 first->op_type = OP_QR;
8787 first->op_ppaddr = PL_ppaddr[OP_QR];
8789 if (second->op_type == OP_MATCH) {
8790 second->op_type = OP_QR;
8791 second->op_ppaddr = PL_ppaddr[OP_QR];
8800 Perl_ck_sassign(pTHX_ OP *o)
8803 OP * const kid = cLISTOPo->op_first;
8805 PERL_ARGS_ASSERT_CK_SASSIGN;
8807 /* has a disposable target? */
8808 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
8809 && !(kid->op_flags & OPf_STACKED)
8810 /* Cannot steal the second time! */
8811 && !(kid->op_private & OPpTARGET_MY)
8812 /* Keep the full thing for madskills */
8816 OP * const kkid = kid->op_sibling;
8818 /* Can just relocate the target. */
8819 if (kkid && kkid->op_type == OP_PADSV
8820 && !(kkid->op_private & OPpLVAL_INTRO))
8822 kid->op_targ = kkid->op_targ;
8824 /* Now we do not need PADSV and SASSIGN. */
8825 kid->op_sibling = o->op_sibling; /* NULL */
8826 cLISTOPo->op_first = NULL;
8829 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
8833 if (kid->op_sibling) {
8834 OP *kkid = kid->op_sibling;
8835 /* For state variable assignment, kkid is a list op whose op_last
8837 if ((kkid->op_type == OP_PADSV ||
8838 (kkid->op_type == OP_LIST &&
8839 (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
8842 && (kkid->op_private & OPpLVAL_INTRO)
8843 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
8844 const PADOFFSET target = kkid->op_targ;
8845 OP *const other = newOP(OP_PADSV,
8847 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
8848 OP *const first = newOP(OP_NULL, 0);
8849 OP *const nullop = newCONDOP(0, first, o, other);
8850 OP *const condop = first->op_next;
8851 /* hijacking PADSTALE for uninitialized state variables */
8852 SvPADSTALE_on(PAD_SVl(target));
8854 condop->op_type = OP_ONCE;
8855 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
8856 condop->op_targ = target;
8857 other->op_targ = target;
8859 /* Because we change the type of the op here, we will skip the
8860 assignment binop->op_last = binop->op_first->op_sibling; at the
8861 end of Perl_newBINOP(). So need to do it here. */
8862 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
8871 Perl_ck_match(pTHX_ OP *o)
8875 PERL_ARGS_ASSERT_CK_MATCH;
8877 if (o->op_type != OP_QR && PL_compcv) {
8878 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
8879 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
8880 o->op_targ = offset;
8881 o->op_private |= OPpTARGET_MY;
8884 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
8885 o->op_private |= OPpRUNTIME;
8890 Perl_ck_method(pTHX_ OP *o)
8892 OP * const kid = cUNOPo->op_first;
8894 PERL_ARGS_ASSERT_CK_METHOD;
8896 if (kid->op_type == OP_CONST) {
8897 SV* sv = kSVOP->op_sv;
8898 const char * const method = SvPVX_const(sv);
8899 if (!(strchr(method, ':') || strchr(method, '\''))) {
8901 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
8902 sv = newSVpvn_share(method, SvUTF8(sv) ? -(I32)SvCUR(sv) : (I32)SvCUR(sv), 0);
8905 kSVOP->op_sv = NULL;
8907 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
8909 op_getmad(o,cmop,'O');
8920 Perl_ck_null(pTHX_ OP *o)
8922 PERL_ARGS_ASSERT_CK_NULL;
8923 PERL_UNUSED_CONTEXT;
8928 Perl_ck_open(pTHX_ OP *o)
8931 HV * const table = GvHV(PL_hintgv);
8933 PERL_ARGS_ASSERT_CK_OPEN;
8936 SV **svp = hv_fetchs(table, "open_IN", FALSE);
8939 const char *d = SvPV_const(*svp, len);
8940 const I32 mode = mode_from_discipline(d, len);
8941 if (mode & O_BINARY)
8942 o->op_private |= OPpOPEN_IN_RAW;
8943 else if (mode & O_TEXT)
8944 o->op_private |= OPpOPEN_IN_CRLF;
8947 svp = hv_fetchs(table, "open_OUT", FALSE);
8950 const char *d = SvPV_const(*svp, len);
8951 const I32 mode = mode_from_discipline(d, len);
8952 if (mode & O_BINARY)
8953 o->op_private |= OPpOPEN_OUT_RAW;
8954 else if (mode & O_TEXT)
8955 o->op_private |= OPpOPEN_OUT_CRLF;
8958 if (o->op_type == OP_BACKTICK) {
8959 if (!(o->op_flags & OPf_KIDS)) {
8960 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
8962 op_getmad(o,newop,'O');
8971 /* In case of three-arg dup open remove strictness
8972 * from the last arg if it is a bareword. */
8973 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
8974 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
8978 if ((last->op_type == OP_CONST) && /* The bareword. */
8979 (last->op_private & OPpCONST_BARE) &&
8980 (last->op_private & OPpCONST_STRICT) &&
8981 (oa = first->op_sibling) && /* The fh. */
8982 (oa = oa->op_sibling) && /* The mode. */
8983 (oa->op_type == OP_CONST) &&
8984 SvPOK(((SVOP*)oa)->op_sv) &&
8985 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
8986 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
8987 (last == oa->op_sibling)) /* The bareword. */
8988 last->op_private &= ~OPpCONST_STRICT;
8994 Perl_ck_repeat(pTHX_ OP *o)
8996 PERL_ARGS_ASSERT_CK_REPEAT;
8998 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
8999 o->op_private |= OPpREPEAT_DOLIST;
9000 cBINOPo->op_first = force_list(cBINOPo->op_first);
9008 Perl_ck_require(pTHX_ OP *o)
9013 PERL_ARGS_ASSERT_CK_REQUIRE;
9015 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
9016 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9018 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
9019 SV * const sv = kid->op_sv;
9020 U32 was_readonly = SvREADONLY(sv);
9027 sv_force_normal_flags(sv, 0);
9028 assert(!SvREADONLY(sv));
9038 for (; s < end; s++) {
9039 if (*s == ':' && s[1] == ':') {
9041 Move(s+2, s+1, end - s - 1, char);
9046 sv_catpvs(sv, ".pm");
9047 SvFLAGS(sv) |= was_readonly;
9051 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
9052 /* handle override, if any */
9053 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
9054 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
9055 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
9056 gv = gvp ? *gvp : NULL;
9060 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
9062 if (o->op_flags & OPf_KIDS) {
9063 kid = cUNOPo->op_first;
9064 cUNOPo->op_first = NULL;
9072 newop = newUNOP(OP_ENTERSUB, OPf_STACKED,
9073 op_append_elem(OP_LIST, kid,
9074 scalar(newUNOP(OP_RV2CV, 0,
9077 op_getmad(o,newop,'O');
9081 return scalar(ck_fun(o));
9085 Perl_ck_return(pTHX_ OP *o)
9090 PERL_ARGS_ASSERT_CK_RETURN;
9092 kid = cLISTOPo->op_first->op_sibling;
9093 if (CvLVALUE(PL_compcv)) {
9094 for (; kid; kid = kid->op_sibling)
9095 op_lvalue(kid, OP_LEAVESUBLV);
9102 Perl_ck_select(pTHX_ OP *o)
9107 PERL_ARGS_ASSERT_CK_SELECT;
9109 if (o->op_flags & OPf_KIDS) {
9110 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
9111 if (kid && kid->op_sibling) {
9112 o->op_type = OP_SSELECT;
9113 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
9115 return fold_constants(op_integerize(op_std_init(o)));
9119 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
9120 if (kid && kid->op_type == OP_RV2GV)
9121 kid->op_private &= ~HINT_STRICT_REFS;
9126 Perl_ck_shift(pTHX_ OP *o)
9129 const I32 type = o->op_type;
9131 PERL_ARGS_ASSERT_CK_SHIFT;
9133 if (!(o->op_flags & OPf_KIDS)) {
9136 if (!CvUNIQUE(PL_compcv)) {
9137 o->op_flags |= OPf_SPECIAL;
9141 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
9144 OP * const oldo = o;
9145 o = newUNOP(type, 0, scalar(argop));
9146 op_getmad(oldo,o,'O');
9151 return newUNOP(type, 0, scalar(argop));
9154 return scalar(ck_fun(o));
9158 Perl_ck_sort(pTHX_ OP *o)
9162 HV * const hinthv = GvHV(PL_hintgv);
9164 PERL_ARGS_ASSERT_CK_SORT;
9167 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
9169 const I32 sorthints = (I32)SvIV(*svp);
9170 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
9171 o->op_private |= OPpSORT_QSORT;
9172 if ((sorthints & HINT_SORT_STABLE) != 0)
9173 o->op_private |= OPpSORT_STABLE;
9177 if (o->op_flags & OPf_STACKED)
9179 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
9180 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
9181 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
9183 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
9185 if (kid->op_type == OP_LEAVE)
9186 op_null(kid); /* wipe out leave */
9187 /* Prevent execution from escaping out of the sort block. */
9190 /* provide scalar context for comparison function/block */
9191 kid = scalar(firstkid);
9193 o->op_flags |= OPf_SPECIAL;
9196 firstkid = firstkid->op_sibling;
9199 /* provide list context for arguments */
9206 S_simplify_sort(pTHX_ OP *o)
9209 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
9216 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
9218 if (!(o->op_flags & OPf_STACKED))
9220 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
9221 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
9222 kid = kUNOP->op_first; /* get past null */
9223 if (!(have_scopeop = kid->op_type == OP_SCOPE)
9224 && kid->op_type != OP_LEAVE)
9226 kid = kLISTOP->op_last; /* get past scope */
9227 switch(kid->op_type) {
9231 if (!have_scopeop) goto padkids;
9236 k = kid; /* remember this node*/
9237 if (kBINOP->op_first->op_type != OP_RV2SV
9238 || kBINOP->op_last ->op_type != OP_RV2SV)
9241 Warn about my($a) or my($b) in a sort block, *if* $a or $b is
9242 then used in a comparison. This catches most, but not
9243 all cases. For instance, it catches
9244 sort { my($a); $a <=> $b }
9246 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
9247 (although why you'd do that is anyone's guess).
9251 if (!ckWARN(WARN_SYNTAX)) return;
9252 kid = kBINOP->op_first;
9254 if (kid->op_type == OP_PADSV) {
9255 SV * const name = AvARRAY(PL_comppad_name)[kid->op_targ];
9256 if (SvCUR(name) == 2 && *SvPVX(name) == '$'
9257 && (SvPVX(name)[1] == 'a' || SvPVX(name)[1] == 'b'))
9258 /* diag_listed_as: "my %s" used in sort comparison */
9259 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9260 "\"%s %s\" used in sort comparison",
9261 SvPAD_STATE(name) ? "state" : "my",
9264 } while ((kid = kid->op_sibling));
9267 kid = kBINOP->op_first; /* get past cmp */
9268 if (kUNOP->op_first->op_type != OP_GV)
9270 kid = kUNOP->op_first; /* get past rv2sv */
9272 if (GvSTASH(gv) != PL_curstash)
9274 gvname = GvNAME(gv);
9275 if (*gvname == 'a' && gvname[1] == '\0')
9277 else if (*gvname == 'b' && gvname[1] == '\0')
9282 kid = k; /* back to cmp */
9283 /* already checked above that it is rv2sv */
9284 kid = kBINOP->op_last; /* down to 2nd arg */
9285 if (kUNOP->op_first->op_type != OP_GV)
9287 kid = kUNOP->op_first; /* get past rv2sv */
9289 if (GvSTASH(gv) != PL_curstash)
9291 gvname = GvNAME(gv);
9293 ? !(*gvname == 'a' && gvname[1] == '\0')
9294 : !(*gvname == 'b' && gvname[1] == '\0'))
9296 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
9298 o->op_private |= OPpSORT_DESCEND;
9299 if (k->op_type == OP_NCMP)
9300 o->op_private |= OPpSORT_NUMERIC;
9301 if (k->op_type == OP_I_NCMP)
9302 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
9303 kid = cLISTOPo->op_first->op_sibling;
9304 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
9306 op_getmad(kid,o,'S'); /* then delete it */
9308 op_free(kid); /* then delete it */
9313 Perl_ck_split(pTHX_ OP *o)
9318 PERL_ARGS_ASSERT_CK_SPLIT;
9320 if (o->op_flags & OPf_STACKED)
9321 return no_fh_allowed(o);
9323 kid = cLISTOPo->op_first;
9324 if (kid->op_type != OP_NULL)
9325 Perl_croak(aTHX_ "panic: ck_split, type=%u", (unsigned) kid->op_type);
9326 kid = kid->op_sibling;
9327 op_free(cLISTOPo->op_first);
9329 cLISTOPo->op_first = kid;
9331 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
9332 cLISTOPo->op_last = kid; /* There was only one element previously */
9335 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
9336 OP * const sibl = kid->op_sibling;
9337 kid->op_sibling = 0;
9338 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0, 0);
9339 if (cLISTOPo->op_first == cLISTOPo->op_last)
9340 cLISTOPo->op_last = kid;
9341 cLISTOPo->op_first = kid;
9342 kid->op_sibling = sibl;
9345 kid->op_type = OP_PUSHRE;
9346 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
9348 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
9349 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
9350 "Use of /g modifier is meaningless in split");
9353 if (!kid->op_sibling)
9354 op_append_elem(OP_SPLIT, o, newDEFSVOP());
9356 kid = kid->op_sibling;
9359 if (!kid->op_sibling)
9360 op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
9361 assert(kid->op_sibling);
9363 kid = kid->op_sibling;
9366 if (kid->op_sibling)
9367 return too_many_arguments_pv(o,OP_DESC(o), 0);
9373 Perl_ck_join(pTHX_ OP *o)
9375 const OP * const kid = cLISTOPo->op_first->op_sibling;
9377 PERL_ARGS_ASSERT_CK_JOIN;
9379 if (kid && kid->op_type == OP_MATCH) {
9380 if (ckWARN(WARN_SYNTAX)) {
9381 const REGEXP *re = PM_GETRE(kPMOP);
9383 ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
9384 SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
9385 : newSVpvs_flags( "STRING", SVs_TEMP );
9386 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9387 "/%"SVf"/ should probably be written as \"%"SVf"\"",
9388 SVfARG(msg), SVfARG(msg));
9395 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
9397 Examines an op, which is expected to identify a subroutine at runtime,
9398 and attempts to determine at compile time which subroutine it identifies.
9399 This is normally used during Perl compilation to determine whether
9400 a prototype can be applied to a function call. I<cvop> is the op
9401 being considered, normally an C<rv2cv> op. A pointer to the identified
9402 subroutine is returned, if it could be determined statically, and a null
9403 pointer is returned if it was not possible to determine statically.
9405 Currently, the subroutine can be identified statically if the RV that the
9406 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
9407 A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
9408 suitable if the constant value must be an RV pointing to a CV. Details of
9409 this process may change in future versions of Perl. If the C<rv2cv> op
9410 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
9411 the subroutine statically: this flag is used to suppress compile-time
9412 magic on a subroutine call, forcing it to use default runtime behaviour.
9414 If I<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
9415 of a GV reference is modified. If a GV was examined and its CV slot was
9416 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
9417 If the op is not optimised away, and the CV slot is later populated with
9418 a subroutine having a prototype, that flag eventually triggers the warning
9419 "called too early to check prototype".
9421 If I<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
9422 of returning a pointer to the subroutine it returns a pointer to the
9423 GV giving the most appropriate name for the subroutine in this context.
9424 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
9425 (C<CvANON>) subroutine that is referenced through a GV it will be the
9426 referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
9427 A null pointer is returned as usual if there is no statically-determinable
9434 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
9439 PERL_ARGS_ASSERT_RV2CV_OP_CV;
9440 if (flags & ~(RV2CVOPCV_MARK_EARLY|RV2CVOPCV_RETURN_NAME_GV))
9441 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
9442 if (cvop->op_type != OP_RV2CV)
9444 if (cvop->op_private & OPpENTERSUB_AMPER)
9446 if (!(cvop->op_flags & OPf_KIDS))
9448 rvop = cUNOPx(cvop)->op_first;
9449 switch (rvop->op_type) {
9451 gv = cGVOPx_gv(rvop);
9454 if (flags & RV2CVOPCV_MARK_EARLY)
9455 rvop->op_private |= OPpEARLY_CV;
9460 SV *rv = cSVOPx_sv(rvop);
9470 if (SvTYPE((SV*)cv) != SVt_PVCV)
9472 if (flags & RV2CVOPCV_RETURN_NAME_GV) {
9473 if (!CvANON(cv) || !gv)
9482 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
9484 Performs the default fixup of the arguments part of an C<entersub>
9485 op tree. This consists of applying list context to each of the
9486 argument ops. This is the standard treatment used on a call marked
9487 with C<&>, or a method call, or a call through a subroutine reference,
9488 or any other call where the callee can't be identified at compile time,
9489 or a call where the callee has no prototype.
9495 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
9498 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
9499 aop = cUNOPx(entersubop)->op_first;
9500 if (!aop->op_sibling)
9501 aop = cUNOPx(aop)->op_first;
9502 for (aop = aop->op_sibling; aop->op_sibling; aop = aop->op_sibling) {
9503 if (!(PL_madskills && aop->op_type == OP_STUB)) {
9505 op_lvalue(aop, OP_ENTERSUB);
9512 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
9514 Performs the fixup of the arguments part of an C<entersub> op tree
9515 based on a subroutine prototype. This makes various modifications to
9516 the argument ops, from applying context up to inserting C<refgen> ops,
9517 and checking the number and syntactic types of arguments, as directed by
9518 the prototype. This is the standard treatment used on a subroutine call,
9519 not marked with C<&>, where the callee can be identified at compile time
9520 and has a prototype.
9522 I<protosv> supplies the subroutine prototype to be applied to the call.
9523 It may be a normal defined scalar, of which the string value will be used.
9524 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
9525 that has been cast to C<SV*>) which has a prototype. The prototype
9526 supplied, in whichever form, does not need to match the actual callee
9527 referenced by the op tree.
9529 If the argument ops disagree with the prototype, for example by having
9530 an unacceptable number of arguments, a valid op tree is returned anyway.
9531 The error is reflected in the parser state, normally resulting in a single
9532 exception at the top level of parsing which covers all the compilation
9533 errors that occurred. In the error message, the callee is referred to
9534 by the name defined by the I<namegv> parameter.
9540 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
9543 const char *proto, *proto_end;
9544 OP *aop, *prev, *cvop;
9547 I32 contextclass = 0;
9548 const char *e = NULL;
9549 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
9550 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
9551 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
9552 "flags=%lx", (unsigned long) SvFLAGS(protosv));
9553 if (SvTYPE(protosv) == SVt_PVCV)
9554 proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
9555 else proto = SvPV(protosv, proto_len);
9556 proto_end = proto + proto_len;
9557 aop = cUNOPx(entersubop)->op_first;
9558 if (!aop->op_sibling)
9559 aop = cUNOPx(aop)->op_first;
9561 aop = aop->op_sibling;
9562 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
9563 while (aop != cvop) {
9565 if (PL_madskills && aop->op_type == OP_STUB) {
9566 aop = aop->op_sibling;
9569 if (PL_madskills && aop->op_type == OP_NULL)
9570 o3 = ((UNOP*)aop)->op_first;
9574 if (proto >= proto_end)
9575 return too_many_arguments_sv(entersubop, gv_ename(namegv), 0);
9583 /* _ must be at the end */
9584 if (proto[1] && !strchr(";@%", proto[1]))
9599 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
9601 arg == 1 ? "block or sub {}" : "sub {}",
9602 gv_ename(namegv), 0, o3);
9605 /* '*' allows any scalar type, including bareword */
9608 if (o3->op_type == OP_RV2GV)
9609 goto wrapref; /* autoconvert GLOB -> GLOBref */
9610 else if (o3->op_type == OP_CONST)
9611 o3->op_private &= ~OPpCONST_STRICT;
9612 else if (o3->op_type == OP_ENTERSUB) {
9613 /* accidental subroutine, revert to bareword */
9614 OP *gvop = ((UNOP*)o3)->op_first;
9615 if (gvop && gvop->op_type == OP_NULL) {
9616 gvop = ((UNOP*)gvop)->op_first;
9618 for (; gvop->op_sibling; gvop = gvop->op_sibling)
9621 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
9622 (gvop = ((UNOP*)gvop)->op_first) &&
9623 gvop->op_type == OP_GV)
9625 GV * const gv = cGVOPx_gv(gvop);
9626 OP * const sibling = aop->op_sibling;
9627 SV * const n = newSVpvs("");
9629 OP * const oldaop = aop;
9633 gv_fullname4(n, gv, "", FALSE);
9634 aop = newSVOP(OP_CONST, 0, n);
9635 op_getmad(oldaop,aop,'O');
9636 prev->op_sibling = aop;
9637 aop->op_sibling = sibling;
9647 if (o3->op_type == OP_RV2AV ||
9648 o3->op_type == OP_PADAV ||
9649 o3->op_type == OP_RV2HV ||
9650 o3->op_type == OP_PADHV
9665 if (contextclass++ == 0) {
9666 e = strchr(proto, ']');
9667 if (!e || e == proto)
9676 const char *p = proto;
9677 const char *const end = proto;
9680 /* \[$] accepts any scalar lvalue */
9682 && Perl_op_lvalue_flags(aTHX_
9684 OP_READ, /* not entersub */
9687 bad_type_sv(arg, Perl_form(aTHX_ "one of %.*s",
9689 gv_ename(namegv), 0, o3);
9694 if (o3->op_type == OP_RV2GV)
9697 bad_type_sv(arg, "symbol", gv_ename(namegv), 0, o3);
9700 if (o3->op_type == OP_ENTERSUB)
9703 bad_type_sv(arg, "subroutine entry", gv_ename(namegv), 0,
9707 if (o3->op_type == OP_RV2SV ||
9708 o3->op_type == OP_PADSV ||
9709 o3->op_type == OP_HELEM ||
9710 o3->op_type == OP_AELEM)
9712 if (!contextclass) {
9713 /* \$ accepts any scalar lvalue */
9714 if (Perl_op_lvalue_flags(aTHX_
9716 OP_READ, /* not entersub */
9719 bad_type_sv(arg, "scalar", gv_ename(namegv), 0, o3);
9723 if (o3->op_type == OP_RV2AV ||
9724 o3->op_type == OP_PADAV)
9727 bad_type_sv(arg, "array", gv_ename(namegv), 0, o3);
9730 if (o3->op_type == OP_RV2HV ||
9731 o3->op_type == OP_PADHV)
9734 bad_type_sv(arg, "hash", gv_ename(namegv), 0, o3);
9738 OP* const kid = aop;
9739 OP* const sib = kid->op_sibling;
9740 kid->op_sibling = 0;
9741 aop = newUNOP(OP_REFGEN, 0, kid);
9742 aop->op_sibling = sib;
9743 prev->op_sibling = aop;
9745 if (contextclass && e) {
9760 SV* const tmpsv = sv_newmortal();
9761 gv_efullname3(tmpsv, namegv, NULL);
9762 Perl_croak(aTHX_ "Malformed prototype for %"SVf": %"SVf,
9763 SVfARG(tmpsv), SVfARG(protosv));
9767 op_lvalue(aop, OP_ENTERSUB);
9769 aop = aop->op_sibling;
9771 if (aop == cvop && *proto == '_') {
9772 /* generate an access to $_ */
9774 aop->op_sibling = prev->op_sibling;
9775 prev->op_sibling = aop; /* instead of cvop */
9777 if (!optional && proto_end > proto &&
9778 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
9779 return too_few_arguments_sv(entersubop, gv_ename(namegv), 0);
9784 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
9786 Performs the fixup of the arguments part of an C<entersub> op tree either
9787 based on a subroutine prototype or using default list-context processing.
9788 This is the standard treatment used on a subroutine call, not marked
9789 with C<&>, where the callee can be identified at compile time.
9791 I<protosv> supplies the subroutine prototype to be applied to the call,
9792 or indicates that there is no prototype. It may be a normal scalar,
9793 in which case if it is defined then the string value will be used
9794 as a prototype, and if it is undefined then there is no prototype.
9795 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
9796 that has been cast to C<SV*>), of which the prototype will be used if it
9797 has one. The prototype (or lack thereof) supplied, in whichever form,
9798 does not need to match the actual callee referenced by the op tree.
9800 If the argument ops disagree with the prototype, for example by having
9801 an unacceptable number of arguments, a valid op tree is returned anyway.
9802 The error is reflected in the parser state, normally resulting in a single
9803 exception at the top level of parsing which covers all the compilation
9804 errors that occurred. In the error message, the callee is referred to
9805 by the name defined by the I<namegv> parameter.
9811 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
9812 GV *namegv, SV *protosv)
9814 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
9815 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
9816 return ck_entersub_args_proto(entersubop, namegv, protosv);
9818 return ck_entersub_args_list(entersubop);
9822 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
9824 int opnum = SvTYPE(protosv) == SVt_PVCV ? 0 : (int)SvUV(protosv);
9825 OP *aop = cUNOPx(entersubop)->op_first;
9827 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
9831 if (!aop->op_sibling)
9832 aop = cUNOPx(aop)->op_first;
9833 aop = aop->op_sibling;
9834 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
9835 if (PL_madskills) while (aop != cvop && aop->op_type == OP_STUB) {
9836 aop = aop->op_sibling;
9839 (void)too_many_arguments_pv(entersubop, GvNAME(namegv), 0);
9841 op_free(entersubop);
9842 switch(GvNAME(namegv)[2]) {
9843 case 'F': return newSVOP(OP_CONST, 0,
9844 newSVpv(CopFILE(PL_curcop),0));
9845 case 'L': return newSVOP(
9848 "%"IVdf, (IV)CopLINE(PL_curcop)
9851 case 'P': return newSVOP(OP_CONST, 0,
9853 ? newSVhek(HvNAME_HEK(PL_curstash))
9864 bool seenarg = FALSE;
9866 if (!aop->op_sibling)
9867 aop = cUNOPx(aop)->op_first;
9870 aop = aop->op_sibling;
9871 prev->op_sibling = NULL;
9874 prev=cvop, cvop = cvop->op_sibling)
9876 if (PL_madskills && cvop->op_sibling
9877 && cvop->op_type != OP_STUB) seenarg = TRUE
9880 prev->op_sibling = NULL;
9881 flags = OPf_SPECIAL * !(cvop->op_private & OPpENTERSUB_NOPAREN);
9883 if (aop == cvop) aop = NULL;
9884 op_free(entersubop);
9886 if (opnum == OP_ENTEREVAL
9887 && GvNAMELEN(namegv)==9 && strnEQ(GvNAME(namegv), "evalbytes", 9))
9888 flags |= OPpEVAL_BYTES <<8;
9890 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
9892 case OA_BASEOP_OR_UNOP:
9894 return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
9898 if (!PL_madskills || seenarg)
9900 (void)too_many_arguments_pv(aop, GvNAME(namegv), 0);
9903 return opnum == OP_RUNCV
9904 ? newPVOP(OP_RUNCV,0,NULL)
9907 return convert(opnum,0,aop);
9915 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
9917 Retrieves the function that will be used to fix up a call to I<cv>.
9918 Specifically, the function is applied to an C<entersub> op tree for a
9919 subroutine call, not marked with C<&>, where the callee can be identified
9920 at compile time as I<cv>.
9922 The C-level function pointer is returned in I<*ckfun_p>, and an SV
9923 argument for it is returned in I<*ckobj_p>. The function is intended
9924 to be called in this manner:
9926 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
9928 In this call, I<entersubop> is a pointer to the C<entersub> op,
9929 which may be replaced by the check function, and I<namegv> is a GV
9930 supplying the name that should be used by the check function to refer
9931 to the callee of the C<entersub> op if it needs to emit any diagnostics.
9932 It is permitted to apply the check function in non-standard situations,
9933 such as to a call to a different subroutine or to a method call.
9935 By default, the function is
9936 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
9937 and the SV parameter is I<cv> itself. This implements standard
9938 prototype processing. It can be changed, for a particular subroutine,
9939 by L</cv_set_call_checker>.
9945 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
9948 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
9949 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
9951 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
9952 *ckobj_p = callmg->mg_obj;
9954 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
9960 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
9962 Sets the function that will be used to fix up a call to I<cv>.
9963 Specifically, the function is applied to an C<entersub> op tree for a
9964 subroutine call, not marked with C<&>, where the callee can be identified
9965 at compile time as I<cv>.
9967 The C-level function pointer is supplied in I<ckfun>, and an SV argument
9968 for it is supplied in I<ckobj>. The function is intended to be called
9971 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
9973 In this call, I<entersubop> is a pointer to the C<entersub> op,
9974 which may be replaced by the check function, and I<namegv> is a GV
9975 supplying the name that should be used by the check function to refer
9976 to the callee of the C<entersub> op if it needs to emit any diagnostics.
9977 It is permitted to apply the check function in non-standard situations,
9978 such as to a call to a different subroutine or to a method call.
9980 The current setting for a particular CV can be retrieved by
9981 L</cv_get_call_checker>.
9987 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
9989 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
9990 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
9991 if (SvMAGICAL((SV*)cv))
9992 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
9995 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
9996 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
9997 if (callmg->mg_flags & MGf_REFCOUNTED) {
9998 SvREFCNT_dec(callmg->mg_obj);
9999 callmg->mg_flags &= ~MGf_REFCOUNTED;
10001 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
10002 callmg->mg_obj = ckobj;
10003 if (ckobj != (SV*)cv) {
10004 SvREFCNT_inc_simple_void_NN(ckobj);
10005 callmg->mg_flags |= MGf_REFCOUNTED;
10007 callmg->mg_flags |= MGf_COPY;
10012 Perl_ck_subr(pTHX_ OP *o)
10018 PERL_ARGS_ASSERT_CK_SUBR;
10020 aop = cUNOPx(o)->op_first;
10021 if (!aop->op_sibling)
10022 aop = cUNOPx(aop)->op_first;
10023 aop = aop->op_sibling;
10024 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
10025 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
10026 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_RETURN_NAME_GV) : NULL;
10028 o->op_private &= ~1;
10029 o->op_private |= OPpENTERSUB_HASTARG;
10030 o->op_private |= (PL_hints & HINT_STRICT_REFS);
10031 if (PERLDB_SUB && PL_curstash != PL_debstash)
10032 o->op_private |= OPpENTERSUB_DB;
10033 if (cvop->op_type == OP_RV2CV) {
10034 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
10036 } else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
10037 if (aop->op_type == OP_CONST)
10038 aop->op_private &= ~OPpCONST_STRICT;
10039 else if (aop->op_type == OP_LIST) {
10040 OP * const sib = ((UNOP*)aop)->op_first->op_sibling;
10041 if (sib && sib->op_type == OP_CONST)
10042 sib->op_private &= ~OPpCONST_STRICT;
10047 return ck_entersub_args_list(o);
10049 Perl_call_checker ckfun;
10051 cv_get_call_checker(cv, &ckfun, &ckobj);
10052 return ckfun(aTHX_ o, namegv, ckobj);
10057 Perl_ck_svconst(pTHX_ OP *o)
10059 PERL_ARGS_ASSERT_CK_SVCONST;
10060 PERL_UNUSED_CONTEXT;
10061 SvREADONLY_on(cSVOPo->op_sv);
10066 Perl_ck_trunc(pTHX_ OP *o)
10068 PERL_ARGS_ASSERT_CK_TRUNC;
10070 if (o->op_flags & OPf_KIDS) {
10071 SVOP *kid = (SVOP*)cUNOPo->op_first;
10073 if (kid->op_type == OP_NULL)
10074 kid = (SVOP*)kid->op_sibling;
10075 if (kid && kid->op_type == OP_CONST &&
10076 (kid->op_private & (OPpCONST_BARE|OPpCONST_FOLDED))
10079 o->op_flags |= OPf_SPECIAL;
10080 kid->op_private &= ~OPpCONST_STRICT;
10087 Perl_ck_substr(pTHX_ OP *o)
10089 PERL_ARGS_ASSERT_CK_SUBSTR;
10092 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
10093 OP *kid = cLISTOPo->op_first;
10095 if (kid->op_type == OP_NULL)
10096 kid = kid->op_sibling;
10098 kid->op_flags |= OPf_MOD;
10105 Perl_ck_tell(pTHX_ OP *o)
10107 PERL_ARGS_ASSERT_CK_TELL;
10109 if (o->op_flags & OPf_KIDS) {
10110 OP *kid = cLISTOPo->op_first;
10111 if (kid->op_type == OP_NULL && kid->op_sibling) kid = kid->op_sibling;
10112 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
10118 Perl_ck_each(pTHX_ OP *o)
10121 OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
10122 const unsigned orig_type = o->op_type;
10123 const unsigned array_type = orig_type == OP_EACH ? OP_AEACH
10124 : orig_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
10125 const unsigned ref_type = orig_type == OP_EACH ? OP_REACH
10126 : orig_type == OP_KEYS ? OP_RKEYS : OP_RVALUES;
10128 PERL_ARGS_ASSERT_CK_EACH;
10131 switch (kid->op_type) {
10137 CHANGE_TYPE(o, array_type);
10140 if (kid->op_private == OPpCONST_BARE
10141 || !SvROK(cSVOPx_sv(kid))
10142 || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
10143 && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV )
10145 /* we let ck_fun handle it */
10148 CHANGE_TYPE(o, ref_type);
10152 /* if treating as a reference, defer additional checks to runtime */
10153 return o->op_type == ref_type ? o : ck_fun(o);
10157 Perl_ck_length(pTHX_ OP *o)
10159 PERL_ARGS_ASSERT_CK_LENGTH;
10163 if (ckWARN(WARN_SYNTAX)) {
10164 const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
10168 const bool hash = kid->op_type == OP_PADHV
10169 || kid->op_type == OP_RV2HV;
10170 switch (kid->op_type) {
10174 (GV *)PL_compcv, hash ? '%' : '@', kid->op_targ,
10180 if (cUNOPx(kid)->op_first->op_type != OP_GV) break;
10182 GV *gv = cGVOPx_gv(cUNOPx(kid)->op_first);
10184 name = varname(gv, hash?'%':'@', 0, NULL, 0, 1);
10191 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10192 "length() used on %"SVf" (did you mean \"scalar(%s%"SVf
10194 name, hash ? "keys " : "", name
10197 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10198 "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
10200 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10201 "length() used on @array (did you mean \"scalar(@array)\"?)");
10208 /* Check for in place reverse and sort assignments like "@a = reverse @a"
10209 and modify the optree to make them work inplace */
10212 S_inplace_aassign(pTHX_ OP *o) {
10214 OP *modop, *modop_pushmark;
10216 OP *oleft, *oleft_pushmark;
10218 PERL_ARGS_ASSERT_INPLACE_AASSIGN;
10220 assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
10222 assert(cUNOPo->op_first->op_type == OP_NULL);
10223 modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
10224 assert(modop_pushmark->op_type == OP_PUSHMARK);
10225 modop = modop_pushmark->op_sibling;
10227 if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
10230 /* no other operation except sort/reverse */
10231 if (modop->op_sibling)
10234 assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
10235 if (!(oright = cUNOPx(modop)->op_first->op_sibling)) return;
10237 if (modop->op_flags & OPf_STACKED) {
10238 /* skip sort subroutine/block */
10239 assert(oright->op_type == OP_NULL);
10240 oright = oright->op_sibling;
10243 assert(cUNOPo->op_first->op_sibling->op_type == OP_NULL);
10244 oleft_pushmark = cUNOPx(cUNOPo->op_first->op_sibling)->op_first;
10245 assert(oleft_pushmark->op_type == OP_PUSHMARK);
10246 oleft = oleft_pushmark->op_sibling;
10248 /* Check the lhs is an array */
10250 (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
10251 || oleft->op_sibling
10252 || (oleft->op_private & OPpLVAL_INTRO)
10256 /* Only one thing on the rhs */
10257 if (oright->op_sibling)
10260 /* check the array is the same on both sides */
10261 if (oleft->op_type == OP_RV2AV) {
10262 if (oright->op_type != OP_RV2AV
10263 || !cUNOPx(oright)->op_first
10264 || cUNOPx(oright)->op_first->op_type != OP_GV
10265 || cUNOPx(oleft )->op_first->op_type != OP_GV
10266 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
10267 cGVOPx_gv(cUNOPx(oright)->op_first)
10271 else if (oright->op_type != OP_PADAV
10272 || oright->op_targ != oleft->op_targ
10276 /* This actually is an inplace assignment */
10278 modop->op_private |= OPpSORT_INPLACE;
10280 /* transfer MODishness etc from LHS arg to RHS arg */
10281 oright->op_flags = oleft->op_flags;
10283 /* remove the aassign op and the lhs */
10285 op_null(oleft_pushmark);
10286 if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
10287 op_null(cUNOPx(oleft)->op_first);
10291 #define MAX_DEFERRED 4
10295 if (defer_ix == (MAX_DEFERRED-1)) { \
10296 CALL_RPEEP(defer_queue[defer_base]); \
10297 defer_base = (defer_base + 1) % MAX_DEFERRED; \
10300 defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = o; \
10303 /* A peephole optimizer. We visit the ops in the order they're to execute.
10304 * See the comments at the top of this file for more details about when
10305 * peep() is called */
10308 Perl_rpeep(pTHX_ register OP *o)
10312 OP* defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
10313 int defer_base = 0;
10316 if (!o || o->op_opt)
10320 SAVEVPTR(PL_curcop);
10321 for (;; o = o->op_next) {
10322 if (o && o->op_opt)
10325 while (defer_ix >= 0)
10326 CALL_RPEEP(defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED]);
10330 /* By default, this op has now been optimised. A couple of cases below
10331 clear this again. */
10334 switch (o->op_type) {
10336 PL_curcop = ((COP*)o); /* for warnings */
10339 PL_curcop = ((COP*)o); /* for warnings */
10341 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
10342 to carry two labels. For now, take the easier option, and skip
10343 this optimisation if the first NEXTSTATE has a label. */
10344 if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
10345 OP *nextop = o->op_next;
10346 while (nextop && nextop->op_type == OP_NULL)
10347 nextop = nextop->op_next;
10349 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
10350 COP *firstcop = (COP *)o;
10351 COP *secondcop = (COP *)nextop;
10352 /* We want the COP pointed to by o (and anything else) to
10353 become the next COP down the line. */
10354 cop_free(firstcop);
10356 firstcop->op_next = secondcop->op_next;
10358 /* Now steal all its pointers, and duplicate the other
10360 firstcop->cop_line = secondcop->cop_line;
10361 #ifdef USE_ITHREADS
10362 firstcop->cop_stashoff = secondcop->cop_stashoff;
10363 firstcop->cop_file = secondcop->cop_file;
10365 firstcop->cop_stash = secondcop->cop_stash;
10366 firstcop->cop_filegv = secondcop->cop_filegv;
10368 firstcop->cop_hints = secondcop->cop_hints;
10369 firstcop->cop_seq = secondcop->cop_seq;
10370 firstcop->cop_warnings = secondcop->cop_warnings;
10371 firstcop->cop_hints_hash = secondcop->cop_hints_hash;
10373 #ifdef USE_ITHREADS
10374 secondcop->cop_stashoff = 0;
10375 secondcop->cop_file = NULL;
10377 secondcop->cop_stash = NULL;
10378 secondcop->cop_filegv = NULL;
10380 secondcop->cop_warnings = NULL;
10381 secondcop->cop_hints_hash = NULL;
10383 /* If we use op_null(), and hence leave an ex-COP, some
10384 warnings are misreported. For example, the compile-time
10385 error in 'use strict; no strict refs;' */
10386 secondcop->op_type = OP_NULL;
10387 secondcop->op_ppaddr = PL_ppaddr[OP_NULL];
10393 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
10394 if (o->op_next->op_private & OPpTARGET_MY) {
10395 if (o->op_flags & OPf_STACKED) /* chained concats */
10396 break; /* ignore_optimization */
10398 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
10399 o->op_targ = o->op_next->op_targ;
10400 o->op_next->op_targ = 0;
10401 o->op_private |= OPpTARGET_MY;
10404 op_null(o->op_next);
10408 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
10409 break; /* Scalar stub must produce undef. List stub is noop */
10413 if (o->op_targ == OP_NEXTSTATE
10414 || o->op_targ == OP_DBSTATE)
10416 PL_curcop = ((COP*)o);
10418 /* XXX: We avoid setting op_seq here to prevent later calls
10419 to rpeep() from mistakenly concluding that optimisation
10420 has already occurred. This doesn't fix the real problem,
10421 though (See 20010220.007). AMS 20010719 */
10422 /* op_seq functionality is now replaced by op_opt */
10429 if (oldop && o->op_next) {
10430 oldop->op_next = o->op_next;
10438 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
10439 OP* const pop = (o->op_type == OP_PADAV) ?
10440 o->op_next : o->op_next->op_next;
10442 if (pop && pop->op_type == OP_CONST &&
10443 ((PL_op = pop->op_next)) &&
10444 pop->op_next->op_type == OP_AELEM &&
10445 !(pop->op_next->op_private &
10446 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
10447 (i = SvIV(((SVOP*)pop)->op_sv)) <= 255 && i >= 0)
10450 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
10451 no_bareword_allowed(pop);
10452 if (o->op_type == OP_GV)
10453 op_null(o->op_next);
10454 op_null(pop->op_next);
10456 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
10457 o->op_next = pop->op_next->op_next;
10458 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
10459 o->op_private = (U8)i;
10460 if (o->op_type == OP_GV) {
10463 o->op_type = OP_AELEMFAST;
10466 o->op_type = OP_AELEMFAST_LEX;
10471 if (o->op_next->op_type == OP_RV2SV) {
10472 if (!(o->op_next->op_private & OPpDEREF)) {
10473 op_null(o->op_next);
10474 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
10476 o->op_next = o->op_next->op_next;
10477 o->op_type = OP_GVSV;
10478 o->op_ppaddr = PL_ppaddr[OP_GVSV];
10481 else if (o->op_next->op_type == OP_READLINE
10482 && o->op_next->op_next->op_type == OP_CONCAT
10483 && (o->op_next->op_next->op_flags & OPf_STACKED))
10485 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
10486 o->op_type = OP_RCATLINE;
10487 o->op_flags |= OPf_STACKED;
10488 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
10489 op_null(o->op_next->op_next);
10490 op_null(o->op_next);
10499 #define HV_OR_SCALARHV(op) \
10500 ( (op)->op_type == OP_PADHV || (op)->op_type == OP_RV2HV \
10502 : (op)->op_type == OP_SCALAR && (op)->op_flags & OPf_KIDS \
10503 && ( cUNOPx(op)->op_first->op_type == OP_PADHV \
10504 || cUNOPx(op)->op_first->op_type == OP_RV2HV) \
10505 ? cUNOPx(op)->op_first \
10509 if ((fop = HV_OR_SCALARHV(cUNOP->op_first)))
10510 fop->op_private |= OPpTRUEBOOL;
10516 fop = cLOGOP->op_first;
10517 sop = fop->op_sibling;
10518 while (cLOGOP->op_other->op_type == OP_NULL)
10519 cLOGOP->op_other = cLOGOP->op_other->op_next;
10520 while (o->op_next && ( o->op_type == o->op_next->op_type
10521 || o->op_next->op_type == OP_NULL))
10522 o->op_next = o->op_next->op_next;
10523 DEFER(cLOGOP->op_other);
10526 fop = HV_OR_SCALARHV(fop);
10527 if (sop) sop = HV_OR_SCALARHV(sop);
10532 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
10533 while (nop && nop->op_next) {
10534 switch (nop->op_next->op_type) {
10539 lop = nop = nop->op_next;
10542 nop = nop->op_next;
10551 if ( (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
10552 || o->op_type == OP_AND )
10553 fop->op_private |= OPpTRUEBOOL;
10554 else if (!(lop->op_flags & OPf_WANT))
10555 fop->op_private |= OPpMAYBE_TRUEBOOL;
10557 if ( (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
10559 sop->op_private |= OPpTRUEBOOL;
10566 if ((fop = HV_OR_SCALARHV(cLOGOP->op_first)))
10567 fop->op_private |= OPpTRUEBOOL;
10568 #undef HV_OR_SCALARHV
10579 while (cLOGOP->op_other->op_type == OP_NULL)
10580 cLOGOP->op_other = cLOGOP->op_other->op_next;
10581 DEFER(cLOGOP->op_other);
10586 while (cLOOP->op_redoop->op_type == OP_NULL)
10587 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
10588 while (cLOOP->op_nextop->op_type == OP_NULL)
10589 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
10590 while (cLOOP->op_lastop->op_type == OP_NULL)
10591 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
10592 /* a while(1) loop doesn't have an op_next that escapes the
10593 * loop, so we have to explicitly follow the op_lastop to
10594 * process the rest of the code */
10595 DEFER(cLOOP->op_lastop);
10599 assert(!(cPMOP->op_pmflags & PMf_ONCE));
10600 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
10601 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
10602 cPMOP->op_pmstashstartu.op_pmreplstart
10603 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
10604 DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
10610 if (o->op_flags & OPf_STACKED) {
10612 cUNOPx(cLISTOP->op_first->op_sibling)->op_first;
10613 if (kid->op_type == OP_SCOPE
10614 || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE))
10615 DEFER(kLISTOP->op_first);
10618 /* check that RHS of sort is a single plain array */
10619 oright = cUNOPo->op_first;
10620 if (!oright || oright->op_type != OP_PUSHMARK)
10623 if (o->op_private & OPpSORT_INPLACE)
10626 /* reverse sort ... can be optimised. */
10627 if (!cUNOPo->op_sibling) {
10628 /* Nothing follows us on the list. */
10629 OP * const reverse = o->op_next;
10631 if (reverse->op_type == OP_REVERSE &&
10632 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
10633 OP * const pushmark = cUNOPx(reverse)->op_first;
10634 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
10635 && (cUNOPx(pushmark)->op_sibling == o)) {
10636 /* reverse -> pushmark -> sort */
10637 o->op_private |= OPpSORT_REVERSE;
10639 pushmark->op_next = oright->op_next;
10649 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
10651 LISTOP *enter, *exlist;
10653 if (o->op_private & OPpSORT_INPLACE)
10656 enter = (LISTOP *) o->op_next;
10659 if (enter->op_type == OP_NULL) {
10660 enter = (LISTOP *) enter->op_next;
10664 /* for $a (...) will have OP_GV then OP_RV2GV here.
10665 for (...) just has an OP_GV. */
10666 if (enter->op_type == OP_GV) {
10667 gvop = (OP *) enter;
10668 enter = (LISTOP *) enter->op_next;
10671 if (enter->op_type == OP_RV2GV) {
10672 enter = (LISTOP *) enter->op_next;
10678 if (enter->op_type != OP_ENTERITER)
10681 iter = enter->op_next;
10682 if (!iter || iter->op_type != OP_ITER)
10685 expushmark = enter->op_first;
10686 if (!expushmark || expushmark->op_type != OP_NULL
10687 || expushmark->op_targ != OP_PUSHMARK)
10690 exlist = (LISTOP *) expushmark->op_sibling;
10691 if (!exlist || exlist->op_type != OP_NULL
10692 || exlist->op_targ != OP_LIST)
10695 if (exlist->op_last != o) {
10696 /* Mmm. Was expecting to point back to this op. */
10699 theirmark = exlist->op_first;
10700 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
10703 if (theirmark->op_sibling != o) {
10704 /* There's something between the mark and the reverse, eg
10705 for (1, reverse (...))
10710 ourmark = ((LISTOP *)o)->op_first;
10711 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
10714 ourlast = ((LISTOP *)o)->op_last;
10715 if (!ourlast || ourlast->op_next != o)
10718 rv2av = ourmark->op_sibling;
10719 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
10720 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
10721 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
10722 /* We're just reversing a single array. */
10723 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
10724 enter->op_flags |= OPf_STACKED;
10727 /* We don't have control over who points to theirmark, so sacrifice
10729 theirmark->op_next = ourmark->op_next;
10730 theirmark->op_flags = ourmark->op_flags;
10731 ourlast->op_next = gvop ? gvop : (OP *) enter;
10734 enter->op_private |= OPpITER_REVERSED;
10735 iter->op_private |= OPpITER_REVERSED;
10742 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
10743 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
10748 if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)) {
10750 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
10752 sv = newRV((SV *)PL_compcv);
10756 o->op_type = OP_CONST;
10757 o->op_ppaddr = PL_ppaddr[OP_CONST];
10758 o->op_flags |= OPf_SPECIAL;
10759 cSVOPo->op_sv = sv;
10764 if (OP_GIMME(o,0) == G_VOID) {
10765 OP *right = cBINOP->op_first;
10767 OP *left = right->op_sibling;
10768 if (left->op_type == OP_SUBSTR
10769 && (left->op_private & 7) < 4) {
10771 cBINOP->op_first = left;
10772 right->op_sibling =
10773 cBINOPx(left)->op_first->op_sibling;
10774 cBINOPx(left)->op_first->op_sibling = right;
10775 left->op_private |= OPpSUBSTR_REPL_FIRST;
10777 (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
10784 Perl_cpeep_t cpeep =
10785 XopENTRY(Perl_custom_op_xop(aTHX_ o), xop_peep);
10787 cpeep(aTHX_ o, oldop);
10798 Perl_peep(pTHX_ register OP *o)
10804 =head1 Custom Operators
10806 =for apidoc Ao||custom_op_xop
10807 Return the XOP structure for a given custom op. This function should be
10808 considered internal to OP_NAME and the other access macros: use them instead.
10814 Perl_custom_op_xop(pTHX_ const OP *o)
10820 static const XOP xop_null = { 0, 0, 0, 0, 0 };
10822 PERL_ARGS_ASSERT_CUSTOM_OP_XOP;
10823 assert(o->op_type == OP_CUSTOM);
10825 /* This is wrong. It assumes a function pointer can be cast to IV,
10826 * which isn't guaranteed, but this is what the old custom OP code
10827 * did. In principle it should be safer to Copy the bytes of the
10828 * pointer into a PV: since the new interface is hidden behind
10829 * functions, this can be changed later if necessary. */
10830 /* Change custom_op_xop if this ever happens */
10831 keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
10834 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
10836 /* assume noone will have just registered a desc */
10837 if (!he && PL_custom_op_names &&
10838 (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
10843 /* XXX does all this need to be shared mem? */
10844 Newxz(xop, 1, XOP);
10845 pv = SvPV(HeVAL(he), l);
10846 XopENTRY_set(xop, xop_name, savepvn(pv, l));
10847 if (PL_custom_op_descs &&
10848 (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
10850 pv = SvPV(HeVAL(he), l);
10851 XopENTRY_set(xop, xop_desc, savepvn(pv, l));
10853 Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
10857 if (!he) return &xop_null;
10859 xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
10864 =for apidoc Ao||custom_op_register
10865 Register a custom op. See L<perlguts/"Custom Operators">.
10871 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
10875 PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
10877 /* see the comment in custom_op_xop */
10878 keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
10880 if (!PL_custom_ops)
10881 PL_custom_ops = newHV();
10883 if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
10884 Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
10888 =head1 Functions in file op.c
10890 =for apidoc core_prototype
10891 This function assigns the prototype of the named core function to C<sv>, or
10892 to a new mortal SV if C<sv> is NULL. It returns the modified C<sv>, or
10893 NULL if the core function has no prototype. C<code> is a code as returned
10894 by C<keyword()>. It must not be equal to 0 or -KEY_CORE.
10900 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
10903 int i = 0, n = 0, seen_question = 0, defgv = 0;
10905 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
10906 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
10907 bool nullret = FALSE;
10909 PERL_ARGS_ASSERT_CORE_PROTOTYPE;
10911 assert (code && code != -KEY_CORE);
10913 if (!sv) sv = sv_newmortal();
10915 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
10917 switch (code < 0 ? -code : code) {
10918 case KEY_and : case KEY_chop: case KEY_chomp:
10919 case KEY_cmp : case KEY_defined: case KEY_delete: case KEY_exec :
10920 case KEY_exists: case KEY_eq : case KEY_ge : case KEY_goto :
10921 case KEY_grep : case KEY_gt : case KEY_last : case KEY_le :
10922 case KEY_lt : case KEY_map : case KEY_ne : case KEY_next :
10923 case KEY_or : case KEY_print : case KEY_printf: case KEY_qr :
10924 case KEY_redo : case KEY_require: case KEY_return: case KEY_say :
10925 case KEY_select: case KEY_sort : case KEY_split : case KEY_system:
10926 case KEY_x : case KEY_xor :
10927 if (!opnum) return NULL; nullret = TRUE; goto findopnum;
10928 case KEY_glob: retsetpvs("_;", OP_GLOB);
10929 case KEY_keys: retsetpvs("+", OP_KEYS);
10930 case KEY_values: retsetpvs("+", OP_VALUES);
10931 case KEY_each: retsetpvs("+", OP_EACH);
10932 case KEY_push: retsetpvs("+@", OP_PUSH);
10933 case KEY_unshift: retsetpvs("+@", OP_UNSHIFT);
10934 case KEY_pop: retsetpvs(";+", OP_POP);
10935 case KEY_shift: retsetpvs(";+", OP_SHIFT);
10936 case KEY_pos: retsetpvs(";\\[$*]", OP_POS);
10938 retsetpvs("+;$$@", OP_SPLICE);
10939 case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
10941 case KEY_evalbytes:
10942 name = "entereval"; break;
10950 while (i < MAXO) { /* The slow way. */
10951 if (strEQ(name, PL_op_name[i])
10952 || strEQ(name, PL_op_desc[i]))
10954 if (nullret) { assert(opnum); *opnum = i; return NULL; }
10961 defgv = PL_opargs[i] & OA_DEFGV;
10962 oa = PL_opargs[i] >> OASHIFT;
10964 if (oa & OA_OPTIONAL && !seen_question && (
10965 !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
10970 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
10971 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
10972 /* But globs are already references (kinda) */
10973 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
10977 if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
10978 && !scalar_mod_type(NULL, i)) {
10983 if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
10987 else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
10988 if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
10989 str[n-1] = '_'; defgv = 0;
10993 if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
10995 sv_setpvn(sv, str, n - 1);
10996 if (opnum) *opnum = i;
11001 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
11004 OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
11007 PERL_ARGS_ASSERT_CORESUB_OP;
11011 return op_append_elem(OP_LINESEQ,
11014 newSVOP(OP_CONST, 0, newSViv(-code % 3)),
11018 case OP_SELECT: /* which represents OP_SSELECT as well */
11023 newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
11024 newSVOP(OP_CONST, 0, newSVuv(1))
11026 coresub_op(newSVuv((UV)OP_SSELECT), 0,
11028 coresub_op(coreargssv, 0, OP_SELECT)
11032 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
11034 return op_append_elem(
11037 opnum == OP_WANTARRAY || opnum == OP_RUNCV
11038 ? OPpOFFBYONE << 8 : 0)
11040 case OA_BASEOP_OR_UNOP:
11041 if (opnum == OP_ENTEREVAL) {
11042 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
11043 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
11045 else o = newUNOP(opnum,0,argop);
11046 if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
11049 if (is_handle_constructor(o, 1))
11050 argop->op_private |= OPpCOREARGS_DEREF1;
11051 if (scalar_mod_type(NULL, opnum))
11052 argop->op_private |= OPpCOREARGS_SCALARMOD;
11056 o = convert(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
11057 if (is_handle_constructor(o, 2))
11058 argop->op_private |= OPpCOREARGS_DEREF2;
11059 if (opnum == OP_SUBSTR) {
11060 o->op_private |= OPpMAYBE_LVSUB;
11069 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
11070 SV * const *new_const_svp)
11072 const char *hvname;
11073 bool is_const = !!CvCONST(old_cv);
11074 SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
11076 PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
11078 if (is_const && new_const_svp && old_const_sv == *new_const_svp)
11080 /* They are 2 constant subroutines generated from
11081 the same constant. This probably means that
11082 they are really the "same" proxy subroutine
11083 instantiated in 2 places. Most likely this is
11084 when a constant is exported twice. Don't warn.
11087 (ckWARN(WARN_REDEFINE)
11089 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
11090 && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
11091 && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
11092 strEQ(hvname, "autouse"))
11096 && ckWARN_d(WARN_REDEFINE)
11097 && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
11100 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
11102 ? "Constant subroutine %"SVf" redefined"
11103 : "Subroutine %"SVf" redefined",
11108 =head1 Hook manipulation
11110 These functions provide convenient and thread-safe means of manipulating
11117 =for apidoc Am|void|wrap_op_checker|Optype opcode|Perl_check_t new_checker|Perl_check_t *old_checker_p
11119 Puts a C function into the chain of check functions for a specified op
11120 type. This is the preferred way to manipulate the L</PL_check> array.
11121 I<opcode> specifies which type of op is to be affected. I<new_checker>
11122 is a pointer to the C function that is to be added to that opcode's
11123 check chain, and I<old_checker_p> points to the storage location where a
11124 pointer to the next function in the chain will be stored. The value of
11125 I<new_pointer> is written into the L</PL_check> array, while the value
11126 previously stored there is written to I<*old_checker_p>.
11128 L</PL_check> is global to an entire process, and a module wishing to
11129 hook op checking may find itself invoked more than once per process,
11130 typically in different threads. To handle that situation, this function
11131 is idempotent. The location I<*old_checker_p> must initially (once
11132 per process) contain a null pointer. A C variable of static duration
11133 (declared at file scope, typically also marked C<static> to give
11134 it internal linkage) will be implicitly initialised appropriately,
11135 if it does not have an explicit initialiser. This function will only
11136 actually modify the check chain if it finds I<*old_checker_p> to be null.
11137 This function is also thread safe on the small scale. It uses appropriate
11138 locking to avoid race conditions in accessing L</PL_check>.
11140 When this function is called, the function referenced by I<new_checker>
11141 must be ready to be called, except for I<*old_checker_p> being unfilled.
11142 In a threading situation, I<new_checker> may be called immediately,
11143 even before this function has returned. I<*old_checker_p> will always
11144 be appropriately set before I<new_checker> is called. If I<new_checker>
11145 decides not to do anything special with an op that it is given (which
11146 is the usual case for most uses of op check hooking), it must chain the
11147 check function referenced by I<*old_checker_p>.
11149 If you want to influence compilation of calls to a specific subroutine,
11150 then use L</cv_set_call_checker> rather than hooking checking of all
11157 Perl_wrap_op_checker(pTHX_ Optype opcode,
11158 Perl_check_t new_checker, Perl_check_t *old_checker_p)
11162 PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
11163 if (*old_checker_p) return;
11164 OP_CHECK_MUTEX_LOCK;
11165 if (!*old_checker_p) {
11166 *old_checker_p = PL_check[opcode];
11167 PL_check[opcode] = new_checker;
11169 OP_CHECK_MUTEX_UNLOCK;
11174 /* Efficient sub that returns a constant scalar value. */
11176 const_sv_xsub(pTHX_ CV* cv)
11180 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
11184 /* diag_listed_as: SKIPME */
11185 Perl_croak(aTHX_ "usage: %s::%s()",
11186 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
11199 * c-indentation-style: bsd
11200 * c-basic-offset: 4
11201 * indent-tabs-mode: nil
11204 * ex: set ts=8 sts=4 sw=4 et: