3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
13 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
14 * youngest of the Old Took's daughters); and Mr. Drogo was his second
15 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
16 * either way, as the saying is, if you follow me." --the Gaffer
19 /* This file contains the functions that create, manipulate and optimize
20 * the OP structures that hold a compiled perl program.
22 * A Perl program is compiled into a tree of OPs. Each op contains
23 * structural pointers (eg to its siblings and the next op in the
24 * execution sequence), a pointer to the function that would execute the
25 * op, plus any data specific to that op. For example, an OP_CONST op
26 * points to the pp_const() function and to an SV containing the constant
27 * value. When pp_const() is executed, its job is to push that SV onto the
30 * OPs are mainly created by the newFOO() functions, which are mainly
31 * called from the parser (in perly.y) as the code is parsed. For example
32 * the Perl code $a + $b * $c would cause the equivalent of the following
33 * to be called (oversimplifying a bit):
35 * newBINOP(OP_ADD, flags,
37 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
40 * Note that during the build of miniperl, a temporary copy of this file
41 * is made, called opmini.c.
45 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
49 An execution-order pass
51 The bottom-up pass is represented by all the "newOP" routines and
52 the ck_ routines. The bottom-upness is actually driven by yacc.
53 So at the point that a ck_ routine fires, we have no idea what the
54 context is, either upward in the syntax tree, or either forward or
55 backward in the execution order. (The bottom-up parser builds that
56 part of the execution order it knows about, but if you follow the "next"
57 links around, you'll find it's actually a closed loop through the
60 Whenever the bottom-up parser gets to a node that supplies context to
61 its components, it invokes that portion of the top-down pass that applies
62 to that part of the subtree (and marks the top node as processed, so
63 if a node further up supplies context, it doesn't have to take the
64 plunge again). As a particular subcase of this, as the new node is
65 built, it takes all the closed execution loops of its subcomponents
66 and links them into a new closed loop for the higher level node. But
67 it's still not the real execution order.
69 The actual execution order is not known till we get a grammar reduction
70 to a top-level unit like a subroutine or file that will be called by
71 "name" rather than via a "next" pointer. At that point, we can call
72 into peep() to do that code's portion of the 3rd pass. It has to be
73 recursive, but it's recursive on basic blocks, not on tree nodes.
81 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
83 #if defined(PL_OP_SLAB_ALLOC)
85 #ifndef PERL_SLAB_SIZE
86 #define PERL_SLAB_SIZE 2048
90 Perl_Slab_Alloc(pTHX_ int m, size_t sz)
93 * To make incrementing use count easy PL_OpSlab is an I32 *
94 * To make inserting the link to slab PL_OpPtr is I32 **
95 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
96 * Add an overhead for pointer to slab and round up as a number of pointers
98 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
99 if ((PL_OpSpace -= sz) < 0) {
100 PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*));
104 Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **);
105 /* We reserve the 0'th I32 sized chunk as a use count */
106 PL_OpSlab = (I32 *) PL_OpPtr;
107 /* Reduce size by the use count word, and by the size we need.
108 * Latter is to mimic the '-=' in the if() above
110 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
111 /* Allocation pointer starts at the top.
112 Theory: because we build leaves before trunk allocating at end
113 means that at run time access is cache friendly upward
115 PL_OpPtr += PERL_SLAB_SIZE;
117 assert( PL_OpSpace >= 0 );
118 /* Move the allocation pointer down */
120 assert( PL_OpPtr > (I32 **) PL_OpSlab );
121 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
122 (*PL_OpSlab)++; /* Increment use count of slab */
123 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
124 assert( *PL_OpSlab > 0 );
125 return (void *)(PL_OpPtr + 1);
129 Perl_Slab_Free(pTHX_ void *op)
131 I32 **ptr = (I32 **) op;
133 assert( ptr-1 > (I32 **) slab );
134 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
136 if (--(*slab) == 0) {
138 # define PerlMemShared PerlMem
141 PerlMemShared_free(slab);
142 if (slab == PL_OpSlab) {
149 * In the following definition, the ", Nullop" is just to make the compiler
150 * think the expression is of the right type: croak actually does a Siglongjmp.
152 #define CHECKOP(type,o) \
153 ((PL_op_mask && PL_op_mask[type]) \
154 ? ( op_free((OP*)o), \
155 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
157 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
159 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
162 S_gv_ename(pTHX_ GV *gv)
165 SV* tmpsv = sv_newmortal();
166 gv_efullname3(tmpsv, gv, Nullch);
167 return SvPV(tmpsv,n_a);
171 S_no_fh_allowed(pTHX_ OP *o)
173 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
179 S_too_few_arguments(pTHX_ OP *o, const char *name)
181 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
186 S_too_many_arguments(pTHX_ OP *o, const char *name)
188 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
193 S_bad_type(pTHX_ I32 n, const char *t, const char *name, const 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_ const OP *o)
202 qerror(Perl_mess(aTHX_
203 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
207 /* "register" allocation */
210 Perl_allocmy(pTHX_ char *name)
214 /* complain about "my $<special_var>" etc etc */
215 if (!(PL_in_my == KEY_our ||
217 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
218 (name[1] == '_' && (*name == '$' || (int)strlen(name) > 2))))
220 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
221 /* 1999-02-27 mjd@plover.com */
223 p = strchr(name, '\0');
224 /* The next block assumes the buffer is at least 205 chars
225 long. At present, it's always at least 256 chars. */
227 strcpy(name+200, "...");
233 /* Move everything else down one character */
234 for (; p-name > 2; p--)
236 name[2] = toCTRL(name[1]);
239 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
242 /* check for duplicate declaration */
244 (bool)(PL_in_my == KEY_our),
245 (PL_curstash ? PL_curstash : PL_defstash)
248 if (PL_in_my_stash && *name != '$') {
249 yyerror(Perl_form(aTHX_
250 "Can't declare class for non-scalar %s in \"%s\"",
251 name, PL_in_my == KEY_our ? "our" : "my"));
254 /* allocate a spare slot and store the name in that slot */
256 off = pad_add_name(name,
259 /* $_ is always in main::, even with our */
260 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
271 Perl_op_free(pTHX_ OP *o)
277 if (!o || o->op_static)
280 if (o->op_private & OPpREFCOUNTED) {
281 switch (o->op_type) {
289 refcnt = OpREFCNT_dec(o);
299 if (o->op_flags & OPf_KIDS) {
300 register OP *kid, *nextkid;
301 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
302 nextkid = kid->op_sibling; /* Get before next freeing kid */
308 type = (OPCODE)o->op_targ;
310 /* COP* is not cleared by op_clear() so that we may track line
311 * numbers etc even after null() */
312 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
317 #ifdef DEBUG_LEAKING_SCALARS
324 Perl_op_clear(pTHX_ OP *o)
328 switch (o->op_type) {
329 case OP_NULL: /* Was holding old type, if any. */
330 case OP_ENTEREVAL: /* Was holding hints. */
334 if (!(o->op_flags & OPf_REF)
335 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
341 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
342 /* not an OP_PADAV replacement */
344 if (cPADOPo->op_padix > 0) {
345 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
346 * may still exist on the pad */
347 pad_swipe(cPADOPo->op_padix, TRUE);
348 cPADOPo->op_padix = 0;
351 SvREFCNT_dec(cSVOPo->op_sv);
352 cSVOPo->op_sv = Nullsv;
356 case OP_METHOD_NAMED:
358 SvREFCNT_dec(cSVOPo->op_sv);
359 cSVOPo->op_sv = Nullsv;
362 Even if op_clear does a pad_free for the target of the op,
363 pad_free doesn't actually remove the sv that exists in the pad;
364 instead it lives on. This results in that it could be reused as
365 a target later on when the pad was reallocated.
368 pad_swipe(o->op_targ,1);
377 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
381 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
382 SvREFCNT_dec(cSVOPo->op_sv);
383 cSVOPo->op_sv = Nullsv;
386 Safefree(cPVOPo->op_pv);
387 cPVOPo->op_pv = Nullch;
391 op_free(cPMOPo->op_pmreplroot);
395 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
396 /* No GvIN_PAD_off here, because other references may still
397 * exist on the pad */
398 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
401 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
408 HV *pmstash = PmopSTASH(cPMOPo);
409 if (pmstash && SvREFCNT(pmstash)) {
410 PMOP *pmop = HvPMROOT(pmstash);
411 PMOP *lastpmop = NULL;
413 if (cPMOPo == pmop) {
415 lastpmop->op_pmnext = pmop->op_pmnext;
417 HvPMROOT(pmstash) = pmop->op_pmnext;
421 pmop = pmop->op_pmnext;
424 PmopSTASH_free(cPMOPo);
426 cPMOPo->op_pmreplroot = Nullop;
427 /* we use the "SAFE" version of the PM_ macros here
428 * since sv_clean_all might release some PMOPs
429 * after PL_regex_padav has been cleared
430 * and the clearing of PL_regex_padav needs to
431 * happen before sv_clean_all
433 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
434 PM_SETRE_SAFE(cPMOPo, (REGEXP*)NULL);
436 if(PL_regex_pad) { /* We could be in destruction */
437 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
438 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
439 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
446 if (o->op_targ > 0) {
447 pad_free(o->op_targ);
453 S_cop_free(pTHX_ COP* cop)
455 Safefree(cop->cop_label); /* FIXME: treaddead ??? */
458 if (! specialWARN(cop->cop_warnings))
459 SvREFCNT_dec(cop->cop_warnings);
460 if (! specialCopIO(cop->cop_io)) {
464 char *s = SvPV(cop->cop_io,len);
465 Perl_warn(aTHX_ "io='%.*s'",(int) len,s); /* ??? --jhi */
468 SvREFCNT_dec(cop->cop_io);
474 Perl_op_null(pTHX_ OP *o)
477 if (o->op_type == OP_NULL)
480 o->op_targ = o->op_type;
481 o->op_type = OP_NULL;
482 o->op_ppaddr = PL_ppaddr[OP_NULL];
486 Perl_op_refcnt_lock(pTHX)
493 Perl_op_refcnt_unlock(pTHX)
499 /* Contextualizers */
501 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
504 Perl_linklist(pTHX_ OP *o)
510 /* establish postfix order */
511 if (cUNOPo->op_first) {
513 o->op_next = LINKLIST(cUNOPo->op_first);
514 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
516 kid->op_next = LINKLIST(kid->op_sibling);
528 Perl_scalarkids(pTHX_ OP *o)
530 if (o && o->op_flags & OPf_KIDS) {
532 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
539 S_scalarboolean(pTHX_ OP *o)
541 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
542 if (ckWARN(WARN_SYNTAX)) {
543 const line_t oldline = CopLINE(PL_curcop);
545 if (PL_copline != NOLINE)
546 CopLINE_set(PL_curcop, PL_copline);
547 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
548 CopLINE_set(PL_curcop, oldline);
555 Perl_scalar(pTHX_ OP *o)
560 /* assumes no premature commitment */
561 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
562 || o->op_type == OP_RETURN)
567 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
569 switch (o->op_type) {
571 scalar(cBINOPo->op_first);
576 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
580 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
581 if (!kPMOP->op_pmreplroot)
582 deprecate_old("implicit split to @_");
590 if (o->op_flags & OPf_KIDS) {
591 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
597 kid = cLISTOPo->op_first;
599 while ((kid = kid->op_sibling)) {
605 WITH_THR(PL_curcop = &PL_compiling);
610 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
616 WITH_THR(PL_curcop = &PL_compiling);
619 if (ckWARN(WARN_VOID))
620 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
626 Perl_scalarvoid(pTHX_ OP *o)
630 const char* useless = 0;
634 if (o->op_type == OP_NEXTSTATE
635 || o->op_type == OP_SETSTATE
636 || o->op_type == OP_DBSTATE
637 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
638 || o->op_targ == OP_SETSTATE
639 || o->op_targ == OP_DBSTATE)))
640 PL_curcop = (COP*)o; /* for warning below */
642 /* assumes no premature commitment */
643 want = o->op_flags & OPf_WANT;
644 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
645 || o->op_type == OP_RETURN)
650 if ((o->op_private & OPpTARGET_MY)
651 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
653 return scalar(o); /* As if inside SASSIGN */
656 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
658 switch (o->op_type) {
660 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
664 if (o->op_flags & OPf_STACKED)
668 if (o->op_private == 4)
740 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
741 useless = OP_DESC(o);
745 kid = cUNOPo->op_first;
746 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
747 kid->op_type != OP_TRANS) {
750 useless = "negative pattern binding (!~)";
757 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
758 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
759 useless = "a variable";
764 if (cSVOPo->op_private & OPpCONST_STRICT)
765 no_bareword_allowed(o);
767 if (ckWARN(WARN_VOID)) {
768 useless = "a constant";
769 /* don't warn on optimised away booleans, eg
770 * use constant Foo, 5; Foo || print; */
771 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
773 /* the constants 0 and 1 are permitted as they are
774 conventionally used as dummies in constructs like
775 1 while some_condition_with_side_effects; */
776 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
778 else if (SvPOK(sv)) {
779 /* perl4's way of mixing documentation and code
780 (before the invention of POD) was based on a
781 trick to mix nroff and perl code. The trick was
782 built upon these three nroff macros being used in
783 void context. The pink camel has the details in
784 the script wrapman near page 319. */
785 if (strnEQ(SvPVX(sv), "di", 2) ||
786 strnEQ(SvPVX(sv), "ds", 2) ||
787 strnEQ(SvPVX(sv), "ig", 2))
792 op_null(o); /* don't execute or even remember it */
796 o->op_type = OP_PREINC; /* pre-increment is faster */
797 o->op_ppaddr = PL_ppaddr[OP_PREINC];
801 o->op_type = OP_PREDEC; /* pre-decrement is faster */
802 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
809 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
814 if (o->op_flags & OPf_STACKED)
821 if (!(o->op_flags & OPf_KIDS))
830 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
837 /* all requires must return a boolean value */
838 o->op_flags &= ~OPf_WANT;
843 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
844 if (!kPMOP->op_pmreplroot)
845 deprecate_old("implicit split to @_");
849 if (useless && ckWARN(WARN_VOID))
850 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
855 Perl_listkids(pTHX_ OP *o)
857 if (o && o->op_flags & OPf_KIDS) {
859 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
866 Perl_list(pTHX_ OP *o)
871 /* assumes no premature commitment */
872 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
873 || o->op_type == OP_RETURN)
878 if ((o->op_private & OPpTARGET_MY)
879 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
881 return o; /* As if inside SASSIGN */
884 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
886 switch (o->op_type) {
889 list(cBINOPo->op_first);
894 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
902 if (!(o->op_flags & OPf_KIDS))
904 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
905 list(cBINOPo->op_first);
906 return gen_constant_list(o);
913 kid = cLISTOPo->op_first;
915 while ((kid = kid->op_sibling)) {
921 WITH_THR(PL_curcop = &PL_compiling);
925 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
931 WITH_THR(PL_curcop = &PL_compiling);
934 /* all requires must return a boolean value */
935 o->op_flags &= ~OPf_WANT;
942 Perl_scalarseq(pTHX_ OP *o)
945 if (o->op_type == OP_LINESEQ ||
946 o->op_type == OP_SCOPE ||
947 o->op_type == OP_LEAVE ||
948 o->op_type == OP_LEAVETRY)
951 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
952 if (kid->op_sibling) {
956 PL_curcop = &PL_compiling;
958 o->op_flags &= ~OPf_PARENS;
959 if (PL_hints & HINT_BLOCK_SCOPE)
960 o->op_flags |= OPf_PARENS;
963 o = newOP(OP_STUB, 0);
968 S_modkids(pTHX_ OP *o, I32 type)
970 if (o && o->op_flags & OPf_KIDS) {
972 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
978 /* Propagate lvalue ("modifiable") context to an op and it's children.
979 * 'type' represents the context type, roughly based on the type of op that
980 * would do the modifying, although local() is represented by OP_NULL.
981 * It's responsible for detecting things that can't be modified, flag
982 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
983 * might have to vivify a reference in $x), and so on.
985 * For example, "$a+1 = 2" would cause mod() to be called with o being
986 * OP_ADD and type being OP_SASSIGN, and would output an error.
990 Perl_mod(pTHX_ OP *o, I32 type)
994 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
997 if (!o || PL_error_count)
1000 if ((o->op_private & OPpTARGET_MY)
1001 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1006 switch (o->op_type) {
1012 if (!(o->op_private & (OPpCONST_ARYBASE)))
1014 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1015 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1019 SAVEI32(PL_compiling.cop_arybase);
1020 PL_compiling.cop_arybase = 0;
1022 else if (type == OP_REFGEN)
1025 Perl_croak(aTHX_ "That use of $[ is unsupported");
1028 if (o->op_flags & OPf_PARENS)
1032 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1033 !(o->op_flags & OPf_STACKED)) {
1034 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1035 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1036 assert(cUNOPo->op_first->op_type == OP_NULL);
1037 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1040 else if (o->op_private & OPpENTERSUB_NOMOD)
1042 else { /* lvalue subroutine call */
1043 o->op_private |= OPpLVAL_INTRO;
1044 PL_modcount = RETURN_UNLIMITED_NUMBER;
1045 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1046 /* Backward compatibility mode: */
1047 o->op_private |= OPpENTERSUB_INARGS;
1050 else { /* Compile-time error message: */
1051 OP *kid = cUNOPo->op_first;
1055 if (kid->op_type == OP_PUSHMARK)
1057 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1059 "panic: unexpected lvalue entersub "
1060 "args: type/targ %ld:%"UVuf,
1061 (long)kid->op_type, (UV)kid->op_targ);
1062 kid = kLISTOP->op_first;
1064 while (kid->op_sibling)
1065 kid = kid->op_sibling;
1066 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1068 if (kid->op_type == OP_METHOD_NAMED
1069 || kid->op_type == OP_METHOD)
1073 NewOp(1101, newop, 1, UNOP);
1074 newop->op_type = OP_RV2CV;
1075 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1076 newop->op_first = Nullop;
1077 newop->op_next = (OP*)newop;
1078 kid->op_sibling = (OP*)newop;
1079 newop->op_private |= OPpLVAL_INTRO;
1083 if (kid->op_type != OP_RV2CV)
1085 "panic: unexpected lvalue entersub "
1086 "entry via type/targ %ld:%"UVuf,
1087 (long)kid->op_type, (UV)kid->op_targ);
1088 kid->op_private |= OPpLVAL_INTRO;
1089 break; /* Postpone until runtime */
1093 kid = kUNOP->op_first;
1094 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1095 kid = kUNOP->op_first;
1096 if (kid->op_type == OP_NULL)
1098 "Unexpected constant lvalue entersub "
1099 "entry via type/targ %ld:%"UVuf,
1100 (long)kid->op_type, (UV)kid->op_targ);
1101 if (kid->op_type != OP_GV) {
1102 /* Restore RV2CV to check lvalueness */
1104 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1105 okid->op_next = kid->op_next;
1106 kid->op_next = okid;
1109 okid->op_next = Nullop;
1110 okid->op_type = OP_RV2CV;
1112 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1113 okid->op_private |= OPpLVAL_INTRO;
1117 cv = GvCV(kGVOP_gv);
1127 /* grep, foreach, subcalls, refgen */
1128 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1130 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1131 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1133 : (o->op_type == OP_ENTERSUB
1134 ? "non-lvalue subroutine call"
1136 type ? PL_op_desc[type] : "local"));
1150 case OP_RIGHT_SHIFT:
1159 if (!(o->op_flags & OPf_STACKED))
1166 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1172 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1173 PL_modcount = RETURN_UNLIMITED_NUMBER;
1174 return o; /* Treat \(@foo) like ordinary list. */
1178 if (scalar_mod_type(o, type))
1180 ref(cUNOPo->op_first, o->op_type);
1184 if (type == OP_LEAVESUBLV)
1185 o->op_private |= OPpMAYBE_LVSUB;
1191 PL_modcount = RETURN_UNLIMITED_NUMBER;
1194 ref(cUNOPo->op_first, o->op_type);
1199 PL_hints |= HINT_BLOCK_SCOPE;
1214 PL_modcount = RETURN_UNLIMITED_NUMBER;
1215 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1216 return o; /* Treat \(@foo) like ordinary list. */
1217 if (scalar_mod_type(o, type))
1219 if (type == OP_LEAVESUBLV)
1220 o->op_private |= OPpMAYBE_LVSUB;
1224 if (!type) /* local() */
1225 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1226 PAD_COMPNAME_PV(o->op_targ));
1234 if (type != OP_SASSIGN)
1238 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1243 if (type == OP_LEAVESUBLV)
1244 o->op_private |= OPpMAYBE_LVSUB;
1246 pad_free(o->op_targ);
1247 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1248 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1249 if (o->op_flags & OPf_KIDS)
1250 mod(cBINOPo->op_first->op_sibling, type);
1255 ref(cBINOPo->op_first, o->op_type);
1256 if (type == OP_ENTERSUB &&
1257 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1258 o->op_private |= OPpLVAL_DEFER;
1259 if (type == OP_LEAVESUBLV)
1260 o->op_private |= OPpMAYBE_LVSUB;
1270 if (o->op_flags & OPf_KIDS)
1271 mod(cLISTOPo->op_last, type);
1276 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1278 else if (!(o->op_flags & OPf_KIDS))
1280 if (o->op_targ != OP_LIST) {
1281 mod(cBINOPo->op_first, type);
1287 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1292 if (type != OP_LEAVESUBLV)
1294 break; /* mod()ing was handled by ck_return() */
1297 /* [20011101.069] File test operators interpret OPf_REF to mean that
1298 their argument is a filehandle; thus \stat(".") should not set
1300 if (type == OP_REFGEN &&
1301 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1304 if (type != OP_LEAVESUBLV)
1305 o->op_flags |= OPf_MOD;
1307 if (type == OP_AASSIGN || type == OP_SASSIGN)
1308 o->op_flags |= OPf_SPECIAL|OPf_REF;
1309 else if (!type) { /* local() */
1312 o->op_private |= OPpLVAL_INTRO;
1313 o->op_flags &= ~OPf_SPECIAL;
1314 PL_hints |= HINT_BLOCK_SCOPE;
1319 if (ckWARN(WARN_SYNTAX)) {
1320 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1321 "Useless localization of %s", OP_DESC(o));
1325 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1326 && type != OP_LEAVESUBLV)
1327 o->op_flags |= OPf_REF;
1332 S_scalar_mod_type(pTHX_ const OP *o, I32 type)
1336 if (o->op_type == OP_RV2GV)
1360 case OP_RIGHT_SHIFT:
1379 S_is_handle_constructor(pTHX_ const OP *o, I32 argnum)
1381 switch (o->op_type) {
1389 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1402 Perl_refkids(pTHX_ OP *o, I32 type)
1404 if (o && o->op_flags & OPf_KIDS) {
1406 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1413 Perl_ref(pTHX_ OP *o, I32 type)
1418 if (!o || PL_error_count)
1421 switch (o->op_type) {
1423 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1424 !(o->op_flags & OPf_STACKED)) {
1425 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1426 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1427 assert(cUNOPo->op_first->op_type == OP_NULL);
1428 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1429 o->op_flags |= OPf_SPECIAL;
1434 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1438 if (type == OP_DEFINED)
1439 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1440 ref(cUNOPo->op_first, o->op_type);
1443 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1444 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1445 : type == OP_RV2HV ? OPpDEREF_HV
1447 o->op_flags |= OPf_MOD;
1452 o->op_flags |= OPf_MOD; /* XXX ??? */
1457 o->op_flags |= OPf_REF;
1460 if (type == OP_DEFINED)
1461 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1462 ref(cUNOPo->op_first, o->op_type);
1467 o->op_flags |= OPf_REF;
1472 if (!(o->op_flags & OPf_KIDS))
1474 ref(cBINOPo->op_first, type);
1478 ref(cBINOPo->op_first, o->op_type);
1479 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1480 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1481 : type == OP_RV2HV ? OPpDEREF_HV
1483 o->op_flags |= OPf_MOD;
1491 if (!(o->op_flags & OPf_KIDS))
1493 ref(cLISTOPo->op_last, type);
1503 S_dup_attrlist(pTHX_ OP *o)
1507 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1508 * where the first kid is OP_PUSHMARK and the remaining ones
1509 * are OP_CONST. We need to push the OP_CONST values.
1511 if (o->op_type == OP_CONST)
1512 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1514 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1515 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1516 if (o->op_type == OP_CONST)
1517 rop = append_elem(OP_LIST, rop,
1518 newSVOP(OP_CONST, o->op_flags,
1519 SvREFCNT_inc(cSVOPo->op_sv)));
1526 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1531 /* fake up C<use attributes $pkg,$rv,@attrs> */
1532 ENTER; /* need to protect against side-effects of 'use' */
1535 stashsv = newSVpv(HvNAME(stash), 0);
1537 stashsv = &PL_sv_no;
1539 #define ATTRSMODULE "attributes"
1540 #define ATTRSMODULE_PM "attributes.pm"
1544 /* Don't force the C<use> if we don't need it. */
1545 svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
1546 sizeof(ATTRSMODULE_PM)-1, 0);
1547 if (svp && *svp != &PL_sv_undef)
1548 ; /* already in %INC */
1550 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1551 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1555 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1556 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1558 prepend_elem(OP_LIST,
1559 newSVOP(OP_CONST, 0, stashsv),
1560 prepend_elem(OP_LIST,
1561 newSVOP(OP_CONST, 0,
1563 dup_attrlist(attrs))));
1569 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1571 OP *pack, *imop, *arg;
1577 assert(target->op_type == OP_PADSV ||
1578 target->op_type == OP_PADHV ||
1579 target->op_type == OP_PADAV);
1581 /* Ensure that attributes.pm is loaded. */
1582 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1584 /* Need package name for method call. */
1585 pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
1587 /* Build up the real arg-list. */
1589 stashsv = newSVpv(HvNAME(stash), 0);
1591 stashsv = &PL_sv_no;
1592 arg = newOP(OP_PADSV, 0);
1593 arg->op_targ = target->op_targ;
1594 arg = prepend_elem(OP_LIST,
1595 newSVOP(OP_CONST, 0, stashsv),
1596 prepend_elem(OP_LIST,
1597 newUNOP(OP_REFGEN, 0,
1598 mod(arg, OP_REFGEN)),
1599 dup_attrlist(attrs)));
1601 /* Fake up a method call to import */
1602 meth = newSVpvn("import", 6);
1603 (void)SvUPGRADE(meth, SVt_PVIV);
1604 (void)SvIOK_on(meth);
1607 PERL_HASH(hash, SvPVX(meth), SvCUR(meth));
1608 SvUV_set(meth, hash);
1610 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1611 append_elem(OP_LIST,
1612 prepend_elem(OP_LIST, pack, list(arg)),
1613 newSVOP(OP_METHOD_NAMED, 0, meth)));
1614 imop->op_private |= OPpENTERSUB_NOMOD;
1616 /* Combine the ops. */
1617 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1621 =notfor apidoc apply_attrs_string
1623 Attempts to apply a list of attributes specified by the C<attrstr> and
1624 C<len> arguments to the subroutine identified by the C<cv> argument which
1625 is expected to be associated with the package identified by the C<stashpv>
1626 argument (see L<attributes>). It gets this wrong, though, in that it
1627 does not correctly identify the boundaries of the individual attribute
1628 specifications within C<attrstr>. This is not really intended for the
1629 public API, but has to be listed here for systems such as AIX which
1630 need an explicit export list for symbols. (It's called from XS code
1631 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1632 to respect attribute syntax properly would be welcome.
1638 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1639 const char *attrstr, STRLEN len)
1644 len = strlen(attrstr);
1648 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1650 const char *sstr = attrstr;
1651 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1652 attrs = append_elem(OP_LIST, attrs,
1653 newSVOP(OP_CONST, 0,
1654 newSVpvn(sstr, attrstr-sstr)));
1658 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1659 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1660 Nullsv, prepend_elem(OP_LIST,
1661 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1662 prepend_elem(OP_LIST,
1663 newSVOP(OP_CONST, 0,
1669 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1673 if (!o || PL_error_count)
1677 if (type == OP_LIST) {
1679 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1680 my_kid(kid, attrs, imopsp);
1681 } else if (type == OP_UNDEF) {
1683 } else if (type == OP_RV2SV || /* "our" declaration */
1685 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1686 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1687 yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
1688 OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
1690 GV *gv = cGVOPx_gv(cUNOPo->op_first);
1692 PL_in_my_stash = Nullhv;
1693 apply_attrs(GvSTASH(gv),
1694 (type == OP_RV2SV ? GvSV(gv) :
1695 type == OP_RV2AV ? (SV*)GvAV(gv) :
1696 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1699 o->op_private |= OPpOUR_INTRO;
1702 else if (type != OP_PADSV &&
1705 type != OP_PUSHMARK)
1707 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1709 PL_in_my == KEY_our ? "our" : "my"));
1712 else if (attrs && type != OP_PUSHMARK) {
1716 PL_in_my_stash = Nullhv;
1718 /* check for C<my Dog $spot> when deciding package */
1719 stash = PAD_COMPNAME_TYPE(o->op_targ);
1721 stash = PL_curstash;
1722 apply_attrs_my(stash, o, attrs, imopsp);
1724 o->op_flags |= OPf_MOD;
1725 o->op_private |= OPpLVAL_INTRO;
1730 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1733 int maybe_scalar = 0;
1735 /* [perl #17376]: this appears to be premature, and results in code such as
1736 C< our(%x); > executing in list mode rather than void mode */
1738 if (o->op_flags & OPf_PARENS)
1747 o = my_kid(o, attrs, &rops);
1749 if (maybe_scalar && o->op_type == OP_PADSV) {
1750 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1751 o->op_private |= OPpLVAL_INTRO;
1754 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1757 PL_in_my_stash = Nullhv;
1762 Perl_my(pTHX_ OP *o)
1764 return my_attrs(o, Nullop);
1768 Perl_sawparens(pTHX_ OP *o)
1771 o->op_flags |= OPf_PARENS;
1776 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1781 if (ckWARN(WARN_MISC) &&
1782 (left->op_type == OP_RV2AV ||
1783 left->op_type == OP_RV2HV ||
1784 left->op_type == OP_PADAV ||
1785 left->op_type == OP_PADHV)) {
1786 const char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
1787 right->op_type == OP_TRANS)
1788 ? right->op_type : OP_MATCH];
1789 const char *sample = ((left->op_type == OP_RV2AV ||
1790 left->op_type == OP_PADAV)
1791 ? "@array" : "%hash");
1792 Perl_warner(aTHX_ packWARN(WARN_MISC),
1793 "Applying %s to %s will act on scalar(%s)",
1794 desc, sample, sample);
1797 if (right->op_type == OP_CONST &&
1798 cSVOPx(right)->op_private & OPpCONST_BARE &&
1799 cSVOPx(right)->op_private & OPpCONST_STRICT)
1801 no_bareword_allowed(right);
1804 ismatchop = right->op_type == OP_MATCH ||
1805 right->op_type == OP_SUBST ||
1806 right->op_type == OP_TRANS;
1807 if (ismatchop && right->op_private & OPpTARGET_MY) {
1809 right->op_private &= ~OPpTARGET_MY;
1811 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1812 right->op_flags |= OPf_STACKED;
1813 if (right->op_type != OP_MATCH &&
1814 ! (right->op_type == OP_TRANS &&
1815 right->op_private & OPpTRANS_IDENTICAL))
1816 left = mod(left, right->op_type);
1817 if (right->op_type == OP_TRANS)
1818 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
1820 o = prepend_elem(right->op_type, scalar(left), right);
1822 return newUNOP(OP_NOT, 0, scalar(o));
1826 return bind_match(type, left,
1827 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
1831 Perl_invert(pTHX_ OP *o)
1835 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
1836 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1840 Perl_scope(pTHX_ OP *o)
1844 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1845 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1846 o->op_type = OP_LEAVE;
1847 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1849 else if (o->op_type == OP_LINESEQ) {
1851 o->op_type = OP_SCOPE;
1852 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1853 kid = ((LISTOP*)o)->op_first;
1854 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
1858 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
1863 /* XXX kept for BINCOMPAT only */
1865 Perl_save_hints(pTHX)
1867 Perl_croak(aTHX_ "internal error: obsolete function save_hints() called");
1871 Perl_block_start(pTHX_ int full)
1873 const int retval = PL_savestack_ix;
1874 pad_block_start(full);
1876 PL_hints &= ~HINT_BLOCK_SCOPE;
1877 SAVESPTR(PL_compiling.cop_warnings);
1878 if (! specialWARN(PL_compiling.cop_warnings)) {
1879 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1880 SAVEFREESV(PL_compiling.cop_warnings) ;
1882 SAVESPTR(PL_compiling.cop_io);
1883 if (! specialCopIO(PL_compiling.cop_io)) {
1884 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1885 SAVEFREESV(PL_compiling.cop_io) ;
1891 Perl_block_end(pTHX_ I32 floor, OP *seq)
1893 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1894 OP* retval = scalarseq(seq);
1896 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
1898 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
1906 const I32 offset = pad_findmy("$_");
1907 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
1908 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1911 OP *o = newOP(OP_PADSV, 0);
1912 o->op_targ = offset;
1918 Perl_newPROG(pTHX_ OP *o)
1923 PL_eval_root = newUNOP(OP_LEAVEEVAL,
1924 ((PL_in_eval & EVAL_KEEPERR)
1925 ? OPf_SPECIAL : 0), o);
1926 PL_eval_start = linklist(PL_eval_root);
1927 PL_eval_root->op_private |= OPpREFCOUNTED;
1928 OpREFCNT_set(PL_eval_root, 1);
1929 PL_eval_root->op_next = 0;
1930 CALL_PEEP(PL_eval_start);
1933 if (o->op_type == OP_STUB) {
1934 PL_comppad_name = 0;
1939 PL_main_root = scope(sawparens(scalarvoid(o)));
1940 PL_curcop = &PL_compiling;
1941 PL_main_start = LINKLIST(PL_main_root);
1942 PL_main_root->op_private |= OPpREFCOUNTED;
1943 OpREFCNT_set(PL_main_root, 1);
1944 PL_main_root->op_next = 0;
1945 CALL_PEEP(PL_main_start);
1948 /* Register with debugger */
1950 CV *cv = get_cv("DB::postponed", FALSE);
1954 XPUSHs((SV*)CopFILEGV(&PL_compiling));
1956 call_sv((SV*)cv, G_DISCARD);
1963 Perl_localize(pTHX_ OP *o, I32 lex)
1965 if (o->op_flags & OPf_PARENS)
1966 /* [perl #17376]: this appears to be premature, and results in code such as
1967 C< our(%x); > executing in list mode rather than void mode */
1974 if (ckWARN(WARN_PARENTHESIS)
1975 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
1977 char *s = PL_bufptr;
1980 /* some heuristics to detect a potential error */
1981 while (*s && (strchr(", \t\n", *s)))
1985 if (*s && strchr("@$%*", *s) && *++s
1986 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
1989 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
1991 while (*s && (strchr(", \t\n", *s)))
1997 if (sigil && (*s == ';' || *s == '=')) {
1998 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
1999 "Parentheses missing around \"%s\" list",
2000 lex ? (PL_in_my == KEY_our ? "our" : "my")
2008 o = mod(o, OP_NULL); /* a bit kludgey */
2010 PL_in_my_stash = Nullhv;
2015 Perl_jmaybe(pTHX_ OP *o)
2017 if (o->op_type == OP_LIST) {
2019 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2020 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2026 Perl_fold_constants(pTHX_ register OP *o)
2030 I32 type = o->op_type;
2033 if (PL_opargs[type] & OA_RETSCALAR)
2035 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2036 o->op_targ = pad_alloc(type, SVs_PADTMP);
2038 /* integerize op, unless it happens to be C<-foo>.
2039 * XXX should pp_i_negate() do magic string negation instead? */
2040 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2041 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2042 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2044 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2047 if (!(PL_opargs[type] & OA_FOLDCONST))
2052 /* XXX might want a ck_negate() for this */
2053 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2065 /* XXX what about the numeric ops? */
2066 if (PL_hints & HINT_LOCALE)
2071 goto nope; /* Don't try to run w/ errors */
2073 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2074 if ((curop->op_type != OP_CONST ||
2075 (curop->op_private & OPpCONST_BARE)) &&
2076 curop->op_type != OP_LIST &&
2077 curop->op_type != OP_SCALAR &&
2078 curop->op_type != OP_NULL &&
2079 curop->op_type != OP_PUSHMARK)
2085 curop = LINKLIST(o);
2089 sv = *(PL_stack_sp--);
2090 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2091 pad_swipe(o->op_targ, FALSE);
2092 else if (SvTEMP(sv)) { /* grab mortal temp? */
2093 (void)SvREFCNT_inc(sv);
2097 if (type == OP_RV2GV)
2098 return newGVOP(OP_GV, 0, (GV*)sv);
2099 return newSVOP(OP_CONST, 0, sv);
2106 Perl_gen_constant_list(pTHX_ register OP *o)
2110 const I32 oldtmps_floor = PL_tmps_floor;
2114 return o; /* Don't attempt to run with errors */
2116 PL_op = curop = LINKLIST(o);
2123 PL_tmps_floor = oldtmps_floor;
2125 o->op_type = OP_RV2AV;
2126 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2127 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2128 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2129 o->op_opt = 0; /* needs to be revisited in peep() */
2130 curop = ((UNOP*)o)->op_first;
2131 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2138 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2141 if (!o || o->op_type != OP_LIST)
2142 o = newLISTOP(OP_LIST, 0, o, Nullop);
2144 o->op_flags &= ~OPf_WANT;
2146 if (!(PL_opargs[type] & OA_MARK))
2147 op_null(cLISTOPo->op_first);
2149 o->op_type = (OPCODE)type;
2150 o->op_ppaddr = PL_ppaddr[type];
2151 o->op_flags |= flags;
2153 o = CHECKOP(type, o);
2154 if (o->op_type != (unsigned)type)
2157 return fold_constants(o);
2160 /* List constructors */
2163 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2171 if (first->op_type != (unsigned)type
2172 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2174 return newLISTOP(type, 0, first, last);
2177 if (first->op_flags & OPf_KIDS)
2178 ((LISTOP*)first)->op_last->op_sibling = last;
2180 first->op_flags |= OPf_KIDS;
2181 ((LISTOP*)first)->op_first = last;
2183 ((LISTOP*)first)->op_last = last;
2188 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2196 if (first->op_type != (unsigned)type)
2197 return prepend_elem(type, (OP*)first, (OP*)last);
2199 if (last->op_type != (unsigned)type)
2200 return append_elem(type, (OP*)first, (OP*)last);
2202 first->op_last->op_sibling = last->op_first;
2203 first->op_last = last->op_last;
2204 first->op_flags |= (last->op_flags & OPf_KIDS);
2212 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2220 if (last->op_type == (unsigned)type) {
2221 if (type == OP_LIST) { /* already a PUSHMARK there */
2222 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2223 ((LISTOP*)last)->op_first->op_sibling = first;
2224 if (!(first->op_flags & OPf_PARENS))
2225 last->op_flags &= ~OPf_PARENS;
2228 if (!(last->op_flags & OPf_KIDS)) {
2229 ((LISTOP*)last)->op_last = first;
2230 last->op_flags |= OPf_KIDS;
2232 first->op_sibling = ((LISTOP*)last)->op_first;
2233 ((LISTOP*)last)->op_first = first;
2235 last->op_flags |= OPf_KIDS;
2239 return newLISTOP(type, 0, first, last);
2245 Perl_newNULLLIST(pTHX)
2247 return newOP(OP_STUB, 0);
2251 Perl_force_list(pTHX_ OP *o)
2253 if (!o || o->op_type != OP_LIST)
2254 o = newLISTOP(OP_LIST, 0, o, Nullop);
2260 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2265 NewOp(1101, listop, 1, LISTOP);
2267 listop->op_type = (OPCODE)type;
2268 listop->op_ppaddr = PL_ppaddr[type];
2271 listop->op_flags = (U8)flags;
2275 else if (!first && last)
2278 first->op_sibling = last;
2279 listop->op_first = first;
2280 listop->op_last = last;
2281 if (type == OP_LIST) {
2283 pushop = newOP(OP_PUSHMARK, 0);
2284 pushop->op_sibling = first;
2285 listop->op_first = pushop;
2286 listop->op_flags |= OPf_KIDS;
2288 listop->op_last = pushop;
2291 return CHECKOP(type, listop);
2295 Perl_newOP(pTHX_ I32 type, I32 flags)
2299 NewOp(1101, o, 1, OP);
2300 o->op_type = (OPCODE)type;
2301 o->op_ppaddr = PL_ppaddr[type];
2302 o->op_flags = (U8)flags;
2305 o->op_private = (U8)(0 | (flags >> 8));
2306 if (PL_opargs[type] & OA_RETSCALAR)
2308 if (PL_opargs[type] & OA_TARGET)
2309 o->op_targ = pad_alloc(type, SVs_PADTMP);
2310 return CHECKOP(type, o);
2314 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2320 first = newOP(OP_STUB, 0);
2321 if (PL_opargs[type] & OA_MARK)
2322 first = force_list(first);
2324 NewOp(1101, unop, 1, UNOP);
2325 unop->op_type = (OPCODE)type;
2326 unop->op_ppaddr = PL_ppaddr[type];
2327 unop->op_first = first;
2328 unop->op_flags = flags | OPf_KIDS;
2329 unop->op_private = (U8)(1 | (flags >> 8));
2330 unop = (UNOP*) CHECKOP(type, unop);
2334 return fold_constants((OP *) unop);
2338 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2342 NewOp(1101, binop, 1, BINOP);
2345 first = newOP(OP_NULL, 0);
2347 binop->op_type = (OPCODE)type;
2348 binop->op_ppaddr = PL_ppaddr[type];
2349 binop->op_first = first;
2350 binop->op_flags = flags | OPf_KIDS;
2353 binop->op_private = (U8)(1 | (flags >> 8));
2356 binop->op_private = (U8)(2 | (flags >> 8));
2357 first->op_sibling = last;
2360 binop = (BINOP*)CHECKOP(type, binop);
2361 if (binop->op_next || binop->op_type != (OPCODE)type)
2364 binop->op_last = binop->op_first->op_sibling;
2366 return fold_constants((OP *)binop);
2369 static int uvcompare(const void *a, const void *b) __attribute__((nonnull,pure));
2371 uvcompare(const void *a, const void *b)
2373 if (*((const UV *)a) < (*(const UV *)b))
2375 if (*((const UV *)a) > (*(const UV *)b))
2377 if (*((const UV *)a+1) < (*(const UV *)b+1))
2379 if (*((const UV *)a+1) > (*(const UV *)b+1))
2385 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2387 SV *tstr = ((SVOP*)expr)->op_sv;
2388 SV *rstr = ((SVOP*)repl)->op_sv;
2391 U8 *t = (U8*)SvPV(tstr, tlen);
2392 U8 *r = (U8*)SvPV(rstr, rlen);
2399 register short *tbl;
2401 PL_hints |= HINT_BLOCK_SCOPE;
2402 complement = o->op_private & OPpTRANS_COMPLEMENT;
2403 del = o->op_private & OPpTRANS_DELETE;
2404 squash = o->op_private & OPpTRANS_SQUASH;
2407 o->op_private |= OPpTRANS_FROM_UTF;
2410 o->op_private |= OPpTRANS_TO_UTF;
2412 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2413 SV* listsv = newSVpvn("# comment\n",10);
2415 U8* tend = t + tlen;
2416 U8* rend = r + rlen;
2430 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2431 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2437 tsave = t = bytes_to_utf8(t, &len);
2440 if (!to_utf && rlen) {
2442 rsave = r = bytes_to_utf8(r, &len);
2446 /* There are several snags with this code on EBCDIC:
2447 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2448 2. scan_const() in toke.c has encoded chars in native encoding which makes
2449 ranges at least in EBCDIC 0..255 range the bottom odd.
2453 U8 tmpbuf[UTF8_MAXBYTES+1];
2456 New(1109, cp, 2*tlen, UV);
2458 transv = newSVpvn("",0);
2460 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2462 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2464 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2468 cp[2*i+1] = cp[2*i];
2472 qsort(cp, i, 2*sizeof(UV), uvcompare);
2473 for (j = 0; j < i; j++) {
2475 diff = val - nextmin;
2477 t = uvuni_to_utf8(tmpbuf,nextmin);
2478 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2480 U8 range_mark = UTF_TO_NATIVE(0xff);
2481 t = uvuni_to_utf8(tmpbuf, val - 1);
2482 sv_catpvn(transv, (char *)&range_mark, 1);
2483 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2490 t = uvuni_to_utf8(tmpbuf,nextmin);
2491 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2493 U8 range_mark = UTF_TO_NATIVE(0xff);
2494 sv_catpvn(transv, (char *)&range_mark, 1);
2496 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2497 UNICODE_ALLOW_SUPER);
2498 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2499 t = (U8*)SvPVX(transv);
2500 tlen = SvCUR(transv);
2504 else if (!rlen && !del) {
2505 r = t; rlen = tlen; rend = tend;
2508 if ((!rlen && !del) || t == r ||
2509 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2511 o->op_private |= OPpTRANS_IDENTICAL;
2515 while (t < tend || tfirst <= tlast) {
2516 /* see if we need more "t" chars */
2517 if (tfirst > tlast) {
2518 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2520 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2522 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2529 /* now see if we need more "r" chars */
2530 if (rfirst > rlast) {
2532 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2534 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2536 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2545 rfirst = rlast = 0xffffffff;
2549 /* now see which range will peter our first, if either. */
2550 tdiff = tlast - tfirst;
2551 rdiff = rlast - rfirst;
2558 if (rfirst == 0xffffffff) {
2559 diff = tdiff; /* oops, pretend rdiff is infinite */
2561 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2562 (long)tfirst, (long)tlast);
2564 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2568 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2569 (long)tfirst, (long)(tfirst + diff),
2572 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2573 (long)tfirst, (long)rfirst);
2575 if (rfirst + diff > max)
2576 max = rfirst + diff;
2578 grows = (tfirst < rfirst &&
2579 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2591 else if (max > 0xff)
2596 Safefree(cPVOPo->op_pv);
2597 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2598 SvREFCNT_dec(listsv);
2600 SvREFCNT_dec(transv);
2602 if (!del && havefinal && rlen)
2603 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2604 newSVuv((UV)final), 0);
2607 o->op_private |= OPpTRANS_GROWS;
2619 tbl = (short*)cPVOPo->op_pv;
2621 Zero(tbl, 256, short);
2622 for (i = 0; i < (I32)tlen; i++)
2624 for (i = 0, j = 0; i < 256; i++) {
2626 if (j >= (I32)rlen) {
2635 if (i < 128 && r[j] >= 128)
2645 o->op_private |= OPpTRANS_IDENTICAL;
2647 else if (j >= (I32)rlen)
2650 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2651 tbl[0x100] = rlen - j;
2652 for (i=0; i < (I32)rlen - j; i++)
2653 tbl[0x101+i] = r[j+i];
2657 if (!rlen && !del) {
2660 o->op_private |= OPpTRANS_IDENTICAL;
2662 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2663 o->op_private |= OPpTRANS_IDENTICAL;
2665 for (i = 0; i < 256; i++)
2667 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
2668 if (j >= (I32)rlen) {
2670 if (tbl[t[i]] == -1)
2676 if (tbl[t[i]] == -1) {
2677 if (t[i] < 128 && r[j] >= 128)
2684 o->op_private |= OPpTRANS_GROWS;
2692 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2697 NewOp(1101, pmop, 1, PMOP);
2698 pmop->op_type = (OPCODE)type;
2699 pmop->op_ppaddr = PL_ppaddr[type];
2700 pmop->op_flags = (U8)flags;
2701 pmop->op_private = (U8)(0 | (flags >> 8));
2703 if (PL_hints & HINT_RE_TAINT)
2704 pmop->op_pmpermflags |= PMf_RETAINT;
2705 if (PL_hints & HINT_LOCALE)
2706 pmop->op_pmpermflags |= PMf_LOCALE;
2707 pmop->op_pmflags = pmop->op_pmpermflags;
2712 if(av_len((AV*) PL_regex_pad[0]) > -1) {
2713 repointer = av_pop((AV*)PL_regex_pad[0]);
2714 pmop->op_pmoffset = SvIV(repointer);
2715 SvREPADTMP_off(repointer);
2716 sv_setiv(repointer,0);
2718 repointer = newSViv(0);
2719 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2720 pmop->op_pmoffset = av_len(PL_regex_padav);
2721 PL_regex_pad = AvARRAY(PL_regex_padav);
2726 /* link into pm list */
2727 if (type != OP_TRANS && PL_curstash) {
2728 pmop->op_pmnext = HvPMROOT(PL_curstash);
2729 HvPMROOT(PL_curstash) = pmop;
2730 PmopSTASH_set(pmop,PL_curstash);
2733 return CHECKOP(type, pmop);
2736 /* Given some sort of match op o, and an expression expr containing a
2737 * pattern, either compile expr into a regex and attach it to o (if it's
2738 * constant), or convert expr into a runtime regcomp op sequence (if it's
2741 * isreg indicates that the pattern is part of a regex construct, eg
2742 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
2743 * split "pattern", which aren't. In the former case, expr will be a list
2744 * if the pattern contains more than one term (eg /a$b/) or if it contains
2745 * a replacement, ie s/// or tr///.
2749 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
2754 I32 repl_has_vars = 0;
2758 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
2759 /* last element in list is the replacement; pop it */
2761 repl = cLISTOPx(expr)->op_last;
2762 kid = cLISTOPx(expr)->op_first;
2763 while (kid->op_sibling != repl)
2764 kid = kid->op_sibling;
2765 kid->op_sibling = Nullop;
2766 cLISTOPx(expr)->op_last = kid;
2769 if (isreg && expr->op_type == OP_LIST &&
2770 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
2772 /* convert single element list to element */
2774 expr = cLISTOPx(oe)->op_first->op_sibling;
2775 cLISTOPx(oe)->op_first->op_sibling = Nullop;
2776 cLISTOPx(oe)->op_last = Nullop;
2780 if (o->op_type == OP_TRANS) {
2781 return pmtrans(o, expr, repl);
2784 reglist = isreg && expr->op_type == OP_LIST;
2788 PL_hints |= HINT_BLOCK_SCOPE;
2791 if (expr->op_type == OP_CONST) {
2793 SV *pat = ((SVOP*)expr)->op_sv;
2794 char *p = SvPV(pat, plen);
2795 if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
2796 sv_setpvn(pat, "\\s+", 3);
2797 p = SvPV(pat, plen);
2798 pm->op_pmflags |= PMf_SKIPWHITE;
2801 pm->op_pmdynflags |= PMdf_UTF8;
2802 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
2803 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
2804 pm->op_pmflags |= PMf_WHITE;
2808 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2809 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2811 : OP_REGCMAYBE),0,expr);
2813 NewOp(1101, rcop, 1, LOGOP);
2814 rcop->op_type = OP_REGCOMP;
2815 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2816 rcop->op_first = scalar(expr);
2817 rcop->op_flags |= OPf_KIDS
2818 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
2819 | (reglist ? OPf_STACKED : 0);
2820 rcop->op_private = 1;
2823 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
2825 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
2828 /* establish postfix order */
2829 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2831 rcop->op_next = expr;
2832 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2835 rcop->op_next = LINKLIST(expr);
2836 expr->op_next = (OP*)rcop;
2839 prepend_elem(o->op_type, scalar((OP*)rcop), o);
2844 if (pm->op_pmflags & PMf_EVAL) {
2846 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
2847 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
2849 else if (repl->op_type == OP_CONST)
2853 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
2854 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
2855 if (curop->op_type == OP_GV) {
2856 GV *gv = cGVOPx_gv(curop);
2858 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
2861 else if (curop->op_type == OP_RV2CV)
2863 else if (curop->op_type == OP_RV2SV ||
2864 curop->op_type == OP_RV2AV ||
2865 curop->op_type == OP_RV2HV ||
2866 curop->op_type == OP_RV2GV) {
2867 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2870 else if (curop->op_type == OP_PADSV ||
2871 curop->op_type == OP_PADAV ||
2872 curop->op_type == OP_PADHV ||
2873 curop->op_type == OP_PADANY) {
2876 else if (curop->op_type == OP_PUSHRE)
2877 ; /* Okay here, dangerous in newASSIGNOP */
2887 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
2888 pm->op_pmflags |= PMf_CONST; /* const for long enough */
2889 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
2890 prepend_elem(o->op_type, scalar(repl), o);
2893 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
2894 pm->op_pmflags |= PMf_MAYBE_CONST;
2895 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2897 NewOp(1101, rcop, 1, LOGOP);
2898 rcop->op_type = OP_SUBSTCONT;
2899 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
2900 rcop->op_first = scalar(repl);
2901 rcop->op_flags |= OPf_KIDS;
2902 rcop->op_private = 1;
2905 /* establish postfix order */
2906 rcop->op_next = LINKLIST(repl);
2907 repl->op_next = (OP*)rcop;
2909 pm->op_pmreplroot = scalar((OP*)rcop);
2910 pm->op_pmreplstart = LINKLIST(rcop);
2919 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
2923 NewOp(1101, svop, 1, SVOP);
2924 svop->op_type = (OPCODE)type;
2925 svop->op_ppaddr = PL_ppaddr[type];
2927 svop->op_next = (OP*)svop;
2928 svop->op_flags = (U8)flags;
2929 if (PL_opargs[type] & OA_RETSCALAR)
2931 if (PL_opargs[type] & OA_TARGET)
2932 svop->op_targ = pad_alloc(type, SVs_PADTMP);
2933 return CHECKOP(type, svop);
2937 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2941 NewOp(1101, padop, 1, PADOP);
2942 padop->op_type = (OPCODE)type;
2943 padop->op_ppaddr = PL_ppaddr[type];
2944 padop->op_padix = pad_alloc(type, SVs_PADTMP);
2945 SvREFCNT_dec(PAD_SVl(padop->op_padix));
2946 PAD_SETSV(padop->op_padix, sv);
2949 padop->op_next = (OP*)padop;
2950 padop->op_flags = (U8)flags;
2951 if (PL_opargs[type] & OA_RETSCALAR)
2953 if (PL_opargs[type] & OA_TARGET)
2954 padop->op_targ = pad_alloc(type, SVs_PADTMP);
2955 return CHECKOP(type, padop);
2959 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
2965 return newPADOP(type, flags, SvREFCNT_inc(gv));
2967 return newSVOP(type, flags, SvREFCNT_inc(gv));
2972 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
2976 NewOp(1101, pvop, 1, PVOP);
2977 pvop->op_type = (OPCODE)type;
2978 pvop->op_ppaddr = PL_ppaddr[type];
2980 pvop->op_next = (OP*)pvop;
2981 pvop->op_flags = (U8)flags;
2982 if (PL_opargs[type] & OA_RETSCALAR)
2984 if (PL_opargs[type] & OA_TARGET)
2985 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
2986 return CHECKOP(type, pvop);
2990 Perl_package(pTHX_ OP *o)
2995 save_hptr(&PL_curstash);
2996 save_item(PL_curstname);
2998 name = SvPV(cSVOPo->op_sv, len);
2999 PL_curstash = gv_stashpvn(name, len, TRUE);
3000 sv_setpvn(PL_curstname, name, len);
3003 PL_hints |= HINT_BLOCK_SCOPE;
3004 PL_copline = NOLINE;
3009 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3015 if (idop->op_type != OP_CONST)
3016 Perl_croak(aTHX_ "Module name must be constant");
3020 if (version != Nullop) {
3021 SV *vesv = ((SVOP*)version)->op_sv;
3023 if (arg == Nullop && !SvNIOKp(vesv)) {
3030 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3031 Perl_croak(aTHX_ "Version number must be constant number");
3033 /* Make copy of idop so we don't free it twice */
3034 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3036 /* Fake up a method call to VERSION */
3037 meth = newSVpvn("VERSION",7);
3038 sv_upgrade(meth, SVt_PVIV);
3039 (void)SvIOK_on(meth);
3042 PERL_HASH(hash, SvPVX(meth), SvCUR(meth));
3043 SvUV_set(meth, hash);
3045 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3046 append_elem(OP_LIST,
3047 prepend_elem(OP_LIST, pack, list(version)),
3048 newSVOP(OP_METHOD_NAMED, 0, meth)));
3052 /* Fake up an import/unimport */
3053 if (arg && arg->op_type == OP_STUB)
3054 imop = arg; /* no import on explicit () */
3055 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3056 imop = Nullop; /* use 5.0; */
3061 /* Make copy of idop so we don't free it twice */
3062 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3064 /* Fake up a method call to import/unimport */
3065 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);
3066 (void)SvUPGRADE(meth, SVt_PVIV);
3067 (void)SvIOK_on(meth);
3070 PERL_HASH(hash, SvPVX(meth), SvCUR(meth));
3071 SvUV_set(meth, hash);
3073 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3074 append_elem(OP_LIST,
3075 prepend_elem(OP_LIST, pack, list(arg)),
3076 newSVOP(OP_METHOD_NAMED, 0, meth)));
3079 /* Fake up the BEGIN {}, which does its thing immediately. */
3081 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3084 append_elem(OP_LINESEQ,
3085 append_elem(OP_LINESEQ,
3086 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, idop)),
3087 newSTATEOP(0, Nullch, veop)),
3088 newSTATEOP(0, Nullch, imop) ));
3090 /* The "did you use incorrect case?" warning used to be here.
3091 * The problem is that on case-insensitive filesystems one
3092 * might get false positives for "use" (and "require"):
3093 * "use Strict" or "require CARP" will work. This causes
3094 * portability problems for the script: in case-strict
3095 * filesystems the script will stop working.
3097 * The "incorrect case" warning checked whether "use Foo"
3098 * imported "Foo" to your namespace, but that is wrong, too:
3099 * there is no requirement nor promise in the language that
3100 * a Foo.pm should or would contain anything in package "Foo".
3102 * There is very little Configure-wise that can be done, either:
3103 * the case-sensitivity of the build filesystem of Perl does not
3104 * help in guessing the case-sensitivity of the runtime environment.
3107 PL_hints |= HINT_BLOCK_SCOPE;
3108 PL_copline = NOLINE;
3110 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3114 =head1 Embedding Functions
3116 =for apidoc load_module
3118 Loads the module whose name is pointed to by the string part of name.
3119 Note that the actual module name, not its filename, should be given.
3120 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3121 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3122 (or 0 for no flags). ver, if specified, provides version semantics
3123 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3124 arguments can be used to specify arguments to the module's import()
3125 method, similar to C<use Foo::Bar VERSION LIST>.
3130 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3133 va_start(args, ver);
3134 vload_module(flags, name, ver, &args);
3138 #ifdef PERL_IMPLICIT_CONTEXT
3140 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3144 va_start(args, ver);
3145 vload_module(flags, name, ver, &args);
3151 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3153 OP *modname, *veop, *imop;
3155 modname = newSVOP(OP_CONST, 0, name);
3156 modname->op_private |= OPpCONST_BARE;
3158 veop = newSVOP(OP_CONST, 0, ver);
3162 if (flags & PERL_LOADMOD_NOIMPORT) {
3163 imop = sawparens(newNULLLIST());
3165 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3166 imop = va_arg(*args, OP*);
3171 sv = va_arg(*args, SV*);
3173 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3174 sv = va_arg(*args, SV*);
3178 const line_t ocopline = PL_copline;
3179 COP * const ocurcop = PL_curcop;
3180 const int oexpect = PL_expect;
3182 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3183 veop, modname, imop);
3184 PL_expect = oexpect;
3185 PL_copline = ocopline;
3186 PL_curcop = ocurcop;
3191 Perl_dofile(pTHX_ OP *term)
3196 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3197 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
3198 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3200 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3201 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3202 append_elem(OP_LIST, term,
3203 scalar(newUNOP(OP_RV2CV, 0,
3208 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3214 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3216 return newBINOP(OP_LSLICE, flags,
3217 list(force_list(subscript)),
3218 list(force_list(listval)) );
3222 S_list_assignment(pTHX_ register const OP *o)
3227 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3228 o = cUNOPo->op_first;
3230 if (o->op_type == OP_COND_EXPR) {
3231 const I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3232 const I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3237 yyerror("Assignment to both a list and a scalar");
3241 if (o->op_type == OP_LIST &&
3242 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3243 o->op_private & OPpLVAL_INTRO)
3246 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3247 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3248 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3251 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3254 if (o->op_type == OP_RV2SV)
3261 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3266 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3267 return newLOGOP(optype, 0,
3268 mod(scalar(left), optype),
3269 newUNOP(OP_SASSIGN, 0, scalar(right)));
3272 return newBINOP(optype, OPf_STACKED,
3273 mod(scalar(left), optype), scalar(right));
3277 if (list_assignment(left)) {
3281 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3282 left = mod(left, OP_AASSIGN);
3290 /* optimise C<my @x = ()> to C<my @x>, and likewise for hashes */
3291 if ((left->op_type == OP_PADAV || left->op_type == OP_PADHV)
3292 && right->op_type == OP_STUB
3293 && (left->op_private & OPpLVAL_INTRO))
3296 left->op_flags &= ~(OPf_REF|OPf_SPECIAL);
3299 curop = list(force_list(left));
3300 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3301 o->op_private = (U8)(0 | (flags >> 8));
3303 /* PL_generation sorcery:
3304 * an assignment like ($a,$b) = ($c,$d) is easier than
3305 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3306 * To detect whether there are common vars, the global var
3307 * PL_generation is incremented for each assign op we compile.
3308 * Then, while compiling the assign op, we run through all the
3309 * variables on both sides of the assignment, setting a spare slot
3310 * in each of them to PL_generation. If any of them already have
3311 * that value, we know we've got commonality. We could use a
3312 * single bit marker, but then we'd have to make 2 passes, first
3313 * to clear the flag, then to test and set it. To find somewhere
3314 * to store these values, evil chicanery is done with SvCUR().
3317 if (!(left->op_private & OPpLVAL_INTRO)) {
3320 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3321 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3322 if (curop->op_type == OP_GV) {
3323 GV *gv = cGVOPx_gv(curop);
3324 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3326 SvCUR_set(gv, PL_generation);
3328 else if (curop->op_type == OP_PADSV ||
3329 curop->op_type == OP_PADAV ||
3330 curop->op_type == OP_PADHV ||
3331 curop->op_type == OP_PADANY)
3333 if (PAD_COMPNAME_GEN(curop->op_targ)
3334 == (STRLEN)PL_generation)
3336 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
3339 else if (curop->op_type == OP_RV2CV)
3341 else if (curop->op_type == OP_RV2SV ||
3342 curop->op_type == OP_RV2AV ||
3343 curop->op_type == OP_RV2HV ||
3344 curop->op_type == OP_RV2GV) {
3345 if (lastop->op_type != OP_GV) /* funny deref? */
3348 else if (curop->op_type == OP_PUSHRE) {
3349 if (((PMOP*)curop)->op_pmreplroot) {
3351 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3352 ((PMOP*)curop)->op_pmreplroot));
3354 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3356 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3358 SvCUR_set(gv, PL_generation);
3367 o->op_private |= OPpASSIGN_COMMON;
3369 if (right && right->op_type == OP_SPLIT) {
3371 if ((tmpop = ((LISTOP*)right)->op_first) &&
3372 tmpop->op_type == OP_PUSHRE)
3374 PMOP *pm = (PMOP*)tmpop;
3375 if (left->op_type == OP_RV2AV &&
3376 !(left->op_private & OPpLVAL_INTRO) &&
3377 !(o->op_private & OPpASSIGN_COMMON) )
3379 tmpop = ((UNOP*)left)->op_first;
3380 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3382 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3383 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3385 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3386 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3388 pm->op_pmflags |= PMf_ONCE;
3389 tmpop = cUNOPo->op_first; /* to list (nulled) */
3390 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3391 tmpop->op_sibling = Nullop; /* don't free split */
3392 right->op_next = tmpop->op_next; /* fix starting loc */
3393 op_free(o); /* blow off assign */
3394 right->op_flags &= ~OPf_WANT;
3395 /* "I don't know and I don't care." */
3400 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3401 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3403 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3405 sv_setiv(sv, PL_modcount+1);
3413 right = newOP(OP_UNDEF, 0);
3414 if (right->op_type == OP_READLINE) {
3415 right->op_flags |= OPf_STACKED;
3416 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3419 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3420 o = newBINOP(OP_SASSIGN, flags,
3421 scalar(right), mod(scalar(left), OP_SASSIGN) );
3433 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3436 const U32 seq = intro_my();
3439 NewOp(1101, cop, 1, COP);
3440 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3441 cop->op_type = OP_DBSTATE;
3442 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3445 cop->op_type = OP_NEXTSTATE;
3446 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3448 cop->op_flags = (U8)flags;
3449 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3451 cop->op_private |= NATIVE_HINTS;
3453 PL_compiling.op_private = cop->op_private;
3454 cop->op_next = (OP*)cop;
3457 cop->cop_label = label;
3458 PL_hints |= HINT_BLOCK_SCOPE;
3461 cop->cop_arybase = PL_curcop->cop_arybase;
3462 if (specialWARN(PL_curcop->cop_warnings))
3463 cop->cop_warnings = PL_curcop->cop_warnings ;
3465 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3466 if (specialCopIO(PL_curcop->cop_io))
3467 cop->cop_io = PL_curcop->cop_io;
3469 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3472 if (PL_copline == NOLINE)
3473 CopLINE_set(cop, CopLINE(PL_curcop));
3475 CopLINE_set(cop, PL_copline);
3476 PL_copline = NOLINE;
3479 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3481 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3483 CopSTASH_set(cop, PL_curstash);
3485 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3486 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3487 if (svp && *svp != &PL_sv_undef ) {
3488 (void)SvIOK_on(*svp);
3489 SvIV_set(*svp, PTR2IV(cop));
3493 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3498 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3501 return new_logop(type, flags, &first, &other);
3505 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3510 OP *first = *firstp;
3511 OP *other = *otherp;
3513 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3514 return newBINOP(type, flags, scalar(first), scalar(other));
3516 scalarboolean(first);
3517 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3518 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3519 if (type == OP_AND || type == OP_OR) {
3525 first = *firstp = cUNOPo->op_first;
3527 first->op_next = o->op_next;
3528 cUNOPo->op_first = Nullop;
3532 if (first->op_type == OP_CONST) {
3533 if (first->op_private & OPpCONST_STRICT)
3534 no_bareword_allowed(first);
3535 else if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3536 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3537 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
3538 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
3539 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
3542 if (other->op_type == OP_CONST)
3543 other->op_private |= OPpCONST_SHORTCIRCUIT;
3547 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
3548 const OP *o2 = other;
3549 if ( ! (o2->op_type == OP_LIST
3550 && (( o2 = cUNOPx(o2)->op_first))
3551 && o2->op_type == OP_PUSHMARK
3552 && (( o2 = o2->op_sibling)) )
3555 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
3556 || o2->op_type == OP_PADHV)
3557 && o2->op_private & OPpLVAL_INTRO
3558 && ckWARN(WARN_DEPRECATED))
3560 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
3561 "Deprecated use of my() in false conditional");
3566 if (first->op_type == OP_CONST)
3567 first->op_private |= OPpCONST_SHORTCIRCUIT;
3571 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS) &&
3572 type != OP_DOR) /* [#24076] Don't warn for <FH> err FOO. */
3574 const OP *k1 = ((UNOP*)first)->op_first;
3575 const OP *k2 = k1->op_sibling;
3577 switch (first->op_type)
3580 if (k2 && k2->op_type == OP_READLINE
3581 && (k2->op_flags & OPf_STACKED)
3582 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3584 warnop = k2->op_type;
3589 if (k1->op_type == OP_READDIR
3590 || k1->op_type == OP_GLOB
3591 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3592 || k1->op_type == OP_EACH)
3594 warnop = ((k1->op_type == OP_NULL)
3595 ? (OPCODE)k1->op_targ : k1->op_type);
3600 const line_t oldline = CopLINE(PL_curcop);
3601 CopLINE_set(PL_curcop, PL_copline);
3602 Perl_warner(aTHX_ packWARN(WARN_MISC),
3603 "Value of %s%s can be \"0\"; test with defined()",
3605 ((warnop == OP_READLINE || warnop == OP_GLOB)
3606 ? " construct" : "() operator"));
3607 CopLINE_set(PL_curcop, oldline);
3614 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3615 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3617 NewOp(1101, logop, 1, LOGOP);
3619 logop->op_type = (OPCODE)type;
3620 logop->op_ppaddr = PL_ppaddr[type];
3621 logop->op_first = first;
3622 logop->op_flags = flags | OPf_KIDS;
3623 logop->op_other = LINKLIST(other);
3624 logop->op_private = (U8)(1 | (flags >> 8));
3626 /* establish postfix order */
3627 logop->op_next = LINKLIST(first);
3628 first->op_next = (OP*)logop;
3629 first->op_sibling = other;
3631 CHECKOP(type,logop);
3633 o = newUNOP(OP_NULL, 0, (OP*)logop);
3640 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3648 return newLOGOP(OP_AND, 0, first, trueop);
3650 return newLOGOP(OP_OR, 0, first, falseop);
3652 scalarboolean(first);
3653 if (first->op_type == OP_CONST) {
3654 if (first->op_private & OPpCONST_BARE &&
3655 first->op_private & OPpCONST_STRICT) {
3656 no_bareword_allowed(first);
3658 if (SvTRUE(((SVOP*)first)->op_sv)) {
3669 NewOp(1101, logop, 1, LOGOP);
3670 logop->op_type = OP_COND_EXPR;
3671 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3672 logop->op_first = first;
3673 logop->op_flags = flags | OPf_KIDS;
3674 logop->op_private = (U8)(1 | (flags >> 8));
3675 logop->op_other = LINKLIST(trueop);
3676 logop->op_next = LINKLIST(falseop);
3678 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
3681 /* establish postfix order */
3682 start = LINKLIST(first);
3683 first->op_next = (OP*)logop;
3685 first->op_sibling = trueop;
3686 trueop->op_sibling = falseop;
3687 o = newUNOP(OP_NULL, 0, (OP*)logop);
3689 trueop->op_next = falseop->op_next = o;
3696 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3705 NewOp(1101, range, 1, LOGOP);
3707 range->op_type = OP_RANGE;
3708 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3709 range->op_first = left;
3710 range->op_flags = OPf_KIDS;
3711 leftstart = LINKLIST(left);
3712 range->op_other = LINKLIST(right);
3713 range->op_private = (U8)(1 | (flags >> 8));
3715 left->op_sibling = right;
3717 range->op_next = (OP*)range;
3718 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3719 flop = newUNOP(OP_FLOP, 0, flip);
3720 o = newUNOP(OP_NULL, 0, flop);
3722 range->op_next = leftstart;
3724 left->op_next = flip;
3725 right->op_next = flop;
3727 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3728 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3729 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3730 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3732 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3733 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3736 if (!flip->op_private || !flop->op_private)
3737 linklist(o); /* blow off optimizer unless constant */
3743 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3747 const bool once = block && block->op_flags & OPf_SPECIAL &&
3748 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3752 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3753 return block; /* do {} while 0 does once */
3754 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3755 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3756 expr = newUNOP(OP_DEFINED, 0,
3757 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3758 } else if (expr->op_flags & OPf_KIDS) {
3759 const OP *k1 = ((UNOP*)expr)->op_first;
3760 const OP *k2 = (k1) ? k1->op_sibling : NULL;
3761 switch (expr->op_type) {
3763 if (k2 && k2->op_type == OP_READLINE
3764 && (k2->op_flags & OPf_STACKED)
3765 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3766 expr = newUNOP(OP_DEFINED, 0, expr);
3770 if (k1->op_type == OP_READDIR
3771 || k1->op_type == OP_GLOB
3772 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3773 || k1->op_type == OP_EACH)
3774 expr = newUNOP(OP_DEFINED, 0, expr);
3780 /* if block is null, the next append_elem() would put UNSTACK, a scalar
3781 * op, in listop. This is wrong. [perl #27024] */
3783 block = newOP(OP_NULL, 0);
3784 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3785 o = new_logop(OP_AND, 0, &expr, &listop);
3788 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3790 if (once && o != listop)
3791 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3794 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3796 o->op_flags |= flags;
3798 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3803 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
3804 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
3814 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3815 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3816 expr = newUNOP(OP_DEFINED, 0,
3817 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3818 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3819 const OP *k1 = ((UNOP*)expr)->op_first;
3820 const OP *k2 = (k1) ? k1->op_sibling : NULL;
3821 switch (expr->op_type) {
3823 if (k2 && k2->op_type == OP_READLINE
3824 && (k2->op_flags & OPf_STACKED)
3825 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3826 expr = newUNOP(OP_DEFINED, 0, expr);
3830 if (k1->op_type == OP_READDIR
3831 || k1->op_type == OP_GLOB
3832 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3833 || k1->op_type == OP_EACH)
3834 expr = newUNOP(OP_DEFINED, 0, expr);
3840 block = newOP(OP_NULL, 0);
3841 else if (cont || has_my) {
3842 block = scope(block);
3846 next = LINKLIST(cont);
3849 OP *unstack = newOP(OP_UNSTACK, 0);
3852 cont = append_elem(OP_LINESEQ, cont, unstack);
3855 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3856 redo = LINKLIST(listop);
3859 PL_copline = (line_t)whileline;
3861 o = new_logop(OP_AND, 0, &expr, &listop);
3862 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3863 op_free(expr); /* oops, it's a while (0) */
3865 return Nullop; /* listop already freed by new_logop */
3868 ((LISTOP*)listop)->op_last->op_next =
3869 (o == listop ? redo : LINKLIST(o));
3875 NewOp(1101,loop,1,LOOP);
3876 loop->op_type = OP_ENTERLOOP;
3877 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3878 loop->op_private = 0;
3879 loop->op_next = (OP*)loop;
3882 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3884 loop->op_redoop = redo;
3885 loop->op_lastop = o;
3886 o->op_private |= loopflags;
3889 loop->op_nextop = next;
3891 loop->op_nextop = o;
3893 o->op_flags |= flags;
3894 o->op_private |= (flags >> 8);
3899 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
3904 PADOFFSET padoff = 0;
3909 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
3910 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
3911 sv->op_type = OP_RV2GV;
3912 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3914 else if (sv->op_type == OP_PADSV) { /* private variable */
3915 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
3916 padoff = sv->op_targ;
3921 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3922 padoff = sv->op_targ;
3924 iterflags |= OPf_SPECIAL;
3929 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3932 const I32 offset = pad_findmy("$_");
3933 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
3934 sv = newGVOP(OP_GV, 0, PL_defgv);
3940 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3941 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3942 iterflags |= OPf_STACKED;
3944 else if (expr->op_type == OP_NULL &&
3945 (expr->op_flags & OPf_KIDS) &&
3946 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3948 /* Basically turn for($x..$y) into the same as for($x,$y), but we
3949 * set the STACKED flag to indicate that these values are to be
3950 * treated as min/max values by 'pp_iterinit'.
3952 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
3953 LOGOP* range = (LOGOP*) flip->op_first;
3954 OP* left = range->op_first;
3955 OP* right = left->op_sibling;
3958 range->op_flags &= ~OPf_KIDS;
3959 range->op_first = Nullop;
3961 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
3962 listop->op_first->op_next = range->op_next;
3963 left->op_next = range->op_other;
3964 right->op_next = (OP*)listop;
3965 listop->op_next = listop->op_first;
3968 expr = (OP*)(listop);
3970 iterflags |= OPf_STACKED;
3973 expr = mod(force_list(expr), OP_GREPSTART);
3976 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
3977 append_elem(OP_LIST, expr, scalar(sv))));
3978 assert(!loop->op_next);
3979 /* for my $x () sets OPpLVAL_INTRO;
3980 * for our $x () sets OPpOUR_INTRO */
3981 loop->op_private = (U8)iterpflags;
3982 #ifdef PL_OP_SLAB_ALLOC
3985 NewOp(1234,tmp,1,LOOP);
3986 Copy(loop,tmp,1,LISTOP);
3991 Renew(loop, 1, LOOP);
3993 loop->op_targ = padoff;
3994 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
3995 PL_copline = forline;
3996 return newSTATEOP(0, label, wop);
4000 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4005 if (type != OP_GOTO || label->op_type == OP_CONST) {
4006 /* "last()" means "last" */
4007 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4008 o = newOP(type, OPf_SPECIAL);
4010 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4011 ? SvPVx(((SVOP*)label)->op_sv, n_a)
4017 /* Check whether it's going to be a goto &function */
4018 if (label->op_type == OP_ENTERSUB
4019 && !(label->op_flags & OPf_STACKED))
4020 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4021 o = newUNOP(type, OPf_STACKED, label);
4023 PL_hints |= HINT_BLOCK_SCOPE;
4028 =for apidoc cv_undef
4030 Clear out all the active components of a CV. This can happen either
4031 by an explicit C<undef &foo>, or by the reference count going to zero.
4032 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4033 children can still follow the full lexical scope chain.
4039 Perl_cv_undef(pTHX_ CV *cv)
4043 if (CvFILE(cv) && !CvXSUB(cv)) {
4044 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4045 Safefree(CvFILE(cv));
4050 if (!CvXSUB(cv) && CvROOT(cv)) {
4052 Perl_croak(aTHX_ "Can't undef active subroutine");
4055 PAD_SAVE_SETNULLPAD();
4057 op_free(CvROOT(cv));
4058 CvROOT(cv) = Nullop;
4061 SvPOK_off((SV*)cv); /* forget prototype */
4066 /* remove CvOUTSIDE unless this is an undef rather than a free */
4067 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4068 if (!CvWEAKOUTSIDE(cv))
4069 SvREFCNT_dec(CvOUTSIDE(cv));
4070 CvOUTSIDE(cv) = Nullcv;
4073 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4079 /* delete all flags except WEAKOUTSIDE */
4080 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4084 Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p)
4086 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4087 SV* msg = sv_newmortal();
4091 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4092 sv_setpv(msg, "Prototype mismatch:");
4094 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4096 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (const SV *)cv);
4098 Perl_sv_catpv(aTHX_ msg, ": none");
4099 sv_catpv(msg, " vs ");
4101 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4103 sv_catpv(msg, "none");
4104 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
4108 static void const_sv_xsub(pTHX_ CV* cv);
4112 =head1 Optree Manipulation Functions
4114 =for apidoc cv_const_sv
4116 If C<cv> is a constant sub eligible for inlining. returns the constant
4117 value returned by the sub. Otherwise, returns NULL.
4119 Constant subs can be created with C<newCONSTSUB> or as described in
4120 L<perlsub/"Constant Functions">.
4125 Perl_cv_const_sv(pTHX_ CV *cv)
4127 if (!cv || !CvCONST(cv))
4129 return (SV*)CvXSUBANY(cv).any_ptr;
4132 /* op_const_sv: examine an optree to determine whether it's in-lineable.
4133 * Can be called in 3 ways:
4136 * look for a single OP_CONST with attached value: return the value
4138 * cv && CvCLONE(cv) && !CvCONST(cv)
4140 * examine the clone prototype, and if contains only a single
4141 * OP_CONST referencing a pad const, or a single PADSV referencing
4142 * an outer lexical, return a non-zero value to indicate the CV is
4143 * a candidate for "constizing" at clone time
4147 * We have just cloned an anon prototype that was marked as a const
4148 * candidiate. Try to grab the current value, and in the case of
4149 * PADSV, ignore it if it has multiple references. Return the value.
4153 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
4160 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4161 o = cLISTOPo->op_first->op_sibling;
4163 for (; o; o = o->op_next) {
4164 OPCODE type = o->op_type;
4166 if (sv && o->op_next == o)
4168 if (o->op_next != o) {
4169 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4171 if (type == OP_DBSTATE)
4174 if (type == OP_LEAVESUB || type == OP_RETURN)
4178 if (type == OP_CONST && cSVOPo->op_sv)
4180 else if (cv && type == OP_CONST) {
4181 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4185 else if (cv && type == OP_PADSV) {
4186 if (CvCONST(cv)) { /* newly cloned anon */
4187 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4188 /* the candidate should have 1 ref from this pad and 1 ref
4189 * from the parent */
4190 if (!sv || SvREFCNT(sv) != 2)
4197 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4198 sv = &PL_sv_undef; /* an arbitrary non-null value */
4209 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4220 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4224 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4226 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4230 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4241 const char * const name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4244 assert(proto->op_type == OP_CONST);
4245 ps = SvPVx(((SVOP*)proto)->op_sv, ps_len);
4250 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4251 SV *sv = sv_newmortal();
4252 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4253 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4254 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4259 gv = name ? gv_fetchsv(cSVOPo->op_sv,
4260 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4262 : gv_fetchpv(aname ? aname
4263 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4264 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4274 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4275 maximum a prototype before. */
4276 if (SvTYPE(gv) > SVt_NULL) {
4277 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4278 && ckWARN_d(WARN_PROTOTYPE))
4280 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4282 cv_ckproto((CV*)gv, NULL, ps);
4285 sv_setpvn((SV*)gv, ps, ps_len);
4287 sv_setiv((SV*)gv, -1);
4288 SvREFCNT_dec(PL_compcv);
4289 cv = PL_compcv = NULL;
4290 PL_sub_generation++;
4294 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4296 #ifdef GV_UNIQUE_CHECK
4297 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4298 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4302 if (!block || !ps || *ps || attrs)
4305 const_sv = op_const_sv(block, Nullcv);
4308 const bool exists = CvROOT(cv) || CvXSUB(cv);
4310 #ifdef GV_UNIQUE_CHECK
4311 if (exists && GvUNIQUE(gv)) {
4312 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4316 /* if the subroutine doesn't exist and wasn't pre-declared
4317 * with a prototype, assume it will be AUTOLOADed,
4318 * skipping the prototype check
4320 if (exists || SvPOK(cv))
4321 cv_ckproto(cv, gv, ps);
4322 /* already defined (or promised)? */
4323 if (exists || GvASSUMECV(gv)) {
4324 if (!block && !attrs) {
4325 if (CvFLAGS(PL_compcv)) {
4326 /* might have had built-in attrs applied */
4327 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4329 /* just a "sub foo;" when &foo is already defined */
4330 SAVEFREESV(PL_compcv);
4333 /* ahem, death to those who redefine active sort subs */
4334 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4335 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4337 if (ckWARN(WARN_REDEFINE)
4339 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4341 const line_t oldline = CopLINE(PL_curcop);
4342 if (PL_copline != NOLINE)
4343 CopLINE_set(PL_curcop, PL_copline);
4344 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4345 CvCONST(cv) ? "Constant subroutine %s redefined"
4346 : "Subroutine %s redefined", name);
4347 CopLINE_set(PL_curcop, oldline);
4355 (void)SvREFCNT_inc(const_sv);
4357 assert(!CvROOT(cv) && !CvCONST(cv));
4358 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
4359 CvXSUBANY(cv).any_ptr = const_sv;
4360 CvXSUB(cv) = const_sv_xsub;
4365 cv = newCONSTSUB(NULL, name, const_sv);
4368 SvREFCNT_dec(PL_compcv);
4370 PL_sub_generation++;
4377 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4378 * before we clobber PL_compcv.
4382 /* Might have had built-in attributes applied -- propagate them. */
4383 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4384 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4385 stash = GvSTASH(CvGV(cv));
4386 else if (CvSTASH(cv))
4387 stash = CvSTASH(cv);
4389 stash = PL_curstash;
4392 /* possibly about to re-define existing subr -- ignore old cv */
4393 rcv = (SV*)PL_compcv;
4394 if (name && GvSTASH(gv))
4395 stash = GvSTASH(gv);
4397 stash = PL_curstash;
4399 apply_attrs(stash, rcv, attrs, FALSE);
4401 if (cv) { /* must reuse cv if autoloaded */
4403 /* got here with just attrs -- work done, so bug out */
4404 SAVEFREESV(PL_compcv);
4407 /* transfer PL_compcv to cv */
4409 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4410 if (!CvWEAKOUTSIDE(cv))
4411 SvREFCNT_dec(CvOUTSIDE(cv));
4412 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4413 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4414 CvOUTSIDE(PL_compcv) = 0;
4415 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4416 CvPADLIST(PL_compcv) = 0;
4417 /* inner references to PL_compcv must be fixed up ... */
4418 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4419 /* ... before we throw it away */
4420 SvREFCNT_dec(PL_compcv);
4422 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4423 ++PL_sub_generation;
4430 PL_sub_generation++;
4434 CvFILE_set_from_cop(cv, PL_curcop);
4435 CvSTASH(cv) = PL_curstash;
4438 sv_setpvn((SV*)cv, ps, ps_len);
4440 if (PL_error_count) {
4444 const char *s = strrchr(name, ':');
4446 if (strEQ(s, "BEGIN")) {
4447 const char not_safe[] =
4448 "BEGIN not safe after errors--compilation aborted";
4449 if (PL_in_eval & EVAL_KEEPERR)
4450 Perl_croak(aTHX_ not_safe);
4452 /* force display of errors found but not reported */
4453 sv_catpv(ERRSV, not_safe);
4454 Perl_croak(aTHX_ "%"SVf, ERRSV);
4463 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4464 mod(scalarseq(block), OP_LEAVESUBLV));
4467 /* This makes sub {}; work as expected. */
4468 if (block->op_type == OP_STUB) {
4470 block = newSTATEOP(0, Nullch, 0);
4472 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4474 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4475 OpREFCNT_set(CvROOT(cv), 1);
4476 CvSTART(cv) = LINKLIST(CvROOT(cv));
4477 CvROOT(cv)->op_next = 0;
4478 CALL_PEEP(CvSTART(cv));
4480 /* now that optimizer has done its work, adjust pad values */
4482 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4485 assert(!CvCONST(cv));
4486 if (ps && !*ps && op_const_sv(block, cv))
4490 if (name || aname) {
4492 const char *tname = (name ? name : aname);
4494 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4495 SV *sv = NEWSV(0,0);
4496 SV *tmpstr = sv_newmortal();
4497 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4501 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4503 (long)PL_subline, (long)CopLINE(PL_curcop));
4504 gv_efullname3(tmpstr, gv, Nullch);
4505 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4506 hv = GvHVn(db_postponed);
4507 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4508 && (pcv = GvCV(db_postponed)))
4514 call_sv((SV*)pcv, G_DISCARD);
4518 if ((s = strrchr(tname,':')))
4523 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4526 if (strEQ(s, "BEGIN") && !PL_error_count) {
4527 const I32 oldscope = PL_scopestack_ix;
4529 SAVECOPFILE(&PL_compiling);
4530 SAVECOPLINE(&PL_compiling);
4533 PL_beginav = newAV();
4534 DEBUG_x( dump_sub(gv) );
4535 av_push(PL_beginav, (SV*)cv);
4536 GvCV(gv) = 0; /* cv has been hijacked */
4537 call_list(oldscope, PL_beginav);
4539 PL_curcop = &PL_compiling;
4540 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4543 else if (strEQ(s, "END") && !PL_error_count) {
4546 DEBUG_x( dump_sub(gv) );
4547 av_unshift(PL_endav, 1);
4548 av_store(PL_endav, 0, (SV*)cv);
4549 GvCV(gv) = 0; /* cv has been hijacked */
4551 else if (strEQ(s, "CHECK") && !PL_error_count) {
4553 PL_checkav = newAV();
4554 DEBUG_x( dump_sub(gv) );
4555 if (PL_main_start && ckWARN(WARN_VOID))
4556 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4557 av_unshift(PL_checkav, 1);
4558 av_store(PL_checkav, 0, (SV*)cv);
4559 GvCV(gv) = 0; /* cv has been hijacked */
4561 else if (strEQ(s, "INIT") && !PL_error_count) {
4563 PL_initav = newAV();
4564 DEBUG_x( dump_sub(gv) );
4565 if (PL_main_start && ckWARN(WARN_VOID))
4566 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4567 av_push(PL_initav, (SV*)cv);
4568 GvCV(gv) = 0; /* cv has been hijacked */
4573 PL_copline = NOLINE;
4578 /* XXX unsafe for threads if eval_owner isn't held */
4580 =for apidoc newCONSTSUB
4582 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4583 eligible for inlining at compile-time.
4589 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
4596 SAVECOPLINE(PL_curcop);
4597 CopLINE_set(PL_curcop, PL_copline);
4600 PL_hints &= ~HINT_BLOCK_SCOPE;
4603 SAVESPTR(PL_curstash);
4604 SAVECOPSTASH(PL_curcop);
4605 PL_curstash = stash;
4606 CopSTASH_set(PL_curcop,stash);
4609 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4610 CvXSUBANY(cv).any_ptr = sv;
4612 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
4615 CopSTASH_free(PL_curcop);
4623 =for apidoc U||newXS
4625 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4631 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
4633 GV *gv = gv_fetchpv(name ? name :
4634 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4635 GV_ADDMULTI, SVt_PVCV);
4639 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4641 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4643 /* just a cached method */
4647 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4648 /* already defined (or promised) */
4649 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4650 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4651 const line_t oldline = CopLINE(PL_curcop);
4652 if (PL_copline != NOLINE)
4653 CopLINE_set(PL_curcop, PL_copline);
4654 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4655 CvCONST(cv) ? "Constant subroutine %s redefined"
4656 : "Subroutine %s redefined"
4658 CopLINE_set(PL_curcop, oldline);
4665 if (cv) /* must reuse cv if autoloaded */
4668 cv = (CV*)NEWSV(1105,0);
4669 sv_upgrade((SV *)cv, SVt_PVCV);
4673 PL_sub_generation++;
4677 (void)gv_fetchfile(filename);
4678 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
4679 an external constant string */
4680 CvXSUB(cv) = subaddr;
4683 const char *s = strrchr(name,':');
4689 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4692 if (strEQ(s, "BEGIN")) {
4694 PL_beginav = newAV();
4695 av_push(PL_beginav, (SV*)cv);
4696 GvCV(gv) = 0; /* cv has been hijacked */
4698 else if (strEQ(s, "END")) {
4701 av_unshift(PL_endav, 1);
4702 av_store(PL_endav, 0, (SV*)cv);
4703 GvCV(gv) = 0; /* cv has been hijacked */
4705 else if (strEQ(s, "CHECK")) {
4707 PL_checkav = newAV();
4708 if (PL_main_start && ckWARN(WARN_VOID))
4709 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4710 av_unshift(PL_checkav, 1);
4711 av_store(PL_checkav, 0, (SV*)cv);
4712 GvCV(gv) = 0; /* cv has been hijacked */
4714 else if (strEQ(s, "INIT")) {
4716 PL_initav = newAV();
4717 if (PL_main_start && ckWARN(WARN_VOID))
4718 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4719 av_push(PL_initav, (SV*)cv);
4720 GvCV(gv) = 0; /* cv has been hijacked */
4731 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4737 gv = gv_fetchsv(cSVOPo->op_sv, TRUE, SVt_PVFM);
4739 gv = gv_fetchpv("STDOUT", TRUE, SVt_PVFM);
4741 #ifdef GV_UNIQUE_CHECK
4743 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4747 if ((cv = GvFORM(gv))) {
4748 if (ckWARN(WARN_REDEFINE)) {
4749 const line_t oldline = CopLINE(PL_curcop);
4750 if (PL_copline != NOLINE)
4751 CopLINE_set(PL_curcop, PL_copline);
4752 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4753 o ? "Format %"SVf" redefined"
4754 : "Format STDOUT redefined" ,cSVOPo->op_sv);
4755 CopLINE_set(PL_curcop, oldline);
4762 CvFILE_set_from_cop(cv, PL_curcop);
4765 pad_tidy(padtidy_FORMAT);
4766 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4767 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4768 OpREFCNT_set(CvROOT(cv), 1);
4769 CvSTART(cv) = LINKLIST(CvROOT(cv));
4770 CvROOT(cv)->op_next = 0;
4771 CALL_PEEP(CvSTART(cv));
4773 PL_copline = NOLINE;
4778 Perl_newANONLIST(pTHX_ OP *o)
4780 return newUNOP(OP_REFGEN, 0,
4781 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4785 Perl_newANONHASH(pTHX_ OP *o)
4787 return newUNOP(OP_REFGEN, 0,
4788 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4792 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4794 return newANONATTRSUB(floor, proto, Nullop, block);
4798 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4800 return newUNOP(OP_REFGEN, 0,
4801 newSVOP(OP_ANONCODE, 0,
4802 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
4806 Perl_oopsAV(pTHX_ OP *o)
4809 switch (o->op_type) {
4811 o->op_type = OP_PADAV;
4812 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4813 return ref(o, OP_RV2AV);
4816 o->op_type = OP_RV2AV;
4817 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4822 if (ckWARN_d(WARN_INTERNAL))
4823 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
4830 Perl_oopsHV(pTHX_ OP *o)
4833 switch (o->op_type) {
4836 o->op_type = OP_PADHV;
4837 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4838 return ref(o, OP_RV2HV);
4842 o->op_type = OP_RV2HV;
4843 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
4848 if (ckWARN_d(WARN_INTERNAL))
4849 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
4856 Perl_newAVREF(pTHX_ OP *o)
4859 if (o->op_type == OP_PADANY) {
4860 o->op_type = OP_PADAV;
4861 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4864 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
4865 && ckWARN(WARN_DEPRECATED)) {
4866 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4867 "Using an array as a reference is deprecated");
4869 return newUNOP(OP_RV2AV, 0, scalar(o));
4873 Perl_newGVREF(pTHX_ I32 type, OP *o)
4875 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
4876 return newUNOP(OP_NULL, 0, o);
4877 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
4881 Perl_newHVREF(pTHX_ OP *o)
4884 if (o->op_type == OP_PADANY) {
4885 o->op_type = OP_PADHV;
4886 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4889 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
4890 && ckWARN(WARN_DEPRECATED)) {
4891 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4892 "Using a hash as a reference is deprecated");
4894 return newUNOP(OP_RV2HV, 0, scalar(o));
4898 Perl_oopsCV(pTHX_ OP *o)
4900 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
4903 #ifndef HASATTRIBUTE
4904 /* No __attribute__, so the compiler doesn't know that croak never returns
4911 Perl_newCVREF(pTHX_ I32 flags, OP *o)
4913 return newUNOP(OP_RV2CV, flags, scalar(o));
4917 Perl_newSVREF(pTHX_ OP *o)
4920 if (o->op_type == OP_PADANY) {
4921 o->op_type = OP_PADSV;
4922 o->op_ppaddr = PL_ppaddr[OP_PADSV];
4925 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4926 o->op_flags |= OPpDONE_SVREF;
4929 return newUNOP(OP_RV2SV, 0, scalar(o));
4932 /* Check routines. See the comments at the top of this file for details
4933 * on when these are called */
4936 Perl_ck_anoncode(pTHX_ OP *o)
4938 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
4939 cSVOPo->op_sv = Nullsv;
4944 Perl_ck_bitop(pTHX_ OP *o)
4946 #define OP_IS_NUMCOMPARE(op) \
4947 ((op) == OP_LT || (op) == OP_I_LT || \
4948 (op) == OP_GT || (op) == OP_I_GT || \
4949 (op) == OP_LE || (op) == OP_I_LE || \
4950 (op) == OP_GE || (op) == OP_I_GE || \
4951 (op) == OP_EQ || (op) == OP_I_EQ || \
4952 (op) == OP_NE || (op) == OP_I_NE || \
4953 (op) == OP_NCMP || (op) == OP_I_NCMP)
4954 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4955 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
4956 && (o->op_type == OP_BIT_OR
4957 || o->op_type == OP_BIT_AND
4958 || o->op_type == OP_BIT_XOR))
4960 const OP * left = cBINOPo->op_first;
4961 const OP * right = left->op_sibling;
4962 if ((OP_IS_NUMCOMPARE(left->op_type) &&
4963 (left->op_flags & OPf_PARENS) == 0) ||
4964 (OP_IS_NUMCOMPARE(right->op_type) &&
4965 (right->op_flags & OPf_PARENS) == 0))
4966 if (ckWARN(WARN_PRECEDENCE))
4967 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4968 "Possible precedence problem on bitwise %c operator",
4969 o->op_type == OP_BIT_OR ? '|'
4970 : o->op_type == OP_BIT_AND ? '&' : '^'
4977 Perl_ck_concat(pTHX_ OP *o)
4979 const OP *kid = cUNOPo->op_first;
4980 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
4981 !(kUNOP->op_first->op_flags & OPf_MOD))
4982 o->op_flags |= OPf_STACKED;
4987 Perl_ck_spair(pTHX_ OP *o)
4990 if (o->op_flags & OPf_KIDS) {
4993 const OPCODE type = o->op_type;
4994 o = modkids(ck_fun(o), type);
4995 kid = cUNOPo->op_first;
4996 newop = kUNOP->op_first->op_sibling;
4998 (newop->op_sibling ||
4999 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5000 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5001 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5005 op_free(kUNOP->op_first);
5006 kUNOP->op_first = newop;
5008 o->op_ppaddr = PL_ppaddr[++o->op_type];
5013 Perl_ck_delete(pTHX_ OP *o)
5017 if (o->op_flags & OPf_KIDS) {
5018 OP *kid = cUNOPo->op_first;
5019 switch (kid->op_type) {
5021 o->op_flags |= OPf_SPECIAL;
5024 o->op_private |= OPpSLICE;
5027 o->op_flags |= OPf_SPECIAL;
5032 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5041 Perl_ck_die(pTHX_ OP *o)
5044 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5050 Perl_ck_eof(pTHX_ OP *o)
5052 const I32 type = o->op_type;
5054 if (o->op_flags & OPf_KIDS) {
5055 if (cLISTOPo->op_first->op_type == OP_STUB) {
5057 o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
5065 Perl_ck_eval(pTHX_ OP *o)
5068 PL_hints |= HINT_BLOCK_SCOPE;
5069 if (o->op_flags & OPf_KIDS) {
5070 SVOP *kid = (SVOP*)cUNOPo->op_first;
5073 o->op_flags &= ~OPf_KIDS;
5076 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
5079 cUNOPo->op_first = 0;
5082 NewOp(1101, enter, 1, LOGOP);
5083 enter->op_type = OP_ENTERTRY;
5084 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5085 enter->op_private = 0;
5087 /* establish postfix order */
5088 enter->op_next = (OP*)enter;
5090 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5091 o->op_type = OP_LEAVETRY;
5092 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5093 enter->op_other = o;
5103 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5105 o->op_targ = (PADOFFSET)PL_hints;
5110 Perl_ck_exit(pTHX_ OP *o)
5113 HV *table = GvHV(PL_hintgv);
5115 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5116 if (svp && *svp && SvTRUE(*svp))
5117 o->op_private |= OPpEXIT_VMSISH;
5119 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5125 Perl_ck_exec(pTHX_ OP *o)
5127 if (o->op_flags & OPf_STACKED) {
5130 kid = cUNOPo->op_first->op_sibling;
5131 if (kid->op_type == OP_RV2GV)
5140 Perl_ck_exists(pTHX_ OP *o)
5143 if (o->op_flags & OPf_KIDS) {
5144 OP *kid = cUNOPo->op_first;
5145 if (kid->op_type == OP_ENTERSUB) {
5146 (void) ref(kid, o->op_type);
5147 if (kid->op_type != OP_RV2CV && !PL_error_count)
5148 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5150 o->op_private |= OPpEXISTS_SUB;
5152 else if (kid->op_type == OP_AELEM)
5153 o->op_flags |= OPf_SPECIAL;
5154 else if (kid->op_type != OP_HELEM)
5155 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5164 Perl_ck_gvconst(pTHX_ register OP *o)
5166 o = fold_constants(o);
5167 if (o->op_type == OP_CONST)
5174 Perl_ck_rvconst(pTHX_ register OP *o)
5177 SVOP *kid = (SVOP*)cUNOPo->op_first;
5179 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5180 if (kid->op_type == OP_CONST) {
5183 SV *kidsv = kid->op_sv;
5185 /* Is it a constant from cv_const_sv()? */
5186 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5187 SV *rsv = SvRV(kidsv);
5188 int svtype = SvTYPE(rsv);
5189 const char *badtype = Nullch;
5191 switch (o->op_type) {
5193 if (svtype > SVt_PVMG)
5194 badtype = "a SCALAR";
5197 if (svtype != SVt_PVAV)
5198 badtype = "an ARRAY";
5201 if (svtype != SVt_PVHV)
5205 if (svtype != SVt_PVCV)
5210 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5213 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5214 const char *badthing = Nullch;
5215 switch (o->op_type) {
5217 badthing = "a SCALAR";
5220 badthing = "an ARRAY";
5223 badthing = "a HASH";
5228 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
5232 * This is a little tricky. We only want to add the symbol if we
5233 * didn't add it in the lexer. Otherwise we get duplicate strict
5234 * warnings. But if we didn't add it in the lexer, we must at
5235 * least pretend like we wanted to add it even if it existed before,
5236 * or we get possible typo warnings. OPpCONST_ENTERED says
5237 * whether the lexer already added THIS instance of this symbol.
5239 iscv = (o->op_type == OP_RV2CV) * 2;
5241 gv = gv_fetchsv(kidsv,
5242 iscv | !(kid->op_private & OPpCONST_ENTERED),
5245 : o->op_type == OP_RV2SV
5247 : o->op_type == OP_RV2AV
5249 : o->op_type == OP_RV2HV
5252 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5254 kid->op_type = OP_GV;
5255 SvREFCNT_dec(kid->op_sv);
5257 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5258 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5259 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
5261 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
5263 kid->op_sv = SvREFCNT_inc(gv);
5265 kid->op_private = 0;
5266 kid->op_ppaddr = PL_ppaddr[OP_GV];
5273 Perl_ck_ftst(pTHX_ OP *o)
5276 const I32 type = o->op_type;
5278 if (o->op_flags & OPf_REF) {
5281 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5282 SVOP *kid = (SVOP*)cUNOPo->op_first;
5284 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5285 OP *newop = newGVOP(type, OPf_REF,
5286 gv_fetchsv(kid->op_sv, TRUE, SVt_PVIO));
5292 if ((PL_hints & HINT_FILETEST_ACCESS) &&
5293 OP_IS_FILETEST_ACCESS(o))
5294 o->op_private |= OPpFT_ACCESS;
5296 if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
5297 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
5298 o->op_private |= OPpFT_STACKED;
5302 if (type == OP_FTTTY)
5303 o = newGVOP(type, OPf_REF, PL_stdingv);
5305 o = newUNOP(type, 0, newDEFSVOP());
5311 Perl_ck_fun(pTHX_ OP *o)
5313 const int type = o->op_type;
5314 register I32 oa = PL_opargs[type] >> OASHIFT;
5316 if (o->op_flags & OPf_STACKED) {
5317 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5320 return no_fh_allowed(o);
5323 if (o->op_flags & OPf_KIDS) {
5324 OP **tokid = &cLISTOPo->op_first;
5325 register OP *kid = cLISTOPo->op_first;
5329 if (kid->op_type == OP_PUSHMARK ||
5330 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5332 tokid = &kid->op_sibling;
5333 kid = kid->op_sibling;
5335 if (!kid && PL_opargs[type] & OA_DEFGV)
5336 *tokid = kid = newDEFSVOP();
5340 sibl = kid->op_sibling;
5343 /* list seen where single (scalar) arg expected? */
5344 if (numargs == 1 && !(oa >> 4)
5345 && kid->op_type == OP_LIST && type != OP_SCALAR)
5347 return too_many_arguments(o,PL_op_desc[type]);
5360 if ((type == OP_PUSH || type == OP_UNSHIFT)
5361 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5362 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5363 "Useless use of %s with no values",
5366 if (kid->op_type == OP_CONST &&
5367 (kid->op_private & OPpCONST_BARE))
5369 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5370 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVAV) ));
5371 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5372 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5373 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
5374 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5377 kid->op_sibling = sibl;
5380 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5381 bad_type(numargs, "array", PL_op_desc[type], kid);
5385 if (kid->op_type == OP_CONST &&
5386 (kid->op_private & OPpCONST_BARE))
5388 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5389 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVHV) ));
5390 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5391 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5392 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
5393 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5396 kid->op_sibling = sibl;
5399 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5400 bad_type(numargs, "hash", PL_op_desc[type], kid);
5405 OP *newop = newUNOP(OP_NULL, 0, kid);
5406 kid->op_sibling = 0;
5408 newop->op_next = newop;
5410 kid->op_sibling = sibl;
5415 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5416 if (kid->op_type == OP_CONST &&
5417 (kid->op_private & OPpCONST_BARE))
5419 OP *newop = newGVOP(OP_GV, 0,
5420 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVIO) );
5421 if (!(o->op_private & 1) && /* if not unop */
5422 kid == cLISTOPo->op_last)
5423 cLISTOPo->op_last = newop;
5427 else if (kid->op_type == OP_READLINE) {
5428 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5429 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5432 I32 flags = OPf_SPECIAL;
5436 /* is this op a FH constructor? */
5437 if (is_handle_constructor(o,numargs)) {
5438 const char *name = Nullch;
5442 /* Set a flag to tell rv2gv to vivify
5443 * need to "prove" flag does not mean something
5444 * else already - NI-S 1999/05/07
5447 if (kid->op_type == OP_PADSV) {
5448 name = PAD_COMPNAME_PV(kid->op_targ);
5449 /* SvCUR of a pad namesv can't be trusted
5450 * (see PL_generation), so calc its length
5456 else if (kid->op_type == OP_RV2SV
5457 && kUNOP->op_first->op_type == OP_GV)
5459 GV *gv = cGVOPx_gv(kUNOP->op_first);
5461 len = GvNAMELEN(gv);
5463 else if (kid->op_type == OP_AELEM
5464 || kid->op_type == OP_HELEM)
5469 if ((op = ((BINOP*)kid)->op_first)) {
5470 SV *tmpstr = Nullsv;
5472 kid->op_type == OP_AELEM ?
5474 if (((op->op_type == OP_RV2AV) ||
5475 (op->op_type == OP_RV2HV)) &&
5476 (op = ((UNOP*)op)->op_first) &&
5477 (op->op_type == OP_GV)) {
5478 /* packagevar $a[] or $h{} */
5479 GV *gv = cGVOPx_gv(op);
5487 else if (op->op_type == OP_PADAV
5488 || op->op_type == OP_PADHV) {
5489 /* lexicalvar $a[] or $h{} */
5490 const char *padname =
5491 PAD_COMPNAME_PV(op->op_targ);
5501 name = SvPV(tmpstr, len);
5506 name = "__ANONIO__";
5513 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5514 namesv = PAD_SVl(targ);
5515 (void)SvUPGRADE(namesv, SVt_PV);
5517 sv_setpvn(namesv, "$", 1);
5518 sv_catpvn(namesv, name, len);
5521 kid->op_sibling = 0;
5522 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5523 kid->op_targ = targ;
5524 kid->op_private |= priv;
5526 kid->op_sibling = sibl;
5532 mod(scalar(kid), type);
5536 tokid = &kid->op_sibling;
5537 kid = kid->op_sibling;
5539 o->op_private |= numargs;
5541 return too_many_arguments(o,OP_DESC(o));
5544 else if (PL_opargs[type] & OA_DEFGV) {
5546 return newUNOP(type, 0, newDEFSVOP());
5550 while (oa & OA_OPTIONAL)
5552 if (oa && oa != OA_LIST)
5553 return too_few_arguments(o,OP_DESC(o));
5559 Perl_ck_glob(pTHX_ OP *o)
5565 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5566 append_elem(OP_GLOB, o, newDEFSVOP());
5568 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5569 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5571 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5574 #if !defined(PERL_EXTERNAL_GLOB)
5575 /* XXX this can be tightened up and made more failsafe. */
5576 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5579 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5580 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5581 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5582 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5583 GvCV(gv) = GvCV(glob_gv);
5584 (void)SvREFCNT_inc((SV*)GvCV(gv));
5585 GvIMPORTED_CV_on(gv);
5588 #endif /* PERL_EXTERNAL_GLOB */
5590 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5591 append_elem(OP_GLOB, o,
5592 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5593 o->op_type = OP_LIST;
5594 o->op_ppaddr = PL_ppaddr[OP_LIST];
5595 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5596 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5597 cLISTOPo->op_first->op_targ = 0;
5598 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5599 append_elem(OP_LIST, o,
5600 scalar(newUNOP(OP_RV2CV, 0,
5601 newGVOP(OP_GV, 0, gv)))));
5602 o = newUNOP(OP_NULL, 0, ck_subr(o));
5603 o->op_targ = OP_GLOB; /* hint at what it used to be */
5606 gv = newGVgen("main");
5608 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5614 Perl_ck_grep(pTHX_ OP *o)
5619 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5622 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5623 NewOp(1101, gwop, 1, LOGOP);
5625 if (o->op_flags & OPf_STACKED) {
5628 kid = cLISTOPo->op_first->op_sibling;
5629 if (!cUNOPx(kid)->op_next)
5630 Perl_croak(aTHX_ "panic: ck_grep");
5631 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
5634 kid->op_next = (OP*)gwop;
5635 o->op_flags &= ~OPf_STACKED;
5637 kid = cLISTOPo->op_first->op_sibling;
5638 if (type == OP_MAPWHILE)
5645 kid = cLISTOPo->op_first->op_sibling;
5646 if (kid->op_type != OP_NULL)
5647 Perl_croak(aTHX_ "panic: ck_grep");
5648 kid = kUNOP->op_first;
5650 gwop->op_type = type;
5651 gwop->op_ppaddr = PL_ppaddr[type];
5652 gwop->op_first = listkids(o);
5653 gwop->op_flags |= OPf_KIDS;
5654 gwop->op_other = LINKLIST(kid);
5655 kid->op_next = (OP*)gwop;
5656 offset = pad_findmy("$_");
5657 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
5658 o->op_private = gwop->op_private = 0;
5659 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5662 o->op_private = gwop->op_private = OPpGREP_LEX;
5663 gwop->op_targ = o->op_targ = offset;
5666 kid = cLISTOPo->op_first->op_sibling;
5667 if (!kid || !kid->op_sibling)
5668 return too_few_arguments(o,OP_DESC(o));
5669 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5670 mod(kid, OP_GREPSTART);
5676 Perl_ck_index(pTHX_ OP *o)
5678 if (o->op_flags & OPf_KIDS) {
5679 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5681 kid = kid->op_sibling; /* get past "big" */
5682 if (kid && kid->op_type == OP_CONST)
5683 fbm_compile(((SVOP*)kid)->op_sv, 0);
5689 Perl_ck_lengthconst(pTHX_ OP *o)
5691 /* XXX length optimization goes here */
5696 Perl_ck_lfun(pTHX_ OP *o)
5698 const OPCODE type = o->op_type;
5699 return modkids(ck_fun(o), type);
5703 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5705 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5706 switch (cUNOPo->op_first->op_type) {
5708 /* This is needed for
5709 if (defined %stash::)
5710 to work. Do not break Tk.
5712 break; /* Globals via GV can be undef */
5714 case OP_AASSIGN: /* Is this a good idea? */
5715 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5716 "defined(@array) is deprecated");
5717 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5718 "\t(Maybe you should just omit the defined()?)\n");
5721 /* This is needed for
5722 if (defined %stash::)
5723 to work. Do not break Tk.
5725 break; /* Globals via GV can be undef */
5727 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5728 "defined(%%hash) is deprecated");
5729 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5730 "\t(Maybe you should just omit the defined()?)\n");
5741 Perl_ck_rfun(pTHX_ OP *o)
5743 const OPCODE type = o->op_type;
5744 return refkids(ck_fun(o), type);
5748 Perl_ck_listiob(pTHX_ OP *o)
5752 kid = cLISTOPo->op_first;
5755 kid = cLISTOPo->op_first;
5757 if (kid->op_type == OP_PUSHMARK)
5758 kid = kid->op_sibling;
5759 if (kid && o->op_flags & OPf_STACKED)
5760 kid = kid->op_sibling;
5761 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5762 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5763 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5764 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5765 cLISTOPo->op_first->op_sibling = kid;
5766 cLISTOPo->op_last = kid;
5767 kid = kid->op_sibling;
5772 append_elem(o->op_type, o, newDEFSVOP());
5778 Perl_ck_sassign(pTHX_ OP *o)
5780 OP *kid = cLISTOPo->op_first;
5781 /* has a disposable target? */
5782 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5783 && !(kid->op_flags & OPf_STACKED)
5784 /* Cannot steal the second time! */
5785 && !(kid->op_private & OPpTARGET_MY))
5787 OP *kkid = kid->op_sibling;
5789 /* Can just relocate the target. */
5790 if (kkid && kkid->op_type == OP_PADSV
5791 && !(kkid->op_private & OPpLVAL_INTRO))
5793 kid->op_targ = kkid->op_targ;
5795 /* Now we do not need PADSV and SASSIGN. */
5796 kid->op_sibling = o->op_sibling; /* NULL */
5797 cLISTOPo->op_first = NULL;
5800 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
5804 /* optimise C<my $x = undef> to C<my $x> */
5805 if (kid->op_type == OP_UNDEF) {
5806 OP *kkid = kid->op_sibling;
5807 if (kkid && kkid->op_type == OP_PADSV
5808 && (kkid->op_private & OPpLVAL_INTRO))
5810 cLISTOPo->op_first = NULL;
5811 kid->op_sibling = NULL;
5821 Perl_ck_match(pTHX_ OP *o)
5823 if (o->op_type != OP_QR) {
5824 const I32 offset = pad_findmy("$_");
5825 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS(offset) & SVpad_OUR)) {
5826 o->op_targ = offset;
5827 o->op_private |= OPpTARGET_MY;
5830 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
5831 o->op_private |= OPpRUNTIME;
5836 Perl_ck_method(pTHX_ OP *o)
5838 OP *kid = cUNOPo->op_first;
5839 if (kid->op_type == OP_CONST) {
5840 SV* sv = kSVOP->op_sv;
5841 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
5843 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5844 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
5847 kSVOP->op_sv = Nullsv;
5849 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5858 Perl_ck_null(pTHX_ OP *o)
5864 Perl_ck_open(pTHX_ OP *o)
5866 HV *table = GvHV(PL_hintgv);
5870 svp = hv_fetch(table, "open_IN", 7, FALSE);
5872 mode = mode_from_discipline(*svp);
5873 if (mode & O_BINARY)
5874 o->op_private |= OPpOPEN_IN_RAW;
5875 else if (mode & O_TEXT)
5876 o->op_private |= OPpOPEN_IN_CRLF;
5879 svp = hv_fetch(table, "open_OUT", 8, FALSE);
5881 mode = mode_from_discipline(*svp);
5882 if (mode & O_BINARY)
5883 o->op_private |= OPpOPEN_OUT_RAW;
5884 else if (mode & O_TEXT)
5885 o->op_private |= OPpOPEN_OUT_CRLF;
5888 if (o->op_type == OP_BACKTICK)
5891 /* In case of three-arg dup open remove strictness
5892 * from the last arg if it is a bareword. */
5893 OP *first = cLISTOPx(o)->op_first; /* The pushmark. */
5894 OP *last = cLISTOPx(o)->op_last; /* The bareword. */
5898 if ((last->op_type == OP_CONST) && /* The bareword. */
5899 (last->op_private & OPpCONST_BARE) &&
5900 (last->op_private & OPpCONST_STRICT) &&
5901 (oa = first->op_sibling) && /* The fh. */
5902 (oa = oa->op_sibling) && /* The mode. */
5903 SvPOK(((SVOP*)oa)->op_sv) &&
5904 (mode = SvPVX(((SVOP*)oa)->op_sv)) &&
5905 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
5906 (last == oa->op_sibling)) /* The bareword. */
5907 last->op_private &= ~OPpCONST_STRICT;
5913 Perl_ck_repeat(pTHX_ OP *o)
5915 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5916 o->op_private |= OPpREPEAT_DOLIST;
5917 cBINOPo->op_first = force_list(cBINOPo->op_first);
5925 Perl_ck_require(pTHX_ OP *o)
5929 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
5930 SVOP *kid = (SVOP*)cUNOPo->op_first;
5932 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5934 for (s = SvPVX(kid->op_sv); *s; s++) {
5935 if (*s == ':' && s[1] == ':') {
5937 Move(s+2, s+1, strlen(s+2)+1, char);
5938 SvCUR_set(kid->op_sv, SvCUR(kid->op_sv) - 1);
5941 if (SvREADONLY(kid->op_sv)) {
5942 SvREADONLY_off(kid->op_sv);
5943 sv_catpvn(kid->op_sv, ".pm", 3);
5944 SvREADONLY_on(kid->op_sv);
5947 sv_catpvn(kid->op_sv, ".pm", 3);
5951 /* handle override, if any */
5952 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
5953 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
5954 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
5956 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5957 OP *kid = cUNOPo->op_first;
5958 cUNOPo->op_first = 0;
5960 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5961 append_elem(OP_LIST, kid,
5962 scalar(newUNOP(OP_RV2CV, 0,
5971 Perl_ck_return(pTHX_ OP *o)
5973 if (CvLVALUE(PL_compcv)) {
5975 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5976 mod(kid, OP_LEAVESUBLV);
5983 Perl_ck_retarget(pTHX_ OP *o)
5985 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5992 Perl_ck_select(pTHX_ OP *o)
5996 if (o->op_flags & OPf_KIDS) {
5997 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5998 if (kid && kid->op_sibling) {
5999 o->op_type = OP_SSELECT;
6000 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6002 return fold_constants(o);
6006 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6007 if (kid && kid->op_type == OP_RV2GV)
6008 kid->op_private &= ~HINT_STRICT_REFS;
6013 Perl_ck_shift(pTHX_ OP *o)
6015 const I32 type = o->op_type;
6017 if (!(o->op_flags & OPf_KIDS)) {
6021 argop = newUNOP(OP_RV2AV, 0,
6022 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
6023 return newUNOP(type, 0, scalar(argop));
6025 return scalar(modkids(ck_fun(o), type));
6029 Perl_ck_sort(pTHX_ OP *o)
6033 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6035 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6036 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6038 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6040 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6042 if (kid->op_type == OP_SCOPE) {
6046 else if (kid->op_type == OP_LEAVE) {
6047 if (o->op_type == OP_SORT) {
6048 op_null(kid); /* wipe out leave */
6051 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6052 if (k->op_next == kid)
6054 /* don't descend into loops */
6055 else if (k->op_type == OP_ENTERLOOP
6056 || k->op_type == OP_ENTERITER)
6058 k = cLOOPx(k)->op_lastop;
6063 kid->op_next = 0; /* just disconnect the leave */
6064 k = kLISTOP->op_first;
6069 if (o->op_type == OP_SORT) {
6070 /* provide scalar context for comparison function/block */
6076 o->op_flags |= OPf_SPECIAL;
6078 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6081 firstkid = firstkid->op_sibling;
6084 /* provide list context for arguments */
6085 if (o->op_type == OP_SORT)
6092 S_simplify_sort(pTHX_ OP *o)
6094 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6099 if (!(o->op_flags & OPf_STACKED))
6101 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6102 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6103 kid = kUNOP->op_first; /* get past null */
6104 if (kid->op_type != OP_SCOPE)
6106 kid = kLISTOP->op_last; /* get past scope */
6107 switch(kid->op_type) {
6115 k = kid; /* remember this node*/
6116 if (kBINOP->op_first->op_type != OP_RV2SV)
6118 kid = kBINOP->op_first; /* get past cmp */
6119 if (kUNOP->op_first->op_type != OP_GV)
6121 kid = kUNOP->op_first; /* get past rv2sv */
6123 if (GvSTASH(gv) != PL_curstash)
6125 gvname = GvNAME(gv);
6126 if (*gvname == 'a' && gvname[1] == '\0')
6128 else if (*gvname == 'b' && gvname[1] == '\0')
6133 kid = k; /* back to cmp */
6134 if (kBINOP->op_last->op_type != OP_RV2SV)
6136 kid = kBINOP->op_last; /* down to 2nd arg */
6137 if (kUNOP->op_first->op_type != OP_GV)
6139 kid = kUNOP->op_first; /* get past rv2sv */
6141 if (GvSTASH(gv) != PL_curstash)
6143 gvname = GvNAME(gv);
6145 ? !(*gvname == 'a' && gvname[1] == '\0')
6146 : !(*gvname == 'b' && gvname[1] == '\0'))
6148 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6150 o->op_private |= OPpSORT_DESCEND;
6151 if (k->op_type == OP_NCMP)
6152 o->op_private |= OPpSORT_NUMERIC;
6153 if (k->op_type == OP_I_NCMP)
6154 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6155 kid = cLISTOPo->op_first->op_sibling;
6156 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6157 op_free(kid); /* then delete it */
6161 Perl_ck_split(pTHX_ OP *o)
6166 if (o->op_flags & OPf_STACKED)
6167 return no_fh_allowed(o);
6169 kid = cLISTOPo->op_first;
6170 if (kid->op_type != OP_NULL)
6171 Perl_croak(aTHX_ "panic: ck_split");
6172 kid = kid->op_sibling;
6173 op_free(cLISTOPo->op_first);
6174 cLISTOPo->op_first = kid;
6176 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6177 cLISTOPo->op_last = kid; /* There was only one element previously */
6180 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6181 OP *sibl = kid->op_sibling;
6182 kid->op_sibling = 0;
6183 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
6184 if (cLISTOPo->op_first == cLISTOPo->op_last)
6185 cLISTOPo->op_last = kid;
6186 cLISTOPo->op_first = kid;
6187 kid->op_sibling = sibl;
6190 kid->op_type = OP_PUSHRE;
6191 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6193 if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
6194 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
6195 "Use of /g modifier is meaningless in split");
6198 if (!kid->op_sibling)
6199 append_elem(OP_SPLIT, o, newDEFSVOP());
6201 kid = kid->op_sibling;
6204 if (!kid->op_sibling)
6205 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6207 kid = kid->op_sibling;
6210 if (kid->op_sibling)
6211 return too_many_arguments(o,OP_DESC(o));
6217 Perl_ck_join(pTHX_ OP *o)
6219 if (ckWARN(WARN_SYNTAX)) {
6220 const OP *kid = cLISTOPo->op_first->op_sibling;
6221 if (kid && kid->op_type == OP_MATCH) {
6222 const REGEXP *re = PM_GETRE(kPMOP);
6223 const char *pmstr = re ? re->precomp : "STRING";
6224 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6225 "/%s/ should probably be written as \"%s\"",
6233 Perl_ck_subr(pTHX_ OP *o)
6235 OP *prev = ((cUNOPo->op_first->op_sibling)
6236 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6237 OP *o2 = prev->op_sibling;
6244 I32 contextclass = 0;
6249 o->op_private |= OPpENTERSUB_HASTARG;
6250 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6251 if (cvop->op_type == OP_RV2CV) {
6253 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6254 op_null(cvop); /* disable rv2cv */
6255 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6256 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6257 GV *gv = cGVOPx_gv(tmpop);
6260 tmpop->op_private |= OPpEARLY_CV;
6263 namegv = CvANON(cv) ? gv : CvGV(cv);
6264 proto = SvPV((SV*)cv, n_a);
6266 if (CvASSERTION(cv)) {
6267 if (PL_hints & HINT_ASSERTING) {
6268 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
6269 o->op_private |= OPpENTERSUB_DB;
6273 if (ckWARN(WARN_ASSERTIONS) && !(PL_hints & HINT_ASSERTIONSSEEN)) {
6274 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
6275 "Impossible to activate assertion call");
6282 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6283 if (o2->op_type == OP_CONST)
6284 o2->op_private &= ~OPpCONST_STRICT;
6285 else if (o2->op_type == OP_LIST) {
6286 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6287 if (o && o->op_type == OP_CONST)
6288 o->op_private &= ~OPpCONST_STRICT;
6291 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6292 if (PERLDB_SUB && PL_curstash != PL_debstash)
6293 o->op_private |= OPpENTERSUB_DB;
6294 while (o2 != cvop) {
6298 return too_many_arguments(o, gv_ename(namegv));
6316 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6318 arg == 1 ? "block or sub {}" : "sub {}",
6319 gv_ename(namegv), o2);
6322 /* '*' allows any scalar type, including bareword */
6325 if (o2->op_type == OP_RV2GV)
6326 goto wrapref; /* autoconvert GLOB -> GLOBref */
6327 else if (o2->op_type == OP_CONST)
6328 o2->op_private &= ~OPpCONST_STRICT;
6329 else if (o2->op_type == OP_ENTERSUB) {
6330 /* accidental subroutine, revert to bareword */
6331 OP *gvop = ((UNOP*)o2)->op_first;
6332 if (gvop && gvop->op_type == OP_NULL) {
6333 gvop = ((UNOP*)gvop)->op_first;
6335 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6338 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6339 (gvop = ((UNOP*)gvop)->op_first) &&
6340 gvop->op_type == OP_GV)
6342 GV *gv = cGVOPx_gv(gvop);
6343 OP *sibling = o2->op_sibling;
6344 SV *n = newSVpvn("",0);
6346 gv_fullname4(n, gv, "", FALSE);
6347 o2 = newSVOP(OP_CONST, 0, n);
6348 prev->op_sibling = o2;
6349 o2->op_sibling = sibling;
6365 if (contextclass++ == 0) {
6366 e = strchr(proto, ']');
6367 if (!e || e == proto)
6380 while (*--p != '[');
6381 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6382 gv_ename(namegv), o2);
6388 if (o2->op_type == OP_RV2GV)
6391 bad_type(arg, "symbol", gv_ename(namegv), o2);
6394 if (o2->op_type == OP_ENTERSUB)
6397 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6400 if (o2->op_type == OP_RV2SV ||
6401 o2->op_type == OP_PADSV ||
6402 o2->op_type == OP_HELEM ||
6403 o2->op_type == OP_AELEM ||
6404 o2->op_type == OP_THREADSV)
6407 bad_type(arg, "scalar", gv_ename(namegv), o2);
6410 if (o2->op_type == OP_RV2AV ||
6411 o2->op_type == OP_PADAV)
6414 bad_type(arg, "array", gv_ename(namegv), o2);
6417 if (o2->op_type == OP_RV2HV ||
6418 o2->op_type == OP_PADHV)
6421 bad_type(arg, "hash", gv_ename(namegv), o2);
6426 OP* sib = kid->op_sibling;
6427 kid->op_sibling = 0;
6428 o2 = newUNOP(OP_REFGEN, 0, kid);
6429 o2->op_sibling = sib;
6430 prev->op_sibling = o2;
6432 if (contextclass && e) {
6447 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6448 gv_ename(namegv), cv);
6453 mod(o2, OP_ENTERSUB);
6455 o2 = o2->op_sibling;
6457 if (proto && !optional &&
6458 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6459 return too_few_arguments(o, gv_ename(namegv));
6462 o=newSVOP(OP_CONST, 0, newSViv(0));
6468 Perl_ck_svconst(pTHX_ OP *o)
6470 SvREADONLY_on(cSVOPo->op_sv);
6475 Perl_ck_trunc(pTHX_ OP *o)
6477 if (o->op_flags & OPf_KIDS) {
6478 SVOP *kid = (SVOP*)cUNOPo->op_first;
6480 if (kid->op_type == OP_NULL)
6481 kid = (SVOP*)kid->op_sibling;
6482 if (kid && kid->op_type == OP_CONST &&
6483 (kid->op_private & OPpCONST_BARE))
6485 o->op_flags |= OPf_SPECIAL;
6486 kid->op_private &= ~OPpCONST_STRICT;
6493 Perl_ck_unpack(pTHX_ OP *o)
6495 OP *kid = cLISTOPo->op_first;
6496 if (kid->op_sibling) {
6497 kid = kid->op_sibling;
6498 if (!kid->op_sibling)
6499 kid->op_sibling = newDEFSVOP();
6505 Perl_ck_substr(pTHX_ OP *o)
6508 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6509 OP *kid = cLISTOPo->op_first;
6511 if (kid->op_type == OP_NULL)
6512 kid = kid->op_sibling;
6514 kid->op_flags |= OPf_MOD;
6520 /* A peephole optimizer. We visit the ops in the order they're to execute.
6521 * See the comments at the top of this file for more details about when
6522 * peep() is called */
6525 Perl_peep(pTHX_ register OP *o)
6528 register OP* oldop = 0;
6530 if (!o || o->op_opt)
6534 SAVEVPTR(PL_curcop);
6535 for (; o; o = o->op_next) {
6539 switch (o->op_type) {
6543 PL_curcop = ((COP*)o); /* for warnings */
6548 if (cSVOPo->op_private & OPpCONST_STRICT)
6549 no_bareword_allowed(o);
6551 case OP_METHOD_NAMED:
6552 /* Relocate sv to the pad for thread safety.
6553 * Despite being a "constant", the SV is written to,
6554 * for reference counts, sv_upgrade() etc. */
6556 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6557 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6558 /* If op_sv is already a PADTMP then it is being used by
6559 * some pad, so make a copy. */
6560 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6561 SvREADONLY_on(PAD_SVl(ix));
6562 SvREFCNT_dec(cSVOPo->op_sv);
6565 SvREFCNT_dec(PAD_SVl(ix));
6566 SvPADTMP_on(cSVOPo->op_sv);
6567 PAD_SETSV(ix, cSVOPo->op_sv);
6568 /* XXX I don't know how this isn't readonly already. */
6569 SvREADONLY_on(PAD_SVl(ix));
6571 cSVOPo->op_sv = Nullsv;
6579 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6580 if (o->op_next->op_private & OPpTARGET_MY) {
6581 if (o->op_flags & OPf_STACKED) /* chained concats */
6582 goto ignore_optimization;
6584 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6585 o->op_targ = o->op_next->op_targ;
6586 o->op_next->op_targ = 0;
6587 o->op_private |= OPpTARGET_MY;
6590 op_null(o->op_next);
6592 ignore_optimization:
6596 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6598 break; /* Scalar stub must produce undef. List stub is noop */
6602 if (o->op_targ == OP_NEXTSTATE
6603 || o->op_targ == OP_DBSTATE
6604 || o->op_targ == OP_SETSTATE)
6606 PL_curcop = ((COP*)o);
6608 /* XXX: We avoid setting op_seq here to prevent later calls
6609 to peep() from mistakenly concluding that optimisation
6610 has already occurred. This doesn't fix the real problem,
6611 though (See 20010220.007). AMS 20010719 */
6612 /* op_seq functionality is now replaced by op_opt */
6613 if (oldop && o->op_next) {
6614 oldop->op_next = o->op_next;
6622 if (oldop && o->op_next) {
6623 oldop->op_next = o->op_next;
6631 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
6632 OP* pop = (o->op_type == OP_PADAV) ?
6633 o->op_next : o->op_next->op_next;
6635 if (pop && pop->op_type == OP_CONST &&
6636 ((PL_op = pop->op_next)) &&
6637 pop->op_next->op_type == OP_AELEM &&
6638 !(pop->op_next->op_private &
6639 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6640 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6645 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
6646 no_bareword_allowed(pop);
6647 if (o->op_type == OP_GV)
6648 op_null(o->op_next);
6649 op_null(pop->op_next);
6651 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6652 o->op_next = pop->op_next->op_next;
6653 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6654 o->op_private = (U8)i;
6655 if (o->op_type == OP_GV) {
6660 o->op_flags |= OPf_SPECIAL;
6661 o->op_type = OP_AELEMFAST;
6667 if (o->op_next->op_type == OP_RV2SV) {
6668 if (!(o->op_next->op_private & OPpDEREF)) {
6669 op_null(o->op_next);
6670 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6672 o->op_next = o->op_next->op_next;
6673 o->op_type = OP_GVSV;
6674 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6677 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6679 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6680 /* XXX could check prototype here instead of just carping */
6681 SV *sv = sv_newmortal();
6682 gv_efullname3(sv, gv, Nullch);
6683 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6684 "%"SVf"() called too early to check prototype",
6688 else if (o->op_next->op_type == OP_READLINE
6689 && o->op_next->op_next->op_type == OP_CONCAT
6690 && (o->op_next->op_next->op_flags & OPf_STACKED))
6692 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6693 o->op_type = OP_RCATLINE;
6694 o->op_flags |= OPf_STACKED;
6695 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6696 op_null(o->op_next->op_next);
6697 op_null(o->op_next);
6714 while (cLOGOP->op_other->op_type == OP_NULL)
6715 cLOGOP->op_other = cLOGOP->op_other->op_next;
6716 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6722 while (cLOOP->op_redoop->op_type == OP_NULL)
6723 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6724 peep(cLOOP->op_redoop);
6725 while (cLOOP->op_nextop->op_type == OP_NULL)
6726 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6727 peep(cLOOP->op_nextop);
6728 while (cLOOP->op_lastop->op_type == OP_NULL)
6729 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6730 peep(cLOOP->op_lastop);
6737 while (cPMOP->op_pmreplstart &&
6738 cPMOP->op_pmreplstart->op_type == OP_NULL)
6739 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6740 peep(cPMOP->op_pmreplstart);
6745 if (ckWARN(WARN_SYNTAX) && o->op_next
6746 && o->op_next->op_type == OP_NEXTSTATE) {
6747 if (o->op_next->op_sibling &&
6748 o->op_next->op_sibling->op_type != OP_EXIT &&
6749 o->op_next->op_sibling->op_type != OP_WARN &&
6750 o->op_next->op_sibling->op_type != OP_DIE) {
6751 const line_t oldline = CopLINE(PL_curcop);
6753 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6754 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6755 "Statement unlikely to be reached");
6756 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6757 "\t(Maybe you meant system() when you said exec()?)\n");
6758 CopLINE_set(PL_curcop, oldline);
6773 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6776 /* Make the CONST have a shared SV */
6777 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6778 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6779 key = SvPV(sv, keylen);
6780 lexname = newSVpvn_share(key,
6781 SvUTF8(sv) ? -(I32)keylen : keylen,
6787 if ((o->op_private & (OPpLVAL_INTRO)))
6790 rop = (UNOP*)((BINOP*)o)->op_first;
6791 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6793 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6794 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6796 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6797 if (!fields || !GvHV(*fields))
6799 key = SvPV(*svp, keylen);
6800 if (!hv_fetch(GvHV(*fields), key,
6801 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
6803 Perl_croak(aTHX_ "No such class field \"%s\" "
6804 "in variable %s of type %s",
6805 key, SvPV_nolen(lexname), HvNAME(SvSTASH(lexname)));
6818 SVOP *first_key_op, *key_op;
6820 if ((o->op_private & (OPpLVAL_INTRO))
6821 /* I bet there's always a pushmark... */
6822 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6823 /* hmmm, no optimization if list contains only one key. */
6825 rop = (UNOP*)((LISTOP*)o)->op_last;
6826 if (rop->op_type != OP_RV2HV)
6828 if (rop->op_first->op_type == OP_PADSV)
6829 /* @$hash{qw(keys here)} */
6830 rop = (UNOP*)rop->op_first;
6832 /* @{$hash}{qw(keys here)} */
6833 if (rop->op_first->op_type == OP_SCOPE
6834 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
6836 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
6842 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
6843 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6845 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6846 if (!fields || !GvHV(*fields))
6848 /* Again guessing that the pushmark can be jumped over.... */
6849 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
6850 ->op_first->op_sibling;
6851 for (key_op = first_key_op; key_op;
6852 key_op = (SVOP*)key_op->op_sibling) {
6853 if (key_op->op_type != OP_CONST)
6855 svp = cSVOPx_svp(key_op);
6856 key = SvPV(*svp, keylen);
6857 if (!hv_fetch(GvHV(*fields), key,
6858 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
6860 Perl_croak(aTHX_ "No such class field \"%s\" "
6861 "in variable %s of type %s",
6862 key, SvPV_nolen(lexname), HvNAME(SvSTASH(lexname)));
6869 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
6873 /* check that RHS of sort is a single plain array */
6874 oright = cUNOPo->op_first;
6875 if (!oright || oright->op_type != OP_PUSHMARK)
6878 /* reverse sort ... can be optimised. */
6879 if (!cUNOPo->op_sibling) {
6880 /* Nothing follows us on the list. */
6881 OP *reverse = o->op_next;
6883 if (reverse->op_type == OP_REVERSE &&
6884 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
6885 OP *pushmark = cUNOPx(reverse)->op_first;
6886 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
6887 && (cUNOPx(pushmark)->op_sibling == o)) {
6888 /* reverse -> pushmark -> sort */
6889 o->op_private |= OPpSORT_REVERSE;
6891 pushmark->op_next = oright->op_next;
6897 /* make @a = sort @a act in-place */
6901 oright = cUNOPx(oright)->op_sibling;
6904 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
6905 oright = cUNOPx(oright)->op_sibling;
6909 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
6910 || oright->op_next != o
6911 || (oright->op_private & OPpLVAL_INTRO)
6915 /* o2 follows the chain of op_nexts through the LHS of the
6916 * assign (if any) to the aassign op itself */
6918 if (!o2 || o2->op_type != OP_NULL)
6921 if (!o2 || o2->op_type != OP_PUSHMARK)
6924 if (o2 && o2->op_type == OP_GV)
6927 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
6928 || (o2->op_private & OPpLVAL_INTRO)
6933 if (!o2 || o2->op_type != OP_NULL)
6936 if (!o2 || o2->op_type != OP_AASSIGN
6937 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
6940 /* check that the sort is the first arg on RHS of assign */
6942 o2 = cUNOPx(o2)->op_first;
6943 if (!o2 || o2->op_type != OP_NULL)
6945 o2 = cUNOPx(o2)->op_first;
6946 if (!o2 || o2->op_type != OP_PUSHMARK)
6948 if (o2->op_sibling != o)
6951 /* check the array is the same on both sides */
6952 if (oleft->op_type == OP_RV2AV) {
6953 if (oright->op_type != OP_RV2AV
6954 || !cUNOPx(oright)->op_first
6955 || cUNOPx(oright)->op_first->op_type != OP_GV
6956 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
6957 cGVOPx_gv(cUNOPx(oright)->op_first)
6961 else if (oright->op_type != OP_PADAV
6962 || oright->op_targ != oleft->op_targ
6966 /* transfer MODishness etc from LHS arg to RHS arg */
6967 oright->op_flags = oleft->op_flags;
6968 o->op_private |= OPpSORT_INPLACE;
6970 /* excise push->gv->rv2av->null->aassign */
6971 o2 = o->op_next->op_next;
6972 op_null(o2); /* PUSHMARK */
6974 if (o2->op_type == OP_GV) {
6975 op_null(o2); /* GV */
6978 op_null(o2); /* RV2AV or PADAV */
6979 o2 = o2->op_next->op_next;
6980 op_null(o2); /* AASSIGN */
6982 o->op_next = o2->op_next;
6988 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
6990 LISTOP *enter, *exlist;
6993 enter = (LISTOP *) o->op_next;
6996 if (enter->op_type == OP_NULL) {
6997 enter = (LISTOP *) enter->op_next;
7001 /* for $a (...) will have OP_GV then OP_RV2GV here.
7002 for (...) just has an OP_GV. */
7003 if (enter->op_type == OP_GV) {
7004 gvop = (OP *) enter;
7005 enter = (LISTOP *) enter->op_next;
7008 if (enter->op_type == OP_RV2GV) {
7009 enter = (LISTOP *) enter->op_next;
7015 if (enter->op_type != OP_ENTERITER)
7018 iter = enter->op_next;
7019 if (!iter || iter->op_type != OP_ITER)
7022 expushmark = enter->op_first;
7023 if (!expushmark || expushmark->op_type != OP_NULL
7024 || expushmark->op_targ != OP_PUSHMARK)
7027 exlist = (LISTOP *) expushmark->op_sibling;
7028 if (!exlist || exlist->op_type != OP_NULL
7029 || exlist->op_targ != OP_LIST)
7032 if (exlist->op_last != o) {
7033 /* Mmm. Was expecting to point back to this op. */
7036 theirmark = exlist->op_first;
7037 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
7040 if (theirmark->op_sibling != o) {
7041 /* There's something between the mark and the reverse, eg
7042 for (1, reverse (...))
7047 ourmark = ((LISTOP *)o)->op_first;
7048 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
7051 ourlast = ((LISTOP *)o)->op_last;
7052 if (!ourlast || ourlast->op_next != o)
7055 rv2av = ourmark->op_sibling;
7056 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
7057 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
7058 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
7059 /* We're just reversing a single array. */
7060 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
7061 enter->op_flags |= OPf_STACKED;
7064 /* We don't have control over who points to theirmark, so sacrifice
7066 theirmark->op_next = ourmark->op_next;
7067 theirmark->op_flags = ourmark->op_flags;
7068 ourlast->op_next = gvop ? gvop : (OP *) enter;
7071 enter->op_private |= OPpITER_REVERSED;
7072 iter->op_private |= OPpITER_REVERSED;
7087 Perl_custom_op_name(pTHX_ const OP* o)
7089 const IV index = PTR2IV(o->op_ppaddr);
7093 if (!PL_custom_op_names) /* This probably shouldn't happen */
7094 return (char *)PL_op_name[OP_CUSTOM];
7096 keysv = sv_2mortal(newSViv(index));
7098 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7100 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7102 return SvPV_nolen(HeVAL(he));
7106 Perl_custom_op_desc(pTHX_ const OP* o)
7108 const IV index = PTR2IV(o->op_ppaddr);
7112 if (!PL_custom_op_descs)
7113 return (char *)PL_op_desc[OP_CUSTOM];
7115 keysv = sv_2mortal(newSViv(index));
7117 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7119 return (char *)PL_op_desc[OP_CUSTOM];
7121 return SvPV_nolen(HeVAL(he));
7126 /* Efficient sub that returns a constant scalar value. */
7128 const_sv_xsub(pTHX_ CV* cv)
7133 Perl_croak(aTHX_ "usage: %s::%s()",
7134 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7138 ST(0) = (SV*)XSANY.any_ptr;
7144 * c-indentation-style: bsd
7146 * indent-tabs-mode: t
7149 * ex: set ts=8 sts=4 sw=4 noet: