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 MAGIC *mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab);
412 PMOP *pmop = (PMOP*) mg->mg_obj;
413 PMOP *lastpmop = NULL;
415 if (cPMOPo == pmop) {
417 lastpmop->op_pmnext = pmop->op_pmnext;
419 mg->mg_obj = (SV*) pmop->op_pmnext;
423 pmop = pmop->op_pmnext;
427 PmopSTASH_free(cPMOPo);
429 cPMOPo->op_pmreplroot = Nullop;
430 /* we use the "SAFE" version of the PM_ macros here
431 * since sv_clean_all might release some PMOPs
432 * after PL_regex_padav has been cleared
433 * and the clearing of PL_regex_padav needs to
434 * happen before sv_clean_all
436 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
437 PM_SETRE_SAFE(cPMOPo, (REGEXP*)NULL);
439 if(PL_regex_pad) { /* We could be in destruction */
440 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
441 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
442 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
449 if (o->op_targ > 0) {
450 pad_free(o->op_targ);
456 S_cop_free(pTHX_ COP* cop)
458 Safefree(cop->cop_label); /* FIXME: treaddead ??? */
461 if (! specialWARN(cop->cop_warnings))
462 SvREFCNT_dec(cop->cop_warnings);
463 if (! specialCopIO(cop->cop_io)) {
467 char *s = SvPV(cop->cop_io,len);
468 Perl_warn(aTHX_ "io='%.*s'",(int) len,s); /* ??? --jhi */
471 SvREFCNT_dec(cop->cop_io);
477 Perl_op_null(pTHX_ OP *o)
480 if (o->op_type == OP_NULL)
483 o->op_targ = o->op_type;
484 o->op_type = OP_NULL;
485 o->op_ppaddr = PL_ppaddr[OP_NULL];
489 Perl_op_refcnt_lock(pTHX)
496 Perl_op_refcnt_unlock(pTHX)
502 /* Contextualizers */
504 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
507 Perl_linklist(pTHX_ OP *o)
513 /* establish postfix order */
514 if (cUNOPo->op_first) {
516 o->op_next = LINKLIST(cUNOPo->op_first);
517 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
519 kid->op_next = LINKLIST(kid->op_sibling);
531 Perl_scalarkids(pTHX_ OP *o)
533 if (o && o->op_flags & OPf_KIDS) {
535 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
542 S_scalarboolean(pTHX_ OP *o)
544 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
545 if (ckWARN(WARN_SYNTAX)) {
546 const line_t oldline = CopLINE(PL_curcop);
548 if (PL_copline != NOLINE)
549 CopLINE_set(PL_curcop, PL_copline);
550 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
551 CopLINE_set(PL_curcop, oldline);
558 Perl_scalar(pTHX_ OP *o)
563 /* assumes no premature commitment */
564 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
565 || o->op_type == OP_RETURN)
570 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
572 switch (o->op_type) {
574 scalar(cBINOPo->op_first);
579 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
583 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
584 if (!kPMOP->op_pmreplroot)
585 deprecate_old("implicit split to @_");
593 if (o->op_flags & OPf_KIDS) {
594 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
600 kid = cLISTOPo->op_first;
602 while ((kid = kid->op_sibling)) {
608 WITH_THR(PL_curcop = &PL_compiling);
613 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
619 WITH_THR(PL_curcop = &PL_compiling);
622 if (ckWARN(WARN_VOID))
623 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
629 Perl_scalarvoid(pTHX_ OP *o)
633 const char* useless = 0;
637 if (o->op_type == OP_NEXTSTATE
638 || o->op_type == OP_SETSTATE
639 || o->op_type == OP_DBSTATE
640 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
641 || o->op_targ == OP_SETSTATE
642 || o->op_targ == OP_DBSTATE)))
643 PL_curcop = (COP*)o; /* for warning below */
645 /* assumes no premature commitment */
646 want = o->op_flags & OPf_WANT;
647 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
648 || o->op_type == OP_RETURN)
653 if ((o->op_private & OPpTARGET_MY)
654 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
656 return scalar(o); /* As if inside SASSIGN */
659 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
661 switch (o->op_type) {
663 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
667 if (o->op_flags & OPf_STACKED)
671 if (o->op_private == 4)
743 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
744 useless = OP_DESC(o);
748 kid = cUNOPo->op_first;
749 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
750 kid->op_type != OP_TRANS) {
753 useless = "negative pattern binding (!~)";
760 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
761 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
762 useless = "a variable";
767 if (cSVOPo->op_private & OPpCONST_STRICT)
768 no_bareword_allowed(o);
770 if (ckWARN(WARN_VOID)) {
771 useless = "a constant";
772 /* don't warn on optimised away booleans, eg
773 * use constant Foo, 5; Foo || print; */
774 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
776 /* the constants 0 and 1 are permitted as they are
777 conventionally used as dummies in constructs like
778 1 while some_condition_with_side_effects; */
779 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
781 else if (SvPOK(sv)) {
782 /* perl4's way of mixing documentation and code
783 (before the invention of POD) was based on a
784 trick to mix nroff and perl code. The trick was
785 built upon these three nroff macros being used in
786 void context. The pink camel has the details in
787 the script wrapman near page 319. */
788 if (strnEQ(SvPVX_const(sv), "di", 2) ||
789 strnEQ(SvPVX_const(sv), "ds", 2) ||
790 strnEQ(SvPVX_const(sv), "ig", 2))
795 op_null(o); /* don't execute or even remember it */
799 o->op_type = OP_PREINC; /* pre-increment is faster */
800 o->op_ppaddr = PL_ppaddr[OP_PREINC];
804 o->op_type = OP_PREDEC; /* pre-decrement is faster */
805 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
812 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
817 if (o->op_flags & OPf_STACKED)
824 if (!(o->op_flags & OPf_KIDS))
833 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
840 /* all requires must return a boolean value */
841 o->op_flags &= ~OPf_WANT;
846 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
847 if (!kPMOP->op_pmreplroot)
848 deprecate_old("implicit split to @_");
852 if (useless && ckWARN(WARN_VOID))
853 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
858 Perl_listkids(pTHX_ OP *o)
860 if (o && o->op_flags & OPf_KIDS) {
862 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
869 Perl_list(pTHX_ OP *o)
874 /* assumes no premature commitment */
875 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
876 || o->op_type == OP_RETURN)
881 if ((o->op_private & OPpTARGET_MY)
882 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
884 return o; /* As if inside SASSIGN */
887 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
889 switch (o->op_type) {
892 list(cBINOPo->op_first);
897 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
905 if (!(o->op_flags & OPf_KIDS))
907 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
908 list(cBINOPo->op_first);
909 return gen_constant_list(o);
916 kid = cLISTOPo->op_first;
918 while ((kid = kid->op_sibling)) {
924 WITH_THR(PL_curcop = &PL_compiling);
928 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
934 WITH_THR(PL_curcop = &PL_compiling);
937 /* all requires must return a boolean value */
938 o->op_flags &= ~OPf_WANT;
945 Perl_scalarseq(pTHX_ OP *o)
948 if (o->op_type == OP_LINESEQ ||
949 o->op_type == OP_SCOPE ||
950 o->op_type == OP_LEAVE ||
951 o->op_type == OP_LEAVETRY)
954 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
955 if (kid->op_sibling) {
959 PL_curcop = &PL_compiling;
961 o->op_flags &= ~OPf_PARENS;
962 if (PL_hints & HINT_BLOCK_SCOPE)
963 o->op_flags |= OPf_PARENS;
966 o = newOP(OP_STUB, 0);
971 S_modkids(pTHX_ OP *o, I32 type)
973 if (o && o->op_flags & OPf_KIDS) {
975 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
981 /* Propagate lvalue ("modifiable") context to an op and it's children.
982 * 'type' represents the context type, roughly based on the type of op that
983 * would do the modifying, although local() is represented by OP_NULL.
984 * It's responsible for detecting things that can't be modified, flag
985 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
986 * might have to vivify a reference in $x), and so on.
988 * For example, "$a+1 = 2" would cause mod() to be called with o being
989 * OP_ADD and type being OP_SASSIGN, and would output an error.
993 Perl_mod(pTHX_ OP *o, I32 type)
997 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1000 if (!o || PL_error_count)
1003 if ((o->op_private & OPpTARGET_MY)
1004 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1009 switch (o->op_type) {
1015 if (!(o->op_private & (OPpCONST_ARYBASE)))
1017 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1018 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1022 SAVEI32(PL_compiling.cop_arybase);
1023 PL_compiling.cop_arybase = 0;
1025 else if (type == OP_REFGEN)
1028 Perl_croak(aTHX_ "That use of $[ is unsupported");
1031 if (o->op_flags & OPf_PARENS)
1035 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1036 !(o->op_flags & OPf_STACKED)) {
1037 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1038 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1039 assert(cUNOPo->op_first->op_type == OP_NULL);
1040 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1043 else if (o->op_private & OPpENTERSUB_NOMOD)
1045 else { /* lvalue subroutine call */
1046 o->op_private |= OPpLVAL_INTRO;
1047 PL_modcount = RETURN_UNLIMITED_NUMBER;
1048 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1049 /* Backward compatibility mode: */
1050 o->op_private |= OPpENTERSUB_INARGS;
1053 else { /* Compile-time error message: */
1054 OP *kid = cUNOPo->op_first;
1058 if (kid->op_type == OP_PUSHMARK)
1060 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1062 "panic: unexpected lvalue entersub "
1063 "args: type/targ %ld:%"UVuf,
1064 (long)kid->op_type, (UV)kid->op_targ);
1065 kid = kLISTOP->op_first;
1067 while (kid->op_sibling)
1068 kid = kid->op_sibling;
1069 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1071 if (kid->op_type == OP_METHOD_NAMED
1072 || kid->op_type == OP_METHOD)
1076 NewOp(1101, newop, 1, UNOP);
1077 newop->op_type = OP_RV2CV;
1078 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1079 newop->op_first = Nullop;
1080 newop->op_next = (OP*)newop;
1081 kid->op_sibling = (OP*)newop;
1082 newop->op_private |= OPpLVAL_INTRO;
1086 if (kid->op_type != OP_RV2CV)
1088 "panic: unexpected lvalue entersub "
1089 "entry via type/targ %ld:%"UVuf,
1090 (long)kid->op_type, (UV)kid->op_targ);
1091 kid->op_private |= OPpLVAL_INTRO;
1092 break; /* Postpone until runtime */
1096 kid = kUNOP->op_first;
1097 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1098 kid = kUNOP->op_first;
1099 if (kid->op_type == OP_NULL)
1101 "Unexpected constant lvalue entersub "
1102 "entry via type/targ %ld:%"UVuf,
1103 (long)kid->op_type, (UV)kid->op_targ);
1104 if (kid->op_type != OP_GV) {
1105 /* Restore RV2CV to check lvalueness */
1107 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1108 okid->op_next = kid->op_next;
1109 kid->op_next = okid;
1112 okid->op_next = Nullop;
1113 okid->op_type = OP_RV2CV;
1115 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1116 okid->op_private |= OPpLVAL_INTRO;
1120 cv = GvCV(kGVOP_gv);
1130 /* grep, foreach, subcalls, refgen */
1131 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1133 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1134 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1136 : (o->op_type == OP_ENTERSUB
1137 ? "non-lvalue subroutine call"
1139 type ? PL_op_desc[type] : "local"));
1153 case OP_RIGHT_SHIFT:
1162 if (!(o->op_flags & OPf_STACKED))
1169 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1175 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1176 PL_modcount = RETURN_UNLIMITED_NUMBER;
1177 return o; /* Treat \(@foo) like ordinary list. */
1181 if (scalar_mod_type(o, type))
1183 ref(cUNOPo->op_first, o->op_type);
1187 if (type == OP_LEAVESUBLV)
1188 o->op_private |= OPpMAYBE_LVSUB;
1194 PL_modcount = RETURN_UNLIMITED_NUMBER;
1197 ref(cUNOPo->op_first, o->op_type);
1202 PL_hints |= HINT_BLOCK_SCOPE;
1217 PL_modcount = RETURN_UNLIMITED_NUMBER;
1218 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1219 return o; /* Treat \(@foo) like ordinary list. */
1220 if (scalar_mod_type(o, type))
1222 if (type == OP_LEAVESUBLV)
1223 o->op_private |= OPpMAYBE_LVSUB;
1227 if (!type) /* local() */
1228 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1229 PAD_COMPNAME_PV(o->op_targ));
1237 if (type != OP_SASSIGN)
1241 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1246 if (type == OP_LEAVESUBLV)
1247 o->op_private |= OPpMAYBE_LVSUB;
1249 pad_free(o->op_targ);
1250 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1251 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1252 if (o->op_flags & OPf_KIDS)
1253 mod(cBINOPo->op_first->op_sibling, type);
1258 ref(cBINOPo->op_first, o->op_type);
1259 if (type == OP_ENTERSUB &&
1260 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1261 o->op_private |= OPpLVAL_DEFER;
1262 if (type == OP_LEAVESUBLV)
1263 o->op_private |= OPpMAYBE_LVSUB;
1273 if (o->op_flags & OPf_KIDS)
1274 mod(cLISTOPo->op_last, type);
1279 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1281 else if (!(o->op_flags & OPf_KIDS))
1283 if (o->op_targ != OP_LIST) {
1284 mod(cBINOPo->op_first, type);
1290 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1295 if (type != OP_LEAVESUBLV)
1297 break; /* mod()ing was handled by ck_return() */
1300 /* [20011101.069] File test operators interpret OPf_REF to mean that
1301 their argument is a filehandle; thus \stat(".") should not set
1303 if (type == OP_REFGEN &&
1304 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1307 if (type != OP_LEAVESUBLV)
1308 o->op_flags |= OPf_MOD;
1310 if (type == OP_AASSIGN || type == OP_SASSIGN)
1311 o->op_flags |= OPf_SPECIAL|OPf_REF;
1312 else if (!type) { /* local() */
1315 o->op_private |= OPpLVAL_INTRO;
1316 o->op_flags &= ~OPf_SPECIAL;
1317 PL_hints |= HINT_BLOCK_SCOPE;
1322 if (ckWARN(WARN_SYNTAX)) {
1323 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1324 "Useless localization of %s", OP_DESC(o));
1328 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1329 && type != OP_LEAVESUBLV)
1330 o->op_flags |= OPf_REF;
1335 S_scalar_mod_type(pTHX_ const OP *o, I32 type)
1339 if (o->op_type == OP_RV2GV)
1363 case OP_RIGHT_SHIFT:
1382 S_is_handle_constructor(pTHX_ const OP *o, I32 numargs)
1384 switch (o->op_type) {
1392 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1405 Perl_refkids(pTHX_ OP *o, I32 type)
1407 if (o && o->op_flags & OPf_KIDS) {
1409 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1416 Perl_ref(pTHX_ OP *o, I32 type)
1421 if (!o || PL_error_count)
1424 switch (o->op_type) {
1426 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1427 !(o->op_flags & OPf_STACKED)) {
1428 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1429 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1430 assert(cUNOPo->op_first->op_type == OP_NULL);
1431 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1432 o->op_flags |= OPf_SPECIAL;
1437 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1441 if (type == OP_DEFINED)
1442 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1443 ref(cUNOPo->op_first, o->op_type);
1446 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1447 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1448 : type == OP_RV2HV ? OPpDEREF_HV
1450 o->op_flags |= OPf_MOD;
1455 o->op_flags |= OPf_MOD; /* XXX ??? */
1460 o->op_flags |= OPf_REF;
1463 if (type == OP_DEFINED)
1464 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1465 ref(cUNOPo->op_first, o->op_type);
1470 o->op_flags |= OPf_REF;
1475 if (!(o->op_flags & OPf_KIDS))
1477 ref(cBINOPo->op_first, type);
1481 ref(cBINOPo->op_first, o->op_type);
1482 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1483 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1484 : type == OP_RV2HV ? OPpDEREF_HV
1486 o->op_flags |= OPf_MOD;
1494 if (!(o->op_flags & OPf_KIDS))
1496 ref(cLISTOPo->op_last, type);
1506 S_dup_attrlist(pTHX_ OP *o)
1510 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1511 * where the first kid is OP_PUSHMARK and the remaining ones
1512 * are OP_CONST. We need to push the OP_CONST values.
1514 if (o->op_type == OP_CONST)
1515 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1517 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1518 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1519 if (o->op_type == OP_CONST)
1520 rop = append_elem(OP_LIST, rop,
1521 newSVOP(OP_CONST, o->op_flags,
1522 SvREFCNT_inc(cSVOPo->op_sv)));
1529 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1534 /* fake up C<use attributes $pkg,$rv,@attrs> */
1535 ENTER; /* need to protect against side-effects of 'use' */
1538 stashsv = newSVpvn(HvNAME_get(stash), HvNAMELEN_get(stash));
1540 stashsv = &PL_sv_no;
1542 #define ATTRSMODULE "attributes"
1543 #define ATTRSMODULE_PM "attributes.pm"
1546 /* Don't force the C<use> if we don't need it. */
1547 SV **svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
1548 sizeof(ATTRSMODULE_PM)-1, 0);
1549 if (svp && *svp != &PL_sv_undef)
1550 ; /* already in %INC */
1552 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1553 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1557 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1558 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1560 prepend_elem(OP_LIST,
1561 newSVOP(OP_CONST, 0, stashsv),
1562 prepend_elem(OP_LIST,
1563 newSVOP(OP_CONST, 0,
1565 dup_attrlist(attrs))));
1571 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1573 OP *pack, *imop, *arg;
1579 assert(target->op_type == OP_PADSV ||
1580 target->op_type == OP_PADHV ||
1581 target->op_type == OP_PADAV);
1583 /* Ensure that attributes.pm is loaded. */
1584 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1586 /* Need package name for method call. */
1587 pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
1589 /* Build up the real arg-list. */
1591 stashsv = newSVpvn(HvNAME_get(stash), HvNAMELEN_get(stash));
1593 stashsv = &PL_sv_no;
1594 arg = newOP(OP_PADSV, 0);
1595 arg->op_targ = target->op_targ;
1596 arg = prepend_elem(OP_LIST,
1597 newSVOP(OP_CONST, 0, stashsv),
1598 prepend_elem(OP_LIST,
1599 newUNOP(OP_REFGEN, 0,
1600 mod(arg, OP_REFGEN)),
1601 dup_attrlist(attrs)));
1603 /* Fake up a method call to import */
1604 meth = newSVpvn("import", 6);
1605 (void)SvUPGRADE(meth, SVt_PVIV);
1606 (void)SvIOK_on(meth);
1609 PERL_HASH(hash, SvPVX_const(meth), SvCUR(meth));
1610 SvUV_set(meth, hash);
1612 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1613 append_elem(OP_LIST,
1614 prepend_elem(OP_LIST, pack, list(arg)),
1615 newSVOP(OP_METHOD_NAMED, 0, meth)));
1616 imop->op_private |= OPpENTERSUB_NOMOD;
1618 /* Combine the ops. */
1619 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1623 =notfor apidoc apply_attrs_string
1625 Attempts to apply a list of attributes specified by the C<attrstr> and
1626 C<len> arguments to the subroutine identified by the C<cv> argument which
1627 is expected to be associated with the package identified by the C<stashpv>
1628 argument (see L<attributes>). It gets this wrong, though, in that it
1629 does not correctly identify the boundaries of the individual attribute
1630 specifications within C<attrstr>. This is not really intended for the
1631 public API, but has to be listed here for systems such as AIX which
1632 need an explicit export list for symbols. (It's called from XS code
1633 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1634 to respect attribute syntax properly would be welcome.
1640 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1641 const char *attrstr, STRLEN len)
1646 len = strlen(attrstr);
1650 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1652 const char *sstr = attrstr;
1653 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1654 attrs = append_elem(OP_LIST, attrs,
1655 newSVOP(OP_CONST, 0,
1656 newSVpvn(sstr, attrstr-sstr)));
1660 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1661 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1662 Nullsv, prepend_elem(OP_LIST,
1663 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1664 prepend_elem(OP_LIST,
1665 newSVOP(OP_CONST, 0,
1671 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1675 if (!o || PL_error_count)
1679 if (type == OP_LIST) {
1681 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1682 my_kid(kid, attrs, imopsp);
1683 } else if (type == OP_UNDEF) {
1685 } else if (type == OP_RV2SV || /* "our" declaration */
1687 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1688 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1689 yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
1690 OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
1692 GV *gv = cGVOPx_gv(cUNOPo->op_first);
1694 PL_in_my_stash = Nullhv;
1695 apply_attrs(GvSTASH(gv),
1696 (type == OP_RV2SV ? GvSV(gv) :
1697 type == OP_RV2AV ? (SV*)GvAV(gv) :
1698 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1701 o->op_private |= OPpOUR_INTRO;
1704 else if (type != OP_PADSV &&
1707 type != OP_PUSHMARK)
1709 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1711 PL_in_my == KEY_our ? "our" : "my"));
1714 else if (attrs && type != OP_PUSHMARK) {
1718 PL_in_my_stash = Nullhv;
1720 /* check for C<my Dog $spot> when deciding package */
1721 stash = PAD_COMPNAME_TYPE(o->op_targ);
1723 stash = PL_curstash;
1724 apply_attrs_my(stash, o, attrs, imopsp);
1726 o->op_flags |= OPf_MOD;
1727 o->op_private |= OPpLVAL_INTRO;
1732 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1735 int maybe_scalar = 0;
1737 /* [perl #17376]: this appears to be premature, and results in code such as
1738 C< our(%x); > executing in list mode rather than void mode */
1740 if (o->op_flags & OPf_PARENS)
1749 o = my_kid(o, attrs, &rops);
1751 if (maybe_scalar && o->op_type == OP_PADSV) {
1752 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1753 o->op_private |= OPpLVAL_INTRO;
1756 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1759 PL_in_my_stash = Nullhv;
1764 Perl_my(pTHX_ OP *o)
1766 return my_attrs(o, Nullop);
1770 Perl_sawparens(pTHX_ OP *o)
1773 o->op_flags |= OPf_PARENS;
1778 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1783 if (ckWARN(WARN_MISC) &&
1784 (left->op_type == OP_RV2AV ||
1785 left->op_type == OP_RV2HV ||
1786 left->op_type == OP_PADAV ||
1787 left->op_type == OP_PADHV)) {
1788 const char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
1789 right->op_type == OP_TRANS)
1790 ? right->op_type : OP_MATCH];
1791 const char *sample = ((left->op_type == OP_RV2AV ||
1792 left->op_type == OP_PADAV)
1793 ? "@array" : "%hash");
1794 Perl_warner(aTHX_ packWARN(WARN_MISC),
1795 "Applying %s to %s will act on scalar(%s)",
1796 desc, sample, sample);
1799 if (right->op_type == OP_CONST &&
1800 cSVOPx(right)->op_private & OPpCONST_BARE &&
1801 cSVOPx(right)->op_private & OPpCONST_STRICT)
1803 no_bareword_allowed(right);
1806 ismatchop = right->op_type == OP_MATCH ||
1807 right->op_type == OP_SUBST ||
1808 right->op_type == OP_TRANS;
1809 if (ismatchop && right->op_private & OPpTARGET_MY) {
1811 right->op_private &= ~OPpTARGET_MY;
1813 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1814 right->op_flags |= OPf_STACKED;
1815 if (right->op_type != OP_MATCH &&
1816 ! (right->op_type == OP_TRANS &&
1817 right->op_private & OPpTRANS_IDENTICAL))
1818 left = mod(left, right->op_type);
1819 if (right->op_type == OP_TRANS)
1820 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
1822 o = prepend_elem(right->op_type, scalar(left), right);
1824 return newUNOP(OP_NOT, 0, scalar(o));
1828 return bind_match(type, left,
1829 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
1833 Perl_invert(pTHX_ OP *o)
1837 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
1838 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1842 Perl_scope(pTHX_ OP *o)
1846 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1847 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1848 o->op_type = OP_LEAVE;
1849 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1851 else if (o->op_type == OP_LINESEQ) {
1853 o->op_type = OP_SCOPE;
1854 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1855 kid = ((LISTOP*)o)->op_first;
1856 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
1860 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
1865 /* XXX kept for BINCOMPAT only */
1867 Perl_save_hints(pTHX)
1869 Perl_croak(aTHX_ "internal error: obsolete function save_hints() called");
1873 Perl_block_start(pTHX_ int full)
1875 const int retval = PL_savestack_ix;
1876 pad_block_start(full);
1878 PL_hints &= ~HINT_BLOCK_SCOPE;
1879 SAVESPTR(PL_compiling.cop_warnings);
1880 if (! specialWARN(PL_compiling.cop_warnings)) {
1881 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1882 SAVEFREESV(PL_compiling.cop_warnings) ;
1884 SAVESPTR(PL_compiling.cop_io);
1885 if (! specialCopIO(PL_compiling.cop_io)) {
1886 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1887 SAVEFREESV(PL_compiling.cop_io) ;
1893 Perl_block_end(pTHX_ I32 floor, OP *seq)
1895 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1896 OP* retval = scalarseq(seq);
1898 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
1900 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
1908 const I32 offset = pad_findmy("$_");
1909 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
1910 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1913 OP *o = newOP(OP_PADSV, 0);
1914 o->op_targ = offset;
1920 Perl_newPROG(pTHX_ OP *o)
1925 PL_eval_root = newUNOP(OP_LEAVEEVAL,
1926 ((PL_in_eval & EVAL_KEEPERR)
1927 ? OPf_SPECIAL : 0), o);
1928 PL_eval_start = linklist(PL_eval_root);
1929 PL_eval_root->op_private |= OPpREFCOUNTED;
1930 OpREFCNT_set(PL_eval_root, 1);
1931 PL_eval_root->op_next = 0;
1932 CALL_PEEP(PL_eval_start);
1935 if (o->op_type == OP_STUB) {
1936 PL_comppad_name = 0;
1941 PL_main_root = scope(sawparens(scalarvoid(o)));
1942 PL_curcop = &PL_compiling;
1943 PL_main_start = LINKLIST(PL_main_root);
1944 PL_main_root->op_private |= OPpREFCOUNTED;
1945 OpREFCNT_set(PL_main_root, 1);
1946 PL_main_root->op_next = 0;
1947 CALL_PEEP(PL_main_start);
1950 /* Register with debugger */
1952 CV *cv = get_cv("DB::postponed", FALSE);
1956 XPUSHs((SV*)CopFILEGV(&PL_compiling));
1958 call_sv((SV*)cv, G_DISCARD);
1965 Perl_localize(pTHX_ OP *o, I32 lex)
1967 if (o->op_flags & OPf_PARENS)
1968 /* [perl #17376]: this appears to be premature, and results in code such as
1969 C< our(%x); > executing in list mode rather than void mode */
1976 if (ckWARN(WARN_PARENTHESIS)
1977 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
1979 char *s = PL_bufptr;
1982 /* some heuristics to detect a potential error */
1983 while (*s && (strchr(", \t\n", *s)))
1987 if (*s && strchr("@$%*", *s) && *++s
1988 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
1991 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
1993 while (*s && (strchr(", \t\n", *s)))
1999 if (sigil && (*s == ';' || *s == '=')) {
2000 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2001 "Parentheses missing around \"%s\" list",
2002 lex ? (PL_in_my == KEY_our ? "our" : "my")
2010 o = mod(o, OP_NULL); /* a bit kludgey */
2012 PL_in_my_stash = Nullhv;
2017 Perl_jmaybe(pTHX_ OP *o)
2019 if (o->op_type == OP_LIST) {
2021 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2022 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2028 Perl_fold_constants(pTHX_ register OP *o)
2032 I32 type = o->op_type;
2035 if (PL_opargs[type] & OA_RETSCALAR)
2037 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2038 o->op_targ = pad_alloc(type, SVs_PADTMP);
2040 /* integerize op, unless it happens to be C<-foo>.
2041 * XXX should pp_i_negate() do magic string negation instead? */
2042 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2043 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2044 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2046 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2049 if (!(PL_opargs[type] & OA_FOLDCONST))
2054 /* XXX might want a ck_negate() for this */
2055 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2067 /* XXX what about the numeric ops? */
2068 if (PL_hints & HINT_LOCALE)
2073 goto nope; /* Don't try to run w/ errors */
2075 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2076 if ((curop->op_type != OP_CONST ||
2077 (curop->op_private & OPpCONST_BARE)) &&
2078 curop->op_type != OP_LIST &&
2079 curop->op_type != OP_SCALAR &&
2080 curop->op_type != OP_NULL &&
2081 curop->op_type != OP_PUSHMARK)
2087 curop = LINKLIST(o);
2091 sv = *(PL_stack_sp--);
2092 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2093 pad_swipe(o->op_targ, FALSE);
2094 else if (SvTEMP(sv)) { /* grab mortal temp? */
2095 (void)SvREFCNT_inc(sv);
2099 if (type == OP_RV2GV)
2100 return newGVOP(OP_GV, 0, (GV*)sv);
2101 return newSVOP(OP_CONST, 0, sv);
2108 Perl_gen_constant_list(pTHX_ register OP *o)
2112 const I32 oldtmps_floor = PL_tmps_floor;
2116 return o; /* Don't attempt to run with errors */
2118 PL_op = curop = LINKLIST(o);
2125 PL_tmps_floor = oldtmps_floor;
2127 o->op_type = OP_RV2AV;
2128 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2129 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2130 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2131 o->op_opt = 0; /* needs to be revisited in peep() */
2132 curop = ((UNOP*)o)->op_first;
2133 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2140 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2143 if (!o || o->op_type != OP_LIST)
2144 o = newLISTOP(OP_LIST, 0, o, Nullop);
2146 o->op_flags &= ~OPf_WANT;
2148 if (!(PL_opargs[type] & OA_MARK))
2149 op_null(cLISTOPo->op_first);
2151 o->op_type = (OPCODE)type;
2152 o->op_ppaddr = PL_ppaddr[type];
2153 o->op_flags |= flags;
2155 o = CHECKOP(type, o);
2156 if (o->op_type != (unsigned)type)
2159 return fold_constants(o);
2162 /* List constructors */
2165 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2173 if (first->op_type != (unsigned)type
2174 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2176 return newLISTOP(type, 0, first, last);
2179 if (first->op_flags & OPf_KIDS)
2180 ((LISTOP*)first)->op_last->op_sibling = last;
2182 first->op_flags |= OPf_KIDS;
2183 ((LISTOP*)first)->op_first = last;
2185 ((LISTOP*)first)->op_last = last;
2190 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2198 if (first->op_type != (unsigned)type)
2199 return prepend_elem(type, (OP*)first, (OP*)last);
2201 if (last->op_type != (unsigned)type)
2202 return append_elem(type, (OP*)first, (OP*)last);
2204 first->op_last->op_sibling = last->op_first;
2205 first->op_last = last->op_last;
2206 first->op_flags |= (last->op_flags & OPf_KIDS);
2214 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2222 if (last->op_type == (unsigned)type) {
2223 if (type == OP_LIST) { /* already a PUSHMARK there */
2224 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2225 ((LISTOP*)last)->op_first->op_sibling = first;
2226 if (!(first->op_flags & OPf_PARENS))
2227 last->op_flags &= ~OPf_PARENS;
2230 if (!(last->op_flags & OPf_KIDS)) {
2231 ((LISTOP*)last)->op_last = first;
2232 last->op_flags |= OPf_KIDS;
2234 first->op_sibling = ((LISTOP*)last)->op_first;
2235 ((LISTOP*)last)->op_first = first;
2237 last->op_flags |= OPf_KIDS;
2241 return newLISTOP(type, 0, first, last);
2247 Perl_newNULLLIST(pTHX)
2249 return newOP(OP_STUB, 0);
2253 Perl_force_list(pTHX_ OP *o)
2255 if (!o || o->op_type != OP_LIST)
2256 o = newLISTOP(OP_LIST, 0, o, Nullop);
2262 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2267 NewOp(1101, listop, 1, LISTOP);
2269 listop->op_type = (OPCODE)type;
2270 listop->op_ppaddr = PL_ppaddr[type];
2273 listop->op_flags = (U8)flags;
2277 else if (!first && last)
2280 first->op_sibling = last;
2281 listop->op_first = first;
2282 listop->op_last = last;
2283 if (type == OP_LIST) {
2285 pushop = newOP(OP_PUSHMARK, 0);
2286 pushop->op_sibling = first;
2287 listop->op_first = pushop;
2288 listop->op_flags |= OPf_KIDS;
2290 listop->op_last = pushop;
2293 return CHECKOP(type, listop);
2297 Perl_newOP(pTHX_ I32 type, I32 flags)
2301 NewOp(1101, o, 1, OP);
2302 o->op_type = (OPCODE)type;
2303 o->op_ppaddr = PL_ppaddr[type];
2304 o->op_flags = (U8)flags;
2307 o->op_private = (U8)(0 | (flags >> 8));
2308 if (PL_opargs[type] & OA_RETSCALAR)
2310 if (PL_opargs[type] & OA_TARGET)
2311 o->op_targ = pad_alloc(type, SVs_PADTMP);
2312 return CHECKOP(type, o);
2316 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2322 first = newOP(OP_STUB, 0);
2323 if (PL_opargs[type] & OA_MARK)
2324 first = force_list(first);
2326 NewOp(1101, unop, 1, UNOP);
2327 unop->op_type = (OPCODE)type;
2328 unop->op_ppaddr = PL_ppaddr[type];
2329 unop->op_first = first;
2330 unop->op_flags = flags | OPf_KIDS;
2331 unop->op_private = (U8)(1 | (flags >> 8));
2332 unop = (UNOP*) CHECKOP(type, unop);
2336 return fold_constants((OP *) unop);
2340 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2344 NewOp(1101, binop, 1, BINOP);
2347 first = newOP(OP_NULL, 0);
2349 binop->op_type = (OPCODE)type;
2350 binop->op_ppaddr = PL_ppaddr[type];
2351 binop->op_first = first;
2352 binop->op_flags = flags | OPf_KIDS;
2355 binop->op_private = (U8)(1 | (flags >> 8));
2358 binop->op_private = (U8)(2 | (flags >> 8));
2359 first->op_sibling = last;
2362 binop = (BINOP*)CHECKOP(type, binop);
2363 if (binop->op_next || binop->op_type != (OPCODE)type)
2366 binop->op_last = binop->op_first->op_sibling;
2368 return fold_constants((OP *)binop);
2371 static int uvcompare(const void *a, const void *b) __attribute__nonnull__(1) __attribute__nonnull__(2) __attribute__pure__;
2372 static int uvcompare(const void *a, const void *b)
2374 if (*((const UV *)a) < (*(const UV *)b))
2376 if (*((const UV *)a) > (*(const UV *)b))
2378 if (*((const UV *)a+1) < (*(const UV *)b+1))
2380 if (*((const UV *)a+1) > (*(const UV *)b+1))
2386 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2388 SV *tstr = ((SVOP*)expr)->op_sv;
2389 SV *rstr = ((SVOP*)repl)->op_sv;
2392 U8 *t = (U8*)SvPV(tstr, tlen);
2393 U8 *r = (U8*)SvPV(rstr, rlen);
2400 register short *tbl;
2402 PL_hints |= HINT_BLOCK_SCOPE;
2403 complement = o->op_private & OPpTRANS_COMPLEMENT;
2404 del = o->op_private & OPpTRANS_DELETE;
2405 squash = o->op_private & OPpTRANS_SQUASH;
2408 o->op_private |= OPpTRANS_FROM_UTF;
2411 o->op_private |= OPpTRANS_TO_UTF;
2413 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2414 SV* listsv = newSVpvn("# comment\n",10);
2416 U8* tend = t + tlen;
2417 U8* rend = r + rlen;
2431 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2432 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2438 tsave = t = bytes_to_utf8(t, &len);
2441 if (!to_utf && rlen) {
2443 rsave = r = bytes_to_utf8(r, &len);
2447 /* There are several snags with this code on EBCDIC:
2448 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2449 2. scan_const() in toke.c has encoded chars in native encoding which makes
2450 ranges at least in EBCDIC 0..255 range the bottom odd.
2454 U8 tmpbuf[UTF8_MAXBYTES+1];
2457 New(1109, cp, 2*tlen, UV);
2459 transv = newSVpvn("",0);
2461 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2463 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2465 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2469 cp[2*i+1] = cp[2*i];
2473 qsort(cp, i, 2*sizeof(UV), uvcompare);
2474 for (j = 0; j < i; j++) {
2476 diff = val - nextmin;
2478 t = uvuni_to_utf8(tmpbuf,nextmin);
2479 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2481 U8 range_mark = UTF_TO_NATIVE(0xff);
2482 t = uvuni_to_utf8(tmpbuf, val - 1);
2483 sv_catpvn(transv, (char *)&range_mark, 1);
2484 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2491 t = uvuni_to_utf8(tmpbuf,nextmin);
2492 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2494 U8 range_mark = UTF_TO_NATIVE(0xff);
2495 sv_catpvn(transv, (char *)&range_mark, 1);
2497 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2498 UNICODE_ALLOW_SUPER);
2499 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2500 t = (U8*)SvPVX(transv);
2501 tlen = SvCUR(transv);
2505 else if (!rlen && !del) {
2506 r = t; rlen = tlen; rend = tend;
2509 if ((!rlen && !del) || t == r ||
2510 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2512 o->op_private |= OPpTRANS_IDENTICAL;
2516 while (t < tend || tfirst <= tlast) {
2517 /* see if we need more "t" chars */
2518 if (tfirst > tlast) {
2519 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2521 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2523 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2530 /* now see if we need more "r" chars */
2531 if (rfirst > rlast) {
2533 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2535 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2537 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2546 rfirst = rlast = 0xffffffff;
2550 /* now see which range will peter our first, if either. */
2551 tdiff = tlast - tfirst;
2552 rdiff = rlast - rfirst;
2559 if (rfirst == 0xffffffff) {
2560 diff = tdiff; /* oops, pretend rdiff is infinite */
2562 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2563 (long)tfirst, (long)tlast);
2565 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2569 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2570 (long)tfirst, (long)(tfirst + diff),
2573 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2574 (long)tfirst, (long)rfirst);
2576 if (rfirst + diff > max)
2577 max = rfirst + diff;
2579 grows = (tfirst < rfirst &&
2580 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2592 else if (max > 0xff)
2597 Safefree(cPVOPo->op_pv);
2598 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2599 SvREFCNT_dec(listsv);
2601 SvREFCNT_dec(transv);
2603 if (!del && havefinal && rlen)
2604 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2605 newSVuv((UV)final), 0);
2608 o->op_private |= OPpTRANS_GROWS;
2620 tbl = (short*)cPVOPo->op_pv;
2622 Zero(tbl, 256, short);
2623 for (i = 0; i < (I32)tlen; i++)
2625 for (i = 0, j = 0; i < 256; i++) {
2627 if (j >= (I32)rlen) {
2636 if (i < 128 && r[j] >= 128)
2646 o->op_private |= OPpTRANS_IDENTICAL;
2648 else if (j >= (I32)rlen)
2651 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2652 tbl[0x100] = rlen - j;
2653 for (i=0; i < (I32)rlen - j; i++)
2654 tbl[0x101+i] = r[j+i];
2658 if (!rlen && !del) {
2661 o->op_private |= OPpTRANS_IDENTICAL;
2663 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2664 o->op_private |= OPpTRANS_IDENTICAL;
2666 for (i = 0; i < 256; i++)
2668 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
2669 if (j >= (I32)rlen) {
2671 if (tbl[t[i]] == -1)
2677 if (tbl[t[i]] == -1) {
2678 if (t[i] < 128 && r[j] >= 128)
2685 o->op_private |= OPpTRANS_GROWS;
2693 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2698 NewOp(1101, pmop, 1, PMOP);
2699 pmop->op_type = (OPCODE)type;
2700 pmop->op_ppaddr = PL_ppaddr[type];
2701 pmop->op_flags = (U8)flags;
2702 pmop->op_private = (U8)(0 | (flags >> 8));
2704 if (PL_hints & HINT_RE_TAINT)
2705 pmop->op_pmpermflags |= PMf_RETAINT;
2706 if (PL_hints & HINT_LOCALE)
2707 pmop->op_pmpermflags |= PMf_LOCALE;
2708 pmop->op_pmflags = pmop->op_pmpermflags;
2713 if(av_len((AV*) PL_regex_pad[0]) > -1) {
2714 repointer = av_pop((AV*)PL_regex_pad[0]);
2715 pmop->op_pmoffset = SvIV(repointer);
2716 SvREPADTMP_off(repointer);
2717 sv_setiv(repointer,0);
2719 repointer = newSViv(0);
2720 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2721 pmop->op_pmoffset = av_len(PL_regex_padav);
2722 PL_regex_pad = AvARRAY(PL_regex_padav);
2727 /* link into pm list */
2728 if (type != OP_TRANS && PL_curstash) {
2729 MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab);
2732 mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0);
2734 pmop->op_pmnext = (PMOP*)mg->mg_obj;
2735 mg->mg_obj = (SV*)pmop;
2736 PmopSTASH_set(pmop,PL_curstash);
2739 return CHECKOP(type, pmop);
2742 /* Given some sort of match op o, and an expression expr containing a
2743 * pattern, either compile expr into a regex and attach it to o (if it's
2744 * constant), or convert expr into a runtime regcomp op sequence (if it's
2747 * isreg indicates that the pattern is part of a regex construct, eg
2748 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
2749 * split "pattern", which aren't. In the former case, expr will be a list
2750 * if the pattern contains more than one term (eg /a$b/) or if it contains
2751 * a replacement, ie s/// or tr///.
2755 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
2760 I32 repl_has_vars = 0;
2764 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
2765 /* last element in list is the replacement; pop it */
2767 repl = cLISTOPx(expr)->op_last;
2768 kid = cLISTOPx(expr)->op_first;
2769 while (kid->op_sibling != repl)
2770 kid = kid->op_sibling;
2771 kid->op_sibling = Nullop;
2772 cLISTOPx(expr)->op_last = kid;
2775 if (isreg && expr->op_type == OP_LIST &&
2776 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
2778 /* convert single element list to element */
2780 expr = cLISTOPx(oe)->op_first->op_sibling;
2781 cLISTOPx(oe)->op_first->op_sibling = Nullop;
2782 cLISTOPx(oe)->op_last = Nullop;
2786 if (o->op_type == OP_TRANS) {
2787 return pmtrans(o, expr, repl);
2790 reglist = isreg && expr->op_type == OP_LIST;
2794 PL_hints |= HINT_BLOCK_SCOPE;
2797 if (expr->op_type == OP_CONST) {
2799 SV *pat = ((SVOP*)expr)->op_sv;
2800 char *p = SvPV(pat, plen);
2801 if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
2802 sv_setpvn(pat, "\\s+", 3);
2803 p = SvPV(pat, plen);
2804 pm->op_pmflags |= PMf_SKIPWHITE;
2807 pm->op_pmdynflags |= PMdf_UTF8;
2808 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
2809 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
2810 pm->op_pmflags |= PMf_WHITE;
2814 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2815 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2817 : OP_REGCMAYBE),0,expr);
2819 NewOp(1101, rcop, 1, LOGOP);
2820 rcop->op_type = OP_REGCOMP;
2821 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2822 rcop->op_first = scalar(expr);
2823 rcop->op_flags |= OPf_KIDS
2824 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
2825 | (reglist ? OPf_STACKED : 0);
2826 rcop->op_private = 1;
2829 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
2831 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
2834 /* establish postfix order */
2835 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2837 rcop->op_next = expr;
2838 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2841 rcop->op_next = LINKLIST(expr);
2842 expr->op_next = (OP*)rcop;
2845 prepend_elem(o->op_type, scalar((OP*)rcop), o);
2850 if (pm->op_pmflags & PMf_EVAL) {
2852 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
2853 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
2855 else if (repl->op_type == OP_CONST)
2859 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
2860 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
2861 if (curop->op_type == OP_GV) {
2862 GV *gv = cGVOPx_gv(curop);
2864 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
2867 else if (curop->op_type == OP_RV2CV)
2869 else if (curop->op_type == OP_RV2SV ||
2870 curop->op_type == OP_RV2AV ||
2871 curop->op_type == OP_RV2HV ||
2872 curop->op_type == OP_RV2GV) {
2873 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2876 else if (curop->op_type == OP_PADSV ||
2877 curop->op_type == OP_PADAV ||
2878 curop->op_type == OP_PADHV ||
2879 curop->op_type == OP_PADANY) {
2882 else if (curop->op_type == OP_PUSHRE)
2883 ; /* Okay here, dangerous in newASSIGNOP */
2893 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
2894 pm->op_pmflags |= PMf_CONST; /* const for long enough */
2895 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
2896 prepend_elem(o->op_type, scalar(repl), o);
2899 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
2900 pm->op_pmflags |= PMf_MAYBE_CONST;
2901 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2903 NewOp(1101, rcop, 1, LOGOP);
2904 rcop->op_type = OP_SUBSTCONT;
2905 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
2906 rcop->op_first = scalar(repl);
2907 rcop->op_flags |= OPf_KIDS;
2908 rcop->op_private = 1;
2911 /* establish postfix order */
2912 rcop->op_next = LINKLIST(repl);
2913 repl->op_next = (OP*)rcop;
2915 pm->op_pmreplroot = scalar((OP*)rcop);
2916 pm->op_pmreplstart = LINKLIST(rcop);
2925 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
2929 NewOp(1101, svop, 1, SVOP);
2930 svop->op_type = (OPCODE)type;
2931 svop->op_ppaddr = PL_ppaddr[type];
2933 svop->op_next = (OP*)svop;
2934 svop->op_flags = (U8)flags;
2935 if (PL_opargs[type] & OA_RETSCALAR)
2937 if (PL_opargs[type] & OA_TARGET)
2938 svop->op_targ = pad_alloc(type, SVs_PADTMP);
2939 return CHECKOP(type, svop);
2943 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2947 NewOp(1101, padop, 1, PADOP);
2948 padop->op_type = (OPCODE)type;
2949 padop->op_ppaddr = PL_ppaddr[type];
2950 padop->op_padix = pad_alloc(type, SVs_PADTMP);
2951 SvREFCNT_dec(PAD_SVl(padop->op_padix));
2952 PAD_SETSV(padop->op_padix, sv);
2955 padop->op_next = (OP*)padop;
2956 padop->op_flags = (U8)flags;
2957 if (PL_opargs[type] & OA_RETSCALAR)
2959 if (PL_opargs[type] & OA_TARGET)
2960 padop->op_targ = pad_alloc(type, SVs_PADTMP);
2961 return CHECKOP(type, padop);
2965 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
2971 return newPADOP(type, flags, SvREFCNT_inc(gv));
2973 return newSVOP(type, flags, SvREFCNT_inc(gv));
2978 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
2982 NewOp(1101, pvop, 1, PVOP);
2983 pvop->op_type = (OPCODE)type;
2984 pvop->op_ppaddr = PL_ppaddr[type];
2986 pvop->op_next = (OP*)pvop;
2987 pvop->op_flags = (U8)flags;
2988 if (PL_opargs[type] & OA_RETSCALAR)
2990 if (PL_opargs[type] & OA_TARGET)
2991 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
2992 return CHECKOP(type, pvop);
2996 Perl_package(pTHX_ OP *o)
3001 save_hptr(&PL_curstash);
3002 save_item(PL_curstname);
3004 name = SvPV(cSVOPo->op_sv, len);
3005 PL_curstash = gv_stashpvn(name, len, TRUE);
3006 sv_setpvn(PL_curstname, name, len);
3009 PL_hints |= HINT_BLOCK_SCOPE;
3010 PL_copline = NOLINE;
3015 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3021 if (idop->op_type != OP_CONST)
3022 Perl_croak(aTHX_ "Module name must be constant");
3026 if (version != Nullop) {
3027 SV *vesv = ((SVOP*)version)->op_sv;
3029 if (arg == Nullop && !SvNIOKp(vesv)) {
3036 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3037 Perl_croak(aTHX_ "Version number must be constant number");
3039 /* Make copy of idop so we don't free it twice */
3040 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3042 /* Fake up a method call to VERSION */
3043 meth = newSVpvn("VERSION",7);
3044 sv_upgrade(meth, SVt_PVIV);
3045 (void)SvIOK_on(meth);
3048 PERL_HASH(hash, SvPVX_const(meth), SvCUR(meth));
3049 SvUV_set(meth, hash);
3051 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3052 append_elem(OP_LIST,
3053 prepend_elem(OP_LIST, pack, list(version)),
3054 newSVOP(OP_METHOD_NAMED, 0, meth)));
3058 /* Fake up an import/unimport */
3059 if (arg && arg->op_type == OP_STUB)
3060 imop = arg; /* no import on explicit () */
3061 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3062 imop = Nullop; /* use 5.0; */
3067 /* Make copy of idop so we don't free it twice */
3068 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3070 /* Fake up a method call to import/unimport */
3071 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);
3072 (void)SvUPGRADE(meth, SVt_PVIV);
3073 (void)SvIOK_on(meth);
3076 PERL_HASH(hash, SvPVX_const(meth), SvCUR(meth));
3077 SvUV_set(meth, hash);
3079 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3080 append_elem(OP_LIST,
3081 prepend_elem(OP_LIST, pack, list(arg)),
3082 newSVOP(OP_METHOD_NAMED, 0, meth)));
3085 /* Fake up the BEGIN {}, which does its thing immediately. */
3087 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3090 append_elem(OP_LINESEQ,
3091 append_elem(OP_LINESEQ,
3092 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, idop)),
3093 newSTATEOP(0, Nullch, veop)),
3094 newSTATEOP(0, Nullch, imop) ));
3096 /* The "did you use incorrect case?" warning used to be here.
3097 * The problem is that on case-insensitive filesystems one
3098 * might get false positives for "use" (and "require"):
3099 * "use Strict" or "require CARP" will work. This causes
3100 * portability problems for the script: in case-strict
3101 * filesystems the script will stop working.
3103 * The "incorrect case" warning checked whether "use Foo"
3104 * imported "Foo" to your namespace, but that is wrong, too:
3105 * there is no requirement nor promise in the language that
3106 * a Foo.pm should or would contain anything in package "Foo".
3108 * There is very little Configure-wise that can be done, either:
3109 * the case-sensitivity of the build filesystem of Perl does not
3110 * help in guessing the case-sensitivity of the runtime environment.
3113 PL_hints |= HINT_BLOCK_SCOPE;
3114 PL_copline = NOLINE;
3116 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3120 =head1 Embedding Functions
3122 =for apidoc load_module
3124 Loads the module whose name is pointed to by the string part of name.
3125 Note that the actual module name, not its filename, should be given.
3126 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3127 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3128 (or 0 for no flags). ver, if specified, provides version semantics
3129 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3130 arguments can be used to specify arguments to the module's import()
3131 method, similar to C<use Foo::Bar VERSION LIST>.
3136 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3139 va_start(args, ver);
3140 vload_module(flags, name, ver, &args);
3144 #ifdef PERL_IMPLICIT_CONTEXT
3146 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3150 va_start(args, ver);
3151 vload_module(flags, name, ver, &args);
3157 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3159 OP *modname, *veop, *imop;
3161 modname = newSVOP(OP_CONST, 0, name);
3162 modname->op_private |= OPpCONST_BARE;
3164 veop = newSVOP(OP_CONST, 0, ver);
3168 if (flags & PERL_LOADMOD_NOIMPORT) {
3169 imop = sawparens(newNULLLIST());
3171 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3172 imop = va_arg(*args, OP*);
3177 sv = va_arg(*args, SV*);
3179 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3180 sv = va_arg(*args, SV*);
3184 const line_t ocopline = PL_copline;
3185 COP * const ocurcop = PL_curcop;
3186 const int oexpect = PL_expect;
3188 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3189 veop, modname, imop);
3190 PL_expect = oexpect;
3191 PL_copline = ocopline;
3192 PL_curcop = ocurcop;
3197 Perl_dofile(pTHX_ OP *term)
3202 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3203 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
3204 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3206 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3207 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3208 append_elem(OP_LIST, term,
3209 scalar(newUNOP(OP_RV2CV, 0,
3214 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3220 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3222 return newBINOP(OP_LSLICE, flags,
3223 list(force_list(subscript)),
3224 list(force_list(listval)) );
3228 S_is_list_assignment(pTHX_ register const OP *o)
3233 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3234 o = cUNOPo->op_first;
3236 if (o->op_type == OP_COND_EXPR) {
3237 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3238 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3243 yyerror("Assignment to both a list and a scalar");
3247 if (o->op_type == OP_LIST &&
3248 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3249 o->op_private & OPpLVAL_INTRO)
3252 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3253 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3254 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3257 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3260 if (o->op_type == OP_RV2SV)
3267 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3272 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3273 return newLOGOP(optype, 0,
3274 mod(scalar(left), optype),
3275 newUNOP(OP_SASSIGN, 0, scalar(right)));
3278 return newBINOP(optype, OPf_STACKED,
3279 mod(scalar(left), optype), scalar(right));
3283 if (is_list_assignment(left)) {
3287 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3288 left = mod(left, OP_AASSIGN);
3296 /* optimise C<my @x = ()> to C<my @x>, and likewise for hashes */
3297 if ((left->op_type == OP_PADAV || left->op_type == OP_PADHV)
3298 && right->op_type == OP_STUB
3299 && (left->op_private & OPpLVAL_INTRO))
3302 left->op_flags &= ~(OPf_REF|OPf_SPECIAL);
3305 curop = list(force_list(left));
3306 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3307 o->op_private = (U8)(0 | (flags >> 8));
3309 /* PL_generation sorcery:
3310 * an assignment like ($a,$b) = ($c,$d) is easier than
3311 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3312 * To detect whether there are common vars, the global var
3313 * PL_generation is incremented for each assign op we compile.
3314 * Then, while compiling the assign op, we run through all the
3315 * variables on both sides of the assignment, setting a spare slot
3316 * in each of them to PL_generation. If any of them already have
3317 * that value, we know we've got commonality. We could use a
3318 * single bit marker, but then we'd have to make 2 passes, first
3319 * to clear the flag, then to test and set it. To find somewhere
3320 * to store these values, evil chicanery is done with SvCUR().
3323 if (!(left->op_private & OPpLVAL_INTRO)) {
3326 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3327 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3328 if (curop->op_type == OP_GV) {
3329 GV *gv = cGVOPx_gv(curop);
3330 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3332 SvCUR_set(gv, PL_generation);
3334 else if (curop->op_type == OP_PADSV ||
3335 curop->op_type == OP_PADAV ||
3336 curop->op_type == OP_PADHV ||
3337 curop->op_type == OP_PADANY)
3339 if (PAD_COMPNAME_GEN(curop->op_targ)
3340 == (STRLEN)PL_generation)
3342 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
3345 else if (curop->op_type == OP_RV2CV)
3347 else if (curop->op_type == OP_RV2SV ||
3348 curop->op_type == OP_RV2AV ||
3349 curop->op_type == OP_RV2HV ||
3350 curop->op_type == OP_RV2GV) {
3351 if (lastop->op_type != OP_GV) /* funny deref? */
3354 else if (curop->op_type == OP_PUSHRE) {
3355 if (((PMOP*)curop)->op_pmreplroot) {
3357 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3358 ((PMOP*)curop)->op_pmreplroot));
3360 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3362 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3364 SvCUR_set(gv, PL_generation);
3373 o->op_private |= OPpASSIGN_COMMON;
3375 if (right && right->op_type == OP_SPLIT) {
3377 if ((tmpop = ((LISTOP*)right)->op_first) &&
3378 tmpop->op_type == OP_PUSHRE)
3380 PMOP *pm = (PMOP*)tmpop;
3381 if (left->op_type == OP_RV2AV &&
3382 !(left->op_private & OPpLVAL_INTRO) &&
3383 !(o->op_private & OPpASSIGN_COMMON) )
3385 tmpop = ((UNOP*)left)->op_first;
3386 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3388 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3389 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3391 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3392 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3394 pm->op_pmflags |= PMf_ONCE;
3395 tmpop = cUNOPo->op_first; /* to list (nulled) */
3396 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3397 tmpop->op_sibling = Nullop; /* don't free split */
3398 right->op_next = tmpop->op_next; /* fix starting loc */
3399 op_free(o); /* blow off assign */
3400 right->op_flags &= ~OPf_WANT;
3401 /* "I don't know and I don't care." */
3406 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3407 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3409 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3411 sv_setiv(sv, PL_modcount+1);
3419 right = newOP(OP_UNDEF, 0);
3420 if (right->op_type == OP_READLINE) {
3421 right->op_flags |= OPf_STACKED;
3422 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3425 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3426 o = newBINOP(OP_SASSIGN, flags,
3427 scalar(right), mod(scalar(left), OP_SASSIGN) );
3439 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3442 const U32 seq = intro_my();
3445 NewOp(1101, cop, 1, COP);
3446 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3447 cop->op_type = OP_DBSTATE;
3448 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3451 cop->op_type = OP_NEXTSTATE;
3452 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3454 cop->op_flags = (U8)flags;
3455 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3457 cop->op_private |= NATIVE_HINTS;
3459 PL_compiling.op_private = cop->op_private;
3460 cop->op_next = (OP*)cop;
3463 cop->cop_label = label;
3464 PL_hints |= HINT_BLOCK_SCOPE;
3467 cop->cop_arybase = PL_curcop->cop_arybase;
3468 if (specialWARN(PL_curcop->cop_warnings))
3469 cop->cop_warnings = PL_curcop->cop_warnings ;
3471 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3472 if (specialCopIO(PL_curcop->cop_io))
3473 cop->cop_io = PL_curcop->cop_io;
3475 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3478 if (PL_copline == NOLINE)
3479 CopLINE_set(cop, CopLINE(PL_curcop));
3481 CopLINE_set(cop, PL_copline);
3482 PL_copline = NOLINE;
3485 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3487 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3489 CopSTASH_set(cop, PL_curstash);
3491 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3492 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3493 if (svp && *svp != &PL_sv_undef ) {
3494 (void)SvIOK_on(*svp);
3495 SvIV_set(*svp, PTR2IV(cop));
3499 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3504 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3507 return new_logop(type, flags, &first, &other);
3511 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3516 OP *first = *firstp;
3517 OP *other = *otherp;
3519 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3520 return newBINOP(type, flags, scalar(first), scalar(other));
3522 scalarboolean(first);
3523 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3524 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3525 if (type == OP_AND || type == OP_OR) {
3531 first = *firstp = cUNOPo->op_first;
3533 first->op_next = o->op_next;
3534 cUNOPo->op_first = Nullop;
3538 if (first->op_type == OP_CONST) {
3539 if (first->op_private & OPpCONST_STRICT)
3540 no_bareword_allowed(first);
3541 else if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3542 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3543 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
3544 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
3545 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
3548 if (other->op_type == OP_CONST)
3549 other->op_private |= OPpCONST_SHORTCIRCUIT;
3553 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
3554 const OP *o2 = other;
3555 if ( ! (o2->op_type == OP_LIST
3556 && (( o2 = cUNOPx(o2)->op_first))
3557 && o2->op_type == OP_PUSHMARK
3558 && (( o2 = o2->op_sibling)) )
3561 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
3562 || o2->op_type == OP_PADHV)
3563 && o2->op_private & OPpLVAL_INTRO
3564 && ckWARN(WARN_DEPRECATED))
3566 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
3567 "Deprecated use of my() in false conditional");
3572 if (first->op_type == OP_CONST)
3573 first->op_private |= OPpCONST_SHORTCIRCUIT;
3577 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS) &&
3578 type != OP_DOR) /* [#24076] Don't warn for <FH> err FOO. */
3580 const OP *k1 = ((UNOP*)first)->op_first;
3581 const OP *k2 = k1->op_sibling;
3583 switch (first->op_type)
3586 if (k2 && k2->op_type == OP_READLINE
3587 && (k2->op_flags & OPf_STACKED)
3588 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3590 warnop = k2->op_type;
3595 if (k1->op_type == OP_READDIR
3596 || k1->op_type == OP_GLOB
3597 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3598 || k1->op_type == OP_EACH)
3600 warnop = ((k1->op_type == OP_NULL)
3601 ? (OPCODE)k1->op_targ : k1->op_type);
3606 const line_t oldline = CopLINE(PL_curcop);
3607 CopLINE_set(PL_curcop, PL_copline);
3608 Perl_warner(aTHX_ packWARN(WARN_MISC),
3609 "Value of %s%s can be \"0\"; test with defined()",
3611 ((warnop == OP_READLINE || warnop == OP_GLOB)
3612 ? " construct" : "() operator"));
3613 CopLINE_set(PL_curcop, oldline);
3620 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3621 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3623 NewOp(1101, logop, 1, LOGOP);
3625 logop->op_type = (OPCODE)type;
3626 logop->op_ppaddr = PL_ppaddr[type];
3627 logop->op_first = first;
3628 logop->op_flags = flags | OPf_KIDS;
3629 logop->op_other = LINKLIST(other);
3630 logop->op_private = (U8)(1 | (flags >> 8));
3632 /* establish postfix order */
3633 logop->op_next = LINKLIST(first);
3634 first->op_next = (OP*)logop;
3635 first->op_sibling = other;
3637 CHECKOP(type,logop);
3639 o = newUNOP(OP_NULL, 0, (OP*)logop);
3646 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3654 return newLOGOP(OP_AND, 0, first, trueop);
3656 return newLOGOP(OP_OR, 0, first, falseop);
3658 scalarboolean(first);
3659 if (first->op_type == OP_CONST) {
3660 if (first->op_private & OPpCONST_BARE &&
3661 first->op_private & OPpCONST_STRICT) {
3662 no_bareword_allowed(first);
3664 if (SvTRUE(((SVOP*)first)->op_sv)) {
3675 NewOp(1101, logop, 1, LOGOP);
3676 logop->op_type = OP_COND_EXPR;
3677 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3678 logop->op_first = first;
3679 logop->op_flags = flags | OPf_KIDS;
3680 logop->op_private = (U8)(1 | (flags >> 8));
3681 logop->op_other = LINKLIST(trueop);
3682 logop->op_next = LINKLIST(falseop);
3684 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
3687 /* establish postfix order */
3688 start = LINKLIST(first);
3689 first->op_next = (OP*)logop;
3691 first->op_sibling = trueop;
3692 trueop->op_sibling = falseop;
3693 o = newUNOP(OP_NULL, 0, (OP*)logop);
3695 trueop->op_next = falseop->op_next = o;
3702 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3711 NewOp(1101, range, 1, LOGOP);
3713 range->op_type = OP_RANGE;
3714 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3715 range->op_first = left;
3716 range->op_flags = OPf_KIDS;
3717 leftstart = LINKLIST(left);
3718 range->op_other = LINKLIST(right);
3719 range->op_private = (U8)(1 | (flags >> 8));
3721 left->op_sibling = right;
3723 range->op_next = (OP*)range;
3724 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3725 flop = newUNOP(OP_FLOP, 0, flip);
3726 o = newUNOP(OP_NULL, 0, flop);
3728 range->op_next = leftstart;
3730 left->op_next = flip;
3731 right->op_next = flop;
3733 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3734 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3735 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3736 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3738 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3739 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3742 if (!flip->op_private || !flop->op_private)
3743 linklist(o); /* blow off optimizer unless constant */
3749 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3753 const bool once = block && block->op_flags & OPf_SPECIAL &&
3754 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3758 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3759 return block; /* do {} while 0 does once */
3760 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3761 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3762 expr = newUNOP(OP_DEFINED, 0,
3763 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3764 } else if (expr->op_flags & OPf_KIDS) {
3765 const OP *k1 = ((UNOP*)expr)->op_first;
3766 const OP *k2 = (k1) ? k1->op_sibling : NULL;
3767 switch (expr->op_type) {
3769 if (k2 && k2->op_type == OP_READLINE
3770 && (k2->op_flags & OPf_STACKED)
3771 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3772 expr = newUNOP(OP_DEFINED, 0, expr);
3776 if (k1->op_type == OP_READDIR
3777 || k1->op_type == OP_GLOB
3778 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3779 || k1->op_type == OP_EACH)
3780 expr = newUNOP(OP_DEFINED, 0, expr);
3786 /* if block is null, the next append_elem() would put UNSTACK, a scalar
3787 * op, in listop. This is wrong. [perl #27024] */
3789 block = newOP(OP_NULL, 0);
3790 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3791 o = new_logop(OP_AND, 0, &expr, &listop);
3794 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3796 if (once && o != listop)
3797 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3800 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3802 o->op_flags |= flags;
3804 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3809 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
3810 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
3820 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3821 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3822 expr = newUNOP(OP_DEFINED, 0,
3823 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3824 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3825 const OP *k1 = ((UNOP*)expr)->op_first;
3826 const OP *k2 = (k1) ? k1->op_sibling : NULL;
3827 switch (expr->op_type) {
3829 if (k2 && k2->op_type == OP_READLINE
3830 && (k2->op_flags & OPf_STACKED)
3831 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3832 expr = newUNOP(OP_DEFINED, 0, expr);
3836 if (k1->op_type == OP_READDIR
3837 || k1->op_type == OP_GLOB
3838 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3839 || k1->op_type == OP_EACH)
3840 expr = newUNOP(OP_DEFINED, 0, expr);
3846 block = newOP(OP_NULL, 0);
3847 else if (cont || has_my) {
3848 block = scope(block);
3852 next = LINKLIST(cont);
3855 OP *unstack = newOP(OP_UNSTACK, 0);
3858 cont = append_elem(OP_LINESEQ, cont, unstack);
3861 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3862 redo = LINKLIST(listop);
3865 PL_copline = (line_t)whileline;
3867 o = new_logop(OP_AND, 0, &expr, &listop);
3868 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3869 op_free(expr); /* oops, it's a while (0) */
3871 return Nullop; /* listop already freed by new_logop */
3874 ((LISTOP*)listop)->op_last->op_next =
3875 (o == listop ? redo : LINKLIST(o));
3881 NewOp(1101,loop,1,LOOP);
3882 loop->op_type = OP_ENTERLOOP;
3883 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3884 loop->op_private = 0;
3885 loop->op_next = (OP*)loop;
3888 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3890 loop->op_redoop = redo;
3891 loop->op_lastop = o;
3892 o->op_private |= loopflags;
3895 loop->op_nextop = next;
3897 loop->op_nextop = o;
3899 o->op_flags |= flags;
3900 o->op_private |= (flags >> 8);
3905 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
3910 PADOFFSET padoff = 0;
3915 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
3916 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
3917 sv->op_type = OP_RV2GV;
3918 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3920 else if (sv->op_type == OP_PADSV) { /* private variable */
3921 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
3922 padoff = sv->op_targ;
3927 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3928 padoff = sv->op_targ;
3930 iterflags |= OPf_SPECIAL;
3935 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3938 const I32 offset = pad_findmy("$_");
3939 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
3940 sv = newGVOP(OP_GV, 0, PL_defgv);
3946 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3947 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3948 iterflags |= OPf_STACKED;
3950 else if (expr->op_type == OP_NULL &&
3951 (expr->op_flags & OPf_KIDS) &&
3952 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3954 /* Basically turn for($x..$y) into the same as for($x,$y), but we
3955 * set the STACKED flag to indicate that these values are to be
3956 * treated as min/max values by 'pp_iterinit'.
3958 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
3959 LOGOP* range = (LOGOP*) flip->op_first;
3960 OP* left = range->op_first;
3961 OP* right = left->op_sibling;
3964 range->op_flags &= ~OPf_KIDS;
3965 range->op_first = Nullop;
3967 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
3968 listop->op_first->op_next = range->op_next;
3969 left->op_next = range->op_other;
3970 right->op_next = (OP*)listop;
3971 listop->op_next = listop->op_first;
3974 expr = (OP*)(listop);
3976 iterflags |= OPf_STACKED;
3979 expr = mod(force_list(expr), OP_GREPSTART);
3982 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
3983 append_elem(OP_LIST, expr, scalar(sv))));
3984 assert(!loop->op_next);
3985 /* for my $x () sets OPpLVAL_INTRO;
3986 * for our $x () sets OPpOUR_INTRO */
3987 loop->op_private = (U8)iterpflags;
3988 #ifdef PL_OP_SLAB_ALLOC
3991 NewOp(1234,tmp,1,LOOP);
3992 Copy(loop,tmp,1,LISTOP);
3997 Renew(loop, 1, LOOP);
3999 loop->op_targ = padoff;
4000 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4001 PL_copline = forline;
4002 return newSTATEOP(0, label, wop);
4006 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4011 if (type != OP_GOTO || label->op_type == OP_CONST) {
4012 /* "last()" means "last" */
4013 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4014 o = newOP(type, OPf_SPECIAL);
4016 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4017 ? SvPVx(((SVOP*)label)->op_sv, n_a)
4023 /* Check whether it's going to be a goto &function */
4024 if (label->op_type == OP_ENTERSUB
4025 && !(label->op_flags & OPf_STACKED))
4026 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4027 o = newUNOP(type, OPf_STACKED, label);
4029 PL_hints |= HINT_BLOCK_SCOPE;
4034 =for apidoc cv_undef
4036 Clear out all the active components of a CV. This can happen either
4037 by an explicit C<undef &foo>, or by the reference count going to zero.
4038 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4039 children can still follow the full lexical scope chain.
4045 Perl_cv_undef(pTHX_ CV *cv)
4049 if (CvFILE(cv) && !CvXSUB(cv)) {
4050 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4051 Safefree(CvFILE(cv));
4056 if (!CvXSUB(cv) && CvROOT(cv)) {
4058 Perl_croak(aTHX_ "Can't undef active subroutine");
4061 PAD_SAVE_SETNULLPAD();
4063 op_free(CvROOT(cv));
4064 CvROOT(cv) = Nullop;
4067 SvPOK_off((SV*)cv); /* forget prototype */
4072 /* remove CvOUTSIDE unless this is an undef rather than a free */
4073 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4074 if (!CvWEAKOUTSIDE(cv))
4075 SvREFCNT_dec(CvOUTSIDE(cv));
4076 CvOUTSIDE(cv) = Nullcv;
4079 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4085 /* delete all flags except WEAKOUTSIDE */
4086 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4090 Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p)
4092 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX_const(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4093 SV* msg = sv_newmortal();
4097 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4098 sv_setpv(msg, "Prototype mismatch:");
4100 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4102 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (const SV *)cv);
4104 Perl_sv_catpv(aTHX_ msg, ": none");
4105 sv_catpv(msg, " vs ");
4107 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4109 sv_catpv(msg, "none");
4110 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
4114 static void const_sv_xsub(pTHX_ CV* cv);
4118 =head1 Optree Manipulation Functions
4120 =for apidoc cv_const_sv
4122 If C<cv> is a constant sub eligible for inlining. returns the constant
4123 value returned by the sub. Otherwise, returns NULL.
4125 Constant subs can be created with C<newCONSTSUB> or as described in
4126 L<perlsub/"Constant Functions">.
4131 Perl_cv_const_sv(pTHX_ CV *cv)
4133 if (!cv || !CvCONST(cv))
4135 return (SV*)CvXSUBANY(cv).any_ptr;
4138 /* op_const_sv: examine an optree to determine whether it's in-lineable.
4139 * Can be called in 3 ways:
4142 * look for a single OP_CONST with attached value: return the value
4144 * cv && CvCLONE(cv) && !CvCONST(cv)
4146 * examine the clone prototype, and if contains only a single
4147 * OP_CONST referencing a pad const, or a single PADSV referencing
4148 * an outer lexical, return a non-zero value to indicate the CV is
4149 * a candidate for "constizing" at clone time
4153 * We have just cloned an anon prototype that was marked as a const
4154 * candidiate. Try to grab the current value, and in the case of
4155 * PADSV, ignore it if it has multiple references. Return the value.
4159 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
4166 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4167 o = cLISTOPo->op_first->op_sibling;
4169 for (; o; o = o->op_next) {
4170 OPCODE type = o->op_type;
4172 if (sv && o->op_next == o)
4174 if (o->op_next != o) {
4175 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4177 if (type == OP_DBSTATE)
4180 if (type == OP_LEAVESUB || type == OP_RETURN)
4184 if (type == OP_CONST && cSVOPo->op_sv)
4186 else if (cv && type == OP_CONST) {
4187 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4191 else if (cv && type == OP_PADSV) {
4192 if (CvCONST(cv)) { /* newly cloned anon */
4193 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4194 /* the candidate should have 1 ref from this pad and 1 ref
4195 * from the parent */
4196 if (!sv || SvREFCNT(sv) != 2)
4203 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4204 sv = &PL_sv_undef; /* an arbitrary non-null value */
4215 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4226 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4230 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4232 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4236 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4247 const char * const name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4250 assert(proto->op_type == OP_CONST);
4251 ps = SvPVx(((SVOP*)proto)->op_sv, ps_len);
4256 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4257 SV *sv = sv_newmortal();
4258 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4259 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4260 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4261 aname = SvPVX_const(sv);
4265 gv = name ? gv_fetchsv(cSVOPo->op_sv,
4266 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4268 : gv_fetchpv(aname ? aname
4269 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4270 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4280 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4281 maximum a prototype before. */
4282 if (SvTYPE(gv) > SVt_NULL) {
4283 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4284 && ckWARN_d(WARN_PROTOTYPE))
4286 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4288 cv_ckproto((CV*)gv, NULL, ps);
4291 sv_setpvn((SV*)gv, ps, ps_len);
4293 sv_setiv((SV*)gv, -1);
4294 SvREFCNT_dec(PL_compcv);
4295 cv = PL_compcv = NULL;
4296 PL_sub_generation++;
4300 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4302 #ifdef GV_UNIQUE_CHECK
4303 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4304 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4308 if (!block || !ps || *ps || attrs)
4311 const_sv = op_const_sv(block, Nullcv);
4314 const bool exists = CvROOT(cv) || CvXSUB(cv);
4316 #ifdef GV_UNIQUE_CHECK
4317 if (exists && GvUNIQUE(gv)) {
4318 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4322 /* if the subroutine doesn't exist and wasn't pre-declared
4323 * with a prototype, assume it will be AUTOLOADed,
4324 * skipping the prototype check
4326 if (exists || SvPOK(cv))
4327 cv_ckproto(cv, gv, ps);
4328 /* already defined (or promised)? */
4329 if (exists || GvASSUMECV(gv)) {
4330 if (!block && !attrs) {
4331 if (CvFLAGS(PL_compcv)) {
4332 /* might have had built-in attrs applied */
4333 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4335 /* just a "sub foo;" when &foo is already defined */
4336 SAVEFREESV(PL_compcv);
4339 /* ahem, death to those who redefine active sort subs */
4340 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4341 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4343 if (ckWARN(WARN_REDEFINE)
4345 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4347 const line_t oldline = CopLINE(PL_curcop);
4348 if (PL_copline != NOLINE)
4349 CopLINE_set(PL_curcop, PL_copline);
4350 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4351 CvCONST(cv) ? "Constant subroutine %s redefined"
4352 : "Subroutine %s redefined", name);
4353 CopLINE_set(PL_curcop, oldline);
4361 (void)SvREFCNT_inc(const_sv);
4363 assert(!CvROOT(cv) && !CvCONST(cv));
4364 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
4365 CvXSUBANY(cv).any_ptr = const_sv;
4366 CvXSUB(cv) = const_sv_xsub;
4371 cv = newCONSTSUB(NULL, name, const_sv);
4374 SvREFCNT_dec(PL_compcv);
4376 PL_sub_generation++;
4383 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4384 * before we clobber PL_compcv.
4388 /* Might have had built-in attributes applied -- propagate them. */
4389 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4390 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4391 stash = GvSTASH(CvGV(cv));
4392 else if (CvSTASH(cv))
4393 stash = CvSTASH(cv);
4395 stash = PL_curstash;
4398 /* possibly about to re-define existing subr -- ignore old cv */
4399 rcv = (SV*)PL_compcv;
4400 if (name && GvSTASH(gv))
4401 stash = GvSTASH(gv);
4403 stash = PL_curstash;
4405 apply_attrs(stash, rcv, attrs, FALSE);
4407 if (cv) { /* must reuse cv if autoloaded */
4409 /* got here with just attrs -- work done, so bug out */
4410 SAVEFREESV(PL_compcv);
4413 /* transfer PL_compcv to cv */
4415 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4416 if (!CvWEAKOUTSIDE(cv))
4417 SvREFCNT_dec(CvOUTSIDE(cv));
4418 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4419 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4420 CvOUTSIDE(PL_compcv) = 0;
4421 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4422 CvPADLIST(PL_compcv) = 0;
4423 /* inner references to PL_compcv must be fixed up ... */
4424 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4425 /* ... before we throw it away */
4426 SvREFCNT_dec(PL_compcv);
4428 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4429 ++PL_sub_generation;
4436 PL_sub_generation++;
4440 CvFILE_set_from_cop(cv, PL_curcop);
4441 CvSTASH(cv) = PL_curstash;
4444 sv_setpvn((SV*)cv, ps, ps_len);
4446 if (PL_error_count) {
4450 const char *s = strrchr(name, ':');
4452 if (strEQ(s, "BEGIN")) {
4453 const char not_safe[] =
4454 "BEGIN not safe after errors--compilation aborted";
4455 if (PL_in_eval & EVAL_KEEPERR)
4456 Perl_croak(aTHX_ not_safe);
4458 /* force display of errors found but not reported */
4459 sv_catpv(ERRSV, not_safe);
4460 Perl_croak(aTHX_ "%"SVf, ERRSV);
4469 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4470 mod(scalarseq(block), OP_LEAVESUBLV));
4473 /* This makes sub {}; work as expected. */
4474 if (block->op_type == OP_STUB) {
4476 block = newSTATEOP(0, Nullch, 0);
4478 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4480 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4481 OpREFCNT_set(CvROOT(cv), 1);
4482 CvSTART(cv) = LINKLIST(CvROOT(cv));
4483 CvROOT(cv)->op_next = 0;
4484 CALL_PEEP(CvSTART(cv));
4486 /* now that optimizer has done its work, adjust pad values */
4488 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4491 assert(!CvCONST(cv));
4492 if (ps && !*ps && op_const_sv(block, cv))
4496 if (name || aname) {
4498 const char *tname = (name ? name : aname);
4500 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4501 SV *sv = NEWSV(0,0);
4502 SV *tmpstr = sv_newmortal();
4503 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4507 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4509 (long)PL_subline, (long)CopLINE(PL_curcop));
4510 gv_efullname3(tmpstr, gv, Nullch);
4511 hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
4512 hv = GvHVn(db_postponed);
4513 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))
4514 && (pcv = GvCV(db_postponed)))
4520 call_sv((SV*)pcv, G_DISCARD);
4524 if ((s = strrchr(tname,':')))
4529 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4532 if (strEQ(s, "BEGIN") && !PL_error_count) {
4533 const I32 oldscope = PL_scopestack_ix;
4535 SAVECOPFILE(&PL_compiling);
4536 SAVECOPLINE(&PL_compiling);
4539 PL_beginav = newAV();
4540 DEBUG_x( dump_sub(gv) );
4541 av_push(PL_beginav, (SV*)cv);
4542 GvCV(gv) = 0; /* cv has been hijacked */
4543 call_list(oldscope, PL_beginav);
4545 PL_curcop = &PL_compiling;
4546 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4549 else if (strEQ(s, "END") && !PL_error_count) {
4552 DEBUG_x( dump_sub(gv) );
4553 av_unshift(PL_endav, 1);
4554 av_store(PL_endav, 0, (SV*)cv);
4555 GvCV(gv) = 0; /* cv has been hijacked */
4557 else if (strEQ(s, "CHECK") && !PL_error_count) {
4559 PL_checkav = newAV();
4560 DEBUG_x( dump_sub(gv) );
4561 if (PL_main_start && ckWARN(WARN_VOID))
4562 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4563 av_unshift(PL_checkav, 1);
4564 av_store(PL_checkav, 0, (SV*)cv);
4565 GvCV(gv) = 0; /* cv has been hijacked */
4567 else if (strEQ(s, "INIT") && !PL_error_count) {
4569 PL_initav = newAV();
4570 DEBUG_x( dump_sub(gv) );
4571 if (PL_main_start && ckWARN(WARN_VOID))
4572 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4573 av_push(PL_initav, (SV*)cv);
4574 GvCV(gv) = 0; /* cv has been hijacked */
4579 PL_copline = NOLINE;
4584 /* XXX unsafe for threads if eval_owner isn't held */
4586 =for apidoc newCONSTSUB
4588 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4589 eligible for inlining at compile-time.
4595 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
4602 SAVECOPLINE(PL_curcop);
4603 CopLINE_set(PL_curcop, PL_copline);
4606 PL_hints &= ~HINT_BLOCK_SCOPE;
4609 SAVESPTR(PL_curstash);
4610 SAVECOPSTASH(PL_curcop);
4611 PL_curstash = stash;
4612 CopSTASH_set(PL_curcop,stash);
4615 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4616 CvXSUBANY(cv).any_ptr = sv;
4618 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
4621 CopSTASH_free(PL_curcop);
4629 =for apidoc U||newXS
4631 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4637 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
4639 GV *gv = gv_fetchpv(name ? name :
4640 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4641 GV_ADDMULTI, SVt_PVCV);
4645 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4647 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4649 /* just a cached method */
4653 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4654 /* already defined (or promised) */
4655 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
4656 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4657 && strEQ(HvNAME_get(GvSTASH(CvGV(cv))), "autouse"))) {
4658 const line_t oldline = CopLINE(PL_curcop);
4659 if (PL_copline != NOLINE)
4660 CopLINE_set(PL_curcop, PL_copline);
4661 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4662 CvCONST(cv) ? "Constant subroutine %s redefined"
4663 : "Subroutine %s redefined"
4665 CopLINE_set(PL_curcop, oldline);
4672 if (cv) /* must reuse cv if autoloaded */
4675 cv = (CV*)NEWSV(1105,0);
4676 sv_upgrade((SV *)cv, SVt_PVCV);
4680 PL_sub_generation++;
4684 (void)gv_fetchfile(filename);
4685 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
4686 an external constant string */
4687 CvXSUB(cv) = subaddr;
4690 const char *s = strrchr(name,':');
4696 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4699 if (strEQ(s, "BEGIN")) {
4701 PL_beginav = newAV();
4702 av_push(PL_beginav, (SV*)cv);
4703 GvCV(gv) = 0; /* cv has been hijacked */
4705 else if (strEQ(s, "END")) {
4708 av_unshift(PL_endav, 1);
4709 av_store(PL_endav, 0, (SV*)cv);
4710 GvCV(gv) = 0; /* cv has been hijacked */
4712 else if (strEQ(s, "CHECK")) {
4714 PL_checkav = newAV();
4715 if (PL_main_start && ckWARN(WARN_VOID))
4716 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4717 av_unshift(PL_checkav, 1);
4718 av_store(PL_checkav, 0, (SV*)cv);
4719 GvCV(gv) = 0; /* cv has been hijacked */
4721 else if (strEQ(s, "INIT")) {
4723 PL_initav = newAV();
4724 if (PL_main_start && ckWARN(WARN_VOID))
4725 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4726 av_push(PL_initav, (SV*)cv);
4727 GvCV(gv) = 0; /* cv has been hijacked */
4738 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4744 gv = gv_fetchsv(cSVOPo->op_sv, TRUE, SVt_PVFM);
4746 gv = gv_fetchpv("STDOUT", TRUE, SVt_PVFM);
4748 #ifdef GV_UNIQUE_CHECK
4750 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4754 if ((cv = GvFORM(gv))) {
4755 if (ckWARN(WARN_REDEFINE)) {
4756 const line_t oldline = CopLINE(PL_curcop);
4757 if (PL_copline != NOLINE)
4758 CopLINE_set(PL_curcop, PL_copline);
4759 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4760 o ? "Format %"SVf" redefined"
4761 : "Format STDOUT redefined" ,cSVOPo->op_sv);
4762 CopLINE_set(PL_curcop, oldline);
4769 CvFILE_set_from_cop(cv, PL_curcop);
4772 pad_tidy(padtidy_FORMAT);
4773 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4774 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4775 OpREFCNT_set(CvROOT(cv), 1);
4776 CvSTART(cv) = LINKLIST(CvROOT(cv));
4777 CvROOT(cv)->op_next = 0;
4778 CALL_PEEP(CvSTART(cv));
4780 PL_copline = NOLINE;
4785 Perl_newANONLIST(pTHX_ OP *o)
4787 return newUNOP(OP_REFGEN, 0,
4788 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4792 Perl_newANONHASH(pTHX_ OP *o)
4794 return newUNOP(OP_REFGEN, 0,
4795 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4799 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4801 return newANONATTRSUB(floor, proto, Nullop, block);
4805 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4807 return newUNOP(OP_REFGEN, 0,
4808 newSVOP(OP_ANONCODE, 0,
4809 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
4813 Perl_oopsAV(pTHX_ OP *o)
4816 switch (o->op_type) {
4818 o->op_type = OP_PADAV;
4819 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4820 return ref(o, OP_RV2AV);
4823 o->op_type = OP_RV2AV;
4824 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4829 if (ckWARN_d(WARN_INTERNAL))
4830 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
4837 Perl_oopsHV(pTHX_ OP *o)
4840 switch (o->op_type) {
4843 o->op_type = OP_PADHV;
4844 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4845 return ref(o, OP_RV2HV);
4849 o->op_type = OP_RV2HV;
4850 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
4855 if (ckWARN_d(WARN_INTERNAL))
4856 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
4863 Perl_newAVREF(pTHX_ OP *o)
4866 if (o->op_type == OP_PADANY) {
4867 o->op_type = OP_PADAV;
4868 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4871 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
4872 && ckWARN(WARN_DEPRECATED)) {
4873 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4874 "Using an array as a reference is deprecated");
4876 return newUNOP(OP_RV2AV, 0, scalar(o));
4880 Perl_newGVREF(pTHX_ I32 type, OP *o)
4882 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
4883 return newUNOP(OP_NULL, 0, o);
4884 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
4888 Perl_newHVREF(pTHX_ OP *o)
4891 if (o->op_type == OP_PADANY) {
4892 o->op_type = OP_PADHV;
4893 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4896 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
4897 && ckWARN(WARN_DEPRECATED)) {
4898 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4899 "Using a hash as a reference is deprecated");
4901 return newUNOP(OP_RV2HV, 0, scalar(o));
4905 Perl_oopsCV(pTHX_ OP *o)
4907 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
4910 NORETURN_FUNCTION_END;
4914 Perl_newCVREF(pTHX_ I32 flags, OP *o)
4916 return newUNOP(OP_RV2CV, flags, scalar(o));
4920 Perl_newSVREF(pTHX_ OP *o)
4923 if (o->op_type == OP_PADANY) {
4924 o->op_type = OP_PADSV;
4925 o->op_ppaddr = PL_ppaddr[OP_PADSV];
4928 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4929 o->op_flags |= OPpDONE_SVREF;
4932 return newUNOP(OP_RV2SV, 0, scalar(o));
4935 /* Check routines. See the comments at the top of this file for details
4936 * on when these are called */
4939 Perl_ck_anoncode(pTHX_ OP *o)
4941 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
4942 cSVOPo->op_sv = Nullsv;
4947 Perl_ck_bitop(pTHX_ OP *o)
4949 #define OP_IS_NUMCOMPARE(op) \
4950 ((op) == OP_LT || (op) == OP_I_LT || \
4951 (op) == OP_GT || (op) == OP_I_GT || \
4952 (op) == OP_LE || (op) == OP_I_LE || \
4953 (op) == OP_GE || (op) == OP_I_GE || \
4954 (op) == OP_EQ || (op) == OP_I_EQ || \
4955 (op) == OP_NE || (op) == OP_I_NE || \
4956 (op) == OP_NCMP || (op) == OP_I_NCMP)
4957 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4958 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
4959 && (o->op_type == OP_BIT_OR
4960 || o->op_type == OP_BIT_AND
4961 || o->op_type == OP_BIT_XOR))
4963 const OP * const left = cBINOPo->op_first;
4964 const OP * const right = left->op_sibling;
4965 if ((OP_IS_NUMCOMPARE(left->op_type) &&
4966 (left->op_flags & OPf_PARENS) == 0) ||
4967 (OP_IS_NUMCOMPARE(right->op_type) &&
4968 (right->op_flags & OPf_PARENS) == 0))
4969 if (ckWARN(WARN_PRECEDENCE))
4970 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4971 "Possible precedence problem on bitwise %c operator",
4972 o->op_type == OP_BIT_OR ? '|'
4973 : o->op_type == OP_BIT_AND ? '&' : '^'
4980 Perl_ck_concat(pTHX_ OP *o)
4982 const OP *kid = cUNOPo->op_first;
4983 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
4984 !(kUNOP->op_first->op_flags & OPf_MOD))
4985 o->op_flags |= OPf_STACKED;
4990 Perl_ck_spair(pTHX_ OP *o)
4993 if (o->op_flags & OPf_KIDS) {
4996 const OPCODE type = o->op_type;
4997 o = modkids(ck_fun(o), type);
4998 kid = cUNOPo->op_first;
4999 newop = kUNOP->op_first->op_sibling;
5001 (newop->op_sibling ||
5002 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5003 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5004 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5008 op_free(kUNOP->op_first);
5009 kUNOP->op_first = newop;
5011 o->op_ppaddr = PL_ppaddr[++o->op_type];
5016 Perl_ck_delete(pTHX_ OP *o)
5020 if (o->op_flags & OPf_KIDS) {
5021 OP *kid = cUNOPo->op_first;
5022 switch (kid->op_type) {
5024 o->op_flags |= OPf_SPECIAL;
5027 o->op_private |= OPpSLICE;
5030 o->op_flags |= OPf_SPECIAL;
5035 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5044 Perl_ck_die(pTHX_ OP *o)
5047 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5053 Perl_ck_eof(pTHX_ OP *o)
5055 const I32 type = o->op_type;
5057 if (o->op_flags & OPf_KIDS) {
5058 if (cLISTOPo->op_first->op_type == OP_STUB) {
5060 o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
5068 Perl_ck_eval(pTHX_ OP *o)
5071 PL_hints |= HINT_BLOCK_SCOPE;
5072 if (o->op_flags & OPf_KIDS) {
5073 SVOP *kid = (SVOP*)cUNOPo->op_first;
5076 o->op_flags &= ~OPf_KIDS;
5079 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
5082 cUNOPo->op_first = 0;
5085 NewOp(1101, enter, 1, LOGOP);
5086 enter->op_type = OP_ENTERTRY;
5087 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5088 enter->op_private = 0;
5090 /* establish postfix order */
5091 enter->op_next = (OP*)enter;
5093 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5094 o->op_type = OP_LEAVETRY;
5095 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5096 enter->op_other = o;
5106 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5108 o->op_targ = (PADOFFSET)PL_hints;
5113 Perl_ck_exit(pTHX_ OP *o)
5116 HV *table = GvHV(PL_hintgv);
5118 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5119 if (svp && *svp && SvTRUE(*svp))
5120 o->op_private |= OPpEXIT_VMSISH;
5122 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5128 Perl_ck_exec(pTHX_ OP *o)
5130 if (o->op_flags & OPf_STACKED) {
5133 kid = cUNOPo->op_first->op_sibling;
5134 if (kid->op_type == OP_RV2GV)
5143 Perl_ck_exists(pTHX_ OP *o)
5146 if (o->op_flags & OPf_KIDS) {
5147 OP *kid = cUNOPo->op_first;
5148 if (kid->op_type == OP_ENTERSUB) {
5149 (void) ref(kid, o->op_type);
5150 if (kid->op_type != OP_RV2CV && !PL_error_count)
5151 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5153 o->op_private |= OPpEXISTS_SUB;
5155 else if (kid->op_type == OP_AELEM)
5156 o->op_flags |= OPf_SPECIAL;
5157 else if (kid->op_type != OP_HELEM)
5158 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5166 Perl_ck_rvconst(pTHX_ register OP *o)
5169 SVOP *kid = (SVOP*)cUNOPo->op_first;
5171 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5172 if (kid->op_type == OP_CONST) {
5175 SV * const kidsv = kid->op_sv;
5177 /* Is it a constant from cv_const_sv()? */
5178 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5179 SV *rsv = SvRV(kidsv);
5180 const int svtype = SvTYPE(rsv);
5181 const char *badtype = Nullch;
5183 switch (o->op_type) {
5185 if (svtype > SVt_PVMG)
5186 badtype = "a SCALAR";
5189 if (svtype != SVt_PVAV)
5190 badtype = "an ARRAY";
5193 if (svtype != SVt_PVHV)
5197 if (svtype != SVt_PVCV)
5202 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5205 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5206 const char *badthing = Nullch;
5207 switch (o->op_type) {
5209 badthing = "a SCALAR";
5212 badthing = "an ARRAY";
5215 badthing = "a HASH";
5220 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
5224 * This is a little tricky. We only want to add the symbol if we
5225 * didn't add it in the lexer. Otherwise we get duplicate strict
5226 * warnings. But if we didn't add it in the lexer, we must at
5227 * least pretend like we wanted to add it even if it existed before,
5228 * or we get possible typo warnings. OPpCONST_ENTERED says
5229 * whether the lexer already added THIS instance of this symbol.
5231 iscv = (o->op_type == OP_RV2CV) * 2;
5233 gv = gv_fetchsv(kidsv,
5234 iscv | !(kid->op_private & OPpCONST_ENTERED),
5237 : o->op_type == OP_RV2SV
5239 : o->op_type == OP_RV2AV
5241 : o->op_type == OP_RV2HV
5244 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5246 kid->op_type = OP_GV;
5247 SvREFCNT_dec(kid->op_sv);
5249 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5250 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5251 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
5253 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
5255 kid->op_sv = SvREFCNT_inc(gv);
5257 kid->op_private = 0;
5258 kid->op_ppaddr = PL_ppaddr[OP_GV];
5265 Perl_ck_ftst(pTHX_ OP *o)
5268 const I32 type = o->op_type;
5270 if (o->op_flags & OPf_REF) {
5273 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5274 SVOP *kid = (SVOP*)cUNOPo->op_first;
5276 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5277 OP *newop = newGVOP(type, OPf_REF,
5278 gv_fetchsv(kid->op_sv, TRUE, SVt_PVIO));
5284 if ((PL_hints & HINT_FILETEST_ACCESS) &&
5285 OP_IS_FILETEST_ACCESS(o))
5286 o->op_private |= OPpFT_ACCESS;
5288 if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
5289 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
5290 o->op_private |= OPpFT_STACKED;
5294 if (type == OP_FTTTY)
5295 o = newGVOP(type, OPf_REF, PL_stdingv);
5297 o = newUNOP(type, 0, newDEFSVOP());
5303 Perl_ck_fun(pTHX_ OP *o)
5305 const int type = o->op_type;
5306 register I32 oa = PL_opargs[type] >> OASHIFT;
5308 if (o->op_flags & OPf_STACKED) {
5309 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5312 return no_fh_allowed(o);
5315 if (o->op_flags & OPf_KIDS) {
5316 OP **tokid = &cLISTOPo->op_first;
5317 register OP *kid = cLISTOPo->op_first;
5321 if (kid->op_type == OP_PUSHMARK ||
5322 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5324 tokid = &kid->op_sibling;
5325 kid = kid->op_sibling;
5327 if (!kid && PL_opargs[type] & OA_DEFGV)
5328 *tokid = kid = newDEFSVOP();
5332 sibl = kid->op_sibling;
5335 /* list seen where single (scalar) arg expected? */
5336 if (numargs == 1 && !(oa >> 4)
5337 && kid->op_type == OP_LIST && type != OP_SCALAR)
5339 return too_many_arguments(o,PL_op_desc[type]);
5352 if ((type == OP_PUSH || type == OP_UNSHIFT)
5353 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5354 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5355 "Useless use of %s with no values",
5358 if (kid->op_type == OP_CONST &&
5359 (kid->op_private & OPpCONST_BARE))
5361 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5362 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVAV) ));
5363 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5364 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5365 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
5366 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5369 kid->op_sibling = sibl;
5372 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5373 bad_type(numargs, "array", PL_op_desc[type], kid);
5377 if (kid->op_type == OP_CONST &&
5378 (kid->op_private & OPpCONST_BARE))
5380 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5381 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVHV) ));
5382 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5383 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5384 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
5385 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5388 kid->op_sibling = sibl;
5391 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5392 bad_type(numargs, "hash", PL_op_desc[type], kid);
5397 OP *newop = newUNOP(OP_NULL, 0, kid);
5398 kid->op_sibling = 0;
5400 newop->op_next = newop;
5402 kid->op_sibling = sibl;
5407 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5408 if (kid->op_type == OP_CONST &&
5409 (kid->op_private & OPpCONST_BARE))
5411 OP *newop = newGVOP(OP_GV, 0,
5412 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVIO) );
5413 if (!(o->op_private & 1) && /* if not unop */
5414 kid == cLISTOPo->op_last)
5415 cLISTOPo->op_last = newop;
5419 else if (kid->op_type == OP_READLINE) {
5420 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5421 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5424 I32 flags = OPf_SPECIAL;
5428 /* is this op a FH constructor? */
5429 if (is_handle_constructor(o,numargs)) {
5430 const char *name = Nullch;
5434 /* Set a flag to tell rv2gv to vivify
5435 * need to "prove" flag does not mean something
5436 * else already - NI-S 1999/05/07
5439 if (kid->op_type == OP_PADSV) {
5440 name = PAD_COMPNAME_PV(kid->op_targ);
5441 /* SvCUR of a pad namesv can't be trusted
5442 * (see PL_generation), so calc its length
5448 else if (kid->op_type == OP_RV2SV
5449 && kUNOP->op_first->op_type == OP_GV)
5451 GV *gv = cGVOPx_gv(kUNOP->op_first);
5453 len = GvNAMELEN(gv);
5455 else if (kid->op_type == OP_AELEM
5456 || kid->op_type == OP_HELEM)
5461 if ((op = ((BINOP*)kid)->op_first)) {
5462 SV *tmpstr = Nullsv;
5464 kid->op_type == OP_AELEM ?
5466 if (((op->op_type == OP_RV2AV) ||
5467 (op->op_type == OP_RV2HV)) &&
5468 (op = ((UNOP*)op)->op_first) &&
5469 (op->op_type == OP_GV)) {
5470 /* packagevar $a[] or $h{} */
5471 GV *gv = cGVOPx_gv(op);
5479 else if (op->op_type == OP_PADAV
5480 || op->op_type == OP_PADHV) {
5481 /* lexicalvar $a[] or $h{} */
5482 const char *padname =
5483 PAD_COMPNAME_PV(op->op_targ);
5493 name = SvPV(tmpstr, len);
5498 name = "__ANONIO__";
5505 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5506 namesv = PAD_SVl(targ);
5507 (void)SvUPGRADE(namesv, SVt_PV);
5509 sv_setpvn(namesv, "$", 1);
5510 sv_catpvn(namesv, name, len);
5513 kid->op_sibling = 0;
5514 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5515 kid->op_targ = targ;
5516 kid->op_private |= priv;
5518 kid->op_sibling = sibl;
5524 mod(scalar(kid), type);
5528 tokid = &kid->op_sibling;
5529 kid = kid->op_sibling;
5531 o->op_private |= numargs;
5533 return too_many_arguments(o,OP_DESC(o));
5536 else if (PL_opargs[type] & OA_DEFGV) {
5538 return newUNOP(type, 0, newDEFSVOP());
5542 while (oa & OA_OPTIONAL)
5544 if (oa && oa != OA_LIST)
5545 return too_few_arguments(o,OP_DESC(o));
5551 Perl_ck_glob(pTHX_ OP *o)
5557 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5558 append_elem(OP_GLOB, o, newDEFSVOP());
5560 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5561 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5563 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5566 #if !defined(PERL_EXTERNAL_GLOB)
5567 /* XXX this can be tightened up and made more failsafe. */
5568 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5571 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5572 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5573 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5574 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5575 GvCV(gv) = GvCV(glob_gv);
5576 (void)SvREFCNT_inc((SV*)GvCV(gv));
5577 GvIMPORTED_CV_on(gv);
5580 #endif /* PERL_EXTERNAL_GLOB */
5582 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5583 append_elem(OP_GLOB, o,
5584 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5585 o->op_type = OP_LIST;
5586 o->op_ppaddr = PL_ppaddr[OP_LIST];
5587 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5588 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5589 cLISTOPo->op_first->op_targ = 0;
5590 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5591 append_elem(OP_LIST, o,
5592 scalar(newUNOP(OP_RV2CV, 0,
5593 newGVOP(OP_GV, 0, gv)))));
5594 o = newUNOP(OP_NULL, 0, ck_subr(o));
5595 o->op_targ = OP_GLOB; /* hint at what it used to be */
5598 gv = newGVgen("main");
5600 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5606 Perl_ck_grep(pTHX_ OP *o)
5611 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5614 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5615 NewOp(1101, gwop, 1, LOGOP);
5617 if (o->op_flags & OPf_STACKED) {
5620 kid = cLISTOPo->op_first->op_sibling;
5621 if (!cUNOPx(kid)->op_next)
5622 Perl_croak(aTHX_ "panic: ck_grep");
5623 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
5626 kid->op_next = (OP*)gwop;
5627 o->op_flags &= ~OPf_STACKED;
5629 kid = cLISTOPo->op_first->op_sibling;
5630 if (type == OP_MAPWHILE)
5637 kid = cLISTOPo->op_first->op_sibling;
5638 if (kid->op_type != OP_NULL)
5639 Perl_croak(aTHX_ "panic: ck_grep");
5640 kid = kUNOP->op_first;
5642 gwop->op_type = type;
5643 gwop->op_ppaddr = PL_ppaddr[type];
5644 gwop->op_first = listkids(o);
5645 gwop->op_flags |= OPf_KIDS;
5646 gwop->op_other = LINKLIST(kid);
5647 kid->op_next = (OP*)gwop;
5648 offset = pad_findmy("$_");
5649 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
5650 o->op_private = gwop->op_private = 0;
5651 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5654 o->op_private = gwop->op_private = OPpGREP_LEX;
5655 gwop->op_targ = o->op_targ = offset;
5658 kid = cLISTOPo->op_first->op_sibling;
5659 if (!kid || !kid->op_sibling)
5660 return too_few_arguments(o,OP_DESC(o));
5661 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5662 mod(kid, OP_GREPSTART);
5668 Perl_ck_index(pTHX_ OP *o)
5670 if (o->op_flags & OPf_KIDS) {
5671 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5673 kid = kid->op_sibling; /* get past "big" */
5674 if (kid && kid->op_type == OP_CONST)
5675 fbm_compile(((SVOP*)kid)->op_sv, 0);
5681 Perl_ck_lengthconst(pTHX_ OP *o)
5683 /* XXX length optimization goes here */
5688 Perl_ck_lfun(pTHX_ OP *o)
5690 const OPCODE type = o->op_type;
5691 return modkids(ck_fun(o), type);
5695 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5697 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5698 switch (cUNOPo->op_first->op_type) {
5700 /* This is needed for
5701 if (defined %stash::)
5702 to work. Do not break Tk.
5704 break; /* Globals via GV can be undef */
5706 case OP_AASSIGN: /* Is this a good idea? */
5707 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5708 "defined(@array) is deprecated");
5709 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5710 "\t(Maybe you should just omit the defined()?)\n");
5713 /* This is needed for
5714 if (defined %stash::)
5715 to work. Do not break Tk.
5717 break; /* Globals via GV can be undef */
5719 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5720 "defined(%%hash) is deprecated");
5721 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5722 "\t(Maybe you should just omit the defined()?)\n");
5733 Perl_ck_rfun(pTHX_ OP *o)
5735 const OPCODE type = o->op_type;
5736 return refkids(ck_fun(o), type);
5740 Perl_ck_listiob(pTHX_ OP *o)
5744 kid = cLISTOPo->op_first;
5747 kid = cLISTOPo->op_first;
5749 if (kid->op_type == OP_PUSHMARK)
5750 kid = kid->op_sibling;
5751 if (kid && o->op_flags & OPf_STACKED)
5752 kid = kid->op_sibling;
5753 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5754 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5755 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5756 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5757 cLISTOPo->op_first->op_sibling = kid;
5758 cLISTOPo->op_last = kid;
5759 kid = kid->op_sibling;
5764 append_elem(o->op_type, o, newDEFSVOP());
5770 Perl_ck_sassign(pTHX_ OP *o)
5772 OP *kid = cLISTOPo->op_first;
5773 /* has a disposable target? */
5774 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5775 && !(kid->op_flags & OPf_STACKED)
5776 /* Cannot steal the second time! */
5777 && !(kid->op_private & OPpTARGET_MY))
5779 OP *kkid = kid->op_sibling;
5781 /* Can just relocate the target. */
5782 if (kkid && kkid->op_type == OP_PADSV
5783 && !(kkid->op_private & OPpLVAL_INTRO))
5785 kid->op_targ = kkid->op_targ;
5787 /* Now we do not need PADSV and SASSIGN. */
5788 kid->op_sibling = o->op_sibling; /* NULL */
5789 cLISTOPo->op_first = NULL;
5792 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
5796 /* optimise C<my $x = undef> to C<my $x> */
5797 if (kid->op_type == OP_UNDEF) {
5798 OP *kkid = kid->op_sibling;
5799 if (kkid && kkid->op_type == OP_PADSV
5800 && (kkid->op_private & OPpLVAL_INTRO))
5802 cLISTOPo->op_first = NULL;
5803 kid->op_sibling = NULL;
5813 Perl_ck_match(pTHX_ OP *o)
5815 if (o->op_type != OP_QR) {
5816 const I32 offset = pad_findmy("$_");
5817 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS(offset) & SVpad_OUR)) {
5818 o->op_targ = offset;
5819 o->op_private |= OPpTARGET_MY;
5822 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
5823 o->op_private |= OPpRUNTIME;
5828 Perl_ck_method(pTHX_ OP *o)
5830 OP *kid = cUNOPo->op_first;
5831 if (kid->op_type == OP_CONST) {
5832 SV* sv = kSVOP->op_sv;
5833 if (!(strchr(SvPVX_const(sv), ':') || strchr(SvPVX_const(sv), '\''))) {
5835 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5836 sv = newSVpvn_share(SvPVX_const(sv), SvCUR(sv), 0);
5839 kSVOP->op_sv = Nullsv;
5841 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5850 Perl_ck_null(pTHX_ OP *o)
5856 Perl_ck_open(pTHX_ OP *o)
5858 HV *table = GvHV(PL_hintgv);
5862 svp = hv_fetch(table, "open_IN", 7, FALSE);
5864 mode = mode_from_discipline(*svp);
5865 if (mode & O_BINARY)
5866 o->op_private |= OPpOPEN_IN_RAW;
5867 else if (mode & O_TEXT)
5868 o->op_private |= OPpOPEN_IN_CRLF;
5871 svp = hv_fetch(table, "open_OUT", 8, FALSE);
5873 mode = mode_from_discipline(*svp);
5874 if (mode & O_BINARY)
5875 o->op_private |= OPpOPEN_OUT_RAW;
5876 else if (mode & O_TEXT)
5877 o->op_private |= OPpOPEN_OUT_CRLF;
5880 if (o->op_type == OP_BACKTICK)
5883 /* In case of three-arg dup open remove strictness
5884 * from the last arg if it is a bareword. */
5885 OP *first = cLISTOPx(o)->op_first; /* The pushmark. */
5886 OP *last = cLISTOPx(o)->op_last; /* The bareword. */
5890 if ((last->op_type == OP_CONST) && /* The bareword. */
5891 (last->op_private & OPpCONST_BARE) &&
5892 (last->op_private & OPpCONST_STRICT) &&
5893 (oa = first->op_sibling) && /* The fh. */
5894 (oa = oa->op_sibling) && /* The mode. */
5895 SvPOK(((SVOP*)oa)->op_sv) &&
5896 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
5897 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
5898 (last == oa->op_sibling)) /* The bareword. */
5899 last->op_private &= ~OPpCONST_STRICT;
5905 Perl_ck_repeat(pTHX_ OP *o)
5907 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5908 o->op_private |= OPpREPEAT_DOLIST;
5909 cBINOPo->op_first = force_list(cBINOPo->op_first);
5917 Perl_ck_require(pTHX_ OP *o)
5921 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
5922 SVOP *kid = (SVOP*)cUNOPo->op_first;
5924 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5926 for (s = SvPVX(kid->op_sv); *s; s++) {
5927 if (*s == ':' && s[1] == ':') {
5929 Move(s+2, s+1, strlen(s+2)+1, char);
5930 SvCUR_set(kid->op_sv, SvCUR(kid->op_sv) - 1);
5933 if (SvREADONLY(kid->op_sv)) {
5934 SvREADONLY_off(kid->op_sv);
5935 sv_catpvn(kid->op_sv, ".pm", 3);
5936 SvREADONLY_on(kid->op_sv);
5939 sv_catpvn(kid->op_sv, ".pm", 3);
5943 /* handle override, if any */
5944 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
5945 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
5946 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
5948 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5949 OP *kid = cUNOPo->op_first;
5950 cUNOPo->op_first = 0;
5952 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5953 append_elem(OP_LIST, kid,
5954 scalar(newUNOP(OP_RV2CV, 0,
5963 Perl_ck_return(pTHX_ OP *o)
5965 if (CvLVALUE(PL_compcv)) {
5967 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5968 mod(kid, OP_LEAVESUBLV);
5975 Perl_ck_retarget(pTHX_ OP *o)
5977 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5984 Perl_ck_select(pTHX_ OP *o)
5988 if (o->op_flags & OPf_KIDS) {
5989 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5990 if (kid && kid->op_sibling) {
5991 o->op_type = OP_SSELECT;
5992 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
5994 return fold_constants(o);
5998 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5999 if (kid && kid->op_type == OP_RV2GV)
6000 kid->op_private &= ~HINT_STRICT_REFS;
6005 Perl_ck_shift(pTHX_ OP *o)
6007 const I32 type = o->op_type;
6009 if (!(o->op_flags & OPf_KIDS)) {
6013 argop = newUNOP(OP_RV2AV, 0,
6014 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
6015 return newUNOP(type, 0, scalar(argop));
6017 return scalar(modkids(ck_fun(o), type));
6021 Perl_ck_sort(pTHX_ OP *o)
6025 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6027 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6028 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6030 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6032 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6034 if (kid->op_type == OP_SCOPE) {
6038 else if (kid->op_type == OP_LEAVE) {
6039 if (o->op_type == OP_SORT) {
6040 op_null(kid); /* wipe out leave */
6043 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6044 if (k->op_next == kid)
6046 /* don't descend into loops */
6047 else if (k->op_type == OP_ENTERLOOP
6048 || k->op_type == OP_ENTERITER)
6050 k = cLOOPx(k)->op_lastop;
6055 kid->op_next = 0; /* just disconnect the leave */
6056 k = kLISTOP->op_first;
6061 if (o->op_type == OP_SORT) {
6062 /* provide scalar context for comparison function/block */
6068 o->op_flags |= OPf_SPECIAL;
6070 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6073 firstkid = firstkid->op_sibling;
6076 /* provide list context for arguments */
6077 if (o->op_type == OP_SORT)
6084 S_simplify_sort(pTHX_ OP *o)
6086 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6091 if (!(o->op_flags & OPf_STACKED))
6093 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6094 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6095 kid = kUNOP->op_first; /* get past null */
6096 if (kid->op_type != OP_SCOPE)
6098 kid = kLISTOP->op_last; /* get past scope */
6099 switch(kid->op_type) {
6107 k = kid; /* remember this node*/
6108 if (kBINOP->op_first->op_type != OP_RV2SV)
6110 kid = kBINOP->op_first; /* get past cmp */
6111 if (kUNOP->op_first->op_type != OP_GV)
6113 kid = kUNOP->op_first; /* get past rv2sv */
6115 if (GvSTASH(gv) != PL_curstash)
6117 gvname = GvNAME(gv);
6118 if (*gvname == 'a' && gvname[1] == '\0')
6120 else if (*gvname == 'b' && gvname[1] == '\0')
6125 kid = k; /* back to cmp */
6126 if (kBINOP->op_last->op_type != OP_RV2SV)
6128 kid = kBINOP->op_last; /* down to 2nd arg */
6129 if (kUNOP->op_first->op_type != OP_GV)
6131 kid = kUNOP->op_first; /* get past rv2sv */
6133 if (GvSTASH(gv) != PL_curstash)
6135 gvname = GvNAME(gv);
6137 ? !(*gvname == 'a' && gvname[1] == '\0')
6138 : !(*gvname == 'b' && gvname[1] == '\0'))
6140 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6142 o->op_private |= OPpSORT_DESCEND;
6143 if (k->op_type == OP_NCMP)
6144 o->op_private |= OPpSORT_NUMERIC;
6145 if (k->op_type == OP_I_NCMP)
6146 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6147 kid = cLISTOPo->op_first->op_sibling;
6148 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6149 op_free(kid); /* then delete it */
6153 Perl_ck_split(pTHX_ OP *o)
6158 if (o->op_flags & OPf_STACKED)
6159 return no_fh_allowed(o);
6161 kid = cLISTOPo->op_first;
6162 if (kid->op_type != OP_NULL)
6163 Perl_croak(aTHX_ "panic: ck_split");
6164 kid = kid->op_sibling;
6165 op_free(cLISTOPo->op_first);
6166 cLISTOPo->op_first = kid;
6168 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6169 cLISTOPo->op_last = kid; /* There was only one element previously */
6172 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6173 OP *sibl = kid->op_sibling;
6174 kid->op_sibling = 0;
6175 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
6176 if (cLISTOPo->op_first == cLISTOPo->op_last)
6177 cLISTOPo->op_last = kid;
6178 cLISTOPo->op_first = kid;
6179 kid->op_sibling = sibl;
6182 kid->op_type = OP_PUSHRE;
6183 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6185 if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
6186 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
6187 "Use of /g modifier is meaningless in split");
6190 if (!kid->op_sibling)
6191 append_elem(OP_SPLIT, o, newDEFSVOP());
6193 kid = kid->op_sibling;
6196 if (!kid->op_sibling)
6197 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6199 kid = kid->op_sibling;
6202 if (kid->op_sibling)
6203 return too_many_arguments(o,OP_DESC(o));
6209 Perl_ck_join(pTHX_ OP *o)
6211 if (ckWARN(WARN_SYNTAX)) {
6212 const OP *kid = cLISTOPo->op_first->op_sibling;
6213 if (kid && kid->op_type == OP_MATCH) {
6214 const REGEXP *re = PM_GETRE(kPMOP);
6215 const char *pmstr = re ? re->precomp : "STRING";
6216 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6217 "/%s/ should probably be written as \"%s\"",
6225 Perl_ck_subr(pTHX_ OP *o)
6227 OP *prev = ((cUNOPo->op_first->op_sibling)
6228 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6229 OP *o2 = prev->op_sibling;
6236 I32 contextclass = 0;
6241 o->op_private |= OPpENTERSUB_HASTARG;
6242 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6243 if (cvop->op_type == OP_RV2CV) {
6245 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6246 op_null(cvop); /* disable rv2cv */
6247 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6248 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6249 GV *gv = cGVOPx_gv(tmpop);
6252 tmpop->op_private |= OPpEARLY_CV;
6255 namegv = CvANON(cv) ? gv : CvGV(cv);
6256 proto = SvPV((SV*)cv, n_a);
6258 if (CvASSERTION(cv)) {
6259 if (PL_hints & HINT_ASSERTING) {
6260 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
6261 o->op_private |= OPpENTERSUB_DB;
6265 if (ckWARN(WARN_ASSERTIONS) && !(PL_hints & HINT_ASSERTIONSSEEN)) {
6266 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
6267 "Impossible to activate assertion call");
6274 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6275 if (o2->op_type == OP_CONST)
6276 o2->op_private &= ~OPpCONST_STRICT;
6277 else if (o2->op_type == OP_LIST) {
6278 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6279 if (o && o->op_type == OP_CONST)
6280 o->op_private &= ~OPpCONST_STRICT;
6283 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6284 if (PERLDB_SUB && PL_curstash != PL_debstash)
6285 o->op_private |= OPpENTERSUB_DB;
6286 while (o2 != cvop) {
6290 return too_many_arguments(o, gv_ename(namegv));
6308 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6310 arg == 1 ? "block or sub {}" : "sub {}",
6311 gv_ename(namegv), o2);
6314 /* '*' allows any scalar type, including bareword */
6317 if (o2->op_type == OP_RV2GV)
6318 goto wrapref; /* autoconvert GLOB -> GLOBref */
6319 else if (o2->op_type == OP_CONST)
6320 o2->op_private &= ~OPpCONST_STRICT;
6321 else if (o2->op_type == OP_ENTERSUB) {
6322 /* accidental subroutine, revert to bareword */
6323 OP *gvop = ((UNOP*)o2)->op_first;
6324 if (gvop && gvop->op_type == OP_NULL) {
6325 gvop = ((UNOP*)gvop)->op_first;
6327 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6330 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6331 (gvop = ((UNOP*)gvop)->op_first) &&
6332 gvop->op_type == OP_GV)
6334 GV *gv = cGVOPx_gv(gvop);
6335 OP *sibling = o2->op_sibling;
6336 SV *n = newSVpvn("",0);
6338 gv_fullname4(n, gv, "", FALSE);
6339 o2 = newSVOP(OP_CONST, 0, n);
6340 prev->op_sibling = o2;
6341 o2->op_sibling = sibling;
6357 if (contextclass++ == 0) {
6358 e = strchr(proto, ']');
6359 if (!e || e == proto)
6372 while (*--p != '[');
6373 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6374 gv_ename(namegv), o2);
6380 if (o2->op_type == OP_RV2GV)
6383 bad_type(arg, "symbol", gv_ename(namegv), o2);
6386 if (o2->op_type == OP_ENTERSUB)
6389 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6392 if (o2->op_type == OP_RV2SV ||
6393 o2->op_type == OP_PADSV ||
6394 o2->op_type == OP_HELEM ||
6395 o2->op_type == OP_AELEM ||
6396 o2->op_type == OP_THREADSV)
6399 bad_type(arg, "scalar", gv_ename(namegv), o2);
6402 if (o2->op_type == OP_RV2AV ||
6403 o2->op_type == OP_PADAV)
6406 bad_type(arg, "array", gv_ename(namegv), o2);
6409 if (o2->op_type == OP_RV2HV ||
6410 o2->op_type == OP_PADHV)
6413 bad_type(arg, "hash", gv_ename(namegv), o2);
6418 OP* sib = kid->op_sibling;
6419 kid->op_sibling = 0;
6420 o2 = newUNOP(OP_REFGEN, 0, kid);
6421 o2->op_sibling = sib;
6422 prev->op_sibling = o2;
6424 if (contextclass && e) {
6439 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6440 gv_ename(namegv), cv);
6445 mod(o2, OP_ENTERSUB);
6447 o2 = o2->op_sibling;
6449 if (proto && !optional &&
6450 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6451 return too_few_arguments(o, gv_ename(namegv));
6454 o=newSVOP(OP_CONST, 0, newSViv(0));
6460 Perl_ck_svconst(pTHX_ OP *o)
6462 SvREADONLY_on(cSVOPo->op_sv);
6467 Perl_ck_trunc(pTHX_ OP *o)
6469 if (o->op_flags & OPf_KIDS) {
6470 SVOP *kid = (SVOP*)cUNOPo->op_first;
6472 if (kid->op_type == OP_NULL)
6473 kid = (SVOP*)kid->op_sibling;
6474 if (kid && kid->op_type == OP_CONST &&
6475 (kid->op_private & OPpCONST_BARE))
6477 o->op_flags |= OPf_SPECIAL;
6478 kid->op_private &= ~OPpCONST_STRICT;
6485 Perl_ck_unpack(pTHX_ OP *o)
6487 OP *kid = cLISTOPo->op_first;
6488 if (kid->op_sibling) {
6489 kid = kid->op_sibling;
6490 if (!kid->op_sibling)
6491 kid->op_sibling = newDEFSVOP();
6497 Perl_ck_substr(pTHX_ OP *o)
6500 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6501 OP *kid = cLISTOPo->op_first;
6503 if (kid->op_type == OP_NULL)
6504 kid = kid->op_sibling;
6506 kid->op_flags |= OPf_MOD;
6512 /* A peephole optimizer. We visit the ops in the order they're to execute.
6513 * See the comments at the top of this file for more details about when
6514 * peep() is called */
6517 Perl_peep(pTHX_ register OP *o)
6520 register OP* oldop = 0;
6522 if (!o || o->op_opt)
6526 SAVEVPTR(PL_curcop);
6527 for (; o; o = o->op_next) {
6531 switch (o->op_type) {
6535 PL_curcop = ((COP*)o); /* for warnings */
6540 if (cSVOPo->op_private & OPpCONST_STRICT)
6541 no_bareword_allowed(o);
6543 case OP_METHOD_NAMED:
6544 /* Relocate sv to the pad for thread safety.
6545 * Despite being a "constant", the SV is written to,
6546 * for reference counts, sv_upgrade() etc. */
6548 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6549 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6550 /* If op_sv is already a PADTMP then it is being used by
6551 * some pad, so make a copy. */
6552 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6553 SvREADONLY_on(PAD_SVl(ix));
6554 SvREFCNT_dec(cSVOPo->op_sv);
6557 SvREFCNT_dec(PAD_SVl(ix));
6558 SvPADTMP_on(cSVOPo->op_sv);
6559 PAD_SETSV(ix, cSVOPo->op_sv);
6560 /* XXX I don't know how this isn't readonly already. */
6561 SvREADONLY_on(PAD_SVl(ix));
6563 cSVOPo->op_sv = Nullsv;
6571 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6572 if (o->op_next->op_private & OPpTARGET_MY) {
6573 if (o->op_flags & OPf_STACKED) /* chained concats */
6574 goto ignore_optimization;
6576 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6577 o->op_targ = o->op_next->op_targ;
6578 o->op_next->op_targ = 0;
6579 o->op_private |= OPpTARGET_MY;
6582 op_null(o->op_next);
6584 ignore_optimization:
6588 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6590 break; /* Scalar stub must produce undef. List stub is noop */
6594 if (o->op_targ == OP_NEXTSTATE
6595 || o->op_targ == OP_DBSTATE
6596 || o->op_targ == OP_SETSTATE)
6598 PL_curcop = ((COP*)o);
6600 /* XXX: We avoid setting op_seq here to prevent later calls
6601 to peep() from mistakenly concluding that optimisation
6602 has already occurred. This doesn't fix the real problem,
6603 though (See 20010220.007). AMS 20010719 */
6604 /* op_seq functionality is now replaced by op_opt */
6605 if (oldop && o->op_next) {
6606 oldop->op_next = o->op_next;
6614 if (oldop && o->op_next) {
6615 oldop->op_next = o->op_next;
6623 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
6624 OP* pop = (o->op_type == OP_PADAV) ?
6625 o->op_next : o->op_next->op_next;
6627 if (pop && pop->op_type == OP_CONST &&
6628 ((PL_op = pop->op_next)) &&
6629 pop->op_next->op_type == OP_AELEM &&
6630 !(pop->op_next->op_private &
6631 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6632 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6637 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
6638 no_bareword_allowed(pop);
6639 if (o->op_type == OP_GV)
6640 op_null(o->op_next);
6641 op_null(pop->op_next);
6643 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6644 o->op_next = pop->op_next->op_next;
6645 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6646 o->op_private = (U8)i;
6647 if (o->op_type == OP_GV) {
6652 o->op_flags |= OPf_SPECIAL;
6653 o->op_type = OP_AELEMFAST;
6659 if (o->op_next->op_type == OP_RV2SV) {
6660 if (!(o->op_next->op_private & OPpDEREF)) {
6661 op_null(o->op_next);
6662 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6664 o->op_next = o->op_next->op_next;
6665 o->op_type = OP_GVSV;
6666 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6669 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6671 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
6672 /* XXX could check prototype here instead of just carping */
6673 SV *sv = sv_newmortal();
6674 gv_efullname3(sv, gv, Nullch);
6675 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6676 "%"SVf"() called too early to check prototype",
6680 else if (o->op_next->op_type == OP_READLINE
6681 && o->op_next->op_next->op_type == OP_CONCAT
6682 && (o->op_next->op_next->op_flags & OPf_STACKED))
6684 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6685 o->op_type = OP_RCATLINE;
6686 o->op_flags |= OPf_STACKED;
6687 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6688 op_null(o->op_next->op_next);
6689 op_null(o->op_next);
6706 while (cLOGOP->op_other->op_type == OP_NULL)
6707 cLOGOP->op_other = cLOGOP->op_other->op_next;
6708 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6714 while (cLOOP->op_redoop->op_type == OP_NULL)
6715 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6716 peep(cLOOP->op_redoop);
6717 while (cLOOP->op_nextop->op_type == OP_NULL)
6718 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6719 peep(cLOOP->op_nextop);
6720 while (cLOOP->op_lastop->op_type == OP_NULL)
6721 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6722 peep(cLOOP->op_lastop);
6729 while (cPMOP->op_pmreplstart &&
6730 cPMOP->op_pmreplstart->op_type == OP_NULL)
6731 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6732 peep(cPMOP->op_pmreplstart);
6737 if (ckWARN(WARN_SYNTAX) && o->op_next
6738 && o->op_next->op_type == OP_NEXTSTATE) {
6739 if (o->op_next->op_sibling &&
6740 o->op_next->op_sibling->op_type != OP_EXIT &&
6741 o->op_next->op_sibling->op_type != OP_WARN &&
6742 o->op_next->op_sibling->op_type != OP_DIE) {
6743 const line_t oldline = CopLINE(PL_curcop);
6745 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6746 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6747 "Statement unlikely to be reached");
6748 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6749 "\t(Maybe you meant system() when you said exec()?)\n");
6750 CopLINE_set(PL_curcop, oldline);
6765 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6768 /* Make the CONST have a shared SV */
6769 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6770 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6771 key = SvPV(sv, keylen);
6772 lexname = newSVpvn_share(key,
6773 SvUTF8(sv) ? -(I32)keylen : keylen,
6779 if ((o->op_private & (OPpLVAL_INTRO)))
6782 rop = (UNOP*)((BINOP*)o)->op_first;
6783 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6785 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6786 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6788 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6789 if (!fields || !GvHV(*fields))
6791 key = SvPV(*svp, keylen);
6792 if (!hv_fetch(GvHV(*fields), key,
6793 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
6795 Perl_croak(aTHX_ "No such class field \"%s\" "
6796 "in variable %s of type %s",
6797 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
6810 SVOP *first_key_op, *key_op;
6812 if ((o->op_private & (OPpLVAL_INTRO))
6813 /* I bet there's always a pushmark... */
6814 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6815 /* hmmm, no optimization if list contains only one key. */
6817 rop = (UNOP*)((LISTOP*)o)->op_last;
6818 if (rop->op_type != OP_RV2HV)
6820 if (rop->op_first->op_type == OP_PADSV)
6821 /* @$hash{qw(keys here)} */
6822 rop = (UNOP*)rop->op_first;
6824 /* @{$hash}{qw(keys here)} */
6825 if (rop->op_first->op_type == OP_SCOPE
6826 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
6828 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
6834 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
6835 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6837 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6838 if (!fields || !GvHV(*fields))
6840 /* Again guessing that the pushmark can be jumped over.... */
6841 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
6842 ->op_first->op_sibling;
6843 for (key_op = first_key_op; key_op;
6844 key_op = (SVOP*)key_op->op_sibling) {
6845 if (key_op->op_type != OP_CONST)
6847 svp = cSVOPx_svp(key_op);
6848 key = SvPV(*svp, keylen);
6849 if (!hv_fetch(GvHV(*fields), key,
6850 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
6852 Perl_croak(aTHX_ "No such class field \"%s\" "
6853 "in variable %s of type %s",
6854 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
6861 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
6865 /* check that RHS of sort is a single plain array */
6866 oright = cUNOPo->op_first;
6867 if (!oright || oright->op_type != OP_PUSHMARK)
6870 /* reverse sort ... can be optimised. */
6871 if (!cUNOPo->op_sibling) {
6872 /* Nothing follows us on the list. */
6873 OP *reverse = o->op_next;
6875 if (reverse->op_type == OP_REVERSE &&
6876 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
6877 OP *pushmark = cUNOPx(reverse)->op_first;
6878 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
6879 && (cUNOPx(pushmark)->op_sibling == o)) {
6880 /* reverse -> pushmark -> sort */
6881 o->op_private |= OPpSORT_REVERSE;
6883 pushmark->op_next = oright->op_next;
6889 /* make @a = sort @a act in-place */
6893 oright = cUNOPx(oright)->op_sibling;
6896 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
6897 oright = cUNOPx(oright)->op_sibling;
6901 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
6902 || oright->op_next != o
6903 || (oright->op_private & OPpLVAL_INTRO)
6907 /* o2 follows the chain of op_nexts through the LHS of the
6908 * assign (if any) to the aassign op itself */
6910 if (!o2 || o2->op_type != OP_NULL)
6913 if (!o2 || o2->op_type != OP_PUSHMARK)
6916 if (o2 && o2->op_type == OP_GV)
6919 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
6920 || (o2->op_private & OPpLVAL_INTRO)
6925 if (!o2 || o2->op_type != OP_NULL)
6928 if (!o2 || o2->op_type != OP_AASSIGN
6929 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
6932 /* check that the sort is the first arg on RHS of assign */
6934 o2 = cUNOPx(o2)->op_first;
6935 if (!o2 || o2->op_type != OP_NULL)
6937 o2 = cUNOPx(o2)->op_first;
6938 if (!o2 || o2->op_type != OP_PUSHMARK)
6940 if (o2->op_sibling != o)
6943 /* check the array is the same on both sides */
6944 if (oleft->op_type == OP_RV2AV) {
6945 if (oright->op_type != OP_RV2AV
6946 || !cUNOPx(oright)->op_first
6947 || cUNOPx(oright)->op_first->op_type != OP_GV
6948 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
6949 cGVOPx_gv(cUNOPx(oright)->op_first)
6953 else if (oright->op_type != OP_PADAV
6954 || oright->op_targ != oleft->op_targ
6958 /* transfer MODishness etc from LHS arg to RHS arg */
6959 oright->op_flags = oleft->op_flags;
6960 o->op_private |= OPpSORT_INPLACE;
6962 /* excise push->gv->rv2av->null->aassign */
6963 o2 = o->op_next->op_next;
6964 op_null(o2); /* PUSHMARK */
6966 if (o2->op_type == OP_GV) {
6967 op_null(o2); /* GV */
6970 op_null(o2); /* RV2AV or PADAV */
6971 o2 = o2->op_next->op_next;
6972 op_null(o2); /* AASSIGN */
6974 o->op_next = o2->op_next;
6980 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
6982 LISTOP *enter, *exlist;
6985 enter = (LISTOP *) o->op_next;
6988 if (enter->op_type == OP_NULL) {
6989 enter = (LISTOP *) enter->op_next;
6993 /* for $a (...) will have OP_GV then OP_RV2GV here.
6994 for (...) just has an OP_GV. */
6995 if (enter->op_type == OP_GV) {
6996 gvop = (OP *) enter;
6997 enter = (LISTOP *) enter->op_next;
7000 if (enter->op_type == OP_RV2GV) {
7001 enter = (LISTOP *) enter->op_next;
7007 if (enter->op_type != OP_ENTERITER)
7010 iter = enter->op_next;
7011 if (!iter || iter->op_type != OP_ITER)
7014 expushmark = enter->op_first;
7015 if (!expushmark || expushmark->op_type != OP_NULL
7016 || expushmark->op_targ != OP_PUSHMARK)
7019 exlist = (LISTOP *) expushmark->op_sibling;
7020 if (!exlist || exlist->op_type != OP_NULL
7021 || exlist->op_targ != OP_LIST)
7024 if (exlist->op_last != o) {
7025 /* Mmm. Was expecting to point back to this op. */
7028 theirmark = exlist->op_first;
7029 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
7032 if (theirmark->op_sibling != o) {
7033 /* There's something between the mark and the reverse, eg
7034 for (1, reverse (...))
7039 ourmark = ((LISTOP *)o)->op_first;
7040 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
7043 ourlast = ((LISTOP *)o)->op_last;
7044 if (!ourlast || ourlast->op_next != o)
7047 rv2av = ourmark->op_sibling;
7048 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
7049 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
7050 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
7051 /* We're just reversing a single array. */
7052 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
7053 enter->op_flags |= OPf_STACKED;
7056 /* We don't have control over who points to theirmark, so sacrifice
7058 theirmark->op_next = ourmark->op_next;
7059 theirmark->op_flags = ourmark->op_flags;
7060 ourlast->op_next = gvop ? gvop : (OP *) enter;
7063 enter->op_private |= OPpITER_REVERSED;
7064 iter->op_private |= OPpITER_REVERSED;
7079 Perl_custom_op_name(pTHX_ const OP* o)
7081 const IV index = PTR2IV(o->op_ppaddr);
7085 if (!PL_custom_op_names) /* This probably shouldn't happen */
7086 return (char *)PL_op_name[OP_CUSTOM];
7088 keysv = sv_2mortal(newSViv(index));
7090 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7092 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7094 return SvPV_nolen(HeVAL(he));
7098 Perl_custom_op_desc(pTHX_ const OP* o)
7100 const IV index = PTR2IV(o->op_ppaddr);
7104 if (!PL_custom_op_descs)
7105 return (char *)PL_op_desc[OP_CUSTOM];
7107 keysv = sv_2mortal(newSViv(index));
7109 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7111 return (char *)PL_op_desc[OP_CUSTOM];
7113 return SvPV_nolen(HeVAL(he));
7118 /* Efficient sub that returns a constant scalar value. */
7120 const_sv_xsub(pTHX_ CV* cv)
7125 Perl_croak(aTHX_ "usage: %s::%s()",
7126 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7130 ST(0) = (SV*)XSANY.any_ptr;
7136 * c-indentation-style: bsd
7138 * indent-tabs-mode: t
7141 * ex: set ts=8 sts=4 sw=4 noet: