3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
13 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
14 * youngest of the Old Took's daughters); and Mr. Drogo was his second
15 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
16 * either way, as the saying is, if you follow me." --the Gaffer
19 /* This file contains the functions that create, manipulate and optimize
20 * the OP structures that hold a compiled perl program.
22 * A Perl program is compiled into a tree of OPs. Each op contains
23 * structural pointers (eg to its siblings and the next op in the
24 * execution sequence), a pointer to the function that would execute the
25 * op, plus any data specific to that op. For example, an OP_CONST op
26 * points to the pp_const() function and to an SV containing the constant
27 * value. When pp_const() is executed, its job is to push that SV onto the
30 * OPs are mainly created by the newFOO() functions, which are mainly
31 * called from the parser (in perly.y) as the code is parsed. For example
32 * the Perl code $a + $b * $c would cause the equivalent of the following
33 * to be called (oversimplifying a bit):
35 * newBINOP(OP_ADD, flags,
37 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
40 * Note that during the build of miniperl, a temporary copy of this file
41 * is made, called opmini.c.
45 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
49 An execution-order pass
51 The bottom-up pass is represented by all the "newOP" routines and
52 the ck_ routines. The bottom-upness is actually driven by yacc.
53 So at the point that a ck_ routine fires, we have no idea what the
54 context is, either upward in the syntax tree, or either forward or
55 backward in the execution order. (The bottom-up parser builds that
56 part of the execution order it knows about, but if you follow the "next"
57 links around, you'll find it's actually a closed loop through the
60 Whenever the bottom-up parser gets to a node that supplies context to
61 its components, it invokes that portion of the top-down pass that applies
62 to that part of the subtree (and marks the top node as processed, so
63 if a node further up supplies context, it doesn't have to take the
64 plunge again). As a particular subcase of this, as the new node is
65 built, it takes all the closed execution loops of its subcomponents
66 and links them into a new closed loop for the higher level node. But
67 it's still not the real execution order.
69 The actual execution order is not known till we get a grammar reduction
70 to a top-level unit like a subroutine or file that will be called by
71 "name" rather than via a "next" pointer. At that point, we can call
72 into peep() to do that code's portion of the 3rd pass. It has to be
73 recursive, but it's recursive on basic blocks, not on tree nodes.
81 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
83 #if defined(PL_OP_SLAB_ALLOC)
85 #ifndef PERL_SLAB_SIZE
86 #define PERL_SLAB_SIZE 2048
90 Perl_Slab_Alloc(pTHX_ int m, size_t sz)
93 * To make incrementing use count easy PL_OpSlab is an I32 *
94 * To make inserting the link to slab PL_OpPtr is I32 **
95 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
96 * Add an overhead for pointer to slab and round up as a number of pointers
98 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
99 if ((PL_OpSpace -= sz) < 0) {
100 PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*));
104 Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **);
105 /* We reserve the 0'th I32 sized chunk as a use count */
106 PL_OpSlab = (I32 *) PL_OpPtr;
107 /* Reduce size by the use count word, and by the size we need.
108 * Latter is to mimic the '-=' in the if() above
110 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
111 /* Allocation pointer starts at the top.
112 Theory: because we build leaves before trunk allocating at end
113 means that at run time access is cache friendly upward
115 PL_OpPtr += PERL_SLAB_SIZE;
117 assert( PL_OpSpace >= 0 );
118 /* Move the allocation pointer down */
120 assert( PL_OpPtr > (I32 **) PL_OpSlab );
121 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
122 (*PL_OpSlab)++; /* Increment use count of slab */
123 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
124 assert( *PL_OpSlab > 0 );
125 return (void *)(PL_OpPtr + 1);
129 Perl_Slab_Free(pTHX_ void *op)
131 I32 **ptr = (I32 **) op;
133 assert( ptr-1 > (I32 **) slab );
134 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
136 if (--(*slab) == 0) {
138 # define PerlMemShared PerlMem
141 PerlMemShared_free(slab);
142 if (slab == PL_OpSlab) {
149 * In the following definition, the ", Nullop" is just to make the compiler
150 * think the expression is of the right type: croak actually does a Siglongjmp.
152 #define CHECKOP(type,o) \
153 ((PL_op_mask && PL_op_mask[type]) \
154 ? ( op_free((OP*)o), \
155 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
157 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
159 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
162 S_gv_ename(pTHX_ GV *gv)
165 SV* tmpsv = sv_newmortal();
166 gv_efullname3(tmpsv, gv, Nullch);
167 return SvPV(tmpsv,n_a);
171 S_no_fh_allowed(pTHX_ OP *o)
173 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
179 S_too_few_arguments(pTHX_ OP *o, const char *name)
181 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
186 S_too_many_arguments(pTHX_ OP *o, const char *name)
188 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
193 S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
195 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
196 (int)n, name, t, OP_DESC(kid)));
200 S_no_bareword_allowed(pTHX_ const OP *o)
202 qerror(Perl_mess(aTHX_
203 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
207 /* "register" allocation */
210 Perl_allocmy(pTHX_ char *name)
214 /* complain about "my $<special_var>" etc etc */
215 if (!(PL_in_my == KEY_our ||
217 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
218 (name[1] == '_' && (*name == '$' || (int)strlen(name) > 2))))
220 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
221 /* 1999-02-27 mjd@plover.com */
223 p = strchr(name, '\0');
224 /* The next block assumes the buffer is at least 205 chars
225 long. At present, it's always at least 256 chars. */
227 strcpy(name+200, "...");
233 /* Move everything else down one character */
234 for (; p-name > 2; p--)
236 name[2] = toCTRL(name[1]);
239 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
242 /* check for duplicate declaration */
244 (bool)(PL_in_my == KEY_our),
245 (PL_curstash ? PL_curstash : PL_defstash)
248 if (PL_in_my_stash && *name != '$') {
249 yyerror(Perl_form(aTHX_
250 "Can't declare class for non-scalar %s in \"%s\"",
251 name, PL_in_my == KEY_our ? "our" : "my"));
254 /* allocate a spare slot and store the name in that slot */
256 off = pad_add_name(name,
259 /* $_ is always in main::, even with our */
260 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
271 Perl_op_free(pTHX_ OP *o)
276 if (!o || o->op_static)
279 if (o->op_private & OPpREFCOUNTED) {
280 switch (o->op_type) {
288 refcnt = OpREFCNT_dec(o);
298 if (o->op_flags & OPf_KIDS) {
299 register OP *kid, *nextkid;
300 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
301 nextkid = kid->op_sibling; /* Get before next freeing kid */
307 type = (OPCODE)o->op_targ;
309 /* COP* is not cleared by op_clear() so that we may track line
310 * numbers etc even after null() */
311 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
319 Perl_op_clear(pTHX_ OP *o)
322 switch (o->op_type) {
323 case OP_NULL: /* Was holding old type, if any. */
324 case OP_ENTEREVAL: /* Was holding hints. */
328 if (!(o->op_flags & OPf_REF)
329 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
335 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
336 /* not an OP_PADAV replacement */
338 if (cPADOPo->op_padix > 0) {
339 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
340 * may still exist on the pad */
341 pad_swipe(cPADOPo->op_padix, TRUE);
342 cPADOPo->op_padix = 0;
345 SvREFCNT_dec(cSVOPo->op_sv);
346 cSVOPo->op_sv = Nullsv;
350 case OP_METHOD_NAMED:
352 SvREFCNT_dec(cSVOPo->op_sv);
353 cSVOPo->op_sv = Nullsv;
356 Even if op_clear does a pad_free for the target of the op,
357 pad_free doesn't actually remove the sv that exists in the pad;
358 instead it lives on. This results in that it could be reused as
359 a target later on when the pad was reallocated.
362 pad_swipe(o->op_targ,1);
371 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
375 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
376 SvREFCNT_dec(cSVOPo->op_sv);
377 cSVOPo->op_sv = Nullsv;
380 Safefree(cPVOPo->op_pv);
381 cPVOPo->op_pv = Nullch;
385 op_free(cPMOPo->op_pmreplroot);
389 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
390 /* No GvIN_PAD_off here, because other references may still
391 * exist on the pad */
392 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
395 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
402 HV *pmstash = PmopSTASH(cPMOPo);
403 if (pmstash && SvREFCNT(pmstash)) {
404 PMOP *pmop = HvPMROOT(pmstash);
405 PMOP *lastpmop = NULL;
407 if (cPMOPo == pmop) {
409 lastpmop->op_pmnext = pmop->op_pmnext;
411 HvPMROOT(pmstash) = pmop->op_pmnext;
415 pmop = pmop->op_pmnext;
418 PmopSTASH_free(cPMOPo);
420 cPMOPo->op_pmreplroot = Nullop;
421 /* we use the "SAFE" version of the PM_ macros here
422 * since sv_clean_all might release some PMOPs
423 * after PL_regex_padav has been cleared
424 * and the clearing of PL_regex_padav needs to
425 * happen before sv_clean_all
427 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
428 PM_SETRE_SAFE(cPMOPo, (REGEXP*)NULL);
430 if(PL_regex_pad) { /* We could be in destruction */
431 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
432 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
433 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
440 if (o->op_targ > 0) {
441 pad_free(o->op_targ);
447 S_cop_free(pTHX_ COP* cop)
449 Safefree(cop->cop_label); /* FIXME: treaddead ??? */
452 if (! specialWARN(cop->cop_warnings))
453 SvREFCNT_dec(cop->cop_warnings);
454 if (! specialCopIO(cop->cop_io)) {
458 char *s = SvPV(cop->cop_io,len);
459 Perl_warn(aTHX_ "io='%.*s'",(int) len,s); /* ??? --jhi */
462 SvREFCNT_dec(cop->cop_io);
468 Perl_op_null(pTHX_ OP *o)
470 if (o->op_type == OP_NULL)
473 o->op_targ = o->op_type;
474 o->op_type = OP_NULL;
475 o->op_ppaddr = PL_ppaddr[OP_NULL];
479 Perl_op_refcnt_lock(pTHX)
485 Perl_op_refcnt_unlock(pTHX)
490 /* Contextualizers */
492 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
495 Perl_linklist(pTHX_ OP *o)
501 /* establish postfix order */
502 if (cUNOPo->op_first) {
504 o->op_next = LINKLIST(cUNOPo->op_first);
505 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
507 kid->op_next = LINKLIST(kid->op_sibling);
519 Perl_scalarkids(pTHX_ OP *o)
521 if (o && o->op_flags & OPf_KIDS) {
523 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
530 S_scalarboolean(pTHX_ OP *o)
532 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
533 if (ckWARN(WARN_SYNTAX)) {
534 const line_t oldline = CopLINE(PL_curcop);
536 if (PL_copline != NOLINE)
537 CopLINE_set(PL_curcop, PL_copline);
538 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
539 CopLINE_set(PL_curcop, oldline);
546 Perl_scalar(pTHX_ OP *o)
550 /* assumes no premature commitment */
551 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
552 || o->op_type == OP_RETURN)
557 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
559 switch (o->op_type) {
561 scalar(cBINOPo->op_first);
566 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
570 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
571 if (!kPMOP->op_pmreplroot)
572 deprecate_old("implicit split to @_");
580 if (o->op_flags & OPf_KIDS) {
581 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
587 kid = cLISTOPo->op_first;
589 while ((kid = kid->op_sibling)) {
595 WITH_THR(PL_curcop = &PL_compiling);
600 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
606 WITH_THR(PL_curcop = &PL_compiling);
609 if (ckWARN(WARN_VOID))
610 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
616 Perl_scalarvoid(pTHX_ OP *o)
619 const char* useless = 0;
623 if (o->op_type == OP_NEXTSTATE
624 || o->op_type == OP_SETSTATE
625 || o->op_type == OP_DBSTATE
626 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
627 || o->op_targ == OP_SETSTATE
628 || o->op_targ == OP_DBSTATE)))
629 PL_curcop = (COP*)o; /* for warning below */
631 /* assumes no premature commitment */
632 want = o->op_flags & OPf_WANT;
633 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
634 || o->op_type == OP_RETURN)
639 if ((o->op_private & OPpTARGET_MY)
640 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
642 return scalar(o); /* As if inside SASSIGN */
645 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
647 switch (o->op_type) {
649 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
653 if (o->op_flags & OPf_STACKED)
657 if (o->op_private == 4)
729 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
730 useless = OP_DESC(o);
734 kid = cUNOPo->op_first;
735 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
736 kid->op_type != OP_TRANS) {
739 useless = "negative pattern binding (!~)";
746 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
747 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
748 useless = "a variable";
753 if (cSVOPo->op_private & OPpCONST_STRICT)
754 no_bareword_allowed(o);
756 if (ckWARN(WARN_VOID)) {
757 useless = "a constant";
758 /* don't warn on optimised away booleans, eg
759 * use constant Foo, 5; Foo || print; */
760 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
762 /* the constants 0 and 1 are permitted as they are
763 conventionally used as dummies in constructs like
764 1 while some_condition_with_side_effects; */
765 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
767 else if (SvPOK(sv)) {
768 /* perl4's way of mixing documentation and code
769 (before the invention of POD) was based on a
770 trick to mix nroff and perl code. The trick was
771 built upon these three nroff macros being used in
772 void context. The pink camel has the details in
773 the script wrapman near page 319. */
774 if (strnEQ(SvPVX(sv), "di", 2) ||
775 strnEQ(SvPVX(sv), "ds", 2) ||
776 strnEQ(SvPVX(sv), "ig", 2))
781 op_null(o); /* don't execute or even remember it */
785 o->op_type = OP_PREINC; /* pre-increment is faster */
786 o->op_ppaddr = PL_ppaddr[OP_PREINC];
790 o->op_type = OP_PREDEC; /* pre-decrement is faster */
791 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
798 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
803 if (o->op_flags & OPf_STACKED)
810 if (!(o->op_flags & OPf_KIDS))
819 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
826 /* all requires must return a boolean value */
827 o->op_flags &= ~OPf_WANT;
832 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
833 if (!kPMOP->op_pmreplroot)
834 deprecate_old("implicit split to @_");
838 if (useless && ckWARN(WARN_VOID))
839 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
844 Perl_listkids(pTHX_ OP *o)
846 if (o && o->op_flags & OPf_KIDS) {
848 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
855 Perl_list(pTHX_ OP *o)
859 /* assumes no premature commitment */
860 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
861 || o->op_type == OP_RETURN)
866 if ((o->op_private & OPpTARGET_MY)
867 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
869 return o; /* As if inside SASSIGN */
872 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
874 switch (o->op_type) {
877 list(cBINOPo->op_first);
882 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
890 if (!(o->op_flags & OPf_KIDS))
892 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
893 list(cBINOPo->op_first);
894 return gen_constant_list(o);
901 kid = cLISTOPo->op_first;
903 while ((kid = kid->op_sibling)) {
909 WITH_THR(PL_curcop = &PL_compiling);
913 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
919 WITH_THR(PL_curcop = &PL_compiling);
922 /* all requires must return a boolean value */
923 o->op_flags &= ~OPf_WANT;
930 Perl_scalarseq(pTHX_ OP *o)
933 if (o->op_type == OP_LINESEQ ||
934 o->op_type == OP_SCOPE ||
935 o->op_type == OP_LEAVE ||
936 o->op_type == OP_LEAVETRY)
939 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
940 if (kid->op_sibling) {
944 PL_curcop = &PL_compiling;
946 o->op_flags &= ~OPf_PARENS;
947 if (PL_hints & HINT_BLOCK_SCOPE)
948 o->op_flags |= OPf_PARENS;
951 o = newOP(OP_STUB, 0);
956 S_modkids(pTHX_ OP *o, I32 type)
958 if (o && o->op_flags & OPf_KIDS) {
960 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
966 /* Propagate lvalue ("modifiable") context to an op and it's children.
967 * 'type' represents the context type, roughly based on the type of op that
968 * would do the modifying, although local() is represented by OP_NULL.
969 * It's responsible for detecting things that can't be modified, flag
970 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
971 * might have to vivify a reference in $x), and so on.
973 * For example, "$a+1 = 2" would cause mod() to be called with o being
974 * OP_ADD and type being OP_SASSIGN, and would output an error.
978 Perl_mod(pTHX_ OP *o, I32 type)
981 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
984 if (!o || PL_error_count)
987 if ((o->op_private & OPpTARGET_MY)
988 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
993 switch (o->op_type) {
999 if (!(o->op_private & (OPpCONST_ARYBASE)))
1001 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1002 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1006 SAVEI32(PL_compiling.cop_arybase);
1007 PL_compiling.cop_arybase = 0;
1009 else if (type == OP_REFGEN)
1012 Perl_croak(aTHX_ "That use of $[ is unsupported");
1015 if (o->op_flags & OPf_PARENS)
1019 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1020 !(o->op_flags & OPf_STACKED)) {
1021 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1022 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1023 assert(cUNOPo->op_first->op_type == OP_NULL);
1024 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1027 else if (o->op_private & OPpENTERSUB_NOMOD)
1029 else { /* lvalue subroutine call */
1030 o->op_private |= OPpLVAL_INTRO;
1031 PL_modcount = RETURN_UNLIMITED_NUMBER;
1032 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1033 /* Backward compatibility mode: */
1034 o->op_private |= OPpENTERSUB_INARGS;
1037 else { /* Compile-time error message: */
1038 OP *kid = cUNOPo->op_first;
1042 if (kid->op_type == OP_PUSHMARK)
1044 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1046 "panic: unexpected lvalue entersub "
1047 "args: type/targ %ld:%"UVuf,
1048 (long)kid->op_type, (UV)kid->op_targ);
1049 kid = kLISTOP->op_first;
1051 while (kid->op_sibling)
1052 kid = kid->op_sibling;
1053 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1055 if (kid->op_type == OP_METHOD_NAMED
1056 || kid->op_type == OP_METHOD)
1060 NewOp(1101, newop, 1, UNOP);
1061 newop->op_type = OP_RV2CV;
1062 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1063 newop->op_first = Nullop;
1064 newop->op_next = (OP*)newop;
1065 kid->op_sibling = (OP*)newop;
1066 newop->op_private |= OPpLVAL_INTRO;
1070 if (kid->op_type != OP_RV2CV)
1072 "panic: unexpected lvalue entersub "
1073 "entry via type/targ %ld:%"UVuf,
1074 (long)kid->op_type, (UV)kid->op_targ);
1075 kid->op_private |= OPpLVAL_INTRO;
1076 break; /* Postpone until runtime */
1080 kid = kUNOP->op_first;
1081 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1082 kid = kUNOP->op_first;
1083 if (kid->op_type == OP_NULL)
1085 "Unexpected constant lvalue entersub "
1086 "entry via type/targ %ld:%"UVuf,
1087 (long)kid->op_type, (UV)kid->op_targ);
1088 if (kid->op_type != OP_GV) {
1089 /* Restore RV2CV to check lvalueness */
1091 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1092 okid->op_next = kid->op_next;
1093 kid->op_next = okid;
1096 okid->op_next = Nullop;
1097 okid->op_type = OP_RV2CV;
1099 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1100 okid->op_private |= OPpLVAL_INTRO;
1104 cv = GvCV(kGVOP_gv);
1114 /* grep, foreach, subcalls, refgen */
1115 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1117 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1118 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1120 : (o->op_type == OP_ENTERSUB
1121 ? "non-lvalue subroutine call"
1123 type ? PL_op_desc[type] : "local"));
1137 case OP_RIGHT_SHIFT:
1146 if (!(o->op_flags & OPf_STACKED))
1153 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1159 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1160 PL_modcount = RETURN_UNLIMITED_NUMBER;
1161 return o; /* Treat \(@foo) like ordinary list. */
1165 if (scalar_mod_type(o, type))
1167 ref(cUNOPo->op_first, o->op_type);
1171 if (type == OP_LEAVESUBLV)
1172 o->op_private |= OPpMAYBE_LVSUB;
1178 PL_modcount = RETURN_UNLIMITED_NUMBER;
1181 ref(cUNOPo->op_first, o->op_type);
1186 PL_hints |= HINT_BLOCK_SCOPE;
1201 PL_modcount = RETURN_UNLIMITED_NUMBER;
1202 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1203 return o; /* Treat \(@foo) like ordinary list. */
1204 if (scalar_mod_type(o, type))
1206 if (type == OP_LEAVESUBLV)
1207 o->op_private |= OPpMAYBE_LVSUB;
1211 if (!type) /* local() */
1212 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1213 PAD_COMPNAME_PV(o->op_targ));
1221 if (type != OP_SASSIGN)
1225 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1230 if (type == OP_LEAVESUBLV)
1231 o->op_private |= OPpMAYBE_LVSUB;
1233 pad_free(o->op_targ);
1234 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1235 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1236 if (o->op_flags & OPf_KIDS)
1237 mod(cBINOPo->op_first->op_sibling, type);
1242 ref(cBINOPo->op_first, o->op_type);
1243 if (type == OP_ENTERSUB &&
1244 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1245 o->op_private |= OPpLVAL_DEFER;
1246 if (type == OP_LEAVESUBLV)
1247 o->op_private |= OPpMAYBE_LVSUB;
1257 if (o->op_flags & OPf_KIDS)
1258 mod(cLISTOPo->op_last, type);
1263 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1265 else if (!(o->op_flags & OPf_KIDS))
1267 if (o->op_targ != OP_LIST) {
1268 mod(cBINOPo->op_first, type);
1274 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1279 if (type != OP_LEAVESUBLV)
1281 break; /* mod()ing was handled by ck_return() */
1284 /* [20011101.069] File test operators interpret OPf_REF to mean that
1285 their argument is a filehandle; thus \stat(".") should not set
1287 if (type == OP_REFGEN &&
1288 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1291 if (type != OP_LEAVESUBLV)
1292 o->op_flags |= OPf_MOD;
1294 if (type == OP_AASSIGN || type == OP_SASSIGN)
1295 o->op_flags |= OPf_SPECIAL|OPf_REF;
1296 else if (!type) { /* local() */
1299 o->op_private |= OPpLVAL_INTRO;
1300 o->op_flags &= ~OPf_SPECIAL;
1301 PL_hints |= HINT_BLOCK_SCOPE;
1306 if (ckWARN(WARN_SYNTAX)) {
1307 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1308 "Useless localization of %s", OP_DESC(o));
1312 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1313 && type != OP_LEAVESUBLV)
1314 o->op_flags |= OPf_REF;
1319 S_scalar_mod_type(pTHX_ const OP *o, I32 type)
1323 if (o->op_type == OP_RV2GV)
1347 case OP_RIGHT_SHIFT:
1366 S_is_handle_constructor(pTHX_ const OP *o, I32 argnum)
1368 switch (o->op_type) {
1376 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1389 Perl_refkids(pTHX_ OP *o, I32 type)
1391 if (o && o->op_flags & OPf_KIDS) {
1393 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1400 Perl_ref(pTHX_ OP *o, I32 type)
1404 if (!o || PL_error_count)
1407 switch (o->op_type) {
1409 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1410 !(o->op_flags & OPf_STACKED)) {
1411 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1412 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1413 assert(cUNOPo->op_first->op_type == OP_NULL);
1414 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1415 o->op_flags |= OPf_SPECIAL;
1420 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1424 if (type == OP_DEFINED)
1425 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1426 ref(cUNOPo->op_first, o->op_type);
1429 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1430 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1431 : type == OP_RV2HV ? OPpDEREF_HV
1433 o->op_flags |= OPf_MOD;
1438 o->op_flags |= OPf_MOD; /* XXX ??? */
1443 o->op_flags |= OPf_REF;
1446 if (type == OP_DEFINED)
1447 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1448 ref(cUNOPo->op_first, o->op_type);
1453 o->op_flags |= OPf_REF;
1458 if (!(o->op_flags & OPf_KIDS))
1460 ref(cBINOPo->op_first, type);
1464 ref(cBINOPo->op_first, o->op_type);
1465 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1466 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1467 : type == OP_RV2HV ? OPpDEREF_HV
1469 o->op_flags |= OPf_MOD;
1477 if (!(o->op_flags & OPf_KIDS))
1479 ref(cLISTOPo->op_last, type);
1489 S_dup_attrlist(pTHX_ OP *o)
1493 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1494 * where the first kid is OP_PUSHMARK and the remaining ones
1495 * are OP_CONST. We need to push the OP_CONST values.
1497 if (o->op_type == OP_CONST)
1498 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1500 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1501 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1502 if (o->op_type == OP_CONST)
1503 rop = append_elem(OP_LIST, rop,
1504 newSVOP(OP_CONST, o->op_flags,
1505 SvREFCNT_inc(cSVOPo->op_sv)));
1512 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1516 /* fake up C<use attributes $pkg,$rv,@attrs> */
1517 ENTER; /* need to protect against side-effects of 'use' */
1520 stashsv = newSVpv(HvNAME(stash), 0);
1522 stashsv = &PL_sv_no;
1524 #define ATTRSMODULE "attributes"
1525 #define ATTRSMODULE_PM "attributes.pm"
1529 /* Don't force the C<use> if we don't need it. */
1530 svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
1531 sizeof(ATTRSMODULE_PM)-1, 0);
1532 if (svp && *svp != &PL_sv_undef)
1533 ; /* already in %INC */
1535 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1536 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1540 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1541 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1543 prepend_elem(OP_LIST,
1544 newSVOP(OP_CONST, 0, stashsv),
1545 prepend_elem(OP_LIST,
1546 newSVOP(OP_CONST, 0,
1548 dup_attrlist(attrs))));
1554 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1556 OP *pack, *imop, *arg;
1562 assert(target->op_type == OP_PADSV ||
1563 target->op_type == OP_PADHV ||
1564 target->op_type == OP_PADAV);
1566 /* Ensure that attributes.pm is loaded. */
1567 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1569 /* Need package name for method call. */
1570 pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
1572 /* Build up the real arg-list. */
1574 stashsv = newSVpv(HvNAME(stash), 0);
1576 stashsv = &PL_sv_no;
1577 arg = newOP(OP_PADSV, 0);
1578 arg->op_targ = target->op_targ;
1579 arg = prepend_elem(OP_LIST,
1580 newSVOP(OP_CONST, 0, stashsv),
1581 prepend_elem(OP_LIST,
1582 newUNOP(OP_REFGEN, 0,
1583 mod(arg, OP_REFGEN)),
1584 dup_attrlist(attrs)));
1586 /* Fake up a method call to import */
1587 meth = newSVpvn("import", 6);
1588 (void)SvUPGRADE(meth, SVt_PVIV);
1589 (void)SvIOK_on(meth);
1592 PERL_HASH(hash, SvPVX(meth), SvCUR(meth));
1593 SvUV_set(meth, hash);
1595 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1596 append_elem(OP_LIST,
1597 prepend_elem(OP_LIST, pack, list(arg)),
1598 newSVOP(OP_METHOD_NAMED, 0, meth)));
1599 imop->op_private |= OPpENTERSUB_NOMOD;
1601 /* Combine the ops. */
1602 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1606 =notfor apidoc apply_attrs_string
1608 Attempts to apply a list of attributes specified by the C<attrstr> and
1609 C<len> arguments to the subroutine identified by the C<cv> argument which
1610 is expected to be associated with the package identified by the C<stashpv>
1611 argument (see L<attributes>). It gets this wrong, though, in that it
1612 does not correctly identify the boundaries of the individual attribute
1613 specifications within C<attrstr>. This is not really intended for the
1614 public API, but has to be listed here for systems such as AIX which
1615 need an explicit export list for symbols. (It's called from XS code
1616 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1617 to respect attribute syntax properly would be welcome.
1623 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1624 const char *attrstr, STRLEN len)
1629 len = strlen(attrstr);
1633 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1635 const char *sstr = attrstr;
1636 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1637 attrs = append_elem(OP_LIST, attrs,
1638 newSVOP(OP_CONST, 0,
1639 newSVpvn(sstr, attrstr-sstr)));
1643 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1644 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1645 Nullsv, prepend_elem(OP_LIST,
1646 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1647 prepend_elem(OP_LIST,
1648 newSVOP(OP_CONST, 0,
1654 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1658 if (!o || PL_error_count)
1662 if (type == OP_LIST) {
1664 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1665 my_kid(kid, attrs, imopsp);
1666 } else if (type == OP_UNDEF) {
1668 } else if (type == OP_RV2SV || /* "our" declaration */
1670 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1671 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1672 yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
1673 OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
1675 GV *gv = cGVOPx_gv(cUNOPo->op_first);
1677 PL_in_my_stash = Nullhv;
1678 apply_attrs(GvSTASH(gv),
1679 (type == OP_RV2SV ? GvSV(gv) :
1680 type == OP_RV2AV ? (SV*)GvAV(gv) :
1681 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1684 o->op_private |= OPpOUR_INTRO;
1687 else if (type != OP_PADSV &&
1690 type != OP_PUSHMARK)
1692 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1694 PL_in_my == KEY_our ? "our" : "my"));
1697 else if (attrs && type != OP_PUSHMARK) {
1701 PL_in_my_stash = Nullhv;
1703 /* check for C<my Dog $spot> when deciding package */
1704 stash = PAD_COMPNAME_TYPE(o->op_targ);
1706 stash = PL_curstash;
1707 apply_attrs_my(stash, o, attrs, imopsp);
1709 o->op_flags |= OPf_MOD;
1710 o->op_private |= OPpLVAL_INTRO;
1715 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1718 int maybe_scalar = 0;
1720 /* [perl #17376]: this appears to be premature, and results in code such as
1721 C< our(%x); > executing in list mode rather than void mode */
1723 if (o->op_flags & OPf_PARENS)
1732 o = my_kid(o, attrs, &rops);
1734 if (maybe_scalar && o->op_type == OP_PADSV) {
1735 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1736 o->op_private |= OPpLVAL_INTRO;
1739 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1742 PL_in_my_stash = Nullhv;
1747 Perl_my(pTHX_ OP *o)
1749 return my_attrs(o, Nullop);
1753 Perl_sawparens(pTHX_ OP *o)
1756 o->op_flags |= OPf_PARENS;
1761 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1766 if (ckWARN(WARN_MISC) &&
1767 (left->op_type == OP_RV2AV ||
1768 left->op_type == OP_RV2HV ||
1769 left->op_type == OP_PADAV ||
1770 left->op_type == OP_PADHV)) {
1771 const char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
1772 right->op_type == OP_TRANS)
1773 ? right->op_type : OP_MATCH];
1774 const char *sample = ((left->op_type == OP_RV2AV ||
1775 left->op_type == OP_PADAV)
1776 ? "@array" : "%hash");
1777 Perl_warner(aTHX_ packWARN(WARN_MISC),
1778 "Applying %s to %s will act on scalar(%s)",
1779 desc, sample, sample);
1782 if (right->op_type == OP_CONST &&
1783 cSVOPx(right)->op_private & OPpCONST_BARE &&
1784 cSVOPx(right)->op_private & OPpCONST_STRICT)
1786 no_bareword_allowed(right);
1789 ismatchop = right->op_type == OP_MATCH ||
1790 right->op_type == OP_SUBST ||
1791 right->op_type == OP_TRANS;
1792 if (ismatchop && right->op_private & OPpTARGET_MY) {
1794 right->op_private &= ~OPpTARGET_MY;
1796 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1797 right->op_flags |= OPf_STACKED;
1798 if (right->op_type != OP_MATCH &&
1799 ! (right->op_type == OP_TRANS &&
1800 right->op_private & OPpTRANS_IDENTICAL))
1801 left = mod(left, right->op_type);
1802 if (right->op_type == OP_TRANS)
1803 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
1805 o = prepend_elem(right->op_type, scalar(left), right);
1807 return newUNOP(OP_NOT, 0, scalar(o));
1811 return bind_match(type, left,
1812 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
1816 Perl_invert(pTHX_ OP *o)
1820 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
1821 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1825 Perl_scope(pTHX_ OP *o)
1828 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1829 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1830 o->op_type = OP_LEAVE;
1831 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1833 else if (o->op_type == OP_LINESEQ) {
1835 o->op_type = OP_SCOPE;
1836 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1837 kid = ((LISTOP*)o)->op_first;
1838 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
1842 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
1847 /* XXX kept for BINCOMPAT only */
1849 Perl_save_hints(pTHX)
1851 Perl_croak(aTHX_ "internal error: obsolete function save_hints() called");
1855 Perl_block_start(pTHX_ int full)
1857 const int retval = PL_savestack_ix;
1858 pad_block_start(full);
1860 PL_hints &= ~HINT_BLOCK_SCOPE;
1861 SAVESPTR(PL_compiling.cop_warnings);
1862 if (! specialWARN(PL_compiling.cop_warnings)) {
1863 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1864 SAVEFREESV(PL_compiling.cop_warnings) ;
1866 SAVESPTR(PL_compiling.cop_io);
1867 if (! specialCopIO(PL_compiling.cop_io)) {
1868 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1869 SAVEFREESV(PL_compiling.cop_io) ;
1875 Perl_block_end(pTHX_ I32 floor, OP *seq)
1877 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1878 OP* retval = scalarseq(seq);
1880 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
1882 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
1890 const I32 offset = pad_findmy("$_");
1891 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
1892 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1895 OP *o = newOP(OP_PADSV, 0);
1896 o->op_targ = offset;
1902 Perl_newPROG(pTHX_ OP *o)
1907 PL_eval_root = newUNOP(OP_LEAVEEVAL,
1908 ((PL_in_eval & EVAL_KEEPERR)
1909 ? OPf_SPECIAL : 0), o);
1910 PL_eval_start = linklist(PL_eval_root);
1911 PL_eval_root->op_private |= OPpREFCOUNTED;
1912 OpREFCNT_set(PL_eval_root, 1);
1913 PL_eval_root->op_next = 0;
1914 CALL_PEEP(PL_eval_start);
1917 if (o->op_type == OP_STUB) {
1918 PL_comppad_name = 0;
1923 PL_main_root = scope(sawparens(scalarvoid(o)));
1924 PL_curcop = &PL_compiling;
1925 PL_main_start = LINKLIST(PL_main_root);
1926 PL_main_root->op_private |= OPpREFCOUNTED;
1927 OpREFCNT_set(PL_main_root, 1);
1928 PL_main_root->op_next = 0;
1929 CALL_PEEP(PL_main_start);
1932 /* Register with debugger */
1934 CV *cv = get_cv("DB::postponed", FALSE);
1938 XPUSHs((SV*)CopFILEGV(&PL_compiling));
1940 call_sv((SV*)cv, G_DISCARD);
1947 Perl_localize(pTHX_ OP *o, I32 lex)
1949 if (o->op_flags & OPf_PARENS)
1950 /* [perl #17376]: this appears to be premature, and results in code such as
1951 C< our(%x); > executing in list mode rather than void mode */
1958 if (ckWARN(WARN_PARENTHESIS)
1959 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
1961 char *s = PL_bufptr;
1964 /* some heuristics to detect a potential error */
1965 while (*s && (strchr(", \t\n", *s)))
1969 if (*s && strchr("@$%*", *s) && *++s
1970 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
1973 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
1975 while (*s && (strchr(", \t\n", *s)))
1981 if (sigil && (*s == ';' || *s == '=')) {
1982 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
1983 "Parentheses missing around \"%s\" list",
1984 lex ? (PL_in_my == KEY_our ? "our" : "my")
1992 o = mod(o, OP_NULL); /* a bit kludgey */
1994 PL_in_my_stash = Nullhv;
1999 Perl_jmaybe(pTHX_ OP *o)
2001 if (o->op_type == OP_LIST) {
2003 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2004 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2010 Perl_fold_constants(pTHX_ register OP *o)
2013 I32 type = o->op_type;
2016 if (PL_opargs[type] & OA_RETSCALAR)
2018 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2019 o->op_targ = pad_alloc(type, SVs_PADTMP);
2021 /* integerize op, unless it happens to be C<-foo>.
2022 * XXX should pp_i_negate() do magic string negation instead? */
2023 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2024 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2025 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2027 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2030 if (!(PL_opargs[type] & OA_FOLDCONST))
2035 /* XXX might want a ck_negate() for this */
2036 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2048 /* XXX what about the numeric ops? */
2049 if (PL_hints & HINT_LOCALE)
2054 goto nope; /* Don't try to run w/ errors */
2056 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2057 if ((curop->op_type != OP_CONST ||
2058 (curop->op_private & OPpCONST_BARE)) &&
2059 curop->op_type != OP_LIST &&
2060 curop->op_type != OP_SCALAR &&
2061 curop->op_type != OP_NULL &&
2062 curop->op_type != OP_PUSHMARK)
2068 curop = LINKLIST(o);
2072 sv = *(PL_stack_sp--);
2073 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2074 pad_swipe(o->op_targ, FALSE);
2075 else if (SvTEMP(sv)) { /* grab mortal temp? */
2076 (void)SvREFCNT_inc(sv);
2080 if (type == OP_RV2GV)
2081 return newGVOP(OP_GV, 0, (GV*)sv);
2082 return newSVOP(OP_CONST, 0, sv);
2089 Perl_gen_constant_list(pTHX_ register OP *o)
2092 const I32 oldtmps_floor = PL_tmps_floor;
2096 return o; /* Don't attempt to run with errors */
2098 PL_op = curop = LINKLIST(o);
2105 PL_tmps_floor = oldtmps_floor;
2107 o->op_type = OP_RV2AV;
2108 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2109 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2110 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2111 o->op_opt = 0; /* needs to be revisited in peep() */
2112 curop = ((UNOP*)o)->op_first;
2113 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2120 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2122 if (!o || o->op_type != OP_LIST)
2123 o = newLISTOP(OP_LIST, 0, o, Nullop);
2125 o->op_flags &= ~OPf_WANT;
2127 if (!(PL_opargs[type] & OA_MARK))
2128 op_null(cLISTOPo->op_first);
2130 o->op_type = (OPCODE)type;
2131 o->op_ppaddr = PL_ppaddr[type];
2132 o->op_flags |= flags;
2134 o = CHECKOP(type, o);
2135 if (o->op_type != (unsigned)type)
2138 return fold_constants(o);
2141 /* List constructors */
2144 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2152 if (first->op_type != (unsigned)type
2153 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2155 return newLISTOP(type, 0, first, last);
2158 if (first->op_flags & OPf_KIDS)
2159 ((LISTOP*)first)->op_last->op_sibling = last;
2161 first->op_flags |= OPf_KIDS;
2162 ((LISTOP*)first)->op_first = last;
2164 ((LISTOP*)first)->op_last = last;
2169 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2177 if (first->op_type != (unsigned)type)
2178 return prepend_elem(type, (OP*)first, (OP*)last);
2180 if (last->op_type != (unsigned)type)
2181 return append_elem(type, (OP*)first, (OP*)last);
2183 first->op_last->op_sibling = last->op_first;
2184 first->op_last = last->op_last;
2185 first->op_flags |= (last->op_flags & OPf_KIDS);
2193 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2201 if (last->op_type == (unsigned)type) {
2202 if (type == OP_LIST) { /* already a PUSHMARK there */
2203 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2204 ((LISTOP*)last)->op_first->op_sibling = first;
2205 if (!(first->op_flags & OPf_PARENS))
2206 last->op_flags &= ~OPf_PARENS;
2209 if (!(last->op_flags & OPf_KIDS)) {
2210 ((LISTOP*)last)->op_last = first;
2211 last->op_flags |= OPf_KIDS;
2213 first->op_sibling = ((LISTOP*)last)->op_first;
2214 ((LISTOP*)last)->op_first = first;
2216 last->op_flags |= OPf_KIDS;
2220 return newLISTOP(type, 0, first, last);
2226 Perl_newNULLLIST(pTHX)
2228 return newOP(OP_STUB, 0);
2232 Perl_force_list(pTHX_ OP *o)
2234 if (!o || o->op_type != OP_LIST)
2235 o = newLISTOP(OP_LIST, 0, o, Nullop);
2241 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2245 NewOp(1101, listop, 1, LISTOP);
2247 listop->op_type = (OPCODE)type;
2248 listop->op_ppaddr = PL_ppaddr[type];
2251 listop->op_flags = (U8)flags;
2255 else if (!first && last)
2258 first->op_sibling = last;
2259 listop->op_first = first;
2260 listop->op_last = last;
2261 if (type == OP_LIST) {
2263 pushop = newOP(OP_PUSHMARK, 0);
2264 pushop->op_sibling = first;
2265 listop->op_first = pushop;
2266 listop->op_flags |= OPf_KIDS;
2268 listop->op_last = pushop;
2271 return CHECKOP(type, listop);
2275 Perl_newOP(pTHX_ I32 type, I32 flags)
2278 NewOp(1101, o, 1, OP);
2279 o->op_type = (OPCODE)type;
2280 o->op_ppaddr = PL_ppaddr[type];
2281 o->op_flags = (U8)flags;
2284 o->op_private = (U8)(0 | (flags >> 8));
2285 if (PL_opargs[type] & OA_RETSCALAR)
2287 if (PL_opargs[type] & OA_TARGET)
2288 o->op_targ = pad_alloc(type, SVs_PADTMP);
2289 return CHECKOP(type, o);
2293 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2298 first = newOP(OP_STUB, 0);
2299 if (PL_opargs[type] & OA_MARK)
2300 first = force_list(first);
2302 NewOp(1101, unop, 1, UNOP);
2303 unop->op_type = (OPCODE)type;
2304 unop->op_ppaddr = PL_ppaddr[type];
2305 unop->op_first = first;
2306 unop->op_flags = flags | OPf_KIDS;
2307 unop->op_private = (U8)(1 | (flags >> 8));
2308 unop = (UNOP*) CHECKOP(type, unop);
2312 return fold_constants((OP *) unop);
2316 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2319 NewOp(1101, binop, 1, BINOP);
2322 first = newOP(OP_NULL, 0);
2324 binop->op_type = (OPCODE)type;
2325 binop->op_ppaddr = PL_ppaddr[type];
2326 binop->op_first = first;
2327 binop->op_flags = flags | OPf_KIDS;
2330 binop->op_private = (U8)(1 | (flags >> 8));
2333 binop->op_private = (U8)(2 | (flags >> 8));
2334 first->op_sibling = last;
2337 binop = (BINOP*)CHECKOP(type, binop);
2338 if (binop->op_next || binop->op_type != (OPCODE)type)
2341 binop->op_last = binop->op_first->op_sibling;
2343 return fold_constants((OP *)binop);
2347 uvcompare(const void *a, const void *b)
2349 if (*((const UV *)a) < (*(const UV *)b))
2351 if (*((const UV *)a) > (*(const UV *)b))
2353 if (*((const UV *)a+1) < (*(const UV *)b+1))
2355 if (*((const UV *)a+1) > (*(const UV *)b+1))
2361 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2363 SV *tstr = ((SVOP*)expr)->op_sv;
2364 SV *rstr = ((SVOP*)repl)->op_sv;
2367 U8 *t = (U8*)SvPV(tstr, tlen);
2368 U8 *r = (U8*)SvPV(rstr, rlen);
2375 register short *tbl;
2377 PL_hints |= HINT_BLOCK_SCOPE;
2378 complement = o->op_private & OPpTRANS_COMPLEMENT;
2379 del = o->op_private & OPpTRANS_DELETE;
2380 squash = o->op_private & OPpTRANS_SQUASH;
2383 o->op_private |= OPpTRANS_FROM_UTF;
2386 o->op_private |= OPpTRANS_TO_UTF;
2388 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2389 SV* listsv = newSVpvn("# comment\n",10);
2391 U8* tend = t + tlen;
2392 U8* rend = r + rlen;
2406 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2407 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2413 tsave = t = bytes_to_utf8(t, &len);
2416 if (!to_utf && rlen) {
2418 rsave = r = bytes_to_utf8(r, &len);
2422 /* There are several snags with this code on EBCDIC:
2423 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2424 2. scan_const() in toke.c has encoded chars in native encoding which makes
2425 ranges at least in EBCDIC 0..255 range the bottom odd.
2429 U8 tmpbuf[UTF8_MAXBYTES+1];
2432 New(1109, cp, 2*tlen, UV);
2434 transv = newSVpvn("",0);
2436 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2438 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2440 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2444 cp[2*i+1] = cp[2*i];
2448 qsort(cp, i, 2*sizeof(UV), uvcompare);
2449 for (j = 0; j < i; j++) {
2451 diff = val - nextmin;
2453 t = uvuni_to_utf8(tmpbuf,nextmin);
2454 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2456 U8 range_mark = UTF_TO_NATIVE(0xff);
2457 t = uvuni_to_utf8(tmpbuf, val - 1);
2458 sv_catpvn(transv, (char *)&range_mark, 1);
2459 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2466 t = uvuni_to_utf8(tmpbuf,nextmin);
2467 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2469 U8 range_mark = UTF_TO_NATIVE(0xff);
2470 sv_catpvn(transv, (char *)&range_mark, 1);
2472 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2473 UNICODE_ALLOW_SUPER);
2474 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2475 t = (U8*)SvPVX(transv);
2476 tlen = SvCUR(transv);
2480 else if (!rlen && !del) {
2481 r = t; rlen = tlen; rend = tend;
2484 if ((!rlen && !del) || t == r ||
2485 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2487 o->op_private |= OPpTRANS_IDENTICAL;
2491 while (t < tend || tfirst <= tlast) {
2492 /* see if we need more "t" chars */
2493 if (tfirst > tlast) {
2494 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2496 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2498 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2505 /* now see if we need more "r" chars */
2506 if (rfirst > rlast) {
2508 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2510 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2512 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2521 rfirst = rlast = 0xffffffff;
2525 /* now see which range will peter our first, if either. */
2526 tdiff = tlast - tfirst;
2527 rdiff = rlast - rfirst;
2534 if (rfirst == 0xffffffff) {
2535 diff = tdiff; /* oops, pretend rdiff is infinite */
2537 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2538 (long)tfirst, (long)tlast);
2540 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2544 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2545 (long)tfirst, (long)(tfirst + diff),
2548 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2549 (long)tfirst, (long)rfirst);
2551 if (rfirst + diff > max)
2552 max = rfirst + diff;
2554 grows = (tfirst < rfirst &&
2555 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2567 else if (max > 0xff)
2572 Safefree(cPVOPo->op_pv);
2573 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2574 SvREFCNT_dec(listsv);
2576 SvREFCNT_dec(transv);
2578 if (!del && havefinal && rlen)
2579 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2580 newSVuv((UV)final), 0);
2583 o->op_private |= OPpTRANS_GROWS;
2595 tbl = (short*)cPVOPo->op_pv;
2597 Zero(tbl, 256, short);
2598 for (i = 0; i < (I32)tlen; i++)
2600 for (i = 0, j = 0; i < 256; i++) {
2602 if (j >= (I32)rlen) {
2611 if (i < 128 && r[j] >= 128)
2621 o->op_private |= OPpTRANS_IDENTICAL;
2623 else if (j >= (I32)rlen)
2626 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2627 tbl[0x100] = rlen - j;
2628 for (i=0; i < (I32)rlen - j; i++)
2629 tbl[0x101+i] = r[j+i];
2633 if (!rlen && !del) {
2636 o->op_private |= OPpTRANS_IDENTICAL;
2638 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2639 o->op_private |= OPpTRANS_IDENTICAL;
2641 for (i = 0; i < 256; i++)
2643 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
2644 if (j >= (I32)rlen) {
2646 if (tbl[t[i]] == -1)
2652 if (tbl[t[i]] == -1) {
2653 if (t[i] < 128 && r[j] >= 128)
2660 o->op_private |= OPpTRANS_GROWS;
2668 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2672 NewOp(1101, pmop, 1, PMOP);
2673 pmop->op_type = (OPCODE)type;
2674 pmop->op_ppaddr = PL_ppaddr[type];
2675 pmop->op_flags = (U8)flags;
2676 pmop->op_private = (U8)(0 | (flags >> 8));
2678 if (PL_hints & HINT_RE_TAINT)
2679 pmop->op_pmpermflags |= PMf_RETAINT;
2680 if (PL_hints & HINT_LOCALE)
2681 pmop->op_pmpermflags |= PMf_LOCALE;
2682 pmop->op_pmflags = pmop->op_pmpermflags;
2687 if(av_len((AV*) PL_regex_pad[0]) > -1) {
2688 repointer = av_pop((AV*)PL_regex_pad[0]);
2689 pmop->op_pmoffset = SvIV(repointer);
2690 SvREPADTMP_off(repointer);
2691 sv_setiv(repointer,0);
2693 repointer = newSViv(0);
2694 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2695 pmop->op_pmoffset = av_len(PL_regex_padav);
2696 PL_regex_pad = AvARRAY(PL_regex_padav);
2701 /* link into pm list */
2702 if (type != OP_TRANS && PL_curstash) {
2703 pmop->op_pmnext = HvPMROOT(PL_curstash);
2704 HvPMROOT(PL_curstash) = pmop;
2705 PmopSTASH_set(pmop,PL_curstash);
2708 return CHECKOP(type, pmop);
2711 /* Given some sort of match op o, and an expression expr containing a
2712 * pattern, either compile expr into a regex and attach it to o (if it's
2713 * constant), or convert expr into a runtime regcomp op sequence (if it's
2716 * isreg indicates that the pattern is part of a regex construct, eg
2717 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
2718 * split "pattern", which aren't. In the former case, expr will be a list
2719 * if the pattern contains more than one term (eg /a$b/) or if it contains
2720 * a replacement, ie s/// or tr///.
2724 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
2728 I32 repl_has_vars = 0;
2732 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
2733 /* last element in list is the replacement; pop it */
2735 repl = cLISTOPx(expr)->op_last;
2736 kid = cLISTOPx(expr)->op_first;
2737 while (kid->op_sibling != repl)
2738 kid = kid->op_sibling;
2739 kid->op_sibling = Nullop;
2740 cLISTOPx(expr)->op_last = kid;
2743 if (isreg && expr->op_type == OP_LIST &&
2744 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
2746 /* convert single element list to element */
2748 expr = cLISTOPx(oe)->op_first->op_sibling;
2749 cLISTOPx(oe)->op_first->op_sibling = Nullop;
2750 cLISTOPx(oe)->op_last = Nullop;
2754 if (o->op_type == OP_TRANS) {
2755 return pmtrans(o, expr, repl);
2758 reglist = isreg && expr->op_type == OP_LIST;
2762 PL_hints |= HINT_BLOCK_SCOPE;
2765 if (expr->op_type == OP_CONST) {
2767 SV *pat = ((SVOP*)expr)->op_sv;
2768 char *p = SvPV(pat, plen);
2769 if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
2770 sv_setpvn(pat, "\\s+", 3);
2771 p = SvPV(pat, plen);
2772 pm->op_pmflags |= PMf_SKIPWHITE;
2775 pm->op_pmdynflags |= PMdf_UTF8;
2776 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
2777 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
2778 pm->op_pmflags |= PMf_WHITE;
2782 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2783 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2785 : OP_REGCMAYBE),0,expr);
2787 NewOp(1101, rcop, 1, LOGOP);
2788 rcop->op_type = OP_REGCOMP;
2789 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2790 rcop->op_first = scalar(expr);
2791 rcop->op_flags |= OPf_KIDS
2792 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
2793 | (reglist ? OPf_STACKED : 0);
2794 rcop->op_private = 1;
2797 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
2799 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
2802 /* establish postfix order */
2803 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2805 rcop->op_next = expr;
2806 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2809 rcop->op_next = LINKLIST(expr);
2810 expr->op_next = (OP*)rcop;
2813 prepend_elem(o->op_type, scalar((OP*)rcop), o);
2818 if (pm->op_pmflags & PMf_EVAL) {
2820 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
2821 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
2823 else if (repl->op_type == OP_CONST)
2827 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
2828 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
2829 if (curop->op_type == OP_GV) {
2830 GV *gv = cGVOPx_gv(curop);
2832 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
2835 else if (curop->op_type == OP_RV2CV)
2837 else if (curop->op_type == OP_RV2SV ||
2838 curop->op_type == OP_RV2AV ||
2839 curop->op_type == OP_RV2HV ||
2840 curop->op_type == OP_RV2GV) {
2841 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2844 else if (curop->op_type == OP_PADSV ||
2845 curop->op_type == OP_PADAV ||
2846 curop->op_type == OP_PADHV ||
2847 curop->op_type == OP_PADANY) {
2850 else if (curop->op_type == OP_PUSHRE)
2851 ; /* Okay here, dangerous in newASSIGNOP */
2861 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
2862 pm->op_pmflags |= PMf_CONST; /* const for long enough */
2863 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
2864 prepend_elem(o->op_type, scalar(repl), o);
2867 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
2868 pm->op_pmflags |= PMf_MAYBE_CONST;
2869 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2871 NewOp(1101, rcop, 1, LOGOP);
2872 rcop->op_type = OP_SUBSTCONT;
2873 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
2874 rcop->op_first = scalar(repl);
2875 rcop->op_flags |= OPf_KIDS;
2876 rcop->op_private = 1;
2879 /* establish postfix order */
2880 rcop->op_next = LINKLIST(repl);
2881 repl->op_next = (OP*)rcop;
2883 pm->op_pmreplroot = scalar((OP*)rcop);
2884 pm->op_pmreplstart = LINKLIST(rcop);
2893 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
2896 NewOp(1101, svop, 1, SVOP);
2897 svop->op_type = (OPCODE)type;
2898 svop->op_ppaddr = PL_ppaddr[type];
2900 svop->op_next = (OP*)svop;
2901 svop->op_flags = (U8)flags;
2902 if (PL_opargs[type] & OA_RETSCALAR)
2904 if (PL_opargs[type] & OA_TARGET)
2905 svop->op_targ = pad_alloc(type, SVs_PADTMP);
2906 return CHECKOP(type, svop);
2910 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2913 NewOp(1101, padop, 1, PADOP);
2914 padop->op_type = (OPCODE)type;
2915 padop->op_ppaddr = PL_ppaddr[type];
2916 padop->op_padix = pad_alloc(type, SVs_PADTMP);
2917 SvREFCNT_dec(PAD_SVl(padop->op_padix));
2918 PAD_SETSV(padop->op_padix, sv);
2921 padop->op_next = (OP*)padop;
2922 padop->op_flags = (U8)flags;
2923 if (PL_opargs[type] & OA_RETSCALAR)
2925 if (PL_opargs[type] & OA_TARGET)
2926 padop->op_targ = pad_alloc(type, SVs_PADTMP);
2927 return CHECKOP(type, padop);
2931 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
2936 return newPADOP(type, flags, SvREFCNT_inc(gv));
2938 return newSVOP(type, flags, SvREFCNT_inc(gv));
2943 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
2946 NewOp(1101, pvop, 1, PVOP);
2947 pvop->op_type = (OPCODE)type;
2948 pvop->op_ppaddr = PL_ppaddr[type];
2950 pvop->op_next = (OP*)pvop;
2951 pvop->op_flags = (U8)flags;
2952 if (PL_opargs[type] & OA_RETSCALAR)
2954 if (PL_opargs[type] & OA_TARGET)
2955 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
2956 return CHECKOP(type, pvop);
2960 Perl_package(pTHX_ OP *o)
2965 save_hptr(&PL_curstash);
2966 save_item(PL_curstname);
2968 name = SvPV(cSVOPo->op_sv, len);
2969 PL_curstash = gv_stashpvn(name, len, TRUE);
2970 sv_setpvn(PL_curstname, name, len);
2973 PL_hints |= HINT_BLOCK_SCOPE;
2974 PL_copline = NOLINE;
2979 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
2985 if (idop->op_type != OP_CONST)
2986 Perl_croak(aTHX_ "Module name must be constant");
2990 if (version != Nullop) {
2991 SV *vesv = ((SVOP*)version)->op_sv;
2993 if (arg == Nullop && !SvNIOKp(vesv)) {
3000 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3001 Perl_croak(aTHX_ "Version number must be constant number");
3003 /* Make copy of idop so we don't free it twice */
3004 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3006 /* Fake up a method call to VERSION */
3007 meth = newSVpvn("VERSION",7);
3008 sv_upgrade(meth, SVt_PVIV);
3009 (void)SvIOK_on(meth);
3012 PERL_HASH(hash, SvPVX(meth), SvCUR(meth));
3013 SvUV_set(meth, hash);
3015 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3016 append_elem(OP_LIST,
3017 prepend_elem(OP_LIST, pack, list(version)),
3018 newSVOP(OP_METHOD_NAMED, 0, meth)));
3022 /* Fake up an import/unimport */
3023 if (arg && arg->op_type == OP_STUB)
3024 imop = arg; /* no import on explicit () */
3025 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3026 imop = Nullop; /* use 5.0; */
3031 /* Make copy of idop so we don't free it twice */
3032 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3034 /* Fake up a method call to import/unimport */
3035 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);
3036 (void)SvUPGRADE(meth, SVt_PVIV);
3037 (void)SvIOK_on(meth);
3040 PERL_HASH(hash, SvPVX(meth), SvCUR(meth));
3041 SvUV_set(meth, hash);
3043 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3044 append_elem(OP_LIST,
3045 prepend_elem(OP_LIST, pack, list(arg)),
3046 newSVOP(OP_METHOD_NAMED, 0, meth)));
3049 /* Fake up the BEGIN {}, which does its thing immediately. */
3051 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3054 append_elem(OP_LINESEQ,
3055 append_elem(OP_LINESEQ,
3056 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, idop)),
3057 newSTATEOP(0, Nullch, veop)),
3058 newSTATEOP(0, Nullch, imop) ));
3060 /* The "did you use incorrect case?" warning used to be here.
3061 * The problem is that on case-insensitive filesystems one
3062 * might get false positives for "use" (and "require"):
3063 * "use Strict" or "require CARP" will work. This causes
3064 * portability problems for the script: in case-strict
3065 * filesystems the script will stop working.
3067 * The "incorrect case" warning checked whether "use Foo"
3068 * imported "Foo" to your namespace, but that is wrong, too:
3069 * there is no requirement nor promise in the language that
3070 * a Foo.pm should or would contain anything in package "Foo".
3072 * There is very little Configure-wise that can be done, either:
3073 * the case-sensitivity of the build filesystem of Perl does not
3074 * help in guessing the case-sensitivity of the runtime environment.
3077 PL_hints |= HINT_BLOCK_SCOPE;
3078 PL_copline = NOLINE;
3080 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3084 =head1 Embedding Functions
3086 =for apidoc load_module
3088 Loads the module whose name is pointed to by the string part of name.
3089 Note that the actual module name, not its filename, should be given.
3090 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3091 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3092 (or 0 for no flags). ver, if specified, provides version semantics
3093 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3094 arguments can be used to specify arguments to the module's import()
3095 method, similar to C<use Foo::Bar VERSION LIST>.
3100 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3103 va_start(args, ver);
3104 vload_module(flags, name, ver, &args);
3108 #ifdef PERL_IMPLICIT_CONTEXT
3110 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3114 va_start(args, ver);
3115 vload_module(flags, name, ver, &args);
3121 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3123 OP *modname, *veop, *imop;
3125 modname = newSVOP(OP_CONST, 0, name);
3126 modname->op_private |= OPpCONST_BARE;
3128 veop = newSVOP(OP_CONST, 0, ver);
3132 if (flags & PERL_LOADMOD_NOIMPORT) {
3133 imop = sawparens(newNULLLIST());
3135 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3136 imop = va_arg(*args, OP*);
3141 sv = va_arg(*args, SV*);
3143 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3144 sv = va_arg(*args, SV*);
3148 const line_t ocopline = PL_copline;
3149 COP * const ocurcop = PL_curcop;
3150 const int oexpect = PL_expect;
3152 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3153 veop, modname, imop);
3154 PL_expect = oexpect;
3155 PL_copline = ocopline;
3156 PL_curcop = ocurcop;
3161 Perl_dofile(pTHX_ OP *term)
3166 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3167 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
3168 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3170 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3171 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3172 append_elem(OP_LIST, term,
3173 scalar(newUNOP(OP_RV2CV, 0,
3178 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3184 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3186 return newBINOP(OP_LSLICE, flags,
3187 list(force_list(subscript)),
3188 list(force_list(listval)) );
3192 S_list_assignment(pTHX_ register const OP *o)
3197 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3198 o = cUNOPo->op_first;
3200 if (o->op_type == OP_COND_EXPR) {
3201 const I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3202 const I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3207 yyerror("Assignment to both a list and a scalar");
3211 if (o->op_type == OP_LIST &&
3212 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3213 o->op_private & OPpLVAL_INTRO)
3216 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3217 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3218 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3221 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3224 if (o->op_type == OP_RV2SV)
3231 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3236 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3237 return newLOGOP(optype, 0,
3238 mod(scalar(left), optype),
3239 newUNOP(OP_SASSIGN, 0, scalar(right)));
3242 return newBINOP(optype, OPf_STACKED,
3243 mod(scalar(left), optype), scalar(right));
3247 if (list_assignment(left)) {
3251 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3252 left = mod(left, OP_AASSIGN);
3260 /* optimise C<my @x = ()> to C<my @x>, and likewise for hashes */
3261 if ((left->op_type == OP_PADAV || left->op_type == OP_PADHV)
3262 && right->op_type == OP_STUB
3263 && (left->op_private & OPpLVAL_INTRO))
3266 left->op_flags &= ~(OPf_REF|OPf_SPECIAL);
3269 curop = list(force_list(left));
3270 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3271 o->op_private = (U8)(0 | (flags >> 8));
3273 /* PL_generation sorcery:
3274 * an assignment like ($a,$b) = ($c,$d) is easier than
3275 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3276 * To detect whether there are common vars, the global var
3277 * PL_generation is incremented for each assign op we compile.
3278 * Then, while compiling the assign op, we run through all the
3279 * variables on both sides of the assignment, setting a spare slot
3280 * in each of them to PL_generation. If any of them already have
3281 * that value, we know we've got commonality. We could use a
3282 * single bit marker, but then we'd have to make 2 passes, first
3283 * to clear the flag, then to test and set it. To find somewhere
3284 * to store these values, evil chicanery is done with SvCUR().
3287 if (!(left->op_private & OPpLVAL_INTRO)) {
3290 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3291 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3292 if (curop->op_type == OP_GV) {
3293 GV *gv = cGVOPx_gv(curop);
3294 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3296 SvCUR(gv) = PL_generation;
3298 else if (curop->op_type == OP_PADSV ||
3299 curop->op_type == OP_PADAV ||
3300 curop->op_type == OP_PADHV ||
3301 curop->op_type == OP_PADANY)
3303 if (PAD_COMPNAME_GEN(curop->op_targ)
3304 == (STRLEN)PL_generation)
3306 PAD_COMPNAME_GEN(curop->op_targ)
3310 else if (curop->op_type == OP_RV2CV)
3312 else if (curop->op_type == OP_RV2SV ||
3313 curop->op_type == OP_RV2AV ||
3314 curop->op_type == OP_RV2HV ||
3315 curop->op_type == OP_RV2GV) {
3316 if (lastop->op_type != OP_GV) /* funny deref? */
3319 else if (curop->op_type == OP_PUSHRE) {
3320 if (((PMOP*)curop)->op_pmreplroot) {
3322 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3323 ((PMOP*)curop)->op_pmreplroot));
3325 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3327 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3329 SvCUR(gv) = PL_generation;
3338 o->op_private |= OPpASSIGN_COMMON;
3340 if (right && right->op_type == OP_SPLIT) {
3342 if ((tmpop = ((LISTOP*)right)->op_first) &&
3343 tmpop->op_type == OP_PUSHRE)
3345 PMOP *pm = (PMOP*)tmpop;
3346 if (left->op_type == OP_RV2AV &&
3347 !(left->op_private & OPpLVAL_INTRO) &&
3348 !(o->op_private & OPpASSIGN_COMMON) )
3350 tmpop = ((UNOP*)left)->op_first;
3351 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3353 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3354 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3356 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3357 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3359 pm->op_pmflags |= PMf_ONCE;
3360 tmpop = cUNOPo->op_first; /* to list (nulled) */
3361 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3362 tmpop->op_sibling = Nullop; /* don't free split */
3363 right->op_next = tmpop->op_next; /* fix starting loc */
3364 op_free(o); /* blow off assign */
3365 right->op_flags &= ~OPf_WANT;
3366 /* "I don't know and I don't care." */
3371 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3372 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3374 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3376 sv_setiv(sv, PL_modcount+1);
3384 right = newOP(OP_UNDEF, 0);
3385 if (right->op_type == OP_READLINE) {
3386 right->op_flags |= OPf_STACKED;
3387 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3390 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3391 o = newBINOP(OP_SASSIGN, flags,
3392 scalar(right), mod(scalar(left), OP_SASSIGN) );
3404 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3406 const U32 seq = intro_my();
3409 NewOp(1101, cop, 1, COP);
3410 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3411 cop->op_type = OP_DBSTATE;
3412 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3415 cop->op_type = OP_NEXTSTATE;
3416 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3418 cop->op_flags = (U8)flags;
3419 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3421 cop->op_private |= NATIVE_HINTS;
3423 PL_compiling.op_private = cop->op_private;
3424 cop->op_next = (OP*)cop;
3427 cop->cop_label = label;
3428 PL_hints |= HINT_BLOCK_SCOPE;
3431 cop->cop_arybase = PL_curcop->cop_arybase;
3432 if (specialWARN(PL_curcop->cop_warnings))
3433 cop->cop_warnings = PL_curcop->cop_warnings ;
3435 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3436 if (specialCopIO(PL_curcop->cop_io))
3437 cop->cop_io = PL_curcop->cop_io;
3439 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3442 if (PL_copline == NOLINE)
3443 CopLINE_set(cop, CopLINE(PL_curcop));
3445 CopLINE_set(cop, PL_copline);
3446 PL_copline = NOLINE;
3449 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3451 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3453 CopSTASH_set(cop, PL_curstash);
3455 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3456 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3457 if (svp && *svp != &PL_sv_undef ) {
3458 (void)SvIOK_on(*svp);
3459 SvIV_set(*svp, PTR2IV(cop));
3463 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3468 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3470 return new_logop(type, flags, &first, &other);
3474 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3478 OP *first = *firstp;
3479 OP *other = *otherp;
3481 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3482 return newBINOP(type, flags, scalar(first), scalar(other));
3484 scalarboolean(first);
3485 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3486 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3487 if (type == OP_AND || type == OP_OR) {
3493 first = *firstp = cUNOPo->op_first;
3495 first->op_next = o->op_next;
3496 cUNOPo->op_first = Nullop;
3500 if (first->op_type == OP_CONST) {
3501 if (first->op_private & OPpCONST_STRICT)
3502 no_bareword_allowed(first);
3503 else if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3504 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3505 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
3506 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
3507 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
3510 if (other->op_type == OP_CONST)
3511 other->op_private |= OPpCONST_SHORTCIRCUIT;
3515 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
3516 const OP *o2 = other;
3517 if ( ! (o2->op_type == OP_LIST
3518 && (( o2 = cUNOPx(o2)->op_first))
3519 && o2->op_type == OP_PUSHMARK
3520 && (( o2 = o2->op_sibling)) )
3523 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
3524 || o2->op_type == OP_PADHV)
3525 && o2->op_private & OPpLVAL_INTRO
3526 && ckWARN(WARN_DEPRECATED))
3528 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
3529 "Deprecated use of my() in false conditional");
3534 if (first->op_type == OP_CONST)
3535 first->op_private |= OPpCONST_SHORTCIRCUIT;
3539 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS) &&
3540 type != OP_DOR) /* [#24076] Don't warn for <FH> err FOO. */
3542 const OP *k1 = ((UNOP*)first)->op_first;
3543 const OP *k2 = k1->op_sibling;
3545 switch (first->op_type)
3548 if (k2 && k2->op_type == OP_READLINE
3549 && (k2->op_flags & OPf_STACKED)
3550 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3552 warnop = k2->op_type;
3557 if (k1->op_type == OP_READDIR
3558 || k1->op_type == OP_GLOB
3559 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3560 || k1->op_type == OP_EACH)
3562 warnop = ((k1->op_type == OP_NULL)
3563 ? (OPCODE)k1->op_targ : k1->op_type);
3568 const line_t oldline = CopLINE(PL_curcop);
3569 CopLINE_set(PL_curcop, PL_copline);
3570 Perl_warner(aTHX_ packWARN(WARN_MISC),
3571 "Value of %s%s can be \"0\"; test with defined()",
3573 ((warnop == OP_READLINE || warnop == OP_GLOB)
3574 ? " construct" : "() operator"));
3575 CopLINE_set(PL_curcop, oldline);
3582 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3583 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3585 NewOp(1101, logop, 1, LOGOP);
3587 logop->op_type = (OPCODE)type;
3588 logop->op_ppaddr = PL_ppaddr[type];
3589 logop->op_first = first;
3590 logop->op_flags = flags | OPf_KIDS;
3591 logop->op_other = LINKLIST(other);
3592 logop->op_private = (U8)(1 | (flags >> 8));
3594 /* establish postfix order */
3595 logop->op_next = LINKLIST(first);
3596 first->op_next = (OP*)logop;
3597 first->op_sibling = other;
3599 CHECKOP(type,logop);
3601 o = newUNOP(OP_NULL, 0, (OP*)logop);
3608 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3615 return newLOGOP(OP_AND, 0, first, trueop);
3617 return newLOGOP(OP_OR, 0, first, falseop);
3619 scalarboolean(first);
3620 if (first->op_type == OP_CONST) {
3621 if (first->op_private & OPpCONST_BARE &&
3622 first->op_private & OPpCONST_STRICT) {
3623 no_bareword_allowed(first);
3625 if (SvTRUE(((SVOP*)first)->op_sv)) {
3636 NewOp(1101, logop, 1, LOGOP);
3637 logop->op_type = OP_COND_EXPR;
3638 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3639 logop->op_first = first;
3640 logop->op_flags = flags | OPf_KIDS;
3641 logop->op_private = (U8)(1 | (flags >> 8));
3642 logop->op_other = LINKLIST(trueop);
3643 logop->op_next = LINKLIST(falseop);
3645 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
3648 /* establish postfix order */
3649 start = LINKLIST(first);
3650 first->op_next = (OP*)logop;
3652 first->op_sibling = trueop;
3653 trueop->op_sibling = falseop;
3654 o = newUNOP(OP_NULL, 0, (OP*)logop);
3656 trueop->op_next = falseop->op_next = o;
3663 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3671 NewOp(1101, range, 1, LOGOP);
3673 range->op_type = OP_RANGE;
3674 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3675 range->op_first = left;
3676 range->op_flags = OPf_KIDS;
3677 leftstart = LINKLIST(left);
3678 range->op_other = LINKLIST(right);
3679 range->op_private = (U8)(1 | (flags >> 8));
3681 left->op_sibling = right;
3683 range->op_next = (OP*)range;
3684 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3685 flop = newUNOP(OP_FLOP, 0, flip);
3686 o = newUNOP(OP_NULL, 0, flop);
3688 range->op_next = leftstart;
3690 left->op_next = flip;
3691 right->op_next = flop;
3693 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3694 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3695 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3696 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3698 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3699 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3702 if (!flip->op_private || !flop->op_private)
3703 linklist(o); /* blow off optimizer unless constant */
3709 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3713 const bool once = block && block->op_flags & OPf_SPECIAL &&
3714 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3718 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3719 return block; /* do {} while 0 does once */
3720 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3721 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3722 expr = newUNOP(OP_DEFINED, 0,
3723 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3724 } else if (expr->op_flags & OPf_KIDS) {
3725 const OP *k1 = ((UNOP*)expr)->op_first;
3726 const OP *k2 = (k1) ? k1->op_sibling : NULL;
3727 switch (expr->op_type) {
3729 if (k2 && k2->op_type == OP_READLINE
3730 && (k2->op_flags & OPf_STACKED)
3731 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3732 expr = newUNOP(OP_DEFINED, 0, expr);
3736 if (k1->op_type == OP_READDIR
3737 || k1->op_type == OP_GLOB
3738 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3739 || k1->op_type == OP_EACH)
3740 expr = newUNOP(OP_DEFINED, 0, expr);
3746 /* if block is null, the next append_elem() would put UNSTACK, a scalar
3747 * op, in listop. This is wrong. [perl #27024] */
3749 block = newOP(OP_NULL, 0);
3750 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3751 o = new_logop(OP_AND, 0, &expr, &listop);
3754 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3756 if (once && o != listop)
3757 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3760 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3762 o->op_flags |= flags;
3764 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3769 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3778 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3779 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3780 expr = newUNOP(OP_DEFINED, 0,
3781 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3782 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3783 const OP *k1 = ((UNOP*)expr)->op_first;
3784 const OP *k2 = (k1) ? k1->op_sibling : NULL;
3785 switch (expr->op_type) {
3787 if (k2 && k2->op_type == OP_READLINE
3788 && (k2->op_flags & OPf_STACKED)
3789 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3790 expr = newUNOP(OP_DEFINED, 0, expr);
3794 if (k1->op_type == OP_READDIR
3795 || k1->op_type == OP_GLOB
3796 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3797 || k1->op_type == OP_EACH)
3798 expr = newUNOP(OP_DEFINED, 0, expr);
3804 block = newOP(OP_NULL, 0);
3806 block = scope(block);
3810 next = LINKLIST(cont);
3813 OP *unstack = newOP(OP_UNSTACK, 0);
3816 cont = append_elem(OP_LINESEQ, cont, unstack);
3819 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3820 redo = LINKLIST(listop);
3823 PL_copline = (line_t)whileline;
3825 o = new_logop(OP_AND, 0, &expr, &listop);
3826 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3827 op_free(expr); /* oops, it's a while (0) */
3829 return Nullop; /* listop already freed by new_logop */
3832 ((LISTOP*)listop)->op_last->op_next =
3833 (o == listop ? redo : LINKLIST(o));
3839 NewOp(1101,loop,1,LOOP);
3840 loop->op_type = OP_ENTERLOOP;
3841 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3842 loop->op_private = 0;
3843 loop->op_next = (OP*)loop;
3846 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3848 loop->op_redoop = redo;
3849 loop->op_lastop = o;
3850 o->op_private |= loopflags;
3853 loop->op_nextop = next;
3855 loop->op_nextop = o;
3857 o->op_flags |= flags;
3858 o->op_private |= (flags >> 8);
3863 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
3867 PADOFFSET padoff = 0;
3872 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
3873 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
3874 sv->op_type = OP_RV2GV;
3875 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3877 else if (sv->op_type == OP_PADSV) { /* private variable */
3878 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
3879 padoff = sv->op_targ;
3884 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3885 padoff = sv->op_targ;
3887 iterflags |= OPf_SPECIAL;
3892 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3895 const I32 offset = pad_findmy("$_");
3896 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
3897 sv = newGVOP(OP_GV, 0, PL_defgv);
3903 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3904 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3905 iterflags |= OPf_STACKED;
3907 else if (expr->op_type == OP_NULL &&
3908 (expr->op_flags & OPf_KIDS) &&
3909 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3911 /* Basically turn for($x..$y) into the same as for($x,$y), but we
3912 * set the STACKED flag to indicate that these values are to be
3913 * treated as min/max values by 'pp_iterinit'.
3915 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
3916 LOGOP* range = (LOGOP*) flip->op_first;
3917 OP* left = range->op_first;
3918 OP* right = left->op_sibling;
3921 range->op_flags &= ~OPf_KIDS;
3922 range->op_first = Nullop;
3924 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
3925 listop->op_first->op_next = range->op_next;
3926 left->op_next = range->op_other;
3927 right->op_next = (OP*)listop;
3928 listop->op_next = listop->op_first;
3931 expr = (OP*)(listop);
3933 iterflags |= OPf_STACKED;
3936 expr = mod(force_list(expr), OP_GREPSTART);
3939 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
3940 append_elem(OP_LIST, expr, scalar(sv))));
3941 assert(!loop->op_next);
3942 /* for my $x () sets OPpLVAL_INTRO;
3943 * for our $x () sets OPpOUR_INTRO */
3944 loop->op_private = (U8)iterpflags;
3945 #ifdef PL_OP_SLAB_ALLOC
3948 NewOp(1234,tmp,1,LOOP);
3949 Copy(loop,tmp,1,LISTOP);
3954 Renew(loop, 1, LOOP);
3956 loop->op_targ = padoff;
3957 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
3958 PL_copline = forline;
3959 return newSTATEOP(0, label, wop);
3963 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
3968 if (type != OP_GOTO || label->op_type == OP_CONST) {
3969 /* "last()" means "last" */
3970 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
3971 o = newOP(type, OPf_SPECIAL);
3973 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
3974 ? SvPVx(((SVOP*)label)->op_sv, n_a)
3980 /* Check whether it's going to be a goto &function */
3981 if (label->op_type == OP_ENTERSUB
3982 && !(label->op_flags & OPf_STACKED))
3983 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
3984 o = newUNOP(type, OPf_STACKED, label);
3986 PL_hints |= HINT_BLOCK_SCOPE;
3991 =for apidoc cv_undef
3993 Clear out all the active components of a CV. This can happen either
3994 by an explicit C<undef &foo>, or by the reference count going to zero.
3995 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
3996 children can still follow the full lexical scope chain.
4002 Perl_cv_undef(pTHX_ CV *cv)
4005 if (CvFILE(cv) && !CvXSUB(cv)) {
4006 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4007 Safefree(CvFILE(cv));
4012 if (!CvXSUB(cv) && CvROOT(cv)) {
4014 Perl_croak(aTHX_ "Can't undef active subroutine");
4017 PAD_SAVE_SETNULLPAD();
4019 op_free(CvROOT(cv));
4020 CvROOT(cv) = Nullop;
4023 SvPOK_off((SV*)cv); /* forget prototype */
4028 /* remove CvOUTSIDE unless this is an undef rather than a free */
4029 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4030 if (!CvWEAKOUTSIDE(cv))
4031 SvREFCNT_dec(CvOUTSIDE(cv));
4032 CvOUTSIDE(cv) = Nullcv;
4035 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4041 /* delete all flags except WEAKOUTSIDE */
4042 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4046 Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p)
4048 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4049 SV* msg = sv_newmortal();
4053 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4054 sv_setpv(msg, "Prototype mismatch:");
4056 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4058 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (const SV *)cv);
4060 Perl_sv_catpv(aTHX_ msg, ": none");
4061 sv_catpv(msg, " vs ");
4063 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4065 sv_catpv(msg, "none");
4066 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
4070 static void const_sv_xsub(pTHX_ CV* cv);
4074 =head1 Optree Manipulation Functions
4076 =for apidoc cv_const_sv
4078 If C<cv> is a constant sub eligible for inlining. returns the constant
4079 value returned by the sub. Otherwise, returns NULL.
4081 Constant subs can be created with C<newCONSTSUB> or as described in
4082 L<perlsub/"Constant Functions">.
4087 Perl_cv_const_sv(pTHX_ CV *cv)
4089 if (!cv || !CvCONST(cv))
4091 return (SV*)CvXSUBANY(cv).any_ptr;
4094 /* op_const_sv: examine an optree to determine whether it's in-lineable.
4095 * Can be called in 3 ways:
4098 * look for a single OP_CONST with attached value: return the value
4100 * cv && CvCLONE(cv) && !CvCONST(cv)
4102 * examine the clone prototype, and if contains only a single
4103 * OP_CONST referencing a pad const, or a single PADSV referencing
4104 * an outer lexical, return a non-zero value to indicate the CV is
4105 * a candidate for "constizing" at clone time
4109 * We have just cloned an anon prototype that was marked as a const
4110 * candidiate. Try to grab the current value, and in the case of
4111 * PADSV, ignore it if it has multiple references. Return the value.
4115 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
4122 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4123 o = cLISTOPo->op_first->op_sibling;
4125 for (; o; o = o->op_next) {
4126 OPCODE type = o->op_type;
4128 if (sv && o->op_next == o)
4130 if (o->op_next != o) {
4131 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4133 if (type == OP_DBSTATE)
4136 if (type == OP_LEAVESUB || type == OP_RETURN)
4140 if (type == OP_CONST && cSVOPo->op_sv)
4142 else if (cv && type == OP_CONST) {
4143 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4147 else if (cv && type == OP_PADSV) {
4148 if (CvCONST(cv)) { /* newly cloned anon */
4149 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4150 /* the candidate should have 1 ref from this pad and 1 ref
4151 * from the parent */
4152 if (!sv || SvREFCNT(sv) != 2)
4159 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4160 sv = &PL_sv_undef; /* an arbitrary non-null value */
4171 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4182 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4186 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4188 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4192 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4202 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4205 assert(proto->op_type == OP_CONST);
4206 ps = SvPVx(((SVOP*)proto)->op_sv, n_a);
4211 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4212 SV *sv = sv_newmortal();
4213 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4214 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4215 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4220 gv = name ? gv_fetchsv(cSVOPo->op_sv,
4221 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4223 : gv_fetchpv(aname ? aname
4224 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4225 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4235 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4236 maximum a prototype before. */
4237 if (SvTYPE(gv) > SVt_NULL) {
4238 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4239 && ckWARN_d(WARN_PROTOTYPE))
4241 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4243 cv_ckproto((CV*)gv, NULL, ps);
4246 sv_setpv((SV*)gv, ps);
4248 sv_setiv((SV*)gv, -1);
4249 SvREFCNT_dec(PL_compcv);
4250 cv = PL_compcv = NULL;
4251 PL_sub_generation++;
4255 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4257 #ifdef GV_UNIQUE_CHECK
4258 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4259 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4263 if (!block || !ps || *ps || attrs)
4266 const_sv = op_const_sv(block, Nullcv);
4269 const bool exists = CvROOT(cv) || CvXSUB(cv);
4271 #ifdef GV_UNIQUE_CHECK
4272 if (exists && GvUNIQUE(gv)) {
4273 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4277 /* if the subroutine doesn't exist and wasn't pre-declared
4278 * with a prototype, assume it will be AUTOLOADed,
4279 * skipping the prototype check
4281 if (exists || SvPOK(cv))
4282 cv_ckproto(cv, gv, ps);
4283 /* already defined (or promised)? */
4284 if (exists || GvASSUMECV(gv)) {
4285 if (!block && !attrs) {
4286 if (CvFLAGS(PL_compcv)) {
4287 /* might have had built-in attrs applied */
4288 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4290 /* just a "sub foo;" when &foo is already defined */
4291 SAVEFREESV(PL_compcv);
4294 /* ahem, death to those who redefine active sort subs */
4295 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4296 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4298 if (ckWARN(WARN_REDEFINE)
4300 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4302 const line_t oldline = CopLINE(PL_curcop);
4303 if (PL_copline != NOLINE)
4304 CopLINE_set(PL_curcop, PL_copline);
4305 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4306 CvCONST(cv) ? "Constant subroutine %s redefined"
4307 : "Subroutine %s redefined", name);
4308 CopLINE_set(PL_curcop, oldline);
4316 (void)SvREFCNT_inc(const_sv);
4318 assert(!CvROOT(cv) && !CvCONST(cv));
4319 sv_setpv((SV*)cv, ""); /* prototype is "" */
4320 CvXSUBANY(cv).any_ptr = const_sv;
4321 CvXSUB(cv) = const_sv_xsub;
4326 cv = newCONSTSUB(NULL, name, const_sv);
4329 SvREFCNT_dec(PL_compcv);
4331 PL_sub_generation++;
4338 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4339 * before we clobber PL_compcv.
4343 /* Might have had built-in attributes applied -- propagate them. */
4344 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4345 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4346 stash = GvSTASH(CvGV(cv));
4347 else if (CvSTASH(cv))
4348 stash = CvSTASH(cv);
4350 stash = PL_curstash;
4353 /* possibly about to re-define existing subr -- ignore old cv */
4354 rcv = (SV*)PL_compcv;
4355 if (name && GvSTASH(gv))
4356 stash = GvSTASH(gv);
4358 stash = PL_curstash;
4360 apply_attrs(stash, rcv, attrs, FALSE);
4362 if (cv) { /* must reuse cv if autoloaded */
4364 /* got here with just attrs -- work done, so bug out */
4365 SAVEFREESV(PL_compcv);
4368 /* transfer PL_compcv to cv */
4370 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4371 if (!CvWEAKOUTSIDE(cv))
4372 SvREFCNT_dec(CvOUTSIDE(cv));
4373 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4374 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4375 CvOUTSIDE(PL_compcv) = 0;
4376 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4377 CvPADLIST(PL_compcv) = 0;
4378 /* inner references to PL_compcv must be fixed up ... */
4379 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4380 /* ... before we throw it away */
4381 SvREFCNT_dec(PL_compcv);
4383 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4384 ++PL_sub_generation;
4391 PL_sub_generation++;
4395 CvFILE_set_from_cop(cv, PL_curcop);
4396 CvSTASH(cv) = PL_curstash;
4399 sv_setpv((SV*)cv, ps);
4401 if (PL_error_count) {
4405 const char *s = strrchr(name, ':');
4407 if (strEQ(s, "BEGIN")) {
4408 const char not_safe[] =
4409 "BEGIN not safe after errors--compilation aborted";
4410 if (PL_in_eval & EVAL_KEEPERR)
4411 Perl_croak(aTHX_ not_safe);
4413 /* force display of errors found but not reported */
4414 sv_catpv(ERRSV, not_safe);
4415 Perl_croak(aTHX_ "%"SVf, ERRSV);
4424 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4425 mod(scalarseq(block), OP_LEAVESUBLV));
4428 /* This makes sub {}; work as expected. */
4429 if (block->op_type == OP_STUB) {
4431 block = newSTATEOP(0, Nullch, 0);
4433 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4435 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4436 OpREFCNT_set(CvROOT(cv), 1);
4437 CvSTART(cv) = LINKLIST(CvROOT(cv));
4438 CvROOT(cv)->op_next = 0;
4439 CALL_PEEP(CvSTART(cv));
4441 /* now that optimizer has done its work, adjust pad values */
4443 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4446 assert(!CvCONST(cv));
4447 if (ps && !*ps && op_const_sv(block, cv))
4451 if (name || aname) {
4453 const char *tname = (name ? name : aname);
4455 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4456 SV *sv = NEWSV(0,0);
4457 SV *tmpstr = sv_newmortal();
4458 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4462 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4464 (long)PL_subline, (long)CopLINE(PL_curcop));
4465 gv_efullname3(tmpstr, gv, Nullch);
4466 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4467 hv = GvHVn(db_postponed);
4468 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4469 && (pcv = GvCV(db_postponed)))
4475 call_sv((SV*)pcv, G_DISCARD);
4479 if ((s = strrchr(tname,':')))
4484 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4487 if (strEQ(s, "BEGIN") && !PL_error_count) {
4488 const I32 oldscope = PL_scopestack_ix;
4490 SAVECOPFILE(&PL_compiling);
4491 SAVECOPLINE(&PL_compiling);
4494 PL_beginav = newAV();
4495 DEBUG_x( dump_sub(gv) );
4496 av_push(PL_beginav, (SV*)cv);
4497 GvCV(gv) = 0; /* cv has been hijacked */
4498 call_list(oldscope, PL_beginav);
4500 PL_curcop = &PL_compiling;
4501 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4504 else if (strEQ(s, "END") && !PL_error_count) {
4507 DEBUG_x( dump_sub(gv) );
4508 av_unshift(PL_endav, 1);
4509 av_store(PL_endav, 0, (SV*)cv);
4510 GvCV(gv) = 0; /* cv has been hijacked */
4512 else if (strEQ(s, "CHECK") && !PL_error_count) {
4514 PL_checkav = newAV();
4515 DEBUG_x( dump_sub(gv) );
4516 if (PL_main_start && ckWARN(WARN_VOID))
4517 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4518 av_unshift(PL_checkav, 1);
4519 av_store(PL_checkav, 0, (SV*)cv);
4520 GvCV(gv) = 0; /* cv has been hijacked */
4522 else if (strEQ(s, "INIT") && !PL_error_count) {
4524 PL_initav = newAV();
4525 DEBUG_x( dump_sub(gv) );
4526 if (PL_main_start && ckWARN(WARN_VOID))
4527 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4528 av_push(PL_initav, (SV*)cv);
4529 GvCV(gv) = 0; /* cv has been hijacked */
4534 PL_copline = NOLINE;
4539 /* XXX unsafe for threads if eval_owner isn't held */
4541 =for apidoc newCONSTSUB
4543 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4544 eligible for inlining at compile-time.
4550 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
4556 SAVECOPLINE(PL_curcop);
4557 CopLINE_set(PL_curcop, PL_copline);
4560 PL_hints &= ~HINT_BLOCK_SCOPE;
4563 SAVESPTR(PL_curstash);
4564 SAVECOPSTASH(PL_curcop);
4565 PL_curstash = stash;
4566 CopSTASH_set(PL_curcop,stash);
4569 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4570 CvXSUBANY(cv).any_ptr = sv;
4572 sv_setpv((SV*)cv, ""); /* prototype is "" */
4575 CopSTASH_free(PL_curcop);
4583 =for apidoc U||newXS
4585 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4591 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
4593 GV *gv = gv_fetchpv(name ? name :
4594 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4595 GV_ADDMULTI, SVt_PVCV);
4599 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4601 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4603 /* just a cached method */
4607 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4608 /* already defined (or promised) */
4609 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4610 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4611 const line_t oldline = CopLINE(PL_curcop);
4612 if (PL_copline != NOLINE)
4613 CopLINE_set(PL_curcop, PL_copline);
4614 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4615 CvCONST(cv) ? "Constant subroutine %s redefined"
4616 : "Subroutine %s redefined"
4618 CopLINE_set(PL_curcop, oldline);
4625 if (cv) /* must reuse cv if autoloaded */
4628 cv = (CV*)NEWSV(1105,0);
4629 sv_upgrade((SV *)cv, SVt_PVCV);
4633 PL_sub_generation++;
4637 (void)gv_fetchfile(filename);
4638 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
4639 an external constant string */
4640 CvXSUB(cv) = subaddr;
4643 const char *s = strrchr(name,':');
4649 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4652 if (strEQ(s, "BEGIN")) {
4654 PL_beginav = newAV();
4655 av_push(PL_beginav, (SV*)cv);
4656 GvCV(gv) = 0; /* cv has been hijacked */
4658 else if (strEQ(s, "END")) {
4661 av_unshift(PL_endav, 1);
4662 av_store(PL_endav, 0, (SV*)cv);
4663 GvCV(gv) = 0; /* cv has been hijacked */
4665 else if (strEQ(s, "CHECK")) {
4667 PL_checkav = newAV();
4668 if (PL_main_start && ckWARN(WARN_VOID))
4669 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4670 av_unshift(PL_checkav, 1);
4671 av_store(PL_checkav, 0, (SV*)cv);
4672 GvCV(gv) = 0; /* cv has been hijacked */
4674 else if (strEQ(s, "INIT")) {
4676 PL_initav = newAV();
4677 if (PL_main_start && ckWARN(WARN_VOID))
4678 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4679 av_push(PL_initav, (SV*)cv);
4680 GvCV(gv) = 0; /* cv has been hijacked */
4691 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4697 gv = gv_fetchsv(cSVOPo->op_sv, TRUE, SVt_PVFM);
4699 gv = gv_fetchpv("STDOUT", TRUE, SVt_PVFM);
4701 #ifdef GV_UNIQUE_CHECK
4703 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4707 if ((cv = GvFORM(gv))) {
4708 if (ckWARN(WARN_REDEFINE)) {
4709 const line_t oldline = CopLINE(PL_curcop);
4710 if (PL_copline != NOLINE)
4711 CopLINE_set(PL_curcop, PL_copline);
4712 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4713 o ? "Format %"SVf" redefined"
4714 : "Format STDOUT redefined" ,cSVOPo->op_sv);
4715 CopLINE_set(PL_curcop, oldline);
4722 CvFILE_set_from_cop(cv, PL_curcop);
4725 pad_tidy(padtidy_FORMAT);
4726 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4727 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4728 OpREFCNT_set(CvROOT(cv), 1);
4729 CvSTART(cv) = LINKLIST(CvROOT(cv));
4730 CvROOT(cv)->op_next = 0;
4731 CALL_PEEP(CvSTART(cv));
4733 PL_copline = NOLINE;
4738 Perl_newANONLIST(pTHX_ OP *o)
4740 return newUNOP(OP_REFGEN, 0,
4741 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4745 Perl_newANONHASH(pTHX_ OP *o)
4747 return newUNOP(OP_REFGEN, 0,
4748 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4752 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4754 return newANONATTRSUB(floor, proto, Nullop, block);
4758 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4760 return newUNOP(OP_REFGEN, 0,
4761 newSVOP(OP_ANONCODE, 0,
4762 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
4766 Perl_oopsAV(pTHX_ OP *o)
4768 switch (o->op_type) {
4770 o->op_type = OP_PADAV;
4771 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4772 return ref(o, OP_RV2AV);
4775 o->op_type = OP_RV2AV;
4776 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4781 if (ckWARN_d(WARN_INTERNAL))
4782 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
4789 Perl_oopsHV(pTHX_ OP *o)
4791 switch (o->op_type) {
4794 o->op_type = OP_PADHV;
4795 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4796 return ref(o, OP_RV2HV);
4800 o->op_type = OP_RV2HV;
4801 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
4806 if (ckWARN_d(WARN_INTERNAL))
4807 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
4814 Perl_newAVREF(pTHX_ OP *o)
4816 if (o->op_type == OP_PADANY) {
4817 o->op_type = OP_PADAV;
4818 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4821 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
4822 && ckWARN(WARN_DEPRECATED)) {
4823 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4824 "Using an array as a reference is deprecated");
4826 return newUNOP(OP_RV2AV, 0, scalar(o));
4830 Perl_newGVREF(pTHX_ I32 type, OP *o)
4832 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
4833 return newUNOP(OP_NULL, 0, o);
4834 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
4838 Perl_newHVREF(pTHX_ OP *o)
4840 if (o->op_type == OP_PADANY) {
4841 o->op_type = OP_PADHV;
4842 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4845 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
4846 && ckWARN(WARN_DEPRECATED)) {
4847 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4848 "Using a hash as a reference is deprecated");
4850 return newUNOP(OP_RV2HV, 0, scalar(o));
4854 Perl_oopsCV(pTHX_ OP *o)
4856 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
4859 #ifndef HASATTRIBUTE
4860 /* No __attribute__, so the compiler doesn't know that croak never returns
4867 Perl_newCVREF(pTHX_ I32 flags, OP *o)
4869 return newUNOP(OP_RV2CV, flags, scalar(o));
4873 Perl_newSVREF(pTHX_ OP *o)
4875 if (o->op_type == OP_PADANY) {
4876 o->op_type = OP_PADSV;
4877 o->op_ppaddr = PL_ppaddr[OP_PADSV];
4880 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4881 o->op_flags |= OPpDONE_SVREF;
4884 return newUNOP(OP_RV2SV, 0, scalar(o));
4887 /* Check routines. See the comments at the top of this file for details
4888 * on when these are called */
4891 Perl_ck_anoncode(pTHX_ OP *o)
4893 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
4894 cSVOPo->op_sv = Nullsv;
4899 Perl_ck_bitop(pTHX_ OP *o)
4901 #define OP_IS_NUMCOMPARE(op) \
4902 ((op) == OP_LT || (op) == OP_I_LT || \
4903 (op) == OP_GT || (op) == OP_I_GT || \
4904 (op) == OP_LE || (op) == OP_I_LE || \
4905 (op) == OP_GE || (op) == OP_I_GE || \
4906 (op) == OP_EQ || (op) == OP_I_EQ || \
4907 (op) == OP_NE || (op) == OP_I_NE || \
4908 (op) == OP_NCMP || (op) == OP_I_NCMP)
4909 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4910 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
4911 && (o->op_type == OP_BIT_OR
4912 || o->op_type == OP_BIT_AND
4913 || o->op_type == OP_BIT_XOR))
4915 const OP * left = cBINOPo->op_first;
4916 const OP * right = left->op_sibling;
4917 if ((OP_IS_NUMCOMPARE(left->op_type) &&
4918 (left->op_flags & OPf_PARENS) == 0) ||
4919 (OP_IS_NUMCOMPARE(right->op_type) &&
4920 (right->op_flags & OPf_PARENS) == 0))
4921 if (ckWARN(WARN_PRECEDENCE))
4922 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4923 "Possible precedence problem on bitwise %c operator",
4924 o->op_type == OP_BIT_OR ? '|'
4925 : o->op_type == OP_BIT_AND ? '&' : '^'
4932 Perl_ck_concat(pTHX_ OP *o)
4934 const OP *kid = cUNOPo->op_first;
4935 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
4936 !(kUNOP->op_first->op_flags & OPf_MOD))
4937 o->op_flags |= OPf_STACKED;
4942 Perl_ck_spair(pTHX_ OP *o)
4944 if (o->op_flags & OPf_KIDS) {
4947 const OPCODE type = o->op_type;
4948 o = modkids(ck_fun(o), type);
4949 kid = cUNOPo->op_first;
4950 newop = kUNOP->op_first->op_sibling;
4952 (newop->op_sibling ||
4953 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
4954 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
4955 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
4959 op_free(kUNOP->op_first);
4960 kUNOP->op_first = newop;
4962 o->op_ppaddr = PL_ppaddr[++o->op_type];
4967 Perl_ck_delete(pTHX_ OP *o)
4971 if (o->op_flags & OPf_KIDS) {
4972 OP *kid = cUNOPo->op_first;
4973 switch (kid->op_type) {
4975 o->op_flags |= OPf_SPECIAL;
4978 o->op_private |= OPpSLICE;
4981 o->op_flags |= OPf_SPECIAL;
4986 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
4995 Perl_ck_die(pTHX_ OP *o)
4998 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5004 Perl_ck_eof(pTHX_ OP *o)
5006 const I32 type = o->op_type;
5008 if (o->op_flags & OPf_KIDS) {
5009 if (cLISTOPo->op_first->op_type == OP_STUB) {
5011 o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
5019 Perl_ck_eval(pTHX_ OP *o)
5021 PL_hints |= HINT_BLOCK_SCOPE;
5022 if (o->op_flags & OPf_KIDS) {
5023 SVOP *kid = (SVOP*)cUNOPo->op_first;
5026 o->op_flags &= ~OPf_KIDS;
5029 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
5032 cUNOPo->op_first = 0;
5035 NewOp(1101, enter, 1, LOGOP);
5036 enter->op_type = OP_ENTERTRY;
5037 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5038 enter->op_private = 0;
5040 /* establish postfix order */
5041 enter->op_next = (OP*)enter;
5043 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5044 o->op_type = OP_LEAVETRY;
5045 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5046 enter->op_other = o;
5056 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5058 o->op_targ = (PADOFFSET)PL_hints;
5063 Perl_ck_exit(pTHX_ OP *o)
5066 HV *table = GvHV(PL_hintgv);
5068 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5069 if (svp && *svp && SvTRUE(*svp))
5070 o->op_private |= OPpEXIT_VMSISH;
5072 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5078 Perl_ck_exec(pTHX_ OP *o)
5080 if (o->op_flags & OPf_STACKED) {
5083 kid = cUNOPo->op_first->op_sibling;
5084 if (kid->op_type == OP_RV2GV)
5093 Perl_ck_exists(pTHX_ OP *o)
5096 if (o->op_flags & OPf_KIDS) {
5097 OP *kid = cUNOPo->op_first;
5098 if (kid->op_type == OP_ENTERSUB) {
5099 (void) ref(kid, o->op_type);
5100 if (kid->op_type != OP_RV2CV && !PL_error_count)
5101 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5103 o->op_private |= OPpEXISTS_SUB;
5105 else if (kid->op_type == OP_AELEM)
5106 o->op_flags |= OPf_SPECIAL;
5107 else if (kid->op_type != OP_HELEM)
5108 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5117 Perl_ck_gvconst(pTHX_ register OP *o)
5119 o = fold_constants(o);
5120 if (o->op_type == OP_CONST)
5127 Perl_ck_rvconst(pTHX_ register OP *o)
5129 SVOP *kid = (SVOP*)cUNOPo->op_first;
5131 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5132 if (kid->op_type == OP_CONST) {
5135 SV *kidsv = kid->op_sv;
5137 /* Is it a constant from cv_const_sv()? */
5138 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5139 SV *rsv = SvRV(kidsv);
5140 int svtype = SvTYPE(rsv);
5141 const char *badtype = Nullch;
5143 switch (o->op_type) {
5145 if (svtype > SVt_PVMG)
5146 badtype = "a SCALAR";
5149 if (svtype != SVt_PVAV)
5150 badtype = "an ARRAY";
5153 if (svtype != SVt_PVHV)
5157 if (svtype != SVt_PVCV)
5162 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5165 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5166 const char *badthing = Nullch;
5167 switch (o->op_type) {
5169 badthing = "a SCALAR";
5172 badthing = "an ARRAY";
5175 badthing = "a HASH";
5180 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
5184 * This is a little tricky. We only want to add the symbol if we
5185 * didn't add it in the lexer. Otherwise we get duplicate strict
5186 * warnings. But if we didn't add it in the lexer, we must at
5187 * least pretend like we wanted to add it even if it existed before,
5188 * or we get possible typo warnings. OPpCONST_ENTERED says
5189 * whether the lexer already added THIS instance of this symbol.
5191 iscv = (o->op_type == OP_RV2CV) * 2;
5193 gv = gv_fetchsv(kidsv,
5194 iscv | !(kid->op_private & OPpCONST_ENTERED),
5197 : o->op_type == OP_RV2SV
5199 : o->op_type == OP_RV2AV
5201 : o->op_type == OP_RV2HV
5204 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5206 kid->op_type = OP_GV;
5207 SvREFCNT_dec(kid->op_sv);
5209 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5210 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5211 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
5213 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
5215 kid->op_sv = SvREFCNT_inc(gv);
5217 kid->op_private = 0;
5218 kid->op_ppaddr = PL_ppaddr[OP_GV];
5225 Perl_ck_ftst(pTHX_ OP *o)
5227 const I32 type = o->op_type;
5229 if (o->op_flags & OPf_REF) {
5232 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5233 SVOP *kid = (SVOP*)cUNOPo->op_first;
5235 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5236 OP *newop = newGVOP(type, OPf_REF,
5237 gv_fetchsv(kid->op_sv, TRUE, SVt_PVIO));
5243 if ((PL_hints & HINT_FILETEST_ACCESS) &&
5244 OP_IS_FILETEST_ACCESS(o))
5245 o->op_private |= OPpFT_ACCESS;
5247 if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
5248 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
5249 o->op_private |= OPpFT_STACKED;
5253 if (type == OP_FTTTY)
5254 o = newGVOP(type, OPf_REF, PL_stdingv);
5256 o = newUNOP(type, 0, newDEFSVOP());
5262 Perl_ck_fun(pTHX_ OP *o)
5264 const int type = o->op_type;
5265 register I32 oa = PL_opargs[type] >> OASHIFT;
5267 if (o->op_flags & OPf_STACKED) {
5268 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5271 return no_fh_allowed(o);
5274 if (o->op_flags & OPf_KIDS) {
5275 OP **tokid = &cLISTOPo->op_first;
5276 register OP *kid = cLISTOPo->op_first;
5280 if (kid->op_type == OP_PUSHMARK ||
5281 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5283 tokid = &kid->op_sibling;
5284 kid = kid->op_sibling;
5286 if (!kid && PL_opargs[type] & OA_DEFGV)
5287 *tokid = kid = newDEFSVOP();
5291 sibl = kid->op_sibling;
5294 /* list seen where single (scalar) arg expected? */
5295 if (numargs == 1 && !(oa >> 4)
5296 && kid->op_type == OP_LIST && type != OP_SCALAR)
5298 return too_many_arguments(o,PL_op_desc[type]);
5311 if ((type == OP_PUSH || type == OP_UNSHIFT)
5312 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5313 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5314 "Useless use of %s with no values",
5317 if (kid->op_type == OP_CONST &&
5318 (kid->op_private & OPpCONST_BARE))
5320 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5321 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVAV) ));
5322 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5323 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5324 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
5325 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5328 kid->op_sibling = sibl;
5331 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5332 bad_type(numargs, "array", PL_op_desc[type], kid);
5336 if (kid->op_type == OP_CONST &&
5337 (kid->op_private & OPpCONST_BARE))
5339 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5340 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVHV) ));
5341 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5342 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5343 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
5344 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5347 kid->op_sibling = sibl;
5350 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5351 bad_type(numargs, "hash", PL_op_desc[type], kid);
5356 OP *newop = newUNOP(OP_NULL, 0, kid);
5357 kid->op_sibling = 0;
5359 newop->op_next = newop;
5361 kid->op_sibling = sibl;
5366 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5367 if (kid->op_type == OP_CONST &&
5368 (kid->op_private & OPpCONST_BARE))
5370 OP *newop = newGVOP(OP_GV, 0,
5371 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVIO) );
5372 if (!(o->op_private & 1) && /* if not unop */
5373 kid == cLISTOPo->op_last)
5374 cLISTOPo->op_last = newop;
5378 else if (kid->op_type == OP_READLINE) {
5379 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5380 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5383 I32 flags = OPf_SPECIAL;
5387 /* is this op a FH constructor? */
5388 if (is_handle_constructor(o,numargs)) {
5389 const char *name = Nullch;
5393 /* Set a flag to tell rv2gv to vivify
5394 * need to "prove" flag does not mean something
5395 * else already - NI-S 1999/05/07
5398 if (kid->op_type == OP_PADSV) {
5399 name = PAD_COMPNAME_PV(kid->op_targ);
5400 /* SvCUR of a pad namesv can't be trusted
5401 * (see PL_generation), so calc its length
5407 else if (kid->op_type == OP_RV2SV
5408 && kUNOP->op_first->op_type == OP_GV)
5410 GV *gv = cGVOPx_gv(kUNOP->op_first);
5412 len = GvNAMELEN(gv);
5414 else if (kid->op_type == OP_AELEM
5415 || kid->op_type == OP_HELEM)
5420 if ((op = ((BINOP*)kid)->op_first)) {
5421 SV *tmpstr = Nullsv;
5423 kid->op_type == OP_AELEM ?
5425 if (((op->op_type == OP_RV2AV) ||
5426 (op->op_type == OP_RV2HV)) &&
5427 (op = ((UNOP*)op)->op_first) &&
5428 (op->op_type == OP_GV)) {
5429 /* packagevar $a[] or $h{} */
5430 GV *gv = cGVOPx_gv(op);
5438 else if (op->op_type == OP_PADAV
5439 || op->op_type == OP_PADHV) {
5440 /* lexicalvar $a[] or $h{} */
5441 const char *padname =
5442 PAD_COMPNAME_PV(op->op_targ);
5452 name = SvPV(tmpstr, len);
5457 name = "__ANONIO__";
5464 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5465 namesv = PAD_SVl(targ);
5466 (void)SvUPGRADE(namesv, SVt_PV);
5468 sv_setpvn(namesv, "$", 1);
5469 sv_catpvn(namesv, name, len);
5472 kid->op_sibling = 0;
5473 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5474 kid->op_targ = targ;
5475 kid->op_private |= priv;
5477 kid->op_sibling = sibl;
5483 mod(scalar(kid), type);
5487 tokid = &kid->op_sibling;
5488 kid = kid->op_sibling;
5490 o->op_private |= numargs;
5492 return too_many_arguments(o,OP_DESC(o));
5495 else if (PL_opargs[type] & OA_DEFGV) {
5497 return newUNOP(type, 0, newDEFSVOP());
5501 while (oa & OA_OPTIONAL)
5503 if (oa && oa != OA_LIST)
5504 return too_few_arguments(o,OP_DESC(o));
5510 Perl_ck_glob(pTHX_ OP *o)
5515 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5516 append_elem(OP_GLOB, o, newDEFSVOP());
5518 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5519 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5521 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5524 #if !defined(PERL_EXTERNAL_GLOB)
5525 /* XXX this can be tightened up and made more failsafe. */
5526 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5529 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5530 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5531 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5532 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5533 GvCV(gv) = GvCV(glob_gv);
5534 (void)SvREFCNT_inc((SV*)GvCV(gv));
5535 GvIMPORTED_CV_on(gv);
5538 #endif /* PERL_EXTERNAL_GLOB */
5540 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5541 append_elem(OP_GLOB, o,
5542 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5543 o->op_type = OP_LIST;
5544 o->op_ppaddr = PL_ppaddr[OP_LIST];
5545 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5546 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5547 cLISTOPo->op_first->op_targ = 0;
5548 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5549 append_elem(OP_LIST, o,
5550 scalar(newUNOP(OP_RV2CV, 0,
5551 newGVOP(OP_GV, 0, gv)))));
5552 o = newUNOP(OP_NULL, 0, ck_subr(o));
5553 o->op_targ = OP_GLOB; /* hint at what it used to be */
5556 gv = newGVgen("main");
5558 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5564 Perl_ck_grep(pTHX_ OP *o)
5568 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5571 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5572 NewOp(1101, gwop, 1, LOGOP);
5574 if (o->op_flags & OPf_STACKED) {
5577 kid = cLISTOPo->op_first->op_sibling;
5578 if (!cUNOPx(kid)->op_next)
5579 Perl_croak(aTHX_ "panic: ck_grep");
5580 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
5583 kid->op_next = (OP*)gwop;
5584 o->op_flags &= ~OPf_STACKED;
5586 kid = cLISTOPo->op_first->op_sibling;
5587 if (type == OP_MAPWHILE)
5594 kid = cLISTOPo->op_first->op_sibling;
5595 if (kid->op_type != OP_NULL)
5596 Perl_croak(aTHX_ "panic: ck_grep");
5597 kid = kUNOP->op_first;
5599 gwop->op_type = type;
5600 gwop->op_ppaddr = PL_ppaddr[type];
5601 gwop->op_first = listkids(o);
5602 gwop->op_flags |= OPf_KIDS;
5603 gwop->op_other = LINKLIST(kid);
5604 kid->op_next = (OP*)gwop;
5605 offset = pad_findmy("$_");
5606 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
5607 o->op_private = gwop->op_private = 0;
5608 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5611 o->op_private = gwop->op_private = OPpGREP_LEX;
5612 gwop->op_targ = o->op_targ = offset;
5615 kid = cLISTOPo->op_first->op_sibling;
5616 if (!kid || !kid->op_sibling)
5617 return too_few_arguments(o,OP_DESC(o));
5618 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5619 mod(kid, OP_GREPSTART);
5625 Perl_ck_index(pTHX_ OP *o)
5627 if (o->op_flags & OPf_KIDS) {
5628 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5630 kid = kid->op_sibling; /* get past "big" */
5631 if (kid && kid->op_type == OP_CONST)
5632 fbm_compile(((SVOP*)kid)->op_sv, 0);
5638 Perl_ck_lengthconst(pTHX_ OP *o)
5640 /* XXX length optimization goes here */
5645 Perl_ck_lfun(pTHX_ OP *o)
5647 const OPCODE type = o->op_type;
5648 return modkids(ck_fun(o), type);
5652 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5654 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5655 switch (cUNOPo->op_first->op_type) {
5657 /* This is needed for
5658 if (defined %stash::)
5659 to work. Do not break Tk.
5661 break; /* Globals via GV can be undef */
5663 case OP_AASSIGN: /* Is this a good idea? */
5664 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5665 "defined(@array) is deprecated");
5666 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5667 "\t(Maybe you should just omit the defined()?)\n");
5670 /* This is needed for
5671 if (defined %stash::)
5672 to work. Do not break Tk.
5674 break; /* Globals via GV can be undef */
5676 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5677 "defined(%%hash) is deprecated");
5678 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5679 "\t(Maybe you should just omit the defined()?)\n");
5690 Perl_ck_rfun(pTHX_ OP *o)
5692 const OPCODE type = o->op_type;
5693 return refkids(ck_fun(o), type);
5697 Perl_ck_listiob(pTHX_ OP *o)
5701 kid = cLISTOPo->op_first;
5704 kid = cLISTOPo->op_first;
5706 if (kid->op_type == OP_PUSHMARK)
5707 kid = kid->op_sibling;
5708 if (kid && o->op_flags & OPf_STACKED)
5709 kid = kid->op_sibling;
5710 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5711 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5712 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5713 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5714 cLISTOPo->op_first->op_sibling = kid;
5715 cLISTOPo->op_last = kid;
5716 kid = kid->op_sibling;
5721 append_elem(o->op_type, o, newDEFSVOP());
5727 Perl_ck_sassign(pTHX_ OP *o)
5729 OP *kid = cLISTOPo->op_first;
5730 /* has a disposable target? */
5731 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5732 && !(kid->op_flags & OPf_STACKED)
5733 /* Cannot steal the second time! */
5734 && !(kid->op_private & OPpTARGET_MY))
5736 OP *kkid = kid->op_sibling;
5738 /* Can just relocate the target. */
5739 if (kkid && kkid->op_type == OP_PADSV
5740 && !(kkid->op_private & OPpLVAL_INTRO))
5742 kid->op_targ = kkid->op_targ;
5744 /* Now we do not need PADSV and SASSIGN. */
5745 kid->op_sibling = o->op_sibling; /* NULL */
5746 cLISTOPo->op_first = NULL;
5749 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
5753 /* optimise C<my $x = undef> to C<my $x> */
5754 if (kid->op_type == OP_UNDEF) {
5755 OP *kkid = kid->op_sibling;
5756 if (kkid && kkid->op_type == OP_PADSV
5757 && (kkid->op_private & OPpLVAL_INTRO))
5759 cLISTOPo->op_first = NULL;
5760 kid->op_sibling = NULL;
5770 Perl_ck_match(pTHX_ OP *o)
5772 if (o->op_type != OP_QR) {
5773 const I32 offset = pad_findmy("$_");
5774 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS(offset) & SVpad_OUR)) {
5775 o->op_targ = offset;
5776 o->op_private |= OPpTARGET_MY;
5779 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
5780 o->op_private |= OPpRUNTIME;
5785 Perl_ck_method(pTHX_ OP *o)
5787 OP *kid = cUNOPo->op_first;
5788 if (kid->op_type == OP_CONST) {
5789 SV* sv = kSVOP->op_sv;
5790 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
5792 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5793 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
5796 kSVOP->op_sv = Nullsv;
5798 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5807 Perl_ck_null(pTHX_ OP *o)
5813 Perl_ck_open(pTHX_ OP *o)
5815 HV *table = GvHV(PL_hintgv);
5819 svp = hv_fetch(table, "open_IN", 7, FALSE);
5821 mode = mode_from_discipline(*svp);
5822 if (mode & O_BINARY)
5823 o->op_private |= OPpOPEN_IN_RAW;
5824 else if (mode & O_TEXT)
5825 o->op_private |= OPpOPEN_IN_CRLF;
5828 svp = hv_fetch(table, "open_OUT", 8, FALSE);
5830 mode = mode_from_discipline(*svp);
5831 if (mode & O_BINARY)
5832 o->op_private |= OPpOPEN_OUT_RAW;
5833 else if (mode & O_TEXT)
5834 o->op_private |= OPpOPEN_OUT_CRLF;
5837 if (o->op_type == OP_BACKTICK)
5840 /* In case of three-arg dup open remove strictness
5841 * from the last arg if it is a bareword. */
5842 OP *first = cLISTOPx(o)->op_first; /* The pushmark. */
5843 OP *last = cLISTOPx(o)->op_last; /* The bareword. */
5847 if ((last->op_type == OP_CONST) && /* The bareword. */
5848 (last->op_private & OPpCONST_BARE) &&
5849 (last->op_private & OPpCONST_STRICT) &&
5850 (oa = first->op_sibling) && /* The fh. */
5851 (oa = oa->op_sibling) && /* The mode. */
5852 SvPOK(((SVOP*)oa)->op_sv) &&
5853 (mode = SvPVX(((SVOP*)oa)->op_sv)) &&
5854 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
5855 (last == oa->op_sibling)) /* The bareword. */
5856 last->op_private &= ~OPpCONST_STRICT;
5862 Perl_ck_repeat(pTHX_ OP *o)
5864 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5865 o->op_private |= OPpREPEAT_DOLIST;
5866 cBINOPo->op_first = force_list(cBINOPo->op_first);
5874 Perl_ck_require(pTHX_ OP *o)
5878 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
5879 SVOP *kid = (SVOP*)cUNOPo->op_first;
5881 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5883 for (s = SvPVX(kid->op_sv); *s; s++) {
5884 if (*s == ':' && s[1] == ':') {
5886 Move(s+2, s+1, strlen(s+2)+1, char);
5887 --SvCUR(kid->op_sv);
5890 if (SvREADONLY(kid->op_sv)) {
5891 SvREADONLY_off(kid->op_sv);
5892 sv_catpvn(kid->op_sv, ".pm", 3);
5893 SvREADONLY_on(kid->op_sv);
5896 sv_catpvn(kid->op_sv, ".pm", 3);
5900 /* handle override, if any */
5901 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
5902 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
5903 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
5905 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5906 OP *kid = cUNOPo->op_first;
5907 cUNOPo->op_first = 0;
5909 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5910 append_elem(OP_LIST, kid,
5911 scalar(newUNOP(OP_RV2CV, 0,
5920 Perl_ck_return(pTHX_ OP *o)
5922 if (CvLVALUE(PL_compcv)) {
5924 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5925 mod(kid, OP_LEAVESUBLV);
5932 Perl_ck_retarget(pTHX_ OP *o)
5934 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5941 Perl_ck_select(pTHX_ OP *o)
5944 if (o->op_flags & OPf_KIDS) {
5945 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5946 if (kid && kid->op_sibling) {
5947 o->op_type = OP_SSELECT;
5948 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
5950 return fold_constants(o);
5954 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5955 if (kid && kid->op_type == OP_RV2GV)
5956 kid->op_private &= ~HINT_STRICT_REFS;
5961 Perl_ck_shift(pTHX_ OP *o)
5963 const I32 type = o->op_type;
5965 if (!(o->op_flags & OPf_KIDS)) {
5969 argop = newUNOP(OP_RV2AV, 0,
5970 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
5971 return newUNOP(type, 0, scalar(argop));
5973 return scalar(modkids(ck_fun(o), type));
5977 Perl_ck_sort(pTHX_ OP *o)
5981 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
5983 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5984 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
5986 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
5988 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
5990 if (kid->op_type == OP_SCOPE) {
5994 else if (kid->op_type == OP_LEAVE) {
5995 if (o->op_type == OP_SORT) {
5996 op_null(kid); /* wipe out leave */
5999 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6000 if (k->op_next == kid)
6002 /* don't descend into loops */
6003 else if (k->op_type == OP_ENTERLOOP
6004 || k->op_type == OP_ENTERITER)
6006 k = cLOOPx(k)->op_lastop;
6011 kid->op_next = 0; /* just disconnect the leave */
6012 k = kLISTOP->op_first;
6017 if (o->op_type == OP_SORT) {
6018 /* provide scalar context for comparison function/block */
6024 o->op_flags |= OPf_SPECIAL;
6026 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6029 firstkid = firstkid->op_sibling;
6032 /* provide list context for arguments */
6033 if (o->op_type == OP_SORT)
6040 S_simplify_sort(pTHX_ OP *o)
6042 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6047 if (!(o->op_flags & OPf_STACKED))
6049 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6050 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6051 kid = kUNOP->op_first; /* get past null */
6052 if (kid->op_type != OP_SCOPE)
6054 kid = kLISTOP->op_last; /* get past scope */
6055 switch(kid->op_type) {
6063 k = kid; /* remember this node*/
6064 if (kBINOP->op_first->op_type != OP_RV2SV)
6066 kid = kBINOP->op_first; /* get past cmp */
6067 if (kUNOP->op_first->op_type != OP_GV)
6069 kid = kUNOP->op_first; /* get past rv2sv */
6071 if (GvSTASH(gv) != PL_curstash)
6073 gvname = GvNAME(gv);
6074 if (*gvname == 'a' && gvname[1] == '\0')
6076 else if (*gvname == 'b' && gvname[1] == '\0')
6081 kid = k; /* back to cmp */
6082 if (kBINOP->op_last->op_type != OP_RV2SV)
6084 kid = kBINOP->op_last; /* down to 2nd arg */
6085 if (kUNOP->op_first->op_type != OP_GV)
6087 kid = kUNOP->op_first; /* get past rv2sv */
6089 if (GvSTASH(gv) != PL_curstash)
6091 gvname = GvNAME(gv);
6093 ? !(*gvname == 'a' && gvname[1] == '\0')
6094 : !(*gvname == 'b' && gvname[1] == '\0'))
6096 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6098 o->op_private |= OPpSORT_DESCEND;
6099 if (k->op_type == OP_NCMP)
6100 o->op_private |= OPpSORT_NUMERIC;
6101 if (k->op_type == OP_I_NCMP)
6102 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6103 kid = cLISTOPo->op_first->op_sibling;
6104 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6105 op_free(kid); /* then delete it */
6109 Perl_ck_split(pTHX_ OP *o)
6113 if (o->op_flags & OPf_STACKED)
6114 return no_fh_allowed(o);
6116 kid = cLISTOPo->op_first;
6117 if (kid->op_type != OP_NULL)
6118 Perl_croak(aTHX_ "panic: ck_split");
6119 kid = kid->op_sibling;
6120 op_free(cLISTOPo->op_first);
6121 cLISTOPo->op_first = kid;
6123 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6124 cLISTOPo->op_last = kid; /* There was only one element previously */
6127 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6128 OP *sibl = kid->op_sibling;
6129 kid->op_sibling = 0;
6130 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
6131 if (cLISTOPo->op_first == cLISTOPo->op_last)
6132 cLISTOPo->op_last = kid;
6133 cLISTOPo->op_first = kid;
6134 kid->op_sibling = sibl;
6137 kid->op_type = OP_PUSHRE;
6138 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6140 if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
6141 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
6142 "Use of /g modifier is meaningless in split");
6145 if (!kid->op_sibling)
6146 append_elem(OP_SPLIT, o, newDEFSVOP());
6148 kid = kid->op_sibling;
6151 if (!kid->op_sibling)
6152 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6154 kid = kid->op_sibling;
6157 if (kid->op_sibling)
6158 return too_many_arguments(o,OP_DESC(o));
6164 Perl_ck_join(pTHX_ OP *o)
6166 if (ckWARN(WARN_SYNTAX)) {
6167 const OP *kid = cLISTOPo->op_first->op_sibling;
6168 if (kid && kid->op_type == OP_MATCH) {
6169 const REGEXP *re = PM_GETRE(kPMOP);
6170 const char *pmstr = re ? re->precomp : "STRING";
6171 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6172 "/%s/ should probably be written as \"%s\"",
6180 Perl_ck_subr(pTHX_ OP *o)
6182 OP *prev = ((cUNOPo->op_first->op_sibling)
6183 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6184 OP *o2 = prev->op_sibling;
6191 I32 contextclass = 0;
6196 o->op_private |= OPpENTERSUB_HASTARG;
6197 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6198 if (cvop->op_type == OP_RV2CV) {
6200 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6201 op_null(cvop); /* disable rv2cv */
6202 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6203 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6204 GV *gv = cGVOPx_gv(tmpop);
6207 tmpop->op_private |= OPpEARLY_CV;
6210 namegv = CvANON(cv) ? gv : CvGV(cv);
6211 proto = SvPV((SV*)cv, n_a);
6213 if (CvASSERTION(cv)) {
6214 if (PL_hints & HINT_ASSERTING) {
6215 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
6216 o->op_private |= OPpENTERSUB_DB;
6220 if (ckWARN(WARN_ASSERTIONS) && !(PL_hints & HINT_ASSERTIONSSEEN)) {
6221 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
6222 "Impossible to activate assertion call");
6229 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6230 if (o2->op_type == OP_CONST)
6231 o2->op_private &= ~OPpCONST_STRICT;
6232 else if (o2->op_type == OP_LIST) {
6233 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6234 if (o && o->op_type == OP_CONST)
6235 o->op_private &= ~OPpCONST_STRICT;
6238 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6239 if (PERLDB_SUB && PL_curstash != PL_debstash)
6240 o->op_private |= OPpENTERSUB_DB;
6241 while (o2 != cvop) {
6245 return too_many_arguments(o, gv_ename(namegv));
6263 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6265 arg == 1 ? "block or sub {}" : "sub {}",
6266 gv_ename(namegv), o2);
6269 /* '*' allows any scalar type, including bareword */
6272 if (o2->op_type == OP_RV2GV)
6273 goto wrapref; /* autoconvert GLOB -> GLOBref */
6274 else if (o2->op_type == OP_CONST)
6275 o2->op_private &= ~OPpCONST_STRICT;
6276 else if (o2->op_type == OP_ENTERSUB) {
6277 /* accidental subroutine, revert to bareword */
6278 OP *gvop = ((UNOP*)o2)->op_first;
6279 if (gvop && gvop->op_type == OP_NULL) {
6280 gvop = ((UNOP*)gvop)->op_first;
6282 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6285 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6286 (gvop = ((UNOP*)gvop)->op_first) &&
6287 gvop->op_type == OP_GV)
6289 GV *gv = cGVOPx_gv(gvop);
6290 OP *sibling = o2->op_sibling;
6291 SV *n = newSVpvn("",0);
6293 gv_fullname4(n, gv, "", FALSE);
6294 o2 = newSVOP(OP_CONST, 0, n);
6295 prev->op_sibling = o2;
6296 o2->op_sibling = sibling;
6312 if (contextclass++ == 0) {
6313 e = strchr(proto, ']');
6314 if (!e || e == proto)
6327 while (*--p != '[');
6328 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6329 gv_ename(namegv), o2);
6335 if (o2->op_type == OP_RV2GV)
6338 bad_type(arg, "symbol", gv_ename(namegv), o2);
6341 if (o2->op_type == OP_ENTERSUB)
6344 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6347 if (o2->op_type == OP_RV2SV ||
6348 o2->op_type == OP_PADSV ||
6349 o2->op_type == OP_HELEM ||
6350 o2->op_type == OP_AELEM ||
6351 o2->op_type == OP_THREADSV)
6354 bad_type(arg, "scalar", gv_ename(namegv), o2);
6357 if (o2->op_type == OP_RV2AV ||
6358 o2->op_type == OP_PADAV)
6361 bad_type(arg, "array", gv_ename(namegv), o2);
6364 if (o2->op_type == OP_RV2HV ||
6365 o2->op_type == OP_PADHV)
6368 bad_type(arg, "hash", gv_ename(namegv), o2);
6373 OP* sib = kid->op_sibling;
6374 kid->op_sibling = 0;
6375 o2 = newUNOP(OP_REFGEN, 0, kid);
6376 o2->op_sibling = sib;
6377 prev->op_sibling = o2;
6379 if (contextclass && e) {
6394 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6395 gv_ename(namegv), cv);
6400 mod(o2, OP_ENTERSUB);
6402 o2 = o2->op_sibling;
6404 if (proto && !optional &&
6405 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6406 return too_few_arguments(o, gv_ename(namegv));
6409 o=newSVOP(OP_CONST, 0, newSViv(0));
6415 Perl_ck_svconst(pTHX_ OP *o)
6417 SvREADONLY_on(cSVOPo->op_sv);
6422 Perl_ck_trunc(pTHX_ OP *o)
6424 if (o->op_flags & OPf_KIDS) {
6425 SVOP *kid = (SVOP*)cUNOPo->op_first;
6427 if (kid->op_type == OP_NULL)
6428 kid = (SVOP*)kid->op_sibling;
6429 if (kid && kid->op_type == OP_CONST &&
6430 (kid->op_private & OPpCONST_BARE))
6432 o->op_flags |= OPf_SPECIAL;
6433 kid->op_private &= ~OPpCONST_STRICT;
6440 Perl_ck_unpack(pTHX_ OP *o)
6442 OP *kid = cLISTOPo->op_first;
6443 if (kid->op_sibling) {
6444 kid = kid->op_sibling;
6445 if (!kid->op_sibling)
6446 kid->op_sibling = newDEFSVOP();
6452 Perl_ck_substr(pTHX_ OP *o)
6455 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6456 OP *kid = cLISTOPo->op_first;
6458 if (kid->op_type == OP_NULL)
6459 kid = kid->op_sibling;
6461 kid->op_flags |= OPf_MOD;
6467 /* A peephole optimizer. We visit the ops in the order they're to execute.
6468 * See the comments at the top of this file for more details about when
6469 * peep() is called */
6472 Perl_peep(pTHX_ register OP *o)
6474 register OP* oldop = 0;
6476 if (!o || o->op_opt)
6480 SAVEVPTR(PL_curcop);
6481 for (; o; o = o->op_next) {
6485 switch (o->op_type) {
6489 PL_curcop = ((COP*)o); /* for warnings */
6494 if (cSVOPo->op_private & OPpCONST_STRICT)
6495 no_bareword_allowed(o);
6497 case OP_METHOD_NAMED:
6498 /* Relocate sv to the pad for thread safety.
6499 * Despite being a "constant", the SV is written to,
6500 * for reference counts, sv_upgrade() etc. */
6502 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6503 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6504 /* If op_sv is already a PADTMP then it is being used by
6505 * some pad, so make a copy. */
6506 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6507 SvREADONLY_on(PAD_SVl(ix));
6508 SvREFCNT_dec(cSVOPo->op_sv);
6511 SvREFCNT_dec(PAD_SVl(ix));
6512 SvPADTMP_on(cSVOPo->op_sv);
6513 PAD_SETSV(ix, cSVOPo->op_sv);
6514 /* XXX I don't know how this isn't readonly already. */
6515 SvREADONLY_on(PAD_SVl(ix));
6517 cSVOPo->op_sv = Nullsv;
6525 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6526 if (o->op_next->op_private & OPpTARGET_MY) {
6527 if (o->op_flags & OPf_STACKED) /* chained concats */
6528 goto ignore_optimization;
6530 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6531 o->op_targ = o->op_next->op_targ;
6532 o->op_next->op_targ = 0;
6533 o->op_private |= OPpTARGET_MY;
6536 op_null(o->op_next);
6538 ignore_optimization:
6542 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6544 break; /* Scalar stub must produce undef. List stub is noop */
6548 if (o->op_targ == OP_NEXTSTATE
6549 || o->op_targ == OP_DBSTATE
6550 || o->op_targ == OP_SETSTATE)
6552 PL_curcop = ((COP*)o);
6554 /* XXX: We avoid setting op_seq here to prevent later calls
6555 to peep() from mistakenly concluding that optimisation
6556 has already occurred. This doesn't fix the real problem,
6557 though (See 20010220.007). AMS 20010719 */
6558 /* op_seq functionality is now replaced by op_opt */
6559 if (oldop && o->op_next) {
6560 oldop->op_next = o->op_next;
6568 if (oldop && o->op_next) {
6569 oldop->op_next = o->op_next;
6577 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
6578 OP* pop = (o->op_type == OP_PADAV) ?
6579 o->op_next : o->op_next->op_next;
6581 if (pop && pop->op_type == OP_CONST &&
6582 ((PL_op = pop->op_next)) &&
6583 pop->op_next->op_type == OP_AELEM &&
6584 !(pop->op_next->op_private &
6585 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6586 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6591 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
6592 no_bareword_allowed(pop);
6593 if (o->op_type == OP_GV)
6594 op_null(o->op_next);
6595 op_null(pop->op_next);
6597 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6598 o->op_next = pop->op_next->op_next;
6599 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6600 o->op_private = (U8)i;
6601 if (o->op_type == OP_GV) {
6606 o->op_flags |= OPf_SPECIAL;
6607 o->op_type = OP_AELEMFAST;
6613 if (o->op_next->op_type == OP_RV2SV) {
6614 if (!(o->op_next->op_private & OPpDEREF)) {
6615 op_null(o->op_next);
6616 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6618 o->op_next = o->op_next->op_next;
6619 o->op_type = OP_GVSV;
6620 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6623 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6625 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6626 /* XXX could check prototype here instead of just carping */
6627 SV *sv = sv_newmortal();
6628 gv_efullname3(sv, gv, Nullch);
6629 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6630 "%"SVf"() called too early to check prototype",
6634 else if (o->op_next->op_type == OP_READLINE
6635 && o->op_next->op_next->op_type == OP_CONCAT
6636 && (o->op_next->op_next->op_flags & OPf_STACKED))
6638 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6639 o->op_type = OP_RCATLINE;
6640 o->op_flags |= OPf_STACKED;
6641 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6642 op_null(o->op_next->op_next);
6643 op_null(o->op_next);
6660 while (cLOGOP->op_other->op_type == OP_NULL)
6661 cLOGOP->op_other = cLOGOP->op_other->op_next;
6662 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6668 while (cLOOP->op_redoop->op_type == OP_NULL)
6669 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6670 peep(cLOOP->op_redoop);
6671 while (cLOOP->op_nextop->op_type == OP_NULL)
6672 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6673 peep(cLOOP->op_nextop);
6674 while (cLOOP->op_lastop->op_type == OP_NULL)
6675 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6676 peep(cLOOP->op_lastop);
6683 while (cPMOP->op_pmreplstart &&
6684 cPMOP->op_pmreplstart->op_type == OP_NULL)
6685 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6686 peep(cPMOP->op_pmreplstart);
6691 if (ckWARN(WARN_SYNTAX) && o->op_next
6692 && o->op_next->op_type == OP_NEXTSTATE) {
6693 if (o->op_next->op_sibling &&
6694 o->op_next->op_sibling->op_type != OP_EXIT &&
6695 o->op_next->op_sibling->op_type != OP_WARN &&
6696 o->op_next->op_sibling->op_type != OP_DIE) {
6697 const line_t oldline = CopLINE(PL_curcop);
6699 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6700 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6701 "Statement unlikely to be reached");
6702 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6703 "\t(Maybe you meant system() when you said exec()?)\n");
6704 CopLINE_set(PL_curcop, oldline);
6719 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6722 /* Make the CONST have a shared SV */
6723 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6724 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6725 key = SvPV(sv, keylen);
6726 lexname = newSVpvn_share(key,
6727 SvUTF8(sv) ? -(I32)keylen : keylen,
6733 if ((o->op_private & (OPpLVAL_INTRO)))
6736 rop = (UNOP*)((BINOP*)o)->op_first;
6737 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6739 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6740 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6742 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6743 if (!fields || !GvHV(*fields))
6745 key = SvPV(*svp, keylen);
6746 if (!hv_fetch(GvHV(*fields), key,
6747 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
6749 Perl_croak(aTHX_ "No such class field \"%s\" "
6750 "in variable %s of type %s",
6751 key, SvPV_nolen(lexname), HvNAME(SvSTASH(lexname)));
6764 SVOP *first_key_op, *key_op;
6766 if ((o->op_private & (OPpLVAL_INTRO))
6767 /* I bet there's always a pushmark... */
6768 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6769 /* hmmm, no optimization if list contains only one key. */
6771 rop = (UNOP*)((LISTOP*)o)->op_last;
6772 if (rop->op_type != OP_RV2HV)
6774 if (rop->op_first->op_type == OP_PADSV)
6775 /* @$hash{qw(keys here)} */
6776 rop = (UNOP*)rop->op_first;
6778 /* @{$hash}{qw(keys here)} */
6779 if (rop->op_first->op_type == OP_SCOPE
6780 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
6782 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
6788 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
6789 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6791 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6792 if (!fields || !GvHV(*fields))
6794 /* Again guessing that the pushmark can be jumped over.... */
6795 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
6796 ->op_first->op_sibling;
6797 for (key_op = first_key_op; key_op;
6798 key_op = (SVOP*)key_op->op_sibling) {
6799 if (key_op->op_type != OP_CONST)
6801 svp = cSVOPx_svp(key_op);
6802 key = SvPV(*svp, keylen);
6803 if (!hv_fetch(GvHV(*fields), key,
6804 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
6806 Perl_croak(aTHX_ "No such class field \"%s\" "
6807 "in variable %s of type %s",
6808 key, SvPV_nolen(lexname), HvNAME(SvSTASH(lexname)));
6815 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
6819 /* check that RHS of sort is a single plain array */
6820 oright = cUNOPo->op_first;
6821 if (!oright || oright->op_type != OP_PUSHMARK)
6824 /* reverse sort ... can be optimised. */
6825 if (!cUNOPo->op_sibling) {
6826 /* Nothing follows us on the list. */
6827 OP *reverse = o->op_next;
6829 if (reverse->op_type == OP_REVERSE &&
6830 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
6831 OP *pushmark = cUNOPx(reverse)->op_first;
6832 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
6833 && (cUNOPx(pushmark)->op_sibling == o)) {
6834 /* reverse -> pushmark -> sort */
6835 o->op_private |= OPpSORT_REVERSE;
6837 pushmark->op_next = oright->op_next;
6843 /* make @a = sort @a act in-place */
6847 oright = cUNOPx(oright)->op_sibling;
6850 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
6851 oright = cUNOPx(oright)->op_sibling;
6855 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
6856 || oright->op_next != o
6857 || (oright->op_private & OPpLVAL_INTRO)
6861 /* o2 follows the chain of op_nexts through the LHS of the
6862 * assign (if any) to the aassign op itself */
6864 if (!o2 || o2->op_type != OP_NULL)
6867 if (!o2 || o2->op_type != OP_PUSHMARK)
6870 if (o2 && o2->op_type == OP_GV)
6873 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
6874 || (o2->op_private & OPpLVAL_INTRO)
6879 if (!o2 || o2->op_type != OP_NULL)
6882 if (!o2 || o2->op_type != OP_AASSIGN
6883 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
6886 /* check that the sort is the first arg on RHS of assign */
6888 o2 = cUNOPx(o2)->op_first;
6889 if (!o2 || o2->op_type != OP_NULL)
6891 o2 = cUNOPx(o2)->op_first;
6892 if (!o2 || o2->op_type != OP_PUSHMARK)
6894 if (o2->op_sibling != o)
6897 /* check the array is the same on both sides */
6898 if (oleft->op_type == OP_RV2AV) {
6899 if (oright->op_type != OP_RV2AV
6900 || !cUNOPx(oright)->op_first
6901 || cUNOPx(oright)->op_first->op_type != OP_GV
6902 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
6903 cGVOPx_gv(cUNOPx(oright)->op_first)
6907 else if (oright->op_type != OP_PADAV
6908 || oright->op_targ != oleft->op_targ
6912 /* transfer MODishness etc from LHS arg to RHS arg */
6913 oright->op_flags = oleft->op_flags;
6914 o->op_private |= OPpSORT_INPLACE;
6916 /* excise push->gv->rv2av->null->aassign */
6917 o2 = o->op_next->op_next;
6918 op_null(o2); /* PUSHMARK */
6920 if (o2->op_type == OP_GV) {
6921 op_null(o2); /* GV */
6924 op_null(o2); /* RV2AV or PADAV */
6925 o2 = o2->op_next->op_next;
6926 op_null(o2); /* AASSIGN */
6928 o->op_next = o2->op_next;
6934 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
6936 LISTOP *enter, *exlist;
6939 enter = (LISTOP *) o->op_next;
6942 if (enter->op_type == OP_NULL) {
6943 enter = (LISTOP *) enter->op_next;
6947 /* for $a (...) will have OP_GV then OP_RV2GV here.
6948 for (...) just has an OP_GV. */
6949 if (enter->op_type == OP_GV) {
6950 gvop = (OP *) enter;
6951 enter = (LISTOP *) enter->op_next;
6954 if (enter->op_type == OP_RV2GV) {
6955 enter = (LISTOP *) enter->op_next;
6961 if (enter->op_type != OP_ENTERITER)
6964 iter = enter->op_next;
6965 if (!iter || iter->op_type != OP_ITER)
6968 expushmark = enter->op_first;
6969 if (!expushmark || expushmark->op_type != OP_NULL
6970 || expushmark->op_targ != OP_PUSHMARK)
6973 exlist = (LISTOP *) expushmark->op_sibling;
6974 if (!exlist || exlist->op_type != OP_NULL
6975 || exlist->op_targ != OP_LIST)
6978 if (exlist->op_last != o) {
6979 /* Mmm. Was expecting to point back to this op. */
6982 theirmark = exlist->op_first;
6983 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
6986 if (theirmark->op_sibling != o) {
6987 /* There's something between the mark and the reverse, eg
6988 for (1, reverse (...))
6993 ourmark = ((LISTOP *)o)->op_first;
6994 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
6997 ourlast = ((LISTOP *)o)->op_last;
6998 if (!ourlast || ourlast->op_next != o)
7001 rv2av = ourmark->op_sibling;
7002 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
7003 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
7004 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
7005 /* We're just reversing a single array. */
7006 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
7007 enter->op_flags |= OPf_STACKED;
7010 /* We don't have control over who points to theirmark, so sacrifice
7012 theirmark->op_next = ourmark->op_next;
7013 theirmark->op_flags = ourmark->op_flags;
7014 ourlast->op_next = gvop ? gvop : (OP *) enter;
7017 enter->op_private |= OPpITER_REVERSED;
7018 iter->op_private |= OPpITER_REVERSED;
7033 Perl_custom_op_name(pTHX_ const OP* o)
7035 const IV index = PTR2IV(o->op_ppaddr);
7039 if (!PL_custom_op_names) /* This probably shouldn't happen */
7040 return PL_op_name[OP_CUSTOM];
7042 keysv = sv_2mortal(newSViv(index));
7044 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7046 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7048 return SvPV_nolen(HeVAL(he));
7052 Perl_custom_op_desc(pTHX_ const OP* o)
7054 const IV index = PTR2IV(o->op_ppaddr);
7058 if (!PL_custom_op_descs)
7059 return PL_op_desc[OP_CUSTOM];
7061 keysv = sv_2mortal(newSViv(index));
7063 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7065 return PL_op_desc[OP_CUSTOM];
7067 return SvPV_nolen(HeVAL(he));
7072 /* Efficient sub that returns a constant scalar value. */
7074 const_sv_xsub(pTHX_ CV* cv)
7079 Perl_croak(aTHX_ "usage: %s::%s()",
7080 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7084 ST(0) = (SV*)XSANY.any_ptr;
7090 * c-indentation-style: bsd
7092 * indent-tabs-mode: t
7095 * vim: shiftwidth=4: