3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
13 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
14 * youngest of the Old Took's daughters); and Mr. Drogo was his second
15 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
16 * either way, as the saying is, if you follow me." --the Gaffer
19 /* This file contains the functions that create, manipulate and optimize
20 * the OP structures that hold a compiled perl program.
22 * A Perl program is compiled into a tree of OPs. Each op contains
23 * structural pointers (eg to its siblings and the next op in the
24 * execution sequence), a pointer to the function that would execute the
25 * op, plus any data specific to that op. For example, an OP_CONST op
26 * points to the pp_const() function and to an SV containing the constant
27 * value. When pp_const() is executed, its job is to push that SV onto the
30 * OPs are mainly created by the newFOO() functions, which are mainly
31 * called from the parser (in perly.y) as the code is parsed. For example
32 * the Perl code $a + $b * $c would cause the equivalent of the following
33 * to be called (oversimplifying a bit):
35 * newBINOP(OP_ADD, flags,
37 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
40 * Note that during the build of miniperl, a temporary copy of this file
41 * is made, called opmini.c.
45 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
49 An execution-order pass
51 The bottom-up pass is represented by all the "newOP" routines and
52 the ck_ routines. The bottom-upness is actually driven by yacc.
53 So at the point that a ck_ routine fires, we have no idea what the
54 context is, either upward in the syntax tree, or either forward or
55 backward in the execution order. (The bottom-up parser builds that
56 part of the execution order it knows about, but if you follow the "next"
57 links around, you'll find it's actually a closed loop through the
60 Whenever the bottom-up parser gets to a node that supplies context to
61 its components, it invokes that portion of the top-down pass that applies
62 to that part of the subtree (and marks the top node as processed, so
63 if a node further up supplies context, it doesn't have to take the
64 plunge again). As a particular subcase of this, as the new node is
65 built, it takes all the closed execution loops of its subcomponents
66 and links them into a new closed loop for the higher level node. But
67 it's still not the real execution order.
69 The actual execution order is not known till we get a grammar reduction
70 to a top-level unit like a subroutine or file that will be called by
71 "name" rather than via a "next" pointer. At that point, we can call
72 into peep() to do that code's portion of the 3rd pass. It has to be
73 recursive, but it's recursive on basic blocks, not on tree nodes.
81 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
83 #if defined(PL_OP_SLAB_ALLOC)
85 #ifndef PERL_SLAB_SIZE
86 #define PERL_SLAB_SIZE 2048
90 Perl_Slab_Alloc(pTHX_ int m, size_t sz)
93 * To make incrementing use count easy PL_OpSlab is an I32 *
94 * To make inserting the link to slab PL_OpPtr is I32 **
95 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
96 * Add an overhead for pointer to slab and round up as a number of pointers
98 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
99 if ((PL_OpSpace -= sz) < 0) {
100 PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*));
104 Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **);
105 /* We reserve the 0'th I32 sized chunk as a use count */
106 PL_OpSlab = (I32 *) PL_OpPtr;
107 /* Reduce size by the use count word, and by the size we need.
108 * Latter is to mimic the '-=' in the if() above
110 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
111 /* Allocation pointer starts at the top.
112 Theory: because we build leaves before trunk allocating at end
113 means that at run time access is cache friendly upward
115 PL_OpPtr += PERL_SLAB_SIZE;
117 assert( PL_OpSpace >= 0 );
118 /* Move the allocation pointer down */
120 assert( PL_OpPtr > (I32 **) PL_OpSlab );
121 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
122 (*PL_OpSlab)++; /* Increment use count of slab */
123 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
124 assert( *PL_OpSlab > 0 );
125 return (void *)(PL_OpPtr + 1);
129 Perl_Slab_Free(pTHX_ void *op)
131 I32 * const * const ptr = (I32 **) op;
132 I32 * const slab = ptr[-1];
133 assert( ptr-1 > (I32 **) slab );
134 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
136 if (--(*slab) == 0) {
138 # define PerlMemShared PerlMem
141 PerlMemShared_free(slab);
142 if (slab == PL_OpSlab) {
149 * In the following definition, the ", (OP*)0" is just to make the compiler
150 * think the expression is of the right type: croak actually does a Siglongjmp.
152 #define CHECKOP(type,o) \
153 ((PL_op_mask && PL_op_mask[type]) \
154 ? ( op_free((OP*)o), \
155 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
157 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
159 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
162 S_gv_ename(pTHX_ GV *gv)
164 SV* const tmpsv = sv_newmortal();
165 gv_efullname3(tmpsv, gv, NULL);
166 return SvPV_nolen_const(tmpsv);
170 S_no_fh_allowed(pTHX_ OP *o)
172 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
178 S_too_few_arguments(pTHX_ OP *o, const char *name)
180 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
185 S_too_many_arguments(pTHX_ OP *o, const char *name)
187 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
192 S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
194 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
195 (int)n, name, t, OP_DESC(kid)));
199 S_no_bareword_allowed(pTHX_ const OP *o)
201 qerror(Perl_mess(aTHX_
202 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
206 /* "register" allocation */
209 Perl_allocmy(pTHX_ char *name)
213 const bool is_our = (PL_in_my == KEY_our);
215 /* complain about "my $<special_var>" etc etc */
219 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
220 (name[1] == '_' && (*name == '$' || name[2]))))
222 /* name[2] is true if strlen(name) > 2 */
223 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
224 /* 1999-02-27 mjd@plover.com */
226 p = strchr(name, '\0');
227 /* The next block assumes the buffer is at least 205 chars
228 long. At present, it's always at least 256 chars. */
230 strcpy(name+200, "...");
236 /* Move everything else down one character */
237 for (; p-name > 2; p--)
239 name[2] = toCTRL(name[1]);
242 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
245 /* check for duplicate declaration */
246 pad_check_dup(name, is_our, (PL_curstash ? PL_curstash : PL_defstash));
248 if (PL_in_my_stash && *name != '$') {
249 yyerror(Perl_form(aTHX_
250 "Can't declare class for non-scalar %s in \"%s\"",
251 name, is_our ? "our" : "my"));
254 /* allocate a spare slot and store the name in that slot */
256 off = pad_add_name(name,
259 /* $_ is always in main::, even with our */
260 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
271 Perl_op_free(pTHX_ OP *o)
276 if (!o || o->op_static)
280 if (o->op_private & OPpREFCOUNTED) {
291 refcnt = OpREFCNT_dec(o);
302 if (o->op_flags & OPf_KIDS) {
303 register OP *kid, *nextkid;
304 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
305 nextkid = kid->op_sibling; /* Get before next freeing kid */
311 type = (OPCODE)o->op_targ;
313 /* COP* is not cleared by op_clear() so that we may track line
314 * numbers etc even after null() */
315 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
320 #ifdef DEBUG_LEAKING_SCALARS
327 Perl_op_clear(pTHX_ OP *o)
331 switch (o->op_type) {
332 case OP_NULL: /* Was holding old type, if any. */
333 case OP_ENTEREVAL: /* Was holding hints. */
337 if (!(o->op_flags & OPf_REF)
338 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
344 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
345 /* not an OP_PADAV replacement */
347 if (cPADOPo->op_padix > 0) {
348 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
349 * may still exist on the pad */
350 pad_swipe(cPADOPo->op_padix, TRUE);
351 cPADOPo->op_padix = 0;
354 SvREFCNT_dec(cSVOPo->op_sv);
355 cSVOPo->op_sv = NULL;
359 case OP_METHOD_NAMED:
361 SvREFCNT_dec(cSVOPo->op_sv);
362 cSVOPo->op_sv = NULL;
365 Even if op_clear does a pad_free for the target of the op,
366 pad_free doesn't actually remove the sv that exists in the pad;
367 instead it lives on. This results in that it could be reused as
368 a target later on when the pad was reallocated.
371 pad_swipe(o->op_targ,1);
380 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
384 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
385 SvREFCNT_dec(cSVOPo->op_sv);
386 cSVOPo->op_sv = NULL;
389 Safefree(cPVOPo->op_pv);
390 cPVOPo->op_pv = NULL;
394 op_free(cPMOPo->op_pmreplroot);
398 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
399 /* No GvIN_PAD_off here, because other references may still
400 * exist on the pad */
401 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
404 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
411 HV * const pmstash = PmopSTASH(cPMOPo);
412 if (pmstash && !SvIS_FREED(pmstash)) {
413 MAGIC * const mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab);
415 PMOP *pmop = (PMOP*) mg->mg_obj;
416 PMOP *lastpmop = NULL;
418 if (cPMOPo == pmop) {
420 lastpmop->op_pmnext = pmop->op_pmnext;
422 mg->mg_obj = (SV*) pmop->op_pmnext;
426 pmop = pmop->op_pmnext;
430 PmopSTASH_free(cPMOPo);
432 cPMOPo->op_pmreplroot = NULL;
433 /* we use the "SAFE" version of the PM_ macros here
434 * since sv_clean_all might release some PMOPs
435 * after PL_regex_padav has been cleared
436 * and the clearing of PL_regex_padav needs to
437 * happen before sv_clean_all
439 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
440 PM_SETRE_SAFE(cPMOPo, NULL);
442 if(PL_regex_pad) { /* We could be in destruction */
443 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
444 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
445 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
452 if (o->op_targ > 0) {
453 pad_free(o->op_targ);
459 S_cop_free(pTHX_ COP* cop)
461 Safefree(cop->cop_label); /* FIXME: treaddead ??? */
464 if (! specialWARN(cop->cop_warnings))
465 SvREFCNT_dec(cop->cop_warnings);
466 if (! specialCopIO(cop->cop_io)) {
470 SvREFCNT_dec(cop->cop_io);
476 Perl_op_null(pTHX_ OP *o)
479 if (o->op_type == OP_NULL)
482 o->op_targ = o->op_type;
483 o->op_type = OP_NULL;
484 o->op_ppaddr = PL_ppaddr[OP_NULL];
488 Perl_op_refcnt_lock(pTHX)
496 Perl_op_refcnt_unlock(pTHX)
503 /* Contextualizers */
505 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
508 Perl_linklist(pTHX_ OP *o)
515 /* establish postfix order */
516 first = cUNOPo->op_first;
519 o->op_next = LINKLIST(first);
522 if (kid->op_sibling) {
523 kid->op_next = LINKLIST(kid->op_sibling);
524 kid = kid->op_sibling;
538 Perl_scalarkids(pTHX_ OP *o)
540 if (o && o->op_flags & OPf_KIDS) {
542 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
549 S_scalarboolean(pTHX_ OP *o)
552 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
553 if (ckWARN(WARN_SYNTAX)) {
554 const line_t oldline = CopLINE(PL_curcop);
556 if (PL_copline != NOLINE)
557 CopLINE_set(PL_curcop, PL_copline);
558 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
559 CopLINE_set(PL_curcop, oldline);
566 Perl_scalar(pTHX_ OP *o)
571 /* assumes no premature commitment */
572 if (!o || PL_error_count || (o->op_flags & OPf_WANT)
573 || o->op_type == OP_RETURN)
578 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
580 switch (o->op_type) {
582 scalar(cBINOPo->op_first);
587 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
591 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
592 if (!kPMOP->op_pmreplroot)
593 deprecate_old("implicit split to @_");
601 if (o->op_flags & OPf_KIDS) {
602 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
608 kid = cLISTOPo->op_first;
610 while ((kid = kid->op_sibling)) {
616 WITH_THR(PL_curcop = &PL_compiling);
621 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
627 WITH_THR(PL_curcop = &PL_compiling);
630 if (ckWARN(WARN_VOID))
631 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
637 Perl_scalarvoid(pTHX_ OP *o)
641 const char* useless = NULL;
645 if (o->op_type == OP_NEXTSTATE
646 || o->op_type == OP_SETSTATE
647 || o->op_type == OP_DBSTATE
648 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
649 || o->op_targ == OP_SETSTATE
650 || o->op_targ == OP_DBSTATE)))
651 PL_curcop = (COP*)o; /* for warning below */
653 /* assumes no premature commitment */
654 want = o->op_flags & OPf_WANT;
655 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
656 || o->op_type == OP_RETURN)
661 if ((o->op_private & OPpTARGET_MY)
662 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
664 return scalar(o); /* As if inside SASSIGN */
667 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
669 switch (o->op_type) {
671 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
675 if (o->op_flags & OPf_STACKED)
679 if (o->op_private == 4)
751 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
752 useless = OP_DESC(o);
756 kid = cUNOPo->op_first;
757 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
758 kid->op_type != OP_TRANS) {
761 useless = "negative pattern binding (!~)";
768 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
769 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
770 useless = "a variable";
775 if (cSVOPo->op_private & OPpCONST_STRICT)
776 no_bareword_allowed(o);
778 if (ckWARN(WARN_VOID)) {
779 useless = "a constant";
780 /* don't warn on optimised away booleans, eg
781 * use constant Foo, 5; Foo || print; */
782 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
784 /* the constants 0 and 1 are permitted as they are
785 conventionally used as dummies in constructs like
786 1 while some_condition_with_side_effects; */
787 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
789 else if (SvPOK(sv)) {
790 /* perl4's way of mixing documentation and code
791 (before the invention of POD) was based on a
792 trick to mix nroff and perl code. The trick was
793 built upon these three nroff macros being used in
794 void context. The pink camel has the details in
795 the script wrapman near page 319. */
796 const char * const maybe_macro = SvPVX_const(sv);
797 if (strnEQ(maybe_macro, "di", 2) ||
798 strnEQ(maybe_macro, "ds", 2) ||
799 strnEQ(maybe_macro, "ig", 2))
804 op_null(o); /* don't execute or even remember it */
808 o->op_type = OP_PREINC; /* pre-increment is faster */
809 o->op_ppaddr = PL_ppaddr[OP_PREINC];
813 o->op_type = OP_PREDEC; /* pre-decrement is faster */
814 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
818 o->op_type = OP_I_PREINC; /* pre-increment is faster */
819 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
823 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
824 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
833 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
838 if (o->op_flags & OPf_STACKED)
845 if (!(o->op_flags & OPf_KIDS))
856 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
863 /* all requires must return a boolean value */
864 o->op_flags &= ~OPf_WANT;
869 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
870 if (!kPMOP->op_pmreplroot)
871 deprecate_old("implicit split to @_");
875 if (useless && ckWARN(WARN_VOID))
876 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
881 Perl_listkids(pTHX_ OP *o)
883 if (o && o->op_flags & OPf_KIDS) {
885 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
892 Perl_list(pTHX_ OP *o)
897 /* assumes no premature commitment */
898 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
899 || o->op_type == OP_RETURN)
904 if ((o->op_private & OPpTARGET_MY)
905 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
907 return o; /* As if inside SASSIGN */
910 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
912 switch (o->op_type) {
915 list(cBINOPo->op_first);
920 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
928 if (!(o->op_flags & OPf_KIDS))
930 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
931 list(cBINOPo->op_first);
932 return gen_constant_list(o);
939 kid = cLISTOPo->op_first;
941 while ((kid = kid->op_sibling)) {
947 WITH_THR(PL_curcop = &PL_compiling);
951 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
957 WITH_THR(PL_curcop = &PL_compiling);
960 /* all requires must return a boolean value */
961 o->op_flags &= ~OPf_WANT;
968 Perl_scalarseq(pTHX_ OP *o)
972 if (o->op_type == OP_LINESEQ ||
973 o->op_type == OP_SCOPE ||
974 o->op_type == OP_LEAVE ||
975 o->op_type == OP_LEAVETRY)
978 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
979 if (kid->op_sibling) {
983 PL_curcop = &PL_compiling;
985 o->op_flags &= ~OPf_PARENS;
986 if (PL_hints & HINT_BLOCK_SCOPE)
987 o->op_flags |= OPf_PARENS;
990 o = newOP(OP_STUB, 0);
995 S_modkids(pTHX_ OP *o, I32 type)
997 if (o && o->op_flags & OPf_KIDS) {
999 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1005 /* Propagate lvalue ("modifiable") context to an op and its children.
1006 * 'type' represents the context type, roughly based on the type of op that
1007 * would do the modifying, although local() is represented by OP_NULL.
1008 * It's responsible for detecting things that can't be modified, flag
1009 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1010 * might have to vivify a reference in $x), and so on.
1012 * For example, "$a+1 = 2" would cause mod() to be called with o being
1013 * OP_ADD and type being OP_SASSIGN, and would output an error.
1017 Perl_mod(pTHX_ OP *o, I32 type)
1021 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1024 if (!o || PL_error_count)
1027 if ((o->op_private & OPpTARGET_MY)
1028 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1033 switch (o->op_type) {
1039 if (!(o->op_private & (OPpCONST_ARYBASE)))
1042 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1043 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1047 SAVEI32(PL_compiling.cop_arybase);
1048 PL_compiling.cop_arybase = 0;
1050 else if (type == OP_REFGEN)
1053 Perl_croak(aTHX_ "That use of $[ is unsupported");
1056 if (o->op_flags & OPf_PARENS)
1060 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1061 !(o->op_flags & OPf_STACKED)) {
1062 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1063 /* The default is to set op_private to the number of children,
1064 which for a UNOP such as RV2CV is always 1. And w're using
1065 the bit for a flag in RV2CV, so we need it clear. */
1066 o->op_private &= ~1;
1067 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1068 assert(cUNOPo->op_first->op_type == OP_NULL);
1069 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1072 else if (o->op_private & OPpENTERSUB_NOMOD)
1074 else { /* lvalue subroutine call */
1075 o->op_private |= OPpLVAL_INTRO;
1076 PL_modcount = RETURN_UNLIMITED_NUMBER;
1077 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1078 /* Backward compatibility mode: */
1079 o->op_private |= OPpENTERSUB_INARGS;
1082 else { /* Compile-time error message: */
1083 OP *kid = cUNOPo->op_first;
1087 if (kid->op_type == OP_PUSHMARK)
1089 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1091 "panic: unexpected lvalue entersub "
1092 "args: type/targ %ld:%"UVuf,
1093 (long)kid->op_type, (UV)kid->op_targ);
1094 kid = kLISTOP->op_first;
1096 while (kid->op_sibling)
1097 kid = kid->op_sibling;
1098 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1100 if (kid->op_type == OP_METHOD_NAMED
1101 || kid->op_type == OP_METHOD)
1105 NewOp(1101, newop, 1, UNOP);
1106 newop->op_type = OP_RV2CV;
1107 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1108 newop->op_first = NULL;
1109 newop->op_next = (OP*)newop;
1110 kid->op_sibling = (OP*)newop;
1111 newop->op_private |= OPpLVAL_INTRO;
1112 newop->op_private &= ~1;
1116 if (kid->op_type != OP_RV2CV)
1118 "panic: unexpected lvalue entersub "
1119 "entry via type/targ %ld:%"UVuf,
1120 (long)kid->op_type, (UV)kid->op_targ);
1121 kid->op_private |= OPpLVAL_INTRO;
1122 break; /* Postpone until runtime */
1126 kid = kUNOP->op_first;
1127 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1128 kid = kUNOP->op_first;
1129 if (kid->op_type == OP_NULL)
1131 "Unexpected constant lvalue entersub "
1132 "entry via type/targ %ld:%"UVuf,
1133 (long)kid->op_type, (UV)kid->op_targ);
1134 if (kid->op_type != OP_GV) {
1135 /* Restore RV2CV to check lvalueness */
1137 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1138 okid->op_next = kid->op_next;
1139 kid->op_next = okid;
1142 okid->op_next = NULL;
1143 okid->op_type = OP_RV2CV;
1145 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1146 okid->op_private |= OPpLVAL_INTRO;
1147 okid->op_private &= ~1;
1151 cv = GvCV(kGVOP_gv);
1161 /* grep, foreach, subcalls, refgen */
1162 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1164 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1165 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1167 : (o->op_type == OP_ENTERSUB
1168 ? "non-lvalue subroutine call"
1170 type ? PL_op_desc[type] : "local"));
1184 case OP_RIGHT_SHIFT:
1193 if (!(o->op_flags & OPf_STACKED))
1200 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1206 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1207 PL_modcount = RETURN_UNLIMITED_NUMBER;
1208 return o; /* Treat \(@foo) like ordinary list. */
1212 if (scalar_mod_type(o, type))
1214 ref(cUNOPo->op_first, o->op_type);
1218 if (type == OP_LEAVESUBLV)
1219 o->op_private |= OPpMAYBE_LVSUB;
1225 PL_modcount = RETURN_UNLIMITED_NUMBER;
1228 ref(cUNOPo->op_first, o->op_type);
1233 PL_hints |= HINT_BLOCK_SCOPE;
1248 PL_modcount = RETURN_UNLIMITED_NUMBER;
1249 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1250 return o; /* Treat \(@foo) like ordinary list. */
1251 if (scalar_mod_type(o, type))
1253 if (type == OP_LEAVESUBLV)
1254 o->op_private |= OPpMAYBE_LVSUB;
1258 if (!type) /* local() */
1259 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1260 PAD_COMPNAME_PV(o->op_targ));
1268 if (type != OP_SASSIGN)
1272 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1277 if (type == OP_LEAVESUBLV)
1278 o->op_private |= OPpMAYBE_LVSUB;
1280 pad_free(o->op_targ);
1281 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1282 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1283 if (o->op_flags & OPf_KIDS)
1284 mod(cBINOPo->op_first->op_sibling, type);
1289 ref(cBINOPo->op_first, o->op_type);
1290 if (type == OP_ENTERSUB &&
1291 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1292 o->op_private |= OPpLVAL_DEFER;
1293 if (type == OP_LEAVESUBLV)
1294 o->op_private |= OPpMAYBE_LVSUB;
1304 if (o->op_flags & OPf_KIDS)
1305 mod(cLISTOPo->op_last, type);
1310 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1312 else if (!(o->op_flags & OPf_KIDS))
1314 if (o->op_targ != OP_LIST) {
1315 mod(cBINOPo->op_first, type);
1321 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1326 if (type != OP_LEAVESUBLV)
1328 break; /* mod()ing was handled by ck_return() */
1331 /* [20011101.069] File test operators interpret OPf_REF to mean that
1332 their argument is a filehandle; thus \stat(".") should not set
1334 if (type == OP_REFGEN &&
1335 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1338 if (type != OP_LEAVESUBLV)
1339 o->op_flags |= OPf_MOD;
1341 if (type == OP_AASSIGN || type == OP_SASSIGN)
1342 o->op_flags |= OPf_SPECIAL|OPf_REF;
1343 else if (!type) { /* local() */
1346 o->op_private |= OPpLVAL_INTRO;
1347 o->op_flags &= ~OPf_SPECIAL;
1348 PL_hints |= HINT_BLOCK_SCOPE;
1353 if (ckWARN(WARN_SYNTAX)) {
1354 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1355 "Useless localization of %s", OP_DESC(o));
1359 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1360 && type != OP_LEAVESUBLV)
1361 o->op_flags |= OPf_REF;
1366 S_scalar_mod_type(const OP *o, I32 type)
1370 if (o->op_type == OP_RV2GV)
1394 case OP_RIGHT_SHIFT:
1413 S_is_handle_constructor(const OP *o, I32 numargs)
1415 switch (o->op_type) {
1423 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1436 Perl_refkids(pTHX_ OP *o, I32 type)
1438 if (o && o->op_flags & OPf_KIDS) {
1440 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1447 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1452 if (!o || PL_error_count)
1455 switch (o->op_type) {
1457 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1458 !(o->op_flags & OPf_STACKED)) {
1459 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1460 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1461 assert(cUNOPo->op_first->op_type == OP_NULL);
1462 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1463 o->op_flags |= OPf_SPECIAL;
1464 o->op_private &= ~1;
1469 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1470 doref(kid, type, set_op_ref);
1473 if (type == OP_DEFINED)
1474 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1475 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1478 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1479 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1480 : type == OP_RV2HV ? OPpDEREF_HV
1482 o->op_flags |= OPf_MOD;
1487 o->op_flags |= OPf_MOD; /* XXX ??? */
1493 o->op_flags |= OPf_REF;
1496 if (type == OP_DEFINED)
1497 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1498 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1504 o->op_flags |= OPf_REF;
1509 if (!(o->op_flags & OPf_KIDS))
1511 doref(cBINOPo->op_first, type, set_op_ref);
1515 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1516 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1517 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1518 : type == OP_RV2HV ? OPpDEREF_HV
1520 o->op_flags |= OPf_MOD;
1530 if (!(o->op_flags & OPf_KIDS))
1532 doref(cLISTOPo->op_last, type, set_op_ref);
1542 S_dup_attrlist(pTHX_ OP *o)
1547 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1548 * where the first kid is OP_PUSHMARK and the remaining ones
1549 * are OP_CONST. We need to push the OP_CONST values.
1551 if (o->op_type == OP_CONST)
1552 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1554 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1556 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1557 if (o->op_type == OP_CONST)
1558 rop = append_elem(OP_LIST, rop,
1559 newSVOP(OP_CONST, o->op_flags,
1560 SvREFCNT_inc_NN(cSVOPo->op_sv)));
1567 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1572 /* fake up C<use attributes $pkg,$rv,@attrs> */
1573 ENTER; /* need to protect against side-effects of 'use' */
1575 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1577 #define ATTRSMODULE "attributes"
1578 #define ATTRSMODULE_PM "attributes.pm"
1581 /* Don't force the C<use> if we don't need it. */
1582 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
1583 if (svp && *svp != &PL_sv_undef)
1584 /*EMPTY*/; /* already in %INC */
1586 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1587 newSVpvs(ATTRSMODULE), NULL);
1590 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1591 newSVpvs(ATTRSMODULE),
1593 prepend_elem(OP_LIST,
1594 newSVOP(OP_CONST, 0, stashsv),
1595 prepend_elem(OP_LIST,
1596 newSVOP(OP_CONST, 0,
1598 dup_attrlist(attrs))));
1604 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1607 OP *pack, *imop, *arg;
1613 assert(target->op_type == OP_PADSV ||
1614 target->op_type == OP_PADHV ||
1615 target->op_type == OP_PADAV);
1617 /* Ensure that attributes.pm is loaded. */
1618 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1620 /* Need package name for method call. */
1621 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
1623 /* Build up the real arg-list. */
1624 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1626 arg = newOP(OP_PADSV, 0);
1627 arg->op_targ = target->op_targ;
1628 arg = prepend_elem(OP_LIST,
1629 newSVOP(OP_CONST, 0, stashsv),
1630 prepend_elem(OP_LIST,
1631 newUNOP(OP_REFGEN, 0,
1632 mod(arg, OP_REFGEN)),
1633 dup_attrlist(attrs)));
1635 /* Fake up a method call to import */
1636 meth = newSVpvs_share("import");
1637 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1638 append_elem(OP_LIST,
1639 prepend_elem(OP_LIST, pack, list(arg)),
1640 newSVOP(OP_METHOD_NAMED, 0, meth)));
1641 imop->op_private |= OPpENTERSUB_NOMOD;
1643 /* Combine the ops. */
1644 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1648 =notfor apidoc apply_attrs_string
1650 Attempts to apply a list of attributes specified by the C<attrstr> and
1651 C<len> arguments to the subroutine identified by the C<cv> argument which
1652 is expected to be associated with the package identified by the C<stashpv>
1653 argument (see L<attributes>). It gets this wrong, though, in that it
1654 does not correctly identify the boundaries of the individual attribute
1655 specifications within C<attrstr>. This is not really intended for the
1656 public API, but has to be listed here for systems such as AIX which
1657 need an explicit export list for symbols. (It's called from XS code
1658 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1659 to respect attribute syntax properly would be welcome.
1665 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1666 const char *attrstr, STRLEN len)
1671 len = strlen(attrstr);
1675 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1677 const char * const sstr = attrstr;
1678 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1679 attrs = append_elem(OP_LIST, attrs,
1680 newSVOP(OP_CONST, 0,
1681 newSVpvn(sstr, attrstr-sstr)));
1685 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1686 newSVpvs(ATTRSMODULE),
1687 NULL, prepend_elem(OP_LIST,
1688 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1689 prepend_elem(OP_LIST,
1690 newSVOP(OP_CONST, 0,
1696 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1701 if (!o || PL_error_count)
1705 if (type == OP_LIST) {
1707 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1708 my_kid(kid, attrs, imopsp);
1709 } else if (type == OP_UNDEF) {
1711 } else if (type == OP_RV2SV || /* "our" declaration */
1713 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1714 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1715 yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
1716 OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
1718 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
1720 PL_in_my_stash = NULL;
1721 apply_attrs(GvSTASH(gv),
1722 (type == OP_RV2SV ? GvSV(gv) :
1723 type == OP_RV2AV ? (SV*)GvAV(gv) :
1724 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1727 o->op_private |= OPpOUR_INTRO;
1730 else if (type != OP_PADSV &&
1733 type != OP_PUSHMARK)
1735 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1737 PL_in_my == KEY_our ? "our" : "my"));
1740 else if (attrs && type != OP_PUSHMARK) {
1744 PL_in_my_stash = NULL;
1746 /* check for C<my Dog $spot> when deciding package */
1747 stash = PAD_COMPNAME_TYPE(o->op_targ);
1749 stash = PL_curstash;
1750 apply_attrs_my(stash, o, attrs, imopsp);
1752 o->op_flags |= OPf_MOD;
1753 o->op_private |= OPpLVAL_INTRO;
1758 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1762 int maybe_scalar = 0;
1764 /* [perl #17376]: this appears to be premature, and results in code such as
1765 C< our(%x); > executing in list mode rather than void mode */
1767 if (o->op_flags & OPf_PARENS)
1777 o = my_kid(o, attrs, &rops);
1779 if (maybe_scalar && o->op_type == OP_PADSV) {
1780 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1781 o->op_private |= OPpLVAL_INTRO;
1784 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1787 PL_in_my_stash = NULL;
1792 Perl_my(pTHX_ OP *o)
1794 return my_attrs(o, NULL);
1798 Perl_sawparens(pTHX_ OP *o)
1800 PERL_UNUSED_CONTEXT;
1802 o->op_flags |= OPf_PARENS;
1807 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1812 if ( (left->op_type == OP_RV2AV ||
1813 left->op_type == OP_RV2HV ||
1814 left->op_type == OP_PADAV ||
1815 left->op_type == OP_PADHV)
1816 && ckWARN(WARN_MISC))
1818 const char * const desc = PL_op_desc[(right->op_type == OP_SUBST ||
1819 right->op_type == OP_TRANS)
1820 ? right->op_type : OP_MATCH];
1821 const char * const sample = ((left->op_type == OP_RV2AV ||
1822 left->op_type == OP_PADAV)
1823 ? "@array" : "%hash");
1824 Perl_warner(aTHX_ packWARN(WARN_MISC),
1825 "Applying %s to %s will act on scalar(%s)",
1826 desc, sample, sample);
1829 if (right->op_type == OP_CONST &&
1830 cSVOPx(right)->op_private & OPpCONST_BARE &&
1831 cSVOPx(right)->op_private & OPpCONST_STRICT)
1833 no_bareword_allowed(right);
1836 ismatchop = right->op_type == OP_MATCH ||
1837 right->op_type == OP_SUBST ||
1838 right->op_type == OP_TRANS;
1839 if (ismatchop && right->op_private & OPpTARGET_MY) {
1841 right->op_private &= ~OPpTARGET_MY;
1843 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1844 right->op_flags |= OPf_STACKED;
1845 if (right->op_type != OP_MATCH &&
1846 ! (right->op_type == OP_TRANS &&
1847 right->op_private & OPpTRANS_IDENTICAL))
1848 left = mod(left, right->op_type);
1849 if (right->op_type == OP_TRANS)
1850 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
1852 o = prepend_elem(right->op_type, scalar(left), right);
1854 return newUNOP(OP_NOT, 0, scalar(o));
1858 return bind_match(type, left,
1859 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
1863 Perl_invert(pTHX_ OP *o)
1867 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
1868 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1872 Perl_scope(pTHX_ OP *o)
1876 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1877 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1878 o->op_type = OP_LEAVE;
1879 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1881 else if (o->op_type == OP_LINESEQ) {
1883 o->op_type = OP_SCOPE;
1884 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1885 kid = ((LISTOP*)o)->op_first;
1886 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
1889 /* The following deals with things like 'do {1 for 1}' */
1890 kid = kid->op_sibling;
1892 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
1897 o = newLISTOP(OP_SCOPE, 0, o, NULL);
1903 Perl_block_start(pTHX_ int full)
1906 const int retval = PL_savestack_ix;
1907 pad_block_start(full);
1909 PL_hints &= ~HINT_BLOCK_SCOPE;
1910 SAVESPTR(PL_compiling.cop_warnings);
1911 if (! specialWARN(PL_compiling.cop_warnings)) {
1912 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1913 SAVEFREESV(PL_compiling.cop_warnings) ;
1915 SAVESPTR(PL_compiling.cop_io);
1916 if (! specialCopIO(PL_compiling.cop_io)) {
1917 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1918 SAVEFREESV(PL_compiling.cop_io) ;
1924 Perl_block_end(pTHX_ I32 floor, OP *seq)
1927 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1928 OP* const retval = scalarseq(seq);
1930 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
1932 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
1941 const I32 offset = pad_findmy("$_");
1942 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
1943 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1946 OP * const o = newOP(OP_PADSV, 0);
1947 o->op_targ = offset;
1953 Perl_newPROG(pTHX_ OP *o)
1959 PL_eval_root = newUNOP(OP_LEAVEEVAL,
1960 ((PL_in_eval & EVAL_KEEPERR)
1961 ? OPf_SPECIAL : 0), o);
1962 PL_eval_start = linklist(PL_eval_root);
1963 PL_eval_root->op_private |= OPpREFCOUNTED;
1964 OpREFCNT_set(PL_eval_root, 1);
1965 PL_eval_root->op_next = 0;
1966 CALL_PEEP(PL_eval_start);
1969 if (o->op_type == OP_STUB) {
1970 PL_comppad_name = 0;
1975 PL_main_root = scope(sawparens(scalarvoid(o)));
1976 PL_curcop = &PL_compiling;
1977 PL_main_start = LINKLIST(PL_main_root);
1978 PL_main_root->op_private |= OPpREFCOUNTED;
1979 OpREFCNT_set(PL_main_root, 1);
1980 PL_main_root->op_next = 0;
1981 CALL_PEEP(PL_main_start);
1984 /* Register with debugger */
1986 CV * const cv = get_cv("DB::postponed", FALSE);
1990 XPUSHs((SV*)CopFILEGV(&PL_compiling));
1992 call_sv((SV*)cv, G_DISCARD);
1999 Perl_localize(pTHX_ OP *o, I32 lex)
2002 if (o->op_flags & OPf_PARENS)
2003 /* [perl #17376]: this appears to be premature, and results in code such as
2004 C< our(%x); > executing in list mode rather than void mode */
2011 if ( PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ','
2012 && ckWARN(WARN_PARENTHESIS))
2014 char *s = PL_bufptr;
2017 /* some heuristics to detect a potential error */
2018 while (*s && (strchr(", \t\n", *s)))
2022 if (*s && strchr("@$%*", *s) && *++s
2023 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2026 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2028 while (*s && (strchr(", \t\n", *s)))
2034 if (sigil && (*s == ';' || *s == '=')) {
2035 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2036 "Parentheses missing around \"%s\" list",
2037 lex ? (PL_in_my == KEY_our ? "our" : "my")
2045 o = mod(o, OP_NULL); /* a bit kludgey */
2047 PL_in_my_stash = NULL;
2052 Perl_jmaybe(pTHX_ OP *o)
2054 if (o->op_type == OP_LIST) {
2056 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL,
2058 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2064 Perl_fold_constants(pTHX_ register OP *o)
2068 I32 type = o->op_type;
2071 if (PL_opargs[type] & OA_RETSCALAR)
2073 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2074 o->op_targ = pad_alloc(type, SVs_PADTMP);
2076 /* integerize op, unless it happens to be C<-foo>.
2077 * XXX should pp_i_negate() do magic string negation instead? */
2078 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2079 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2080 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2082 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2085 if (!(PL_opargs[type] & OA_FOLDCONST))
2090 /* XXX might want a ck_negate() for this */
2091 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2102 /* XXX what about the numeric ops? */
2103 if (PL_hints & HINT_LOCALE)
2108 goto nope; /* Don't try to run w/ errors */
2110 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2111 if ((curop->op_type != OP_CONST ||
2112 (curop->op_private & OPpCONST_BARE)) &&
2113 curop->op_type != OP_LIST &&
2114 curop->op_type != OP_SCALAR &&
2115 curop->op_type != OP_NULL &&
2116 curop->op_type != OP_PUSHMARK)
2122 curop = LINKLIST(o);
2126 sv = *(PL_stack_sp--);
2127 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2128 pad_swipe(o->op_targ, FALSE);
2129 else if (SvTEMP(sv)) { /* grab mortal temp? */
2130 SvREFCNT_inc_simple_void(sv);
2134 if (type == OP_RV2GV)
2135 return newGVOP(OP_GV, 0, (GV*)sv);
2136 return newSVOP(OP_CONST, 0, sv);
2143 Perl_gen_constant_list(pTHX_ register OP *o)
2147 const I32 oldtmps_floor = PL_tmps_floor;
2151 return o; /* Don't attempt to run with errors */
2153 PL_op = curop = LINKLIST(o);
2160 PL_tmps_floor = oldtmps_floor;
2162 o->op_type = OP_RV2AV;
2163 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2164 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2165 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2166 o->op_opt = 0; /* needs to be revisited in peep() */
2167 curop = ((UNOP*)o)->op_first;
2168 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2175 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2178 if (!o || o->op_type != OP_LIST)
2179 o = newLISTOP(OP_LIST, 0, o, NULL);
2181 o->op_flags &= ~OPf_WANT;
2183 if (!(PL_opargs[type] & OA_MARK))
2184 op_null(cLISTOPo->op_first);
2186 o->op_type = (OPCODE)type;
2187 o->op_ppaddr = PL_ppaddr[type];
2188 o->op_flags |= flags;
2190 o = CHECKOP(type, o);
2191 if (o->op_type != (unsigned)type)
2194 return fold_constants(o);
2197 /* List constructors */
2200 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2208 if (first->op_type != (unsigned)type
2209 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2211 return newLISTOP(type, 0, first, last);
2214 if (first->op_flags & OPf_KIDS)
2215 ((LISTOP*)first)->op_last->op_sibling = last;
2217 first->op_flags |= OPf_KIDS;
2218 ((LISTOP*)first)->op_first = last;
2220 ((LISTOP*)first)->op_last = last;
2225 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2233 if (first->op_type != (unsigned)type)
2234 return prepend_elem(type, (OP*)first, (OP*)last);
2236 if (last->op_type != (unsigned)type)
2237 return append_elem(type, (OP*)first, (OP*)last);
2239 first->op_last->op_sibling = last->op_first;
2240 first->op_last = last->op_last;
2241 first->op_flags |= (last->op_flags & OPf_KIDS);
2249 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2257 if (last->op_type == (unsigned)type) {
2258 if (type == OP_LIST) { /* already a PUSHMARK there */
2259 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2260 ((LISTOP*)last)->op_first->op_sibling = first;
2261 if (!(first->op_flags & OPf_PARENS))
2262 last->op_flags &= ~OPf_PARENS;
2265 if (!(last->op_flags & OPf_KIDS)) {
2266 ((LISTOP*)last)->op_last = first;
2267 last->op_flags |= OPf_KIDS;
2269 first->op_sibling = ((LISTOP*)last)->op_first;
2270 ((LISTOP*)last)->op_first = first;
2272 last->op_flags |= OPf_KIDS;
2276 return newLISTOP(type, 0, first, last);
2282 Perl_newNULLLIST(pTHX)
2284 return newOP(OP_STUB, 0);
2288 Perl_force_list(pTHX_ OP *o)
2290 if (!o || o->op_type != OP_LIST)
2291 o = newLISTOP(OP_LIST, 0, o, NULL);
2297 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2302 NewOp(1101, listop, 1, LISTOP);
2304 listop->op_type = (OPCODE)type;
2305 listop->op_ppaddr = PL_ppaddr[type];
2308 listop->op_flags = (U8)flags;
2312 else if (!first && last)
2315 first->op_sibling = last;
2316 listop->op_first = first;
2317 listop->op_last = last;
2318 if (type == OP_LIST) {
2319 OP* const pushop = newOP(OP_PUSHMARK, 0);
2320 pushop->op_sibling = first;
2321 listop->op_first = pushop;
2322 listop->op_flags |= OPf_KIDS;
2324 listop->op_last = pushop;
2327 return CHECKOP(type, listop);
2331 Perl_newOP(pTHX_ I32 type, I32 flags)
2335 NewOp(1101, o, 1, OP);
2336 o->op_type = (OPCODE)type;
2337 o->op_ppaddr = PL_ppaddr[type];
2338 o->op_flags = (U8)flags;
2341 o->op_private = (U8)(0 | (flags >> 8));
2342 if (PL_opargs[type] & OA_RETSCALAR)
2344 if (PL_opargs[type] & OA_TARGET)
2345 o->op_targ = pad_alloc(type, SVs_PADTMP);
2346 return CHECKOP(type, o);
2350 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2356 first = newOP(OP_STUB, 0);
2357 if (PL_opargs[type] & OA_MARK)
2358 first = force_list(first);
2360 NewOp(1101, unop, 1, UNOP);
2361 unop->op_type = (OPCODE)type;
2362 unop->op_ppaddr = PL_ppaddr[type];
2363 unop->op_first = first;
2364 unop->op_flags = (U8)(flags | OPf_KIDS);
2365 unop->op_private = (U8)(1 | (flags >> 8));
2366 unop = (UNOP*) CHECKOP(type, unop);
2370 return fold_constants((OP *) unop);
2374 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2378 NewOp(1101, binop, 1, BINOP);
2381 first = newOP(OP_NULL, 0);
2383 binop->op_type = (OPCODE)type;
2384 binop->op_ppaddr = PL_ppaddr[type];
2385 binop->op_first = first;
2386 binop->op_flags = (U8)(flags | OPf_KIDS);
2389 binop->op_private = (U8)(1 | (flags >> 8));
2392 binop->op_private = (U8)(2 | (flags >> 8));
2393 first->op_sibling = last;
2396 binop = (BINOP*)CHECKOP(type, binop);
2397 if (binop->op_next || binop->op_type != (OPCODE)type)
2400 binop->op_last = binop->op_first->op_sibling;
2402 return fold_constants((OP *)binop);
2405 static int uvcompare(const void *a, const void *b)
2406 __attribute__nonnull__(1)
2407 __attribute__nonnull__(2)
2408 __attribute__pure__;
2409 static int uvcompare(const void *a, const void *b)
2411 if (*((const UV *)a) < (*(const UV *)b))
2413 if (*((const UV *)a) > (*(const UV *)b))
2415 if (*((const UV *)a+1) < (*(const UV *)b+1))
2417 if (*((const UV *)a+1) > (*(const UV *)b+1))
2423 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2426 SV * const tstr = ((SVOP*)expr)->op_sv;
2427 SV * const rstr = ((SVOP*)repl)->op_sv;
2430 const U8 *t = (U8*)SvPV_const(tstr, tlen);
2431 const U8 *r = (U8*)SvPV_const(rstr, rlen);
2435 register short *tbl;
2437 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
2438 const I32 squash = o->op_private & OPpTRANS_SQUASH;
2439 I32 del = o->op_private & OPpTRANS_DELETE;
2440 PL_hints |= HINT_BLOCK_SCOPE;
2443 o->op_private |= OPpTRANS_FROM_UTF;
2446 o->op_private |= OPpTRANS_TO_UTF;
2448 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2449 SV* const listsv = newSVpvs("# comment\n");
2451 const U8* tend = t + tlen;
2452 const U8* rend = r + rlen;
2466 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2467 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2473 t = tsave = bytes_to_utf8(t, &len);
2476 if (!to_utf && rlen) {
2478 r = rsave = bytes_to_utf8(r, &len);
2482 /* There are several snags with this code on EBCDIC:
2483 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2484 2. scan_const() in toke.c has encoded chars in native encoding which makes
2485 ranges at least in EBCDIC 0..255 range the bottom odd.
2489 U8 tmpbuf[UTF8_MAXBYTES+1];
2492 Newx(cp, 2*tlen, UV);
2494 transv = newSVpvs("");
2496 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2498 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2500 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2504 cp[2*i+1] = cp[2*i];
2508 qsort(cp, i, 2*sizeof(UV), uvcompare);
2509 for (j = 0; j < i; j++) {
2511 diff = val - nextmin;
2513 t = uvuni_to_utf8(tmpbuf,nextmin);
2514 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2516 U8 range_mark = UTF_TO_NATIVE(0xff);
2517 t = uvuni_to_utf8(tmpbuf, val - 1);
2518 sv_catpvn(transv, (char *)&range_mark, 1);
2519 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2526 t = uvuni_to_utf8(tmpbuf,nextmin);
2527 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2529 U8 range_mark = UTF_TO_NATIVE(0xff);
2530 sv_catpvn(transv, (char *)&range_mark, 1);
2532 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2533 UNICODE_ALLOW_SUPER);
2534 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2535 t = (const U8*)SvPVX_const(transv);
2536 tlen = SvCUR(transv);
2540 else if (!rlen && !del) {
2541 r = t; rlen = tlen; rend = tend;
2544 if ((!rlen && !del) || t == r ||
2545 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2547 o->op_private |= OPpTRANS_IDENTICAL;
2551 while (t < tend || tfirst <= tlast) {
2552 /* see if we need more "t" chars */
2553 if (tfirst > tlast) {
2554 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2556 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2558 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2565 /* now see if we need more "r" chars */
2566 if (rfirst > rlast) {
2568 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2570 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2572 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2581 rfirst = rlast = 0xffffffff;
2585 /* now see which range will peter our first, if either. */
2586 tdiff = tlast - tfirst;
2587 rdiff = rlast - rfirst;
2594 if (rfirst == 0xffffffff) {
2595 diff = tdiff; /* oops, pretend rdiff is infinite */
2597 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2598 (long)tfirst, (long)tlast);
2600 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2604 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2605 (long)tfirst, (long)(tfirst + diff),
2608 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2609 (long)tfirst, (long)rfirst);
2611 if (rfirst + diff > max)
2612 max = rfirst + diff;
2614 grows = (tfirst < rfirst &&
2615 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2627 else if (max > 0xff)
2632 Safefree(cPVOPo->op_pv);
2633 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2634 SvREFCNT_dec(listsv);
2635 SvREFCNT_dec(transv);
2637 if (!del && havefinal && rlen)
2638 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2639 newSVuv((UV)final), 0);
2642 o->op_private |= OPpTRANS_GROWS;
2652 tbl = (short*)cPVOPo->op_pv;
2654 Zero(tbl, 256, short);
2655 for (i = 0; i < (I32)tlen; i++)
2657 for (i = 0, j = 0; i < 256; i++) {
2659 if (j >= (I32)rlen) {
2668 if (i < 128 && r[j] >= 128)
2678 o->op_private |= OPpTRANS_IDENTICAL;
2680 else if (j >= (I32)rlen)
2683 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2684 tbl[0x100] = (short)(rlen - j);
2685 for (i=0; i < (I32)rlen - j; i++)
2686 tbl[0x101+i] = r[j+i];
2690 if (!rlen && !del) {
2693 o->op_private |= OPpTRANS_IDENTICAL;
2695 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2696 o->op_private |= OPpTRANS_IDENTICAL;
2698 for (i = 0; i < 256; i++)
2700 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
2701 if (j >= (I32)rlen) {
2703 if (tbl[t[i]] == -1)
2709 if (tbl[t[i]] == -1) {
2710 if (t[i] < 128 && r[j] >= 128)
2717 o->op_private |= OPpTRANS_GROWS;
2725 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2730 NewOp(1101, pmop, 1, PMOP);
2731 pmop->op_type = (OPCODE)type;
2732 pmop->op_ppaddr = PL_ppaddr[type];
2733 pmop->op_flags = (U8)flags;
2734 pmop->op_private = (U8)(0 | (flags >> 8));
2736 if (PL_hints & HINT_RE_TAINT)
2737 pmop->op_pmpermflags |= PMf_RETAINT;
2738 if (PL_hints & HINT_LOCALE)
2739 pmop->op_pmpermflags |= PMf_LOCALE;
2740 pmop->op_pmflags = pmop->op_pmpermflags;
2743 if (av_len((AV*) PL_regex_pad[0]) > -1) {
2744 SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
2745 pmop->op_pmoffset = SvIV(repointer);
2746 SvREPADTMP_off(repointer);
2747 sv_setiv(repointer,0);
2749 SV * const repointer = newSViv(0);
2750 av_push(PL_regex_padav, SvREFCNT_inc_simple_NN(repointer));
2751 pmop->op_pmoffset = av_len(PL_regex_padav);
2752 PL_regex_pad = AvARRAY(PL_regex_padav);
2756 /* link into pm list */
2757 if (type != OP_TRANS && PL_curstash) {
2758 MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab);
2761 mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0);
2763 pmop->op_pmnext = (PMOP*)mg->mg_obj;
2764 mg->mg_obj = (SV*)pmop;
2765 PmopSTASH_set(pmop,PL_curstash);
2768 return CHECKOP(type, pmop);
2771 /* Given some sort of match op o, and an expression expr containing a
2772 * pattern, either compile expr into a regex and attach it to o (if it's
2773 * constant), or convert expr into a runtime regcomp op sequence (if it's
2776 * isreg indicates that the pattern is part of a regex construct, eg
2777 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
2778 * split "pattern", which aren't. In the former case, expr will be a list
2779 * if the pattern contains more than one term (eg /a$b/) or if it contains
2780 * a replacement, ie s/// or tr///.
2784 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
2789 I32 repl_has_vars = 0;
2793 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
2794 /* last element in list is the replacement; pop it */
2796 repl = cLISTOPx(expr)->op_last;
2797 kid = cLISTOPx(expr)->op_first;
2798 while (kid->op_sibling != repl)
2799 kid = kid->op_sibling;
2800 kid->op_sibling = NULL;
2801 cLISTOPx(expr)->op_last = kid;
2804 if (isreg && expr->op_type == OP_LIST &&
2805 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
2807 /* convert single element list to element */
2808 OP* const oe = expr;
2809 expr = cLISTOPx(oe)->op_first->op_sibling;
2810 cLISTOPx(oe)->op_first->op_sibling = NULL;
2811 cLISTOPx(oe)->op_last = NULL;
2815 if (o->op_type == OP_TRANS) {
2816 return pmtrans(o, expr, repl);
2819 reglist = isreg && expr->op_type == OP_LIST;
2823 PL_hints |= HINT_BLOCK_SCOPE;
2826 if (expr->op_type == OP_CONST) {
2828 SV * const pat = ((SVOP*)expr)->op_sv;
2829 const char *p = SvPV_const(pat, plen);
2830 if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
2831 U32 was_readonly = SvREADONLY(pat);
2835 sv_force_normal_flags(pat, 0);
2836 assert(!SvREADONLY(pat));
2839 SvREADONLY_off(pat);
2843 sv_setpvn(pat, "\\s+", 3);
2845 SvFLAGS(pat) |= was_readonly;
2847 p = SvPV_const(pat, plen);
2848 pm->op_pmflags |= PMf_SKIPWHITE;
2851 pm->op_pmdynflags |= PMdf_UTF8;
2852 /* FIXME - can we make this function take const char * args? */
2853 PM_SETRE(pm, CALLREGCOMP(aTHX_ (char*)p, (char*)p + plen, pm));
2854 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
2855 pm->op_pmflags |= PMf_WHITE;
2859 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2860 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2862 : OP_REGCMAYBE),0,expr);
2864 NewOp(1101, rcop, 1, LOGOP);
2865 rcop->op_type = OP_REGCOMP;
2866 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2867 rcop->op_first = scalar(expr);
2868 rcop->op_flags |= OPf_KIDS
2869 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
2870 | (reglist ? OPf_STACKED : 0);
2871 rcop->op_private = 1;
2874 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
2876 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
2879 /* establish postfix order */
2880 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2882 rcop->op_next = expr;
2883 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2886 rcop->op_next = LINKLIST(expr);
2887 expr->op_next = (OP*)rcop;
2890 prepend_elem(o->op_type, scalar((OP*)rcop), o);
2895 if (pm->op_pmflags & PMf_EVAL) {
2897 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
2898 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
2900 else if (repl->op_type == OP_CONST)
2904 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
2905 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
2906 if (curop->op_type == OP_GV) {
2907 GV * const gv = cGVOPx_gv(curop);
2909 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
2912 else if (curop->op_type == OP_RV2CV)
2914 else if (curop->op_type == OP_RV2SV ||
2915 curop->op_type == OP_RV2AV ||
2916 curop->op_type == OP_RV2HV ||
2917 curop->op_type == OP_RV2GV) {
2918 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2921 else if (curop->op_type == OP_PADSV ||
2922 curop->op_type == OP_PADAV ||
2923 curop->op_type == OP_PADHV ||
2924 curop->op_type == OP_PADANY) {
2927 else if (curop->op_type == OP_PUSHRE)
2928 /*EMPTY*/; /* Okay here, dangerous in newASSIGNOP */
2938 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
2939 pm->op_pmflags |= PMf_CONST; /* const for long enough */
2940 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
2941 prepend_elem(o->op_type, scalar(repl), o);
2944 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
2945 pm->op_pmflags |= PMf_MAYBE_CONST;
2946 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2948 NewOp(1101, rcop, 1, LOGOP);
2949 rcop->op_type = OP_SUBSTCONT;
2950 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
2951 rcop->op_first = scalar(repl);
2952 rcop->op_flags |= OPf_KIDS;
2953 rcop->op_private = 1;
2956 /* establish postfix order */
2957 rcop->op_next = LINKLIST(repl);
2958 repl->op_next = (OP*)rcop;
2960 pm->op_pmreplroot = scalar((OP*)rcop);
2961 pm->op_pmreplstart = LINKLIST(rcop);
2970 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
2974 NewOp(1101, svop, 1, SVOP);
2975 svop->op_type = (OPCODE)type;
2976 svop->op_ppaddr = PL_ppaddr[type];
2978 svop->op_next = (OP*)svop;
2979 svop->op_flags = (U8)flags;
2980 if (PL_opargs[type] & OA_RETSCALAR)
2982 if (PL_opargs[type] & OA_TARGET)
2983 svop->op_targ = pad_alloc(type, SVs_PADTMP);
2984 return CHECKOP(type, svop);
2988 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2992 NewOp(1101, padop, 1, PADOP);
2993 padop->op_type = (OPCODE)type;
2994 padop->op_ppaddr = PL_ppaddr[type];
2995 padop->op_padix = pad_alloc(type, SVs_PADTMP);
2996 SvREFCNT_dec(PAD_SVl(padop->op_padix));
2997 PAD_SETSV(padop->op_padix, sv);
3000 padop->op_next = (OP*)padop;
3001 padop->op_flags = (U8)flags;
3002 if (PL_opargs[type] & OA_RETSCALAR)
3004 if (PL_opargs[type] & OA_TARGET)
3005 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3006 return CHECKOP(type, padop);
3010 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3016 return newPADOP(type, flags, SvREFCNT_inc_simple(gv));
3018 return newSVOP(type, flags, SvREFCNT_inc_simple(gv));
3023 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3027 NewOp(1101, pvop, 1, PVOP);
3028 pvop->op_type = (OPCODE)type;
3029 pvop->op_ppaddr = PL_ppaddr[type];
3031 pvop->op_next = (OP*)pvop;
3032 pvop->op_flags = (U8)flags;
3033 if (PL_opargs[type] & OA_RETSCALAR)
3035 if (PL_opargs[type] & OA_TARGET)
3036 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3037 return CHECKOP(type, pvop);
3041 Perl_package(pTHX_ OP *o)
3047 save_hptr(&PL_curstash);
3048 save_item(PL_curstname);
3050 name = SvPV_const(cSVOPo->op_sv, len);
3051 PL_curstash = gv_stashpvn(name, len, TRUE);
3052 sv_setpvn(PL_curstname, name, len);
3055 PL_hints |= HINT_BLOCK_SCOPE;
3056 PL_copline = NOLINE;
3061 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3068 if (idop->op_type != OP_CONST)
3069 Perl_croak(aTHX_ "Module name must be constant");
3074 SV * const vesv = ((SVOP*)version)->op_sv;
3076 if (!arg && !SvNIOKp(vesv)) {
3083 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3084 Perl_croak(aTHX_ "Version number must be constant number");
3086 /* Make copy of idop so we don't free it twice */
3087 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3089 /* Fake up a method call to VERSION */
3090 meth = newSVpvs_share("VERSION");
3091 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3092 append_elem(OP_LIST,
3093 prepend_elem(OP_LIST, pack, list(version)),
3094 newSVOP(OP_METHOD_NAMED, 0, meth)));
3098 /* Fake up an import/unimport */
3099 if (arg && arg->op_type == OP_STUB)
3100 imop = arg; /* no import on explicit () */
3101 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3102 imop = NULL; /* use 5.0; */
3104 idop->op_private |= OPpCONST_NOVER;
3109 /* Make copy of idop so we don't free it twice */
3110 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3112 /* Fake up a method call to import/unimport */
3114 ? newSVpvs_share("import") : newSVpvs_share("unimport");
3115 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3116 append_elem(OP_LIST,
3117 prepend_elem(OP_LIST, pack, list(arg)),
3118 newSVOP(OP_METHOD_NAMED, 0, meth)));
3121 /* Fake up the BEGIN {}, which does its thing immediately. */
3123 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3126 append_elem(OP_LINESEQ,
3127 append_elem(OP_LINESEQ,
3128 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3129 newSTATEOP(0, NULL, veop)),
3130 newSTATEOP(0, NULL, imop) ));
3132 /* The "did you use incorrect case?" warning used to be here.
3133 * The problem is that on case-insensitive filesystems one
3134 * might get false positives for "use" (and "require"):
3135 * "use Strict" or "require CARP" will work. This causes
3136 * portability problems for the script: in case-strict
3137 * filesystems the script will stop working.
3139 * The "incorrect case" warning checked whether "use Foo"
3140 * imported "Foo" to your namespace, but that is wrong, too:
3141 * there is no requirement nor promise in the language that
3142 * a Foo.pm should or would contain anything in package "Foo".
3144 * There is very little Configure-wise that can be done, either:
3145 * the case-sensitivity of the build filesystem of Perl does not
3146 * help in guessing the case-sensitivity of the runtime environment.
3149 PL_hints |= HINT_BLOCK_SCOPE;
3150 PL_copline = NOLINE;
3152 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3156 =head1 Embedding Functions
3158 =for apidoc load_module
3160 Loads the module whose name is pointed to by the string part of name.
3161 Note that the actual module name, not its filename, should be given.
3162 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3163 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3164 (or 0 for no flags). ver, if specified, provides version semantics
3165 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3166 arguments can be used to specify arguments to the module's import()
3167 method, similar to C<use Foo::Bar VERSION LIST>.
3172 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3175 va_start(args, ver);
3176 vload_module(flags, name, ver, &args);
3180 #ifdef PERL_IMPLICIT_CONTEXT
3182 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3186 va_start(args, ver);
3187 vload_module(flags, name, ver, &args);
3193 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3198 OP * const modname = newSVOP(OP_CONST, 0, name);
3199 modname->op_private |= OPpCONST_BARE;
3201 veop = newSVOP(OP_CONST, 0, ver);
3205 if (flags & PERL_LOADMOD_NOIMPORT) {
3206 imop = sawparens(newNULLLIST());
3208 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3209 imop = va_arg(*args, OP*);
3214 sv = va_arg(*args, SV*);
3216 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3217 sv = va_arg(*args, SV*);
3221 const line_t ocopline = PL_copline;
3222 COP * const ocurcop = PL_curcop;
3223 const int oexpect = PL_expect;
3225 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3226 veop, modname, imop);
3227 PL_expect = oexpect;
3228 PL_copline = ocopline;
3229 PL_curcop = ocurcop;
3234 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
3240 if (!force_builtin) {
3241 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
3242 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
3243 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
3244 gv = gvp ? *gvp : NULL;
3248 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3249 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3250 append_elem(OP_LIST, term,
3251 scalar(newUNOP(OP_RV2CV, 0,
3256 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3262 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3264 return newBINOP(OP_LSLICE, flags,
3265 list(force_list(subscript)),
3266 list(force_list(listval)) );
3270 S_is_list_assignment(pTHX_ register const OP *o)
3275 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3276 o = cUNOPo->op_first;
3278 if (o->op_type == OP_COND_EXPR) {
3279 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3280 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3285 yyerror("Assignment to both a list and a scalar");
3289 if (o->op_type == OP_LIST &&
3290 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3291 o->op_private & OPpLVAL_INTRO)
3294 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3295 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3296 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3299 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3302 if (o->op_type == OP_RV2SV)
3309 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3315 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3316 return newLOGOP(optype, 0,
3317 mod(scalar(left), optype),
3318 newUNOP(OP_SASSIGN, 0, scalar(right)));
3321 return newBINOP(optype, OPf_STACKED,
3322 mod(scalar(left), optype), scalar(right));
3326 if (is_list_assignment(left)) {
3330 /* Grandfathering $[ assignment here. Bletch.*/
3331 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
3332 PL_eval_start = (left->op_type == OP_CONST) ? right : 0;
3333 left = mod(left, OP_AASSIGN);
3336 else if (left->op_type == OP_CONST) {
3337 /* Result of assignment is always 1 (or we'd be dead already) */
3338 return newSVOP(OP_CONST, 0, newSViv(1));
3340 curop = list(force_list(left));
3341 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3342 o->op_private = (U8)(0 | (flags >> 8));
3344 /* PL_generation sorcery:
3345 * an assignment like ($a,$b) = ($c,$d) is easier than
3346 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3347 * To detect whether there are common vars, the global var
3348 * PL_generation is incremented for each assign op we compile.
3349 * Then, while compiling the assign op, we run through all the
3350 * variables on both sides of the assignment, setting a spare slot
3351 * in each of them to PL_generation. If any of them already have
3352 * that value, we know we've got commonality. We could use a
3353 * single bit marker, but then we'd have to make 2 passes, first
3354 * to clear the flag, then to test and set it. To find somewhere
3355 * to store these values, evil chicanery is done with SvCUR().
3358 if (!(left->op_private & OPpLVAL_INTRO)) {
3361 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3362 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3363 if (curop->op_type == OP_GV) {
3364 GV *gv = cGVOPx_gv(curop);
3366 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
3368 GvASSIGN_GENERATION_set(gv, PL_generation);
3370 else if (curop->op_type == OP_PADSV ||
3371 curop->op_type == OP_PADAV ||
3372 curop->op_type == OP_PADHV ||
3373 curop->op_type == OP_PADANY)
3375 if (PAD_COMPNAME_GEN(curop->op_targ)
3376 == (STRLEN)PL_generation)
3378 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
3381 else if (curop->op_type == OP_RV2CV)
3383 else if (curop->op_type == OP_RV2SV ||
3384 curop->op_type == OP_RV2AV ||
3385 curop->op_type == OP_RV2HV ||
3386 curop->op_type == OP_RV2GV) {
3387 if (lastop->op_type != OP_GV) /* funny deref? */
3390 else if (curop->op_type == OP_PUSHRE) {
3391 if (((PMOP*)curop)->op_pmreplroot) {
3393 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3394 ((PMOP*)curop)->op_pmreplroot));
3396 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3399 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
3401 GvASSIGN_GENERATION_set(gv, PL_generation);
3402 GvASSIGN_GENERATION_set(gv, PL_generation);
3411 o->op_private |= OPpASSIGN_COMMON;
3413 if (right && right->op_type == OP_SPLIT) {
3415 if ((tmpop = ((LISTOP*)right)->op_first) &&
3416 tmpop->op_type == OP_PUSHRE)
3418 PMOP * const pm = (PMOP*)tmpop;
3419 if (left->op_type == OP_RV2AV &&
3420 !(left->op_private & OPpLVAL_INTRO) &&
3421 !(o->op_private & OPpASSIGN_COMMON) )
3423 tmpop = ((UNOP*)left)->op_first;
3424 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3426 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3427 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3429 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3430 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
3432 pm->op_pmflags |= PMf_ONCE;
3433 tmpop = cUNOPo->op_first; /* to list (nulled) */
3434 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3435 tmpop->op_sibling = NULL; /* don't free split */
3436 right->op_next = tmpop->op_next; /* fix starting loc */
3437 op_free(o); /* blow off assign */
3438 right->op_flags &= ~OPf_WANT;
3439 /* "I don't know and I don't care." */
3444 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3445 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3447 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3449 sv_setiv(sv, PL_modcount+1);
3457 right = newOP(OP_UNDEF, 0);
3458 if (right->op_type == OP_READLINE) {
3459 right->op_flags |= OPf_STACKED;
3460 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3463 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3464 o = newBINOP(OP_SASSIGN, flags,
3465 scalar(right), mod(scalar(left), OP_SASSIGN) );
3469 o = newSVOP(OP_CONST, 0, newSViv(PL_compiling.cop_arybase));
3476 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3479 const U32 seq = intro_my();
3482 NewOp(1101, cop, 1, COP);
3483 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3484 cop->op_type = OP_DBSTATE;
3485 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3488 cop->op_type = OP_NEXTSTATE;
3489 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3491 cop->op_flags = (U8)flags;
3492 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3494 cop->op_private |= NATIVE_HINTS;
3496 PL_compiling.op_private = cop->op_private;
3497 cop->op_next = (OP*)cop;
3500 cop->cop_label = label;
3501 PL_hints |= HINT_BLOCK_SCOPE;
3504 cop->cop_arybase = PL_curcop->cop_arybase;
3505 if (specialWARN(PL_curcop->cop_warnings))
3506 cop->cop_warnings = PL_curcop->cop_warnings ;
3508 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3509 if (specialCopIO(PL_curcop->cop_io))
3510 cop->cop_io = PL_curcop->cop_io;
3512 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3515 if (PL_copline == NOLINE)
3516 CopLINE_set(cop, CopLINE(PL_curcop));
3518 CopLINE_set(cop, PL_copline);
3519 PL_copline = NOLINE;
3522 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3524 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3526 CopSTASH_set(cop, PL_curstash);
3528 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3529 SV * const * const svp = av_fetch(CopFILEAVx(PL_curcop), (I32)CopLINE(cop), FALSE);
3530 if (svp && *svp != &PL_sv_undef ) {
3531 (void)SvIOK_on(*svp);
3532 SvIV_set(*svp, PTR2IV(cop));
3536 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3541 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3544 return new_logop(type, flags, &first, &other);
3548 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3553 OP *first = *firstp;
3554 OP * const other = *otherp;
3556 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3557 return newBINOP(type, flags, scalar(first), scalar(other));
3559 scalarboolean(first);
3560 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3561 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3562 if (type == OP_AND || type == OP_OR) {
3568 first = *firstp = cUNOPo->op_first;
3570 first->op_next = o->op_next;
3571 cUNOPo->op_first = NULL;
3575 if (first->op_type == OP_CONST) {
3576 if (first->op_private & OPpCONST_STRICT)
3577 no_bareword_allowed(first);
3578 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
3579 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3580 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
3581 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
3582 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
3585 if (other->op_type == OP_CONST)
3586 other->op_private |= OPpCONST_SHORTCIRCUIT;
3590 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
3591 const OP *o2 = other;
3592 if ( ! (o2->op_type == OP_LIST
3593 && (( o2 = cUNOPx(o2)->op_first))
3594 && o2->op_type == OP_PUSHMARK
3595 && (( o2 = o2->op_sibling)) )
3598 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
3599 || o2->op_type == OP_PADHV)
3600 && o2->op_private & OPpLVAL_INTRO
3601 && ckWARN(WARN_DEPRECATED))
3603 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
3604 "Deprecated use of my() in false conditional");
3609 if (first->op_type == OP_CONST)
3610 first->op_private |= OPpCONST_SHORTCIRCUIT;
3614 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
3615 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
3617 const OP * const k1 = ((UNOP*)first)->op_first;
3618 const OP * const k2 = k1->op_sibling;
3620 switch (first->op_type)
3623 if (k2 && k2->op_type == OP_READLINE
3624 && (k2->op_flags & OPf_STACKED)
3625 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3627 warnop = k2->op_type;
3632 if (k1->op_type == OP_READDIR
3633 || k1->op_type == OP_GLOB
3634 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3635 || k1->op_type == OP_EACH)
3637 warnop = ((k1->op_type == OP_NULL)
3638 ? (OPCODE)k1->op_targ : k1->op_type);
3643 const line_t oldline = CopLINE(PL_curcop);
3644 CopLINE_set(PL_curcop, PL_copline);
3645 Perl_warner(aTHX_ packWARN(WARN_MISC),
3646 "Value of %s%s can be \"0\"; test with defined()",
3648 ((warnop == OP_READLINE || warnop == OP_GLOB)
3649 ? " construct" : "() operator"));
3650 CopLINE_set(PL_curcop, oldline);
3657 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3658 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3660 NewOp(1101, logop, 1, LOGOP);
3662 logop->op_type = (OPCODE)type;
3663 logop->op_ppaddr = PL_ppaddr[type];
3664 logop->op_first = first;
3665 logop->op_flags = (U8)(flags | OPf_KIDS);
3666 logop->op_other = LINKLIST(other);
3667 logop->op_private = (U8)(1 | (flags >> 8));
3669 /* establish postfix order */
3670 logop->op_next = LINKLIST(first);
3671 first->op_next = (OP*)logop;
3672 first->op_sibling = other;
3674 CHECKOP(type,logop);
3676 o = newUNOP(OP_NULL, 0, (OP*)logop);
3683 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3691 return newLOGOP(OP_AND, 0, first, trueop);
3693 return newLOGOP(OP_OR, 0, first, falseop);
3695 scalarboolean(first);
3696 if (first->op_type == OP_CONST) {
3697 if (first->op_private & OPpCONST_BARE &&
3698 first->op_private & OPpCONST_STRICT) {
3699 no_bareword_allowed(first);
3701 if (SvTRUE(((SVOP*)first)->op_sv)) {
3712 NewOp(1101, logop, 1, LOGOP);
3713 logop->op_type = OP_COND_EXPR;
3714 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3715 logop->op_first = first;
3716 logop->op_flags = (U8)(flags | OPf_KIDS);
3717 logop->op_private = (U8)(1 | (flags >> 8));
3718 logop->op_other = LINKLIST(trueop);
3719 logop->op_next = LINKLIST(falseop);
3721 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
3724 /* establish postfix order */
3725 start = LINKLIST(first);
3726 first->op_next = (OP*)logop;
3728 first->op_sibling = trueop;
3729 trueop->op_sibling = falseop;
3730 o = newUNOP(OP_NULL, 0, (OP*)logop);
3732 trueop->op_next = falseop->op_next = o;
3739 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3748 NewOp(1101, range, 1, LOGOP);
3750 range->op_type = OP_RANGE;
3751 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3752 range->op_first = left;
3753 range->op_flags = OPf_KIDS;
3754 leftstart = LINKLIST(left);
3755 range->op_other = LINKLIST(right);
3756 range->op_private = (U8)(1 | (flags >> 8));
3758 left->op_sibling = right;
3760 range->op_next = (OP*)range;
3761 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3762 flop = newUNOP(OP_FLOP, 0, flip);
3763 o = newUNOP(OP_NULL, 0, flop);
3765 range->op_next = leftstart;
3767 left->op_next = flip;
3768 right->op_next = flop;
3770 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3771 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3772 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3773 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3775 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3776 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3779 if (!flip->op_private || !flop->op_private)
3780 linklist(o); /* blow off optimizer unless constant */
3786 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3791 const bool once = block && block->op_flags & OPf_SPECIAL &&
3792 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3794 PERL_UNUSED_ARG(debuggable);
3797 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3798 return block; /* do {} while 0 does once */
3799 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3800 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3801 expr = newUNOP(OP_DEFINED, 0,
3802 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3803 } else if (expr->op_flags & OPf_KIDS) {
3804 const OP * const k1 = ((UNOP*)expr)->op_first;
3805 const OP * const k2 = k1 ? k1->op_sibling : NULL;
3806 switch (expr->op_type) {
3808 if (k2 && k2->op_type == OP_READLINE
3809 && (k2->op_flags & OPf_STACKED)
3810 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3811 expr = newUNOP(OP_DEFINED, 0, expr);
3815 if (k1->op_type == OP_READDIR
3816 || k1->op_type == OP_GLOB
3817 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3818 || k1->op_type == OP_EACH)
3819 expr = newUNOP(OP_DEFINED, 0, expr);
3825 /* if block is null, the next append_elem() would put UNSTACK, a scalar
3826 * op, in listop. This is wrong. [perl #27024] */
3828 block = newOP(OP_NULL, 0);
3829 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3830 o = new_logop(OP_AND, 0, &expr, &listop);
3833 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3835 if (once && o != listop)
3836 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3839 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3841 o->op_flags |= flags;
3843 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3848 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
3849 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
3858 PERL_UNUSED_ARG(debuggable);
3861 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3862 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3863 expr = newUNOP(OP_DEFINED, 0,
3864 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3865 } else if (expr->op_flags & OPf_KIDS) {
3866 const OP * const k1 = ((UNOP*)expr)->op_first;
3867 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
3868 switch (expr->op_type) {
3870 if (k2 && k2->op_type == OP_READLINE
3871 && (k2->op_flags & OPf_STACKED)
3872 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3873 expr = newUNOP(OP_DEFINED, 0, expr);
3877 if (k1->op_type == OP_READDIR
3878 || k1->op_type == OP_GLOB
3879 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3880 || k1->op_type == OP_EACH)
3881 expr = newUNOP(OP_DEFINED, 0, expr);
3888 block = newOP(OP_NULL, 0);
3889 else if (cont || has_my) {
3890 block = scope(block);
3894 next = LINKLIST(cont);
3897 OP * const unstack = newOP(OP_UNSTACK, 0);
3900 cont = append_elem(OP_LINESEQ, cont, unstack);
3903 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3904 redo = LINKLIST(listop);
3907 PL_copline = (line_t)whileline;
3909 o = new_logop(OP_AND, 0, &expr, &listop);
3910 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3911 op_free(expr); /* oops, it's a while (0) */
3913 return NULL; /* listop already freed by new_logop */
3916 ((LISTOP*)listop)->op_last->op_next =
3917 (o == listop ? redo : LINKLIST(o));
3923 NewOp(1101,loop,1,LOOP);
3924 loop->op_type = OP_ENTERLOOP;
3925 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3926 loop->op_private = 0;
3927 loop->op_next = (OP*)loop;
3930 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3932 loop->op_redoop = redo;
3933 loop->op_lastop = o;
3934 o->op_private |= loopflags;
3937 loop->op_nextop = next;
3939 loop->op_nextop = o;
3941 o->op_flags |= flags;
3942 o->op_private |= (flags >> 8);
3947 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
3952 PADOFFSET padoff = 0;
3957 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
3958 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
3959 sv->op_type = OP_RV2GV;
3960 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3961 if (cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
3962 iterpflags |= OPpITER_DEF;
3964 else if (sv->op_type == OP_PADSV) { /* private variable */
3965 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
3966 padoff = sv->op_targ;
3971 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3972 padoff = sv->op_targ;
3974 iterflags |= OPf_SPECIAL;
3979 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3980 if (padoff && strEQ(PAD_COMPNAME_PV(padoff), "$_"))
3981 iterpflags |= OPpITER_DEF;
3984 const I32 offset = pad_findmy("$_");
3985 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
3986 sv = newGVOP(OP_GV, 0, PL_defgv);
3991 iterpflags |= OPpITER_DEF;
3993 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3994 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3995 iterflags |= OPf_STACKED;
3997 else if (expr->op_type == OP_NULL &&
3998 (expr->op_flags & OPf_KIDS) &&
3999 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4001 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4002 * set the STACKED flag to indicate that these values are to be
4003 * treated as min/max values by 'pp_iterinit'.
4005 UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4006 LOGOP* const range = (LOGOP*) flip->op_first;
4007 OP* const left = range->op_first;
4008 OP* const right = left->op_sibling;
4011 range->op_flags &= ~OPf_KIDS;
4012 range->op_first = NULL;
4014 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4015 listop->op_first->op_next = range->op_next;
4016 left->op_next = range->op_other;
4017 right->op_next = (OP*)listop;
4018 listop->op_next = listop->op_first;
4021 expr = (OP*)(listop);
4023 iterflags |= OPf_STACKED;
4026 expr = mod(force_list(expr), OP_GREPSTART);
4029 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4030 append_elem(OP_LIST, expr, scalar(sv))));
4031 assert(!loop->op_next);
4032 /* for my $x () sets OPpLVAL_INTRO;
4033 * for our $x () sets OPpOUR_INTRO */
4034 loop->op_private = (U8)iterpflags;
4035 #ifdef PL_OP_SLAB_ALLOC
4038 NewOp(1234,tmp,1,LOOP);
4039 Copy(loop,tmp,1,LISTOP);
4044 Renew(loop, 1, LOOP);
4046 loop->op_targ = padoff;
4047 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4048 PL_copline = forline;
4049 return newSTATEOP(0, label, wop);
4053 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4058 if (type != OP_GOTO || label->op_type == OP_CONST) {
4059 /* "last()" means "last" */
4060 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4061 o = newOP(type, OPf_SPECIAL);
4063 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4064 ? SvPVx_nolen_const(((SVOP*)label)->op_sv)
4070 /* Check whether it's going to be a goto &function */
4071 if (label->op_type == OP_ENTERSUB
4072 && !(label->op_flags & OPf_STACKED))
4073 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4074 o = newUNOP(type, OPf_STACKED, label);
4076 PL_hints |= HINT_BLOCK_SCOPE;
4080 /* if the condition is a literal array or hash
4081 (or @{ ... } etc), make a reference to it.
4084 S_ref_array_or_hash(pTHX_ OP *cond)
4087 && (cond->op_type == OP_RV2AV
4088 || cond->op_type == OP_PADAV
4089 || cond->op_type == OP_RV2HV
4090 || cond->op_type == OP_PADHV))
4092 return newUNOP(OP_REFGEN,
4093 0, mod(cond, OP_REFGEN));
4099 /* These construct the optree fragments representing given()
4102 entergiven and enterwhen are LOGOPs; the op_other pointer
4103 points up to the associated leave op. We need this so we
4104 can put it in the context and make break/continue work.
4105 (Also, of course, pp_enterwhen will jump straight to
4106 op_other if the match fails.)
4111 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
4112 I32 enter_opcode, I32 leave_opcode,
4113 PADOFFSET entertarg)
4119 NewOp(1101, enterop, 1, LOGOP);
4120 enterop->op_type = enter_opcode;
4121 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
4122 enterop->op_flags = (U8) OPf_KIDS;
4123 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
4124 enterop->op_private = 0;
4126 o = newUNOP(leave_opcode, 0, (OP *) enterop);
4129 enterop->op_first = scalar(cond);
4130 cond->op_sibling = block;
4132 o->op_next = LINKLIST(cond);
4133 cond->op_next = (OP *) enterop;
4136 /* This is a default {} block */
4137 enterop->op_first = block;
4138 enterop->op_flags |= OPf_SPECIAL;
4140 o->op_next = (OP *) enterop;
4143 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
4144 entergiven and enterwhen both
4147 enterop->op_next = LINKLIST(block);
4148 block->op_next = enterop->op_other = o;
4153 /* Does this look like a boolean operation? For these purposes
4154 a boolean operation is:
4155 - a subroutine call [*]
4156 - a logical connective
4157 - a comparison operator
4158 - a filetest operator, with the exception of -s -M -A -C
4159 - defined(), exists() or eof()
4160 - /$re/ or $foo =~ /$re/
4162 [*] possibly surprising
4166 S_looks_like_bool(pTHX_ OP *o)
4169 switch(o->op_type) {
4171 return looks_like_bool(cLOGOPo->op_first);
4175 looks_like_bool(cLOGOPo->op_first)
4176 && looks_like_bool(cLOGOPo->op_first->op_sibling));
4180 case OP_NOT: case OP_XOR:
4181 /* Note that OP_DOR is not here */
4183 case OP_EQ: case OP_NE: case OP_LT:
4184 case OP_GT: case OP_LE: case OP_GE:
4186 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
4187 case OP_I_GT: case OP_I_LE: case OP_I_GE:
4189 case OP_SEQ: case OP_SNE: case OP_SLT:
4190 case OP_SGT: case OP_SLE: case OP_SGE:
4194 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
4195 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
4196 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
4197 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
4198 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
4199 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
4200 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
4201 case OP_FTTEXT: case OP_FTBINARY:
4203 case OP_DEFINED: case OP_EXISTS:
4204 case OP_MATCH: case OP_EOF:
4209 /* Detect comparisons that have been optimized away */
4210 if (cSVOPo->op_sv == &PL_sv_yes
4211 || cSVOPo->op_sv == &PL_sv_no)
4222 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
4226 return newGIVWHENOP(
4227 ref_array_or_hash(cond),
4229 OP_ENTERGIVEN, OP_LEAVEGIVEN,
4233 /* If cond is null, this is a default {} block */
4235 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
4237 bool cond_llb = (!cond || looks_like_bool(cond));
4243 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
4245 scalar(ref_array_or_hash(cond)));
4248 return newGIVWHENOP(
4250 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
4251 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
4255 =for apidoc cv_undef
4257 Clear out all the active components of a CV. This can happen either
4258 by an explicit C<undef &foo>, or by the reference count going to zero.
4259 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4260 children can still follow the full lexical scope chain.
4266 Perl_cv_undef(pTHX_ CV *cv)
4270 if (CvFILE(cv) && !CvISXSUB(cv)) {
4271 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4272 Safefree(CvFILE(cv));
4277 if (!CvISXSUB(cv) && CvROOT(cv)) {
4278 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
4279 Perl_croak(aTHX_ "Can't undef active subroutine");
4282 PAD_SAVE_SETNULLPAD();
4284 op_free(CvROOT(cv));
4289 SvPOK_off((SV*)cv); /* forget prototype */
4294 /* remove CvOUTSIDE unless this is an undef rather than a free */
4295 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4296 if (!CvWEAKOUTSIDE(cv))
4297 SvREFCNT_dec(CvOUTSIDE(cv));
4298 CvOUTSIDE(cv) = NULL;
4301 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4304 if (CvISXSUB(cv) && CvXSUB(cv)) {
4307 /* delete all flags except WEAKOUTSIDE */
4308 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4312 Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p)
4314 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX_const(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4315 SV* const msg = sv_newmortal();
4319 gv_efullname3(name = sv_newmortal(), gv, NULL);
4320 sv_setpv(msg, "Prototype mismatch:");
4322 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4324 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (const SV *)cv);
4326 sv_catpvs(msg, ": none");
4327 sv_catpvs(msg, " vs ");
4329 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4331 sv_catpvs(msg, "none");
4332 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
4336 static void const_sv_xsub(pTHX_ CV* cv);
4340 =head1 Optree Manipulation Functions
4342 =for apidoc cv_const_sv
4344 If C<cv> is a constant sub eligible for inlining. returns the constant
4345 value returned by the sub. Otherwise, returns NULL.
4347 Constant subs can be created with C<newCONSTSUB> or as described in
4348 L<perlsub/"Constant Functions">.
4353 Perl_cv_const_sv(pTHX_ CV *cv)
4355 PERL_UNUSED_CONTEXT;
4358 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
4360 return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
4363 /* op_const_sv: examine an optree to determine whether it's in-lineable.
4364 * Can be called in 3 ways:
4367 * look for a single OP_CONST with attached value: return the value
4369 * cv && CvCLONE(cv) && !CvCONST(cv)
4371 * examine the clone prototype, and if contains only a single
4372 * OP_CONST referencing a pad const, or a single PADSV referencing
4373 * an outer lexical, return a non-zero value to indicate the CV is
4374 * a candidate for "constizing" at clone time
4378 * We have just cloned an anon prototype that was marked as a const
4379 * candidiate. Try to grab the current value, and in the case of
4380 * PADSV, ignore it if it has multiple references. Return the value.
4384 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
4392 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4393 o = cLISTOPo->op_first->op_sibling;
4395 for (; o; o = o->op_next) {
4396 const OPCODE type = o->op_type;
4398 if (sv && o->op_next == o)
4400 if (o->op_next != o) {
4401 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4403 if (type == OP_DBSTATE)
4406 if (type == OP_LEAVESUB || type == OP_RETURN)
4410 if (type == OP_CONST && cSVOPo->op_sv)
4412 else if (cv && type == OP_CONST) {
4413 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4417 else if (cv && type == OP_PADSV) {
4418 if (CvCONST(cv)) { /* newly cloned anon */
4419 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4420 /* the candidate should have 1 ref from this pad and 1 ref
4421 * from the parent */
4422 if (!sv || SvREFCNT(sv) != 2)
4429 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4430 sv = &PL_sv_undef; /* an arbitrary non-null value */
4441 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4443 PERL_UNUSED_ARG(floor);
4453 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4457 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4459 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
4463 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4470 register CV *cv = NULL;
4472 /* If the subroutine has no body, no attributes, and no builtin attributes
4473 then it's just a sub declaration, and we may be able to get away with
4474 storing with a placeholder scalar in the symbol table, rather than a
4475 full GV and CV. If anything is present then it will take a full CV to
4477 const I32 gv_fetch_flags
4478 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
4479 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
4480 const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : NULL;
4483 assert(proto->op_type == OP_CONST);
4484 ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len);
4489 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4490 SV * const sv = sv_newmortal();
4491 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4492 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4493 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4494 aname = SvPVX_const(sv);
4499 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
4500 : gv_fetchpv(aname ? aname
4501 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4502 gv_fetch_flags, SVt_PVCV);
4511 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4512 maximum a prototype before. */
4513 if (SvTYPE(gv) > SVt_NULL) {
4514 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4515 && ckWARN_d(WARN_PROTOTYPE))
4517 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4519 cv_ckproto((CV*)gv, NULL, ps);
4522 sv_setpvn((SV*)gv, ps, ps_len);
4524 sv_setiv((SV*)gv, -1);
4525 SvREFCNT_dec(PL_compcv);
4526 cv = PL_compcv = NULL;
4527 PL_sub_generation++;
4531 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
4533 #ifdef GV_UNIQUE_CHECK
4534 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4535 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4539 if (!block || !ps || *ps || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
4542 const_sv = op_const_sv(block, NULL);
4545 const bool exists = CvROOT(cv) || CvXSUB(cv);
4547 #ifdef GV_UNIQUE_CHECK
4548 if (exists && GvUNIQUE(gv)) {
4549 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4553 /* if the subroutine doesn't exist and wasn't pre-declared
4554 * with a prototype, assume it will be AUTOLOADed,
4555 * skipping the prototype check
4557 if (exists || SvPOK(cv))
4558 cv_ckproto(cv, gv, ps);
4559 /* already defined (or promised)? */
4560 if (exists || GvASSUMECV(gv)) {
4561 if (!block && !attrs) {
4562 if (CvFLAGS(PL_compcv)) {
4563 /* might have had built-in attrs applied */
4564 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4566 /* just a "sub foo;" when &foo is already defined */
4567 SAVEFREESV(PL_compcv);
4571 if (ckWARN(WARN_REDEFINE)
4573 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4575 const line_t oldline = CopLINE(PL_curcop);
4576 if (PL_copline != NOLINE)
4577 CopLINE_set(PL_curcop, PL_copline);
4578 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4579 CvCONST(cv) ? "Constant subroutine %s redefined"
4580 : "Subroutine %s redefined", name);
4581 CopLINE_set(PL_curcop, oldline);
4589 SvREFCNT_inc_void_NN(const_sv);
4591 assert(!CvROOT(cv) && !CvCONST(cv));
4592 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
4593 CvXSUBANY(cv).any_ptr = const_sv;
4594 CvXSUB(cv) = const_sv_xsub;
4600 cv = newCONSTSUB(NULL, name, const_sv);
4603 SvREFCNT_dec(PL_compcv);
4605 PL_sub_generation++;
4612 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4613 * before we clobber PL_compcv.
4617 /* Might have had built-in attributes applied -- propagate them. */
4618 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4619 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4620 stash = GvSTASH(CvGV(cv));
4621 else if (CvSTASH(cv))
4622 stash = CvSTASH(cv);
4624 stash = PL_curstash;
4627 /* possibly about to re-define existing subr -- ignore old cv */
4628 rcv = (SV*)PL_compcv;
4629 if (name && GvSTASH(gv))
4630 stash = GvSTASH(gv);
4632 stash = PL_curstash;
4634 apply_attrs(stash, rcv, attrs, FALSE);
4636 if (cv) { /* must reuse cv if autoloaded */
4638 /* got here with just attrs -- work done, so bug out */
4639 SAVEFREESV(PL_compcv);
4642 /* transfer PL_compcv to cv */
4644 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4645 if (!CvWEAKOUTSIDE(cv))
4646 SvREFCNT_dec(CvOUTSIDE(cv));
4647 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4648 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4649 CvOUTSIDE(PL_compcv) = 0;
4650 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4651 CvPADLIST(PL_compcv) = 0;
4652 /* inner references to PL_compcv must be fixed up ... */
4653 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4654 /* ... before we throw it away */
4655 SvREFCNT_dec(PL_compcv);
4657 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4658 ++PL_sub_generation;
4665 PL_sub_generation++;
4669 CvFILE_set_from_cop(cv, PL_curcop);
4670 CvSTASH(cv) = PL_curstash;
4673 sv_setpvn((SV*)cv, ps, ps_len);
4675 if (PL_error_count) {
4679 const char *s = strrchr(name, ':');
4681 if (strEQ(s, "BEGIN")) {
4682 const char not_safe[] =
4683 "BEGIN not safe after errors--compilation aborted";
4684 if (PL_in_eval & EVAL_KEEPERR)
4685 Perl_croak(aTHX_ not_safe);
4687 /* force display of errors found but not reported */
4688 sv_catpv(ERRSV, not_safe);
4689 Perl_croak(aTHX_ "%"SVf, ERRSV);
4698 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4699 mod(scalarseq(block), OP_LEAVESUBLV));
4702 /* This makes sub {}; work as expected. */
4703 if (block->op_type == OP_STUB) {
4705 block = newSTATEOP(0, NULL, 0);
4707 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4709 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4710 OpREFCNT_set(CvROOT(cv), 1);
4711 CvSTART(cv) = LINKLIST(CvROOT(cv));
4712 CvROOT(cv)->op_next = 0;
4713 CALL_PEEP(CvSTART(cv));
4715 /* now that optimizer has done its work, adjust pad values */
4717 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4720 assert(!CvCONST(cv));
4721 if (ps && !*ps && op_const_sv(block, cv))
4725 if (name || aname) {
4727 const char * const tname = (name ? name : aname);
4729 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4730 SV * const sv = newSV(0);
4731 SV * const tmpstr = sv_newmortal();
4732 GV * const db_postponed = gv_fetchpvs("DB::postponed",
4733 GV_ADDMULTI, SVt_PVHV);
4736 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4738 (long)PL_subline, (long)CopLINE(PL_curcop));
4739 gv_efullname3(tmpstr, gv, NULL);
4740 hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
4741 hv = GvHVn(db_postponed);
4742 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
4743 CV * const pcv = GvCV(db_postponed);
4749 call_sv((SV*)pcv, G_DISCARD);
4754 if ((s = strrchr(tname,':')))
4759 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4762 if (strEQ(s, "BEGIN") && !PL_error_count) {
4763 const I32 oldscope = PL_scopestack_ix;
4765 SAVECOPFILE(&PL_compiling);
4766 SAVECOPLINE(&PL_compiling);
4769 PL_beginav = newAV();
4770 DEBUG_x( dump_sub(gv) );
4771 av_push(PL_beginav, (SV*)cv);
4772 GvCV(gv) = 0; /* cv has been hijacked */
4773 call_list(oldscope, PL_beginav);
4775 PL_curcop = &PL_compiling;
4776 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4779 else if (strEQ(s, "END") && !PL_error_count) {
4782 DEBUG_x( dump_sub(gv) );
4783 av_unshift(PL_endav, 1);
4784 av_store(PL_endav, 0, (SV*)cv);
4785 GvCV(gv) = 0; /* cv has been hijacked */
4787 else if (strEQ(s, "CHECK") && !PL_error_count) {
4789 PL_checkav = newAV();
4790 DEBUG_x( dump_sub(gv) );
4791 if (PL_main_start && ckWARN(WARN_VOID))
4792 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4793 av_unshift(PL_checkav, 1);
4794 av_store(PL_checkav, 0, (SV*)cv);
4795 GvCV(gv) = 0; /* cv has been hijacked */
4797 else if (strEQ(s, "INIT") && !PL_error_count) {
4799 PL_initav = newAV();
4800 DEBUG_x( dump_sub(gv) );
4801 if (PL_main_start && ckWARN(WARN_VOID))
4802 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4803 av_push(PL_initav, (SV*)cv);
4804 GvCV(gv) = 0; /* cv has been hijacked */
4809 PL_copline = NOLINE;
4814 /* XXX unsafe for threads if eval_owner isn't held */
4816 =for apidoc newCONSTSUB
4818 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4819 eligible for inlining at compile-time.
4825 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
4832 SAVECOPLINE(PL_curcop);
4833 CopLINE_set(PL_curcop, PL_copline);
4836 PL_hints &= ~HINT_BLOCK_SCOPE;
4839 SAVESPTR(PL_curstash);
4840 SAVECOPSTASH(PL_curcop);
4841 PL_curstash = stash;
4842 CopSTASH_set(PL_curcop,stash);
4845 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4846 CvXSUBANY(cv).any_ptr = sv;
4848 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
4852 CopSTASH_free(PL_curcop);
4860 =for apidoc U||newXS
4862 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4868 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
4871 GV * const gv = gv_fetchpv(name ? name :
4872 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4873 GV_ADDMULTI, SVt_PVCV);
4877 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4879 if ((cv = (name ? GvCV(gv) : NULL))) {
4881 /* just a cached method */
4885 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4886 /* already defined (or promised) */
4887 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
4888 if (ckWARN(WARN_REDEFINE)) {
4889 GV * const gvcv = CvGV(cv);
4891 HV * const stash = GvSTASH(gvcv);
4893 const char *redefined_name = HvNAME_get(stash);
4894 if ( strEQ(redefined_name,"autouse") ) {
4895 const line_t oldline = CopLINE(PL_curcop);
4896 if (PL_copline != NOLINE)
4897 CopLINE_set(PL_curcop, PL_copline);
4898 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4899 CvCONST(cv) ? "Constant subroutine %s redefined"
4900 : "Subroutine %s redefined"
4902 CopLINE_set(PL_curcop, oldline);
4912 if (cv) /* must reuse cv if autoloaded */
4916 sv_upgrade((SV *)cv, SVt_PVCV);
4920 PL_sub_generation++;
4924 (void)gv_fetchfile(filename);
4925 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
4926 an external constant string */
4928 CvXSUB(cv) = subaddr;
4931 const char *s = strrchr(name,':');
4937 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4940 if (strEQ(s, "BEGIN")) {
4942 PL_beginav = newAV();
4943 av_push(PL_beginav, (SV*)cv);
4944 GvCV(gv) = 0; /* cv has been hijacked */
4946 else if (strEQ(s, "END")) {
4949 av_unshift(PL_endav, 1);
4950 av_store(PL_endav, 0, (SV*)cv);
4951 GvCV(gv) = 0; /* cv has been hijacked */
4953 else if (strEQ(s, "CHECK")) {
4955 PL_checkav = newAV();
4956 if (PL_main_start && ckWARN(WARN_VOID))
4957 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4958 av_unshift(PL_checkav, 1);
4959 av_store(PL_checkav, 0, (SV*)cv);
4960 GvCV(gv) = 0; /* cv has been hijacked */
4962 else if (strEQ(s, "INIT")) {
4964 PL_initav = newAV();
4965 if (PL_main_start && ckWARN(WARN_VOID))
4966 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4967 av_push(PL_initav, (SV*)cv);
4968 GvCV(gv) = 0; /* cv has been hijacked */
4979 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4985 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
4986 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
4988 #ifdef GV_UNIQUE_CHECK
4990 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4994 if ((cv = GvFORM(gv))) {
4995 if (ckWARN(WARN_REDEFINE)) {
4996 const line_t oldline = CopLINE(PL_curcop);
4997 if (PL_copline != NOLINE)
4998 CopLINE_set(PL_curcop, PL_copline);
4999 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5000 o ? "Format %"SVf" redefined"
5001 : "Format STDOUT redefined" ,cSVOPo->op_sv);
5002 CopLINE_set(PL_curcop, oldline);
5009 CvFILE_set_from_cop(cv, PL_curcop);
5012 pad_tidy(padtidy_FORMAT);
5013 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5014 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5015 OpREFCNT_set(CvROOT(cv), 1);
5016 CvSTART(cv) = LINKLIST(CvROOT(cv));
5017 CvROOT(cv)->op_next = 0;
5018 CALL_PEEP(CvSTART(cv));
5020 PL_copline = NOLINE;
5025 Perl_newANONLIST(pTHX_ OP *o)
5027 return newUNOP(OP_REFGEN, 0,
5028 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5032 Perl_newANONHASH(pTHX_ OP *o)
5034 return newUNOP(OP_REFGEN, 0,
5035 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5039 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5041 return newANONATTRSUB(floor, proto, NULL, block);
5045 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5047 return newUNOP(OP_REFGEN, 0,
5048 newSVOP(OP_ANONCODE, 0,
5049 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5053 Perl_oopsAV(pTHX_ OP *o)
5056 switch (o->op_type) {
5058 o->op_type = OP_PADAV;
5059 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5060 return ref(o, OP_RV2AV);
5063 o->op_type = OP_RV2AV;
5064 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5069 if (ckWARN_d(WARN_INTERNAL))
5070 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
5077 Perl_oopsHV(pTHX_ OP *o)
5080 switch (o->op_type) {
5083 o->op_type = OP_PADHV;
5084 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5085 return ref(o, OP_RV2HV);
5089 o->op_type = OP_RV2HV;
5090 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5095 if (ckWARN_d(WARN_INTERNAL))
5096 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
5103 Perl_newAVREF(pTHX_ OP *o)
5106 if (o->op_type == OP_PADANY) {
5107 o->op_type = OP_PADAV;
5108 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5111 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5112 && ckWARN(WARN_DEPRECATED)) {
5113 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5114 "Using an array as a reference is deprecated");
5116 return newUNOP(OP_RV2AV, 0, scalar(o));
5120 Perl_newGVREF(pTHX_ I32 type, OP *o)
5122 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5123 return newUNOP(OP_NULL, 0, o);
5124 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5128 Perl_newHVREF(pTHX_ OP *o)
5131 if (o->op_type == OP_PADANY) {
5132 o->op_type = OP_PADHV;
5133 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5136 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5137 && ckWARN(WARN_DEPRECATED)) {
5138 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5139 "Using a hash as a reference is deprecated");
5141 return newUNOP(OP_RV2HV, 0, scalar(o));
5145 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5147 return newUNOP(OP_RV2CV, flags, scalar(o));
5151 Perl_newSVREF(pTHX_ OP *o)
5154 if (o->op_type == OP_PADANY) {
5155 o->op_type = OP_PADSV;
5156 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5159 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5160 o->op_flags |= OPpDONE_SVREF;
5163 return newUNOP(OP_RV2SV, 0, scalar(o));
5166 /* Check routines. See the comments at the top of this file for details
5167 * on when these are called */
5170 Perl_ck_anoncode(pTHX_ OP *o)
5172 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
5173 cSVOPo->op_sv = NULL;
5178 Perl_ck_bitop(pTHX_ OP *o)
5181 #define OP_IS_NUMCOMPARE(op) \
5182 ((op) == OP_LT || (op) == OP_I_LT || \
5183 (op) == OP_GT || (op) == OP_I_GT || \
5184 (op) == OP_LE || (op) == OP_I_LE || \
5185 (op) == OP_GE || (op) == OP_I_GE || \
5186 (op) == OP_EQ || (op) == OP_I_EQ || \
5187 (op) == OP_NE || (op) == OP_I_NE || \
5188 (op) == OP_NCMP || (op) == OP_I_NCMP)
5189 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
5190 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
5191 && (o->op_type == OP_BIT_OR
5192 || o->op_type == OP_BIT_AND
5193 || o->op_type == OP_BIT_XOR))
5195 const OP * const left = cBINOPo->op_first;
5196 const OP * const right = left->op_sibling;
5197 if ((OP_IS_NUMCOMPARE(left->op_type) &&
5198 (left->op_flags & OPf_PARENS) == 0) ||
5199 (OP_IS_NUMCOMPARE(right->op_type) &&
5200 (right->op_flags & OPf_PARENS) == 0))
5201 if (ckWARN(WARN_PRECEDENCE))
5202 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
5203 "Possible precedence problem on bitwise %c operator",
5204 o->op_type == OP_BIT_OR ? '|'
5205 : o->op_type == OP_BIT_AND ? '&' : '^'
5212 Perl_ck_concat(pTHX_ OP *o)
5214 const OP * const kid = cUNOPo->op_first;
5215 PERL_UNUSED_CONTEXT;
5216 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
5217 !(kUNOP->op_first->op_flags & OPf_MOD))
5218 o->op_flags |= OPf_STACKED;
5223 Perl_ck_spair(pTHX_ OP *o)
5226 if (o->op_flags & OPf_KIDS) {
5229 const OPCODE type = o->op_type;
5230 o = modkids(ck_fun(o), type);
5231 kid = cUNOPo->op_first;
5232 newop = kUNOP->op_first->op_sibling;
5234 (newop->op_sibling ||
5235 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5236 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5237 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5241 op_free(kUNOP->op_first);
5242 kUNOP->op_first = newop;
5244 o->op_ppaddr = PL_ppaddr[++o->op_type];
5249 Perl_ck_delete(pTHX_ OP *o)
5253 if (o->op_flags & OPf_KIDS) {
5254 OP * const kid = cUNOPo->op_first;
5255 switch (kid->op_type) {
5257 o->op_flags |= OPf_SPECIAL;
5260 o->op_private |= OPpSLICE;
5263 o->op_flags |= OPf_SPECIAL;
5268 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5277 Perl_ck_die(pTHX_ OP *o)
5280 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5286 Perl_ck_eof(pTHX_ OP *o)
5289 const I32 type = o->op_type;
5291 if (o->op_flags & OPf_KIDS) {
5292 if (cLISTOPo->op_first->op_type == OP_STUB) {
5294 o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
5302 Perl_ck_eval(pTHX_ OP *o)
5305 PL_hints |= HINT_BLOCK_SCOPE;
5306 if (o->op_flags & OPf_KIDS) {
5307 SVOP * const kid = (SVOP*)cUNOPo->op_first;
5310 o->op_flags &= ~OPf_KIDS;
5313 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
5316 cUNOPo->op_first = 0;
5319 NewOp(1101, enter, 1, LOGOP);
5320 enter->op_type = OP_ENTERTRY;
5321 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5322 enter->op_private = 0;
5324 /* establish postfix order */
5325 enter->op_next = (OP*)enter;
5327 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5328 o->op_type = OP_LEAVETRY;
5329 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5330 enter->op_other = o;
5340 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5342 o->op_targ = (PADOFFSET)PL_hints;
5343 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
5344 /* Store a copy of %^H that pp_entereval can pick up */
5345 OP *hhop = newSVOP(OP_CONST, 0, (SV*)newHVhv(GvHV(PL_hintgv)));
5346 cUNOPo->op_first->op_sibling = hhop;
5347 o->op_private |= OPpEVAL_HAS_HH;
5353 Perl_ck_exit(pTHX_ OP *o)
5356 HV * const table = GvHV(PL_hintgv);
5358 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
5359 if (svp && *svp && SvTRUE(*svp))
5360 o->op_private |= OPpEXIT_VMSISH;
5362 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5368 Perl_ck_exec(pTHX_ OP *o)
5370 if (o->op_flags & OPf_STACKED) {
5373 kid = cUNOPo->op_first->op_sibling;
5374 if (kid->op_type == OP_RV2GV)
5383 Perl_ck_exists(pTHX_ OP *o)
5387 if (o->op_flags & OPf_KIDS) {
5388 OP * const kid = cUNOPo->op_first;
5389 if (kid->op_type == OP_ENTERSUB) {
5390 (void) ref(kid, o->op_type);
5391 if (kid->op_type != OP_RV2CV && !PL_error_count)
5392 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5394 o->op_private |= OPpEXISTS_SUB;
5396 else if (kid->op_type == OP_AELEM)
5397 o->op_flags |= OPf_SPECIAL;
5398 else if (kid->op_type != OP_HELEM)
5399 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5407 Perl_ck_rvconst(pTHX_ register OP *o)
5410 SVOP * const kid = (SVOP*)cUNOPo->op_first;
5412 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5413 if (o->op_type == OP_RV2CV)
5414 o->op_private &= ~1;
5416 if (kid->op_type == OP_CONST) {
5419 SV * const kidsv = kid->op_sv;
5421 /* Is it a constant from cv_const_sv()? */
5422 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5423 SV * const rsv = SvRV(kidsv);
5424 const int svtype = SvTYPE(rsv);
5425 const char *badtype = NULL;
5427 switch (o->op_type) {
5429 if (svtype > SVt_PVMG)
5430 badtype = "a SCALAR";
5433 if (svtype != SVt_PVAV)
5434 badtype = "an ARRAY";
5437 if (svtype != SVt_PVHV)
5441 if (svtype != SVt_PVCV)
5446 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5449 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
5450 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
5451 /* If this is an access to a stash, disable "strict refs", because
5452 * stashes aren't auto-vivified at compile-time (unless we store
5453 * symbols in them), and we don't want to produce a run-time
5454 * stricture error when auto-vivifying the stash. */
5455 const char *s = SvPV_nolen(kidsv);
5456 const STRLEN l = SvCUR(kidsv);
5457 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
5458 o->op_private &= ~HINT_STRICT_REFS;
5460 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5461 const char *badthing;
5462 switch (o->op_type) {
5464 badthing = "a SCALAR";
5467 badthing = "an ARRAY";
5470 badthing = "a HASH";
5478 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
5482 * This is a little tricky. We only want to add the symbol if we
5483 * didn't add it in the lexer. Otherwise we get duplicate strict
5484 * warnings. But if we didn't add it in the lexer, we must at
5485 * least pretend like we wanted to add it even if it existed before,
5486 * or we get possible typo warnings. OPpCONST_ENTERED says
5487 * whether the lexer already added THIS instance of this symbol.
5489 iscv = (o->op_type == OP_RV2CV) * 2;
5491 gv = gv_fetchsv(kidsv,
5492 iscv | !(kid->op_private & OPpCONST_ENTERED),
5495 : o->op_type == OP_RV2SV
5497 : o->op_type == OP_RV2AV
5499 : o->op_type == OP_RV2HV
5502 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5504 kid->op_type = OP_GV;
5505 SvREFCNT_dec(kid->op_sv);
5507 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5508 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5509 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
5511 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv));
5513 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
5515 kid->op_private = 0;
5516 kid->op_ppaddr = PL_ppaddr[OP_GV];
5523 Perl_ck_ftst(pTHX_ OP *o)
5526 const I32 type = o->op_type;
5528 if (o->op_flags & OPf_REF) {
5531 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5532 SVOP * const kid = (SVOP*)cUNOPo->op_first;
5534 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5535 OP * const newop = newGVOP(type, OPf_REF,
5536 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
5542 if ((PL_hints & HINT_FILETEST_ACCESS) &&
5543 OP_IS_FILETEST_ACCESS(o))
5544 o->op_private |= OPpFT_ACCESS;
5546 if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
5547 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
5548 o->op_private |= OPpFT_STACKED;
5552 if (type == OP_FTTTY)
5553 o = newGVOP(type, OPf_REF, PL_stdingv);
5555 o = newUNOP(type, 0, newDEFSVOP());
5561 Perl_ck_fun(pTHX_ OP *o)
5564 const int type = o->op_type;
5565 register I32 oa = PL_opargs[type] >> OASHIFT;
5567 if (o->op_flags & OPf_STACKED) {
5568 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5571 return no_fh_allowed(o);
5574 if (o->op_flags & OPf_KIDS) {
5575 OP **tokid = &cLISTOPo->op_first;
5576 register OP *kid = cLISTOPo->op_first;
5580 if (kid->op_type == OP_PUSHMARK ||
5581 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5583 tokid = &kid->op_sibling;
5584 kid = kid->op_sibling;
5586 if (!kid && PL_opargs[type] & OA_DEFGV)
5587 *tokid = kid = newDEFSVOP();
5591 sibl = kid->op_sibling;
5594 /* list seen where single (scalar) arg expected? */
5595 if (numargs == 1 && !(oa >> 4)
5596 && kid->op_type == OP_LIST && type != OP_SCALAR)
5598 return too_many_arguments(o,PL_op_desc[type]);
5611 if ((type == OP_PUSH || type == OP_UNSHIFT)
5612 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5613 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5614 "Useless use of %s with no values",
5617 if (kid->op_type == OP_CONST &&
5618 (kid->op_private & OPpCONST_BARE))
5620 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
5621 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
5622 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5623 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5624 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
5625 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5628 kid->op_sibling = sibl;
5631 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5632 bad_type(numargs, "array", PL_op_desc[type], kid);
5636 if (kid->op_type == OP_CONST &&
5637 (kid->op_private & OPpCONST_BARE))
5639 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
5640 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
5641 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5642 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5643 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
5644 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5647 kid->op_sibling = sibl;
5650 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5651 bad_type(numargs, "hash", PL_op_desc[type], kid);
5656 OP * const newop = newUNOP(OP_NULL, 0, kid);
5657 kid->op_sibling = 0;
5659 newop->op_next = newop;
5661 kid->op_sibling = sibl;
5666 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5667 if (kid->op_type == OP_CONST &&
5668 (kid->op_private & OPpCONST_BARE))
5670 OP * const newop = newGVOP(OP_GV, 0,
5671 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
5672 if (!(o->op_private & 1) && /* if not unop */
5673 kid == cLISTOPo->op_last)
5674 cLISTOPo->op_last = newop;
5678 else if (kid->op_type == OP_READLINE) {
5679 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5680 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5683 I32 flags = OPf_SPECIAL;
5687 /* is this op a FH constructor? */
5688 if (is_handle_constructor(o,numargs)) {
5689 const char *name = NULL;
5693 /* Set a flag to tell rv2gv to vivify
5694 * need to "prove" flag does not mean something
5695 * else already - NI-S 1999/05/07
5698 if (kid->op_type == OP_PADSV) {
5699 name = PAD_COMPNAME_PV(kid->op_targ);
5700 /* SvCUR of a pad namesv can't be trusted
5701 * (see PL_generation), so calc its length
5707 else if (kid->op_type == OP_RV2SV
5708 && kUNOP->op_first->op_type == OP_GV)
5710 GV * const gv = cGVOPx_gv(kUNOP->op_first);
5712 len = GvNAMELEN(gv);
5714 else if (kid->op_type == OP_AELEM
5715 || kid->op_type == OP_HELEM)
5717 OP *op = ((BINOP*)kid)->op_first;
5721 const char * const a =
5722 kid->op_type == OP_AELEM ?
5724 if (((op->op_type == OP_RV2AV) ||
5725 (op->op_type == OP_RV2HV)) &&
5726 (op = ((UNOP*)op)->op_first) &&
5727 (op->op_type == OP_GV)) {
5728 /* packagevar $a[] or $h{} */
5729 GV * const gv = cGVOPx_gv(op);
5737 else if (op->op_type == OP_PADAV
5738 || op->op_type == OP_PADHV) {
5739 /* lexicalvar $a[] or $h{} */
5740 const char * const padname =
5741 PAD_COMPNAME_PV(op->op_targ);
5750 name = SvPV_const(tmpstr, len);
5755 name = "__ANONIO__";
5762 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5763 namesv = PAD_SVl(targ);
5764 SvUPGRADE(namesv, SVt_PV);
5766 sv_setpvn(namesv, "$", 1);
5767 sv_catpvn(namesv, name, len);
5770 kid->op_sibling = 0;
5771 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5772 kid->op_targ = targ;
5773 kid->op_private |= priv;
5775 kid->op_sibling = sibl;
5781 mod(scalar(kid), type);
5785 tokid = &kid->op_sibling;
5786 kid = kid->op_sibling;
5788 o->op_private |= numargs;
5790 return too_many_arguments(o,OP_DESC(o));
5793 else if (PL_opargs[type] & OA_DEFGV) {
5795 return newUNOP(type, 0, newDEFSVOP());
5799 while (oa & OA_OPTIONAL)
5801 if (oa && oa != OA_LIST)
5802 return too_few_arguments(o,OP_DESC(o));
5808 Perl_ck_glob(pTHX_ OP *o)
5814 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5815 append_elem(OP_GLOB, o, newDEFSVOP());
5817 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
5818 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5820 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
5823 #if !defined(PERL_EXTERNAL_GLOB)
5824 /* XXX this can be tightened up and made more failsafe. */
5825 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5828 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5829 newSVpvs("File::Glob"), NULL, NULL, NULL);
5830 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
5831 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
5832 GvCV(gv) = GvCV(glob_gv);
5833 SvREFCNT_inc_void((SV*)GvCV(gv));
5834 GvIMPORTED_CV_on(gv);
5837 #endif /* PERL_EXTERNAL_GLOB */
5839 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5840 append_elem(OP_GLOB, o,
5841 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5842 o->op_type = OP_LIST;
5843 o->op_ppaddr = PL_ppaddr[OP_LIST];
5844 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5845 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5846 cLISTOPo->op_first->op_targ = 0;
5847 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5848 append_elem(OP_LIST, o,
5849 scalar(newUNOP(OP_RV2CV, 0,
5850 newGVOP(OP_GV, 0, gv)))));
5851 o = newUNOP(OP_NULL, 0, ck_subr(o));
5852 o->op_targ = OP_GLOB; /* hint at what it used to be */
5855 gv = newGVgen("main");
5857 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5863 Perl_ck_grep(pTHX_ OP *o)
5868 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5871 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5872 NewOp(1101, gwop, 1, LOGOP);
5874 if (o->op_flags & OPf_STACKED) {
5877 kid = cLISTOPo->op_first->op_sibling;
5878 if (!cUNOPx(kid)->op_next)
5879 Perl_croak(aTHX_ "panic: ck_grep");
5880 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
5883 kid->op_next = (OP*)gwop;
5884 o->op_flags &= ~OPf_STACKED;
5886 kid = cLISTOPo->op_first->op_sibling;
5887 if (type == OP_MAPWHILE)
5894 kid = cLISTOPo->op_first->op_sibling;
5895 if (kid->op_type != OP_NULL)
5896 Perl_croak(aTHX_ "panic: ck_grep");
5897 kid = kUNOP->op_first;
5899 gwop->op_type = type;
5900 gwop->op_ppaddr = PL_ppaddr[type];
5901 gwop->op_first = listkids(o);
5902 gwop->op_flags |= OPf_KIDS;
5903 gwop->op_other = LINKLIST(kid);
5904 kid->op_next = (OP*)gwop;
5905 offset = pad_findmy("$_");
5906 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
5907 o->op_private = gwop->op_private = 0;
5908 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5911 o->op_private = gwop->op_private = OPpGREP_LEX;
5912 gwop->op_targ = o->op_targ = offset;
5915 kid = cLISTOPo->op_first->op_sibling;
5916 if (!kid || !kid->op_sibling)
5917 return too_few_arguments(o,OP_DESC(o));
5918 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5919 mod(kid, OP_GREPSTART);
5925 Perl_ck_index(pTHX_ OP *o)
5927 if (o->op_flags & OPf_KIDS) {
5928 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5930 kid = kid->op_sibling; /* get past "big" */
5931 if (kid && kid->op_type == OP_CONST)
5932 fbm_compile(((SVOP*)kid)->op_sv, 0);
5938 Perl_ck_lengthconst(pTHX_ OP *o)
5940 /* XXX length optimization goes here */
5945 Perl_ck_lfun(pTHX_ OP *o)
5947 const OPCODE type = o->op_type;
5948 return modkids(ck_fun(o), type);
5952 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5954 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5955 switch (cUNOPo->op_first->op_type) {
5957 /* This is needed for
5958 if (defined %stash::)
5959 to work. Do not break Tk.
5961 break; /* Globals via GV can be undef */
5963 case OP_AASSIGN: /* Is this a good idea? */
5964 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5965 "defined(@array) is deprecated");
5966 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5967 "\t(Maybe you should just omit the defined()?)\n");
5970 /* This is needed for
5971 if (defined %stash::)
5972 to work. Do not break Tk.
5974 break; /* Globals via GV can be undef */
5976 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5977 "defined(%%hash) is deprecated");
5978 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5979 "\t(Maybe you should just omit the defined()?)\n");
5990 Perl_ck_rfun(pTHX_ OP *o)
5992 const OPCODE type = o->op_type;
5993 return refkids(ck_fun(o), type);
5997 Perl_ck_listiob(pTHX_ OP *o)
6001 kid = cLISTOPo->op_first;
6004 kid = cLISTOPo->op_first;
6006 if (kid->op_type == OP_PUSHMARK)
6007 kid = kid->op_sibling;
6008 if (kid && o->op_flags & OPf_STACKED)
6009 kid = kid->op_sibling;
6010 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6011 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6012 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6013 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6014 cLISTOPo->op_first->op_sibling = kid;
6015 cLISTOPo->op_last = kid;
6016 kid = kid->op_sibling;
6021 append_elem(o->op_type, o, newDEFSVOP());
6027 Perl_ck_say(pTHX_ OP *o)
6030 o->op_type = OP_PRINT;
6031 cLISTOPo->op_last = cLISTOPo->op_last->op_sibling
6032 = newSVOP(OP_CONST, 0, newSVpvs("\n"));
6037 Perl_ck_smartmatch(pTHX_ OP *o)
6040 if (0 == (o->op_flags & OPf_SPECIAL)) {
6041 OP *first = cBINOPo->op_first;
6042 OP *second = first->op_sibling;
6044 /* Implicitly take a reference to an array or hash */
6045 first->op_sibling = NULL;
6046 first = cBINOPo->op_first = ref_array_or_hash(first);
6047 second = first->op_sibling = ref_array_or_hash(second);
6049 /* Implicitly take a reference to a regular expression */
6050 if (first->op_type == OP_MATCH) {
6051 first->op_type = OP_QR;
6052 first->op_ppaddr = PL_ppaddr[OP_QR];
6054 if (second->op_type == OP_MATCH) {
6055 second->op_type = OP_QR;
6056 second->op_ppaddr = PL_ppaddr[OP_QR];
6065 Perl_ck_sassign(pTHX_ OP *o)
6067 OP *kid = cLISTOPo->op_first;
6068 /* has a disposable target? */
6069 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6070 && !(kid->op_flags & OPf_STACKED)
6071 /* Cannot steal the second time! */
6072 && !(kid->op_private & OPpTARGET_MY))
6074 OP * const kkid = kid->op_sibling;
6076 /* Can just relocate the target. */
6077 if (kkid && kkid->op_type == OP_PADSV
6078 && !(kkid->op_private & OPpLVAL_INTRO))
6080 kid->op_targ = kkid->op_targ;
6082 /* Now we do not need PADSV and SASSIGN. */
6083 kid->op_sibling = o->op_sibling; /* NULL */
6084 cLISTOPo->op_first = NULL;
6087 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6095 Perl_ck_match(pTHX_ OP *o)
6098 if (o->op_type != OP_QR && PL_compcv) {
6099 const I32 offset = pad_findmy("$_");
6100 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
6101 o->op_targ = offset;
6102 o->op_private |= OPpTARGET_MY;
6105 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
6106 o->op_private |= OPpRUNTIME;
6111 Perl_ck_method(pTHX_ OP *o)
6113 OP * const kid = cUNOPo->op_first;
6114 if (kid->op_type == OP_CONST) {
6115 SV* sv = kSVOP->op_sv;
6116 const char * const method = SvPVX_const(sv);
6117 if (!(strchr(method, ':') || strchr(method, '\''))) {
6119 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6120 sv = newSVpvn_share(method, SvCUR(sv), 0);
6123 kSVOP->op_sv = NULL;
6125 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6134 Perl_ck_null(pTHX_ OP *o)
6136 PERL_UNUSED_CONTEXT;
6141 Perl_ck_open(pTHX_ OP *o)
6144 HV * const table = GvHV(PL_hintgv);
6146 SV **svp = hv_fetchs(table, "open_IN", FALSE);
6148 const I32 mode = mode_from_discipline(*svp);
6149 if (mode & O_BINARY)
6150 o->op_private |= OPpOPEN_IN_RAW;
6151 else if (mode & O_TEXT)
6152 o->op_private |= OPpOPEN_IN_CRLF;
6155 svp = hv_fetchs(table, "open_OUT", FALSE);
6157 const I32 mode = mode_from_discipline(*svp);
6158 if (mode & O_BINARY)
6159 o->op_private |= OPpOPEN_OUT_RAW;
6160 else if (mode & O_TEXT)
6161 o->op_private |= OPpOPEN_OUT_CRLF;
6164 if (o->op_type == OP_BACKTICK)
6167 /* In case of three-arg dup open remove strictness
6168 * from the last arg if it is a bareword. */
6169 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
6170 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
6174 if ((last->op_type == OP_CONST) && /* The bareword. */
6175 (last->op_private & OPpCONST_BARE) &&
6176 (last->op_private & OPpCONST_STRICT) &&
6177 (oa = first->op_sibling) && /* The fh. */
6178 (oa = oa->op_sibling) && /* The mode. */
6179 (oa->op_type == OP_CONST) &&
6180 SvPOK(((SVOP*)oa)->op_sv) &&
6181 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
6182 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
6183 (last == oa->op_sibling)) /* The bareword. */
6184 last->op_private &= ~OPpCONST_STRICT;
6190 Perl_ck_repeat(pTHX_ OP *o)
6192 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6193 o->op_private |= OPpREPEAT_DOLIST;
6194 cBINOPo->op_first = force_list(cBINOPo->op_first);
6202 Perl_ck_require(pTHX_ OP *o)
6207 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6208 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6210 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6211 SV * const sv = kid->op_sv;
6212 U32 was_readonly = SvREADONLY(sv);
6217 sv_force_normal_flags(sv, 0);
6218 assert(!SvREADONLY(sv));
6225 for (s = SvPVX(sv); *s; s++) {
6226 if (*s == ':' && s[1] == ':') {
6227 const STRLEN len = strlen(s+2)+1;
6229 Move(s+2, s+1, len, char);
6230 SvCUR_set(sv, SvCUR(sv) - 1);
6233 sv_catpvs(sv, ".pm");
6234 SvFLAGS(sv) |= was_readonly;
6238 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
6239 /* handle override, if any */
6240 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
6241 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6242 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
6243 gv = gvp ? *gvp : NULL;
6247 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6248 OP * const kid = cUNOPo->op_first;
6249 cUNOPo->op_first = 0;
6251 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6252 append_elem(OP_LIST, kid,
6253 scalar(newUNOP(OP_RV2CV, 0,
6262 Perl_ck_return(pTHX_ OP *o)
6265 if (CvLVALUE(PL_compcv)) {
6267 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6268 mod(kid, OP_LEAVESUBLV);
6274 Perl_ck_select(pTHX_ OP *o)
6278 if (o->op_flags & OPf_KIDS) {
6279 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6280 if (kid && kid->op_sibling) {
6281 o->op_type = OP_SSELECT;
6282 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6284 return fold_constants(o);
6288 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6289 if (kid && kid->op_type == OP_RV2GV)
6290 kid->op_private &= ~HINT_STRICT_REFS;
6295 Perl_ck_shift(pTHX_ OP *o)
6298 const I32 type = o->op_type;
6300 if (!(o->op_flags & OPf_KIDS)) {
6304 argop = newUNOP(OP_RV2AV, 0,
6305 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
6306 return newUNOP(type, 0, scalar(argop));
6308 return scalar(modkids(ck_fun(o), type));
6312 Perl_ck_sort(pTHX_ OP *o)
6317 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0)
6319 HV * const hinthv = GvHV(PL_hintgv);
6321 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
6323 const I32 sorthints = (I32)SvIV(*svp);
6324 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
6325 o->op_private |= OPpSORT_QSORT;
6326 if ((sorthints & HINT_SORT_STABLE) != 0)
6327 o->op_private |= OPpSORT_STABLE;
6332 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6334 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6335 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6337 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6339 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6341 if (kid->op_type == OP_SCOPE) {
6345 else if (kid->op_type == OP_LEAVE) {
6346 if (o->op_type == OP_SORT) {
6347 op_null(kid); /* wipe out leave */
6350 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6351 if (k->op_next == kid)
6353 /* don't descend into loops */
6354 else if (k->op_type == OP_ENTERLOOP
6355 || k->op_type == OP_ENTERITER)
6357 k = cLOOPx(k)->op_lastop;
6362 kid->op_next = 0; /* just disconnect the leave */
6363 k = kLISTOP->op_first;
6368 if (o->op_type == OP_SORT) {
6369 /* provide scalar context for comparison function/block */
6375 o->op_flags |= OPf_SPECIAL;
6377 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6380 firstkid = firstkid->op_sibling;
6383 /* provide list context for arguments */
6384 if (o->op_type == OP_SORT)
6391 S_simplify_sort(pTHX_ OP *o)
6394 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6399 if (!(o->op_flags & OPf_STACKED))
6401 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
6402 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
6403 kid = kUNOP->op_first; /* get past null */
6404 if (kid->op_type != OP_SCOPE)
6406 kid = kLISTOP->op_last; /* get past scope */
6407 switch(kid->op_type) {
6415 k = kid; /* remember this node*/
6416 if (kBINOP->op_first->op_type != OP_RV2SV)
6418 kid = kBINOP->op_first; /* get past cmp */
6419 if (kUNOP->op_first->op_type != OP_GV)
6421 kid = kUNOP->op_first; /* get past rv2sv */
6423 if (GvSTASH(gv) != PL_curstash)
6425 gvname = GvNAME(gv);
6426 if (*gvname == 'a' && gvname[1] == '\0')
6428 else if (*gvname == 'b' && gvname[1] == '\0')
6433 kid = k; /* back to cmp */
6434 if (kBINOP->op_last->op_type != OP_RV2SV)
6436 kid = kBINOP->op_last; /* down to 2nd arg */
6437 if (kUNOP->op_first->op_type != OP_GV)
6439 kid = kUNOP->op_first; /* get past rv2sv */
6441 if (GvSTASH(gv) != PL_curstash)
6443 gvname = GvNAME(gv);
6445 ? !(*gvname == 'a' && gvname[1] == '\0')
6446 : !(*gvname == 'b' && gvname[1] == '\0'))
6448 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6450 o->op_private |= OPpSORT_DESCEND;
6451 if (k->op_type == OP_NCMP)
6452 o->op_private |= OPpSORT_NUMERIC;
6453 if (k->op_type == OP_I_NCMP)
6454 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6455 kid = cLISTOPo->op_first->op_sibling;
6456 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6457 op_free(kid); /* then delete it */
6461 Perl_ck_split(pTHX_ OP *o)
6466 if (o->op_flags & OPf_STACKED)
6467 return no_fh_allowed(o);
6469 kid = cLISTOPo->op_first;
6470 if (kid->op_type != OP_NULL)
6471 Perl_croak(aTHX_ "panic: ck_split");
6472 kid = kid->op_sibling;
6473 op_free(cLISTOPo->op_first);
6474 cLISTOPo->op_first = kid;
6476 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
6477 cLISTOPo->op_last = kid; /* There was only one element previously */
6480 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6481 OP * const sibl = kid->op_sibling;
6482 kid->op_sibling = 0;
6483 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
6484 if (cLISTOPo->op_first == cLISTOPo->op_last)
6485 cLISTOPo->op_last = kid;
6486 cLISTOPo->op_first = kid;
6487 kid->op_sibling = sibl;
6490 kid->op_type = OP_PUSHRE;
6491 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6493 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
6494 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
6495 "Use of /g modifier is meaningless in split");
6498 if (!kid->op_sibling)
6499 append_elem(OP_SPLIT, o, newDEFSVOP());
6501 kid = kid->op_sibling;
6504 if (!kid->op_sibling)
6505 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6507 kid = kid->op_sibling;
6510 if (kid->op_sibling)
6511 return too_many_arguments(o,OP_DESC(o));
6517 Perl_ck_join(pTHX_ OP *o)
6519 const OP * const kid = cLISTOPo->op_first->op_sibling;
6520 if (kid && kid->op_type == OP_MATCH) {
6521 if (ckWARN(WARN_SYNTAX)) {
6522 const REGEXP *re = PM_GETRE(kPMOP);
6523 const char *pmstr = re ? re->precomp : "STRING";
6524 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6525 "/%s/ should probably be written as \"%s\"",
6533 Perl_ck_subr(pTHX_ OP *o)
6536 OP *prev = ((cUNOPo->op_first->op_sibling)
6537 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6538 OP *o2 = prev->op_sibling;
6545 I32 contextclass = 0;
6549 o->op_private |= OPpENTERSUB_HASTARG;
6550 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6551 if (cvop->op_type == OP_RV2CV) {
6553 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6554 op_null(cvop); /* disable rv2cv */
6555 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6556 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6557 GV *gv = cGVOPx_gv(tmpop);
6560 tmpop->op_private |= OPpEARLY_CV;
6563 namegv = CvANON(cv) ? gv : CvGV(cv);
6564 proto = SvPV_nolen((SV*)cv);
6566 if (CvASSERTION(cv)) {
6567 if (PL_hints & HINT_ASSERTING) {
6568 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
6569 o->op_private |= OPpENTERSUB_DB;
6573 if (!(PL_hints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
6574 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
6575 "Impossible to activate assertion call");
6582 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6583 if (o2->op_type == OP_CONST)
6584 o2->op_private &= ~OPpCONST_STRICT;
6585 else if (o2->op_type == OP_LIST) {
6586 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
6587 if (sib && sib->op_type == OP_CONST)
6588 sib->op_private &= ~OPpCONST_STRICT;
6591 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6592 if (PERLDB_SUB && PL_curstash != PL_debstash)
6593 o->op_private |= OPpENTERSUB_DB;
6594 while (o2 != cvop) {
6598 return too_many_arguments(o, gv_ename(namegv));
6616 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6618 arg == 1 ? "block or sub {}" : "sub {}",
6619 gv_ename(namegv), o2);
6622 /* '*' allows any scalar type, including bareword */
6625 if (o2->op_type == OP_RV2GV)
6626 goto wrapref; /* autoconvert GLOB -> GLOBref */
6627 else if (o2->op_type == OP_CONST)
6628 o2->op_private &= ~OPpCONST_STRICT;
6629 else if (o2->op_type == OP_ENTERSUB) {
6630 /* accidental subroutine, revert to bareword */
6631 OP *gvop = ((UNOP*)o2)->op_first;
6632 if (gvop && gvop->op_type == OP_NULL) {
6633 gvop = ((UNOP*)gvop)->op_first;
6635 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6638 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6639 (gvop = ((UNOP*)gvop)->op_first) &&
6640 gvop->op_type == OP_GV)
6642 GV * const gv = cGVOPx_gv(gvop);
6643 OP * const sibling = o2->op_sibling;
6644 SV * const n = newSVpvs("");
6646 gv_fullname4(n, gv, "", FALSE);
6647 o2 = newSVOP(OP_CONST, 0, n);
6648 prev->op_sibling = o2;
6649 o2->op_sibling = sibling;
6665 if (contextclass++ == 0) {
6666 e = strchr(proto, ']');
6667 if (!e || e == proto)
6676 /* XXX We shouldn't be modifying proto, so we can const proto */
6681 while (*--p != '[');
6682 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6683 gv_ename(namegv), o2);
6689 if (o2->op_type == OP_RV2GV)
6692 bad_type(arg, "symbol", gv_ename(namegv), o2);
6695 if (o2->op_type == OP_ENTERSUB)
6698 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6701 if (o2->op_type == OP_RV2SV ||
6702 o2->op_type == OP_PADSV ||
6703 o2->op_type == OP_HELEM ||
6704 o2->op_type == OP_AELEM ||
6705 o2->op_type == OP_THREADSV)
6708 bad_type(arg, "scalar", gv_ename(namegv), o2);
6711 if (o2->op_type == OP_RV2AV ||
6712 o2->op_type == OP_PADAV)
6715 bad_type(arg, "array", gv_ename(namegv), o2);
6718 if (o2->op_type == OP_RV2HV ||
6719 o2->op_type == OP_PADHV)
6722 bad_type(arg, "hash", gv_ename(namegv), o2);
6727 OP* const sib = kid->op_sibling;
6728 kid->op_sibling = 0;
6729 o2 = newUNOP(OP_REFGEN, 0, kid);
6730 o2->op_sibling = sib;
6731 prev->op_sibling = o2;
6733 if (contextclass && e) {
6748 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6749 gv_ename(namegv), cv);
6754 mod(o2, OP_ENTERSUB);
6756 o2 = o2->op_sibling;
6758 if (proto && !optional &&
6759 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6760 return too_few_arguments(o, gv_ename(namegv));
6763 o=newSVOP(OP_CONST, 0, newSViv(0));
6769 Perl_ck_svconst(pTHX_ OP *o)
6771 PERL_UNUSED_CONTEXT;
6772 SvREADONLY_on(cSVOPo->op_sv);
6777 Perl_ck_chdir(pTHX_ OP *o)
6779 if (o->op_flags & OPf_KIDS) {
6780 SVOP *kid = (SVOP*)cUNOPo->op_first;
6782 if (kid && kid->op_type == OP_CONST &&
6783 (kid->op_private & OPpCONST_BARE))
6785 o->op_flags |= OPf_SPECIAL;
6786 kid->op_private &= ~OPpCONST_STRICT;
6793 Perl_ck_trunc(pTHX_ OP *o)
6795 if (o->op_flags & OPf_KIDS) {
6796 SVOP *kid = (SVOP*)cUNOPo->op_first;
6798 if (kid->op_type == OP_NULL)
6799 kid = (SVOP*)kid->op_sibling;
6800 if (kid && kid->op_type == OP_CONST &&
6801 (kid->op_private & OPpCONST_BARE))
6803 o->op_flags |= OPf_SPECIAL;
6804 kid->op_private &= ~OPpCONST_STRICT;
6811 Perl_ck_unpack(pTHX_ OP *o)
6813 OP *kid = cLISTOPo->op_first;
6814 if (kid->op_sibling) {
6815 kid = kid->op_sibling;
6816 if (!kid->op_sibling)
6817 kid->op_sibling = newDEFSVOP();
6823 Perl_ck_substr(pTHX_ OP *o)
6826 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6827 OP *kid = cLISTOPo->op_first;
6829 if (kid->op_type == OP_NULL)
6830 kid = kid->op_sibling;
6832 kid->op_flags |= OPf_MOD;
6838 /* A peephole optimizer. We visit the ops in the order they're to execute.
6839 * See the comments at the top of this file for more details about when
6840 * peep() is called */
6843 Perl_peep(pTHX_ register OP *o)
6846 register OP* oldop = NULL;
6848 if (!o || o->op_opt)
6852 SAVEVPTR(PL_curcop);
6853 for (; o; o = o->op_next) {
6857 switch (o->op_type) {
6861 PL_curcop = ((COP*)o); /* for warnings */
6866 if (cSVOPo->op_private & OPpCONST_STRICT)
6867 no_bareword_allowed(o);
6869 case OP_METHOD_NAMED:
6870 /* Relocate sv to the pad for thread safety.
6871 * Despite being a "constant", the SV is written to,
6872 * for reference counts, sv_upgrade() etc. */
6874 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6875 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6876 /* If op_sv is already a PADTMP then it is being used by
6877 * some pad, so make a copy. */
6878 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6879 SvREADONLY_on(PAD_SVl(ix));
6880 SvREFCNT_dec(cSVOPo->op_sv);
6882 else if (o->op_type == OP_CONST
6883 && cSVOPo->op_sv == &PL_sv_undef) {
6884 /* PL_sv_undef is hack - it's unsafe to store it in the
6885 AV that is the pad, because av_fetch treats values of
6886 PL_sv_undef as a "free" AV entry and will merrily
6887 replace them with a new SV, causing pad_alloc to think
6888 that this pad slot is free. (When, clearly, it is not)
6890 SvOK_off(PAD_SVl(ix));
6891 SvPADTMP_on(PAD_SVl(ix));
6892 SvREADONLY_on(PAD_SVl(ix));
6895 SvREFCNT_dec(PAD_SVl(ix));
6896 SvPADTMP_on(cSVOPo->op_sv);
6897 PAD_SETSV(ix, cSVOPo->op_sv);
6898 /* XXX I don't know how this isn't readonly already. */
6899 SvREADONLY_on(PAD_SVl(ix));
6901 cSVOPo->op_sv = NULL;
6909 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6910 if (o->op_next->op_private & OPpTARGET_MY) {
6911 if (o->op_flags & OPf_STACKED) /* chained concats */
6912 goto ignore_optimization;
6914 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6915 o->op_targ = o->op_next->op_targ;
6916 o->op_next->op_targ = 0;
6917 o->op_private |= OPpTARGET_MY;
6920 op_null(o->op_next);
6922 ignore_optimization:
6926 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6928 break; /* Scalar stub must produce undef. List stub is noop */
6932 if (o->op_targ == OP_NEXTSTATE
6933 || o->op_targ == OP_DBSTATE
6934 || o->op_targ == OP_SETSTATE)
6936 PL_curcop = ((COP*)o);
6938 /* XXX: We avoid setting op_seq here to prevent later calls
6939 to peep() from mistakenly concluding that optimisation
6940 has already occurred. This doesn't fix the real problem,
6941 though (See 20010220.007). AMS 20010719 */
6942 /* op_seq functionality is now replaced by op_opt */
6943 if (oldop && o->op_next) {
6944 oldop->op_next = o->op_next;
6952 if (oldop && o->op_next) {
6953 oldop->op_next = o->op_next;
6961 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
6962 OP* const pop = (o->op_type == OP_PADAV) ?
6963 o->op_next : o->op_next->op_next;
6965 if (pop && pop->op_type == OP_CONST &&
6966 ((PL_op = pop->op_next)) &&
6967 pop->op_next->op_type == OP_AELEM &&
6968 !(pop->op_next->op_private &
6969 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6970 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6975 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
6976 no_bareword_allowed(pop);
6977 if (o->op_type == OP_GV)
6978 op_null(o->op_next);
6979 op_null(pop->op_next);
6981 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6982 o->op_next = pop->op_next->op_next;
6983 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6984 o->op_private = (U8)i;
6985 if (o->op_type == OP_GV) {
6990 o->op_flags |= OPf_SPECIAL;
6991 o->op_type = OP_AELEMFAST;
6997 if (o->op_next->op_type == OP_RV2SV) {
6998 if (!(o->op_next->op_private & OPpDEREF)) {
6999 op_null(o->op_next);
7000 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
7002 o->op_next = o->op_next->op_next;
7003 o->op_type = OP_GVSV;
7004 o->op_ppaddr = PL_ppaddr[OP_GVSV];
7007 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
7008 GV * const gv = cGVOPo_gv;
7009 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
7010 /* XXX could check prototype here instead of just carping */
7011 SV * const sv = sv_newmortal();
7012 gv_efullname3(sv, gv, NULL);
7013 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
7014 "%"SVf"() called too early to check prototype",
7018 else if (o->op_next->op_type == OP_READLINE
7019 && o->op_next->op_next->op_type == OP_CONCAT
7020 && (o->op_next->op_next->op_flags & OPf_STACKED))
7022 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7023 o->op_type = OP_RCATLINE;
7024 o->op_flags |= OPf_STACKED;
7025 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
7026 op_null(o->op_next->op_next);
7027 op_null(o->op_next);
7044 while (cLOGOP->op_other->op_type == OP_NULL)
7045 cLOGOP->op_other = cLOGOP->op_other->op_next;
7046 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
7052 while (cLOOP->op_redoop->op_type == OP_NULL)
7053 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
7054 peep(cLOOP->op_redoop);
7055 while (cLOOP->op_nextop->op_type == OP_NULL)
7056 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
7057 peep(cLOOP->op_nextop);
7058 while (cLOOP->op_lastop->op_type == OP_NULL)
7059 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
7060 peep(cLOOP->op_lastop);
7067 while (cPMOP->op_pmreplstart &&
7068 cPMOP->op_pmreplstart->op_type == OP_NULL)
7069 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
7070 peep(cPMOP->op_pmreplstart);
7075 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
7076 && ckWARN(WARN_SYNTAX))
7078 if (o->op_next->op_sibling &&
7079 o->op_next->op_sibling->op_type != OP_EXIT &&
7080 o->op_next->op_sibling->op_type != OP_WARN &&
7081 o->op_next->op_sibling->op_type != OP_DIE) {
7082 const line_t oldline = CopLINE(PL_curcop);
7084 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
7085 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7086 "Statement unlikely to be reached");
7087 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7088 "\t(Maybe you meant system() when you said exec()?)\n");
7089 CopLINE_set(PL_curcop, oldline);
7099 const char *key = NULL;
7104 if (((BINOP*)o)->op_last->op_type != OP_CONST)
7107 /* Make the CONST have a shared SV */
7108 svp = cSVOPx_svp(((BINOP*)o)->op_last);
7109 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7110 key = SvPV_const(sv, keylen);
7111 lexname = newSVpvn_share(key,
7112 SvUTF8(sv) ? -(I32)keylen : keylen,
7118 if ((o->op_private & (OPpLVAL_INTRO)))
7121 rop = (UNOP*)((BINOP*)o)->op_first;
7122 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7124 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7125 if (!SvPAD_TYPED(lexname))
7127 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
7128 if (!fields || !GvHV(*fields))
7130 key = SvPV_const(*svp, keylen);
7131 if (!hv_fetch(GvHV(*fields), key,
7132 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
7134 Perl_croak(aTHX_ "No such class field \"%s\" "
7135 "in variable %s of type %s",
7136 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
7149 SVOP *first_key_op, *key_op;
7151 if ((o->op_private & (OPpLVAL_INTRO))
7152 /* I bet there's always a pushmark... */
7153 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7154 /* hmmm, no optimization if list contains only one key. */
7156 rop = (UNOP*)((LISTOP*)o)->op_last;
7157 if (rop->op_type != OP_RV2HV)
7159 if (rop->op_first->op_type == OP_PADSV)
7160 /* @$hash{qw(keys here)} */
7161 rop = (UNOP*)rop->op_first;
7163 /* @{$hash}{qw(keys here)} */
7164 if (rop->op_first->op_type == OP_SCOPE
7165 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
7167 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
7173 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
7174 if (!SvPAD_TYPED(lexname))
7176 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
7177 if (!fields || !GvHV(*fields))
7179 /* Again guessing that the pushmark can be jumped over.... */
7180 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7181 ->op_first->op_sibling;
7182 for (key_op = first_key_op; key_op;
7183 key_op = (SVOP*)key_op->op_sibling) {
7184 if (key_op->op_type != OP_CONST)
7186 svp = cSVOPx_svp(key_op);
7187 key = SvPV_const(*svp, keylen);
7188 if (!hv_fetch(GvHV(*fields), key,
7189 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
7191 Perl_croak(aTHX_ "No such class field \"%s\" "
7192 "in variable %s of type %s",
7193 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
7200 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
7204 /* check that RHS of sort is a single plain array */
7205 OP *oright = cUNOPo->op_first;
7206 if (!oright || oright->op_type != OP_PUSHMARK)
7209 /* reverse sort ... can be optimised. */
7210 if (!cUNOPo->op_sibling) {
7211 /* Nothing follows us on the list. */
7212 OP * const reverse = o->op_next;
7214 if (reverse->op_type == OP_REVERSE &&
7215 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
7216 OP * const pushmark = cUNOPx(reverse)->op_first;
7217 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
7218 && (cUNOPx(pushmark)->op_sibling == o)) {
7219 /* reverse -> pushmark -> sort */
7220 o->op_private |= OPpSORT_REVERSE;
7222 pushmark->op_next = oright->op_next;
7228 /* make @a = sort @a act in-place */
7232 oright = cUNOPx(oright)->op_sibling;
7235 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
7236 oright = cUNOPx(oright)->op_sibling;
7240 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
7241 || oright->op_next != o
7242 || (oright->op_private & OPpLVAL_INTRO)
7246 /* o2 follows the chain of op_nexts through the LHS of the
7247 * assign (if any) to the aassign op itself */
7249 if (!o2 || o2->op_type != OP_NULL)
7252 if (!o2 || o2->op_type != OP_PUSHMARK)
7255 if (o2 && o2->op_type == OP_GV)
7258 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
7259 || (o2->op_private & OPpLVAL_INTRO)
7264 if (!o2 || o2->op_type != OP_NULL)
7267 if (!o2 || o2->op_type != OP_AASSIGN
7268 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
7271 /* check that the sort is the first arg on RHS of assign */
7273 o2 = cUNOPx(o2)->op_first;
7274 if (!o2 || o2->op_type != OP_NULL)
7276 o2 = cUNOPx(o2)->op_first;
7277 if (!o2 || o2->op_type != OP_PUSHMARK)
7279 if (o2->op_sibling != o)
7282 /* check the array is the same on both sides */
7283 if (oleft->op_type == OP_RV2AV) {
7284 if (oright->op_type != OP_RV2AV
7285 || !cUNOPx(oright)->op_first
7286 || cUNOPx(oright)->op_first->op_type != OP_GV
7287 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
7288 cGVOPx_gv(cUNOPx(oright)->op_first)
7292 else if (oright->op_type != OP_PADAV
7293 || oright->op_targ != oleft->op_targ
7297 /* transfer MODishness etc from LHS arg to RHS arg */
7298 oright->op_flags = oleft->op_flags;
7299 o->op_private |= OPpSORT_INPLACE;
7301 /* excise push->gv->rv2av->null->aassign */
7302 o2 = o->op_next->op_next;
7303 op_null(o2); /* PUSHMARK */
7305 if (o2->op_type == OP_GV) {
7306 op_null(o2); /* GV */
7309 op_null(o2); /* RV2AV or PADAV */
7310 o2 = o2->op_next->op_next;
7311 op_null(o2); /* AASSIGN */
7313 o->op_next = o2->op_next;
7319 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
7321 LISTOP *enter, *exlist;
7324 enter = (LISTOP *) o->op_next;
7327 if (enter->op_type == OP_NULL) {
7328 enter = (LISTOP *) enter->op_next;
7332 /* for $a (...) will have OP_GV then OP_RV2GV here.
7333 for (...) just has an OP_GV. */
7334 if (enter->op_type == OP_GV) {
7335 gvop = (OP *) enter;
7336 enter = (LISTOP *) enter->op_next;
7339 if (enter->op_type == OP_RV2GV) {
7340 enter = (LISTOP *) enter->op_next;
7346 if (enter->op_type != OP_ENTERITER)
7349 iter = enter->op_next;
7350 if (!iter || iter->op_type != OP_ITER)
7353 expushmark = enter->op_first;
7354 if (!expushmark || expushmark->op_type != OP_NULL
7355 || expushmark->op_targ != OP_PUSHMARK)
7358 exlist = (LISTOP *) expushmark->op_sibling;
7359 if (!exlist || exlist->op_type != OP_NULL
7360 || exlist->op_targ != OP_LIST)
7363 if (exlist->op_last != o) {
7364 /* Mmm. Was expecting to point back to this op. */
7367 theirmark = exlist->op_first;
7368 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
7371 if (theirmark->op_sibling != o) {
7372 /* There's something between the mark and the reverse, eg
7373 for (1, reverse (...))
7378 ourmark = ((LISTOP *)o)->op_first;
7379 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
7382 ourlast = ((LISTOP *)o)->op_last;
7383 if (!ourlast || ourlast->op_next != o)
7386 rv2av = ourmark->op_sibling;
7387 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
7388 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
7389 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
7390 /* We're just reversing a single array. */
7391 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
7392 enter->op_flags |= OPf_STACKED;
7395 /* We don't have control over who points to theirmark, so sacrifice
7397 theirmark->op_next = ourmark->op_next;
7398 theirmark->op_flags = ourmark->op_flags;
7399 ourlast->op_next = gvop ? gvop : (OP *) enter;
7402 enter->op_private |= OPpITER_REVERSED;
7403 iter->op_private |= OPpITER_REVERSED;
7410 UNOP *refgen, *rv2cv;
7413 /* I do not understand this, but if o->op_opt isn't set to 1,
7414 various tests in ext/B/t/bytecode.t fail with no readily
7420 if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID)
7423 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
7426 rv2gv = ((BINOP *)o)->op_last;
7427 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
7430 refgen = (UNOP *)((BINOP *)o)->op_first;
7432 if (!refgen || refgen->op_type != OP_REFGEN)
7435 exlist = (LISTOP *)refgen->op_first;
7436 if (!exlist || exlist->op_type != OP_NULL
7437 || exlist->op_targ != OP_LIST)
7440 if (exlist->op_first->op_type != OP_PUSHMARK)
7443 rv2cv = (UNOP*)exlist->op_last;
7445 if (rv2cv->op_type != OP_RV2CV)
7448 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
7449 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
7450 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
7452 o->op_private |= OPpASSIGN_CV_TO_GV;
7453 rv2gv->op_private |= OPpDONT_INIT_GV;
7454 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
7470 Perl_custom_op_name(pTHX_ const OP* o)
7473 const IV index = PTR2IV(o->op_ppaddr);
7477 if (!PL_custom_op_names) /* This probably shouldn't happen */
7478 return (char *)PL_op_name[OP_CUSTOM];
7480 keysv = sv_2mortal(newSViv(index));
7482 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7484 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7486 return SvPV_nolen(HeVAL(he));
7490 Perl_custom_op_desc(pTHX_ const OP* o)
7493 const IV index = PTR2IV(o->op_ppaddr);
7497 if (!PL_custom_op_descs)
7498 return (char *)PL_op_desc[OP_CUSTOM];
7500 keysv = sv_2mortal(newSViv(index));
7502 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7504 return (char *)PL_op_desc[OP_CUSTOM];
7506 return SvPV_nolen(HeVAL(he));
7511 /* Efficient sub that returns a constant scalar value. */
7513 const_sv_xsub(pTHX_ CV* cv)
7520 Perl_croak(aTHX_ "usage: %s::%s()",
7521 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7525 ST(0) = (SV*)XSANY.any_ptr;
7531 * c-indentation-style: bsd
7533 * indent-tabs-mode: t
7536 * ex: set ts=8 sts=4 sw=4 noet: