3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 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 **ptr = (I32 **) op;
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 ", Nullop" 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)
165 SV* tmpsv = sv_newmortal();
166 gv_efullname3(tmpsv, gv, Nullch);
167 return SvPV(tmpsv,n_a);
171 S_no_fh_allowed(pTHX_ OP *o)
173 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
179 S_too_few_arguments(pTHX_ OP *o, const char *name)
181 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
186 S_too_many_arguments(pTHX_ OP *o, const char *name)
188 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
193 S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
195 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
196 (int)n, name, t, OP_DESC(kid)));
200 S_no_bareword_allowed(pTHX_ const OP *o)
202 qerror(Perl_mess(aTHX_
203 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
207 /* "register" allocation */
210 Perl_allocmy(pTHX_ char *name)
214 /* complain about "my $<special_var>" etc etc */
215 if (!(PL_in_my == KEY_our ||
217 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
218 (name[1] == '_' && (*name == '$' || (int)strlen(name) > 2))))
220 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
221 /* 1999-02-27 mjd@plover.com */
223 p = strchr(name, '\0');
224 /* The next block assumes the buffer is at least 205 chars
225 long. At present, it's always at least 256 chars. */
227 strcpy(name+200, "...");
233 /* Move everything else down one character */
234 for (; p-name > 2; p--)
236 name[2] = toCTRL(name[1]);
239 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
242 /* check for duplicate declaration */
244 (bool)(PL_in_my == KEY_our),
245 (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, PL_in_my == KEY_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)
279 if (o->op_private & OPpREFCOUNTED) {
280 switch (o->op_type) {
288 refcnt = OpREFCNT_dec(o);
298 if (o->op_flags & OPf_KIDS) {
299 register OP *kid, *nextkid;
300 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
301 nextkid = kid->op_sibling; /* Get before next freeing kid */
307 type = (OPCODE)o->op_targ;
309 /* COP* is not cleared by op_clear() so that we may track line
310 * numbers etc even after null() */
311 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
319 Perl_op_clear(pTHX_ OP *o)
322 switch (o->op_type) {
323 case OP_NULL: /* Was holding old type, if any. */
324 case OP_ENTEREVAL: /* Was holding hints. */
328 if (!(o->op_flags & OPf_REF)
329 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
335 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
336 /* not an OP_PADAV replacement */
338 if (cPADOPo->op_padix > 0) {
339 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
340 * may still exist on the pad */
341 pad_swipe(cPADOPo->op_padix, TRUE);
342 cPADOPo->op_padix = 0;
345 SvREFCNT_dec(cSVOPo->op_sv);
346 cSVOPo->op_sv = Nullsv;
350 case OP_METHOD_NAMED:
352 SvREFCNT_dec(cSVOPo->op_sv);
353 cSVOPo->op_sv = Nullsv;
356 Even if op_clear does a pad_free for the target of the op,
357 pad_free doesn't actually remove the sv that exists in the pad;
358 instead it lives on. This results in that it could be reused as
359 a target later on when the pad was reallocated.
362 pad_swipe(o->op_targ,1);
371 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
375 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
376 SvREFCNT_dec(cSVOPo->op_sv);
377 cSVOPo->op_sv = Nullsv;
380 Safefree(cPVOPo->op_pv);
381 cPVOPo->op_pv = Nullch;
385 op_free(cPMOPo->op_pmreplroot);
389 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
390 /* No GvIN_PAD_off here, because other references may still
391 * exist on the pad */
392 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
395 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
402 HV *pmstash = PmopSTASH(cPMOPo);
403 if (pmstash && SvREFCNT(pmstash)) {
404 PMOP *pmop = HvPMROOT(pmstash);
405 PMOP *lastpmop = NULL;
407 if (cPMOPo == pmop) {
409 lastpmop->op_pmnext = pmop->op_pmnext;
411 HvPMROOT(pmstash) = pmop->op_pmnext;
415 pmop = pmop->op_pmnext;
418 PmopSTASH_free(cPMOPo);
420 cPMOPo->op_pmreplroot = Nullop;
421 /* we use the "SAFE" version of the PM_ macros here
422 * since sv_clean_all might release some PMOPs
423 * after PL_regex_padav has been cleared
424 * and the clearing of PL_regex_padav needs to
425 * happen before sv_clean_all
427 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
428 PM_SETRE_SAFE(cPMOPo, (REGEXP*)NULL);
430 if(PL_regex_pad) { /* We could be in destruction */
431 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
432 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
433 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
440 if (o->op_targ > 0) {
441 pad_free(o->op_targ);
447 S_cop_free(pTHX_ COP* cop)
449 Safefree(cop->cop_label); /* FIXME: treaddead ??? */
452 if (! specialWARN(cop->cop_warnings))
453 SvREFCNT_dec(cop->cop_warnings);
454 if (! specialCopIO(cop->cop_io)) {
458 char *s = SvPV(cop->cop_io,len);
459 Perl_warn(aTHX_ "io='%.*s'",(int) len,s); /* ??? --jhi */
462 SvREFCNT_dec(cop->cop_io);
468 Perl_op_null(pTHX_ OP *o)
470 if (o->op_type == OP_NULL)
473 o->op_targ = o->op_type;
474 o->op_type = OP_NULL;
475 o->op_ppaddr = PL_ppaddr[OP_NULL];
479 Perl_op_refcnt_lock(pTHX)
485 Perl_op_refcnt_unlock(pTHX)
490 /* Contextualizers */
492 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
495 Perl_linklist(pTHX_ OP *o)
501 /* establish postfix order */
502 if (cUNOPo->op_first) {
504 o->op_next = LINKLIST(cUNOPo->op_first);
505 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
507 kid->op_next = LINKLIST(kid->op_sibling);
519 Perl_scalarkids(pTHX_ OP *o)
521 if (o && o->op_flags & OPf_KIDS) {
523 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
530 S_scalarboolean(pTHX_ OP *o)
532 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
533 if (ckWARN(WARN_SYNTAX)) {
534 const line_t oldline = CopLINE(PL_curcop);
536 if (PL_copline != NOLINE)
537 CopLINE_set(PL_curcop, PL_copline);
538 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
539 CopLINE_set(PL_curcop, oldline);
546 Perl_scalar(pTHX_ OP *o)
550 /* assumes no premature commitment */
551 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
552 || o->op_type == OP_RETURN)
557 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
559 switch (o->op_type) {
561 scalar(cBINOPo->op_first);
566 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
570 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
571 if (!kPMOP->op_pmreplroot)
572 deprecate_old("implicit split to @_");
580 if (o->op_flags & OPf_KIDS) {
581 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
587 kid = cLISTOPo->op_first;
589 while ((kid = kid->op_sibling)) {
595 WITH_THR(PL_curcop = &PL_compiling);
600 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
606 WITH_THR(PL_curcop = &PL_compiling);
609 if (ckWARN(WARN_VOID))
610 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
616 Perl_scalarvoid(pTHX_ OP *o)
619 const char* useless = 0;
623 if (o->op_type == OP_NEXTSTATE
624 || o->op_type == OP_SETSTATE
625 || o->op_type == OP_DBSTATE
626 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
627 || o->op_targ == OP_SETSTATE
628 || o->op_targ == OP_DBSTATE)))
629 PL_curcop = (COP*)o; /* for warning below */
631 /* assumes no premature commitment */
632 want = o->op_flags & OPf_WANT;
633 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
634 || o->op_type == OP_RETURN)
639 if ((o->op_private & OPpTARGET_MY)
640 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
642 return scalar(o); /* As if inside SASSIGN */
645 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
647 switch (o->op_type) {
649 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
653 if (o->op_flags & OPf_STACKED)
657 if (o->op_private == 4)
729 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
730 useless = OP_DESC(o);
734 kid = cUNOPo->op_first;
735 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
736 kid->op_type != OP_TRANS) {
739 useless = "negative pattern binding (!~)";
746 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
747 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
748 useless = "a variable";
753 if (cSVOPo->op_private & OPpCONST_STRICT)
754 no_bareword_allowed(o);
756 if (ckWARN(WARN_VOID)) {
757 useless = "a constant";
758 /* don't warn on optimised away booleans, eg
759 * use constant Foo, 5; Foo || print; */
760 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
762 /* the constants 0 and 1 are permitted as they are
763 conventionally used as dummies in constructs like
764 1 while some_condition_with_side_effects; */
765 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
767 else if (SvPOK(sv)) {
768 /* perl4's way of mixing documentation and code
769 (before the invention of POD) was based on a
770 trick to mix nroff and perl code. The trick was
771 built upon these three nroff macros being used in
772 void context. The pink camel has the details in
773 the script wrapman near page 319. */
774 if (strnEQ(SvPVX(sv), "di", 2) ||
775 strnEQ(SvPVX(sv), "ds", 2) ||
776 strnEQ(SvPVX(sv), "ig", 2))
781 op_null(o); /* don't execute or even remember it */
785 o->op_type = OP_PREINC; /* pre-increment is faster */
786 o->op_ppaddr = PL_ppaddr[OP_PREINC];
790 o->op_type = OP_PREDEC; /* pre-decrement is faster */
791 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
798 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
803 if (o->op_flags & OPf_STACKED)
810 if (!(o->op_flags & OPf_KIDS))
819 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
826 /* all requires must return a boolean value */
827 o->op_flags &= ~OPf_WANT;
832 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
833 if (!kPMOP->op_pmreplroot)
834 deprecate_old("implicit split to @_");
838 if (useless && ckWARN(WARN_VOID))
839 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
844 Perl_listkids(pTHX_ OP *o)
846 if (o && o->op_flags & OPf_KIDS) {
848 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
855 Perl_list(pTHX_ OP *o)
859 /* assumes no premature commitment */
860 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
861 || o->op_type == OP_RETURN)
866 if ((o->op_private & OPpTARGET_MY)
867 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
869 return o; /* As if inside SASSIGN */
872 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
874 switch (o->op_type) {
877 list(cBINOPo->op_first);
882 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
890 if (!(o->op_flags & OPf_KIDS))
892 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
893 list(cBINOPo->op_first);
894 return gen_constant_list(o);
901 kid = cLISTOPo->op_first;
903 while ((kid = kid->op_sibling)) {
909 WITH_THR(PL_curcop = &PL_compiling);
913 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
919 WITH_THR(PL_curcop = &PL_compiling);
922 /* all requires must return a boolean value */
923 o->op_flags &= ~OPf_WANT;
930 Perl_scalarseq(pTHX_ OP *o)
933 if (o->op_type == OP_LINESEQ ||
934 o->op_type == OP_SCOPE ||
935 o->op_type == OP_LEAVE ||
936 o->op_type == OP_LEAVETRY)
939 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
940 if (kid->op_sibling) {
944 PL_curcop = &PL_compiling;
946 o->op_flags &= ~OPf_PARENS;
947 if (PL_hints & HINT_BLOCK_SCOPE)
948 o->op_flags |= OPf_PARENS;
951 o = newOP(OP_STUB, 0);
956 S_modkids(pTHX_ OP *o, I32 type)
958 if (o && o->op_flags & OPf_KIDS) {
960 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
966 /* Propagate lvalue ("modifiable") context to an op and it's children.
967 * 'type' represents the context type, roughly based on the type of op that
968 * would do the modifying, although local() is represented by OP_NULL.
969 * It's responsible for detecting things that can't be modified, flag
970 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
971 * might have to vivify a reference in $x), and so on.
973 * For example, "$a+1 = 2" would cause mod() to be called with o being
974 * OP_ADD and type being OP_SASSIGN, and would output an error.
978 Perl_mod(pTHX_ OP *o, I32 type)
981 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
984 if (!o || PL_error_count)
987 if ((o->op_private & OPpTARGET_MY)
988 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
993 switch (o->op_type) {
999 if (!(o->op_private & (OPpCONST_ARYBASE)))
1001 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1002 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1006 SAVEI32(PL_compiling.cop_arybase);
1007 PL_compiling.cop_arybase = 0;
1009 else if (type == OP_REFGEN)
1012 Perl_croak(aTHX_ "That use of $[ is unsupported");
1015 if (o->op_flags & OPf_PARENS)
1019 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1020 !(o->op_flags & OPf_STACKED)) {
1021 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1022 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1023 assert(cUNOPo->op_first->op_type == OP_NULL);
1024 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1027 else if (o->op_private & OPpENTERSUB_NOMOD)
1029 else { /* lvalue subroutine call */
1030 o->op_private |= OPpLVAL_INTRO;
1031 PL_modcount = RETURN_UNLIMITED_NUMBER;
1032 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1033 /* Backward compatibility mode: */
1034 o->op_private |= OPpENTERSUB_INARGS;
1037 else { /* Compile-time error message: */
1038 OP *kid = cUNOPo->op_first;
1042 if (kid->op_type == OP_PUSHMARK)
1044 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1046 "panic: unexpected lvalue entersub "
1047 "args: type/targ %ld:%"UVuf,
1048 (long)kid->op_type, (UV)kid->op_targ);
1049 kid = kLISTOP->op_first;
1051 while (kid->op_sibling)
1052 kid = kid->op_sibling;
1053 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1055 if (kid->op_type == OP_METHOD_NAMED
1056 || kid->op_type == OP_METHOD)
1060 NewOp(1101, newop, 1, UNOP);
1061 newop->op_type = OP_RV2CV;
1062 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1063 newop->op_first = Nullop;
1064 newop->op_next = (OP*)newop;
1065 kid->op_sibling = (OP*)newop;
1066 newop->op_private |= OPpLVAL_INTRO;
1070 if (kid->op_type != OP_RV2CV)
1072 "panic: unexpected lvalue entersub "
1073 "entry via type/targ %ld:%"UVuf,
1074 (long)kid->op_type, (UV)kid->op_targ);
1075 kid->op_private |= OPpLVAL_INTRO;
1076 break; /* Postpone until runtime */
1080 kid = kUNOP->op_first;
1081 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1082 kid = kUNOP->op_first;
1083 if (kid->op_type == OP_NULL)
1085 "Unexpected constant lvalue entersub "
1086 "entry via type/targ %ld:%"UVuf,
1087 (long)kid->op_type, (UV)kid->op_targ);
1088 if (kid->op_type != OP_GV) {
1089 /* Restore RV2CV to check lvalueness */
1091 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1092 okid->op_next = kid->op_next;
1093 kid->op_next = okid;
1096 okid->op_next = Nullop;
1097 okid->op_type = OP_RV2CV;
1099 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1100 okid->op_private |= OPpLVAL_INTRO;
1104 cv = GvCV(kGVOP_gv);
1114 /* grep, foreach, subcalls, refgen */
1115 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1117 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1118 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1120 : (o->op_type == OP_ENTERSUB
1121 ? "non-lvalue subroutine call"
1123 type ? PL_op_desc[type] : "local"));
1137 case OP_RIGHT_SHIFT:
1146 if (!(o->op_flags & OPf_STACKED))
1153 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1159 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1160 PL_modcount = RETURN_UNLIMITED_NUMBER;
1161 return o; /* Treat \(@foo) like ordinary list. */
1165 if (scalar_mod_type(o, type))
1167 ref(cUNOPo->op_first, o->op_type);
1171 if (type == OP_LEAVESUBLV)
1172 o->op_private |= OPpMAYBE_LVSUB;
1178 PL_modcount = RETURN_UNLIMITED_NUMBER;
1181 ref(cUNOPo->op_first, o->op_type);
1186 PL_hints |= HINT_BLOCK_SCOPE;
1201 PL_modcount = RETURN_UNLIMITED_NUMBER;
1202 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1203 return o; /* Treat \(@foo) like ordinary list. */
1204 if (scalar_mod_type(o, type))
1206 if (type == OP_LEAVESUBLV)
1207 o->op_private |= OPpMAYBE_LVSUB;
1211 if (!type) /* local() */
1212 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1213 PAD_COMPNAME_PV(o->op_targ));
1221 if (type != OP_SASSIGN)
1225 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1230 if (type == OP_LEAVESUBLV)
1231 o->op_private |= OPpMAYBE_LVSUB;
1233 pad_free(o->op_targ);
1234 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1235 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1236 if (o->op_flags & OPf_KIDS)
1237 mod(cBINOPo->op_first->op_sibling, type);
1242 ref(cBINOPo->op_first, o->op_type);
1243 if (type == OP_ENTERSUB &&
1244 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1245 o->op_private |= OPpLVAL_DEFER;
1246 if (type == OP_LEAVESUBLV)
1247 o->op_private |= OPpMAYBE_LVSUB;
1257 if (o->op_flags & OPf_KIDS)
1258 mod(cLISTOPo->op_last, type);
1263 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1265 else if (!(o->op_flags & OPf_KIDS))
1267 if (o->op_targ != OP_LIST) {
1268 mod(cBINOPo->op_first, type);
1274 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1279 if (type != OP_LEAVESUBLV)
1281 break; /* mod()ing was handled by ck_return() */
1284 /* [20011101.069] File test operators interpret OPf_REF to mean that
1285 their argument is a filehandle; thus \stat(".") should not set
1287 if (type == OP_REFGEN &&
1288 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1291 if (type != OP_LEAVESUBLV)
1292 o->op_flags |= OPf_MOD;
1294 if (type == OP_AASSIGN || type == OP_SASSIGN)
1295 o->op_flags |= OPf_SPECIAL|OPf_REF;
1296 else if (!type) { /* local() */
1299 o->op_private |= OPpLVAL_INTRO;
1300 o->op_flags &= ~OPf_SPECIAL;
1301 PL_hints |= HINT_BLOCK_SCOPE;
1306 if (ckWARN(WARN_SYNTAX)) {
1307 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1308 "Useless localization of %s", OP_DESC(o));
1312 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1313 && type != OP_LEAVESUBLV)
1314 o->op_flags |= OPf_REF;
1319 S_scalar_mod_type(pTHX_ const OP *o, I32 type)
1323 if (o->op_type == OP_RV2GV)
1347 case OP_RIGHT_SHIFT:
1366 S_is_handle_constructor(pTHX_ const OP *o, I32 argnum)
1368 switch (o->op_type) {
1376 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1389 Perl_refkids(pTHX_ OP *o, I32 type)
1391 if (o && o->op_flags & OPf_KIDS) {
1393 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1400 Perl_ref(pTHX_ OP *o, I32 type)
1404 if (!o || PL_error_count)
1407 switch (o->op_type) {
1409 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1410 !(o->op_flags & OPf_STACKED)) {
1411 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1412 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1413 assert(cUNOPo->op_first->op_type == OP_NULL);
1414 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1415 o->op_flags |= OPf_SPECIAL;
1420 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1424 if (type == OP_DEFINED)
1425 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1426 ref(cUNOPo->op_first, o->op_type);
1429 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1430 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1431 : type == OP_RV2HV ? OPpDEREF_HV
1433 o->op_flags |= OPf_MOD;
1438 o->op_flags |= OPf_MOD; /* XXX ??? */
1443 o->op_flags |= OPf_REF;
1446 if (type == OP_DEFINED)
1447 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1448 ref(cUNOPo->op_first, o->op_type);
1453 o->op_flags |= OPf_REF;
1458 if (!(o->op_flags & OPf_KIDS))
1460 ref(cBINOPo->op_first, type);
1464 ref(cBINOPo->op_first, o->op_type);
1465 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1466 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1467 : type == OP_RV2HV ? OPpDEREF_HV
1469 o->op_flags |= OPf_MOD;
1477 if (!(o->op_flags & OPf_KIDS))
1479 ref(cLISTOPo->op_last, type);
1489 S_dup_attrlist(pTHX_ OP *o)
1493 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1494 * where the first kid is OP_PUSHMARK and the remaining ones
1495 * are OP_CONST. We need to push the OP_CONST values.
1497 if (o->op_type == OP_CONST)
1498 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1500 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1501 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1502 if (o->op_type == OP_CONST)
1503 rop = append_elem(OP_LIST, rop,
1504 newSVOP(OP_CONST, o->op_flags,
1505 SvREFCNT_inc(cSVOPo->op_sv)));
1512 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1516 /* fake up C<use attributes $pkg,$rv,@attrs> */
1517 ENTER; /* need to protect against side-effects of 'use' */
1520 stashsv = newSVpv(HvNAME(stash), 0);
1522 stashsv = &PL_sv_no;
1524 #define ATTRSMODULE "attributes"
1525 #define ATTRSMODULE_PM "attributes.pm"
1529 /* Don't force the C<use> if we don't need it. */
1530 svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
1531 sizeof(ATTRSMODULE_PM)-1, 0);
1532 if (svp && *svp != &PL_sv_undef)
1533 ; /* already in %INC */
1535 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1536 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1540 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1541 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1543 prepend_elem(OP_LIST,
1544 newSVOP(OP_CONST, 0, stashsv),
1545 prepend_elem(OP_LIST,
1546 newSVOP(OP_CONST, 0,
1548 dup_attrlist(attrs))));
1554 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1556 OP *pack, *imop, *arg;
1562 assert(target->op_type == OP_PADSV ||
1563 target->op_type == OP_PADHV ||
1564 target->op_type == OP_PADAV);
1566 /* Ensure that attributes.pm is loaded. */
1567 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1569 /* Need package name for method call. */
1570 pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
1572 /* Build up the real arg-list. */
1574 stashsv = newSVpv(HvNAME(stash), 0);
1576 stashsv = &PL_sv_no;
1577 arg = newOP(OP_PADSV, 0);
1578 arg->op_targ = target->op_targ;
1579 arg = prepend_elem(OP_LIST,
1580 newSVOP(OP_CONST, 0, stashsv),
1581 prepend_elem(OP_LIST,
1582 newUNOP(OP_REFGEN, 0,
1583 mod(arg, OP_REFGEN)),
1584 dup_attrlist(attrs)));
1586 /* Fake up a method call to import */
1587 meth = newSVpvn("import", 6);
1588 (void)SvUPGRADE(meth, SVt_PVIV);
1589 (void)SvIOK_on(meth);
1590 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
1591 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1592 append_elem(OP_LIST,
1593 prepend_elem(OP_LIST, pack, list(arg)),
1594 newSVOP(OP_METHOD_NAMED, 0, meth)));
1595 imop->op_private |= OPpENTERSUB_NOMOD;
1597 /* Combine the ops. */
1598 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1602 =notfor apidoc apply_attrs_string
1604 Attempts to apply a list of attributes specified by the C<attrstr> and
1605 C<len> arguments to the subroutine identified by the C<cv> argument which
1606 is expected to be associated with the package identified by the C<stashpv>
1607 argument (see L<attributes>). It gets this wrong, though, in that it
1608 does not correctly identify the boundaries of the individual attribute
1609 specifications within C<attrstr>. This is not really intended for the
1610 public API, but has to be listed here for systems such as AIX which
1611 need an explicit export list for symbols. (It's called from XS code
1612 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1613 to respect attribute syntax properly would be welcome.
1619 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1620 const char *attrstr, STRLEN len)
1625 len = strlen(attrstr);
1629 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1631 const char *sstr = attrstr;
1632 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1633 attrs = append_elem(OP_LIST, attrs,
1634 newSVOP(OP_CONST, 0,
1635 newSVpvn(sstr, attrstr-sstr)));
1639 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1640 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1641 Nullsv, prepend_elem(OP_LIST,
1642 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1643 prepend_elem(OP_LIST,
1644 newSVOP(OP_CONST, 0,
1650 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1654 if (!o || PL_error_count)
1658 if (type == OP_LIST) {
1660 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1661 my_kid(kid, attrs, imopsp);
1662 } else if (type == OP_UNDEF) {
1664 } else if (type == OP_RV2SV || /* "our" declaration */
1666 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1667 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1668 yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
1669 OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
1671 GV *gv = cGVOPx_gv(cUNOPo->op_first);
1673 PL_in_my_stash = Nullhv;
1674 apply_attrs(GvSTASH(gv),
1675 (type == OP_RV2SV ? GvSV(gv) :
1676 type == OP_RV2AV ? (SV*)GvAV(gv) :
1677 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1680 o->op_private |= OPpOUR_INTRO;
1683 else if (type != OP_PADSV &&
1686 type != OP_PUSHMARK)
1688 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1690 PL_in_my == KEY_our ? "our" : "my"));
1693 else if (attrs && type != OP_PUSHMARK) {
1697 PL_in_my_stash = Nullhv;
1699 /* check for C<my Dog $spot> when deciding package */
1700 stash = PAD_COMPNAME_TYPE(o->op_targ);
1702 stash = PL_curstash;
1703 apply_attrs_my(stash, o, attrs, imopsp);
1705 o->op_flags |= OPf_MOD;
1706 o->op_private |= OPpLVAL_INTRO;
1711 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1714 int maybe_scalar = 0;
1716 /* [perl #17376]: this appears to be premature, and results in code such as
1717 C< our(%x); > executing in list mode rather than void mode */
1719 if (o->op_flags & OPf_PARENS)
1728 o = my_kid(o, attrs, &rops);
1730 if (maybe_scalar && o->op_type == OP_PADSV) {
1731 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1732 o->op_private |= OPpLVAL_INTRO;
1735 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1738 PL_in_my_stash = Nullhv;
1743 Perl_my(pTHX_ OP *o)
1745 return my_attrs(o, Nullop);
1749 Perl_sawparens(pTHX_ OP *o)
1752 o->op_flags |= OPf_PARENS;
1757 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1762 if (ckWARN(WARN_MISC) &&
1763 (left->op_type == OP_RV2AV ||
1764 left->op_type == OP_RV2HV ||
1765 left->op_type == OP_PADAV ||
1766 left->op_type == OP_PADHV)) {
1767 const char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
1768 right->op_type == OP_TRANS)
1769 ? right->op_type : OP_MATCH];
1770 const char *sample = ((left->op_type == OP_RV2AV ||
1771 left->op_type == OP_PADAV)
1772 ? "@array" : "%hash");
1773 Perl_warner(aTHX_ packWARN(WARN_MISC),
1774 "Applying %s to %s will act on scalar(%s)",
1775 desc, sample, sample);
1778 if (right->op_type == OP_CONST &&
1779 cSVOPx(right)->op_private & OPpCONST_BARE &&
1780 cSVOPx(right)->op_private & OPpCONST_STRICT)
1782 no_bareword_allowed(right);
1785 ismatchop = right->op_type == OP_MATCH ||
1786 right->op_type == OP_SUBST ||
1787 right->op_type == OP_TRANS;
1788 if (ismatchop && right->op_private & OPpTARGET_MY) {
1790 right->op_private &= ~OPpTARGET_MY;
1792 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1793 right->op_flags |= OPf_STACKED;
1794 if (right->op_type != OP_MATCH &&
1795 ! (right->op_type == OP_TRANS &&
1796 right->op_private & OPpTRANS_IDENTICAL))
1797 left = mod(left, right->op_type);
1798 if (right->op_type == OP_TRANS)
1799 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
1801 o = prepend_elem(right->op_type, scalar(left), right);
1803 return newUNOP(OP_NOT, 0, scalar(o));
1807 return bind_match(type, left,
1808 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
1812 Perl_invert(pTHX_ OP *o)
1816 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
1817 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1821 Perl_scope(pTHX_ OP *o)
1824 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1825 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1826 o->op_type = OP_LEAVE;
1827 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1829 else if (o->op_type == OP_LINESEQ) {
1831 o->op_type = OP_SCOPE;
1832 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1833 kid = ((LISTOP*)o)->op_first;
1834 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
1838 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
1843 /* XXX kept for BINCOMPAT only */
1845 Perl_save_hints(pTHX)
1847 Perl_croak(aTHX_ "internal error: obsolete function save_hints() called");
1851 Perl_block_start(pTHX_ int full)
1853 const int retval = PL_savestack_ix;
1854 pad_block_start(full);
1856 PL_hints &= ~HINT_BLOCK_SCOPE;
1857 SAVESPTR(PL_compiling.cop_warnings);
1858 if (! specialWARN(PL_compiling.cop_warnings)) {
1859 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1860 SAVEFREESV(PL_compiling.cop_warnings) ;
1862 SAVESPTR(PL_compiling.cop_io);
1863 if (! specialCopIO(PL_compiling.cop_io)) {
1864 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1865 SAVEFREESV(PL_compiling.cop_io) ;
1871 Perl_block_end(pTHX_ I32 floor, OP *seq)
1873 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1874 OP* retval = scalarseq(seq);
1876 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
1878 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
1886 const I32 offset = pad_findmy("$_");
1887 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
1888 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1891 OP *o = newOP(OP_PADSV, 0);
1892 o->op_targ = offset;
1898 Perl_newPROG(pTHX_ OP *o)
1903 PL_eval_root = newUNOP(OP_LEAVEEVAL,
1904 ((PL_in_eval & EVAL_KEEPERR)
1905 ? OPf_SPECIAL : 0), o);
1906 PL_eval_start = linklist(PL_eval_root);
1907 PL_eval_root->op_private |= OPpREFCOUNTED;
1908 OpREFCNT_set(PL_eval_root, 1);
1909 PL_eval_root->op_next = 0;
1910 CALL_PEEP(PL_eval_start);
1913 if (o->op_type == OP_STUB) {
1914 PL_comppad_name = 0;
1919 PL_main_root = scope(sawparens(scalarvoid(o)));
1920 PL_curcop = &PL_compiling;
1921 PL_main_start = LINKLIST(PL_main_root);
1922 PL_main_root->op_private |= OPpREFCOUNTED;
1923 OpREFCNT_set(PL_main_root, 1);
1924 PL_main_root->op_next = 0;
1925 CALL_PEEP(PL_main_start);
1928 /* Register with debugger */
1930 CV *cv = get_cv("DB::postponed", FALSE);
1934 XPUSHs((SV*)CopFILEGV(&PL_compiling));
1936 call_sv((SV*)cv, G_DISCARD);
1943 Perl_localize(pTHX_ OP *o, I32 lex)
1945 if (o->op_flags & OPf_PARENS)
1946 /* [perl #17376]: this appears to be premature, and results in code such as
1947 C< our(%x); > executing in list mode rather than void mode */
1954 if (ckWARN(WARN_PARENTHESIS)
1955 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
1957 char *s = PL_bufptr;
1960 /* some heuristics to detect a potential error */
1961 while (*s && (strchr(", \t\n", *s)))
1965 if (*s && strchr("@$%*", *s) && *++s
1966 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
1969 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
1971 while (*s && (strchr(", \t\n", *s)))
1977 if (sigil && (*s == ';' || *s == '=')) {
1978 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
1979 "Parentheses missing around \"%s\" list",
1980 lex ? (PL_in_my == KEY_our ? "our" : "my")
1988 o = mod(o, OP_NULL); /* a bit kludgey */
1990 PL_in_my_stash = Nullhv;
1995 Perl_jmaybe(pTHX_ OP *o)
1997 if (o->op_type == OP_LIST) {
1999 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2000 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2006 Perl_fold_constants(pTHX_ register OP *o)
2009 I32 type = o->op_type;
2012 if (PL_opargs[type] & OA_RETSCALAR)
2014 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2015 o->op_targ = pad_alloc(type, SVs_PADTMP);
2017 /* integerize op, unless it happens to be C<-foo>.
2018 * XXX should pp_i_negate() do magic string negation instead? */
2019 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2020 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2021 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2023 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2026 if (!(PL_opargs[type] & OA_FOLDCONST))
2031 /* XXX might want a ck_negate() for this */
2032 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2044 /* XXX what about the numeric ops? */
2045 if (PL_hints & HINT_LOCALE)
2050 goto nope; /* Don't try to run w/ errors */
2052 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2053 if ((curop->op_type != OP_CONST ||
2054 (curop->op_private & OPpCONST_BARE)) &&
2055 curop->op_type != OP_LIST &&
2056 curop->op_type != OP_SCALAR &&
2057 curop->op_type != OP_NULL &&
2058 curop->op_type != OP_PUSHMARK)
2064 curop = LINKLIST(o);
2068 sv = *(PL_stack_sp--);
2069 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2070 pad_swipe(o->op_targ, FALSE);
2071 else if (SvTEMP(sv)) { /* grab mortal temp? */
2072 (void)SvREFCNT_inc(sv);
2076 if (type == OP_RV2GV)
2077 return newGVOP(OP_GV, 0, (GV*)sv);
2078 return newSVOP(OP_CONST, 0, sv);
2085 Perl_gen_constant_list(pTHX_ register OP *o)
2088 const I32 oldtmps_floor = PL_tmps_floor;
2092 return o; /* Don't attempt to run with errors */
2094 PL_op = curop = LINKLIST(o);
2101 PL_tmps_floor = oldtmps_floor;
2103 o->op_type = OP_RV2AV;
2104 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2105 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2106 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2107 o->op_opt = 0; /* needs to be revisited in peep() */
2108 curop = ((UNOP*)o)->op_first;
2109 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2116 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2118 if (!o || o->op_type != OP_LIST)
2119 o = newLISTOP(OP_LIST, 0, o, Nullop);
2121 o->op_flags &= ~OPf_WANT;
2123 if (!(PL_opargs[type] & OA_MARK))
2124 op_null(cLISTOPo->op_first);
2126 o->op_type = (OPCODE)type;
2127 o->op_ppaddr = PL_ppaddr[type];
2128 o->op_flags |= flags;
2130 o = CHECKOP(type, o);
2131 if (o->op_type != (unsigned)type)
2134 return fold_constants(o);
2137 /* List constructors */
2140 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2148 if (first->op_type != (unsigned)type
2149 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2151 return newLISTOP(type, 0, first, last);
2154 if (first->op_flags & OPf_KIDS)
2155 ((LISTOP*)first)->op_last->op_sibling = last;
2157 first->op_flags |= OPf_KIDS;
2158 ((LISTOP*)first)->op_first = last;
2160 ((LISTOP*)first)->op_last = last;
2165 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2173 if (first->op_type != (unsigned)type)
2174 return prepend_elem(type, (OP*)first, (OP*)last);
2176 if (last->op_type != (unsigned)type)
2177 return append_elem(type, (OP*)first, (OP*)last);
2179 first->op_last->op_sibling = last->op_first;
2180 first->op_last = last->op_last;
2181 first->op_flags |= (last->op_flags & OPf_KIDS);
2189 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2197 if (last->op_type == (unsigned)type) {
2198 if (type == OP_LIST) { /* already a PUSHMARK there */
2199 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2200 ((LISTOP*)last)->op_first->op_sibling = first;
2201 if (!(first->op_flags & OPf_PARENS))
2202 last->op_flags &= ~OPf_PARENS;
2205 if (!(last->op_flags & OPf_KIDS)) {
2206 ((LISTOP*)last)->op_last = first;
2207 last->op_flags |= OPf_KIDS;
2209 first->op_sibling = ((LISTOP*)last)->op_first;
2210 ((LISTOP*)last)->op_first = first;
2212 last->op_flags |= OPf_KIDS;
2216 return newLISTOP(type, 0, first, last);
2222 Perl_newNULLLIST(pTHX)
2224 return newOP(OP_STUB, 0);
2228 Perl_force_list(pTHX_ OP *o)
2230 if (!o || o->op_type != OP_LIST)
2231 o = newLISTOP(OP_LIST, 0, o, Nullop);
2237 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2241 NewOp(1101, listop, 1, LISTOP);
2243 listop->op_type = (OPCODE)type;
2244 listop->op_ppaddr = PL_ppaddr[type];
2247 listop->op_flags = (U8)flags;
2251 else if (!first && last)
2254 first->op_sibling = last;
2255 listop->op_first = first;
2256 listop->op_last = last;
2257 if (type == OP_LIST) {
2259 pushop = newOP(OP_PUSHMARK, 0);
2260 pushop->op_sibling = first;
2261 listop->op_first = pushop;
2262 listop->op_flags |= OPf_KIDS;
2264 listop->op_last = pushop;
2267 return CHECKOP(type, listop);
2271 Perl_newOP(pTHX_ I32 type, I32 flags)
2274 NewOp(1101, o, 1, OP);
2275 o->op_type = (OPCODE)type;
2276 o->op_ppaddr = PL_ppaddr[type];
2277 o->op_flags = (U8)flags;
2280 o->op_private = (U8)(0 | (flags >> 8));
2281 if (PL_opargs[type] & OA_RETSCALAR)
2283 if (PL_opargs[type] & OA_TARGET)
2284 o->op_targ = pad_alloc(type, SVs_PADTMP);
2285 return CHECKOP(type, o);
2289 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2294 first = newOP(OP_STUB, 0);
2295 if (PL_opargs[type] & OA_MARK)
2296 first = force_list(first);
2298 NewOp(1101, unop, 1, UNOP);
2299 unop->op_type = (OPCODE)type;
2300 unop->op_ppaddr = PL_ppaddr[type];
2301 unop->op_first = first;
2302 unop->op_flags = flags | OPf_KIDS;
2303 unop->op_private = (U8)(1 | (flags >> 8));
2304 unop = (UNOP*) CHECKOP(type, unop);
2308 return fold_constants((OP *) unop);
2312 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2315 NewOp(1101, binop, 1, BINOP);
2318 first = newOP(OP_NULL, 0);
2320 binop->op_type = (OPCODE)type;
2321 binop->op_ppaddr = PL_ppaddr[type];
2322 binop->op_first = first;
2323 binop->op_flags = flags | OPf_KIDS;
2326 binop->op_private = (U8)(1 | (flags >> 8));
2329 binop->op_private = (U8)(2 | (flags >> 8));
2330 first->op_sibling = last;
2333 binop = (BINOP*)CHECKOP(type, binop);
2334 if (binop->op_next || binop->op_type != (OPCODE)type)
2337 binop->op_last = binop->op_first->op_sibling;
2339 return fold_constants((OP *)binop);
2343 uvcompare(const void *a, const void *b)
2345 if (*((const UV *)a) < (*(const UV *)b))
2347 if (*((const UV *)a) > (*(const UV *)b))
2349 if (*((const UV *)a+1) < (*(const UV *)b+1))
2351 if (*((const UV *)a+1) > (*(const UV *)b+1))
2357 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2359 SV *tstr = ((SVOP*)expr)->op_sv;
2360 SV *rstr = ((SVOP*)repl)->op_sv;
2363 U8 *t = (U8*)SvPV(tstr, tlen);
2364 U8 *r = (U8*)SvPV(rstr, rlen);
2371 register short *tbl;
2373 PL_hints |= HINT_BLOCK_SCOPE;
2374 complement = o->op_private & OPpTRANS_COMPLEMENT;
2375 del = o->op_private & OPpTRANS_DELETE;
2376 squash = o->op_private & OPpTRANS_SQUASH;
2379 o->op_private |= OPpTRANS_FROM_UTF;
2382 o->op_private |= OPpTRANS_TO_UTF;
2384 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2385 SV* listsv = newSVpvn("# comment\n",10);
2387 U8* tend = t + tlen;
2388 U8* rend = r + rlen;
2402 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2403 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2409 tsave = t = bytes_to_utf8(t, &len);
2412 if (!to_utf && rlen) {
2414 rsave = r = bytes_to_utf8(r, &len);
2418 /* There are several snags with this code on EBCDIC:
2419 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2420 2. scan_const() in toke.c has encoded chars in native encoding which makes
2421 ranges at least in EBCDIC 0..255 range the bottom odd.
2425 U8 tmpbuf[UTF8_MAXBYTES+1];
2428 New(1109, cp, 2*tlen, UV);
2430 transv = newSVpvn("",0);
2432 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2434 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2436 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2440 cp[2*i+1] = cp[2*i];
2444 qsort(cp, i, 2*sizeof(UV), uvcompare);
2445 for (j = 0; j < i; j++) {
2447 diff = val - nextmin;
2449 t = uvuni_to_utf8(tmpbuf,nextmin);
2450 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2452 U8 range_mark = UTF_TO_NATIVE(0xff);
2453 t = uvuni_to_utf8(tmpbuf, val - 1);
2454 sv_catpvn(transv, (char *)&range_mark, 1);
2455 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2462 t = uvuni_to_utf8(tmpbuf,nextmin);
2463 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2465 U8 range_mark = UTF_TO_NATIVE(0xff);
2466 sv_catpvn(transv, (char *)&range_mark, 1);
2468 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2469 UNICODE_ALLOW_SUPER);
2470 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2471 t = (U8*)SvPVX(transv);
2472 tlen = SvCUR(transv);
2476 else if (!rlen && !del) {
2477 r = t; rlen = tlen; rend = tend;
2480 if ((!rlen && !del) || t == r ||
2481 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2483 o->op_private |= OPpTRANS_IDENTICAL;
2487 while (t < tend || tfirst <= tlast) {
2488 /* see if we need more "t" chars */
2489 if (tfirst > tlast) {
2490 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2492 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2494 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2501 /* now see if we need more "r" chars */
2502 if (rfirst > rlast) {
2504 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2506 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2508 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2517 rfirst = rlast = 0xffffffff;
2521 /* now see which range will peter our first, if either. */
2522 tdiff = tlast - tfirst;
2523 rdiff = rlast - rfirst;
2530 if (rfirst == 0xffffffff) {
2531 diff = tdiff; /* oops, pretend rdiff is infinite */
2533 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2534 (long)tfirst, (long)tlast);
2536 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2540 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2541 (long)tfirst, (long)(tfirst + diff),
2544 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2545 (long)tfirst, (long)rfirst);
2547 if (rfirst + diff > max)
2548 max = rfirst + diff;
2550 grows = (tfirst < rfirst &&
2551 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2563 else if (max > 0xff)
2568 Safefree(cPVOPo->op_pv);
2569 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2570 SvREFCNT_dec(listsv);
2572 SvREFCNT_dec(transv);
2574 if (!del && havefinal && rlen)
2575 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2576 newSVuv((UV)final), 0);
2579 o->op_private |= OPpTRANS_GROWS;
2591 tbl = (short*)cPVOPo->op_pv;
2593 Zero(tbl, 256, short);
2594 for (i = 0; i < (I32)tlen; i++)
2596 for (i = 0, j = 0; i < 256; i++) {
2598 if (j >= (I32)rlen) {
2607 if (i < 128 && r[j] >= 128)
2617 o->op_private |= OPpTRANS_IDENTICAL;
2619 else if (j >= (I32)rlen)
2622 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2623 tbl[0x100] = rlen - j;
2624 for (i=0; i < (I32)rlen - j; i++)
2625 tbl[0x101+i] = r[j+i];
2629 if (!rlen && !del) {
2632 o->op_private |= OPpTRANS_IDENTICAL;
2634 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2635 o->op_private |= OPpTRANS_IDENTICAL;
2637 for (i = 0; i < 256; i++)
2639 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
2640 if (j >= (I32)rlen) {
2642 if (tbl[t[i]] == -1)
2648 if (tbl[t[i]] == -1) {
2649 if (t[i] < 128 && r[j] >= 128)
2656 o->op_private |= OPpTRANS_GROWS;
2664 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2668 NewOp(1101, pmop, 1, PMOP);
2669 pmop->op_type = (OPCODE)type;
2670 pmop->op_ppaddr = PL_ppaddr[type];
2671 pmop->op_flags = (U8)flags;
2672 pmop->op_private = (U8)(0 | (flags >> 8));
2674 if (PL_hints & HINT_RE_TAINT)
2675 pmop->op_pmpermflags |= PMf_RETAINT;
2676 if (PL_hints & HINT_LOCALE)
2677 pmop->op_pmpermflags |= PMf_LOCALE;
2678 pmop->op_pmflags = pmop->op_pmpermflags;
2683 if(av_len((AV*) PL_regex_pad[0]) > -1) {
2684 repointer = av_pop((AV*)PL_regex_pad[0]);
2685 pmop->op_pmoffset = SvIV(repointer);
2686 SvREPADTMP_off(repointer);
2687 sv_setiv(repointer,0);
2689 repointer = newSViv(0);
2690 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2691 pmop->op_pmoffset = av_len(PL_regex_padav);
2692 PL_regex_pad = AvARRAY(PL_regex_padav);
2697 /* link into pm list */
2698 if (type != OP_TRANS && PL_curstash) {
2699 pmop->op_pmnext = HvPMROOT(PL_curstash);
2700 HvPMROOT(PL_curstash) = pmop;
2701 PmopSTASH_set(pmop,PL_curstash);
2704 return CHECKOP(type, pmop);
2707 /* Given some sort of match op o, and an expression expr containing a
2708 * pattern, either compile expr into a regex and attach it to o (if it's
2709 * constant), or convert expr into a runtime regcomp op sequence (if it's
2712 * isreg indicates that the pattern is part of a regex construct, eg
2713 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
2714 * split "pattern", which aren't. In the former case, expr will be a list
2715 * if the pattern contains more than one term (eg /a$b/) or if it contains
2716 * a replacement, ie s/// or tr///.
2720 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
2724 I32 repl_has_vars = 0;
2728 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
2729 /* last element in list is the replacement; pop it */
2731 repl = cLISTOPx(expr)->op_last;
2732 kid = cLISTOPx(expr)->op_first;
2733 while (kid->op_sibling != repl)
2734 kid = kid->op_sibling;
2735 kid->op_sibling = Nullop;
2736 cLISTOPx(expr)->op_last = kid;
2739 if (isreg && expr->op_type == OP_LIST &&
2740 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
2742 /* convert single element list to element */
2744 expr = cLISTOPx(oe)->op_first->op_sibling;
2745 cLISTOPx(oe)->op_first->op_sibling = Nullop;
2746 cLISTOPx(oe)->op_last = Nullop;
2750 if (o->op_type == OP_TRANS) {
2751 return pmtrans(o, expr, repl);
2754 reglist = isreg && expr->op_type == OP_LIST;
2758 PL_hints |= HINT_BLOCK_SCOPE;
2761 if (expr->op_type == OP_CONST) {
2763 SV *pat = ((SVOP*)expr)->op_sv;
2764 char *p = SvPV(pat, plen);
2765 if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
2766 sv_setpvn(pat, "\\s+", 3);
2767 p = SvPV(pat, plen);
2768 pm->op_pmflags |= PMf_SKIPWHITE;
2771 pm->op_pmdynflags |= PMdf_UTF8;
2772 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
2773 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
2774 pm->op_pmflags |= PMf_WHITE;
2778 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2779 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2781 : OP_REGCMAYBE),0,expr);
2783 NewOp(1101, rcop, 1, LOGOP);
2784 rcop->op_type = OP_REGCOMP;
2785 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2786 rcop->op_first = scalar(expr);
2787 rcop->op_flags |= OPf_KIDS
2788 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
2789 | (reglist ? OPf_STACKED : 0);
2790 rcop->op_private = 1;
2793 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
2795 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
2798 /* establish postfix order */
2799 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2801 rcop->op_next = expr;
2802 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2805 rcop->op_next = LINKLIST(expr);
2806 expr->op_next = (OP*)rcop;
2809 prepend_elem(o->op_type, scalar((OP*)rcop), o);
2814 if (pm->op_pmflags & PMf_EVAL) {
2816 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
2817 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
2819 else if (repl->op_type == OP_CONST)
2823 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
2824 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
2825 if (curop->op_type == OP_GV) {
2826 GV *gv = cGVOPx_gv(curop);
2828 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
2831 else if (curop->op_type == OP_RV2CV)
2833 else if (curop->op_type == OP_RV2SV ||
2834 curop->op_type == OP_RV2AV ||
2835 curop->op_type == OP_RV2HV ||
2836 curop->op_type == OP_RV2GV) {
2837 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2840 else if (curop->op_type == OP_PADSV ||
2841 curop->op_type == OP_PADAV ||
2842 curop->op_type == OP_PADHV ||
2843 curop->op_type == OP_PADANY) {
2846 else if (curop->op_type == OP_PUSHRE)
2847 ; /* Okay here, dangerous in newASSIGNOP */
2857 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
2858 pm->op_pmflags |= PMf_CONST; /* const for long enough */
2859 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
2860 prepend_elem(o->op_type, scalar(repl), o);
2863 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
2864 pm->op_pmflags |= PMf_MAYBE_CONST;
2865 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2867 NewOp(1101, rcop, 1, LOGOP);
2868 rcop->op_type = OP_SUBSTCONT;
2869 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
2870 rcop->op_first = scalar(repl);
2871 rcop->op_flags |= OPf_KIDS;
2872 rcop->op_private = 1;
2875 /* establish postfix order */
2876 rcop->op_next = LINKLIST(repl);
2877 repl->op_next = (OP*)rcop;
2879 pm->op_pmreplroot = scalar((OP*)rcop);
2880 pm->op_pmreplstart = LINKLIST(rcop);
2889 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
2892 NewOp(1101, svop, 1, SVOP);
2893 svop->op_type = (OPCODE)type;
2894 svop->op_ppaddr = PL_ppaddr[type];
2896 svop->op_next = (OP*)svop;
2897 svop->op_flags = (U8)flags;
2898 if (PL_opargs[type] & OA_RETSCALAR)
2900 if (PL_opargs[type] & OA_TARGET)
2901 svop->op_targ = pad_alloc(type, SVs_PADTMP);
2902 return CHECKOP(type, svop);
2906 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2909 NewOp(1101, padop, 1, PADOP);
2910 padop->op_type = (OPCODE)type;
2911 padop->op_ppaddr = PL_ppaddr[type];
2912 padop->op_padix = pad_alloc(type, SVs_PADTMP);
2913 SvREFCNT_dec(PAD_SVl(padop->op_padix));
2914 PAD_SETSV(padop->op_padix, sv);
2917 padop->op_next = (OP*)padop;
2918 padop->op_flags = (U8)flags;
2919 if (PL_opargs[type] & OA_RETSCALAR)
2921 if (PL_opargs[type] & OA_TARGET)
2922 padop->op_targ = pad_alloc(type, SVs_PADTMP);
2923 return CHECKOP(type, padop);
2927 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
2932 return newPADOP(type, flags, SvREFCNT_inc(gv));
2934 return newSVOP(type, flags, SvREFCNT_inc(gv));
2939 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
2942 NewOp(1101, pvop, 1, PVOP);
2943 pvop->op_type = (OPCODE)type;
2944 pvop->op_ppaddr = PL_ppaddr[type];
2946 pvop->op_next = (OP*)pvop;
2947 pvop->op_flags = (U8)flags;
2948 if (PL_opargs[type] & OA_RETSCALAR)
2950 if (PL_opargs[type] & OA_TARGET)
2951 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
2952 return CHECKOP(type, pvop);
2956 Perl_package(pTHX_ OP *o)
2961 save_hptr(&PL_curstash);
2962 save_item(PL_curstname);
2964 name = SvPV(cSVOPo->op_sv, len);
2965 PL_curstash = gv_stashpvn(name, len, TRUE);
2966 sv_setpvn(PL_curstname, name, len);
2969 PL_hints |= HINT_BLOCK_SCOPE;
2970 PL_copline = NOLINE;
2975 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
2981 if (idop->op_type != OP_CONST)
2982 Perl_croak(aTHX_ "Module name must be constant");
2986 if (version != Nullop) {
2987 SV *vesv = ((SVOP*)version)->op_sv;
2989 if (arg == Nullop && !SvNIOKp(vesv)) {
2996 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
2997 Perl_croak(aTHX_ "Version number must be constant number");
2999 /* Make copy of idop so we don't free it twice */
3000 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3002 /* Fake up a method call to VERSION */
3003 meth = newSVpvn("VERSION",7);
3004 sv_upgrade(meth, SVt_PVIV);
3005 (void)SvIOK_on(meth);
3006 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3007 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3008 append_elem(OP_LIST,
3009 prepend_elem(OP_LIST, pack, list(version)),
3010 newSVOP(OP_METHOD_NAMED, 0, meth)));
3014 /* Fake up an import/unimport */
3015 if (arg && arg->op_type == OP_STUB)
3016 imop = arg; /* no import on explicit () */
3017 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3018 imop = Nullop; /* use 5.0; */
3023 /* Make copy of idop so we don't free it twice */
3024 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3026 /* Fake up a method call to import/unimport */
3027 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);
3028 (void)SvUPGRADE(meth, SVt_PVIV);
3029 (void)SvIOK_on(meth);
3030 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3031 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3032 append_elem(OP_LIST,
3033 prepend_elem(OP_LIST, pack, list(arg)),
3034 newSVOP(OP_METHOD_NAMED, 0, meth)));
3037 /* Fake up the BEGIN {}, which does its thing immediately. */
3039 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3042 append_elem(OP_LINESEQ,
3043 append_elem(OP_LINESEQ,
3044 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, idop)),
3045 newSTATEOP(0, Nullch, veop)),
3046 newSTATEOP(0, Nullch, imop) ));
3048 /* The "did you use incorrect case?" warning used to be here.
3049 * The problem is that on case-insensitive filesystems one
3050 * might get false positives for "use" (and "require"):
3051 * "use Strict" or "require CARP" will work. This causes
3052 * portability problems for the script: in case-strict
3053 * filesystems the script will stop working.
3055 * The "incorrect case" warning checked whether "use Foo"
3056 * imported "Foo" to your namespace, but that is wrong, too:
3057 * there is no requirement nor promise in the language that
3058 * a Foo.pm should or would contain anything in package "Foo".
3060 * There is very little Configure-wise that can be done, either:
3061 * the case-sensitivity of the build filesystem of Perl does not
3062 * help in guessing the case-sensitivity of the runtime environment.
3065 PL_hints |= HINT_BLOCK_SCOPE;
3066 PL_copline = NOLINE;
3068 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3072 =head1 Embedding Functions
3074 =for apidoc load_module
3076 Loads the module whose name is pointed to by the string part of name.
3077 Note that the actual module name, not its filename, should be given.
3078 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3079 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3080 (or 0 for no flags). ver, if specified, provides version semantics
3081 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3082 arguments can be used to specify arguments to the module's import()
3083 method, similar to C<use Foo::Bar VERSION LIST>.
3088 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3091 va_start(args, ver);
3092 vload_module(flags, name, ver, &args);
3096 #ifdef PERL_IMPLICIT_CONTEXT
3098 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3102 va_start(args, ver);
3103 vload_module(flags, name, ver, &args);
3109 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3111 OP *modname, *veop, *imop;
3113 modname = newSVOP(OP_CONST, 0, name);
3114 modname->op_private |= OPpCONST_BARE;
3116 veop = newSVOP(OP_CONST, 0, ver);
3120 if (flags & PERL_LOADMOD_NOIMPORT) {
3121 imop = sawparens(newNULLLIST());
3123 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3124 imop = va_arg(*args, OP*);
3129 sv = va_arg(*args, SV*);
3131 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3132 sv = va_arg(*args, SV*);
3136 const line_t ocopline = PL_copline;
3137 COP * const ocurcop = PL_curcop;
3138 const int oexpect = PL_expect;
3140 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3141 veop, modname, imop);
3142 PL_expect = oexpect;
3143 PL_copline = ocopline;
3144 PL_curcop = ocurcop;
3149 Perl_dofile(pTHX_ OP *term)
3154 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3155 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
3156 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3158 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3159 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3160 append_elem(OP_LIST, term,
3161 scalar(newUNOP(OP_RV2CV, 0,
3166 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3172 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3174 return newBINOP(OP_LSLICE, flags,
3175 list(force_list(subscript)),
3176 list(force_list(listval)) );
3180 S_list_assignment(pTHX_ register const OP *o)
3185 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3186 o = cUNOPo->op_first;
3188 if (o->op_type == OP_COND_EXPR) {
3189 const I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3190 const I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3195 yyerror("Assignment to both a list and a scalar");
3199 if (o->op_type == OP_LIST &&
3200 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3201 o->op_private & OPpLVAL_INTRO)
3204 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3205 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3206 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3209 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3212 if (o->op_type == OP_RV2SV)
3219 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3224 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3225 return newLOGOP(optype, 0,
3226 mod(scalar(left), optype),
3227 newUNOP(OP_SASSIGN, 0, scalar(right)));
3230 return newBINOP(optype, OPf_STACKED,
3231 mod(scalar(left), optype), scalar(right));
3235 if (list_assignment(left)) {
3239 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3240 left = mod(left, OP_AASSIGN);
3248 /* optimise C<my @x = ()> to C<my @x>, and likewise for hashes */
3249 if ((left->op_type == OP_PADAV || left->op_type == OP_PADHV)
3250 && right->op_type == OP_STUB
3251 && (left->op_private & OPpLVAL_INTRO))
3254 left->op_flags &= ~(OPf_REF|OPf_SPECIAL);
3257 curop = list(force_list(left));
3258 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3259 o->op_private = (U8)(0 | (flags >> 8));
3261 /* PL_generation sorcery:
3262 * an assignment like ($a,$b) = ($c,$d) is easier than
3263 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3264 * To detect whether there are common vars, the global var
3265 * PL_generation is incremented for each assign op we compile.
3266 * Then, while compiling the assign op, we run through all the
3267 * variables on both sides of the assignment, setting a spare slot
3268 * in each of them to PL_generation. If any of them already have
3269 * that value, we know we've got commonality. We could use a
3270 * single bit marker, but then we'd have to make 2 passes, first
3271 * to clear the flag, then to test and set it. To find somewhere
3272 * to store these values, evil chicanery is done with SvCUR().
3275 if (!(left->op_private & OPpLVAL_INTRO)) {
3278 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3279 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3280 if (curop->op_type == OP_GV) {
3281 GV *gv = cGVOPx_gv(curop);
3282 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3284 SvCUR(gv) = PL_generation;
3286 else if (curop->op_type == OP_PADSV ||
3287 curop->op_type == OP_PADAV ||
3288 curop->op_type == OP_PADHV ||
3289 curop->op_type == OP_PADANY)
3291 if (PAD_COMPNAME_GEN(curop->op_targ)
3292 == (STRLEN)PL_generation)
3294 PAD_COMPNAME_GEN(curop->op_targ)
3298 else if (curop->op_type == OP_RV2CV)
3300 else if (curop->op_type == OP_RV2SV ||
3301 curop->op_type == OP_RV2AV ||
3302 curop->op_type == OP_RV2HV ||
3303 curop->op_type == OP_RV2GV) {
3304 if (lastop->op_type != OP_GV) /* funny deref? */
3307 else if (curop->op_type == OP_PUSHRE) {
3308 if (((PMOP*)curop)->op_pmreplroot) {
3310 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3311 ((PMOP*)curop)->op_pmreplroot));
3313 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3315 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3317 SvCUR(gv) = PL_generation;
3326 o->op_private |= OPpASSIGN_COMMON;
3328 if (right && right->op_type == OP_SPLIT) {
3330 if ((tmpop = ((LISTOP*)right)->op_first) &&
3331 tmpop->op_type == OP_PUSHRE)
3333 PMOP *pm = (PMOP*)tmpop;
3334 if (left->op_type == OP_RV2AV &&
3335 !(left->op_private & OPpLVAL_INTRO) &&
3336 !(o->op_private & OPpASSIGN_COMMON) )
3338 tmpop = ((UNOP*)left)->op_first;
3339 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3341 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3342 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3344 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3345 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3347 pm->op_pmflags |= PMf_ONCE;
3348 tmpop = cUNOPo->op_first; /* to list (nulled) */
3349 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3350 tmpop->op_sibling = Nullop; /* don't free split */
3351 right->op_next = tmpop->op_next; /* fix starting loc */
3352 op_free(o); /* blow off assign */
3353 right->op_flags &= ~OPf_WANT;
3354 /* "I don't know and I don't care." */
3359 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3360 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3362 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3364 sv_setiv(sv, PL_modcount+1);
3372 right = newOP(OP_UNDEF, 0);
3373 if (right->op_type == OP_READLINE) {
3374 right->op_flags |= OPf_STACKED;
3375 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3378 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3379 o = newBINOP(OP_SASSIGN, flags,
3380 scalar(right), mod(scalar(left), OP_SASSIGN) );
3392 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3394 const U32 seq = intro_my();
3397 NewOp(1101, cop, 1, COP);
3398 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3399 cop->op_type = OP_DBSTATE;
3400 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3403 cop->op_type = OP_NEXTSTATE;
3404 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3406 cop->op_flags = (U8)flags;
3407 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3409 cop->op_private |= NATIVE_HINTS;
3411 PL_compiling.op_private = cop->op_private;
3412 cop->op_next = (OP*)cop;
3415 cop->cop_label = label;
3416 PL_hints |= HINT_BLOCK_SCOPE;
3419 cop->cop_arybase = PL_curcop->cop_arybase;
3420 if (specialWARN(PL_curcop->cop_warnings))
3421 cop->cop_warnings = PL_curcop->cop_warnings ;
3423 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3424 if (specialCopIO(PL_curcop->cop_io))
3425 cop->cop_io = PL_curcop->cop_io;
3427 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3430 if (PL_copline == NOLINE)
3431 CopLINE_set(cop, CopLINE(PL_curcop));
3433 CopLINE_set(cop, PL_copline);
3434 PL_copline = NOLINE;
3437 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3439 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3441 CopSTASH_set(cop, PL_curstash);
3443 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3444 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3445 if (svp && *svp != &PL_sv_undef ) {
3446 (void)SvIOK_on(*svp);
3447 SvIVX(*svp) = PTR2IV(cop);
3451 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3456 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3458 return new_logop(type, flags, &first, &other);
3462 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3466 OP *first = *firstp;
3467 OP *other = *otherp;
3469 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3470 return newBINOP(type, flags, scalar(first), scalar(other));
3472 scalarboolean(first);
3473 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3474 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3475 if (type == OP_AND || type == OP_OR) {
3481 first = *firstp = cUNOPo->op_first;
3483 first->op_next = o->op_next;
3484 cUNOPo->op_first = Nullop;
3488 if (first->op_type == OP_CONST) {
3489 if (first->op_private & OPpCONST_STRICT)
3490 no_bareword_allowed(first);
3491 else if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3492 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3493 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
3494 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
3495 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
3498 if (other->op_type == OP_CONST)
3499 other->op_private |= OPpCONST_SHORTCIRCUIT;
3503 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
3504 const OP *o2 = other;
3505 if ( ! (o2->op_type == OP_LIST
3506 && (( o2 = cUNOPx(o2)->op_first))
3507 && o2->op_type == OP_PUSHMARK
3508 && (( o2 = o2->op_sibling)) )
3511 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
3512 || o2->op_type == OP_PADHV)
3513 && o2->op_private & OPpLVAL_INTRO
3514 && ckWARN(WARN_DEPRECATED))
3516 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
3517 "Deprecated use of my() in false conditional");
3522 if (first->op_type == OP_CONST)
3523 first->op_private |= OPpCONST_SHORTCIRCUIT;
3527 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS) &&
3528 type != OP_DOR) /* [#24076] Don't warn for <FH> err FOO. */
3530 const OP *k1 = ((UNOP*)first)->op_first;
3531 const OP *k2 = k1->op_sibling;
3533 switch (first->op_type)
3536 if (k2 && k2->op_type == OP_READLINE
3537 && (k2->op_flags & OPf_STACKED)
3538 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3540 warnop = k2->op_type;
3545 if (k1->op_type == OP_READDIR
3546 || k1->op_type == OP_GLOB
3547 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3548 || k1->op_type == OP_EACH)
3550 warnop = ((k1->op_type == OP_NULL)
3551 ? (OPCODE)k1->op_targ : k1->op_type);
3556 const line_t oldline = CopLINE(PL_curcop);
3557 CopLINE_set(PL_curcop, PL_copline);
3558 Perl_warner(aTHX_ packWARN(WARN_MISC),
3559 "Value of %s%s can be \"0\"; test with defined()",
3561 ((warnop == OP_READLINE || warnop == OP_GLOB)
3562 ? " construct" : "() operator"));
3563 CopLINE_set(PL_curcop, oldline);
3570 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3571 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3573 NewOp(1101, logop, 1, LOGOP);
3575 logop->op_type = (OPCODE)type;
3576 logop->op_ppaddr = PL_ppaddr[type];
3577 logop->op_first = first;
3578 logop->op_flags = flags | OPf_KIDS;
3579 logop->op_other = LINKLIST(other);
3580 logop->op_private = (U8)(1 | (flags >> 8));
3582 /* establish postfix order */
3583 logop->op_next = LINKLIST(first);
3584 first->op_next = (OP*)logop;
3585 first->op_sibling = other;
3587 CHECKOP(type,logop);
3589 o = newUNOP(OP_NULL, 0, (OP*)logop);
3596 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3603 return newLOGOP(OP_AND, 0, first, trueop);
3605 return newLOGOP(OP_OR, 0, first, falseop);
3607 scalarboolean(first);
3608 if (first->op_type == OP_CONST) {
3609 if (first->op_private & OPpCONST_BARE &&
3610 first->op_private & OPpCONST_STRICT) {
3611 no_bareword_allowed(first);
3613 if (SvTRUE(((SVOP*)first)->op_sv)) {
3624 NewOp(1101, logop, 1, LOGOP);
3625 logop->op_type = OP_COND_EXPR;
3626 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3627 logop->op_first = first;
3628 logop->op_flags = flags | OPf_KIDS;
3629 logop->op_private = (U8)(1 | (flags >> 8));
3630 logop->op_other = LINKLIST(trueop);
3631 logop->op_next = LINKLIST(falseop);
3633 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
3636 /* establish postfix order */
3637 start = LINKLIST(first);
3638 first->op_next = (OP*)logop;
3640 first->op_sibling = trueop;
3641 trueop->op_sibling = falseop;
3642 o = newUNOP(OP_NULL, 0, (OP*)logop);
3644 trueop->op_next = falseop->op_next = o;
3651 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3659 NewOp(1101, range, 1, LOGOP);
3661 range->op_type = OP_RANGE;
3662 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3663 range->op_first = left;
3664 range->op_flags = OPf_KIDS;
3665 leftstart = LINKLIST(left);
3666 range->op_other = LINKLIST(right);
3667 range->op_private = (U8)(1 | (flags >> 8));
3669 left->op_sibling = right;
3671 range->op_next = (OP*)range;
3672 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3673 flop = newUNOP(OP_FLOP, 0, flip);
3674 o = newUNOP(OP_NULL, 0, flop);
3676 range->op_next = leftstart;
3678 left->op_next = flip;
3679 right->op_next = flop;
3681 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3682 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3683 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3684 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3686 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3687 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3690 if (!flip->op_private || !flop->op_private)
3691 linklist(o); /* blow off optimizer unless constant */
3697 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3701 const bool once = block && block->op_flags & OPf_SPECIAL &&
3702 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3706 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3707 return block; /* do {} while 0 does once */
3708 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3709 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3710 expr = newUNOP(OP_DEFINED, 0,
3711 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3712 } else if (expr->op_flags & OPf_KIDS) {
3713 const OP *k1 = ((UNOP*)expr)->op_first;
3714 const OP *k2 = (k1) ? k1->op_sibling : NULL;
3715 switch (expr->op_type) {
3717 if (k2 && k2->op_type == OP_READLINE
3718 && (k2->op_flags & OPf_STACKED)
3719 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3720 expr = newUNOP(OP_DEFINED, 0, expr);
3724 if (k1->op_type == OP_READDIR
3725 || k1->op_type == OP_GLOB
3726 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3727 || k1->op_type == OP_EACH)
3728 expr = newUNOP(OP_DEFINED, 0, expr);
3734 /* if block is null, the next append_elem() would put UNSTACK, a scalar
3735 * op, in listop. This is wrong. [perl #27024] */
3737 block = newOP(OP_NULL, 0);
3738 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3739 o = new_logop(OP_AND, 0, &expr, &listop);
3742 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3744 if (once && o != listop)
3745 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3748 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3750 o->op_flags |= flags;
3752 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3757 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3766 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3767 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3768 expr = newUNOP(OP_DEFINED, 0,
3769 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3770 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3771 const OP *k1 = ((UNOP*)expr)->op_first;
3772 const OP *k2 = (k1) ? k1->op_sibling : NULL;
3773 switch (expr->op_type) {
3775 if (k2 && k2->op_type == OP_READLINE
3776 && (k2->op_flags & OPf_STACKED)
3777 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3778 expr = newUNOP(OP_DEFINED, 0, expr);
3782 if (k1->op_type == OP_READDIR
3783 || k1->op_type == OP_GLOB
3784 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3785 || k1->op_type == OP_EACH)
3786 expr = newUNOP(OP_DEFINED, 0, expr);
3792 block = newOP(OP_NULL, 0);
3794 block = scope(block);
3798 next = LINKLIST(cont);
3801 OP *unstack = newOP(OP_UNSTACK, 0);
3804 cont = append_elem(OP_LINESEQ, cont, unstack);
3807 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3808 redo = LINKLIST(listop);
3811 PL_copline = (line_t)whileline;
3813 o = new_logop(OP_AND, 0, &expr, &listop);
3814 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3815 op_free(expr); /* oops, it's a while (0) */
3817 return Nullop; /* listop already freed by new_logop */
3820 ((LISTOP*)listop)->op_last->op_next =
3821 (o == listop ? redo : LINKLIST(o));
3827 NewOp(1101,loop,1,LOOP);
3828 loop->op_type = OP_ENTERLOOP;
3829 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3830 loop->op_private = 0;
3831 loop->op_next = (OP*)loop;
3834 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3836 loop->op_redoop = redo;
3837 loop->op_lastop = o;
3838 o->op_private |= loopflags;
3841 loop->op_nextop = next;
3843 loop->op_nextop = o;
3845 o->op_flags |= flags;
3846 o->op_private |= (flags >> 8);
3851 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
3855 PADOFFSET padoff = 0;
3860 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
3861 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
3862 sv->op_type = OP_RV2GV;
3863 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3865 else if (sv->op_type == OP_PADSV) { /* private variable */
3866 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
3867 padoff = sv->op_targ;
3872 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3873 padoff = sv->op_targ;
3875 iterflags |= OPf_SPECIAL;
3880 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3883 const I32 offset = pad_findmy("$_");
3884 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
3885 sv = newGVOP(OP_GV, 0, PL_defgv);
3891 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3892 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3893 iterflags |= OPf_STACKED;
3895 else if (expr->op_type == OP_NULL &&
3896 (expr->op_flags & OPf_KIDS) &&
3897 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3899 /* Basically turn for($x..$y) into the same as for($x,$y), but we
3900 * set the STACKED flag to indicate that these values are to be
3901 * treated as min/max values by 'pp_iterinit'.
3903 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
3904 LOGOP* range = (LOGOP*) flip->op_first;
3905 OP* left = range->op_first;
3906 OP* right = left->op_sibling;
3909 range->op_flags &= ~OPf_KIDS;
3910 range->op_first = Nullop;
3912 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
3913 listop->op_first->op_next = range->op_next;
3914 left->op_next = range->op_other;
3915 right->op_next = (OP*)listop;
3916 listop->op_next = listop->op_first;
3919 expr = (OP*)(listop);
3921 iterflags |= OPf_STACKED;
3924 expr = mod(force_list(expr), OP_GREPSTART);
3927 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
3928 append_elem(OP_LIST, expr, scalar(sv))));
3929 assert(!loop->op_next);
3930 /* for my $x () sets OPpLVAL_INTRO;
3931 * for our $x () sets OPpOUR_INTRO */
3932 loop->op_private = (U8)iterpflags;
3933 #ifdef PL_OP_SLAB_ALLOC
3936 NewOp(1234,tmp,1,LOOP);
3937 Copy(loop,tmp,1,LISTOP);
3942 Renew(loop, 1, LOOP);
3944 loop->op_targ = padoff;
3945 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
3946 PL_copline = forline;
3947 return newSTATEOP(0, label, wop);
3951 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
3956 if (type != OP_GOTO || label->op_type == OP_CONST) {
3957 /* "last()" means "last" */
3958 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
3959 o = newOP(type, OPf_SPECIAL);
3961 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
3962 ? SvPVx(((SVOP*)label)->op_sv, n_a)
3968 /* Check whether it's going to be a goto &function */
3969 if (label->op_type == OP_ENTERSUB
3970 && !(label->op_flags & OPf_STACKED))
3971 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
3972 o = newUNOP(type, OPf_STACKED, label);
3974 PL_hints |= HINT_BLOCK_SCOPE;
3979 =for apidoc cv_undef
3981 Clear out all the active components of a CV. This can happen either
3982 by an explicit C<undef &foo>, or by the reference count going to zero.
3983 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
3984 children can still follow the full lexical scope chain.
3990 Perl_cv_undef(pTHX_ CV *cv)
3993 if (CvFILE(cv) && !CvXSUB(cv)) {
3994 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
3995 Safefree(CvFILE(cv));
4000 if (!CvXSUB(cv) && CvROOT(cv)) {
4002 Perl_croak(aTHX_ "Can't undef active subroutine");
4005 PAD_SAVE_SETNULLPAD();
4007 op_free(CvROOT(cv));
4008 CvROOT(cv) = Nullop;
4011 SvPOK_off((SV*)cv); /* forget prototype */
4016 /* remove CvOUTSIDE unless this is an undef rather than a free */
4017 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4018 if (!CvWEAKOUTSIDE(cv))
4019 SvREFCNT_dec(CvOUTSIDE(cv));
4020 CvOUTSIDE(cv) = Nullcv;
4023 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4029 /* delete all flags except WEAKOUTSIDE */
4030 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4034 Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p)
4036 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4037 SV* msg = sv_newmortal();
4041 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4042 sv_setpv(msg, "Prototype mismatch:");
4044 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4046 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (const SV *)cv);
4048 Perl_sv_catpv(aTHX_ msg, ": none");
4049 sv_catpv(msg, " vs ");
4051 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4053 sv_catpv(msg, "none");
4054 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
4058 static void const_sv_xsub(pTHX_ CV* cv);
4062 =head1 Optree Manipulation Functions
4064 =for apidoc cv_const_sv
4066 If C<cv> is a constant sub eligible for inlining. returns the constant
4067 value returned by the sub. Otherwise, returns NULL.
4069 Constant subs can be created with C<newCONSTSUB> or as described in
4070 L<perlsub/"Constant Functions">.
4075 Perl_cv_const_sv(pTHX_ CV *cv)
4077 if (!cv || !CvCONST(cv))
4079 return (SV*)CvXSUBANY(cv).any_ptr;
4082 /* op_const_sv: examine an optree to determine whether it's in-lineable.
4083 * Can be called in 3 ways:
4086 * look for a single OP_CONST with attached value: return the value
4088 * cv && CvCLONE(cv) && !CvCONST(cv)
4090 * examine the clone prototype, and if contains only a single
4091 * OP_CONST referencing a pad const, or a single PADSV referencing
4092 * an outer lexical, return a non-zero value to indicate the CV is
4093 * a candidate for "constizing" at clone time
4097 * We have just cloned an anon prototype that was marked as a const
4098 * candidiate. Try to grab the current value, and in the case of
4099 * PADSV, ignore it if it has multiple references. Return the value.
4103 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
4110 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4111 o = cLISTOPo->op_first->op_sibling;
4113 for (; o; o = o->op_next) {
4114 OPCODE type = o->op_type;
4116 if (sv && o->op_next == o)
4118 if (o->op_next != o) {
4119 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4121 if (type == OP_DBSTATE)
4124 if (type == OP_LEAVESUB || type == OP_RETURN)
4128 if (type == OP_CONST && cSVOPo->op_sv)
4130 else if (cv && type == OP_CONST) {
4131 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4135 else if (cv && type == OP_PADSV) {
4136 if (CvCONST(cv)) { /* newly cloned anon */
4137 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4138 /* the candidate should have 1 ref from this pad and 1 ref
4139 * from the parent */
4140 if (!sv || SvREFCNT(sv) != 2)
4147 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4148 sv = &PL_sv_undef; /* an arbitrary non-null value */
4159 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4170 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4174 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4176 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4180 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4190 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4193 assert(proto->op_type == OP_CONST);
4194 ps = SvPVx(((SVOP*)proto)->op_sv, n_a);
4199 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4200 SV *sv = sv_newmortal();
4201 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4202 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4203 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4208 gv = name ? gv_fetchsv(cSVOPo->op_sv,
4209 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4211 : gv_fetchpv(aname ? aname
4212 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4213 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4223 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4224 maximum a prototype before. */
4225 if (SvTYPE(gv) > SVt_NULL) {
4226 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4227 && ckWARN_d(WARN_PROTOTYPE))
4229 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4231 cv_ckproto((CV*)gv, NULL, ps);
4234 sv_setpv((SV*)gv, ps);
4236 sv_setiv((SV*)gv, -1);
4237 SvREFCNT_dec(PL_compcv);
4238 cv = PL_compcv = NULL;
4239 PL_sub_generation++;
4243 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4245 #ifdef GV_UNIQUE_CHECK
4246 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4247 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4251 if (!block || !ps || *ps || attrs)
4254 const_sv = op_const_sv(block, Nullcv);
4257 const bool exists = CvROOT(cv) || CvXSUB(cv);
4259 #ifdef GV_UNIQUE_CHECK
4260 if (exists && GvUNIQUE(gv)) {
4261 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4265 /* if the subroutine doesn't exist and wasn't pre-declared
4266 * with a prototype, assume it will be AUTOLOADed,
4267 * skipping the prototype check
4269 if (exists || SvPOK(cv))
4270 cv_ckproto(cv, gv, ps);
4271 /* already defined (or promised)? */
4272 if (exists || GvASSUMECV(gv)) {
4273 if (!block && !attrs) {
4274 if (CvFLAGS(PL_compcv)) {
4275 /* might have had built-in attrs applied */
4276 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4278 /* just a "sub foo;" when &foo is already defined */
4279 SAVEFREESV(PL_compcv);
4282 /* ahem, death to those who redefine active sort subs */
4283 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4284 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4286 if (ckWARN(WARN_REDEFINE)
4288 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4290 const line_t oldline = CopLINE(PL_curcop);
4291 if (PL_copline != NOLINE)
4292 CopLINE_set(PL_curcop, PL_copline);
4293 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4294 CvCONST(cv) ? "Constant subroutine %s redefined"
4295 : "Subroutine %s redefined", name);
4296 CopLINE_set(PL_curcop, oldline);
4304 (void)SvREFCNT_inc(const_sv);
4306 assert(!CvROOT(cv) && !CvCONST(cv));
4307 sv_setpv((SV*)cv, ""); /* prototype is "" */
4308 CvXSUBANY(cv).any_ptr = const_sv;
4309 CvXSUB(cv) = const_sv_xsub;
4314 cv = newCONSTSUB(NULL, name, const_sv);
4317 SvREFCNT_dec(PL_compcv);
4319 PL_sub_generation++;
4326 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4327 * before we clobber PL_compcv.
4331 /* Might have had built-in attributes applied -- propagate them. */
4332 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4333 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4334 stash = GvSTASH(CvGV(cv));
4335 else if (CvSTASH(cv))
4336 stash = CvSTASH(cv);
4338 stash = PL_curstash;
4341 /* possibly about to re-define existing subr -- ignore old cv */
4342 rcv = (SV*)PL_compcv;
4343 if (name && GvSTASH(gv))
4344 stash = GvSTASH(gv);
4346 stash = PL_curstash;
4348 apply_attrs(stash, rcv, attrs, FALSE);
4350 if (cv) { /* must reuse cv if autoloaded */
4352 /* got here with just attrs -- work done, so bug out */
4353 SAVEFREESV(PL_compcv);
4356 /* transfer PL_compcv to cv */
4358 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4359 if (!CvWEAKOUTSIDE(cv))
4360 SvREFCNT_dec(CvOUTSIDE(cv));
4361 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4362 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4363 CvOUTSIDE(PL_compcv) = 0;
4364 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4365 CvPADLIST(PL_compcv) = 0;
4366 /* inner references to PL_compcv must be fixed up ... */
4367 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4368 /* ... before we throw it away */
4369 SvREFCNT_dec(PL_compcv);
4371 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4372 ++PL_sub_generation;
4379 PL_sub_generation++;
4383 CvFILE_set_from_cop(cv, PL_curcop);
4384 CvSTASH(cv) = PL_curstash;
4387 sv_setpv((SV*)cv, ps);
4389 if (PL_error_count) {
4393 const char *s = strrchr(name, ':');
4395 if (strEQ(s, "BEGIN")) {
4396 const char not_safe[] =
4397 "BEGIN not safe after errors--compilation aborted";
4398 if (PL_in_eval & EVAL_KEEPERR)
4399 Perl_croak(aTHX_ not_safe);
4401 /* force display of errors found but not reported */
4402 sv_catpv(ERRSV, not_safe);
4403 Perl_croak(aTHX_ "%"SVf, ERRSV);
4412 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4413 mod(scalarseq(block), OP_LEAVESUBLV));
4416 /* This makes sub {}; work as expected. */
4417 if (block->op_type == OP_STUB) {
4419 block = newSTATEOP(0, Nullch, 0);
4421 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4423 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4424 OpREFCNT_set(CvROOT(cv), 1);
4425 CvSTART(cv) = LINKLIST(CvROOT(cv));
4426 CvROOT(cv)->op_next = 0;
4427 CALL_PEEP(CvSTART(cv));
4429 /* now that optimizer has done its work, adjust pad values */
4431 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4434 assert(!CvCONST(cv));
4435 if (ps && !*ps && op_const_sv(block, cv))
4439 if (name || aname) {
4441 const char *tname = (name ? name : aname);
4443 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4444 SV *sv = NEWSV(0,0);
4445 SV *tmpstr = sv_newmortal();
4446 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4450 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4452 (long)PL_subline, (long)CopLINE(PL_curcop));
4453 gv_efullname3(tmpstr, gv, Nullch);
4454 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4455 hv = GvHVn(db_postponed);
4456 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4457 && (pcv = GvCV(db_postponed)))
4463 call_sv((SV*)pcv, G_DISCARD);
4467 if ((s = strrchr(tname,':')))
4472 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4475 if (strEQ(s, "BEGIN") && !PL_error_count) {
4476 const I32 oldscope = PL_scopestack_ix;
4478 SAVECOPFILE(&PL_compiling);
4479 SAVECOPLINE(&PL_compiling);
4482 PL_beginav = newAV();
4483 DEBUG_x( dump_sub(gv) );
4484 av_push(PL_beginav, (SV*)cv);
4485 GvCV(gv) = 0; /* cv has been hijacked */
4486 call_list(oldscope, PL_beginav);
4488 PL_curcop = &PL_compiling;
4489 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4492 else if (strEQ(s, "END") && !PL_error_count) {
4495 DEBUG_x( dump_sub(gv) );
4496 av_unshift(PL_endav, 1);
4497 av_store(PL_endav, 0, (SV*)cv);
4498 GvCV(gv) = 0; /* cv has been hijacked */
4500 else if (strEQ(s, "CHECK") && !PL_error_count) {
4502 PL_checkav = newAV();
4503 DEBUG_x( dump_sub(gv) );
4504 if (PL_main_start && ckWARN(WARN_VOID))
4505 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4506 av_unshift(PL_checkav, 1);
4507 av_store(PL_checkav, 0, (SV*)cv);
4508 GvCV(gv) = 0; /* cv has been hijacked */
4510 else if (strEQ(s, "INIT") && !PL_error_count) {
4512 PL_initav = newAV();
4513 DEBUG_x( dump_sub(gv) );
4514 if (PL_main_start && ckWARN(WARN_VOID))
4515 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4516 av_push(PL_initav, (SV*)cv);
4517 GvCV(gv) = 0; /* cv has been hijacked */
4522 PL_copline = NOLINE;
4527 /* XXX unsafe for threads if eval_owner isn't held */
4529 =for apidoc newCONSTSUB
4531 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4532 eligible for inlining at compile-time.
4538 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
4544 SAVECOPLINE(PL_curcop);
4545 CopLINE_set(PL_curcop, PL_copline);
4548 PL_hints &= ~HINT_BLOCK_SCOPE;
4551 SAVESPTR(PL_curstash);
4552 SAVECOPSTASH(PL_curcop);
4553 PL_curstash = stash;
4554 CopSTASH_set(PL_curcop,stash);
4557 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4558 CvXSUBANY(cv).any_ptr = sv;
4560 sv_setpv((SV*)cv, ""); /* prototype is "" */
4563 CopSTASH_free(PL_curcop);
4571 =for apidoc U||newXS
4573 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4579 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
4581 GV *gv = gv_fetchpv(name ? name :
4582 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4583 GV_ADDMULTI, SVt_PVCV);
4587 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4589 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4591 /* just a cached method */
4595 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4596 /* already defined (or promised) */
4597 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4598 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4599 const line_t oldline = CopLINE(PL_curcop);
4600 if (PL_copline != NOLINE)
4601 CopLINE_set(PL_curcop, PL_copline);
4602 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4603 CvCONST(cv) ? "Constant subroutine %s redefined"
4604 : "Subroutine %s redefined"
4606 CopLINE_set(PL_curcop, oldline);
4613 if (cv) /* must reuse cv if autoloaded */
4616 cv = (CV*)NEWSV(1105,0);
4617 sv_upgrade((SV *)cv, SVt_PVCV);
4621 PL_sub_generation++;
4625 (void)gv_fetchfile(filename);
4626 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
4627 an external constant string */
4628 CvXSUB(cv) = subaddr;
4631 const char *s = strrchr(name,':');
4637 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4640 if (strEQ(s, "BEGIN")) {
4642 PL_beginav = newAV();
4643 av_push(PL_beginav, (SV*)cv);
4644 GvCV(gv) = 0; /* cv has been hijacked */
4646 else if (strEQ(s, "END")) {
4649 av_unshift(PL_endav, 1);
4650 av_store(PL_endav, 0, (SV*)cv);
4651 GvCV(gv) = 0; /* cv has been hijacked */
4653 else if (strEQ(s, "CHECK")) {
4655 PL_checkav = newAV();
4656 if (PL_main_start && ckWARN(WARN_VOID))
4657 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4658 av_unshift(PL_checkav, 1);
4659 av_store(PL_checkav, 0, (SV*)cv);
4660 GvCV(gv) = 0; /* cv has been hijacked */
4662 else if (strEQ(s, "INIT")) {
4664 PL_initav = newAV();
4665 if (PL_main_start && ckWARN(WARN_VOID))
4666 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4667 av_push(PL_initav, (SV*)cv);
4668 GvCV(gv) = 0; /* cv has been hijacked */
4679 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4685 gv = gv_fetchsv(cSVOPo->op_sv, TRUE, SVt_PVFM);
4687 gv = gv_fetchpv("STDOUT", TRUE, SVt_PVFM);
4689 #ifdef GV_UNIQUE_CHECK
4691 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4695 if ((cv = GvFORM(gv))) {
4696 if (ckWARN(WARN_REDEFINE)) {
4697 const line_t oldline = CopLINE(PL_curcop);
4698 if (PL_copline != NOLINE)
4699 CopLINE_set(PL_curcop, PL_copline);
4700 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4701 o ? "Format %"SVf" redefined"
4702 : "Format STDOUT redefined" ,cSVOPo->op_sv);
4703 CopLINE_set(PL_curcop, oldline);
4710 CvFILE_set_from_cop(cv, PL_curcop);
4713 pad_tidy(padtidy_FORMAT);
4714 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4715 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4716 OpREFCNT_set(CvROOT(cv), 1);
4717 CvSTART(cv) = LINKLIST(CvROOT(cv));
4718 CvROOT(cv)->op_next = 0;
4719 CALL_PEEP(CvSTART(cv));
4721 PL_copline = NOLINE;
4726 Perl_newANONLIST(pTHX_ OP *o)
4728 return newUNOP(OP_REFGEN, 0,
4729 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4733 Perl_newANONHASH(pTHX_ OP *o)
4735 return newUNOP(OP_REFGEN, 0,
4736 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4740 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4742 return newANONATTRSUB(floor, proto, Nullop, block);
4746 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4748 return newUNOP(OP_REFGEN, 0,
4749 newSVOP(OP_ANONCODE, 0,
4750 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
4754 Perl_oopsAV(pTHX_ OP *o)
4756 switch (o->op_type) {
4758 o->op_type = OP_PADAV;
4759 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4760 return ref(o, OP_RV2AV);
4763 o->op_type = OP_RV2AV;
4764 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4769 if (ckWARN_d(WARN_INTERNAL))
4770 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
4777 Perl_oopsHV(pTHX_ OP *o)
4779 switch (o->op_type) {
4782 o->op_type = OP_PADHV;
4783 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4784 return ref(o, OP_RV2HV);
4788 o->op_type = OP_RV2HV;
4789 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
4794 if (ckWARN_d(WARN_INTERNAL))
4795 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
4802 Perl_newAVREF(pTHX_ OP *o)
4804 if (o->op_type == OP_PADANY) {
4805 o->op_type = OP_PADAV;
4806 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4809 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
4810 && ckWARN(WARN_DEPRECATED)) {
4811 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4812 "Using an array as a reference is deprecated");
4814 return newUNOP(OP_RV2AV, 0, scalar(o));
4818 Perl_newGVREF(pTHX_ I32 type, OP *o)
4820 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
4821 return newUNOP(OP_NULL, 0, o);
4822 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
4826 Perl_newHVREF(pTHX_ OP *o)
4828 if (o->op_type == OP_PADANY) {
4829 o->op_type = OP_PADHV;
4830 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4833 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
4834 && ckWARN(WARN_DEPRECATED)) {
4835 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4836 "Using a hash as a reference is deprecated");
4838 return newUNOP(OP_RV2HV, 0, scalar(o));
4842 Perl_oopsCV(pTHX_ OP *o)
4844 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
4847 #ifndef HASATTRIBUTE
4848 /* No __attribute__, so the compiler doesn't know that croak never returns
4855 Perl_newCVREF(pTHX_ I32 flags, OP *o)
4857 return newUNOP(OP_RV2CV, flags, scalar(o));
4861 Perl_newSVREF(pTHX_ OP *o)
4863 if (o->op_type == OP_PADANY) {
4864 o->op_type = OP_PADSV;
4865 o->op_ppaddr = PL_ppaddr[OP_PADSV];
4868 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4869 o->op_flags |= OPpDONE_SVREF;
4872 return newUNOP(OP_RV2SV, 0, scalar(o));
4875 /* Check routines. See the comments at the top of this file for details
4876 * on when these are called */
4879 Perl_ck_anoncode(pTHX_ OP *o)
4881 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
4882 cSVOPo->op_sv = Nullsv;
4887 Perl_ck_bitop(pTHX_ OP *o)
4889 #define OP_IS_NUMCOMPARE(op) \
4890 ((op) == OP_LT || (op) == OP_I_LT || \
4891 (op) == OP_GT || (op) == OP_I_GT || \
4892 (op) == OP_LE || (op) == OP_I_LE || \
4893 (op) == OP_GE || (op) == OP_I_GE || \
4894 (op) == OP_EQ || (op) == OP_I_EQ || \
4895 (op) == OP_NE || (op) == OP_I_NE || \
4896 (op) == OP_NCMP || (op) == OP_I_NCMP)
4897 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4898 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
4899 && (o->op_type == OP_BIT_OR
4900 || o->op_type == OP_BIT_AND
4901 || o->op_type == OP_BIT_XOR))
4903 const OP * left = cBINOPo->op_first;
4904 const OP * right = left->op_sibling;
4905 if ((OP_IS_NUMCOMPARE(left->op_type) &&
4906 (left->op_flags & OPf_PARENS) == 0) ||
4907 (OP_IS_NUMCOMPARE(right->op_type) &&
4908 (right->op_flags & OPf_PARENS) == 0))
4909 if (ckWARN(WARN_PRECEDENCE))
4910 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4911 "Possible precedence problem on bitwise %c operator",
4912 o->op_type == OP_BIT_OR ? '|'
4913 : o->op_type == OP_BIT_AND ? '&' : '^'
4920 Perl_ck_concat(pTHX_ OP *o)
4922 const OP *kid = cUNOPo->op_first;
4923 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
4924 !(kUNOP->op_first->op_flags & OPf_MOD))
4925 o->op_flags |= OPf_STACKED;
4930 Perl_ck_spair(pTHX_ OP *o)
4932 if (o->op_flags & OPf_KIDS) {
4935 const OPCODE type = o->op_type;
4936 o = modkids(ck_fun(o), type);
4937 kid = cUNOPo->op_first;
4938 newop = kUNOP->op_first->op_sibling;
4940 (newop->op_sibling ||
4941 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
4942 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
4943 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
4947 op_free(kUNOP->op_first);
4948 kUNOP->op_first = newop;
4950 o->op_ppaddr = PL_ppaddr[++o->op_type];
4955 Perl_ck_delete(pTHX_ OP *o)
4959 if (o->op_flags & OPf_KIDS) {
4960 OP *kid = cUNOPo->op_first;
4961 switch (kid->op_type) {
4963 o->op_flags |= OPf_SPECIAL;
4966 o->op_private |= OPpSLICE;
4969 o->op_flags |= OPf_SPECIAL;
4974 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
4983 Perl_ck_die(pTHX_ OP *o)
4986 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4992 Perl_ck_eof(pTHX_ OP *o)
4994 const I32 type = o->op_type;
4996 if (o->op_flags & OPf_KIDS) {
4997 if (cLISTOPo->op_first->op_type == OP_STUB) {
4999 o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
5007 Perl_ck_eval(pTHX_ OP *o)
5009 PL_hints |= HINT_BLOCK_SCOPE;
5010 if (o->op_flags & OPf_KIDS) {
5011 SVOP *kid = (SVOP*)cUNOPo->op_first;
5014 o->op_flags &= ~OPf_KIDS;
5017 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
5020 cUNOPo->op_first = 0;
5023 NewOp(1101, enter, 1, LOGOP);
5024 enter->op_type = OP_ENTERTRY;
5025 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5026 enter->op_private = 0;
5028 /* establish postfix order */
5029 enter->op_next = (OP*)enter;
5031 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5032 o->op_type = OP_LEAVETRY;
5033 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5034 enter->op_other = o;
5044 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5046 o->op_targ = (PADOFFSET)PL_hints;
5051 Perl_ck_exit(pTHX_ OP *o)
5054 HV *table = GvHV(PL_hintgv);
5056 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5057 if (svp && *svp && SvTRUE(*svp))
5058 o->op_private |= OPpEXIT_VMSISH;
5060 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5066 Perl_ck_exec(pTHX_ OP *o)
5068 if (o->op_flags & OPf_STACKED) {
5071 kid = cUNOPo->op_first->op_sibling;
5072 if (kid->op_type == OP_RV2GV)
5081 Perl_ck_exists(pTHX_ OP *o)
5084 if (o->op_flags & OPf_KIDS) {
5085 OP *kid = cUNOPo->op_first;
5086 if (kid->op_type == OP_ENTERSUB) {
5087 (void) ref(kid, o->op_type);
5088 if (kid->op_type != OP_RV2CV && !PL_error_count)
5089 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5091 o->op_private |= OPpEXISTS_SUB;
5093 else if (kid->op_type == OP_AELEM)
5094 o->op_flags |= OPf_SPECIAL;
5095 else if (kid->op_type != OP_HELEM)
5096 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5105 Perl_ck_gvconst(pTHX_ register OP *o)
5107 o = fold_constants(o);
5108 if (o->op_type == OP_CONST)
5115 Perl_ck_rvconst(pTHX_ register OP *o)
5117 SVOP *kid = (SVOP*)cUNOPo->op_first;
5119 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5120 if (kid->op_type == OP_CONST) {
5123 SV *kidsv = kid->op_sv;
5125 /* Is it a constant from cv_const_sv()? */
5126 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5127 SV *rsv = SvRV(kidsv);
5128 int svtype = SvTYPE(rsv);
5129 const char *badtype = Nullch;
5131 switch (o->op_type) {
5133 if (svtype > SVt_PVMG)
5134 badtype = "a SCALAR";
5137 if (svtype != SVt_PVAV)
5138 badtype = "an ARRAY";
5141 if (svtype != SVt_PVHV)
5145 if (svtype != SVt_PVCV)
5150 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5153 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5154 const char *badthing = Nullch;
5155 switch (o->op_type) {
5157 badthing = "a SCALAR";
5160 badthing = "an ARRAY";
5163 badthing = "a HASH";
5168 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
5172 * This is a little tricky. We only want to add the symbol if we
5173 * didn't add it in the lexer. Otherwise we get duplicate strict
5174 * warnings. But if we didn't add it in the lexer, we must at
5175 * least pretend like we wanted to add it even if it existed before,
5176 * or we get possible typo warnings. OPpCONST_ENTERED says
5177 * whether the lexer already added THIS instance of this symbol.
5179 iscv = (o->op_type == OP_RV2CV) * 2;
5181 gv = gv_fetchsv(kidsv,
5182 iscv | !(kid->op_private & OPpCONST_ENTERED),
5185 : o->op_type == OP_RV2SV
5187 : o->op_type == OP_RV2AV
5189 : o->op_type == OP_RV2HV
5192 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5194 kid->op_type = OP_GV;
5195 SvREFCNT_dec(kid->op_sv);
5197 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5198 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5199 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
5201 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
5203 kid->op_sv = SvREFCNT_inc(gv);
5205 kid->op_private = 0;
5206 kid->op_ppaddr = PL_ppaddr[OP_GV];
5213 Perl_ck_ftst(pTHX_ OP *o)
5215 const I32 type = o->op_type;
5217 if (o->op_flags & OPf_REF) {
5220 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5221 SVOP *kid = (SVOP*)cUNOPo->op_first;
5223 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5224 OP *newop = newGVOP(type, OPf_REF,
5225 gv_fetchsv(kid->op_sv, TRUE, SVt_PVIO));
5231 if ((PL_hints & HINT_FILETEST_ACCESS) &&
5232 OP_IS_FILETEST_ACCESS(o))
5233 o->op_private |= OPpFT_ACCESS;
5235 if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
5236 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
5237 o->op_private |= OPpFT_STACKED;
5241 if (type == OP_FTTTY)
5242 o = newGVOP(type, OPf_REF, PL_stdingv);
5244 o = newUNOP(type, 0, newDEFSVOP());
5250 Perl_ck_fun(pTHX_ OP *o)
5252 const int type = o->op_type;
5253 register I32 oa = PL_opargs[type] >> OASHIFT;
5255 if (o->op_flags & OPf_STACKED) {
5256 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5259 return no_fh_allowed(o);
5262 if (o->op_flags & OPf_KIDS) {
5263 OP **tokid = &cLISTOPo->op_first;
5264 register OP *kid = cLISTOPo->op_first;
5268 if (kid->op_type == OP_PUSHMARK ||
5269 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5271 tokid = &kid->op_sibling;
5272 kid = kid->op_sibling;
5274 if (!kid && PL_opargs[type] & OA_DEFGV)
5275 *tokid = kid = newDEFSVOP();
5279 sibl = kid->op_sibling;
5282 /* list seen where single (scalar) arg expected? */
5283 if (numargs == 1 && !(oa >> 4)
5284 && kid->op_type == OP_LIST && type != OP_SCALAR)
5286 return too_many_arguments(o,PL_op_desc[type]);
5299 if ((type == OP_PUSH || type == OP_UNSHIFT)
5300 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5301 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5302 "Useless use of %s with no values",
5305 if (kid->op_type == OP_CONST &&
5306 (kid->op_private & OPpCONST_BARE))
5308 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5309 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVAV) ));
5310 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5311 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5312 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
5313 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5316 kid->op_sibling = sibl;
5319 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5320 bad_type(numargs, "array", PL_op_desc[type], kid);
5324 if (kid->op_type == OP_CONST &&
5325 (kid->op_private & OPpCONST_BARE))
5327 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5328 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVHV) ));
5329 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5330 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5331 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
5332 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5335 kid->op_sibling = sibl;
5338 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5339 bad_type(numargs, "hash", PL_op_desc[type], kid);
5344 OP *newop = newUNOP(OP_NULL, 0, kid);
5345 kid->op_sibling = 0;
5347 newop->op_next = newop;
5349 kid->op_sibling = sibl;
5354 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5355 if (kid->op_type == OP_CONST &&
5356 (kid->op_private & OPpCONST_BARE))
5358 OP *newop = newGVOP(OP_GV, 0,
5359 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVIO) );
5360 if (!(o->op_private & 1) && /* if not unop */
5361 kid == cLISTOPo->op_last)
5362 cLISTOPo->op_last = newop;
5366 else if (kid->op_type == OP_READLINE) {
5367 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5368 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5371 I32 flags = OPf_SPECIAL;
5375 /* is this op a FH constructor? */
5376 if (is_handle_constructor(o,numargs)) {
5377 const char *name = Nullch;
5381 /* Set a flag to tell rv2gv to vivify
5382 * need to "prove" flag does not mean something
5383 * else already - NI-S 1999/05/07
5386 if (kid->op_type == OP_PADSV) {
5387 name = PAD_COMPNAME_PV(kid->op_targ);
5388 /* SvCUR of a pad namesv can't be trusted
5389 * (see PL_generation), so calc its length
5395 else if (kid->op_type == OP_RV2SV
5396 && kUNOP->op_first->op_type == OP_GV)
5398 GV *gv = cGVOPx_gv(kUNOP->op_first);
5400 len = GvNAMELEN(gv);
5402 else if (kid->op_type == OP_AELEM
5403 || kid->op_type == OP_HELEM)
5408 if ((op = ((BINOP*)kid)->op_first)) {
5409 SV *tmpstr = Nullsv;
5411 kid->op_type == OP_AELEM ?
5413 if (((op->op_type == OP_RV2AV) ||
5414 (op->op_type == OP_RV2HV)) &&
5415 (op = ((UNOP*)op)->op_first) &&
5416 (op->op_type == OP_GV)) {
5417 /* packagevar $a[] or $h{} */
5418 GV *gv = cGVOPx_gv(op);
5426 else if (op->op_type == OP_PADAV
5427 || op->op_type == OP_PADHV) {
5428 /* lexicalvar $a[] or $h{} */
5429 const char *padname =
5430 PAD_COMPNAME_PV(op->op_targ);
5440 name = SvPV(tmpstr, len);
5445 name = "__ANONIO__";
5452 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5453 namesv = PAD_SVl(targ);
5454 (void)SvUPGRADE(namesv, SVt_PV);
5456 sv_setpvn(namesv, "$", 1);
5457 sv_catpvn(namesv, name, len);
5460 kid->op_sibling = 0;
5461 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5462 kid->op_targ = targ;
5463 kid->op_private |= priv;
5465 kid->op_sibling = sibl;
5471 mod(scalar(kid), type);
5475 tokid = &kid->op_sibling;
5476 kid = kid->op_sibling;
5478 o->op_private |= numargs;
5480 return too_many_arguments(o,OP_DESC(o));
5483 else if (PL_opargs[type] & OA_DEFGV) {
5485 return newUNOP(type, 0, newDEFSVOP());
5489 while (oa & OA_OPTIONAL)
5491 if (oa && oa != OA_LIST)
5492 return too_few_arguments(o,OP_DESC(o));
5498 Perl_ck_glob(pTHX_ OP *o)
5503 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5504 append_elem(OP_GLOB, o, newDEFSVOP());
5506 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5507 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5509 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5512 #if !defined(PERL_EXTERNAL_GLOB)
5513 /* XXX this can be tightened up and made more failsafe. */
5514 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5517 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5518 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5519 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5520 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5521 GvCV(gv) = GvCV(glob_gv);
5522 (void)SvREFCNT_inc((SV*)GvCV(gv));
5523 GvIMPORTED_CV_on(gv);
5526 #endif /* PERL_EXTERNAL_GLOB */
5528 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5529 append_elem(OP_GLOB, o,
5530 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5531 o->op_type = OP_LIST;
5532 o->op_ppaddr = PL_ppaddr[OP_LIST];
5533 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5534 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5535 cLISTOPo->op_first->op_targ = 0;
5536 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5537 append_elem(OP_LIST, o,
5538 scalar(newUNOP(OP_RV2CV, 0,
5539 newGVOP(OP_GV, 0, gv)))));
5540 o = newUNOP(OP_NULL, 0, ck_subr(o));
5541 o->op_targ = OP_GLOB; /* hint at what it used to be */
5544 gv = newGVgen("main");
5546 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5552 Perl_ck_grep(pTHX_ OP *o)
5556 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5559 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5560 NewOp(1101, gwop, 1, LOGOP);
5562 if (o->op_flags & OPf_STACKED) {
5565 kid = cLISTOPo->op_first->op_sibling;
5566 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
5569 kid->op_next = (OP*)gwop;
5570 o->op_flags &= ~OPf_STACKED;
5572 kid = cLISTOPo->op_first->op_sibling;
5573 if (type == OP_MAPWHILE)
5580 kid = cLISTOPo->op_first->op_sibling;
5581 if (kid->op_type != OP_NULL)
5582 Perl_croak(aTHX_ "panic: ck_grep");
5583 kid = kUNOP->op_first;
5585 gwop->op_type = type;
5586 gwop->op_ppaddr = PL_ppaddr[type];
5587 gwop->op_first = listkids(o);
5588 gwop->op_flags |= OPf_KIDS;
5589 gwop->op_other = LINKLIST(kid);
5590 kid->op_next = (OP*)gwop;
5591 offset = pad_findmy("$_");
5592 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
5593 o->op_private = gwop->op_private = 0;
5594 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5597 o->op_private = gwop->op_private = OPpGREP_LEX;
5598 gwop->op_targ = o->op_targ = offset;
5601 kid = cLISTOPo->op_first->op_sibling;
5602 if (!kid || !kid->op_sibling)
5603 return too_few_arguments(o,OP_DESC(o));
5604 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5605 mod(kid, OP_GREPSTART);
5611 Perl_ck_index(pTHX_ OP *o)
5613 if (o->op_flags & OPf_KIDS) {
5614 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5616 kid = kid->op_sibling; /* get past "big" */
5617 if (kid && kid->op_type == OP_CONST)
5618 fbm_compile(((SVOP*)kid)->op_sv, 0);
5624 Perl_ck_lengthconst(pTHX_ OP *o)
5626 /* XXX length optimization goes here */
5631 Perl_ck_lfun(pTHX_ OP *o)
5633 const OPCODE type = o->op_type;
5634 return modkids(ck_fun(o), type);
5638 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5640 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5641 switch (cUNOPo->op_first->op_type) {
5643 /* This is needed for
5644 if (defined %stash::)
5645 to work. Do not break Tk.
5647 break; /* Globals via GV can be undef */
5649 case OP_AASSIGN: /* Is this a good idea? */
5650 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5651 "defined(@array) is deprecated");
5652 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5653 "\t(Maybe you should just omit the defined()?)\n");
5656 /* This is needed for
5657 if (defined %stash::)
5658 to work. Do not break Tk.
5660 break; /* Globals via GV can be undef */
5662 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5663 "defined(%%hash) is deprecated");
5664 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5665 "\t(Maybe you should just omit the defined()?)\n");
5676 Perl_ck_rfun(pTHX_ OP *o)
5678 const OPCODE type = o->op_type;
5679 return refkids(ck_fun(o), type);
5683 Perl_ck_listiob(pTHX_ OP *o)
5687 kid = cLISTOPo->op_first;
5690 kid = cLISTOPo->op_first;
5692 if (kid->op_type == OP_PUSHMARK)
5693 kid = kid->op_sibling;
5694 if (kid && o->op_flags & OPf_STACKED)
5695 kid = kid->op_sibling;
5696 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5697 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5698 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5699 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5700 cLISTOPo->op_first->op_sibling = kid;
5701 cLISTOPo->op_last = kid;
5702 kid = kid->op_sibling;
5707 append_elem(o->op_type, o, newDEFSVOP());
5713 Perl_ck_sassign(pTHX_ OP *o)
5715 OP *kid = cLISTOPo->op_first;
5716 /* has a disposable target? */
5717 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5718 && !(kid->op_flags & OPf_STACKED)
5719 /* Cannot steal the second time! */
5720 && !(kid->op_private & OPpTARGET_MY))
5722 OP *kkid = kid->op_sibling;
5724 /* Can just relocate the target. */
5725 if (kkid && kkid->op_type == OP_PADSV
5726 && !(kkid->op_private & OPpLVAL_INTRO))
5728 kid->op_targ = kkid->op_targ;
5730 /* Now we do not need PADSV and SASSIGN. */
5731 kid->op_sibling = o->op_sibling; /* NULL */
5732 cLISTOPo->op_first = NULL;
5735 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
5739 /* optimise C<my $x = undef> to C<my $x> */
5740 if (kid->op_type == OP_UNDEF) {
5741 OP *kkid = kid->op_sibling;
5742 if (kkid && kkid->op_type == OP_PADSV
5743 && (kkid->op_private & OPpLVAL_INTRO))
5745 cLISTOPo->op_first = NULL;
5746 kid->op_sibling = NULL;
5756 Perl_ck_match(pTHX_ OP *o)
5758 if (o->op_type != OP_QR) {
5759 const I32 offset = pad_findmy("$_");
5760 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS(offset) & SVpad_OUR)) {
5761 o->op_targ = offset;
5762 o->op_private |= OPpTARGET_MY;
5765 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
5766 o->op_private |= OPpRUNTIME;
5771 Perl_ck_method(pTHX_ OP *o)
5773 OP *kid = cUNOPo->op_first;
5774 if (kid->op_type == OP_CONST) {
5775 SV* sv = kSVOP->op_sv;
5776 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
5778 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5779 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
5782 kSVOP->op_sv = Nullsv;
5784 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5793 Perl_ck_null(pTHX_ OP *o)
5799 Perl_ck_open(pTHX_ OP *o)
5801 HV *table = GvHV(PL_hintgv);
5805 svp = hv_fetch(table, "open_IN", 7, FALSE);
5807 mode = mode_from_discipline(*svp);
5808 if (mode & O_BINARY)
5809 o->op_private |= OPpOPEN_IN_RAW;
5810 else if (mode & O_TEXT)
5811 o->op_private |= OPpOPEN_IN_CRLF;
5814 svp = hv_fetch(table, "open_OUT", 8, FALSE);
5816 mode = mode_from_discipline(*svp);
5817 if (mode & O_BINARY)
5818 o->op_private |= OPpOPEN_OUT_RAW;
5819 else if (mode & O_TEXT)
5820 o->op_private |= OPpOPEN_OUT_CRLF;
5823 if (o->op_type == OP_BACKTICK)
5826 /* In case of three-arg dup open remove strictness
5827 * from the last arg if it is a bareword. */
5828 OP *first = cLISTOPx(o)->op_first; /* The pushmark. */
5829 OP *last = cLISTOPx(o)->op_last; /* The bareword. */
5833 if ((last->op_type == OP_CONST) && /* The bareword. */
5834 (last->op_private & OPpCONST_BARE) &&
5835 (last->op_private & OPpCONST_STRICT) &&
5836 (oa = first->op_sibling) && /* The fh. */
5837 (oa = oa->op_sibling) && /* The mode. */
5838 SvPOK(((SVOP*)oa)->op_sv) &&
5839 (mode = SvPVX(((SVOP*)oa)->op_sv)) &&
5840 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
5841 (last == oa->op_sibling)) /* The bareword. */
5842 last->op_private &= ~OPpCONST_STRICT;
5848 Perl_ck_repeat(pTHX_ OP *o)
5850 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5851 o->op_private |= OPpREPEAT_DOLIST;
5852 cBINOPo->op_first = force_list(cBINOPo->op_first);
5860 Perl_ck_require(pTHX_ OP *o)
5864 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
5865 SVOP *kid = (SVOP*)cUNOPo->op_first;
5867 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5869 for (s = SvPVX(kid->op_sv); *s; s++) {
5870 if (*s == ':' && s[1] == ':') {
5872 Move(s+2, s+1, strlen(s+2)+1, char);
5873 --SvCUR(kid->op_sv);
5876 if (SvREADONLY(kid->op_sv)) {
5877 SvREADONLY_off(kid->op_sv);
5878 sv_catpvn(kid->op_sv, ".pm", 3);
5879 SvREADONLY_on(kid->op_sv);
5882 sv_catpvn(kid->op_sv, ".pm", 3);
5886 /* handle override, if any */
5887 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
5888 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
5889 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
5891 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5892 OP *kid = cUNOPo->op_first;
5893 cUNOPo->op_first = 0;
5895 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5896 append_elem(OP_LIST, kid,
5897 scalar(newUNOP(OP_RV2CV, 0,
5906 Perl_ck_return(pTHX_ OP *o)
5908 if (CvLVALUE(PL_compcv)) {
5910 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5911 mod(kid, OP_LEAVESUBLV);
5918 Perl_ck_retarget(pTHX_ OP *o)
5920 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5927 Perl_ck_select(pTHX_ OP *o)
5930 if (o->op_flags & OPf_KIDS) {
5931 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5932 if (kid && kid->op_sibling) {
5933 o->op_type = OP_SSELECT;
5934 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
5936 return fold_constants(o);
5940 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5941 if (kid && kid->op_type == OP_RV2GV)
5942 kid->op_private &= ~HINT_STRICT_REFS;
5947 Perl_ck_shift(pTHX_ OP *o)
5949 const I32 type = o->op_type;
5951 if (!(o->op_flags & OPf_KIDS)) {
5955 argop = newUNOP(OP_RV2AV, 0,
5956 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
5957 return newUNOP(type, 0, scalar(argop));
5959 return scalar(modkids(ck_fun(o), type));
5963 Perl_ck_sort(pTHX_ OP *o)
5967 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
5969 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5970 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
5972 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
5974 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
5976 if (kid->op_type == OP_SCOPE) {
5980 else if (kid->op_type == OP_LEAVE) {
5981 if (o->op_type == OP_SORT) {
5982 op_null(kid); /* wipe out leave */
5985 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
5986 if (k->op_next == kid)
5988 /* don't descend into loops */
5989 else if (k->op_type == OP_ENTERLOOP
5990 || k->op_type == OP_ENTERITER)
5992 k = cLOOPx(k)->op_lastop;
5997 kid->op_next = 0; /* just disconnect the leave */
5998 k = kLISTOP->op_first;
6003 if (o->op_type == OP_SORT) {
6004 /* provide scalar context for comparison function/block */
6010 o->op_flags |= OPf_SPECIAL;
6012 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6015 firstkid = firstkid->op_sibling;
6018 /* provide list context for arguments */
6019 if (o->op_type == OP_SORT)
6026 S_simplify_sort(pTHX_ OP *o)
6028 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6033 if (!(o->op_flags & OPf_STACKED))
6035 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6036 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6037 kid = kUNOP->op_first; /* get past null */
6038 if (kid->op_type != OP_SCOPE)
6040 kid = kLISTOP->op_last; /* get past scope */
6041 switch(kid->op_type) {
6049 k = kid; /* remember this node*/
6050 if (kBINOP->op_first->op_type != OP_RV2SV)
6052 kid = kBINOP->op_first; /* get past cmp */
6053 if (kUNOP->op_first->op_type != OP_GV)
6055 kid = kUNOP->op_first; /* get past rv2sv */
6057 if (GvSTASH(gv) != PL_curstash)
6059 gvname = GvNAME(gv);
6060 if (*gvname == 'a' && gvname[1] == '\0')
6062 else if (*gvname == 'b' && gvname[1] == '\0')
6067 kid = k; /* back to cmp */
6068 if (kBINOP->op_last->op_type != OP_RV2SV)
6070 kid = kBINOP->op_last; /* down to 2nd arg */
6071 if (kUNOP->op_first->op_type != OP_GV)
6073 kid = kUNOP->op_first; /* get past rv2sv */
6075 if (GvSTASH(gv) != PL_curstash)
6077 gvname = GvNAME(gv);
6079 ? !(*gvname == 'a' && gvname[1] == '\0')
6080 : !(*gvname == 'b' && gvname[1] == '\0'))
6082 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6084 o->op_private |= OPpSORT_DESCEND;
6085 if (k->op_type == OP_NCMP)
6086 o->op_private |= OPpSORT_NUMERIC;
6087 if (k->op_type == OP_I_NCMP)
6088 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6089 kid = cLISTOPo->op_first->op_sibling;
6090 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6091 op_free(kid); /* then delete it */
6095 Perl_ck_split(pTHX_ OP *o)
6099 if (o->op_flags & OPf_STACKED)
6100 return no_fh_allowed(o);
6102 kid = cLISTOPo->op_first;
6103 if (kid->op_type != OP_NULL)
6104 Perl_croak(aTHX_ "panic: ck_split");
6105 kid = kid->op_sibling;
6106 op_free(cLISTOPo->op_first);
6107 cLISTOPo->op_first = kid;
6109 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6110 cLISTOPo->op_last = kid; /* There was only one element previously */
6113 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6114 OP *sibl = kid->op_sibling;
6115 kid->op_sibling = 0;
6116 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
6117 if (cLISTOPo->op_first == cLISTOPo->op_last)
6118 cLISTOPo->op_last = kid;
6119 cLISTOPo->op_first = kid;
6120 kid->op_sibling = sibl;
6123 kid->op_type = OP_PUSHRE;
6124 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6126 if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
6127 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
6128 "Use of /g modifier is meaningless in split");
6131 if (!kid->op_sibling)
6132 append_elem(OP_SPLIT, o, newDEFSVOP());
6134 kid = kid->op_sibling;
6137 if (!kid->op_sibling)
6138 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6140 kid = kid->op_sibling;
6143 if (kid->op_sibling)
6144 return too_many_arguments(o,OP_DESC(o));
6150 Perl_ck_join(pTHX_ OP *o)
6152 if (ckWARN(WARN_SYNTAX)) {
6153 const OP *kid = cLISTOPo->op_first->op_sibling;
6154 if (kid && kid->op_type == OP_MATCH) {
6155 const REGEXP *re = PM_GETRE(kPMOP);
6156 const char *pmstr = re ? re->precomp : "STRING";
6157 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6158 "/%s/ should probably be written as \"%s\"",
6166 Perl_ck_subr(pTHX_ OP *o)
6168 OP *prev = ((cUNOPo->op_first->op_sibling)
6169 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6170 OP *o2 = prev->op_sibling;
6177 I32 contextclass = 0;
6182 o->op_private |= OPpENTERSUB_HASTARG;
6183 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6184 if (cvop->op_type == OP_RV2CV) {
6186 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6187 op_null(cvop); /* disable rv2cv */
6188 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6189 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6190 GV *gv = cGVOPx_gv(tmpop);
6193 tmpop->op_private |= OPpEARLY_CV;
6196 namegv = CvANON(cv) ? gv : CvGV(cv);
6197 proto = SvPV((SV*)cv, n_a);
6199 if (CvASSERTION(cv)) {
6200 if (PL_hints & HINT_ASSERTING) {
6201 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
6202 o->op_private |= OPpENTERSUB_DB;
6206 if (ckWARN(WARN_ASSERTIONS) && !(PL_hints & HINT_ASSERTIONSSEEN)) {
6207 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
6208 "Impossible to activate assertion call");
6215 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6216 if (o2->op_type == OP_CONST)
6217 o2->op_private &= ~OPpCONST_STRICT;
6218 else if (o2->op_type == OP_LIST) {
6219 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6220 if (o && o->op_type == OP_CONST)
6221 o->op_private &= ~OPpCONST_STRICT;
6224 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6225 if (PERLDB_SUB && PL_curstash != PL_debstash)
6226 o->op_private |= OPpENTERSUB_DB;
6227 while (o2 != cvop) {
6231 return too_many_arguments(o, gv_ename(namegv));
6249 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6251 arg == 1 ? "block or sub {}" : "sub {}",
6252 gv_ename(namegv), o2);
6255 /* '*' allows any scalar type, including bareword */
6258 if (o2->op_type == OP_RV2GV)
6259 goto wrapref; /* autoconvert GLOB -> GLOBref */
6260 else if (o2->op_type == OP_CONST)
6261 o2->op_private &= ~OPpCONST_STRICT;
6262 else if (o2->op_type == OP_ENTERSUB) {
6263 /* accidental subroutine, revert to bareword */
6264 OP *gvop = ((UNOP*)o2)->op_first;
6265 if (gvop && gvop->op_type == OP_NULL) {
6266 gvop = ((UNOP*)gvop)->op_first;
6268 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6271 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6272 (gvop = ((UNOP*)gvop)->op_first) &&
6273 gvop->op_type == OP_GV)
6275 GV *gv = cGVOPx_gv(gvop);
6276 OP *sibling = o2->op_sibling;
6277 SV *n = newSVpvn("",0);
6279 gv_fullname4(n, gv, "", FALSE);
6280 o2 = newSVOP(OP_CONST, 0, n);
6281 prev->op_sibling = o2;
6282 o2->op_sibling = sibling;
6298 if (contextclass++ == 0) {
6299 e = strchr(proto, ']');
6300 if (!e || e == proto)
6313 while (*--p != '[');
6314 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6315 gv_ename(namegv), o2);
6321 if (o2->op_type == OP_RV2GV)
6324 bad_type(arg, "symbol", gv_ename(namegv), o2);
6327 if (o2->op_type == OP_ENTERSUB)
6330 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6333 if (o2->op_type == OP_RV2SV ||
6334 o2->op_type == OP_PADSV ||
6335 o2->op_type == OP_HELEM ||
6336 o2->op_type == OP_AELEM ||
6337 o2->op_type == OP_THREADSV)
6340 bad_type(arg, "scalar", gv_ename(namegv), o2);
6343 if (o2->op_type == OP_RV2AV ||
6344 o2->op_type == OP_PADAV)
6347 bad_type(arg, "array", gv_ename(namegv), o2);
6350 if (o2->op_type == OP_RV2HV ||
6351 o2->op_type == OP_PADHV)
6354 bad_type(arg, "hash", gv_ename(namegv), o2);
6359 OP* sib = kid->op_sibling;
6360 kid->op_sibling = 0;
6361 o2 = newUNOP(OP_REFGEN, 0, kid);
6362 o2->op_sibling = sib;
6363 prev->op_sibling = o2;
6365 if (contextclass && e) {
6380 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6381 gv_ename(namegv), cv);
6386 mod(o2, OP_ENTERSUB);
6388 o2 = o2->op_sibling;
6390 if (proto && !optional &&
6391 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6392 return too_few_arguments(o, gv_ename(namegv));
6395 o=newSVOP(OP_CONST, 0, newSViv(0));
6401 Perl_ck_svconst(pTHX_ OP *o)
6403 SvREADONLY_on(cSVOPo->op_sv);
6408 Perl_ck_trunc(pTHX_ OP *o)
6410 if (o->op_flags & OPf_KIDS) {
6411 SVOP *kid = (SVOP*)cUNOPo->op_first;
6413 if (kid->op_type == OP_NULL)
6414 kid = (SVOP*)kid->op_sibling;
6415 if (kid && kid->op_type == OP_CONST &&
6416 (kid->op_private & OPpCONST_BARE))
6418 o->op_flags |= OPf_SPECIAL;
6419 kid->op_private &= ~OPpCONST_STRICT;
6426 Perl_ck_unpack(pTHX_ OP *o)
6428 OP *kid = cLISTOPo->op_first;
6429 if (kid->op_sibling) {
6430 kid = kid->op_sibling;
6431 if (!kid->op_sibling)
6432 kid->op_sibling = newDEFSVOP();
6438 Perl_ck_substr(pTHX_ OP *o)
6441 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6442 OP *kid = cLISTOPo->op_first;
6444 if (kid->op_type == OP_NULL)
6445 kid = kid->op_sibling;
6447 kid->op_flags |= OPf_MOD;
6453 /* A peephole optimizer. We visit the ops in the order they're to execute.
6454 * See the comments at the top of this file for more details about when
6455 * peep() is called */
6458 Perl_peep(pTHX_ register OP *o)
6460 register OP* oldop = 0;
6462 if (!o || o->op_opt)
6466 SAVEVPTR(PL_curcop);
6467 for (; o; o = o->op_next) {
6471 switch (o->op_type) {
6475 PL_curcop = ((COP*)o); /* for warnings */
6480 if (cSVOPo->op_private & OPpCONST_STRICT)
6481 no_bareword_allowed(o);
6483 case OP_METHOD_NAMED:
6484 /* Relocate sv to the pad for thread safety.
6485 * Despite being a "constant", the SV is written to,
6486 * for reference counts, sv_upgrade() etc. */
6488 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6489 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6490 /* If op_sv is already a PADTMP then it is being used by
6491 * some pad, so make a copy. */
6492 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6493 SvREADONLY_on(PAD_SVl(ix));
6494 SvREFCNT_dec(cSVOPo->op_sv);
6497 SvREFCNT_dec(PAD_SVl(ix));
6498 SvPADTMP_on(cSVOPo->op_sv);
6499 PAD_SETSV(ix, cSVOPo->op_sv);
6500 /* XXX I don't know how this isn't readonly already. */
6501 SvREADONLY_on(PAD_SVl(ix));
6503 cSVOPo->op_sv = Nullsv;
6511 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6512 if (o->op_next->op_private & OPpTARGET_MY) {
6513 if (o->op_flags & OPf_STACKED) /* chained concats */
6514 goto ignore_optimization;
6516 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6517 o->op_targ = o->op_next->op_targ;
6518 o->op_next->op_targ = 0;
6519 o->op_private |= OPpTARGET_MY;
6522 op_null(o->op_next);
6524 ignore_optimization:
6528 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6530 break; /* Scalar stub must produce undef. List stub is noop */
6534 if (o->op_targ == OP_NEXTSTATE
6535 || o->op_targ == OP_DBSTATE
6536 || o->op_targ == OP_SETSTATE)
6538 PL_curcop = ((COP*)o);
6540 /* XXX: We avoid setting op_seq here to prevent later calls
6541 to peep() from mistakenly concluding that optimisation
6542 has already occurred. This doesn't fix the real problem,
6543 though (See 20010220.007). AMS 20010719 */
6544 /* op_seq functionality is now replaced by op_opt */
6545 if (oldop && o->op_next) {
6546 oldop->op_next = o->op_next;
6554 if (oldop && o->op_next) {
6555 oldop->op_next = o->op_next;
6563 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
6564 OP* pop = (o->op_type == OP_PADAV) ?
6565 o->op_next : o->op_next->op_next;
6567 if (pop && pop->op_type == OP_CONST &&
6568 ((PL_op = pop->op_next)) &&
6569 pop->op_next->op_type == OP_AELEM &&
6570 !(pop->op_next->op_private &
6571 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6572 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6577 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
6578 no_bareword_allowed(pop);
6579 if (o->op_type == OP_GV)
6580 op_null(o->op_next);
6581 op_null(pop->op_next);
6583 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6584 o->op_next = pop->op_next->op_next;
6585 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6586 o->op_private = (U8)i;
6587 if (o->op_type == OP_GV) {
6592 o->op_flags |= OPf_SPECIAL;
6593 o->op_type = OP_AELEMFAST;
6599 if (o->op_next->op_type == OP_RV2SV) {
6600 if (!(o->op_next->op_private & OPpDEREF)) {
6601 op_null(o->op_next);
6602 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6604 o->op_next = o->op_next->op_next;
6605 o->op_type = OP_GVSV;
6606 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6609 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6611 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6612 /* XXX could check prototype here instead of just carping */
6613 SV *sv = sv_newmortal();
6614 gv_efullname3(sv, gv, Nullch);
6615 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6616 "%"SVf"() called too early to check prototype",
6620 else if (o->op_next->op_type == OP_READLINE
6621 && o->op_next->op_next->op_type == OP_CONCAT
6622 && (o->op_next->op_next->op_flags & OPf_STACKED))
6624 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6625 o->op_type = OP_RCATLINE;
6626 o->op_flags |= OPf_STACKED;
6627 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6628 op_null(o->op_next->op_next);
6629 op_null(o->op_next);
6646 while (cLOGOP->op_other->op_type == OP_NULL)
6647 cLOGOP->op_other = cLOGOP->op_other->op_next;
6648 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6654 while (cLOOP->op_redoop->op_type == OP_NULL)
6655 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6656 peep(cLOOP->op_redoop);
6657 while (cLOOP->op_nextop->op_type == OP_NULL)
6658 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6659 peep(cLOOP->op_nextop);
6660 while (cLOOP->op_lastop->op_type == OP_NULL)
6661 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6662 peep(cLOOP->op_lastop);
6669 while (cPMOP->op_pmreplstart &&
6670 cPMOP->op_pmreplstart->op_type == OP_NULL)
6671 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6672 peep(cPMOP->op_pmreplstart);
6677 if (ckWARN(WARN_SYNTAX) && o->op_next
6678 && o->op_next->op_type == OP_NEXTSTATE) {
6679 if (o->op_next->op_sibling &&
6680 o->op_next->op_sibling->op_type != OP_EXIT &&
6681 o->op_next->op_sibling->op_type != OP_WARN &&
6682 o->op_next->op_sibling->op_type != OP_DIE) {
6683 const line_t oldline = CopLINE(PL_curcop);
6685 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6686 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6687 "Statement unlikely to be reached");
6688 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6689 "\t(Maybe you meant system() when you said exec()?)\n");
6690 CopLINE_set(PL_curcop, oldline);
6705 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6708 /* Make the CONST have a shared SV */
6709 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6710 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6711 key = SvPV(sv, keylen);
6712 lexname = newSVpvn_share(key,
6713 SvUTF8(sv) ? -(I32)keylen : keylen,
6719 if ((o->op_private & (OPpLVAL_INTRO)))
6722 rop = (UNOP*)((BINOP*)o)->op_first;
6723 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6725 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6726 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6728 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6729 if (!fields || !GvHV(*fields))
6731 key = SvPV(*svp, keylen);
6732 if (!hv_fetch(GvHV(*fields), key,
6733 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
6735 Perl_croak(aTHX_ "No such class field \"%s\" "
6736 "in variable %s of type %s",
6737 key, SvPV_nolen(lexname), HvNAME(SvSTASH(lexname)));
6750 SVOP *first_key_op, *key_op;
6752 if ((o->op_private & (OPpLVAL_INTRO))
6753 /* I bet there's always a pushmark... */
6754 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6755 /* hmmm, no optimization if list contains only one key. */
6757 rop = (UNOP*)((LISTOP*)o)->op_last;
6758 if (rop->op_type != OP_RV2HV)
6760 if (rop->op_first->op_type == OP_PADSV)
6761 /* @$hash{qw(keys here)} */
6762 rop = (UNOP*)rop->op_first;
6764 /* @{$hash}{qw(keys here)} */
6765 if (rop->op_first->op_type == OP_SCOPE
6766 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
6768 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
6774 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
6775 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6777 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6778 if (!fields || !GvHV(*fields))
6780 /* Again guessing that the pushmark can be jumped over.... */
6781 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
6782 ->op_first->op_sibling;
6783 for (key_op = first_key_op; key_op;
6784 key_op = (SVOP*)key_op->op_sibling) {
6785 if (key_op->op_type != OP_CONST)
6787 svp = cSVOPx_svp(key_op);
6788 key = SvPV(*svp, keylen);
6789 if (!hv_fetch(GvHV(*fields), key,
6790 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
6792 Perl_croak(aTHX_ "No such class field \"%s\" "
6793 "in variable %s of type %s",
6794 key, SvPV_nolen(lexname), HvNAME(SvSTASH(lexname)));
6801 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
6805 /* check that RHS of sort is a single plain array */
6806 oright = cUNOPo->op_first;
6807 if (!oright || oright->op_type != OP_PUSHMARK)
6810 /* reverse sort ... can be optimised. */
6811 if (!cUNOPo->op_sibling) {
6812 /* Nothing follows us on the list. */
6813 OP *reverse = o->op_next;
6815 if (reverse->op_type == OP_REVERSE &&
6816 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
6817 OP *pushmark = cUNOPx(reverse)->op_first;
6818 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
6819 && (cUNOPx(pushmark)->op_sibling == o)) {
6820 /* reverse -> pushmark -> sort */
6821 o->op_private |= OPpSORT_REVERSE;
6823 pushmark->op_next = oright->op_next;
6829 /* make @a = sort @a act in-place */
6833 oright = cUNOPx(oright)->op_sibling;
6836 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
6837 oright = cUNOPx(oright)->op_sibling;
6841 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
6842 || oright->op_next != o
6843 || (oright->op_private & OPpLVAL_INTRO)
6847 /* o2 follows the chain of op_nexts through the LHS of the
6848 * assign (if any) to the aassign op itself */
6850 if (!o2 || o2->op_type != OP_NULL)
6853 if (!o2 || o2->op_type != OP_PUSHMARK)
6856 if (o2 && o2->op_type == OP_GV)
6859 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
6860 || (o2->op_private & OPpLVAL_INTRO)
6865 if (!o2 || o2->op_type != OP_NULL)
6868 if (!o2 || o2->op_type != OP_AASSIGN
6869 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
6872 /* check that the sort is the first arg on RHS of assign */
6874 o2 = cUNOPx(o2)->op_first;
6875 if (!o2 || o2->op_type != OP_NULL)
6877 o2 = cUNOPx(o2)->op_first;
6878 if (!o2 || o2->op_type != OP_PUSHMARK)
6880 if (o2->op_sibling != o)
6883 /* check the array is the same on both sides */
6884 if (oleft->op_type == OP_RV2AV) {
6885 if (oright->op_type != OP_RV2AV
6886 || !cUNOPx(oright)->op_first
6887 || cUNOPx(oright)->op_first->op_type != OP_GV
6888 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
6889 cGVOPx_gv(cUNOPx(oright)->op_first)
6893 else if (oright->op_type != OP_PADAV
6894 || oright->op_targ != oleft->op_targ
6898 /* transfer MODishness etc from LHS arg to RHS arg */
6899 oright->op_flags = oleft->op_flags;
6900 o->op_private |= OPpSORT_INPLACE;
6902 /* excise push->gv->rv2av->null->aassign */
6903 o2 = o->op_next->op_next;
6904 op_null(o2); /* PUSHMARK */
6906 if (o2->op_type == OP_GV) {
6907 op_null(o2); /* GV */
6910 op_null(o2); /* RV2AV or PADAV */
6911 o2 = o2->op_next->op_next;
6912 op_null(o2); /* AASSIGN */
6914 o->op_next = o2->op_next;
6920 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
6922 LISTOP *enter, *exlist;
6925 enter = (LISTOP *) o->op_next;
6928 if (enter->op_type == OP_NULL) {
6929 enter = (LISTOP *) enter->op_next;
6933 /* for $a (...) will have OP_GV then OP_RV2GV here.
6934 for (...) just has an OP_GV. */
6935 if (enter->op_type == OP_GV) {
6936 gvop = (OP *) enter;
6937 enter = (LISTOP *) enter->op_next;
6940 if (enter->op_type == OP_RV2GV) {
6941 enter = (LISTOP *) enter->op_next;
6947 if (enter->op_type != OP_ENTERITER)
6950 iter = enter->op_next;
6951 if (!iter || iter->op_type != OP_ITER)
6954 expushmark = enter->op_first;
6955 if (!expushmark || expushmark->op_type != OP_NULL
6956 || expushmark->op_targ != OP_PUSHMARK)
6959 exlist = (LISTOP *) expushmark->op_sibling;
6960 if (!exlist || exlist->op_type != OP_NULL
6961 || exlist->op_targ != OP_LIST)
6964 if (exlist->op_last != o) {
6965 /* Mmm. Was expecting to point back to this op. */
6968 theirmark = exlist->op_first;
6969 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
6972 if (theirmark->op_sibling != o) {
6973 /* There's something between the mark and the reverse, eg
6974 for (1, reverse (...))
6979 ourmark = ((LISTOP *)o)->op_first;
6980 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
6983 ourlast = ((LISTOP *)o)->op_last;
6984 if (!ourlast || ourlast->op_next != o)
6987 rv2av = ourmark->op_sibling;
6988 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
6989 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
6990 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
6991 /* We're just reversing a single array. */
6992 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
6993 enter->op_flags |= OPf_STACKED;
6996 /* We don't have control over who points to theirmark, so sacrifice
6998 theirmark->op_next = ourmark->op_next;
6999 theirmark->op_flags = ourmark->op_flags;
7000 ourlast->op_next = gvop ? gvop : (OP *) enter;
7003 enter->op_private |= OPpITER_REVERSED;
7004 iter->op_private |= OPpITER_REVERSED;
7019 Perl_custom_op_name(pTHX_ const OP* o)
7021 const IV index = PTR2IV(o->op_ppaddr);
7025 if (!PL_custom_op_names) /* This probably shouldn't happen */
7026 return PL_op_name[OP_CUSTOM];
7028 keysv = sv_2mortal(newSViv(index));
7030 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7032 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7034 return SvPV_nolen(HeVAL(he));
7038 Perl_custom_op_desc(pTHX_ const OP* o)
7040 const IV index = PTR2IV(o->op_ppaddr);
7044 if (!PL_custom_op_descs)
7045 return PL_op_desc[OP_CUSTOM];
7047 keysv = sv_2mortal(newSViv(index));
7049 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7051 return PL_op_desc[OP_CUSTOM];
7053 return SvPV_nolen(HeVAL(he));
7058 /* Efficient sub that returns a constant scalar value. */
7060 const_sv_xsub(pTHX_ CV* cv)
7065 Perl_croak(aTHX_ "usage: %s::%s()",
7066 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7070 ST(0) = (SV*)XSANY.any_ptr;