3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
13 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
14 * youngest of the Old Took's daughters); and Mr. Drogo was his second
15 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
16 * either way, as the saying is, if you follow me." --the Gaffer
19 /* This file contains the functions that create, manipulate and optimize
20 * the OP structures that hold a compiled perl program.
22 * A Perl program is compiled into a tree of OPs. Each op contains
23 * structural pointers (eg to its siblings and the next op in the
24 * execution sequence), a pointer to the function that would execute the
25 * op, plus any data specific to that op. For example, an OP_CONST op
26 * points to the pp_const() function and to an SV containing the constant
27 * value. When pp_const() is executed, its job is to push that SV onto the
30 * OPs are mainly created by the newFOO() functions, which are mainly
31 * called from the parser (in perly.y) as the code is parsed. For example
32 * the Perl code $a + $b * $c would cause the equivalent of the following
33 * to be called (oversimplifying a bit):
35 * newBINOP(OP_ADD, flags,
37 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
40 * Note that during the build of miniperl, a temporary copy of this file
41 * is made, called opmini.c.
45 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
49 An execution-order pass
51 The bottom-up pass is represented by all the "newOP" routines and
52 the ck_ routines. The bottom-upness is actually driven by yacc.
53 So at the point that a ck_ routine fires, we have no idea what the
54 context is, either upward in the syntax tree, or either forward or
55 backward in the execution order. (The bottom-up parser builds that
56 part of the execution order it knows about, but if you follow the "next"
57 links around, you'll find it's actually a closed loop through the
60 Whenever the bottom-up parser gets to a node that supplies context to
61 its components, it invokes that portion of the top-down pass that applies
62 to that part of the subtree (and marks the top node as processed, so
63 if a node further up supplies context, it doesn't have to take the
64 plunge again). As a particular subcase of this, as the new node is
65 built, it takes all the closed execution loops of its subcomponents
66 and links them into a new closed loop for the higher level node. But
67 it's still not the real execution order.
69 The actual execution order is not known till we get a grammar reduction
70 to a top-level unit like a subroutine or file that will be called by
71 "name" rather than via a "next" pointer. At that point, we can call
72 into peep() to do that code's portion of the 3rd pass. It has to be
73 recursive, but it's recursive on basic blocks, not on tree nodes.
81 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
83 #if defined(PL_OP_SLAB_ALLOC)
85 #ifndef PERL_SLAB_SIZE
86 #define PERL_SLAB_SIZE 2048
90 Perl_Slab_Alloc(pTHX_ int m, size_t sz)
93 * To make incrementing use count easy PL_OpSlab is an I32 *
94 * To make inserting the link to slab PL_OpPtr is I32 **
95 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
96 * Add an overhead for pointer to slab and round up as a number of pointers
98 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
99 if ((PL_OpSpace -= sz) < 0) {
100 PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*));
104 Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **);
105 /* We reserve the 0'th I32 sized chunk as a use count */
106 PL_OpSlab = (I32 *) PL_OpPtr;
107 /* Reduce size by the use count word, and by the size we need.
108 * Latter is to mimic the '-=' in the if() above
110 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
111 /* Allocation pointer starts at the top.
112 Theory: because we build leaves before trunk allocating at end
113 means that at run time access is cache friendly upward
115 PL_OpPtr += PERL_SLAB_SIZE;
117 assert( PL_OpSpace >= 0 );
118 /* Move the allocation pointer down */
120 assert( PL_OpPtr > (I32 **) PL_OpSlab );
121 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
122 (*PL_OpSlab)++; /* Increment use count of slab */
123 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
124 assert( *PL_OpSlab > 0 );
125 return (void *)(PL_OpPtr + 1);
129 Perl_Slab_Free(pTHX_ void *op)
131 I32 **ptr = (I32 **) op;
133 assert( ptr-1 > (I32 **) slab );
134 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
136 if (--(*slab) == 0) {
138 # define PerlMemShared PerlMem
141 PerlMemShared_free(slab);
142 if (slab == PL_OpSlab) {
149 * In the following definition, the ", Nullop" is just to make the compiler
150 * think the expression is of the right type: croak actually does a Siglongjmp.
152 #define CHECKOP(type,o) \
153 ((PL_op_mask && PL_op_mask[type]) \
154 ? ( op_free((OP*)o), \
155 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
157 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
159 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
162 S_gv_ename(pTHX_ GV *gv)
165 SV* tmpsv = sv_newmortal();
166 gv_efullname3(tmpsv, gv, Nullch);
167 return SvPV(tmpsv,n_a);
171 S_no_fh_allowed(pTHX_ OP *o)
173 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
179 S_too_few_arguments(pTHX_ OP *o, const char *name)
181 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
186 S_too_many_arguments(pTHX_ OP *o, const char *name)
188 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
193 S_bad_type(pTHX_ I32 n, const char *t, const char *name, OP *kid)
195 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
196 (int)n, name, t, OP_DESC(kid)));
200 S_no_bareword_allowed(pTHX_ OP *o)
202 qerror(Perl_mess(aTHX_
203 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
207 /* "register" allocation */
210 Perl_allocmy(pTHX_ char *name)
214 /* complain about "my $<special_var>" etc etc */
215 if (!(PL_in_my == KEY_our ||
217 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
218 (name[1] == '_' && (*name == '$' || (int)strlen(name) > 2))))
220 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
221 /* 1999-02-27 mjd@plover.com */
223 p = strchr(name, '\0');
224 /* The next block assumes the buffer is at least 205 chars
225 long. At present, it's always at least 256 chars. */
227 strcpy(name+200, "...");
233 /* Move everything else down one character */
234 for (; p-name > 2; p--)
236 name[2] = toCTRL(name[1]);
239 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
242 /* check for duplicate declaration */
244 (bool)(PL_in_my == KEY_our),
245 (PL_curstash ? PL_curstash : PL_defstash)
248 if (PL_in_my_stash && *name != '$') {
249 yyerror(Perl_form(aTHX_
250 "Can't declare class for non-scalar %s in \"%s\"",
251 name, PL_in_my == KEY_our ? "our" : "my"));
254 /* allocate a spare slot and store the name in that slot */
256 off = pad_add_name(name,
259 /* $_ is always in main::, even with our */
260 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
271 Perl_op_free(pTHX_ OP *o)
273 register OP *kid, *nextkid;
277 if (!o || o->op_static)
280 if (o->op_private & OPpREFCOUNTED) {
281 switch (o->op_type) {
289 refcnt = OpREFCNT_dec(o);
299 if (o->op_flags & OPf_KIDS) {
300 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
301 nextkid = kid->op_sibling; /* Get before next freeing kid */
307 type = (OPCODE)o->op_targ;
309 /* COP* is not cleared by op_clear() so that we may track line
310 * numbers etc even after null() */
311 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
319 Perl_op_clear(pTHX_ OP *o)
322 switch (o->op_type) {
323 case OP_NULL: /* Was holding old type, if any. */
324 case OP_ENTEREVAL: /* Was holding hints. */
328 if (!(o->op_flags & OPf_REF)
329 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
335 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
336 /* not an OP_PADAV replacement */
338 if (cPADOPo->op_padix > 0) {
339 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
340 * may still exist on the pad */
341 pad_swipe(cPADOPo->op_padix, TRUE);
342 cPADOPo->op_padix = 0;
345 SvREFCNT_dec(cSVOPo->op_sv);
346 cSVOPo->op_sv = Nullsv;
350 case OP_METHOD_NAMED:
352 SvREFCNT_dec(cSVOPo->op_sv);
353 cSVOPo->op_sv = Nullsv;
356 Even if op_clear does a pad_free for the target of the op,
357 pad_free doesn't actually remove the sv that exists in the pad;
358 instead it lives on. This results in that it could be reused as
359 a target later on when the pad was reallocated.
362 pad_swipe(o->op_targ,1);
371 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
375 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
376 SvREFCNT_dec(cSVOPo->op_sv);
377 cSVOPo->op_sv = Nullsv;
380 Safefree(cPVOPo->op_pv);
381 cPVOPo->op_pv = Nullch;
385 op_free(cPMOPo->op_pmreplroot);
389 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
390 /* No GvIN_PAD_off here, because other references may still
391 * exist on the pad */
392 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
395 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
402 HV *pmstash = PmopSTASH(cPMOPo);
403 if (pmstash && SvREFCNT(pmstash)) {
404 PMOP *pmop = HvPMROOT(pmstash);
405 PMOP *lastpmop = NULL;
407 if (cPMOPo == pmop) {
409 lastpmop->op_pmnext = pmop->op_pmnext;
411 HvPMROOT(pmstash) = pmop->op_pmnext;
415 pmop = pmop->op_pmnext;
418 PmopSTASH_free(cPMOPo);
420 cPMOPo->op_pmreplroot = Nullop;
421 /* we use the "SAFE" version of the PM_ macros here
422 * since sv_clean_all might release some PMOPs
423 * after PL_regex_padav has been cleared
424 * and the clearing of PL_regex_padav needs to
425 * happen before sv_clean_all
427 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
428 PM_SETRE_SAFE(cPMOPo, (REGEXP*)NULL);
430 if(PL_regex_pad) { /* We could be in destruction */
431 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
432 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
433 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
440 if (o->op_targ > 0) {
441 pad_free(o->op_targ);
447 S_cop_free(pTHX_ COP* cop)
449 Safefree(cop->cop_label); /* FIXME: treaddead ??? */
452 if (! specialWARN(cop->cop_warnings))
453 SvREFCNT_dec(cop->cop_warnings);
454 if (! specialCopIO(cop->cop_io)) {
458 char *s = SvPV(cop->cop_io,len);
459 Perl_warn(aTHX_ "io='%.*s'",(int) len,s); /* ??? --jhi */
462 SvREFCNT_dec(cop->cop_io);
468 Perl_op_null(pTHX_ OP *o)
470 if (o->op_type == OP_NULL)
473 o->op_targ = o->op_type;
474 o->op_type = OP_NULL;
475 o->op_ppaddr = PL_ppaddr[OP_NULL];
479 Perl_op_refcnt_lock(pTHX)
485 Perl_op_refcnt_unlock(pTHX)
490 /* Contextualizers */
492 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
495 Perl_linklist(pTHX_ OP *o)
502 /* establish postfix order */
503 if (cUNOPo->op_first) {
504 o->op_next = LINKLIST(cUNOPo->op_first);
505 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
507 kid->op_next = LINKLIST(kid->op_sibling);
519 Perl_scalarkids(pTHX_ OP *o)
521 if (o && o->op_flags & OPf_KIDS) {
523 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
530 S_scalarboolean(pTHX_ OP *o)
532 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
533 if (ckWARN(WARN_SYNTAX)) {
534 line_t oldline = CopLINE(PL_curcop);
536 if (PL_copline != NOLINE)
537 CopLINE_set(PL_curcop, PL_copline);
538 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
539 CopLINE_set(PL_curcop, oldline);
546 Perl_scalar(pTHX_ OP *o)
550 /* assumes no premature commitment */
551 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
552 || o->op_type == OP_RETURN)
557 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
559 switch (o->op_type) {
561 scalar(cBINOPo->op_first);
566 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
570 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
571 if (!kPMOP->op_pmreplroot)
572 deprecate_old("implicit split to @_");
580 if (o->op_flags & OPf_KIDS) {
581 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
587 kid = cLISTOPo->op_first;
589 while ((kid = kid->op_sibling)) {
595 WITH_THR(PL_curcop = &PL_compiling);
600 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
606 WITH_THR(PL_curcop = &PL_compiling);
609 if (ckWARN(WARN_VOID))
610 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
616 Perl_scalarvoid(pTHX_ OP *o)
619 const char* useless = 0;
623 if (o->op_type == OP_NEXTSTATE
624 || o->op_type == OP_SETSTATE
625 || o->op_type == OP_DBSTATE
626 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
627 || o->op_targ == OP_SETSTATE
628 || o->op_targ == OP_DBSTATE)))
629 PL_curcop = (COP*)o; /* for warning below */
631 /* assumes no premature commitment */
632 want = o->op_flags & OPf_WANT;
633 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
634 || o->op_type == OP_RETURN)
639 if ((o->op_private & OPpTARGET_MY)
640 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
642 return scalar(o); /* As if inside SASSIGN */
645 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
647 switch (o->op_type) {
649 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
653 if (o->op_flags & OPf_STACKED)
657 if (o->op_private == 4)
729 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
730 useless = OP_DESC(o);
734 kid = cUNOPo->op_first;
735 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
736 kid->op_type != OP_TRANS) {
739 useless = "negative pattern binding (!~)";
746 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
747 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
748 useless = "a variable";
753 if (cSVOPo->op_private & OPpCONST_STRICT)
754 no_bareword_allowed(o);
756 if (ckWARN(WARN_VOID)) {
757 useless = "a constant";
758 /* don't warn on optimised away booleans, eg
759 * use constant Foo, 5; Foo || print; */
760 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
762 /* the constants 0 and 1 are permitted as they are
763 conventionally used as dummies in constructs like
764 1 while some_condition_with_side_effects; */
765 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
767 else if (SvPOK(sv)) {
768 /* perl4's way of mixing documentation and code
769 (before the invention of POD) was based on a
770 trick to mix nroff and perl code. The trick was
771 built upon these three nroff macros being used in
772 void context. The pink camel has the details in
773 the script wrapman near page 319. */
774 if (strnEQ(SvPVX(sv), "di", 2) ||
775 strnEQ(SvPVX(sv), "ds", 2) ||
776 strnEQ(SvPVX(sv), "ig", 2))
781 op_null(o); /* don't execute or even remember it */
785 o->op_type = OP_PREINC; /* pre-increment is faster */
786 o->op_ppaddr = PL_ppaddr[OP_PREINC];
790 o->op_type = OP_PREDEC; /* pre-decrement is faster */
791 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
798 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
803 if (o->op_flags & OPf_STACKED)
810 if (!(o->op_flags & OPf_KIDS))
819 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
826 /* all requires must return a boolean value */
827 o->op_flags &= ~OPf_WANT;
832 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
833 if (!kPMOP->op_pmreplroot)
834 deprecate_old("implicit split to @_");
838 if (useless && ckWARN(WARN_VOID))
839 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
844 Perl_listkids(pTHX_ OP *o)
847 if (o && o->op_flags & OPf_KIDS) {
848 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
855 Perl_list(pTHX_ OP *o)
859 /* assumes no premature commitment */
860 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
861 || o->op_type == OP_RETURN)
866 if ((o->op_private & OPpTARGET_MY)
867 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
869 return o; /* As if inside SASSIGN */
872 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
874 switch (o->op_type) {
877 list(cBINOPo->op_first);
882 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
890 if (!(o->op_flags & OPf_KIDS))
892 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
893 list(cBINOPo->op_first);
894 return gen_constant_list(o);
901 kid = cLISTOPo->op_first;
903 while ((kid = kid->op_sibling)) {
909 WITH_THR(PL_curcop = &PL_compiling);
913 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
919 WITH_THR(PL_curcop = &PL_compiling);
922 /* all requires must return a boolean value */
923 o->op_flags &= ~OPf_WANT;
930 Perl_scalarseq(pTHX_ OP *o)
935 if (o->op_type == OP_LINESEQ ||
936 o->op_type == OP_SCOPE ||
937 o->op_type == OP_LEAVE ||
938 o->op_type == OP_LEAVETRY)
940 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
941 if (kid->op_sibling) {
945 PL_curcop = &PL_compiling;
947 o->op_flags &= ~OPf_PARENS;
948 if (PL_hints & HINT_BLOCK_SCOPE)
949 o->op_flags |= OPf_PARENS;
952 o = newOP(OP_STUB, 0);
957 S_modkids(pTHX_ OP *o, I32 type)
960 if (o && o->op_flags & OPf_KIDS) {
961 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
967 /* Propagate lvalue ("modifiable") context to an op and it's children.
968 * 'type' represents the context type, roughly based on the type of op that
969 * would do the modifying, although local() is represented by OP_NULL.
970 * It's responsible for detecting things that can't be modified, flag
971 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
972 * might have to vivify a reference in $x), and so on.
974 * For example, "$a+1 = 2" would cause mod() to be called with o being
975 * OP_ADD and type being OP_SASSIGN, and would output an error.
979 Perl_mod(pTHX_ OP *o, I32 type)
982 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
985 if (!o || PL_error_count)
988 if ((o->op_private & OPpTARGET_MY)
989 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
994 switch (o->op_type) {
1000 if (!(o->op_private & (OPpCONST_ARYBASE)))
1002 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1003 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1007 SAVEI32(PL_compiling.cop_arybase);
1008 PL_compiling.cop_arybase = 0;
1010 else if (type == OP_REFGEN)
1013 Perl_croak(aTHX_ "That use of $[ is unsupported");
1016 if (o->op_flags & OPf_PARENS)
1020 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1021 !(o->op_flags & OPf_STACKED)) {
1022 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1023 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1024 assert(cUNOPo->op_first->op_type == OP_NULL);
1025 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1028 else if (o->op_private & OPpENTERSUB_NOMOD)
1030 else { /* lvalue subroutine call */
1031 o->op_private |= OPpLVAL_INTRO;
1032 PL_modcount = RETURN_UNLIMITED_NUMBER;
1033 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1034 /* Backward compatibility mode: */
1035 o->op_private |= OPpENTERSUB_INARGS;
1038 else { /* Compile-time error message: */
1039 OP *kid = cUNOPo->op_first;
1043 if (kid->op_type == OP_PUSHMARK)
1045 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1047 "panic: unexpected lvalue entersub "
1048 "args: type/targ %ld:%"UVuf,
1049 (long)kid->op_type, (UV)kid->op_targ);
1050 kid = kLISTOP->op_first;
1052 while (kid->op_sibling)
1053 kid = kid->op_sibling;
1054 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1056 if (kid->op_type == OP_METHOD_NAMED
1057 || kid->op_type == OP_METHOD)
1061 NewOp(1101, newop, 1, UNOP);
1062 newop->op_type = OP_RV2CV;
1063 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1064 newop->op_first = Nullop;
1065 newop->op_next = (OP*)newop;
1066 kid->op_sibling = (OP*)newop;
1067 newop->op_private |= OPpLVAL_INTRO;
1071 if (kid->op_type != OP_RV2CV)
1073 "panic: unexpected lvalue entersub "
1074 "entry via type/targ %ld:%"UVuf,
1075 (long)kid->op_type, (UV)kid->op_targ);
1076 kid->op_private |= OPpLVAL_INTRO;
1077 break; /* Postpone until runtime */
1081 kid = kUNOP->op_first;
1082 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1083 kid = kUNOP->op_first;
1084 if (kid->op_type == OP_NULL)
1086 "Unexpected constant lvalue entersub "
1087 "entry via type/targ %ld:%"UVuf,
1088 (long)kid->op_type, (UV)kid->op_targ);
1089 if (kid->op_type != OP_GV) {
1090 /* Restore RV2CV to check lvalueness */
1092 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1093 okid->op_next = kid->op_next;
1094 kid->op_next = okid;
1097 okid->op_next = Nullop;
1098 okid->op_type = OP_RV2CV;
1100 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1101 okid->op_private |= OPpLVAL_INTRO;
1105 cv = GvCV(kGVOP_gv);
1115 /* grep, foreach, subcalls, refgen */
1116 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1118 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1119 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1121 : (o->op_type == OP_ENTERSUB
1122 ? "non-lvalue subroutine call"
1124 type ? PL_op_desc[type] : "local"));
1138 case OP_RIGHT_SHIFT:
1147 if (!(o->op_flags & OPf_STACKED))
1154 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1160 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1161 PL_modcount = RETURN_UNLIMITED_NUMBER;
1162 return o; /* Treat \(@foo) like ordinary list. */
1166 if (scalar_mod_type(o, type))
1168 ref(cUNOPo->op_first, o->op_type);
1172 if (type == OP_LEAVESUBLV)
1173 o->op_private |= OPpMAYBE_LVSUB;
1179 PL_modcount = RETURN_UNLIMITED_NUMBER;
1182 ref(cUNOPo->op_first, o->op_type);
1187 PL_hints |= HINT_BLOCK_SCOPE;
1202 PL_modcount = RETURN_UNLIMITED_NUMBER;
1203 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1204 return o; /* Treat \(@foo) like ordinary list. */
1205 if (scalar_mod_type(o, type))
1207 if (type == OP_LEAVESUBLV)
1208 o->op_private |= OPpMAYBE_LVSUB;
1212 if (!type) /* local() */
1213 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1214 PAD_COMPNAME_PV(o->op_targ));
1222 if (type != OP_SASSIGN)
1226 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1231 if (type == OP_LEAVESUBLV)
1232 o->op_private |= OPpMAYBE_LVSUB;
1234 pad_free(o->op_targ);
1235 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1236 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1237 if (o->op_flags & OPf_KIDS)
1238 mod(cBINOPo->op_first->op_sibling, type);
1243 ref(cBINOPo->op_first, o->op_type);
1244 if (type == OP_ENTERSUB &&
1245 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1246 o->op_private |= OPpLVAL_DEFER;
1247 if (type == OP_LEAVESUBLV)
1248 o->op_private |= OPpMAYBE_LVSUB;
1258 if (o->op_flags & OPf_KIDS)
1259 mod(cLISTOPo->op_last, type);
1264 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1266 else if (!(o->op_flags & OPf_KIDS))
1268 if (o->op_targ != OP_LIST) {
1269 mod(cBINOPo->op_first, type);
1275 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1280 if (type != OP_LEAVESUBLV)
1282 break; /* mod()ing was handled by ck_return() */
1285 /* [20011101.069] File test operators interpret OPf_REF to mean that
1286 their argument is a filehandle; thus \stat(".") should not set
1288 if (type == OP_REFGEN &&
1289 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1292 if (type != OP_LEAVESUBLV)
1293 o->op_flags |= OPf_MOD;
1295 if (type == OP_AASSIGN || type == OP_SASSIGN)
1296 o->op_flags |= OPf_SPECIAL|OPf_REF;
1297 else if (!type) { /* local() */
1300 o->op_private |= OPpLVAL_INTRO;
1301 o->op_flags &= ~OPf_SPECIAL;
1302 PL_hints |= HINT_BLOCK_SCOPE;
1307 if (ckWARN(WARN_SYNTAX)) {
1308 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1309 "Useless localization of %s", OP_DESC(o));
1313 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1314 && type != OP_LEAVESUBLV)
1315 o->op_flags |= OPf_REF;
1320 S_scalar_mod_type(pTHX_ OP *o, I32 type)
1324 if (o->op_type == OP_RV2GV)
1348 case OP_RIGHT_SHIFT:
1367 S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
1369 switch (o->op_type) {
1377 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1390 Perl_refkids(pTHX_ OP *o, I32 type)
1393 if (o && o->op_flags & OPf_KIDS) {
1394 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1401 Perl_ref(pTHX_ OP *o, I32 type)
1405 if (!o || PL_error_count)
1408 switch (o->op_type) {
1410 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1411 !(o->op_flags & OPf_STACKED)) {
1412 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1413 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1414 assert(cUNOPo->op_first->op_type == OP_NULL);
1415 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1416 o->op_flags |= OPf_SPECIAL;
1421 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1425 if (type == OP_DEFINED)
1426 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1427 ref(cUNOPo->op_first, o->op_type);
1430 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1431 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1432 : type == OP_RV2HV ? OPpDEREF_HV
1434 o->op_flags |= OPf_MOD;
1439 o->op_flags |= OPf_MOD; /* XXX ??? */
1444 o->op_flags |= OPf_REF;
1447 if (type == OP_DEFINED)
1448 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1449 ref(cUNOPo->op_first, o->op_type);
1454 o->op_flags |= OPf_REF;
1459 if (!(o->op_flags & OPf_KIDS))
1461 ref(cBINOPo->op_first, type);
1465 ref(cBINOPo->op_first, o->op_type);
1466 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1467 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1468 : type == OP_RV2HV ? OPpDEREF_HV
1470 o->op_flags |= OPf_MOD;
1478 if (!(o->op_flags & OPf_KIDS))
1480 ref(cLISTOPo->op_last, type);
1490 S_dup_attrlist(pTHX_ OP *o)
1494 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1495 * where the first kid is OP_PUSHMARK and the remaining ones
1496 * are OP_CONST. We need to push the OP_CONST values.
1498 if (o->op_type == OP_CONST)
1499 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1501 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1502 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1503 if (o->op_type == OP_CONST)
1504 rop = append_elem(OP_LIST, rop,
1505 newSVOP(OP_CONST, o->op_flags,
1506 SvREFCNT_inc(cSVOPo->op_sv)));
1513 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1517 /* fake up C<use attributes $pkg,$rv,@attrs> */
1518 ENTER; /* need to protect against side-effects of 'use' */
1521 stashsv = newSVpv(HvNAME(stash), 0);
1523 stashsv = &PL_sv_no;
1525 #define ATTRSMODULE "attributes"
1526 #define ATTRSMODULE_PM "attributes.pm"
1530 /* Don't force the C<use> if we don't need it. */
1531 svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
1532 sizeof(ATTRSMODULE_PM)-1, 0);
1533 if (svp && *svp != &PL_sv_undef)
1534 ; /* already in %INC */
1536 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1537 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1541 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1542 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1544 prepend_elem(OP_LIST,
1545 newSVOP(OP_CONST, 0, stashsv),
1546 prepend_elem(OP_LIST,
1547 newSVOP(OP_CONST, 0,
1549 dup_attrlist(attrs))));
1555 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1557 OP *pack, *imop, *arg;
1563 assert(target->op_type == OP_PADSV ||
1564 target->op_type == OP_PADHV ||
1565 target->op_type == OP_PADAV);
1567 /* Ensure that attributes.pm is loaded. */
1568 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1570 /* Need package name for method call. */
1571 pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
1573 /* Build up the real arg-list. */
1575 stashsv = newSVpv(HvNAME(stash), 0);
1577 stashsv = &PL_sv_no;
1578 arg = newOP(OP_PADSV, 0);
1579 arg->op_targ = target->op_targ;
1580 arg = prepend_elem(OP_LIST,
1581 newSVOP(OP_CONST, 0, stashsv),
1582 prepend_elem(OP_LIST,
1583 newUNOP(OP_REFGEN, 0,
1584 mod(arg, OP_REFGEN)),
1585 dup_attrlist(attrs)));
1587 /* Fake up a method call to import */
1588 meth = newSVpvn("import", 6);
1589 (void)SvUPGRADE(meth, SVt_PVIV);
1590 (void)SvIOK_on(meth);
1591 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
1592 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1593 append_elem(OP_LIST,
1594 prepend_elem(OP_LIST, pack, list(arg)),
1595 newSVOP(OP_METHOD_NAMED, 0, meth)));
1596 imop->op_private |= OPpENTERSUB_NOMOD;
1598 /* Combine the ops. */
1599 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1603 =notfor apidoc apply_attrs_string
1605 Attempts to apply a list of attributes specified by the C<attrstr> and
1606 C<len> arguments to the subroutine identified by the C<cv> argument which
1607 is expected to be associated with the package identified by the C<stashpv>
1608 argument (see L<attributes>). It gets this wrong, though, in that it
1609 does not correctly identify the boundaries of the individual attribute
1610 specifications within C<attrstr>. This is not really intended for the
1611 public API, but has to be listed here for systems such as AIX which
1612 need an explicit export list for symbols. (It's called from XS code
1613 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1614 to respect attribute syntax properly would be welcome.
1620 Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
1621 char *attrstr, STRLEN len)
1626 len = strlen(attrstr);
1630 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1632 char *sstr = attrstr;
1633 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1634 attrs = append_elem(OP_LIST, attrs,
1635 newSVOP(OP_CONST, 0,
1636 newSVpvn(sstr, attrstr-sstr)));
1640 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1641 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1642 Nullsv, prepend_elem(OP_LIST,
1643 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1644 prepend_elem(OP_LIST,
1645 newSVOP(OP_CONST, 0,
1651 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1656 if (!o || PL_error_count)
1660 if (type == OP_LIST) {
1661 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1662 my_kid(kid, attrs, imopsp);
1663 } else if (type == OP_UNDEF) {
1665 } else if (type == OP_RV2SV || /* "our" declaration */
1667 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1668 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1669 yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
1670 OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
1672 GV *gv = cGVOPx_gv(cUNOPo->op_first);
1674 PL_in_my_stash = Nullhv;
1675 apply_attrs(GvSTASH(gv),
1676 (type == OP_RV2SV ? GvSV(gv) :
1677 type == OP_RV2AV ? (SV*)GvAV(gv) :
1678 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1681 o->op_private |= OPpOUR_INTRO;
1684 else if (type != OP_PADSV &&
1687 type != OP_PUSHMARK)
1689 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1691 PL_in_my == KEY_our ? "our" : "my"));
1694 else if (attrs && type != OP_PUSHMARK) {
1698 PL_in_my_stash = Nullhv;
1700 /* check for C<my Dog $spot> when deciding package */
1701 stash = PAD_COMPNAME_TYPE(o->op_targ);
1703 stash = PL_curstash;
1704 apply_attrs_my(stash, o, attrs, imopsp);
1706 o->op_flags |= OPf_MOD;
1707 o->op_private |= OPpLVAL_INTRO;
1712 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1715 int maybe_scalar = 0;
1717 /* [perl #17376]: this appears to be premature, and results in code such as
1718 C< our(%x); > executing in list mode rather than void mode */
1720 if (o->op_flags & OPf_PARENS)
1729 o = my_kid(o, attrs, &rops);
1731 if (maybe_scalar && o->op_type == OP_PADSV) {
1732 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1733 o->op_private |= OPpLVAL_INTRO;
1736 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1739 PL_in_my_stash = Nullhv;
1744 Perl_my(pTHX_ OP *o)
1746 return my_attrs(o, Nullop);
1750 Perl_sawparens(pTHX_ OP *o)
1753 o->op_flags |= OPf_PARENS;
1758 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1763 if (ckWARN(WARN_MISC) &&
1764 (left->op_type == OP_RV2AV ||
1765 left->op_type == OP_RV2HV ||
1766 left->op_type == OP_PADAV ||
1767 left->op_type == OP_PADHV)) {
1768 const char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
1769 right->op_type == OP_TRANS)
1770 ? right->op_type : OP_MATCH];
1771 const char *sample = ((left->op_type == OP_RV2AV ||
1772 left->op_type == OP_PADAV)
1773 ? "@array" : "%hash");
1774 Perl_warner(aTHX_ packWARN(WARN_MISC),
1775 "Applying %s to %s will act on scalar(%s)",
1776 desc, sample, sample);
1779 if (right->op_type == OP_CONST &&
1780 cSVOPx(right)->op_private & OPpCONST_BARE &&
1781 cSVOPx(right)->op_private & OPpCONST_STRICT)
1783 no_bareword_allowed(right);
1786 ismatchop = right->op_type == OP_MATCH ||
1787 right->op_type == OP_SUBST ||
1788 right->op_type == OP_TRANS;
1789 if (ismatchop && right->op_private & OPpTARGET_MY) {
1791 right->op_private &= ~OPpTARGET_MY;
1793 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1794 right->op_flags |= OPf_STACKED;
1795 if (right->op_type != OP_MATCH &&
1796 ! (right->op_type == OP_TRANS &&
1797 right->op_private & OPpTRANS_IDENTICAL))
1798 left = mod(left, right->op_type);
1799 if (right->op_type == OP_TRANS)
1800 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
1802 o = prepend_elem(right->op_type, scalar(left), right);
1804 return newUNOP(OP_NOT, 0, scalar(o));
1808 return bind_match(type, left,
1809 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
1813 Perl_invert(pTHX_ OP *o)
1817 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
1818 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1822 Perl_scope(pTHX_ OP *o)
1825 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1826 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1827 o->op_type = OP_LEAVE;
1828 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1830 else if (o->op_type == OP_LINESEQ) {
1832 o->op_type = OP_SCOPE;
1833 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1834 kid = ((LISTOP*)o)->op_first;
1835 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
1839 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
1844 /* XXX kept for BINCOMPAT only */
1846 Perl_save_hints(pTHX)
1848 Perl_croak(aTHX_ "internal error: obsolete function save_hints() called");
1852 Perl_block_start(pTHX_ int full)
1854 const int retval = PL_savestack_ix;
1855 pad_block_start(full);
1857 PL_hints &= ~HINT_BLOCK_SCOPE;
1858 SAVESPTR(PL_compiling.cop_warnings);
1859 if (! specialWARN(PL_compiling.cop_warnings)) {
1860 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1861 SAVEFREESV(PL_compiling.cop_warnings) ;
1863 SAVESPTR(PL_compiling.cop_io);
1864 if (! specialCopIO(PL_compiling.cop_io)) {
1865 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1866 SAVEFREESV(PL_compiling.cop_io) ;
1872 Perl_block_end(pTHX_ I32 floor, OP *seq)
1874 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1875 OP* retval = scalarseq(seq);
1877 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
1879 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
1887 I32 offset = pad_findmy("$_");
1888 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
1889 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1892 OP *o = newOP(OP_PADSV, 0);
1893 o->op_targ = offset;
1899 Perl_newPROG(pTHX_ OP *o)
1904 PL_eval_root = newUNOP(OP_LEAVEEVAL,
1905 ((PL_in_eval & EVAL_KEEPERR)
1906 ? OPf_SPECIAL : 0), o);
1907 PL_eval_start = linklist(PL_eval_root);
1908 PL_eval_root->op_private |= OPpREFCOUNTED;
1909 OpREFCNT_set(PL_eval_root, 1);
1910 PL_eval_root->op_next = 0;
1911 CALL_PEEP(PL_eval_start);
1914 if (o->op_type == OP_STUB) {
1915 PL_comppad_name = 0;
1920 PL_main_root = scope(sawparens(scalarvoid(o)));
1921 PL_curcop = &PL_compiling;
1922 PL_main_start = LINKLIST(PL_main_root);
1923 PL_main_root->op_private |= OPpREFCOUNTED;
1924 OpREFCNT_set(PL_main_root, 1);
1925 PL_main_root->op_next = 0;
1926 CALL_PEEP(PL_main_start);
1929 /* Register with debugger */
1931 CV *cv = get_cv("DB::postponed", FALSE);
1935 XPUSHs((SV*)CopFILEGV(&PL_compiling));
1937 call_sv((SV*)cv, G_DISCARD);
1944 Perl_localize(pTHX_ OP *o, I32 lex)
1946 if (o->op_flags & OPf_PARENS)
1947 /* [perl #17376]: this appears to be premature, and results in code such as
1948 C< our(%x); > executing in list mode rather than void mode */
1955 if (ckWARN(WARN_PARENTHESIS)
1956 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
1958 char *s = PL_bufptr;
1961 /* some heuristics to detect a potential error */
1962 while (*s && (strchr(", \t\n", *s)))
1966 if (*s && strchr("@$%*", *s) && *++s
1967 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
1970 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
1972 while (*s && (strchr(", \t\n", *s)))
1978 if (sigil && (*s == ';' || *s == '=')) {
1979 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
1980 "Parentheses missing around \"%s\" list",
1981 lex ? (PL_in_my == KEY_our ? "our" : "my")
1989 o = mod(o, OP_NULL); /* a bit kludgey */
1991 PL_in_my_stash = Nullhv;
1996 Perl_jmaybe(pTHX_ OP *o)
1998 if (o->op_type == OP_LIST) {
2000 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2001 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2007 Perl_fold_constants(pTHX_ register OP *o)
2010 I32 type = o->op_type;
2013 if (PL_opargs[type] & OA_RETSCALAR)
2015 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2016 o->op_targ = pad_alloc(type, SVs_PADTMP);
2018 /* integerize op, unless it happens to be C<-foo>.
2019 * XXX should pp_i_negate() do magic string negation instead? */
2020 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2021 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2022 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2024 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2027 if (!(PL_opargs[type] & OA_FOLDCONST))
2032 /* XXX might want a ck_negate() for this */
2033 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2045 /* XXX what about the numeric ops? */
2046 if (PL_hints & HINT_LOCALE)
2051 goto nope; /* Don't try to run w/ errors */
2053 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2054 if ((curop->op_type != OP_CONST ||
2055 (curop->op_private & OPpCONST_BARE)) &&
2056 curop->op_type != OP_LIST &&
2057 curop->op_type != OP_SCALAR &&
2058 curop->op_type != OP_NULL &&
2059 curop->op_type != OP_PUSHMARK)
2065 curop = LINKLIST(o);
2069 sv = *(PL_stack_sp--);
2070 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2071 pad_swipe(o->op_targ, FALSE);
2072 else if (SvTEMP(sv)) { /* grab mortal temp? */
2073 (void)SvREFCNT_inc(sv);
2077 if (type == OP_RV2GV)
2078 return newGVOP(OP_GV, 0, (GV*)sv);
2079 return newSVOP(OP_CONST, 0, sv);
2086 Perl_gen_constant_list(pTHX_ register OP *o)
2089 I32 oldtmps_floor = PL_tmps_floor;
2093 return o; /* Don't attempt to run with errors */
2095 PL_op = curop = LINKLIST(o);
2102 PL_tmps_floor = oldtmps_floor;
2104 o->op_type = OP_RV2AV;
2105 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2106 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2107 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2108 o->op_opt = 0; /* needs to be revisited in peep() */
2109 curop = ((UNOP*)o)->op_first;
2110 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2117 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2119 if (!o || o->op_type != OP_LIST)
2120 o = newLISTOP(OP_LIST, 0, o, Nullop);
2122 o->op_flags &= ~OPf_WANT;
2124 if (!(PL_opargs[type] & OA_MARK))
2125 op_null(cLISTOPo->op_first);
2127 o->op_type = (OPCODE)type;
2128 o->op_ppaddr = PL_ppaddr[type];
2129 o->op_flags |= flags;
2131 o = CHECKOP(type, o);
2132 if (o->op_type != type)
2135 return fold_constants(o);
2138 /* List constructors */
2141 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2149 if (first->op_type != type
2150 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2152 return newLISTOP(type, 0, first, last);
2155 if (first->op_flags & OPf_KIDS)
2156 ((LISTOP*)first)->op_last->op_sibling = last;
2158 first->op_flags |= OPf_KIDS;
2159 ((LISTOP*)first)->op_first = last;
2161 ((LISTOP*)first)->op_last = last;
2166 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2174 if (first->op_type != type)
2175 return prepend_elem(type, (OP*)first, (OP*)last);
2177 if (last->op_type != type)
2178 return append_elem(type, (OP*)first, (OP*)last);
2180 first->op_last->op_sibling = last->op_first;
2181 first->op_last = last->op_last;
2182 first->op_flags |= (last->op_flags & OPf_KIDS);
2190 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2198 if (last->op_type == type) {
2199 if (type == OP_LIST) { /* already a PUSHMARK there */
2200 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2201 ((LISTOP*)last)->op_first->op_sibling = first;
2202 if (!(first->op_flags & OPf_PARENS))
2203 last->op_flags &= ~OPf_PARENS;
2206 if (!(last->op_flags & OPf_KIDS)) {
2207 ((LISTOP*)last)->op_last = first;
2208 last->op_flags |= OPf_KIDS;
2210 first->op_sibling = ((LISTOP*)last)->op_first;
2211 ((LISTOP*)last)->op_first = first;
2213 last->op_flags |= OPf_KIDS;
2217 return newLISTOP(type, 0, first, last);
2223 Perl_newNULLLIST(pTHX)
2225 return newOP(OP_STUB, 0);
2229 Perl_force_list(pTHX_ OP *o)
2231 if (!o || o->op_type != OP_LIST)
2232 o = newLISTOP(OP_LIST, 0, o, Nullop);
2238 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2242 NewOp(1101, listop, 1, LISTOP);
2244 listop->op_type = (OPCODE)type;
2245 listop->op_ppaddr = PL_ppaddr[type];
2248 listop->op_flags = (U8)flags;
2252 else if (!first && last)
2255 first->op_sibling = last;
2256 listop->op_first = first;
2257 listop->op_last = last;
2258 if (type == OP_LIST) {
2260 pushop = newOP(OP_PUSHMARK, 0);
2261 pushop->op_sibling = first;
2262 listop->op_first = pushop;
2263 listop->op_flags |= OPf_KIDS;
2265 listop->op_last = pushop;
2268 return CHECKOP(type, listop);
2272 Perl_newOP(pTHX_ I32 type, I32 flags)
2275 NewOp(1101, o, 1, OP);
2276 o->op_type = (OPCODE)type;
2277 o->op_ppaddr = PL_ppaddr[type];
2278 o->op_flags = (U8)flags;
2281 o->op_private = (U8)(0 | (flags >> 8));
2282 if (PL_opargs[type] & OA_RETSCALAR)
2284 if (PL_opargs[type] & OA_TARGET)
2285 o->op_targ = pad_alloc(type, SVs_PADTMP);
2286 return CHECKOP(type, o);
2290 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2295 first = newOP(OP_STUB, 0);
2296 if (PL_opargs[type] & OA_MARK)
2297 first = force_list(first);
2299 NewOp(1101, unop, 1, UNOP);
2300 unop->op_type = (OPCODE)type;
2301 unop->op_ppaddr = PL_ppaddr[type];
2302 unop->op_first = first;
2303 unop->op_flags = flags | OPf_KIDS;
2304 unop->op_private = (U8)(1 | (flags >> 8));
2305 unop = (UNOP*) CHECKOP(type, unop);
2309 return fold_constants((OP *) unop);
2313 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2316 NewOp(1101, binop, 1, BINOP);
2319 first = newOP(OP_NULL, 0);
2321 binop->op_type = (OPCODE)type;
2322 binop->op_ppaddr = PL_ppaddr[type];
2323 binop->op_first = first;
2324 binop->op_flags = flags | OPf_KIDS;
2327 binop->op_private = (U8)(1 | (flags >> 8));
2330 binop->op_private = (U8)(2 | (flags >> 8));
2331 first->op_sibling = last;
2334 binop = (BINOP*)CHECKOP(type, binop);
2335 if (binop->op_next || binop->op_type != (OPCODE)type)
2338 binop->op_last = binop->op_first->op_sibling;
2340 return fold_constants((OP *)binop);
2344 uvcompare(const void *a, const void *b)
2346 if (*((const UV *)a) < (*(const UV *)b))
2348 if (*((const UV *)a) > (*(const UV *)b))
2350 if (*((const UV *)a+1) < (*(const UV *)b+1))
2352 if (*((const UV *)a+1) > (*(const UV *)b+1))
2358 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2360 SV *tstr = ((SVOP*)expr)->op_sv;
2361 SV *rstr = ((SVOP*)repl)->op_sv;
2364 U8 *t = (U8*)SvPV(tstr, tlen);
2365 U8 *r = (U8*)SvPV(rstr, rlen);
2372 register short *tbl;
2374 PL_hints |= HINT_BLOCK_SCOPE;
2375 complement = o->op_private & OPpTRANS_COMPLEMENT;
2376 del = o->op_private & OPpTRANS_DELETE;
2377 squash = o->op_private & OPpTRANS_SQUASH;
2380 o->op_private |= OPpTRANS_FROM_UTF;
2383 o->op_private |= OPpTRANS_TO_UTF;
2385 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2386 SV* listsv = newSVpvn("# comment\n",10);
2388 U8* tend = t + tlen;
2389 U8* rend = r + rlen;
2403 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2404 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2410 tsave = t = bytes_to_utf8(t, &len);
2413 if (!to_utf && rlen) {
2415 rsave = r = bytes_to_utf8(r, &len);
2419 /* There are several snags with this code on EBCDIC:
2420 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2421 2. scan_const() in toke.c has encoded chars in native encoding which makes
2422 ranges at least in EBCDIC 0..255 range the bottom odd.
2426 U8 tmpbuf[UTF8_MAXBYTES+1];
2429 New(1109, cp, 2*tlen, UV);
2431 transv = newSVpvn("",0);
2433 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2435 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2437 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2441 cp[2*i+1] = cp[2*i];
2445 qsort(cp, i, 2*sizeof(UV), uvcompare);
2446 for (j = 0; j < i; j++) {
2448 diff = val - nextmin;
2450 t = uvuni_to_utf8(tmpbuf,nextmin);
2451 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2453 U8 range_mark = UTF_TO_NATIVE(0xff);
2454 t = uvuni_to_utf8(tmpbuf, val - 1);
2455 sv_catpvn(transv, (char *)&range_mark, 1);
2456 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2463 t = uvuni_to_utf8(tmpbuf,nextmin);
2464 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2466 U8 range_mark = UTF_TO_NATIVE(0xff);
2467 sv_catpvn(transv, (char *)&range_mark, 1);
2469 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2470 UNICODE_ALLOW_SUPER);
2471 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2472 t = (U8*)SvPVX(transv);
2473 tlen = SvCUR(transv);
2477 else if (!rlen && !del) {
2478 r = t; rlen = tlen; rend = tend;
2481 if ((!rlen && !del) || t == r ||
2482 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2484 o->op_private |= OPpTRANS_IDENTICAL;
2488 while (t < tend || tfirst <= tlast) {
2489 /* see if we need more "t" chars */
2490 if (tfirst > tlast) {
2491 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2493 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2495 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2502 /* now see if we need more "r" chars */
2503 if (rfirst > rlast) {
2505 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2507 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2509 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2518 rfirst = rlast = 0xffffffff;
2522 /* now see which range will peter our first, if either. */
2523 tdiff = tlast - tfirst;
2524 rdiff = rlast - rfirst;
2531 if (rfirst == 0xffffffff) {
2532 diff = tdiff; /* oops, pretend rdiff is infinite */
2534 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2535 (long)tfirst, (long)tlast);
2537 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2541 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2542 (long)tfirst, (long)(tfirst + diff),
2545 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2546 (long)tfirst, (long)rfirst);
2548 if (rfirst + diff > max)
2549 max = rfirst + diff;
2551 grows = (tfirst < rfirst &&
2552 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2564 else if (max > 0xff)
2569 Safefree(cPVOPo->op_pv);
2570 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2571 SvREFCNT_dec(listsv);
2573 SvREFCNT_dec(transv);
2575 if (!del && havefinal && rlen)
2576 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2577 newSVuv((UV)final), 0);
2580 o->op_private |= OPpTRANS_GROWS;
2592 tbl = (short*)cPVOPo->op_pv;
2594 Zero(tbl, 256, short);
2595 for (i = 0; i < (I32)tlen; i++)
2597 for (i = 0, j = 0; i < 256; i++) {
2599 if (j >= (I32)rlen) {
2608 if (i < 128 && r[j] >= 128)
2618 o->op_private |= OPpTRANS_IDENTICAL;
2620 else if (j >= (I32)rlen)
2623 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2624 tbl[0x100] = rlen - j;
2625 for (i=0; i < (I32)rlen - j; i++)
2626 tbl[0x101+i] = r[j+i];
2630 if (!rlen && !del) {
2633 o->op_private |= OPpTRANS_IDENTICAL;
2635 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2636 o->op_private |= OPpTRANS_IDENTICAL;
2638 for (i = 0; i < 256; i++)
2640 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
2641 if (j >= (I32)rlen) {
2643 if (tbl[t[i]] == -1)
2649 if (tbl[t[i]] == -1) {
2650 if (t[i] < 128 && r[j] >= 128)
2657 o->op_private |= OPpTRANS_GROWS;
2665 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2669 NewOp(1101, pmop, 1, PMOP);
2670 pmop->op_type = (OPCODE)type;
2671 pmop->op_ppaddr = PL_ppaddr[type];
2672 pmop->op_flags = (U8)flags;
2673 pmop->op_private = (U8)(0 | (flags >> 8));
2675 if (PL_hints & HINT_RE_TAINT)
2676 pmop->op_pmpermflags |= PMf_RETAINT;
2677 if (PL_hints & HINT_LOCALE)
2678 pmop->op_pmpermflags |= PMf_LOCALE;
2679 pmop->op_pmflags = pmop->op_pmpermflags;
2684 if(av_len((AV*) PL_regex_pad[0]) > -1) {
2685 repointer = av_pop((AV*)PL_regex_pad[0]);
2686 pmop->op_pmoffset = SvIV(repointer);
2687 SvREPADTMP_off(repointer);
2688 sv_setiv(repointer,0);
2690 repointer = newSViv(0);
2691 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2692 pmop->op_pmoffset = av_len(PL_regex_padav);
2693 PL_regex_pad = AvARRAY(PL_regex_padav);
2698 /* link into pm list */
2699 if (type != OP_TRANS && PL_curstash) {
2700 pmop->op_pmnext = HvPMROOT(PL_curstash);
2701 HvPMROOT(PL_curstash) = pmop;
2702 PmopSTASH_set(pmop,PL_curstash);
2705 return CHECKOP(type, pmop);
2708 /* Given some sort of match op o, and an expression expr containing a
2709 * pattern, either compile expr into a regex and attach it to o (if it's
2710 * constant), or convert expr into a runtime regcomp op sequence (if it's
2713 * isreg indicates that the pattern is part of a regex construct, eg
2714 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
2715 * split "pattern", which aren't. In the former case, expr will be a list
2716 * if the pattern contains more than one term (eg /a$b/) or if it contains
2717 * a replacement, ie s/// or tr///.
2721 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
2725 I32 repl_has_vars = 0;
2729 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
2730 /* last element in list is the replacement; pop it */
2732 repl = cLISTOPx(expr)->op_last;
2733 kid = cLISTOPx(expr)->op_first;
2734 while (kid->op_sibling != repl)
2735 kid = kid->op_sibling;
2736 kid->op_sibling = Nullop;
2737 cLISTOPx(expr)->op_last = kid;
2740 if (isreg && expr->op_type == OP_LIST &&
2741 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
2743 /* convert single element list to element */
2745 expr = cLISTOPx(oe)->op_first->op_sibling;
2746 cLISTOPx(oe)->op_first->op_sibling = Nullop;
2747 cLISTOPx(oe)->op_last = Nullop;
2751 if (o->op_type == OP_TRANS) {
2752 return pmtrans(o, expr, repl);
2755 reglist = isreg && expr->op_type == OP_LIST;
2759 PL_hints |= HINT_BLOCK_SCOPE;
2762 if (expr->op_type == OP_CONST) {
2764 SV *pat = ((SVOP*)expr)->op_sv;
2765 char *p = SvPV(pat, plen);
2766 if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
2767 sv_setpvn(pat, "\\s+", 3);
2768 p = SvPV(pat, plen);
2769 pm->op_pmflags |= PMf_SKIPWHITE;
2772 pm->op_pmdynflags |= PMdf_UTF8;
2773 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
2774 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
2775 pm->op_pmflags |= PMf_WHITE;
2779 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2780 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2782 : OP_REGCMAYBE),0,expr);
2784 NewOp(1101, rcop, 1, LOGOP);
2785 rcop->op_type = OP_REGCOMP;
2786 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2787 rcop->op_first = scalar(expr);
2788 rcop->op_flags |= OPf_KIDS
2789 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
2790 | (reglist ? OPf_STACKED : 0);
2791 rcop->op_private = 1;
2794 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
2796 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
2799 /* establish postfix order */
2800 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2802 rcop->op_next = expr;
2803 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2806 rcop->op_next = LINKLIST(expr);
2807 expr->op_next = (OP*)rcop;
2810 prepend_elem(o->op_type, scalar((OP*)rcop), o);
2815 if (pm->op_pmflags & PMf_EVAL) {
2817 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
2818 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
2820 else if (repl->op_type == OP_CONST)
2824 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
2825 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
2826 if (curop->op_type == OP_GV) {
2827 GV *gv = cGVOPx_gv(curop);
2829 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
2832 else if (curop->op_type == OP_RV2CV)
2834 else if (curop->op_type == OP_RV2SV ||
2835 curop->op_type == OP_RV2AV ||
2836 curop->op_type == OP_RV2HV ||
2837 curop->op_type == OP_RV2GV) {
2838 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2841 else if (curop->op_type == OP_PADSV ||
2842 curop->op_type == OP_PADAV ||
2843 curop->op_type == OP_PADHV ||
2844 curop->op_type == OP_PADANY) {
2847 else if (curop->op_type == OP_PUSHRE)
2848 ; /* Okay here, dangerous in newASSIGNOP */
2858 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
2859 pm->op_pmflags |= PMf_CONST; /* const for long enough */
2860 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
2861 prepend_elem(o->op_type, scalar(repl), o);
2864 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
2865 pm->op_pmflags |= PMf_MAYBE_CONST;
2866 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2868 NewOp(1101, rcop, 1, LOGOP);
2869 rcop->op_type = OP_SUBSTCONT;
2870 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
2871 rcop->op_first = scalar(repl);
2872 rcop->op_flags |= OPf_KIDS;
2873 rcop->op_private = 1;
2876 /* establish postfix order */
2877 rcop->op_next = LINKLIST(repl);
2878 repl->op_next = (OP*)rcop;
2880 pm->op_pmreplroot = scalar((OP*)rcop);
2881 pm->op_pmreplstart = LINKLIST(rcop);
2890 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
2893 NewOp(1101, svop, 1, SVOP);
2894 svop->op_type = (OPCODE)type;
2895 svop->op_ppaddr = PL_ppaddr[type];
2897 svop->op_next = (OP*)svop;
2898 svop->op_flags = (U8)flags;
2899 if (PL_opargs[type] & OA_RETSCALAR)
2901 if (PL_opargs[type] & OA_TARGET)
2902 svop->op_targ = pad_alloc(type, SVs_PADTMP);
2903 return CHECKOP(type, svop);
2907 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2910 NewOp(1101, padop, 1, PADOP);
2911 padop->op_type = (OPCODE)type;
2912 padop->op_ppaddr = PL_ppaddr[type];
2913 padop->op_padix = pad_alloc(type, SVs_PADTMP);
2914 SvREFCNT_dec(PAD_SVl(padop->op_padix));
2915 PAD_SETSV(padop->op_padix, sv);
2918 padop->op_next = (OP*)padop;
2919 padop->op_flags = (U8)flags;
2920 if (PL_opargs[type] & OA_RETSCALAR)
2922 if (PL_opargs[type] & OA_TARGET)
2923 padop->op_targ = pad_alloc(type, SVs_PADTMP);
2924 return CHECKOP(type, padop);
2928 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
2933 return newPADOP(type, flags, SvREFCNT_inc(gv));
2935 return newSVOP(type, flags, SvREFCNT_inc(gv));
2940 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
2943 NewOp(1101, pvop, 1, PVOP);
2944 pvop->op_type = (OPCODE)type;
2945 pvop->op_ppaddr = PL_ppaddr[type];
2947 pvop->op_next = (OP*)pvop;
2948 pvop->op_flags = (U8)flags;
2949 if (PL_opargs[type] & OA_RETSCALAR)
2951 if (PL_opargs[type] & OA_TARGET)
2952 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
2953 return CHECKOP(type, pvop);
2957 Perl_package(pTHX_ OP *o)
2962 save_hptr(&PL_curstash);
2963 save_item(PL_curstname);
2965 name = SvPV(cSVOPo->op_sv, len);
2966 PL_curstash = gv_stashpvn(name, len, TRUE);
2967 sv_setpvn(PL_curstname, name, len);
2970 PL_hints |= HINT_BLOCK_SCOPE;
2971 PL_copline = NOLINE;
2976 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
2982 if (idop->op_type != OP_CONST)
2983 Perl_croak(aTHX_ "Module name must be constant");
2987 if (version != Nullop) {
2988 SV *vesv = ((SVOP*)version)->op_sv;
2990 if (arg == Nullop && !SvNIOKp(vesv)) {
2997 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
2998 Perl_croak(aTHX_ "Version number must be constant number");
3000 /* Make copy of idop so we don't free it twice */
3001 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3003 /* Fake up a method call to VERSION */
3004 meth = newSVpvn("VERSION",7);
3005 sv_upgrade(meth, SVt_PVIV);
3006 (void)SvIOK_on(meth);
3007 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3008 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3009 append_elem(OP_LIST,
3010 prepend_elem(OP_LIST, pack, list(version)),
3011 newSVOP(OP_METHOD_NAMED, 0, meth)));
3015 /* Fake up an import/unimport */
3016 if (arg && arg->op_type == OP_STUB)
3017 imop = arg; /* no import on explicit () */
3018 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3019 imop = Nullop; /* use 5.0; */
3024 /* Make copy of idop so we don't free it twice */
3025 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3027 /* Fake up a method call to import/unimport */
3028 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);
3029 (void)SvUPGRADE(meth, SVt_PVIV);
3030 (void)SvIOK_on(meth);
3031 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3032 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3033 append_elem(OP_LIST,
3034 prepend_elem(OP_LIST, pack, list(arg)),
3035 newSVOP(OP_METHOD_NAMED, 0, meth)));
3038 /* Fake up the BEGIN {}, which does its thing immediately. */
3040 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3043 append_elem(OP_LINESEQ,
3044 append_elem(OP_LINESEQ,
3045 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, idop)),
3046 newSTATEOP(0, Nullch, veop)),
3047 newSTATEOP(0, Nullch, imop) ));
3049 /* The "did you use incorrect case?" warning used to be here.
3050 * The problem is that on case-insensitive filesystems one
3051 * might get false positives for "use" (and "require"):
3052 * "use Strict" or "require CARP" will work. This causes
3053 * portability problems for the script: in case-strict
3054 * filesystems the script will stop working.
3056 * The "incorrect case" warning checked whether "use Foo"
3057 * imported "Foo" to your namespace, but that is wrong, too:
3058 * there is no requirement nor promise in the language that
3059 * a Foo.pm should or would contain anything in package "Foo".
3061 * There is very little Configure-wise that can be done, either:
3062 * the case-sensitivity of the build filesystem of Perl does not
3063 * help in guessing the case-sensitivity of the runtime environment.
3066 PL_hints |= HINT_BLOCK_SCOPE;
3067 PL_copline = NOLINE;
3069 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3073 =head1 Embedding Functions
3075 =for apidoc load_module
3077 Loads the module whose name is pointed to by the string part of name.
3078 Note that the actual module name, not its filename, should be given.
3079 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3080 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3081 (or 0 for no flags). ver, if specified, provides version semantics
3082 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3083 arguments can be used to specify arguments to the module's import()
3084 method, similar to C<use Foo::Bar VERSION LIST>.
3089 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3092 va_start(args, ver);
3093 vload_module(flags, name, ver, &args);
3097 #ifdef PERL_IMPLICIT_CONTEXT
3099 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3103 va_start(args, ver);
3104 vload_module(flags, name, ver, &args);
3110 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3112 OP *modname, *veop, *imop;
3114 modname = newSVOP(OP_CONST, 0, name);
3115 modname->op_private |= OPpCONST_BARE;
3117 veop = newSVOP(OP_CONST, 0, ver);
3121 if (flags & PERL_LOADMOD_NOIMPORT) {
3122 imop = sawparens(newNULLLIST());
3124 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3125 imop = va_arg(*args, OP*);
3130 sv = va_arg(*args, SV*);
3132 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3133 sv = va_arg(*args, SV*);
3137 line_t ocopline = PL_copline;
3138 COP *ocurcop = PL_curcop;
3139 int oexpect = PL_expect;
3141 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3142 veop, modname, imop);
3143 PL_expect = oexpect;
3144 PL_copline = ocopline;
3145 PL_curcop = ocurcop;
3150 Perl_dofile(pTHX_ OP *term)
3155 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3156 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
3157 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3159 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3160 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3161 append_elem(OP_LIST, term,
3162 scalar(newUNOP(OP_RV2CV, 0,
3167 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3173 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3175 return newBINOP(OP_LSLICE, flags,
3176 list(force_list(subscript)),
3177 list(force_list(listval)) );
3181 S_list_assignment(pTHX_ register OP *o)
3186 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3187 o = cUNOPo->op_first;
3189 if (o->op_type == OP_COND_EXPR) {
3190 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3191 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3196 yyerror("Assignment to both a list and a scalar");
3200 if (o->op_type == OP_LIST &&
3201 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3202 o->op_private & OPpLVAL_INTRO)
3205 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3206 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3207 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3210 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3213 if (o->op_type == OP_RV2SV)
3220 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3225 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3226 return newLOGOP(optype, 0,
3227 mod(scalar(left), optype),
3228 newUNOP(OP_SASSIGN, 0, scalar(right)));
3231 return newBINOP(optype, OPf_STACKED,
3232 mod(scalar(left), optype), scalar(right));
3236 if (list_assignment(left)) {
3240 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3241 left = mod(left, OP_AASSIGN);
3249 /* optimise C<my @x = ()> to C<my @x>, and likewise for hashes */
3250 if ((left->op_type == OP_PADAV || left->op_type == OP_PADHV)
3251 && right->op_type == OP_STUB
3252 && (left->op_private & OPpLVAL_INTRO))
3255 left->op_flags &= ~(OPf_REF|OPf_SPECIAL);
3258 curop = list(force_list(left));
3259 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3260 o->op_private = (U8)(0 | (flags >> 8));
3262 /* PL_generation sorcery:
3263 * an assignment like ($a,$b) = ($c,$d) is easier than
3264 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3265 * To detect whether there are common vars, the global var
3266 * PL_generation is incremented for each assign op we compile.
3267 * Then, while compiling the assign op, we run through all the
3268 * variables on both sides of the assignment, setting a spare slot
3269 * in each of them to PL_generation. If any of them already have
3270 * that value, we know we've got commonality. We could use a
3271 * single bit marker, but then we'd have to make 2 passes, first
3272 * to clear the flag, then to test and set it. To find somewhere
3273 * to store these values, evil chicanery is done with SvCUR().
3276 if (!(left->op_private & OPpLVAL_INTRO)) {
3279 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3280 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3281 if (curop->op_type == OP_GV) {
3282 GV *gv = cGVOPx_gv(curop);
3283 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3285 SvCUR(gv) = PL_generation;
3287 else if (curop->op_type == OP_PADSV ||
3288 curop->op_type == OP_PADAV ||
3289 curop->op_type == OP_PADHV ||
3290 curop->op_type == OP_PADANY)
3292 if (PAD_COMPNAME_GEN(curop->op_targ)
3293 == (STRLEN)PL_generation)
3295 PAD_COMPNAME_GEN(curop->op_targ)
3299 else if (curop->op_type == OP_RV2CV)
3301 else if (curop->op_type == OP_RV2SV ||
3302 curop->op_type == OP_RV2AV ||
3303 curop->op_type == OP_RV2HV ||
3304 curop->op_type == OP_RV2GV) {
3305 if (lastop->op_type != OP_GV) /* funny deref? */
3308 else if (curop->op_type == OP_PUSHRE) {
3309 if (((PMOP*)curop)->op_pmreplroot) {
3311 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3312 ((PMOP*)curop)->op_pmreplroot));
3314 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3316 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3318 SvCUR(gv) = PL_generation;
3327 o->op_private |= OPpASSIGN_COMMON;
3329 if (right && right->op_type == OP_SPLIT) {
3331 if ((tmpop = ((LISTOP*)right)->op_first) &&
3332 tmpop->op_type == OP_PUSHRE)
3334 PMOP *pm = (PMOP*)tmpop;
3335 if (left->op_type == OP_RV2AV &&
3336 !(left->op_private & OPpLVAL_INTRO) &&
3337 !(o->op_private & OPpASSIGN_COMMON) )
3339 tmpop = ((UNOP*)left)->op_first;
3340 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3342 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3343 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3345 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3346 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3348 pm->op_pmflags |= PMf_ONCE;
3349 tmpop = cUNOPo->op_first; /* to list (nulled) */
3350 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3351 tmpop->op_sibling = Nullop; /* don't free split */
3352 right->op_next = tmpop->op_next; /* fix starting loc */
3353 op_free(o); /* blow off assign */
3354 right->op_flags &= ~OPf_WANT;
3355 /* "I don't know and I don't care." */
3360 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3361 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3363 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3365 sv_setiv(sv, PL_modcount+1);
3373 right = newOP(OP_UNDEF, 0);
3374 if (right->op_type == OP_READLINE) {
3375 right->op_flags |= OPf_STACKED;
3376 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3379 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3380 o = newBINOP(OP_SASSIGN, flags,
3381 scalar(right), mod(scalar(left), OP_SASSIGN) );
3393 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3395 const U32 seq = intro_my();
3398 NewOp(1101, cop, 1, COP);
3399 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3400 cop->op_type = OP_DBSTATE;
3401 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3404 cop->op_type = OP_NEXTSTATE;
3405 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3407 cop->op_flags = (U8)flags;
3408 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3410 cop->op_private |= NATIVE_HINTS;
3412 PL_compiling.op_private = cop->op_private;
3413 cop->op_next = (OP*)cop;
3416 cop->cop_label = label;
3417 PL_hints |= HINT_BLOCK_SCOPE;
3420 cop->cop_arybase = PL_curcop->cop_arybase;
3421 if (specialWARN(PL_curcop->cop_warnings))
3422 cop->cop_warnings = PL_curcop->cop_warnings ;
3424 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3425 if (specialCopIO(PL_curcop->cop_io))
3426 cop->cop_io = PL_curcop->cop_io;
3428 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3431 if (PL_copline == NOLINE)
3432 CopLINE_set(cop, CopLINE(PL_curcop));
3434 CopLINE_set(cop, PL_copline);
3435 PL_copline = NOLINE;
3438 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3440 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3442 CopSTASH_set(cop, PL_curstash);
3444 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3445 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3446 if (svp && *svp != &PL_sv_undef ) {
3447 (void)SvIOK_on(*svp);
3448 SvIVX(*svp) = PTR2IV(cop);
3452 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3457 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3459 return new_logop(type, flags, &first, &other);
3463 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3467 OP *first = *firstp;
3468 OP *other = *otherp;
3470 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3471 return newBINOP(type, flags, scalar(first), scalar(other));
3473 scalarboolean(first);
3474 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3475 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3476 if (type == OP_AND || type == OP_OR) {
3482 first = *firstp = cUNOPo->op_first;
3484 first->op_next = o->op_next;
3485 cUNOPo->op_first = Nullop;
3489 if (first->op_type == OP_CONST) {
3490 if (first->op_private & OPpCONST_STRICT)
3491 no_bareword_allowed(first);
3492 else if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3493 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3494 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
3495 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
3496 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
3499 if (other->op_type == OP_CONST)
3500 other->op_private |= OPpCONST_SHORTCIRCUIT;
3504 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
3506 if ( ! (o2->op_type == OP_LIST
3507 && (( o2 = cUNOPx(o2)->op_first))
3508 && o2->op_type == OP_PUSHMARK
3509 && (( o2 = o2->op_sibling)) )
3512 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
3513 || o2->op_type == OP_PADHV)
3514 && o2->op_private & OPpLVAL_INTRO
3515 && ckWARN(WARN_DEPRECATED))
3517 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
3518 "Deprecated use of my() in false conditional");
3523 if (first->op_type == OP_CONST)
3524 first->op_private |= OPpCONST_SHORTCIRCUIT;
3528 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS) &&
3529 type != OP_DOR) /* [#24076] Don't warn for <FH> err FOO. */
3531 OP *k1 = ((UNOP*)first)->op_first;
3532 OP *k2 = k1->op_sibling;
3534 switch (first->op_type)
3537 if (k2 && k2->op_type == OP_READLINE
3538 && (k2->op_flags & OPf_STACKED)
3539 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3541 warnop = k2->op_type;
3546 if (k1->op_type == OP_READDIR
3547 || k1->op_type == OP_GLOB
3548 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3549 || k1->op_type == OP_EACH)
3551 warnop = ((k1->op_type == OP_NULL)
3552 ? (OPCODE)k1->op_targ : k1->op_type);
3557 line_t oldline = CopLINE(PL_curcop);
3558 CopLINE_set(PL_curcop, PL_copline);
3559 Perl_warner(aTHX_ packWARN(WARN_MISC),
3560 "Value of %s%s can be \"0\"; test with defined()",
3562 ((warnop == OP_READLINE || warnop == OP_GLOB)
3563 ? " construct" : "() operator"));
3564 CopLINE_set(PL_curcop, oldline);
3571 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3572 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3574 NewOp(1101, logop, 1, LOGOP);
3576 logop->op_type = (OPCODE)type;
3577 logop->op_ppaddr = PL_ppaddr[type];
3578 logop->op_first = first;
3579 logop->op_flags = flags | OPf_KIDS;
3580 logop->op_other = LINKLIST(other);
3581 logop->op_private = (U8)(1 | (flags >> 8));
3583 /* establish postfix order */
3584 logop->op_next = LINKLIST(first);
3585 first->op_next = (OP*)logop;
3586 first->op_sibling = other;
3588 CHECKOP(type,logop);
3590 o = newUNOP(OP_NULL, 0, (OP*)logop);
3597 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3604 return newLOGOP(OP_AND, 0, first, trueop);
3606 return newLOGOP(OP_OR, 0, first, falseop);
3608 scalarboolean(first);
3609 if (first->op_type == OP_CONST) {
3610 if (first->op_private & OPpCONST_BARE &&
3611 first->op_private & OPpCONST_STRICT) {
3612 no_bareword_allowed(first);
3614 if (SvTRUE(((SVOP*)first)->op_sv)) {
3625 NewOp(1101, logop, 1, LOGOP);
3626 logop->op_type = OP_COND_EXPR;
3627 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3628 logop->op_first = first;
3629 logop->op_flags = flags | OPf_KIDS;
3630 logop->op_private = (U8)(1 | (flags >> 8));
3631 logop->op_other = LINKLIST(trueop);
3632 logop->op_next = LINKLIST(falseop);
3634 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
3637 /* establish postfix order */
3638 start = LINKLIST(first);
3639 first->op_next = (OP*)logop;
3641 first->op_sibling = trueop;
3642 trueop->op_sibling = falseop;
3643 o = newUNOP(OP_NULL, 0, (OP*)logop);
3645 trueop->op_next = falseop->op_next = o;
3652 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3660 NewOp(1101, range, 1, LOGOP);
3662 range->op_type = OP_RANGE;
3663 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3664 range->op_first = left;
3665 range->op_flags = OPf_KIDS;
3666 leftstart = LINKLIST(left);
3667 range->op_other = LINKLIST(right);
3668 range->op_private = (U8)(1 | (flags >> 8));
3670 left->op_sibling = right;
3672 range->op_next = (OP*)range;
3673 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3674 flop = newUNOP(OP_FLOP, 0, flip);
3675 o = newUNOP(OP_NULL, 0, flop);
3677 range->op_next = leftstart;
3679 left->op_next = flip;
3680 right->op_next = flop;
3682 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3683 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3684 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3685 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3687 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3688 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3691 if (!flip->op_private || !flop->op_private)
3692 linklist(o); /* blow off optimizer unless constant */
3698 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3702 const bool once = block && block->op_flags & OPf_SPECIAL &&
3703 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3707 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3708 return block; /* do {} while 0 does once */
3709 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3710 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3711 expr = newUNOP(OP_DEFINED, 0,
3712 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3713 } else if (expr->op_flags & OPf_KIDS) {
3714 const OP *k1 = ((UNOP*)expr)->op_first;
3715 const OP *k2 = (k1) ? k1->op_sibling : NULL;
3716 switch (expr->op_type) {
3718 if (k2 && k2->op_type == OP_READLINE
3719 && (k2->op_flags & OPf_STACKED)
3720 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3721 expr = newUNOP(OP_DEFINED, 0, expr);
3725 if (k1->op_type == OP_READDIR
3726 || k1->op_type == OP_GLOB
3727 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3728 || k1->op_type == OP_EACH)
3729 expr = newUNOP(OP_DEFINED, 0, expr);
3735 /* if block is null, the next append_elem() would put UNSTACK, a scalar
3736 * op, in listop. This is wrong. [perl #27024] */
3738 block = newOP(OP_NULL, 0);
3739 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3740 o = new_logop(OP_AND, 0, &expr, &listop);
3743 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3745 if (once && o != listop)
3746 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3749 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3751 o->op_flags |= flags;
3753 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3758 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3767 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3768 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3769 expr = newUNOP(OP_DEFINED, 0,
3770 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3771 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3772 const OP *k1 = ((UNOP*)expr)->op_first;
3773 const OP *k2 = (k1) ? k1->op_sibling : NULL;
3774 switch (expr->op_type) {
3776 if (k2 && k2->op_type == OP_READLINE
3777 && (k2->op_flags & OPf_STACKED)
3778 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3779 expr = newUNOP(OP_DEFINED, 0, expr);
3783 if (k1->op_type == OP_READDIR
3784 || k1->op_type == OP_GLOB
3785 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3786 || k1->op_type == OP_EACH)
3787 expr = newUNOP(OP_DEFINED, 0, expr);
3793 block = newOP(OP_NULL, 0);
3795 block = scope(block);
3799 next = LINKLIST(cont);
3802 OP *unstack = newOP(OP_UNSTACK, 0);
3805 cont = append_elem(OP_LINESEQ, cont, unstack);
3808 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3809 redo = LINKLIST(listop);
3812 PL_copline = (line_t)whileline;
3814 o = new_logop(OP_AND, 0, &expr, &listop);
3815 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3816 op_free(expr); /* oops, it's a while (0) */
3818 return Nullop; /* listop already freed by new_logop */
3821 ((LISTOP*)listop)->op_last->op_next =
3822 (o == listop ? redo : LINKLIST(o));
3828 NewOp(1101,loop,1,LOOP);
3829 loop->op_type = OP_ENTERLOOP;
3830 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3831 loop->op_private = 0;
3832 loop->op_next = (OP*)loop;
3835 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3837 loop->op_redoop = redo;
3838 loop->op_lastop = o;
3839 o->op_private |= loopflags;
3842 loop->op_nextop = next;
3844 loop->op_nextop = o;
3846 o->op_flags |= flags;
3847 o->op_private |= (flags >> 8);
3852 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
3856 PADOFFSET padoff = 0;
3861 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
3862 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
3863 sv->op_type = OP_RV2GV;
3864 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3866 else if (sv->op_type == OP_PADSV) { /* private variable */
3867 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
3868 padoff = sv->op_targ;
3873 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3874 padoff = sv->op_targ;
3876 iterflags |= OPf_SPECIAL;
3881 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3884 const I32 offset = pad_findmy("$_");
3885 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
3886 sv = newGVOP(OP_GV, 0, PL_defgv);
3892 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3893 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3894 iterflags |= OPf_STACKED;
3896 else if (expr->op_type == OP_NULL &&
3897 (expr->op_flags & OPf_KIDS) &&
3898 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3900 /* Basically turn for($x..$y) into the same as for($x,$y), but we
3901 * set the STACKED flag to indicate that these values are to be
3902 * treated as min/max values by 'pp_iterinit'.
3904 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
3905 LOGOP* range = (LOGOP*) flip->op_first;
3906 OP* left = range->op_first;
3907 OP* right = left->op_sibling;
3910 range->op_flags &= ~OPf_KIDS;
3911 range->op_first = Nullop;
3913 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
3914 listop->op_first->op_next = range->op_next;
3915 left->op_next = range->op_other;
3916 right->op_next = (OP*)listop;
3917 listop->op_next = listop->op_first;
3920 expr = (OP*)(listop);
3922 iterflags |= OPf_STACKED;
3925 expr = mod(force_list(expr), OP_GREPSTART);
3928 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
3929 append_elem(OP_LIST, expr, scalar(sv))));
3930 assert(!loop->op_next);
3931 /* for my $x () sets OPpLVAL_INTRO;
3932 * for our $x () sets OPpOUR_INTRO */
3933 loop->op_private = (U8)iterpflags;
3934 #ifdef PL_OP_SLAB_ALLOC
3937 NewOp(1234,tmp,1,LOOP);
3938 Copy(loop,tmp,1,LISTOP);
3943 Renew(loop, 1, LOOP);
3945 loop->op_targ = padoff;
3946 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
3947 PL_copline = forline;
3948 return newSTATEOP(0, label, wop);
3952 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
3957 if (type != OP_GOTO || label->op_type == OP_CONST) {
3958 /* "last()" means "last" */
3959 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
3960 o = newOP(type, OPf_SPECIAL);
3962 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
3963 ? SvPVx(((SVOP*)label)->op_sv, n_a)
3969 /* Check whether it's going to be a goto &function */
3970 if (label->op_type == OP_ENTERSUB
3971 && !(label->op_flags & OPf_STACKED))
3972 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
3973 o = newUNOP(type, OPf_STACKED, label);
3975 PL_hints |= HINT_BLOCK_SCOPE;
3980 =for apidoc cv_undef
3982 Clear out all the active components of a CV. This can happen either
3983 by an explicit C<undef &foo>, or by the reference count going to zero.
3984 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
3985 children can still follow the full lexical scope chain.
3991 Perl_cv_undef(pTHX_ CV *cv)
3994 if (CvFILE(cv) && !CvXSUB(cv)) {
3995 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
3996 Safefree(CvFILE(cv));
4001 if (!CvXSUB(cv) && CvROOT(cv)) {
4003 Perl_croak(aTHX_ "Can't undef active subroutine");
4006 PAD_SAVE_SETNULLPAD();
4008 op_free(CvROOT(cv));
4009 CvROOT(cv) = Nullop;
4012 SvPOK_off((SV*)cv); /* forget prototype */
4017 /* remove CvOUTSIDE unless this is an undef rather than a free */
4018 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4019 if (!CvWEAKOUTSIDE(cv))
4020 SvREFCNT_dec(CvOUTSIDE(cv));
4021 CvOUTSIDE(cv) = Nullcv;
4024 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4030 /* delete all flags except WEAKOUTSIDE */
4031 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4035 Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p)
4037 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4038 SV* msg = sv_newmortal();
4042 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4043 sv_setpv(msg, "Prototype mismatch:");
4045 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4047 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (const SV *)cv);
4049 Perl_sv_catpv(aTHX_ msg, ": none");
4050 sv_catpv(msg, " vs ");
4052 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4054 sv_catpv(msg, "none");
4055 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
4059 static void const_sv_xsub(pTHX_ CV* cv);
4063 =head1 Optree Manipulation Functions
4065 =for apidoc cv_const_sv
4067 If C<cv> is a constant sub eligible for inlining. returns the constant
4068 value returned by the sub. Otherwise, returns NULL.
4070 Constant subs can be created with C<newCONSTSUB> or as described in
4071 L<perlsub/"Constant Functions">.
4076 Perl_cv_const_sv(pTHX_ CV *cv)
4078 if (!cv || !CvCONST(cv))
4080 return (SV*)CvXSUBANY(cv).any_ptr;
4083 /* op_const_sv: examine an optree to determine whether it's in-lineable.
4084 * Can be called in 3 ways:
4087 * look for a single OP_CONST with attached value: return the value
4089 * cv && CvCLONE(cv) && !CvCONST(cv)
4091 * examine the clone prototype, and if contains only a single
4092 * OP_CONST referencing a pad const, or a single PADSV referencing
4093 * an outer lexical, return a non-zero value to indicate the CV is
4094 * a candidate for "constizing" at clone time
4098 * We have just cloned an anon prototype that was marked as a const
4099 * candidiate. Try to grab the current value, and in the case of
4100 * PADSV, ignore it if it has multiple references. Return the value.
4104 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4111 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4112 o = cLISTOPo->op_first->op_sibling;
4114 for (; o; o = o->op_next) {
4115 OPCODE type = o->op_type;
4117 if (sv && o->op_next == o)
4119 if (o->op_next != o) {
4120 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4122 if (type == OP_DBSTATE)
4125 if (type == OP_LEAVESUB || type == OP_RETURN)
4129 if (type == OP_CONST && cSVOPo->op_sv)
4131 else if (cv && type == OP_CONST) {
4132 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4136 else if (cv && type == OP_PADSV) {
4137 if (CvCONST(cv)) { /* newly cloned anon */
4138 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4139 /* the candidate should have 1 ref from this pad and 1 ref
4140 * from the parent */
4141 if (!sv || SvREFCNT(sv) != 2)
4148 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4149 sv = &PL_sv_undef; /* an arbitrary non-null value */
4160 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4171 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4175 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4177 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4181 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4191 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4194 assert(proto->op_type == OP_CONST);
4195 ps = SvPVx(((SVOP*)proto)->op_sv, n_a);
4200 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4201 SV *sv = sv_newmortal();
4202 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4203 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4204 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4209 gv = name ? gv_fetchsv(cSVOPo->op_sv,
4210 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4212 : gv_fetchpv(aname ? aname
4213 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4214 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4224 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4225 maximum a prototype before. */
4226 if (SvTYPE(gv) > SVt_NULL) {
4227 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4228 && ckWARN_d(WARN_PROTOTYPE))
4230 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4232 cv_ckproto((CV*)gv, NULL, ps);
4235 sv_setpv((SV*)gv, ps);
4237 sv_setiv((SV*)gv, -1);
4238 SvREFCNT_dec(PL_compcv);
4239 cv = PL_compcv = NULL;
4240 PL_sub_generation++;
4244 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4246 #ifdef GV_UNIQUE_CHECK
4247 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4248 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4252 if (!block || !ps || *ps || attrs)
4255 const_sv = op_const_sv(block, Nullcv);
4258 bool exists = CvROOT(cv) || CvXSUB(cv);
4260 #ifdef GV_UNIQUE_CHECK
4261 if (exists && GvUNIQUE(gv)) {
4262 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4266 /* if the subroutine doesn't exist and wasn't pre-declared
4267 * with a prototype, assume it will be AUTOLOADed,
4268 * skipping the prototype check
4270 if (exists || SvPOK(cv))
4271 cv_ckproto(cv, gv, ps);
4272 /* already defined (or promised)? */
4273 if (exists || GvASSUMECV(gv)) {
4274 if (!block && !attrs) {
4275 if (CvFLAGS(PL_compcv)) {
4276 /* might have had built-in attrs applied */
4277 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4279 /* just a "sub foo;" when &foo is already defined */
4280 SAVEFREESV(PL_compcv);
4283 /* ahem, death to those who redefine active sort subs */
4284 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4285 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4287 if (ckWARN(WARN_REDEFINE)
4289 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4291 line_t oldline = CopLINE(PL_curcop);
4292 if (PL_copline != NOLINE)
4293 CopLINE_set(PL_curcop, PL_copline);
4294 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4295 CvCONST(cv) ? "Constant subroutine %s redefined"
4296 : "Subroutine %s redefined", name);
4297 CopLINE_set(PL_curcop, oldline);
4305 (void)SvREFCNT_inc(const_sv);
4307 assert(!CvROOT(cv) && !CvCONST(cv));
4308 sv_setpv((SV*)cv, ""); /* prototype is "" */
4309 CvXSUBANY(cv).any_ptr = const_sv;
4310 CvXSUB(cv) = const_sv_xsub;
4315 cv = newCONSTSUB(NULL, name, const_sv);
4318 SvREFCNT_dec(PL_compcv);
4320 PL_sub_generation++;
4327 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4328 * before we clobber PL_compcv.
4332 /* Might have had built-in attributes applied -- propagate them. */
4333 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4334 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4335 stash = GvSTASH(CvGV(cv));
4336 else if (CvSTASH(cv))
4337 stash = CvSTASH(cv);
4339 stash = PL_curstash;
4342 /* possibly about to re-define existing subr -- ignore old cv */
4343 rcv = (SV*)PL_compcv;
4344 if (name && GvSTASH(gv))
4345 stash = GvSTASH(gv);
4347 stash = PL_curstash;
4349 apply_attrs(stash, rcv, attrs, FALSE);
4351 if (cv) { /* must reuse cv if autoloaded */
4353 /* got here with just attrs -- work done, so bug out */
4354 SAVEFREESV(PL_compcv);
4357 /* transfer PL_compcv to cv */
4359 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4360 if (!CvWEAKOUTSIDE(cv))
4361 SvREFCNT_dec(CvOUTSIDE(cv));
4362 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4363 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4364 CvOUTSIDE(PL_compcv) = 0;
4365 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4366 CvPADLIST(PL_compcv) = 0;
4367 /* inner references to PL_compcv must be fixed up ... */
4368 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4369 /* ... before we throw it away */
4370 SvREFCNT_dec(PL_compcv);
4372 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4373 ++PL_sub_generation;
4380 PL_sub_generation++;
4384 CvFILE_set_from_cop(cv, PL_curcop);
4385 CvSTASH(cv) = PL_curstash;
4388 sv_setpv((SV*)cv, ps);
4390 if (PL_error_count) {
4394 char *s = strrchr(name, ':');
4396 if (strEQ(s, "BEGIN")) {
4397 const char not_safe[] =
4398 "BEGIN not safe after errors--compilation aborted";
4399 if (PL_in_eval & EVAL_KEEPERR)
4400 Perl_croak(aTHX_ not_safe);
4402 /* force display of errors found but not reported */
4403 sv_catpv(ERRSV, not_safe);
4404 Perl_croak(aTHX_ "%"SVf, ERRSV);
4413 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4414 mod(scalarseq(block), OP_LEAVESUBLV));
4417 /* This makes sub {}; work as expected. */
4418 if (block->op_type == OP_STUB) {
4420 block = newSTATEOP(0, Nullch, 0);
4422 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4424 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4425 OpREFCNT_set(CvROOT(cv), 1);
4426 CvSTART(cv) = LINKLIST(CvROOT(cv));
4427 CvROOT(cv)->op_next = 0;
4428 CALL_PEEP(CvSTART(cv));
4430 /* now that optimizer has done its work, adjust pad values */
4432 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4435 assert(!CvCONST(cv));
4436 if (ps && !*ps && op_const_sv(block, cv))
4440 if (name || aname) {
4442 char *tname = (name ? name : aname);
4444 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4445 SV *sv = NEWSV(0,0);
4446 SV *tmpstr = sv_newmortal();
4447 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4451 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4453 (long)PL_subline, (long)CopLINE(PL_curcop));
4454 gv_efullname3(tmpstr, gv, Nullch);
4455 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4456 hv = GvHVn(db_postponed);
4457 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4458 && (pcv = GvCV(db_postponed)))
4464 call_sv((SV*)pcv, G_DISCARD);
4468 if ((s = strrchr(tname,':')))
4473 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4476 if (strEQ(s, "BEGIN") && !PL_error_count) {
4477 I32 oldscope = PL_scopestack_ix;
4479 SAVECOPFILE(&PL_compiling);
4480 SAVECOPLINE(&PL_compiling);
4483 PL_beginav = newAV();
4484 DEBUG_x( dump_sub(gv) );
4485 av_push(PL_beginav, (SV*)cv);
4486 GvCV(gv) = 0; /* cv has been hijacked */
4487 call_list(oldscope, PL_beginav);
4489 PL_curcop = &PL_compiling;
4490 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4493 else if (strEQ(s, "END") && !PL_error_count) {
4496 DEBUG_x( dump_sub(gv) );
4497 av_unshift(PL_endav, 1);
4498 av_store(PL_endav, 0, (SV*)cv);
4499 GvCV(gv) = 0; /* cv has been hijacked */
4501 else if (strEQ(s, "CHECK") && !PL_error_count) {
4503 PL_checkav = newAV();
4504 DEBUG_x( dump_sub(gv) );
4505 if (PL_main_start && ckWARN(WARN_VOID))
4506 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4507 av_unshift(PL_checkav, 1);
4508 av_store(PL_checkav, 0, (SV*)cv);
4509 GvCV(gv) = 0; /* cv has been hijacked */
4511 else if (strEQ(s, "INIT") && !PL_error_count) {
4513 PL_initav = newAV();
4514 DEBUG_x( dump_sub(gv) );
4515 if (PL_main_start && ckWARN(WARN_VOID))
4516 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4517 av_push(PL_initav, (SV*)cv);
4518 GvCV(gv) = 0; /* cv has been hijacked */
4523 PL_copline = NOLINE;
4528 /* XXX unsafe for threads if eval_owner isn't held */
4530 =for apidoc newCONSTSUB
4532 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4533 eligible for inlining at compile-time.
4539 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
4545 SAVECOPLINE(PL_curcop);
4546 CopLINE_set(PL_curcop, PL_copline);
4549 PL_hints &= ~HINT_BLOCK_SCOPE;
4552 SAVESPTR(PL_curstash);
4553 SAVECOPSTASH(PL_curcop);
4554 PL_curstash = stash;
4555 CopSTASH_set(PL_curcop,stash);
4558 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4559 CvXSUBANY(cv).any_ptr = sv;
4561 sv_setpv((SV*)cv, ""); /* prototype is "" */
4564 CopSTASH_free(PL_curcop);
4572 =for apidoc U||newXS
4574 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4580 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
4582 GV *gv = gv_fetchpv(name ? name :
4583 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4584 GV_ADDMULTI, SVt_PVCV);
4588 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4590 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4592 /* just a cached method */
4596 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4597 /* already defined (or promised) */
4598 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4599 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4600 line_t oldline = CopLINE(PL_curcop);
4601 if (PL_copline != NOLINE)
4602 CopLINE_set(PL_curcop, PL_copline);
4603 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4604 CvCONST(cv) ? "Constant subroutine %s redefined"
4605 : "Subroutine %s redefined"
4607 CopLINE_set(PL_curcop, oldline);
4614 if (cv) /* must reuse cv if autoloaded */
4617 cv = (CV*)NEWSV(1105,0);
4618 sv_upgrade((SV *)cv, SVt_PVCV);
4622 PL_sub_generation++;
4626 (void)gv_fetchfile(filename);
4627 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
4628 an external constant string */
4629 CvXSUB(cv) = subaddr;
4632 const char *s = strrchr(name,':');
4638 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4641 if (strEQ(s, "BEGIN")) {
4643 PL_beginav = newAV();
4644 av_push(PL_beginav, (SV*)cv);
4645 GvCV(gv) = 0; /* cv has been hijacked */
4647 else if (strEQ(s, "END")) {
4650 av_unshift(PL_endav, 1);
4651 av_store(PL_endav, 0, (SV*)cv);
4652 GvCV(gv) = 0; /* cv has been hijacked */
4654 else if (strEQ(s, "CHECK")) {
4656 PL_checkav = newAV();
4657 if (PL_main_start && ckWARN(WARN_VOID))
4658 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4659 av_unshift(PL_checkav, 1);
4660 av_store(PL_checkav, 0, (SV*)cv);
4661 GvCV(gv) = 0; /* cv has been hijacked */
4663 else if (strEQ(s, "INIT")) {
4665 PL_initav = newAV();
4666 if (PL_main_start && ckWARN(WARN_VOID))
4667 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4668 av_push(PL_initav, (SV*)cv);
4669 GvCV(gv) = 0; /* cv has been hijacked */
4680 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4686 gv = gv_fetchsv(cSVOPo->op_sv, TRUE, SVt_PVFM);
4688 gv = gv_fetchpv("STDOUT", TRUE, SVt_PVFM);
4690 #ifdef GV_UNIQUE_CHECK
4692 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4696 if ((cv = GvFORM(gv))) {
4697 if (ckWARN(WARN_REDEFINE)) {
4698 line_t oldline = CopLINE(PL_curcop);
4699 if (PL_copline != NOLINE)
4700 CopLINE_set(PL_curcop, PL_copline);
4701 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4702 o ? "Format %"SVf" redefined"
4703 : "Format STDOUT redefined" ,cSVOPo->op_sv);
4704 CopLINE_set(PL_curcop, oldline);
4711 CvFILE_set_from_cop(cv, PL_curcop);
4714 pad_tidy(padtidy_FORMAT);
4715 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4716 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4717 OpREFCNT_set(CvROOT(cv), 1);
4718 CvSTART(cv) = LINKLIST(CvROOT(cv));
4719 CvROOT(cv)->op_next = 0;
4720 CALL_PEEP(CvSTART(cv));
4722 PL_copline = NOLINE;
4727 Perl_newANONLIST(pTHX_ OP *o)
4729 return newUNOP(OP_REFGEN, 0,
4730 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4734 Perl_newANONHASH(pTHX_ OP *o)
4736 return newUNOP(OP_REFGEN, 0,
4737 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4741 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4743 return newANONATTRSUB(floor, proto, Nullop, block);
4747 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4749 return newUNOP(OP_REFGEN, 0,
4750 newSVOP(OP_ANONCODE, 0,
4751 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
4755 Perl_oopsAV(pTHX_ OP *o)
4757 switch (o->op_type) {
4759 o->op_type = OP_PADAV;
4760 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4761 return ref(o, OP_RV2AV);
4764 o->op_type = OP_RV2AV;
4765 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4770 if (ckWARN_d(WARN_INTERNAL))
4771 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
4778 Perl_oopsHV(pTHX_ OP *o)
4780 switch (o->op_type) {
4783 o->op_type = OP_PADHV;
4784 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4785 return ref(o, OP_RV2HV);
4789 o->op_type = OP_RV2HV;
4790 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
4795 if (ckWARN_d(WARN_INTERNAL))
4796 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
4803 Perl_newAVREF(pTHX_ OP *o)
4805 if (o->op_type == OP_PADANY) {
4806 o->op_type = OP_PADAV;
4807 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4810 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
4811 && ckWARN(WARN_DEPRECATED)) {
4812 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4813 "Using an array as a reference is deprecated");
4815 return newUNOP(OP_RV2AV, 0, scalar(o));
4819 Perl_newGVREF(pTHX_ I32 type, OP *o)
4821 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
4822 return newUNOP(OP_NULL, 0, o);
4823 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
4827 Perl_newHVREF(pTHX_ OP *o)
4829 if (o->op_type == OP_PADANY) {
4830 o->op_type = OP_PADHV;
4831 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4834 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
4835 && ckWARN(WARN_DEPRECATED)) {
4836 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4837 "Using a hash as a reference is deprecated");
4839 return newUNOP(OP_RV2HV, 0, scalar(o));
4843 Perl_oopsCV(pTHX_ OP *o)
4845 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
4851 Perl_newCVREF(pTHX_ I32 flags, OP *o)
4853 return newUNOP(OP_RV2CV, flags, scalar(o));
4857 Perl_newSVREF(pTHX_ OP *o)
4859 if (o->op_type == OP_PADANY) {
4860 o->op_type = OP_PADSV;
4861 o->op_ppaddr = PL_ppaddr[OP_PADSV];
4864 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4865 o->op_flags |= OPpDONE_SVREF;
4868 return newUNOP(OP_RV2SV, 0, scalar(o));
4871 /* Check routines. See the comments at the top of this file for details
4872 * on when these are called */
4875 Perl_ck_anoncode(pTHX_ OP *o)
4877 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
4878 cSVOPo->op_sv = Nullsv;
4883 Perl_ck_bitop(pTHX_ OP *o)
4885 #define OP_IS_NUMCOMPARE(op) \
4886 ((op) == OP_LT || (op) == OP_I_LT || \
4887 (op) == OP_GT || (op) == OP_I_GT || \
4888 (op) == OP_LE || (op) == OP_I_LE || \
4889 (op) == OP_GE || (op) == OP_I_GE || \
4890 (op) == OP_EQ || (op) == OP_I_EQ || \
4891 (op) == OP_NE || (op) == OP_I_NE || \
4892 (op) == OP_NCMP || (op) == OP_I_NCMP)
4893 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4894 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
4895 && (o->op_type == OP_BIT_OR
4896 || o->op_type == OP_BIT_AND
4897 || o->op_type == OP_BIT_XOR))
4899 OP * left = cBINOPo->op_first;
4900 OP * right = left->op_sibling;
4901 if ((OP_IS_NUMCOMPARE(left->op_type) &&
4902 (left->op_flags & OPf_PARENS) == 0) ||
4903 (OP_IS_NUMCOMPARE(right->op_type) &&
4904 (right->op_flags & OPf_PARENS) == 0))
4905 if (ckWARN(WARN_PRECEDENCE))
4906 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4907 "Possible precedence problem on bitwise %c operator",
4908 o->op_type == OP_BIT_OR ? '|'
4909 : o->op_type == OP_BIT_AND ? '&' : '^'
4916 Perl_ck_concat(pTHX_ OP *o)
4918 OP *kid = cUNOPo->op_first;
4919 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
4920 !(kUNOP->op_first->op_flags & OPf_MOD))
4921 o->op_flags |= OPf_STACKED;
4926 Perl_ck_spair(pTHX_ OP *o)
4928 if (o->op_flags & OPf_KIDS) {
4931 OPCODE type = o->op_type;
4932 o = modkids(ck_fun(o), type);
4933 kid = cUNOPo->op_first;
4934 newop = kUNOP->op_first->op_sibling;
4936 (newop->op_sibling ||
4937 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
4938 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
4939 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
4943 op_free(kUNOP->op_first);
4944 kUNOP->op_first = newop;
4946 o->op_ppaddr = PL_ppaddr[++o->op_type];
4951 Perl_ck_delete(pTHX_ OP *o)
4955 if (o->op_flags & OPf_KIDS) {
4956 OP *kid = cUNOPo->op_first;
4957 switch (kid->op_type) {
4959 o->op_flags |= OPf_SPECIAL;
4962 o->op_private |= OPpSLICE;
4965 o->op_flags |= OPf_SPECIAL;
4970 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
4979 Perl_ck_die(pTHX_ OP *o)
4982 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4988 Perl_ck_eof(pTHX_ OP *o)
4990 I32 type = o->op_type;
4992 if (o->op_flags & OPf_KIDS) {
4993 if (cLISTOPo->op_first->op_type == OP_STUB) {
4995 o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
5003 Perl_ck_eval(pTHX_ OP *o)
5005 PL_hints |= HINT_BLOCK_SCOPE;
5006 if (o->op_flags & OPf_KIDS) {
5007 SVOP *kid = (SVOP*)cUNOPo->op_first;
5010 o->op_flags &= ~OPf_KIDS;
5013 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
5016 cUNOPo->op_first = 0;
5019 NewOp(1101, enter, 1, LOGOP);
5020 enter->op_type = OP_ENTERTRY;
5021 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5022 enter->op_private = 0;
5024 /* establish postfix order */
5025 enter->op_next = (OP*)enter;
5027 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5028 o->op_type = OP_LEAVETRY;
5029 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5030 enter->op_other = o;
5040 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5042 o->op_targ = (PADOFFSET)PL_hints;
5047 Perl_ck_exit(pTHX_ OP *o)
5050 HV *table = GvHV(PL_hintgv);
5052 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5053 if (svp && *svp && SvTRUE(*svp))
5054 o->op_private |= OPpEXIT_VMSISH;
5056 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5062 Perl_ck_exec(pTHX_ OP *o)
5065 if (o->op_flags & OPf_STACKED) {
5067 kid = cUNOPo->op_first->op_sibling;
5068 if (kid->op_type == OP_RV2GV)
5077 Perl_ck_exists(pTHX_ OP *o)
5080 if (o->op_flags & OPf_KIDS) {
5081 OP *kid = cUNOPo->op_first;
5082 if (kid->op_type == OP_ENTERSUB) {
5083 (void) ref(kid, o->op_type);
5084 if (kid->op_type != OP_RV2CV && !PL_error_count)
5085 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5087 o->op_private |= OPpEXISTS_SUB;
5089 else if (kid->op_type == OP_AELEM)
5090 o->op_flags |= OPf_SPECIAL;
5091 else if (kid->op_type != OP_HELEM)
5092 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5101 Perl_ck_gvconst(pTHX_ register OP *o)
5103 o = fold_constants(o);
5104 if (o->op_type == OP_CONST)
5111 Perl_ck_rvconst(pTHX_ register OP *o)
5113 SVOP *kid = (SVOP*)cUNOPo->op_first;
5115 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5116 if (kid->op_type == OP_CONST) {
5119 SV *kidsv = kid->op_sv;
5121 /* Is it a constant from cv_const_sv()? */
5122 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5123 SV *rsv = SvRV(kidsv);
5124 int svtype = SvTYPE(rsv);
5125 const char *badtype = Nullch;
5127 switch (o->op_type) {
5129 if (svtype > SVt_PVMG)
5130 badtype = "a SCALAR";
5133 if (svtype != SVt_PVAV)
5134 badtype = "an ARRAY";
5137 if (svtype != SVt_PVHV)
5141 if (svtype != SVt_PVCV)
5146 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5149 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5150 const char *badthing = Nullch;
5151 switch (o->op_type) {
5153 badthing = "a SCALAR";
5156 badthing = "an ARRAY";
5159 badthing = "a HASH";
5164 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
5168 * This is a little tricky. We only want to add the symbol if we
5169 * didn't add it in the lexer. Otherwise we get duplicate strict
5170 * warnings. But if we didn't add it in the lexer, we must at
5171 * least pretend like we wanted to add it even if it existed before,
5172 * or we get possible typo warnings. OPpCONST_ENTERED says
5173 * whether the lexer already added THIS instance of this symbol.
5175 iscv = (o->op_type == OP_RV2CV) * 2;
5177 gv = gv_fetchsv(kidsv,
5178 iscv | !(kid->op_private & OPpCONST_ENTERED),
5181 : o->op_type == OP_RV2SV
5183 : o->op_type == OP_RV2AV
5185 : o->op_type == OP_RV2HV
5188 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5190 kid->op_type = OP_GV;
5191 SvREFCNT_dec(kid->op_sv);
5193 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5194 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5195 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
5197 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
5199 kid->op_sv = SvREFCNT_inc(gv);
5201 kid->op_private = 0;
5202 kid->op_ppaddr = PL_ppaddr[OP_GV];
5209 Perl_ck_ftst(pTHX_ OP *o)
5211 I32 type = o->op_type;
5213 if (o->op_flags & OPf_REF) {
5216 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5217 SVOP *kid = (SVOP*)cUNOPo->op_first;
5219 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5220 OP *newop = newGVOP(type, OPf_REF,
5221 gv_fetchsv(kid->op_sv, TRUE, SVt_PVIO));
5227 if ((PL_hints & HINT_FILETEST_ACCESS) &&
5228 OP_IS_FILETEST_ACCESS(o))
5229 o->op_private |= OPpFT_ACCESS;
5231 if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
5232 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
5233 o->op_private |= OPpFT_STACKED;
5237 if (type == OP_FTTTY)
5238 o = newGVOP(type, OPf_REF, PL_stdingv);
5240 o = newUNOP(type, 0, newDEFSVOP());
5246 Perl_ck_fun(pTHX_ OP *o)
5252 int type = o->op_type;
5253 register I32 oa = PL_opargs[type] >> OASHIFT;
5255 if (o->op_flags & OPf_STACKED) {
5256 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5259 return no_fh_allowed(o);
5262 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 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5306 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVAV) ));
5307 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5308 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5309 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
5310 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5313 kid->op_sibling = sibl;
5316 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5317 bad_type(numargs, "array", PL_op_desc[type], kid);
5321 if (kid->op_type == OP_CONST &&
5322 (kid->op_private & OPpCONST_BARE))
5324 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5325 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVHV) ));
5326 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5327 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5328 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
5329 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5332 kid->op_sibling = sibl;
5335 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5336 bad_type(numargs, "hash", PL_op_desc[type], kid);
5341 OP *newop = newUNOP(OP_NULL, 0, kid);
5342 kid->op_sibling = 0;
5344 newop->op_next = newop;
5346 kid->op_sibling = sibl;
5351 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5352 if (kid->op_type == OP_CONST &&
5353 (kid->op_private & OPpCONST_BARE))
5355 OP *newop = newGVOP(OP_GV, 0,
5356 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVIO) );
5357 if (!(o->op_private & 1) && /* if not unop */
5358 kid == cLISTOPo->op_last)
5359 cLISTOPo->op_last = newop;
5363 else if (kid->op_type == OP_READLINE) {
5364 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5365 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5368 I32 flags = OPf_SPECIAL;
5372 /* is this op a FH constructor? */
5373 if (is_handle_constructor(o,numargs)) {
5374 const char *name = Nullch;
5378 /* Set a flag to tell rv2gv to vivify
5379 * need to "prove" flag does not mean something
5380 * else already - NI-S 1999/05/07
5383 if (kid->op_type == OP_PADSV) {
5384 name = PAD_COMPNAME_PV(kid->op_targ);
5385 /* SvCUR of a pad namesv can't be trusted
5386 * (see PL_generation), so calc its length
5392 else if (kid->op_type == OP_RV2SV
5393 && kUNOP->op_first->op_type == OP_GV)
5395 GV *gv = cGVOPx_gv(kUNOP->op_first);
5397 len = GvNAMELEN(gv);
5399 else if (kid->op_type == OP_AELEM
5400 || kid->op_type == OP_HELEM)
5405 if ((op = ((BINOP*)kid)->op_first)) {
5406 SV *tmpstr = Nullsv;
5408 kid->op_type == OP_AELEM ?
5410 if (((op->op_type == OP_RV2AV) ||
5411 (op->op_type == OP_RV2HV)) &&
5412 (op = ((UNOP*)op)->op_first) &&
5413 (op->op_type == OP_GV)) {
5414 /* packagevar $a[] or $h{} */
5415 GV *gv = cGVOPx_gv(op);
5423 else if (op->op_type == OP_PADAV
5424 || op->op_type == OP_PADHV) {
5425 /* lexicalvar $a[] or $h{} */
5427 PAD_COMPNAME_PV(op->op_targ);
5437 name = SvPV(tmpstr, len);
5442 name = "__ANONIO__";
5449 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5450 namesv = PAD_SVl(targ);
5451 (void)SvUPGRADE(namesv, SVt_PV);
5453 sv_setpvn(namesv, "$", 1);
5454 sv_catpvn(namesv, name, len);
5457 kid->op_sibling = 0;
5458 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5459 kid->op_targ = targ;
5460 kid->op_private |= priv;
5462 kid->op_sibling = sibl;
5468 mod(scalar(kid), type);
5472 tokid = &kid->op_sibling;
5473 kid = kid->op_sibling;
5475 o->op_private |= numargs;
5477 return too_many_arguments(o,OP_DESC(o));
5480 else if (PL_opargs[type] & OA_DEFGV) {
5482 return newUNOP(type, 0, newDEFSVOP());
5486 while (oa & OA_OPTIONAL)
5488 if (oa && oa != OA_LIST)
5489 return too_few_arguments(o,OP_DESC(o));
5495 Perl_ck_glob(pTHX_ OP *o)
5500 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5501 append_elem(OP_GLOB, o, newDEFSVOP());
5503 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5504 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5506 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5509 #if !defined(PERL_EXTERNAL_GLOB)
5510 /* XXX this can be tightened up and made more failsafe. */
5511 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5514 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5515 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5516 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5517 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5518 GvCV(gv) = GvCV(glob_gv);
5519 (void)SvREFCNT_inc((SV*)GvCV(gv));
5520 GvIMPORTED_CV_on(gv);
5523 #endif /* PERL_EXTERNAL_GLOB */
5525 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5526 append_elem(OP_GLOB, o,
5527 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5528 o->op_type = OP_LIST;
5529 o->op_ppaddr = PL_ppaddr[OP_LIST];
5530 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5531 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5532 cLISTOPo->op_first->op_targ = 0;
5533 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5534 append_elem(OP_LIST, o,
5535 scalar(newUNOP(OP_RV2CV, 0,
5536 newGVOP(OP_GV, 0, gv)))));
5537 o = newUNOP(OP_NULL, 0, ck_subr(o));
5538 o->op_targ = OP_GLOB; /* hint at what it used to be */
5541 gv = newGVgen("main");
5543 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5549 Perl_ck_grep(pTHX_ OP *o)
5553 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5556 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5557 NewOp(1101, gwop, 1, LOGOP);
5559 if (o->op_flags & OPf_STACKED) {
5562 kid = cLISTOPo->op_first->op_sibling;
5563 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
5566 kid->op_next = (OP*)gwop;
5567 o->op_flags &= ~OPf_STACKED;
5569 kid = cLISTOPo->op_first->op_sibling;
5570 if (type == OP_MAPWHILE)
5577 kid = cLISTOPo->op_first->op_sibling;
5578 if (kid->op_type != OP_NULL)
5579 Perl_croak(aTHX_ "panic: ck_grep");
5580 kid = kUNOP->op_first;
5582 gwop->op_type = type;
5583 gwop->op_ppaddr = PL_ppaddr[type];
5584 gwop->op_first = listkids(o);
5585 gwop->op_flags |= OPf_KIDS;
5586 gwop->op_other = LINKLIST(kid);
5587 kid->op_next = (OP*)gwop;
5588 offset = pad_findmy("$_");
5589 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
5590 o->op_private = gwop->op_private = 0;
5591 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5594 o->op_private = gwop->op_private = OPpGREP_LEX;
5595 gwop->op_targ = o->op_targ = offset;
5598 kid = cLISTOPo->op_first->op_sibling;
5599 if (!kid || !kid->op_sibling)
5600 return too_few_arguments(o,OP_DESC(o));
5601 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5602 mod(kid, OP_GREPSTART);
5608 Perl_ck_index(pTHX_ OP *o)
5610 if (o->op_flags & OPf_KIDS) {
5611 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5613 kid = kid->op_sibling; /* get past "big" */
5614 if (kid && kid->op_type == OP_CONST)
5615 fbm_compile(((SVOP*)kid)->op_sv, 0);
5621 Perl_ck_lengthconst(pTHX_ OP *o)
5623 /* XXX length optimization goes here */
5628 Perl_ck_lfun(pTHX_ OP *o)
5630 OPCODE type = o->op_type;
5631 return modkids(ck_fun(o), type);
5635 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5637 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5638 switch (cUNOPo->op_first->op_type) {
5640 /* This is needed for
5641 if (defined %stash::)
5642 to work. Do not break Tk.
5644 break; /* Globals via GV can be undef */
5646 case OP_AASSIGN: /* Is this a good idea? */
5647 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5648 "defined(@array) is deprecated");
5649 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5650 "\t(Maybe you should just omit the defined()?)\n");
5653 /* This is needed for
5654 if (defined %stash::)
5655 to work. Do not break Tk.
5657 break; /* Globals via GV can be undef */
5659 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5660 "defined(%%hash) is deprecated");
5661 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5662 "\t(Maybe you should just omit the defined()?)\n");
5673 Perl_ck_rfun(pTHX_ OP *o)
5675 OPCODE type = o->op_type;
5676 return refkids(ck_fun(o), type);
5680 Perl_ck_listiob(pTHX_ OP *o)
5684 kid = cLISTOPo->op_first;
5687 kid = cLISTOPo->op_first;
5689 if (kid->op_type == OP_PUSHMARK)
5690 kid = kid->op_sibling;
5691 if (kid && o->op_flags & OPf_STACKED)
5692 kid = kid->op_sibling;
5693 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5694 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5695 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5696 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5697 cLISTOPo->op_first->op_sibling = kid;
5698 cLISTOPo->op_last = kid;
5699 kid = kid->op_sibling;
5704 append_elem(o->op_type, o, newDEFSVOP());
5710 Perl_ck_sassign(pTHX_ OP *o)
5712 OP *kid = cLISTOPo->op_first;
5713 /* has a disposable target? */
5714 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5715 && !(kid->op_flags & OPf_STACKED)
5716 /* Cannot steal the second time! */
5717 && !(kid->op_private & OPpTARGET_MY))
5719 OP *kkid = kid->op_sibling;
5721 /* Can just relocate the target. */
5722 if (kkid && kkid->op_type == OP_PADSV
5723 && !(kkid->op_private & OPpLVAL_INTRO))
5725 kid->op_targ = kkid->op_targ;
5727 /* Now we do not need PADSV and SASSIGN. */
5728 kid->op_sibling = o->op_sibling; /* NULL */
5729 cLISTOPo->op_first = NULL;
5732 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
5736 /* optimise C<my $x = undef> to C<my $x> */
5737 if (kid->op_type == OP_UNDEF) {
5738 OP *kkid = kid->op_sibling;
5739 if (kkid && kkid->op_type == OP_PADSV
5740 && (kkid->op_private & OPpLVAL_INTRO))
5742 cLISTOPo->op_first = NULL;
5743 kid->op_sibling = NULL;
5753 Perl_ck_match(pTHX_ OP *o)
5755 if (o->op_type != OP_QR) {
5756 I32 offset = pad_findmy("$_");
5757 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS(offset) & SVpad_OUR)) {
5758 o->op_targ = offset;
5759 o->op_private |= OPpTARGET_MY;
5762 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
5763 o->op_private |= OPpRUNTIME;
5768 Perl_ck_method(pTHX_ OP *o)
5770 OP *kid = cUNOPo->op_first;
5771 if (kid->op_type == OP_CONST) {
5772 SV* sv = kSVOP->op_sv;
5773 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
5775 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5776 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
5779 kSVOP->op_sv = Nullsv;
5781 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5790 Perl_ck_null(pTHX_ OP *o)
5796 Perl_ck_open(pTHX_ OP *o)
5798 HV *table = GvHV(PL_hintgv);
5802 svp = hv_fetch(table, "open_IN", 7, FALSE);
5804 mode = mode_from_discipline(*svp);
5805 if (mode & O_BINARY)
5806 o->op_private |= OPpOPEN_IN_RAW;
5807 else if (mode & O_TEXT)
5808 o->op_private |= OPpOPEN_IN_CRLF;
5811 svp = hv_fetch(table, "open_OUT", 8, FALSE);
5813 mode = mode_from_discipline(*svp);
5814 if (mode & O_BINARY)
5815 o->op_private |= OPpOPEN_OUT_RAW;
5816 else if (mode & O_TEXT)
5817 o->op_private |= OPpOPEN_OUT_CRLF;
5820 if (o->op_type == OP_BACKTICK)
5823 /* In case of three-arg dup open remove strictness
5824 * from the last arg if it is a bareword. */
5825 OP *first = cLISTOPx(o)->op_first; /* The pushmark. */
5826 OP *last = cLISTOPx(o)->op_last; /* The bareword. */
5830 if ((last->op_type == OP_CONST) && /* The bareword. */
5831 (last->op_private & OPpCONST_BARE) &&
5832 (last->op_private & OPpCONST_STRICT) &&
5833 (oa = first->op_sibling) && /* The fh. */
5834 (oa = oa->op_sibling) && /* The mode. */
5835 SvPOK(((SVOP*)oa)->op_sv) &&
5836 (mode = SvPVX(((SVOP*)oa)->op_sv)) &&
5837 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
5838 (last == oa->op_sibling)) /* The bareword. */
5839 last->op_private &= ~OPpCONST_STRICT;
5845 Perl_ck_repeat(pTHX_ OP *o)
5847 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5848 o->op_private |= OPpREPEAT_DOLIST;
5849 cBINOPo->op_first = force_list(cBINOPo->op_first);
5857 Perl_ck_require(pTHX_ OP *o)
5861 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
5862 SVOP *kid = (SVOP*)cUNOPo->op_first;
5864 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5866 for (s = SvPVX(kid->op_sv); *s; s++) {
5867 if (*s == ':' && s[1] == ':') {
5869 Move(s+2, s+1, strlen(s+2)+1, char);
5870 --SvCUR(kid->op_sv);
5873 if (SvREADONLY(kid->op_sv)) {
5874 SvREADONLY_off(kid->op_sv);
5875 sv_catpvn(kid->op_sv, ".pm", 3);
5876 SvREADONLY_on(kid->op_sv);
5879 sv_catpvn(kid->op_sv, ".pm", 3);
5883 /* handle override, if any */
5884 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
5885 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
5886 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
5888 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5889 OP *kid = cUNOPo->op_first;
5890 cUNOPo->op_first = 0;
5892 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5893 append_elem(OP_LIST, kid,
5894 scalar(newUNOP(OP_RV2CV, 0,
5903 Perl_ck_return(pTHX_ OP *o)
5906 if (CvLVALUE(PL_compcv)) {
5907 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5908 mod(kid, OP_LEAVESUBLV);
5915 Perl_ck_retarget(pTHX_ OP *o)
5917 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5924 Perl_ck_select(pTHX_ OP *o)
5927 if (o->op_flags & OPf_KIDS) {
5928 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5929 if (kid && kid->op_sibling) {
5930 o->op_type = OP_SSELECT;
5931 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
5933 return fold_constants(o);
5937 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5938 if (kid && kid->op_type == OP_RV2GV)
5939 kid->op_private &= ~HINT_STRICT_REFS;
5944 Perl_ck_shift(pTHX_ OP *o)
5946 I32 type = o->op_type;
5948 if (!(o->op_flags & OPf_KIDS)) {
5952 argop = newUNOP(OP_RV2AV, 0,
5953 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
5954 return newUNOP(type, 0, scalar(argop));
5956 return scalar(modkids(ck_fun(o), type));
5960 Perl_ck_sort(pTHX_ OP *o)
5964 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
5966 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5967 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
5969 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
5971 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
5973 if (kid->op_type == OP_SCOPE) {
5977 else if (kid->op_type == OP_LEAVE) {
5978 if (o->op_type == OP_SORT) {
5979 op_null(kid); /* wipe out leave */
5982 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
5983 if (k->op_next == kid)
5985 /* don't descend into loops */
5986 else if (k->op_type == OP_ENTERLOOP
5987 || k->op_type == OP_ENTERITER)
5989 k = cLOOPx(k)->op_lastop;
5994 kid->op_next = 0; /* just disconnect the leave */
5995 k = kLISTOP->op_first;
6000 if (o->op_type == OP_SORT) {
6001 /* provide scalar context for comparison function/block */
6007 o->op_flags |= OPf_SPECIAL;
6009 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6012 firstkid = firstkid->op_sibling;
6015 /* provide list context for arguments */
6016 if (o->op_type == OP_SORT)
6023 S_simplify_sort(pTHX_ OP *o)
6025 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6030 if (!(o->op_flags & OPf_STACKED))
6032 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6033 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6034 kid = kUNOP->op_first; /* get past null */
6035 if (kid->op_type != OP_SCOPE)
6037 kid = kLISTOP->op_last; /* get past scope */
6038 switch(kid->op_type) {
6046 k = kid; /* remember this node*/
6047 if (kBINOP->op_first->op_type != OP_RV2SV)
6049 kid = kBINOP->op_first; /* get past cmp */
6050 if (kUNOP->op_first->op_type != OP_GV)
6052 kid = kUNOP->op_first; /* get past rv2sv */
6054 if (GvSTASH(gv) != PL_curstash)
6056 gvname = GvNAME(gv);
6057 if (*gvname == 'a' && gvname[1] == '\0')
6059 else if (*gvname == 'b' && gvname[1] == '\0')
6064 kid = k; /* back to cmp */
6065 if (kBINOP->op_last->op_type != OP_RV2SV)
6067 kid = kBINOP->op_last; /* down to 2nd arg */
6068 if (kUNOP->op_first->op_type != OP_GV)
6070 kid = kUNOP->op_first; /* get past rv2sv */
6072 if (GvSTASH(gv) != PL_curstash)
6074 gvname = GvNAME(gv);
6076 ? !(*gvname == 'a' && gvname[1] == '\0')
6077 : !(*gvname == 'b' && gvname[1] == '\0'))
6079 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6081 o->op_private |= OPpSORT_DESCEND;
6082 if (k->op_type == OP_NCMP)
6083 o->op_private |= OPpSORT_NUMERIC;
6084 if (k->op_type == OP_I_NCMP)
6085 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6086 kid = cLISTOPo->op_first->op_sibling;
6087 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6088 op_free(kid); /* then delete it */
6092 Perl_ck_split(pTHX_ OP *o)
6096 if (o->op_flags & OPf_STACKED)
6097 return no_fh_allowed(o);
6099 kid = cLISTOPo->op_first;
6100 if (kid->op_type != OP_NULL)
6101 Perl_croak(aTHX_ "panic: ck_split");
6102 kid = kid->op_sibling;
6103 op_free(cLISTOPo->op_first);
6104 cLISTOPo->op_first = kid;
6106 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6107 cLISTOPo->op_last = kid; /* There was only one element previously */
6110 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6111 OP *sibl = kid->op_sibling;
6112 kid->op_sibling = 0;
6113 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
6114 if (cLISTOPo->op_first == cLISTOPo->op_last)
6115 cLISTOPo->op_last = kid;
6116 cLISTOPo->op_first = kid;
6117 kid->op_sibling = sibl;
6120 kid->op_type = OP_PUSHRE;
6121 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6123 if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
6124 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
6125 "Use of /g modifier is meaningless in split");
6128 if (!kid->op_sibling)
6129 append_elem(OP_SPLIT, o, newDEFSVOP());
6131 kid = kid->op_sibling;
6134 if (!kid->op_sibling)
6135 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6137 kid = kid->op_sibling;
6140 if (kid->op_sibling)
6141 return too_many_arguments(o,OP_DESC(o));
6147 Perl_ck_join(pTHX_ OP *o)
6149 if (ckWARN(WARN_SYNTAX)) {
6150 OP *kid = cLISTOPo->op_first->op_sibling;
6151 if (kid && kid->op_type == OP_MATCH) {
6152 const char *pmstr = "STRING";
6153 if (PM_GETRE(kPMOP))
6154 pmstr = PM_GETRE(kPMOP)->precomp;
6155 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6156 "/%s/ should probably be written as \"%s\"",
6164 Perl_ck_subr(pTHX_ OP *o)
6166 OP *prev = ((cUNOPo->op_first->op_sibling)
6167 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6168 OP *o2 = prev->op_sibling;
6175 I32 contextclass = 0;
6180 o->op_private |= OPpENTERSUB_HASTARG;
6181 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6182 if (cvop->op_type == OP_RV2CV) {
6184 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6185 op_null(cvop); /* disable rv2cv */
6186 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6187 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6188 GV *gv = cGVOPx_gv(tmpop);
6191 tmpop->op_private |= OPpEARLY_CV;
6194 namegv = CvANON(cv) ? gv : CvGV(cv);
6195 proto = SvPV((SV*)cv, n_a);
6197 if (CvASSERTION(cv)) {
6198 if (PL_hints & HINT_ASSERTING) {
6199 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
6200 o->op_private |= OPpENTERSUB_DB;
6204 if (ckWARN(WARN_ASSERTIONS) && !(PL_hints & HINT_ASSERTIONSSEEN)) {
6205 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
6206 "Impossible to activate assertion call");
6213 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6214 if (o2->op_type == OP_CONST)
6215 o2->op_private &= ~OPpCONST_STRICT;
6216 else if (o2->op_type == OP_LIST) {
6217 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6218 if (o && o->op_type == OP_CONST)
6219 o->op_private &= ~OPpCONST_STRICT;
6222 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6223 if (PERLDB_SUB && PL_curstash != PL_debstash)
6224 o->op_private |= OPpENTERSUB_DB;
6225 while (o2 != cvop) {
6229 return too_many_arguments(o, gv_ename(namegv));
6247 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6249 arg == 1 ? "block or sub {}" : "sub {}",
6250 gv_ename(namegv), o2);
6253 /* '*' allows any scalar type, including bareword */
6256 if (o2->op_type == OP_RV2GV)
6257 goto wrapref; /* autoconvert GLOB -> GLOBref */
6258 else if (o2->op_type == OP_CONST)
6259 o2->op_private &= ~OPpCONST_STRICT;
6260 else if (o2->op_type == OP_ENTERSUB) {
6261 /* accidental subroutine, revert to bareword */
6262 OP *gvop = ((UNOP*)o2)->op_first;
6263 if (gvop && gvop->op_type == OP_NULL) {
6264 gvop = ((UNOP*)gvop)->op_first;
6266 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6269 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6270 (gvop = ((UNOP*)gvop)->op_first) &&
6271 gvop->op_type == OP_GV)
6273 GV *gv = cGVOPx_gv(gvop);
6274 OP *sibling = o2->op_sibling;
6275 SV *n = newSVpvn("",0);
6277 gv_fullname4(n, gv, "", FALSE);
6278 o2 = newSVOP(OP_CONST, 0, n);
6279 prev->op_sibling = o2;
6280 o2->op_sibling = sibling;
6296 if (contextclass++ == 0) {
6297 e = strchr(proto, ']');
6298 if (!e || e == proto)
6311 while (*--p != '[');
6312 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6313 gv_ename(namegv), o2);
6319 if (o2->op_type == OP_RV2GV)
6322 bad_type(arg, "symbol", gv_ename(namegv), o2);
6325 if (o2->op_type == OP_ENTERSUB)
6328 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6331 if (o2->op_type == OP_RV2SV ||
6332 o2->op_type == OP_PADSV ||
6333 o2->op_type == OP_HELEM ||
6334 o2->op_type == OP_AELEM ||
6335 o2->op_type == OP_THREADSV)
6338 bad_type(arg, "scalar", gv_ename(namegv), o2);
6341 if (o2->op_type == OP_RV2AV ||
6342 o2->op_type == OP_PADAV)
6345 bad_type(arg, "array", gv_ename(namegv), o2);
6348 if (o2->op_type == OP_RV2HV ||
6349 o2->op_type == OP_PADHV)
6352 bad_type(arg, "hash", gv_ename(namegv), o2);
6357 OP* sib = kid->op_sibling;
6358 kid->op_sibling = 0;
6359 o2 = newUNOP(OP_REFGEN, 0, kid);
6360 o2->op_sibling = sib;
6361 prev->op_sibling = o2;
6363 if (contextclass && e) {
6378 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6379 gv_ename(namegv), cv);
6384 mod(o2, OP_ENTERSUB);
6386 o2 = o2->op_sibling;
6388 if (proto && !optional &&
6389 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6390 return too_few_arguments(o, gv_ename(namegv));
6393 o=newSVOP(OP_CONST, 0, newSViv(0));
6399 Perl_ck_svconst(pTHX_ OP *o)
6401 SvREADONLY_on(cSVOPo->op_sv);
6406 Perl_ck_trunc(pTHX_ OP *o)
6408 if (o->op_flags & OPf_KIDS) {
6409 SVOP *kid = (SVOP*)cUNOPo->op_first;
6411 if (kid->op_type == OP_NULL)
6412 kid = (SVOP*)kid->op_sibling;
6413 if (kid && kid->op_type == OP_CONST &&
6414 (kid->op_private & OPpCONST_BARE))
6416 o->op_flags |= OPf_SPECIAL;
6417 kid->op_private &= ~OPpCONST_STRICT;
6424 Perl_ck_unpack(pTHX_ OP *o)
6426 OP *kid = cLISTOPo->op_first;
6427 if (kid->op_sibling) {
6428 kid = kid->op_sibling;
6429 if (!kid->op_sibling)
6430 kid->op_sibling = newDEFSVOP();
6436 Perl_ck_substr(pTHX_ OP *o)
6439 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6440 OP *kid = cLISTOPo->op_first;
6442 if (kid->op_type == OP_NULL)
6443 kid = kid->op_sibling;
6445 kid->op_flags |= OPf_MOD;
6451 /* A peephole optimizer. We visit the ops in the order they're to execute.
6452 * See the comments at the top of this file for more details about when
6453 * peep() is called */
6456 Perl_peep(pTHX_ register OP *o)
6458 register OP* oldop = 0;
6460 if (!o || o->op_opt)
6464 SAVEVPTR(PL_curcop);
6465 for (; o; o = o->op_next) {
6469 switch (o->op_type) {
6473 PL_curcop = ((COP*)o); /* for warnings */
6478 if (cSVOPo->op_private & OPpCONST_STRICT)
6479 no_bareword_allowed(o);
6481 case OP_METHOD_NAMED:
6482 /* Relocate sv to the pad for thread safety.
6483 * Despite being a "constant", the SV is written to,
6484 * for reference counts, sv_upgrade() etc. */
6486 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6487 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6488 /* If op_sv is already a PADTMP then it is being used by
6489 * some pad, so make a copy. */
6490 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6491 SvREADONLY_on(PAD_SVl(ix));
6492 SvREFCNT_dec(cSVOPo->op_sv);
6495 SvREFCNT_dec(PAD_SVl(ix));
6496 SvPADTMP_on(cSVOPo->op_sv);
6497 PAD_SETSV(ix, cSVOPo->op_sv);
6498 /* XXX I don't know how this isn't readonly already. */
6499 SvREADONLY_on(PAD_SVl(ix));
6501 cSVOPo->op_sv = Nullsv;
6509 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6510 if (o->op_next->op_private & OPpTARGET_MY) {
6511 if (o->op_flags & OPf_STACKED) /* chained concats */
6512 goto ignore_optimization;
6514 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6515 o->op_targ = o->op_next->op_targ;
6516 o->op_next->op_targ = 0;
6517 o->op_private |= OPpTARGET_MY;
6520 op_null(o->op_next);
6522 ignore_optimization:
6526 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6528 break; /* Scalar stub must produce undef. List stub is noop */
6532 if (o->op_targ == OP_NEXTSTATE
6533 || o->op_targ == OP_DBSTATE
6534 || o->op_targ == OP_SETSTATE)
6536 PL_curcop = ((COP*)o);
6538 /* XXX: We avoid setting op_seq here to prevent later calls
6539 to peep() from mistakenly concluding that optimisation
6540 has already occurred. This doesn't fix the real problem,
6541 though (See 20010220.007). AMS 20010719 */
6542 /* op_seq functionality is now replaced by op_opt */
6543 if (oldop && o->op_next) {
6544 oldop->op_next = o->op_next;
6552 if (oldop && o->op_next) {
6553 oldop->op_next = o->op_next;
6561 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
6562 OP* pop = (o->op_type == OP_PADAV) ?
6563 o->op_next : o->op_next->op_next;
6565 if (pop && pop->op_type == OP_CONST &&
6566 ((PL_op = pop->op_next)) &&
6567 pop->op_next->op_type == OP_AELEM &&
6568 !(pop->op_next->op_private &
6569 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6570 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6575 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
6576 no_bareword_allowed(pop);
6577 if (o->op_type == OP_GV)
6578 op_null(o->op_next);
6579 op_null(pop->op_next);
6581 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6582 o->op_next = pop->op_next->op_next;
6583 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6584 o->op_private = (U8)i;
6585 if (o->op_type == OP_GV) {
6590 o->op_flags |= OPf_SPECIAL;
6591 o->op_type = OP_AELEMFAST;
6597 if (o->op_next->op_type == OP_RV2SV) {
6598 if (!(o->op_next->op_private & OPpDEREF)) {
6599 op_null(o->op_next);
6600 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6602 o->op_next = o->op_next->op_next;
6603 o->op_type = OP_GVSV;
6604 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6607 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6609 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6610 /* XXX could check prototype here instead of just carping */
6611 SV *sv = sv_newmortal();
6612 gv_efullname3(sv, gv, Nullch);
6613 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6614 "%"SVf"() called too early to check prototype",
6618 else if (o->op_next->op_type == OP_READLINE
6619 && o->op_next->op_next->op_type == OP_CONCAT
6620 && (o->op_next->op_next->op_flags & OPf_STACKED))
6622 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6623 o->op_type = OP_RCATLINE;
6624 o->op_flags |= OPf_STACKED;
6625 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6626 op_null(o->op_next->op_next);
6627 op_null(o->op_next);
6644 while (cLOGOP->op_other->op_type == OP_NULL)
6645 cLOGOP->op_other = cLOGOP->op_other->op_next;
6646 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6652 while (cLOOP->op_redoop->op_type == OP_NULL)
6653 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6654 peep(cLOOP->op_redoop);
6655 while (cLOOP->op_nextop->op_type == OP_NULL)
6656 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6657 peep(cLOOP->op_nextop);
6658 while (cLOOP->op_lastop->op_type == OP_NULL)
6659 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6660 peep(cLOOP->op_lastop);
6667 while (cPMOP->op_pmreplstart &&
6668 cPMOP->op_pmreplstart->op_type == OP_NULL)
6669 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6670 peep(cPMOP->op_pmreplstart);
6675 if (ckWARN(WARN_SYNTAX) && o->op_next
6676 && o->op_next->op_type == OP_NEXTSTATE) {
6677 if (o->op_next->op_sibling &&
6678 o->op_next->op_sibling->op_type != OP_EXIT &&
6679 o->op_next->op_sibling->op_type != OP_WARN &&
6680 o->op_next->op_sibling->op_type != OP_DIE) {
6681 line_t oldline = CopLINE(PL_curcop);
6683 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6684 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6685 "Statement unlikely to be reached");
6686 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6687 "\t(Maybe you meant system() when you said exec()?)\n");
6688 CopLINE_set(PL_curcop, oldline);
6703 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6706 /* Make the CONST have a shared SV */
6707 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6708 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6709 key = SvPV(sv, keylen);
6710 lexname = newSVpvn_share(key,
6711 SvUTF8(sv) ? -(I32)keylen : keylen,
6717 if ((o->op_private & (OPpLVAL_INTRO)))
6720 rop = (UNOP*)((BINOP*)o)->op_first;
6721 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6723 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6724 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6726 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6727 if (!fields || !GvHV(*fields))
6729 key = SvPV(*svp, keylen);
6730 if (!hv_fetch(GvHV(*fields), key,
6731 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
6733 Perl_croak(aTHX_ "No such class field \"%s\" "
6734 "in variable %s of type %s",
6735 key, SvPV_nolen(lexname), HvNAME(SvSTASH(lexname)));
6748 SVOP *first_key_op, *key_op;
6750 if ((o->op_private & (OPpLVAL_INTRO))
6751 /* I bet there's always a pushmark... */
6752 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6753 /* hmmm, no optimization if list contains only one key. */
6755 rop = (UNOP*)((LISTOP*)o)->op_last;
6756 if (rop->op_type != OP_RV2HV)
6758 if (rop->op_first->op_type == OP_PADSV)
6759 /* @$hash{qw(keys here)} */
6760 rop = (UNOP*)rop->op_first;
6762 /* @{$hash}{qw(keys here)} */
6763 if (rop->op_first->op_type == OP_SCOPE
6764 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
6766 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
6772 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
6773 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6775 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6776 if (!fields || !GvHV(*fields))
6778 /* Again guessing that the pushmark can be jumped over.... */
6779 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
6780 ->op_first->op_sibling;
6781 for (key_op = first_key_op; key_op;
6782 key_op = (SVOP*)key_op->op_sibling) {
6783 if (key_op->op_type != OP_CONST)
6785 svp = cSVOPx_svp(key_op);
6786 key = SvPV(*svp, keylen);
6787 if (!hv_fetch(GvHV(*fields), key,
6788 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
6790 Perl_croak(aTHX_ "No such class field \"%s\" "
6791 "in variable %s of type %s",
6792 key, SvPV_nolen(lexname), HvNAME(SvSTASH(lexname)));
6799 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
6803 /* check that RHS of sort is a single plain array */
6804 oright = cUNOPo->op_first;
6805 if (!oright || oright->op_type != OP_PUSHMARK)
6808 /* reverse sort ... can be optimised. */
6809 if (!cUNOPo->op_sibling) {
6810 /* Nothing follows us on the list. */
6811 OP *reverse = o->op_next;
6813 if (reverse->op_type == OP_REVERSE &&
6814 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
6815 OP *pushmark = cUNOPx(reverse)->op_first;
6816 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
6817 && (cUNOPx(pushmark)->op_sibling == o)) {
6818 /* reverse -> pushmark -> sort */
6819 o->op_private |= OPpSORT_REVERSE;
6821 pushmark->op_next = oright->op_next;
6827 /* make @a = sort @a act in-place */
6831 oright = cUNOPx(oright)->op_sibling;
6834 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
6835 oright = cUNOPx(oright)->op_sibling;
6839 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
6840 || oright->op_next != o
6841 || (oright->op_private & OPpLVAL_INTRO)
6845 /* o2 follows the chain of op_nexts through the LHS of the
6846 * assign (if any) to the aassign op itself */
6848 if (!o2 || o2->op_type != OP_NULL)
6851 if (!o2 || o2->op_type != OP_PUSHMARK)
6854 if (o2 && o2->op_type == OP_GV)
6857 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
6858 || (o2->op_private & OPpLVAL_INTRO)
6863 if (!o2 || o2->op_type != OP_NULL)
6866 if (!o2 || o2->op_type != OP_AASSIGN
6867 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
6870 /* check that the sort is the first arg on RHS of assign */
6872 o2 = cUNOPx(o2)->op_first;
6873 if (!o2 || o2->op_type != OP_NULL)
6875 o2 = cUNOPx(o2)->op_first;
6876 if (!o2 || o2->op_type != OP_PUSHMARK)
6878 if (o2->op_sibling != o)
6881 /* check the array is the same on both sides */
6882 if (oleft->op_type == OP_RV2AV) {
6883 if (oright->op_type != OP_RV2AV
6884 || !cUNOPx(oright)->op_first
6885 || cUNOPx(oright)->op_first->op_type != OP_GV
6886 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
6887 cGVOPx_gv(cUNOPx(oright)->op_first)
6891 else if (oright->op_type != OP_PADAV
6892 || oright->op_targ != oleft->op_targ
6896 /* transfer MODishness etc from LHS arg to RHS arg */
6897 oright->op_flags = oleft->op_flags;
6898 o->op_private |= OPpSORT_INPLACE;
6900 /* excise push->gv->rv2av->null->aassign */
6901 o2 = o->op_next->op_next;
6902 op_null(o2); /* PUSHMARK */
6904 if (o2->op_type == OP_GV) {
6905 op_null(o2); /* GV */
6908 op_null(o2); /* RV2AV or PADAV */
6909 o2 = o2->op_next->op_next;
6910 op_null(o2); /* AASSIGN */
6912 o->op_next = o2->op_next;
6918 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
6920 LISTOP *enter, *exlist;
6923 enter = (LISTOP *) o->op_next;
6926 if (enter->op_type == OP_NULL) {
6927 enter = (LISTOP *) enter->op_next;
6931 /* for $a (...) will have OP_GV then OP_RV2GV here.
6932 for (...) just has an OP_GV. */
6933 if (enter->op_type == OP_GV) {
6934 gvop = (OP *) enter;
6935 enter = (LISTOP *) enter->op_next;
6938 if (enter->op_type == OP_RV2GV) {
6939 enter = (LISTOP *) enter->op_next;
6945 if (enter->op_type != OP_ENTERITER)
6948 iter = enter->op_next;
6949 if (!iter || iter->op_type != OP_ITER)
6952 expushmark = enter->op_first;
6953 if (!expushmark || expushmark->op_type != OP_NULL
6954 || expushmark->op_targ != OP_PUSHMARK)
6957 exlist = (LISTOP *) expushmark->op_sibling;
6958 if (!exlist || exlist->op_type != OP_NULL
6959 || exlist->op_targ != OP_LIST)
6962 if (exlist->op_last != o) {
6963 /* Mmm. Was expecting to point back to this op. */
6966 theirmark = exlist->op_first;
6967 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
6970 if (theirmark->op_sibling != o) {
6971 /* There's something between the mark and the reverse, eg
6972 for (1, reverse (...))
6977 ourmark = ((LISTOP *)o)->op_first;
6978 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
6981 ourlast = ((LISTOP *)o)->op_last;
6982 if (!ourlast || ourlast->op_next != o)
6985 rv2av = ourmark->op_sibling;
6986 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
6987 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
6988 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
6989 /* We're just reversing a single array. */
6990 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
6991 enter->op_flags |= OPf_STACKED;
6994 /* We don't have control over who points to theirmark, so sacrifice
6996 theirmark->op_next = ourmark->op_next;
6997 theirmark->op_flags = ourmark->op_flags;
6998 ourlast->op_next = gvop ? gvop : (OP *) enter;
7001 enter->op_private |= OPpITER_REVERSED;
7002 iter->op_private |= OPpITER_REVERSED;
7018 const char* Perl_custom_op_name(pTHX_ const OP* o)
7020 const IV index = PTR2IV(o->op_ppaddr);
7024 if (!PL_custom_op_names) /* This probably shouldn't happen */
7025 return PL_op_name[OP_CUSTOM];
7027 keysv = sv_2mortal(newSViv(index));
7029 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7031 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7033 return SvPV_nolen(HeVAL(he));
7036 const char* Perl_custom_op_desc(pTHX_ const OP* o)
7038 const IV index = PTR2IV(o->op_ppaddr);
7042 if (!PL_custom_op_descs)
7043 return PL_op_desc[OP_CUSTOM];
7045 keysv = sv_2mortal(newSViv(index));
7047 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7049 return PL_op_desc[OP_CUSTOM];
7051 return SvPV_nolen(HeVAL(he));
7057 /* Efficient sub that returns a constant scalar value. */
7059 const_sv_xsub(pTHX_ CV* cv)
7064 Perl_croak(aTHX_ "usage: %s::%s()",
7065 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7069 ST(0) = (SV*)XSANY.any_ptr;