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, 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_ 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)
273 register OP *kid, *nextkid;
277 if (!o || o->op_static)
280 if (o->op_private & OPpREFCOUNTED) {
281 switch (o->op_type) {
289 refcnt = OpREFCNT_dec(o);
299 if (o->op_flags & OPf_KIDS) {
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)
502 /* establish postfix order */
503 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 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)
847 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)
935 if (o->op_type == OP_LINESEQ ||
936 o->op_type == OP_SCOPE ||
937 o->op_type == OP_LEAVE ||
938 o->op_type == OP_LEAVETRY)
940 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
941 if (kid->op_sibling) {
945 PL_curcop = &PL_compiling;
947 o->op_flags &= ~OPf_PARENS;
948 if (PL_hints & HINT_BLOCK_SCOPE)
949 o->op_flags |= OPf_PARENS;
952 o = newOP(OP_STUB, 0);
957 S_modkids(pTHX_ OP *o, I32 type)
960 if (o && o->op_flags & OPf_KIDS) {
961 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
967 /* Propagate lvalue ("modifiable") context to an op and it's children.
968 * 'type' represents the context type, roughly based on the type of op that
969 * would do the modifying, although local() is represented by OP_NULL.
970 * It's responsible for detecting things that can't be modified, flag
971 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
972 * might have to vivify a reference in $x), and so on.
974 * For example, "$a+1 = 2" would cause mod() to be called with o being
975 * OP_ADD and type being OP_SASSIGN, and would output an error.
979 Perl_mod(pTHX_ OP *o, I32 type)
982 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
985 if (!o || PL_error_count)
988 if ((o->op_private & OPpTARGET_MY)
989 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
994 switch (o->op_type) {
1000 if (!(o->op_private & (OPpCONST_ARYBASE)))
1002 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1003 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1007 SAVEI32(PL_compiling.cop_arybase);
1008 PL_compiling.cop_arybase = 0;
1010 else if (type == OP_REFGEN)
1013 Perl_croak(aTHX_ "That use of $[ is unsupported");
1016 if (o->op_flags & OPf_PARENS)
1020 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1021 !(o->op_flags & OPf_STACKED)) {
1022 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1023 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1024 assert(cUNOPo->op_first->op_type == OP_NULL);
1025 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1028 else if (o->op_private & OPpENTERSUB_NOMOD)
1030 else { /* lvalue subroutine call */
1031 o->op_private |= OPpLVAL_INTRO;
1032 PL_modcount = RETURN_UNLIMITED_NUMBER;
1033 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1034 /* Backward compatibility mode: */
1035 o->op_private |= OPpENTERSUB_INARGS;
1038 else { /* Compile-time error message: */
1039 OP *kid = cUNOPo->op_first;
1043 if (kid->op_type == OP_PUSHMARK)
1045 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1047 "panic: unexpected lvalue entersub "
1048 "args: type/targ %ld:%"UVuf,
1049 (long)kid->op_type, (UV)kid->op_targ);
1050 kid = kLISTOP->op_first;
1052 while (kid->op_sibling)
1053 kid = kid->op_sibling;
1054 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1056 if (kid->op_type == OP_METHOD_NAMED
1057 || kid->op_type == OP_METHOD)
1061 NewOp(1101, newop, 1, UNOP);
1062 newop->op_type = OP_RV2CV;
1063 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1064 newop->op_first = Nullop;
1065 newop->op_next = (OP*)newop;
1066 kid->op_sibling = (OP*)newop;
1067 newop->op_private |= OPpLVAL_INTRO;
1071 if (kid->op_type != OP_RV2CV)
1073 "panic: unexpected lvalue entersub "
1074 "entry via type/targ %ld:%"UVuf,
1075 (long)kid->op_type, (UV)kid->op_targ);
1076 kid->op_private |= OPpLVAL_INTRO;
1077 break; /* Postpone until runtime */
1081 kid = kUNOP->op_first;
1082 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1083 kid = kUNOP->op_first;
1084 if (kid->op_type == OP_NULL)
1086 "Unexpected constant lvalue entersub "
1087 "entry via type/targ %ld:%"UVuf,
1088 (long)kid->op_type, (UV)kid->op_targ);
1089 if (kid->op_type != OP_GV) {
1090 /* Restore RV2CV to check lvalueness */
1092 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1093 okid->op_next = kid->op_next;
1094 kid->op_next = okid;
1097 okid->op_next = Nullop;
1098 okid->op_type = OP_RV2CV;
1100 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1101 okid->op_private |= OPpLVAL_INTRO;
1105 cv = GvCV(kGVOP_gv);
1115 /* grep, foreach, subcalls, refgen */
1116 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1118 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1119 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1121 : (o->op_type == OP_ENTERSUB
1122 ? "non-lvalue subroutine call"
1124 type ? PL_op_desc[type] : "local"));
1138 case OP_RIGHT_SHIFT:
1147 if (!(o->op_flags & OPf_STACKED))
1154 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1160 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1161 PL_modcount = RETURN_UNLIMITED_NUMBER;
1162 return o; /* Treat \(@foo) like ordinary list. */
1166 if (scalar_mod_type(o, type))
1168 ref(cUNOPo->op_first, o->op_type);
1172 if (type == OP_LEAVESUBLV)
1173 o->op_private |= OPpMAYBE_LVSUB;
1179 PL_modcount = RETURN_UNLIMITED_NUMBER;
1182 ref(cUNOPo->op_first, o->op_type);
1187 PL_hints |= HINT_BLOCK_SCOPE;
1202 PL_modcount = RETURN_UNLIMITED_NUMBER;
1203 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1204 return o; /* Treat \(@foo) like ordinary list. */
1205 if (scalar_mod_type(o, type))
1207 if (type == OP_LEAVESUBLV)
1208 o->op_private |= OPpMAYBE_LVSUB;
1212 if (!type) /* local() */
1213 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1214 PAD_COMPNAME_PV(o->op_targ));
1222 if (type != OP_SASSIGN)
1226 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1231 if (type == OP_LEAVESUBLV)
1232 o->op_private |= OPpMAYBE_LVSUB;
1234 pad_free(o->op_targ);
1235 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1236 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1237 if (o->op_flags & OPf_KIDS)
1238 mod(cBINOPo->op_first->op_sibling, type);
1243 ref(cBINOPo->op_first, o->op_type);
1244 if (type == OP_ENTERSUB &&
1245 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1246 o->op_private |= OPpLVAL_DEFER;
1247 if (type == OP_LEAVESUBLV)
1248 o->op_private |= OPpMAYBE_LVSUB;
1258 if (o->op_flags & OPf_KIDS)
1259 mod(cLISTOPo->op_last, type);
1264 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1266 else if (!(o->op_flags & OPf_KIDS))
1268 if (o->op_targ != OP_LIST) {
1269 mod(cBINOPo->op_first, type);
1275 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1280 if (type != OP_LEAVESUBLV)
1282 break; /* mod()ing was handled by ck_return() */
1285 /* [20011101.069] File test operators interpret OPf_REF to mean that
1286 their argument is a filehandle; thus \stat(".") should not set
1288 if (type == OP_REFGEN &&
1289 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1292 if (type != OP_LEAVESUBLV)
1293 o->op_flags |= OPf_MOD;
1295 if (type == OP_AASSIGN || type == OP_SASSIGN)
1296 o->op_flags |= OPf_SPECIAL|OPf_REF;
1297 else if (!type) { /* local() */
1300 o->op_private |= OPpLVAL_INTRO;
1301 o->op_flags &= ~OPf_SPECIAL;
1302 PL_hints |= HINT_BLOCK_SCOPE;
1307 if (ckWARN(WARN_SYNTAX)) {
1308 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1309 "Useless localization of %s", OP_DESC(o));
1313 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1314 && type != OP_LEAVESUBLV)
1315 o->op_flags |= OPf_REF;
1320 S_scalar_mod_type(pTHX_ OP *o, I32 type)
1324 if (o->op_type == OP_RV2GV)
1348 case OP_RIGHT_SHIFT:
1367 S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
1369 switch (o->op_type) {
1377 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1390 Perl_refkids(pTHX_ OP *o, I32 type)
1393 if (o && o->op_flags & OPf_KIDS) {
1394 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1401 Perl_ref(pTHX_ OP *o, I32 type)
1405 if (!o || PL_error_count)
1408 switch (o->op_type) {
1410 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1411 !(o->op_flags & OPf_STACKED)) {
1412 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1413 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1414 assert(cUNOPo->op_first->op_type == OP_NULL);
1415 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1416 o->op_flags |= OPf_SPECIAL;
1421 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1425 if (type == OP_DEFINED)
1426 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1427 ref(cUNOPo->op_first, o->op_type);
1430 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1431 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1432 : type == OP_RV2HV ? OPpDEREF_HV
1434 o->op_flags |= OPf_MOD;
1439 o->op_flags |= OPf_MOD; /* XXX ??? */
1444 o->op_flags |= OPf_REF;
1447 if (type == OP_DEFINED)
1448 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1449 ref(cUNOPo->op_first, o->op_type);
1454 o->op_flags |= OPf_REF;
1459 if (!(o->op_flags & OPf_KIDS))
1461 ref(cBINOPo->op_first, type);
1465 ref(cBINOPo->op_first, o->op_type);
1466 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1467 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1468 : type == OP_RV2HV ? OPpDEREF_HV
1470 o->op_flags |= OPf_MOD;
1478 if (!(o->op_flags & OPf_KIDS))
1480 ref(cLISTOPo->op_last, type);
1490 S_dup_attrlist(pTHX_ OP *o)
1494 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1495 * where the first kid is OP_PUSHMARK and the remaining ones
1496 * are OP_CONST. We need to push the OP_CONST values.
1498 if (o->op_type == OP_CONST)
1499 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1501 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1502 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1503 if (o->op_type == OP_CONST)
1504 rop = append_elem(OP_LIST, rop,
1505 newSVOP(OP_CONST, o->op_flags,
1506 SvREFCNT_inc(cSVOPo->op_sv)));
1513 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1517 /* fake up C<use attributes $pkg,$rv,@attrs> */
1518 ENTER; /* need to protect against side-effects of 'use' */
1521 stashsv = newSVpv(HvNAME(stash), 0);
1523 stashsv = &PL_sv_no;
1525 #define ATTRSMODULE "attributes"
1526 #define ATTRSMODULE_PM "attributes.pm"
1530 /* Don't force the C<use> if we don't need it. */
1531 svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
1532 sizeof(ATTRSMODULE_PM)-1, 0);
1533 if (svp && *svp != &PL_sv_undef)
1534 ; /* already in %INC */
1536 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1537 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1541 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1542 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1544 prepend_elem(OP_LIST,
1545 newSVOP(OP_CONST, 0, stashsv),
1546 prepend_elem(OP_LIST,
1547 newSVOP(OP_CONST, 0,
1549 dup_attrlist(attrs))));
1555 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1557 OP *pack, *imop, *arg;
1563 assert(target->op_type == OP_PADSV ||
1564 target->op_type == OP_PADHV ||
1565 target->op_type == OP_PADAV);
1567 /* Ensure that attributes.pm is loaded. */
1568 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1570 /* Need package name for method call. */
1571 pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
1573 /* Build up the real arg-list. */
1575 stashsv = newSVpv(HvNAME(stash), 0);
1577 stashsv = &PL_sv_no;
1578 arg = newOP(OP_PADSV, 0);
1579 arg->op_targ = target->op_targ;
1580 arg = prepend_elem(OP_LIST,
1581 newSVOP(OP_CONST, 0, stashsv),
1582 prepend_elem(OP_LIST,
1583 newUNOP(OP_REFGEN, 0,
1584 mod(arg, OP_REFGEN)),
1585 dup_attrlist(attrs)));
1587 /* Fake up a method call to import */
1588 meth = newSVpvn("import", 6);
1589 (void)SvUPGRADE(meth, SVt_PVIV);
1590 (void)SvIOK_on(meth);
1591 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
1592 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1593 append_elem(OP_LIST,
1594 prepend_elem(OP_LIST, pack, list(arg)),
1595 newSVOP(OP_METHOD_NAMED, 0, meth)));
1596 imop->op_private |= OPpENTERSUB_NOMOD;
1598 /* Combine the ops. */
1599 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1603 =notfor apidoc apply_attrs_string
1605 Attempts to apply a list of attributes specified by the C<attrstr> and
1606 C<len> arguments to the subroutine identified by the C<cv> argument which
1607 is expected to be associated with the package identified by the C<stashpv>
1608 argument (see L<attributes>). It gets this wrong, though, in that it
1609 does not correctly identify the boundaries of the individual attribute
1610 specifications within C<attrstr>. This is not really intended for the
1611 public API, but has to be listed here for systems such as AIX which
1612 need an explicit export list for symbols. (It's called from XS code
1613 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1614 to respect attribute syntax properly would be welcome.
1620 Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
1621 char *attrstr, STRLEN len)
1626 len = strlen(attrstr);
1630 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1632 char *sstr = attrstr;
1633 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1634 attrs = append_elem(OP_LIST, attrs,
1635 newSVOP(OP_CONST, 0,
1636 newSVpvn(sstr, attrstr-sstr)));
1640 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1641 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1642 Nullsv, prepend_elem(OP_LIST,
1643 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1644 prepend_elem(OP_LIST,
1645 newSVOP(OP_CONST, 0,
1651 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1656 if (!o || PL_error_count)
1660 if (type == OP_LIST) {
1661 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1662 my_kid(kid, attrs, imopsp);
1663 } else if (type == OP_UNDEF) {
1665 } else if (type == OP_RV2SV || /* "our" declaration */
1667 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1668 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1669 yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
1670 OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
1672 GV *gv = cGVOPx_gv(cUNOPo->op_first);
1674 PL_in_my_stash = Nullhv;
1675 apply_attrs(GvSTASH(gv),
1676 (type == OP_RV2SV ? GvSV(gv) :
1677 type == OP_RV2AV ? (SV*)GvAV(gv) :
1678 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1681 o->op_private |= OPpOUR_INTRO;
1684 else if (type != OP_PADSV &&
1687 type != OP_PUSHMARK)
1689 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1691 PL_in_my == KEY_our ? "our" : "my"));
1694 else if (attrs && type != OP_PUSHMARK) {
1698 PL_in_my_stash = Nullhv;
1700 /* check for C<my Dog $spot> when deciding package */
1701 stash = PAD_COMPNAME_TYPE(o->op_targ);
1703 stash = PL_curstash;
1704 apply_attrs_my(stash, o, attrs, imopsp);
1706 o->op_flags |= OPf_MOD;
1707 o->op_private |= OPpLVAL_INTRO;
1712 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1715 int maybe_scalar = 0;
1717 /* [perl #17376]: this appears to be premature, and results in code such as
1718 C< our(%x); > executing in list mode rather than void mode */
1720 if (o->op_flags & OPf_PARENS)
1729 o = my_kid(o, attrs, &rops);
1731 if (maybe_scalar && o->op_type == OP_PADSV) {
1732 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1733 o->op_private |= OPpLVAL_INTRO;
1736 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1739 PL_in_my_stash = Nullhv;
1744 Perl_my(pTHX_ OP *o)
1746 return my_attrs(o, Nullop);
1750 Perl_sawparens(pTHX_ OP *o)
1753 o->op_flags |= OPf_PARENS;
1758 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1763 if (ckWARN(WARN_MISC) &&
1764 (left->op_type == OP_RV2AV ||
1765 left->op_type == OP_RV2HV ||
1766 left->op_type == OP_PADAV ||
1767 left->op_type == OP_PADHV)) {
1768 const char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
1769 right->op_type == OP_TRANS)
1770 ? right->op_type : OP_MATCH];
1771 const char *sample = ((left->op_type == OP_RV2AV ||
1772 left->op_type == OP_PADAV)
1773 ? "@array" : "%hash");
1774 Perl_warner(aTHX_ packWARN(WARN_MISC),
1775 "Applying %s to %s will act on scalar(%s)",
1776 desc, sample, sample);
1779 if (right->op_type == OP_CONST &&
1780 cSVOPx(right)->op_private & OPpCONST_BARE &&
1781 cSVOPx(right)->op_private & OPpCONST_STRICT)
1783 no_bareword_allowed(right);
1786 ismatchop = right->op_type == OP_MATCH ||
1787 right->op_type == OP_SUBST ||
1788 right->op_type == OP_TRANS;
1789 if (ismatchop && right->op_private & OPpTARGET_MY) {
1791 right->op_private &= ~OPpTARGET_MY;
1793 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1794 right->op_flags |= OPf_STACKED;
1795 if (right->op_type != OP_MATCH &&
1796 ! (right->op_type == OP_TRANS &&
1797 right->op_private & OPpTRANS_IDENTICAL))
1798 left = mod(left, right->op_type);
1799 if (right->op_type == OP_TRANS)
1800 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
1802 o = prepend_elem(right->op_type, scalar(left), right);
1804 return newUNOP(OP_NOT, 0, scalar(o));
1808 return bind_match(type, left,
1809 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
1813 Perl_invert(pTHX_ OP *o)
1817 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
1818 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1822 Perl_scope(pTHX_ OP *o)
1825 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1826 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1827 o->op_type = OP_LEAVE;
1828 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1830 else if (o->op_type == OP_LINESEQ) {
1832 o->op_type = OP_SCOPE;
1833 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1834 kid = ((LISTOP*)o)->op_first;
1835 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
1839 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
1844 /* XXX kept for BINCOMPAT only */
1846 Perl_save_hints(pTHX)
1848 Perl_croak(aTHX_ "internal error: obsolete function save_hints() called");
1852 Perl_block_start(pTHX_ int full)
1854 const int retval = PL_savestack_ix;
1855 pad_block_start(full);
1857 PL_hints &= ~HINT_BLOCK_SCOPE;
1858 SAVESPTR(PL_compiling.cop_warnings);
1859 if (! specialWARN(PL_compiling.cop_warnings)) {
1860 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1861 SAVEFREESV(PL_compiling.cop_warnings) ;
1863 SAVESPTR(PL_compiling.cop_io);
1864 if (! specialCopIO(PL_compiling.cop_io)) {
1865 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1866 SAVEFREESV(PL_compiling.cop_io) ;
1872 Perl_block_end(pTHX_ I32 floor, OP *seq)
1874 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1875 OP* retval = scalarseq(seq);
1877 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
1879 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
1887 I32 offset = pad_findmy("$_");
1888 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
1889 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1892 OP *o = newOP(OP_PADSV, 0);
1893 o->op_targ = offset;
1899 Perl_newPROG(pTHX_ OP *o)
1904 PL_eval_root = newUNOP(OP_LEAVEEVAL,
1905 ((PL_in_eval & EVAL_KEEPERR)
1906 ? OPf_SPECIAL : 0), o);
1907 PL_eval_start = linklist(PL_eval_root);
1908 PL_eval_root->op_private |= OPpREFCOUNTED;
1909 OpREFCNT_set(PL_eval_root, 1);
1910 PL_eval_root->op_next = 0;
1911 CALL_PEEP(PL_eval_start);
1914 if (o->op_type == OP_STUB) {
1915 PL_comppad_name = 0;
1920 PL_main_root = scope(sawparens(scalarvoid(o)));
1921 PL_curcop = &PL_compiling;
1922 PL_main_start = LINKLIST(PL_main_root);
1923 PL_main_root->op_private |= OPpREFCOUNTED;
1924 OpREFCNT_set(PL_main_root, 1);
1925 PL_main_root->op_next = 0;
1926 CALL_PEEP(PL_main_start);
1929 /* Register with debugger */
1931 CV *cv = get_cv("DB::postponed", FALSE);
1935 XPUSHs((SV*)CopFILEGV(&PL_compiling));
1937 call_sv((SV*)cv, G_DISCARD);
1944 Perl_localize(pTHX_ OP *o, I32 lex)
1946 if (o->op_flags & OPf_PARENS)
1947 /* [perl #17376]: this appears to be premature, and results in code such as
1948 C< our(%x); > executing in list mode rather than void mode */
1955 if (ckWARN(WARN_PARENTHESIS)
1956 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
1958 char *s = PL_bufptr;
1961 /* some heuristics to detect a potential error */
1962 while (*s && (strchr(", \t\n", *s)))
1966 if (*s && strchr("@$%*", *s) && *++s
1967 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
1970 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
1972 while (*s && (strchr(", \t\n", *s)))
1978 if (sigil && (*s == ';' || *s == '=')) {
1979 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
1980 "Parentheses missing around \"%s\" list",
1981 lex ? (PL_in_my == KEY_our ? "our" : "my")
1989 o = mod(o, OP_NULL); /* a bit kludgey */
1991 PL_in_my_stash = Nullhv;
1996 Perl_jmaybe(pTHX_ OP *o)
1998 if (o->op_type == OP_LIST) {
2000 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2001 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2007 Perl_fold_constants(pTHX_ register OP *o)
2010 I32 type = o->op_type;
2013 if (PL_opargs[type] & OA_RETSCALAR)
2015 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2016 o->op_targ = pad_alloc(type, SVs_PADTMP);
2018 /* integerize op, unless it happens to be C<-foo>.
2019 * XXX should pp_i_negate() do magic string negation instead? */
2020 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2021 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2022 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2024 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2027 if (!(PL_opargs[type] & OA_FOLDCONST))
2032 /* XXX might want a ck_negate() for this */
2033 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2045 /* XXX what about the numeric ops? */
2046 if (PL_hints & HINT_LOCALE)
2051 goto nope; /* Don't try to run w/ errors */
2053 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2054 if ((curop->op_type != OP_CONST ||
2055 (curop->op_private & OPpCONST_BARE)) &&
2056 curop->op_type != OP_LIST &&
2057 curop->op_type != OP_SCALAR &&
2058 curop->op_type != OP_NULL &&
2059 curop->op_type != OP_PUSHMARK)
2065 curop = LINKLIST(o);
2069 sv = *(PL_stack_sp--);
2070 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2071 pad_swipe(o->op_targ, FALSE);
2072 else if (SvTEMP(sv)) { /* grab mortal temp? */
2073 (void)SvREFCNT_inc(sv);
2077 if (type == OP_RV2GV)
2078 return newGVOP(OP_GV, 0, (GV*)sv);
2079 return newSVOP(OP_CONST, 0, sv);
2086 Perl_gen_constant_list(pTHX_ register OP *o)
2089 I32 oldtmps_floor = PL_tmps_floor;
2093 return o; /* Don't attempt to run with errors */
2095 PL_op = curop = LINKLIST(o);
2102 PL_tmps_floor = oldtmps_floor;
2104 o->op_type = OP_RV2AV;
2105 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2106 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2107 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2108 o->op_opt = 0; /* needs to be revisited in peep() */
2109 curop = ((UNOP*)o)->op_first;
2110 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2117 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2119 if (!o || o->op_type != OP_LIST)
2120 o = newLISTOP(OP_LIST, 0, o, Nullop);
2122 o->op_flags &= ~OPf_WANT;
2124 if (!(PL_opargs[type] & OA_MARK))
2125 op_null(cLISTOPo->op_first);
2127 o->op_type = (OPCODE)type;
2128 o->op_ppaddr = PL_ppaddr[type];
2129 o->op_flags |= flags;
2131 o = CHECKOP(type, o);
2132 if (o->op_type != type)
2135 return fold_constants(o);
2138 /* List constructors */
2141 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2149 if (first->op_type != type
2150 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2152 return newLISTOP(type, 0, first, last);
2155 if (first->op_flags & OPf_KIDS)
2156 ((LISTOP*)first)->op_last->op_sibling = last;
2158 first->op_flags |= OPf_KIDS;
2159 ((LISTOP*)first)->op_first = last;
2161 ((LISTOP*)first)->op_last = last;
2166 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2174 if (first->op_type != type)
2175 return prepend_elem(type, (OP*)first, (OP*)last);
2177 if (last->op_type != type)
2178 return append_elem(type, (OP*)first, (OP*)last);
2180 first->op_last->op_sibling = last->op_first;
2181 first->op_last = last->op_last;
2182 first->op_flags |= (last->op_flags & OPf_KIDS);
2190 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2198 if (last->op_type == type) {
2199 if (type == OP_LIST) { /* already a PUSHMARK there */
2200 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2201 ((LISTOP*)last)->op_first->op_sibling = first;
2202 if (!(first->op_flags & OPf_PARENS))
2203 last->op_flags &= ~OPf_PARENS;
2206 if (!(last->op_flags & OPf_KIDS)) {
2207 ((LISTOP*)last)->op_last = first;
2208 last->op_flags |= OPf_KIDS;
2210 first->op_sibling = ((LISTOP*)last)->op_first;
2211 ((LISTOP*)last)->op_first = first;
2213 last->op_flags |= OPf_KIDS;
2217 return newLISTOP(type, 0, first, last);
2223 Perl_newNULLLIST(pTHX)
2225 return newOP(OP_STUB, 0);
2229 Perl_force_list(pTHX_ OP *o)
2231 if (!o || o->op_type != OP_LIST)
2232 o = newLISTOP(OP_LIST, 0, o, Nullop);
2238 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2242 NewOp(1101, listop, 1, LISTOP);
2244 listop->op_type = (OPCODE)type;
2245 listop->op_ppaddr = PL_ppaddr[type];
2248 listop->op_flags = (U8)flags;
2252 else if (!first && last)
2255 first->op_sibling = last;
2256 listop->op_first = first;
2257 listop->op_last = last;
2258 if (type == OP_LIST) {
2260 pushop = newOP(OP_PUSHMARK, 0);
2261 pushop->op_sibling = first;
2262 listop->op_first = pushop;
2263 listop->op_flags |= OPf_KIDS;
2265 listop->op_last = pushop;
2268 return CHECKOP(type, listop);
2272 Perl_newOP(pTHX_ I32 type, I32 flags)
2275 NewOp(1101, o, 1, OP);
2276 o->op_type = (OPCODE)type;
2277 o->op_ppaddr = PL_ppaddr[type];
2278 o->op_flags = (U8)flags;
2281 o->op_private = (U8)(0 | (flags >> 8));
2282 if (PL_opargs[type] & OA_RETSCALAR)
2284 if (PL_opargs[type] & OA_TARGET)
2285 o->op_targ = pad_alloc(type, SVs_PADTMP);
2286 return CHECKOP(type, o);
2290 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2295 first = newOP(OP_STUB, 0);
2296 if (PL_opargs[type] & OA_MARK)
2297 first = force_list(first);
2299 NewOp(1101, unop, 1, UNOP);
2300 unop->op_type = (OPCODE)type;
2301 unop->op_ppaddr = PL_ppaddr[type];
2302 unop->op_first = first;
2303 unop->op_flags = flags | OPf_KIDS;
2304 unop->op_private = (U8)(1 | (flags >> 8));
2305 unop = (UNOP*) CHECKOP(type, unop);
2309 return fold_constants((OP *) unop);
2313 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2316 NewOp(1101, binop, 1, BINOP);
2319 first = newOP(OP_NULL, 0);
2321 binop->op_type = (OPCODE)type;
2322 binop->op_ppaddr = PL_ppaddr[type];
2323 binop->op_first = first;
2324 binop->op_flags = flags | OPf_KIDS;
2327 binop->op_private = (U8)(1 | (flags >> 8));
2330 binop->op_private = (U8)(2 | (flags >> 8));
2331 first->op_sibling = last;
2334 binop = (BINOP*)CHECKOP(type, binop);
2335 if (binop->op_next || binop->op_type != (OPCODE)type)
2338 binop->op_last = binop->op_first->op_sibling;
2340 return fold_constants((OP *)binop);
2344 uvcompare(const void *a, const void *b)
2346 if (*((const UV *)a) < (*(const UV *)b))
2348 if (*((const UV *)a) > (*(const UV *)b))
2350 if (*((const UV *)a+1) < (*(const UV *)b+1))
2352 if (*((const UV *)a+1) > (*(const UV *)b+1))
2358 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2360 SV *tstr = ((SVOP*)expr)->op_sv;
2361 SV *rstr = ((SVOP*)repl)->op_sv;
2364 U8 *t = (U8*)SvPV(tstr, tlen);
2365 U8 *r = (U8*)SvPV(rstr, rlen);
2372 register short *tbl;
2374 PL_hints |= HINT_BLOCK_SCOPE;
2375 complement = o->op_private & OPpTRANS_COMPLEMENT;
2376 del = o->op_private & OPpTRANS_DELETE;
2377 squash = o->op_private & OPpTRANS_SQUASH;
2380 o->op_private |= OPpTRANS_FROM_UTF;
2383 o->op_private |= OPpTRANS_TO_UTF;
2385 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2386 SV* listsv = newSVpvn("# comment\n",10);
2388 U8* tend = t + tlen;
2389 U8* rend = r + rlen;
2403 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2404 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2410 tsave = t = bytes_to_utf8(t, &len);
2413 if (!to_utf && rlen) {
2415 rsave = r = bytes_to_utf8(r, &len);
2419 /* There are several snags with this code on EBCDIC:
2420 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2421 2. scan_const() in toke.c has encoded chars in native encoding which makes
2422 ranges at least in EBCDIC 0..255 range the bottom odd.
2426 U8 tmpbuf[UTF8_MAXBYTES+1];
2429 New(1109, cp, 2*tlen, UV);
2431 transv = newSVpvn("",0);
2433 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2435 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2437 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2441 cp[2*i+1] = cp[2*i];
2445 qsort(cp, i, 2*sizeof(UV), uvcompare);
2446 for (j = 0; j < i; j++) {
2448 diff = val - nextmin;
2450 t = uvuni_to_utf8(tmpbuf,nextmin);
2451 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2453 U8 range_mark = UTF_TO_NATIVE(0xff);
2454 t = uvuni_to_utf8(tmpbuf, val - 1);
2455 sv_catpvn(transv, (char *)&range_mark, 1);
2456 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2463 t = uvuni_to_utf8(tmpbuf,nextmin);
2464 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2466 U8 range_mark = UTF_TO_NATIVE(0xff);
2467 sv_catpvn(transv, (char *)&range_mark, 1);
2469 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2470 UNICODE_ALLOW_SUPER);
2471 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2472 t = (U8*)SvPVX(transv);
2473 tlen = SvCUR(transv);
2477 else if (!rlen && !del) {
2478 r = t; rlen = tlen; rend = tend;
2481 if ((!rlen && !del) || t == r ||
2482 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2484 o->op_private |= OPpTRANS_IDENTICAL;
2488 while (t < tend || tfirst <= tlast) {
2489 /* see if we need more "t" chars */
2490 if (tfirst > tlast) {
2491 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2493 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2495 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2502 /* now see if we need more "r" chars */
2503 if (rfirst > rlast) {
2505 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2507 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2509 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2518 rfirst = rlast = 0xffffffff;
2522 /* now see which range will peter our first, if either. */
2523 tdiff = tlast - tfirst;
2524 rdiff = rlast - rfirst;
2531 if (rfirst == 0xffffffff) {
2532 diff = tdiff; /* oops, pretend rdiff is infinite */
2534 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2535 (long)tfirst, (long)tlast);
2537 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2541 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2542 (long)tfirst, (long)(tfirst + diff),
2545 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2546 (long)tfirst, (long)rfirst);
2548 if (rfirst + diff > max)
2549 max = rfirst + diff;
2551 grows = (tfirst < rfirst &&
2552 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2564 else if (max > 0xff)
2569 Safefree(cPVOPo->op_pv);
2570 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2571 SvREFCNT_dec(listsv);
2573 SvREFCNT_dec(transv);
2575 if (!del && havefinal && rlen)
2576 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2577 newSVuv((UV)final), 0);
2580 o->op_private |= OPpTRANS_GROWS;
2592 tbl = (short*)cPVOPo->op_pv;
2594 Zero(tbl, 256, short);
2595 for (i = 0; i < (I32)tlen; i++)
2597 for (i = 0, j = 0; i < 256; i++) {
2599 if (j >= (I32)rlen) {
2608 if (i < 128 && r[j] >= 128)
2618 o->op_private |= OPpTRANS_IDENTICAL;
2620 else if (j >= (I32)rlen)
2623 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2624 tbl[0x100] = rlen - j;
2625 for (i=0; i < (I32)rlen - j; i++)
2626 tbl[0x101+i] = r[j+i];
2630 if (!rlen && !del) {
2633 o->op_private |= OPpTRANS_IDENTICAL;
2635 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2636 o->op_private |= OPpTRANS_IDENTICAL;
2638 for (i = 0; i < 256; i++)
2640 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
2641 if (j >= (I32)rlen) {
2643 if (tbl[t[i]] == -1)
2649 if (tbl[t[i]] == -1) {
2650 if (t[i] < 128 && r[j] >= 128)
2657 o->op_private |= OPpTRANS_GROWS;
2665 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2669 NewOp(1101, pmop, 1, PMOP);
2670 pmop->op_type = (OPCODE)type;
2671 pmop->op_ppaddr = PL_ppaddr[type];
2672 pmop->op_flags = (U8)flags;
2673 pmop->op_private = (U8)(0 | (flags >> 8));
2675 if (PL_hints & HINT_RE_TAINT)
2676 pmop->op_pmpermflags |= PMf_RETAINT;
2677 if (PL_hints & HINT_LOCALE)
2678 pmop->op_pmpermflags |= PMf_LOCALE;
2679 pmop->op_pmflags = pmop->op_pmpermflags;
2684 if(av_len((AV*) PL_regex_pad[0]) > -1) {
2685 repointer = av_pop((AV*)PL_regex_pad[0]);
2686 pmop->op_pmoffset = SvIV(repointer);
2687 SvREPADTMP_off(repointer);
2688 sv_setiv(repointer,0);
2690 repointer = newSViv(0);
2691 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2692 pmop->op_pmoffset = av_len(PL_regex_padav);
2693 PL_regex_pad = AvARRAY(PL_regex_padav);
2698 /* link into pm list */
2699 if (type != OP_TRANS && PL_curstash) {
2700 pmop->op_pmnext = HvPMROOT(PL_curstash);
2701 HvPMROOT(PL_curstash) = pmop;
2702 PmopSTASH_set(pmop,PL_curstash);
2705 return CHECKOP(type, pmop);
2708 /* Given some sort of match op o, and an expression expr containing a
2709 * pattern, either compile expr into a regex and attach it to o (if it's
2710 * constant), or convert expr into a runtime regcomp op sequence (if it's
2713 * isreg indicates that the pattern is part of a regex construct, eg
2714 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
2715 * split "pattern", which aren't. In the former case, expr will be a list
2716 * if the pattern contains more than one term (eg /a$b/) or if it contains
2717 * a replacement, ie s/// or tr///.
2721 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
2725 I32 repl_has_vars = 0;
2729 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
2730 /* last element in list is the replacement; pop it */
2732 repl = cLISTOPx(expr)->op_last;
2733 kid = cLISTOPx(expr)->op_first;
2734 while (kid->op_sibling != repl)
2735 kid = kid->op_sibling;
2736 kid->op_sibling = Nullop;
2737 cLISTOPx(expr)->op_last = kid;
2740 if (isreg && expr->op_type == OP_LIST &&
2741 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
2743 /* convert single element list to element */
2745 expr = cLISTOPx(oe)->op_first->op_sibling;
2746 cLISTOPx(oe)->op_first->op_sibling = Nullop;
2747 cLISTOPx(oe)->op_last = Nullop;
2751 if (o->op_type == OP_TRANS) {
2752 return pmtrans(o, expr, repl);
2755 reglist = isreg && expr->op_type == OP_LIST;
2759 PL_hints |= HINT_BLOCK_SCOPE;
2762 if (expr->op_type == OP_CONST) {
2764 SV *pat = ((SVOP*)expr)->op_sv;
2765 char *p = SvPV(pat, plen);
2766 if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
2767 sv_setpvn(pat, "\\s+", 3);
2768 p = SvPV(pat, plen);
2769 pm->op_pmflags |= PMf_SKIPWHITE;
2772 pm->op_pmdynflags |= PMdf_UTF8;
2773 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
2774 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
2775 pm->op_pmflags |= PMf_WHITE;
2779 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2780 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2782 : OP_REGCMAYBE),0,expr);
2784 NewOp(1101, rcop, 1, LOGOP);
2785 rcop->op_type = OP_REGCOMP;
2786 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2787 rcop->op_first = scalar(expr);
2788 rcop->op_flags |= OPf_KIDS
2789 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
2790 | (reglist ? OPf_STACKED : 0);
2791 rcop->op_private = 1;
2794 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
2796 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
2799 /* establish postfix order */
2800 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2802 rcop->op_next = expr;
2803 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2806 rcop->op_next = LINKLIST(expr);
2807 expr->op_next = (OP*)rcop;
2810 prepend_elem(o->op_type, scalar((OP*)rcop), o);
2815 if (pm->op_pmflags & PMf_EVAL) {
2817 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
2818 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
2820 else if (repl->op_type == OP_CONST)
2824 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
2825 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
2826 if (curop->op_type == OP_GV) {
2827 GV *gv = cGVOPx_gv(curop);
2829 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
2832 else if (curop->op_type == OP_RV2CV)
2834 else if (curop->op_type == OP_RV2SV ||
2835 curop->op_type == OP_RV2AV ||
2836 curop->op_type == OP_RV2HV ||
2837 curop->op_type == OP_RV2GV) {
2838 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2841 else if (curop->op_type == OP_PADSV ||
2842 curop->op_type == OP_PADAV ||
2843 curop->op_type == OP_PADHV ||
2844 curop->op_type == OP_PADANY) {
2847 else if (curop->op_type == OP_PUSHRE)
2848 ; /* Okay here, dangerous in newASSIGNOP */
2858 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
2859 pm->op_pmflags |= PMf_CONST; /* const for long enough */
2860 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
2861 prepend_elem(o->op_type, scalar(repl), o);
2864 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
2865 pm->op_pmflags |= PMf_MAYBE_CONST;
2866 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2868 NewOp(1101, rcop, 1, LOGOP);
2869 rcop->op_type = OP_SUBSTCONT;
2870 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
2871 rcop->op_first = scalar(repl);
2872 rcop->op_flags |= OPf_KIDS;
2873 rcop->op_private = 1;
2876 /* establish postfix order */
2877 rcop->op_next = LINKLIST(repl);
2878 repl->op_next = (OP*)rcop;
2880 pm->op_pmreplroot = scalar((OP*)rcop);
2881 pm->op_pmreplstart = LINKLIST(rcop);
2890 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
2893 NewOp(1101, svop, 1, SVOP);
2894 svop->op_type = (OPCODE)type;
2895 svop->op_ppaddr = PL_ppaddr[type];
2897 svop->op_next = (OP*)svop;
2898 svop->op_flags = (U8)flags;
2899 if (PL_opargs[type] & OA_RETSCALAR)
2901 if (PL_opargs[type] & OA_TARGET)
2902 svop->op_targ = pad_alloc(type, SVs_PADTMP);
2903 return CHECKOP(type, svop);
2907 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2910 NewOp(1101, padop, 1, PADOP);
2911 padop->op_type = (OPCODE)type;
2912 padop->op_ppaddr = PL_ppaddr[type];
2913 padop->op_padix = pad_alloc(type, SVs_PADTMP);
2914 SvREFCNT_dec(PAD_SVl(padop->op_padix));
2915 PAD_SETSV(padop->op_padix, sv);
2918 padop->op_next = (OP*)padop;
2919 padop->op_flags = (U8)flags;
2920 if (PL_opargs[type] & OA_RETSCALAR)
2922 if (PL_opargs[type] & OA_TARGET)
2923 padop->op_targ = pad_alloc(type, SVs_PADTMP);
2924 return CHECKOP(type, padop);
2928 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
2933 return newPADOP(type, flags, SvREFCNT_inc(gv));
2935 return newSVOP(type, flags, SvREFCNT_inc(gv));
2940 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
2943 NewOp(1101, pvop, 1, PVOP);
2944 pvop->op_type = (OPCODE)type;
2945 pvop->op_ppaddr = PL_ppaddr[type];
2947 pvop->op_next = (OP*)pvop;
2948 pvop->op_flags = (U8)flags;
2949 if (PL_opargs[type] & OA_RETSCALAR)
2951 if (PL_opargs[type] & OA_TARGET)
2952 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
2953 return CHECKOP(type, pvop);
2957 Perl_package(pTHX_ OP *o)
2962 save_hptr(&PL_curstash);
2963 save_item(PL_curstname);
2965 name = SvPV(cSVOPo->op_sv, len);
2966 PL_curstash = gv_stashpvn(name, len, TRUE);
2967 sv_setpvn(PL_curstname, name, len);
2970 PL_hints |= HINT_BLOCK_SCOPE;
2971 PL_copline = NOLINE;
2976 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
2982 if (idop->op_type != OP_CONST)
2983 Perl_croak(aTHX_ "Module name must be constant");
2987 if (version != Nullop) {
2988 SV *vesv = ((SVOP*)version)->op_sv;
2990 if (arg == Nullop && !SvNIOKp(vesv)) {
2997 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
2998 Perl_croak(aTHX_ "Version number must be constant number");
3000 /* Make copy of idop so we don't free it twice */
3001 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3003 /* Fake up a method call to VERSION */
3004 meth = newSVpvn("VERSION",7);
3005 sv_upgrade(meth, SVt_PVIV);
3006 (void)SvIOK_on(meth);
3007 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3008 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3009 append_elem(OP_LIST,
3010 prepend_elem(OP_LIST, pack, list(version)),
3011 newSVOP(OP_METHOD_NAMED, 0, meth)));
3015 /* Fake up an import/unimport */
3016 if (arg && arg->op_type == OP_STUB)
3017 imop = arg; /* no import on explicit () */
3018 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3019 imop = Nullop; /* use 5.0; */
3024 /* Make copy of idop so we don't free it twice */
3025 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3027 /* Fake up a method call to import/unimport */
3028 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);
3029 (void)SvUPGRADE(meth, SVt_PVIV);
3030 (void)SvIOK_on(meth);
3031 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3032 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3033 append_elem(OP_LIST,
3034 prepend_elem(OP_LIST, pack, list(arg)),
3035 newSVOP(OP_METHOD_NAMED, 0, meth)));
3038 /* Fake up the BEGIN {}, which does its thing immediately. */
3040 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3043 append_elem(OP_LINESEQ,
3044 append_elem(OP_LINESEQ,
3045 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, idop)),
3046 newSTATEOP(0, Nullch, veop)),
3047 newSTATEOP(0, Nullch, imop) ));
3049 /* The "did you use incorrect case?" warning used to be here.
3050 * The problem is that on case-insensitive filesystems one
3051 * might get false positives for "use" (and "require"):
3052 * "use Strict" or "require CARP" will work. This causes
3053 * portability problems for the script: in case-strict
3054 * filesystems the script will stop working.
3056 * The "incorrect case" warning checked whether "use Foo"
3057 * imported "Foo" to your namespace, but that is wrong, too:
3058 * there is no requirement nor promise in the language that
3059 * a Foo.pm should or would contain anything in package "Foo".
3061 * There is very little Configure-wise that can be done, either:
3062 * the case-sensitivity of the build filesystem of Perl does not
3063 * help in guessing the case-sensitivity of the runtime environment.
3066 PL_hints |= HINT_BLOCK_SCOPE;
3067 PL_copline = NOLINE;
3069 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3073 =head1 Embedding Functions
3075 =for apidoc load_module
3077 Loads the module whose name is pointed to by the string part of name.
3078 Note that the actual module name, not its filename, should be given.
3079 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3080 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3081 (or 0 for no flags). ver, if specified, provides version semantics
3082 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3083 arguments can be used to specify arguments to the module's import()
3084 method, similar to C<use Foo::Bar VERSION LIST>.
3089 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3092 va_start(args, ver);
3093 vload_module(flags, name, ver, &args);
3097 #ifdef PERL_IMPLICIT_CONTEXT
3099 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3103 va_start(args, ver);
3104 vload_module(flags, name, ver, &args);
3110 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3112 OP *modname, *veop, *imop;
3114 modname = newSVOP(OP_CONST, 0, name);
3115 modname->op_private |= OPpCONST_BARE;
3117 veop = newSVOP(OP_CONST, 0, ver);
3121 if (flags & PERL_LOADMOD_NOIMPORT) {
3122 imop = sawparens(newNULLLIST());
3124 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3125 imop = va_arg(*args, OP*);
3130 sv = va_arg(*args, SV*);
3132 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3133 sv = va_arg(*args, SV*);
3137 line_t ocopline = PL_copline;
3138 COP *ocurcop = PL_curcop;
3139 int oexpect = PL_expect;
3141 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3142 veop, modname, imop);
3143 PL_expect = oexpect;
3144 PL_copline = ocopline;
3145 PL_curcop = ocurcop;
3150 Perl_dofile(pTHX_ OP *term)
3155 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3156 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
3157 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3159 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3160 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3161 append_elem(OP_LIST, term,
3162 scalar(newUNOP(OP_RV2CV, 0,
3167 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3173 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3175 return newBINOP(OP_LSLICE, flags,
3176 list(force_list(subscript)),
3177 list(force_list(listval)) );
3181 S_list_assignment(pTHX_ register OP *o)
3186 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3187 o = cUNOPo->op_first;
3189 if (o->op_type == OP_COND_EXPR) {
3190 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3191 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3196 yyerror("Assignment to both a list and a scalar");
3200 if (o->op_type == OP_LIST &&
3201 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3202 o->op_private & OPpLVAL_INTRO)
3205 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3206 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3207 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3210 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3213 if (o->op_type == OP_RV2SV)
3220 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3225 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3226 return newLOGOP(optype, 0,
3227 mod(scalar(left), optype),
3228 newUNOP(OP_SASSIGN, 0, scalar(right)));
3231 return newBINOP(optype, OPf_STACKED,
3232 mod(scalar(left), optype), scalar(right));
3236 if (list_assignment(left)) {
3240 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3241 left = mod(left, OP_AASSIGN);
3249 /* optimise C<my @x = ()> to C<my @x>, and likewise for hashes */
3250 if ((left->op_type == OP_PADAV || left->op_type == OP_PADHV)
3251 && right->op_type == OP_STUB
3252 && (left->op_private & OPpLVAL_INTRO))
3255 left->op_flags &= ~(OPf_REF|OPf_SPECIAL);
3258 curop = list(force_list(left));
3259 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3260 o->op_private = (U8)(0 | (flags >> 8));
3262 /* PL_generation sorcery:
3263 * an assignment like ($a,$b) = ($c,$d) is easier than
3264 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3265 * To detect whether there are common vars, the global var
3266 * PL_generation is incremented for each assign op we compile.
3267 * Then, while compiling the assign op, we run through all the
3268 * variables on both sides of the assignment, setting a spare slot
3269 * in each of them to PL_generation. If any of them already have
3270 * that value, we know we've got commonality. We could use a
3271 * single bit marker, but then we'd have to make 2 passes, first
3272 * to clear the flag, then to test and set it. To find somewhere
3273 * to store these values, evil chicanery is done with SvCUR().
3276 if (!(left->op_private & OPpLVAL_INTRO)) {
3279 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3280 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3281 if (curop->op_type == OP_GV) {
3282 GV *gv = cGVOPx_gv(curop);
3283 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3285 SvCUR(gv) = PL_generation;
3287 else if (curop->op_type == OP_PADSV ||
3288 curop->op_type == OP_PADAV ||
3289 curop->op_type == OP_PADHV ||
3290 curop->op_type == OP_PADANY)
3292 if (PAD_COMPNAME_GEN(curop->op_targ)
3293 == (STRLEN)PL_generation)
3295 PAD_COMPNAME_GEN(curop->op_targ)
3299 else if (curop->op_type == OP_RV2CV)
3301 else if (curop->op_type == OP_RV2SV ||
3302 curop->op_type == OP_RV2AV ||
3303 curop->op_type == OP_RV2HV ||
3304 curop->op_type == OP_RV2GV) {
3305 if (lastop->op_type != OP_GV) /* funny deref? */
3308 else if (curop->op_type == OP_PUSHRE) {
3309 if (((PMOP*)curop)->op_pmreplroot) {
3311 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3312 ((PMOP*)curop)->op_pmreplroot));
3314 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3316 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3318 SvCUR(gv) = PL_generation;
3327 o->op_private |= OPpASSIGN_COMMON;
3329 if (right && right->op_type == OP_SPLIT) {
3331 if ((tmpop = ((LISTOP*)right)->op_first) &&
3332 tmpop->op_type == OP_PUSHRE)
3334 PMOP *pm = (PMOP*)tmpop;
3335 if (left->op_type == OP_RV2AV &&
3336 !(left->op_private & OPpLVAL_INTRO) &&
3337 !(o->op_private & OPpASSIGN_COMMON) )
3339 tmpop = ((UNOP*)left)->op_first;
3340 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3342 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3343 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3345 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3346 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3348 pm->op_pmflags |= PMf_ONCE;
3349 tmpop = cUNOPo->op_first; /* to list (nulled) */
3350 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3351 tmpop->op_sibling = Nullop; /* don't free split */
3352 right->op_next = tmpop->op_next; /* fix starting loc */
3353 op_free(o); /* blow off assign */
3354 right->op_flags &= ~OPf_WANT;
3355 /* "I don't know and I don't care." */
3360 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3361 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3363 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3365 sv_setiv(sv, PL_modcount+1);
3373 right = newOP(OP_UNDEF, 0);
3374 if (right->op_type == OP_READLINE) {
3375 right->op_flags |= OPf_STACKED;
3376 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3379 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3380 o = newBINOP(OP_SASSIGN, flags,
3381 scalar(right), mod(scalar(left), OP_SASSIGN) );
3393 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3395 const U32 seq = intro_my();
3398 NewOp(1101, cop, 1, COP);
3399 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3400 cop->op_type = OP_DBSTATE;
3401 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3404 cop->op_type = OP_NEXTSTATE;
3405 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3407 cop->op_flags = (U8)flags;
3408 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3410 cop->op_private |= NATIVE_HINTS;
3412 PL_compiling.op_private = cop->op_private;
3413 cop->op_next = (OP*)cop;
3416 cop->cop_label = label;
3417 PL_hints |= HINT_BLOCK_SCOPE;
3420 cop->cop_arybase = PL_curcop->cop_arybase;
3421 if (specialWARN(PL_curcop->cop_warnings))
3422 cop->cop_warnings = PL_curcop->cop_warnings ;
3424 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3425 if (specialCopIO(PL_curcop->cop_io))
3426 cop->cop_io = PL_curcop->cop_io;
3428 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3431 if (PL_copline == NOLINE)
3432 CopLINE_set(cop, CopLINE(PL_curcop));
3434 CopLINE_set(cop, PL_copline);
3435 PL_copline = NOLINE;
3438 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3440 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3442 CopSTASH_set(cop, PL_curstash);
3444 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3445 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3446 if (svp && *svp != &PL_sv_undef ) {
3447 (void)SvIOK_on(*svp);
3448 SvIVX(*svp) = PTR2IV(cop);
3452 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3457 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3459 return new_logop(type, flags, &first, &other);
3463 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3467 OP *first = *firstp;
3468 OP *other = *otherp;
3470 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3471 return newBINOP(type, flags, scalar(first), scalar(other));
3473 scalarboolean(first);
3474 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3475 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3476 if (type == OP_AND || type == OP_OR) {
3482 first = *firstp = cUNOPo->op_first;
3484 first->op_next = o->op_next;
3485 cUNOPo->op_first = Nullop;
3489 if (first->op_type == OP_CONST) {
3490 if (first->op_private & OPpCONST_STRICT)
3491 no_bareword_allowed(first);
3492 else if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3493 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3494 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
3495 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
3496 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
3499 if (other->op_type == OP_CONST)
3500 other->op_private |= OPpCONST_SHORTCIRCUIT;
3504 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
3506 if ( ! (o2->op_type == OP_LIST
3507 && (( o2 = cUNOPx(o2)->op_first))
3508 && o2->op_type == OP_PUSHMARK
3509 && (( o2 = o2->op_sibling)) )
3512 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
3513 || o2->op_type == OP_PADHV)
3514 && o2->op_private & OPpLVAL_INTRO
3515 && ckWARN(WARN_DEPRECATED))
3517 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
3518 "Deprecated use of my() in false conditional");
3523 if (first->op_type == OP_CONST)
3524 first->op_private |= OPpCONST_SHORTCIRCUIT;
3528 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS) &&
3529 type != OP_DOR) /* [#24076] Don't warn for <FH> err FOO. */
3531 OP *k1 = ((UNOP*)first)->op_first;
3532 OP *k2 = k1->op_sibling;
3534 switch (first->op_type)
3537 if (k2 && k2->op_type == OP_READLINE
3538 && (k2->op_flags & OPf_STACKED)
3539 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3541 warnop = k2->op_type;
3546 if (k1->op_type == OP_READDIR
3547 || k1->op_type == OP_GLOB
3548 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3549 || k1->op_type == OP_EACH)
3551 warnop = ((k1->op_type == OP_NULL)
3552 ? (OPCODE)k1->op_targ : k1->op_type);
3557 line_t oldline = CopLINE(PL_curcop);
3558 CopLINE_set(PL_curcop, PL_copline);
3559 Perl_warner(aTHX_ packWARN(WARN_MISC),
3560 "Value of %s%s can be \"0\"; test with defined()",
3562 ((warnop == OP_READLINE || warnop == OP_GLOB)
3563 ? " construct" : "() operator"));
3564 CopLINE_set(PL_curcop, oldline);
3571 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3572 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3574 NewOp(1101, logop, 1, LOGOP);
3576 logop->op_type = (OPCODE)type;
3577 logop->op_ppaddr = PL_ppaddr[type];
3578 logop->op_first = first;
3579 logop->op_flags = flags | OPf_KIDS;
3580 logop->op_other = LINKLIST(other);
3581 logop->op_private = (U8)(1 | (flags >> 8));
3583 /* establish postfix order */
3584 logop->op_next = LINKLIST(first);
3585 first->op_next = (OP*)logop;
3586 first->op_sibling = other;
3588 CHECKOP(type,logop);
3590 o = newUNOP(OP_NULL, 0, (OP*)logop);
3597 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3604 return newLOGOP(OP_AND, 0, first, trueop);
3606 return newLOGOP(OP_OR, 0, first, falseop);
3608 scalarboolean(first);
3609 if (first->op_type == OP_CONST) {
3610 if (first->op_private & OPpCONST_BARE &&
3611 first->op_private & OPpCONST_STRICT) {
3612 no_bareword_allowed(first);
3614 if (SvTRUE(((SVOP*)first)->op_sv)) {
3625 NewOp(1101, logop, 1, LOGOP);
3626 logop->op_type = OP_COND_EXPR;
3627 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3628 logop->op_first = first;
3629 logop->op_flags = flags | OPf_KIDS;
3630 logop->op_private = (U8)(1 | (flags >> 8));
3631 logop->op_other = LINKLIST(trueop);
3632 logop->op_next = LINKLIST(falseop);
3634 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
3637 /* establish postfix order */
3638 start = LINKLIST(first);
3639 first->op_next = (OP*)logop;
3641 first->op_sibling = trueop;
3642 trueop->op_sibling = falseop;
3643 o = newUNOP(OP_NULL, 0, (OP*)logop);
3645 trueop->op_next = falseop->op_next = o;
3652 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3660 NewOp(1101, range, 1, LOGOP);
3662 range->op_type = OP_RANGE;
3663 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3664 range->op_first = left;
3665 range->op_flags = OPf_KIDS;
3666 leftstart = LINKLIST(left);
3667 range->op_other = LINKLIST(right);
3668 range->op_private = (U8)(1 | (flags >> 8));
3670 left->op_sibling = right;
3672 range->op_next = (OP*)range;
3673 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3674 flop = newUNOP(OP_FLOP, 0, flip);
3675 o = newUNOP(OP_NULL, 0, flop);
3677 range->op_next = leftstart;
3679 left->op_next = flip;
3680 right->op_next = flop;
3682 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3683 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3684 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3685 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3687 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3688 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3691 if (!flip->op_private || !flop->op_private)
3692 linklist(o); /* blow off optimizer unless constant */
3698 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3702 const bool once = block && block->op_flags & OPf_SPECIAL &&
3703 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3707 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3708 return block; /* do {} while 0 does once */
3709 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3710 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3711 expr = newUNOP(OP_DEFINED, 0,
3712 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3713 } else if (expr->op_flags & OPf_KIDS) {
3714 const OP *k1 = ((UNOP*)expr)->op_first;
3715 const OP *k2 = (k1) ? k1->op_sibling : NULL;
3716 switch (expr->op_type) {
3718 if (k2 && k2->op_type == OP_READLINE
3719 && (k2->op_flags & OPf_STACKED)
3720 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3721 expr = newUNOP(OP_DEFINED, 0, expr);
3725 if (k1->op_type == OP_READDIR
3726 || k1->op_type == OP_GLOB
3727 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3728 || k1->op_type == OP_EACH)
3729 expr = newUNOP(OP_DEFINED, 0, expr);
3735 /* if block is null, the next append_elem() would put UNSTACK, a scalar
3736 * op, in listop. This is wrong. [perl #27024] */
3738 block = newOP(OP_NULL, 0);
3739 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3740 o = new_logop(OP_AND, 0, &expr, &listop);
3743 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3745 if (once && o != listop)
3746 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3749 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3751 o->op_flags |= flags;
3753 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3758 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3767 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3768 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3769 expr = newUNOP(OP_DEFINED, 0,
3770 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3771 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3772 const OP *k1 = ((UNOP*)expr)->op_first;
3773 const OP *k2 = (k1) ? k1->op_sibling : NULL;
3774 switch (expr->op_type) {
3776 if (k2 && k2->op_type == OP_READLINE
3777 && (k2->op_flags & OPf_STACKED)
3778 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3779 expr = newUNOP(OP_DEFINED, 0, expr);
3783 if (k1->op_type == OP_READDIR
3784 || k1->op_type == OP_GLOB
3785 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3786 || k1->op_type == OP_EACH)
3787 expr = newUNOP(OP_DEFINED, 0, expr);
3793 block = newOP(OP_NULL, 0);
3795 block = scope(block);
3799 next = LINKLIST(cont);
3802 OP *unstack = newOP(OP_UNSTACK, 0);
3805 cont = append_elem(OP_LINESEQ, cont, unstack);
3808 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3809 redo = LINKLIST(listop);
3812 PL_copline = (line_t)whileline;
3814 o = new_logop(OP_AND, 0, &expr, &listop);
3815 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3816 op_free(expr); /* oops, it's a while (0) */
3818 return Nullop; /* listop already freed by new_logop */
3821 ((LISTOP*)listop)->op_last->op_next =
3822 (o == listop ? redo : LINKLIST(o));
3828 NewOp(1101,loop,1,LOOP);
3829 loop->op_type = OP_ENTERLOOP;
3830 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3831 loop->op_private = 0;
3832 loop->op_next = (OP*)loop;
3835 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3837 loop->op_redoop = redo;
3838 loop->op_lastop = o;
3839 o->op_private |= loopflags;
3842 loop->op_nextop = next;
3844 loop->op_nextop = o;
3846 o->op_flags |= flags;
3847 o->op_private |= (flags >> 8);
3852 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
3856 PADOFFSET padoff = 0;
3861 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
3862 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
3863 sv->op_type = OP_RV2GV;
3864 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3866 else if (sv->op_type == OP_PADSV) { /* private variable */
3867 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
3868 padoff = sv->op_targ;
3873 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3874 padoff = sv->op_targ;
3876 iterflags |= OPf_SPECIAL;
3881 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3884 const I32 offset = pad_findmy("$_");
3885 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
3886 sv = newGVOP(OP_GV, 0, PL_defgv);
3892 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3893 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3894 iterflags |= OPf_STACKED;
3896 else if (expr->op_type == OP_NULL &&
3897 (expr->op_flags & OPf_KIDS) &&
3898 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3900 /* Basically turn for($x..$y) into the same as for($x,$y), but we
3901 * set the STACKED flag to indicate that these values are to be
3902 * treated as min/max values by 'pp_iterinit'.
3904 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
3905 LOGOP* range = (LOGOP*) flip->op_first;
3906 OP* left = range->op_first;
3907 OP* right = left->op_sibling;
3910 range->op_flags &= ~OPf_KIDS;
3911 range->op_first = Nullop;
3913 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
3914 listop->op_first->op_next = range->op_next;
3915 left->op_next = range->op_other;
3916 right->op_next = (OP*)listop;
3917 listop->op_next = listop->op_first;
3920 expr = (OP*)(listop);
3922 iterflags |= OPf_STACKED;
3925 expr = mod(force_list(expr), OP_GREPSTART);
3928 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
3929 append_elem(OP_LIST, expr, scalar(sv))));
3930 assert(!loop->op_next);
3931 /* for my $x () sets OPpLVAL_INTRO;
3932 * for our $x () sets OPpOUR_INTRO */
3933 loop->op_private = (U8)iterpflags;
3934 #ifdef PL_OP_SLAB_ALLOC
3937 NewOp(1234,tmp,1,LOOP);
3938 Copy(loop,tmp,1,LISTOP);
3943 Renew(loop, 1, LOOP);
3945 loop->op_targ = padoff;
3946 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
3947 PL_copline = forline;
3948 return newSTATEOP(0, label, wop);
3952 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
3957 if (type != OP_GOTO || label->op_type == OP_CONST) {
3958 /* "last()" means "last" */
3959 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
3960 o = newOP(type, OPf_SPECIAL);
3962 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
3963 ? SvPVx(((SVOP*)label)->op_sv, n_a)
3969 /* Check whether it's going to be a goto &function */
3970 if (label->op_type == OP_ENTERSUB
3971 && !(label->op_flags & OPf_STACKED))
3972 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
3973 o = newUNOP(type, OPf_STACKED, label);
3975 PL_hints |= HINT_BLOCK_SCOPE;
3980 =for apidoc cv_undef
3982 Clear out all the active components of a CV. This can happen either
3983 by an explicit C<undef &foo>, or by the reference count going to zero.
3984 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
3985 children can still follow the full lexical scope chain.
3991 Perl_cv_undef(pTHX_ CV *cv)
3994 if (CvFILE(cv) && !CvXSUB(cv)) {
3995 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
3996 Safefree(CvFILE(cv));
4001 if (!CvXSUB(cv) && CvROOT(cv)) {
4003 Perl_croak(aTHX_ "Can't undef active subroutine");
4006 PAD_SAVE_SETNULLPAD();
4008 op_free(CvROOT(cv));
4009 CvROOT(cv) = Nullop;
4012 SvPOK_off((SV*)cv); /* forget prototype */
4017 /* remove CvOUTSIDE unless this is an undef rather than a free */
4018 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4019 if (!CvWEAKOUTSIDE(cv))
4020 SvREFCNT_dec(CvOUTSIDE(cv));
4021 CvOUTSIDE(cv) = Nullcv;
4024 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4030 /* delete all flags except WEAKOUTSIDE */
4031 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4035 Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p)
4037 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4038 SV* msg = sv_newmortal();
4042 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4043 sv_setpv(msg, "Prototype mismatch:");
4045 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4047 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (const SV *)cv);
4049 Perl_sv_catpv(aTHX_ msg, ": none");
4050 sv_catpv(msg, " vs ");
4052 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4054 sv_catpv(msg, "none");
4055 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
4059 static void const_sv_xsub(pTHX_ CV* cv);
4063 =head1 Optree Manipulation Functions
4065 =for apidoc cv_const_sv
4067 If C<cv> is a constant sub eligible for inlining. returns the constant
4068 value returned by the sub. Otherwise, returns NULL.
4070 Constant subs can be created with C<newCONSTSUB> or as described in
4071 L<perlsub/"Constant Functions">.
4076 Perl_cv_const_sv(pTHX_ CV *cv)
4078 if (!cv || !CvCONST(cv))
4080 return (SV*)CvXSUBANY(cv).any_ptr;
4083 /* op_const_sv: examine an optree to determine whether it's in-lineable.
4084 * Can be called in 3 ways:
4087 * look for a single OP_CONST with attached value: return the value
4089 * cv && CvCLONE(cv) && !CvCONST(cv)
4091 * examine the clone prototype, and if contains only a single
4092 * OP_CONST referencing a pad const, or a single PADSV referencing
4093 * an outer lexical, return a non-zero value to indicate the CV is
4094 * a candidate for "constizing" at clone time
4098 * We have just cloned an anon prototype that was marked as a const
4099 * candidiate. Try to grab the current value, and in the case of
4100 * PADSV, ignore it if it has multiple references. Return the value.
4104 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4111 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4112 o = cLISTOPo->op_first->op_sibling;
4114 for (; o; o = o->op_next) {
4115 OPCODE type = o->op_type;
4117 if (sv && o->op_next == o)
4119 if (o->op_next != o) {
4120 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4122 if (type == OP_DBSTATE)
4125 if (type == OP_LEAVESUB || type == OP_RETURN)
4129 if (type == OP_CONST && cSVOPo->op_sv)
4131 else if (cv && type == OP_CONST) {
4132 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4136 else if (cv && type == OP_PADSV) {
4137 if (CvCONST(cv)) { /* newly cloned anon */
4138 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4139 /* the candidate should have 1 ref from this pad and 1 ref
4140 * from the parent */
4141 if (!sv || SvREFCNT(sv) != 2)
4148 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4149 sv = &PL_sv_undef; /* an arbitrary non-null value */
4160 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4171 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4175 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4177 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4181 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4191 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4194 assert(proto->op_type == OP_CONST);
4195 ps = SvPVx(((SVOP*)proto)->op_sv, n_a);
4200 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4201 SV *sv = sv_newmortal();
4202 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4203 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4204 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4209 gv = name ? gv_fetchsv(cSVOPo->op_sv,
4210 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4212 : gv_fetchpv(aname ? aname
4213 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4214 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4224 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4225 maximum a prototype before. */
4226 if (SvTYPE(gv) > SVt_NULL) {
4227 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4228 && ckWARN_d(WARN_PROTOTYPE))
4230 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4232 cv_ckproto((CV*)gv, NULL, ps);
4235 sv_setpv((SV*)gv, ps);
4237 sv_setiv((SV*)gv, -1);
4238 SvREFCNT_dec(PL_compcv);
4239 cv = PL_compcv = NULL;
4240 PL_sub_generation++;
4244 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4246 #ifdef GV_UNIQUE_CHECK
4247 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4248 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4252 if (!block || !ps || *ps || attrs)
4255 const_sv = op_const_sv(block, Nullcv);
4258 bool exists = CvROOT(cv) || CvXSUB(cv);
4260 #ifdef GV_UNIQUE_CHECK
4261 if (exists && GvUNIQUE(gv)) {
4262 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4266 /* if the subroutine doesn't exist and wasn't pre-declared
4267 * with a prototype, assume it will be AUTOLOADed,
4268 * skipping the prototype check
4270 if (exists || SvPOK(cv))
4271 cv_ckproto(cv, gv, ps);
4272 /* already defined (or promised)? */
4273 if (exists || GvASSUMECV(gv)) {
4274 if (!block && !attrs) {
4275 if (CvFLAGS(PL_compcv)) {
4276 /* might have had built-in attrs applied */
4277 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4279 /* just a "sub foo;" when &foo is already defined */
4280 SAVEFREESV(PL_compcv);
4283 /* ahem, death to those who redefine active sort subs */
4284 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4285 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4287 if (ckWARN(WARN_REDEFINE)
4289 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4291 line_t oldline = CopLINE(PL_curcop);
4292 if (PL_copline != NOLINE)
4293 CopLINE_set(PL_curcop, PL_copline);
4294 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4295 CvCONST(cv) ? "Constant subroutine %s redefined"
4296 : "Subroutine %s redefined", name);
4297 CopLINE_set(PL_curcop, oldline);
4305 (void)SvREFCNT_inc(const_sv);
4307 assert(!CvROOT(cv) && !CvCONST(cv));
4308 sv_setpv((SV*)cv, ""); /* prototype is "" */
4309 CvXSUBANY(cv).any_ptr = const_sv;
4310 CvXSUB(cv) = const_sv_xsub;
4315 cv = newCONSTSUB(NULL, name, const_sv);
4318 SvREFCNT_dec(PL_compcv);
4320 PL_sub_generation++;
4327 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4328 * before we clobber PL_compcv.
4332 /* Might have had built-in attributes applied -- propagate them. */
4333 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4334 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4335 stash = GvSTASH(CvGV(cv));
4336 else if (CvSTASH(cv))
4337 stash = CvSTASH(cv);
4339 stash = PL_curstash;
4342 /* possibly about to re-define existing subr -- ignore old cv */
4343 rcv = (SV*)PL_compcv;
4344 if (name && GvSTASH(gv))
4345 stash = GvSTASH(gv);
4347 stash = PL_curstash;
4349 apply_attrs(stash, rcv, attrs, FALSE);
4351 if (cv) { /* must reuse cv if autoloaded */
4353 /* got here with just attrs -- work done, so bug out */
4354 SAVEFREESV(PL_compcv);
4357 /* transfer PL_compcv to cv */
4359 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4360 if (!CvWEAKOUTSIDE(cv))
4361 SvREFCNT_dec(CvOUTSIDE(cv));
4362 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4363 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4364 CvOUTSIDE(PL_compcv) = 0;
4365 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4366 CvPADLIST(PL_compcv) = 0;
4367 /* inner references to PL_compcv must be fixed up ... */
4368 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4369 /* ... before we throw it away */
4370 SvREFCNT_dec(PL_compcv);
4372 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4373 ++PL_sub_generation;
4380 PL_sub_generation++;
4384 CvFILE_set_from_cop(cv, PL_curcop);
4385 CvSTASH(cv) = PL_curstash;
4388 sv_setpv((SV*)cv, ps);
4390 if (PL_error_count) {
4394 char *s = strrchr(name, ':');
4396 if (strEQ(s, "BEGIN")) {
4397 const char not_safe[] =
4398 "BEGIN not safe after errors--compilation aborted";
4399 if (PL_in_eval & EVAL_KEEPERR)
4400 Perl_croak(aTHX_ not_safe);
4402 /* force display of errors found but not reported */
4403 sv_catpv(ERRSV, not_safe);
4404 Perl_croak(aTHX_ "%"SVf, ERRSV);
4413 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4414 mod(scalarseq(block), OP_LEAVESUBLV));
4417 /* This makes sub {}; work as expected. */
4418 if (block->op_type == OP_STUB) {
4420 block = newSTATEOP(0, Nullch, 0);
4422 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4424 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4425 OpREFCNT_set(CvROOT(cv), 1);
4426 CvSTART(cv) = LINKLIST(CvROOT(cv));
4427 CvROOT(cv)->op_next = 0;
4428 CALL_PEEP(CvSTART(cv));
4430 /* now that optimizer has done its work, adjust pad values */
4432 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4435 assert(!CvCONST(cv));
4436 if (ps && !*ps && op_const_sv(block, cv))
4440 if (name || aname) {
4442 char *tname = (name ? name : aname);
4444 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4445 SV *sv = NEWSV(0,0);
4446 SV *tmpstr = sv_newmortal();
4447 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4451 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4453 (long)PL_subline, (long)CopLINE(PL_curcop));
4454 gv_efullname3(tmpstr, gv, Nullch);
4455 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4456 hv = GvHVn(db_postponed);
4457 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4458 && (pcv = GvCV(db_postponed)))
4464 call_sv((SV*)pcv, G_DISCARD);
4468 if ((s = strrchr(tname,':')))
4473 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4476 if (strEQ(s, "BEGIN") && !PL_error_count) {
4477 I32 oldscope = PL_scopestack_ix;
4479 SAVECOPFILE(&PL_compiling);
4480 SAVECOPLINE(&PL_compiling);
4483 PL_beginav = newAV();
4484 DEBUG_x( dump_sub(gv) );
4485 av_push(PL_beginav, (SV*)cv);
4486 GvCV(gv) = 0; /* cv has been hijacked */
4487 call_list(oldscope, PL_beginav);
4489 PL_curcop = &PL_compiling;
4490 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4493 else if (strEQ(s, "END") && !PL_error_count) {
4496 DEBUG_x( dump_sub(gv) );
4497 av_unshift(PL_endav, 1);
4498 av_store(PL_endav, 0, (SV*)cv);
4499 GvCV(gv) = 0; /* cv has been hijacked */
4501 else if (strEQ(s, "CHECK") && !PL_error_count) {
4503 PL_checkav = newAV();
4504 DEBUG_x( dump_sub(gv) );
4505 if (PL_main_start && ckWARN(WARN_VOID))
4506 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4507 av_unshift(PL_checkav, 1);
4508 av_store(PL_checkav, 0, (SV*)cv);
4509 GvCV(gv) = 0; /* cv has been hijacked */
4511 else if (strEQ(s, "INIT") && !PL_error_count) {
4513 PL_initav = newAV();
4514 DEBUG_x( dump_sub(gv) );
4515 if (PL_main_start && ckWARN(WARN_VOID))
4516 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4517 av_push(PL_initav, (SV*)cv);
4518 GvCV(gv) = 0; /* cv has been hijacked */
4523 PL_copline = NOLINE;
4528 /* XXX unsafe for threads if eval_owner isn't held */
4530 =for apidoc newCONSTSUB
4532 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4533 eligible for inlining at compile-time.
4539 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
4545 SAVECOPLINE(PL_curcop);
4546 CopLINE_set(PL_curcop, PL_copline);
4549 PL_hints &= ~HINT_BLOCK_SCOPE;
4552 SAVESPTR(PL_curstash);
4553 SAVECOPSTASH(PL_curcop);
4554 PL_curstash = stash;
4555 CopSTASH_set(PL_curcop,stash);
4558 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4559 CvXSUBANY(cv).any_ptr = sv;
4561 sv_setpv((SV*)cv, ""); /* prototype is "" */
4564 CopSTASH_free(PL_curcop);
4572 =for apidoc U||newXS
4574 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4580 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
4582 GV *gv = gv_fetchpv(name ? name :
4583 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4584 GV_ADDMULTI, SVt_PVCV);
4588 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4590 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4592 /* just a cached method */
4596 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4597 /* already defined (or promised) */
4598 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4599 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4600 line_t oldline = CopLINE(PL_curcop);
4601 if (PL_copline != NOLINE)
4602 CopLINE_set(PL_curcop, PL_copline);
4603 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4604 CvCONST(cv) ? "Constant subroutine %s redefined"
4605 : "Subroutine %s redefined"
4607 CopLINE_set(PL_curcop, oldline);
4614 if (cv) /* must reuse cv if autoloaded */
4617 cv = (CV*)NEWSV(1105,0);
4618 sv_upgrade((SV *)cv, SVt_PVCV);
4622 PL_sub_generation++;
4626 (void)gv_fetchfile(filename);
4627 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
4628 an external constant string */
4629 CvXSUB(cv) = subaddr;
4632 const char *s = strrchr(name,':');
4638 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4641 if (strEQ(s, "BEGIN")) {
4643 PL_beginav = newAV();
4644 av_push(PL_beginav, (SV*)cv);
4645 GvCV(gv) = 0; /* cv has been hijacked */
4647 else if (strEQ(s, "END")) {
4650 av_unshift(PL_endav, 1);
4651 av_store(PL_endav, 0, (SV*)cv);
4652 GvCV(gv) = 0; /* cv has been hijacked */
4654 else if (strEQ(s, "CHECK")) {
4656 PL_checkav = newAV();
4657 if (PL_main_start && ckWARN(WARN_VOID))
4658 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4659 av_unshift(PL_checkav, 1);
4660 av_store(PL_checkav, 0, (SV*)cv);
4661 GvCV(gv) = 0; /* cv has been hijacked */
4663 else if (strEQ(s, "INIT")) {
4665 PL_initav = newAV();
4666 if (PL_main_start && ckWARN(WARN_VOID))
4667 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4668 av_push(PL_initav, (SV*)cv);
4669 GvCV(gv) = 0; /* cv has been hijacked */
4680 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4686 gv = gv_fetchsv(cSVOPo->op_sv, TRUE, SVt_PVFM);
4688 gv = gv_fetchpv("STDOUT", TRUE, SVt_PVFM);
4690 #ifdef GV_UNIQUE_CHECK
4692 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4696 if ((cv = GvFORM(gv))) {
4697 if (ckWARN(WARN_REDEFINE)) {
4698 line_t oldline = CopLINE(PL_curcop);
4699 if (PL_copline != NOLINE)
4700 CopLINE_set(PL_curcop, PL_copline);
4701 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4702 o ? "Format %"SVf" redefined"
4703 : "Format STDOUT redefined" ,cSVOPo->op_sv);
4704 CopLINE_set(PL_curcop, oldline);
4711 CvFILE_set_from_cop(cv, PL_curcop);
4714 pad_tidy(padtidy_FORMAT);
4715 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4716 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4717 OpREFCNT_set(CvROOT(cv), 1);
4718 CvSTART(cv) = LINKLIST(CvROOT(cv));
4719 CvROOT(cv)->op_next = 0;
4720 CALL_PEEP(CvSTART(cv));
4722 PL_copline = NOLINE;
4727 Perl_newANONLIST(pTHX_ OP *o)
4729 return newUNOP(OP_REFGEN, 0,
4730 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4734 Perl_newANONHASH(pTHX_ OP *o)
4736 return newUNOP(OP_REFGEN, 0,
4737 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4741 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4743 return newANONATTRSUB(floor, proto, Nullop, block);
4747 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4749 return newUNOP(OP_REFGEN, 0,
4750 newSVOP(OP_ANONCODE, 0,
4751 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
4755 Perl_oopsAV(pTHX_ OP *o)
4757 switch (o->op_type) {
4759 o->op_type = OP_PADAV;
4760 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4761 return ref(o, OP_RV2AV);
4764 o->op_type = OP_RV2AV;
4765 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4770 if (ckWARN_d(WARN_INTERNAL))
4771 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
4778 Perl_oopsHV(pTHX_ OP *o)
4780 switch (o->op_type) {
4783 o->op_type = OP_PADHV;
4784 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4785 return ref(o, OP_RV2HV);
4789 o->op_type = OP_RV2HV;
4790 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
4795 if (ckWARN_d(WARN_INTERNAL))
4796 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
4803 Perl_newAVREF(pTHX_ OP *o)
4805 if (o->op_type == OP_PADANY) {
4806 o->op_type = OP_PADAV;
4807 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4810 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
4811 && ckWARN(WARN_DEPRECATED)) {
4812 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4813 "Using an array as a reference is deprecated");
4815 return newUNOP(OP_RV2AV, 0, scalar(o));
4819 Perl_newGVREF(pTHX_ I32 type, OP *o)
4821 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
4822 return newUNOP(OP_NULL, 0, o);
4823 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
4827 Perl_newHVREF(pTHX_ OP *o)
4829 if (o->op_type == OP_PADANY) {
4830 o->op_type = OP_PADHV;
4831 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4834 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
4835 && ckWARN(WARN_DEPRECATED)) {
4836 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4837 "Using a hash as a reference is deprecated");
4839 return newUNOP(OP_RV2HV, 0, scalar(o));
4843 Perl_oopsCV(pTHX_ OP *o)
4845 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
4848 #ifndef HASATTRIBUTE
4849 /* No __attribute__, so the compiler doesn't know that croak never returns
4856 Perl_newCVREF(pTHX_ I32 flags, OP *o)
4858 return newUNOP(OP_RV2CV, flags, scalar(o));
4862 Perl_newSVREF(pTHX_ OP *o)
4864 if (o->op_type == OP_PADANY) {
4865 o->op_type = OP_PADSV;
4866 o->op_ppaddr = PL_ppaddr[OP_PADSV];
4869 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4870 o->op_flags |= OPpDONE_SVREF;
4873 return newUNOP(OP_RV2SV, 0, scalar(o));
4876 /* Check routines. See the comments at the top of this file for details
4877 * on when these are called */
4880 Perl_ck_anoncode(pTHX_ OP *o)
4882 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
4883 cSVOPo->op_sv = Nullsv;
4888 Perl_ck_bitop(pTHX_ OP *o)
4890 #define OP_IS_NUMCOMPARE(op) \
4891 ((op) == OP_LT || (op) == OP_I_LT || \
4892 (op) == OP_GT || (op) == OP_I_GT || \
4893 (op) == OP_LE || (op) == OP_I_LE || \
4894 (op) == OP_GE || (op) == OP_I_GE || \
4895 (op) == OP_EQ || (op) == OP_I_EQ || \
4896 (op) == OP_NE || (op) == OP_I_NE || \
4897 (op) == OP_NCMP || (op) == OP_I_NCMP)
4898 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4899 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
4900 && (o->op_type == OP_BIT_OR
4901 || o->op_type == OP_BIT_AND
4902 || o->op_type == OP_BIT_XOR))
4904 OP * left = cBINOPo->op_first;
4905 OP * right = left->op_sibling;
4906 if ((OP_IS_NUMCOMPARE(left->op_type) &&
4907 (left->op_flags & OPf_PARENS) == 0) ||
4908 (OP_IS_NUMCOMPARE(right->op_type) &&
4909 (right->op_flags & OPf_PARENS) == 0))
4910 if (ckWARN(WARN_PRECEDENCE))
4911 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4912 "Possible precedence problem on bitwise %c operator",
4913 o->op_type == OP_BIT_OR ? '|'
4914 : o->op_type == OP_BIT_AND ? '&' : '^'
4921 Perl_ck_concat(pTHX_ OP *o)
4923 OP *kid = cUNOPo->op_first;
4924 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
4925 !(kUNOP->op_first->op_flags & OPf_MOD))
4926 o->op_flags |= OPf_STACKED;
4931 Perl_ck_spair(pTHX_ OP *o)
4933 if (o->op_flags & OPf_KIDS) {
4936 OPCODE type = o->op_type;
4937 o = modkids(ck_fun(o), type);
4938 kid = cUNOPo->op_first;
4939 newop = kUNOP->op_first->op_sibling;
4941 (newop->op_sibling ||
4942 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
4943 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
4944 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
4948 op_free(kUNOP->op_first);
4949 kUNOP->op_first = newop;
4951 o->op_ppaddr = PL_ppaddr[++o->op_type];
4956 Perl_ck_delete(pTHX_ OP *o)
4960 if (o->op_flags & OPf_KIDS) {
4961 OP *kid = cUNOPo->op_first;
4962 switch (kid->op_type) {
4964 o->op_flags |= OPf_SPECIAL;
4967 o->op_private |= OPpSLICE;
4970 o->op_flags |= OPf_SPECIAL;
4975 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
4984 Perl_ck_die(pTHX_ OP *o)
4987 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4993 Perl_ck_eof(pTHX_ OP *o)
4995 I32 type = o->op_type;
4997 if (o->op_flags & OPf_KIDS) {
4998 if (cLISTOPo->op_first->op_type == OP_STUB) {
5000 o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
5008 Perl_ck_eval(pTHX_ OP *o)
5010 PL_hints |= HINT_BLOCK_SCOPE;
5011 if (o->op_flags & OPf_KIDS) {
5012 SVOP *kid = (SVOP*)cUNOPo->op_first;
5015 o->op_flags &= ~OPf_KIDS;
5018 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
5021 cUNOPo->op_first = 0;
5024 NewOp(1101, enter, 1, LOGOP);
5025 enter->op_type = OP_ENTERTRY;
5026 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5027 enter->op_private = 0;
5029 /* establish postfix order */
5030 enter->op_next = (OP*)enter;
5032 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5033 o->op_type = OP_LEAVETRY;
5034 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5035 enter->op_other = o;
5045 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5047 o->op_targ = (PADOFFSET)PL_hints;
5052 Perl_ck_exit(pTHX_ OP *o)
5055 HV *table = GvHV(PL_hintgv);
5057 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5058 if (svp && *svp && SvTRUE(*svp))
5059 o->op_private |= OPpEXIT_VMSISH;
5061 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5067 Perl_ck_exec(pTHX_ OP *o)
5070 if (o->op_flags & OPf_STACKED) {
5072 kid = cUNOPo->op_first->op_sibling;
5073 if (kid->op_type == OP_RV2GV)
5082 Perl_ck_exists(pTHX_ OP *o)
5085 if (o->op_flags & OPf_KIDS) {
5086 OP *kid = cUNOPo->op_first;
5087 if (kid->op_type == OP_ENTERSUB) {
5088 (void) ref(kid, o->op_type);
5089 if (kid->op_type != OP_RV2CV && !PL_error_count)
5090 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5092 o->op_private |= OPpEXISTS_SUB;
5094 else if (kid->op_type == OP_AELEM)
5095 o->op_flags |= OPf_SPECIAL;
5096 else if (kid->op_type != OP_HELEM)
5097 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5106 Perl_ck_gvconst(pTHX_ register OP *o)
5108 o = fold_constants(o);
5109 if (o->op_type == OP_CONST)
5116 Perl_ck_rvconst(pTHX_ register OP *o)
5118 SVOP *kid = (SVOP*)cUNOPo->op_first;
5120 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5121 if (kid->op_type == OP_CONST) {
5124 SV *kidsv = kid->op_sv;
5126 /* Is it a constant from cv_const_sv()? */
5127 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5128 SV *rsv = SvRV(kidsv);
5129 int svtype = SvTYPE(rsv);
5130 const char *badtype = Nullch;
5132 switch (o->op_type) {
5134 if (svtype > SVt_PVMG)
5135 badtype = "a SCALAR";
5138 if (svtype != SVt_PVAV)
5139 badtype = "an ARRAY";
5142 if (svtype != SVt_PVHV)
5146 if (svtype != SVt_PVCV)
5151 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5154 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5155 const char *badthing = Nullch;
5156 switch (o->op_type) {
5158 badthing = "a SCALAR";
5161 badthing = "an ARRAY";
5164 badthing = "a HASH";
5169 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
5173 * This is a little tricky. We only want to add the symbol if we
5174 * didn't add it in the lexer. Otherwise we get duplicate strict
5175 * warnings. But if we didn't add it in the lexer, we must at
5176 * least pretend like we wanted to add it even if it existed before,
5177 * or we get possible typo warnings. OPpCONST_ENTERED says
5178 * whether the lexer already added THIS instance of this symbol.
5180 iscv = (o->op_type == OP_RV2CV) * 2;
5182 gv = gv_fetchsv(kidsv,
5183 iscv | !(kid->op_private & OPpCONST_ENTERED),
5186 : o->op_type == OP_RV2SV
5188 : o->op_type == OP_RV2AV
5190 : o->op_type == OP_RV2HV
5193 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5195 kid->op_type = OP_GV;
5196 SvREFCNT_dec(kid->op_sv);
5198 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5199 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5200 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
5202 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
5204 kid->op_sv = SvREFCNT_inc(gv);
5206 kid->op_private = 0;
5207 kid->op_ppaddr = PL_ppaddr[OP_GV];
5214 Perl_ck_ftst(pTHX_ OP *o)
5216 I32 type = o->op_type;
5218 if (o->op_flags & OPf_REF) {
5221 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5222 SVOP *kid = (SVOP*)cUNOPo->op_first;
5224 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5225 OP *newop = newGVOP(type, OPf_REF,
5226 gv_fetchsv(kid->op_sv, TRUE, SVt_PVIO));
5232 if ((PL_hints & HINT_FILETEST_ACCESS) &&
5233 OP_IS_FILETEST_ACCESS(o))
5234 o->op_private |= OPpFT_ACCESS;
5236 if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
5237 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
5238 o->op_private |= OPpFT_STACKED;
5242 if (type == OP_FTTTY)
5243 o = newGVOP(type, OPf_REF, PL_stdingv);
5245 o = newUNOP(type, 0, newDEFSVOP());
5251 Perl_ck_fun(pTHX_ OP *o)
5257 int type = o->op_type;
5258 register I32 oa = PL_opargs[type] >> OASHIFT;
5260 if (o->op_flags & OPf_STACKED) {
5261 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5264 return no_fh_allowed(o);
5267 if (o->op_flags & OPf_KIDS) {
5268 tokid = &cLISTOPo->op_first;
5269 kid = cLISTOPo->op_first;
5270 if (kid->op_type == OP_PUSHMARK ||
5271 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5273 tokid = &kid->op_sibling;
5274 kid = kid->op_sibling;
5276 if (!kid && PL_opargs[type] & OA_DEFGV)
5277 *tokid = kid = newDEFSVOP();
5281 sibl = kid->op_sibling;
5284 /* list seen where single (scalar) arg expected? */
5285 if (numargs == 1 && !(oa >> 4)
5286 && kid->op_type == OP_LIST && type != OP_SCALAR)
5288 return too_many_arguments(o,PL_op_desc[type]);
5301 if ((type == OP_PUSH || type == OP_UNSHIFT)
5302 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5303 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5304 "Useless use of %s with no values",
5307 if (kid->op_type == OP_CONST &&
5308 (kid->op_private & OPpCONST_BARE))
5310 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5311 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVAV) ));
5312 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5313 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5314 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
5315 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5318 kid->op_sibling = sibl;
5321 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5322 bad_type(numargs, "array", PL_op_desc[type], kid);
5326 if (kid->op_type == OP_CONST &&
5327 (kid->op_private & OPpCONST_BARE))
5329 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5330 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVHV) ));
5331 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5332 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5333 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
5334 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5337 kid->op_sibling = sibl;
5340 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5341 bad_type(numargs, "hash", PL_op_desc[type], kid);
5346 OP *newop = newUNOP(OP_NULL, 0, kid);
5347 kid->op_sibling = 0;
5349 newop->op_next = newop;
5351 kid->op_sibling = sibl;
5356 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5357 if (kid->op_type == OP_CONST &&
5358 (kid->op_private & OPpCONST_BARE))
5360 OP *newop = newGVOP(OP_GV, 0,
5361 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVIO) );
5362 if (!(o->op_private & 1) && /* if not unop */
5363 kid == cLISTOPo->op_last)
5364 cLISTOPo->op_last = newop;
5368 else if (kid->op_type == OP_READLINE) {
5369 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5370 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5373 I32 flags = OPf_SPECIAL;
5377 /* is this op a FH constructor? */
5378 if (is_handle_constructor(o,numargs)) {
5379 const char *name = Nullch;
5383 /* Set a flag to tell rv2gv to vivify
5384 * need to "prove" flag does not mean something
5385 * else already - NI-S 1999/05/07
5388 if (kid->op_type == OP_PADSV) {
5389 name = PAD_COMPNAME_PV(kid->op_targ);
5390 /* SvCUR of a pad namesv can't be trusted
5391 * (see PL_generation), so calc its length
5397 else if (kid->op_type == OP_RV2SV
5398 && kUNOP->op_first->op_type == OP_GV)
5400 GV *gv = cGVOPx_gv(kUNOP->op_first);
5402 len = GvNAMELEN(gv);
5404 else if (kid->op_type == OP_AELEM
5405 || kid->op_type == OP_HELEM)
5410 if ((op = ((BINOP*)kid)->op_first)) {
5411 SV *tmpstr = Nullsv;
5413 kid->op_type == OP_AELEM ?
5415 if (((op->op_type == OP_RV2AV) ||
5416 (op->op_type == OP_RV2HV)) &&
5417 (op = ((UNOP*)op)->op_first) &&
5418 (op->op_type == OP_GV)) {
5419 /* packagevar $a[] or $h{} */
5420 GV *gv = cGVOPx_gv(op);
5428 else if (op->op_type == OP_PADAV
5429 || op->op_type == OP_PADHV) {
5430 /* lexicalvar $a[] or $h{} */
5432 PAD_COMPNAME_PV(op->op_targ);
5442 name = SvPV(tmpstr, len);
5447 name = "__ANONIO__";
5454 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5455 namesv = PAD_SVl(targ);
5456 (void)SvUPGRADE(namesv, SVt_PV);
5458 sv_setpvn(namesv, "$", 1);
5459 sv_catpvn(namesv, name, len);
5462 kid->op_sibling = 0;
5463 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5464 kid->op_targ = targ;
5465 kid->op_private |= priv;
5467 kid->op_sibling = sibl;
5473 mod(scalar(kid), type);
5477 tokid = &kid->op_sibling;
5478 kid = kid->op_sibling;
5480 o->op_private |= numargs;
5482 return too_many_arguments(o,OP_DESC(o));
5485 else if (PL_opargs[type] & OA_DEFGV) {
5487 return newUNOP(type, 0, newDEFSVOP());
5491 while (oa & OA_OPTIONAL)
5493 if (oa && oa != OA_LIST)
5494 return too_few_arguments(o,OP_DESC(o));
5500 Perl_ck_glob(pTHX_ OP *o)
5505 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5506 append_elem(OP_GLOB, o, newDEFSVOP());
5508 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5509 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5511 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5514 #if !defined(PERL_EXTERNAL_GLOB)
5515 /* XXX this can be tightened up and made more failsafe. */
5516 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5519 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5520 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5521 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5522 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5523 GvCV(gv) = GvCV(glob_gv);
5524 (void)SvREFCNT_inc((SV*)GvCV(gv));
5525 GvIMPORTED_CV_on(gv);
5528 #endif /* PERL_EXTERNAL_GLOB */
5530 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5531 append_elem(OP_GLOB, o,
5532 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5533 o->op_type = OP_LIST;
5534 o->op_ppaddr = PL_ppaddr[OP_LIST];
5535 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5536 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5537 cLISTOPo->op_first->op_targ = 0;
5538 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5539 append_elem(OP_LIST, o,
5540 scalar(newUNOP(OP_RV2CV, 0,
5541 newGVOP(OP_GV, 0, gv)))));
5542 o = newUNOP(OP_NULL, 0, ck_subr(o));
5543 o->op_targ = OP_GLOB; /* hint at what it used to be */
5546 gv = newGVgen("main");
5548 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5554 Perl_ck_grep(pTHX_ OP *o)
5558 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5561 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5562 NewOp(1101, gwop, 1, LOGOP);
5564 if (o->op_flags & OPf_STACKED) {
5567 kid = cLISTOPo->op_first->op_sibling;
5568 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
5571 kid->op_next = (OP*)gwop;
5572 o->op_flags &= ~OPf_STACKED;
5574 kid = cLISTOPo->op_first->op_sibling;
5575 if (type == OP_MAPWHILE)
5582 kid = cLISTOPo->op_first->op_sibling;
5583 if (kid->op_type != OP_NULL)
5584 Perl_croak(aTHX_ "panic: ck_grep");
5585 kid = kUNOP->op_first;
5587 gwop->op_type = type;
5588 gwop->op_ppaddr = PL_ppaddr[type];
5589 gwop->op_first = listkids(o);
5590 gwop->op_flags |= OPf_KIDS;
5591 gwop->op_other = LINKLIST(kid);
5592 kid->op_next = (OP*)gwop;
5593 offset = pad_findmy("$_");
5594 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
5595 o->op_private = gwop->op_private = 0;
5596 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5599 o->op_private = gwop->op_private = OPpGREP_LEX;
5600 gwop->op_targ = o->op_targ = offset;
5603 kid = cLISTOPo->op_first->op_sibling;
5604 if (!kid || !kid->op_sibling)
5605 return too_few_arguments(o,OP_DESC(o));
5606 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5607 mod(kid, OP_GREPSTART);
5613 Perl_ck_index(pTHX_ OP *o)
5615 if (o->op_flags & OPf_KIDS) {
5616 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5618 kid = kid->op_sibling; /* get past "big" */
5619 if (kid && kid->op_type == OP_CONST)
5620 fbm_compile(((SVOP*)kid)->op_sv, 0);
5626 Perl_ck_lengthconst(pTHX_ OP *o)
5628 /* XXX length optimization goes here */
5633 Perl_ck_lfun(pTHX_ OP *o)
5635 OPCODE type = o->op_type;
5636 return modkids(ck_fun(o), type);
5640 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5642 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5643 switch (cUNOPo->op_first->op_type) {
5645 /* This is needed for
5646 if (defined %stash::)
5647 to work. Do not break Tk.
5649 break; /* Globals via GV can be undef */
5651 case OP_AASSIGN: /* Is this a good idea? */
5652 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5653 "defined(@array) is deprecated");
5654 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5655 "\t(Maybe you should just omit the defined()?)\n");
5658 /* This is needed for
5659 if (defined %stash::)
5660 to work. Do not break Tk.
5662 break; /* Globals via GV can be undef */
5664 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5665 "defined(%%hash) is deprecated");
5666 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5667 "\t(Maybe you should just omit the defined()?)\n");
5678 Perl_ck_rfun(pTHX_ OP *o)
5680 OPCODE type = o->op_type;
5681 return refkids(ck_fun(o), type);
5685 Perl_ck_listiob(pTHX_ OP *o)
5689 kid = cLISTOPo->op_first;
5692 kid = cLISTOPo->op_first;
5694 if (kid->op_type == OP_PUSHMARK)
5695 kid = kid->op_sibling;
5696 if (kid && o->op_flags & OPf_STACKED)
5697 kid = kid->op_sibling;
5698 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5699 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5700 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5701 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5702 cLISTOPo->op_first->op_sibling = kid;
5703 cLISTOPo->op_last = kid;
5704 kid = kid->op_sibling;
5709 append_elem(o->op_type, o, newDEFSVOP());
5715 Perl_ck_sassign(pTHX_ OP *o)
5717 OP *kid = cLISTOPo->op_first;
5718 /* has a disposable target? */
5719 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5720 && !(kid->op_flags & OPf_STACKED)
5721 /* Cannot steal the second time! */
5722 && !(kid->op_private & OPpTARGET_MY))
5724 OP *kkid = kid->op_sibling;
5726 /* Can just relocate the target. */
5727 if (kkid && kkid->op_type == OP_PADSV
5728 && !(kkid->op_private & OPpLVAL_INTRO))
5730 kid->op_targ = kkid->op_targ;
5732 /* Now we do not need PADSV and SASSIGN. */
5733 kid->op_sibling = o->op_sibling; /* NULL */
5734 cLISTOPo->op_first = NULL;
5737 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
5741 /* optimise C<my $x = undef> to C<my $x> */
5742 if (kid->op_type == OP_UNDEF) {
5743 OP *kkid = kid->op_sibling;
5744 if (kkid && kkid->op_type == OP_PADSV
5745 && (kkid->op_private & OPpLVAL_INTRO))
5747 cLISTOPo->op_first = NULL;
5748 kid->op_sibling = NULL;
5758 Perl_ck_match(pTHX_ OP *o)
5760 if (o->op_type != OP_QR) {
5761 I32 offset = pad_findmy("$_");
5762 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS(offset) & SVpad_OUR)) {
5763 o->op_targ = offset;
5764 o->op_private |= OPpTARGET_MY;
5767 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
5768 o->op_private |= OPpRUNTIME;
5773 Perl_ck_method(pTHX_ OP *o)
5775 OP *kid = cUNOPo->op_first;
5776 if (kid->op_type == OP_CONST) {
5777 SV* sv = kSVOP->op_sv;
5778 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
5780 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5781 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
5784 kSVOP->op_sv = Nullsv;
5786 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5795 Perl_ck_null(pTHX_ OP *o)
5801 Perl_ck_open(pTHX_ OP *o)
5803 HV *table = GvHV(PL_hintgv);
5807 svp = hv_fetch(table, "open_IN", 7, FALSE);
5809 mode = mode_from_discipline(*svp);
5810 if (mode & O_BINARY)
5811 o->op_private |= OPpOPEN_IN_RAW;
5812 else if (mode & O_TEXT)
5813 o->op_private |= OPpOPEN_IN_CRLF;
5816 svp = hv_fetch(table, "open_OUT", 8, FALSE);
5818 mode = mode_from_discipline(*svp);
5819 if (mode & O_BINARY)
5820 o->op_private |= OPpOPEN_OUT_RAW;
5821 else if (mode & O_TEXT)
5822 o->op_private |= OPpOPEN_OUT_CRLF;
5825 if (o->op_type == OP_BACKTICK)
5828 /* In case of three-arg dup open remove strictness
5829 * from the last arg if it is a bareword. */
5830 OP *first = cLISTOPx(o)->op_first; /* The pushmark. */
5831 OP *last = cLISTOPx(o)->op_last; /* The bareword. */
5835 if ((last->op_type == OP_CONST) && /* The bareword. */
5836 (last->op_private & OPpCONST_BARE) &&
5837 (last->op_private & OPpCONST_STRICT) &&
5838 (oa = first->op_sibling) && /* The fh. */
5839 (oa = oa->op_sibling) && /* The mode. */
5840 SvPOK(((SVOP*)oa)->op_sv) &&
5841 (mode = SvPVX(((SVOP*)oa)->op_sv)) &&
5842 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
5843 (last == oa->op_sibling)) /* The bareword. */
5844 last->op_private &= ~OPpCONST_STRICT;
5850 Perl_ck_repeat(pTHX_ OP *o)
5852 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5853 o->op_private |= OPpREPEAT_DOLIST;
5854 cBINOPo->op_first = force_list(cBINOPo->op_first);
5862 Perl_ck_require(pTHX_ OP *o)
5866 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
5867 SVOP *kid = (SVOP*)cUNOPo->op_first;
5869 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5871 for (s = SvPVX(kid->op_sv); *s; s++) {
5872 if (*s == ':' && s[1] == ':') {
5874 Move(s+2, s+1, strlen(s+2)+1, char);
5875 --SvCUR(kid->op_sv);
5878 if (SvREADONLY(kid->op_sv)) {
5879 SvREADONLY_off(kid->op_sv);
5880 sv_catpvn(kid->op_sv, ".pm", 3);
5881 SvREADONLY_on(kid->op_sv);
5884 sv_catpvn(kid->op_sv, ".pm", 3);
5888 /* handle override, if any */
5889 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
5890 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
5891 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
5893 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5894 OP *kid = cUNOPo->op_first;
5895 cUNOPo->op_first = 0;
5897 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5898 append_elem(OP_LIST, kid,
5899 scalar(newUNOP(OP_RV2CV, 0,
5908 Perl_ck_return(pTHX_ OP *o)
5911 if (CvLVALUE(PL_compcv)) {
5912 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5913 mod(kid, OP_LEAVESUBLV);
5920 Perl_ck_retarget(pTHX_ OP *o)
5922 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5929 Perl_ck_select(pTHX_ OP *o)
5932 if (o->op_flags & OPf_KIDS) {
5933 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5934 if (kid && kid->op_sibling) {
5935 o->op_type = OP_SSELECT;
5936 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
5938 return fold_constants(o);
5942 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5943 if (kid && kid->op_type == OP_RV2GV)
5944 kid->op_private &= ~HINT_STRICT_REFS;
5949 Perl_ck_shift(pTHX_ OP *o)
5951 I32 type = o->op_type;
5953 if (!(o->op_flags & OPf_KIDS)) {
5957 argop = newUNOP(OP_RV2AV, 0,
5958 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
5959 return newUNOP(type, 0, scalar(argop));
5961 return scalar(modkids(ck_fun(o), type));
5965 Perl_ck_sort(pTHX_ OP *o)
5969 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
5971 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5972 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
5974 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
5976 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
5978 if (kid->op_type == OP_SCOPE) {
5982 else if (kid->op_type == OP_LEAVE) {
5983 if (o->op_type == OP_SORT) {
5984 op_null(kid); /* wipe out leave */
5987 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
5988 if (k->op_next == kid)
5990 /* don't descend into loops */
5991 else if (k->op_type == OP_ENTERLOOP
5992 || k->op_type == OP_ENTERITER)
5994 k = cLOOPx(k)->op_lastop;
5999 kid->op_next = 0; /* just disconnect the leave */
6000 k = kLISTOP->op_first;
6005 if (o->op_type == OP_SORT) {
6006 /* provide scalar context for comparison function/block */
6012 o->op_flags |= OPf_SPECIAL;
6014 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6017 firstkid = firstkid->op_sibling;
6020 /* provide list context for arguments */
6021 if (o->op_type == OP_SORT)
6028 S_simplify_sort(pTHX_ OP *o)
6030 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6035 if (!(o->op_flags & OPf_STACKED))
6037 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6038 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6039 kid = kUNOP->op_first; /* get past null */
6040 if (kid->op_type != OP_SCOPE)
6042 kid = kLISTOP->op_last; /* get past scope */
6043 switch(kid->op_type) {
6051 k = kid; /* remember this node*/
6052 if (kBINOP->op_first->op_type != OP_RV2SV)
6054 kid = kBINOP->op_first; /* get past cmp */
6055 if (kUNOP->op_first->op_type != OP_GV)
6057 kid = kUNOP->op_first; /* get past rv2sv */
6059 if (GvSTASH(gv) != PL_curstash)
6061 gvname = GvNAME(gv);
6062 if (*gvname == 'a' && gvname[1] == '\0')
6064 else if (*gvname == 'b' && gvname[1] == '\0')
6069 kid = k; /* back to cmp */
6070 if (kBINOP->op_last->op_type != OP_RV2SV)
6072 kid = kBINOP->op_last; /* down to 2nd arg */
6073 if (kUNOP->op_first->op_type != OP_GV)
6075 kid = kUNOP->op_first; /* get past rv2sv */
6077 if (GvSTASH(gv) != PL_curstash)
6079 gvname = GvNAME(gv);
6081 ? !(*gvname == 'a' && gvname[1] == '\0')
6082 : !(*gvname == 'b' && gvname[1] == '\0'))
6084 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6086 o->op_private |= OPpSORT_DESCEND;
6087 if (k->op_type == OP_NCMP)
6088 o->op_private |= OPpSORT_NUMERIC;
6089 if (k->op_type == OP_I_NCMP)
6090 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6091 kid = cLISTOPo->op_first->op_sibling;
6092 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6093 op_free(kid); /* then delete it */
6097 Perl_ck_split(pTHX_ OP *o)
6101 if (o->op_flags & OPf_STACKED)
6102 return no_fh_allowed(o);
6104 kid = cLISTOPo->op_first;
6105 if (kid->op_type != OP_NULL)
6106 Perl_croak(aTHX_ "panic: ck_split");
6107 kid = kid->op_sibling;
6108 op_free(cLISTOPo->op_first);
6109 cLISTOPo->op_first = kid;
6111 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6112 cLISTOPo->op_last = kid; /* There was only one element previously */
6115 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6116 OP *sibl = kid->op_sibling;
6117 kid->op_sibling = 0;
6118 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
6119 if (cLISTOPo->op_first == cLISTOPo->op_last)
6120 cLISTOPo->op_last = kid;
6121 cLISTOPo->op_first = kid;
6122 kid->op_sibling = sibl;
6125 kid->op_type = OP_PUSHRE;
6126 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6128 if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
6129 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
6130 "Use of /g modifier is meaningless in split");
6133 if (!kid->op_sibling)
6134 append_elem(OP_SPLIT, o, newDEFSVOP());
6136 kid = kid->op_sibling;
6139 if (!kid->op_sibling)
6140 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6142 kid = kid->op_sibling;
6145 if (kid->op_sibling)
6146 return too_many_arguments(o,OP_DESC(o));
6152 Perl_ck_join(pTHX_ OP *o)
6154 if (ckWARN(WARN_SYNTAX)) {
6155 OP *kid = cLISTOPo->op_first->op_sibling;
6156 if (kid && kid->op_type == OP_MATCH) {
6157 const char *pmstr = "STRING";
6158 if (PM_GETRE(kPMOP))
6159 pmstr = PM_GETRE(kPMOP)->precomp;
6160 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6161 "/%s/ should probably be written as \"%s\"",
6169 Perl_ck_subr(pTHX_ OP *o)
6171 OP *prev = ((cUNOPo->op_first->op_sibling)
6172 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6173 OP *o2 = prev->op_sibling;
6180 I32 contextclass = 0;
6185 o->op_private |= OPpENTERSUB_HASTARG;
6186 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6187 if (cvop->op_type == OP_RV2CV) {
6189 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6190 op_null(cvop); /* disable rv2cv */
6191 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6192 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6193 GV *gv = cGVOPx_gv(tmpop);
6196 tmpop->op_private |= OPpEARLY_CV;
6199 namegv = CvANON(cv) ? gv : CvGV(cv);
6200 proto = SvPV((SV*)cv, n_a);
6202 if (CvASSERTION(cv)) {
6203 if (PL_hints & HINT_ASSERTING) {
6204 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
6205 o->op_private |= OPpENTERSUB_DB;
6209 if (ckWARN(WARN_ASSERTIONS) && !(PL_hints & HINT_ASSERTIONSSEEN)) {
6210 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
6211 "Impossible to activate assertion call");
6218 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6219 if (o2->op_type == OP_CONST)
6220 o2->op_private &= ~OPpCONST_STRICT;
6221 else if (o2->op_type == OP_LIST) {
6222 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6223 if (o && o->op_type == OP_CONST)
6224 o->op_private &= ~OPpCONST_STRICT;
6227 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6228 if (PERLDB_SUB && PL_curstash != PL_debstash)
6229 o->op_private |= OPpENTERSUB_DB;
6230 while (o2 != cvop) {
6234 return too_many_arguments(o, gv_ename(namegv));
6252 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6254 arg == 1 ? "block or sub {}" : "sub {}",
6255 gv_ename(namegv), o2);
6258 /* '*' allows any scalar type, including bareword */
6261 if (o2->op_type == OP_RV2GV)
6262 goto wrapref; /* autoconvert GLOB -> GLOBref */
6263 else if (o2->op_type == OP_CONST)
6264 o2->op_private &= ~OPpCONST_STRICT;
6265 else if (o2->op_type == OP_ENTERSUB) {
6266 /* accidental subroutine, revert to bareword */
6267 OP *gvop = ((UNOP*)o2)->op_first;
6268 if (gvop && gvop->op_type == OP_NULL) {
6269 gvop = ((UNOP*)gvop)->op_first;
6271 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6274 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6275 (gvop = ((UNOP*)gvop)->op_first) &&
6276 gvop->op_type == OP_GV)
6278 GV *gv = cGVOPx_gv(gvop);
6279 OP *sibling = o2->op_sibling;
6280 SV *n = newSVpvn("",0);
6282 gv_fullname4(n, gv, "", FALSE);
6283 o2 = newSVOP(OP_CONST, 0, n);
6284 prev->op_sibling = o2;
6285 o2->op_sibling = sibling;
6301 if (contextclass++ == 0) {
6302 e = strchr(proto, ']');
6303 if (!e || e == proto)
6316 while (*--p != '[');
6317 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6318 gv_ename(namegv), o2);
6324 if (o2->op_type == OP_RV2GV)
6327 bad_type(arg, "symbol", gv_ename(namegv), o2);
6330 if (o2->op_type == OP_ENTERSUB)
6333 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6336 if (o2->op_type == OP_RV2SV ||
6337 o2->op_type == OP_PADSV ||
6338 o2->op_type == OP_HELEM ||
6339 o2->op_type == OP_AELEM ||
6340 o2->op_type == OP_THREADSV)
6343 bad_type(arg, "scalar", gv_ename(namegv), o2);
6346 if (o2->op_type == OP_RV2AV ||
6347 o2->op_type == OP_PADAV)
6350 bad_type(arg, "array", gv_ename(namegv), o2);
6353 if (o2->op_type == OP_RV2HV ||
6354 o2->op_type == OP_PADHV)
6357 bad_type(arg, "hash", gv_ename(namegv), o2);
6362 OP* sib = kid->op_sibling;
6363 kid->op_sibling = 0;
6364 o2 = newUNOP(OP_REFGEN, 0, kid);
6365 o2->op_sibling = sib;
6366 prev->op_sibling = o2;
6368 if (contextclass && e) {
6383 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6384 gv_ename(namegv), cv);
6389 mod(o2, OP_ENTERSUB);
6391 o2 = o2->op_sibling;
6393 if (proto && !optional &&
6394 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6395 return too_few_arguments(o, gv_ename(namegv));
6398 o=newSVOP(OP_CONST, 0, newSViv(0));
6404 Perl_ck_svconst(pTHX_ OP *o)
6406 SvREADONLY_on(cSVOPo->op_sv);
6411 Perl_ck_trunc(pTHX_ OP *o)
6413 if (o->op_flags & OPf_KIDS) {
6414 SVOP *kid = (SVOP*)cUNOPo->op_first;
6416 if (kid->op_type == OP_NULL)
6417 kid = (SVOP*)kid->op_sibling;
6418 if (kid && kid->op_type == OP_CONST &&
6419 (kid->op_private & OPpCONST_BARE))
6421 o->op_flags |= OPf_SPECIAL;
6422 kid->op_private &= ~OPpCONST_STRICT;
6429 Perl_ck_unpack(pTHX_ OP *o)
6431 OP *kid = cLISTOPo->op_first;
6432 if (kid->op_sibling) {
6433 kid = kid->op_sibling;
6434 if (!kid->op_sibling)
6435 kid->op_sibling = newDEFSVOP();
6441 Perl_ck_substr(pTHX_ OP *o)
6444 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6445 OP *kid = cLISTOPo->op_first;
6447 if (kid->op_type == OP_NULL)
6448 kid = kid->op_sibling;
6450 kid->op_flags |= OPf_MOD;
6456 /* A peephole optimizer. We visit the ops in the order they're to execute.
6457 * See the comments at the top of this file for more details about when
6458 * peep() is called */
6461 Perl_peep(pTHX_ register OP *o)
6463 register OP* oldop = 0;
6465 if (!o || o->op_opt)
6469 SAVEVPTR(PL_curcop);
6470 for (; o; o = o->op_next) {
6474 switch (o->op_type) {
6478 PL_curcop = ((COP*)o); /* for warnings */
6483 if (cSVOPo->op_private & OPpCONST_STRICT)
6484 no_bareword_allowed(o);
6486 case OP_METHOD_NAMED:
6487 /* Relocate sv to the pad for thread safety.
6488 * Despite being a "constant", the SV is written to,
6489 * for reference counts, sv_upgrade() etc. */
6491 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6492 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6493 /* If op_sv is already a PADTMP then it is being used by
6494 * some pad, so make a copy. */
6495 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6496 SvREADONLY_on(PAD_SVl(ix));
6497 SvREFCNT_dec(cSVOPo->op_sv);
6500 SvREFCNT_dec(PAD_SVl(ix));
6501 SvPADTMP_on(cSVOPo->op_sv);
6502 PAD_SETSV(ix, cSVOPo->op_sv);
6503 /* XXX I don't know how this isn't readonly already. */
6504 SvREADONLY_on(PAD_SVl(ix));
6506 cSVOPo->op_sv = Nullsv;
6514 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6515 if (o->op_next->op_private & OPpTARGET_MY) {
6516 if (o->op_flags & OPf_STACKED) /* chained concats */
6517 goto ignore_optimization;
6519 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6520 o->op_targ = o->op_next->op_targ;
6521 o->op_next->op_targ = 0;
6522 o->op_private |= OPpTARGET_MY;
6525 op_null(o->op_next);
6527 ignore_optimization:
6531 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6533 break; /* Scalar stub must produce undef. List stub is noop */
6537 if (o->op_targ == OP_NEXTSTATE
6538 || o->op_targ == OP_DBSTATE
6539 || o->op_targ == OP_SETSTATE)
6541 PL_curcop = ((COP*)o);
6543 /* XXX: We avoid setting op_seq here to prevent later calls
6544 to peep() from mistakenly concluding that optimisation
6545 has already occurred. This doesn't fix the real problem,
6546 though (See 20010220.007). AMS 20010719 */
6547 /* op_seq functionality is now replaced by op_opt */
6548 if (oldop && o->op_next) {
6549 oldop->op_next = o->op_next;
6557 if (oldop && o->op_next) {
6558 oldop->op_next = o->op_next;
6566 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
6567 OP* pop = (o->op_type == OP_PADAV) ?
6568 o->op_next : o->op_next->op_next;
6570 if (pop && pop->op_type == OP_CONST &&
6571 ((PL_op = pop->op_next)) &&
6572 pop->op_next->op_type == OP_AELEM &&
6573 !(pop->op_next->op_private &
6574 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6575 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6580 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
6581 no_bareword_allowed(pop);
6582 if (o->op_type == OP_GV)
6583 op_null(o->op_next);
6584 op_null(pop->op_next);
6586 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6587 o->op_next = pop->op_next->op_next;
6588 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6589 o->op_private = (U8)i;
6590 if (o->op_type == OP_GV) {
6595 o->op_flags |= OPf_SPECIAL;
6596 o->op_type = OP_AELEMFAST;
6602 if (o->op_next->op_type == OP_RV2SV) {
6603 if (!(o->op_next->op_private & OPpDEREF)) {
6604 op_null(o->op_next);
6605 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6607 o->op_next = o->op_next->op_next;
6608 o->op_type = OP_GVSV;
6609 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6612 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6614 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6615 /* XXX could check prototype here instead of just carping */
6616 SV *sv = sv_newmortal();
6617 gv_efullname3(sv, gv, Nullch);
6618 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6619 "%"SVf"() called too early to check prototype",
6623 else if (o->op_next->op_type == OP_READLINE
6624 && o->op_next->op_next->op_type == OP_CONCAT
6625 && (o->op_next->op_next->op_flags & OPf_STACKED))
6627 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6628 o->op_type = OP_RCATLINE;
6629 o->op_flags |= OPf_STACKED;
6630 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6631 op_null(o->op_next->op_next);
6632 op_null(o->op_next);
6649 while (cLOGOP->op_other->op_type == OP_NULL)
6650 cLOGOP->op_other = cLOGOP->op_other->op_next;
6651 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6657 while (cLOOP->op_redoop->op_type == OP_NULL)
6658 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6659 peep(cLOOP->op_redoop);
6660 while (cLOOP->op_nextop->op_type == OP_NULL)
6661 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6662 peep(cLOOP->op_nextop);
6663 while (cLOOP->op_lastop->op_type == OP_NULL)
6664 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6665 peep(cLOOP->op_lastop);
6672 while (cPMOP->op_pmreplstart &&
6673 cPMOP->op_pmreplstart->op_type == OP_NULL)
6674 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6675 peep(cPMOP->op_pmreplstart);
6680 if (ckWARN(WARN_SYNTAX) && o->op_next
6681 && o->op_next->op_type == OP_NEXTSTATE) {
6682 if (o->op_next->op_sibling &&
6683 o->op_next->op_sibling->op_type != OP_EXIT &&
6684 o->op_next->op_sibling->op_type != OP_WARN &&
6685 o->op_next->op_sibling->op_type != OP_DIE) {
6686 line_t oldline = CopLINE(PL_curcop);
6688 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6689 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6690 "Statement unlikely to be reached");
6691 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6692 "\t(Maybe you meant system() when you said exec()?)\n");
6693 CopLINE_set(PL_curcop, oldline);
6708 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6711 /* Make the CONST have a shared SV */
6712 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6713 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6714 key = SvPV(sv, keylen);
6715 lexname = newSVpvn_share(key,
6716 SvUTF8(sv) ? -(I32)keylen : keylen,
6722 if ((o->op_private & (OPpLVAL_INTRO)))
6725 rop = (UNOP*)((BINOP*)o)->op_first;
6726 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6728 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6729 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6731 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6732 if (!fields || !GvHV(*fields))
6734 key = SvPV(*svp, keylen);
6735 if (!hv_fetch(GvHV(*fields), key,
6736 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
6738 Perl_croak(aTHX_ "No such class field \"%s\" "
6739 "in variable %s of type %s",
6740 key, SvPV_nolen(lexname), HvNAME(SvSTASH(lexname)));
6753 SVOP *first_key_op, *key_op;
6755 if ((o->op_private & (OPpLVAL_INTRO))
6756 /* I bet there's always a pushmark... */
6757 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6758 /* hmmm, no optimization if list contains only one key. */
6760 rop = (UNOP*)((LISTOP*)o)->op_last;
6761 if (rop->op_type != OP_RV2HV)
6763 if (rop->op_first->op_type == OP_PADSV)
6764 /* @$hash{qw(keys here)} */
6765 rop = (UNOP*)rop->op_first;
6767 /* @{$hash}{qw(keys here)} */
6768 if (rop->op_first->op_type == OP_SCOPE
6769 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
6771 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
6777 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
6778 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6780 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6781 if (!fields || !GvHV(*fields))
6783 /* Again guessing that the pushmark can be jumped over.... */
6784 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
6785 ->op_first->op_sibling;
6786 for (key_op = first_key_op; key_op;
6787 key_op = (SVOP*)key_op->op_sibling) {
6788 if (key_op->op_type != OP_CONST)
6790 svp = cSVOPx_svp(key_op);
6791 key = SvPV(*svp, keylen);
6792 if (!hv_fetch(GvHV(*fields), key,
6793 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
6795 Perl_croak(aTHX_ "No such class field \"%s\" "
6796 "in variable %s of type %s",
6797 key, SvPV_nolen(lexname), HvNAME(SvSTASH(lexname)));
6804 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
6808 /* check that RHS of sort is a single plain array */
6809 oright = cUNOPo->op_first;
6810 if (!oright || oright->op_type != OP_PUSHMARK)
6813 /* reverse sort ... can be optimised. */
6814 if (!cUNOPo->op_sibling) {
6815 /* Nothing follows us on the list. */
6816 OP *reverse = o->op_next;
6818 if (reverse->op_type == OP_REVERSE &&
6819 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
6820 OP *pushmark = cUNOPx(reverse)->op_first;
6821 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
6822 && (cUNOPx(pushmark)->op_sibling == o)) {
6823 /* reverse -> pushmark -> sort */
6824 o->op_private |= OPpSORT_REVERSE;
6826 pushmark->op_next = oright->op_next;
6832 /* make @a = sort @a act in-place */
6836 oright = cUNOPx(oright)->op_sibling;
6839 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
6840 oright = cUNOPx(oright)->op_sibling;
6844 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
6845 || oright->op_next != o
6846 || (oright->op_private & OPpLVAL_INTRO)
6850 /* o2 follows the chain of op_nexts through the LHS of the
6851 * assign (if any) to the aassign op itself */
6853 if (!o2 || o2->op_type != OP_NULL)
6856 if (!o2 || o2->op_type != OP_PUSHMARK)
6859 if (o2 && o2->op_type == OP_GV)
6862 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
6863 || (o2->op_private & OPpLVAL_INTRO)
6868 if (!o2 || o2->op_type != OP_NULL)
6871 if (!o2 || o2->op_type != OP_AASSIGN
6872 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
6875 /* check that the sort is the first arg on RHS of assign */
6877 o2 = cUNOPx(o2)->op_first;
6878 if (!o2 || o2->op_type != OP_NULL)
6880 o2 = cUNOPx(o2)->op_first;
6881 if (!o2 || o2->op_type != OP_PUSHMARK)
6883 if (o2->op_sibling != o)
6886 /* check the array is the same on both sides */
6887 if (oleft->op_type == OP_RV2AV) {
6888 if (oright->op_type != OP_RV2AV
6889 || !cUNOPx(oright)->op_first
6890 || cUNOPx(oright)->op_first->op_type != OP_GV
6891 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
6892 cGVOPx_gv(cUNOPx(oright)->op_first)
6896 else if (oright->op_type != OP_PADAV
6897 || oright->op_targ != oleft->op_targ
6901 /* transfer MODishness etc from LHS arg to RHS arg */
6902 oright->op_flags = oleft->op_flags;
6903 o->op_private |= OPpSORT_INPLACE;
6905 /* excise push->gv->rv2av->null->aassign */
6906 o2 = o->op_next->op_next;
6907 op_null(o2); /* PUSHMARK */
6909 if (o2->op_type == OP_GV) {
6910 op_null(o2); /* GV */
6913 op_null(o2); /* RV2AV or PADAV */
6914 o2 = o2->op_next->op_next;
6915 op_null(o2); /* AASSIGN */
6917 o->op_next = o2->op_next;
6923 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
6925 LISTOP *enter, *exlist;
6928 enter = (LISTOP *) o->op_next;
6931 if (enter->op_type == OP_NULL) {
6932 enter = (LISTOP *) enter->op_next;
6936 /* for $a (...) will have OP_GV then OP_RV2GV here.
6937 for (...) just has an OP_GV. */
6938 if (enter->op_type == OP_GV) {
6939 gvop = (OP *) enter;
6940 enter = (LISTOP *) enter->op_next;
6943 if (enter->op_type == OP_RV2GV) {
6944 enter = (LISTOP *) enter->op_next;
6950 if (enter->op_type != OP_ENTERITER)
6953 iter = enter->op_next;
6954 if (!iter || iter->op_type != OP_ITER)
6957 expushmark = enter->op_first;
6958 if (!expushmark || expushmark->op_type != OP_NULL
6959 || expushmark->op_targ != OP_PUSHMARK)
6962 exlist = (LISTOP *) expushmark->op_sibling;
6963 if (!exlist || exlist->op_type != OP_NULL
6964 || exlist->op_targ != OP_LIST)
6967 if (exlist->op_last != o) {
6968 /* Mmm. Was expecting to point back to this op. */
6971 theirmark = exlist->op_first;
6972 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
6975 if (theirmark->op_sibling != o) {
6976 /* There's something between the mark and the reverse, eg
6977 for (1, reverse (...))
6982 ourmark = ((LISTOP *)o)->op_first;
6983 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
6986 ourlast = ((LISTOP *)o)->op_last;
6987 if (!ourlast || ourlast->op_next != o)
6990 rv2av = ourmark->op_sibling;
6991 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
6992 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
6993 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
6994 /* We're just reversing a single array. */
6995 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
6996 enter->op_flags |= OPf_STACKED;
6999 /* We don't have control over who points to theirmark, so sacrifice
7001 theirmark->op_next = ourmark->op_next;
7002 theirmark->op_flags = ourmark->op_flags;
7003 ourlast->op_next = gvop ? gvop : (OP *) enter;
7006 enter->op_private |= OPpITER_REVERSED;
7007 iter->op_private |= OPpITER_REVERSED;
7023 const char* Perl_custom_op_name(pTHX_ const OP* o)
7025 const IV index = PTR2IV(o->op_ppaddr);
7029 if (!PL_custom_op_names) /* This probably shouldn't happen */
7030 return PL_op_name[OP_CUSTOM];
7032 keysv = sv_2mortal(newSViv(index));
7034 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7036 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7038 return SvPV_nolen(HeVAL(he));
7041 const char* Perl_custom_op_desc(pTHX_ const OP* o)
7043 const IV index = PTR2IV(o->op_ppaddr);
7047 if (!PL_custom_op_descs)
7048 return PL_op_desc[OP_CUSTOM];
7050 keysv = sv_2mortal(newSViv(index));
7052 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7054 return PL_op_desc[OP_CUSTOM];
7056 return SvPV_nolen(HeVAL(he));
7062 /* Efficient sub that returns a constant scalar value. */
7064 const_sv_xsub(pTHX_ CV* cv)
7069 Perl_croak(aTHX_ "usage: %s::%s()",
7070 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7074 ST(0) = (SV*)XSANY.any_ptr;