3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
13 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
14 * youngest of the Old Took's daughters); and Mr. Drogo was his second
15 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
16 * either way, as the saying is, if you follow me." --the Gaffer
19 /* This file contains the functions that create, manipulate and optimize
20 * the OP structures that hold a compiled perl program.
22 * A Perl program is compiled into a tree of OPs. Each op contains
23 * structural pointers (eg to its siblings and the next op in the
24 * execution sequence), a pointer to the function that would execute the
25 * op, plus any data specific to that op. For example, an OP_CONST op
26 * points to the pp_const() function and to an SV containing the constant
27 * value. When pp_const() is executed, its job is to push that SV onto the
30 * OPs are mainly created by the newFOO() functions, which are mainly
31 * called from the parser (in perly.y) as the code is parsed. For example
32 * the Perl code $a + $b * $c would cause the equivalent of the following
33 * to be called (oversimplifying a bit):
35 * newBINOP(OP_ADD, flags,
37 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
40 * Note that during the build of miniperl, a temporary copy of this file
41 * is made, called opmini.c.
45 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
49 An execution-order pass
51 The bottom-up pass is represented by all the "newOP" routines and
52 the ck_ routines. The bottom-upness is actually driven by yacc.
53 So at the point that a ck_ routine fires, we have no idea what the
54 context is, either upward in the syntax tree, or either forward or
55 backward in the execution order. (The bottom-up parser builds that
56 part of the execution order it knows about, but if you follow the "next"
57 links around, you'll find it's actually a closed loop through the
60 Whenever the bottom-up parser gets to a node that supplies context to
61 its components, it invokes that portion of the top-down pass that applies
62 to that part of the subtree (and marks the top node as processed, so
63 if a node further up supplies context, it doesn't have to take the
64 plunge again). As a particular subcase of this, as the new node is
65 built, it takes all the closed execution loops of its subcomponents
66 and links them into a new closed loop for the higher level node. But
67 it's still not the real execution order.
69 The actual execution order is not known till we get a grammar reduction
70 to a top-level unit like a subroutine or file that will be called by
71 "name" rather than via a "next" pointer. At that point, we can call
72 into peep() to do that code's portion of the 3rd pass. It has to be
73 recursive, but it's recursive on basic blocks, not on tree nodes.
81 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
83 #if defined(PL_OP_SLAB_ALLOC)
85 #ifndef PERL_SLAB_SIZE
86 #define PERL_SLAB_SIZE 2048
90 Perl_Slab_Alloc(pTHX_ int m, size_t sz)
93 * To make incrementing use count easy PL_OpSlab is an I32 *
94 * To make inserting the link to slab PL_OpPtr is I32 **
95 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
96 * Add an overhead for pointer to slab and round up as a number of pointers
98 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
99 if ((PL_OpSpace -= sz) < 0) {
100 PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*));
104 Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **);
105 /* We reserve the 0'th I32 sized chunk as a use count */
106 PL_OpSlab = (I32 *) PL_OpPtr;
107 /* Reduce size by the use count word, and by the size we need.
108 * Latter is to mimic the '-=' in the if() above
110 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
111 /* Allocation pointer starts at the top.
112 Theory: because we build leaves before trunk allocating at end
113 means that at run time access is cache friendly upward
115 PL_OpPtr += PERL_SLAB_SIZE;
117 assert( PL_OpSpace >= 0 );
118 /* Move the allocation pointer down */
120 assert( PL_OpPtr > (I32 **) PL_OpSlab );
121 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
122 (*PL_OpSlab)++; /* Increment use count of slab */
123 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
124 assert( *PL_OpSlab > 0 );
125 return (void *)(PL_OpPtr + 1);
129 Perl_Slab_Free(pTHX_ void *op)
131 I32 **ptr = (I32 **) op;
133 assert( ptr-1 > (I32 **) slab );
134 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
136 if (--(*slab) == 0) {
138 # define PerlMemShared PerlMem
141 PerlMemShared_free(slab);
142 if (slab == PL_OpSlab) {
149 * In the following definition, the ", Nullop" is just to make the compiler
150 * think the expression is of the right type: croak actually does a Siglongjmp.
152 #define CHECKOP(type,o) \
153 ((PL_op_mask && PL_op_mask[type]) \
154 ? ( op_free((OP*)o), \
155 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
157 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
159 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
162 S_gv_ename(pTHX_ GV *gv)
165 SV* tmpsv = sv_newmortal();
166 gv_efullname3(tmpsv, gv, Nullch);
167 return SvPV(tmpsv,n_a);
171 S_no_fh_allowed(pTHX_ OP *o)
173 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
179 S_too_few_arguments(pTHX_ OP *o, char *name)
181 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
186 S_too_many_arguments(pTHX_ OP *o, char *name)
188 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
193 S_bad_type(pTHX_ I32 n, char *t, char *name, OP *kid)
195 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
196 (int)n, name, t, OP_DESC(kid)));
200 S_no_bareword_allowed(pTHX_ OP *o)
202 qerror(Perl_mess(aTHX_
203 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
207 /* "register" allocation */
210 Perl_allocmy(pTHX_ char *name)
214 /* complain about "my $<special_var>" etc etc */
215 if (!(PL_in_my == KEY_our ||
217 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
218 (name[1] == '_' && (*name == '$' || (int)strlen(name) > 2))))
220 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
221 /* 1999-02-27 mjd@plover.com */
223 p = strchr(name, '\0');
224 /* The next block assumes the buffer is at least 205 chars
225 long. At present, it's always at least 256 chars. */
227 strcpy(name+200, "...");
233 /* Move everything else down one character */
234 for (; p-name > 2; p--)
236 name[2] = toCTRL(name[1]);
239 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
242 /* check for duplicate declaration */
244 (bool)(PL_in_my == KEY_our),
245 (PL_curstash ? PL_curstash : PL_defstash)
248 if (PL_in_my_stash && *name != '$') {
249 yyerror(Perl_form(aTHX_
250 "Can't declare class for non-scalar %s in \"%s\"",
251 name, PL_in_my == KEY_our ? "our" : "my"));
254 /* allocate a spare slot and store the name in that slot */
256 off = pad_add_name(name,
259 ? (PL_curstash ? PL_curstash : PL_defstash)
270 Perl_op_free(pTHX_ OP *o)
272 register OP *kid, *nextkid;
276 if (!o || o->op_static)
279 if (o->op_private & OPpREFCOUNTED) {
280 switch (o->op_type) {
288 refcnt = OpREFCNT_dec(o);
298 if (o->op_flags & OPf_KIDS) {
299 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
300 nextkid = kid->op_sibling; /* Get before next freeing kid */
306 type = (OPCODE)o->op_targ;
308 /* COP* is not cleared by op_clear() so that we may track line
309 * numbers etc even after null() */
310 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
318 Perl_op_clear(pTHX_ OP *o)
321 switch (o->op_type) {
322 case OP_NULL: /* Was holding old type, if any. */
323 case OP_ENTEREVAL: /* Was holding hints. */
327 if (!(o->op_flags & OPf_REF)
328 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
334 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
335 /* not an OP_PADAV replacement */
337 if (cPADOPo->op_padix > 0) {
338 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
339 * may still exist on the pad */
340 pad_swipe(cPADOPo->op_padix, TRUE);
341 cPADOPo->op_padix = 0;
344 SvREFCNT_dec(cSVOPo->op_sv);
345 cSVOPo->op_sv = Nullsv;
349 case OP_METHOD_NAMED:
351 SvREFCNT_dec(cSVOPo->op_sv);
352 cSVOPo->op_sv = Nullsv;
355 Even if op_clear does a pad_free for the target of the op,
356 pad_free doesn't actually remove the sv that exists in the pad;
357 instead it lives on. This results in that it could be reused as
358 a target later on when the pad was reallocated.
361 pad_swipe(o->op_targ,1);
370 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
374 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
375 SvREFCNT_dec(cSVOPo->op_sv);
376 cSVOPo->op_sv = Nullsv;
379 Safefree(cPVOPo->op_pv);
380 cPVOPo->op_pv = Nullch;
384 op_free(cPMOPo->op_pmreplroot);
388 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
389 /* No GvIN_PAD_off here, because other references may still
390 * exist on the pad */
391 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
394 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
401 HV *pmstash = PmopSTASH(cPMOPo);
402 if (pmstash && SvREFCNT(pmstash)) {
403 PMOP *pmop = HvPMROOT(pmstash);
404 PMOP *lastpmop = NULL;
406 if (cPMOPo == pmop) {
408 lastpmop->op_pmnext = pmop->op_pmnext;
410 HvPMROOT(pmstash) = pmop->op_pmnext;
414 pmop = pmop->op_pmnext;
417 PmopSTASH_free(cPMOPo);
419 cPMOPo->op_pmreplroot = Nullop;
420 /* we use the "SAFE" version of the PM_ macros here
421 * since sv_clean_all might release some PMOPs
422 * after PL_regex_padav has been cleared
423 * and the clearing of PL_regex_padav needs to
424 * happen before sv_clean_all
426 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
427 PM_SETRE_SAFE(cPMOPo, (REGEXP*)NULL);
429 if(PL_regex_pad) { /* We could be in destruction */
430 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
431 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
432 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
439 if (o->op_targ > 0) {
440 pad_free(o->op_targ);
446 S_cop_free(pTHX_ COP* cop)
448 Safefree(cop->cop_label); /* FIXME: treaddead ??? */
451 if (! specialWARN(cop->cop_warnings))
452 SvREFCNT_dec(cop->cop_warnings);
453 if (! specialCopIO(cop->cop_io)) {
457 char *s = SvPV(cop->cop_io,len);
458 Perl_warn(aTHX_ "io='%.*s'",(int) len,s); /* ??? --jhi */
461 SvREFCNT_dec(cop->cop_io);
467 Perl_op_null(pTHX_ OP *o)
469 if (o->op_type == OP_NULL)
472 o->op_targ = o->op_type;
473 o->op_type = OP_NULL;
474 o->op_ppaddr = PL_ppaddr[OP_NULL];
478 Perl_op_refcnt_lock(pTHX)
484 Perl_op_refcnt_unlock(pTHX)
489 /* Contextualizers */
491 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
494 Perl_linklist(pTHX_ OP *o)
501 /* establish postfix order */
502 if (cUNOPo->op_first) {
503 o->op_next = LINKLIST(cUNOPo->op_first);
504 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
506 kid->op_next = LINKLIST(kid->op_sibling);
518 Perl_scalarkids(pTHX_ OP *o)
521 if (o && o->op_flags & OPf_KIDS) {
522 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
529 S_scalarboolean(pTHX_ OP *o)
531 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
532 if (ckWARN(WARN_SYNTAX)) {
533 line_t oldline = CopLINE(PL_curcop);
535 if (PL_copline != NOLINE)
536 CopLINE_set(PL_curcop, PL_copline);
537 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
538 CopLINE_set(PL_curcop, oldline);
545 Perl_scalar(pTHX_ OP *o)
549 /* assumes no premature commitment */
550 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
551 || o->op_type == OP_RETURN)
556 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
558 switch (o->op_type) {
560 scalar(cBINOPo->op_first);
565 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
569 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
570 if (!kPMOP->op_pmreplroot)
571 deprecate_old("implicit split to @_");
579 if (o->op_flags & OPf_KIDS) {
580 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
586 kid = cLISTOPo->op_first;
588 while ((kid = kid->op_sibling)) {
594 WITH_THR(PL_curcop = &PL_compiling);
599 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
605 WITH_THR(PL_curcop = &PL_compiling);
608 if (ckWARN(WARN_VOID))
609 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
615 Perl_scalarvoid(pTHX_ OP *o)
622 if (o->op_type == OP_NEXTSTATE
623 || o->op_type == OP_SETSTATE
624 || o->op_type == OP_DBSTATE
625 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
626 || o->op_targ == OP_SETSTATE
627 || o->op_targ == OP_DBSTATE)))
628 PL_curcop = (COP*)o; /* for warning below */
630 /* assumes no premature commitment */
631 want = o->op_flags & OPf_WANT;
632 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
633 || o->op_type == OP_RETURN)
638 if ((o->op_private & OPpTARGET_MY)
639 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
641 return scalar(o); /* As if inside SASSIGN */
644 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
646 switch (o->op_type) {
648 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
652 if (o->op_flags & OPf_STACKED)
656 if (o->op_private == 4)
728 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
729 useless = OP_DESC(o);
733 kid = cUNOPo->op_first;
734 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
735 kid->op_type != OP_TRANS) {
738 useless = "negative pattern binding (!~)";
745 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
746 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
747 useless = "a variable";
752 if (cSVOPo->op_private & OPpCONST_STRICT)
753 no_bareword_allowed(o);
755 if (ckWARN(WARN_VOID)) {
756 useless = "a constant";
757 /* don't warn on optimised away booleans, eg
758 * use constant Foo, 5; Foo || print; */
759 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
761 /* the constants 0 and 1 are permitted as they are
762 conventionally used as dummies in constructs like
763 1 while some_condition_with_side_effects; */
764 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
766 else if (SvPOK(sv)) {
767 /* perl4's way of mixing documentation and code
768 (before the invention of POD) was based on a
769 trick to mix nroff and perl code. The trick was
770 built upon these three nroff macros being used in
771 void context. The pink camel has the details in
772 the script wrapman near page 319. */
773 if (strnEQ(SvPVX(sv), "di", 2) ||
774 strnEQ(SvPVX(sv), "ds", 2) ||
775 strnEQ(SvPVX(sv), "ig", 2))
780 op_null(o); /* don't execute or even remember it */
784 o->op_type = OP_PREINC; /* pre-increment is faster */
785 o->op_ppaddr = PL_ppaddr[OP_PREINC];
789 o->op_type = OP_PREDEC; /* pre-decrement is faster */
790 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
797 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
802 if (o->op_flags & OPf_STACKED)
809 if (!(o->op_flags & OPf_KIDS))
818 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
825 /* all requires must return a boolean value */
826 o->op_flags &= ~OPf_WANT;
831 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
832 if (!kPMOP->op_pmreplroot)
833 deprecate_old("implicit split to @_");
837 if (useless && ckWARN(WARN_VOID))
838 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
843 Perl_listkids(pTHX_ OP *o)
846 if (o && o->op_flags & OPf_KIDS) {
847 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
854 Perl_list(pTHX_ OP *o)
858 /* assumes no premature commitment */
859 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
860 || o->op_type == OP_RETURN)
865 if ((o->op_private & OPpTARGET_MY)
866 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
868 return o; /* As if inside SASSIGN */
871 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
873 switch (o->op_type) {
876 list(cBINOPo->op_first);
881 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
889 if (!(o->op_flags & OPf_KIDS))
891 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
892 list(cBINOPo->op_first);
893 return gen_constant_list(o);
900 kid = cLISTOPo->op_first;
902 while ((kid = kid->op_sibling)) {
908 WITH_THR(PL_curcop = &PL_compiling);
912 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
918 WITH_THR(PL_curcop = &PL_compiling);
921 /* all requires must return a boolean value */
922 o->op_flags &= ~OPf_WANT;
929 Perl_scalarseq(pTHX_ OP *o)
934 if (o->op_type == OP_LINESEQ ||
935 o->op_type == OP_SCOPE ||
936 o->op_type == OP_LEAVE ||
937 o->op_type == OP_LEAVETRY)
939 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
940 if (kid->op_sibling) {
944 PL_curcop = &PL_compiling;
946 o->op_flags &= ~OPf_PARENS;
947 if (PL_hints & HINT_BLOCK_SCOPE)
948 o->op_flags |= OPf_PARENS;
951 o = newOP(OP_STUB, 0);
956 S_modkids(pTHX_ OP *o, I32 type)
959 if (o && o->op_flags & OPf_KIDS) {
960 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
966 /* Propagate lvalue ("modifiable") context to an op and it's children.
967 * 'type' represents the context type, roughly based on the type of op that
968 * would do the modifying, although local() is represented by OP_NULL.
969 * It's responsible for detecting things that can't be modified, flag
970 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
971 * might have to vivify a reference in $x), and so on.
973 * For example, "$a+1 = 2" would cause mod() to be called with o being
974 * OP_ADD and type being OP_SASSIGN, and would output an error.
978 Perl_mod(pTHX_ OP *o, I32 type)
981 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
984 if (!o || PL_error_count)
987 if ((o->op_private & OPpTARGET_MY)
988 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
993 switch (o->op_type) {
999 if (!(o->op_private & (OPpCONST_ARYBASE)))
1001 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1002 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1006 SAVEI32(PL_compiling.cop_arybase);
1007 PL_compiling.cop_arybase = 0;
1009 else if (type == OP_REFGEN)
1012 Perl_croak(aTHX_ "That use of $[ is unsupported");
1015 if (o->op_flags & OPf_PARENS)
1019 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1020 !(o->op_flags & OPf_STACKED)) {
1021 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1022 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1023 assert(cUNOPo->op_first->op_type == OP_NULL);
1024 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1027 else if (o->op_private & OPpENTERSUB_NOMOD)
1029 else { /* lvalue subroutine call */
1030 o->op_private |= OPpLVAL_INTRO;
1031 PL_modcount = RETURN_UNLIMITED_NUMBER;
1032 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1033 /* Backward compatibility mode: */
1034 o->op_private |= OPpENTERSUB_INARGS;
1037 else { /* Compile-time error message: */
1038 OP *kid = cUNOPo->op_first;
1042 if (kid->op_type == OP_PUSHMARK)
1044 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1046 "panic: unexpected lvalue entersub "
1047 "args: type/targ %ld:%"UVuf,
1048 (long)kid->op_type, (UV)kid->op_targ);
1049 kid = kLISTOP->op_first;
1051 while (kid->op_sibling)
1052 kid = kid->op_sibling;
1053 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1055 if (kid->op_type == OP_METHOD_NAMED
1056 || kid->op_type == OP_METHOD)
1060 NewOp(1101, newop, 1, UNOP);
1061 newop->op_type = OP_RV2CV;
1062 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1063 newop->op_first = Nullop;
1064 newop->op_next = (OP*)newop;
1065 kid->op_sibling = (OP*)newop;
1066 newop->op_private |= OPpLVAL_INTRO;
1070 if (kid->op_type != OP_RV2CV)
1072 "panic: unexpected lvalue entersub "
1073 "entry via type/targ %ld:%"UVuf,
1074 (long)kid->op_type, (UV)kid->op_targ);
1075 kid->op_private |= OPpLVAL_INTRO;
1076 break; /* Postpone until runtime */
1080 kid = kUNOP->op_first;
1081 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1082 kid = kUNOP->op_first;
1083 if (kid->op_type == OP_NULL)
1085 "Unexpected constant lvalue entersub "
1086 "entry via type/targ %ld:%"UVuf,
1087 (long)kid->op_type, (UV)kid->op_targ);
1088 if (kid->op_type != OP_GV) {
1089 /* Restore RV2CV to check lvalueness */
1091 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1092 okid->op_next = kid->op_next;
1093 kid->op_next = okid;
1096 okid->op_next = Nullop;
1097 okid->op_type = OP_RV2CV;
1099 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1100 okid->op_private |= OPpLVAL_INTRO;
1104 cv = GvCV(kGVOP_gv);
1114 /* grep, foreach, subcalls, refgen */
1115 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1117 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1118 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1120 : (o->op_type == OP_ENTERSUB
1121 ? "non-lvalue subroutine call"
1123 type ? PL_op_desc[type] : "local"));
1137 case OP_RIGHT_SHIFT:
1146 if (!(o->op_flags & OPf_STACKED))
1153 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1159 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1160 PL_modcount = RETURN_UNLIMITED_NUMBER;
1161 return o; /* Treat \(@foo) like ordinary list. */
1165 if (scalar_mod_type(o, type))
1167 ref(cUNOPo->op_first, o->op_type);
1171 if (type == OP_LEAVESUBLV)
1172 o->op_private |= OPpMAYBE_LVSUB;
1178 PL_modcount = RETURN_UNLIMITED_NUMBER;
1181 ref(cUNOPo->op_first, o->op_type);
1186 PL_hints |= HINT_BLOCK_SCOPE;
1201 PL_modcount = RETURN_UNLIMITED_NUMBER;
1202 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1203 return o; /* Treat \(@foo) like ordinary list. */
1204 if (scalar_mod_type(o, type))
1206 if (type == OP_LEAVESUBLV)
1207 o->op_private |= OPpMAYBE_LVSUB;
1211 if (!type) /* local() */
1212 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1213 PAD_COMPNAME_PV(o->op_targ));
1221 if (type != OP_SASSIGN)
1225 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1230 if (type == OP_LEAVESUBLV)
1231 o->op_private |= OPpMAYBE_LVSUB;
1233 pad_free(o->op_targ);
1234 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1235 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1236 if (o->op_flags & OPf_KIDS)
1237 mod(cBINOPo->op_first->op_sibling, type);
1242 ref(cBINOPo->op_first, o->op_type);
1243 if (type == OP_ENTERSUB &&
1244 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1245 o->op_private |= OPpLVAL_DEFER;
1246 if (type == OP_LEAVESUBLV)
1247 o->op_private |= OPpMAYBE_LVSUB;
1257 if (o->op_flags & OPf_KIDS)
1258 mod(cLISTOPo->op_last, type);
1263 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1265 else if (!(o->op_flags & OPf_KIDS))
1267 if (o->op_targ != OP_LIST) {
1268 mod(cBINOPo->op_first, type);
1274 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1279 if (type != OP_LEAVESUBLV)
1281 break; /* mod()ing was handled by ck_return() */
1284 /* [20011101.069] File test operators interpret OPf_REF to mean that
1285 their argument is a filehandle; thus \stat(".") should not set
1287 if (type == OP_REFGEN &&
1288 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1291 if (type != OP_LEAVESUBLV)
1292 o->op_flags |= OPf_MOD;
1294 if (type == OP_AASSIGN || type == OP_SASSIGN)
1295 o->op_flags |= OPf_SPECIAL|OPf_REF;
1296 else if (!type) { /* local() */
1299 o->op_private |= OPpLVAL_INTRO;
1300 o->op_flags &= ~OPf_SPECIAL;
1301 PL_hints |= HINT_BLOCK_SCOPE;
1306 if (ckWARN(WARN_SYNTAX)) {
1307 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1308 "Useless localization of %s", OP_DESC(o));
1312 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1313 && type != OP_LEAVESUBLV)
1314 o->op_flags |= OPf_REF;
1319 S_scalar_mod_type(pTHX_ OP *o, I32 type)
1323 if (o->op_type == OP_RV2GV)
1347 case OP_RIGHT_SHIFT:
1366 S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
1368 switch (o->op_type) {
1376 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1389 Perl_refkids(pTHX_ OP *o, I32 type)
1392 if (o && o->op_flags & OPf_KIDS) {
1393 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1400 Perl_ref(pTHX_ OP *o, I32 type)
1404 if (!o || PL_error_count)
1407 switch (o->op_type) {
1409 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1410 !(o->op_flags & OPf_STACKED)) {
1411 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1412 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1413 assert(cUNOPo->op_first->op_type == OP_NULL);
1414 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1415 o->op_flags |= OPf_SPECIAL;
1420 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1424 if (type == OP_DEFINED)
1425 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1426 ref(cUNOPo->op_first, o->op_type);
1429 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1430 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1431 : type == OP_RV2HV ? OPpDEREF_HV
1433 o->op_flags |= OPf_MOD;
1438 o->op_flags |= OPf_MOD; /* XXX ??? */
1443 o->op_flags |= OPf_REF;
1446 if (type == OP_DEFINED)
1447 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1448 ref(cUNOPo->op_first, o->op_type);
1453 o->op_flags |= OPf_REF;
1458 if (!(o->op_flags & OPf_KIDS))
1460 ref(cBINOPo->op_first, type);
1464 ref(cBINOPo->op_first, o->op_type);
1465 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1466 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1467 : type == OP_RV2HV ? OPpDEREF_HV
1469 o->op_flags |= OPf_MOD;
1477 if (!(o->op_flags & OPf_KIDS))
1479 ref(cLISTOPo->op_last, type);
1489 S_dup_attrlist(pTHX_ OP *o)
1493 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1494 * where the first kid is OP_PUSHMARK and the remaining ones
1495 * are OP_CONST. We need to push the OP_CONST values.
1497 if (o->op_type == OP_CONST)
1498 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1500 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1501 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1502 if (o->op_type == OP_CONST)
1503 rop = append_elem(OP_LIST, rop,
1504 newSVOP(OP_CONST, o->op_flags,
1505 SvREFCNT_inc(cSVOPo->op_sv)));
1512 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1516 /* fake up C<use attributes $pkg,$rv,@attrs> */
1517 ENTER; /* need to protect against side-effects of 'use' */
1520 stashsv = newSVpv(HvNAME(stash), 0);
1522 stashsv = &PL_sv_no;
1524 #define ATTRSMODULE "attributes"
1525 #define ATTRSMODULE_PM "attributes.pm"
1529 /* Don't force the C<use> if we don't need it. */
1530 svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
1531 sizeof(ATTRSMODULE_PM)-1, 0);
1532 if (svp && *svp != &PL_sv_undef)
1533 ; /* already in %INC */
1535 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1536 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1540 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1541 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1543 prepend_elem(OP_LIST,
1544 newSVOP(OP_CONST, 0, stashsv),
1545 prepend_elem(OP_LIST,
1546 newSVOP(OP_CONST, 0,
1548 dup_attrlist(attrs))));
1554 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1556 OP *pack, *imop, *arg;
1562 assert(target->op_type == OP_PADSV ||
1563 target->op_type == OP_PADHV ||
1564 target->op_type == OP_PADAV);
1566 /* Ensure that attributes.pm is loaded. */
1567 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1569 /* Need package name for method call. */
1570 pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
1572 /* Build up the real arg-list. */
1574 stashsv = newSVpv(HvNAME(stash), 0);
1576 stashsv = &PL_sv_no;
1577 arg = newOP(OP_PADSV, 0);
1578 arg->op_targ = target->op_targ;
1579 arg = prepend_elem(OP_LIST,
1580 newSVOP(OP_CONST, 0, stashsv),
1581 prepend_elem(OP_LIST,
1582 newUNOP(OP_REFGEN, 0,
1583 mod(arg, OP_REFGEN)),
1584 dup_attrlist(attrs)));
1586 /* Fake up a method call to import */
1587 meth = newSVpvn("import", 6);
1588 (void)SvUPGRADE(meth, SVt_PVIV);
1589 (void)SvIOK_on(meth);
1590 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
1591 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1592 append_elem(OP_LIST,
1593 prepend_elem(OP_LIST, pack, list(arg)),
1594 newSVOP(OP_METHOD_NAMED, 0, meth)));
1595 imop->op_private |= OPpENTERSUB_NOMOD;
1597 /* Combine the ops. */
1598 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1602 =notfor apidoc apply_attrs_string
1604 Attempts to apply a list of attributes specified by the C<attrstr> and
1605 C<len> arguments to the subroutine identified by the C<cv> argument which
1606 is expected to be associated with the package identified by the C<stashpv>
1607 argument (see L<attributes>). It gets this wrong, though, in that it
1608 does not correctly identify the boundaries of the individual attribute
1609 specifications within C<attrstr>. This is not really intended for the
1610 public API, but has to be listed here for systems such as AIX which
1611 need an explicit export list for symbols. (It's called from XS code
1612 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1613 to respect attribute syntax properly would be welcome.
1619 Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
1620 char *attrstr, STRLEN len)
1625 len = strlen(attrstr);
1629 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1631 char *sstr = attrstr;
1632 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1633 attrs = append_elem(OP_LIST, attrs,
1634 newSVOP(OP_CONST, 0,
1635 newSVpvn(sstr, attrstr-sstr)));
1639 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1640 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1641 Nullsv, prepend_elem(OP_LIST,
1642 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1643 prepend_elem(OP_LIST,
1644 newSVOP(OP_CONST, 0,
1650 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1655 if (!o || PL_error_count)
1659 if (type == OP_LIST) {
1660 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1661 my_kid(kid, attrs, imopsp);
1662 } else if (type == OP_UNDEF) {
1664 } else if (type == OP_RV2SV || /* "our" declaration */
1666 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1667 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1668 yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
1669 OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
1671 GV *gv = cGVOPx_gv(cUNOPo->op_first);
1673 PL_in_my_stash = Nullhv;
1674 apply_attrs(GvSTASH(gv),
1675 (type == OP_RV2SV ? GvSV(gv) :
1676 type == OP_RV2AV ? (SV*)GvAV(gv) :
1677 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1680 o->op_private |= OPpOUR_INTRO;
1683 else if (type != OP_PADSV &&
1686 type != OP_PUSHMARK)
1688 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1690 PL_in_my == KEY_our ? "our" : "my"));
1693 else if (attrs && type != OP_PUSHMARK) {
1697 PL_in_my_stash = Nullhv;
1699 /* check for C<my Dog $spot> when deciding package */
1700 stash = PAD_COMPNAME_TYPE(o->op_targ);
1702 stash = PL_curstash;
1703 apply_attrs_my(stash, o, attrs, imopsp);
1705 o->op_flags |= OPf_MOD;
1706 o->op_private |= OPpLVAL_INTRO;
1711 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1714 int maybe_scalar = 0;
1716 /* [perl #17376]: this appears to be premature, and results in code such as
1717 C< our(%x); > executing in list mode rather than void mode */
1719 if (o->op_flags & OPf_PARENS)
1728 o = my_kid(o, attrs, &rops);
1730 if (maybe_scalar && o->op_type == OP_PADSV) {
1731 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1732 o->op_private |= OPpLVAL_INTRO;
1735 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1738 PL_in_my_stash = Nullhv;
1743 Perl_my(pTHX_ OP *o)
1745 return my_attrs(o, Nullop);
1749 Perl_sawparens(pTHX_ OP *o)
1752 o->op_flags |= OPf_PARENS;
1757 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1762 if (ckWARN(WARN_MISC) &&
1763 (left->op_type == OP_RV2AV ||
1764 left->op_type == OP_RV2HV ||
1765 left->op_type == OP_PADAV ||
1766 left->op_type == OP_PADHV)) {
1767 char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
1768 right->op_type == OP_TRANS)
1769 ? right->op_type : OP_MATCH];
1770 const char *sample = ((left->op_type == OP_RV2AV ||
1771 left->op_type == OP_PADAV)
1772 ? "@array" : "%hash");
1773 Perl_warner(aTHX_ packWARN(WARN_MISC),
1774 "Applying %s to %s will act on scalar(%s)",
1775 desc, sample, sample);
1778 if (right->op_type == OP_CONST &&
1779 cSVOPx(right)->op_private & OPpCONST_BARE &&
1780 cSVOPx(right)->op_private & OPpCONST_STRICT)
1782 no_bareword_allowed(right);
1785 ismatchop = right->op_type == OP_MATCH ||
1786 right->op_type == OP_SUBST ||
1787 right->op_type == OP_TRANS;
1788 if (ismatchop && right->op_private & OPpTARGET_MY) {
1790 right->op_private &= ~OPpTARGET_MY;
1792 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1793 right->op_flags |= OPf_STACKED;
1794 if (right->op_type != OP_MATCH &&
1795 ! (right->op_type == OP_TRANS &&
1796 right->op_private & OPpTRANS_IDENTICAL))
1797 left = mod(left, right->op_type);
1798 if (right->op_type == OP_TRANS)
1799 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
1801 o = prepend_elem(right->op_type, scalar(left), right);
1803 return newUNOP(OP_NOT, 0, scalar(o));
1807 return bind_match(type, left,
1808 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
1812 Perl_invert(pTHX_ OP *o)
1816 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
1817 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1821 Perl_scope(pTHX_ OP *o)
1824 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1825 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1826 o->op_type = OP_LEAVE;
1827 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1829 else if (o->op_type == OP_LINESEQ) {
1831 o->op_type = OP_SCOPE;
1832 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1833 kid = ((LISTOP*)o)->op_first;
1834 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
1838 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
1843 /* XXX kept for BINCOMPAT only */
1845 Perl_save_hints(pTHX)
1847 Perl_croak(aTHX_ "internal error: obsolete function save_hints() called");
1851 Perl_block_start(pTHX_ int full)
1853 int retval = PL_savestack_ix;
1854 pad_block_start(full);
1856 PL_hints &= ~HINT_BLOCK_SCOPE;
1857 SAVESPTR(PL_compiling.cop_warnings);
1858 if (! specialWARN(PL_compiling.cop_warnings)) {
1859 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1860 SAVEFREESV(PL_compiling.cop_warnings) ;
1862 SAVESPTR(PL_compiling.cop_io);
1863 if (! specialCopIO(PL_compiling.cop_io)) {
1864 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1865 SAVEFREESV(PL_compiling.cop_io) ;
1871 Perl_block_end(pTHX_ I32 floor, OP *seq)
1873 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1874 OP* retval = scalarseq(seq);
1876 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
1878 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
1886 I32 offset = pad_findmy("$_");
1887 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
1888 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1891 OP *o = newOP(OP_PADSV, 0);
1892 o->op_targ = offset;
1898 Perl_newPROG(pTHX_ OP *o)
1903 PL_eval_root = newUNOP(OP_LEAVEEVAL,
1904 ((PL_in_eval & EVAL_KEEPERR)
1905 ? OPf_SPECIAL : 0), o);
1906 PL_eval_start = linklist(PL_eval_root);
1907 PL_eval_root->op_private |= OPpREFCOUNTED;
1908 OpREFCNT_set(PL_eval_root, 1);
1909 PL_eval_root->op_next = 0;
1910 CALL_PEEP(PL_eval_start);
1913 if (o->op_type == OP_STUB) {
1914 PL_comppad_name = 0;
1919 PL_main_root = scope(sawparens(scalarvoid(o)));
1920 PL_curcop = &PL_compiling;
1921 PL_main_start = LINKLIST(PL_main_root);
1922 PL_main_root->op_private |= OPpREFCOUNTED;
1923 OpREFCNT_set(PL_main_root, 1);
1924 PL_main_root->op_next = 0;
1925 CALL_PEEP(PL_main_start);
1928 /* Register with debugger */
1930 CV *cv = get_cv("DB::postponed", FALSE);
1934 XPUSHs((SV*)CopFILEGV(&PL_compiling));
1936 call_sv((SV*)cv, G_DISCARD);
1943 Perl_localize(pTHX_ OP *o, I32 lex)
1945 if (o->op_flags & OPf_PARENS)
1946 /* [perl #17376]: this appears to be premature, and results in code such as
1947 C< our(%x); > executing in list mode rather than void mode */
1954 if (ckWARN(WARN_PARENTHESIS)
1955 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
1957 char *s = PL_bufptr;
1960 /* some heuristics to detect a potential error */
1961 while (*s && (strchr(", \t\n", *s)))
1965 if (*s && strchr("@$%*", *s) && *++s
1966 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
1969 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
1971 while (*s && (strchr(", \t\n", *s)))
1977 if (sigil && (*s == ';' || *s == '=')) {
1978 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
1979 "Parentheses missing around \"%s\" list",
1980 lex ? (PL_in_my == KEY_our ? "our" : "my")
1988 o = mod(o, OP_NULL); /* a bit kludgey */
1990 PL_in_my_stash = Nullhv;
1995 Perl_jmaybe(pTHX_ OP *o)
1997 if (o->op_type == OP_LIST) {
1999 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2000 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2006 Perl_fold_constants(pTHX_ register OP *o)
2009 I32 type = o->op_type;
2012 if (PL_opargs[type] & OA_RETSCALAR)
2014 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2015 o->op_targ = pad_alloc(type, SVs_PADTMP);
2017 /* integerize op, unless it happens to be C<-foo>.
2018 * XXX should pp_i_negate() do magic string negation instead? */
2019 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2020 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2021 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2023 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2026 if (!(PL_opargs[type] & OA_FOLDCONST))
2031 /* XXX might want a ck_negate() for this */
2032 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2044 /* XXX what about the numeric ops? */
2045 if (PL_hints & HINT_LOCALE)
2050 goto nope; /* Don't try to run w/ errors */
2052 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2053 if ((curop->op_type != OP_CONST ||
2054 (curop->op_private & OPpCONST_BARE)) &&
2055 curop->op_type != OP_LIST &&
2056 curop->op_type != OP_SCALAR &&
2057 curop->op_type != OP_NULL &&
2058 curop->op_type != OP_PUSHMARK)
2064 curop = LINKLIST(o);
2068 sv = *(PL_stack_sp--);
2069 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2070 pad_swipe(o->op_targ, FALSE);
2071 else if (SvTEMP(sv)) { /* grab mortal temp? */
2072 (void)SvREFCNT_inc(sv);
2076 if (type == OP_RV2GV)
2077 return newGVOP(OP_GV, 0, (GV*)sv);
2078 return newSVOP(OP_CONST, 0, sv);
2085 Perl_gen_constant_list(pTHX_ register OP *o)
2088 I32 oldtmps_floor = PL_tmps_floor;
2092 return o; /* Don't attempt to run with errors */
2094 PL_op = curop = LINKLIST(o);
2101 PL_tmps_floor = oldtmps_floor;
2103 o->op_type = OP_RV2AV;
2104 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2105 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2106 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2107 o->op_opt = 0; /* needs to be revisited in peep() */
2108 curop = ((UNOP*)o)->op_first;
2109 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2116 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2118 if (!o || o->op_type != OP_LIST)
2119 o = newLISTOP(OP_LIST, 0, o, Nullop);
2121 o->op_flags &= ~OPf_WANT;
2123 if (!(PL_opargs[type] & OA_MARK))
2124 op_null(cLISTOPo->op_first);
2126 o->op_type = (OPCODE)type;
2127 o->op_ppaddr = PL_ppaddr[type];
2128 o->op_flags |= flags;
2130 o = CHECKOP(type, o);
2131 if (o->op_type != type)
2134 return fold_constants(o);
2137 /* List constructors */
2140 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2148 if (first->op_type != type
2149 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2151 return newLISTOP(type, 0, first, last);
2154 if (first->op_flags & OPf_KIDS)
2155 ((LISTOP*)first)->op_last->op_sibling = last;
2157 first->op_flags |= OPf_KIDS;
2158 ((LISTOP*)first)->op_first = last;
2160 ((LISTOP*)first)->op_last = last;
2165 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2173 if (first->op_type != type)
2174 return prepend_elem(type, (OP*)first, (OP*)last);
2176 if (last->op_type != type)
2177 return append_elem(type, (OP*)first, (OP*)last);
2179 first->op_last->op_sibling = last->op_first;
2180 first->op_last = last->op_last;
2181 first->op_flags |= (last->op_flags & OPf_KIDS);
2189 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2197 if (last->op_type == type) {
2198 if (type == OP_LIST) { /* already a PUSHMARK there */
2199 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2200 ((LISTOP*)last)->op_first->op_sibling = first;
2201 if (!(first->op_flags & OPf_PARENS))
2202 last->op_flags &= ~OPf_PARENS;
2205 if (!(last->op_flags & OPf_KIDS)) {
2206 ((LISTOP*)last)->op_last = first;
2207 last->op_flags |= OPf_KIDS;
2209 first->op_sibling = ((LISTOP*)last)->op_first;
2210 ((LISTOP*)last)->op_first = first;
2212 last->op_flags |= OPf_KIDS;
2216 return newLISTOP(type, 0, first, last);
2222 Perl_newNULLLIST(pTHX)
2224 return newOP(OP_STUB, 0);
2228 Perl_force_list(pTHX_ OP *o)
2230 if (!o || o->op_type != OP_LIST)
2231 o = newLISTOP(OP_LIST, 0, o, Nullop);
2237 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2241 NewOp(1101, listop, 1, LISTOP);
2243 listop->op_type = (OPCODE)type;
2244 listop->op_ppaddr = PL_ppaddr[type];
2247 listop->op_flags = (U8)flags;
2251 else if (!first && last)
2254 first->op_sibling = last;
2255 listop->op_first = first;
2256 listop->op_last = last;
2257 if (type == OP_LIST) {
2259 pushop = newOP(OP_PUSHMARK, 0);
2260 pushop->op_sibling = first;
2261 listop->op_first = pushop;
2262 listop->op_flags |= OPf_KIDS;
2264 listop->op_last = pushop;
2267 return CHECKOP(type, listop);
2271 Perl_newOP(pTHX_ I32 type, I32 flags)
2274 NewOp(1101, o, 1, OP);
2275 o->op_type = (OPCODE)type;
2276 o->op_ppaddr = PL_ppaddr[type];
2277 o->op_flags = (U8)flags;
2280 o->op_private = (U8)(0 | (flags >> 8));
2281 if (PL_opargs[type] & OA_RETSCALAR)
2283 if (PL_opargs[type] & OA_TARGET)
2284 o->op_targ = pad_alloc(type, SVs_PADTMP);
2285 return CHECKOP(type, o);
2289 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2294 first = newOP(OP_STUB, 0);
2295 if (PL_opargs[type] & OA_MARK)
2296 first = force_list(first);
2298 NewOp(1101, unop, 1, UNOP);
2299 unop->op_type = (OPCODE)type;
2300 unop->op_ppaddr = PL_ppaddr[type];
2301 unop->op_first = first;
2302 unop->op_flags = flags | OPf_KIDS;
2303 unop->op_private = (U8)(1 | (flags >> 8));
2304 unop = (UNOP*) CHECKOP(type, unop);
2308 return fold_constants((OP *) unop);
2312 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2315 NewOp(1101, binop, 1, BINOP);
2318 first = newOP(OP_NULL, 0);
2320 binop->op_type = (OPCODE)type;
2321 binop->op_ppaddr = PL_ppaddr[type];
2322 binop->op_first = first;
2323 binop->op_flags = flags | OPf_KIDS;
2326 binop->op_private = (U8)(1 | (flags >> 8));
2329 binop->op_private = (U8)(2 | (flags >> 8));
2330 first->op_sibling = last;
2333 binop = (BINOP*)CHECKOP(type, binop);
2334 if (binop->op_next || binop->op_type != (OPCODE)type)
2337 binop->op_last = binop->op_first->op_sibling;
2339 return fold_constants((OP *)binop);
2343 uvcompare(const void *a, const void *b)
2345 if (*((UV *)a) < (*(UV *)b))
2347 if (*((UV *)a) > (*(UV *)b))
2349 if (*((UV *)a+1) < (*(UV *)b+1))
2351 if (*((UV *)a+1) > (*(UV *)b+1))
2357 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2359 SV *tstr = ((SVOP*)expr)->op_sv;
2360 SV *rstr = ((SVOP*)repl)->op_sv;
2363 U8 *t = (U8*)SvPV(tstr, tlen);
2364 U8 *r = (U8*)SvPV(rstr, rlen);
2371 register short *tbl;
2373 PL_hints |= HINT_BLOCK_SCOPE;
2374 complement = o->op_private & OPpTRANS_COMPLEMENT;
2375 del = o->op_private & OPpTRANS_DELETE;
2376 squash = o->op_private & OPpTRANS_SQUASH;
2379 o->op_private |= OPpTRANS_FROM_UTF;
2382 o->op_private |= OPpTRANS_TO_UTF;
2384 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2385 SV* listsv = newSVpvn("# comment\n",10);
2387 U8* tend = t + tlen;
2388 U8* rend = r + rlen;
2402 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2403 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2409 tsave = t = bytes_to_utf8(t, &len);
2412 if (!to_utf && rlen) {
2414 rsave = r = bytes_to_utf8(r, &len);
2418 /* There are several snags with this code on EBCDIC:
2419 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2420 2. scan_const() in toke.c has encoded chars in native encoding which makes
2421 ranges at least in EBCDIC 0..255 range the bottom odd.
2425 U8 tmpbuf[UTF8_MAXLEN+1];
2428 New(1109, cp, 2*tlen, UV);
2430 transv = newSVpvn("",0);
2432 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2434 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2436 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2440 cp[2*i+1] = cp[2*i];
2444 qsort(cp, i, 2*sizeof(UV), uvcompare);
2445 for (j = 0; j < i; j++) {
2447 diff = val - nextmin;
2449 t = uvuni_to_utf8(tmpbuf,nextmin);
2450 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2452 U8 range_mark = UTF_TO_NATIVE(0xff);
2453 t = uvuni_to_utf8(tmpbuf, val - 1);
2454 sv_catpvn(transv, (char *)&range_mark, 1);
2455 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2462 t = uvuni_to_utf8(tmpbuf,nextmin);
2463 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2465 U8 range_mark = UTF_TO_NATIVE(0xff);
2466 sv_catpvn(transv, (char *)&range_mark, 1);
2468 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2469 UNICODE_ALLOW_SUPER);
2470 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2471 t = (U8*)SvPVX(transv);
2472 tlen = SvCUR(transv);
2476 else if (!rlen && !del) {
2477 r = t; rlen = tlen; rend = tend;
2480 if ((!rlen && !del) || t == r ||
2481 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2483 o->op_private |= OPpTRANS_IDENTICAL;
2487 while (t < tend || tfirst <= tlast) {
2488 /* see if we need more "t" chars */
2489 if (tfirst > tlast) {
2490 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2492 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2494 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2501 /* now see if we need more "r" chars */
2502 if (rfirst > rlast) {
2504 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2506 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2508 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2517 rfirst = rlast = 0xffffffff;
2521 /* now see which range will peter our first, if either. */
2522 tdiff = tlast - tfirst;
2523 rdiff = rlast - rfirst;
2530 if (rfirst == 0xffffffff) {
2531 diff = tdiff; /* oops, pretend rdiff is infinite */
2533 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2534 (long)tfirst, (long)tlast);
2536 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2540 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2541 (long)tfirst, (long)(tfirst + diff),
2544 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2545 (long)tfirst, (long)rfirst);
2547 if (rfirst + diff > max)
2548 max = rfirst + diff;
2550 grows = (tfirst < rfirst &&
2551 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2563 else if (max > 0xff)
2568 Safefree(cPVOPo->op_pv);
2569 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2570 SvREFCNT_dec(listsv);
2572 SvREFCNT_dec(transv);
2574 if (!del && havefinal && rlen)
2575 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2576 newSVuv((UV)final), 0);
2579 o->op_private |= OPpTRANS_GROWS;
2591 tbl = (short*)cPVOPo->op_pv;
2593 Zero(tbl, 256, short);
2594 for (i = 0; i < (I32)tlen; i++)
2596 for (i = 0, j = 0; i < 256; i++) {
2598 if (j >= (I32)rlen) {
2607 if (i < 128 && r[j] >= 128)
2617 o->op_private |= OPpTRANS_IDENTICAL;
2619 else if (j >= (I32)rlen)
2622 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2623 tbl[0x100] = rlen - j;
2624 for (i=0; i < (I32)rlen - j; i++)
2625 tbl[0x101+i] = r[j+i];
2629 if (!rlen && !del) {
2632 o->op_private |= OPpTRANS_IDENTICAL;
2634 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2635 o->op_private |= OPpTRANS_IDENTICAL;
2637 for (i = 0; i < 256; i++)
2639 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
2640 if (j >= (I32)rlen) {
2642 if (tbl[t[i]] == -1)
2648 if (tbl[t[i]] == -1) {
2649 if (t[i] < 128 && r[j] >= 128)
2656 o->op_private |= OPpTRANS_GROWS;
2664 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2668 NewOp(1101, pmop, 1, PMOP);
2669 pmop->op_type = (OPCODE)type;
2670 pmop->op_ppaddr = PL_ppaddr[type];
2671 pmop->op_flags = (U8)flags;
2672 pmop->op_private = (U8)(0 | (flags >> 8));
2674 if (PL_hints & HINT_RE_TAINT)
2675 pmop->op_pmpermflags |= PMf_RETAINT;
2676 if (PL_hints & HINT_LOCALE)
2677 pmop->op_pmpermflags |= PMf_LOCALE;
2678 pmop->op_pmflags = pmop->op_pmpermflags;
2683 if(av_len((AV*) PL_regex_pad[0]) > -1) {
2684 repointer = av_pop((AV*)PL_regex_pad[0]);
2685 pmop->op_pmoffset = SvIV(repointer);
2686 SvREPADTMP_off(repointer);
2687 sv_setiv(repointer,0);
2689 repointer = newSViv(0);
2690 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2691 pmop->op_pmoffset = av_len(PL_regex_padav);
2692 PL_regex_pad = AvARRAY(PL_regex_padav);
2697 /* link into pm list */
2698 if (type != OP_TRANS && PL_curstash) {
2699 pmop->op_pmnext = HvPMROOT(PL_curstash);
2700 HvPMROOT(PL_curstash) = pmop;
2701 PmopSTASH_set(pmop,PL_curstash);
2704 return CHECKOP(type, pmop);
2707 /* Given some sort of match op o, and an expression expr containing a
2708 * pattern, either compile expr into a regex and attach it to o (if it's
2709 * constant), or convert expr into a runtime regcomp op sequence (if it's
2712 * isreg indicates that the pattern is part of a regex construct, eg
2713 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
2714 * split "pattern", which aren't. In the former case, expr will be a list
2715 * if the pattern contains more than one term (eg /a$b/) or if it contains
2716 * a replacement, ie s/// or tr///.
2720 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
2724 I32 repl_has_vars = 0;
2728 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
2729 /* last element in list is the replacement; pop it */
2731 repl = cLISTOPx(expr)->op_last;
2732 kid = cLISTOPx(expr)->op_first;
2733 while (kid->op_sibling != repl)
2734 kid = kid->op_sibling;
2735 kid->op_sibling = Nullop;
2736 cLISTOPx(expr)->op_last = kid;
2739 if (isreg && expr->op_type == OP_LIST &&
2740 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
2742 /* convert single element list to element */
2744 expr = cLISTOPx(oe)->op_first->op_sibling;
2745 cLISTOPx(oe)->op_first->op_sibling = Nullop;
2746 cLISTOPx(oe)->op_last = Nullop;
2750 if (o->op_type == OP_TRANS) {
2751 return pmtrans(o, expr, repl);
2754 reglist = isreg && expr->op_type == OP_LIST;
2758 PL_hints |= HINT_BLOCK_SCOPE;
2761 if (expr->op_type == OP_CONST) {
2763 SV *pat = ((SVOP*)expr)->op_sv;
2764 char *p = SvPV(pat, plen);
2765 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
2766 sv_setpvn(pat, "\\s+", 3);
2767 p = SvPV(pat, plen);
2768 pm->op_pmflags |= PMf_SKIPWHITE;
2771 pm->op_pmdynflags |= PMdf_UTF8;
2772 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
2773 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
2774 pm->op_pmflags |= PMf_WHITE;
2778 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2779 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2781 : OP_REGCMAYBE),0,expr);
2783 NewOp(1101, rcop, 1, LOGOP);
2784 rcop->op_type = OP_REGCOMP;
2785 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2786 rcop->op_first = scalar(expr);
2787 rcop->op_flags |= OPf_KIDS
2788 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
2789 | (reglist ? OPf_STACKED : 0);
2790 rcop->op_private = 1;
2793 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
2795 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
2798 /* establish postfix order */
2799 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2801 rcop->op_next = expr;
2802 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2805 rcop->op_next = LINKLIST(expr);
2806 expr->op_next = (OP*)rcop;
2809 prepend_elem(o->op_type, scalar((OP*)rcop), o);
2814 if (pm->op_pmflags & PMf_EVAL) {
2816 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
2817 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
2819 else if (repl->op_type == OP_CONST)
2823 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
2824 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
2825 if (curop->op_type == OP_GV) {
2826 GV *gv = cGVOPx_gv(curop);
2828 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
2831 else if (curop->op_type == OP_RV2CV)
2833 else if (curop->op_type == OP_RV2SV ||
2834 curop->op_type == OP_RV2AV ||
2835 curop->op_type == OP_RV2HV ||
2836 curop->op_type == OP_RV2GV) {
2837 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2840 else if (curop->op_type == OP_PADSV ||
2841 curop->op_type == OP_PADAV ||
2842 curop->op_type == OP_PADHV ||
2843 curop->op_type == OP_PADANY) {
2846 else if (curop->op_type == OP_PUSHRE)
2847 ; /* Okay here, dangerous in newASSIGNOP */
2857 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
2858 pm->op_pmflags |= PMf_CONST; /* const for long enough */
2859 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
2860 prepend_elem(o->op_type, scalar(repl), o);
2863 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
2864 pm->op_pmflags |= PMf_MAYBE_CONST;
2865 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2867 NewOp(1101, rcop, 1, LOGOP);
2868 rcop->op_type = OP_SUBSTCONT;
2869 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
2870 rcop->op_first = scalar(repl);
2871 rcop->op_flags |= OPf_KIDS;
2872 rcop->op_private = 1;
2875 /* establish postfix order */
2876 rcop->op_next = LINKLIST(repl);
2877 repl->op_next = (OP*)rcop;
2879 pm->op_pmreplroot = scalar((OP*)rcop);
2880 pm->op_pmreplstart = LINKLIST(rcop);
2889 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
2892 NewOp(1101, svop, 1, SVOP);
2893 svop->op_type = (OPCODE)type;
2894 svop->op_ppaddr = PL_ppaddr[type];
2896 svop->op_next = (OP*)svop;
2897 svop->op_flags = (U8)flags;
2898 if (PL_opargs[type] & OA_RETSCALAR)
2900 if (PL_opargs[type] & OA_TARGET)
2901 svop->op_targ = pad_alloc(type, SVs_PADTMP);
2902 return CHECKOP(type, svop);
2906 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2909 NewOp(1101, padop, 1, PADOP);
2910 padop->op_type = (OPCODE)type;
2911 padop->op_ppaddr = PL_ppaddr[type];
2912 padop->op_padix = pad_alloc(type, SVs_PADTMP);
2913 SvREFCNT_dec(PAD_SVl(padop->op_padix));
2914 PAD_SETSV(padop->op_padix, sv);
2917 padop->op_next = (OP*)padop;
2918 padop->op_flags = (U8)flags;
2919 if (PL_opargs[type] & OA_RETSCALAR)
2921 if (PL_opargs[type] & OA_TARGET)
2922 padop->op_targ = pad_alloc(type, SVs_PADTMP);
2923 return CHECKOP(type, padop);
2927 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
2932 return newPADOP(type, flags, SvREFCNT_inc(gv));
2934 return newSVOP(type, flags, SvREFCNT_inc(gv));
2939 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
2942 NewOp(1101, pvop, 1, PVOP);
2943 pvop->op_type = (OPCODE)type;
2944 pvop->op_ppaddr = PL_ppaddr[type];
2946 pvop->op_next = (OP*)pvop;
2947 pvop->op_flags = (U8)flags;
2948 if (PL_opargs[type] & OA_RETSCALAR)
2950 if (PL_opargs[type] & OA_TARGET)
2951 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
2952 return CHECKOP(type, pvop);
2956 Perl_package(pTHX_ OP *o)
2961 save_hptr(&PL_curstash);
2962 save_item(PL_curstname);
2964 name = SvPV(cSVOPo->op_sv, len);
2965 PL_curstash = gv_stashpvn(name, len, TRUE);
2966 sv_setpvn(PL_curstname, name, len);
2969 PL_hints |= HINT_BLOCK_SCOPE;
2970 PL_copline = NOLINE;
2975 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
2981 if (idop->op_type != OP_CONST)
2982 Perl_croak(aTHX_ "Module name must be constant");
2986 if (version != Nullop) {
2987 SV *vesv = ((SVOP*)version)->op_sv;
2989 if (arg == Nullop && !SvNIOKp(vesv)) {
2996 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
2997 Perl_croak(aTHX_ "Version number must be constant number");
2999 /* Make copy of idop so we don't free it twice */
3000 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3002 /* Fake up a method call to VERSION */
3003 meth = newSVpvn("VERSION",7);
3004 sv_upgrade(meth, SVt_PVIV);
3005 (void)SvIOK_on(meth);
3006 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3007 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3008 append_elem(OP_LIST,
3009 prepend_elem(OP_LIST, pack, list(version)),
3010 newSVOP(OP_METHOD_NAMED, 0, meth)));
3014 /* Fake up an import/unimport */
3015 if (arg && arg->op_type == OP_STUB)
3016 imop = arg; /* no import on explicit () */
3017 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3018 imop = Nullop; /* use 5.0; */
3023 /* Make copy of idop so we don't free it twice */
3024 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3026 /* Fake up a method call to import/unimport */
3027 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);
3028 (void)SvUPGRADE(meth, SVt_PVIV);
3029 (void)SvIOK_on(meth);
3030 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3031 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3032 append_elem(OP_LIST,
3033 prepend_elem(OP_LIST, pack, list(arg)),
3034 newSVOP(OP_METHOD_NAMED, 0, meth)));
3037 /* Fake up the BEGIN {}, which does its thing immediately. */
3039 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3042 append_elem(OP_LINESEQ,
3043 append_elem(OP_LINESEQ,
3044 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, idop)),
3045 newSTATEOP(0, Nullch, veop)),
3046 newSTATEOP(0, Nullch, imop) ));
3048 /* The "did you use incorrect case?" warning used to be here.
3049 * The problem is that on case-insensitive filesystems one
3050 * might get false positives for "use" (and "require"):
3051 * "use Strict" or "require CARP" will work. This causes
3052 * portability problems for the script: in case-strict
3053 * filesystems the script will stop working.
3055 * The "incorrect case" warning checked whether "use Foo"
3056 * imported "Foo" to your namespace, but that is wrong, too:
3057 * there is no requirement nor promise in the language that
3058 * a Foo.pm should or would contain anything in package "Foo".
3060 * There is very little Configure-wise that can be done, either:
3061 * the case-sensitivity of the build filesystem of Perl does not
3062 * help in guessing the case-sensitivity of the runtime environment.
3065 PL_hints |= HINT_BLOCK_SCOPE;
3066 PL_copline = NOLINE;
3068 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3072 =head1 Embedding Functions
3074 =for apidoc load_module
3076 Loads the module whose name is pointed to by the string part of name.
3077 Note that the actual module name, not its filename, should be given.
3078 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3079 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3080 (or 0 for no flags). ver, if specified, provides version semantics
3081 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3082 arguments can be used to specify arguments to the module's import()
3083 method, similar to C<use Foo::Bar VERSION LIST>.
3088 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3091 va_start(args, ver);
3092 vload_module(flags, name, ver, &args);
3096 #ifdef PERL_IMPLICIT_CONTEXT
3098 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3102 va_start(args, ver);
3103 vload_module(flags, name, ver, &args);
3109 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3111 OP *modname, *veop, *imop;
3113 modname = newSVOP(OP_CONST, 0, name);
3114 modname->op_private |= OPpCONST_BARE;
3116 veop = newSVOP(OP_CONST, 0, ver);
3120 if (flags & PERL_LOADMOD_NOIMPORT) {
3121 imop = sawparens(newNULLLIST());
3123 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3124 imop = va_arg(*args, OP*);
3129 sv = va_arg(*args, SV*);
3131 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3132 sv = va_arg(*args, SV*);
3136 line_t ocopline = PL_copline;
3137 COP *ocurcop = PL_curcop;
3138 int oexpect = PL_expect;
3140 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3141 veop, modname, imop);
3142 PL_expect = oexpect;
3143 PL_copline = ocopline;
3144 PL_curcop = ocurcop;
3149 Perl_dofile(pTHX_ OP *term)
3154 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3155 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
3156 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3158 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3159 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3160 append_elem(OP_LIST, term,
3161 scalar(newUNOP(OP_RV2CV, 0,
3166 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3172 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3174 return newBINOP(OP_LSLICE, flags,
3175 list(force_list(subscript)),
3176 list(force_list(listval)) );
3180 S_list_assignment(pTHX_ register OP *o)
3185 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3186 o = cUNOPo->op_first;
3188 if (o->op_type == OP_COND_EXPR) {
3189 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3190 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3195 yyerror("Assignment to both a list and a scalar");
3199 if (o->op_type == OP_LIST &&
3200 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3201 o->op_private & OPpLVAL_INTRO)
3204 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3205 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3206 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3209 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3212 if (o->op_type == OP_RV2SV)
3219 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3224 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3225 return newLOGOP(optype, 0,
3226 mod(scalar(left), optype),
3227 newUNOP(OP_SASSIGN, 0, scalar(right)));
3230 return newBINOP(optype, OPf_STACKED,
3231 mod(scalar(left), optype), scalar(right));
3235 if (list_assignment(left)) {
3239 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3240 left = mod(left, OP_AASSIGN);
3248 /* optimise C<my @x = ()> to C<my @x>, and likewise for hashes */
3249 if ((left->op_type == OP_PADAV || left->op_type == OP_PADHV)
3250 && right->op_type == OP_STUB
3251 && (left->op_private & OPpLVAL_INTRO))
3254 left->op_flags &= ~(OPf_REF|OPf_SPECIAL);
3257 curop = list(force_list(left));
3258 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3259 o->op_private = (U8)(0 | (flags >> 8));
3261 /* PL_generation sorcery:
3262 * an assignment like ($a,$b) = ($c,$d) is easier than
3263 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3264 * To detect whether there are common vars, the global var
3265 * PL_generation is incremented for each assign op we compile.
3266 * Then, while compiling the assign op, we run through all the
3267 * variables on both sides of the assignment, setting a spare slot
3268 * in each of them to PL_generation. If any of them already have
3269 * that value, we know we've got commonality. We could use a
3270 * single bit marker, but then we'd have to make 2 passes, first
3271 * to clear the flag, then to test and set it. To find somewhere
3272 * to store these values, evil chicanery is done with SvCUR().
3275 if (!(left->op_private & OPpLVAL_INTRO)) {
3278 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3279 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3280 if (curop->op_type == OP_GV) {
3281 GV *gv = cGVOPx_gv(curop);
3282 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3284 SvCUR(gv) = PL_generation;
3286 else if (curop->op_type == OP_PADSV ||
3287 curop->op_type == OP_PADAV ||
3288 curop->op_type == OP_PADHV ||
3289 curop->op_type == OP_PADANY)
3291 if (PAD_COMPNAME_GEN(curop->op_targ)
3292 == (STRLEN)PL_generation)
3294 PAD_COMPNAME_GEN(curop->op_targ)
3298 else if (curop->op_type == OP_RV2CV)
3300 else if (curop->op_type == OP_RV2SV ||
3301 curop->op_type == OP_RV2AV ||
3302 curop->op_type == OP_RV2HV ||
3303 curop->op_type == OP_RV2GV) {
3304 if (lastop->op_type != OP_GV) /* funny deref? */
3307 else if (curop->op_type == OP_PUSHRE) {
3308 if (((PMOP*)curop)->op_pmreplroot) {
3310 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3311 ((PMOP*)curop)->op_pmreplroot));
3313 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3315 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3317 SvCUR(gv) = PL_generation;
3326 o->op_private |= OPpASSIGN_COMMON;
3328 if (right && right->op_type == OP_SPLIT) {
3330 if ((tmpop = ((LISTOP*)right)->op_first) &&
3331 tmpop->op_type == OP_PUSHRE)
3333 PMOP *pm = (PMOP*)tmpop;
3334 if (left->op_type == OP_RV2AV &&
3335 !(left->op_private & OPpLVAL_INTRO) &&
3336 !(o->op_private & OPpASSIGN_COMMON) )
3338 tmpop = ((UNOP*)left)->op_first;
3339 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3341 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3342 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3344 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3345 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3347 pm->op_pmflags |= PMf_ONCE;
3348 tmpop = cUNOPo->op_first; /* to list (nulled) */
3349 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3350 tmpop->op_sibling = Nullop; /* don't free split */
3351 right->op_next = tmpop->op_next; /* fix starting loc */
3352 op_free(o); /* blow off assign */
3353 right->op_flags &= ~OPf_WANT;
3354 /* "I don't know and I don't care." */
3359 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3360 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3362 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3364 sv_setiv(sv, PL_modcount+1);
3372 right = newOP(OP_UNDEF, 0);
3373 if (right->op_type == OP_READLINE) {
3374 right->op_flags |= OPf_STACKED;
3375 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3378 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3379 o = newBINOP(OP_SASSIGN, flags,
3380 scalar(right), mod(scalar(left), OP_SASSIGN) );
3392 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3394 U32 seq = intro_my();
3397 NewOp(1101, cop, 1, COP);
3398 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3399 cop->op_type = OP_DBSTATE;
3400 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3403 cop->op_type = OP_NEXTSTATE;
3404 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3406 cop->op_flags = (U8)flags;
3407 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3409 cop->op_private |= NATIVE_HINTS;
3411 PL_compiling.op_private = cop->op_private;
3412 cop->op_next = (OP*)cop;
3415 cop->cop_label = label;
3416 PL_hints |= HINT_BLOCK_SCOPE;
3419 cop->cop_arybase = PL_curcop->cop_arybase;
3420 if (specialWARN(PL_curcop->cop_warnings))
3421 cop->cop_warnings = PL_curcop->cop_warnings ;
3423 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3424 if (specialCopIO(PL_curcop->cop_io))
3425 cop->cop_io = PL_curcop->cop_io;
3427 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3430 if (PL_copline == NOLINE)
3431 CopLINE_set(cop, CopLINE(PL_curcop));
3433 CopLINE_set(cop, PL_copline);
3434 PL_copline = NOLINE;
3437 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3439 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3441 CopSTASH_set(cop, PL_curstash);
3443 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3444 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3445 if (svp && *svp != &PL_sv_undef ) {
3446 (void)SvIOK_on(*svp);
3447 SvIVX(*svp) = PTR2IV(cop);
3451 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3456 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3458 return new_logop(type, flags, &first, &other);
3462 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3466 OP *first = *firstp;
3467 OP *other = *otherp;
3469 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3470 return newBINOP(type, flags, scalar(first), scalar(other));
3472 scalarboolean(first);
3473 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3474 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3475 if (type == OP_AND || type == OP_OR) {
3481 first = *firstp = cUNOPo->op_first;
3483 first->op_next = o->op_next;
3484 cUNOPo->op_first = Nullop;
3488 if (first->op_type == OP_CONST) {
3489 if (first->op_private & OPpCONST_STRICT)
3490 no_bareword_allowed(first);
3491 else if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3492 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3493 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
3494 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
3495 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
3498 if (other->op_type == OP_CONST)
3499 other->op_private |= OPpCONST_SHORTCIRCUIT;
3503 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
3505 if ( ! (o2->op_type == OP_LIST
3506 && (( o2 = cUNOPx(o2)->op_first))
3507 && o2->op_type == OP_PUSHMARK
3508 && (( o2 = o2->op_sibling)) )
3511 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
3512 || o2->op_type == OP_PADHV)
3513 && o2->op_private & OPpLVAL_INTRO
3514 && ckWARN(WARN_DEPRECATED))
3516 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
3517 "Deprecated use of my() in false conditional");
3522 if (first->op_type == OP_CONST)
3523 first->op_private |= OPpCONST_SHORTCIRCUIT;
3527 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS) &&
3528 type != OP_DOR) /* [#24076] Don't warn for <FH> err FOO. */
3530 OP *k1 = ((UNOP*)first)->op_first;
3531 OP *k2 = k1->op_sibling;
3533 switch (first->op_type)
3536 if (k2 && k2->op_type == OP_READLINE
3537 && (k2->op_flags & OPf_STACKED)
3538 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3540 warnop = k2->op_type;
3545 if (k1->op_type == OP_READDIR
3546 || k1->op_type == OP_GLOB
3547 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3548 || k1->op_type == OP_EACH)
3550 warnop = ((k1->op_type == OP_NULL)
3551 ? (OPCODE)k1->op_targ : k1->op_type);
3556 line_t oldline = CopLINE(PL_curcop);
3557 CopLINE_set(PL_curcop, PL_copline);
3558 Perl_warner(aTHX_ packWARN(WARN_MISC),
3559 "Value of %s%s can be \"0\"; test with defined()",
3561 ((warnop == OP_READLINE || warnop == OP_GLOB)
3562 ? " construct" : "() operator"));
3563 CopLINE_set(PL_curcop, oldline);
3570 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3571 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3573 NewOp(1101, logop, 1, LOGOP);
3575 logop->op_type = (OPCODE)type;
3576 logop->op_ppaddr = PL_ppaddr[type];
3577 logop->op_first = first;
3578 logop->op_flags = flags | OPf_KIDS;
3579 logop->op_other = LINKLIST(other);
3580 logop->op_private = (U8)(1 | (flags >> 8));
3582 /* establish postfix order */
3583 logop->op_next = LINKLIST(first);
3584 first->op_next = (OP*)logop;
3585 first->op_sibling = other;
3587 CHECKOP(type,logop);
3589 o = newUNOP(OP_NULL, 0, (OP*)logop);
3596 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3603 return newLOGOP(OP_AND, 0, first, trueop);
3605 return newLOGOP(OP_OR, 0, first, falseop);
3607 scalarboolean(first);
3608 if (first->op_type == OP_CONST) {
3609 if (first->op_private & OPpCONST_BARE &&
3610 first->op_private & OPpCONST_STRICT) {
3611 no_bareword_allowed(first);
3613 if (SvTRUE(((SVOP*)first)->op_sv)) {
3624 NewOp(1101, logop, 1, LOGOP);
3625 logop->op_type = OP_COND_EXPR;
3626 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3627 logop->op_first = first;
3628 logop->op_flags = flags | OPf_KIDS;
3629 logop->op_private = (U8)(1 | (flags >> 8));
3630 logop->op_other = LINKLIST(trueop);
3631 logop->op_next = LINKLIST(falseop);
3633 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
3636 /* establish postfix order */
3637 start = LINKLIST(first);
3638 first->op_next = (OP*)logop;
3640 first->op_sibling = trueop;
3641 trueop->op_sibling = falseop;
3642 o = newUNOP(OP_NULL, 0, (OP*)logop);
3644 trueop->op_next = falseop->op_next = o;
3651 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3659 NewOp(1101, range, 1, LOGOP);
3661 range->op_type = OP_RANGE;
3662 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3663 range->op_first = left;
3664 range->op_flags = OPf_KIDS;
3665 leftstart = LINKLIST(left);
3666 range->op_other = LINKLIST(right);
3667 range->op_private = (U8)(1 | (flags >> 8));
3669 left->op_sibling = right;
3671 range->op_next = (OP*)range;
3672 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3673 flop = newUNOP(OP_FLOP, 0, flip);
3674 o = newUNOP(OP_NULL, 0, flop);
3676 range->op_next = leftstart;
3678 left->op_next = flip;
3679 right->op_next = flop;
3681 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3682 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3683 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3684 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3686 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3687 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3690 if (!flip->op_private || !flop->op_private)
3691 linklist(o); /* blow off optimizer unless constant */
3697 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3701 int once = block && block->op_flags & OPf_SPECIAL &&
3702 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3705 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3706 return block; /* do {} while 0 does once */
3707 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3708 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3709 expr = newUNOP(OP_DEFINED, 0,
3710 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3711 } else if (expr->op_flags & OPf_KIDS) {
3712 OP *k1 = ((UNOP*)expr)->op_first;
3713 OP *k2 = (k1) ? k1->op_sibling : NULL;
3714 switch (expr->op_type) {
3716 if (k2 && k2->op_type == OP_READLINE
3717 && (k2->op_flags & OPf_STACKED)
3718 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3719 expr = newUNOP(OP_DEFINED, 0, expr);
3723 if (k1->op_type == OP_READDIR
3724 || k1->op_type == OP_GLOB
3725 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3726 || k1->op_type == OP_EACH)
3727 expr = newUNOP(OP_DEFINED, 0, expr);
3733 /* if block is null, the next append_elem() would put UNSTACK, a scalar
3734 * op, in listop. This is wrong. [perl #27024] */
3736 block = newOP(OP_NULL, 0);
3737 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3738 o = new_logop(OP_AND, 0, &expr, &listop);
3741 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3743 if (once && o != listop)
3744 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3747 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3749 o->op_flags |= flags;
3751 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3756 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3764 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3765 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3766 expr = newUNOP(OP_DEFINED, 0,
3767 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3768 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3769 OP *k1 = ((UNOP*)expr)->op_first;
3770 OP *k2 = (k1) ? k1->op_sibling : NULL;
3771 switch (expr->op_type) {
3773 if (k2 && k2->op_type == OP_READLINE
3774 && (k2->op_flags & OPf_STACKED)
3775 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3776 expr = newUNOP(OP_DEFINED, 0, expr);
3780 if (k1->op_type == OP_READDIR
3781 || k1->op_type == OP_GLOB
3782 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3783 || k1->op_type == OP_EACH)
3784 expr = newUNOP(OP_DEFINED, 0, expr);
3790 block = newOP(OP_NULL, 0);
3792 block = scope(block);
3796 next = LINKLIST(cont);
3799 OP *unstack = newOP(OP_UNSTACK, 0);
3802 cont = append_elem(OP_LINESEQ, cont, unstack);
3805 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3806 redo = LINKLIST(listop);
3809 PL_copline = (line_t)whileline;
3811 o = new_logop(OP_AND, 0, &expr, &listop);
3812 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3813 op_free(expr); /* oops, it's a while (0) */
3815 return Nullop; /* listop already freed by new_logop */
3818 ((LISTOP*)listop)->op_last->op_next =
3819 (o == listop ? redo : LINKLIST(o));
3825 NewOp(1101,loop,1,LOOP);
3826 loop->op_type = OP_ENTERLOOP;
3827 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3828 loop->op_private = 0;
3829 loop->op_next = (OP*)loop;
3832 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3834 loop->op_redoop = redo;
3835 loop->op_lastop = o;
3836 o->op_private |= loopflags;
3839 loop->op_nextop = next;
3841 loop->op_nextop = o;
3843 o->op_flags |= flags;
3844 o->op_private |= (flags >> 8);
3849 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
3853 PADOFFSET padoff = 0;
3858 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
3859 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
3860 sv->op_type = OP_RV2GV;
3861 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3863 else if (sv->op_type == OP_PADSV) { /* private variable */
3864 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
3865 padoff = sv->op_targ;
3870 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3871 padoff = sv->op_targ;
3873 iterflags |= OPf_SPECIAL;
3878 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3881 I32 offset = pad_findmy("$_");
3882 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
3883 sv = newGVOP(OP_GV, 0, PL_defgv);
3889 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3890 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3891 iterflags |= OPf_STACKED;
3893 else if (expr->op_type == OP_NULL &&
3894 (expr->op_flags & OPf_KIDS) &&
3895 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3897 /* Basically turn for($x..$y) into the same as for($x,$y), but we
3898 * set the STACKED flag to indicate that these values are to be
3899 * treated as min/max values by 'pp_iterinit'.
3901 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
3902 LOGOP* range = (LOGOP*) flip->op_first;
3903 OP* left = range->op_first;
3904 OP* right = left->op_sibling;
3907 range->op_flags &= ~OPf_KIDS;
3908 range->op_first = Nullop;
3910 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
3911 listop->op_first->op_next = range->op_next;
3912 left->op_next = range->op_other;
3913 right->op_next = (OP*)listop;
3914 listop->op_next = listop->op_first;
3917 expr = (OP*)(listop);
3919 iterflags |= OPf_STACKED;
3922 expr = mod(force_list(expr), OP_GREPSTART);
3926 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
3927 append_elem(OP_LIST, expr, scalar(sv))));
3928 assert(!loop->op_next);
3929 /* for my $x () sets OPpLVAL_INTRO;
3930 * for our $x () sets OPpOUR_INTRO */
3931 loop->op_private = (U8)iterpflags;
3932 #ifdef PL_OP_SLAB_ALLOC
3935 NewOp(1234,tmp,1,LOOP);
3936 Copy(loop,tmp,1,LOOP);
3941 Renew(loop, 1, LOOP);
3943 loop->op_targ = padoff;
3944 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
3945 PL_copline = forline;
3946 return newSTATEOP(0, label, wop);
3950 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
3955 if (type != OP_GOTO || label->op_type == OP_CONST) {
3956 /* "last()" means "last" */
3957 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
3958 o = newOP(type, OPf_SPECIAL);
3960 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
3961 ? SvPVx(((SVOP*)label)->op_sv, n_a)
3967 /* Check whether it's going to be a goto &function */
3968 if (label->op_type == OP_ENTERSUB
3969 && !(label->op_flags & OPf_STACKED))
3970 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
3971 o = newUNOP(type, OPf_STACKED, label);
3973 PL_hints |= HINT_BLOCK_SCOPE;
3978 =for apidoc cv_undef
3980 Clear out all the active components of a CV. This can happen either
3981 by an explicit C<undef &foo>, or by the reference count going to zero.
3982 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
3983 children can still follow the full lexical scope chain.
3989 Perl_cv_undef(pTHX_ CV *cv)
3992 if (CvFILE(cv) && !CvXSUB(cv)) {
3993 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
3994 Safefree(CvFILE(cv));
3999 if (!CvXSUB(cv) && CvROOT(cv)) {
4001 Perl_croak(aTHX_ "Can't undef active subroutine");
4004 PAD_SAVE_SETNULLPAD();
4006 op_free(CvROOT(cv));
4007 CvROOT(cv) = Nullop;
4010 SvPOK_off((SV*)cv); /* forget prototype */
4015 /* remove CvOUTSIDE unless this is an undef rather than a free */
4016 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4017 if (!CvWEAKOUTSIDE(cv))
4018 SvREFCNT_dec(CvOUTSIDE(cv));
4019 CvOUTSIDE(cv) = Nullcv;
4022 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4028 /* delete all flags except WEAKOUTSIDE */
4029 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4033 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4035 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4036 SV* msg = sv_newmortal();
4040 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4041 sv_setpv(msg, "Prototype mismatch:");
4043 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4045 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (SV *)cv);
4047 Perl_sv_catpvf(aTHX_ msg, ": none");
4048 sv_catpv(msg, " vs ");
4050 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4052 sv_catpv(msg, "none");
4053 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
4057 static void const_sv_xsub(pTHX_ CV* cv);
4061 =head1 Optree Manipulation Functions
4063 =for apidoc cv_const_sv
4065 If C<cv> is a constant sub eligible for inlining. returns the constant
4066 value returned by the sub. Otherwise, returns NULL.
4068 Constant subs can be created with C<newCONSTSUB> or as described in
4069 L<perlsub/"Constant Functions">.
4074 Perl_cv_const_sv(pTHX_ CV *cv)
4076 if (!cv || !CvCONST(cv))
4078 return (SV*)CvXSUBANY(cv).any_ptr;
4081 /* op_const_sv: examine an optree to determine whether it's in-lineable.
4082 * Can be called in 3 ways:
4085 * look for a single OP_CONST with attached value: return the value
4087 * cv && CvCLONE(cv) && !CvCONST(cv)
4089 * examine the clone prototype, and if contains only a single
4090 * OP_CONST referencing a pad const, or a single PADSV referencing
4091 * an outer lexical, return a non-zero value to indicate the CV is
4092 * a candidate for "constizing" at clone time
4096 * We have just cloned an anon prototype that was marked as a const
4097 * candidiate. Try to grab the current value, and in the case of
4098 * PADSV, ignore it if it has multiple references. Return the value.
4102 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4109 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4110 o = cLISTOPo->op_first->op_sibling;
4112 for (; o; o = o->op_next) {
4113 OPCODE type = o->op_type;
4115 if (sv && o->op_next == o)
4117 if (o->op_next != o) {
4118 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4120 if (type == OP_DBSTATE)
4123 if (type == OP_LEAVESUB || type == OP_RETURN)
4127 if (type == OP_CONST && cSVOPo->op_sv)
4129 else if (cv && type == OP_CONST) {
4130 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4134 else if (cv && type == OP_PADSV) {
4135 if (CvCONST(cv)) { /* newly cloned anon */
4136 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4137 /* the candidate should have 1 ref from this pad and 1 ref
4138 * from the parent */
4139 if (!sv || SvREFCNT(sv) != 2)
4146 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4147 sv = &PL_sv_undef; /* an arbitrary non-null value */
4158 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4168 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4172 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4174 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4178 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4188 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4191 assert(proto->op_type == OP_CONST);
4192 ps = SvPVx(((SVOP*)proto)->op_sv, n_a);
4197 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4198 SV *sv = sv_newmortal();
4199 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4200 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4201 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4206 gv = gv_fetchpv(name ? name : (aname ? aname :
4207 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__")),
4208 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4218 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4219 maximum a prototype before. */
4220 if (SvTYPE(gv) > SVt_NULL) {
4221 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4222 && ckWARN_d(WARN_PROTOTYPE))
4224 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4226 cv_ckproto((CV*)gv, NULL, ps);
4229 sv_setpv((SV*)gv, ps);
4231 sv_setiv((SV*)gv, -1);
4232 SvREFCNT_dec(PL_compcv);
4233 cv = PL_compcv = NULL;
4234 PL_sub_generation++;
4238 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4240 #ifdef GV_UNIQUE_CHECK
4241 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4242 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4246 if (!block || !ps || *ps || attrs)
4249 const_sv = op_const_sv(block, Nullcv);
4252 bool exists = CvROOT(cv) || CvXSUB(cv);
4254 #ifdef GV_UNIQUE_CHECK
4255 if (exists && GvUNIQUE(gv)) {
4256 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4260 /* if the subroutine doesn't exist and wasn't pre-declared
4261 * with a prototype, assume it will be AUTOLOADed,
4262 * skipping the prototype check
4264 if (exists || SvPOK(cv))
4265 cv_ckproto(cv, gv, ps);
4266 /* already defined (or promised)? */
4267 if (exists || GvASSUMECV(gv)) {
4268 if (!block && !attrs) {
4269 if (CvFLAGS(PL_compcv)) {
4270 /* might have had built-in attrs applied */
4271 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4273 /* just a "sub foo;" when &foo is already defined */
4274 SAVEFREESV(PL_compcv);
4277 /* ahem, death to those who redefine active sort subs */
4278 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4279 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4281 if (ckWARN(WARN_REDEFINE)
4283 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4285 line_t oldline = CopLINE(PL_curcop);
4286 if (PL_copline != NOLINE)
4287 CopLINE_set(PL_curcop, PL_copline);
4288 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4289 CvCONST(cv) ? "Constant subroutine %s redefined"
4290 : "Subroutine %s redefined", name);
4291 CopLINE_set(PL_curcop, oldline);
4299 SvREFCNT_inc(const_sv);
4301 assert(!CvROOT(cv) && !CvCONST(cv));
4302 sv_setpv((SV*)cv, ""); /* prototype is "" */
4303 CvXSUBANY(cv).any_ptr = const_sv;
4304 CvXSUB(cv) = const_sv_xsub;
4309 cv = newCONSTSUB(NULL, name, const_sv);
4312 SvREFCNT_dec(PL_compcv);
4314 PL_sub_generation++;
4321 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4322 * before we clobber PL_compcv.
4326 /* Might have had built-in attributes applied -- propagate them. */
4327 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4328 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4329 stash = GvSTASH(CvGV(cv));
4330 else if (CvSTASH(cv))
4331 stash = CvSTASH(cv);
4333 stash = PL_curstash;
4336 /* possibly about to re-define existing subr -- ignore old cv */
4337 rcv = (SV*)PL_compcv;
4338 if (name && GvSTASH(gv))
4339 stash = GvSTASH(gv);
4341 stash = PL_curstash;
4343 apply_attrs(stash, rcv, attrs, FALSE);
4345 if (cv) { /* must reuse cv if autoloaded */
4347 /* got here with just attrs -- work done, so bug out */
4348 SAVEFREESV(PL_compcv);
4351 /* transfer PL_compcv to cv */
4353 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4354 if (!CvWEAKOUTSIDE(cv))
4355 SvREFCNT_dec(CvOUTSIDE(cv));
4356 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4357 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4358 CvOUTSIDE(PL_compcv) = 0;
4359 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4360 CvPADLIST(PL_compcv) = 0;
4361 /* inner references to PL_compcv must be fixed up ... */
4362 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4363 /* ... before we throw it away */
4364 SvREFCNT_dec(PL_compcv);
4366 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4367 ++PL_sub_generation;
4374 PL_sub_generation++;
4378 CvFILE_set_from_cop(cv, PL_curcop);
4379 CvSTASH(cv) = PL_curstash;
4382 sv_setpv((SV*)cv, ps);
4384 if (PL_error_count) {
4388 char *s = strrchr(name, ':');
4390 if (strEQ(s, "BEGIN")) {
4392 "BEGIN not safe after errors--compilation aborted";
4393 if (PL_in_eval & EVAL_KEEPERR)
4394 Perl_croak(aTHX_ not_safe);
4396 /* force display of errors found but not reported */
4397 sv_catpv(ERRSV, not_safe);
4398 Perl_croak(aTHX_ "%"SVf, ERRSV);
4407 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4408 mod(scalarseq(block), OP_LEAVESUBLV));
4411 /* This makes sub {}; work as expected. */
4412 if (block->op_type == OP_STUB) {
4414 block = newSTATEOP(0, Nullch, 0);
4416 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4418 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4419 OpREFCNT_set(CvROOT(cv), 1);
4420 CvSTART(cv) = LINKLIST(CvROOT(cv));
4421 CvROOT(cv)->op_next = 0;
4422 CALL_PEEP(CvSTART(cv));
4424 /* now that optimizer has done its work, adjust pad values */
4426 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4429 assert(!CvCONST(cv));
4430 if (ps && !*ps && op_const_sv(block, cv))
4434 if (name || aname) {
4436 char *tname = (name ? name : aname);
4438 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4439 SV *sv = NEWSV(0,0);
4440 SV *tmpstr = sv_newmortal();
4441 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4445 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4447 (long)PL_subline, (long)CopLINE(PL_curcop));
4448 gv_efullname3(tmpstr, gv, Nullch);
4449 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4450 hv = GvHVn(db_postponed);
4451 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4452 && (pcv = GvCV(db_postponed)))
4458 call_sv((SV*)pcv, G_DISCARD);
4462 if ((s = strrchr(tname,':')))
4467 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4470 if (strEQ(s, "BEGIN") && !PL_error_count) {
4471 I32 oldscope = PL_scopestack_ix;
4473 SAVECOPFILE(&PL_compiling);
4474 SAVECOPLINE(&PL_compiling);
4477 PL_beginav = newAV();
4478 DEBUG_x( dump_sub(gv) );
4479 av_push(PL_beginav, (SV*)cv);
4480 GvCV(gv) = 0; /* cv has been hijacked */
4481 call_list(oldscope, PL_beginav);
4483 PL_curcop = &PL_compiling;
4484 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4487 else if (strEQ(s, "END") && !PL_error_count) {
4490 DEBUG_x( dump_sub(gv) );
4491 av_unshift(PL_endav, 1);
4492 av_store(PL_endav, 0, (SV*)cv);
4493 GvCV(gv) = 0; /* cv has been hijacked */
4495 else if (strEQ(s, "CHECK") && !PL_error_count) {
4497 PL_checkav = newAV();
4498 DEBUG_x( dump_sub(gv) );
4499 if (PL_main_start && ckWARN(WARN_VOID))
4500 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4501 av_unshift(PL_checkav, 1);
4502 av_store(PL_checkav, 0, (SV*)cv);
4503 GvCV(gv) = 0; /* cv has been hijacked */
4505 else if (strEQ(s, "INIT") && !PL_error_count) {
4507 PL_initav = newAV();
4508 DEBUG_x( dump_sub(gv) );
4509 if (PL_main_start && ckWARN(WARN_VOID))
4510 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4511 av_push(PL_initav, (SV*)cv);
4512 GvCV(gv) = 0; /* cv has been hijacked */
4517 PL_copline = NOLINE;
4522 /* XXX unsafe for threads if eval_owner isn't held */
4524 =for apidoc newCONSTSUB
4526 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4527 eligible for inlining at compile-time.
4533 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4539 SAVECOPLINE(PL_curcop);
4540 CopLINE_set(PL_curcop, PL_copline);
4543 PL_hints &= ~HINT_BLOCK_SCOPE;
4546 SAVESPTR(PL_curstash);
4547 SAVECOPSTASH(PL_curcop);
4548 PL_curstash = stash;
4549 CopSTASH_set(PL_curcop,stash);
4552 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4553 CvXSUBANY(cv).any_ptr = sv;
4555 sv_setpv((SV*)cv, ""); /* prototype is "" */
4558 CopSTASH_free(PL_curcop);
4566 =for apidoc U||newXS
4568 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4574 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
4576 GV *gv = gv_fetchpv(name ? name :
4577 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4578 GV_ADDMULTI, SVt_PVCV);
4582 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4584 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4586 /* just a cached method */
4590 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4591 /* already defined (or promised) */
4592 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4593 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4594 line_t oldline = CopLINE(PL_curcop);
4595 if (PL_copline != NOLINE)
4596 CopLINE_set(PL_curcop, PL_copline);
4597 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4598 CvCONST(cv) ? "Constant subroutine %s redefined"
4599 : "Subroutine %s redefined"
4601 CopLINE_set(PL_curcop, oldline);
4608 if (cv) /* must reuse cv if autoloaded */
4611 cv = (CV*)NEWSV(1105,0);
4612 sv_upgrade((SV *)cv, SVt_PVCV);
4616 PL_sub_generation++;
4620 (void)gv_fetchfile(filename);
4621 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
4622 an external constant string */
4623 CvXSUB(cv) = subaddr;
4626 char *s = strrchr(name,':');
4632 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4635 if (strEQ(s, "BEGIN")) {
4637 PL_beginav = newAV();
4638 av_push(PL_beginav, (SV*)cv);
4639 GvCV(gv) = 0; /* cv has been hijacked */
4641 else if (strEQ(s, "END")) {
4644 av_unshift(PL_endav, 1);
4645 av_store(PL_endav, 0, (SV*)cv);
4646 GvCV(gv) = 0; /* cv has been hijacked */
4648 else if (strEQ(s, "CHECK")) {
4650 PL_checkav = newAV();
4651 if (PL_main_start && ckWARN(WARN_VOID))
4652 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4653 av_unshift(PL_checkav, 1);
4654 av_store(PL_checkav, 0, (SV*)cv);
4655 GvCV(gv) = 0; /* cv has been hijacked */
4657 else if (strEQ(s, "INIT")) {
4659 PL_initav = newAV();
4660 if (PL_main_start && ckWARN(WARN_VOID))
4661 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4662 av_push(PL_initav, (SV*)cv);
4663 GvCV(gv) = 0; /* cv has been hijacked */
4674 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4682 name = SvPVx(cSVOPo->op_sv, n_a);
4685 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
4686 #ifdef GV_UNIQUE_CHECK
4688 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4692 if ((cv = GvFORM(gv))) {
4693 if (ckWARN(WARN_REDEFINE)) {
4694 line_t oldline = CopLINE(PL_curcop);
4695 if (PL_copline != NOLINE)
4696 CopLINE_set(PL_curcop, PL_copline);
4697 Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Format %s redefined",name);
4698 CopLINE_set(PL_curcop, oldline);
4705 CvFILE_set_from_cop(cv, PL_curcop);
4708 pad_tidy(padtidy_FORMAT);
4709 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4710 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4711 OpREFCNT_set(CvROOT(cv), 1);
4712 CvSTART(cv) = LINKLIST(CvROOT(cv));
4713 CvROOT(cv)->op_next = 0;
4714 CALL_PEEP(CvSTART(cv));
4716 PL_copline = NOLINE;
4721 Perl_newANONLIST(pTHX_ OP *o)
4723 return newUNOP(OP_REFGEN, 0,
4724 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4728 Perl_newANONHASH(pTHX_ OP *o)
4730 return newUNOP(OP_REFGEN, 0,
4731 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4735 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4737 return newANONATTRSUB(floor, proto, Nullop, block);
4741 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4743 return newUNOP(OP_REFGEN, 0,
4744 newSVOP(OP_ANONCODE, 0,
4745 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
4749 Perl_oopsAV(pTHX_ OP *o)
4751 switch (o->op_type) {
4753 o->op_type = OP_PADAV;
4754 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4755 return ref(o, OP_RV2AV);
4758 o->op_type = OP_RV2AV;
4759 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4764 if (ckWARN_d(WARN_INTERNAL))
4765 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
4772 Perl_oopsHV(pTHX_ OP *o)
4774 switch (o->op_type) {
4777 o->op_type = OP_PADHV;
4778 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4779 return ref(o, OP_RV2HV);
4783 o->op_type = OP_RV2HV;
4784 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
4789 if (ckWARN_d(WARN_INTERNAL))
4790 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
4797 Perl_newAVREF(pTHX_ OP *o)
4799 if (o->op_type == OP_PADANY) {
4800 o->op_type = OP_PADAV;
4801 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4804 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
4805 && ckWARN(WARN_DEPRECATED)) {
4806 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4807 "Using an array as a reference is deprecated");
4809 return newUNOP(OP_RV2AV, 0, scalar(o));
4813 Perl_newGVREF(pTHX_ I32 type, OP *o)
4815 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
4816 return newUNOP(OP_NULL, 0, o);
4817 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
4821 Perl_newHVREF(pTHX_ OP *o)
4823 if (o->op_type == OP_PADANY) {
4824 o->op_type = OP_PADHV;
4825 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4828 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
4829 && ckWARN(WARN_DEPRECATED)) {
4830 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4831 "Using a hash as a reference is deprecated");
4833 return newUNOP(OP_RV2HV, 0, scalar(o));
4837 Perl_oopsCV(pTHX_ OP *o)
4839 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
4845 Perl_newCVREF(pTHX_ I32 flags, OP *o)
4847 return newUNOP(OP_RV2CV, flags, scalar(o));
4851 Perl_newSVREF(pTHX_ OP *o)
4853 if (o->op_type == OP_PADANY) {
4854 o->op_type = OP_PADSV;
4855 o->op_ppaddr = PL_ppaddr[OP_PADSV];
4858 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4859 o->op_flags |= OPpDONE_SVREF;
4862 return newUNOP(OP_RV2SV, 0, scalar(o));
4865 /* Check routines. See the comments at the top of this file for details
4866 * on when these are called */
4869 Perl_ck_anoncode(pTHX_ OP *o)
4871 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
4872 cSVOPo->op_sv = Nullsv;
4877 Perl_ck_bitop(pTHX_ OP *o)
4879 #define OP_IS_NUMCOMPARE(op) \
4880 ((op) == OP_LT || (op) == OP_I_LT || \
4881 (op) == OP_GT || (op) == OP_I_GT || \
4882 (op) == OP_LE || (op) == OP_I_LE || \
4883 (op) == OP_GE || (op) == OP_I_GE || \
4884 (op) == OP_EQ || (op) == OP_I_EQ || \
4885 (op) == OP_NE || (op) == OP_I_NE || \
4886 (op) == OP_NCMP || (op) == OP_I_NCMP)
4887 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4888 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
4889 && (o->op_type == OP_BIT_OR
4890 || o->op_type == OP_BIT_AND
4891 || o->op_type == OP_BIT_XOR))
4893 OP * left = cBINOPo->op_first;
4894 OP * right = left->op_sibling;
4895 if ((OP_IS_NUMCOMPARE(left->op_type) &&
4896 (left->op_flags & OPf_PARENS) == 0) ||
4897 (OP_IS_NUMCOMPARE(right->op_type) &&
4898 (right->op_flags & OPf_PARENS) == 0))
4899 if (ckWARN(WARN_PRECEDENCE))
4900 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4901 "Possible precedence problem on bitwise %c operator",
4902 o->op_type == OP_BIT_OR ? '|'
4903 : o->op_type == OP_BIT_AND ? '&' : '^'
4910 Perl_ck_concat(pTHX_ OP *o)
4912 OP *kid = cUNOPo->op_first;
4913 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
4914 !(kUNOP->op_first->op_flags & OPf_MOD))
4915 o->op_flags |= OPf_STACKED;
4920 Perl_ck_spair(pTHX_ OP *o)
4922 if (o->op_flags & OPf_KIDS) {
4925 OPCODE type = o->op_type;
4926 o = modkids(ck_fun(o), type);
4927 kid = cUNOPo->op_first;
4928 newop = kUNOP->op_first->op_sibling;
4930 (newop->op_sibling ||
4931 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
4932 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
4933 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
4937 op_free(kUNOP->op_first);
4938 kUNOP->op_first = newop;
4940 o->op_ppaddr = PL_ppaddr[++o->op_type];
4945 Perl_ck_delete(pTHX_ OP *o)
4949 if (o->op_flags & OPf_KIDS) {
4950 OP *kid = cUNOPo->op_first;
4951 switch (kid->op_type) {
4953 o->op_flags |= OPf_SPECIAL;
4956 o->op_private |= OPpSLICE;
4959 o->op_flags |= OPf_SPECIAL;
4964 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
4973 Perl_ck_die(pTHX_ OP *o)
4976 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4982 Perl_ck_eof(pTHX_ OP *o)
4984 I32 type = o->op_type;
4986 if (o->op_flags & OPf_KIDS) {
4987 if (cLISTOPo->op_first->op_type == OP_STUB) {
4989 o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
4997 Perl_ck_eval(pTHX_ OP *o)
4999 PL_hints |= HINT_BLOCK_SCOPE;
5000 if (o->op_flags & OPf_KIDS) {
5001 SVOP *kid = (SVOP*)cUNOPo->op_first;
5004 o->op_flags &= ~OPf_KIDS;
5007 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
5010 cUNOPo->op_first = 0;
5013 NewOp(1101, enter, 1, LOGOP);
5014 enter->op_type = OP_ENTERTRY;
5015 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5016 enter->op_private = 0;
5018 /* establish postfix order */
5019 enter->op_next = (OP*)enter;
5021 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5022 o->op_type = OP_LEAVETRY;
5023 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5024 enter->op_other = o;
5034 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5036 o->op_targ = (PADOFFSET)PL_hints;
5041 Perl_ck_exit(pTHX_ OP *o)
5044 HV *table = GvHV(PL_hintgv);
5046 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5047 if (svp && *svp && SvTRUE(*svp))
5048 o->op_private |= OPpEXIT_VMSISH;
5050 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5056 Perl_ck_exec(pTHX_ OP *o)
5059 if (o->op_flags & OPf_STACKED) {
5061 kid = cUNOPo->op_first->op_sibling;
5062 if (kid->op_type == OP_RV2GV)
5071 Perl_ck_exists(pTHX_ OP *o)
5074 if (o->op_flags & OPf_KIDS) {
5075 OP *kid = cUNOPo->op_first;
5076 if (kid->op_type == OP_ENTERSUB) {
5077 (void) ref(kid, o->op_type);
5078 if (kid->op_type != OP_RV2CV && !PL_error_count)
5079 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5081 o->op_private |= OPpEXISTS_SUB;
5083 else if (kid->op_type == OP_AELEM)
5084 o->op_flags |= OPf_SPECIAL;
5085 else if (kid->op_type != OP_HELEM)
5086 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5095 Perl_ck_gvconst(pTHX_ register OP *o)
5097 o = fold_constants(o);
5098 if (o->op_type == OP_CONST)
5105 Perl_ck_rvconst(pTHX_ register OP *o)
5107 SVOP *kid = (SVOP*)cUNOPo->op_first;
5109 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5110 if (kid->op_type == OP_CONST) {
5114 SV *kidsv = kid->op_sv;
5117 /* Is it a constant from cv_const_sv()? */
5118 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5119 SV *rsv = SvRV(kidsv);
5120 int svtype = SvTYPE(rsv);
5121 char *badtype = Nullch;
5123 switch (o->op_type) {
5125 if (svtype > SVt_PVMG)
5126 badtype = "a SCALAR";
5129 if (svtype != SVt_PVAV)
5130 badtype = "an ARRAY";
5133 if (svtype != SVt_PVHV)
5137 if (svtype != SVt_PVCV)
5142 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5145 name = SvPV(kidsv, n_a);
5146 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5147 char *badthing = Nullch;
5148 switch (o->op_type) {
5150 badthing = "a SCALAR";
5153 badthing = "an ARRAY";
5156 badthing = "a HASH";
5161 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5165 * This is a little tricky. We only want to add the symbol if we
5166 * didn't add it in the lexer. Otherwise we get duplicate strict
5167 * warnings. But if we didn't add it in the lexer, we must at
5168 * least pretend like we wanted to add it even if it existed before,
5169 * or we get possible typo warnings. OPpCONST_ENTERED says
5170 * whether the lexer already added THIS instance of this symbol.
5172 iscv = (o->op_type == OP_RV2CV) * 2;
5174 gv = gv_fetchpv(name,
5175 iscv | !(kid->op_private & OPpCONST_ENTERED),
5178 : o->op_type == OP_RV2SV
5180 : o->op_type == OP_RV2AV
5182 : o->op_type == OP_RV2HV
5185 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5187 kid->op_type = OP_GV;
5188 SvREFCNT_dec(kid->op_sv);
5190 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5191 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5192 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
5194 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
5196 kid->op_sv = SvREFCNT_inc(gv);
5198 kid->op_private = 0;
5199 kid->op_ppaddr = PL_ppaddr[OP_GV];
5206 Perl_ck_ftst(pTHX_ OP *o)
5208 I32 type = o->op_type;
5210 if (o->op_flags & OPf_REF) {
5213 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5214 SVOP *kid = (SVOP*)cUNOPo->op_first;
5216 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5218 OP *newop = newGVOP(type, OPf_REF,
5219 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5225 if ((PL_hints & HINT_FILETEST_ACCESS) &&
5226 OP_IS_FILETEST_ACCESS(o))
5227 o->op_private |= OPpFT_ACCESS;
5229 if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
5230 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
5231 o->op_private |= OPpFT_STACKED;
5235 if (type == OP_FTTTY)
5236 o = newGVOP(type, OPf_REF, PL_stdingv);
5238 o = newUNOP(type, 0, newDEFSVOP());
5244 Perl_ck_fun(pTHX_ OP *o)
5250 int type = o->op_type;
5251 register I32 oa = PL_opargs[type] >> OASHIFT;
5253 if (o->op_flags & OPf_STACKED) {
5254 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5257 return no_fh_allowed(o);
5260 if (o->op_flags & OPf_KIDS) {
5262 tokid = &cLISTOPo->op_first;
5263 kid = cLISTOPo->op_first;
5264 if (kid->op_type == OP_PUSHMARK ||
5265 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5267 tokid = &kid->op_sibling;
5268 kid = kid->op_sibling;
5270 if (!kid && PL_opargs[type] & OA_DEFGV)
5271 *tokid = kid = newDEFSVOP();
5275 sibl = kid->op_sibling;
5278 /* list seen where single (scalar) arg expected? */
5279 if (numargs == 1 && !(oa >> 4)
5280 && kid->op_type == OP_LIST && type != OP_SCALAR)
5282 return too_many_arguments(o,PL_op_desc[type]);
5295 if ((type == OP_PUSH || type == OP_UNSHIFT)
5296 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5297 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5298 "Useless use of %s with no values",
5301 if (kid->op_type == OP_CONST &&
5302 (kid->op_private & OPpCONST_BARE))
5304 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5305 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5306 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5307 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5308 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5309 "Array @%s missing the @ in argument %"IVdf" of %s()",
5310 name, (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 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5325 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5326 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5327 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5328 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5329 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5330 name, (IV)numargs, PL_op_desc[type]);
5333 kid->op_sibling = sibl;
5336 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5337 bad_type(numargs, "hash", PL_op_desc[type], kid);
5342 OP *newop = newUNOP(OP_NULL, 0, kid);
5343 kid->op_sibling = 0;
5345 newop->op_next = newop;
5347 kid->op_sibling = sibl;
5352 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5353 if (kid->op_type == OP_CONST &&
5354 (kid->op_private & OPpCONST_BARE))
5356 OP *newop = newGVOP(OP_GV, 0,
5357 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5359 if (!(o->op_private & 1) && /* if not unop */
5360 kid == cLISTOPo->op_last)
5361 cLISTOPo->op_last = newop;
5365 else if (kid->op_type == OP_READLINE) {
5366 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5367 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5370 I32 flags = OPf_SPECIAL;
5374 /* is this op a FH constructor? */
5375 if (is_handle_constructor(o,numargs)) {
5376 char *name = Nullch;
5380 /* Set a flag to tell rv2gv to vivify
5381 * need to "prove" flag does not mean something
5382 * else already - NI-S 1999/05/07
5385 if (kid->op_type == OP_PADSV) {
5386 name = PAD_COMPNAME_PV(kid->op_targ);
5387 /* SvCUR of a pad namesv can't be trusted
5388 * (see PL_generation), so calc its length
5394 else if (kid->op_type == OP_RV2SV
5395 && kUNOP->op_first->op_type == OP_GV)
5397 GV *gv = cGVOPx_gv(kUNOP->op_first);
5399 len = GvNAMELEN(gv);
5401 else if (kid->op_type == OP_AELEM
5402 || kid->op_type == OP_HELEM)
5407 if ((op = ((BINOP*)kid)->op_first)) {
5408 SV *tmpstr = Nullsv;
5410 kid->op_type == OP_AELEM ?
5412 if (((op->op_type == OP_RV2AV) ||
5413 (op->op_type == OP_RV2HV)) &&
5414 (op = ((UNOP*)op)->op_first) &&
5415 (op->op_type == OP_GV)) {
5416 /* packagevar $a[] or $h{} */
5417 GV *gv = cGVOPx_gv(op);
5425 else if (op->op_type == OP_PADAV
5426 || op->op_type == OP_PADHV) {
5427 /* lexicalvar $a[] or $h{} */
5429 PAD_COMPNAME_PV(op->op_targ);
5439 name = SvPV(tmpstr, len);
5444 name = "__ANONIO__";
5451 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5452 namesv = PAD_SVl(targ);
5453 (void)SvUPGRADE(namesv, SVt_PV);
5455 sv_setpvn(namesv, "$", 1);
5456 sv_catpvn(namesv, name, len);
5459 kid->op_sibling = 0;
5460 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5461 kid->op_targ = targ;
5462 kid->op_private |= priv;
5464 kid->op_sibling = sibl;
5470 mod(scalar(kid), type);
5474 tokid = &kid->op_sibling;
5475 kid = kid->op_sibling;
5477 o->op_private |= numargs;
5479 return too_many_arguments(o,OP_DESC(o));
5482 else if (PL_opargs[type] & OA_DEFGV) {
5484 return newUNOP(type, 0, newDEFSVOP());
5488 while (oa & OA_OPTIONAL)
5490 if (oa && oa != OA_LIST)
5491 return too_few_arguments(o,OP_DESC(o));
5497 Perl_ck_glob(pTHX_ OP *o)
5502 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5503 append_elem(OP_GLOB, o, newDEFSVOP());
5505 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5506 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5508 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5511 #if !defined(PERL_EXTERNAL_GLOB)
5512 /* XXX this can be tightened up and made more failsafe. */
5513 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5516 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5517 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5518 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5519 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5520 GvCV(gv) = GvCV(glob_gv);
5521 SvREFCNT_inc((SV*)GvCV(gv));
5522 GvIMPORTED_CV_on(gv);
5525 #endif /* PERL_EXTERNAL_GLOB */
5527 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5528 append_elem(OP_GLOB, o,
5529 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5530 o->op_type = OP_LIST;
5531 o->op_ppaddr = PL_ppaddr[OP_LIST];
5532 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5533 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5534 cLISTOPo->op_first->op_targ = 0;
5535 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5536 append_elem(OP_LIST, o,
5537 scalar(newUNOP(OP_RV2CV, 0,
5538 newGVOP(OP_GV, 0, gv)))));
5539 o = newUNOP(OP_NULL, 0, ck_subr(o));
5540 o->op_targ = OP_GLOB; /* hint at what it used to be */
5543 gv = newGVgen("main");
5545 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5551 Perl_ck_grep(pTHX_ OP *o)
5555 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5558 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5559 NewOp(1101, gwop, 1, LOGOP);
5561 if (o->op_flags & OPf_STACKED) {
5564 kid = cLISTOPo->op_first->op_sibling;
5565 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
5568 kid->op_next = (OP*)gwop;
5569 o->op_flags &= ~OPf_STACKED;
5571 kid = cLISTOPo->op_first->op_sibling;
5572 if (type == OP_MAPWHILE)
5579 kid = cLISTOPo->op_first->op_sibling;
5580 if (kid->op_type != OP_NULL)
5581 Perl_croak(aTHX_ "panic: ck_grep");
5582 kid = kUNOP->op_first;
5584 gwop->op_type = type;
5585 gwop->op_ppaddr = PL_ppaddr[type];
5586 gwop->op_first = listkids(o);
5587 gwop->op_flags |= OPf_KIDS;
5588 gwop->op_other = LINKLIST(kid);
5589 kid->op_next = (OP*)gwop;
5590 offset = pad_findmy("$_");
5591 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
5592 o->op_private = gwop->op_private = 0;
5593 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5596 o->op_private = gwop->op_private = OPpGREP_LEX;
5597 gwop->op_targ = o->op_targ = offset;
5600 kid = cLISTOPo->op_first->op_sibling;
5601 if (!kid || !kid->op_sibling)
5602 return too_few_arguments(o,OP_DESC(o));
5603 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5604 mod(kid, OP_GREPSTART);
5610 Perl_ck_index(pTHX_ OP *o)
5612 if (o->op_flags & OPf_KIDS) {
5613 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5615 kid = kid->op_sibling; /* get past "big" */
5616 if (kid && kid->op_type == OP_CONST)
5617 fbm_compile(((SVOP*)kid)->op_sv, 0);
5623 Perl_ck_lengthconst(pTHX_ OP *o)
5625 /* XXX length optimization goes here */
5630 Perl_ck_lfun(pTHX_ OP *o)
5632 OPCODE type = o->op_type;
5633 return modkids(ck_fun(o), type);
5637 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5639 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5640 switch (cUNOPo->op_first->op_type) {
5642 /* This is needed for
5643 if (defined %stash::)
5644 to work. Do not break Tk.
5646 break; /* Globals via GV can be undef */
5648 case OP_AASSIGN: /* Is this a good idea? */
5649 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5650 "defined(@array) is deprecated");
5651 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5652 "\t(Maybe you should just omit the defined()?)\n");
5655 /* This is needed for
5656 if (defined %stash::)
5657 to work. Do not break Tk.
5659 break; /* Globals via GV can be undef */
5661 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5662 "defined(%%hash) is deprecated");
5663 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5664 "\t(Maybe you should just omit the defined()?)\n");
5675 Perl_ck_rfun(pTHX_ OP *o)
5677 OPCODE type = o->op_type;
5678 return refkids(ck_fun(o), type);
5682 Perl_ck_listiob(pTHX_ OP *o)
5686 kid = cLISTOPo->op_first;
5689 kid = cLISTOPo->op_first;
5691 if (kid->op_type == OP_PUSHMARK)
5692 kid = kid->op_sibling;
5693 if (kid && o->op_flags & OPf_STACKED)
5694 kid = kid->op_sibling;
5695 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5696 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5697 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5698 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5699 cLISTOPo->op_first->op_sibling = kid;
5700 cLISTOPo->op_last = kid;
5701 kid = kid->op_sibling;
5706 append_elem(o->op_type, o, newDEFSVOP());
5712 Perl_ck_sassign(pTHX_ OP *o)
5714 OP *kid = cLISTOPo->op_first;
5715 /* has a disposable target? */
5716 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5717 && !(kid->op_flags & OPf_STACKED)
5718 /* Cannot steal the second time! */
5719 && !(kid->op_private & OPpTARGET_MY))
5721 OP *kkid = kid->op_sibling;
5723 /* Can just relocate the target. */
5724 if (kkid && kkid->op_type == OP_PADSV
5725 && !(kkid->op_private & OPpLVAL_INTRO))
5727 kid->op_targ = kkid->op_targ;
5729 /* Now we do not need PADSV and SASSIGN. */
5730 kid->op_sibling = o->op_sibling; /* NULL */
5731 cLISTOPo->op_first = NULL;
5734 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
5738 /* optimise C<my $x = undef> to C<my $x> */
5739 if (kid->op_type == OP_UNDEF) {
5740 OP *kkid = kid->op_sibling;
5741 if (kkid && kkid->op_type == OP_PADSV
5742 && (kkid->op_private & OPpLVAL_INTRO))
5744 cLISTOPo->op_first = NULL;
5745 kid->op_sibling = NULL;
5755 Perl_ck_match(pTHX_ OP *o)
5757 if (o->op_type != OP_QR) {
5758 I32 offset = pad_findmy("$_");
5759 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS(offset) & SVpad_OUR)) {
5760 o->op_targ = offset;
5761 o->op_private |= OPpTARGET_MY;
5764 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
5765 o->op_private |= OPpRUNTIME;
5770 Perl_ck_method(pTHX_ OP *o)
5772 OP *kid = cUNOPo->op_first;
5773 if (kid->op_type == OP_CONST) {
5774 SV* sv = kSVOP->op_sv;
5775 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
5777 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5778 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
5781 kSVOP->op_sv = Nullsv;
5783 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5792 Perl_ck_null(pTHX_ OP *o)
5798 Perl_ck_open(pTHX_ OP *o)
5800 HV *table = GvHV(PL_hintgv);
5804 svp = hv_fetch(table, "open_IN", 7, FALSE);
5806 mode = mode_from_discipline(*svp);
5807 if (mode & O_BINARY)
5808 o->op_private |= OPpOPEN_IN_RAW;
5809 else if (mode & O_TEXT)
5810 o->op_private |= OPpOPEN_IN_CRLF;
5813 svp = hv_fetch(table, "open_OUT", 8, FALSE);
5815 mode = mode_from_discipline(*svp);
5816 if (mode & O_BINARY)
5817 o->op_private |= OPpOPEN_OUT_RAW;
5818 else if (mode & O_TEXT)
5819 o->op_private |= OPpOPEN_OUT_CRLF;
5822 if (o->op_type == OP_BACKTICK)
5825 /* In case of three-arg dup open remove strictness
5826 * from the last arg if it is a bareword. */
5827 OP *first = cLISTOPx(o)->op_first; /* The pushmark. */
5828 OP *last = cLISTOPx(o)->op_last; /* The bareword. */
5832 if ((last->op_type == OP_CONST) && /* The bareword. */
5833 (last->op_private & OPpCONST_BARE) &&
5834 (last->op_private & OPpCONST_STRICT) &&
5835 (oa = first->op_sibling) && /* The fh. */
5836 (oa = oa->op_sibling) && /* The mode. */
5837 SvPOK(((SVOP*)oa)->op_sv) &&
5838 (mode = SvPVX(((SVOP*)oa)->op_sv)) &&
5839 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
5840 (last == oa->op_sibling)) /* The bareword. */
5841 last->op_private &= ~OPpCONST_STRICT;
5847 Perl_ck_repeat(pTHX_ OP *o)
5849 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5850 o->op_private |= OPpREPEAT_DOLIST;
5851 cBINOPo->op_first = force_list(cBINOPo->op_first);
5859 Perl_ck_require(pTHX_ OP *o)
5863 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
5864 SVOP *kid = (SVOP*)cUNOPo->op_first;
5866 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5868 for (s = SvPVX(kid->op_sv); *s; s++) {
5869 if (*s == ':' && s[1] == ':') {
5871 Move(s+2, s+1, strlen(s+2)+1, char);
5872 --SvCUR(kid->op_sv);
5875 if (SvREADONLY(kid->op_sv)) {
5876 SvREADONLY_off(kid->op_sv);
5877 sv_catpvn(kid->op_sv, ".pm", 3);
5878 SvREADONLY_on(kid->op_sv);
5881 sv_catpvn(kid->op_sv, ".pm", 3);
5885 /* handle override, if any */
5886 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
5887 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
5888 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
5890 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5891 OP *kid = cUNOPo->op_first;
5892 cUNOPo->op_first = 0;
5894 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5895 append_elem(OP_LIST, kid,
5896 scalar(newUNOP(OP_RV2CV, 0,
5905 Perl_ck_return(pTHX_ OP *o)
5908 if (CvLVALUE(PL_compcv)) {
5909 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5910 mod(kid, OP_LEAVESUBLV);
5917 Perl_ck_retarget(pTHX_ OP *o)
5919 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5926 Perl_ck_select(pTHX_ OP *o)
5929 if (o->op_flags & OPf_KIDS) {
5930 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5931 if (kid && kid->op_sibling) {
5932 o->op_type = OP_SSELECT;
5933 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
5935 return fold_constants(o);
5939 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5940 if (kid && kid->op_type == OP_RV2GV)
5941 kid->op_private &= ~HINT_STRICT_REFS;
5946 Perl_ck_shift(pTHX_ OP *o)
5948 I32 type = o->op_type;
5950 if (!(o->op_flags & OPf_KIDS)) {
5954 argop = newUNOP(OP_RV2AV, 0,
5955 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
5956 return newUNOP(type, 0, scalar(argop));
5958 return scalar(modkids(ck_fun(o), type));
5962 Perl_ck_sort(pTHX_ OP *o)
5966 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
5968 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5969 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
5971 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
5973 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
5975 if (kid->op_type == OP_SCOPE) {
5979 else if (kid->op_type == OP_LEAVE) {
5980 if (o->op_type == OP_SORT) {
5981 op_null(kid); /* wipe out leave */
5984 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
5985 if (k->op_next == kid)
5987 /* don't descend into loops */
5988 else if (k->op_type == OP_ENTERLOOP
5989 || k->op_type == OP_ENTERITER)
5991 k = cLOOPx(k)->op_lastop;
5996 kid->op_next = 0; /* just disconnect the leave */
5997 k = kLISTOP->op_first;
6002 if (o->op_type == OP_SORT) {
6003 /* provide scalar context for comparison function/block */
6009 o->op_flags |= OPf_SPECIAL;
6011 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6014 firstkid = firstkid->op_sibling;
6017 /* provide list context for arguments */
6018 if (o->op_type == OP_SORT)
6025 S_simplify_sort(pTHX_ OP *o)
6027 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6031 if (!(o->op_flags & OPf_STACKED))
6033 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6034 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6035 kid = kUNOP->op_first; /* get past null */
6036 if (kid->op_type != OP_SCOPE)
6038 kid = kLISTOP->op_last; /* get past scope */
6039 switch(kid->op_type) {
6047 k = kid; /* remember this node*/
6048 if (kBINOP->op_first->op_type != OP_RV2SV)
6050 kid = kBINOP->op_first; /* get past cmp */
6051 if (kUNOP->op_first->op_type != OP_GV)
6053 kid = kUNOP->op_first; /* get past rv2sv */
6055 if (GvSTASH(gv) != PL_curstash)
6057 if (strEQ(GvNAME(gv), "a"))
6059 else if (strEQ(GvNAME(gv), "b"))
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 ? strNE(GvNAME(gv), "a")
6075 : strNE(GvNAME(gv), "b")))
6077 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6079 o->op_private |= OPpSORT_DESCEND;
6080 if (k->op_type == OP_NCMP)
6081 o->op_private |= OPpSORT_NUMERIC;
6082 if (k->op_type == OP_I_NCMP)
6083 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6084 kid = cLISTOPo->op_first->op_sibling;
6085 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6086 op_free(kid); /* then delete it */
6090 Perl_ck_split(pTHX_ OP *o)
6094 if (o->op_flags & OPf_STACKED)
6095 return no_fh_allowed(o);
6097 kid = cLISTOPo->op_first;
6098 if (kid->op_type != OP_NULL)
6099 Perl_croak(aTHX_ "panic: ck_split");
6100 kid = kid->op_sibling;
6101 op_free(cLISTOPo->op_first);
6102 cLISTOPo->op_first = kid;
6104 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6105 cLISTOPo->op_last = kid; /* There was only one element previously */
6108 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6109 OP *sibl = kid->op_sibling;
6110 kid->op_sibling = 0;
6111 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
6112 if (cLISTOPo->op_first == cLISTOPo->op_last)
6113 cLISTOPo->op_last = kid;
6114 cLISTOPo->op_first = kid;
6115 kid->op_sibling = sibl;
6118 kid->op_type = OP_PUSHRE;
6119 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6121 if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
6122 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
6123 "Use of /g modifier is meaningless in split");
6126 if (!kid->op_sibling)
6127 append_elem(OP_SPLIT, o, newDEFSVOP());
6129 kid = kid->op_sibling;
6132 if (!kid->op_sibling)
6133 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6135 kid = kid->op_sibling;
6138 if (kid->op_sibling)
6139 return too_many_arguments(o,OP_DESC(o));
6145 Perl_ck_join(pTHX_ OP *o)
6147 if (ckWARN(WARN_SYNTAX)) {
6148 OP *kid = cLISTOPo->op_first->op_sibling;
6149 if (kid && kid->op_type == OP_MATCH) {
6150 char *pmstr = "STRING";
6151 if (PM_GETRE(kPMOP))
6152 pmstr = PM_GETRE(kPMOP)->precomp;
6153 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6154 "/%s/ should probably be written as \"%s\"",
6162 Perl_ck_subr(pTHX_ OP *o)
6164 OP *prev = ((cUNOPo->op_first->op_sibling)
6165 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6166 OP *o2 = prev->op_sibling;
6173 I32 contextclass = 0;
6178 o->op_private |= OPpENTERSUB_HASTARG;
6179 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6180 if (cvop->op_type == OP_RV2CV) {
6182 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6183 op_null(cvop); /* disable rv2cv */
6184 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6185 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6186 GV *gv = cGVOPx_gv(tmpop);
6189 tmpop->op_private |= OPpEARLY_CV;
6192 namegv = CvANON(cv) ? gv : CvGV(cv);
6193 proto = SvPV((SV*)cv, n_a);
6195 if (CvASSERTION(cv)) {
6196 if (PL_hints & HINT_ASSERTING) {
6197 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
6198 o->op_private |= OPpENTERSUB_DB;
6202 if (ckWARN(WARN_ASSERTIONS) && !(PL_hints & HINT_ASSERTIONSSEEN)) {
6203 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
6204 "Impossible to activate assertion call");
6211 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6212 if (o2->op_type == OP_CONST)
6213 o2->op_private &= ~OPpCONST_STRICT;
6214 else if (o2->op_type == OP_LIST) {
6215 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6216 if (o && o->op_type == OP_CONST)
6217 o->op_private &= ~OPpCONST_STRICT;
6220 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6221 if (PERLDB_SUB && PL_curstash != PL_debstash)
6222 o->op_private |= OPpENTERSUB_DB;
6223 while (o2 != cvop) {
6227 return too_many_arguments(o, gv_ename(namegv));
6245 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6247 arg == 1 ? "block or sub {}" : "sub {}",
6248 gv_ename(namegv), o2);
6251 /* '*' allows any scalar type, including bareword */
6254 if (o2->op_type == OP_RV2GV)
6255 goto wrapref; /* autoconvert GLOB -> GLOBref */
6256 else if (o2->op_type == OP_CONST)
6257 o2->op_private &= ~OPpCONST_STRICT;
6258 else if (o2->op_type == OP_ENTERSUB) {
6259 /* accidental subroutine, revert to bareword */
6260 OP *gvop = ((UNOP*)o2)->op_first;
6261 if (gvop && gvop->op_type == OP_NULL) {
6262 gvop = ((UNOP*)gvop)->op_first;
6264 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6267 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6268 (gvop = ((UNOP*)gvop)->op_first) &&
6269 gvop->op_type == OP_GV)
6271 GV *gv = cGVOPx_gv(gvop);
6272 OP *sibling = o2->op_sibling;
6273 SV *n = newSVpvn("",0);
6275 gv_fullname3(n, gv, "");
6276 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6277 sv_chop(n, SvPVX(n)+6);
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 char* Perl_custom_op_name(pTHX_ OP* o)
7020 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 char* Perl_custom_op_desc(pTHX_ OP* o)
7038 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;