3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 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_MAXLEN+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) && strEQ(p, " ")) {
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_catpvf(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 = gv_fetchpv(name ? name : (aname ? aname :
4208 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__")),
4209 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4219 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4220 maximum a prototype before. */
4221 if (SvTYPE(gv) > SVt_NULL) {
4222 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4223 && ckWARN_d(WARN_PROTOTYPE))
4225 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4227 cv_ckproto((CV*)gv, NULL, ps);
4230 sv_setpv((SV*)gv, ps);
4232 sv_setiv((SV*)gv, -1);
4233 SvREFCNT_dec(PL_compcv);
4234 cv = PL_compcv = NULL;
4235 PL_sub_generation++;
4239 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4241 #ifdef GV_UNIQUE_CHECK
4242 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4243 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4247 if (!block || !ps || *ps || attrs)
4250 const_sv = op_const_sv(block, Nullcv);
4253 bool exists = CvROOT(cv) || CvXSUB(cv);
4255 #ifdef GV_UNIQUE_CHECK
4256 if (exists && GvUNIQUE(gv)) {
4257 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4261 /* if the subroutine doesn't exist and wasn't pre-declared
4262 * with a prototype, assume it will be AUTOLOADed,
4263 * skipping the prototype check
4265 if (exists || SvPOK(cv))
4266 cv_ckproto(cv, gv, ps);
4267 /* already defined (or promised)? */
4268 if (exists || GvASSUMECV(gv)) {
4269 if (!block && !attrs) {
4270 if (CvFLAGS(PL_compcv)) {
4271 /* might have had built-in attrs applied */
4272 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4274 /* just a "sub foo;" when &foo is already defined */
4275 SAVEFREESV(PL_compcv);
4278 /* ahem, death to those who redefine active sort subs */
4279 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4280 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4282 if (ckWARN(WARN_REDEFINE)
4284 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4286 line_t oldline = CopLINE(PL_curcop);
4287 if (PL_copline != NOLINE)
4288 CopLINE_set(PL_curcop, PL_copline);
4289 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4290 CvCONST(cv) ? "Constant subroutine %s redefined"
4291 : "Subroutine %s redefined", name);
4292 CopLINE_set(PL_curcop, oldline);
4300 SvREFCNT_inc(const_sv);
4302 assert(!CvROOT(cv) && !CvCONST(cv));
4303 sv_setpv((SV*)cv, ""); /* prototype is "" */
4304 CvXSUBANY(cv).any_ptr = const_sv;
4305 CvXSUB(cv) = const_sv_xsub;
4310 cv = newCONSTSUB(NULL, name, const_sv);
4313 SvREFCNT_dec(PL_compcv);
4315 PL_sub_generation++;
4322 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4323 * before we clobber PL_compcv.
4327 /* Might have had built-in attributes applied -- propagate them. */
4328 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4329 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4330 stash = GvSTASH(CvGV(cv));
4331 else if (CvSTASH(cv))
4332 stash = CvSTASH(cv);
4334 stash = PL_curstash;
4337 /* possibly about to re-define existing subr -- ignore old cv */
4338 rcv = (SV*)PL_compcv;
4339 if (name && GvSTASH(gv))
4340 stash = GvSTASH(gv);
4342 stash = PL_curstash;
4344 apply_attrs(stash, rcv, attrs, FALSE);
4346 if (cv) { /* must reuse cv if autoloaded */
4348 /* got here with just attrs -- work done, so bug out */
4349 SAVEFREESV(PL_compcv);
4352 /* transfer PL_compcv to cv */
4354 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4355 if (!CvWEAKOUTSIDE(cv))
4356 SvREFCNT_dec(CvOUTSIDE(cv));
4357 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4358 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4359 CvOUTSIDE(PL_compcv) = 0;
4360 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4361 CvPADLIST(PL_compcv) = 0;
4362 /* inner references to PL_compcv must be fixed up ... */
4363 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4364 /* ... before we throw it away */
4365 SvREFCNT_dec(PL_compcv);
4367 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4368 ++PL_sub_generation;
4375 PL_sub_generation++;
4379 CvFILE_set_from_cop(cv, PL_curcop);
4380 CvSTASH(cv) = PL_curstash;
4383 sv_setpv((SV*)cv, ps);
4385 if (PL_error_count) {
4389 char *s = strrchr(name, ':');
4391 if (strEQ(s, "BEGIN")) {
4393 "BEGIN not safe after errors--compilation aborted";
4394 if (PL_in_eval & EVAL_KEEPERR)
4395 Perl_croak(aTHX_ not_safe);
4397 /* force display of errors found but not reported */
4398 sv_catpv(ERRSV, not_safe);
4399 Perl_croak(aTHX_ "%"SVf, ERRSV);
4408 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4409 mod(scalarseq(block), OP_LEAVESUBLV));
4412 /* This makes sub {}; work as expected. */
4413 if (block->op_type == OP_STUB) {
4415 block = newSTATEOP(0, Nullch, 0);
4417 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4419 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4420 OpREFCNT_set(CvROOT(cv), 1);
4421 CvSTART(cv) = LINKLIST(CvROOT(cv));
4422 CvROOT(cv)->op_next = 0;
4423 CALL_PEEP(CvSTART(cv));
4425 /* now that optimizer has done its work, adjust pad values */
4427 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4430 assert(!CvCONST(cv));
4431 if (ps && !*ps && op_const_sv(block, cv))
4435 if (name || aname) {
4437 char *tname = (name ? name : aname);
4439 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4440 SV *sv = NEWSV(0,0);
4441 SV *tmpstr = sv_newmortal();
4442 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4446 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4448 (long)PL_subline, (long)CopLINE(PL_curcop));
4449 gv_efullname3(tmpstr, gv, Nullch);
4450 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4451 hv = GvHVn(db_postponed);
4452 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4453 && (pcv = GvCV(db_postponed)))
4459 call_sv((SV*)pcv, G_DISCARD);
4463 if ((s = strrchr(tname,':')))
4468 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4471 if (strEQ(s, "BEGIN") && !PL_error_count) {
4472 I32 oldscope = PL_scopestack_ix;
4474 SAVECOPFILE(&PL_compiling);
4475 SAVECOPLINE(&PL_compiling);
4478 PL_beginav = newAV();
4479 DEBUG_x( dump_sub(gv) );
4480 av_push(PL_beginav, (SV*)cv);
4481 GvCV(gv) = 0; /* cv has been hijacked */
4482 call_list(oldscope, PL_beginav);
4484 PL_curcop = &PL_compiling;
4485 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4488 else if (strEQ(s, "END") && !PL_error_count) {
4491 DEBUG_x( dump_sub(gv) );
4492 av_unshift(PL_endav, 1);
4493 av_store(PL_endav, 0, (SV*)cv);
4494 GvCV(gv) = 0; /* cv has been hijacked */
4496 else if (strEQ(s, "CHECK") && !PL_error_count) {
4498 PL_checkav = newAV();
4499 DEBUG_x( dump_sub(gv) );
4500 if (PL_main_start && ckWARN(WARN_VOID))
4501 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4502 av_unshift(PL_checkav, 1);
4503 av_store(PL_checkav, 0, (SV*)cv);
4504 GvCV(gv) = 0; /* cv has been hijacked */
4506 else if (strEQ(s, "INIT") && !PL_error_count) {
4508 PL_initav = newAV();
4509 DEBUG_x( dump_sub(gv) );
4510 if (PL_main_start && ckWARN(WARN_VOID))
4511 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4512 av_push(PL_initav, (SV*)cv);
4513 GvCV(gv) = 0; /* cv has been hijacked */
4518 PL_copline = NOLINE;
4523 /* XXX unsafe for threads if eval_owner isn't held */
4525 =for apidoc newCONSTSUB
4527 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4528 eligible for inlining at compile-time.
4534 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4540 SAVECOPLINE(PL_curcop);
4541 CopLINE_set(PL_curcop, PL_copline);
4544 PL_hints &= ~HINT_BLOCK_SCOPE;
4547 SAVESPTR(PL_curstash);
4548 SAVECOPSTASH(PL_curcop);
4549 PL_curstash = stash;
4550 CopSTASH_set(PL_curcop,stash);
4553 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4554 CvXSUBANY(cv).any_ptr = sv;
4556 sv_setpv((SV*)cv, ""); /* prototype is "" */
4559 CopSTASH_free(PL_curcop);
4567 =for apidoc U||newXS
4569 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4575 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
4577 GV *gv = gv_fetchpv(name ? name :
4578 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4579 GV_ADDMULTI, SVt_PVCV);
4583 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4585 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4587 /* just a cached method */
4591 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4592 /* already defined (or promised) */
4593 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4594 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4595 line_t oldline = CopLINE(PL_curcop);
4596 if (PL_copline != NOLINE)
4597 CopLINE_set(PL_curcop, PL_copline);
4598 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4599 CvCONST(cv) ? "Constant subroutine %s redefined"
4600 : "Subroutine %s redefined"
4602 CopLINE_set(PL_curcop, oldline);
4609 if (cv) /* must reuse cv if autoloaded */
4612 cv = (CV*)NEWSV(1105,0);
4613 sv_upgrade((SV *)cv, SVt_PVCV);
4617 PL_sub_generation++;
4621 (void)gv_fetchfile(filename);
4622 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
4623 an external constant string */
4624 CvXSUB(cv) = subaddr;
4627 char *s = strrchr(name,':');
4633 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4636 if (strEQ(s, "BEGIN")) {
4638 PL_beginav = newAV();
4639 av_push(PL_beginav, (SV*)cv);
4640 GvCV(gv) = 0; /* cv has been hijacked */
4642 else if (strEQ(s, "END")) {
4645 av_unshift(PL_endav, 1);
4646 av_store(PL_endav, 0, (SV*)cv);
4647 GvCV(gv) = 0; /* cv has been hijacked */
4649 else if (strEQ(s, "CHECK")) {
4651 PL_checkav = newAV();
4652 if (PL_main_start && ckWARN(WARN_VOID))
4653 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4654 av_unshift(PL_checkav, 1);
4655 av_store(PL_checkav, 0, (SV*)cv);
4656 GvCV(gv) = 0; /* cv has been hijacked */
4658 else if (strEQ(s, "INIT")) {
4660 PL_initav = newAV();
4661 if (PL_main_start && ckWARN(WARN_VOID))
4662 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4663 av_push(PL_initav, (SV*)cv);
4664 GvCV(gv) = 0; /* cv has been hijacked */
4675 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4683 name = SvPVx(cSVOPo->op_sv, n_a);
4686 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
4687 #ifdef GV_UNIQUE_CHECK
4689 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4693 if ((cv = GvFORM(gv))) {
4694 if (ckWARN(WARN_REDEFINE)) {
4695 line_t oldline = CopLINE(PL_curcop);
4696 if (PL_copline != NOLINE)
4697 CopLINE_set(PL_curcop, PL_copline);
4698 Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Format %s redefined",name);
4699 CopLINE_set(PL_curcop, oldline);
4706 CvFILE_set_from_cop(cv, PL_curcop);
4709 pad_tidy(padtidy_FORMAT);
4710 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4711 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4712 OpREFCNT_set(CvROOT(cv), 1);
4713 CvSTART(cv) = LINKLIST(CvROOT(cv));
4714 CvROOT(cv)->op_next = 0;
4715 CALL_PEEP(CvSTART(cv));
4717 PL_copline = NOLINE;
4722 Perl_newANONLIST(pTHX_ OP *o)
4724 return newUNOP(OP_REFGEN, 0,
4725 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4729 Perl_newANONHASH(pTHX_ OP *o)
4731 return newUNOP(OP_REFGEN, 0,
4732 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4736 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4738 return newANONATTRSUB(floor, proto, Nullop, block);
4742 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4744 return newUNOP(OP_REFGEN, 0,
4745 newSVOP(OP_ANONCODE, 0,
4746 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
4750 Perl_oopsAV(pTHX_ OP *o)
4752 switch (o->op_type) {
4754 o->op_type = OP_PADAV;
4755 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4756 return ref(o, OP_RV2AV);
4759 o->op_type = OP_RV2AV;
4760 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4765 if (ckWARN_d(WARN_INTERNAL))
4766 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
4773 Perl_oopsHV(pTHX_ OP *o)
4775 switch (o->op_type) {
4778 o->op_type = OP_PADHV;
4779 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4780 return ref(o, OP_RV2HV);
4784 o->op_type = OP_RV2HV;
4785 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
4790 if (ckWARN_d(WARN_INTERNAL))
4791 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
4798 Perl_newAVREF(pTHX_ OP *o)
4800 if (o->op_type == OP_PADANY) {
4801 o->op_type = OP_PADAV;
4802 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4805 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
4806 && ckWARN(WARN_DEPRECATED)) {
4807 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4808 "Using an array as a reference is deprecated");
4810 return newUNOP(OP_RV2AV, 0, scalar(o));
4814 Perl_newGVREF(pTHX_ I32 type, OP *o)
4816 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
4817 return newUNOP(OP_NULL, 0, o);
4818 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
4822 Perl_newHVREF(pTHX_ OP *o)
4824 if (o->op_type == OP_PADANY) {
4825 o->op_type = OP_PADHV;
4826 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4829 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
4830 && ckWARN(WARN_DEPRECATED)) {
4831 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4832 "Using a hash as a reference is deprecated");
4834 return newUNOP(OP_RV2HV, 0, scalar(o));
4838 Perl_oopsCV(pTHX_ OP *o)
4840 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
4846 Perl_newCVREF(pTHX_ I32 flags, OP *o)
4848 return newUNOP(OP_RV2CV, flags, scalar(o));
4852 Perl_newSVREF(pTHX_ OP *o)
4854 if (o->op_type == OP_PADANY) {
4855 o->op_type = OP_PADSV;
4856 o->op_ppaddr = PL_ppaddr[OP_PADSV];
4859 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4860 o->op_flags |= OPpDONE_SVREF;
4863 return newUNOP(OP_RV2SV, 0, scalar(o));
4866 /* Check routines. See the comments at the top of this file for details
4867 * on when these are called */
4870 Perl_ck_anoncode(pTHX_ OP *o)
4872 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
4873 cSVOPo->op_sv = Nullsv;
4878 Perl_ck_bitop(pTHX_ OP *o)
4880 #define OP_IS_NUMCOMPARE(op) \
4881 ((op) == OP_LT || (op) == OP_I_LT || \
4882 (op) == OP_GT || (op) == OP_I_GT || \
4883 (op) == OP_LE || (op) == OP_I_LE || \
4884 (op) == OP_GE || (op) == OP_I_GE || \
4885 (op) == OP_EQ || (op) == OP_I_EQ || \
4886 (op) == OP_NE || (op) == OP_I_NE || \
4887 (op) == OP_NCMP || (op) == OP_I_NCMP)
4888 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4889 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
4890 && (o->op_type == OP_BIT_OR
4891 || o->op_type == OP_BIT_AND
4892 || o->op_type == OP_BIT_XOR))
4894 OP * left = cBINOPo->op_first;
4895 OP * right = left->op_sibling;
4896 if ((OP_IS_NUMCOMPARE(left->op_type) &&
4897 (left->op_flags & OPf_PARENS) == 0) ||
4898 (OP_IS_NUMCOMPARE(right->op_type) &&
4899 (right->op_flags & OPf_PARENS) == 0))
4900 if (ckWARN(WARN_PRECEDENCE))
4901 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4902 "Possible precedence problem on bitwise %c operator",
4903 o->op_type == OP_BIT_OR ? '|'
4904 : o->op_type == OP_BIT_AND ? '&' : '^'
4911 Perl_ck_concat(pTHX_ OP *o)
4913 OP *kid = cUNOPo->op_first;
4914 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
4915 !(kUNOP->op_first->op_flags & OPf_MOD))
4916 o->op_flags |= OPf_STACKED;
4921 Perl_ck_spair(pTHX_ OP *o)
4923 if (o->op_flags & OPf_KIDS) {
4926 OPCODE type = o->op_type;
4927 o = modkids(ck_fun(o), type);
4928 kid = cUNOPo->op_first;
4929 newop = kUNOP->op_first->op_sibling;
4931 (newop->op_sibling ||
4932 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
4933 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
4934 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
4938 op_free(kUNOP->op_first);
4939 kUNOP->op_first = newop;
4941 o->op_ppaddr = PL_ppaddr[++o->op_type];
4946 Perl_ck_delete(pTHX_ OP *o)
4950 if (o->op_flags & OPf_KIDS) {
4951 OP *kid = cUNOPo->op_first;
4952 switch (kid->op_type) {
4954 o->op_flags |= OPf_SPECIAL;
4957 o->op_private |= OPpSLICE;
4960 o->op_flags |= OPf_SPECIAL;
4965 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
4974 Perl_ck_die(pTHX_ OP *o)
4977 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4983 Perl_ck_eof(pTHX_ OP *o)
4985 I32 type = o->op_type;
4987 if (o->op_flags & OPf_KIDS) {
4988 if (cLISTOPo->op_first->op_type == OP_STUB) {
4990 o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
4998 Perl_ck_eval(pTHX_ OP *o)
5000 PL_hints |= HINT_BLOCK_SCOPE;
5001 if (o->op_flags & OPf_KIDS) {
5002 SVOP *kid = (SVOP*)cUNOPo->op_first;
5005 o->op_flags &= ~OPf_KIDS;
5008 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
5011 cUNOPo->op_first = 0;
5014 NewOp(1101, enter, 1, LOGOP);
5015 enter->op_type = OP_ENTERTRY;
5016 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5017 enter->op_private = 0;
5019 /* establish postfix order */
5020 enter->op_next = (OP*)enter;
5022 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5023 o->op_type = OP_LEAVETRY;
5024 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5025 enter->op_other = o;
5035 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5037 o->op_targ = (PADOFFSET)PL_hints;
5042 Perl_ck_exit(pTHX_ OP *o)
5045 HV *table = GvHV(PL_hintgv);
5047 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5048 if (svp && *svp && SvTRUE(*svp))
5049 o->op_private |= OPpEXIT_VMSISH;
5051 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5057 Perl_ck_exec(pTHX_ OP *o)
5060 if (o->op_flags & OPf_STACKED) {
5062 kid = cUNOPo->op_first->op_sibling;
5063 if (kid->op_type == OP_RV2GV)
5072 Perl_ck_exists(pTHX_ OP *o)
5075 if (o->op_flags & OPf_KIDS) {
5076 OP *kid = cUNOPo->op_first;
5077 if (kid->op_type == OP_ENTERSUB) {
5078 (void) ref(kid, o->op_type);
5079 if (kid->op_type != OP_RV2CV && !PL_error_count)
5080 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5082 o->op_private |= OPpEXISTS_SUB;
5084 else if (kid->op_type == OP_AELEM)
5085 o->op_flags |= OPf_SPECIAL;
5086 else if (kid->op_type != OP_HELEM)
5087 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5096 Perl_ck_gvconst(pTHX_ register OP *o)
5098 o = fold_constants(o);
5099 if (o->op_type == OP_CONST)
5106 Perl_ck_rvconst(pTHX_ register OP *o)
5108 SVOP *kid = (SVOP*)cUNOPo->op_first;
5110 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5111 if (kid->op_type == OP_CONST) {
5115 SV *kidsv = kid->op_sv;
5118 /* Is it a constant from cv_const_sv()? */
5119 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5120 SV *rsv = SvRV(kidsv);
5121 int svtype = SvTYPE(rsv);
5122 char *badtype = Nullch;
5124 switch (o->op_type) {
5126 if (svtype > SVt_PVMG)
5127 badtype = "a SCALAR";
5130 if (svtype != SVt_PVAV)
5131 badtype = "an ARRAY";
5134 if (svtype != SVt_PVHV)
5138 if (svtype != SVt_PVCV)
5143 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5146 name = SvPV(kidsv, n_a);
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 (\"%s\") 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_fetchpv(name,
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)) {
5219 OP *newop = newGVOP(type, OPf_REF,
5220 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5226 if ((PL_hints & HINT_FILETEST_ACCESS) &&
5227 OP_IS_FILETEST_ACCESS(o))
5228 o->op_private |= OPpFT_ACCESS;
5230 if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
5231 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
5232 o->op_private |= OPpFT_STACKED;
5236 if (type == OP_FTTTY)
5237 o = newGVOP(type, OPf_REF, PL_stdingv);
5239 o = newUNOP(type, 0, newDEFSVOP());
5245 Perl_ck_fun(pTHX_ OP *o)
5251 int type = o->op_type;
5252 register I32 oa = PL_opargs[type] >> OASHIFT;
5254 if (o->op_flags & OPf_STACKED) {
5255 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5258 return no_fh_allowed(o);
5261 if (o->op_flags & OPf_KIDS) {
5263 tokid = &cLISTOPo->op_first;
5264 kid = cLISTOPo->op_first;
5265 if (kid->op_type == OP_PUSHMARK ||
5266 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5268 tokid = &kid->op_sibling;
5269 kid = kid->op_sibling;
5271 if (!kid && PL_opargs[type] & OA_DEFGV)
5272 *tokid = kid = newDEFSVOP();
5276 sibl = kid->op_sibling;
5279 /* list seen where single (scalar) arg expected? */
5280 if (numargs == 1 && !(oa >> 4)
5281 && kid->op_type == OP_LIST && type != OP_SCALAR)
5283 return too_many_arguments(o,PL_op_desc[type]);
5296 if ((type == OP_PUSH || type == OP_UNSHIFT)
5297 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5298 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5299 "Useless use of %s with no values",
5302 if (kid->op_type == OP_CONST &&
5303 (kid->op_private & OPpCONST_BARE))
5305 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5306 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5307 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5308 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5309 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5310 "Array @%s missing the @ in argument %"IVdf" of %s()",
5311 name, (IV)numargs, PL_op_desc[type]);
5314 kid->op_sibling = sibl;
5317 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5318 bad_type(numargs, "array", PL_op_desc[type], kid);
5322 if (kid->op_type == OP_CONST &&
5323 (kid->op_private & OPpCONST_BARE))
5325 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5326 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5327 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5328 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5329 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5330 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5331 name, (IV)numargs, PL_op_desc[type]);
5334 kid->op_sibling = sibl;
5337 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5338 bad_type(numargs, "hash", PL_op_desc[type], kid);
5343 OP *newop = newUNOP(OP_NULL, 0, kid);
5344 kid->op_sibling = 0;
5346 newop->op_next = newop;
5348 kid->op_sibling = sibl;
5353 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5354 if (kid->op_type == OP_CONST &&
5355 (kid->op_private & OPpCONST_BARE))
5357 OP *newop = newGVOP(OP_GV, 0,
5358 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5360 if (!(o->op_private & 1) && /* if not unop */
5361 kid == cLISTOPo->op_last)
5362 cLISTOPo->op_last = newop;
5366 else if (kid->op_type == OP_READLINE) {
5367 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5368 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5371 I32 flags = OPf_SPECIAL;
5375 /* is this op a FH constructor? */
5376 if (is_handle_constructor(o,numargs)) {
5377 char *name = Nullch;
5381 /* Set a flag to tell rv2gv to vivify
5382 * need to "prove" flag does not mean something
5383 * else already - NI-S 1999/05/07
5386 if (kid->op_type == OP_PADSV) {
5387 name = PAD_COMPNAME_PV(kid->op_targ);
5388 /* SvCUR of a pad namesv can't be trusted
5389 * (see PL_generation), so calc its length
5395 else if (kid->op_type == OP_RV2SV
5396 && kUNOP->op_first->op_type == OP_GV)
5398 GV *gv = cGVOPx_gv(kUNOP->op_first);
5400 len = GvNAMELEN(gv);
5402 else if (kid->op_type == OP_AELEM
5403 || kid->op_type == OP_HELEM)
5408 if ((op = ((BINOP*)kid)->op_first)) {
5409 SV *tmpstr = Nullsv;
5411 kid->op_type == OP_AELEM ?
5413 if (((op->op_type == OP_RV2AV) ||
5414 (op->op_type == OP_RV2HV)) &&
5415 (op = ((UNOP*)op)->op_first) &&
5416 (op->op_type == OP_GV)) {
5417 /* packagevar $a[] or $h{} */
5418 GV *gv = cGVOPx_gv(op);
5426 else if (op->op_type == OP_PADAV
5427 || op->op_type == OP_PADHV) {
5428 /* lexicalvar $a[] or $h{} */
5430 PAD_COMPNAME_PV(op->op_targ);
5440 name = SvPV(tmpstr, len);
5445 name = "__ANONIO__";
5452 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5453 namesv = PAD_SVl(targ);
5454 (void)SvUPGRADE(namesv, SVt_PV);
5456 sv_setpvn(namesv, "$", 1);
5457 sv_catpvn(namesv, name, len);
5460 kid->op_sibling = 0;
5461 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5462 kid->op_targ = targ;
5463 kid->op_private |= priv;
5465 kid->op_sibling = sibl;
5471 mod(scalar(kid), type);
5475 tokid = &kid->op_sibling;
5476 kid = kid->op_sibling;
5478 o->op_private |= numargs;
5480 return too_many_arguments(o,OP_DESC(o));
5483 else if (PL_opargs[type] & OA_DEFGV) {
5485 return newUNOP(type, 0, newDEFSVOP());
5489 while (oa & OA_OPTIONAL)
5491 if (oa && oa != OA_LIST)
5492 return too_few_arguments(o,OP_DESC(o));
5498 Perl_ck_glob(pTHX_ OP *o)
5503 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5504 append_elem(OP_GLOB, o, newDEFSVOP());
5506 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5507 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5509 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5512 #if !defined(PERL_EXTERNAL_GLOB)
5513 /* XXX this can be tightened up and made more failsafe. */
5514 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5517 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5518 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5519 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5520 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5521 GvCV(gv) = GvCV(glob_gv);
5522 SvREFCNT_inc((SV*)GvCV(gv));
5523 GvIMPORTED_CV_on(gv);
5526 #endif /* PERL_EXTERNAL_GLOB */
5528 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5529 append_elem(OP_GLOB, o,
5530 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5531 o->op_type = OP_LIST;
5532 o->op_ppaddr = PL_ppaddr[OP_LIST];
5533 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5534 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5535 cLISTOPo->op_first->op_targ = 0;
5536 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5537 append_elem(OP_LIST, o,
5538 scalar(newUNOP(OP_RV2CV, 0,
5539 newGVOP(OP_GV, 0, gv)))));
5540 o = newUNOP(OP_NULL, 0, ck_subr(o));
5541 o->op_targ = OP_GLOB; /* hint at what it used to be */
5544 gv = newGVgen("main");
5546 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5552 Perl_ck_grep(pTHX_ OP *o)
5556 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5559 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5560 NewOp(1101, gwop, 1, LOGOP);
5562 if (o->op_flags & OPf_STACKED) {
5565 kid = cLISTOPo->op_first->op_sibling;
5566 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
5569 kid->op_next = (OP*)gwop;
5570 o->op_flags &= ~OPf_STACKED;
5572 kid = cLISTOPo->op_first->op_sibling;
5573 if (type == OP_MAPWHILE)
5580 kid = cLISTOPo->op_first->op_sibling;
5581 if (kid->op_type != OP_NULL)
5582 Perl_croak(aTHX_ "panic: ck_grep");
5583 kid = kUNOP->op_first;
5585 gwop->op_type = type;
5586 gwop->op_ppaddr = PL_ppaddr[type];
5587 gwop->op_first = listkids(o);
5588 gwop->op_flags |= OPf_KIDS;
5589 gwop->op_other = LINKLIST(kid);
5590 kid->op_next = (OP*)gwop;
5591 offset = pad_findmy("$_");
5592 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
5593 o->op_private = gwop->op_private = 0;
5594 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5597 o->op_private = gwop->op_private = OPpGREP_LEX;
5598 gwop->op_targ = o->op_targ = offset;
5601 kid = cLISTOPo->op_first->op_sibling;
5602 if (!kid || !kid->op_sibling)
5603 return too_few_arguments(o,OP_DESC(o));
5604 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5605 mod(kid, OP_GREPSTART);
5611 Perl_ck_index(pTHX_ OP *o)
5613 if (o->op_flags & OPf_KIDS) {
5614 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5616 kid = kid->op_sibling; /* get past "big" */
5617 if (kid && kid->op_type == OP_CONST)
5618 fbm_compile(((SVOP*)kid)->op_sv, 0);
5624 Perl_ck_lengthconst(pTHX_ OP *o)
5626 /* XXX length optimization goes here */
5631 Perl_ck_lfun(pTHX_ OP *o)
5633 OPCODE type = o->op_type;
5634 return modkids(ck_fun(o), type);
5638 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5640 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5641 switch (cUNOPo->op_first->op_type) {
5643 /* This is needed for
5644 if (defined %stash::)
5645 to work. Do not break Tk.
5647 break; /* Globals via GV can be undef */
5649 case OP_AASSIGN: /* Is this a good idea? */
5650 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5651 "defined(@array) is deprecated");
5652 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5653 "\t(Maybe you should just omit the defined()?)\n");
5656 /* This is needed for
5657 if (defined %stash::)
5658 to work. Do not break Tk.
5660 break; /* Globals via GV can be undef */
5662 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5663 "defined(%%hash) is deprecated");
5664 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5665 "\t(Maybe you should just omit the defined()?)\n");
5676 Perl_ck_rfun(pTHX_ OP *o)
5678 OPCODE type = o->op_type;
5679 return refkids(ck_fun(o), type);
5683 Perl_ck_listiob(pTHX_ OP *o)
5687 kid = cLISTOPo->op_first;
5690 kid = cLISTOPo->op_first;
5692 if (kid->op_type == OP_PUSHMARK)
5693 kid = kid->op_sibling;
5694 if (kid && o->op_flags & OPf_STACKED)
5695 kid = kid->op_sibling;
5696 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5697 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5698 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5699 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5700 cLISTOPo->op_first->op_sibling = kid;
5701 cLISTOPo->op_last = kid;
5702 kid = kid->op_sibling;
5707 append_elem(o->op_type, o, newDEFSVOP());
5713 Perl_ck_sassign(pTHX_ OP *o)
5715 OP *kid = cLISTOPo->op_first;
5716 /* has a disposable target? */
5717 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5718 && !(kid->op_flags & OPf_STACKED)
5719 /* Cannot steal the second time! */
5720 && !(kid->op_private & OPpTARGET_MY))
5722 OP *kkid = kid->op_sibling;
5724 /* Can just relocate the target. */
5725 if (kkid && kkid->op_type == OP_PADSV
5726 && !(kkid->op_private & OPpLVAL_INTRO))
5728 kid->op_targ = kkid->op_targ;
5730 /* Now we do not need PADSV and SASSIGN. */
5731 kid->op_sibling = o->op_sibling; /* NULL */
5732 cLISTOPo->op_first = NULL;
5735 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
5739 /* optimise C<my $x = undef> to C<my $x> */
5740 if (kid->op_type == OP_UNDEF) {
5741 OP *kkid = kid->op_sibling;
5742 if (kkid && kkid->op_type == OP_PADSV
5743 && (kkid->op_private & OPpLVAL_INTRO))
5745 cLISTOPo->op_first = NULL;
5746 kid->op_sibling = NULL;
5756 Perl_ck_match(pTHX_ OP *o)
5758 if (o->op_type != OP_QR) {
5759 I32 offset = pad_findmy("$_");
5760 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS(offset) & SVpad_OUR)) {
5761 o->op_targ = offset;
5762 o->op_private |= OPpTARGET_MY;
5765 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
5766 o->op_private |= OPpRUNTIME;
5771 Perl_ck_method(pTHX_ OP *o)
5773 OP *kid = cUNOPo->op_first;
5774 if (kid->op_type == OP_CONST) {
5775 SV* sv = kSVOP->op_sv;
5776 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
5778 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5779 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
5782 kSVOP->op_sv = Nullsv;
5784 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5793 Perl_ck_null(pTHX_ OP *o)
5799 Perl_ck_open(pTHX_ OP *o)
5801 HV *table = GvHV(PL_hintgv);
5805 svp = hv_fetch(table, "open_IN", 7, FALSE);
5807 mode = mode_from_discipline(*svp);
5808 if (mode & O_BINARY)
5809 o->op_private |= OPpOPEN_IN_RAW;
5810 else if (mode & O_TEXT)
5811 o->op_private |= OPpOPEN_IN_CRLF;
5814 svp = hv_fetch(table, "open_OUT", 8, FALSE);
5816 mode = mode_from_discipline(*svp);
5817 if (mode & O_BINARY)
5818 o->op_private |= OPpOPEN_OUT_RAW;
5819 else if (mode & O_TEXT)
5820 o->op_private |= OPpOPEN_OUT_CRLF;
5823 if (o->op_type == OP_BACKTICK)
5826 /* In case of three-arg dup open remove strictness
5827 * from the last arg if it is a bareword. */
5828 OP *first = cLISTOPx(o)->op_first; /* The pushmark. */
5829 OP *last = cLISTOPx(o)->op_last; /* The bareword. */
5833 if ((last->op_type == OP_CONST) && /* The bareword. */
5834 (last->op_private & OPpCONST_BARE) &&
5835 (last->op_private & OPpCONST_STRICT) &&
5836 (oa = first->op_sibling) && /* The fh. */
5837 (oa = oa->op_sibling) && /* The mode. */
5838 SvPOK(((SVOP*)oa)->op_sv) &&
5839 (mode = SvPVX(((SVOP*)oa)->op_sv)) &&
5840 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
5841 (last == oa->op_sibling)) /* The bareword. */
5842 last->op_private &= ~OPpCONST_STRICT;
5848 Perl_ck_repeat(pTHX_ OP *o)
5850 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5851 o->op_private |= OPpREPEAT_DOLIST;
5852 cBINOPo->op_first = force_list(cBINOPo->op_first);
5860 Perl_ck_require(pTHX_ OP *o)
5864 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
5865 SVOP *kid = (SVOP*)cUNOPo->op_first;
5867 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5869 for (s = SvPVX(kid->op_sv); *s; s++) {
5870 if (*s == ':' && s[1] == ':') {
5872 Move(s+2, s+1, strlen(s+2)+1, char);
5873 --SvCUR(kid->op_sv);
5876 if (SvREADONLY(kid->op_sv)) {
5877 SvREADONLY_off(kid->op_sv);
5878 sv_catpvn(kid->op_sv, ".pm", 3);
5879 SvREADONLY_on(kid->op_sv);
5882 sv_catpvn(kid->op_sv, ".pm", 3);
5886 /* handle override, if any */
5887 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
5888 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
5889 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
5891 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5892 OP *kid = cUNOPo->op_first;
5893 cUNOPo->op_first = 0;
5895 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5896 append_elem(OP_LIST, kid,
5897 scalar(newUNOP(OP_RV2CV, 0,
5906 Perl_ck_return(pTHX_ OP *o)
5909 if (CvLVALUE(PL_compcv)) {
5910 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5911 mod(kid, OP_LEAVESUBLV);
5918 Perl_ck_retarget(pTHX_ OP *o)
5920 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5927 Perl_ck_select(pTHX_ OP *o)
5930 if (o->op_flags & OPf_KIDS) {
5931 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5932 if (kid && kid->op_sibling) {
5933 o->op_type = OP_SSELECT;
5934 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
5936 return fold_constants(o);
5940 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5941 if (kid && kid->op_type == OP_RV2GV)
5942 kid->op_private &= ~HINT_STRICT_REFS;
5947 Perl_ck_shift(pTHX_ OP *o)
5949 I32 type = o->op_type;
5951 if (!(o->op_flags & OPf_KIDS)) {
5955 argop = newUNOP(OP_RV2AV, 0,
5956 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
5957 return newUNOP(type, 0, scalar(argop));
5959 return scalar(modkids(ck_fun(o), type));
5963 Perl_ck_sort(pTHX_ OP *o)
5967 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
5969 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5970 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
5972 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
5974 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
5976 if (kid->op_type == OP_SCOPE) {
5980 else if (kid->op_type == OP_LEAVE) {
5981 if (o->op_type == OP_SORT) {
5982 op_null(kid); /* wipe out leave */
5985 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
5986 if (k->op_next == kid)
5988 /* don't descend into loops */
5989 else if (k->op_type == OP_ENTERLOOP
5990 || k->op_type == OP_ENTERITER)
5992 k = cLOOPx(k)->op_lastop;
5997 kid->op_next = 0; /* just disconnect the leave */
5998 k = kLISTOP->op_first;
6003 if (o->op_type == OP_SORT) {
6004 /* provide scalar context for comparison function/block */
6010 o->op_flags |= OPf_SPECIAL;
6012 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6015 firstkid = firstkid->op_sibling;
6018 /* provide list context for arguments */
6019 if (o->op_type == OP_SORT)
6026 S_simplify_sort(pTHX_ OP *o)
6028 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6032 if (!(o->op_flags & OPf_STACKED))
6034 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6035 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6036 kid = kUNOP->op_first; /* get past null */
6037 if (kid->op_type != OP_SCOPE)
6039 kid = kLISTOP->op_last; /* get past scope */
6040 switch(kid->op_type) {
6048 k = kid; /* remember this node*/
6049 if (kBINOP->op_first->op_type != OP_RV2SV)
6051 kid = kBINOP->op_first; /* get past cmp */
6052 if (kUNOP->op_first->op_type != OP_GV)
6054 kid = kUNOP->op_first; /* get past rv2sv */
6056 if (GvSTASH(gv) != PL_curstash)
6058 if (strEQ(GvNAME(gv), "a"))
6060 else if (strEQ(GvNAME(gv), "b"))
6065 kid = k; /* back to cmp */
6066 if (kBINOP->op_last->op_type != OP_RV2SV)
6068 kid = kBINOP->op_last; /* down to 2nd arg */
6069 if (kUNOP->op_first->op_type != OP_GV)
6071 kid = kUNOP->op_first; /* get past rv2sv */
6073 if (GvSTASH(gv) != PL_curstash
6075 ? strNE(GvNAME(gv), "a")
6076 : strNE(GvNAME(gv), "b")))
6078 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6080 o->op_private |= OPpSORT_DESCEND;
6081 if (k->op_type == OP_NCMP)
6082 o->op_private |= OPpSORT_NUMERIC;
6083 if (k->op_type == OP_I_NCMP)
6084 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6085 kid = cLISTOPo->op_first->op_sibling;
6086 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6087 op_free(kid); /* then delete it */
6091 Perl_ck_split(pTHX_ OP *o)
6095 if (o->op_flags & OPf_STACKED)
6096 return no_fh_allowed(o);
6098 kid = cLISTOPo->op_first;
6099 if (kid->op_type != OP_NULL)
6100 Perl_croak(aTHX_ "panic: ck_split");
6101 kid = kid->op_sibling;
6102 op_free(cLISTOPo->op_first);
6103 cLISTOPo->op_first = kid;
6105 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6106 cLISTOPo->op_last = kid; /* There was only one element previously */
6109 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6110 OP *sibl = kid->op_sibling;
6111 kid->op_sibling = 0;
6112 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
6113 if (cLISTOPo->op_first == cLISTOPo->op_last)
6114 cLISTOPo->op_last = kid;
6115 cLISTOPo->op_first = kid;
6116 kid->op_sibling = sibl;
6119 kid->op_type = OP_PUSHRE;
6120 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6122 if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
6123 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
6124 "Use of /g modifier is meaningless in split");
6127 if (!kid->op_sibling)
6128 append_elem(OP_SPLIT, o, newDEFSVOP());
6130 kid = kid->op_sibling;
6133 if (!kid->op_sibling)
6134 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6136 kid = kid->op_sibling;
6139 if (kid->op_sibling)
6140 return too_many_arguments(o,OP_DESC(o));
6146 Perl_ck_join(pTHX_ OP *o)
6148 if (ckWARN(WARN_SYNTAX)) {
6149 OP *kid = cLISTOPo->op_first->op_sibling;
6150 if (kid && kid->op_type == OP_MATCH) {
6151 char *pmstr = "STRING";
6152 if (PM_GETRE(kPMOP))
6153 pmstr = PM_GETRE(kPMOP)->precomp;
6154 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6155 "/%s/ should probably be written as \"%s\"",
6163 Perl_ck_subr(pTHX_ OP *o)
6165 OP *prev = ((cUNOPo->op_first->op_sibling)
6166 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6167 OP *o2 = prev->op_sibling;
6174 I32 contextclass = 0;
6179 o->op_private |= OPpENTERSUB_HASTARG;
6180 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6181 if (cvop->op_type == OP_RV2CV) {
6183 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6184 op_null(cvop); /* disable rv2cv */
6185 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6186 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6187 GV *gv = cGVOPx_gv(tmpop);
6190 tmpop->op_private |= OPpEARLY_CV;
6193 namegv = CvANON(cv) ? gv : CvGV(cv);
6194 proto = SvPV((SV*)cv, n_a);
6196 if (CvASSERTION(cv)) {
6197 if (PL_hints & HINT_ASSERTING) {
6198 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
6199 o->op_private |= OPpENTERSUB_DB;
6203 if (ckWARN(WARN_ASSERTIONS) && !(PL_hints & HINT_ASSERTIONSSEEN)) {
6204 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
6205 "Impossible to activate assertion call");
6212 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6213 if (o2->op_type == OP_CONST)
6214 o2->op_private &= ~OPpCONST_STRICT;
6215 else if (o2->op_type == OP_LIST) {
6216 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6217 if (o && o->op_type == OP_CONST)
6218 o->op_private &= ~OPpCONST_STRICT;
6221 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6222 if (PERLDB_SUB && PL_curstash != PL_debstash)
6223 o->op_private |= OPpENTERSUB_DB;
6224 while (o2 != cvop) {
6228 return too_many_arguments(o, gv_ename(namegv));
6246 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6248 arg == 1 ? "block or sub {}" : "sub {}",
6249 gv_ename(namegv), o2);
6252 /* '*' allows any scalar type, including bareword */
6255 if (o2->op_type == OP_RV2GV)
6256 goto wrapref; /* autoconvert GLOB -> GLOBref */
6257 else if (o2->op_type == OP_CONST)
6258 o2->op_private &= ~OPpCONST_STRICT;
6259 else if (o2->op_type == OP_ENTERSUB) {
6260 /* accidental subroutine, revert to bareword */
6261 OP *gvop = ((UNOP*)o2)->op_first;
6262 if (gvop && gvop->op_type == OP_NULL) {
6263 gvop = ((UNOP*)gvop)->op_first;
6265 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6268 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6269 (gvop = ((UNOP*)gvop)->op_first) &&
6270 gvop->op_type == OP_GV)
6272 GV *gv = cGVOPx_gv(gvop);
6273 OP *sibling = o2->op_sibling;
6274 SV *n = newSVpvn("",0);
6276 gv_fullname4(n, gv, "", FALSE);
6277 o2 = newSVOP(OP_CONST, 0, n);
6278 prev->op_sibling = o2;
6279 o2->op_sibling = sibling;
6295 if (contextclass++ == 0) {
6296 e = strchr(proto, ']');
6297 if (!e || e == proto)
6310 while (*--p != '[');
6311 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6312 gv_ename(namegv), o2);
6318 if (o2->op_type == OP_RV2GV)
6321 bad_type(arg, "symbol", gv_ename(namegv), o2);
6324 if (o2->op_type == OP_ENTERSUB)
6327 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6330 if (o2->op_type == OP_RV2SV ||
6331 o2->op_type == OP_PADSV ||
6332 o2->op_type == OP_HELEM ||
6333 o2->op_type == OP_AELEM ||
6334 o2->op_type == OP_THREADSV)
6337 bad_type(arg, "scalar", gv_ename(namegv), o2);
6340 if (o2->op_type == OP_RV2AV ||
6341 o2->op_type == OP_PADAV)
6344 bad_type(arg, "array", gv_ename(namegv), o2);
6347 if (o2->op_type == OP_RV2HV ||
6348 o2->op_type == OP_PADHV)
6351 bad_type(arg, "hash", gv_ename(namegv), o2);
6356 OP* sib = kid->op_sibling;
6357 kid->op_sibling = 0;
6358 o2 = newUNOP(OP_REFGEN, 0, kid);
6359 o2->op_sibling = sib;
6360 prev->op_sibling = o2;
6362 if (contextclass && e) {
6377 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6378 gv_ename(namegv), cv);
6383 mod(o2, OP_ENTERSUB);
6385 o2 = o2->op_sibling;
6387 if (proto && !optional &&
6388 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6389 return too_few_arguments(o, gv_ename(namegv));
6392 o=newSVOP(OP_CONST, 0, newSViv(0));
6398 Perl_ck_svconst(pTHX_ OP *o)
6400 SvREADONLY_on(cSVOPo->op_sv);
6405 Perl_ck_trunc(pTHX_ OP *o)
6407 if (o->op_flags & OPf_KIDS) {
6408 SVOP *kid = (SVOP*)cUNOPo->op_first;
6410 if (kid->op_type == OP_NULL)
6411 kid = (SVOP*)kid->op_sibling;
6412 if (kid && kid->op_type == OP_CONST &&
6413 (kid->op_private & OPpCONST_BARE))
6415 o->op_flags |= OPf_SPECIAL;
6416 kid->op_private &= ~OPpCONST_STRICT;
6423 Perl_ck_unpack(pTHX_ OP *o)
6425 OP *kid = cLISTOPo->op_first;
6426 if (kid->op_sibling) {
6427 kid = kid->op_sibling;
6428 if (!kid->op_sibling)
6429 kid->op_sibling = newDEFSVOP();
6435 Perl_ck_substr(pTHX_ OP *o)
6438 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6439 OP *kid = cLISTOPo->op_first;
6441 if (kid->op_type == OP_NULL)
6442 kid = kid->op_sibling;
6444 kid->op_flags |= OPf_MOD;
6450 /* A peephole optimizer. We visit the ops in the order they're to execute.
6451 * See the comments at the top of this file for more details about when
6452 * peep() is called */
6455 Perl_peep(pTHX_ register OP *o)
6457 register OP* oldop = 0;
6459 if (!o || o->op_opt)
6463 SAVEVPTR(PL_curcop);
6464 for (; o; o = o->op_next) {
6468 switch (o->op_type) {
6472 PL_curcop = ((COP*)o); /* for warnings */
6477 if (cSVOPo->op_private & OPpCONST_STRICT)
6478 no_bareword_allowed(o);
6480 case OP_METHOD_NAMED:
6481 /* Relocate sv to the pad for thread safety.
6482 * Despite being a "constant", the SV is written to,
6483 * for reference counts, sv_upgrade() etc. */
6485 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6486 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6487 /* If op_sv is already a PADTMP then it is being used by
6488 * some pad, so make a copy. */
6489 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6490 SvREADONLY_on(PAD_SVl(ix));
6491 SvREFCNT_dec(cSVOPo->op_sv);
6494 SvREFCNT_dec(PAD_SVl(ix));
6495 SvPADTMP_on(cSVOPo->op_sv);
6496 PAD_SETSV(ix, cSVOPo->op_sv);
6497 /* XXX I don't know how this isn't readonly already. */
6498 SvREADONLY_on(PAD_SVl(ix));
6500 cSVOPo->op_sv = Nullsv;
6508 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6509 if (o->op_next->op_private & OPpTARGET_MY) {
6510 if (o->op_flags & OPf_STACKED) /* chained concats */
6511 goto ignore_optimization;
6513 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6514 o->op_targ = o->op_next->op_targ;
6515 o->op_next->op_targ = 0;
6516 o->op_private |= OPpTARGET_MY;
6519 op_null(o->op_next);
6521 ignore_optimization:
6525 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6527 break; /* Scalar stub must produce undef. List stub is noop */
6531 if (o->op_targ == OP_NEXTSTATE
6532 || o->op_targ == OP_DBSTATE
6533 || o->op_targ == OP_SETSTATE)
6535 PL_curcop = ((COP*)o);
6537 /* XXX: We avoid setting op_seq here to prevent later calls
6538 to peep() from mistakenly concluding that optimisation
6539 has already occurred. This doesn't fix the real problem,
6540 though (See 20010220.007). AMS 20010719 */
6541 /* op_seq functionality is now replaced by op_opt */
6542 if (oldop && o->op_next) {
6543 oldop->op_next = o->op_next;
6551 if (oldop && o->op_next) {
6552 oldop->op_next = o->op_next;
6560 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
6561 OP* pop = (o->op_type == OP_PADAV) ?
6562 o->op_next : o->op_next->op_next;
6564 if (pop && pop->op_type == OP_CONST &&
6565 ((PL_op = pop->op_next)) &&
6566 pop->op_next->op_type == OP_AELEM &&
6567 !(pop->op_next->op_private &
6568 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6569 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6574 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
6575 no_bareword_allowed(pop);
6576 if (o->op_type == OP_GV)
6577 op_null(o->op_next);
6578 op_null(pop->op_next);
6580 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6581 o->op_next = pop->op_next->op_next;
6582 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6583 o->op_private = (U8)i;
6584 if (o->op_type == OP_GV) {
6589 o->op_flags |= OPf_SPECIAL;
6590 o->op_type = OP_AELEMFAST;
6596 if (o->op_next->op_type == OP_RV2SV) {
6597 if (!(o->op_next->op_private & OPpDEREF)) {
6598 op_null(o->op_next);
6599 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6601 o->op_next = o->op_next->op_next;
6602 o->op_type = OP_GVSV;
6603 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6606 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6608 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6609 /* XXX could check prototype here instead of just carping */
6610 SV *sv = sv_newmortal();
6611 gv_efullname3(sv, gv, Nullch);
6612 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6613 "%"SVf"() called too early to check prototype",
6617 else if (o->op_next->op_type == OP_READLINE
6618 && o->op_next->op_next->op_type == OP_CONCAT
6619 && (o->op_next->op_next->op_flags & OPf_STACKED))
6621 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6622 o->op_type = OP_RCATLINE;
6623 o->op_flags |= OPf_STACKED;
6624 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6625 op_null(o->op_next->op_next);
6626 op_null(o->op_next);
6643 while (cLOGOP->op_other->op_type == OP_NULL)
6644 cLOGOP->op_other = cLOGOP->op_other->op_next;
6645 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6651 while (cLOOP->op_redoop->op_type == OP_NULL)
6652 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6653 peep(cLOOP->op_redoop);
6654 while (cLOOP->op_nextop->op_type == OP_NULL)
6655 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6656 peep(cLOOP->op_nextop);
6657 while (cLOOP->op_lastop->op_type == OP_NULL)
6658 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6659 peep(cLOOP->op_lastop);
6666 while (cPMOP->op_pmreplstart &&
6667 cPMOP->op_pmreplstart->op_type == OP_NULL)
6668 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6669 peep(cPMOP->op_pmreplstart);
6674 if (ckWARN(WARN_SYNTAX) && o->op_next
6675 && o->op_next->op_type == OP_NEXTSTATE) {
6676 if (o->op_next->op_sibling &&
6677 o->op_next->op_sibling->op_type != OP_EXIT &&
6678 o->op_next->op_sibling->op_type != OP_WARN &&
6679 o->op_next->op_sibling->op_type != OP_DIE) {
6680 line_t oldline = CopLINE(PL_curcop);
6682 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6683 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6684 "Statement unlikely to be reached");
6685 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6686 "\t(Maybe you meant system() when you said exec()?)\n");
6687 CopLINE_set(PL_curcop, oldline);
6702 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6705 /* Make the CONST have a shared SV */
6706 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6707 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6708 key = SvPV(sv, keylen);
6709 lexname = newSVpvn_share(key,
6710 SvUTF8(sv) ? -(I32)keylen : keylen,
6716 if ((o->op_private & (OPpLVAL_INTRO)))
6719 rop = (UNOP*)((BINOP*)o)->op_first;
6720 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6722 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6723 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6725 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6726 if (!fields || !GvHV(*fields))
6728 key = SvPV(*svp, keylen);
6729 if (!hv_fetch(GvHV(*fields), key,
6730 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
6732 Perl_croak(aTHX_ "No such class field \"%s\" "
6733 "in variable %s of type %s",
6734 key, SvPV_nolen(lexname), HvNAME(SvSTASH(lexname)));
6747 SVOP *first_key_op, *key_op;
6749 if ((o->op_private & (OPpLVAL_INTRO))
6750 /* I bet there's always a pushmark... */
6751 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6752 /* hmmm, no optimization if list contains only one key. */
6754 rop = (UNOP*)((LISTOP*)o)->op_last;
6755 if (rop->op_type != OP_RV2HV)
6757 if (rop->op_first->op_type == OP_PADSV)
6758 /* @$hash{qw(keys here)} */
6759 rop = (UNOP*)rop->op_first;
6761 /* @{$hash}{qw(keys here)} */
6762 if (rop->op_first->op_type == OP_SCOPE
6763 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
6765 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
6771 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
6772 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6774 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6775 if (!fields || !GvHV(*fields))
6777 /* Again guessing that the pushmark can be jumped over.... */
6778 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
6779 ->op_first->op_sibling;
6780 for (key_op = first_key_op; key_op;
6781 key_op = (SVOP*)key_op->op_sibling) {
6782 if (key_op->op_type != OP_CONST)
6784 svp = cSVOPx_svp(key_op);
6785 key = SvPV(*svp, keylen);
6786 if (!hv_fetch(GvHV(*fields), key,
6787 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
6789 Perl_croak(aTHX_ "No such class field \"%s\" "
6790 "in variable %s of type %s",
6791 key, SvPV_nolen(lexname), HvNAME(SvSTASH(lexname)));
6798 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
6802 /* check that RHS of sort is a single plain array */
6803 oright = cUNOPo->op_first;
6804 if (!oright || oright->op_type != OP_PUSHMARK)
6807 /* reverse sort ... can be optimised. */
6808 if (!cUNOPo->op_sibling) {
6809 /* Nothing follows us on the list. */
6810 OP *reverse = o->op_next;
6812 if (reverse->op_type == OP_REVERSE &&
6813 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
6814 OP *pushmark = cUNOPx(reverse)->op_first;
6815 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
6816 && (cUNOPx(pushmark)->op_sibling == o)) {
6817 /* reverse -> pushmark -> sort */
6818 o->op_private |= OPpSORT_REVERSE;
6820 pushmark->op_next = oright->op_next;
6826 /* make @a = sort @a act in-place */
6830 oright = cUNOPx(oright)->op_sibling;
6833 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
6834 oright = cUNOPx(oright)->op_sibling;
6838 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
6839 || oright->op_next != o
6840 || (oright->op_private & OPpLVAL_INTRO)
6844 /* o2 follows the chain of op_nexts through the LHS of the
6845 * assign (if any) to the aassign op itself */
6847 if (!o2 || o2->op_type != OP_NULL)
6850 if (!o2 || o2->op_type != OP_PUSHMARK)
6853 if (o2 && o2->op_type == OP_GV)
6856 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
6857 || (o2->op_private & OPpLVAL_INTRO)
6862 if (!o2 || o2->op_type != OP_NULL)
6865 if (!o2 || o2->op_type != OP_AASSIGN
6866 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
6869 /* check that the sort is the first arg on RHS of assign */
6871 o2 = cUNOPx(o2)->op_first;
6872 if (!o2 || o2->op_type != OP_NULL)
6874 o2 = cUNOPx(o2)->op_first;
6875 if (!o2 || o2->op_type != OP_PUSHMARK)
6877 if (o2->op_sibling != o)
6880 /* check the array is the same on both sides */
6881 if (oleft->op_type == OP_RV2AV) {
6882 if (oright->op_type != OP_RV2AV
6883 || !cUNOPx(oright)->op_first
6884 || cUNOPx(oright)->op_first->op_type != OP_GV
6885 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
6886 cGVOPx_gv(cUNOPx(oright)->op_first)
6890 else if (oright->op_type != OP_PADAV
6891 || oright->op_targ != oleft->op_targ
6895 /* transfer MODishness etc from LHS arg to RHS arg */
6896 oright->op_flags = oleft->op_flags;
6897 o->op_private |= OPpSORT_INPLACE;
6899 /* excise push->gv->rv2av->null->aassign */
6900 o2 = o->op_next->op_next;
6901 op_null(o2); /* PUSHMARK */
6903 if (o2->op_type == OP_GV) {
6904 op_null(o2); /* GV */
6907 op_null(o2); /* RV2AV or PADAV */
6908 o2 = o2->op_next->op_next;
6909 op_null(o2); /* AASSIGN */
6911 o->op_next = o2->op_next;
6917 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
6919 LISTOP *enter, *exlist;
6922 enter = (LISTOP *) o->op_next;
6925 if (enter->op_type == OP_NULL) {
6926 enter = (LISTOP *) enter->op_next;
6930 /* for $a (...) will have OP_GV then OP_RV2GV here.
6931 for (...) just has an OP_GV. */
6932 if (enter->op_type == OP_GV) {
6933 gvop = (OP *) enter;
6934 enter = (LISTOP *) enter->op_next;
6937 if (enter->op_type == OP_RV2GV) {
6938 enter = (LISTOP *) enter->op_next;
6944 if (enter->op_type != OP_ENTERITER)
6947 iter = enter->op_next;
6948 if (!iter || iter->op_type != OP_ITER)
6951 expushmark = enter->op_first;
6952 if (!expushmark || expushmark->op_type != OP_NULL
6953 || expushmark->op_targ != OP_PUSHMARK)
6956 exlist = (LISTOP *) expushmark->op_sibling;
6957 if (!exlist || exlist->op_type != OP_NULL
6958 || exlist->op_targ != OP_LIST)
6961 if (exlist->op_last != o) {
6962 /* Mmm. Was expecting to point back to this op. */
6965 theirmark = exlist->op_first;
6966 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
6969 if (theirmark->op_sibling != o) {
6970 /* There's something between the mark and the reverse, eg
6971 for (1, reverse (...))
6976 ourmark = ((LISTOP *)o)->op_first;
6977 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
6980 ourlast = ((LISTOP *)o)->op_last;
6981 if (!ourlast || ourlast->op_next != o)
6984 rv2av = ourmark->op_sibling;
6985 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
6986 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
6987 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
6988 /* We're just reversing a single array. */
6989 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
6990 enter->op_flags |= OPf_STACKED;
6993 /* We don't have control over who points to theirmark, so sacrifice
6995 theirmark->op_next = ourmark->op_next;
6996 theirmark->op_flags = ourmark->op_flags;
6997 ourlast->op_next = gvop ? gvop : (OP *) enter;
7000 enter->op_private |= OPpITER_REVERSED;
7001 iter->op_private |= OPpITER_REVERSED;
7017 char* Perl_custom_op_name(pTHX_ OP* o)
7019 IV index = PTR2IV(o->op_ppaddr);
7023 if (!PL_custom_op_names) /* This probably shouldn't happen */
7024 return PL_op_name[OP_CUSTOM];
7026 keysv = sv_2mortal(newSViv(index));
7028 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7030 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7032 return SvPV_nolen(HeVAL(he));
7035 char* Perl_custom_op_desc(pTHX_ OP* o)
7037 IV index = PTR2IV(o->op_ppaddr);
7041 if (!PL_custom_op_descs)
7042 return PL_op_desc[OP_CUSTOM];
7044 keysv = sv_2mortal(newSViv(index));
7046 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7048 return PL_op_desc[OP_CUSTOM];
7050 return SvPV_nolen(HeVAL(he));
7056 /* Efficient sub that returns a constant scalar value. */
7058 const_sv_xsub(pTHX_ CV* cv)
7063 Perl_croak(aTHX_ "usage: %s::%s()",
7064 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7068 ST(0) = (SV*)XSANY.any_ptr;