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, char *name)
181 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
186 S_too_many_arguments(pTHX_ OP *o, char *name)
188 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
193 S_bad_type(pTHX_ I32 n, char *t, 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)
522 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)
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 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 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 (*((UV *)a) < (*(UV *)b))
2348 if (*((UV *)a) > (*(UV *)b))
2350 if (*((UV *)a+1) < (*(UV *)b+1))
2352 if (*((UV *)a+1) > (*(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 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 int once = block && block->op_flags & OPf_SPECIAL &&
3703 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3706 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3707 return block; /* do {} while 0 does once */
3708 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3709 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3710 expr = newUNOP(OP_DEFINED, 0,
3711 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3712 } else if (expr->op_flags & OPf_KIDS) {
3713 OP *k1 = ((UNOP*)expr)->op_first;
3714 OP *k2 = (k1) ? k1->op_sibling : NULL;
3715 switch (expr->op_type) {
3717 if (k2 && k2->op_type == OP_READLINE
3718 && (k2->op_flags & OPf_STACKED)
3719 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3720 expr = newUNOP(OP_DEFINED, 0, expr);
3724 if (k1->op_type == OP_READDIR
3725 || k1->op_type == OP_GLOB
3726 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3727 || k1->op_type == OP_EACH)
3728 expr = newUNOP(OP_DEFINED, 0, expr);
3734 /* if block is null, the next append_elem() would put UNSTACK, a scalar
3735 * op, in listop. This is wrong. [perl #27024] */
3737 block = newOP(OP_NULL, 0);
3738 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3739 o = new_logop(OP_AND, 0, &expr, &listop);
3742 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3744 if (once && o != listop)
3745 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3748 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3750 o->op_flags |= flags;
3752 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3757 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3765 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3766 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3767 expr = newUNOP(OP_DEFINED, 0,
3768 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3769 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3770 OP *k1 = ((UNOP*)expr)->op_first;
3771 OP *k2 = (k1) ? k1->op_sibling : NULL;
3772 switch (expr->op_type) {
3774 if (k2 && k2->op_type == OP_READLINE
3775 && (k2->op_flags & OPf_STACKED)
3776 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3777 expr = newUNOP(OP_DEFINED, 0, expr);
3781 if (k1->op_type == OP_READDIR
3782 || k1->op_type == OP_GLOB
3783 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3784 || k1->op_type == OP_EACH)
3785 expr = newUNOP(OP_DEFINED, 0, expr);
3791 block = newOP(OP_NULL, 0);
3793 block = scope(block);
3797 next = LINKLIST(cont);
3800 OP *unstack = newOP(OP_UNSTACK, 0);
3803 cont = append_elem(OP_LINESEQ, cont, unstack);
3806 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3807 redo = LINKLIST(listop);
3810 PL_copline = (line_t)whileline;
3812 o = new_logop(OP_AND, 0, &expr, &listop);
3813 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3814 op_free(expr); /* oops, it's a while (0) */
3816 return Nullop; /* listop already freed by new_logop */
3819 ((LISTOP*)listop)->op_last->op_next =
3820 (o == listop ? redo : LINKLIST(o));
3826 NewOp(1101,loop,1,LOOP);
3827 loop->op_type = OP_ENTERLOOP;
3828 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3829 loop->op_private = 0;
3830 loop->op_next = (OP*)loop;
3833 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3835 loop->op_redoop = redo;
3836 loop->op_lastop = o;
3837 o->op_private |= loopflags;
3840 loop->op_nextop = next;
3842 loop->op_nextop = o;
3844 o->op_flags |= flags;
3845 o->op_private |= (flags >> 8);
3850 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
3854 PADOFFSET padoff = 0;
3859 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
3860 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
3861 sv->op_type = OP_RV2GV;
3862 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3864 else if (sv->op_type == OP_PADSV) { /* private variable */
3865 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
3866 padoff = sv->op_targ;
3871 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3872 padoff = sv->op_targ;
3874 iterflags |= OPf_SPECIAL;
3879 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3882 I32 offset = pad_findmy("$_");
3883 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
3884 sv = newGVOP(OP_GV, 0, PL_defgv);
3890 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3891 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3892 iterflags |= OPf_STACKED;
3894 else if (expr->op_type == OP_NULL &&
3895 (expr->op_flags & OPf_KIDS) &&
3896 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3898 /* Basically turn for($x..$y) into the same as for($x,$y), but we
3899 * set the STACKED flag to indicate that these values are to be
3900 * treated as min/max values by 'pp_iterinit'.
3902 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
3903 LOGOP* range = (LOGOP*) flip->op_first;
3904 OP* left = range->op_first;
3905 OP* right = left->op_sibling;
3908 range->op_flags &= ~OPf_KIDS;
3909 range->op_first = Nullop;
3911 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
3912 listop->op_first->op_next = range->op_next;
3913 left->op_next = range->op_other;
3914 right->op_next = (OP*)listop;
3915 listop->op_next = listop->op_first;
3918 expr = (OP*)(listop);
3920 iterflags |= OPf_STACKED;
3923 expr = mod(force_list(expr), OP_GREPSTART);
3927 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
3928 append_elem(OP_LIST, expr, scalar(sv))));
3929 assert(!loop->op_next);
3930 /* for my $x () sets OPpLVAL_INTRO;
3931 * for our $x () sets OPpOUR_INTRO */
3932 loop->op_private = (U8)iterpflags;
3933 #ifdef PL_OP_SLAB_ALLOC
3936 NewOp(1234,tmp,1,LOOP);
3937 Copy(loop,tmp,1,LOOP);
3942 Renew(loop, 1, LOOP);
3944 loop->op_targ = padoff;
3945 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
3946 PL_copline = forline;
3947 return newSTATEOP(0, label, wop);
3951 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
3956 if (type != OP_GOTO || label->op_type == OP_CONST) {
3957 /* "last()" means "last" */
3958 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
3959 o = newOP(type, OPf_SPECIAL);
3961 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
3962 ? SvPVx(((SVOP*)label)->op_sv, n_a)
3968 /* Check whether it's going to be a goto &function */
3969 if (label->op_type == OP_ENTERSUB
3970 && !(label->op_flags & OPf_STACKED))
3971 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
3972 o = newUNOP(type, OPf_STACKED, label);
3974 PL_hints |= HINT_BLOCK_SCOPE;
3979 =for apidoc cv_undef
3981 Clear out all the active components of a CV. This can happen either
3982 by an explicit C<undef &foo>, or by the reference count going to zero.
3983 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
3984 children can still follow the full lexical scope chain.
3990 Perl_cv_undef(pTHX_ CV *cv)
3993 if (CvFILE(cv) && !CvXSUB(cv)) {
3994 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
3995 Safefree(CvFILE(cv));
4000 if (!CvXSUB(cv) && CvROOT(cv)) {
4002 Perl_croak(aTHX_ "Can't undef active subroutine");
4005 PAD_SAVE_SETNULLPAD();
4007 op_free(CvROOT(cv));
4008 CvROOT(cv) = Nullop;
4011 SvPOK_off((SV*)cv); /* forget prototype */
4016 /* remove CvOUTSIDE unless this is an undef rather than a free */
4017 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4018 if (!CvWEAKOUTSIDE(cv))
4019 SvREFCNT_dec(CvOUTSIDE(cv));
4020 CvOUTSIDE(cv) = Nullcv;
4023 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4029 /* delete all flags except WEAKOUTSIDE */
4030 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4034 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4036 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4037 SV* msg = sv_newmortal();
4041 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4042 sv_setpv(msg, "Prototype mismatch:");
4044 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4046 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (SV *)cv);
4048 Perl_sv_catpv(aTHX_ msg, ": none");
4049 sv_catpv(msg, " vs ");
4051 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4053 sv_catpv(msg, "none");
4054 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
4058 static void const_sv_xsub(pTHX_ CV* cv);
4062 =head1 Optree Manipulation Functions
4064 =for apidoc cv_const_sv
4066 If C<cv> is a constant sub eligible for inlining. returns the constant
4067 value returned by the sub. Otherwise, returns NULL.
4069 Constant subs can be created with C<newCONSTSUB> or as described in
4070 L<perlsub/"Constant Functions">.
4075 Perl_cv_const_sv(pTHX_ CV *cv)
4077 if (!cv || !CvCONST(cv))
4079 return (SV*)CvXSUBANY(cv).any_ptr;
4082 /* op_const_sv: examine an optree to determine whether it's in-lineable.
4083 * Can be called in 3 ways:
4086 * look for a single OP_CONST with attached value: return the value
4088 * cv && CvCLONE(cv) && !CvCONST(cv)
4090 * examine the clone prototype, and if contains only a single
4091 * OP_CONST referencing a pad const, or a single PADSV referencing
4092 * an outer lexical, return a non-zero value to indicate the CV is
4093 * a candidate for "constizing" at clone time
4097 * We have just cloned an anon prototype that was marked as a const
4098 * candidiate. Try to grab the current value, and in the case of
4099 * PADSV, ignore it if it has multiple references. Return the value.
4103 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4110 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4111 o = cLISTOPo->op_first->op_sibling;
4113 for (; o; o = o->op_next) {
4114 OPCODE type = o->op_type;
4116 if (sv && o->op_next == o)
4118 if (o->op_next != o) {
4119 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4121 if (type == OP_DBSTATE)
4124 if (type == OP_LEAVESUB || type == OP_RETURN)
4128 if (type == OP_CONST && cSVOPo->op_sv)
4130 else if (cv && type == OP_CONST) {
4131 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4135 else if (cv && type == OP_PADSV) {
4136 if (CvCONST(cv)) { /* newly cloned anon */
4137 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4138 /* the candidate should have 1 ref from this pad and 1 ref
4139 * from the parent */
4140 if (!sv || SvREFCNT(sv) != 2)
4147 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4148 sv = &PL_sv_undef; /* an arbitrary non-null value */
4159 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4169 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4173 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4175 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4179 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4189 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4192 assert(proto->op_type == OP_CONST);
4193 ps = SvPVx(((SVOP*)proto)->op_sv, n_a);
4198 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4199 SV *sv = sv_newmortal();
4200 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4201 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4202 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4207 gv = name ? gv_fetchsv(cSVOPo->op_sv,
4208 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4210 : gv_fetchpv(aname ? aname
4211 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4212 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4222 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4223 maximum a prototype before. */
4224 if (SvTYPE(gv) > SVt_NULL) {
4225 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4226 && ckWARN_d(WARN_PROTOTYPE))
4228 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4230 cv_ckproto((CV*)gv, NULL, ps);
4233 sv_setpv((SV*)gv, ps);
4235 sv_setiv((SV*)gv, -1);
4236 SvREFCNT_dec(PL_compcv);
4237 cv = PL_compcv = NULL;
4238 PL_sub_generation++;
4242 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4244 #ifdef GV_UNIQUE_CHECK
4245 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4246 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4250 if (!block || !ps || *ps || attrs)
4253 const_sv = op_const_sv(block, Nullcv);
4256 bool exists = CvROOT(cv) || CvXSUB(cv);
4258 #ifdef GV_UNIQUE_CHECK
4259 if (exists && GvUNIQUE(gv)) {
4260 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4264 /* if the subroutine doesn't exist and wasn't pre-declared
4265 * with a prototype, assume it will be AUTOLOADed,
4266 * skipping the prototype check
4268 if (exists || SvPOK(cv))
4269 cv_ckproto(cv, gv, ps);
4270 /* already defined (or promised)? */
4271 if (exists || GvASSUMECV(gv)) {
4272 if (!block && !attrs) {
4273 if (CvFLAGS(PL_compcv)) {
4274 /* might have had built-in attrs applied */
4275 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4277 /* just a "sub foo;" when &foo is already defined */
4278 SAVEFREESV(PL_compcv);
4281 /* ahem, death to those who redefine active sort subs */
4282 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4283 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4285 if (ckWARN(WARN_REDEFINE)
4287 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4289 line_t oldline = CopLINE(PL_curcop);
4290 if (PL_copline != NOLINE)
4291 CopLINE_set(PL_curcop, PL_copline);
4292 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4293 CvCONST(cv) ? "Constant subroutine %s redefined"
4294 : "Subroutine %s redefined", name);
4295 CopLINE_set(PL_curcop, oldline);
4303 SvREFCNT_inc(const_sv);
4305 assert(!CvROOT(cv) && !CvCONST(cv));
4306 sv_setpv((SV*)cv, ""); /* prototype is "" */
4307 CvXSUBANY(cv).any_ptr = const_sv;
4308 CvXSUB(cv) = const_sv_xsub;
4313 cv = newCONSTSUB(NULL, name, const_sv);
4316 SvREFCNT_dec(PL_compcv);
4318 PL_sub_generation++;
4325 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4326 * before we clobber PL_compcv.
4330 /* Might have had built-in attributes applied -- propagate them. */
4331 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4332 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4333 stash = GvSTASH(CvGV(cv));
4334 else if (CvSTASH(cv))
4335 stash = CvSTASH(cv);
4337 stash = PL_curstash;
4340 /* possibly about to re-define existing subr -- ignore old cv */
4341 rcv = (SV*)PL_compcv;
4342 if (name && GvSTASH(gv))
4343 stash = GvSTASH(gv);
4345 stash = PL_curstash;
4347 apply_attrs(stash, rcv, attrs, FALSE);
4349 if (cv) { /* must reuse cv if autoloaded */
4351 /* got here with just attrs -- work done, so bug out */
4352 SAVEFREESV(PL_compcv);
4355 /* transfer PL_compcv to cv */
4357 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4358 if (!CvWEAKOUTSIDE(cv))
4359 SvREFCNT_dec(CvOUTSIDE(cv));
4360 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4361 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4362 CvOUTSIDE(PL_compcv) = 0;
4363 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4364 CvPADLIST(PL_compcv) = 0;
4365 /* inner references to PL_compcv must be fixed up ... */
4366 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4367 /* ... before we throw it away */
4368 SvREFCNT_dec(PL_compcv);
4370 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4371 ++PL_sub_generation;
4378 PL_sub_generation++;
4382 CvFILE_set_from_cop(cv, PL_curcop);
4383 CvSTASH(cv) = PL_curstash;
4386 sv_setpv((SV*)cv, ps);
4388 if (PL_error_count) {
4392 char *s = strrchr(name, ':');
4394 if (strEQ(s, "BEGIN")) {
4396 "BEGIN not safe after errors--compilation aborted";
4397 if (PL_in_eval & EVAL_KEEPERR)
4398 Perl_croak(aTHX_ not_safe);
4400 /* force display of errors found but not reported */
4401 sv_catpv(ERRSV, not_safe);
4402 Perl_croak(aTHX_ "%"SVf, ERRSV);
4411 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4412 mod(scalarseq(block), OP_LEAVESUBLV));
4415 /* This makes sub {}; work as expected. */
4416 if (block->op_type == OP_STUB) {
4418 block = newSTATEOP(0, Nullch, 0);
4420 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4422 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4423 OpREFCNT_set(CvROOT(cv), 1);
4424 CvSTART(cv) = LINKLIST(CvROOT(cv));
4425 CvROOT(cv)->op_next = 0;
4426 CALL_PEEP(CvSTART(cv));
4428 /* now that optimizer has done its work, adjust pad values */
4430 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4433 assert(!CvCONST(cv));
4434 if (ps && !*ps && op_const_sv(block, cv))
4438 if (name || aname) {
4440 char *tname = (name ? name : aname);
4442 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4443 SV *sv = NEWSV(0,0);
4444 SV *tmpstr = sv_newmortal();
4445 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4449 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4451 (long)PL_subline, (long)CopLINE(PL_curcop));
4452 gv_efullname3(tmpstr, gv, Nullch);
4453 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4454 hv = GvHVn(db_postponed);
4455 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4456 && (pcv = GvCV(db_postponed)))
4462 call_sv((SV*)pcv, G_DISCARD);
4466 if ((s = strrchr(tname,':')))
4471 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4474 if (strEQ(s, "BEGIN") && !PL_error_count) {
4475 I32 oldscope = PL_scopestack_ix;
4477 SAVECOPFILE(&PL_compiling);
4478 SAVECOPLINE(&PL_compiling);
4481 PL_beginav = newAV();
4482 DEBUG_x( dump_sub(gv) );
4483 av_push(PL_beginav, (SV*)cv);
4484 GvCV(gv) = 0; /* cv has been hijacked */
4485 call_list(oldscope, PL_beginav);
4487 PL_curcop = &PL_compiling;
4488 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4491 else if (strEQ(s, "END") && !PL_error_count) {
4494 DEBUG_x( dump_sub(gv) );
4495 av_unshift(PL_endav, 1);
4496 av_store(PL_endav, 0, (SV*)cv);
4497 GvCV(gv) = 0; /* cv has been hijacked */
4499 else if (strEQ(s, "CHECK") && !PL_error_count) {
4501 PL_checkav = newAV();
4502 DEBUG_x( dump_sub(gv) );
4503 if (PL_main_start && ckWARN(WARN_VOID))
4504 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4505 av_unshift(PL_checkav, 1);
4506 av_store(PL_checkav, 0, (SV*)cv);
4507 GvCV(gv) = 0; /* cv has been hijacked */
4509 else if (strEQ(s, "INIT") && !PL_error_count) {
4511 PL_initav = newAV();
4512 DEBUG_x( dump_sub(gv) );
4513 if (PL_main_start && ckWARN(WARN_VOID))
4514 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4515 av_push(PL_initav, (SV*)cv);
4516 GvCV(gv) = 0; /* cv has been hijacked */
4521 PL_copline = NOLINE;
4526 /* XXX unsafe for threads if eval_owner isn't held */
4528 =for apidoc newCONSTSUB
4530 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4531 eligible for inlining at compile-time.
4537 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4543 SAVECOPLINE(PL_curcop);
4544 CopLINE_set(PL_curcop, PL_copline);
4547 PL_hints &= ~HINT_BLOCK_SCOPE;
4550 SAVESPTR(PL_curstash);
4551 SAVECOPSTASH(PL_curcop);
4552 PL_curstash = stash;
4553 CopSTASH_set(PL_curcop,stash);
4556 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4557 CvXSUBANY(cv).any_ptr = sv;
4559 sv_setpv((SV*)cv, ""); /* prototype is "" */
4562 CopSTASH_free(PL_curcop);
4570 =for apidoc U||newXS
4572 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4578 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
4580 GV *gv = gv_fetchpv(name ? name :
4581 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4582 GV_ADDMULTI, SVt_PVCV);
4586 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4588 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4590 /* just a cached method */
4594 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4595 /* already defined (or promised) */
4596 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4597 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4598 line_t oldline = CopLINE(PL_curcop);
4599 if (PL_copline != NOLINE)
4600 CopLINE_set(PL_curcop, PL_copline);
4601 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4602 CvCONST(cv) ? "Constant subroutine %s redefined"
4603 : "Subroutine %s redefined"
4605 CopLINE_set(PL_curcop, oldline);
4612 if (cv) /* must reuse cv if autoloaded */
4615 cv = (CV*)NEWSV(1105,0);
4616 sv_upgrade((SV *)cv, SVt_PVCV);
4620 PL_sub_generation++;
4624 (void)gv_fetchfile(filename);
4625 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
4626 an external constant string */
4627 CvXSUB(cv) = subaddr;
4630 char *s = strrchr(name,':');
4636 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4639 if (strEQ(s, "BEGIN")) {
4641 PL_beginav = newAV();
4642 av_push(PL_beginav, (SV*)cv);
4643 GvCV(gv) = 0; /* cv has been hijacked */
4645 else if (strEQ(s, "END")) {
4648 av_unshift(PL_endav, 1);
4649 av_store(PL_endav, 0, (SV*)cv);
4650 GvCV(gv) = 0; /* cv has been hijacked */
4652 else if (strEQ(s, "CHECK")) {
4654 PL_checkav = newAV();
4655 if (PL_main_start && ckWARN(WARN_VOID))
4656 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4657 av_unshift(PL_checkav, 1);
4658 av_store(PL_checkav, 0, (SV*)cv);
4659 GvCV(gv) = 0; /* cv has been hijacked */
4661 else if (strEQ(s, "INIT")) {
4663 PL_initav = newAV();
4664 if (PL_main_start && ckWARN(WARN_VOID))
4665 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4666 av_push(PL_initav, (SV*)cv);
4667 GvCV(gv) = 0; /* cv has been hijacked */
4678 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4684 gv = gv_fetchsv(cSVOPo->op_sv, TRUE, SVt_PVFM);
4686 gv = gv_fetchpv("STDOUT", TRUE, SVt_PVFM);
4688 #ifdef GV_UNIQUE_CHECK
4690 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4694 if ((cv = GvFORM(gv))) {
4695 if (ckWARN(WARN_REDEFINE)) {
4696 line_t oldline = CopLINE(PL_curcop);
4697 if (PL_copline != NOLINE)
4698 CopLINE_set(PL_curcop, PL_copline);
4699 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4700 o ? "Format %"SVf" redefined"
4701 : "Format STDOUT redefined" ,cSVOPo->op_sv);
4702 CopLINE_set(PL_curcop, oldline);
4709 CvFILE_set_from_cop(cv, PL_curcop);
4712 pad_tidy(padtidy_FORMAT);
4713 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4714 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4715 OpREFCNT_set(CvROOT(cv), 1);
4716 CvSTART(cv) = LINKLIST(CvROOT(cv));
4717 CvROOT(cv)->op_next = 0;
4718 CALL_PEEP(CvSTART(cv));
4720 PL_copline = NOLINE;
4725 Perl_newANONLIST(pTHX_ OP *o)
4727 return newUNOP(OP_REFGEN, 0,
4728 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4732 Perl_newANONHASH(pTHX_ OP *o)
4734 return newUNOP(OP_REFGEN, 0,
4735 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4739 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4741 return newANONATTRSUB(floor, proto, Nullop, block);
4745 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4747 return newUNOP(OP_REFGEN, 0,
4748 newSVOP(OP_ANONCODE, 0,
4749 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
4753 Perl_oopsAV(pTHX_ OP *o)
4755 switch (o->op_type) {
4757 o->op_type = OP_PADAV;
4758 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4759 return ref(o, OP_RV2AV);
4762 o->op_type = OP_RV2AV;
4763 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4768 if (ckWARN_d(WARN_INTERNAL))
4769 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
4776 Perl_oopsHV(pTHX_ OP *o)
4778 switch (o->op_type) {
4781 o->op_type = OP_PADHV;
4782 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4783 return ref(o, OP_RV2HV);
4787 o->op_type = OP_RV2HV;
4788 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
4793 if (ckWARN_d(WARN_INTERNAL))
4794 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
4801 Perl_newAVREF(pTHX_ OP *o)
4803 if (o->op_type == OP_PADANY) {
4804 o->op_type = OP_PADAV;
4805 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4808 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
4809 && ckWARN(WARN_DEPRECATED)) {
4810 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4811 "Using an array as a reference is deprecated");
4813 return newUNOP(OP_RV2AV, 0, scalar(o));
4817 Perl_newGVREF(pTHX_ I32 type, OP *o)
4819 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
4820 return newUNOP(OP_NULL, 0, o);
4821 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
4825 Perl_newHVREF(pTHX_ OP *o)
4827 if (o->op_type == OP_PADANY) {
4828 o->op_type = OP_PADHV;
4829 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4832 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
4833 && ckWARN(WARN_DEPRECATED)) {
4834 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4835 "Using a hash as a reference is deprecated");
4837 return newUNOP(OP_RV2HV, 0, scalar(o));
4841 Perl_oopsCV(pTHX_ OP *o)
4843 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
4849 Perl_newCVREF(pTHX_ I32 flags, OP *o)
4851 return newUNOP(OP_RV2CV, flags, scalar(o));
4855 Perl_newSVREF(pTHX_ OP *o)
4857 if (o->op_type == OP_PADANY) {
4858 o->op_type = OP_PADSV;
4859 o->op_ppaddr = PL_ppaddr[OP_PADSV];
4862 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4863 o->op_flags |= OPpDONE_SVREF;
4866 return newUNOP(OP_RV2SV, 0, scalar(o));
4869 /* Check routines. See the comments at the top of this file for details
4870 * on when these are called */
4873 Perl_ck_anoncode(pTHX_ OP *o)
4875 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
4876 cSVOPo->op_sv = Nullsv;
4881 Perl_ck_bitop(pTHX_ OP *o)
4883 #define OP_IS_NUMCOMPARE(op) \
4884 ((op) == OP_LT || (op) == OP_I_LT || \
4885 (op) == OP_GT || (op) == OP_I_GT || \
4886 (op) == OP_LE || (op) == OP_I_LE || \
4887 (op) == OP_GE || (op) == OP_I_GE || \
4888 (op) == OP_EQ || (op) == OP_I_EQ || \
4889 (op) == OP_NE || (op) == OP_I_NE || \
4890 (op) == OP_NCMP || (op) == OP_I_NCMP)
4891 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4892 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
4893 && (o->op_type == OP_BIT_OR
4894 || o->op_type == OP_BIT_AND
4895 || o->op_type == OP_BIT_XOR))
4897 OP * left = cBINOPo->op_first;
4898 OP * right = left->op_sibling;
4899 if ((OP_IS_NUMCOMPARE(left->op_type) &&
4900 (left->op_flags & OPf_PARENS) == 0) ||
4901 (OP_IS_NUMCOMPARE(right->op_type) &&
4902 (right->op_flags & OPf_PARENS) == 0))
4903 if (ckWARN(WARN_PRECEDENCE))
4904 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4905 "Possible precedence problem on bitwise %c operator",
4906 o->op_type == OP_BIT_OR ? '|'
4907 : o->op_type == OP_BIT_AND ? '&' : '^'
4914 Perl_ck_concat(pTHX_ OP *o)
4916 OP *kid = cUNOPo->op_first;
4917 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
4918 !(kUNOP->op_first->op_flags & OPf_MOD))
4919 o->op_flags |= OPf_STACKED;
4924 Perl_ck_spair(pTHX_ OP *o)
4926 if (o->op_flags & OPf_KIDS) {
4929 OPCODE type = o->op_type;
4930 o = modkids(ck_fun(o), type);
4931 kid = cUNOPo->op_first;
4932 newop = kUNOP->op_first->op_sibling;
4934 (newop->op_sibling ||
4935 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
4936 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
4937 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
4941 op_free(kUNOP->op_first);
4942 kUNOP->op_first = newop;
4944 o->op_ppaddr = PL_ppaddr[++o->op_type];
4949 Perl_ck_delete(pTHX_ OP *o)
4953 if (o->op_flags & OPf_KIDS) {
4954 OP *kid = cUNOPo->op_first;
4955 switch (kid->op_type) {
4957 o->op_flags |= OPf_SPECIAL;
4960 o->op_private |= OPpSLICE;
4963 o->op_flags |= OPf_SPECIAL;
4968 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
4977 Perl_ck_die(pTHX_ OP *o)
4980 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4986 Perl_ck_eof(pTHX_ OP *o)
4988 I32 type = o->op_type;
4990 if (o->op_flags & OPf_KIDS) {
4991 if (cLISTOPo->op_first->op_type == OP_STUB) {
4993 o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
5001 Perl_ck_eval(pTHX_ OP *o)
5003 PL_hints |= HINT_BLOCK_SCOPE;
5004 if (o->op_flags & OPf_KIDS) {
5005 SVOP *kid = (SVOP*)cUNOPo->op_first;
5008 o->op_flags &= ~OPf_KIDS;
5011 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
5014 cUNOPo->op_first = 0;
5017 NewOp(1101, enter, 1, LOGOP);
5018 enter->op_type = OP_ENTERTRY;
5019 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5020 enter->op_private = 0;
5022 /* establish postfix order */
5023 enter->op_next = (OP*)enter;
5025 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5026 o->op_type = OP_LEAVETRY;
5027 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5028 enter->op_other = o;
5038 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5040 o->op_targ = (PADOFFSET)PL_hints;
5045 Perl_ck_exit(pTHX_ OP *o)
5048 HV *table = GvHV(PL_hintgv);
5050 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5051 if (svp && *svp && SvTRUE(*svp))
5052 o->op_private |= OPpEXIT_VMSISH;
5054 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5060 Perl_ck_exec(pTHX_ OP *o)
5063 if (o->op_flags & OPf_STACKED) {
5065 kid = cUNOPo->op_first->op_sibling;
5066 if (kid->op_type == OP_RV2GV)
5075 Perl_ck_exists(pTHX_ OP *o)
5078 if (o->op_flags & OPf_KIDS) {
5079 OP *kid = cUNOPo->op_first;
5080 if (kid->op_type == OP_ENTERSUB) {
5081 (void) ref(kid, o->op_type);
5082 if (kid->op_type != OP_RV2CV && !PL_error_count)
5083 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5085 o->op_private |= OPpEXISTS_SUB;
5087 else if (kid->op_type == OP_AELEM)
5088 o->op_flags |= OPf_SPECIAL;
5089 else if (kid->op_type != OP_HELEM)
5090 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5099 Perl_ck_gvconst(pTHX_ register OP *o)
5101 o = fold_constants(o);
5102 if (o->op_type == OP_CONST)
5109 Perl_ck_rvconst(pTHX_ register OP *o)
5111 SVOP *kid = (SVOP*)cUNOPo->op_first;
5113 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5114 if (kid->op_type == OP_CONST) {
5117 SV *kidsv = kid->op_sv;
5119 /* Is it a constant from cv_const_sv()? */
5120 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5121 SV *rsv = SvRV(kidsv);
5122 int svtype = SvTYPE(rsv);
5123 char *badtype = Nullch;
5125 switch (o->op_type) {
5127 if (svtype > SVt_PVMG)
5128 badtype = "a SCALAR";
5131 if (svtype != SVt_PVAV)
5132 badtype = "an ARRAY";
5135 if (svtype != SVt_PVHV)
5139 if (svtype != SVt_PVCV)
5144 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5147 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5148 char *badthing = Nullch;
5149 switch (o->op_type) {
5151 badthing = "a SCALAR";
5154 badthing = "an ARRAY";
5157 badthing = "a HASH";
5162 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
5166 * This is a little tricky. We only want to add the symbol if we
5167 * didn't add it in the lexer. Otherwise we get duplicate strict
5168 * warnings. But if we didn't add it in the lexer, we must at
5169 * least pretend like we wanted to add it even if it existed before,
5170 * or we get possible typo warnings. OPpCONST_ENTERED says
5171 * whether the lexer already added THIS instance of this symbol.
5173 iscv = (o->op_type == OP_RV2CV) * 2;
5175 gv = gv_fetchsv(kidsv,
5176 iscv | !(kid->op_private & OPpCONST_ENTERED),
5179 : o->op_type == OP_RV2SV
5181 : o->op_type == OP_RV2AV
5183 : o->op_type == OP_RV2HV
5186 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5188 kid->op_type = OP_GV;
5189 SvREFCNT_dec(kid->op_sv);
5191 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5192 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5193 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
5195 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
5197 kid->op_sv = SvREFCNT_inc(gv);
5199 kid->op_private = 0;
5200 kid->op_ppaddr = PL_ppaddr[OP_GV];
5207 Perl_ck_ftst(pTHX_ OP *o)
5209 I32 type = o->op_type;
5211 if (o->op_flags & OPf_REF) {
5214 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5215 SVOP *kid = (SVOP*)cUNOPo->op_first;
5217 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5218 OP *newop = newGVOP(type, OPf_REF,
5219 gv_fetchsv(kid->op_sv, TRUE, SVt_PVIO));
5225 if ((PL_hints & HINT_FILETEST_ACCESS) &&
5226 OP_IS_FILETEST_ACCESS(o))
5227 o->op_private |= OPpFT_ACCESS;
5229 if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
5230 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
5231 o->op_private |= OPpFT_STACKED;
5235 if (type == OP_FTTTY)
5236 o = newGVOP(type, OPf_REF, PL_stdingv);
5238 o = newUNOP(type, 0, newDEFSVOP());
5244 Perl_ck_fun(pTHX_ OP *o)
5250 int type = o->op_type;
5251 register I32 oa = PL_opargs[type] >> OASHIFT;
5253 if (o->op_flags & OPf_STACKED) {
5254 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5257 return no_fh_allowed(o);
5260 if (o->op_flags & OPf_KIDS) {
5261 tokid = &cLISTOPo->op_first;
5262 kid = cLISTOPo->op_first;
5263 if (kid->op_type == OP_PUSHMARK ||
5264 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5266 tokid = &kid->op_sibling;
5267 kid = kid->op_sibling;
5269 if (!kid && PL_opargs[type] & OA_DEFGV)
5270 *tokid = kid = newDEFSVOP();
5274 sibl = kid->op_sibling;
5277 /* list seen where single (scalar) arg expected? */
5278 if (numargs == 1 && !(oa >> 4)
5279 && kid->op_type == OP_LIST && type != OP_SCALAR)
5281 return too_many_arguments(o,PL_op_desc[type]);
5294 if ((type == OP_PUSH || type == OP_UNSHIFT)
5295 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5296 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5297 "Useless use of %s with no values",
5300 if (kid->op_type == OP_CONST &&
5301 (kid->op_private & OPpCONST_BARE))
5303 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5304 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVAV) ));
5305 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5306 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5307 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
5308 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5311 kid->op_sibling = sibl;
5314 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5315 bad_type(numargs, "array", PL_op_desc[type], kid);
5319 if (kid->op_type == OP_CONST &&
5320 (kid->op_private & OPpCONST_BARE))
5322 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5323 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVHV) ));
5324 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5325 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5326 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
5327 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5330 kid->op_sibling = sibl;
5333 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5334 bad_type(numargs, "hash", PL_op_desc[type], kid);
5339 OP *newop = newUNOP(OP_NULL, 0, kid);
5340 kid->op_sibling = 0;
5342 newop->op_next = newop;
5344 kid->op_sibling = sibl;
5349 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5350 if (kid->op_type == OP_CONST &&
5351 (kid->op_private & OPpCONST_BARE))
5353 OP *newop = newGVOP(OP_GV, 0,
5354 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVIO) );
5355 if (!(o->op_private & 1) && /* if not unop */
5356 kid == cLISTOPo->op_last)
5357 cLISTOPo->op_last = newop;
5361 else if (kid->op_type == OP_READLINE) {
5362 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5363 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5366 I32 flags = OPf_SPECIAL;
5370 /* is this op a FH constructor? */
5371 if (is_handle_constructor(o,numargs)) {
5372 char *name = Nullch;
5376 /* Set a flag to tell rv2gv to vivify
5377 * need to "prove" flag does not mean something
5378 * else already - NI-S 1999/05/07
5381 if (kid->op_type == OP_PADSV) {
5382 name = PAD_COMPNAME_PV(kid->op_targ);
5383 /* SvCUR of a pad namesv can't be trusted
5384 * (see PL_generation), so calc its length
5390 else if (kid->op_type == OP_RV2SV
5391 && kUNOP->op_first->op_type == OP_GV)
5393 GV *gv = cGVOPx_gv(kUNOP->op_first);
5395 len = GvNAMELEN(gv);
5397 else if (kid->op_type == OP_AELEM
5398 || kid->op_type == OP_HELEM)
5403 if ((op = ((BINOP*)kid)->op_first)) {
5404 SV *tmpstr = Nullsv;
5406 kid->op_type == OP_AELEM ?
5408 if (((op->op_type == OP_RV2AV) ||
5409 (op->op_type == OP_RV2HV)) &&
5410 (op = ((UNOP*)op)->op_first) &&
5411 (op->op_type == OP_GV)) {
5412 /* packagevar $a[] or $h{} */
5413 GV *gv = cGVOPx_gv(op);
5421 else if (op->op_type == OP_PADAV
5422 || op->op_type == OP_PADHV) {
5423 /* lexicalvar $a[] or $h{} */
5425 PAD_COMPNAME_PV(op->op_targ);
5435 name = SvPV(tmpstr, len);
5440 name = "__ANONIO__";
5447 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5448 namesv = PAD_SVl(targ);
5449 (void)SvUPGRADE(namesv, SVt_PV);
5451 sv_setpvn(namesv, "$", 1);
5452 sv_catpvn(namesv, name, len);
5455 kid->op_sibling = 0;
5456 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5457 kid->op_targ = targ;
5458 kid->op_private |= priv;
5460 kid->op_sibling = sibl;
5466 mod(scalar(kid), type);
5470 tokid = &kid->op_sibling;
5471 kid = kid->op_sibling;
5473 o->op_private |= numargs;
5475 return too_many_arguments(o,OP_DESC(o));
5478 else if (PL_opargs[type] & OA_DEFGV) {
5480 return newUNOP(type, 0, newDEFSVOP());
5484 while (oa & OA_OPTIONAL)
5486 if (oa && oa != OA_LIST)
5487 return too_few_arguments(o,OP_DESC(o));
5493 Perl_ck_glob(pTHX_ OP *o)
5498 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5499 append_elem(OP_GLOB, o, newDEFSVOP());
5501 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5502 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5504 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5507 #if !defined(PERL_EXTERNAL_GLOB)
5508 /* XXX this can be tightened up and made more failsafe. */
5509 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5512 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5513 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5514 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5515 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5516 GvCV(gv) = GvCV(glob_gv);
5517 SvREFCNT_inc((SV*)GvCV(gv));
5518 GvIMPORTED_CV_on(gv);
5521 #endif /* PERL_EXTERNAL_GLOB */
5523 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5524 append_elem(OP_GLOB, o,
5525 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5526 o->op_type = OP_LIST;
5527 o->op_ppaddr = PL_ppaddr[OP_LIST];
5528 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5529 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5530 cLISTOPo->op_first->op_targ = 0;
5531 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5532 append_elem(OP_LIST, o,
5533 scalar(newUNOP(OP_RV2CV, 0,
5534 newGVOP(OP_GV, 0, gv)))));
5535 o = newUNOP(OP_NULL, 0, ck_subr(o));
5536 o->op_targ = OP_GLOB; /* hint at what it used to be */
5539 gv = newGVgen("main");
5541 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5547 Perl_ck_grep(pTHX_ OP *o)
5551 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5554 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5555 NewOp(1101, gwop, 1, LOGOP);
5557 if (o->op_flags & OPf_STACKED) {
5560 kid = cLISTOPo->op_first->op_sibling;
5561 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
5564 kid->op_next = (OP*)gwop;
5565 o->op_flags &= ~OPf_STACKED;
5567 kid = cLISTOPo->op_first->op_sibling;
5568 if (type == OP_MAPWHILE)
5575 kid = cLISTOPo->op_first->op_sibling;
5576 if (kid->op_type != OP_NULL)
5577 Perl_croak(aTHX_ "panic: ck_grep");
5578 kid = kUNOP->op_first;
5580 gwop->op_type = type;
5581 gwop->op_ppaddr = PL_ppaddr[type];
5582 gwop->op_first = listkids(o);
5583 gwop->op_flags |= OPf_KIDS;
5584 gwop->op_other = LINKLIST(kid);
5585 kid->op_next = (OP*)gwop;
5586 offset = pad_findmy("$_");
5587 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
5588 o->op_private = gwop->op_private = 0;
5589 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5592 o->op_private = gwop->op_private = OPpGREP_LEX;
5593 gwop->op_targ = o->op_targ = offset;
5596 kid = cLISTOPo->op_first->op_sibling;
5597 if (!kid || !kid->op_sibling)
5598 return too_few_arguments(o,OP_DESC(o));
5599 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5600 mod(kid, OP_GREPSTART);
5606 Perl_ck_index(pTHX_ OP *o)
5608 if (o->op_flags & OPf_KIDS) {
5609 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5611 kid = kid->op_sibling; /* get past "big" */
5612 if (kid && kid->op_type == OP_CONST)
5613 fbm_compile(((SVOP*)kid)->op_sv, 0);
5619 Perl_ck_lengthconst(pTHX_ OP *o)
5621 /* XXX length optimization goes here */
5626 Perl_ck_lfun(pTHX_ OP *o)
5628 OPCODE type = o->op_type;
5629 return modkids(ck_fun(o), type);
5633 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5635 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5636 switch (cUNOPo->op_first->op_type) {
5638 /* This is needed for
5639 if (defined %stash::)
5640 to work. Do not break Tk.
5642 break; /* Globals via GV can be undef */
5644 case OP_AASSIGN: /* Is this a good idea? */
5645 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5646 "defined(@array) is deprecated");
5647 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5648 "\t(Maybe you should just omit the defined()?)\n");
5651 /* This is needed for
5652 if (defined %stash::)
5653 to work. Do not break Tk.
5655 break; /* Globals via GV can be undef */
5657 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5658 "defined(%%hash) is deprecated");
5659 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5660 "\t(Maybe you should just omit the defined()?)\n");
5671 Perl_ck_rfun(pTHX_ OP *o)
5673 OPCODE type = o->op_type;
5674 return refkids(ck_fun(o), type);
5678 Perl_ck_listiob(pTHX_ OP *o)
5682 kid = cLISTOPo->op_first;
5685 kid = cLISTOPo->op_first;
5687 if (kid->op_type == OP_PUSHMARK)
5688 kid = kid->op_sibling;
5689 if (kid && o->op_flags & OPf_STACKED)
5690 kid = kid->op_sibling;
5691 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5692 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5693 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5694 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5695 cLISTOPo->op_first->op_sibling = kid;
5696 cLISTOPo->op_last = kid;
5697 kid = kid->op_sibling;
5702 append_elem(o->op_type, o, newDEFSVOP());
5708 Perl_ck_sassign(pTHX_ OP *o)
5710 OP *kid = cLISTOPo->op_first;
5711 /* has a disposable target? */
5712 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5713 && !(kid->op_flags & OPf_STACKED)
5714 /* Cannot steal the second time! */
5715 && !(kid->op_private & OPpTARGET_MY))
5717 OP *kkid = kid->op_sibling;
5719 /* Can just relocate the target. */
5720 if (kkid && kkid->op_type == OP_PADSV
5721 && !(kkid->op_private & OPpLVAL_INTRO))
5723 kid->op_targ = kkid->op_targ;
5725 /* Now we do not need PADSV and SASSIGN. */
5726 kid->op_sibling = o->op_sibling; /* NULL */
5727 cLISTOPo->op_first = NULL;
5730 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
5734 /* optimise C<my $x = undef> to C<my $x> */
5735 if (kid->op_type == OP_UNDEF) {
5736 OP *kkid = kid->op_sibling;
5737 if (kkid && kkid->op_type == OP_PADSV
5738 && (kkid->op_private & OPpLVAL_INTRO))
5740 cLISTOPo->op_first = NULL;
5741 kid->op_sibling = NULL;
5751 Perl_ck_match(pTHX_ OP *o)
5753 if (o->op_type != OP_QR) {
5754 I32 offset = pad_findmy("$_");
5755 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS(offset) & SVpad_OUR)) {
5756 o->op_targ = offset;
5757 o->op_private |= OPpTARGET_MY;
5760 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
5761 o->op_private |= OPpRUNTIME;
5766 Perl_ck_method(pTHX_ OP *o)
5768 OP *kid = cUNOPo->op_first;
5769 if (kid->op_type == OP_CONST) {
5770 SV* sv = kSVOP->op_sv;
5771 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
5773 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5774 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
5777 kSVOP->op_sv = Nullsv;
5779 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5788 Perl_ck_null(pTHX_ OP *o)
5794 Perl_ck_open(pTHX_ OP *o)
5796 HV *table = GvHV(PL_hintgv);
5800 svp = hv_fetch(table, "open_IN", 7, FALSE);
5802 mode = mode_from_discipline(*svp);
5803 if (mode & O_BINARY)
5804 o->op_private |= OPpOPEN_IN_RAW;
5805 else if (mode & O_TEXT)
5806 o->op_private |= OPpOPEN_IN_CRLF;
5809 svp = hv_fetch(table, "open_OUT", 8, FALSE);
5811 mode = mode_from_discipline(*svp);
5812 if (mode & O_BINARY)
5813 o->op_private |= OPpOPEN_OUT_RAW;
5814 else if (mode & O_TEXT)
5815 o->op_private |= OPpOPEN_OUT_CRLF;
5818 if (o->op_type == OP_BACKTICK)
5821 /* In case of three-arg dup open remove strictness
5822 * from the last arg if it is a bareword. */
5823 OP *first = cLISTOPx(o)->op_first; /* The pushmark. */
5824 OP *last = cLISTOPx(o)->op_last; /* The bareword. */
5828 if ((last->op_type == OP_CONST) && /* The bareword. */
5829 (last->op_private & OPpCONST_BARE) &&
5830 (last->op_private & OPpCONST_STRICT) &&
5831 (oa = first->op_sibling) && /* The fh. */
5832 (oa = oa->op_sibling) && /* The mode. */
5833 SvPOK(((SVOP*)oa)->op_sv) &&
5834 (mode = SvPVX(((SVOP*)oa)->op_sv)) &&
5835 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
5836 (last == oa->op_sibling)) /* The bareword. */
5837 last->op_private &= ~OPpCONST_STRICT;
5843 Perl_ck_repeat(pTHX_ OP *o)
5845 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5846 o->op_private |= OPpREPEAT_DOLIST;
5847 cBINOPo->op_first = force_list(cBINOPo->op_first);
5855 Perl_ck_require(pTHX_ OP *o)
5859 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
5860 SVOP *kid = (SVOP*)cUNOPo->op_first;
5862 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5864 for (s = SvPVX(kid->op_sv); *s; s++) {
5865 if (*s == ':' && s[1] == ':') {
5867 Move(s+2, s+1, strlen(s+2)+1, char);
5868 --SvCUR(kid->op_sv);
5871 if (SvREADONLY(kid->op_sv)) {
5872 SvREADONLY_off(kid->op_sv);
5873 sv_catpvn(kid->op_sv, ".pm", 3);
5874 SvREADONLY_on(kid->op_sv);
5877 sv_catpvn(kid->op_sv, ".pm", 3);
5881 /* handle override, if any */
5882 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
5883 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
5884 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
5886 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5887 OP *kid = cUNOPo->op_first;
5888 cUNOPo->op_first = 0;
5890 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5891 append_elem(OP_LIST, kid,
5892 scalar(newUNOP(OP_RV2CV, 0,
5901 Perl_ck_return(pTHX_ OP *o)
5904 if (CvLVALUE(PL_compcv)) {
5905 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5906 mod(kid, OP_LEAVESUBLV);
5913 Perl_ck_retarget(pTHX_ OP *o)
5915 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5922 Perl_ck_select(pTHX_ OP *o)
5925 if (o->op_flags & OPf_KIDS) {
5926 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5927 if (kid && kid->op_sibling) {
5928 o->op_type = OP_SSELECT;
5929 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
5931 return fold_constants(o);
5935 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5936 if (kid && kid->op_type == OP_RV2GV)
5937 kid->op_private &= ~HINT_STRICT_REFS;
5942 Perl_ck_shift(pTHX_ OP *o)
5944 I32 type = o->op_type;
5946 if (!(o->op_flags & OPf_KIDS)) {
5950 argop = newUNOP(OP_RV2AV, 0,
5951 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
5952 return newUNOP(type, 0, scalar(argop));
5954 return scalar(modkids(ck_fun(o), type));
5958 Perl_ck_sort(pTHX_ OP *o)
5962 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
5964 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5965 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
5967 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
5969 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
5971 if (kid->op_type == OP_SCOPE) {
5975 else if (kid->op_type == OP_LEAVE) {
5976 if (o->op_type == OP_SORT) {
5977 op_null(kid); /* wipe out leave */
5980 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
5981 if (k->op_next == kid)
5983 /* don't descend into loops */
5984 else if (k->op_type == OP_ENTERLOOP
5985 || k->op_type == OP_ENTERITER)
5987 k = cLOOPx(k)->op_lastop;
5992 kid->op_next = 0; /* just disconnect the leave */
5993 k = kLISTOP->op_first;
5998 if (o->op_type == OP_SORT) {
5999 /* provide scalar context for comparison function/block */
6005 o->op_flags |= OPf_SPECIAL;
6007 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6010 firstkid = firstkid->op_sibling;
6013 /* provide list context for arguments */
6014 if (o->op_type == OP_SORT)
6021 S_simplify_sort(pTHX_ OP *o)
6023 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6028 if (!(o->op_flags & OPf_STACKED))
6030 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6031 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6032 kid = kUNOP->op_first; /* get past null */
6033 if (kid->op_type != OP_SCOPE)
6035 kid = kLISTOP->op_last; /* get past scope */
6036 switch(kid->op_type) {
6044 k = kid; /* remember this node*/
6045 if (kBINOP->op_first->op_type != OP_RV2SV)
6047 kid = kBINOP->op_first; /* get past cmp */
6048 if (kUNOP->op_first->op_type != OP_GV)
6050 kid = kUNOP->op_first; /* get past rv2sv */
6052 if (GvSTASH(gv) != PL_curstash)
6054 gvname = GvNAME(gv);
6055 if (*gvname == 'a' && gvname[1] == '\0')
6057 else if (*gvname == 'b' && gvname[1] == '\0')
6062 kid = k; /* back to cmp */
6063 if (kBINOP->op_last->op_type != OP_RV2SV)
6065 kid = kBINOP->op_last; /* down to 2nd arg */
6066 if (kUNOP->op_first->op_type != OP_GV)
6068 kid = kUNOP->op_first; /* get past rv2sv */
6070 if (GvSTASH(gv) != PL_curstash)
6072 gvname = GvNAME(gv);
6074 ? !(*gvname == 'a' && gvname[1] == '\0')
6075 : !(*gvname == 'b' && gvname[1] == '\0'))
6077 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6079 o->op_private |= OPpSORT_DESCEND;
6080 if (k->op_type == OP_NCMP)
6081 o->op_private |= OPpSORT_NUMERIC;
6082 if (k->op_type == OP_I_NCMP)
6083 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6084 kid = cLISTOPo->op_first->op_sibling;
6085 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6086 op_free(kid); /* then delete it */
6090 Perl_ck_split(pTHX_ OP *o)
6094 if (o->op_flags & OPf_STACKED)
6095 return no_fh_allowed(o);
6097 kid = cLISTOPo->op_first;
6098 if (kid->op_type != OP_NULL)
6099 Perl_croak(aTHX_ "panic: ck_split");
6100 kid = kid->op_sibling;
6101 op_free(cLISTOPo->op_first);
6102 cLISTOPo->op_first = kid;
6104 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6105 cLISTOPo->op_last = kid; /* There was only one element previously */
6108 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6109 OP *sibl = kid->op_sibling;
6110 kid->op_sibling = 0;
6111 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
6112 if (cLISTOPo->op_first == cLISTOPo->op_last)
6113 cLISTOPo->op_last = kid;
6114 cLISTOPo->op_first = kid;
6115 kid->op_sibling = sibl;
6118 kid->op_type = OP_PUSHRE;
6119 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6121 if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
6122 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
6123 "Use of /g modifier is meaningless in split");
6126 if (!kid->op_sibling)
6127 append_elem(OP_SPLIT, o, newDEFSVOP());
6129 kid = kid->op_sibling;
6132 if (!kid->op_sibling)
6133 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6135 kid = kid->op_sibling;
6138 if (kid->op_sibling)
6139 return too_many_arguments(o,OP_DESC(o));
6145 Perl_ck_join(pTHX_ OP *o)
6147 if (ckWARN(WARN_SYNTAX)) {
6148 OP *kid = cLISTOPo->op_first->op_sibling;
6149 if (kid && kid->op_type == OP_MATCH) {
6150 char *pmstr = "STRING";
6151 if (PM_GETRE(kPMOP))
6152 pmstr = PM_GETRE(kPMOP)->precomp;
6153 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6154 "/%s/ should probably be written as \"%s\"",
6162 Perl_ck_subr(pTHX_ OP *o)
6164 OP *prev = ((cUNOPo->op_first->op_sibling)
6165 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6166 OP *o2 = prev->op_sibling;
6173 I32 contextclass = 0;
6178 o->op_private |= OPpENTERSUB_HASTARG;
6179 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6180 if (cvop->op_type == OP_RV2CV) {
6182 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6183 op_null(cvop); /* disable rv2cv */
6184 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6185 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6186 GV *gv = cGVOPx_gv(tmpop);
6189 tmpop->op_private |= OPpEARLY_CV;
6192 namegv = CvANON(cv) ? gv : CvGV(cv);
6193 proto = SvPV((SV*)cv, n_a);
6195 if (CvASSERTION(cv)) {
6196 if (PL_hints & HINT_ASSERTING) {
6197 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
6198 o->op_private |= OPpENTERSUB_DB;
6202 if (ckWARN(WARN_ASSERTIONS) && !(PL_hints & HINT_ASSERTIONSSEEN)) {
6203 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
6204 "Impossible to activate assertion call");
6211 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6212 if (o2->op_type == OP_CONST)
6213 o2->op_private &= ~OPpCONST_STRICT;
6214 else if (o2->op_type == OP_LIST) {
6215 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6216 if (o && o->op_type == OP_CONST)
6217 o->op_private &= ~OPpCONST_STRICT;
6220 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6221 if (PERLDB_SUB && PL_curstash != PL_debstash)
6222 o->op_private |= OPpENTERSUB_DB;
6223 while (o2 != cvop) {
6227 return too_many_arguments(o, gv_ename(namegv));
6245 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6247 arg == 1 ? "block or sub {}" : "sub {}",
6248 gv_ename(namegv), o2);
6251 /* '*' allows any scalar type, including bareword */
6254 if (o2->op_type == OP_RV2GV)
6255 goto wrapref; /* autoconvert GLOB -> GLOBref */
6256 else if (o2->op_type == OP_CONST)
6257 o2->op_private &= ~OPpCONST_STRICT;
6258 else if (o2->op_type == OP_ENTERSUB) {
6259 /* accidental subroutine, revert to bareword */
6260 OP *gvop = ((UNOP*)o2)->op_first;
6261 if (gvop && gvop->op_type == OP_NULL) {
6262 gvop = ((UNOP*)gvop)->op_first;
6264 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6267 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6268 (gvop = ((UNOP*)gvop)->op_first) &&
6269 gvop->op_type == OP_GV)
6271 GV *gv = cGVOPx_gv(gvop);
6272 OP *sibling = o2->op_sibling;
6273 SV *n = newSVpvn("",0);
6275 gv_fullname4(n, gv, "", FALSE);
6276 o2 = newSVOP(OP_CONST, 0, n);
6277 prev->op_sibling = o2;
6278 o2->op_sibling = sibling;
6294 if (contextclass++ == 0) {
6295 e = strchr(proto, ']');
6296 if (!e || e == proto)
6309 while (*--p != '[');
6310 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6311 gv_ename(namegv), o2);
6317 if (o2->op_type == OP_RV2GV)
6320 bad_type(arg, "symbol", gv_ename(namegv), o2);
6323 if (o2->op_type == OP_ENTERSUB)
6326 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6329 if (o2->op_type == OP_RV2SV ||
6330 o2->op_type == OP_PADSV ||
6331 o2->op_type == OP_HELEM ||
6332 o2->op_type == OP_AELEM ||
6333 o2->op_type == OP_THREADSV)
6336 bad_type(arg, "scalar", gv_ename(namegv), o2);
6339 if (o2->op_type == OP_RV2AV ||
6340 o2->op_type == OP_PADAV)
6343 bad_type(arg, "array", gv_ename(namegv), o2);
6346 if (o2->op_type == OP_RV2HV ||
6347 o2->op_type == OP_PADHV)
6350 bad_type(arg, "hash", gv_ename(namegv), o2);
6355 OP* sib = kid->op_sibling;
6356 kid->op_sibling = 0;
6357 o2 = newUNOP(OP_REFGEN, 0, kid);
6358 o2->op_sibling = sib;
6359 prev->op_sibling = o2;
6361 if (contextclass && e) {
6376 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6377 gv_ename(namegv), cv);
6382 mod(o2, OP_ENTERSUB);
6384 o2 = o2->op_sibling;
6386 if (proto && !optional &&
6387 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6388 return too_few_arguments(o, gv_ename(namegv));
6391 o=newSVOP(OP_CONST, 0, newSViv(0));
6397 Perl_ck_svconst(pTHX_ OP *o)
6399 SvREADONLY_on(cSVOPo->op_sv);
6404 Perl_ck_trunc(pTHX_ OP *o)
6406 if (o->op_flags & OPf_KIDS) {
6407 SVOP *kid = (SVOP*)cUNOPo->op_first;
6409 if (kid->op_type == OP_NULL)
6410 kid = (SVOP*)kid->op_sibling;
6411 if (kid && kid->op_type == OP_CONST &&
6412 (kid->op_private & OPpCONST_BARE))
6414 o->op_flags |= OPf_SPECIAL;
6415 kid->op_private &= ~OPpCONST_STRICT;
6422 Perl_ck_unpack(pTHX_ OP *o)
6424 OP *kid = cLISTOPo->op_first;
6425 if (kid->op_sibling) {
6426 kid = kid->op_sibling;
6427 if (!kid->op_sibling)
6428 kid->op_sibling = newDEFSVOP();
6434 Perl_ck_substr(pTHX_ OP *o)
6437 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6438 OP *kid = cLISTOPo->op_first;
6440 if (kid->op_type == OP_NULL)
6441 kid = kid->op_sibling;
6443 kid->op_flags |= OPf_MOD;
6449 /* A peephole optimizer. We visit the ops in the order they're to execute.
6450 * See the comments at the top of this file for more details about when
6451 * peep() is called */
6454 Perl_peep(pTHX_ register OP *o)
6456 register OP* oldop = 0;
6458 if (!o || o->op_opt)
6462 SAVEVPTR(PL_curcop);
6463 for (; o; o = o->op_next) {
6467 switch (o->op_type) {
6471 PL_curcop = ((COP*)o); /* for warnings */
6476 if (cSVOPo->op_private & OPpCONST_STRICT)
6477 no_bareword_allowed(o);
6479 case OP_METHOD_NAMED:
6480 /* Relocate sv to the pad for thread safety.
6481 * Despite being a "constant", the SV is written to,
6482 * for reference counts, sv_upgrade() etc. */
6484 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6485 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6486 /* If op_sv is already a PADTMP then it is being used by
6487 * some pad, so make a copy. */
6488 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6489 SvREADONLY_on(PAD_SVl(ix));
6490 SvREFCNT_dec(cSVOPo->op_sv);
6493 SvREFCNT_dec(PAD_SVl(ix));
6494 SvPADTMP_on(cSVOPo->op_sv);
6495 PAD_SETSV(ix, cSVOPo->op_sv);
6496 /* XXX I don't know how this isn't readonly already. */
6497 SvREADONLY_on(PAD_SVl(ix));
6499 cSVOPo->op_sv = Nullsv;
6507 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6508 if (o->op_next->op_private & OPpTARGET_MY) {
6509 if (o->op_flags & OPf_STACKED) /* chained concats */
6510 goto ignore_optimization;
6512 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6513 o->op_targ = o->op_next->op_targ;
6514 o->op_next->op_targ = 0;
6515 o->op_private |= OPpTARGET_MY;
6518 op_null(o->op_next);
6520 ignore_optimization:
6524 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6526 break; /* Scalar stub must produce undef. List stub is noop */
6530 if (o->op_targ == OP_NEXTSTATE
6531 || o->op_targ == OP_DBSTATE
6532 || o->op_targ == OP_SETSTATE)
6534 PL_curcop = ((COP*)o);
6536 /* XXX: We avoid setting op_seq here to prevent later calls
6537 to peep() from mistakenly concluding that optimisation
6538 has already occurred. This doesn't fix the real problem,
6539 though (See 20010220.007). AMS 20010719 */
6540 /* op_seq functionality is now replaced by op_opt */
6541 if (oldop && o->op_next) {
6542 oldop->op_next = o->op_next;
6550 if (oldop && o->op_next) {
6551 oldop->op_next = o->op_next;
6559 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
6560 OP* pop = (o->op_type == OP_PADAV) ?
6561 o->op_next : o->op_next->op_next;
6563 if (pop && pop->op_type == OP_CONST &&
6564 ((PL_op = pop->op_next)) &&
6565 pop->op_next->op_type == OP_AELEM &&
6566 !(pop->op_next->op_private &
6567 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6568 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6573 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
6574 no_bareword_allowed(pop);
6575 if (o->op_type == OP_GV)
6576 op_null(o->op_next);
6577 op_null(pop->op_next);
6579 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6580 o->op_next = pop->op_next->op_next;
6581 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6582 o->op_private = (U8)i;
6583 if (o->op_type == OP_GV) {
6588 o->op_flags |= OPf_SPECIAL;
6589 o->op_type = OP_AELEMFAST;
6595 if (o->op_next->op_type == OP_RV2SV) {
6596 if (!(o->op_next->op_private & OPpDEREF)) {
6597 op_null(o->op_next);
6598 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6600 o->op_next = o->op_next->op_next;
6601 o->op_type = OP_GVSV;
6602 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6605 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6607 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6608 /* XXX could check prototype here instead of just carping */
6609 SV *sv = sv_newmortal();
6610 gv_efullname3(sv, gv, Nullch);
6611 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6612 "%"SVf"() called too early to check prototype",
6616 else if (o->op_next->op_type == OP_READLINE
6617 && o->op_next->op_next->op_type == OP_CONCAT
6618 && (o->op_next->op_next->op_flags & OPf_STACKED))
6620 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6621 o->op_type = OP_RCATLINE;
6622 o->op_flags |= OPf_STACKED;
6623 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6624 op_null(o->op_next->op_next);
6625 op_null(o->op_next);
6642 while (cLOGOP->op_other->op_type == OP_NULL)
6643 cLOGOP->op_other = cLOGOP->op_other->op_next;
6644 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6650 while (cLOOP->op_redoop->op_type == OP_NULL)
6651 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6652 peep(cLOOP->op_redoop);
6653 while (cLOOP->op_nextop->op_type == OP_NULL)
6654 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6655 peep(cLOOP->op_nextop);
6656 while (cLOOP->op_lastop->op_type == OP_NULL)
6657 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6658 peep(cLOOP->op_lastop);
6665 while (cPMOP->op_pmreplstart &&
6666 cPMOP->op_pmreplstart->op_type == OP_NULL)
6667 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6668 peep(cPMOP->op_pmreplstart);
6673 if (ckWARN(WARN_SYNTAX) && o->op_next
6674 && o->op_next->op_type == OP_NEXTSTATE) {
6675 if (o->op_next->op_sibling &&
6676 o->op_next->op_sibling->op_type != OP_EXIT &&
6677 o->op_next->op_sibling->op_type != OP_WARN &&
6678 o->op_next->op_sibling->op_type != OP_DIE) {
6679 line_t oldline = CopLINE(PL_curcop);
6681 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6682 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6683 "Statement unlikely to be reached");
6684 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6685 "\t(Maybe you meant system() when you said exec()?)\n");
6686 CopLINE_set(PL_curcop, oldline);
6701 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6704 /* Make the CONST have a shared SV */
6705 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6706 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6707 key = SvPV(sv, keylen);
6708 lexname = newSVpvn_share(key,
6709 SvUTF8(sv) ? -(I32)keylen : keylen,
6715 if ((o->op_private & (OPpLVAL_INTRO)))
6718 rop = (UNOP*)((BINOP*)o)->op_first;
6719 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6721 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6722 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6724 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6725 if (!fields || !GvHV(*fields))
6727 key = SvPV(*svp, keylen);
6728 if (!hv_fetch(GvHV(*fields), key,
6729 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
6731 Perl_croak(aTHX_ "No such class field \"%s\" "
6732 "in variable %s of type %s",
6733 key, SvPV_nolen(lexname), HvNAME(SvSTASH(lexname)));
6746 SVOP *first_key_op, *key_op;
6748 if ((o->op_private & (OPpLVAL_INTRO))
6749 /* I bet there's always a pushmark... */
6750 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6751 /* hmmm, no optimization if list contains only one key. */
6753 rop = (UNOP*)((LISTOP*)o)->op_last;
6754 if (rop->op_type != OP_RV2HV)
6756 if (rop->op_first->op_type == OP_PADSV)
6757 /* @$hash{qw(keys here)} */
6758 rop = (UNOP*)rop->op_first;
6760 /* @{$hash}{qw(keys here)} */
6761 if (rop->op_first->op_type == OP_SCOPE
6762 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
6764 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
6770 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
6771 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6773 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6774 if (!fields || !GvHV(*fields))
6776 /* Again guessing that the pushmark can be jumped over.... */
6777 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
6778 ->op_first->op_sibling;
6779 for (key_op = first_key_op; key_op;
6780 key_op = (SVOP*)key_op->op_sibling) {
6781 if (key_op->op_type != OP_CONST)
6783 svp = cSVOPx_svp(key_op);
6784 key = SvPV(*svp, keylen);
6785 if (!hv_fetch(GvHV(*fields), key,
6786 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
6788 Perl_croak(aTHX_ "No such class field \"%s\" "
6789 "in variable %s of type %s",
6790 key, SvPV_nolen(lexname), HvNAME(SvSTASH(lexname)));
6797 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
6801 /* check that RHS of sort is a single plain array */
6802 oright = cUNOPo->op_first;
6803 if (!oright || oright->op_type != OP_PUSHMARK)
6806 /* reverse sort ... can be optimised. */
6807 if (!cUNOPo->op_sibling) {
6808 /* Nothing follows us on the list. */
6809 OP *reverse = o->op_next;
6811 if (reverse->op_type == OP_REVERSE &&
6812 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
6813 OP *pushmark = cUNOPx(reverse)->op_first;
6814 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
6815 && (cUNOPx(pushmark)->op_sibling == o)) {
6816 /* reverse -> pushmark -> sort */
6817 o->op_private |= OPpSORT_REVERSE;
6819 pushmark->op_next = oright->op_next;
6825 /* make @a = sort @a act in-place */
6829 oright = cUNOPx(oright)->op_sibling;
6832 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
6833 oright = cUNOPx(oright)->op_sibling;
6837 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
6838 || oright->op_next != o
6839 || (oright->op_private & OPpLVAL_INTRO)
6843 /* o2 follows the chain of op_nexts through the LHS of the
6844 * assign (if any) to the aassign op itself */
6846 if (!o2 || o2->op_type != OP_NULL)
6849 if (!o2 || o2->op_type != OP_PUSHMARK)
6852 if (o2 && o2->op_type == OP_GV)
6855 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
6856 || (o2->op_private & OPpLVAL_INTRO)
6861 if (!o2 || o2->op_type != OP_NULL)
6864 if (!o2 || o2->op_type != OP_AASSIGN
6865 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
6868 /* check that the sort is the first arg on RHS of assign */
6870 o2 = cUNOPx(o2)->op_first;
6871 if (!o2 || o2->op_type != OP_NULL)
6873 o2 = cUNOPx(o2)->op_first;
6874 if (!o2 || o2->op_type != OP_PUSHMARK)
6876 if (o2->op_sibling != o)
6879 /* check the array is the same on both sides */
6880 if (oleft->op_type == OP_RV2AV) {
6881 if (oright->op_type != OP_RV2AV
6882 || !cUNOPx(oright)->op_first
6883 || cUNOPx(oright)->op_first->op_type != OP_GV
6884 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
6885 cGVOPx_gv(cUNOPx(oright)->op_first)
6889 else if (oright->op_type != OP_PADAV
6890 || oright->op_targ != oleft->op_targ
6894 /* transfer MODishness etc from LHS arg to RHS arg */
6895 oright->op_flags = oleft->op_flags;
6896 o->op_private |= OPpSORT_INPLACE;
6898 /* excise push->gv->rv2av->null->aassign */
6899 o2 = o->op_next->op_next;
6900 op_null(o2); /* PUSHMARK */
6902 if (o2->op_type == OP_GV) {
6903 op_null(o2); /* GV */
6906 op_null(o2); /* RV2AV or PADAV */
6907 o2 = o2->op_next->op_next;
6908 op_null(o2); /* AASSIGN */
6910 o->op_next = o2->op_next;
6916 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
6918 LISTOP *enter, *exlist;
6921 enter = (LISTOP *) o->op_next;
6924 if (enter->op_type == OP_NULL) {
6925 enter = (LISTOP *) enter->op_next;
6929 /* for $a (...) will have OP_GV then OP_RV2GV here.
6930 for (...) just has an OP_GV. */
6931 if (enter->op_type == OP_GV) {
6932 gvop = (OP *) enter;
6933 enter = (LISTOP *) enter->op_next;
6936 if (enter->op_type == OP_RV2GV) {
6937 enter = (LISTOP *) enter->op_next;
6943 if (enter->op_type != OP_ENTERITER)
6946 iter = enter->op_next;
6947 if (!iter || iter->op_type != OP_ITER)
6950 expushmark = enter->op_first;
6951 if (!expushmark || expushmark->op_type != OP_NULL
6952 || expushmark->op_targ != OP_PUSHMARK)
6955 exlist = (LISTOP *) expushmark->op_sibling;
6956 if (!exlist || exlist->op_type != OP_NULL
6957 || exlist->op_targ != OP_LIST)
6960 if (exlist->op_last != o) {
6961 /* Mmm. Was expecting to point back to this op. */
6964 theirmark = exlist->op_first;
6965 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
6968 if (theirmark->op_sibling != o) {
6969 /* There's something between the mark and the reverse, eg
6970 for (1, reverse (...))
6975 ourmark = ((LISTOP *)o)->op_first;
6976 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
6979 ourlast = ((LISTOP *)o)->op_last;
6980 if (!ourlast || ourlast->op_next != o)
6983 rv2av = ourmark->op_sibling;
6984 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
6985 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
6986 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
6987 /* We're just reversing a single array. */
6988 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
6989 enter->op_flags |= OPf_STACKED;
6992 /* We don't have control over who points to theirmark, so sacrifice
6994 theirmark->op_next = ourmark->op_next;
6995 theirmark->op_flags = ourmark->op_flags;
6996 ourlast->op_next = gvop ? gvop : (OP *) enter;
6999 enter->op_private |= OPpITER_REVERSED;
7000 iter->op_private |= OPpITER_REVERSED;
7016 char* Perl_custom_op_name(pTHX_ OP* o)
7018 IV index = PTR2IV(o->op_ppaddr);
7022 if (!PL_custom_op_names) /* This probably shouldn't happen */
7023 return PL_op_name[OP_CUSTOM];
7025 keysv = sv_2mortal(newSViv(index));
7027 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7029 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7031 return SvPV_nolen(HeVAL(he));
7034 char* Perl_custom_op_desc(pTHX_ OP* o)
7036 IV index = PTR2IV(o->op_ppaddr);
7040 if (!PL_custom_op_descs)
7041 return PL_op_desc[OP_CUSTOM];
7043 keysv = sv_2mortal(newSViv(index));
7045 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7047 return PL_op_desc[OP_CUSTOM];
7049 return SvPV_nolen(HeVAL(he));
7055 /* Efficient sub that returns a constant scalar value. */
7057 const_sv_xsub(pTHX_ CV* cv)
7062 Perl_croak(aTHX_ "usage: %s::%s()",
7063 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7067 ST(0) = (SV*)XSANY.any_ptr;