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_set(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_set(curop->op_targ, PL_generation);
3309 else if (curop->op_type == OP_RV2CV)
3311 else if (curop->op_type == OP_RV2SV ||
3312 curop->op_type == OP_RV2AV ||
3313 curop->op_type == OP_RV2HV ||
3314 curop->op_type == OP_RV2GV) {
3315 if (lastop->op_type != OP_GV) /* funny deref? */
3318 else if (curop->op_type == OP_PUSHRE) {
3319 if (((PMOP*)curop)->op_pmreplroot) {
3321 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3322 ((PMOP*)curop)->op_pmreplroot));
3324 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3326 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3328 SvCUR_set(gv, PL_generation);
3337 o->op_private |= OPpASSIGN_COMMON;
3339 if (right && right->op_type == OP_SPLIT) {
3341 if ((tmpop = ((LISTOP*)right)->op_first) &&
3342 tmpop->op_type == OP_PUSHRE)
3344 PMOP *pm = (PMOP*)tmpop;
3345 if (left->op_type == OP_RV2AV &&
3346 !(left->op_private & OPpLVAL_INTRO) &&
3347 !(o->op_private & OPpASSIGN_COMMON) )
3349 tmpop = ((UNOP*)left)->op_first;
3350 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3352 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3353 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3355 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3356 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3358 pm->op_pmflags |= PMf_ONCE;
3359 tmpop = cUNOPo->op_first; /* to list (nulled) */
3360 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3361 tmpop->op_sibling = Nullop; /* don't free split */
3362 right->op_next = tmpop->op_next; /* fix starting loc */
3363 op_free(o); /* blow off assign */
3364 right->op_flags &= ~OPf_WANT;
3365 /* "I don't know and I don't care." */
3370 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3371 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3373 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3375 sv_setiv(sv, PL_modcount+1);
3383 right = newOP(OP_UNDEF, 0);
3384 if (right->op_type == OP_READLINE) {
3385 right->op_flags |= OPf_STACKED;
3386 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3389 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3390 o = newBINOP(OP_SASSIGN, flags,
3391 scalar(right), mod(scalar(left), OP_SASSIGN) );
3403 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3405 const U32 seq = intro_my();
3408 NewOp(1101, cop, 1, COP);
3409 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3410 cop->op_type = OP_DBSTATE;
3411 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3414 cop->op_type = OP_NEXTSTATE;
3415 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3417 cop->op_flags = (U8)flags;
3418 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3420 cop->op_private |= NATIVE_HINTS;
3422 PL_compiling.op_private = cop->op_private;
3423 cop->op_next = (OP*)cop;
3426 cop->cop_label = label;
3427 PL_hints |= HINT_BLOCK_SCOPE;
3430 cop->cop_arybase = PL_curcop->cop_arybase;
3431 if (specialWARN(PL_curcop->cop_warnings))
3432 cop->cop_warnings = PL_curcop->cop_warnings ;
3434 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3435 if (specialCopIO(PL_curcop->cop_io))
3436 cop->cop_io = PL_curcop->cop_io;
3438 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3441 if (PL_copline == NOLINE)
3442 CopLINE_set(cop, CopLINE(PL_curcop));
3444 CopLINE_set(cop, PL_copline);
3445 PL_copline = NOLINE;
3448 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3450 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3452 CopSTASH_set(cop, PL_curstash);
3454 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3455 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3456 if (svp && *svp != &PL_sv_undef ) {
3457 (void)SvIOK_on(*svp);
3458 SvIV_set(*svp, PTR2IV(cop));
3462 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3467 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3469 return new_logop(type, flags, &first, &other);
3473 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3477 OP *first = *firstp;
3478 OP *other = *otherp;
3480 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3481 return newBINOP(type, flags, scalar(first), scalar(other));
3483 scalarboolean(first);
3484 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3485 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3486 if (type == OP_AND || type == OP_OR) {
3492 first = *firstp = cUNOPo->op_first;
3494 first->op_next = o->op_next;
3495 cUNOPo->op_first = Nullop;
3499 if (first->op_type == OP_CONST) {
3500 if (first->op_private & OPpCONST_STRICT)
3501 no_bareword_allowed(first);
3502 else if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3503 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3504 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
3505 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
3506 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
3509 if (other->op_type == OP_CONST)
3510 other->op_private |= OPpCONST_SHORTCIRCUIT;
3514 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
3515 const OP *o2 = other;
3516 if ( ! (o2->op_type == OP_LIST
3517 && (( o2 = cUNOPx(o2)->op_first))
3518 && o2->op_type == OP_PUSHMARK
3519 && (( o2 = o2->op_sibling)) )
3522 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
3523 || o2->op_type == OP_PADHV)
3524 && o2->op_private & OPpLVAL_INTRO
3525 && ckWARN(WARN_DEPRECATED))
3527 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
3528 "Deprecated use of my() in false conditional");
3533 if (first->op_type == OP_CONST)
3534 first->op_private |= OPpCONST_SHORTCIRCUIT;
3538 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS) &&
3539 type != OP_DOR) /* [#24076] Don't warn for <FH> err FOO. */
3541 const OP *k1 = ((UNOP*)first)->op_first;
3542 const OP *k2 = k1->op_sibling;
3544 switch (first->op_type)
3547 if (k2 && k2->op_type == OP_READLINE
3548 && (k2->op_flags & OPf_STACKED)
3549 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3551 warnop = k2->op_type;
3556 if (k1->op_type == OP_READDIR
3557 || k1->op_type == OP_GLOB
3558 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3559 || k1->op_type == OP_EACH)
3561 warnop = ((k1->op_type == OP_NULL)
3562 ? (OPCODE)k1->op_targ : k1->op_type);
3567 const line_t oldline = CopLINE(PL_curcop);
3568 CopLINE_set(PL_curcop, PL_copline);
3569 Perl_warner(aTHX_ packWARN(WARN_MISC),
3570 "Value of %s%s can be \"0\"; test with defined()",
3572 ((warnop == OP_READLINE || warnop == OP_GLOB)
3573 ? " construct" : "() operator"));
3574 CopLINE_set(PL_curcop, oldline);
3581 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3582 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3584 NewOp(1101, logop, 1, LOGOP);
3586 logop->op_type = (OPCODE)type;
3587 logop->op_ppaddr = PL_ppaddr[type];
3588 logop->op_first = first;
3589 logop->op_flags = flags | OPf_KIDS;
3590 logop->op_other = LINKLIST(other);
3591 logop->op_private = (U8)(1 | (flags >> 8));
3593 /* establish postfix order */
3594 logop->op_next = LINKLIST(first);
3595 first->op_next = (OP*)logop;
3596 first->op_sibling = other;
3598 CHECKOP(type,logop);
3600 o = newUNOP(OP_NULL, 0, (OP*)logop);
3607 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3614 return newLOGOP(OP_AND, 0, first, trueop);
3616 return newLOGOP(OP_OR, 0, first, falseop);
3618 scalarboolean(first);
3619 if (first->op_type == OP_CONST) {
3620 if (first->op_private & OPpCONST_BARE &&
3621 first->op_private & OPpCONST_STRICT) {
3622 no_bareword_allowed(first);
3624 if (SvTRUE(((SVOP*)first)->op_sv)) {
3635 NewOp(1101, logop, 1, LOGOP);
3636 logop->op_type = OP_COND_EXPR;
3637 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3638 logop->op_first = first;
3639 logop->op_flags = flags | OPf_KIDS;
3640 logop->op_private = (U8)(1 | (flags >> 8));
3641 logop->op_other = LINKLIST(trueop);
3642 logop->op_next = LINKLIST(falseop);
3644 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
3647 /* establish postfix order */
3648 start = LINKLIST(first);
3649 first->op_next = (OP*)logop;
3651 first->op_sibling = trueop;
3652 trueop->op_sibling = falseop;
3653 o = newUNOP(OP_NULL, 0, (OP*)logop);
3655 trueop->op_next = falseop->op_next = o;
3662 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3670 NewOp(1101, range, 1, LOGOP);
3672 range->op_type = OP_RANGE;
3673 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3674 range->op_first = left;
3675 range->op_flags = OPf_KIDS;
3676 leftstart = LINKLIST(left);
3677 range->op_other = LINKLIST(right);
3678 range->op_private = (U8)(1 | (flags >> 8));
3680 left->op_sibling = right;
3682 range->op_next = (OP*)range;
3683 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3684 flop = newUNOP(OP_FLOP, 0, flip);
3685 o = newUNOP(OP_NULL, 0, flop);
3687 range->op_next = leftstart;
3689 left->op_next = flip;
3690 right->op_next = flop;
3692 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3693 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3694 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3695 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3697 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3698 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3701 if (!flip->op_private || !flop->op_private)
3702 linklist(o); /* blow off optimizer unless constant */
3708 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3712 const bool once = block && block->op_flags & OPf_SPECIAL &&
3713 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3717 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3718 return block; /* do {} while 0 does once */
3719 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3720 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3721 expr = newUNOP(OP_DEFINED, 0,
3722 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3723 } else if (expr->op_flags & OPf_KIDS) {
3724 const OP *k1 = ((UNOP*)expr)->op_first;
3725 const OP *k2 = (k1) ? k1->op_sibling : NULL;
3726 switch (expr->op_type) {
3728 if (k2 && k2->op_type == OP_READLINE
3729 && (k2->op_flags & OPf_STACKED)
3730 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3731 expr = newUNOP(OP_DEFINED, 0, expr);
3735 if (k1->op_type == OP_READDIR
3736 || k1->op_type == OP_GLOB
3737 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3738 || k1->op_type == OP_EACH)
3739 expr = newUNOP(OP_DEFINED, 0, expr);
3745 /* if block is null, the next append_elem() would put UNSTACK, a scalar
3746 * op, in listop. This is wrong. [perl #27024] */
3748 block = newOP(OP_NULL, 0);
3749 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3750 o = new_logop(OP_AND, 0, &expr, &listop);
3753 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3755 if (once && o != listop)
3756 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3759 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3761 o->op_flags |= flags;
3763 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3768 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3777 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3778 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3779 expr = newUNOP(OP_DEFINED, 0,
3780 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3781 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3782 const OP *k1 = ((UNOP*)expr)->op_first;
3783 const OP *k2 = (k1) ? k1->op_sibling : NULL;
3784 switch (expr->op_type) {
3786 if (k2 && k2->op_type == OP_READLINE
3787 && (k2->op_flags & OPf_STACKED)
3788 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3789 expr = newUNOP(OP_DEFINED, 0, expr);
3793 if (k1->op_type == OP_READDIR
3794 || k1->op_type == OP_GLOB
3795 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3796 || k1->op_type == OP_EACH)
3797 expr = newUNOP(OP_DEFINED, 0, expr);
3803 block = newOP(OP_NULL, 0);
3805 block = scope(block);
3809 next = LINKLIST(cont);
3812 OP *unstack = newOP(OP_UNSTACK, 0);
3815 cont = append_elem(OP_LINESEQ, cont, unstack);
3818 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3819 redo = LINKLIST(listop);
3822 PL_copline = (line_t)whileline;
3824 o = new_logop(OP_AND, 0, &expr, &listop);
3825 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3826 op_free(expr); /* oops, it's a while (0) */
3828 return Nullop; /* listop already freed by new_logop */
3831 ((LISTOP*)listop)->op_last->op_next =
3832 (o == listop ? redo : LINKLIST(o));
3838 NewOp(1101,loop,1,LOOP);
3839 loop->op_type = OP_ENTERLOOP;
3840 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3841 loop->op_private = 0;
3842 loop->op_next = (OP*)loop;
3845 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3847 loop->op_redoop = redo;
3848 loop->op_lastop = o;
3849 o->op_private |= loopflags;
3852 loop->op_nextop = next;
3854 loop->op_nextop = o;
3856 o->op_flags |= flags;
3857 o->op_private |= (flags >> 8);
3862 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
3866 PADOFFSET padoff = 0;
3871 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
3872 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
3873 sv->op_type = OP_RV2GV;
3874 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3876 else if (sv->op_type == OP_PADSV) { /* private variable */
3877 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
3878 padoff = sv->op_targ;
3883 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3884 padoff = sv->op_targ;
3886 iterflags |= OPf_SPECIAL;
3891 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3894 const I32 offset = pad_findmy("$_");
3895 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
3896 sv = newGVOP(OP_GV, 0, PL_defgv);
3902 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3903 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3904 iterflags |= OPf_STACKED;
3906 else if (expr->op_type == OP_NULL &&
3907 (expr->op_flags & OPf_KIDS) &&
3908 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3910 /* Basically turn for($x..$y) into the same as for($x,$y), but we
3911 * set the STACKED flag to indicate that these values are to be
3912 * treated as min/max values by 'pp_iterinit'.
3914 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
3915 LOGOP* range = (LOGOP*) flip->op_first;
3916 OP* left = range->op_first;
3917 OP* right = left->op_sibling;
3920 range->op_flags &= ~OPf_KIDS;
3921 range->op_first = Nullop;
3923 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
3924 listop->op_first->op_next = range->op_next;
3925 left->op_next = range->op_other;
3926 right->op_next = (OP*)listop;
3927 listop->op_next = listop->op_first;
3930 expr = (OP*)(listop);
3932 iterflags |= OPf_STACKED;
3935 expr = mod(force_list(expr), OP_GREPSTART);
3938 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
3939 append_elem(OP_LIST, expr, scalar(sv))));
3940 assert(!loop->op_next);
3941 /* for my $x () sets OPpLVAL_INTRO;
3942 * for our $x () sets OPpOUR_INTRO */
3943 loop->op_private = (U8)iterpflags;
3944 #ifdef PL_OP_SLAB_ALLOC
3947 NewOp(1234,tmp,1,LOOP);
3948 Copy(loop,tmp,1,LISTOP);
3953 Renew(loop, 1, LOOP);
3955 loop->op_targ = padoff;
3956 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
3957 PL_copline = forline;
3958 return newSTATEOP(0, label, wop);
3962 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
3967 if (type != OP_GOTO || label->op_type == OP_CONST) {
3968 /* "last()" means "last" */
3969 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
3970 o = newOP(type, OPf_SPECIAL);
3972 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
3973 ? SvPVx(((SVOP*)label)->op_sv, n_a)
3979 /* Check whether it's going to be a goto &function */
3980 if (label->op_type == OP_ENTERSUB
3981 && !(label->op_flags & OPf_STACKED))
3982 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
3983 o = newUNOP(type, OPf_STACKED, label);
3985 PL_hints |= HINT_BLOCK_SCOPE;
3990 =for apidoc cv_undef
3992 Clear out all the active components of a CV. This can happen either
3993 by an explicit C<undef &foo>, or by the reference count going to zero.
3994 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
3995 children can still follow the full lexical scope chain.
4001 Perl_cv_undef(pTHX_ CV *cv)
4004 if (CvFILE(cv) && !CvXSUB(cv)) {
4005 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4006 Safefree(CvFILE(cv));
4011 if (!CvXSUB(cv) && CvROOT(cv)) {
4013 Perl_croak(aTHX_ "Can't undef active subroutine");
4016 PAD_SAVE_SETNULLPAD();
4018 op_free(CvROOT(cv));
4019 CvROOT(cv) = Nullop;
4022 SvPOK_off((SV*)cv); /* forget prototype */
4027 /* remove CvOUTSIDE unless this is an undef rather than a free */
4028 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4029 if (!CvWEAKOUTSIDE(cv))
4030 SvREFCNT_dec(CvOUTSIDE(cv));
4031 CvOUTSIDE(cv) = Nullcv;
4034 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4040 /* delete all flags except WEAKOUTSIDE */
4041 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4045 Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p)
4047 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4048 SV* msg = sv_newmortal();
4052 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4053 sv_setpv(msg, "Prototype mismatch:");
4055 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4057 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (const SV *)cv);
4059 Perl_sv_catpv(aTHX_ msg, ": none");
4060 sv_catpv(msg, " vs ");
4062 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4064 sv_catpv(msg, "none");
4065 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
4069 static void const_sv_xsub(pTHX_ CV* cv);
4073 =head1 Optree Manipulation Functions
4075 =for apidoc cv_const_sv
4077 If C<cv> is a constant sub eligible for inlining. returns the constant
4078 value returned by the sub. Otherwise, returns NULL.
4080 Constant subs can be created with C<newCONSTSUB> or as described in
4081 L<perlsub/"Constant Functions">.
4086 Perl_cv_const_sv(pTHX_ CV *cv)
4088 if (!cv || !CvCONST(cv))
4090 return (SV*)CvXSUBANY(cv).any_ptr;
4093 /* op_const_sv: examine an optree to determine whether it's in-lineable.
4094 * Can be called in 3 ways:
4097 * look for a single OP_CONST with attached value: return the value
4099 * cv && CvCLONE(cv) && !CvCONST(cv)
4101 * examine the clone prototype, and if contains only a single
4102 * OP_CONST referencing a pad const, or a single PADSV referencing
4103 * an outer lexical, return a non-zero value to indicate the CV is
4104 * a candidate for "constizing" at clone time
4108 * We have just cloned an anon prototype that was marked as a const
4109 * candidiate. Try to grab the current value, and in the case of
4110 * PADSV, ignore it if it has multiple references. Return the value.
4114 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
4121 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4122 o = cLISTOPo->op_first->op_sibling;
4124 for (; o; o = o->op_next) {
4125 OPCODE type = o->op_type;
4127 if (sv && o->op_next == o)
4129 if (o->op_next != o) {
4130 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4132 if (type == OP_DBSTATE)
4135 if (type == OP_LEAVESUB || type == OP_RETURN)
4139 if (type == OP_CONST && cSVOPo->op_sv)
4141 else if (cv && type == OP_CONST) {
4142 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4146 else if (cv && type == OP_PADSV) {
4147 if (CvCONST(cv)) { /* newly cloned anon */
4148 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4149 /* the candidate should have 1 ref from this pad and 1 ref
4150 * from the parent */
4151 if (!sv || SvREFCNT(sv) != 2)
4158 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4159 sv = &PL_sv_undef; /* an arbitrary non-null value */
4170 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4181 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4185 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4187 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4191 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4201 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4204 assert(proto->op_type == OP_CONST);
4205 ps = SvPVx(((SVOP*)proto)->op_sv, n_a);
4210 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4211 SV *sv = sv_newmortal();
4212 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4213 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4214 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4219 gv = name ? gv_fetchsv(cSVOPo->op_sv,
4220 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4222 : gv_fetchpv(aname ? aname
4223 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4224 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4234 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4235 maximum a prototype before. */
4236 if (SvTYPE(gv) > SVt_NULL) {
4237 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4238 && ckWARN_d(WARN_PROTOTYPE))
4240 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4242 cv_ckproto((CV*)gv, NULL, ps);
4245 sv_setpv((SV*)gv, ps);
4247 sv_setiv((SV*)gv, -1);
4248 SvREFCNT_dec(PL_compcv);
4249 cv = PL_compcv = NULL;
4250 PL_sub_generation++;
4254 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4256 #ifdef GV_UNIQUE_CHECK
4257 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4258 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4262 if (!block || !ps || *ps || attrs)
4265 const_sv = op_const_sv(block, Nullcv);
4268 const bool exists = CvROOT(cv) || CvXSUB(cv);
4270 #ifdef GV_UNIQUE_CHECK
4271 if (exists && GvUNIQUE(gv)) {
4272 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4276 /* if the subroutine doesn't exist and wasn't pre-declared
4277 * with a prototype, assume it will be AUTOLOADed,
4278 * skipping the prototype check
4280 if (exists || SvPOK(cv))
4281 cv_ckproto(cv, gv, ps);
4282 /* already defined (or promised)? */
4283 if (exists || GvASSUMECV(gv)) {
4284 if (!block && !attrs) {
4285 if (CvFLAGS(PL_compcv)) {
4286 /* might have had built-in attrs applied */
4287 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4289 /* just a "sub foo;" when &foo is already defined */
4290 SAVEFREESV(PL_compcv);
4293 /* ahem, death to those who redefine active sort subs */
4294 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4295 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4297 if (ckWARN(WARN_REDEFINE)
4299 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4301 const line_t oldline = CopLINE(PL_curcop);
4302 if (PL_copline != NOLINE)
4303 CopLINE_set(PL_curcop, PL_copline);
4304 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4305 CvCONST(cv) ? "Constant subroutine %s redefined"
4306 : "Subroutine %s redefined", name);
4307 CopLINE_set(PL_curcop, oldline);
4315 (void)SvREFCNT_inc(const_sv);
4317 assert(!CvROOT(cv) && !CvCONST(cv));
4318 sv_setpv((SV*)cv, ""); /* prototype is "" */
4319 CvXSUBANY(cv).any_ptr = const_sv;
4320 CvXSUB(cv) = const_sv_xsub;
4325 cv = newCONSTSUB(NULL, name, const_sv);
4328 SvREFCNT_dec(PL_compcv);
4330 PL_sub_generation++;
4337 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4338 * before we clobber PL_compcv.
4342 /* Might have had built-in attributes applied -- propagate them. */
4343 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4344 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4345 stash = GvSTASH(CvGV(cv));
4346 else if (CvSTASH(cv))
4347 stash = CvSTASH(cv);
4349 stash = PL_curstash;
4352 /* possibly about to re-define existing subr -- ignore old cv */
4353 rcv = (SV*)PL_compcv;
4354 if (name && GvSTASH(gv))
4355 stash = GvSTASH(gv);
4357 stash = PL_curstash;
4359 apply_attrs(stash, rcv, attrs, FALSE);
4361 if (cv) { /* must reuse cv if autoloaded */
4363 /* got here with just attrs -- work done, so bug out */
4364 SAVEFREESV(PL_compcv);
4367 /* transfer PL_compcv to cv */
4369 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4370 if (!CvWEAKOUTSIDE(cv))
4371 SvREFCNT_dec(CvOUTSIDE(cv));
4372 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4373 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4374 CvOUTSIDE(PL_compcv) = 0;
4375 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4376 CvPADLIST(PL_compcv) = 0;
4377 /* inner references to PL_compcv must be fixed up ... */
4378 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4379 /* ... before we throw it away */
4380 SvREFCNT_dec(PL_compcv);
4382 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4383 ++PL_sub_generation;
4390 PL_sub_generation++;
4394 CvFILE_set_from_cop(cv, PL_curcop);
4395 CvSTASH(cv) = PL_curstash;
4398 sv_setpv((SV*)cv, ps);
4400 if (PL_error_count) {
4404 const char *s = strrchr(name, ':');
4406 if (strEQ(s, "BEGIN")) {
4407 const char not_safe[] =
4408 "BEGIN not safe after errors--compilation aborted";
4409 if (PL_in_eval & EVAL_KEEPERR)
4410 Perl_croak(aTHX_ not_safe);
4412 /* force display of errors found but not reported */
4413 sv_catpv(ERRSV, not_safe);
4414 Perl_croak(aTHX_ "%"SVf, ERRSV);
4423 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4424 mod(scalarseq(block), OP_LEAVESUBLV));
4427 /* This makes sub {}; work as expected. */
4428 if (block->op_type == OP_STUB) {
4430 block = newSTATEOP(0, Nullch, 0);
4432 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4434 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4435 OpREFCNT_set(CvROOT(cv), 1);
4436 CvSTART(cv) = LINKLIST(CvROOT(cv));
4437 CvROOT(cv)->op_next = 0;
4438 CALL_PEEP(CvSTART(cv));
4440 /* now that optimizer has done its work, adjust pad values */
4442 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4445 assert(!CvCONST(cv));
4446 if (ps && !*ps && op_const_sv(block, cv))
4450 if (name || aname) {
4452 const char *tname = (name ? name : aname);
4454 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4455 SV *sv = NEWSV(0,0);
4456 SV *tmpstr = sv_newmortal();
4457 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4461 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4463 (long)PL_subline, (long)CopLINE(PL_curcop));
4464 gv_efullname3(tmpstr, gv, Nullch);
4465 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4466 hv = GvHVn(db_postponed);
4467 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4468 && (pcv = GvCV(db_postponed)))
4474 call_sv((SV*)pcv, G_DISCARD);
4478 if ((s = strrchr(tname,':')))
4483 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4486 if (strEQ(s, "BEGIN") && !PL_error_count) {
4487 const I32 oldscope = PL_scopestack_ix;
4489 SAVECOPFILE(&PL_compiling);
4490 SAVECOPLINE(&PL_compiling);
4493 PL_beginav = newAV();
4494 DEBUG_x( dump_sub(gv) );
4495 av_push(PL_beginav, (SV*)cv);
4496 GvCV(gv) = 0; /* cv has been hijacked */
4497 call_list(oldscope, PL_beginav);
4499 PL_curcop = &PL_compiling;
4500 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4503 else if (strEQ(s, "END") && !PL_error_count) {
4506 DEBUG_x( dump_sub(gv) );
4507 av_unshift(PL_endav, 1);
4508 av_store(PL_endav, 0, (SV*)cv);
4509 GvCV(gv) = 0; /* cv has been hijacked */
4511 else if (strEQ(s, "CHECK") && !PL_error_count) {
4513 PL_checkav = newAV();
4514 DEBUG_x( dump_sub(gv) );
4515 if (PL_main_start && ckWARN(WARN_VOID))
4516 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4517 av_unshift(PL_checkav, 1);
4518 av_store(PL_checkav, 0, (SV*)cv);
4519 GvCV(gv) = 0; /* cv has been hijacked */
4521 else if (strEQ(s, "INIT") && !PL_error_count) {
4523 PL_initav = newAV();
4524 DEBUG_x( dump_sub(gv) );
4525 if (PL_main_start && ckWARN(WARN_VOID))
4526 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4527 av_push(PL_initav, (SV*)cv);
4528 GvCV(gv) = 0; /* cv has been hijacked */
4533 PL_copline = NOLINE;
4538 /* XXX unsafe for threads if eval_owner isn't held */
4540 =for apidoc newCONSTSUB
4542 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4543 eligible for inlining at compile-time.
4549 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
4555 SAVECOPLINE(PL_curcop);
4556 CopLINE_set(PL_curcop, PL_copline);
4559 PL_hints &= ~HINT_BLOCK_SCOPE;
4562 SAVESPTR(PL_curstash);
4563 SAVECOPSTASH(PL_curcop);
4564 PL_curstash = stash;
4565 CopSTASH_set(PL_curcop,stash);
4568 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4569 CvXSUBANY(cv).any_ptr = sv;
4571 sv_setpv((SV*)cv, ""); /* prototype is "" */
4574 CopSTASH_free(PL_curcop);
4582 =for apidoc U||newXS
4584 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4590 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
4592 GV *gv = gv_fetchpv(name ? name :
4593 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4594 GV_ADDMULTI, SVt_PVCV);
4598 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4600 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4602 /* just a cached method */
4606 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4607 /* already defined (or promised) */
4608 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4609 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4610 const line_t oldline = CopLINE(PL_curcop);
4611 if (PL_copline != NOLINE)
4612 CopLINE_set(PL_curcop, PL_copline);
4613 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4614 CvCONST(cv) ? "Constant subroutine %s redefined"
4615 : "Subroutine %s redefined"
4617 CopLINE_set(PL_curcop, oldline);
4624 if (cv) /* must reuse cv if autoloaded */
4627 cv = (CV*)NEWSV(1105,0);
4628 sv_upgrade((SV *)cv, SVt_PVCV);
4632 PL_sub_generation++;
4636 (void)gv_fetchfile(filename);
4637 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
4638 an external constant string */
4639 CvXSUB(cv) = subaddr;
4642 const char *s = strrchr(name,':');
4648 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4651 if (strEQ(s, "BEGIN")) {
4653 PL_beginav = newAV();
4654 av_push(PL_beginav, (SV*)cv);
4655 GvCV(gv) = 0; /* cv has been hijacked */
4657 else if (strEQ(s, "END")) {
4660 av_unshift(PL_endav, 1);
4661 av_store(PL_endav, 0, (SV*)cv);
4662 GvCV(gv) = 0; /* cv has been hijacked */
4664 else if (strEQ(s, "CHECK")) {
4666 PL_checkav = newAV();
4667 if (PL_main_start && ckWARN(WARN_VOID))
4668 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4669 av_unshift(PL_checkav, 1);
4670 av_store(PL_checkav, 0, (SV*)cv);
4671 GvCV(gv) = 0; /* cv has been hijacked */
4673 else if (strEQ(s, "INIT")) {
4675 PL_initav = newAV();
4676 if (PL_main_start && ckWARN(WARN_VOID))
4677 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4678 av_push(PL_initav, (SV*)cv);
4679 GvCV(gv) = 0; /* cv has been hijacked */
4690 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4696 gv = gv_fetchsv(cSVOPo->op_sv, TRUE, SVt_PVFM);
4698 gv = gv_fetchpv("STDOUT", TRUE, SVt_PVFM);
4700 #ifdef GV_UNIQUE_CHECK
4702 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4706 if ((cv = GvFORM(gv))) {
4707 if (ckWARN(WARN_REDEFINE)) {
4708 const line_t oldline = CopLINE(PL_curcop);
4709 if (PL_copline != NOLINE)
4710 CopLINE_set(PL_curcop, PL_copline);
4711 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4712 o ? "Format %"SVf" redefined"
4713 : "Format STDOUT redefined" ,cSVOPo->op_sv);
4714 CopLINE_set(PL_curcop, oldline);
4721 CvFILE_set_from_cop(cv, PL_curcop);
4724 pad_tidy(padtidy_FORMAT);
4725 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4726 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4727 OpREFCNT_set(CvROOT(cv), 1);
4728 CvSTART(cv) = LINKLIST(CvROOT(cv));
4729 CvROOT(cv)->op_next = 0;
4730 CALL_PEEP(CvSTART(cv));
4732 PL_copline = NOLINE;
4737 Perl_newANONLIST(pTHX_ OP *o)
4739 return newUNOP(OP_REFGEN, 0,
4740 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4744 Perl_newANONHASH(pTHX_ OP *o)
4746 return newUNOP(OP_REFGEN, 0,
4747 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4751 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4753 return newANONATTRSUB(floor, proto, Nullop, block);
4757 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4759 return newUNOP(OP_REFGEN, 0,
4760 newSVOP(OP_ANONCODE, 0,
4761 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
4765 Perl_oopsAV(pTHX_ OP *o)
4767 switch (o->op_type) {
4769 o->op_type = OP_PADAV;
4770 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4771 return ref(o, OP_RV2AV);
4774 o->op_type = OP_RV2AV;
4775 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4780 if (ckWARN_d(WARN_INTERNAL))
4781 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
4788 Perl_oopsHV(pTHX_ OP *o)
4790 switch (o->op_type) {
4793 o->op_type = OP_PADHV;
4794 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4795 return ref(o, OP_RV2HV);
4799 o->op_type = OP_RV2HV;
4800 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
4805 if (ckWARN_d(WARN_INTERNAL))
4806 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
4813 Perl_newAVREF(pTHX_ OP *o)
4815 if (o->op_type == OP_PADANY) {
4816 o->op_type = OP_PADAV;
4817 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4820 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
4821 && ckWARN(WARN_DEPRECATED)) {
4822 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4823 "Using an array as a reference is deprecated");
4825 return newUNOP(OP_RV2AV, 0, scalar(o));
4829 Perl_newGVREF(pTHX_ I32 type, OP *o)
4831 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
4832 return newUNOP(OP_NULL, 0, o);
4833 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
4837 Perl_newHVREF(pTHX_ OP *o)
4839 if (o->op_type == OP_PADANY) {
4840 o->op_type = OP_PADHV;
4841 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4844 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
4845 && ckWARN(WARN_DEPRECATED)) {
4846 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4847 "Using a hash as a reference is deprecated");
4849 return newUNOP(OP_RV2HV, 0, scalar(o));
4853 Perl_oopsCV(pTHX_ OP *o)
4855 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
4858 #ifndef HASATTRIBUTE
4859 /* No __attribute__, so the compiler doesn't know that croak never returns
4866 Perl_newCVREF(pTHX_ I32 flags, OP *o)
4868 return newUNOP(OP_RV2CV, flags, scalar(o));
4872 Perl_newSVREF(pTHX_ OP *o)
4874 if (o->op_type == OP_PADANY) {
4875 o->op_type = OP_PADSV;
4876 o->op_ppaddr = PL_ppaddr[OP_PADSV];
4879 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4880 o->op_flags |= OPpDONE_SVREF;
4883 return newUNOP(OP_RV2SV, 0, scalar(o));
4886 /* Check routines. See the comments at the top of this file for details
4887 * on when these are called */
4890 Perl_ck_anoncode(pTHX_ OP *o)
4892 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
4893 cSVOPo->op_sv = Nullsv;
4898 Perl_ck_bitop(pTHX_ OP *o)
4900 #define OP_IS_NUMCOMPARE(op) \
4901 ((op) == OP_LT || (op) == OP_I_LT || \
4902 (op) == OP_GT || (op) == OP_I_GT || \
4903 (op) == OP_LE || (op) == OP_I_LE || \
4904 (op) == OP_GE || (op) == OP_I_GE || \
4905 (op) == OP_EQ || (op) == OP_I_EQ || \
4906 (op) == OP_NE || (op) == OP_I_NE || \
4907 (op) == OP_NCMP || (op) == OP_I_NCMP)
4908 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4909 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
4910 && (o->op_type == OP_BIT_OR
4911 || o->op_type == OP_BIT_AND
4912 || o->op_type == OP_BIT_XOR))
4914 const OP * left = cBINOPo->op_first;
4915 const OP * right = left->op_sibling;
4916 if ((OP_IS_NUMCOMPARE(left->op_type) &&
4917 (left->op_flags & OPf_PARENS) == 0) ||
4918 (OP_IS_NUMCOMPARE(right->op_type) &&
4919 (right->op_flags & OPf_PARENS) == 0))
4920 if (ckWARN(WARN_PRECEDENCE))
4921 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4922 "Possible precedence problem on bitwise %c operator",
4923 o->op_type == OP_BIT_OR ? '|'
4924 : o->op_type == OP_BIT_AND ? '&' : '^'
4931 Perl_ck_concat(pTHX_ OP *o)
4933 const OP *kid = cUNOPo->op_first;
4934 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
4935 !(kUNOP->op_first->op_flags & OPf_MOD))
4936 o->op_flags |= OPf_STACKED;
4941 Perl_ck_spair(pTHX_ OP *o)
4943 if (o->op_flags & OPf_KIDS) {
4946 const OPCODE type = o->op_type;
4947 o = modkids(ck_fun(o), type);
4948 kid = cUNOPo->op_first;
4949 newop = kUNOP->op_first->op_sibling;
4951 (newop->op_sibling ||
4952 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
4953 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
4954 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
4958 op_free(kUNOP->op_first);
4959 kUNOP->op_first = newop;
4961 o->op_ppaddr = PL_ppaddr[++o->op_type];
4966 Perl_ck_delete(pTHX_ OP *o)
4970 if (o->op_flags & OPf_KIDS) {
4971 OP *kid = cUNOPo->op_first;
4972 switch (kid->op_type) {
4974 o->op_flags |= OPf_SPECIAL;
4977 o->op_private |= OPpSLICE;
4980 o->op_flags |= OPf_SPECIAL;
4985 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
4994 Perl_ck_die(pTHX_ OP *o)
4997 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5003 Perl_ck_eof(pTHX_ OP *o)
5005 const I32 type = o->op_type;
5007 if (o->op_flags & OPf_KIDS) {
5008 if (cLISTOPo->op_first->op_type == OP_STUB) {
5010 o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
5018 Perl_ck_eval(pTHX_ OP *o)
5020 PL_hints |= HINT_BLOCK_SCOPE;
5021 if (o->op_flags & OPf_KIDS) {
5022 SVOP *kid = (SVOP*)cUNOPo->op_first;
5025 o->op_flags &= ~OPf_KIDS;
5028 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
5031 cUNOPo->op_first = 0;
5034 NewOp(1101, enter, 1, LOGOP);
5035 enter->op_type = OP_ENTERTRY;
5036 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5037 enter->op_private = 0;
5039 /* establish postfix order */
5040 enter->op_next = (OP*)enter;
5042 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5043 o->op_type = OP_LEAVETRY;
5044 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5045 enter->op_other = o;
5055 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5057 o->op_targ = (PADOFFSET)PL_hints;
5062 Perl_ck_exit(pTHX_ OP *o)
5065 HV *table = GvHV(PL_hintgv);
5067 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5068 if (svp && *svp && SvTRUE(*svp))
5069 o->op_private |= OPpEXIT_VMSISH;
5071 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5077 Perl_ck_exec(pTHX_ OP *o)
5079 if (o->op_flags & OPf_STACKED) {
5082 kid = cUNOPo->op_first->op_sibling;
5083 if (kid->op_type == OP_RV2GV)
5092 Perl_ck_exists(pTHX_ OP *o)
5095 if (o->op_flags & OPf_KIDS) {
5096 OP *kid = cUNOPo->op_first;
5097 if (kid->op_type == OP_ENTERSUB) {
5098 (void) ref(kid, o->op_type);
5099 if (kid->op_type != OP_RV2CV && !PL_error_count)
5100 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5102 o->op_private |= OPpEXISTS_SUB;
5104 else if (kid->op_type == OP_AELEM)
5105 o->op_flags |= OPf_SPECIAL;
5106 else if (kid->op_type != OP_HELEM)
5107 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5116 Perl_ck_gvconst(pTHX_ register OP *o)
5118 o = fold_constants(o);
5119 if (o->op_type == OP_CONST)
5126 Perl_ck_rvconst(pTHX_ register OP *o)
5128 SVOP *kid = (SVOP*)cUNOPo->op_first;
5130 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5131 if (kid->op_type == OP_CONST) {
5134 SV *kidsv = kid->op_sv;
5136 /* Is it a constant from cv_const_sv()? */
5137 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5138 SV *rsv = SvRV(kidsv);
5139 int svtype = SvTYPE(rsv);
5140 const char *badtype = Nullch;
5142 switch (o->op_type) {
5144 if (svtype > SVt_PVMG)
5145 badtype = "a SCALAR";
5148 if (svtype != SVt_PVAV)
5149 badtype = "an ARRAY";
5152 if (svtype != SVt_PVHV)
5156 if (svtype != SVt_PVCV)
5161 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5164 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5165 const char *badthing = Nullch;
5166 switch (o->op_type) {
5168 badthing = "a SCALAR";
5171 badthing = "an ARRAY";
5174 badthing = "a HASH";
5179 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
5183 * This is a little tricky. We only want to add the symbol if we
5184 * didn't add it in the lexer. Otherwise we get duplicate strict
5185 * warnings. But if we didn't add it in the lexer, we must at
5186 * least pretend like we wanted to add it even if it existed before,
5187 * or we get possible typo warnings. OPpCONST_ENTERED says
5188 * whether the lexer already added THIS instance of this symbol.
5190 iscv = (o->op_type == OP_RV2CV) * 2;
5192 gv = gv_fetchsv(kidsv,
5193 iscv | !(kid->op_private & OPpCONST_ENTERED),
5196 : o->op_type == OP_RV2SV
5198 : o->op_type == OP_RV2AV
5200 : o->op_type == OP_RV2HV
5203 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5205 kid->op_type = OP_GV;
5206 SvREFCNT_dec(kid->op_sv);
5208 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5209 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5210 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
5212 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
5214 kid->op_sv = SvREFCNT_inc(gv);
5216 kid->op_private = 0;
5217 kid->op_ppaddr = PL_ppaddr[OP_GV];
5224 Perl_ck_ftst(pTHX_ OP *o)
5226 const I32 type = o->op_type;
5228 if (o->op_flags & OPf_REF) {
5231 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5232 SVOP *kid = (SVOP*)cUNOPo->op_first;
5234 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5235 OP *newop = newGVOP(type, OPf_REF,
5236 gv_fetchsv(kid->op_sv, TRUE, SVt_PVIO));
5242 if ((PL_hints & HINT_FILETEST_ACCESS) &&
5243 OP_IS_FILETEST_ACCESS(o))
5244 o->op_private |= OPpFT_ACCESS;
5246 if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
5247 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
5248 o->op_private |= OPpFT_STACKED;
5252 if (type == OP_FTTTY)
5253 o = newGVOP(type, OPf_REF, PL_stdingv);
5255 o = newUNOP(type, 0, newDEFSVOP());
5261 Perl_ck_fun(pTHX_ OP *o)
5263 const int type = o->op_type;
5264 register I32 oa = PL_opargs[type] >> OASHIFT;
5266 if (o->op_flags & OPf_STACKED) {
5267 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5270 return no_fh_allowed(o);
5273 if (o->op_flags & OPf_KIDS) {
5274 OP **tokid = &cLISTOPo->op_first;
5275 register OP *kid = cLISTOPo->op_first;
5279 if (kid->op_type == OP_PUSHMARK ||
5280 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5282 tokid = &kid->op_sibling;
5283 kid = kid->op_sibling;
5285 if (!kid && PL_opargs[type] & OA_DEFGV)
5286 *tokid = kid = newDEFSVOP();
5290 sibl = kid->op_sibling;
5293 /* list seen where single (scalar) arg expected? */
5294 if (numargs == 1 && !(oa >> 4)
5295 && kid->op_type == OP_LIST && type != OP_SCALAR)
5297 return too_many_arguments(o,PL_op_desc[type]);
5310 if ((type == OP_PUSH || type == OP_UNSHIFT)
5311 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5312 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5313 "Useless use of %s with no values",
5316 if (kid->op_type == OP_CONST &&
5317 (kid->op_private & OPpCONST_BARE))
5319 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5320 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVAV) ));
5321 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5322 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5323 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
5324 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5327 kid->op_sibling = sibl;
5330 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5331 bad_type(numargs, "array", PL_op_desc[type], kid);
5335 if (kid->op_type == OP_CONST &&
5336 (kid->op_private & OPpCONST_BARE))
5338 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5339 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVHV) ));
5340 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5341 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5342 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
5343 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5346 kid->op_sibling = sibl;
5349 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5350 bad_type(numargs, "hash", PL_op_desc[type], kid);
5355 OP *newop = newUNOP(OP_NULL, 0, kid);
5356 kid->op_sibling = 0;
5358 newop->op_next = newop;
5360 kid->op_sibling = sibl;
5365 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5366 if (kid->op_type == OP_CONST &&
5367 (kid->op_private & OPpCONST_BARE))
5369 OP *newop = newGVOP(OP_GV, 0,
5370 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVIO) );
5371 if (!(o->op_private & 1) && /* if not unop */
5372 kid == cLISTOPo->op_last)
5373 cLISTOPo->op_last = newop;
5377 else if (kid->op_type == OP_READLINE) {
5378 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5379 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5382 I32 flags = OPf_SPECIAL;
5386 /* is this op a FH constructor? */
5387 if (is_handle_constructor(o,numargs)) {
5388 const char *name = Nullch;
5392 /* Set a flag to tell rv2gv to vivify
5393 * need to "prove" flag does not mean something
5394 * else already - NI-S 1999/05/07
5397 if (kid->op_type == OP_PADSV) {
5398 name = PAD_COMPNAME_PV(kid->op_targ);
5399 /* SvCUR of a pad namesv can't be trusted
5400 * (see PL_generation), so calc its length
5406 else if (kid->op_type == OP_RV2SV
5407 && kUNOP->op_first->op_type == OP_GV)
5409 GV *gv = cGVOPx_gv(kUNOP->op_first);
5411 len = GvNAMELEN(gv);
5413 else if (kid->op_type == OP_AELEM
5414 || kid->op_type == OP_HELEM)
5419 if ((op = ((BINOP*)kid)->op_first)) {
5420 SV *tmpstr = Nullsv;
5422 kid->op_type == OP_AELEM ?
5424 if (((op->op_type == OP_RV2AV) ||
5425 (op->op_type == OP_RV2HV)) &&
5426 (op = ((UNOP*)op)->op_first) &&
5427 (op->op_type == OP_GV)) {
5428 /* packagevar $a[] or $h{} */
5429 GV *gv = cGVOPx_gv(op);
5437 else if (op->op_type == OP_PADAV
5438 || op->op_type == OP_PADHV) {
5439 /* lexicalvar $a[] or $h{} */
5440 const char *padname =
5441 PAD_COMPNAME_PV(op->op_targ);
5451 name = SvPV(tmpstr, len);
5456 name = "__ANONIO__";
5463 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5464 namesv = PAD_SVl(targ);
5465 (void)SvUPGRADE(namesv, SVt_PV);
5467 sv_setpvn(namesv, "$", 1);
5468 sv_catpvn(namesv, name, len);
5471 kid->op_sibling = 0;
5472 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5473 kid->op_targ = targ;
5474 kid->op_private |= priv;
5476 kid->op_sibling = sibl;
5482 mod(scalar(kid), type);
5486 tokid = &kid->op_sibling;
5487 kid = kid->op_sibling;
5489 o->op_private |= numargs;
5491 return too_many_arguments(o,OP_DESC(o));
5494 else if (PL_opargs[type] & OA_DEFGV) {
5496 return newUNOP(type, 0, newDEFSVOP());
5500 while (oa & OA_OPTIONAL)
5502 if (oa && oa != OA_LIST)
5503 return too_few_arguments(o,OP_DESC(o));
5509 Perl_ck_glob(pTHX_ OP *o)
5514 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5515 append_elem(OP_GLOB, o, newDEFSVOP());
5517 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5518 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5520 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5523 #if !defined(PERL_EXTERNAL_GLOB)
5524 /* XXX this can be tightened up and made more failsafe. */
5525 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5528 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5529 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5530 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5531 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5532 GvCV(gv) = GvCV(glob_gv);
5533 (void)SvREFCNT_inc((SV*)GvCV(gv));
5534 GvIMPORTED_CV_on(gv);
5537 #endif /* PERL_EXTERNAL_GLOB */
5539 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5540 append_elem(OP_GLOB, o,
5541 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5542 o->op_type = OP_LIST;
5543 o->op_ppaddr = PL_ppaddr[OP_LIST];
5544 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5545 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5546 cLISTOPo->op_first->op_targ = 0;
5547 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5548 append_elem(OP_LIST, o,
5549 scalar(newUNOP(OP_RV2CV, 0,
5550 newGVOP(OP_GV, 0, gv)))));
5551 o = newUNOP(OP_NULL, 0, ck_subr(o));
5552 o->op_targ = OP_GLOB; /* hint at what it used to be */
5555 gv = newGVgen("main");
5557 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5563 Perl_ck_grep(pTHX_ OP *o)
5567 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5570 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5571 NewOp(1101, gwop, 1, LOGOP);
5573 if (o->op_flags & OPf_STACKED) {
5576 kid = cLISTOPo->op_first->op_sibling;
5577 if (!cUNOPx(kid)->op_next)
5578 Perl_croak(aTHX_ "panic: ck_grep");
5579 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
5582 kid->op_next = (OP*)gwop;
5583 o->op_flags &= ~OPf_STACKED;
5585 kid = cLISTOPo->op_first->op_sibling;
5586 if (type == OP_MAPWHILE)
5593 kid = cLISTOPo->op_first->op_sibling;
5594 if (kid->op_type != OP_NULL)
5595 Perl_croak(aTHX_ "panic: ck_grep");
5596 kid = kUNOP->op_first;
5598 gwop->op_type = type;
5599 gwop->op_ppaddr = PL_ppaddr[type];
5600 gwop->op_first = listkids(o);
5601 gwop->op_flags |= OPf_KIDS;
5602 gwop->op_other = LINKLIST(kid);
5603 kid->op_next = (OP*)gwop;
5604 offset = pad_findmy("$_");
5605 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
5606 o->op_private = gwop->op_private = 0;
5607 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5610 o->op_private = gwop->op_private = OPpGREP_LEX;
5611 gwop->op_targ = o->op_targ = offset;
5614 kid = cLISTOPo->op_first->op_sibling;
5615 if (!kid || !kid->op_sibling)
5616 return too_few_arguments(o,OP_DESC(o));
5617 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5618 mod(kid, OP_GREPSTART);
5624 Perl_ck_index(pTHX_ OP *o)
5626 if (o->op_flags & OPf_KIDS) {
5627 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5629 kid = kid->op_sibling; /* get past "big" */
5630 if (kid && kid->op_type == OP_CONST)
5631 fbm_compile(((SVOP*)kid)->op_sv, 0);
5637 Perl_ck_lengthconst(pTHX_ OP *o)
5639 /* XXX length optimization goes here */
5644 Perl_ck_lfun(pTHX_ OP *o)
5646 const OPCODE type = o->op_type;
5647 return modkids(ck_fun(o), type);
5651 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5653 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5654 switch (cUNOPo->op_first->op_type) {
5656 /* This is needed for
5657 if (defined %stash::)
5658 to work. Do not break Tk.
5660 break; /* Globals via GV can be undef */
5662 case OP_AASSIGN: /* Is this a good idea? */
5663 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5664 "defined(@array) is deprecated");
5665 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5666 "\t(Maybe you should just omit the defined()?)\n");
5669 /* This is needed for
5670 if (defined %stash::)
5671 to work. Do not break Tk.
5673 break; /* Globals via GV can be undef */
5675 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5676 "defined(%%hash) is deprecated");
5677 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5678 "\t(Maybe you should just omit the defined()?)\n");
5689 Perl_ck_rfun(pTHX_ OP *o)
5691 const OPCODE type = o->op_type;
5692 return refkids(ck_fun(o), type);
5696 Perl_ck_listiob(pTHX_ OP *o)
5700 kid = cLISTOPo->op_first;
5703 kid = cLISTOPo->op_first;
5705 if (kid->op_type == OP_PUSHMARK)
5706 kid = kid->op_sibling;
5707 if (kid && o->op_flags & OPf_STACKED)
5708 kid = kid->op_sibling;
5709 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5710 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5711 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5712 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5713 cLISTOPo->op_first->op_sibling = kid;
5714 cLISTOPo->op_last = kid;
5715 kid = kid->op_sibling;
5720 append_elem(o->op_type, o, newDEFSVOP());
5726 Perl_ck_sassign(pTHX_ OP *o)
5728 OP *kid = cLISTOPo->op_first;
5729 /* has a disposable target? */
5730 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5731 && !(kid->op_flags & OPf_STACKED)
5732 /* Cannot steal the second time! */
5733 && !(kid->op_private & OPpTARGET_MY))
5735 OP *kkid = kid->op_sibling;
5737 /* Can just relocate the target. */
5738 if (kkid && kkid->op_type == OP_PADSV
5739 && !(kkid->op_private & OPpLVAL_INTRO))
5741 kid->op_targ = kkid->op_targ;
5743 /* Now we do not need PADSV and SASSIGN. */
5744 kid->op_sibling = o->op_sibling; /* NULL */
5745 cLISTOPo->op_first = NULL;
5748 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
5752 /* optimise C<my $x = undef> to C<my $x> */
5753 if (kid->op_type == OP_UNDEF) {
5754 OP *kkid = kid->op_sibling;
5755 if (kkid && kkid->op_type == OP_PADSV
5756 && (kkid->op_private & OPpLVAL_INTRO))
5758 cLISTOPo->op_first = NULL;
5759 kid->op_sibling = NULL;
5769 Perl_ck_match(pTHX_ OP *o)
5771 if (o->op_type != OP_QR) {
5772 const I32 offset = pad_findmy("$_");
5773 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS(offset) & SVpad_OUR)) {
5774 o->op_targ = offset;
5775 o->op_private |= OPpTARGET_MY;
5778 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
5779 o->op_private |= OPpRUNTIME;
5784 Perl_ck_method(pTHX_ OP *o)
5786 OP *kid = cUNOPo->op_first;
5787 if (kid->op_type == OP_CONST) {
5788 SV* sv = kSVOP->op_sv;
5789 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
5791 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5792 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
5795 kSVOP->op_sv = Nullsv;
5797 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5806 Perl_ck_null(pTHX_ OP *o)
5812 Perl_ck_open(pTHX_ OP *o)
5814 HV *table = GvHV(PL_hintgv);
5818 svp = hv_fetch(table, "open_IN", 7, FALSE);
5820 mode = mode_from_discipline(*svp);
5821 if (mode & O_BINARY)
5822 o->op_private |= OPpOPEN_IN_RAW;
5823 else if (mode & O_TEXT)
5824 o->op_private |= OPpOPEN_IN_CRLF;
5827 svp = hv_fetch(table, "open_OUT", 8, FALSE);
5829 mode = mode_from_discipline(*svp);
5830 if (mode & O_BINARY)
5831 o->op_private |= OPpOPEN_OUT_RAW;
5832 else if (mode & O_TEXT)
5833 o->op_private |= OPpOPEN_OUT_CRLF;
5836 if (o->op_type == OP_BACKTICK)
5839 /* In case of three-arg dup open remove strictness
5840 * from the last arg if it is a bareword. */
5841 OP *first = cLISTOPx(o)->op_first; /* The pushmark. */
5842 OP *last = cLISTOPx(o)->op_last; /* The bareword. */
5846 if ((last->op_type == OP_CONST) && /* The bareword. */
5847 (last->op_private & OPpCONST_BARE) &&
5848 (last->op_private & OPpCONST_STRICT) &&
5849 (oa = first->op_sibling) && /* The fh. */
5850 (oa = oa->op_sibling) && /* The mode. */
5851 SvPOK(((SVOP*)oa)->op_sv) &&
5852 (mode = SvPVX(((SVOP*)oa)->op_sv)) &&
5853 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
5854 (last == oa->op_sibling)) /* The bareword. */
5855 last->op_private &= ~OPpCONST_STRICT;
5861 Perl_ck_repeat(pTHX_ OP *o)
5863 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5864 o->op_private |= OPpREPEAT_DOLIST;
5865 cBINOPo->op_first = force_list(cBINOPo->op_first);
5873 Perl_ck_require(pTHX_ OP *o)
5877 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
5878 SVOP *kid = (SVOP*)cUNOPo->op_first;
5880 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5882 for (s = SvPVX(kid->op_sv); *s; s++) {
5883 if (*s == ':' && s[1] == ':') {
5885 Move(s+2, s+1, strlen(s+2)+1, char);
5886 SvCUR_set(kid->op_sv, SvCUR(kid->op_sv) - 1);
5889 if (SvREADONLY(kid->op_sv)) {
5890 SvREADONLY_off(kid->op_sv);
5891 sv_catpvn(kid->op_sv, ".pm", 3);
5892 SvREADONLY_on(kid->op_sv);
5895 sv_catpvn(kid->op_sv, ".pm", 3);
5899 /* handle override, if any */
5900 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
5901 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
5902 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
5904 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5905 OP *kid = cUNOPo->op_first;
5906 cUNOPo->op_first = 0;
5908 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5909 append_elem(OP_LIST, kid,
5910 scalar(newUNOP(OP_RV2CV, 0,
5919 Perl_ck_return(pTHX_ OP *o)
5921 if (CvLVALUE(PL_compcv)) {
5923 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5924 mod(kid, OP_LEAVESUBLV);
5931 Perl_ck_retarget(pTHX_ OP *o)
5933 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5940 Perl_ck_select(pTHX_ OP *o)
5943 if (o->op_flags & OPf_KIDS) {
5944 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5945 if (kid && kid->op_sibling) {
5946 o->op_type = OP_SSELECT;
5947 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
5949 return fold_constants(o);
5953 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5954 if (kid && kid->op_type == OP_RV2GV)
5955 kid->op_private &= ~HINT_STRICT_REFS;
5960 Perl_ck_shift(pTHX_ OP *o)
5962 const I32 type = o->op_type;
5964 if (!(o->op_flags & OPf_KIDS)) {
5968 argop = newUNOP(OP_RV2AV, 0,
5969 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
5970 return newUNOP(type, 0, scalar(argop));
5972 return scalar(modkids(ck_fun(o), type));
5976 Perl_ck_sort(pTHX_ OP *o)
5980 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
5982 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5983 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
5985 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
5987 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
5989 if (kid->op_type == OP_SCOPE) {
5993 else if (kid->op_type == OP_LEAVE) {
5994 if (o->op_type == OP_SORT) {
5995 op_null(kid); /* wipe out leave */
5998 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
5999 if (k->op_next == kid)
6001 /* don't descend into loops */
6002 else if (k->op_type == OP_ENTERLOOP
6003 || k->op_type == OP_ENTERITER)
6005 k = cLOOPx(k)->op_lastop;
6010 kid->op_next = 0; /* just disconnect the leave */
6011 k = kLISTOP->op_first;
6016 if (o->op_type == OP_SORT) {
6017 /* provide scalar context for comparison function/block */
6023 o->op_flags |= OPf_SPECIAL;
6025 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6028 firstkid = firstkid->op_sibling;
6031 /* provide list context for arguments */
6032 if (o->op_type == OP_SORT)
6039 S_simplify_sort(pTHX_ OP *o)
6041 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6046 if (!(o->op_flags & OPf_STACKED))
6048 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6049 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6050 kid = kUNOP->op_first; /* get past null */
6051 if (kid->op_type != OP_SCOPE)
6053 kid = kLISTOP->op_last; /* get past scope */
6054 switch(kid->op_type) {
6062 k = kid; /* remember this node*/
6063 if (kBINOP->op_first->op_type != OP_RV2SV)
6065 kid = kBINOP->op_first; /* get past cmp */
6066 if (kUNOP->op_first->op_type != OP_GV)
6068 kid = kUNOP->op_first; /* get past rv2sv */
6070 if (GvSTASH(gv) != PL_curstash)
6072 gvname = GvNAME(gv);
6073 if (*gvname == 'a' && gvname[1] == '\0')
6075 else if (*gvname == 'b' && gvname[1] == '\0')
6080 kid = k; /* back to cmp */
6081 if (kBINOP->op_last->op_type != OP_RV2SV)
6083 kid = kBINOP->op_last; /* down to 2nd arg */
6084 if (kUNOP->op_first->op_type != OP_GV)
6086 kid = kUNOP->op_first; /* get past rv2sv */
6088 if (GvSTASH(gv) != PL_curstash)
6090 gvname = GvNAME(gv);
6092 ? !(*gvname == 'a' && gvname[1] == '\0')
6093 : !(*gvname == 'b' && gvname[1] == '\0'))
6095 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6097 o->op_private |= OPpSORT_DESCEND;
6098 if (k->op_type == OP_NCMP)
6099 o->op_private |= OPpSORT_NUMERIC;
6100 if (k->op_type == OP_I_NCMP)
6101 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6102 kid = cLISTOPo->op_first->op_sibling;
6103 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6104 op_free(kid); /* then delete it */
6108 Perl_ck_split(pTHX_ OP *o)
6112 if (o->op_flags & OPf_STACKED)
6113 return no_fh_allowed(o);
6115 kid = cLISTOPo->op_first;
6116 if (kid->op_type != OP_NULL)
6117 Perl_croak(aTHX_ "panic: ck_split");
6118 kid = kid->op_sibling;
6119 op_free(cLISTOPo->op_first);
6120 cLISTOPo->op_first = kid;
6122 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6123 cLISTOPo->op_last = kid; /* There was only one element previously */
6126 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6127 OP *sibl = kid->op_sibling;
6128 kid->op_sibling = 0;
6129 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
6130 if (cLISTOPo->op_first == cLISTOPo->op_last)
6131 cLISTOPo->op_last = kid;
6132 cLISTOPo->op_first = kid;
6133 kid->op_sibling = sibl;
6136 kid->op_type = OP_PUSHRE;
6137 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6139 if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
6140 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
6141 "Use of /g modifier is meaningless in split");
6144 if (!kid->op_sibling)
6145 append_elem(OP_SPLIT, o, newDEFSVOP());
6147 kid = kid->op_sibling;
6150 if (!kid->op_sibling)
6151 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6153 kid = kid->op_sibling;
6156 if (kid->op_sibling)
6157 return too_many_arguments(o,OP_DESC(o));
6163 Perl_ck_join(pTHX_ OP *o)
6165 if (ckWARN(WARN_SYNTAX)) {
6166 const OP *kid = cLISTOPo->op_first->op_sibling;
6167 if (kid && kid->op_type == OP_MATCH) {
6168 const REGEXP *re = PM_GETRE(kPMOP);
6169 const char *pmstr = re ? re->precomp : "STRING";
6170 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6171 "/%s/ should probably be written as \"%s\"",
6179 Perl_ck_subr(pTHX_ OP *o)
6181 OP *prev = ((cUNOPo->op_first->op_sibling)
6182 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6183 OP *o2 = prev->op_sibling;
6190 I32 contextclass = 0;
6195 o->op_private |= OPpENTERSUB_HASTARG;
6196 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6197 if (cvop->op_type == OP_RV2CV) {
6199 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6200 op_null(cvop); /* disable rv2cv */
6201 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6202 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6203 GV *gv = cGVOPx_gv(tmpop);
6206 tmpop->op_private |= OPpEARLY_CV;
6209 namegv = CvANON(cv) ? gv : CvGV(cv);
6210 proto = SvPV((SV*)cv, n_a);
6212 if (CvASSERTION(cv)) {
6213 if (PL_hints & HINT_ASSERTING) {
6214 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
6215 o->op_private |= OPpENTERSUB_DB;
6219 if (ckWARN(WARN_ASSERTIONS) && !(PL_hints & HINT_ASSERTIONSSEEN)) {
6220 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
6221 "Impossible to activate assertion call");
6228 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6229 if (o2->op_type == OP_CONST)
6230 o2->op_private &= ~OPpCONST_STRICT;
6231 else if (o2->op_type == OP_LIST) {
6232 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6233 if (o && o->op_type == OP_CONST)
6234 o->op_private &= ~OPpCONST_STRICT;
6237 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6238 if (PERLDB_SUB && PL_curstash != PL_debstash)
6239 o->op_private |= OPpENTERSUB_DB;
6240 while (o2 != cvop) {
6244 return too_many_arguments(o, gv_ename(namegv));
6262 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6264 arg == 1 ? "block or sub {}" : "sub {}",
6265 gv_ename(namegv), o2);
6268 /* '*' allows any scalar type, including bareword */
6271 if (o2->op_type == OP_RV2GV)
6272 goto wrapref; /* autoconvert GLOB -> GLOBref */
6273 else if (o2->op_type == OP_CONST)
6274 o2->op_private &= ~OPpCONST_STRICT;
6275 else if (o2->op_type == OP_ENTERSUB) {
6276 /* accidental subroutine, revert to bareword */
6277 OP *gvop = ((UNOP*)o2)->op_first;
6278 if (gvop && gvop->op_type == OP_NULL) {
6279 gvop = ((UNOP*)gvop)->op_first;
6281 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6284 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6285 (gvop = ((UNOP*)gvop)->op_first) &&
6286 gvop->op_type == OP_GV)
6288 GV *gv = cGVOPx_gv(gvop);
6289 OP *sibling = o2->op_sibling;
6290 SV *n = newSVpvn("",0);
6292 gv_fullname4(n, gv, "", FALSE);
6293 o2 = newSVOP(OP_CONST, 0, n);
6294 prev->op_sibling = o2;
6295 o2->op_sibling = sibling;
6311 if (contextclass++ == 0) {
6312 e = strchr(proto, ']');
6313 if (!e || e == proto)
6326 while (*--p != '[');
6327 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6328 gv_ename(namegv), o2);
6334 if (o2->op_type == OP_RV2GV)
6337 bad_type(arg, "symbol", gv_ename(namegv), o2);
6340 if (o2->op_type == OP_ENTERSUB)
6343 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6346 if (o2->op_type == OP_RV2SV ||
6347 o2->op_type == OP_PADSV ||
6348 o2->op_type == OP_HELEM ||
6349 o2->op_type == OP_AELEM ||
6350 o2->op_type == OP_THREADSV)
6353 bad_type(arg, "scalar", gv_ename(namegv), o2);
6356 if (o2->op_type == OP_RV2AV ||
6357 o2->op_type == OP_PADAV)
6360 bad_type(arg, "array", gv_ename(namegv), o2);
6363 if (o2->op_type == OP_RV2HV ||
6364 o2->op_type == OP_PADHV)
6367 bad_type(arg, "hash", gv_ename(namegv), o2);
6372 OP* sib = kid->op_sibling;
6373 kid->op_sibling = 0;
6374 o2 = newUNOP(OP_REFGEN, 0, kid);
6375 o2->op_sibling = sib;
6376 prev->op_sibling = o2;
6378 if (contextclass && e) {
6393 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6394 gv_ename(namegv), cv);
6399 mod(o2, OP_ENTERSUB);
6401 o2 = o2->op_sibling;
6403 if (proto && !optional &&
6404 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6405 return too_few_arguments(o, gv_ename(namegv));
6408 o=newSVOP(OP_CONST, 0, newSViv(0));
6414 Perl_ck_svconst(pTHX_ OP *o)
6416 SvREADONLY_on(cSVOPo->op_sv);
6421 Perl_ck_trunc(pTHX_ OP *o)
6423 if (o->op_flags & OPf_KIDS) {
6424 SVOP *kid = (SVOP*)cUNOPo->op_first;
6426 if (kid->op_type == OP_NULL)
6427 kid = (SVOP*)kid->op_sibling;
6428 if (kid && kid->op_type == OP_CONST &&
6429 (kid->op_private & OPpCONST_BARE))
6431 o->op_flags |= OPf_SPECIAL;
6432 kid->op_private &= ~OPpCONST_STRICT;
6439 Perl_ck_unpack(pTHX_ OP *o)
6441 OP *kid = cLISTOPo->op_first;
6442 if (kid->op_sibling) {
6443 kid = kid->op_sibling;
6444 if (!kid->op_sibling)
6445 kid->op_sibling = newDEFSVOP();
6451 Perl_ck_substr(pTHX_ OP *o)
6454 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6455 OP *kid = cLISTOPo->op_first;
6457 if (kid->op_type == OP_NULL)
6458 kid = kid->op_sibling;
6460 kid->op_flags |= OPf_MOD;
6466 /* A peephole optimizer. We visit the ops in the order they're to execute.
6467 * See the comments at the top of this file for more details about when
6468 * peep() is called */
6471 Perl_peep(pTHX_ register OP *o)
6473 register OP* oldop = 0;
6475 if (!o || o->op_opt)
6479 SAVEVPTR(PL_curcop);
6480 for (; o; o = o->op_next) {
6484 switch (o->op_type) {
6488 PL_curcop = ((COP*)o); /* for warnings */
6493 if (cSVOPo->op_private & OPpCONST_STRICT)
6494 no_bareword_allowed(o);
6496 case OP_METHOD_NAMED:
6497 /* Relocate sv to the pad for thread safety.
6498 * Despite being a "constant", the SV is written to,
6499 * for reference counts, sv_upgrade() etc. */
6501 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6502 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6503 /* If op_sv is already a PADTMP then it is being used by
6504 * some pad, so make a copy. */
6505 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6506 SvREADONLY_on(PAD_SVl(ix));
6507 SvREFCNT_dec(cSVOPo->op_sv);
6510 SvREFCNT_dec(PAD_SVl(ix));
6511 SvPADTMP_on(cSVOPo->op_sv);
6512 PAD_SETSV(ix, cSVOPo->op_sv);
6513 /* XXX I don't know how this isn't readonly already. */
6514 SvREADONLY_on(PAD_SVl(ix));
6516 cSVOPo->op_sv = Nullsv;
6524 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6525 if (o->op_next->op_private & OPpTARGET_MY) {
6526 if (o->op_flags & OPf_STACKED) /* chained concats */
6527 goto ignore_optimization;
6529 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6530 o->op_targ = o->op_next->op_targ;
6531 o->op_next->op_targ = 0;
6532 o->op_private |= OPpTARGET_MY;
6535 op_null(o->op_next);
6537 ignore_optimization:
6541 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6543 break; /* Scalar stub must produce undef. List stub is noop */
6547 if (o->op_targ == OP_NEXTSTATE
6548 || o->op_targ == OP_DBSTATE
6549 || o->op_targ == OP_SETSTATE)
6551 PL_curcop = ((COP*)o);
6553 /* XXX: We avoid setting op_seq here to prevent later calls
6554 to peep() from mistakenly concluding that optimisation
6555 has already occurred. This doesn't fix the real problem,
6556 though (See 20010220.007). AMS 20010719 */
6557 /* op_seq functionality is now replaced by op_opt */
6558 if (oldop && o->op_next) {
6559 oldop->op_next = o->op_next;
6567 if (oldop && o->op_next) {
6568 oldop->op_next = o->op_next;
6576 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
6577 OP* pop = (o->op_type == OP_PADAV) ?
6578 o->op_next : o->op_next->op_next;
6580 if (pop && pop->op_type == OP_CONST &&
6581 ((PL_op = pop->op_next)) &&
6582 pop->op_next->op_type == OP_AELEM &&
6583 !(pop->op_next->op_private &
6584 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6585 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6590 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
6591 no_bareword_allowed(pop);
6592 if (o->op_type == OP_GV)
6593 op_null(o->op_next);
6594 op_null(pop->op_next);
6596 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6597 o->op_next = pop->op_next->op_next;
6598 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6599 o->op_private = (U8)i;
6600 if (o->op_type == OP_GV) {
6605 o->op_flags |= OPf_SPECIAL;
6606 o->op_type = OP_AELEMFAST;
6612 if (o->op_next->op_type == OP_RV2SV) {
6613 if (!(o->op_next->op_private & OPpDEREF)) {
6614 op_null(o->op_next);
6615 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6617 o->op_next = o->op_next->op_next;
6618 o->op_type = OP_GVSV;
6619 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6622 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6624 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6625 /* XXX could check prototype here instead of just carping */
6626 SV *sv = sv_newmortal();
6627 gv_efullname3(sv, gv, Nullch);
6628 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6629 "%"SVf"() called too early to check prototype",
6633 else if (o->op_next->op_type == OP_READLINE
6634 && o->op_next->op_next->op_type == OP_CONCAT
6635 && (o->op_next->op_next->op_flags & OPf_STACKED))
6637 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6638 o->op_type = OP_RCATLINE;
6639 o->op_flags |= OPf_STACKED;
6640 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6641 op_null(o->op_next->op_next);
6642 op_null(o->op_next);
6659 while (cLOGOP->op_other->op_type == OP_NULL)
6660 cLOGOP->op_other = cLOGOP->op_other->op_next;
6661 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6667 while (cLOOP->op_redoop->op_type == OP_NULL)
6668 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6669 peep(cLOOP->op_redoop);
6670 while (cLOOP->op_nextop->op_type == OP_NULL)
6671 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6672 peep(cLOOP->op_nextop);
6673 while (cLOOP->op_lastop->op_type == OP_NULL)
6674 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6675 peep(cLOOP->op_lastop);
6682 while (cPMOP->op_pmreplstart &&
6683 cPMOP->op_pmreplstart->op_type == OP_NULL)
6684 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6685 peep(cPMOP->op_pmreplstart);
6690 if (ckWARN(WARN_SYNTAX) && o->op_next
6691 && o->op_next->op_type == OP_NEXTSTATE) {
6692 if (o->op_next->op_sibling &&
6693 o->op_next->op_sibling->op_type != OP_EXIT &&
6694 o->op_next->op_sibling->op_type != OP_WARN &&
6695 o->op_next->op_sibling->op_type != OP_DIE) {
6696 const line_t oldline = CopLINE(PL_curcop);
6698 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6699 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6700 "Statement unlikely to be reached");
6701 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6702 "\t(Maybe you meant system() when you said exec()?)\n");
6703 CopLINE_set(PL_curcop, oldline);
6718 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6721 /* Make the CONST have a shared SV */
6722 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6723 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6724 key = SvPV(sv, keylen);
6725 lexname = newSVpvn_share(key,
6726 SvUTF8(sv) ? -(I32)keylen : keylen,
6732 if ((o->op_private & (OPpLVAL_INTRO)))
6735 rop = (UNOP*)((BINOP*)o)->op_first;
6736 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6738 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6739 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6741 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6742 if (!fields || !GvHV(*fields))
6744 key = SvPV(*svp, keylen);
6745 if (!hv_fetch(GvHV(*fields), key,
6746 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
6748 Perl_croak(aTHX_ "No such class field \"%s\" "
6749 "in variable %s of type %s",
6750 key, SvPV_nolen(lexname), HvNAME(SvSTASH(lexname)));
6763 SVOP *first_key_op, *key_op;
6765 if ((o->op_private & (OPpLVAL_INTRO))
6766 /* I bet there's always a pushmark... */
6767 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6768 /* hmmm, no optimization if list contains only one key. */
6770 rop = (UNOP*)((LISTOP*)o)->op_last;
6771 if (rop->op_type != OP_RV2HV)
6773 if (rop->op_first->op_type == OP_PADSV)
6774 /* @$hash{qw(keys here)} */
6775 rop = (UNOP*)rop->op_first;
6777 /* @{$hash}{qw(keys here)} */
6778 if (rop->op_first->op_type == OP_SCOPE
6779 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
6781 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
6787 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
6788 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6790 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6791 if (!fields || !GvHV(*fields))
6793 /* Again guessing that the pushmark can be jumped over.... */
6794 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
6795 ->op_first->op_sibling;
6796 for (key_op = first_key_op; key_op;
6797 key_op = (SVOP*)key_op->op_sibling) {
6798 if (key_op->op_type != OP_CONST)
6800 svp = cSVOPx_svp(key_op);
6801 key = SvPV(*svp, keylen);
6802 if (!hv_fetch(GvHV(*fields), key,
6803 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
6805 Perl_croak(aTHX_ "No such class field \"%s\" "
6806 "in variable %s of type %s",
6807 key, SvPV_nolen(lexname), HvNAME(SvSTASH(lexname)));
6814 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
6818 /* check that RHS of sort is a single plain array */
6819 oright = cUNOPo->op_first;
6820 if (!oright || oright->op_type != OP_PUSHMARK)
6823 /* reverse sort ... can be optimised. */
6824 if (!cUNOPo->op_sibling) {
6825 /* Nothing follows us on the list. */
6826 OP *reverse = o->op_next;
6828 if (reverse->op_type == OP_REVERSE &&
6829 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
6830 OP *pushmark = cUNOPx(reverse)->op_first;
6831 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
6832 && (cUNOPx(pushmark)->op_sibling == o)) {
6833 /* reverse -> pushmark -> sort */
6834 o->op_private |= OPpSORT_REVERSE;
6836 pushmark->op_next = oright->op_next;
6842 /* make @a = sort @a act in-place */
6846 oright = cUNOPx(oright)->op_sibling;
6849 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
6850 oright = cUNOPx(oright)->op_sibling;
6854 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
6855 || oright->op_next != o
6856 || (oright->op_private & OPpLVAL_INTRO)
6860 /* o2 follows the chain of op_nexts through the LHS of the
6861 * assign (if any) to the aassign op itself */
6863 if (!o2 || o2->op_type != OP_NULL)
6866 if (!o2 || o2->op_type != OP_PUSHMARK)
6869 if (o2 && o2->op_type == OP_GV)
6872 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
6873 || (o2->op_private & OPpLVAL_INTRO)
6878 if (!o2 || o2->op_type != OP_NULL)
6881 if (!o2 || o2->op_type != OP_AASSIGN
6882 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
6885 /* check that the sort is the first arg on RHS of assign */
6887 o2 = cUNOPx(o2)->op_first;
6888 if (!o2 || o2->op_type != OP_NULL)
6890 o2 = cUNOPx(o2)->op_first;
6891 if (!o2 || o2->op_type != OP_PUSHMARK)
6893 if (o2->op_sibling != o)
6896 /* check the array is the same on both sides */
6897 if (oleft->op_type == OP_RV2AV) {
6898 if (oright->op_type != OP_RV2AV
6899 || !cUNOPx(oright)->op_first
6900 || cUNOPx(oright)->op_first->op_type != OP_GV
6901 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
6902 cGVOPx_gv(cUNOPx(oright)->op_first)
6906 else if (oright->op_type != OP_PADAV
6907 || oright->op_targ != oleft->op_targ
6911 /* transfer MODishness etc from LHS arg to RHS arg */
6912 oright->op_flags = oleft->op_flags;
6913 o->op_private |= OPpSORT_INPLACE;
6915 /* excise push->gv->rv2av->null->aassign */
6916 o2 = o->op_next->op_next;
6917 op_null(o2); /* PUSHMARK */
6919 if (o2->op_type == OP_GV) {
6920 op_null(o2); /* GV */
6923 op_null(o2); /* RV2AV or PADAV */
6924 o2 = o2->op_next->op_next;
6925 op_null(o2); /* AASSIGN */
6927 o->op_next = o2->op_next;
6933 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
6935 LISTOP *enter, *exlist;
6938 enter = (LISTOP *) o->op_next;
6941 if (enter->op_type == OP_NULL) {
6942 enter = (LISTOP *) enter->op_next;
6946 /* for $a (...) will have OP_GV then OP_RV2GV here.
6947 for (...) just has an OP_GV. */
6948 if (enter->op_type == OP_GV) {
6949 gvop = (OP *) enter;
6950 enter = (LISTOP *) enter->op_next;
6953 if (enter->op_type == OP_RV2GV) {
6954 enter = (LISTOP *) enter->op_next;
6960 if (enter->op_type != OP_ENTERITER)
6963 iter = enter->op_next;
6964 if (!iter || iter->op_type != OP_ITER)
6967 expushmark = enter->op_first;
6968 if (!expushmark || expushmark->op_type != OP_NULL
6969 || expushmark->op_targ != OP_PUSHMARK)
6972 exlist = (LISTOP *) expushmark->op_sibling;
6973 if (!exlist || exlist->op_type != OP_NULL
6974 || exlist->op_targ != OP_LIST)
6977 if (exlist->op_last != o) {
6978 /* Mmm. Was expecting to point back to this op. */
6981 theirmark = exlist->op_first;
6982 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
6985 if (theirmark->op_sibling != o) {
6986 /* There's something between the mark and the reverse, eg
6987 for (1, reverse (...))
6992 ourmark = ((LISTOP *)o)->op_first;
6993 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
6996 ourlast = ((LISTOP *)o)->op_last;
6997 if (!ourlast || ourlast->op_next != o)
7000 rv2av = ourmark->op_sibling;
7001 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
7002 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
7003 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
7004 /* We're just reversing a single array. */
7005 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
7006 enter->op_flags |= OPf_STACKED;
7009 /* We don't have control over who points to theirmark, so sacrifice
7011 theirmark->op_next = ourmark->op_next;
7012 theirmark->op_flags = ourmark->op_flags;
7013 ourlast->op_next = gvop ? gvop : (OP *) enter;
7016 enter->op_private |= OPpITER_REVERSED;
7017 iter->op_private |= OPpITER_REVERSED;
7032 Perl_custom_op_name(pTHX_ const OP* o)
7034 const IV index = PTR2IV(o->op_ppaddr);
7038 if (!PL_custom_op_names) /* This probably shouldn't happen */
7039 return PL_op_name[OP_CUSTOM];
7041 keysv = sv_2mortal(newSViv(index));
7043 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7045 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7047 return SvPV_nolen(HeVAL(he));
7051 Perl_custom_op_desc(pTHX_ const OP* o)
7053 const IV index = PTR2IV(o->op_ppaddr);
7057 if (!PL_custom_op_descs)
7058 return PL_op_desc[OP_CUSTOM];
7060 keysv = sv_2mortal(newSViv(index));
7062 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7064 return PL_op_desc[OP_CUSTOM];
7066 return SvPV_nolen(HeVAL(he));
7071 /* Efficient sub that returns a constant scalar value. */
7073 const_sv_xsub(pTHX_ CV* cv)
7078 Perl_croak(aTHX_ "usage: %s::%s()",
7079 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7083 ST(0) = (SV*)XSANY.any_ptr;
7089 * c-indentation-style: bsd
7091 * indent-tabs-mode: t
7094 * vim: shiftwidth=4: