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__(1) __attribute__nonnull__(2) __attribute__pure__;
2370 static int uvcompare(const void *a, const void *b)
2372 if (*((const UV *)a) < (*(const UV *)b))
2374 if (*((const UV *)a) > (*(const UV *)b))
2376 if (*((const UV *)a+1) < (*(const UV *)b+1))
2378 if (*((const UV *)a+1) > (*(const UV *)b+1))
2384 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2386 SV *tstr = ((SVOP*)expr)->op_sv;
2387 SV *rstr = ((SVOP*)repl)->op_sv;
2390 U8 *t = (U8*)SvPV(tstr, tlen);
2391 U8 *r = (U8*)SvPV(rstr, rlen);
2398 register short *tbl;
2400 PL_hints |= HINT_BLOCK_SCOPE;
2401 complement = o->op_private & OPpTRANS_COMPLEMENT;
2402 del = o->op_private & OPpTRANS_DELETE;
2403 squash = o->op_private & OPpTRANS_SQUASH;
2406 o->op_private |= OPpTRANS_FROM_UTF;
2409 o->op_private |= OPpTRANS_TO_UTF;
2411 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2412 SV* listsv = newSVpvn("# comment\n",10);
2414 U8* tend = t + tlen;
2415 U8* rend = r + rlen;
2429 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2430 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2436 tsave = t = bytes_to_utf8(t, &len);
2439 if (!to_utf && rlen) {
2441 rsave = r = bytes_to_utf8(r, &len);
2445 /* There are several snags with this code on EBCDIC:
2446 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2447 2. scan_const() in toke.c has encoded chars in native encoding which makes
2448 ranges at least in EBCDIC 0..255 range the bottom odd.
2452 U8 tmpbuf[UTF8_MAXBYTES+1];
2455 New(1109, cp, 2*tlen, UV);
2457 transv = newSVpvn("",0);
2459 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2461 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2463 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2467 cp[2*i+1] = cp[2*i];
2471 qsort(cp, i, 2*sizeof(UV), uvcompare);
2472 for (j = 0; j < i; j++) {
2474 diff = val - nextmin;
2476 t = uvuni_to_utf8(tmpbuf,nextmin);
2477 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2479 U8 range_mark = UTF_TO_NATIVE(0xff);
2480 t = uvuni_to_utf8(tmpbuf, val - 1);
2481 sv_catpvn(transv, (char *)&range_mark, 1);
2482 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2489 t = uvuni_to_utf8(tmpbuf,nextmin);
2490 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2492 U8 range_mark = UTF_TO_NATIVE(0xff);
2493 sv_catpvn(transv, (char *)&range_mark, 1);
2495 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2496 UNICODE_ALLOW_SUPER);
2497 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2498 t = (U8*)SvPVX(transv);
2499 tlen = SvCUR(transv);
2503 else if (!rlen && !del) {
2504 r = t; rlen = tlen; rend = tend;
2507 if ((!rlen && !del) || t == r ||
2508 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2510 o->op_private |= OPpTRANS_IDENTICAL;
2514 while (t < tend || tfirst <= tlast) {
2515 /* see if we need more "t" chars */
2516 if (tfirst > tlast) {
2517 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2519 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2521 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2528 /* now see if we need more "r" chars */
2529 if (rfirst > rlast) {
2531 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2533 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2535 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2544 rfirst = rlast = 0xffffffff;
2548 /* now see which range will peter our first, if either. */
2549 tdiff = tlast - tfirst;
2550 rdiff = rlast - rfirst;
2557 if (rfirst == 0xffffffff) {
2558 diff = tdiff; /* oops, pretend rdiff is infinite */
2560 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2561 (long)tfirst, (long)tlast);
2563 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2567 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2568 (long)tfirst, (long)(tfirst + diff),
2571 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2572 (long)tfirst, (long)rfirst);
2574 if (rfirst + diff > max)
2575 max = rfirst + diff;
2577 grows = (tfirst < rfirst &&
2578 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2590 else if (max > 0xff)
2595 Safefree(cPVOPo->op_pv);
2596 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2597 SvREFCNT_dec(listsv);
2599 SvREFCNT_dec(transv);
2601 if (!del && havefinal && rlen)
2602 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2603 newSVuv((UV)final), 0);
2606 o->op_private |= OPpTRANS_GROWS;
2618 tbl = (short*)cPVOPo->op_pv;
2620 Zero(tbl, 256, short);
2621 for (i = 0; i < (I32)tlen; i++)
2623 for (i = 0, j = 0; i < 256; i++) {
2625 if (j >= (I32)rlen) {
2634 if (i < 128 && r[j] >= 128)
2644 o->op_private |= OPpTRANS_IDENTICAL;
2646 else if (j >= (I32)rlen)
2649 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2650 tbl[0x100] = rlen - j;
2651 for (i=0; i < (I32)rlen - j; i++)
2652 tbl[0x101+i] = r[j+i];
2656 if (!rlen && !del) {
2659 o->op_private |= OPpTRANS_IDENTICAL;
2661 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2662 o->op_private |= OPpTRANS_IDENTICAL;
2664 for (i = 0; i < 256; i++)
2666 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
2667 if (j >= (I32)rlen) {
2669 if (tbl[t[i]] == -1)
2675 if (tbl[t[i]] == -1) {
2676 if (t[i] < 128 && r[j] >= 128)
2683 o->op_private |= OPpTRANS_GROWS;
2691 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2696 NewOp(1101, pmop, 1, PMOP);
2697 pmop->op_type = (OPCODE)type;
2698 pmop->op_ppaddr = PL_ppaddr[type];
2699 pmop->op_flags = (U8)flags;
2700 pmop->op_private = (U8)(0 | (flags >> 8));
2702 if (PL_hints & HINT_RE_TAINT)
2703 pmop->op_pmpermflags |= PMf_RETAINT;
2704 if (PL_hints & HINT_LOCALE)
2705 pmop->op_pmpermflags |= PMf_LOCALE;
2706 pmop->op_pmflags = pmop->op_pmpermflags;
2711 if(av_len((AV*) PL_regex_pad[0]) > -1) {
2712 repointer = av_pop((AV*)PL_regex_pad[0]);
2713 pmop->op_pmoffset = SvIV(repointer);
2714 SvREPADTMP_off(repointer);
2715 sv_setiv(repointer,0);
2717 repointer = newSViv(0);
2718 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2719 pmop->op_pmoffset = av_len(PL_regex_padav);
2720 PL_regex_pad = AvARRAY(PL_regex_padav);
2725 /* link into pm list */
2726 if (type != OP_TRANS && PL_curstash) {
2727 pmop->op_pmnext = HvPMROOT(PL_curstash);
2728 HvPMROOT(PL_curstash) = pmop;
2729 PmopSTASH_set(pmop,PL_curstash);
2732 return CHECKOP(type, pmop);
2735 /* Given some sort of match op o, and an expression expr containing a
2736 * pattern, either compile expr into a regex and attach it to o (if it's
2737 * constant), or convert expr into a runtime regcomp op sequence (if it's
2740 * isreg indicates that the pattern is part of a regex construct, eg
2741 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
2742 * split "pattern", which aren't. In the former case, expr will be a list
2743 * if the pattern contains more than one term (eg /a$b/) or if it contains
2744 * a replacement, ie s/// or tr///.
2748 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
2753 I32 repl_has_vars = 0;
2757 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
2758 /* last element in list is the replacement; pop it */
2760 repl = cLISTOPx(expr)->op_last;
2761 kid = cLISTOPx(expr)->op_first;
2762 while (kid->op_sibling != repl)
2763 kid = kid->op_sibling;
2764 kid->op_sibling = Nullop;
2765 cLISTOPx(expr)->op_last = kid;
2768 if (isreg && expr->op_type == OP_LIST &&
2769 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
2771 /* convert single element list to element */
2773 expr = cLISTOPx(oe)->op_first->op_sibling;
2774 cLISTOPx(oe)->op_first->op_sibling = Nullop;
2775 cLISTOPx(oe)->op_last = Nullop;
2779 if (o->op_type == OP_TRANS) {
2780 return pmtrans(o, expr, repl);
2783 reglist = isreg && expr->op_type == OP_LIST;
2787 PL_hints |= HINT_BLOCK_SCOPE;
2790 if (expr->op_type == OP_CONST) {
2792 SV *pat = ((SVOP*)expr)->op_sv;
2793 char *p = SvPV(pat, plen);
2794 if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
2795 sv_setpvn(pat, "\\s+", 3);
2796 p = SvPV(pat, plen);
2797 pm->op_pmflags |= PMf_SKIPWHITE;
2800 pm->op_pmdynflags |= PMdf_UTF8;
2801 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
2802 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
2803 pm->op_pmflags |= PMf_WHITE;
2807 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2808 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2810 : OP_REGCMAYBE),0,expr);
2812 NewOp(1101, rcop, 1, LOGOP);
2813 rcop->op_type = OP_REGCOMP;
2814 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2815 rcop->op_first = scalar(expr);
2816 rcop->op_flags |= OPf_KIDS
2817 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
2818 | (reglist ? OPf_STACKED : 0);
2819 rcop->op_private = 1;
2822 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
2824 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
2827 /* establish postfix order */
2828 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2830 rcop->op_next = expr;
2831 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2834 rcop->op_next = LINKLIST(expr);
2835 expr->op_next = (OP*)rcop;
2838 prepend_elem(o->op_type, scalar((OP*)rcop), o);
2843 if (pm->op_pmflags & PMf_EVAL) {
2845 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
2846 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
2848 else if (repl->op_type == OP_CONST)
2852 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
2853 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
2854 if (curop->op_type == OP_GV) {
2855 GV *gv = cGVOPx_gv(curop);
2857 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
2860 else if (curop->op_type == OP_RV2CV)
2862 else if (curop->op_type == OP_RV2SV ||
2863 curop->op_type == OP_RV2AV ||
2864 curop->op_type == OP_RV2HV ||
2865 curop->op_type == OP_RV2GV) {
2866 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2869 else if (curop->op_type == OP_PADSV ||
2870 curop->op_type == OP_PADAV ||
2871 curop->op_type == OP_PADHV ||
2872 curop->op_type == OP_PADANY) {
2875 else if (curop->op_type == OP_PUSHRE)
2876 ; /* Okay here, dangerous in newASSIGNOP */
2886 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
2887 pm->op_pmflags |= PMf_CONST; /* const for long enough */
2888 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
2889 prepend_elem(o->op_type, scalar(repl), o);
2892 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
2893 pm->op_pmflags |= PMf_MAYBE_CONST;
2894 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2896 NewOp(1101, rcop, 1, LOGOP);
2897 rcop->op_type = OP_SUBSTCONT;
2898 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
2899 rcop->op_first = scalar(repl);
2900 rcop->op_flags |= OPf_KIDS;
2901 rcop->op_private = 1;
2904 /* establish postfix order */
2905 rcop->op_next = LINKLIST(repl);
2906 repl->op_next = (OP*)rcop;
2908 pm->op_pmreplroot = scalar((OP*)rcop);
2909 pm->op_pmreplstart = LINKLIST(rcop);
2918 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
2922 NewOp(1101, svop, 1, SVOP);
2923 svop->op_type = (OPCODE)type;
2924 svop->op_ppaddr = PL_ppaddr[type];
2926 svop->op_next = (OP*)svop;
2927 svop->op_flags = (U8)flags;
2928 if (PL_opargs[type] & OA_RETSCALAR)
2930 if (PL_opargs[type] & OA_TARGET)
2931 svop->op_targ = pad_alloc(type, SVs_PADTMP);
2932 return CHECKOP(type, svop);
2936 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2940 NewOp(1101, padop, 1, PADOP);
2941 padop->op_type = (OPCODE)type;
2942 padop->op_ppaddr = PL_ppaddr[type];
2943 padop->op_padix = pad_alloc(type, SVs_PADTMP);
2944 SvREFCNT_dec(PAD_SVl(padop->op_padix));
2945 PAD_SETSV(padop->op_padix, sv);
2948 padop->op_next = (OP*)padop;
2949 padop->op_flags = (U8)flags;
2950 if (PL_opargs[type] & OA_RETSCALAR)
2952 if (PL_opargs[type] & OA_TARGET)
2953 padop->op_targ = pad_alloc(type, SVs_PADTMP);
2954 return CHECKOP(type, padop);
2958 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
2964 return newPADOP(type, flags, SvREFCNT_inc(gv));
2966 return newSVOP(type, flags, SvREFCNT_inc(gv));
2971 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
2975 NewOp(1101, pvop, 1, PVOP);
2976 pvop->op_type = (OPCODE)type;
2977 pvop->op_ppaddr = PL_ppaddr[type];
2979 pvop->op_next = (OP*)pvop;
2980 pvop->op_flags = (U8)flags;
2981 if (PL_opargs[type] & OA_RETSCALAR)
2983 if (PL_opargs[type] & OA_TARGET)
2984 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
2985 return CHECKOP(type, pvop);
2989 Perl_package(pTHX_ OP *o)
2994 save_hptr(&PL_curstash);
2995 save_item(PL_curstname);
2997 name = SvPV(cSVOPo->op_sv, len);
2998 PL_curstash = gv_stashpvn(name, len, TRUE);
2999 sv_setpvn(PL_curstname, name, len);
3002 PL_hints |= HINT_BLOCK_SCOPE;
3003 PL_copline = NOLINE;
3008 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3014 if (idop->op_type != OP_CONST)
3015 Perl_croak(aTHX_ "Module name must be constant");
3019 if (version != Nullop) {
3020 SV *vesv = ((SVOP*)version)->op_sv;
3022 if (arg == Nullop && !SvNIOKp(vesv)) {
3029 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3030 Perl_croak(aTHX_ "Version number must be constant number");
3032 /* Make copy of idop so we don't free it twice */
3033 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3035 /* Fake up a method call to VERSION */
3036 meth = newSVpvn("VERSION",7);
3037 sv_upgrade(meth, SVt_PVIV);
3038 (void)SvIOK_on(meth);
3041 PERL_HASH(hash, SvPVX(meth), SvCUR(meth));
3042 SvUV_set(meth, hash);
3044 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3045 append_elem(OP_LIST,
3046 prepend_elem(OP_LIST, pack, list(version)),
3047 newSVOP(OP_METHOD_NAMED, 0, meth)));
3051 /* Fake up an import/unimport */
3052 if (arg && arg->op_type == OP_STUB)
3053 imop = arg; /* no import on explicit () */
3054 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3055 imop = Nullop; /* use 5.0; */
3060 /* Make copy of idop so we don't free it twice */
3061 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3063 /* Fake up a method call to import/unimport */
3064 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);
3065 (void)SvUPGRADE(meth, SVt_PVIV);
3066 (void)SvIOK_on(meth);
3069 PERL_HASH(hash, SvPVX(meth), SvCUR(meth));
3070 SvUV_set(meth, hash);
3072 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3073 append_elem(OP_LIST,
3074 prepend_elem(OP_LIST, pack, list(arg)),
3075 newSVOP(OP_METHOD_NAMED, 0, meth)));
3078 /* Fake up the BEGIN {}, which does its thing immediately. */
3080 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3083 append_elem(OP_LINESEQ,
3084 append_elem(OP_LINESEQ,
3085 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, idop)),
3086 newSTATEOP(0, Nullch, veop)),
3087 newSTATEOP(0, Nullch, imop) ));
3089 /* The "did you use incorrect case?" warning used to be here.
3090 * The problem is that on case-insensitive filesystems one
3091 * might get false positives for "use" (and "require"):
3092 * "use Strict" or "require CARP" will work. This causes
3093 * portability problems for the script: in case-strict
3094 * filesystems the script will stop working.
3096 * The "incorrect case" warning checked whether "use Foo"
3097 * imported "Foo" to your namespace, but that is wrong, too:
3098 * there is no requirement nor promise in the language that
3099 * a Foo.pm should or would contain anything in package "Foo".
3101 * There is very little Configure-wise that can be done, either:
3102 * the case-sensitivity of the build filesystem of Perl does not
3103 * help in guessing the case-sensitivity of the runtime environment.
3106 PL_hints |= HINT_BLOCK_SCOPE;
3107 PL_copline = NOLINE;
3109 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3113 =head1 Embedding Functions
3115 =for apidoc load_module
3117 Loads the module whose name is pointed to by the string part of name.
3118 Note that the actual module name, not its filename, should be given.
3119 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3120 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3121 (or 0 for no flags). ver, if specified, provides version semantics
3122 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3123 arguments can be used to specify arguments to the module's import()
3124 method, similar to C<use Foo::Bar VERSION LIST>.
3129 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3132 va_start(args, ver);
3133 vload_module(flags, name, ver, &args);
3137 #ifdef PERL_IMPLICIT_CONTEXT
3139 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3143 va_start(args, ver);
3144 vload_module(flags, name, ver, &args);
3150 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3152 OP *modname, *veop, *imop;
3154 modname = newSVOP(OP_CONST, 0, name);
3155 modname->op_private |= OPpCONST_BARE;
3157 veop = newSVOP(OP_CONST, 0, ver);
3161 if (flags & PERL_LOADMOD_NOIMPORT) {
3162 imop = sawparens(newNULLLIST());
3164 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3165 imop = va_arg(*args, OP*);
3170 sv = va_arg(*args, SV*);
3172 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3173 sv = va_arg(*args, SV*);
3177 const line_t ocopline = PL_copline;
3178 COP * const ocurcop = PL_curcop;
3179 const int oexpect = PL_expect;
3181 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3182 veop, modname, imop);
3183 PL_expect = oexpect;
3184 PL_copline = ocopline;
3185 PL_curcop = ocurcop;
3190 Perl_dofile(pTHX_ OP *term)
3195 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3196 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
3197 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3199 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3200 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3201 append_elem(OP_LIST, term,
3202 scalar(newUNOP(OP_RV2CV, 0,
3207 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3213 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3215 return newBINOP(OP_LSLICE, flags,
3216 list(force_list(subscript)),
3217 list(force_list(listval)) );
3221 S_list_assignment(pTHX_ register const OP *o)
3226 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3227 o = cUNOPo->op_first;
3229 if (o->op_type == OP_COND_EXPR) {
3230 const I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3231 const I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3236 yyerror("Assignment to both a list and a scalar");
3240 if (o->op_type == OP_LIST &&
3241 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3242 o->op_private & OPpLVAL_INTRO)
3245 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3246 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3247 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3250 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3253 if (o->op_type == OP_RV2SV)
3260 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3265 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3266 return newLOGOP(optype, 0,
3267 mod(scalar(left), optype),
3268 newUNOP(OP_SASSIGN, 0, scalar(right)));
3271 return newBINOP(optype, OPf_STACKED,
3272 mod(scalar(left), optype), scalar(right));
3276 if (list_assignment(left)) {
3280 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3281 left = mod(left, OP_AASSIGN);
3289 /* optimise C<my @x = ()> to C<my @x>, and likewise for hashes */
3290 if ((left->op_type == OP_PADAV || left->op_type == OP_PADHV)
3291 && right->op_type == OP_STUB
3292 && (left->op_private & OPpLVAL_INTRO))
3295 left->op_flags &= ~(OPf_REF|OPf_SPECIAL);
3298 curop = list(force_list(left));
3299 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3300 o->op_private = (U8)(0 | (flags >> 8));
3302 /* PL_generation sorcery:
3303 * an assignment like ($a,$b) = ($c,$d) is easier than
3304 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3305 * To detect whether there are common vars, the global var
3306 * PL_generation is incremented for each assign op we compile.
3307 * Then, while compiling the assign op, we run through all the
3308 * variables on both sides of the assignment, setting a spare slot
3309 * in each of them to PL_generation. If any of them already have
3310 * that value, we know we've got commonality. We could use a
3311 * single bit marker, but then we'd have to make 2 passes, first
3312 * to clear the flag, then to test and set it. To find somewhere
3313 * to store these values, evil chicanery is done with SvCUR().
3316 if (!(left->op_private & OPpLVAL_INTRO)) {
3319 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3320 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3321 if (curop->op_type == OP_GV) {
3322 GV *gv = cGVOPx_gv(curop);
3323 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3325 SvCUR_set(gv, PL_generation);
3327 else if (curop->op_type == OP_PADSV ||
3328 curop->op_type == OP_PADAV ||
3329 curop->op_type == OP_PADHV ||
3330 curop->op_type == OP_PADANY)
3332 if (PAD_COMPNAME_GEN(curop->op_targ)
3333 == (STRLEN)PL_generation)
3335 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
3338 else if (curop->op_type == OP_RV2CV)
3340 else if (curop->op_type == OP_RV2SV ||
3341 curop->op_type == OP_RV2AV ||
3342 curop->op_type == OP_RV2HV ||
3343 curop->op_type == OP_RV2GV) {
3344 if (lastop->op_type != OP_GV) /* funny deref? */
3347 else if (curop->op_type == OP_PUSHRE) {
3348 if (((PMOP*)curop)->op_pmreplroot) {
3350 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3351 ((PMOP*)curop)->op_pmreplroot));
3353 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3355 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3357 SvCUR_set(gv, PL_generation);
3366 o->op_private |= OPpASSIGN_COMMON;
3368 if (right && right->op_type == OP_SPLIT) {
3370 if ((tmpop = ((LISTOP*)right)->op_first) &&
3371 tmpop->op_type == OP_PUSHRE)
3373 PMOP *pm = (PMOP*)tmpop;
3374 if (left->op_type == OP_RV2AV &&
3375 !(left->op_private & OPpLVAL_INTRO) &&
3376 !(o->op_private & OPpASSIGN_COMMON) )
3378 tmpop = ((UNOP*)left)->op_first;
3379 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3381 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3382 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3384 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3385 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3387 pm->op_pmflags |= PMf_ONCE;
3388 tmpop = cUNOPo->op_first; /* to list (nulled) */
3389 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3390 tmpop->op_sibling = Nullop; /* don't free split */
3391 right->op_next = tmpop->op_next; /* fix starting loc */
3392 op_free(o); /* blow off assign */
3393 right->op_flags &= ~OPf_WANT;
3394 /* "I don't know and I don't care." */
3399 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3400 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3402 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3404 sv_setiv(sv, PL_modcount+1);
3412 right = newOP(OP_UNDEF, 0);
3413 if (right->op_type == OP_READLINE) {
3414 right->op_flags |= OPf_STACKED;
3415 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3418 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3419 o = newBINOP(OP_SASSIGN, flags,
3420 scalar(right), mod(scalar(left), OP_SASSIGN) );
3432 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3435 const U32 seq = intro_my();
3438 NewOp(1101, cop, 1, COP);
3439 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3440 cop->op_type = OP_DBSTATE;
3441 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3444 cop->op_type = OP_NEXTSTATE;
3445 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3447 cop->op_flags = (U8)flags;
3448 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3450 cop->op_private |= NATIVE_HINTS;
3452 PL_compiling.op_private = cop->op_private;
3453 cop->op_next = (OP*)cop;
3456 cop->cop_label = label;
3457 PL_hints |= HINT_BLOCK_SCOPE;
3460 cop->cop_arybase = PL_curcop->cop_arybase;
3461 if (specialWARN(PL_curcop->cop_warnings))
3462 cop->cop_warnings = PL_curcop->cop_warnings ;
3464 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3465 if (specialCopIO(PL_curcop->cop_io))
3466 cop->cop_io = PL_curcop->cop_io;
3468 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3471 if (PL_copline == NOLINE)
3472 CopLINE_set(cop, CopLINE(PL_curcop));
3474 CopLINE_set(cop, PL_copline);
3475 PL_copline = NOLINE;
3478 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3480 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3482 CopSTASH_set(cop, PL_curstash);
3484 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3485 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3486 if (svp && *svp != &PL_sv_undef ) {
3487 (void)SvIOK_on(*svp);
3488 SvIV_set(*svp, PTR2IV(cop));
3492 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3497 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3500 return new_logop(type, flags, &first, &other);
3504 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3509 OP *first = *firstp;
3510 OP *other = *otherp;
3512 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3513 return newBINOP(type, flags, scalar(first), scalar(other));
3515 scalarboolean(first);
3516 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3517 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3518 if (type == OP_AND || type == OP_OR) {
3524 first = *firstp = cUNOPo->op_first;
3526 first->op_next = o->op_next;
3527 cUNOPo->op_first = Nullop;
3531 if (first->op_type == OP_CONST) {
3532 if (first->op_private & OPpCONST_STRICT)
3533 no_bareword_allowed(first);
3534 else if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3535 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3536 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
3537 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
3538 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
3541 if (other->op_type == OP_CONST)
3542 other->op_private |= OPpCONST_SHORTCIRCUIT;
3546 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
3547 const OP *o2 = other;
3548 if ( ! (o2->op_type == OP_LIST
3549 && (( o2 = cUNOPx(o2)->op_first))
3550 && o2->op_type == OP_PUSHMARK
3551 && (( o2 = o2->op_sibling)) )
3554 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
3555 || o2->op_type == OP_PADHV)
3556 && o2->op_private & OPpLVAL_INTRO
3557 && ckWARN(WARN_DEPRECATED))
3559 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
3560 "Deprecated use of my() in false conditional");
3565 if (first->op_type == OP_CONST)
3566 first->op_private |= OPpCONST_SHORTCIRCUIT;
3570 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS) &&
3571 type != OP_DOR) /* [#24076] Don't warn for <FH> err FOO. */
3573 const OP *k1 = ((UNOP*)first)->op_first;
3574 const OP *k2 = k1->op_sibling;
3576 switch (first->op_type)
3579 if (k2 && k2->op_type == OP_READLINE
3580 && (k2->op_flags & OPf_STACKED)
3581 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3583 warnop = k2->op_type;
3588 if (k1->op_type == OP_READDIR
3589 || k1->op_type == OP_GLOB
3590 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3591 || k1->op_type == OP_EACH)
3593 warnop = ((k1->op_type == OP_NULL)
3594 ? (OPCODE)k1->op_targ : k1->op_type);
3599 const line_t oldline = CopLINE(PL_curcop);
3600 CopLINE_set(PL_curcop, PL_copline);
3601 Perl_warner(aTHX_ packWARN(WARN_MISC),
3602 "Value of %s%s can be \"0\"; test with defined()",
3604 ((warnop == OP_READLINE || warnop == OP_GLOB)
3605 ? " construct" : "() operator"));
3606 CopLINE_set(PL_curcop, oldline);
3613 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3614 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3616 NewOp(1101, logop, 1, LOGOP);
3618 logop->op_type = (OPCODE)type;
3619 logop->op_ppaddr = PL_ppaddr[type];
3620 logop->op_first = first;
3621 logop->op_flags = flags | OPf_KIDS;
3622 logop->op_other = LINKLIST(other);
3623 logop->op_private = (U8)(1 | (flags >> 8));
3625 /* establish postfix order */
3626 logop->op_next = LINKLIST(first);
3627 first->op_next = (OP*)logop;
3628 first->op_sibling = other;
3630 CHECKOP(type,logop);
3632 o = newUNOP(OP_NULL, 0, (OP*)logop);
3639 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3647 return newLOGOP(OP_AND, 0, first, trueop);
3649 return newLOGOP(OP_OR, 0, first, falseop);
3651 scalarboolean(first);
3652 if (first->op_type == OP_CONST) {
3653 if (first->op_private & OPpCONST_BARE &&
3654 first->op_private & OPpCONST_STRICT) {
3655 no_bareword_allowed(first);
3657 if (SvTRUE(((SVOP*)first)->op_sv)) {
3668 NewOp(1101, logop, 1, LOGOP);
3669 logop->op_type = OP_COND_EXPR;
3670 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3671 logop->op_first = first;
3672 logop->op_flags = flags | OPf_KIDS;
3673 logop->op_private = (U8)(1 | (flags >> 8));
3674 logop->op_other = LINKLIST(trueop);
3675 logop->op_next = LINKLIST(falseop);
3677 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
3680 /* establish postfix order */
3681 start = LINKLIST(first);
3682 first->op_next = (OP*)logop;
3684 first->op_sibling = trueop;
3685 trueop->op_sibling = falseop;
3686 o = newUNOP(OP_NULL, 0, (OP*)logop);
3688 trueop->op_next = falseop->op_next = o;
3695 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3704 NewOp(1101, range, 1, LOGOP);
3706 range->op_type = OP_RANGE;
3707 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3708 range->op_first = left;
3709 range->op_flags = OPf_KIDS;
3710 leftstart = LINKLIST(left);
3711 range->op_other = LINKLIST(right);
3712 range->op_private = (U8)(1 | (flags >> 8));
3714 left->op_sibling = right;
3716 range->op_next = (OP*)range;
3717 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3718 flop = newUNOP(OP_FLOP, 0, flip);
3719 o = newUNOP(OP_NULL, 0, flop);
3721 range->op_next = leftstart;
3723 left->op_next = flip;
3724 right->op_next = flop;
3726 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3727 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3728 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3729 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3731 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3732 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3735 if (!flip->op_private || !flop->op_private)
3736 linklist(o); /* blow off optimizer unless constant */
3742 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3746 const bool once = block && block->op_flags & OPf_SPECIAL &&
3747 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3751 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3752 return block; /* do {} while 0 does once */
3753 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3754 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3755 expr = newUNOP(OP_DEFINED, 0,
3756 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3757 } else if (expr->op_flags & OPf_KIDS) {
3758 const OP *k1 = ((UNOP*)expr)->op_first;
3759 const OP *k2 = (k1) ? k1->op_sibling : NULL;
3760 switch (expr->op_type) {
3762 if (k2 && k2->op_type == OP_READLINE
3763 && (k2->op_flags & OPf_STACKED)
3764 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3765 expr = newUNOP(OP_DEFINED, 0, expr);
3769 if (k1->op_type == OP_READDIR
3770 || k1->op_type == OP_GLOB
3771 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3772 || k1->op_type == OP_EACH)
3773 expr = newUNOP(OP_DEFINED, 0, expr);
3779 /* if block is null, the next append_elem() would put UNSTACK, a scalar
3780 * op, in listop. This is wrong. [perl #27024] */
3782 block = newOP(OP_NULL, 0);
3783 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3784 o = new_logop(OP_AND, 0, &expr, &listop);
3787 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3789 if (once && o != listop)
3790 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3793 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3795 o->op_flags |= flags;
3797 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3802 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
3803 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
3813 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3814 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3815 expr = newUNOP(OP_DEFINED, 0,
3816 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3817 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3818 const OP *k1 = ((UNOP*)expr)->op_first;
3819 const OP *k2 = (k1) ? k1->op_sibling : NULL;
3820 switch (expr->op_type) {
3822 if (k2 && k2->op_type == OP_READLINE
3823 && (k2->op_flags & OPf_STACKED)
3824 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3825 expr = newUNOP(OP_DEFINED, 0, expr);
3829 if (k1->op_type == OP_READDIR
3830 || k1->op_type == OP_GLOB
3831 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3832 || k1->op_type == OP_EACH)
3833 expr = newUNOP(OP_DEFINED, 0, expr);
3839 block = newOP(OP_NULL, 0);
3840 else if (cont || has_my) {
3841 block = scope(block);
3845 next = LINKLIST(cont);
3848 OP *unstack = newOP(OP_UNSTACK, 0);
3851 cont = append_elem(OP_LINESEQ, cont, unstack);
3854 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3855 redo = LINKLIST(listop);
3858 PL_copline = (line_t)whileline;
3860 o = new_logop(OP_AND, 0, &expr, &listop);
3861 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3862 op_free(expr); /* oops, it's a while (0) */
3864 return Nullop; /* listop already freed by new_logop */
3867 ((LISTOP*)listop)->op_last->op_next =
3868 (o == listop ? redo : LINKLIST(o));
3874 NewOp(1101,loop,1,LOOP);
3875 loop->op_type = OP_ENTERLOOP;
3876 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3877 loop->op_private = 0;
3878 loop->op_next = (OP*)loop;
3881 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3883 loop->op_redoop = redo;
3884 loop->op_lastop = o;
3885 o->op_private |= loopflags;
3888 loop->op_nextop = next;
3890 loop->op_nextop = o;
3892 o->op_flags |= flags;
3893 o->op_private |= (flags >> 8);
3898 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
3903 PADOFFSET padoff = 0;
3908 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
3909 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
3910 sv->op_type = OP_RV2GV;
3911 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3913 else if (sv->op_type == OP_PADSV) { /* private variable */
3914 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
3915 padoff = sv->op_targ;
3920 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3921 padoff = sv->op_targ;
3923 iterflags |= OPf_SPECIAL;
3928 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3931 const I32 offset = pad_findmy("$_");
3932 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
3933 sv = newGVOP(OP_GV, 0, PL_defgv);
3939 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3940 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3941 iterflags |= OPf_STACKED;
3943 else if (expr->op_type == OP_NULL &&
3944 (expr->op_flags & OPf_KIDS) &&
3945 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3947 /* Basically turn for($x..$y) into the same as for($x,$y), but we
3948 * set the STACKED flag to indicate that these values are to be
3949 * treated as min/max values by 'pp_iterinit'.
3951 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
3952 LOGOP* range = (LOGOP*) flip->op_first;
3953 OP* left = range->op_first;
3954 OP* right = left->op_sibling;
3957 range->op_flags &= ~OPf_KIDS;
3958 range->op_first = Nullop;
3960 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
3961 listop->op_first->op_next = range->op_next;
3962 left->op_next = range->op_other;
3963 right->op_next = (OP*)listop;
3964 listop->op_next = listop->op_first;
3967 expr = (OP*)(listop);
3969 iterflags |= OPf_STACKED;
3972 expr = mod(force_list(expr), OP_GREPSTART);
3975 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
3976 append_elem(OP_LIST, expr, scalar(sv))));
3977 assert(!loop->op_next);
3978 /* for my $x () sets OPpLVAL_INTRO;
3979 * for our $x () sets OPpOUR_INTRO */
3980 loop->op_private = (U8)iterpflags;
3981 #ifdef PL_OP_SLAB_ALLOC
3984 NewOp(1234,tmp,1,LOOP);
3985 Copy(loop,tmp,1,LISTOP);
3990 Renew(loop, 1, LOOP);
3992 loop->op_targ = padoff;
3993 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
3994 PL_copline = forline;
3995 return newSTATEOP(0, label, wop);
3999 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4004 if (type != OP_GOTO || label->op_type == OP_CONST) {
4005 /* "last()" means "last" */
4006 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4007 o = newOP(type, OPf_SPECIAL);
4009 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4010 ? SvPVx(((SVOP*)label)->op_sv, n_a)
4016 /* Check whether it's going to be a goto &function */
4017 if (label->op_type == OP_ENTERSUB
4018 && !(label->op_flags & OPf_STACKED))
4019 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4020 o = newUNOP(type, OPf_STACKED, label);
4022 PL_hints |= HINT_BLOCK_SCOPE;
4027 =for apidoc cv_undef
4029 Clear out all the active components of a CV. This can happen either
4030 by an explicit C<undef &foo>, or by the reference count going to zero.
4031 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4032 children can still follow the full lexical scope chain.
4038 Perl_cv_undef(pTHX_ CV *cv)
4042 if (CvFILE(cv) && !CvXSUB(cv)) {
4043 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4044 Safefree(CvFILE(cv));
4049 if (!CvXSUB(cv) && CvROOT(cv)) {
4051 Perl_croak(aTHX_ "Can't undef active subroutine");
4054 PAD_SAVE_SETNULLPAD();
4056 op_free(CvROOT(cv));
4057 CvROOT(cv) = Nullop;
4060 SvPOK_off((SV*)cv); /* forget prototype */
4065 /* remove CvOUTSIDE unless this is an undef rather than a free */
4066 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4067 if (!CvWEAKOUTSIDE(cv))
4068 SvREFCNT_dec(CvOUTSIDE(cv));
4069 CvOUTSIDE(cv) = Nullcv;
4072 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4078 /* delete all flags except WEAKOUTSIDE */
4079 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4083 Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p)
4085 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4086 SV* msg = sv_newmortal();
4090 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4091 sv_setpv(msg, "Prototype mismatch:");
4093 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4095 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (const SV *)cv);
4097 Perl_sv_catpv(aTHX_ msg, ": none");
4098 sv_catpv(msg, " vs ");
4100 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4102 sv_catpv(msg, "none");
4103 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
4107 static void const_sv_xsub(pTHX_ CV* cv);
4111 =head1 Optree Manipulation Functions
4113 =for apidoc cv_const_sv
4115 If C<cv> is a constant sub eligible for inlining. returns the constant
4116 value returned by the sub. Otherwise, returns NULL.
4118 Constant subs can be created with C<newCONSTSUB> or as described in
4119 L<perlsub/"Constant Functions">.
4124 Perl_cv_const_sv(pTHX_ CV *cv)
4126 if (!cv || !CvCONST(cv))
4128 return (SV*)CvXSUBANY(cv).any_ptr;
4131 /* op_const_sv: examine an optree to determine whether it's in-lineable.
4132 * Can be called in 3 ways:
4135 * look for a single OP_CONST with attached value: return the value
4137 * cv && CvCLONE(cv) && !CvCONST(cv)
4139 * examine the clone prototype, and if contains only a single
4140 * OP_CONST referencing a pad const, or a single PADSV referencing
4141 * an outer lexical, return a non-zero value to indicate the CV is
4142 * a candidate for "constizing" at clone time
4146 * We have just cloned an anon prototype that was marked as a const
4147 * candidiate. Try to grab the current value, and in the case of
4148 * PADSV, ignore it if it has multiple references. Return the value.
4152 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
4159 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4160 o = cLISTOPo->op_first->op_sibling;
4162 for (; o; o = o->op_next) {
4163 OPCODE type = o->op_type;
4165 if (sv && o->op_next == o)
4167 if (o->op_next != o) {
4168 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4170 if (type == OP_DBSTATE)
4173 if (type == OP_LEAVESUB || type == OP_RETURN)
4177 if (type == OP_CONST && cSVOPo->op_sv)
4179 else if (cv && type == OP_CONST) {
4180 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4184 else if (cv && type == OP_PADSV) {
4185 if (CvCONST(cv)) { /* newly cloned anon */
4186 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4187 /* the candidate should have 1 ref from this pad and 1 ref
4188 * from the parent */
4189 if (!sv || SvREFCNT(sv) != 2)
4196 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4197 sv = &PL_sv_undef; /* an arbitrary non-null value */
4208 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4219 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4223 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4225 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4229 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4240 const char * const name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4243 assert(proto->op_type == OP_CONST);
4244 ps = SvPVx(((SVOP*)proto)->op_sv, ps_len);
4249 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4250 SV *sv = sv_newmortal();
4251 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4252 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4253 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4258 gv = name ? gv_fetchsv(cSVOPo->op_sv,
4259 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4261 : gv_fetchpv(aname ? aname
4262 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4263 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4273 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4274 maximum a prototype before. */
4275 if (SvTYPE(gv) > SVt_NULL) {
4276 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4277 && ckWARN_d(WARN_PROTOTYPE))
4279 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4281 cv_ckproto((CV*)gv, NULL, ps);
4284 sv_setpvn((SV*)gv, ps, ps_len);
4286 sv_setiv((SV*)gv, -1);
4287 SvREFCNT_dec(PL_compcv);
4288 cv = PL_compcv = NULL;
4289 PL_sub_generation++;
4293 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4295 #ifdef GV_UNIQUE_CHECK
4296 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4297 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4301 if (!block || !ps || *ps || attrs)
4304 const_sv = op_const_sv(block, Nullcv);
4307 const bool exists = CvROOT(cv) || CvXSUB(cv);
4309 #ifdef GV_UNIQUE_CHECK
4310 if (exists && GvUNIQUE(gv)) {
4311 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4315 /* if the subroutine doesn't exist and wasn't pre-declared
4316 * with a prototype, assume it will be AUTOLOADed,
4317 * skipping the prototype check
4319 if (exists || SvPOK(cv))
4320 cv_ckproto(cv, gv, ps);
4321 /* already defined (or promised)? */
4322 if (exists || GvASSUMECV(gv)) {
4323 if (!block && !attrs) {
4324 if (CvFLAGS(PL_compcv)) {
4325 /* might have had built-in attrs applied */
4326 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4328 /* just a "sub foo;" when &foo is already defined */
4329 SAVEFREESV(PL_compcv);
4332 /* ahem, death to those who redefine active sort subs */
4333 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4334 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4336 if (ckWARN(WARN_REDEFINE)
4338 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4340 const line_t oldline = CopLINE(PL_curcop);
4341 if (PL_copline != NOLINE)
4342 CopLINE_set(PL_curcop, PL_copline);
4343 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4344 CvCONST(cv) ? "Constant subroutine %s redefined"
4345 : "Subroutine %s redefined", name);
4346 CopLINE_set(PL_curcop, oldline);
4354 (void)SvREFCNT_inc(const_sv);
4356 assert(!CvROOT(cv) && !CvCONST(cv));
4357 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
4358 CvXSUBANY(cv).any_ptr = const_sv;
4359 CvXSUB(cv) = const_sv_xsub;
4364 cv = newCONSTSUB(NULL, name, const_sv);
4367 SvREFCNT_dec(PL_compcv);
4369 PL_sub_generation++;
4376 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4377 * before we clobber PL_compcv.
4381 /* Might have had built-in attributes applied -- propagate them. */
4382 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4383 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4384 stash = GvSTASH(CvGV(cv));
4385 else if (CvSTASH(cv))
4386 stash = CvSTASH(cv);
4388 stash = PL_curstash;
4391 /* possibly about to re-define existing subr -- ignore old cv */
4392 rcv = (SV*)PL_compcv;
4393 if (name && GvSTASH(gv))
4394 stash = GvSTASH(gv);
4396 stash = PL_curstash;
4398 apply_attrs(stash, rcv, attrs, FALSE);
4400 if (cv) { /* must reuse cv if autoloaded */
4402 /* got here with just attrs -- work done, so bug out */
4403 SAVEFREESV(PL_compcv);
4406 /* transfer PL_compcv to cv */
4408 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4409 if (!CvWEAKOUTSIDE(cv))
4410 SvREFCNT_dec(CvOUTSIDE(cv));
4411 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4412 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4413 CvOUTSIDE(PL_compcv) = 0;
4414 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4415 CvPADLIST(PL_compcv) = 0;
4416 /* inner references to PL_compcv must be fixed up ... */
4417 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4418 /* ... before we throw it away */
4419 SvREFCNT_dec(PL_compcv);
4421 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4422 ++PL_sub_generation;
4429 PL_sub_generation++;
4433 CvFILE_set_from_cop(cv, PL_curcop);
4434 CvSTASH(cv) = PL_curstash;
4437 sv_setpvn((SV*)cv, ps, ps_len);
4439 if (PL_error_count) {
4443 const char *s = strrchr(name, ':');
4445 if (strEQ(s, "BEGIN")) {
4446 const char not_safe[] =
4447 "BEGIN not safe after errors--compilation aborted";
4448 if (PL_in_eval & EVAL_KEEPERR)
4449 Perl_croak(aTHX_ not_safe);
4451 /* force display of errors found but not reported */
4452 sv_catpv(ERRSV, not_safe);
4453 Perl_croak(aTHX_ "%"SVf, ERRSV);
4462 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4463 mod(scalarseq(block), OP_LEAVESUBLV));
4466 /* This makes sub {}; work as expected. */
4467 if (block->op_type == OP_STUB) {
4469 block = newSTATEOP(0, Nullch, 0);
4471 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4473 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4474 OpREFCNT_set(CvROOT(cv), 1);
4475 CvSTART(cv) = LINKLIST(CvROOT(cv));
4476 CvROOT(cv)->op_next = 0;
4477 CALL_PEEP(CvSTART(cv));
4479 /* now that optimizer has done its work, adjust pad values */
4481 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4484 assert(!CvCONST(cv));
4485 if (ps && !*ps && op_const_sv(block, cv))
4489 if (name || aname) {
4491 const char *tname = (name ? name : aname);
4493 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4494 SV *sv = NEWSV(0,0);
4495 SV *tmpstr = sv_newmortal();
4496 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4500 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4502 (long)PL_subline, (long)CopLINE(PL_curcop));
4503 gv_efullname3(tmpstr, gv, Nullch);
4504 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4505 hv = GvHVn(db_postponed);
4506 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4507 && (pcv = GvCV(db_postponed)))
4513 call_sv((SV*)pcv, G_DISCARD);
4517 if ((s = strrchr(tname,':')))
4522 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4525 if (strEQ(s, "BEGIN") && !PL_error_count) {
4526 const I32 oldscope = PL_scopestack_ix;
4528 SAVECOPFILE(&PL_compiling);
4529 SAVECOPLINE(&PL_compiling);
4532 PL_beginav = newAV();
4533 DEBUG_x( dump_sub(gv) );
4534 av_push(PL_beginav, (SV*)cv);
4535 GvCV(gv) = 0; /* cv has been hijacked */
4536 call_list(oldscope, PL_beginav);
4538 PL_curcop = &PL_compiling;
4539 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4542 else if (strEQ(s, "END") && !PL_error_count) {
4545 DEBUG_x( dump_sub(gv) );
4546 av_unshift(PL_endav, 1);
4547 av_store(PL_endav, 0, (SV*)cv);
4548 GvCV(gv) = 0; /* cv has been hijacked */
4550 else if (strEQ(s, "CHECK") && !PL_error_count) {
4552 PL_checkav = newAV();
4553 DEBUG_x( dump_sub(gv) );
4554 if (PL_main_start && ckWARN(WARN_VOID))
4555 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4556 av_unshift(PL_checkav, 1);
4557 av_store(PL_checkav, 0, (SV*)cv);
4558 GvCV(gv) = 0; /* cv has been hijacked */
4560 else if (strEQ(s, "INIT") && !PL_error_count) {
4562 PL_initav = newAV();
4563 DEBUG_x( dump_sub(gv) );
4564 if (PL_main_start && ckWARN(WARN_VOID))
4565 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4566 av_push(PL_initav, (SV*)cv);
4567 GvCV(gv) = 0; /* cv has been hijacked */
4572 PL_copline = NOLINE;
4577 /* XXX unsafe for threads if eval_owner isn't held */
4579 =for apidoc newCONSTSUB
4581 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4582 eligible for inlining at compile-time.
4588 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
4595 SAVECOPLINE(PL_curcop);
4596 CopLINE_set(PL_curcop, PL_copline);
4599 PL_hints &= ~HINT_BLOCK_SCOPE;
4602 SAVESPTR(PL_curstash);
4603 SAVECOPSTASH(PL_curcop);
4604 PL_curstash = stash;
4605 CopSTASH_set(PL_curcop,stash);
4608 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4609 CvXSUBANY(cv).any_ptr = sv;
4611 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
4614 CopSTASH_free(PL_curcop);
4622 =for apidoc U||newXS
4624 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4630 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
4632 GV *gv = gv_fetchpv(name ? name :
4633 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4634 GV_ADDMULTI, SVt_PVCV);
4638 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4640 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4642 /* just a cached method */
4646 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4647 /* already defined (or promised) */
4648 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4649 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4650 const line_t oldline = CopLINE(PL_curcop);
4651 if (PL_copline != NOLINE)
4652 CopLINE_set(PL_curcop, PL_copline);
4653 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4654 CvCONST(cv) ? "Constant subroutine %s redefined"
4655 : "Subroutine %s redefined"
4657 CopLINE_set(PL_curcop, oldline);
4664 if (cv) /* must reuse cv if autoloaded */
4667 cv = (CV*)NEWSV(1105,0);
4668 sv_upgrade((SV *)cv, SVt_PVCV);
4672 PL_sub_generation++;
4676 (void)gv_fetchfile(filename);
4677 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
4678 an external constant string */
4679 CvXSUB(cv) = subaddr;
4682 const char *s = strrchr(name,':');
4688 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4691 if (strEQ(s, "BEGIN")) {
4693 PL_beginav = newAV();
4694 av_push(PL_beginav, (SV*)cv);
4695 GvCV(gv) = 0; /* cv has been hijacked */
4697 else if (strEQ(s, "END")) {
4700 av_unshift(PL_endav, 1);
4701 av_store(PL_endav, 0, (SV*)cv);
4702 GvCV(gv) = 0; /* cv has been hijacked */
4704 else if (strEQ(s, "CHECK")) {
4706 PL_checkav = newAV();
4707 if (PL_main_start && ckWARN(WARN_VOID))
4708 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4709 av_unshift(PL_checkav, 1);
4710 av_store(PL_checkav, 0, (SV*)cv);
4711 GvCV(gv) = 0; /* cv has been hijacked */
4713 else if (strEQ(s, "INIT")) {
4715 PL_initav = newAV();
4716 if (PL_main_start && ckWARN(WARN_VOID))
4717 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4718 av_push(PL_initav, (SV*)cv);
4719 GvCV(gv) = 0; /* cv has been hijacked */
4730 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4736 gv = gv_fetchsv(cSVOPo->op_sv, TRUE, SVt_PVFM);
4738 gv = gv_fetchpv("STDOUT", TRUE, SVt_PVFM);
4740 #ifdef GV_UNIQUE_CHECK
4742 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4746 if ((cv = GvFORM(gv))) {
4747 if (ckWARN(WARN_REDEFINE)) {
4748 const line_t oldline = CopLINE(PL_curcop);
4749 if (PL_copline != NOLINE)
4750 CopLINE_set(PL_curcop, PL_copline);
4751 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4752 o ? "Format %"SVf" redefined"
4753 : "Format STDOUT redefined" ,cSVOPo->op_sv);
4754 CopLINE_set(PL_curcop, oldline);
4761 CvFILE_set_from_cop(cv, PL_curcop);
4764 pad_tidy(padtidy_FORMAT);
4765 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4766 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4767 OpREFCNT_set(CvROOT(cv), 1);
4768 CvSTART(cv) = LINKLIST(CvROOT(cv));
4769 CvROOT(cv)->op_next = 0;
4770 CALL_PEEP(CvSTART(cv));
4772 PL_copline = NOLINE;
4777 Perl_newANONLIST(pTHX_ OP *o)
4779 return newUNOP(OP_REFGEN, 0,
4780 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4784 Perl_newANONHASH(pTHX_ OP *o)
4786 return newUNOP(OP_REFGEN, 0,
4787 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4791 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4793 return newANONATTRSUB(floor, proto, Nullop, block);
4797 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4799 return newUNOP(OP_REFGEN, 0,
4800 newSVOP(OP_ANONCODE, 0,
4801 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
4805 Perl_oopsAV(pTHX_ OP *o)
4808 switch (o->op_type) {
4810 o->op_type = OP_PADAV;
4811 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4812 return ref(o, OP_RV2AV);
4815 o->op_type = OP_RV2AV;
4816 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4821 if (ckWARN_d(WARN_INTERNAL))
4822 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
4829 Perl_oopsHV(pTHX_ OP *o)
4832 switch (o->op_type) {
4835 o->op_type = OP_PADHV;
4836 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4837 return ref(o, OP_RV2HV);
4841 o->op_type = OP_RV2HV;
4842 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
4847 if (ckWARN_d(WARN_INTERNAL))
4848 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
4855 Perl_newAVREF(pTHX_ OP *o)
4858 if (o->op_type == OP_PADANY) {
4859 o->op_type = OP_PADAV;
4860 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4863 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
4864 && ckWARN(WARN_DEPRECATED)) {
4865 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4866 "Using an array as a reference is deprecated");
4868 return newUNOP(OP_RV2AV, 0, scalar(o));
4872 Perl_newGVREF(pTHX_ I32 type, OP *o)
4874 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
4875 return newUNOP(OP_NULL, 0, o);
4876 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
4880 Perl_newHVREF(pTHX_ OP *o)
4883 if (o->op_type == OP_PADANY) {
4884 o->op_type = OP_PADHV;
4885 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4888 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
4889 && ckWARN(WARN_DEPRECATED)) {
4890 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4891 "Using a hash as a reference is deprecated");
4893 return newUNOP(OP_RV2HV, 0, scalar(o));
4897 Perl_oopsCV(pTHX_ OP *o)
4899 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
4902 #ifndef HASATTRIBUTE_NORETURN
4903 /* No __attribute__((noreturn)), so the compiler doesn't know that
4904 * croak never returns. */
4910 Perl_newCVREF(pTHX_ I32 flags, OP *o)
4912 return newUNOP(OP_RV2CV, flags, scalar(o));
4916 Perl_newSVREF(pTHX_ OP *o)
4919 if (o->op_type == OP_PADANY) {
4920 o->op_type = OP_PADSV;
4921 o->op_ppaddr = PL_ppaddr[OP_PADSV];
4924 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4925 o->op_flags |= OPpDONE_SVREF;
4928 return newUNOP(OP_RV2SV, 0, scalar(o));
4931 /* Check routines. See the comments at the top of this file for details
4932 * on when these are called */
4935 Perl_ck_anoncode(pTHX_ OP *o)
4937 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
4938 cSVOPo->op_sv = Nullsv;
4943 Perl_ck_bitop(pTHX_ OP *o)
4945 #define OP_IS_NUMCOMPARE(op) \
4946 ((op) == OP_LT || (op) == OP_I_LT || \
4947 (op) == OP_GT || (op) == OP_I_GT || \
4948 (op) == OP_LE || (op) == OP_I_LE || \
4949 (op) == OP_GE || (op) == OP_I_GE || \
4950 (op) == OP_EQ || (op) == OP_I_EQ || \
4951 (op) == OP_NE || (op) == OP_I_NE || \
4952 (op) == OP_NCMP || (op) == OP_I_NCMP)
4953 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4954 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
4955 && (o->op_type == OP_BIT_OR
4956 || o->op_type == OP_BIT_AND
4957 || o->op_type == OP_BIT_XOR))
4959 const OP * left = cBINOPo->op_first;
4960 const OP * right = left->op_sibling;
4961 if ((OP_IS_NUMCOMPARE(left->op_type) &&
4962 (left->op_flags & OPf_PARENS) == 0) ||
4963 (OP_IS_NUMCOMPARE(right->op_type) &&
4964 (right->op_flags & OPf_PARENS) == 0))
4965 if (ckWARN(WARN_PRECEDENCE))
4966 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4967 "Possible precedence problem on bitwise %c operator",
4968 o->op_type == OP_BIT_OR ? '|'
4969 : o->op_type == OP_BIT_AND ? '&' : '^'
4976 Perl_ck_concat(pTHX_ OP *o)
4978 const OP *kid = cUNOPo->op_first;
4979 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
4980 !(kUNOP->op_first->op_flags & OPf_MOD))
4981 o->op_flags |= OPf_STACKED;
4986 Perl_ck_spair(pTHX_ OP *o)
4989 if (o->op_flags & OPf_KIDS) {
4992 const OPCODE type = o->op_type;
4993 o = modkids(ck_fun(o), type);
4994 kid = cUNOPo->op_first;
4995 newop = kUNOP->op_first->op_sibling;
4997 (newop->op_sibling ||
4998 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
4999 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5000 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5004 op_free(kUNOP->op_first);
5005 kUNOP->op_first = newop;
5007 o->op_ppaddr = PL_ppaddr[++o->op_type];
5012 Perl_ck_delete(pTHX_ OP *o)
5016 if (o->op_flags & OPf_KIDS) {
5017 OP *kid = cUNOPo->op_first;
5018 switch (kid->op_type) {
5020 o->op_flags |= OPf_SPECIAL;
5023 o->op_private |= OPpSLICE;
5026 o->op_flags |= OPf_SPECIAL;
5031 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5040 Perl_ck_die(pTHX_ OP *o)
5043 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5049 Perl_ck_eof(pTHX_ OP *o)
5051 const I32 type = o->op_type;
5053 if (o->op_flags & OPf_KIDS) {
5054 if (cLISTOPo->op_first->op_type == OP_STUB) {
5056 o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
5064 Perl_ck_eval(pTHX_ OP *o)
5067 PL_hints |= HINT_BLOCK_SCOPE;
5068 if (o->op_flags & OPf_KIDS) {
5069 SVOP *kid = (SVOP*)cUNOPo->op_first;
5072 o->op_flags &= ~OPf_KIDS;
5075 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
5078 cUNOPo->op_first = 0;
5081 NewOp(1101, enter, 1, LOGOP);
5082 enter->op_type = OP_ENTERTRY;
5083 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5084 enter->op_private = 0;
5086 /* establish postfix order */
5087 enter->op_next = (OP*)enter;
5089 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5090 o->op_type = OP_LEAVETRY;
5091 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5092 enter->op_other = o;
5102 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5104 o->op_targ = (PADOFFSET)PL_hints;
5109 Perl_ck_exit(pTHX_ OP *o)
5112 HV *table = GvHV(PL_hintgv);
5114 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5115 if (svp && *svp && SvTRUE(*svp))
5116 o->op_private |= OPpEXIT_VMSISH;
5118 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5124 Perl_ck_exec(pTHX_ OP *o)
5126 if (o->op_flags & OPf_STACKED) {
5129 kid = cUNOPo->op_first->op_sibling;
5130 if (kid->op_type == OP_RV2GV)
5139 Perl_ck_exists(pTHX_ OP *o)
5142 if (o->op_flags & OPf_KIDS) {
5143 OP *kid = cUNOPo->op_first;
5144 if (kid->op_type == OP_ENTERSUB) {
5145 (void) ref(kid, o->op_type);
5146 if (kid->op_type != OP_RV2CV && !PL_error_count)
5147 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5149 o->op_private |= OPpEXISTS_SUB;
5151 else if (kid->op_type == OP_AELEM)
5152 o->op_flags |= OPf_SPECIAL;
5153 else if (kid->op_type != OP_HELEM)
5154 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5163 Perl_ck_gvconst(pTHX_ register OP *o)
5165 o = fold_constants(o);
5166 if (o->op_type == OP_CONST)
5173 Perl_ck_rvconst(pTHX_ register OP *o)
5176 SVOP *kid = (SVOP*)cUNOPo->op_first;
5178 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5179 if (kid->op_type == OP_CONST) {
5182 SV *kidsv = kid->op_sv;
5184 /* Is it a constant from cv_const_sv()? */
5185 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5186 SV *rsv = SvRV(kidsv);
5187 int svtype = SvTYPE(rsv);
5188 const char *badtype = Nullch;
5190 switch (o->op_type) {
5192 if (svtype > SVt_PVMG)
5193 badtype = "a SCALAR";
5196 if (svtype != SVt_PVAV)
5197 badtype = "an ARRAY";
5200 if (svtype != SVt_PVHV)
5204 if (svtype != SVt_PVCV)
5209 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5212 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5213 const char *badthing = Nullch;
5214 switch (o->op_type) {
5216 badthing = "a SCALAR";
5219 badthing = "an ARRAY";
5222 badthing = "a HASH";
5227 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
5231 * This is a little tricky. We only want to add the symbol if we
5232 * didn't add it in the lexer. Otherwise we get duplicate strict
5233 * warnings. But if we didn't add it in the lexer, we must at
5234 * least pretend like we wanted to add it even if it existed before,
5235 * or we get possible typo warnings. OPpCONST_ENTERED says
5236 * whether the lexer already added THIS instance of this symbol.
5238 iscv = (o->op_type == OP_RV2CV) * 2;
5240 gv = gv_fetchsv(kidsv,
5241 iscv | !(kid->op_private & OPpCONST_ENTERED),
5244 : o->op_type == OP_RV2SV
5246 : o->op_type == OP_RV2AV
5248 : o->op_type == OP_RV2HV
5251 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5253 kid->op_type = OP_GV;
5254 SvREFCNT_dec(kid->op_sv);
5256 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5257 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5258 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
5260 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
5262 kid->op_sv = SvREFCNT_inc(gv);
5264 kid->op_private = 0;
5265 kid->op_ppaddr = PL_ppaddr[OP_GV];
5272 Perl_ck_ftst(pTHX_ OP *o)
5275 const I32 type = o->op_type;
5277 if (o->op_flags & OPf_REF) {
5280 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5281 SVOP *kid = (SVOP*)cUNOPo->op_first;
5283 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5284 OP *newop = newGVOP(type, OPf_REF,
5285 gv_fetchsv(kid->op_sv, TRUE, SVt_PVIO));
5291 if ((PL_hints & HINT_FILETEST_ACCESS) &&
5292 OP_IS_FILETEST_ACCESS(o))
5293 o->op_private |= OPpFT_ACCESS;
5295 if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
5296 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
5297 o->op_private |= OPpFT_STACKED;
5301 if (type == OP_FTTTY)
5302 o = newGVOP(type, OPf_REF, PL_stdingv);
5304 o = newUNOP(type, 0, newDEFSVOP());
5310 Perl_ck_fun(pTHX_ OP *o)
5312 const int type = o->op_type;
5313 register I32 oa = PL_opargs[type] >> OASHIFT;
5315 if (o->op_flags & OPf_STACKED) {
5316 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5319 return no_fh_allowed(o);
5322 if (o->op_flags & OPf_KIDS) {
5323 OP **tokid = &cLISTOPo->op_first;
5324 register OP *kid = cLISTOPo->op_first;
5328 if (kid->op_type == OP_PUSHMARK ||
5329 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5331 tokid = &kid->op_sibling;
5332 kid = kid->op_sibling;
5334 if (!kid && PL_opargs[type] & OA_DEFGV)
5335 *tokid = kid = newDEFSVOP();
5339 sibl = kid->op_sibling;
5342 /* list seen where single (scalar) arg expected? */
5343 if (numargs == 1 && !(oa >> 4)
5344 && kid->op_type == OP_LIST && type != OP_SCALAR)
5346 return too_many_arguments(o,PL_op_desc[type]);
5359 if ((type == OP_PUSH || type == OP_UNSHIFT)
5360 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5361 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5362 "Useless use of %s with no values",
5365 if (kid->op_type == OP_CONST &&
5366 (kid->op_private & OPpCONST_BARE))
5368 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5369 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVAV) ));
5370 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5371 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5372 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
5373 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5376 kid->op_sibling = sibl;
5379 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5380 bad_type(numargs, "array", PL_op_desc[type], kid);
5384 if (kid->op_type == OP_CONST &&
5385 (kid->op_private & OPpCONST_BARE))
5387 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5388 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVHV) ));
5389 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5390 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5391 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
5392 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5395 kid->op_sibling = sibl;
5398 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5399 bad_type(numargs, "hash", PL_op_desc[type], kid);
5404 OP *newop = newUNOP(OP_NULL, 0, kid);
5405 kid->op_sibling = 0;
5407 newop->op_next = newop;
5409 kid->op_sibling = sibl;
5414 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5415 if (kid->op_type == OP_CONST &&
5416 (kid->op_private & OPpCONST_BARE))
5418 OP *newop = newGVOP(OP_GV, 0,
5419 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVIO) );
5420 if (!(o->op_private & 1) && /* if not unop */
5421 kid == cLISTOPo->op_last)
5422 cLISTOPo->op_last = newop;
5426 else if (kid->op_type == OP_READLINE) {
5427 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5428 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5431 I32 flags = OPf_SPECIAL;
5435 /* is this op a FH constructor? */
5436 if (is_handle_constructor(o,numargs)) {
5437 const char *name = Nullch;
5441 /* Set a flag to tell rv2gv to vivify
5442 * need to "prove" flag does not mean something
5443 * else already - NI-S 1999/05/07
5446 if (kid->op_type == OP_PADSV) {
5447 name = PAD_COMPNAME_PV(kid->op_targ);
5448 /* SvCUR of a pad namesv can't be trusted
5449 * (see PL_generation), so calc its length
5455 else if (kid->op_type == OP_RV2SV
5456 && kUNOP->op_first->op_type == OP_GV)
5458 GV *gv = cGVOPx_gv(kUNOP->op_first);
5460 len = GvNAMELEN(gv);
5462 else if (kid->op_type == OP_AELEM
5463 || kid->op_type == OP_HELEM)
5468 if ((op = ((BINOP*)kid)->op_first)) {
5469 SV *tmpstr = Nullsv;
5471 kid->op_type == OP_AELEM ?
5473 if (((op->op_type == OP_RV2AV) ||
5474 (op->op_type == OP_RV2HV)) &&
5475 (op = ((UNOP*)op)->op_first) &&
5476 (op->op_type == OP_GV)) {
5477 /* packagevar $a[] or $h{} */
5478 GV *gv = cGVOPx_gv(op);
5486 else if (op->op_type == OP_PADAV
5487 || op->op_type == OP_PADHV) {
5488 /* lexicalvar $a[] or $h{} */
5489 const char *padname =
5490 PAD_COMPNAME_PV(op->op_targ);
5500 name = SvPV(tmpstr, len);
5505 name = "__ANONIO__";
5512 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5513 namesv = PAD_SVl(targ);
5514 (void)SvUPGRADE(namesv, SVt_PV);
5516 sv_setpvn(namesv, "$", 1);
5517 sv_catpvn(namesv, name, len);
5520 kid->op_sibling = 0;
5521 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5522 kid->op_targ = targ;
5523 kid->op_private |= priv;
5525 kid->op_sibling = sibl;
5531 mod(scalar(kid), type);
5535 tokid = &kid->op_sibling;
5536 kid = kid->op_sibling;
5538 o->op_private |= numargs;
5540 return too_many_arguments(o,OP_DESC(o));
5543 else if (PL_opargs[type] & OA_DEFGV) {
5545 return newUNOP(type, 0, newDEFSVOP());
5549 while (oa & OA_OPTIONAL)
5551 if (oa && oa != OA_LIST)
5552 return too_few_arguments(o,OP_DESC(o));
5558 Perl_ck_glob(pTHX_ OP *o)
5564 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5565 append_elem(OP_GLOB, o, newDEFSVOP());
5567 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5568 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5570 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5573 #if !defined(PERL_EXTERNAL_GLOB)
5574 /* XXX this can be tightened up and made more failsafe. */
5575 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5578 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5579 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5580 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5581 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5582 GvCV(gv) = GvCV(glob_gv);
5583 (void)SvREFCNT_inc((SV*)GvCV(gv));
5584 GvIMPORTED_CV_on(gv);
5587 #endif /* PERL_EXTERNAL_GLOB */
5589 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5590 append_elem(OP_GLOB, o,
5591 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5592 o->op_type = OP_LIST;
5593 o->op_ppaddr = PL_ppaddr[OP_LIST];
5594 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5595 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5596 cLISTOPo->op_first->op_targ = 0;
5597 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5598 append_elem(OP_LIST, o,
5599 scalar(newUNOP(OP_RV2CV, 0,
5600 newGVOP(OP_GV, 0, gv)))));
5601 o = newUNOP(OP_NULL, 0, ck_subr(o));
5602 o->op_targ = OP_GLOB; /* hint at what it used to be */
5605 gv = newGVgen("main");
5607 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5613 Perl_ck_grep(pTHX_ OP *o)
5618 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5621 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5622 NewOp(1101, gwop, 1, LOGOP);
5624 if (o->op_flags & OPf_STACKED) {
5627 kid = cLISTOPo->op_first->op_sibling;
5628 if (!cUNOPx(kid)->op_next)
5629 Perl_croak(aTHX_ "panic: ck_grep");
5630 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
5633 kid->op_next = (OP*)gwop;
5634 o->op_flags &= ~OPf_STACKED;
5636 kid = cLISTOPo->op_first->op_sibling;
5637 if (type == OP_MAPWHILE)
5644 kid = cLISTOPo->op_first->op_sibling;
5645 if (kid->op_type != OP_NULL)
5646 Perl_croak(aTHX_ "panic: ck_grep");
5647 kid = kUNOP->op_first;
5649 gwop->op_type = type;
5650 gwop->op_ppaddr = PL_ppaddr[type];
5651 gwop->op_first = listkids(o);
5652 gwop->op_flags |= OPf_KIDS;
5653 gwop->op_other = LINKLIST(kid);
5654 kid->op_next = (OP*)gwop;
5655 offset = pad_findmy("$_");
5656 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
5657 o->op_private = gwop->op_private = 0;
5658 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5661 o->op_private = gwop->op_private = OPpGREP_LEX;
5662 gwop->op_targ = o->op_targ = offset;
5665 kid = cLISTOPo->op_first->op_sibling;
5666 if (!kid || !kid->op_sibling)
5667 return too_few_arguments(o,OP_DESC(o));
5668 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5669 mod(kid, OP_GREPSTART);
5675 Perl_ck_index(pTHX_ OP *o)
5677 if (o->op_flags & OPf_KIDS) {
5678 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5680 kid = kid->op_sibling; /* get past "big" */
5681 if (kid && kid->op_type == OP_CONST)
5682 fbm_compile(((SVOP*)kid)->op_sv, 0);
5688 Perl_ck_lengthconst(pTHX_ OP *o)
5690 /* XXX length optimization goes here */
5695 Perl_ck_lfun(pTHX_ OP *o)
5697 const OPCODE type = o->op_type;
5698 return modkids(ck_fun(o), type);
5702 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5704 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5705 switch (cUNOPo->op_first->op_type) {
5707 /* This is needed for
5708 if (defined %stash::)
5709 to work. Do not break Tk.
5711 break; /* Globals via GV can be undef */
5713 case OP_AASSIGN: /* Is this a good idea? */
5714 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5715 "defined(@array) is deprecated");
5716 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5717 "\t(Maybe you should just omit the defined()?)\n");
5720 /* This is needed for
5721 if (defined %stash::)
5722 to work. Do not break Tk.
5724 break; /* Globals via GV can be undef */
5726 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5727 "defined(%%hash) is deprecated");
5728 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5729 "\t(Maybe you should just omit the defined()?)\n");
5740 Perl_ck_rfun(pTHX_ OP *o)
5742 const OPCODE type = o->op_type;
5743 return refkids(ck_fun(o), type);
5747 Perl_ck_listiob(pTHX_ OP *o)
5751 kid = cLISTOPo->op_first;
5754 kid = cLISTOPo->op_first;
5756 if (kid->op_type == OP_PUSHMARK)
5757 kid = kid->op_sibling;
5758 if (kid && o->op_flags & OPf_STACKED)
5759 kid = kid->op_sibling;
5760 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5761 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5762 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5763 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5764 cLISTOPo->op_first->op_sibling = kid;
5765 cLISTOPo->op_last = kid;
5766 kid = kid->op_sibling;
5771 append_elem(o->op_type, o, newDEFSVOP());
5777 Perl_ck_sassign(pTHX_ OP *o)
5779 OP *kid = cLISTOPo->op_first;
5780 /* has a disposable target? */
5781 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5782 && !(kid->op_flags & OPf_STACKED)
5783 /* Cannot steal the second time! */
5784 && !(kid->op_private & OPpTARGET_MY))
5786 OP *kkid = kid->op_sibling;
5788 /* Can just relocate the target. */
5789 if (kkid && kkid->op_type == OP_PADSV
5790 && !(kkid->op_private & OPpLVAL_INTRO))
5792 kid->op_targ = kkid->op_targ;
5794 /* Now we do not need PADSV and SASSIGN. */
5795 kid->op_sibling = o->op_sibling; /* NULL */
5796 cLISTOPo->op_first = NULL;
5799 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
5803 /* optimise C<my $x = undef> to C<my $x> */
5804 if (kid->op_type == OP_UNDEF) {
5805 OP *kkid = kid->op_sibling;
5806 if (kkid && kkid->op_type == OP_PADSV
5807 && (kkid->op_private & OPpLVAL_INTRO))
5809 cLISTOPo->op_first = NULL;
5810 kid->op_sibling = NULL;
5820 Perl_ck_match(pTHX_ OP *o)
5822 if (o->op_type != OP_QR) {
5823 const I32 offset = pad_findmy("$_");
5824 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS(offset) & SVpad_OUR)) {
5825 o->op_targ = offset;
5826 o->op_private |= OPpTARGET_MY;
5829 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
5830 o->op_private |= OPpRUNTIME;
5835 Perl_ck_method(pTHX_ OP *o)
5837 OP *kid = cUNOPo->op_first;
5838 if (kid->op_type == OP_CONST) {
5839 SV* sv = kSVOP->op_sv;
5840 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
5842 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5843 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
5846 kSVOP->op_sv = Nullsv;
5848 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5857 Perl_ck_null(pTHX_ OP *o)
5863 Perl_ck_open(pTHX_ OP *o)
5865 HV *table = GvHV(PL_hintgv);
5869 svp = hv_fetch(table, "open_IN", 7, FALSE);
5871 mode = mode_from_discipline(*svp);
5872 if (mode & O_BINARY)
5873 o->op_private |= OPpOPEN_IN_RAW;
5874 else if (mode & O_TEXT)
5875 o->op_private |= OPpOPEN_IN_CRLF;
5878 svp = hv_fetch(table, "open_OUT", 8, FALSE);
5880 mode = mode_from_discipline(*svp);
5881 if (mode & O_BINARY)
5882 o->op_private |= OPpOPEN_OUT_RAW;
5883 else if (mode & O_TEXT)
5884 o->op_private |= OPpOPEN_OUT_CRLF;
5887 if (o->op_type == OP_BACKTICK)
5890 /* In case of three-arg dup open remove strictness
5891 * from the last arg if it is a bareword. */
5892 OP *first = cLISTOPx(o)->op_first; /* The pushmark. */
5893 OP *last = cLISTOPx(o)->op_last; /* The bareword. */
5897 if ((last->op_type == OP_CONST) && /* The bareword. */
5898 (last->op_private & OPpCONST_BARE) &&
5899 (last->op_private & OPpCONST_STRICT) &&
5900 (oa = first->op_sibling) && /* The fh. */
5901 (oa = oa->op_sibling) && /* The mode. */
5902 SvPOK(((SVOP*)oa)->op_sv) &&
5903 (mode = SvPVX(((SVOP*)oa)->op_sv)) &&
5904 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
5905 (last == oa->op_sibling)) /* The bareword. */
5906 last->op_private &= ~OPpCONST_STRICT;
5912 Perl_ck_repeat(pTHX_ OP *o)
5914 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5915 o->op_private |= OPpREPEAT_DOLIST;
5916 cBINOPo->op_first = force_list(cBINOPo->op_first);
5924 Perl_ck_require(pTHX_ OP *o)
5928 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
5929 SVOP *kid = (SVOP*)cUNOPo->op_first;
5931 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5933 for (s = SvPVX(kid->op_sv); *s; s++) {
5934 if (*s == ':' && s[1] == ':') {
5936 Move(s+2, s+1, strlen(s+2)+1, char);
5937 SvCUR_set(kid->op_sv, SvCUR(kid->op_sv) - 1);
5940 if (SvREADONLY(kid->op_sv)) {
5941 SvREADONLY_off(kid->op_sv);
5942 sv_catpvn(kid->op_sv, ".pm", 3);
5943 SvREADONLY_on(kid->op_sv);
5946 sv_catpvn(kid->op_sv, ".pm", 3);
5950 /* handle override, if any */
5951 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
5952 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
5953 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
5955 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5956 OP *kid = cUNOPo->op_first;
5957 cUNOPo->op_first = 0;
5959 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5960 append_elem(OP_LIST, kid,
5961 scalar(newUNOP(OP_RV2CV, 0,
5970 Perl_ck_return(pTHX_ OP *o)
5972 if (CvLVALUE(PL_compcv)) {
5974 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5975 mod(kid, OP_LEAVESUBLV);
5982 Perl_ck_retarget(pTHX_ OP *o)
5984 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5991 Perl_ck_select(pTHX_ OP *o)
5995 if (o->op_flags & OPf_KIDS) {
5996 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5997 if (kid && kid->op_sibling) {
5998 o->op_type = OP_SSELECT;
5999 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6001 return fold_constants(o);
6005 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6006 if (kid && kid->op_type == OP_RV2GV)
6007 kid->op_private &= ~HINT_STRICT_REFS;
6012 Perl_ck_shift(pTHX_ OP *o)
6014 const I32 type = o->op_type;
6016 if (!(o->op_flags & OPf_KIDS)) {
6020 argop = newUNOP(OP_RV2AV, 0,
6021 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
6022 return newUNOP(type, 0, scalar(argop));
6024 return scalar(modkids(ck_fun(o), type));
6028 Perl_ck_sort(pTHX_ OP *o)
6032 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6034 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6035 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6037 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6039 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6041 if (kid->op_type == OP_SCOPE) {
6045 else if (kid->op_type == OP_LEAVE) {
6046 if (o->op_type == OP_SORT) {
6047 op_null(kid); /* wipe out leave */
6050 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6051 if (k->op_next == kid)
6053 /* don't descend into loops */
6054 else if (k->op_type == OP_ENTERLOOP
6055 || k->op_type == OP_ENTERITER)
6057 k = cLOOPx(k)->op_lastop;
6062 kid->op_next = 0; /* just disconnect the leave */
6063 k = kLISTOP->op_first;
6068 if (o->op_type == OP_SORT) {
6069 /* provide scalar context for comparison function/block */
6075 o->op_flags |= OPf_SPECIAL;
6077 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6080 firstkid = firstkid->op_sibling;
6083 /* provide list context for arguments */
6084 if (o->op_type == OP_SORT)
6091 S_simplify_sort(pTHX_ OP *o)
6093 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6098 if (!(o->op_flags & OPf_STACKED))
6100 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6101 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6102 kid = kUNOP->op_first; /* get past null */
6103 if (kid->op_type != OP_SCOPE)
6105 kid = kLISTOP->op_last; /* get past scope */
6106 switch(kid->op_type) {
6114 k = kid; /* remember this node*/
6115 if (kBINOP->op_first->op_type != OP_RV2SV)
6117 kid = kBINOP->op_first; /* get past cmp */
6118 if (kUNOP->op_first->op_type != OP_GV)
6120 kid = kUNOP->op_first; /* get past rv2sv */
6122 if (GvSTASH(gv) != PL_curstash)
6124 gvname = GvNAME(gv);
6125 if (*gvname == 'a' && gvname[1] == '\0')
6127 else if (*gvname == 'b' && gvname[1] == '\0')
6132 kid = k; /* back to cmp */
6133 if (kBINOP->op_last->op_type != OP_RV2SV)
6135 kid = kBINOP->op_last; /* down to 2nd arg */
6136 if (kUNOP->op_first->op_type != OP_GV)
6138 kid = kUNOP->op_first; /* get past rv2sv */
6140 if (GvSTASH(gv) != PL_curstash)
6142 gvname = GvNAME(gv);
6144 ? !(*gvname == 'a' && gvname[1] == '\0')
6145 : !(*gvname == 'b' && gvname[1] == '\0'))
6147 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6149 o->op_private |= OPpSORT_DESCEND;
6150 if (k->op_type == OP_NCMP)
6151 o->op_private |= OPpSORT_NUMERIC;
6152 if (k->op_type == OP_I_NCMP)
6153 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6154 kid = cLISTOPo->op_first->op_sibling;
6155 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6156 op_free(kid); /* then delete it */
6160 Perl_ck_split(pTHX_ OP *o)
6165 if (o->op_flags & OPf_STACKED)
6166 return no_fh_allowed(o);
6168 kid = cLISTOPo->op_first;
6169 if (kid->op_type != OP_NULL)
6170 Perl_croak(aTHX_ "panic: ck_split");
6171 kid = kid->op_sibling;
6172 op_free(cLISTOPo->op_first);
6173 cLISTOPo->op_first = kid;
6175 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6176 cLISTOPo->op_last = kid; /* There was only one element previously */
6179 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6180 OP *sibl = kid->op_sibling;
6181 kid->op_sibling = 0;
6182 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
6183 if (cLISTOPo->op_first == cLISTOPo->op_last)
6184 cLISTOPo->op_last = kid;
6185 cLISTOPo->op_first = kid;
6186 kid->op_sibling = sibl;
6189 kid->op_type = OP_PUSHRE;
6190 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6192 if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
6193 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
6194 "Use of /g modifier is meaningless in split");
6197 if (!kid->op_sibling)
6198 append_elem(OP_SPLIT, o, newDEFSVOP());
6200 kid = kid->op_sibling;
6203 if (!kid->op_sibling)
6204 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6206 kid = kid->op_sibling;
6209 if (kid->op_sibling)
6210 return too_many_arguments(o,OP_DESC(o));
6216 Perl_ck_join(pTHX_ OP *o)
6218 if (ckWARN(WARN_SYNTAX)) {
6219 const OP *kid = cLISTOPo->op_first->op_sibling;
6220 if (kid && kid->op_type == OP_MATCH) {
6221 const REGEXP *re = PM_GETRE(kPMOP);
6222 const char *pmstr = re ? re->precomp : "STRING";
6223 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6224 "/%s/ should probably be written as \"%s\"",
6232 Perl_ck_subr(pTHX_ OP *o)
6234 OP *prev = ((cUNOPo->op_first->op_sibling)
6235 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6236 OP *o2 = prev->op_sibling;
6243 I32 contextclass = 0;
6248 o->op_private |= OPpENTERSUB_HASTARG;
6249 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6250 if (cvop->op_type == OP_RV2CV) {
6252 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6253 op_null(cvop); /* disable rv2cv */
6254 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6255 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6256 GV *gv = cGVOPx_gv(tmpop);
6259 tmpop->op_private |= OPpEARLY_CV;
6262 namegv = CvANON(cv) ? gv : CvGV(cv);
6263 proto = SvPV((SV*)cv, n_a);
6265 if (CvASSERTION(cv)) {
6266 if (PL_hints & HINT_ASSERTING) {
6267 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
6268 o->op_private |= OPpENTERSUB_DB;
6272 if (ckWARN(WARN_ASSERTIONS) && !(PL_hints & HINT_ASSERTIONSSEEN)) {
6273 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
6274 "Impossible to activate assertion call");
6281 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6282 if (o2->op_type == OP_CONST)
6283 o2->op_private &= ~OPpCONST_STRICT;
6284 else if (o2->op_type == OP_LIST) {
6285 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6286 if (o && o->op_type == OP_CONST)
6287 o->op_private &= ~OPpCONST_STRICT;
6290 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6291 if (PERLDB_SUB && PL_curstash != PL_debstash)
6292 o->op_private |= OPpENTERSUB_DB;
6293 while (o2 != cvop) {
6297 return too_many_arguments(o, gv_ename(namegv));
6315 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6317 arg == 1 ? "block or sub {}" : "sub {}",
6318 gv_ename(namegv), o2);
6321 /* '*' allows any scalar type, including bareword */
6324 if (o2->op_type == OP_RV2GV)
6325 goto wrapref; /* autoconvert GLOB -> GLOBref */
6326 else if (o2->op_type == OP_CONST)
6327 o2->op_private &= ~OPpCONST_STRICT;
6328 else if (o2->op_type == OP_ENTERSUB) {
6329 /* accidental subroutine, revert to bareword */
6330 OP *gvop = ((UNOP*)o2)->op_first;
6331 if (gvop && gvop->op_type == OP_NULL) {
6332 gvop = ((UNOP*)gvop)->op_first;
6334 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6337 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6338 (gvop = ((UNOP*)gvop)->op_first) &&
6339 gvop->op_type == OP_GV)
6341 GV *gv = cGVOPx_gv(gvop);
6342 OP *sibling = o2->op_sibling;
6343 SV *n = newSVpvn("",0);
6345 gv_fullname4(n, gv, "", FALSE);
6346 o2 = newSVOP(OP_CONST, 0, n);
6347 prev->op_sibling = o2;
6348 o2->op_sibling = sibling;
6364 if (contextclass++ == 0) {
6365 e = strchr(proto, ']');
6366 if (!e || e == proto)
6379 while (*--p != '[');
6380 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6381 gv_ename(namegv), o2);
6387 if (o2->op_type == OP_RV2GV)
6390 bad_type(arg, "symbol", gv_ename(namegv), o2);
6393 if (o2->op_type == OP_ENTERSUB)
6396 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6399 if (o2->op_type == OP_RV2SV ||
6400 o2->op_type == OP_PADSV ||
6401 o2->op_type == OP_HELEM ||
6402 o2->op_type == OP_AELEM ||
6403 o2->op_type == OP_THREADSV)
6406 bad_type(arg, "scalar", gv_ename(namegv), o2);
6409 if (o2->op_type == OP_RV2AV ||
6410 o2->op_type == OP_PADAV)
6413 bad_type(arg, "array", gv_ename(namegv), o2);
6416 if (o2->op_type == OP_RV2HV ||
6417 o2->op_type == OP_PADHV)
6420 bad_type(arg, "hash", gv_ename(namegv), o2);
6425 OP* sib = kid->op_sibling;
6426 kid->op_sibling = 0;
6427 o2 = newUNOP(OP_REFGEN, 0, kid);
6428 o2->op_sibling = sib;
6429 prev->op_sibling = o2;
6431 if (contextclass && e) {
6446 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6447 gv_ename(namegv), cv);
6452 mod(o2, OP_ENTERSUB);
6454 o2 = o2->op_sibling;
6456 if (proto && !optional &&
6457 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6458 return too_few_arguments(o, gv_ename(namegv));
6461 o=newSVOP(OP_CONST, 0, newSViv(0));
6467 Perl_ck_svconst(pTHX_ OP *o)
6469 SvREADONLY_on(cSVOPo->op_sv);
6474 Perl_ck_trunc(pTHX_ OP *o)
6476 if (o->op_flags & OPf_KIDS) {
6477 SVOP *kid = (SVOP*)cUNOPo->op_first;
6479 if (kid->op_type == OP_NULL)
6480 kid = (SVOP*)kid->op_sibling;
6481 if (kid && kid->op_type == OP_CONST &&
6482 (kid->op_private & OPpCONST_BARE))
6484 o->op_flags |= OPf_SPECIAL;
6485 kid->op_private &= ~OPpCONST_STRICT;
6492 Perl_ck_unpack(pTHX_ OP *o)
6494 OP *kid = cLISTOPo->op_first;
6495 if (kid->op_sibling) {
6496 kid = kid->op_sibling;
6497 if (!kid->op_sibling)
6498 kid->op_sibling = newDEFSVOP();
6504 Perl_ck_substr(pTHX_ OP *o)
6507 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6508 OP *kid = cLISTOPo->op_first;
6510 if (kid->op_type == OP_NULL)
6511 kid = kid->op_sibling;
6513 kid->op_flags |= OPf_MOD;
6519 /* A peephole optimizer. We visit the ops in the order they're to execute.
6520 * See the comments at the top of this file for more details about when
6521 * peep() is called */
6524 Perl_peep(pTHX_ register OP *o)
6527 register OP* oldop = 0;
6529 if (!o || o->op_opt)
6533 SAVEVPTR(PL_curcop);
6534 for (; o; o = o->op_next) {
6538 switch (o->op_type) {
6542 PL_curcop = ((COP*)o); /* for warnings */
6547 if (cSVOPo->op_private & OPpCONST_STRICT)
6548 no_bareword_allowed(o);
6550 case OP_METHOD_NAMED:
6551 /* Relocate sv to the pad for thread safety.
6552 * Despite being a "constant", the SV is written to,
6553 * for reference counts, sv_upgrade() etc. */
6555 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6556 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6557 /* If op_sv is already a PADTMP then it is being used by
6558 * some pad, so make a copy. */
6559 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6560 SvREADONLY_on(PAD_SVl(ix));
6561 SvREFCNT_dec(cSVOPo->op_sv);
6564 SvREFCNT_dec(PAD_SVl(ix));
6565 SvPADTMP_on(cSVOPo->op_sv);
6566 PAD_SETSV(ix, cSVOPo->op_sv);
6567 /* XXX I don't know how this isn't readonly already. */
6568 SvREADONLY_on(PAD_SVl(ix));
6570 cSVOPo->op_sv = Nullsv;
6578 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6579 if (o->op_next->op_private & OPpTARGET_MY) {
6580 if (o->op_flags & OPf_STACKED) /* chained concats */
6581 goto ignore_optimization;
6583 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6584 o->op_targ = o->op_next->op_targ;
6585 o->op_next->op_targ = 0;
6586 o->op_private |= OPpTARGET_MY;
6589 op_null(o->op_next);
6591 ignore_optimization:
6595 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6597 break; /* Scalar stub must produce undef. List stub is noop */
6601 if (o->op_targ == OP_NEXTSTATE
6602 || o->op_targ == OP_DBSTATE
6603 || o->op_targ == OP_SETSTATE)
6605 PL_curcop = ((COP*)o);
6607 /* XXX: We avoid setting op_seq here to prevent later calls
6608 to peep() from mistakenly concluding that optimisation
6609 has already occurred. This doesn't fix the real problem,
6610 though (See 20010220.007). AMS 20010719 */
6611 /* op_seq functionality is now replaced by op_opt */
6612 if (oldop && o->op_next) {
6613 oldop->op_next = o->op_next;
6621 if (oldop && o->op_next) {
6622 oldop->op_next = o->op_next;
6630 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
6631 OP* pop = (o->op_type == OP_PADAV) ?
6632 o->op_next : o->op_next->op_next;
6634 if (pop && pop->op_type == OP_CONST &&
6635 ((PL_op = pop->op_next)) &&
6636 pop->op_next->op_type == OP_AELEM &&
6637 !(pop->op_next->op_private &
6638 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6639 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6644 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
6645 no_bareword_allowed(pop);
6646 if (o->op_type == OP_GV)
6647 op_null(o->op_next);
6648 op_null(pop->op_next);
6650 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6651 o->op_next = pop->op_next->op_next;
6652 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6653 o->op_private = (U8)i;
6654 if (o->op_type == OP_GV) {
6659 o->op_flags |= OPf_SPECIAL;
6660 o->op_type = OP_AELEMFAST;
6666 if (o->op_next->op_type == OP_RV2SV) {
6667 if (!(o->op_next->op_private & OPpDEREF)) {
6668 op_null(o->op_next);
6669 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6671 o->op_next = o->op_next->op_next;
6672 o->op_type = OP_GVSV;
6673 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6676 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6678 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6679 /* XXX could check prototype here instead of just carping */
6680 SV *sv = sv_newmortal();
6681 gv_efullname3(sv, gv, Nullch);
6682 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6683 "%"SVf"() called too early to check prototype",
6687 else if (o->op_next->op_type == OP_READLINE
6688 && o->op_next->op_next->op_type == OP_CONCAT
6689 && (o->op_next->op_next->op_flags & OPf_STACKED))
6691 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6692 o->op_type = OP_RCATLINE;
6693 o->op_flags |= OPf_STACKED;
6694 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6695 op_null(o->op_next->op_next);
6696 op_null(o->op_next);
6713 while (cLOGOP->op_other->op_type == OP_NULL)
6714 cLOGOP->op_other = cLOGOP->op_other->op_next;
6715 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6721 while (cLOOP->op_redoop->op_type == OP_NULL)
6722 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6723 peep(cLOOP->op_redoop);
6724 while (cLOOP->op_nextop->op_type == OP_NULL)
6725 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6726 peep(cLOOP->op_nextop);
6727 while (cLOOP->op_lastop->op_type == OP_NULL)
6728 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6729 peep(cLOOP->op_lastop);
6736 while (cPMOP->op_pmreplstart &&
6737 cPMOP->op_pmreplstart->op_type == OP_NULL)
6738 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6739 peep(cPMOP->op_pmreplstart);
6744 if (ckWARN(WARN_SYNTAX) && o->op_next
6745 && o->op_next->op_type == OP_NEXTSTATE) {
6746 if (o->op_next->op_sibling &&
6747 o->op_next->op_sibling->op_type != OP_EXIT &&
6748 o->op_next->op_sibling->op_type != OP_WARN &&
6749 o->op_next->op_sibling->op_type != OP_DIE) {
6750 const line_t oldline = CopLINE(PL_curcop);
6752 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6753 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6754 "Statement unlikely to be reached");
6755 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6756 "\t(Maybe you meant system() when you said exec()?)\n");
6757 CopLINE_set(PL_curcop, oldline);
6772 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6775 /* Make the CONST have a shared SV */
6776 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6777 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6778 key = SvPV(sv, keylen);
6779 lexname = newSVpvn_share(key,
6780 SvUTF8(sv) ? -(I32)keylen : keylen,
6786 if ((o->op_private & (OPpLVAL_INTRO)))
6789 rop = (UNOP*)((BINOP*)o)->op_first;
6790 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6792 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6793 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6795 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6796 if (!fields || !GvHV(*fields))
6798 key = SvPV(*svp, keylen);
6799 if (!hv_fetch(GvHV(*fields), key,
6800 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
6802 Perl_croak(aTHX_ "No such class field \"%s\" "
6803 "in variable %s of type %s",
6804 key, SvPV_nolen(lexname), HvNAME(SvSTASH(lexname)));
6817 SVOP *first_key_op, *key_op;
6819 if ((o->op_private & (OPpLVAL_INTRO))
6820 /* I bet there's always a pushmark... */
6821 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6822 /* hmmm, no optimization if list contains only one key. */
6824 rop = (UNOP*)((LISTOP*)o)->op_last;
6825 if (rop->op_type != OP_RV2HV)
6827 if (rop->op_first->op_type == OP_PADSV)
6828 /* @$hash{qw(keys here)} */
6829 rop = (UNOP*)rop->op_first;
6831 /* @{$hash}{qw(keys here)} */
6832 if (rop->op_first->op_type == OP_SCOPE
6833 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
6835 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
6841 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
6842 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6844 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6845 if (!fields || !GvHV(*fields))
6847 /* Again guessing that the pushmark can be jumped over.... */
6848 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
6849 ->op_first->op_sibling;
6850 for (key_op = first_key_op; key_op;
6851 key_op = (SVOP*)key_op->op_sibling) {
6852 if (key_op->op_type != OP_CONST)
6854 svp = cSVOPx_svp(key_op);
6855 key = SvPV(*svp, keylen);
6856 if (!hv_fetch(GvHV(*fields), key,
6857 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
6859 Perl_croak(aTHX_ "No such class field \"%s\" "
6860 "in variable %s of type %s",
6861 key, SvPV_nolen(lexname), HvNAME(SvSTASH(lexname)));
6868 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
6872 /* check that RHS of sort is a single plain array */
6873 oright = cUNOPo->op_first;
6874 if (!oright || oright->op_type != OP_PUSHMARK)
6877 /* reverse sort ... can be optimised. */
6878 if (!cUNOPo->op_sibling) {
6879 /* Nothing follows us on the list. */
6880 OP *reverse = o->op_next;
6882 if (reverse->op_type == OP_REVERSE &&
6883 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
6884 OP *pushmark = cUNOPx(reverse)->op_first;
6885 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
6886 && (cUNOPx(pushmark)->op_sibling == o)) {
6887 /* reverse -> pushmark -> sort */
6888 o->op_private |= OPpSORT_REVERSE;
6890 pushmark->op_next = oright->op_next;
6896 /* make @a = sort @a act in-place */
6900 oright = cUNOPx(oright)->op_sibling;
6903 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
6904 oright = cUNOPx(oright)->op_sibling;
6908 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
6909 || oright->op_next != o
6910 || (oright->op_private & OPpLVAL_INTRO)
6914 /* o2 follows the chain of op_nexts through the LHS of the
6915 * assign (if any) to the aassign op itself */
6917 if (!o2 || o2->op_type != OP_NULL)
6920 if (!o2 || o2->op_type != OP_PUSHMARK)
6923 if (o2 && o2->op_type == OP_GV)
6926 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
6927 || (o2->op_private & OPpLVAL_INTRO)
6932 if (!o2 || o2->op_type != OP_NULL)
6935 if (!o2 || o2->op_type != OP_AASSIGN
6936 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
6939 /* check that the sort is the first arg on RHS of assign */
6941 o2 = cUNOPx(o2)->op_first;
6942 if (!o2 || o2->op_type != OP_NULL)
6944 o2 = cUNOPx(o2)->op_first;
6945 if (!o2 || o2->op_type != OP_PUSHMARK)
6947 if (o2->op_sibling != o)
6950 /* check the array is the same on both sides */
6951 if (oleft->op_type == OP_RV2AV) {
6952 if (oright->op_type != OP_RV2AV
6953 || !cUNOPx(oright)->op_first
6954 || cUNOPx(oright)->op_first->op_type != OP_GV
6955 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
6956 cGVOPx_gv(cUNOPx(oright)->op_first)
6960 else if (oright->op_type != OP_PADAV
6961 || oright->op_targ != oleft->op_targ
6965 /* transfer MODishness etc from LHS arg to RHS arg */
6966 oright->op_flags = oleft->op_flags;
6967 o->op_private |= OPpSORT_INPLACE;
6969 /* excise push->gv->rv2av->null->aassign */
6970 o2 = o->op_next->op_next;
6971 op_null(o2); /* PUSHMARK */
6973 if (o2->op_type == OP_GV) {
6974 op_null(o2); /* GV */
6977 op_null(o2); /* RV2AV or PADAV */
6978 o2 = o2->op_next->op_next;
6979 op_null(o2); /* AASSIGN */
6981 o->op_next = o2->op_next;
6987 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
6989 LISTOP *enter, *exlist;
6992 enter = (LISTOP *) o->op_next;
6995 if (enter->op_type == OP_NULL) {
6996 enter = (LISTOP *) enter->op_next;
7000 /* for $a (...) will have OP_GV then OP_RV2GV here.
7001 for (...) just has an OP_GV. */
7002 if (enter->op_type == OP_GV) {
7003 gvop = (OP *) enter;
7004 enter = (LISTOP *) enter->op_next;
7007 if (enter->op_type == OP_RV2GV) {
7008 enter = (LISTOP *) enter->op_next;
7014 if (enter->op_type != OP_ENTERITER)
7017 iter = enter->op_next;
7018 if (!iter || iter->op_type != OP_ITER)
7021 expushmark = enter->op_first;
7022 if (!expushmark || expushmark->op_type != OP_NULL
7023 || expushmark->op_targ != OP_PUSHMARK)
7026 exlist = (LISTOP *) expushmark->op_sibling;
7027 if (!exlist || exlist->op_type != OP_NULL
7028 || exlist->op_targ != OP_LIST)
7031 if (exlist->op_last != o) {
7032 /* Mmm. Was expecting to point back to this op. */
7035 theirmark = exlist->op_first;
7036 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
7039 if (theirmark->op_sibling != o) {
7040 /* There's something between the mark and the reverse, eg
7041 for (1, reverse (...))
7046 ourmark = ((LISTOP *)o)->op_first;
7047 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
7050 ourlast = ((LISTOP *)o)->op_last;
7051 if (!ourlast || ourlast->op_next != o)
7054 rv2av = ourmark->op_sibling;
7055 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
7056 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
7057 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
7058 /* We're just reversing a single array. */
7059 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
7060 enter->op_flags |= OPf_STACKED;
7063 /* We don't have control over who points to theirmark, so sacrifice
7065 theirmark->op_next = ourmark->op_next;
7066 theirmark->op_flags = ourmark->op_flags;
7067 ourlast->op_next = gvop ? gvop : (OP *) enter;
7070 enter->op_private |= OPpITER_REVERSED;
7071 iter->op_private |= OPpITER_REVERSED;
7086 Perl_custom_op_name(pTHX_ const OP* o)
7088 const IV index = PTR2IV(o->op_ppaddr);
7092 if (!PL_custom_op_names) /* This probably shouldn't happen */
7093 return (char *)PL_op_name[OP_CUSTOM];
7095 keysv = sv_2mortal(newSViv(index));
7097 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7099 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7101 return SvPV_nolen(HeVAL(he));
7105 Perl_custom_op_desc(pTHX_ const OP* o)
7107 const IV index = PTR2IV(o->op_ppaddr);
7111 if (!PL_custom_op_descs)
7112 return (char *)PL_op_desc[OP_CUSTOM];
7114 keysv = sv_2mortal(newSViv(index));
7116 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7118 return (char *)PL_op_desc[OP_CUSTOM];
7120 return SvPV_nolen(HeVAL(he));
7125 /* Efficient sub that returns a constant scalar value. */
7127 const_sv_xsub(pTHX_ CV* cv)
7132 Perl_croak(aTHX_ "usage: %s::%s()",
7133 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7137 ST(0) = (SV*)XSANY.any_ptr;
7143 * c-indentation-style: bsd
7145 * indent-tabs-mode: t
7148 * ex: set ts=8 sts=4 sw=4 noet: