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);
1592 PERL_HASH(hash, SvPVX(meth), SvCUR(meth));
1593 SvUV_set(meth, hash);
1595 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1596 append_elem(OP_LIST,
1597 prepend_elem(OP_LIST, pack, list(arg)),
1598 newSVOP(OP_METHOD_NAMED, 0, meth)));
1599 imop->op_private |= OPpENTERSUB_NOMOD;
1601 /* Combine the ops. */
1602 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1606 =notfor apidoc apply_attrs_string
1608 Attempts to apply a list of attributes specified by the C<attrstr> and
1609 C<len> arguments to the subroutine identified by the C<cv> argument which
1610 is expected to be associated with the package identified by the C<stashpv>
1611 argument (see L<attributes>). It gets this wrong, though, in that it
1612 does not correctly identify the boundaries of the individual attribute
1613 specifications within C<attrstr>. This is not really intended for the
1614 public API, but has to be listed here for systems such as AIX which
1615 need an explicit export list for symbols. (It's called from XS code
1616 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1617 to respect attribute syntax properly would be welcome.
1623 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1624 const char *attrstr, STRLEN len)
1629 len = strlen(attrstr);
1633 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1635 const char *sstr = attrstr;
1636 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1637 attrs = append_elem(OP_LIST, attrs,
1638 newSVOP(OP_CONST, 0,
1639 newSVpvn(sstr, attrstr-sstr)));
1643 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1644 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1645 Nullsv, prepend_elem(OP_LIST,
1646 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1647 prepend_elem(OP_LIST,
1648 newSVOP(OP_CONST, 0,
1654 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1658 if (!o || PL_error_count)
1662 if (type == OP_LIST) {
1664 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1665 my_kid(kid, attrs, imopsp);
1666 } else if (type == OP_UNDEF) {
1668 } else if (type == OP_RV2SV || /* "our" declaration */
1670 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1671 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1672 yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
1673 OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
1675 GV *gv = cGVOPx_gv(cUNOPo->op_first);
1677 PL_in_my_stash = Nullhv;
1678 apply_attrs(GvSTASH(gv),
1679 (type == OP_RV2SV ? GvSV(gv) :
1680 type == OP_RV2AV ? (SV*)GvAV(gv) :
1681 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1684 o->op_private |= OPpOUR_INTRO;
1687 else if (type != OP_PADSV &&
1690 type != OP_PUSHMARK)
1692 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1694 PL_in_my == KEY_our ? "our" : "my"));
1697 else if (attrs && type != OP_PUSHMARK) {
1701 PL_in_my_stash = Nullhv;
1703 /* check for C<my Dog $spot> when deciding package */
1704 stash = PAD_COMPNAME_TYPE(o->op_targ);
1706 stash = PL_curstash;
1707 apply_attrs_my(stash, o, attrs, imopsp);
1709 o->op_flags |= OPf_MOD;
1710 o->op_private |= OPpLVAL_INTRO;
1715 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1718 int maybe_scalar = 0;
1720 /* [perl #17376]: this appears to be premature, and results in code such as
1721 C< our(%x); > executing in list mode rather than void mode */
1723 if (o->op_flags & OPf_PARENS)
1732 o = my_kid(o, attrs, &rops);
1734 if (maybe_scalar && o->op_type == OP_PADSV) {
1735 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1736 o->op_private |= OPpLVAL_INTRO;
1739 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1742 PL_in_my_stash = Nullhv;
1747 Perl_my(pTHX_ OP *o)
1749 return my_attrs(o, Nullop);
1753 Perl_sawparens(pTHX_ OP *o)
1756 o->op_flags |= OPf_PARENS;
1761 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1766 if (ckWARN(WARN_MISC) &&
1767 (left->op_type == OP_RV2AV ||
1768 left->op_type == OP_RV2HV ||
1769 left->op_type == OP_PADAV ||
1770 left->op_type == OP_PADHV)) {
1771 const char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
1772 right->op_type == OP_TRANS)
1773 ? right->op_type : OP_MATCH];
1774 const char *sample = ((left->op_type == OP_RV2AV ||
1775 left->op_type == OP_PADAV)
1776 ? "@array" : "%hash");
1777 Perl_warner(aTHX_ packWARN(WARN_MISC),
1778 "Applying %s to %s will act on scalar(%s)",
1779 desc, sample, sample);
1782 if (right->op_type == OP_CONST &&
1783 cSVOPx(right)->op_private & OPpCONST_BARE &&
1784 cSVOPx(right)->op_private & OPpCONST_STRICT)
1786 no_bareword_allowed(right);
1789 ismatchop = right->op_type == OP_MATCH ||
1790 right->op_type == OP_SUBST ||
1791 right->op_type == OP_TRANS;
1792 if (ismatchop && right->op_private & OPpTARGET_MY) {
1794 right->op_private &= ~OPpTARGET_MY;
1796 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1797 right->op_flags |= OPf_STACKED;
1798 if (right->op_type != OP_MATCH &&
1799 ! (right->op_type == OP_TRANS &&
1800 right->op_private & OPpTRANS_IDENTICAL))
1801 left = mod(left, right->op_type);
1802 if (right->op_type == OP_TRANS)
1803 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
1805 o = prepend_elem(right->op_type, scalar(left), right);
1807 return newUNOP(OP_NOT, 0, scalar(o));
1811 return bind_match(type, left,
1812 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
1816 Perl_invert(pTHX_ OP *o)
1820 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
1821 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1825 Perl_scope(pTHX_ OP *o)
1828 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1829 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1830 o->op_type = OP_LEAVE;
1831 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1833 else if (o->op_type == OP_LINESEQ) {
1835 o->op_type = OP_SCOPE;
1836 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1837 kid = ((LISTOP*)o)->op_first;
1838 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
1842 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
1847 /* XXX kept for BINCOMPAT only */
1849 Perl_save_hints(pTHX)
1851 Perl_croak(aTHX_ "internal error: obsolete function save_hints() called");
1855 Perl_block_start(pTHX_ int full)
1857 const int retval = PL_savestack_ix;
1858 pad_block_start(full);
1860 PL_hints &= ~HINT_BLOCK_SCOPE;
1861 SAVESPTR(PL_compiling.cop_warnings);
1862 if (! specialWARN(PL_compiling.cop_warnings)) {
1863 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1864 SAVEFREESV(PL_compiling.cop_warnings) ;
1866 SAVESPTR(PL_compiling.cop_io);
1867 if (! specialCopIO(PL_compiling.cop_io)) {
1868 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1869 SAVEFREESV(PL_compiling.cop_io) ;
1875 Perl_block_end(pTHX_ I32 floor, OP *seq)
1877 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1878 OP* retval = scalarseq(seq);
1880 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
1882 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
1890 const I32 offset = pad_findmy("$_");
1891 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
1892 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1895 OP *o = newOP(OP_PADSV, 0);
1896 o->op_targ = offset;
1902 Perl_newPROG(pTHX_ OP *o)
1907 PL_eval_root = newUNOP(OP_LEAVEEVAL,
1908 ((PL_in_eval & EVAL_KEEPERR)
1909 ? OPf_SPECIAL : 0), o);
1910 PL_eval_start = linklist(PL_eval_root);
1911 PL_eval_root->op_private |= OPpREFCOUNTED;
1912 OpREFCNT_set(PL_eval_root, 1);
1913 PL_eval_root->op_next = 0;
1914 CALL_PEEP(PL_eval_start);
1917 if (o->op_type == OP_STUB) {
1918 PL_comppad_name = 0;
1923 PL_main_root = scope(sawparens(scalarvoid(o)));
1924 PL_curcop = &PL_compiling;
1925 PL_main_start = LINKLIST(PL_main_root);
1926 PL_main_root->op_private |= OPpREFCOUNTED;
1927 OpREFCNT_set(PL_main_root, 1);
1928 PL_main_root->op_next = 0;
1929 CALL_PEEP(PL_main_start);
1932 /* Register with debugger */
1934 CV *cv = get_cv("DB::postponed", FALSE);
1938 XPUSHs((SV*)CopFILEGV(&PL_compiling));
1940 call_sv((SV*)cv, G_DISCARD);
1947 Perl_localize(pTHX_ OP *o, I32 lex)
1949 if (o->op_flags & OPf_PARENS)
1950 /* [perl #17376]: this appears to be premature, and results in code such as
1951 C< our(%x); > executing in list mode rather than void mode */
1958 if (ckWARN(WARN_PARENTHESIS)
1959 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
1961 char *s = PL_bufptr;
1964 /* some heuristics to detect a potential error */
1965 while (*s && (strchr(", \t\n", *s)))
1969 if (*s && strchr("@$%*", *s) && *++s
1970 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
1973 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
1975 while (*s && (strchr(", \t\n", *s)))
1981 if (sigil && (*s == ';' || *s == '=')) {
1982 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
1983 "Parentheses missing around \"%s\" list",
1984 lex ? (PL_in_my == KEY_our ? "our" : "my")
1992 o = mod(o, OP_NULL); /* a bit kludgey */
1994 PL_in_my_stash = Nullhv;
1999 Perl_jmaybe(pTHX_ OP *o)
2001 if (o->op_type == OP_LIST) {
2003 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2004 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2010 Perl_fold_constants(pTHX_ register OP *o)
2013 I32 type = o->op_type;
2016 if (PL_opargs[type] & OA_RETSCALAR)
2018 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2019 o->op_targ = pad_alloc(type, SVs_PADTMP);
2021 /* integerize op, unless it happens to be C<-foo>.
2022 * XXX should pp_i_negate() do magic string negation instead? */
2023 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2024 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2025 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2027 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2030 if (!(PL_opargs[type] & OA_FOLDCONST))
2035 /* XXX might want a ck_negate() for this */
2036 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2048 /* XXX what about the numeric ops? */
2049 if (PL_hints & HINT_LOCALE)
2054 goto nope; /* Don't try to run w/ errors */
2056 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2057 if ((curop->op_type != OP_CONST ||
2058 (curop->op_private & OPpCONST_BARE)) &&
2059 curop->op_type != OP_LIST &&
2060 curop->op_type != OP_SCALAR &&
2061 curop->op_type != OP_NULL &&
2062 curop->op_type != OP_PUSHMARK)
2068 curop = LINKLIST(o);
2072 sv = *(PL_stack_sp--);
2073 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2074 pad_swipe(o->op_targ, FALSE);
2075 else if (SvTEMP(sv)) { /* grab mortal temp? */
2076 (void)SvREFCNT_inc(sv);
2080 if (type == OP_RV2GV)
2081 return newGVOP(OP_GV, 0, (GV*)sv);
2082 return newSVOP(OP_CONST, 0, sv);
2089 Perl_gen_constant_list(pTHX_ register OP *o)
2092 const I32 oldtmps_floor = PL_tmps_floor;
2096 return o; /* Don't attempt to run with errors */
2098 PL_op = curop = LINKLIST(o);
2105 PL_tmps_floor = oldtmps_floor;
2107 o->op_type = OP_RV2AV;
2108 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2109 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2110 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2111 o->op_opt = 0; /* needs to be revisited in peep() */
2112 curop = ((UNOP*)o)->op_first;
2113 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2120 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2122 if (!o || o->op_type != OP_LIST)
2123 o = newLISTOP(OP_LIST, 0, o, Nullop);
2125 o->op_flags &= ~OPf_WANT;
2127 if (!(PL_opargs[type] & OA_MARK))
2128 op_null(cLISTOPo->op_first);
2130 o->op_type = (OPCODE)type;
2131 o->op_ppaddr = PL_ppaddr[type];
2132 o->op_flags |= flags;
2134 o = CHECKOP(type, o);
2135 if (o->op_type != (unsigned)type)
2138 return fold_constants(o);
2141 /* List constructors */
2144 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2152 if (first->op_type != (unsigned)type
2153 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2155 return newLISTOP(type, 0, first, last);
2158 if (first->op_flags & OPf_KIDS)
2159 ((LISTOP*)first)->op_last->op_sibling = last;
2161 first->op_flags |= OPf_KIDS;
2162 ((LISTOP*)first)->op_first = last;
2164 ((LISTOP*)first)->op_last = last;
2169 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2177 if (first->op_type != (unsigned)type)
2178 return prepend_elem(type, (OP*)first, (OP*)last);
2180 if (last->op_type != (unsigned)type)
2181 return append_elem(type, (OP*)first, (OP*)last);
2183 first->op_last->op_sibling = last->op_first;
2184 first->op_last = last->op_last;
2185 first->op_flags |= (last->op_flags & OPf_KIDS);
2193 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2201 if (last->op_type == (unsigned)type) {
2202 if (type == OP_LIST) { /* already a PUSHMARK there */
2203 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2204 ((LISTOP*)last)->op_first->op_sibling = first;
2205 if (!(first->op_flags & OPf_PARENS))
2206 last->op_flags &= ~OPf_PARENS;
2209 if (!(last->op_flags & OPf_KIDS)) {
2210 ((LISTOP*)last)->op_last = first;
2211 last->op_flags |= OPf_KIDS;
2213 first->op_sibling = ((LISTOP*)last)->op_first;
2214 ((LISTOP*)last)->op_first = first;
2216 last->op_flags |= OPf_KIDS;
2220 return newLISTOP(type, 0, first, last);
2226 Perl_newNULLLIST(pTHX)
2228 return newOP(OP_STUB, 0);
2232 Perl_force_list(pTHX_ OP *o)
2234 if (!o || o->op_type != OP_LIST)
2235 o = newLISTOP(OP_LIST, 0, o, Nullop);
2241 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2245 NewOp(1101, listop, 1, LISTOP);
2247 listop->op_type = (OPCODE)type;
2248 listop->op_ppaddr = PL_ppaddr[type];
2251 listop->op_flags = (U8)flags;
2255 else if (!first && last)
2258 first->op_sibling = last;
2259 listop->op_first = first;
2260 listop->op_last = last;
2261 if (type == OP_LIST) {
2263 pushop = newOP(OP_PUSHMARK, 0);
2264 pushop->op_sibling = first;
2265 listop->op_first = pushop;
2266 listop->op_flags |= OPf_KIDS;
2268 listop->op_last = pushop;
2271 return CHECKOP(type, listop);
2275 Perl_newOP(pTHX_ I32 type, I32 flags)
2278 NewOp(1101, o, 1, OP);
2279 o->op_type = (OPCODE)type;
2280 o->op_ppaddr = PL_ppaddr[type];
2281 o->op_flags = (U8)flags;
2284 o->op_private = (U8)(0 | (flags >> 8));
2285 if (PL_opargs[type] & OA_RETSCALAR)
2287 if (PL_opargs[type] & OA_TARGET)
2288 o->op_targ = pad_alloc(type, SVs_PADTMP);
2289 return CHECKOP(type, o);
2293 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2298 first = newOP(OP_STUB, 0);
2299 if (PL_opargs[type] & OA_MARK)
2300 first = force_list(first);
2302 NewOp(1101, unop, 1, UNOP);
2303 unop->op_type = (OPCODE)type;
2304 unop->op_ppaddr = PL_ppaddr[type];
2305 unop->op_first = first;
2306 unop->op_flags = flags | OPf_KIDS;
2307 unop->op_private = (U8)(1 | (flags >> 8));
2308 unop = (UNOP*) CHECKOP(type, unop);
2312 return fold_constants((OP *) unop);
2316 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2319 NewOp(1101, binop, 1, BINOP);
2322 first = newOP(OP_NULL, 0);
2324 binop->op_type = (OPCODE)type;
2325 binop->op_ppaddr = PL_ppaddr[type];
2326 binop->op_first = first;
2327 binop->op_flags = flags | OPf_KIDS;
2330 binop->op_private = (U8)(1 | (flags >> 8));
2333 binop->op_private = (U8)(2 | (flags >> 8));
2334 first->op_sibling = last;
2337 binop = (BINOP*)CHECKOP(type, binop);
2338 if (binop->op_next || binop->op_type != (OPCODE)type)
2341 binop->op_last = binop->op_first->op_sibling;
2343 return fold_constants((OP *)binop);
2347 uvcompare(const void *a, const void *b)
2349 if (*((const UV *)a) < (*(const UV *)b))
2351 if (*((const UV *)a) > (*(const UV *)b))
2353 if (*((const UV *)a+1) < (*(const UV *)b+1))
2355 if (*((const UV *)a+1) > (*(const UV *)b+1))
2361 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2363 SV *tstr = ((SVOP*)expr)->op_sv;
2364 SV *rstr = ((SVOP*)repl)->op_sv;
2367 U8 *t = (U8*)SvPV(tstr, tlen);
2368 U8 *r = (U8*)SvPV(rstr, rlen);
2375 register short *tbl;
2377 PL_hints |= HINT_BLOCK_SCOPE;
2378 complement = o->op_private & OPpTRANS_COMPLEMENT;
2379 del = o->op_private & OPpTRANS_DELETE;
2380 squash = o->op_private & OPpTRANS_SQUASH;
2383 o->op_private |= OPpTRANS_FROM_UTF;
2386 o->op_private |= OPpTRANS_TO_UTF;
2388 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2389 SV* listsv = newSVpvn("# comment\n",10);
2391 U8* tend = t + tlen;
2392 U8* rend = r + rlen;
2406 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2407 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2413 tsave = t = bytes_to_utf8(t, &len);
2416 if (!to_utf && rlen) {
2418 rsave = r = bytes_to_utf8(r, &len);
2422 /* There are several snags with this code on EBCDIC:
2423 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2424 2. scan_const() in toke.c has encoded chars in native encoding which makes
2425 ranges at least in EBCDIC 0..255 range the bottom odd.
2429 U8 tmpbuf[UTF8_MAXBYTES+1];
2432 New(1109, cp, 2*tlen, UV);
2434 transv = newSVpvn("",0);
2436 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2438 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2440 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2444 cp[2*i+1] = cp[2*i];
2448 qsort(cp, i, 2*sizeof(UV), uvcompare);
2449 for (j = 0; j < i; j++) {
2451 diff = val - nextmin;
2453 t = uvuni_to_utf8(tmpbuf,nextmin);
2454 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2456 U8 range_mark = UTF_TO_NATIVE(0xff);
2457 t = uvuni_to_utf8(tmpbuf, val - 1);
2458 sv_catpvn(transv, (char *)&range_mark, 1);
2459 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2466 t = uvuni_to_utf8(tmpbuf,nextmin);
2467 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2469 U8 range_mark = UTF_TO_NATIVE(0xff);
2470 sv_catpvn(transv, (char *)&range_mark, 1);
2472 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2473 UNICODE_ALLOW_SUPER);
2474 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2475 t = (U8*)SvPVX(transv);
2476 tlen = SvCUR(transv);
2480 else if (!rlen && !del) {
2481 r = t; rlen = tlen; rend = tend;
2484 if ((!rlen && !del) || t == r ||
2485 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2487 o->op_private |= OPpTRANS_IDENTICAL;
2491 while (t < tend || tfirst <= tlast) {
2492 /* see if we need more "t" chars */
2493 if (tfirst > tlast) {
2494 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2496 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2498 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2505 /* now see if we need more "r" chars */
2506 if (rfirst > rlast) {
2508 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2510 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2512 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2521 rfirst = rlast = 0xffffffff;
2525 /* now see which range will peter our first, if either. */
2526 tdiff = tlast - tfirst;
2527 rdiff = rlast - rfirst;
2534 if (rfirst == 0xffffffff) {
2535 diff = tdiff; /* oops, pretend rdiff is infinite */
2537 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2538 (long)tfirst, (long)tlast);
2540 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2544 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2545 (long)tfirst, (long)(tfirst + diff),
2548 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2549 (long)tfirst, (long)rfirst);
2551 if (rfirst + diff > max)
2552 max = rfirst + diff;
2554 grows = (tfirst < rfirst &&
2555 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2567 else if (max > 0xff)
2572 Safefree(cPVOPo->op_pv);
2573 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2574 SvREFCNT_dec(listsv);
2576 SvREFCNT_dec(transv);
2578 if (!del && havefinal && rlen)
2579 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2580 newSVuv((UV)final), 0);
2583 o->op_private |= OPpTRANS_GROWS;
2595 tbl = (short*)cPVOPo->op_pv;
2597 Zero(tbl, 256, short);
2598 for (i = 0; i < (I32)tlen; i++)
2600 for (i = 0, j = 0; i < 256; i++) {
2602 if (j >= (I32)rlen) {
2611 if (i < 128 && r[j] >= 128)
2621 o->op_private |= OPpTRANS_IDENTICAL;
2623 else if (j >= (I32)rlen)
2626 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2627 tbl[0x100] = rlen - j;
2628 for (i=0; i < (I32)rlen - j; i++)
2629 tbl[0x101+i] = r[j+i];
2633 if (!rlen && !del) {
2636 o->op_private |= OPpTRANS_IDENTICAL;
2638 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2639 o->op_private |= OPpTRANS_IDENTICAL;
2641 for (i = 0; i < 256; i++)
2643 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
2644 if (j >= (I32)rlen) {
2646 if (tbl[t[i]] == -1)
2652 if (tbl[t[i]] == -1) {
2653 if (t[i] < 128 && r[j] >= 128)
2660 o->op_private |= OPpTRANS_GROWS;
2668 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2672 NewOp(1101, pmop, 1, PMOP);
2673 pmop->op_type = (OPCODE)type;
2674 pmop->op_ppaddr = PL_ppaddr[type];
2675 pmop->op_flags = (U8)flags;
2676 pmop->op_private = (U8)(0 | (flags >> 8));
2678 if (PL_hints & HINT_RE_TAINT)
2679 pmop->op_pmpermflags |= PMf_RETAINT;
2680 if (PL_hints & HINT_LOCALE)
2681 pmop->op_pmpermflags |= PMf_LOCALE;
2682 pmop->op_pmflags = pmop->op_pmpermflags;
2687 if(av_len((AV*) PL_regex_pad[0]) > -1) {
2688 repointer = av_pop((AV*)PL_regex_pad[0]);
2689 pmop->op_pmoffset = SvIV(repointer);
2690 SvREPADTMP_off(repointer);
2691 sv_setiv(repointer,0);
2693 repointer = newSViv(0);
2694 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2695 pmop->op_pmoffset = av_len(PL_regex_padav);
2696 PL_regex_pad = AvARRAY(PL_regex_padav);
2701 /* link into pm list */
2702 if (type != OP_TRANS && PL_curstash) {
2703 pmop->op_pmnext = HvPMROOT(PL_curstash);
2704 HvPMROOT(PL_curstash) = pmop;
2705 PmopSTASH_set(pmop,PL_curstash);
2708 return CHECKOP(type, pmop);
2711 /* Given some sort of match op o, and an expression expr containing a
2712 * pattern, either compile expr into a regex and attach it to o (if it's
2713 * constant), or convert expr into a runtime regcomp op sequence (if it's
2716 * isreg indicates that the pattern is part of a regex construct, eg
2717 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
2718 * split "pattern", which aren't. In the former case, expr will be a list
2719 * if the pattern contains more than one term (eg /a$b/) or if it contains
2720 * a replacement, ie s/// or tr///.
2724 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
2728 I32 repl_has_vars = 0;
2732 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
2733 /* last element in list is the replacement; pop it */
2735 repl = cLISTOPx(expr)->op_last;
2736 kid = cLISTOPx(expr)->op_first;
2737 while (kid->op_sibling != repl)
2738 kid = kid->op_sibling;
2739 kid->op_sibling = Nullop;
2740 cLISTOPx(expr)->op_last = kid;
2743 if (isreg && expr->op_type == OP_LIST &&
2744 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
2746 /* convert single element list to element */
2748 expr = cLISTOPx(oe)->op_first->op_sibling;
2749 cLISTOPx(oe)->op_first->op_sibling = Nullop;
2750 cLISTOPx(oe)->op_last = Nullop;
2754 if (o->op_type == OP_TRANS) {
2755 return pmtrans(o, expr, repl);
2758 reglist = isreg && expr->op_type == OP_LIST;
2762 PL_hints |= HINT_BLOCK_SCOPE;
2765 if (expr->op_type == OP_CONST) {
2767 SV *pat = ((SVOP*)expr)->op_sv;
2768 char *p = SvPV(pat, plen);
2769 if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
2770 sv_setpvn(pat, "\\s+", 3);
2771 p = SvPV(pat, plen);
2772 pm->op_pmflags |= PMf_SKIPWHITE;
2775 pm->op_pmdynflags |= PMdf_UTF8;
2776 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
2777 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
2778 pm->op_pmflags |= PMf_WHITE;
2782 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2783 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2785 : OP_REGCMAYBE),0,expr);
2787 NewOp(1101, rcop, 1, LOGOP);
2788 rcop->op_type = OP_REGCOMP;
2789 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2790 rcop->op_first = scalar(expr);
2791 rcop->op_flags |= OPf_KIDS
2792 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
2793 | (reglist ? OPf_STACKED : 0);
2794 rcop->op_private = 1;
2797 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
2799 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
2802 /* establish postfix order */
2803 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2805 rcop->op_next = expr;
2806 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2809 rcop->op_next = LINKLIST(expr);
2810 expr->op_next = (OP*)rcop;
2813 prepend_elem(o->op_type, scalar((OP*)rcop), o);
2818 if (pm->op_pmflags & PMf_EVAL) {
2820 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
2821 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
2823 else if (repl->op_type == OP_CONST)
2827 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
2828 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
2829 if (curop->op_type == OP_GV) {
2830 GV *gv = cGVOPx_gv(curop);
2832 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
2835 else if (curop->op_type == OP_RV2CV)
2837 else if (curop->op_type == OP_RV2SV ||
2838 curop->op_type == OP_RV2AV ||
2839 curop->op_type == OP_RV2HV ||
2840 curop->op_type == OP_RV2GV) {
2841 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2844 else if (curop->op_type == OP_PADSV ||
2845 curop->op_type == OP_PADAV ||
2846 curop->op_type == OP_PADHV ||
2847 curop->op_type == OP_PADANY) {
2850 else if (curop->op_type == OP_PUSHRE)
2851 ; /* Okay here, dangerous in newASSIGNOP */
2861 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
2862 pm->op_pmflags |= PMf_CONST; /* const for long enough */
2863 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
2864 prepend_elem(o->op_type, scalar(repl), o);
2867 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
2868 pm->op_pmflags |= PMf_MAYBE_CONST;
2869 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2871 NewOp(1101, rcop, 1, LOGOP);
2872 rcop->op_type = OP_SUBSTCONT;
2873 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
2874 rcop->op_first = scalar(repl);
2875 rcop->op_flags |= OPf_KIDS;
2876 rcop->op_private = 1;
2879 /* establish postfix order */
2880 rcop->op_next = LINKLIST(repl);
2881 repl->op_next = (OP*)rcop;
2883 pm->op_pmreplroot = scalar((OP*)rcop);
2884 pm->op_pmreplstart = LINKLIST(rcop);
2893 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
2896 NewOp(1101, svop, 1, SVOP);
2897 svop->op_type = (OPCODE)type;
2898 svop->op_ppaddr = PL_ppaddr[type];
2900 svop->op_next = (OP*)svop;
2901 svop->op_flags = (U8)flags;
2902 if (PL_opargs[type] & OA_RETSCALAR)
2904 if (PL_opargs[type] & OA_TARGET)
2905 svop->op_targ = pad_alloc(type, SVs_PADTMP);
2906 return CHECKOP(type, svop);
2910 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2913 NewOp(1101, padop, 1, PADOP);
2914 padop->op_type = (OPCODE)type;
2915 padop->op_ppaddr = PL_ppaddr[type];
2916 padop->op_padix = pad_alloc(type, SVs_PADTMP);
2917 SvREFCNT_dec(PAD_SVl(padop->op_padix));
2918 PAD_SETSV(padop->op_padix, sv);
2921 padop->op_next = (OP*)padop;
2922 padop->op_flags = (U8)flags;
2923 if (PL_opargs[type] & OA_RETSCALAR)
2925 if (PL_opargs[type] & OA_TARGET)
2926 padop->op_targ = pad_alloc(type, SVs_PADTMP);
2927 return CHECKOP(type, padop);
2931 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
2936 return newPADOP(type, flags, SvREFCNT_inc(gv));
2938 return newSVOP(type, flags, SvREFCNT_inc(gv));
2943 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
2946 NewOp(1101, pvop, 1, PVOP);
2947 pvop->op_type = (OPCODE)type;
2948 pvop->op_ppaddr = PL_ppaddr[type];
2950 pvop->op_next = (OP*)pvop;
2951 pvop->op_flags = (U8)flags;
2952 if (PL_opargs[type] & OA_RETSCALAR)
2954 if (PL_opargs[type] & OA_TARGET)
2955 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
2956 return CHECKOP(type, pvop);
2960 Perl_package(pTHX_ OP *o)
2965 save_hptr(&PL_curstash);
2966 save_item(PL_curstname);
2968 name = SvPV(cSVOPo->op_sv, len);
2969 PL_curstash = gv_stashpvn(name, len, TRUE);
2970 sv_setpvn(PL_curstname, name, len);
2973 PL_hints |= HINT_BLOCK_SCOPE;
2974 PL_copline = NOLINE;
2979 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
2985 if (idop->op_type != OP_CONST)
2986 Perl_croak(aTHX_ "Module name must be constant");
2990 if (version != Nullop) {
2991 SV *vesv = ((SVOP*)version)->op_sv;
2993 if (arg == Nullop && !SvNIOKp(vesv)) {
3000 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3001 Perl_croak(aTHX_ "Version number must be constant number");
3003 /* Make copy of idop so we don't free it twice */
3004 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3006 /* Fake up a method call to VERSION */
3007 meth = newSVpvn("VERSION",7);
3008 sv_upgrade(meth, SVt_PVIV);
3009 (void)SvIOK_on(meth);
3012 PERL_HASH(hash, SvPVX(meth), SvCUR(meth));
3013 SvUV_set(meth, hash);
3015 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3016 append_elem(OP_LIST,
3017 prepend_elem(OP_LIST, pack, list(version)),
3018 newSVOP(OP_METHOD_NAMED, 0, meth)));
3022 /* Fake up an import/unimport */
3023 if (arg && arg->op_type == OP_STUB)
3024 imop = arg; /* no import on explicit () */
3025 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3026 imop = Nullop; /* use 5.0; */
3031 /* Make copy of idop so we don't free it twice */
3032 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3034 /* Fake up a method call to import/unimport */
3035 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);
3036 (void)SvUPGRADE(meth, SVt_PVIV);
3037 (void)SvIOK_on(meth);
3040 PERL_HASH(hash, SvPVX(meth), SvCUR(meth));
3041 SvUV_set(meth, hash);
3043 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3044 append_elem(OP_LIST,
3045 prepend_elem(OP_LIST, pack, list(arg)),
3046 newSVOP(OP_METHOD_NAMED, 0, meth)));
3049 /* Fake up the BEGIN {}, which does its thing immediately. */
3051 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3054 append_elem(OP_LINESEQ,
3055 append_elem(OP_LINESEQ,
3056 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, idop)),
3057 newSTATEOP(0, Nullch, veop)),
3058 newSTATEOP(0, Nullch, imop) ));
3060 /* The "did you use incorrect case?" warning used to be here.
3061 * The problem is that on case-insensitive filesystems one
3062 * might get false positives for "use" (and "require"):
3063 * "use Strict" or "require CARP" will work. This causes
3064 * portability problems for the script: in case-strict
3065 * filesystems the script will stop working.
3067 * The "incorrect case" warning checked whether "use Foo"
3068 * imported "Foo" to your namespace, but that is wrong, too:
3069 * there is no requirement nor promise in the language that
3070 * a Foo.pm should or would contain anything in package "Foo".
3072 * There is very little Configure-wise that can be done, either:
3073 * the case-sensitivity of the build filesystem of Perl does not
3074 * help in guessing the case-sensitivity of the runtime environment.
3077 PL_hints |= HINT_BLOCK_SCOPE;
3078 PL_copline = NOLINE;
3080 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3084 =head1 Embedding Functions
3086 =for apidoc load_module
3088 Loads the module whose name is pointed to by the string part of name.
3089 Note that the actual module name, not its filename, should be given.
3090 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3091 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3092 (or 0 for no flags). ver, if specified, provides version semantics
3093 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3094 arguments can be used to specify arguments to the module's import()
3095 method, similar to C<use Foo::Bar VERSION LIST>.
3100 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3103 va_start(args, ver);
3104 vload_module(flags, name, ver, &args);
3108 #ifdef PERL_IMPLICIT_CONTEXT
3110 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3114 va_start(args, ver);
3115 vload_module(flags, name, ver, &args);
3121 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3123 OP *modname, *veop, *imop;
3125 modname = newSVOP(OP_CONST, 0, name);
3126 modname->op_private |= OPpCONST_BARE;
3128 veop = newSVOP(OP_CONST, 0, ver);
3132 if (flags & PERL_LOADMOD_NOIMPORT) {
3133 imop = sawparens(newNULLLIST());
3135 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3136 imop = va_arg(*args, OP*);
3141 sv = va_arg(*args, SV*);
3143 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3144 sv = va_arg(*args, SV*);
3148 const line_t ocopline = PL_copline;
3149 COP * const ocurcop = PL_curcop;
3150 const int oexpect = PL_expect;
3152 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3153 veop, modname, imop);
3154 PL_expect = oexpect;
3155 PL_copline = ocopline;
3156 PL_curcop = ocurcop;
3161 Perl_dofile(pTHX_ OP *term)
3166 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3167 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
3168 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3170 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3171 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3172 append_elem(OP_LIST, term,
3173 scalar(newUNOP(OP_RV2CV, 0,
3178 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3184 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3186 return newBINOP(OP_LSLICE, flags,
3187 list(force_list(subscript)),
3188 list(force_list(listval)) );
3192 S_list_assignment(pTHX_ register const OP *o)
3197 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3198 o = cUNOPo->op_first;
3200 if (o->op_type == OP_COND_EXPR) {
3201 const I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3202 const I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3207 yyerror("Assignment to both a list and a scalar");
3211 if (o->op_type == OP_LIST &&
3212 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3213 o->op_private & OPpLVAL_INTRO)
3216 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3217 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3218 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3221 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3224 if (o->op_type == OP_RV2SV)
3231 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3236 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3237 return newLOGOP(optype, 0,
3238 mod(scalar(left), optype),
3239 newUNOP(OP_SASSIGN, 0, scalar(right)));
3242 return newBINOP(optype, OPf_STACKED,
3243 mod(scalar(left), optype), scalar(right));
3247 if (list_assignment(left)) {
3251 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3252 left = mod(left, OP_AASSIGN);
3260 /* optimise C<my @x = ()> to C<my @x>, and likewise for hashes */
3261 if ((left->op_type == OP_PADAV || left->op_type == OP_PADHV)
3262 && right->op_type == OP_STUB
3263 && (left->op_private & OPpLVAL_INTRO))
3266 left->op_flags &= ~(OPf_REF|OPf_SPECIAL);
3269 curop = list(force_list(left));
3270 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3271 o->op_private = (U8)(0 | (flags >> 8));
3273 /* PL_generation sorcery:
3274 * an assignment like ($a,$b) = ($c,$d) is easier than
3275 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3276 * To detect whether there are common vars, the global var
3277 * PL_generation is incremented for each assign op we compile.
3278 * Then, while compiling the assign op, we run through all the
3279 * variables on both sides of the assignment, setting a spare slot
3280 * in each of them to PL_generation. If any of them already have
3281 * that value, we know we've got commonality. We could use a
3282 * single bit marker, but then we'd have to make 2 passes, first
3283 * to clear the flag, then to test and set it. To find somewhere
3284 * to store these values, evil chicanery is done with SvCUR().
3287 if (!(left->op_private & OPpLVAL_INTRO)) {
3290 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3291 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3292 if (curop->op_type == OP_GV) {
3293 GV *gv = cGVOPx_gv(curop);
3294 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3296 SvCUR(gv) = PL_generation;
3298 else if (curop->op_type == OP_PADSV ||
3299 curop->op_type == OP_PADAV ||
3300 curop->op_type == OP_PADHV ||
3301 curop->op_type == OP_PADANY)
3303 if (PAD_COMPNAME_GEN(curop->op_targ)
3304 == (STRLEN)PL_generation)
3306 PAD_COMPNAME_GEN(curop->op_targ)
3310 else if (curop->op_type == OP_RV2CV)
3312 else if (curop->op_type == OP_RV2SV ||
3313 curop->op_type == OP_RV2AV ||
3314 curop->op_type == OP_RV2HV ||
3315 curop->op_type == OP_RV2GV) {
3316 if (lastop->op_type != OP_GV) /* funny deref? */
3319 else if (curop->op_type == OP_PUSHRE) {
3320 if (((PMOP*)curop)->op_pmreplroot) {
3322 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3323 ((PMOP*)curop)->op_pmreplroot));
3325 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3327 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3329 SvCUR(gv) = PL_generation;
3338 o->op_private |= OPpASSIGN_COMMON;
3340 if (right && right->op_type == OP_SPLIT) {
3342 if ((tmpop = ((LISTOP*)right)->op_first) &&
3343 tmpop->op_type == OP_PUSHRE)
3345 PMOP *pm = (PMOP*)tmpop;
3346 if (left->op_type == OP_RV2AV &&
3347 !(left->op_private & OPpLVAL_INTRO) &&
3348 !(o->op_private & OPpASSIGN_COMMON) )
3350 tmpop = ((UNOP*)left)->op_first;
3351 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3353 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3354 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3356 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3357 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3359 pm->op_pmflags |= PMf_ONCE;
3360 tmpop = cUNOPo->op_first; /* to list (nulled) */
3361 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3362 tmpop->op_sibling = Nullop; /* don't free split */
3363 right->op_next = tmpop->op_next; /* fix starting loc */
3364 op_free(o); /* blow off assign */
3365 right->op_flags &= ~OPf_WANT;
3366 /* "I don't know and I don't care." */
3371 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3372 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3374 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3376 sv_setiv(sv, PL_modcount+1);
3384 right = newOP(OP_UNDEF, 0);
3385 if (right->op_type == OP_READLINE) {
3386 right->op_flags |= OPf_STACKED;
3387 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3390 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3391 o = newBINOP(OP_SASSIGN, flags,
3392 scalar(right), mod(scalar(left), OP_SASSIGN) );
3404 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3406 const U32 seq = intro_my();
3409 NewOp(1101, cop, 1, COP);
3410 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3411 cop->op_type = OP_DBSTATE;
3412 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3415 cop->op_type = OP_NEXTSTATE;
3416 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3418 cop->op_flags = (U8)flags;
3419 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3421 cop->op_private |= NATIVE_HINTS;
3423 PL_compiling.op_private = cop->op_private;
3424 cop->op_next = (OP*)cop;
3427 cop->cop_label = label;
3428 PL_hints |= HINT_BLOCK_SCOPE;
3431 cop->cop_arybase = PL_curcop->cop_arybase;
3432 if (specialWARN(PL_curcop->cop_warnings))
3433 cop->cop_warnings = PL_curcop->cop_warnings ;
3435 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3436 if (specialCopIO(PL_curcop->cop_io))
3437 cop->cop_io = PL_curcop->cop_io;
3439 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3442 if (PL_copline == NOLINE)
3443 CopLINE_set(cop, CopLINE(PL_curcop));
3445 CopLINE_set(cop, PL_copline);
3446 PL_copline = NOLINE;
3449 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3451 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3453 CopSTASH_set(cop, PL_curstash);
3455 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3456 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3457 if (svp && *svp != &PL_sv_undef ) {
3458 (void)SvIOK_on(*svp);
3459 SvIV_set(*svp, PTR2IV(cop));
3463 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3468 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3470 return new_logop(type, flags, &first, &other);
3474 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3478 OP *first = *firstp;
3479 OP *other = *otherp;
3481 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3482 return newBINOP(type, flags, scalar(first), scalar(other));
3484 scalarboolean(first);
3485 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3486 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3487 if (type == OP_AND || type == OP_OR) {
3493 first = *firstp = cUNOPo->op_first;
3495 first->op_next = o->op_next;
3496 cUNOPo->op_first = Nullop;
3500 if (first->op_type == OP_CONST) {
3501 if (first->op_private & OPpCONST_STRICT)
3502 no_bareword_allowed(first);
3503 else if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3504 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3505 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
3506 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
3507 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
3510 if (other->op_type == OP_CONST)
3511 other->op_private |= OPpCONST_SHORTCIRCUIT;
3515 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
3516 const OP *o2 = other;
3517 if ( ! (o2->op_type == OP_LIST
3518 && (( o2 = cUNOPx(o2)->op_first))
3519 && o2->op_type == OP_PUSHMARK
3520 && (( o2 = o2->op_sibling)) )
3523 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
3524 || o2->op_type == OP_PADHV)
3525 && o2->op_private & OPpLVAL_INTRO
3526 && ckWARN(WARN_DEPRECATED))
3528 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
3529 "Deprecated use of my() in false conditional");
3534 if (first->op_type == OP_CONST)
3535 first->op_private |= OPpCONST_SHORTCIRCUIT;
3539 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS) &&
3540 type != OP_DOR) /* [#24076] Don't warn for <FH> err FOO. */
3542 const OP *k1 = ((UNOP*)first)->op_first;
3543 const OP *k2 = k1->op_sibling;
3545 switch (first->op_type)
3548 if (k2 && k2->op_type == OP_READLINE
3549 && (k2->op_flags & OPf_STACKED)
3550 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3552 warnop = k2->op_type;
3557 if (k1->op_type == OP_READDIR
3558 || k1->op_type == OP_GLOB
3559 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3560 || k1->op_type == OP_EACH)
3562 warnop = ((k1->op_type == OP_NULL)
3563 ? (OPCODE)k1->op_targ : k1->op_type);
3568 const line_t oldline = CopLINE(PL_curcop);
3569 CopLINE_set(PL_curcop, PL_copline);
3570 Perl_warner(aTHX_ packWARN(WARN_MISC),
3571 "Value of %s%s can be \"0\"; test with defined()",
3573 ((warnop == OP_READLINE || warnop == OP_GLOB)
3574 ? " construct" : "() operator"));
3575 CopLINE_set(PL_curcop, oldline);
3582 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3583 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3585 NewOp(1101, logop, 1, LOGOP);
3587 logop->op_type = (OPCODE)type;
3588 logop->op_ppaddr = PL_ppaddr[type];
3589 logop->op_first = first;
3590 logop->op_flags = flags | OPf_KIDS;
3591 logop->op_other = LINKLIST(other);
3592 logop->op_private = (U8)(1 | (flags >> 8));
3594 /* establish postfix order */
3595 logop->op_next = LINKLIST(first);
3596 first->op_next = (OP*)logop;
3597 first->op_sibling = other;
3599 CHECKOP(type,logop);
3601 o = newUNOP(OP_NULL, 0, (OP*)logop);
3608 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3615 return newLOGOP(OP_AND, 0, first, trueop);
3617 return newLOGOP(OP_OR, 0, first, falseop);
3619 scalarboolean(first);
3620 if (first->op_type == OP_CONST) {
3621 if (first->op_private & OPpCONST_BARE &&
3622 first->op_private & OPpCONST_STRICT) {
3623 no_bareword_allowed(first);
3625 if (SvTRUE(((SVOP*)first)->op_sv)) {
3636 NewOp(1101, logop, 1, LOGOP);
3637 logop->op_type = OP_COND_EXPR;
3638 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3639 logop->op_first = first;
3640 logop->op_flags = flags | OPf_KIDS;
3641 logop->op_private = (U8)(1 | (flags >> 8));
3642 logop->op_other = LINKLIST(trueop);
3643 logop->op_next = LINKLIST(falseop);
3645 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
3648 /* establish postfix order */
3649 start = LINKLIST(first);
3650 first->op_next = (OP*)logop;
3652 first->op_sibling = trueop;
3653 trueop->op_sibling = falseop;
3654 o = newUNOP(OP_NULL, 0, (OP*)logop);
3656 trueop->op_next = falseop->op_next = o;
3663 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3671 NewOp(1101, range, 1, LOGOP);
3673 range->op_type = OP_RANGE;
3674 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3675 range->op_first = left;
3676 range->op_flags = OPf_KIDS;
3677 leftstart = LINKLIST(left);
3678 range->op_other = LINKLIST(right);
3679 range->op_private = (U8)(1 | (flags >> 8));
3681 left->op_sibling = right;
3683 range->op_next = (OP*)range;
3684 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3685 flop = newUNOP(OP_FLOP, 0, flip);
3686 o = newUNOP(OP_NULL, 0, flop);
3688 range->op_next = leftstart;
3690 left->op_next = flip;
3691 right->op_next = flop;
3693 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3694 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3695 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3696 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3698 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3699 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3702 if (!flip->op_private || !flop->op_private)
3703 linklist(o); /* blow off optimizer unless constant */
3709 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3713 const bool once = block && block->op_flags & OPf_SPECIAL &&
3714 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3718 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3719 return block; /* do {} while 0 does once */
3720 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3721 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3722 expr = newUNOP(OP_DEFINED, 0,
3723 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3724 } else if (expr->op_flags & OPf_KIDS) {
3725 const OP *k1 = ((UNOP*)expr)->op_first;
3726 const OP *k2 = (k1) ? k1->op_sibling : NULL;
3727 switch (expr->op_type) {
3729 if (k2 && k2->op_type == OP_READLINE
3730 && (k2->op_flags & OPf_STACKED)
3731 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3732 expr = newUNOP(OP_DEFINED, 0, expr);
3736 if (k1->op_type == OP_READDIR
3737 || k1->op_type == OP_GLOB
3738 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3739 || k1->op_type == OP_EACH)
3740 expr = newUNOP(OP_DEFINED, 0, expr);
3746 /* if block is null, the next append_elem() would put UNSTACK, a scalar
3747 * op, in listop. This is wrong. [perl #27024] */
3749 block = newOP(OP_NULL, 0);
3750 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3751 o = new_logop(OP_AND, 0, &expr, &listop);
3754 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3756 if (once && o != listop)
3757 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3760 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3762 o->op_flags |= flags;
3764 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3769 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3778 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3779 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3780 expr = newUNOP(OP_DEFINED, 0,
3781 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3782 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3783 const OP *k1 = ((UNOP*)expr)->op_first;
3784 const OP *k2 = (k1) ? k1->op_sibling : NULL;
3785 switch (expr->op_type) {
3787 if (k2 && k2->op_type == OP_READLINE
3788 && (k2->op_flags & OPf_STACKED)
3789 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3790 expr = newUNOP(OP_DEFINED, 0, expr);
3794 if (k1->op_type == OP_READDIR
3795 || k1->op_type == OP_GLOB
3796 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3797 || k1->op_type == OP_EACH)
3798 expr = newUNOP(OP_DEFINED, 0, expr);
3804 block = newOP(OP_NULL, 0);
3806 block = scope(block);
3810 next = LINKLIST(cont);
3813 OP *unstack = newOP(OP_UNSTACK, 0);
3816 cont = append_elem(OP_LINESEQ, cont, unstack);
3819 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3820 redo = LINKLIST(listop);
3823 PL_copline = (line_t)whileline;
3825 o = new_logop(OP_AND, 0, &expr, &listop);
3826 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3827 op_free(expr); /* oops, it's a while (0) */
3829 return Nullop; /* listop already freed by new_logop */
3832 ((LISTOP*)listop)->op_last->op_next =
3833 (o == listop ? redo : LINKLIST(o));
3839 NewOp(1101,loop,1,LOOP);
3840 loop->op_type = OP_ENTERLOOP;
3841 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3842 loop->op_private = 0;
3843 loop->op_next = (OP*)loop;
3846 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3848 loop->op_redoop = redo;
3849 loop->op_lastop = o;
3850 o->op_private |= loopflags;
3853 loop->op_nextop = next;
3855 loop->op_nextop = o;
3857 o->op_flags |= flags;
3858 o->op_private |= (flags >> 8);
3863 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
3867 PADOFFSET padoff = 0;
3872 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
3873 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
3874 sv->op_type = OP_RV2GV;
3875 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3877 else if (sv->op_type == OP_PADSV) { /* private variable */
3878 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
3879 padoff = sv->op_targ;
3884 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3885 padoff = sv->op_targ;
3887 iterflags |= OPf_SPECIAL;
3892 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3895 const I32 offset = pad_findmy("$_");
3896 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
3897 sv = newGVOP(OP_GV, 0, PL_defgv);
3903 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3904 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3905 iterflags |= OPf_STACKED;
3907 else if (expr->op_type == OP_NULL &&
3908 (expr->op_flags & OPf_KIDS) &&
3909 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3911 /* Basically turn for($x..$y) into the same as for($x,$y), but we
3912 * set the STACKED flag to indicate that these values are to be
3913 * treated as min/max values by 'pp_iterinit'.
3915 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
3916 LOGOP* range = (LOGOP*) flip->op_first;
3917 OP* left = range->op_first;
3918 OP* right = left->op_sibling;
3921 range->op_flags &= ~OPf_KIDS;
3922 range->op_first = Nullop;
3924 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
3925 listop->op_first->op_next = range->op_next;
3926 left->op_next = range->op_other;
3927 right->op_next = (OP*)listop;
3928 listop->op_next = listop->op_first;
3931 expr = (OP*)(listop);
3933 iterflags |= OPf_STACKED;
3936 expr = mod(force_list(expr), OP_GREPSTART);
3939 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
3940 append_elem(OP_LIST, expr, scalar(sv))));
3941 assert(!loop->op_next);
3942 /* for my $x () sets OPpLVAL_INTRO;
3943 * for our $x () sets OPpOUR_INTRO */
3944 loop->op_private = (U8)iterpflags;
3945 #ifdef PL_OP_SLAB_ALLOC
3948 NewOp(1234,tmp,1,LOOP);
3949 Copy(loop,tmp,1,LISTOP);
3954 Renew(loop, 1, LOOP);
3956 loop->op_targ = padoff;
3957 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
3958 PL_copline = forline;
3959 return newSTATEOP(0, label, wop);
3963 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
3968 if (type != OP_GOTO || label->op_type == OP_CONST) {
3969 /* "last()" means "last" */
3970 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
3971 o = newOP(type, OPf_SPECIAL);
3973 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
3974 ? SvPVx(((SVOP*)label)->op_sv, n_a)
3980 /* Check whether it's going to be a goto &function */
3981 if (label->op_type == OP_ENTERSUB
3982 && !(label->op_flags & OPf_STACKED))
3983 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
3984 o = newUNOP(type, OPf_STACKED, label);
3986 PL_hints |= HINT_BLOCK_SCOPE;
3991 =for apidoc cv_undef
3993 Clear out all the active components of a CV. This can happen either
3994 by an explicit C<undef &foo>, or by the reference count going to zero.
3995 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
3996 children can still follow the full lexical scope chain.
4002 Perl_cv_undef(pTHX_ CV *cv)
4005 if (CvFILE(cv) && !CvXSUB(cv)) {
4006 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4007 Safefree(CvFILE(cv));
4012 if (!CvXSUB(cv) && CvROOT(cv)) {
4014 Perl_croak(aTHX_ "Can't undef active subroutine");
4017 PAD_SAVE_SETNULLPAD();
4019 op_free(CvROOT(cv));
4020 CvROOT(cv) = Nullop;
4023 SvPOK_off((SV*)cv); /* forget prototype */
4028 /* remove CvOUTSIDE unless this is an undef rather than a free */
4029 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4030 if (!CvWEAKOUTSIDE(cv))
4031 SvREFCNT_dec(CvOUTSIDE(cv));
4032 CvOUTSIDE(cv) = Nullcv;
4035 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4041 /* delete all flags except WEAKOUTSIDE */
4042 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4046 Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p)
4048 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4049 SV* msg = sv_newmortal();
4053 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4054 sv_setpv(msg, "Prototype mismatch:");
4056 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4058 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (const SV *)cv);
4060 Perl_sv_catpv(aTHX_ msg, ": none");
4061 sv_catpv(msg, " vs ");
4063 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4065 sv_catpv(msg, "none");
4066 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
4070 static void const_sv_xsub(pTHX_ CV* cv);
4074 =head1 Optree Manipulation Functions
4076 =for apidoc cv_const_sv
4078 If C<cv> is a constant sub eligible for inlining. returns the constant
4079 value returned by the sub. Otherwise, returns NULL.
4081 Constant subs can be created with C<newCONSTSUB> or as described in
4082 L<perlsub/"Constant Functions">.
4087 Perl_cv_const_sv(pTHX_ CV *cv)
4089 if (!cv || !CvCONST(cv))
4091 return (SV*)CvXSUBANY(cv).any_ptr;
4094 /* op_const_sv: examine an optree to determine whether it's in-lineable.
4095 * Can be called in 3 ways:
4098 * look for a single OP_CONST with attached value: return the value
4100 * cv && CvCLONE(cv) && !CvCONST(cv)
4102 * examine the clone prototype, and if contains only a single
4103 * OP_CONST referencing a pad const, or a single PADSV referencing
4104 * an outer lexical, return a non-zero value to indicate the CV is
4105 * a candidate for "constizing" at clone time
4109 * We have just cloned an anon prototype that was marked as a const
4110 * candidiate. Try to grab the current value, and in the case of
4111 * PADSV, ignore it if it has multiple references. Return the value.
4115 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
4122 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4123 o = cLISTOPo->op_first->op_sibling;
4125 for (; o; o = o->op_next) {
4126 OPCODE type = o->op_type;
4128 if (sv && o->op_next == o)
4130 if (o->op_next != o) {
4131 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4133 if (type == OP_DBSTATE)
4136 if (type == OP_LEAVESUB || type == OP_RETURN)
4140 if (type == OP_CONST && cSVOPo->op_sv)
4142 else if (cv && type == OP_CONST) {
4143 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4147 else if (cv && type == OP_PADSV) {
4148 if (CvCONST(cv)) { /* newly cloned anon */
4149 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4150 /* the candidate should have 1 ref from this pad and 1 ref
4151 * from the parent */
4152 if (!sv || SvREFCNT(sv) != 2)
4159 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4160 sv = &PL_sv_undef; /* an arbitrary non-null value */
4171 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4182 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4186 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4188 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4192 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4202 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4205 assert(proto->op_type == OP_CONST);
4206 ps = SvPVx(((SVOP*)proto)->op_sv, n_a);
4211 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4212 SV *sv = sv_newmortal();
4213 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4214 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4215 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4220 gv = name ? gv_fetchsv(cSVOPo->op_sv,
4221 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4223 : gv_fetchpv(aname ? aname
4224 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4225 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4235 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4236 maximum a prototype before. */
4237 if (SvTYPE(gv) > SVt_NULL) {
4238 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4239 && ckWARN_d(WARN_PROTOTYPE))
4241 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4243 cv_ckproto((CV*)gv, NULL, ps);
4246 sv_setpv((SV*)gv, ps);
4248 sv_setiv((SV*)gv, -1);
4249 SvREFCNT_dec(PL_compcv);
4250 cv = PL_compcv = NULL;
4251 PL_sub_generation++;
4255 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4257 #ifdef GV_UNIQUE_CHECK
4258 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4259 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4263 if (!block || !ps || *ps || attrs)
4266 const_sv = op_const_sv(block, Nullcv);
4269 const bool exists = CvROOT(cv) || CvXSUB(cv);
4271 #ifdef GV_UNIQUE_CHECK
4272 if (exists && GvUNIQUE(gv)) {
4273 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4277 /* if the subroutine doesn't exist and wasn't pre-declared
4278 * with a prototype, assume it will be AUTOLOADed,
4279 * skipping the prototype check
4281 if (exists || SvPOK(cv))
4282 cv_ckproto(cv, gv, ps);
4283 /* already defined (or promised)? */
4284 if (exists || GvASSUMECV(gv)) {
4285 if (!block && !attrs) {
4286 if (CvFLAGS(PL_compcv)) {
4287 /* might have had built-in attrs applied */
4288 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4290 /* just a "sub foo;" when &foo is already defined */
4291 SAVEFREESV(PL_compcv);
4294 /* ahem, death to those who redefine active sort subs */
4295 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4296 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4298 if (ckWARN(WARN_REDEFINE)
4300 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4302 const line_t oldline = CopLINE(PL_curcop);
4303 if (PL_copline != NOLINE)
4304 CopLINE_set(PL_curcop, PL_copline);
4305 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4306 CvCONST(cv) ? "Constant subroutine %s redefined"
4307 : "Subroutine %s redefined", name);
4308 CopLINE_set(PL_curcop, oldline);
4316 (void)SvREFCNT_inc(const_sv);
4318 assert(!CvROOT(cv) && !CvCONST(cv));
4319 sv_setpv((SV*)cv, ""); /* prototype is "" */
4320 CvXSUBANY(cv).any_ptr = const_sv;
4321 CvXSUB(cv) = const_sv_xsub;
4326 cv = newCONSTSUB(NULL, name, const_sv);
4329 SvREFCNT_dec(PL_compcv);
4331 PL_sub_generation++;
4338 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4339 * before we clobber PL_compcv.
4343 /* Might have had built-in attributes applied -- propagate them. */
4344 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4345 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4346 stash = GvSTASH(CvGV(cv));
4347 else if (CvSTASH(cv))
4348 stash = CvSTASH(cv);
4350 stash = PL_curstash;
4353 /* possibly about to re-define existing subr -- ignore old cv */
4354 rcv = (SV*)PL_compcv;
4355 if (name && GvSTASH(gv))
4356 stash = GvSTASH(gv);
4358 stash = PL_curstash;
4360 apply_attrs(stash, rcv, attrs, FALSE);
4362 if (cv) { /* must reuse cv if autoloaded */
4364 /* got here with just attrs -- work done, so bug out */
4365 SAVEFREESV(PL_compcv);
4368 /* transfer PL_compcv to cv */
4370 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4371 if (!CvWEAKOUTSIDE(cv))
4372 SvREFCNT_dec(CvOUTSIDE(cv));
4373 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4374 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4375 CvOUTSIDE(PL_compcv) = 0;
4376 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4377 CvPADLIST(PL_compcv) = 0;
4378 /* inner references to PL_compcv must be fixed up ... */
4379 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4380 /* ... before we throw it away */
4381 SvREFCNT_dec(PL_compcv);
4383 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4384 ++PL_sub_generation;
4391 PL_sub_generation++;
4395 CvFILE_set_from_cop(cv, PL_curcop);
4396 CvSTASH(cv) = PL_curstash;
4399 sv_setpv((SV*)cv, ps);
4401 if (PL_error_count) {
4405 const char *s = strrchr(name, ':');
4407 if (strEQ(s, "BEGIN")) {
4408 const char not_safe[] =
4409 "BEGIN not safe after errors--compilation aborted";
4410 if (PL_in_eval & EVAL_KEEPERR)
4411 Perl_croak(aTHX_ not_safe);
4413 /* force display of errors found but not reported */
4414 sv_catpv(ERRSV, not_safe);
4415 Perl_croak(aTHX_ "%"SVf, ERRSV);
4424 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4425 mod(scalarseq(block), OP_LEAVESUBLV));
4428 /* This makes sub {}; work as expected. */
4429 if (block->op_type == OP_STUB) {
4431 block = newSTATEOP(0, Nullch, 0);
4433 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4435 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4436 OpREFCNT_set(CvROOT(cv), 1);
4437 CvSTART(cv) = LINKLIST(CvROOT(cv));
4438 CvROOT(cv)->op_next = 0;
4439 CALL_PEEP(CvSTART(cv));
4441 /* now that optimizer has done its work, adjust pad values */
4443 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4446 assert(!CvCONST(cv));
4447 if (ps && !*ps && op_const_sv(block, cv))
4451 if (name || aname) {
4453 const char *tname = (name ? name : aname);
4455 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4456 SV *sv = NEWSV(0,0);
4457 SV *tmpstr = sv_newmortal();
4458 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4462 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4464 (long)PL_subline, (long)CopLINE(PL_curcop));
4465 gv_efullname3(tmpstr, gv, Nullch);
4466 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4467 hv = GvHVn(db_postponed);
4468 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4469 && (pcv = GvCV(db_postponed)))
4475 call_sv((SV*)pcv, G_DISCARD);
4479 if ((s = strrchr(tname,':')))
4484 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4487 if (strEQ(s, "BEGIN") && !PL_error_count) {
4488 const I32 oldscope = PL_scopestack_ix;
4490 SAVECOPFILE(&PL_compiling);
4491 SAVECOPLINE(&PL_compiling);
4494 PL_beginav = newAV();
4495 DEBUG_x( dump_sub(gv) );
4496 av_push(PL_beginav, (SV*)cv);
4497 GvCV(gv) = 0; /* cv has been hijacked */
4498 call_list(oldscope, PL_beginav);
4500 PL_curcop = &PL_compiling;
4501 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4504 else if (strEQ(s, "END") && !PL_error_count) {
4507 DEBUG_x( dump_sub(gv) );
4508 av_unshift(PL_endav, 1);
4509 av_store(PL_endav, 0, (SV*)cv);
4510 GvCV(gv) = 0; /* cv has been hijacked */
4512 else if (strEQ(s, "CHECK") && !PL_error_count) {
4514 PL_checkav = newAV();
4515 DEBUG_x( dump_sub(gv) );
4516 if (PL_main_start && ckWARN(WARN_VOID))
4517 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4518 av_unshift(PL_checkav, 1);
4519 av_store(PL_checkav, 0, (SV*)cv);
4520 GvCV(gv) = 0; /* cv has been hijacked */
4522 else if (strEQ(s, "INIT") && !PL_error_count) {
4524 PL_initav = newAV();
4525 DEBUG_x( dump_sub(gv) );
4526 if (PL_main_start && ckWARN(WARN_VOID))
4527 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4528 av_push(PL_initav, (SV*)cv);
4529 GvCV(gv) = 0; /* cv has been hijacked */
4534 PL_copline = NOLINE;
4539 /* XXX unsafe for threads if eval_owner isn't held */
4541 =for apidoc newCONSTSUB
4543 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4544 eligible for inlining at compile-time.
4550 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
4556 SAVECOPLINE(PL_curcop);
4557 CopLINE_set(PL_curcop, PL_copline);
4560 PL_hints &= ~HINT_BLOCK_SCOPE;
4563 SAVESPTR(PL_curstash);
4564 SAVECOPSTASH(PL_curcop);
4565 PL_curstash = stash;
4566 CopSTASH_set(PL_curcop,stash);
4569 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4570 CvXSUBANY(cv).any_ptr = sv;
4572 sv_setpv((SV*)cv, ""); /* prototype is "" */
4575 CopSTASH_free(PL_curcop);
4583 =for apidoc U||newXS
4585 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4591 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
4593 GV *gv = gv_fetchpv(name ? name :
4594 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4595 GV_ADDMULTI, SVt_PVCV);
4599 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4601 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4603 /* just a cached method */
4607 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4608 /* already defined (or promised) */
4609 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4610 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4611 const line_t oldline = CopLINE(PL_curcop);
4612 if (PL_copline != NOLINE)
4613 CopLINE_set(PL_curcop, PL_copline);
4614 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4615 CvCONST(cv) ? "Constant subroutine %s redefined"
4616 : "Subroutine %s redefined"
4618 CopLINE_set(PL_curcop, oldline);
4625 if (cv) /* must reuse cv if autoloaded */
4628 cv = (CV*)NEWSV(1105,0);
4629 sv_upgrade((SV *)cv, SVt_PVCV);
4633 PL_sub_generation++;
4637 (void)gv_fetchfile(filename);
4638 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
4639 an external constant string */
4640 CvXSUB(cv) = subaddr;
4643 const char *s = strrchr(name,':');
4649 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4652 if (strEQ(s, "BEGIN")) {
4654 PL_beginav = newAV();
4655 av_push(PL_beginav, (SV*)cv);
4656 GvCV(gv) = 0; /* cv has been hijacked */
4658 else if (strEQ(s, "END")) {
4661 av_unshift(PL_endav, 1);
4662 av_store(PL_endav, 0, (SV*)cv);
4663 GvCV(gv) = 0; /* cv has been hijacked */
4665 else if (strEQ(s, "CHECK")) {
4667 PL_checkav = newAV();
4668 if (PL_main_start && ckWARN(WARN_VOID))
4669 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4670 av_unshift(PL_checkav, 1);
4671 av_store(PL_checkav, 0, (SV*)cv);
4672 GvCV(gv) = 0; /* cv has been hijacked */
4674 else if (strEQ(s, "INIT")) {
4676 PL_initav = newAV();
4677 if (PL_main_start && ckWARN(WARN_VOID))
4678 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4679 av_push(PL_initav, (SV*)cv);
4680 GvCV(gv) = 0; /* cv has been hijacked */
4691 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4697 gv = gv_fetchsv(cSVOPo->op_sv, TRUE, SVt_PVFM);
4699 gv = gv_fetchpv("STDOUT", TRUE, SVt_PVFM);
4701 #ifdef GV_UNIQUE_CHECK
4703 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4707 if ((cv = GvFORM(gv))) {
4708 if (ckWARN(WARN_REDEFINE)) {
4709 const line_t oldline = CopLINE(PL_curcop);
4710 if (PL_copline != NOLINE)
4711 CopLINE_set(PL_curcop, PL_copline);
4712 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4713 o ? "Format %"SVf" redefined"
4714 : "Format STDOUT redefined" ,cSVOPo->op_sv);
4715 CopLINE_set(PL_curcop, oldline);
4722 CvFILE_set_from_cop(cv, PL_curcop);
4725 pad_tidy(padtidy_FORMAT);
4726 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4727 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4728 OpREFCNT_set(CvROOT(cv), 1);
4729 CvSTART(cv) = LINKLIST(CvROOT(cv));
4730 CvROOT(cv)->op_next = 0;
4731 CALL_PEEP(CvSTART(cv));
4733 PL_copline = NOLINE;
4738 Perl_newANONLIST(pTHX_ OP *o)
4740 return newUNOP(OP_REFGEN, 0,
4741 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4745 Perl_newANONHASH(pTHX_ OP *o)
4747 return newUNOP(OP_REFGEN, 0,
4748 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4752 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4754 return newANONATTRSUB(floor, proto, Nullop, block);
4758 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4760 return newUNOP(OP_REFGEN, 0,
4761 newSVOP(OP_ANONCODE, 0,
4762 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
4766 Perl_oopsAV(pTHX_ OP *o)
4768 switch (o->op_type) {
4770 o->op_type = OP_PADAV;
4771 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4772 return ref(o, OP_RV2AV);
4775 o->op_type = OP_RV2AV;
4776 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4781 if (ckWARN_d(WARN_INTERNAL))
4782 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
4789 Perl_oopsHV(pTHX_ OP *o)
4791 switch (o->op_type) {
4794 o->op_type = OP_PADHV;
4795 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4796 return ref(o, OP_RV2HV);
4800 o->op_type = OP_RV2HV;
4801 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
4806 if (ckWARN_d(WARN_INTERNAL))
4807 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
4814 Perl_newAVREF(pTHX_ OP *o)
4816 if (o->op_type == OP_PADANY) {
4817 o->op_type = OP_PADAV;
4818 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4821 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
4822 && ckWARN(WARN_DEPRECATED)) {
4823 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4824 "Using an array as a reference is deprecated");
4826 return newUNOP(OP_RV2AV, 0, scalar(o));
4830 Perl_newGVREF(pTHX_ I32 type, OP *o)
4832 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
4833 return newUNOP(OP_NULL, 0, o);
4834 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
4838 Perl_newHVREF(pTHX_ OP *o)
4840 if (o->op_type == OP_PADANY) {
4841 o->op_type = OP_PADHV;
4842 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4845 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
4846 && ckWARN(WARN_DEPRECATED)) {
4847 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4848 "Using a hash as a reference is deprecated");
4850 return newUNOP(OP_RV2HV, 0, scalar(o));
4854 Perl_oopsCV(pTHX_ OP *o)
4856 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
4859 #ifndef HASATTRIBUTE
4860 /* No __attribute__, so the compiler doesn't know that croak never returns
4867 Perl_newCVREF(pTHX_ I32 flags, OP *o)
4869 return newUNOP(OP_RV2CV, flags, scalar(o));
4873 Perl_newSVREF(pTHX_ OP *o)
4875 if (o->op_type == OP_PADANY) {
4876 o->op_type = OP_PADSV;
4877 o->op_ppaddr = PL_ppaddr[OP_PADSV];
4880 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4881 o->op_flags |= OPpDONE_SVREF;
4884 return newUNOP(OP_RV2SV, 0, scalar(o));
4887 /* Check routines. See the comments at the top of this file for details
4888 * on when these are called */
4891 Perl_ck_anoncode(pTHX_ OP *o)
4893 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
4894 cSVOPo->op_sv = Nullsv;
4899 Perl_ck_bitop(pTHX_ OP *o)
4901 #define OP_IS_NUMCOMPARE(op) \
4902 ((op) == OP_LT || (op) == OP_I_LT || \
4903 (op) == OP_GT || (op) == OP_I_GT || \
4904 (op) == OP_LE || (op) == OP_I_LE || \
4905 (op) == OP_GE || (op) == OP_I_GE || \
4906 (op) == OP_EQ || (op) == OP_I_EQ || \
4907 (op) == OP_NE || (op) == OP_I_NE || \
4908 (op) == OP_NCMP || (op) == OP_I_NCMP)
4909 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4910 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
4911 && (o->op_type == OP_BIT_OR
4912 || o->op_type == OP_BIT_AND
4913 || o->op_type == OP_BIT_XOR))
4915 const OP * left = cBINOPo->op_first;
4916 const OP * right = left->op_sibling;
4917 if ((OP_IS_NUMCOMPARE(left->op_type) &&
4918 (left->op_flags & OPf_PARENS) == 0) ||
4919 (OP_IS_NUMCOMPARE(right->op_type) &&
4920 (right->op_flags & OPf_PARENS) == 0))
4921 if (ckWARN(WARN_PRECEDENCE))
4922 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4923 "Possible precedence problem on bitwise %c operator",
4924 o->op_type == OP_BIT_OR ? '|'
4925 : o->op_type == OP_BIT_AND ? '&' : '^'
4932 Perl_ck_concat(pTHX_ OP *o)
4934 const OP *kid = cUNOPo->op_first;
4935 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
4936 !(kUNOP->op_first->op_flags & OPf_MOD))
4937 o->op_flags |= OPf_STACKED;
4942 Perl_ck_spair(pTHX_ OP *o)
4944 if (o->op_flags & OPf_KIDS) {
4947 const OPCODE type = o->op_type;
4948 o = modkids(ck_fun(o), type);
4949 kid = cUNOPo->op_first;
4950 newop = kUNOP->op_first->op_sibling;
4952 (newop->op_sibling ||
4953 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
4954 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
4955 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
4959 op_free(kUNOP->op_first);
4960 kUNOP->op_first = newop;
4962 o->op_ppaddr = PL_ppaddr[++o->op_type];
4967 Perl_ck_delete(pTHX_ OP *o)
4971 if (o->op_flags & OPf_KIDS) {
4972 OP *kid = cUNOPo->op_first;
4973 switch (kid->op_type) {
4975 o->op_flags |= OPf_SPECIAL;
4978 o->op_private |= OPpSLICE;
4981 o->op_flags |= OPf_SPECIAL;
4986 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
4995 Perl_ck_die(pTHX_ OP *o)
4998 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5004 Perl_ck_eof(pTHX_ OP *o)
5006 const I32 type = o->op_type;
5008 if (o->op_flags & OPf_KIDS) {
5009 if (cLISTOPo->op_first->op_type == OP_STUB) {
5011 o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
5019 Perl_ck_eval(pTHX_ OP *o)
5021 PL_hints |= HINT_BLOCK_SCOPE;
5022 if (o->op_flags & OPf_KIDS) {
5023 SVOP *kid = (SVOP*)cUNOPo->op_first;
5026 o->op_flags &= ~OPf_KIDS;
5029 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
5032 cUNOPo->op_first = 0;
5035 NewOp(1101, enter, 1, LOGOP);
5036 enter->op_type = OP_ENTERTRY;
5037 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5038 enter->op_private = 0;
5040 /* establish postfix order */
5041 enter->op_next = (OP*)enter;
5043 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5044 o->op_type = OP_LEAVETRY;
5045 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5046 enter->op_other = o;
5056 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5058 o->op_targ = (PADOFFSET)PL_hints;
5063 Perl_ck_exit(pTHX_ OP *o)
5066 HV *table = GvHV(PL_hintgv);
5068 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5069 if (svp && *svp && SvTRUE(*svp))
5070 o->op_private |= OPpEXIT_VMSISH;
5072 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5078 Perl_ck_exec(pTHX_ OP *o)
5080 if (o->op_flags & OPf_STACKED) {
5083 kid = cUNOPo->op_first->op_sibling;
5084 if (kid->op_type == OP_RV2GV)
5093 Perl_ck_exists(pTHX_ OP *o)
5096 if (o->op_flags & OPf_KIDS) {
5097 OP *kid = cUNOPo->op_first;
5098 if (kid->op_type == OP_ENTERSUB) {
5099 (void) ref(kid, o->op_type);
5100 if (kid->op_type != OP_RV2CV && !PL_error_count)
5101 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5103 o->op_private |= OPpEXISTS_SUB;
5105 else if (kid->op_type == OP_AELEM)
5106 o->op_flags |= OPf_SPECIAL;
5107 else if (kid->op_type != OP_HELEM)
5108 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5117 Perl_ck_gvconst(pTHX_ register OP *o)
5119 o = fold_constants(o);
5120 if (o->op_type == OP_CONST)
5127 Perl_ck_rvconst(pTHX_ register OP *o)
5129 SVOP *kid = (SVOP*)cUNOPo->op_first;
5131 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5132 if (kid->op_type == OP_CONST) {
5135 SV *kidsv = kid->op_sv;
5137 /* Is it a constant from cv_const_sv()? */
5138 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5139 SV *rsv = SvRV(kidsv);
5140 int svtype = SvTYPE(rsv);
5141 const char *badtype = Nullch;
5143 switch (o->op_type) {
5145 if (svtype > SVt_PVMG)
5146 badtype = "a SCALAR";
5149 if (svtype != SVt_PVAV)
5150 badtype = "an ARRAY";
5153 if (svtype != SVt_PVHV)
5157 if (svtype != SVt_PVCV)
5162 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5165 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5166 const char *badthing = Nullch;
5167 switch (o->op_type) {
5169 badthing = "a SCALAR";
5172 badthing = "an ARRAY";
5175 badthing = "a HASH";
5180 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
5184 * This is a little tricky. We only want to add the symbol if we
5185 * didn't add it in the lexer. Otherwise we get duplicate strict
5186 * warnings. But if we didn't add it in the lexer, we must at
5187 * least pretend like we wanted to add it even if it existed before,
5188 * or we get possible typo warnings. OPpCONST_ENTERED says
5189 * whether the lexer already added THIS instance of this symbol.
5191 iscv = (o->op_type == OP_RV2CV) * 2;
5193 gv = gv_fetchsv(kidsv,
5194 iscv | !(kid->op_private & OPpCONST_ENTERED),
5197 : o->op_type == OP_RV2SV
5199 : o->op_type == OP_RV2AV
5201 : o->op_type == OP_RV2HV
5204 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5206 kid->op_type = OP_GV;
5207 SvREFCNT_dec(kid->op_sv);
5209 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5210 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5211 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
5213 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
5215 kid->op_sv = SvREFCNT_inc(gv);
5217 kid->op_private = 0;
5218 kid->op_ppaddr = PL_ppaddr[OP_GV];
5225 Perl_ck_ftst(pTHX_ OP *o)
5227 const I32 type = o->op_type;
5229 if (o->op_flags & OPf_REF) {
5232 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5233 SVOP *kid = (SVOP*)cUNOPo->op_first;
5235 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5236 OP *newop = newGVOP(type, OPf_REF,
5237 gv_fetchsv(kid->op_sv, TRUE, SVt_PVIO));
5243 if ((PL_hints & HINT_FILETEST_ACCESS) &&
5244 OP_IS_FILETEST_ACCESS(o))
5245 o->op_private |= OPpFT_ACCESS;
5247 if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
5248 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
5249 o->op_private |= OPpFT_STACKED;
5253 if (type == OP_FTTTY)
5254 o = newGVOP(type, OPf_REF, PL_stdingv);
5256 o = newUNOP(type, 0, newDEFSVOP());
5262 Perl_ck_fun(pTHX_ OP *o)
5264 const int type = o->op_type;
5265 register I32 oa = PL_opargs[type] >> OASHIFT;
5267 if (o->op_flags & OPf_STACKED) {
5268 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5271 return no_fh_allowed(o);
5274 if (o->op_flags & OPf_KIDS) {
5275 OP **tokid = &cLISTOPo->op_first;
5276 register OP *kid = cLISTOPo->op_first;
5280 if (kid->op_type == OP_PUSHMARK ||
5281 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5283 tokid = &kid->op_sibling;
5284 kid = kid->op_sibling;
5286 if (!kid && PL_opargs[type] & OA_DEFGV)
5287 *tokid = kid = newDEFSVOP();
5291 sibl = kid->op_sibling;
5294 /* list seen where single (scalar) arg expected? */
5295 if (numargs == 1 && !(oa >> 4)
5296 && kid->op_type == OP_LIST && type != OP_SCALAR)
5298 return too_many_arguments(o,PL_op_desc[type]);
5311 if ((type == OP_PUSH || type == OP_UNSHIFT)
5312 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5313 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5314 "Useless use of %s with no values",
5317 if (kid->op_type == OP_CONST &&
5318 (kid->op_private & OPpCONST_BARE))
5320 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5321 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVAV) ));
5322 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5323 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5324 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
5325 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5328 kid->op_sibling = sibl;
5331 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5332 bad_type(numargs, "array", PL_op_desc[type], kid);
5336 if (kid->op_type == OP_CONST &&
5337 (kid->op_private & OPpCONST_BARE))
5339 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5340 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVHV) ));
5341 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5342 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5343 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
5344 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5347 kid->op_sibling = sibl;
5350 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5351 bad_type(numargs, "hash", PL_op_desc[type], kid);
5356 OP *newop = newUNOP(OP_NULL, 0, kid);
5357 kid->op_sibling = 0;
5359 newop->op_next = newop;
5361 kid->op_sibling = sibl;
5366 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5367 if (kid->op_type == OP_CONST &&
5368 (kid->op_private & OPpCONST_BARE))
5370 OP *newop = newGVOP(OP_GV, 0,
5371 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVIO) );
5372 if (!(o->op_private & 1) && /* if not unop */
5373 kid == cLISTOPo->op_last)
5374 cLISTOPo->op_last = newop;
5378 else if (kid->op_type == OP_READLINE) {
5379 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5380 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5383 I32 flags = OPf_SPECIAL;
5387 /* is this op a FH constructor? */
5388 if (is_handle_constructor(o,numargs)) {
5389 const char *name = Nullch;
5393 /* Set a flag to tell rv2gv to vivify
5394 * need to "prove" flag does not mean something
5395 * else already - NI-S 1999/05/07
5398 if (kid->op_type == OP_PADSV) {
5399 name = PAD_COMPNAME_PV(kid->op_targ);
5400 /* SvCUR of a pad namesv can't be trusted
5401 * (see PL_generation), so calc its length
5407 else if (kid->op_type == OP_RV2SV
5408 && kUNOP->op_first->op_type == OP_GV)
5410 GV *gv = cGVOPx_gv(kUNOP->op_first);
5412 len = GvNAMELEN(gv);
5414 else if (kid->op_type == OP_AELEM
5415 || kid->op_type == OP_HELEM)
5420 if ((op = ((BINOP*)kid)->op_first)) {
5421 SV *tmpstr = Nullsv;
5423 kid->op_type == OP_AELEM ?
5425 if (((op->op_type == OP_RV2AV) ||
5426 (op->op_type == OP_RV2HV)) &&
5427 (op = ((UNOP*)op)->op_first) &&
5428 (op->op_type == OP_GV)) {
5429 /* packagevar $a[] or $h{} */
5430 GV *gv = cGVOPx_gv(op);
5438 else if (op->op_type == OP_PADAV
5439 || op->op_type == OP_PADHV) {
5440 /* lexicalvar $a[] or $h{} */
5441 const char *padname =
5442 PAD_COMPNAME_PV(op->op_targ);
5452 name = SvPV(tmpstr, len);
5457 name = "__ANONIO__";
5464 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5465 namesv = PAD_SVl(targ);
5466 (void)SvUPGRADE(namesv, SVt_PV);
5468 sv_setpvn(namesv, "$", 1);
5469 sv_catpvn(namesv, name, len);
5472 kid->op_sibling = 0;
5473 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5474 kid->op_targ = targ;
5475 kid->op_private |= priv;
5477 kid->op_sibling = sibl;
5483 mod(scalar(kid), type);
5487 tokid = &kid->op_sibling;
5488 kid = kid->op_sibling;
5490 o->op_private |= numargs;
5492 return too_many_arguments(o,OP_DESC(o));
5495 else if (PL_opargs[type] & OA_DEFGV) {
5497 return newUNOP(type, 0, newDEFSVOP());
5501 while (oa & OA_OPTIONAL)
5503 if (oa && oa != OA_LIST)
5504 return too_few_arguments(o,OP_DESC(o));
5510 Perl_ck_glob(pTHX_ OP *o)
5515 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5516 append_elem(OP_GLOB, o, newDEFSVOP());
5518 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5519 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5521 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5524 #if !defined(PERL_EXTERNAL_GLOB)
5525 /* XXX this can be tightened up and made more failsafe. */
5526 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5529 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5530 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5531 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5532 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5533 GvCV(gv) = GvCV(glob_gv);
5534 (void)SvREFCNT_inc((SV*)GvCV(gv));
5535 GvIMPORTED_CV_on(gv);
5538 #endif /* PERL_EXTERNAL_GLOB */
5540 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5541 append_elem(OP_GLOB, o,
5542 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5543 o->op_type = OP_LIST;
5544 o->op_ppaddr = PL_ppaddr[OP_LIST];
5545 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5546 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5547 cLISTOPo->op_first->op_targ = 0;
5548 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5549 append_elem(OP_LIST, o,
5550 scalar(newUNOP(OP_RV2CV, 0,
5551 newGVOP(OP_GV, 0, gv)))));
5552 o = newUNOP(OP_NULL, 0, ck_subr(o));
5553 o->op_targ = OP_GLOB; /* hint at what it used to be */
5556 gv = newGVgen("main");
5558 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5564 Perl_ck_grep(pTHX_ OP *o)
5568 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5571 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5572 NewOp(1101, gwop, 1, LOGOP);
5574 if (o->op_flags & OPf_STACKED) {
5577 kid = cLISTOPo->op_first->op_sibling;
5578 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
5581 kid->op_next = (OP*)gwop;
5582 o->op_flags &= ~OPf_STACKED;
5584 kid = cLISTOPo->op_first->op_sibling;
5585 if (type == OP_MAPWHILE)
5592 kid = cLISTOPo->op_first->op_sibling;
5593 if (kid->op_type != OP_NULL)
5594 Perl_croak(aTHX_ "panic: ck_grep");
5595 kid = kUNOP->op_first;
5597 gwop->op_type = type;
5598 gwop->op_ppaddr = PL_ppaddr[type];
5599 gwop->op_first = listkids(o);
5600 gwop->op_flags |= OPf_KIDS;
5601 gwop->op_other = LINKLIST(kid);
5602 kid->op_next = (OP*)gwop;
5603 offset = pad_findmy("$_");
5604 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
5605 o->op_private = gwop->op_private = 0;
5606 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5609 o->op_private = gwop->op_private = OPpGREP_LEX;
5610 gwop->op_targ = o->op_targ = offset;
5613 kid = cLISTOPo->op_first->op_sibling;
5614 if (!kid || !kid->op_sibling)
5615 return too_few_arguments(o,OP_DESC(o));
5616 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5617 mod(kid, OP_GREPSTART);
5623 Perl_ck_index(pTHX_ OP *o)
5625 if (o->op_flags & OPf_KIDS) {
5626 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5628 kid = kid->op_sibling; /* get past "big" */
5629 if (kid && kid->op_type == OP_CONST)
5630 fbm_compile(((SVOP*)kid)->op_sv, 0);
5636 Perl_ck_lengthconst(pTHX_ OP *o)
5638 /* XXX length optimization goes here */
5643 Perl_ck_lfun(pTHX_ OP *o)
5645 const OPCODE type = o->op_type;
5646 return modkids(ck_fun(o), type);
5650 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5652 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5653 switch (cUNOPo->op_first->op_type) {
5655 /* This is needed for
5656 if (defined %stash::)
5657 to work. Do not break Tk.
5659 break; /* Globals via GV can be undef */
5661 case OP_AASSIGN: /* Is this a good idea? */
5662 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5663 "defined(@array) is deprecated");
5664 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5665 "\t(Maybe you should just omit the defined()?)\n");
5668 /* This is needed for
5669 if (defined %stash::)
5670 to work. Do not break Tk.
5672 break; /* Globals via GV can be undef */
5674 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5675 "defined(%%hash) is deprecated");
5676 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5677 "\t(Maybe you should just omit the defined()?)\n");
5688 Perl_ck_rfun(pTHX_ OP *o)
5690 const OPCODE type = o->op_type;
5691 return refkids(ck_fun(o), type);
5695 Perl_ck_listiob(pTHX_ OP *o)
5699 kid = cLISTOPo->op_first;
5702 kid = cLISTOPo->op_first;
5704 if (kid->op_type == OP_PUSHMARK)
5705 kid = kid->op_sibling;
5706 if (kid && o->op_flags & OPf_STACKED)
5707 kid = kid->op_sibling;
5708 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5709 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5710 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5711 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5712 cLISTOPo->op_first->op_sibling = kid;
5713 cLISTOPo->op_last = kid;
5714 kid = kid->op_sibling;
5719 append_elem(o->op_type, o, newDEFSVOP());
5725 Perl_ck_sassign(pTHX_ OP *o)
5727 OP *kid = cLISTOPo->op_first;
5728 /* has a disposable target? */
5729 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5730 && !(kid->op_flags & OPf_STACKED)
5731 /* Cannot steal the second time! */
5732 && !(kid->op_private & OPpTARGET_MY))
5734 OP *kkid = kid->op_sibling;
5736 /* Can just relocate the target. */
5737 if (kkid && kkid->op_type == OP_PADSV
5738 && !(kkid->op_private & OPpLVAL_INTRO))
5740 kid->op_targ = kkid->op_targ;
5742 /* Now we do not need PADSV and SASSIGN. */
5743 kid->op_sibling = o->op_sibling; /* NULL */
5744 cLISTOPo->op_first = NULL;
5747 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
5751 /* optimise C<my $x = undef> to C<my $x> */
5752 if (kid->op_type == OP_UNDEF) {
5753 OP *kkid = kid->op_sibling;
5754 if (kkid && kkid->op_type == OP_PADSV
5755 && (kkid->op_private & OPpLVAL_INTRO))
5757 cLISTOPo->op_first = NULL;
5758 kid->op_sibling = NULL;
5768 Perl_ck_match(pTHX_ OP *o)
5770 if (o->op_type != OP_QR) {
5771 const I32 offset = pad_findmy("$_");
5772 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS(offset) & SVpad_OUR)) {
5773 o->op_targ = offset;
5774 o->op_private |= OPpTARGET_MY;
5777 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
5778 o->op_private |= OPpRUNTIME;
5783 Perl_ck_method(pTHX_ OP *o)
5785 OP *kid = cUNOPo->op_first;
5786 if (kid->op_type == OP_CONST) {
5787 SV* sv = kSVOP->op_sv;
5788 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
5790 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5791 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
5794 kSVOP->op_sv = Nullsv;
5796 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5805 Perl_ck_null(pTHX_ OP *o)
5811 Perl_ck_open(pTHX_ OP *o)
5813 HV *table = GvHV(PL_hintgv);
5817 svp = hv_fetch(table, "open_IN", 7, FALSE);
5819 mode = mode_from_discipline(*svp);
5820 if (mode & O_BINARY)
5821 o->op_private |= OPpOPEN_IN_RAW;
5822 else if (mode & O_TEXT)
5823 o->op_private |= OPpOPEN_IN_CRLF;
5826 svp = hv_fetch(table, "open_OUT", 8, FALSE);
5828 mode = mode_from_discipline(*svp);
5829 if (mode & O_BINARY)
5830 o->op_private |= OPpOPEN_OUT_RAW;
5831 else if (mode & O_TEXT)
5832 o->op_private |= OPpOPEN_OUT_CRLF;
5835 if (o->op_type == OP_BACKTICK)
5838 /* In case of three-arg dup open remove strictness
5839 * from the last arg if it is a bareword. */
5840 OP *first = cLISTOPx(o)->op_first; /* The pushmark. */
5841 OP *last = cLISTOPx(o)->op_last; /* The bareword. */
5845 if ((last->op_type == OP_CONST) && /* The bareword. */
5846 (last->op_private & OPpCONST_BARE) &&
5847 (last->op_private & OPpCONST_STRICT) &&
5848 (oa = first->op_sibling) && /* The fh. */
5849 (oa = oa->op_sibling) && /* The mode. */
5850 SvPOK(((SVOP*)oa)->op_sv) &&
5851 (mode = SvPVX(((SVOP*)oa)->op_sv)) &&
5852 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
5853 (last == oa->op_sibling)) /* The bareword. */
5854 last->op_private &= ~OPpCONST_STRICT;
5860 Perl_ck_repeat(pTHX_ OP *o)
5862 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5863 o->op_private |= OPpREPEAT_DOLIST;
5864 cBINOPo->op_first = force_list(cBINOPo->op_first);
5872 Perl_ck_require(pTHX_ OP *o)
5876 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
5877 SVOP *kid = (SVOP*)cUNOPo->op_first;
5879 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5881 for (s = SvPVX(kid->op_sv); *s; s++) {
5882 if (*s == ':' && s[1] == ':') {
5884 Move(s+2, s+1, strlen(s+2)+1, char);
5885 --SvCUR(kid->op_sv);
5888 if (SvREADONLY(kid->op_sv)) {
5889 SvREADONLY_off(kid->op_sv);
5890 sv_catpvn(kid->op_sv, ".pm", 3);
5891 SvREADONLY_on(kid->op_sv);
5894 sv_catpvn(kid->op_sv, ".pm", 3);
5898 /* handle override, if any */
5899 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
5900 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
5901 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
5903 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5904 OP *kid = cUNOPo->op_first;
5905 cUNOPo->op_first = 0;
5907 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5908 append_elem(OP_LIST, kid,
5909 scalar(newUNOP(OP_RV2CV, 0,
5918 Perl_ck_return(pTHX_ OP *o)
5920 if (CvLVALUE(PL_compcv)) {
5922 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5923 mod(kid, OP_LEAVESUBLV);
5930 Perl_ck_retarget(pTHX_ OP *o)
5932 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5939 Perl_ck_select(pTHX_ OP *o)
5942 if (o->op_flags & OPf_KIDS) {
5943 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5944 if (kid && kid->op_sibling) {
5945 o->op_type = OP_SSELECT;
5946 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
5948 return fold_constants(o);
5952 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5953 if (kid && kid->op_type == OP_RV2GV)
5954 kid->op_private &= ~HINT_STRICT_REFS;
5959 Perl_ck_shift(pTHX_ OP *o)
5961 const I32 type = o->op_type;
5963 if (!(o->op_flags & OPf_KIDS)) {
5967 argop = newUNOP(OP_RV2AV, 0,
5968 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
5969 return newUNOP(type, 0, scalar(argop));
5971 return scalar(modkids(ck_fun(o), type));
5975 Perl_ck_sort(pTHX_ OP *o)
5979 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
5981 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5982 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
5984 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
5986 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
5988 if (kid->op_type == OP_SCOPE) {
5992 else if (kid->op_type == OP_LEAVE) {
5993 if (o->op_type == OP_SORT) {
5994 op_null(kid); /* wipe out leave */
5997 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
5998 if (k->op_next == kid)
6000 /* don't descend into loops */
6001 else if (k->op_type == OP_ENTERLOOP
6002 || k->op_type == OP_ENTERITER)
6004 k = cLOOPx(k)->op_lastop;
6009 kid->op_next = 0; /* just disconnect the leave */
6010 k = kLISTOP->op_first;
6015 if (o->op_type == OP_SORT) {
6016 /* provide scalar context for comparison function/block */
6022 o->op_flags |= OPf_SPECIAL;
6024 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6027 firstkid = firstkid->op_sibling;
6030 /* provide list context for arguments */
6031 if (o->op_type == OP_SORT)
6038 S_simplify_sort(pTHX_ OP *o)
6040 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6045 if (!(o->op_flags & OPf_STACKED))
6047 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6048 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6049 kid = kUNOP->op_first; /* get past null */
6050 if (kid->op_type != OP_SCOPE)
6052 kid = kLISTOP->op_last; /* get past scope */
6053 switch(kid->op_type) {
6061 k = kid; /* remember this node*/
6062 if (kBINOP->op_first->op_type != OP_RV2SV)
6064 kid = kBINOP->op_first; /* get past cmp */
6065 if (kUNOP->op_first->op_type != OP_GV)
6067 kid = kUNOP->op_first; /* get past rv2sv */
6069 if (GvSTASH(gv) != PL_curstash)
6071 gvname = GvNAME(gv);
6072 if (*gvname == 'a' && gvname[1] == '\0')
6074 else if (*gvname == 'b' && gvname[1] == '\0')
6079 kid = k; /* back to cmp */
6080 if (kBINOP->op_last->op_type != OP_RV2SV)
6082 kid = kBINOP->op_last; /* down to 2nd arg */
6083 if (kUNOP->op_first->op_type != OP_GV)
6085 kid = kUNOP->op_first; /* get past rv2sv */
6087 if (GvSTASH(gv) != PL_curstash)
6089 gvname = GvNAME(gv);
6091 ? !(*gvname == 'a' && gvname[1] == '\0')
6092 : !(*gvname == 'b' && gvname[1] == '\0'))
6094 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6096 o->op_private |= OPpSORT_DESCEND;
6097 if (k->op_type == OP_NCMP)
6098 o->op_private |= OPpSORT_NUMERIC;
6099 if (k->op_type == OP_I_NCMP)
6100 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6101 kid = cLISTOPo->op_first->op_sibling;
6102 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6103 op_free(kid); /* then delete it */
6107 Perl_ck_split(pTHX_ OP *o)
6111 if (o->op_flags & OPf_STACKED)
6112 return no_fh_allowed(o);
6114 kid = cLISTOPo->op_first;
6115 if (kid->op_type != OP_NULL)
6116 Perl_croak(aTHX_ "panic: ck_split");
6117 kid = kid->op_sibling;
6118 op_free(cLISTOPo->op_first);
6119 cLISTOPo->op_first = kid;
6121 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6122 cLISTOPo->op_last = kid; /* There was only one element previously */
6125 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6126 OP *sibl = kid->op_sibling;
6127 kid->op_sibling = 0;
6128 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
6129 if (cLISTOPo->op_first == cLISTOPo->op_last)
6130 cLISTOPo->op_last = kid;
6131 cLISTOPo->op_first = kid;
6132 kid->op_sibling = sibl;
6135 kid->op_type = OP_PUSHRE;
6136 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6138 if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
6139 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
6140 "Use of /g modifier is meaningless in split");
6143 if (!kid->op_sibling)
6144 append_elem(OP_SPLIT, o, newDEFSVOP());
6146 kid = kid->op_sibling;
6149 if (!kid->op_sibling)
6150 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6152 kid = kid->op_sibling;
6155 if (kid->op_sibling)
6156 return too_many_arguments(o,OP_DESC(o));
6162 Perl_ck_join(pTHX_ OP *o)
6164 if (ckWARN(WARN_SYNTAX)) {
6165 const OP *kid = cLISTOPo->op_first->op_sibling;
6166 if (kid && kid->op_type == OP_MATCH) {
6167 const REGEXP *re = PM_GETRE(kPMOP);
6168 const char *pmstr = re ? re->precomp : "STRING";
6169 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6170 "/%s/ should probably be written as \"%s\"",
6178 Perl_ck_subr(pTHX_ OP *o)
6180 OP *prev = ((cUNOPo->op_first->op_sibling)
6181 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6182 OP *o2 = prev->op_sibling;
6189 I32 contextclass = 0;
6194 o->op_private |= OPpENTERSUB_HASTARG;
6195 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6196 if (cvop->op_type == OP_RV2CV) {
6198 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6199 op_null(cvop); /* disable rv2cv */
6200 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6201 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6202 GV *gv = cGVOPx_gv(tmpop);
6205 tmpop->op_private |= OPpEARLY_CV;
6208 namegv = CvANON(cv) ? gv : CvGV(cv);
6209 proto = SvPV((SV*)cv, n_a);
6211 if (CvASSERTION(cv)) {
6212 if (PL_hints & HINT_ASSERTING) {
6213 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
6214 o->op_private |= OPpENTERSUB_DB;
6218 if (ckWARN(WARN_ASSERTIONS) && !(PL_hints & HINT_ASSERTIONSSEEN)) {
6219 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
6220 "Impossible to activate assertion call");
6227 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6228 if (o2->op_type == OP_CONST)
6229 o2->op_private &= ~OPpCONST_STRICT;
6230 else if (o2->op_type == OP_LIST) {
6231 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6232 if (o && o->op_type == OP_CONST)
6233 o->op_private &= ~OPpCONST_STRICT;
6236 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6237 if (PERLDB_SUB && PL_curstash != PL_debstash)
6238 o->op_private |= OPpENTERSUB_DB;
6239 while (o2 != cvop) {
6243 return too_many_arguments(o, gv_ename(namegv));
6261 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6263 arg == 1 ? "block or sub {}" : "sub {}",
6264 gv_ename(namegv), o2);
6267 /* '*' allows any scalar type, including bareword */
6270 if (o2->op_type == OP_RV2GV)
6271 goto wrapref; /* autoconvert GLOB -> GLOBref */
6272 else if (o2->op_type == OP_CONST)
6273 o2->op_private &= ~OPpCONST_STRICT;
6274 else if (o2->op_type == OP_ENTERSUB) {
6275 /* accidental subroutine, revert to bareword */
6276 OP *gvop = ((UNOP*)o2)->op_first;
6277 if (gvop && gvop->op_type == OP_NULL) {
6278 gvop = ((UNOP*)gvop)->op_first;
6280 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6283 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6284 (gvop = ((UNOP*)gvop)->op_first) &&
6285 gvop->op_type == OP_GV)
6287 GV *gv = cGVOPx_gv(gvop);
6288 OP *sibling = o2->op_sibling;
6289 SV *n = newSVpvn("",0);
6291 gv_fullname4(n, gv, "", FALSE);
6292 o2 = newSVOP(OP_CONST, 0, n);
6293 prev->op_sibling = o2;
6294 o2->op_sibling = sibling;
6310 if (contextclass++ == 0) {
6311 e = strchr(proto, ']');
6312 if (!e || e == proto)
6325 while (*--p != '[');
6326 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6327 gv_ename(namegv), o2);
6333 if (o2->op_type == OP_RV2GV)
6336 bad_type(arg, "symbol", gv_ename(namegv), o2);
6339 if (o2->op_type == OP_ENTERSUB)
6342 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6345 if (o2->op_type == OP_RV2SV ||
6346 o2->op_type == OP_PADSV ||
6347 o2->op_type == OP_HELEM ||
6348 o2->op_type == OP_AELEM ||
6349 o2->op_type == OP_THREADSV)
6352 bad_type(arg, "scalar", gv_ename(namegv), o2);
6355 if (o2->op_type == OP_RV2AV ||
6356 o2->op_type == OP_PADAV)
6359 bad_type(arg, "array", gv_ename(namegv), o2);
6362 if (o2->op_type == OP_RV2HV ||
6363 o2->op_type == OP_PADHV)
6366 bad_type(arg, "hash", gv_ename(namegv), o2);
6371 OP* sib = kid->op_sibling;
6372 kid->op_sibling = 0;
6373 o2 = newUNOP(OP_REFGEN, 0, kid);
6374 o2->op_sibling = sib;
6375 prev->op_sibling = o2;
6377 if (contextclass && e) {
6392 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6393 gv_ename(namegv), cv);
6398 mod(o2, OP_ENTERSUB);
6400 o2 = o2->op_sibling;
6402 if (proto && !optional &&
6403 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6404 return too_few_arguments(o, gv_ename(namegv));
6407 o=newSVOP(OP_CONST, 0, newSViv(0));
6413 Perl_ck_svconst(pTHX_ OP *o)
6415 SvREADONLY_on(cSVOPo->op_sv);
6420 Perl_ck_trunc(pTHX_ OP *o)
6422 if (o->op_flags & OPf_KIDS) {
6423 SVOP *kid = (SVOP*)cUNOPo->op_first;
6425 if (kid->op_type == OP_NULL)
6426 kid = (SVOP*)kid->op_sibling;
6427 if (kid && kid->op_type == OP_CONST &&
6428 (kid->op_private & OPpCONST_BARE))
6430 o->op_flags |= OPf_SPECIAL;
6431 kid->op_private &= ~OPpCONST_STRICT;
6438 Perl_ck_unpack(pTHX_ OP *o)
6440 OP *kid = cLISTOPo->op_first;
6441 if (kid->op_sibling) {
6442 kid = kid->op_sibling;
6443 if (!kid->op_sibling)
6444 kid->op_sibling = newDEFSVOP();
6450 Perl_ck_substr(pTHX_ OP *o)
6453 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6454 OP *kid = cLISTOPo->op_first;
6456 if (kid->op_type == OP_NULL)
6457 kid = kid->op_sibling;
6459 kid->op_flags |= OPf_MOD;
6465 /* A peephole optimizer. We visit the ops in the order they're to execute.
6466 * See the comments at the top of this file for more details about when
6467 * peep() is called */
6470 Perl_peep(pTHX_ register OP *o)
6472 register OP* oldop = 0;
6474 if (!o || o->op_opt)
6478 SAVEVPTR(PL_curcop);
6479 for (; o; o = o->op_next) {
6483 switch (o->op_type) {
6487 PL_curcop = ((COP*)o); /* for warnings */
6492 if (cSVOPo->op_private & OPpCONST_STRICT)
6493 no_bareword_allowed(o);
6495 case OP_METHOD_NAMED:
6496 /* Relocate sv to the pad for thread safety.
6497 * Despite being a "constant", the SV is written to,
6498 * for reference counts, sv_upgrade() etc. */
6500 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6501 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6502 /* If op_sv is already a PADTMP then it is being used by
6503 * some pad, so make a copy. */
6504 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6505 SvREADONLY_on(PAD_SVl(ix));
6506 SvREFCNT_dec(cSVOPo->op_sv);
6509 SvREFCNT_dec(PAD_SVl(ix));
6510 SvPADTMP_on(cSVOPo->op_sv);
6511 PAD_SETSV(ix, cSVOPo->op_sv);
6512 /* XXX I don't know how this isn't readonly already. */
6513 SvREADONLY_on(PAD_SVl(ix));
6515 cSVOPo->op_sv = Nullsv;
6523 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6524 if (o->op_next->op_private & OPpTARGET_MY) {
6525 if (o->op_flags & OPf_STACKED) /* chained concats */
6526 goto ignore_optimization;
6528 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6529 o->op_targ = o->op_next->op_targ;
6530 o->op_next->op_targ = 0;
6531 o->op_private |= OPpTARGET_MY;
6534 op_null(o->op_next);
6536 ignore_optimization:
6540 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6542 break; /* Scalar stub must produce undef. List stub is noop */
6546 if (o->op_targ == OP_NEXTSTATE
6547 || o->op_targ == OP_DBSTATE
6548 || o->op_targ == OP_SETSTATE)
6550 PL_curcop = ((COP*)o);
6552 /* XXX: We avoid setting op_seq here to prevent later calls
6553 to peep() from mistakenly concluding that optimisation
6554 has already occurred. This doesn't fix the real problem,
6555 though (See 20010220.007). AMS 20010719 */
6556 /* op_seq functionality is now replaced by op_opt */
6557 if (oldop && o->op_next) {
6558 oldop->op_next = o->op_next;
6566 if (oldop && o->op_next) {
6567 oldop->op_next = o->op_next;
6575 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
6576 OP* pop = (o->op_type == OP_PADAV) ?
6577 o->op_next : o->op_next->op_next;
6579 if (pop && pop->op_type == OP_CONST &&
6580 ((PL_op = pop->op_next)) &&
6581 pop->op_next->op_type == OP_AELEM &&
6582 !(pop->op_next->op_private &
6583 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6584 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6589 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
6590 no_bareword_allowed(pop);
6591 if (o->op_type == OP_GV)
6592 op_null(o->op_next);
6593 op_null(pop->op_next);
6595 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6596 o->op_next = pop->op_next->op_next;
6597 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6598 o->op_private = (U8)i;
6599 if (o->op_type == OP_GV) {
6604 o->op_flags |= OPf_SPECIAL;
6605 o->op_type = OP_AELEMFAST;
6611 if (o->op_next->op_type == OP_RV2SV) {
6612 if (!(o->op_next->op_private & OPpDEREF)) {
6613 op_null(o->op_next);
6614 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6616 o->op_next = o->op_next->op_next;
6617 o->op_type = OP_GVSV;
6618 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6621 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6623 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6624 /* XXX could check prototype here instead of just carping */
6625 SV *sv = sv_newmortal();
6626 gv_efullname3(sv, gv, Nullch);
6627 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6628 "%"SVf"() called too early to check prototype",
6632 else if (o->op_next->op_type == OP_READLINE
6633 && o->op_next->op_next->op_type == OP_CONCAT
6634 && (o->op_next->op_next->op_flags & OPf_STACKED))
6636 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6637 o->op_type = OP_RCATLINE;
6638 o->op_flags |= OPf_STACKED;
6639 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6640 op_null(o->op_next->op_next);
6641 op_null(o->op_next);
6658 while (cLOGOP->op_other->op_type == OP_NULL)
6659 cLOGOP->op_other = cLOGOP->op_other->op_next;
6660 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6666 while (cLOOP->op_redoop->op_type == OP_NULL)
6667 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6668 peep(cLOOP->op_redoop);
6669 while (cLOOP->op_nextop->op_type == OP_NULL)
6670 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6671 peep(cLOOP->op_nextop);
6672 while (cLOOP->op_lastop->op_type == OP_NULL)
6673 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6674 peep(cLOOP->op_lastop);
6681 while (cPMOP->op_pmreplstart &&
6682 cPMOP->op_pmreplstart->op_type == OP_NULL)
6683 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6684 peep(cPMOP->op_pmreplstart);
6689 if (ckWARN(WARN_SYNTAX) && o->op_next
6690 && o->op_next->op_type == OP_NEXTSTATE) {
6691 if (o->op_next->op_sibling &&
6692 o->op_next->op_sibling->op_type != OP_EXIT &&
6693 o->op_next->op_sibling->op_type != OP_WARN &&
6694 o->op_next->op_sibling->op_type != OP_DIE) {
6695 const line_t oldline = CopLINE(PL_curcop);
6697 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6698 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6699 "Statement unlikely to be reached");
6700 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6701 "\t(Maybe you meant system() when you said exec()?)\n");
6702 CopLINE_set(PL_curcop, oldline);
6717 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6720 /* Make the CONST have a shared SV */
6721 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6722 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6723 key = SvPV(sv, keylen);
6724 lexname = newSVpvn_share(key,
6725 SvUTF8(sv) ? -(I32)keylen : keylen,
6731 if ((o->op_private & (OPpLVAL_INTRO)))
6734 rop = (UNOP*)((BINOP*)o)->op_first;
6735 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6737 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6738 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6740 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6741 if (!fields || !GvHV(*fields))
6743 key = SvPV(*svp, keylen);
6744 if (!hv_fetch(GvHV(*fields), key,
6745 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
6747 Perl_croak(aTHX_ "No such class field \"%s\" "
6748 "in variable %s of type %s",
6749 key, SvPV_nolen(lexname), HvNAME(SvSTASH(lexname)));
6762 SVOP *first_key_op, *key_op;
6764 if ((o->op_private & (OPpLVAL_INTRO))
6765 /* I bet there's always a pushmark... */
6766 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6767 /* hmmm, no optimization if list contains only one key. */
6769 rop = (UNOP*)((LISTOP*)o)->op_last;
6770 if (rop->op_type != OP_RV2HV)
6772 if (rop->op_first->op_type == OP_PADSV)
6773 /* @$hash{qw(keys here)} */
6774 rop = (UNOP*)rop->op_first;
6776 /* @{$hash}{qw(keys here)} */
6777 if (rop->op_first->op_type == OP_SCOPE
6778 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
6780 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
6786 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
6787 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6789 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6790 if (!fields || !GvHV(*fields))
6792 /* Again guessing that the pushmark can be jumped over.... */
6793 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
6794 ->op_first->op_sibling;
6795 for (key_op = first_key_op; key_op;
6796 key_op = (SVOP*)key_op->op_sibling) {
6797 if (key_op->op_type != OP_CONST)
6799 svp = cSVOPx_svp(key_op);
6800 key = SvPV(*svp, keylen);
6801 if (!hv_fetch(GvHV(*fields), key,
6802 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
6804 Perl_croak(aTHX_ "No such class field \"%s\" "
6805 "in variable %s of type %s",
6806 key, SvPV_nolen(lexname), HvNAME(SvSTASH(lexname)));
6813 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
6817 /* check that RHS of sort is a single plain array */
6818 oright = cUNOPo->op_first;
6819 if (!oright || oright->op_type != OP_PUSHMARK)
6822 /* reverse sort ... can be optimised. */
6823 if (!cUNOPo->op_sibling) {
6824 /* Nothing follows us on the list. */
6825 OP *reverse = o->op_next;
6827 if (reverse->op_type == OP_REVERSE &&
6828 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
6829 OP *pushmark = cUNOPx(reverse)->op_first;
6830 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
6831 && (cUNOPx(pushmark)->op_sibling == o)) {
6832 /* reverse -> pushmark -> sort */
6833 o->op_private |= OPpSORT_REVERSE;
6835 pushmark->op_next = oright->op_next;
6841 /* make @a = sort @a act in-place */
6845 oright = cUNOPx(oright)->op_sibling;
6848 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
6849 oright = cUNOPx(oright)->op_sibling;
6853 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
6854 || oright->op_next != o
6855 || (oright->op_private & OPpLVAL_INTRO)
6859 /* o2 follows the chain of op_nexts through the LHS of the
6860 * assign (if any) to the aassign op itself */
6862 if (!o2 || o2->op_type != OP_NULL)
6865 if (!o2 || o2->op_type != OP_PUSHMARK)
6868 if (o2 && o2->op_type == OP_GV)
6871 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
6872 || (o2->op_private & OPpLVAL_INTRO)
6877 if (!o2 || o2->op_type != OP_NULL)
6880 if (!o2 || o2->op_type != OP_AASSIGN
6881 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
6884 /* check that the sort is the first arg on RHS of assign */
6886 o2 = cUNOPx(o2)->op_first;
6887 if (!o2 || o2->op_type != OP_NULL)
6889 o2 = cUNOPx(o2)->op_first;
6890 if (!o2 || o2->op_type != OP_PUSHMARK)
6892 if (o2->op_sibling != o)
6895 /* check the array is the same on both sides */
6896 if (oleft->op_type == OP_RV2AV) {
6897 if (oright->op_type != OP_RV2AV
6898 || !cUNOPx(oright)->op_first
6899 || cUNOPx(oright)->op_first->op_type != OP_GV
6900 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
6901 cGVOPx_gv(cUNOPx(oright)->op_first)
6905 else if (oright->op_type != OP_PADAV
6906 || oright->op_targ != oleft->op_targ
6910 /* transfer MODishness etc from LHS arg to RHS arg */
6911 oright->op_flags = oleft->op_flags;
6912 o->op_private |= OPpSORT_INPLACE;
6914 /* excise push->gv->rv2av->null->aassign */
6915 o2 = o->op_next->op_next;
6916 op_null(o2); /* PUSHMARK */
6918 if (o2->op_type == OP_GV) {
6919 op_null(o2); /* GV */
6922 op_null(o2); /* RV2AV or PADAV */
6923 o2 = o2->op_next->op_next;
6924 op_null(o2); /* AASSIGN */
6926 o->op_next = o2->op_next;
6932 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
6934 LISTOP *enter, *exlist;
6937 enter = (LISTOP *) o->op_next;
6940 if (enter->op_type == OP_NULL) {
6941 enter = (LISTOP *) enter->op_next;
6945 /* for $a (...) will have OP_GV then OP_RV2GV here.
6946 for (...) just has an OP_GV. */
6947 if (enter->op_type == OP_GV) {
6948 gvop = (OP *) enter;
6949 enter = (LISTOP *) enter->op_next;
6952 if (enter->op_type == OP_RV2GV) {
6953 enter = (LISTOP *) enter->op_next;
6959 if (enter->op_type != OP_ENTERITER)
6962 iter = enter->op_next;
6963 if (!iter || iter->op_type != OP_ITER)
6966 expushmark = enter->op_first;
6967 if (!expushmark || expushmark->op_type != OP_NULL
6968 || expushmark->op_targ != OP_PUSHMARK)
6971 exlist = (LISTOP *) expushmark->op_sibling;
6972 if (!exlist || exlist->op_type != OP_NULL
6973 || exlist->op_targ != OP_LIST)
6976 if (exlist->op_last != o) {
6977 /* Mmm. Was expecting to point back to this op. */
6980 theirmark = exlist->op_first;
6981 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
6984 if (theirmark->op_sibling != o) {
6985 /* There's something between the mark and the reverse, eg
6986 for (1, reverse (...))
6991 ourmark = ((LISTOP *)o)->op_first;
6992 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
6995 ourlast = ((LISTOP *)o)->op_last;
6996 if (!ourlast || ourlast->op_next != o)
6999 rv2av = ourmark->op_sibling;
7000 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
7001 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
7002 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
7003 /* We're just reversing a single array. */
7004 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
7005 enter->op_flags |= OPf_STACKED;
7008 /* We don't have control over who points to theirmark, so sacrifice
7010 theirmark->op_next = ourmark->op_next;
7011 theirmark->op_flags = ourmark->op_flags;
7012 ourlast->op_next = gvop ? gvop : (OP *) enter;
7015 enter->op_private |= OPpITER_REVERSED;
7016 iter->op_private |= OPpITER_REVERSED;
7031 Perl_custom_op_name(pTHX_ const OP* o)
7033 const IV index = PTR2IV(o->op_ppaddr);
7037 if (!PL_custom_op_names) /* This probably shouldn't happen */
7038 return PL_op_name[OP_CUSTOM];
7040 keysv = sv_2mortal(newSViv(index));
7042 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7044 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7046 return SvPV_nolen(HeVAL(he));
7050 Perl_custom_op_desc(pTHX_ const OP* o)
7052 const IV index = PTR2IV(o->op_ppaddr);
7056 if (!PL_custom_op_descs)
7057 return PL_op_desc[OP_CUSTOM];
7059 keysv = sv_2mortal(newSViv(index));
7061 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7063 return PL_op_desc[OP_CUSTOM];
7065 return SvPV_nolen(HeVAL(he));
7070 /* Efficient sub that returns a constant scalar value. */
7072 const_sv_xsub(pTHX_ CV* cv)
7077 Perl_croak(aTHX_ "usage: %s::%s()",
7078 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7082 ST(0) = (SV*)XSANY.any_ptr;
7088 * c-indentation-style: bsd
7090 * indent-tabs-mode: t
7093 * vim: shiftwidth=4: