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;
4065 CvSTART(cv) = Nullop;
4068 SvPOK_off((SV*)cv); /* forget prototype */
4073 /* remove CvOUTSIDE unless this is an undef rather than a free */
4074 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4075 if (!CvWEAKOUTSIDE(cv))
4076 SvREFCNT_dec(CvOUTSIDE(cv));
4077 CvOUTSIDE(cv) = Nullcv;
4080 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4086 /* delete all flags except WEAKOUTSIDE */
4087 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4091 Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p)
4093 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX_const(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4094 SV* msg = sv_newmortal();
4098 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4099 sv_setpv(msg, "Prototype mismatch:");
4101 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4103 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (const SV *)cv);
4105 Perl_sv_catpv(aTHX_ msg, ": none");
4106 sv_catpv(msg, " vs ");
4108 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4110 sv_catpv(msg, "none");
4111 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
4115 static void const_sv_xsub(pTHX_ CV* cv);
4119 =head1 Optree Manipulation Functions
4121 =for apidoc cv_const_sv
4123 If C<cv> is a constant sub eligible for inlining. returns the constant
4124 value returned by the sub. Otherwise, returns NULL.
4126 Constant subs can be created with C<newCONSTSUB> or as described in
4127 L<perlsub/"Constant Functions">.
4132 Perl_cv_const_sv(pTHX_ CV *cv)
4134 if (!cv || !CvCONST(cv))
4136 return (SV*)CvXSUBANY(cv).any_ptr;
4139 /* op_const_sv: examine an optree to determine whether it's in-lineable.
4140 * Can be called in 3 ways:
4143 * look for a single OP_CONST with attached value: return the value
4145 * cv && CvCLONE(cv) && !CvCONST(cv)
4147 * examine the clone prototype, and if contains only a single
4148 * OP_CONST referencing a pad const, or a single PADSV referencing
4149 * an outer lexical, return a non-zero value to indicate the CV is
4150 * a candidate for "constizing" at clone time
4154 * We have just cloned an anon prototype that was marked as a const
4155 * candidiate. Try to grab the current value, and in the case of
4156 * PADSV, ignore it if it has multiple references. Return the value.
4160 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
4167 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4168 o = cLISTOPo->op_first->op_sibling;
4170 for (; o; o = o->op_next) {
4171 OPCODE type = o->op_type;
4173 if (sv && o->op_next == o)
4175 if (o->op_next != o) {
4176 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4178 if (type == OP_DBSTATE)
4181 if (type == OP_LEAVESUB || type == OP_RETURN)
4185 if (type == OP_CONST && cSVOPo->op_sv)
4187 else if (cv && type == OP_CONST) {
4188 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4192 else if (cv && type == OP_PADSV) {
4193 if (CvCONST(cv)) { /* newly cloned anon */
4194 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4195 /* the candidate should have 1 ref from this pad and 1 ref
4196 * from the parent */
4197 if (!sv || SvREFCNT(sv) != 2)
4204 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4205 sv = &PL_sv_undef; /* an arbitrary non-null value */
4216 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4227 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4231 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4233 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4237 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4248 const char * const name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4251 assert(proto->op_type == OP_CONST);
4252 ps = SvPVx(((SVOP*)proto)->op_sv, ps_len);
4257 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4258 SV *sv = sv_newmortal();
4259 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4260 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4261 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4262 aname = SvPVX_const(sv);
4266 gv = name ? gv_fetchsv(cSVOPo->op_sv,
4267 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4269 : gv_fetchpv(aname ? aname
4270 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4271 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4281 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4282 maximum a prototype before. */
4283 if (SvTYPE(gv) > SVt_NULL) {
4284 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4285 && ckWARN_d(WARN_PROTOTYPE))
4287 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4289 cv_ckproto((CV*)gv, NULL, ps);
4292 sv_setpvn((SV*)gv, ps, ps_len);
4294 sv_setiv((SV*)gv, -1);
4295 SvREFCNT_dec(PL_compcv);
4296 cv = PL_compcv = NULL;
4297 PL_sub_generation++;
4301 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4303 #ifdef GV_UNIQUE_CHECK
4304 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4305 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4309 if (!block || !ps || *ps || attrs)
4312 const_sv = op_const_sv(block, Nullcv);
4315 const bool exists = CvROOT(cv) || CvXSUB(cv);
4317 #ifdef GV_UNIQUE_CHECK
4318 if (exists && GvUNIQUE(gv)) {
4319 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4323 /* if the subroutine doesn't exist and wasn't pre-declared
4324 * with a prototype, assume it will be AUTOLOADed,
4325 * skipping the prototype check
4327 if (exists || SvPOK(cv))
4328 cv_ckproto(cv, gv, ps);
4329 /* already defined (or promised)? */
4330 if (exists || GvASSUMECV(gv)) {
4331 if (!block && !attrs) {
4332 if (CvFLAGS(PL_compcv)) {
4333 /* might have had built-in attrs applied */
4334 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4336 /* just a "sub foo;" when &foo is already defined */
4337 SAVEFREESV(PL_compcv);
4340 /* ahem, death to those who redefine active sort subs */
4341 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4342 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4344 if (ckWARN(WARN_REDEFINE)
4346 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4348 const line_t oldline = CopLINE(PL_curcop);
4349 if (PL_copline != NOLINE)
4350 CopLINE_set(PL_curcop, PL_copline);
4351 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4352 CvCONST(cv) ? "Constant subroutine %s redefined"
4353 : "Subroutine %s redefined", name);
4354 CopLINE_set(PL_curcop, oldline);
4362 (void)SvREFCNT_inc(const_sv);
4364 assert(!CvROOT(cv) && !CvCONST(cv));
4365 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
4366 CvXSUBANY(cv).any_ptr = const_sv;
4367 CvXSUB(cv) = const_sv_xsub;
4372 cv = newCONSTSUB(NULL, name, const_sv);
4375 SvREFCNT_dec(PL_compcv);
4377 PL_sub_generation++;
4384 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4385 * before we clobber PL_compcv.
4389 /* Might have had built-in attributes applied -- propagate them. */
4390 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4391 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4392 stash = GvSTASH(CvGV(cv));
4393 else if (CvSTASH(cv))
4394 stash = CvSTASH(cv);
4396 stash = PL_curstash;
4399 /* possibly about to re-define existing subr -- ignore old cv */
4400 rcv = (SV*)PL_compcv;
4401 if (name && GvSTASH(gv))
4402 stash = GvSTASH(gv);
4404 stash = PL_curstash;
4406 apply_attrs(stash, rcv, attrs, FALSE);
4408 if (cv) { /* must reuse cv if autoloaded */
4410 /* got here with just attrs -- work done, so bug out */
4411 SAVEFREESV(PL_compcv);
4414 /* transfer PL_compcv to cv */
4416 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4417 if (!CvWEAKOUTSIDE(cv))
4418 SvREFCNT_dec(CvOUTSIDE(cv));
4419 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4420 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4421 CvOUTSIDE(PL_compcv) = 0;
4422 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4423 CvPADLIST(PL_compcv) = 0;
4424 /* inner references to PL_compcv must be fixed up ... */
4425 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4426 /* ... before we throw it away */
4427 SvREFCNT_dec(PL_compcv);
4429 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4430 ++PL_sub_generation;
4437 PL_sub_generation++;
4441 CvFILE_set_from_cop(cv, PL_curcop);
4442 CvSTASH(cv) = PL_curstash;
4445 sv_setpvn((SV*)cv, ps, ps_len);
4447 if (PL_error_count) {
4451 const char *s = strrchr(name, ':');
4453 if (strEQ(s, "BEGIN")) {
4454 const char not_safe[] =
4455 "BEGIN not safe after errors--compilation aborted";
4456 if (PL_in_eval & EVAL_KEEPERR)
4457 Perl_croak(aTHX_ not_safe);
4459 /* force display of errors found but not reported */
4460 sv_catpv(ERRSV, not_safe);
4461 Perl_croak(aTHX_ "%"SVf, ERRSV);
4470 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4471 mod(scalarseq(block), OP_LEAVESUBLV));
4474 /* This makes sub {}; work as expected. */
4475 if (block->op_type == OP_STUB) {
4477 block = newSTATEOP(0, Nullch, 0);
4479 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4481 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4482 OpREFCNT_set(CvROOT(cv), 1);
4483 CvSTART(cv) = LINKLIST(CvROOT(cv));
4484 CvROOT(cv)->op_next = 0;
4485 CALL_PEEP(CvSTART(cv));
4487 /* now that optimizer has done its work, adjust pad values */
4489 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4492 assert(!CvCONST(cv));
4493 if (ps && !*ps && op_const_sv(block, cv))
4497 if (name || aname) {
4499 const char *tname = (name ? name : aname);
4501 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4502 SV *sv = NEWSV(0,0);
4503 SV *tmpstr = sv_newmortal();
4504 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4508 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4510 (long)PL_subline, (long)CopLINE(PL_curcop));
4511 gv_efullname3(tmpstr, gv, Nullch);
4512 hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
4513 hv = GvHVn(db_postponed);
4514 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))
4515 && (pcv = GvCV(db_postponed)))
4521 call_sv((SV*)pcv, G_DISCARD);
4525 if ((s = strrchr(tname,':')))
4530 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4533 if (strEQ(s, "BEGIN") && !PL_error_count) {
4534 const I32 oldscope = PL_scopestack_ix;
4536 SAVECOPFILE(&PL_compiling);
4537 SAVECOPLINE(&PL_compiling);
4540 PL_beginav = newAV();
4541 DEBUG_x( dump_sub(gv) );
4542 av_push(PL_beginav, (SV*)cv);
4543 GvCV(gv) = 0; /* cv has been hijacked */
4544 call_list(oldscope, PL_beginav);
4546 PL_curcop = &PL_compiling;
4547 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4550 else if (strEQ(s, "END") && !PL_error_count) {
4553 DEBUG_x( dump_sub(gv) );
4554 av_unshift(PL_endav, 1);
4555 av_store(PL_endav, 0, (SV*)cv);
4556 GvCV(gv) = 0; /* cv has been hijacked */
4558 else if (strEQ(s, "CHECK") && !PL_error_count) {
4560 PL_checkav = newAV();
4561 DEBUG_x( dump_sub(gv) );
4562 if (PL_main_start && ckWARN(WARN_VOID))
4563 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4564 av_unshift(PL_checkav, 1);
4565 av_store(PL_checkav, 0, (SV*)cv);
4566 GvCV(gv) = 0; /* cv has been hijacked */
4568 else if (strEQ(s, "INIT") && !PL_error_count) {
4570 PL_initav = newAV();
4571 DEBUG_x( dump_sub(gv) );
4572 if (PL_main_start && ckWARN(WARN_VOID))
4573 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4574 av_push(PL_initav, (SV*)cv);
4575 GvCV(gv) = 0; /* cv has been hijacked */
4580 PL_copline = NOLINE;
4585 /* XXX unsafe for threads if eval_owner isn't held */
4587 =for apidoc newCONSTSUB
4589 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4590 eligible for inlining at compile-time.
4596 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
4603 SAVECOPLINE(PL_curcop);
4604 CopLINE_set(PL_curcop, PL_copline);
4607 PL_hints &= ~HINT_BLOCK_SCOPE;
4610 SAVESPTR(PL_curstash);
4611 SAVECOPSTASH(PL_curcop);
4612 PL_curstash = stash;
4613 CopSTASH_set(PL_curcop,stash);
4616 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4617 CvXSUBANY(cv).any_ptr = sv;
4619 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
4622 CopSTASH_free(PL_curcop);
4630 =for apidoc U||newXS
4632 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4638 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
4640 GV *gv = gv_fetchpv(name ? name :
4641 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4642 GV_ADDMULTI, SVt_PVCV);
4646 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4648 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4650 /* just a cached method */
4654 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4655 /* already defined (or promised) */
4656 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
4657 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4658 && strEQ(HvNAME_get(GvSTASH(CvGV(cv))), "autouse"))) {
4659 const line_t oldline = CopLINE(PL_curcop);
4660 if (PL_copline != NOLINE)
4661 CopLINE_set(PL_curcop, PL_copline);
4662 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4663 CvCONST(cv) ? "Constant subroutine %s redefined"
4664 : "Subroutine %s redefined"
4666 CopLINE_set(PL_curcop, oldline);
4673 if (cv) /* must reuse cv if autoloaded */
4676 cv = (CV*)NEWSV(1105,0);
4677 sv_upgrade((SV *)cv, SVt_PVCV);
4681 PL_sub_generation++;
4685 (void)gv_fetchfile(filename);
4686 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
4687 an external constant string */
4688 CvXSUB(cv) = subaddr;
4691 const char *s = strrchr(name,':');
4697 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4700 if (strEQ(s, "BEGIN")) {
4702 PL_beginav = newAV();
4703 av_push(PL_beginav, (SV*)cv);
4704 GvCV(gv) = 0; /* cv has been hijacked */
4706 else if (strEQ(s, "END")) {
4709 av_unshift(PL_endav, 1);
4710 av_store(PL_endav, 0, (SV*)cv);
4711 GvCV(gv) = 0; /* cv has been hijacked */
4713 else if (strEQ(s, "CHECK")) {
4715 PL_checkav = newAV();
4716 if (PL_main_start && ckWARN(WARN_VOID))
4717 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4718 av_unshift(PL_checkav, 1);
4719 av_store(PL_checkav, 0, (SV*)cv);
4720 GvCV(gv) = 0; /* cv has been hijacked */
4722 else if (strEQ(s, "INIT")) {
4724 PL_initav = newAV();
4725 if (PL_main_start && ckWARN(WARN_VOID))
4726 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4727 av_push(PL_initav, (SV*)cv);
4728 GvCV(gv) = 0; /* cv has been hijacked */
4739 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4745 gv = gv_fetchsv(cSVOPo->op_sv, TRUE, SVt_PVFM);
4747 gv = gv_fetchpv("STDOUT", TRUE, SVt_PVFM);
4749 #ifdef GV_UNIQUE_CHECK
4751 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4755 if ((cv = GvFORM(gv))) {
4756 if (ckWARN(WARN_REDEFINE)) {
4757 const line_t oldline = CopLINE(PL_curcop);
4758 if (PL_copline != NOLINE)
4759 CopLINE_set(PL_curcop, PL_copline);
4760 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4761 o ? "Format %"SVf" redefined"
4762 : "Format STDOUT redefined" ,cSVOPo->op_sv);
4763 CopLINE_set(PL_curcop, oldline);
4770 CvFILE_set_from_cop(cv, PL_curcop);
4773 pad_tidy(padtidy_FORMAT);
4774 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4775 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4776 OpREFCNT_set(CvROOT(cv), 1);
4777 CvSTART(cv) = LINKLIST(CvROOT(cv));
4778 CvROOT(cv)->op_next = 0;
4779 CALL_PEEP(CvSTART(cv));
4781 PL_copline = NOLINE;
4786 Perl_newANONLIST(pTHX_ OP *o)
4788 return newUNOP(OP_REFGEN, 0,
4789 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4793 Perl_newANONHASH(pTHX_ OP *o)
4795 return newUNOP(OP_REFGEN, 0,
4796 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4800 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4802 return newANONATTRSUB(floor, proto, Nullop, block);
4806 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4808 return newUNOP(OP_REFGEN, 0,
4809 newSVOP(OP_ANONCODE, 0,
4810 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
4814 Perl_oopsAV(pTHX_ OP *o)
4817 switch (o->op_type) {
4819 o->op_type = OP_PADAV;
4820 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4821 return ref(o, OP_RV2AV);
4824 o->op_type = OP_RV2AV;
4825 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4830 if (ckWARN_d(WARN_INTERNAL))
4831 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
4838 Perl_oopsHV(pTHX_ OP *o)
4841 switch (o->op_type) {
4844 o->op_type = OP_PADHV;
4845 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4846 return ref(o, OP_RV2HV);
4850 o->op_type = OP_RV2HV;
4851 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
4856 if (ckWARN_d(WARN_INTERNAL))
4857 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
4864 Perl_newAVREF(pTHX_ OP *o)
4867 if (o->op_type == OP_PADANY) {
4868 o->op_type = OP_PADAV;
4869 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4872 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
4873 && ckWARN(WARN_DEPRECATED)) {
4874 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4875 "Using an array as a reference is deprecated");
4877 return newUNOP(OP_RV2AV, 0, scalar(o));
4881 Perl_newGVREF(pTHX_ I32 type, OP *o)
4883 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
4884 return newUNOP(OP_NULL, 0, o);
4885 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
4889 Perl_newHVREF(pTHX_ OP *o)
4892 if (o->op_type == OP_PADANY) {
4893 o->op_type = OP_PADHV;
4894 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4897 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
4898 && ckWARN(WARN_DEPRECATED)) {
4899 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4900 "Using a hash as a reference is deprecated");
4902 return newUNOP(OP_RV2HV, 0, scalar(o));
4906 Perl_oopsCV(pTHX_ OP *o)
4908 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
4911 NORETURN_FUNCTION_END;
4915 Perl_newCVREF(pTHX_ I32 flags, OP *o)
4917 return newUNOP(OP_RV2CV, flags, scalar(o));
4921 Perl_newSVREF(pTHX_ OP *o)
4924 if (o->op_type == OP_PADANY) {
4925 o->op_type = OP_PADSV;
4926 o->op_ppaddr = PL_ppaddr[OP_PADSV];
4929 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4930 o->op_flags |= OPpDONE_SVREF;
4933 return newUNOP(OP_RV2SV, 0, scalar(o));
4936 /* Check routines. See the comments at the top of this file for details
4937 * on when these are called */
4940 Perl_ck_anoncode(pTHX_ OP *o)
4942 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
4943 cSVOPo->op_sv = Nullsv;
4948 Perl_ck_bitop(pTHX_ OP *o)
4950 #define OP_IS_NUMCOMPARE(op) \
4951 ((op) == OP_LT || (op) == OP_I_LT || \
4952 (op) == OP_GT || (op) == OP_I_GT || \
4953 (op) == OP_LE || (op) == OP_I_LE || \
4954 (op) == OP_GE || (op) == OP_I_GE || \
4955 (op) == OP_EQ || (op) == OP_I_EQ || \
4956 (op) == OP_NE || (op) == OP_I_NE || \
4957 (op) == OP_NCMP || (op) == OP_I_NCMP)
4958 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4959 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
4960 && (o->op_type == OP_BIT_OR
4961 || o->op_type == OP_BIT_AND
4962 || o->op_type == OP_BIT_XOR))
4964 const OP * const left = cBINOPo->op_first;
4965 const OP * const right = left->op_sibling;
4966 if ((OP_IS_NUMCOMPARE(left->op_type) &&
4967 (left->op_flags & OPf_PARENS) == 0) ||
4968 (OP_IS_NUMCOMPARE(right->op_type) &&
4969 (right->op_flags & OPf_PARENS) == 0))
4970 if (ckWARN(WARN_PRECEDENCE))
4971 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4972 "Possible precedence problem on bitwise %c operator",
4973 o->op_type == OP_BIT_OR ? '|'
4974 : o->op_type == OP_BIT_AND ? '&' : '^'
4981 Perl_ck_concat(pTHX_ OP *o)
4983 const OP *kid = cUNOPo->op_first;
4984 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
4985 !(kUNOP->op_first->op_flags & OPf_MOD))
4986 o->op_flags |= OPf_STACKED;
4991 Perl_ck_spair(pTHX_ OP *o)
4994 if (o->op_flags & OPf_KIDS) {
4997 const OPCODE type = o->op_type;
4998 o = modkids(ck_fun(o), type);
4999 kid = cUNOPo->op_first;
5000 newop = kUNOP->op_first->op_sibling;
5002 (newop->op_sibling ||
5003 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5004 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5005 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5009 op_free(kUNOP->op_first);
5010 kUNOP->op_first = newop;
5012 o->op_ppaddr = PL_ppaddr[++o->op_type];
5017 Perl_ck_delete(pTHX_ OP *o)
5021 if (o->op_flags & OPf_KIDS) {
5022 OP *kid = cUNOPo->op_first;
5023 switch (kid->op_type) {
5025 o->op_flags |= OPf_SPECIAL;
5028 o->op_private |= OPpSLICE;
5031 o->op_flags |= OPf_SPECIAL;
5036 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5045 Perl_ck_die(pTHX_ OP *o)
5048 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5054 Perl_ck_eof(pTHX_ OP *o)
5056 const I32 type = o->op_type;
5058 if (o->op_flags & OPf_KIDS) {
5059 if (cLISTOPo->op_first->op_type == OP_STUB) {
5061 o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
5069 Perl_ck_eval(pTHX_ OP *o)
5072 PL_hints |= HINT_BLOCK_SCOPE;
5073 if (o->op_flags & OPf_KIDS) {
5074 SVOP *kid = (SVOP*)cUNOPo->op_first;
5077 o->op_flags &= ~OPf_KIDS;
5080 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
5083 cUNOPo->op_first = 0;
5086 NewOp(1101, enter, 1, LOGOP);
5087 enter->op_type = OP_ENTERTRY;
5088 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5089 enter->op_private = 0;
5091 /* establish postfix order */
5092 enter->op_next = (OP*)enter;
5094 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5095 o->op_type = OP_LEAVETRY;
5096 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5097 enter->op_other = o;
5107 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5109 o->op_targ = (PADOFFSET)PL_hints;
5114 Perl_ck_exit(pTHX_ OP *o)
5117 HV *table = GvHV(PL_hintgv);
5119 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5120 if (svp && *svp && SvTRUE(*svp))
5121 o->op_private |= OPpEXIT_VMSISH;
5123 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5129 Perl_ck_exec(pTHX_ OP *o)
5131 if (o->op_flags & OPf_STACKED) {
5134 kid = cUNOPo->op_first->op_sibling;
5135 if (kid->op_type == OP_RV2GV)
5144 Perl_ck_exists(pTHX_ OP *o)
5147 if (o->op_flags & OPf_KIDS) {
5148 OP *kid = cUNOPo->op_first;
5149 if (kid->op_type == OP_ENTERSUB) {
5150 (void) ref(kid, o->op_type);
5151 if (kid->op_type != OP_RV2CV && !PL_error_count)
5152 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5154 o->op_private |= OPpEXISTS_SUB;
5156 else if (kid->op_type == OP_AELEM)
5157 o->op_flags |= OPf_SPECIAL;
5158 else if (kid->op_type != OP_HELEM)
5159 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5167 Perl_ck_rvconst(pTHX_ register OP *o)
5170 SVOP *kid = (SVOP*)cUNOPo->op_first;
5172 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5173 if (kid->op_type == OP_CONST) {
5176 SV * const kidsv = kid->op_sv;
5178 /* Is it a constant from cv_const_sv()? */
5179 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5180 SV *rsv = SvRV(kidsv);
5181 const int svtype = SvTYPE(rsv);
5182 const char *badtype = Nullch;
5184 switch (o->op_type) {
5186 if (svtype > SVt_PVMG)
5187 badtype = "a SCALAR";
5190 if (svtype != SVt_PVAV)
5191 badtype = "an ARRAY";
5194 if (svtype != SVt_PVHV)
5198 if (svtype != SVt_PVCV)
5203 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5206 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5207 const char *badthing = Nullch;
5208 switch (o->op_type) {
5210 badthing = "a SCALAR";
5213 badthing = "an ARRAY";
5216 badthing = "a HASH";
5221 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
5225 * This is a little tricky. We only want to add the symbol if we
5226 * didn't add it in the lexer. Otherwise we get duplicate strict
5227 * warnings. But if we didn't add it in the lexer, we must at
5228 * least pretend like we wanted to add it even if it existed before,
5229 * or we get possible typo warnings. OPpCONST_ENTERED says
5230 * whether the lexer already added THIS instance of this symbol.
5232 iscv = (o->op_type == OP_RV2CV) * 2;
5234 gv = gv_fetchsv(kidsv,
5235 iscv | !(kid->op_private & OPpCONST_ENTERED),
5238 : o->op_type == OP_RV2SV
5240 : o->op_type == OP_RV2AV
5242 : o->op_type == OP_RV2HV
5245 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5247 kid->op_type = OP_GV;
5248 SvREFCNT_dec(kid->op_sv);
5250 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5251 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5252 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
5254 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
5256 kid->op_sv = SvREFCNT_inc(gv);
5258 kid->op_private = 0;
5259 kid->op_ppaddr = PL_ppaddr[OP_GV];
5266 Perl_ck_ftst(pTHX_ OP *o)
5269 const I32 type = o->op_type;
5271 if (o->op_flags & OPf_REF) {
5274 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5275 SVOP *kid = (SVOP*)cUNOPo->op_first;
5277 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5278 OP *newop = newGVOP(type, OPf_REF,
5279 gv_fetchsv(kid->op_sv, TRUE, SVt_PVIO));
5285 if ((PL_hints & HINT_FILETEST_ACCESS) &&
5286 OP_IS_FILETEST_ACCESS(o))
5287 o->op_private |= OPpFT_ACCESS;
5289 if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
5290 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
5291 o->op_private |= OPpFT_STACKED;
5295 if (type == OP_FTTTY)
5296 o = newGVOP(type, OPf_REF, PL_stdingv);
5298 o = newUNOP(type, 0, newDEFSVOP());
5304 Perl_ck_fun(pTHX_ OP *o)
5306 const int type = o->op_type;
5307 register I32 oa = PL_opargs[type] >> OASHIFT;
5309 if (o->op_flags & OPf_STACKED) {
5310 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5313 return no_fh_allowed(o);
5316 if (o->op_flags & OPf_KIDS) {
5317 OP **tokid = &cLISTOPo->op_first;
5318 register OP *kid = cLISTOPo->op_first;
5322 if (kid->op_type == OP_PUSHMARK ||
5323 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5325 tokid = &kid->op_sibling;
5326 kid = kid->op_sibling;
5328 if (!kid && PL_opargs[type] & OA_DEFGV)
5329 *tokid = kid = newDEFSVOP();
5333 sibl = kid->op_sibling;
5336 /* list seen where single (scalar) arg expected? */
5337 if (numargs == 1 && !(oa >> 4)
5338 && kid->op_type == OP_LIST && type != OP_SCALAR)
5340 return too_many_arguments(o,PL_op_desc[type]);
5353 if ((type == OP_PUSH || type == OP_UNSHIFT)
5354 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5355 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5356 "Useless use of %s with no values",
5359 if (kid->op_type == OP_CONST &&
5360 (kid->op_private & OPpCONST_BARE))
5362 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5363 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVAV) ));
5364 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5365 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5366 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
5367 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5370 kid->op_sibling = sibl;
5373 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5374 bad_type(numargs, "array", PL_op_desc[type], kid);
5378 if (kid->op_type == OP_CONST &&
5379 (kid->op_private & OPpCONST_BARE))
5381 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5382 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVHV) ));
5383 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5384 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5385 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
5386 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5389 kid->op_sibling = sibl;
5392 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5393 bad_type(numargs, "hash", PL_op_desc[type], kid);
5398 OP *newop = newUNOP(OP_NULL, 0, kid);
5399 kid->op_sibling = 0;
5401 newop->op_next = newop;
5403 kid->op_sibling = sibl;
5408 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5409 if (kid->op_type == OP_CONST &&
5410 (kid->op_private & OPpCONST_BARE))
5412 OP *newop = newGVOP(OP_GV, 0,
5413 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVIO) );
5414 if (!(o->op_private & 1) && /* if not unop */
5415 kid == cLISTOPo->op_last)
5416 cLISTOPo->op_last = newop;
5420 else if (kid->op_type == OP_READLINE) {
5421 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5422 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5425 I32 flags = OPf_SPECIAL;
5429 /* is this op a FH constructor? */
5430 if (is_handle_constructor(o,numargs)) {
5431 const char *name = Nullch;
5435 /* Set a flag to tell rv2gv to vivify
5436 * need to "prove" flag does not mean something
5437 * else already - NI-S 1999/05/07
5440 if (kid->op_type == OP_PADSV) {
5441 name = PAD_COMPNAME_PV(kid->op_targ);
5442 /* SvCUR of a pad namesv can't be trusted
5443 * (see PL_generation), so calc its length
5449 else if (kid->op_type == OP_RV2SV
5450 && kUNOP->op_first->op_type == OP_GV)
5452 GV *gv = cGVOPx_gv(kUNOP->op_first);
5454 len = GvNAMELEN(gv);
5456 else if (kid->op_type == OP_AELEM
5457 || kid->op_type == OP_HELEM)
5462 if ((op = ((BINOP*)kid)->op_first)) {
5463 SV *tmpstr = Nullsv;
5465 kid->op_type == OP_AELEM ?
5467 if (((op->op_type == OP_RV2AV) ||
5468 (op->op_type == OP_RV2HV)) &&
5469 (op = ((UNOP*)op)->op_first) &&
5470 (op->op_type == OP_GV)) {
5471 /* packagevar $a[] or $h{} */
5472 GV *gv = cGVOPx_gv(op);
5480 else if (op->op_type == OP_PADAV
5481 || op->op_type == OP_PADHV) {
5482 /* lexicalvar $a[] or $h{} */
5483 const char *padname =
5484 PAD_COMPNAME_PV(op->op_targ);
5494 name = SvPV(tmpstr, len);
5499 name = "__ANONIO__";
5506 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5507 namesv = PAD_SVl(targ);
5508 (void)SvUPGRADE(namesv, SVt_PV);
5510 sv_setpvn(namesv, "$", 1);
5511 sv_catpvn(namesv, name, len);
5514 kid->op_sibling = 0;
5515 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5516 kid->op_targ = targ;
5517 kid->op_private |= priv;
5519 kid->op_sibling = sibl;
5525 mod(scalar(kid), type);
5529 tokid = &kid->op_sibling;
5530 kid = kid->op_sibling;
5532 o->op_private |= numargs;
5534 return too_many_arguments(o,OP_DESC(o));
5537 else if (PL_opargs[type] & OA_DEFGV) {
5539 return newUNOP(type, 0, newDEFSVOP());
5543 while (oa & OA_OPTIONAL)
5545 if (oa && oa != OA_LIST)
5546 return too_few_arguments(o,OP_DESC(o));
5552 Perl_ck_glob(pTHX_ OP *o)
5558 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5559 append_elem(OP_GLOB, o, newDEFSVOP());
5561 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5562 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5564 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5567 #if !defined(PERL_EXTERNAL_GLOB)
5568 /* XXX this can be tightened up and made more failsafe. */
5569 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5572 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5573 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5574 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5575 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5576 GvCV(gv) = GvCV(glob_gv);
5577 (void)SvREFCNT_inc((SV*)GvCV(gv));
5578 GvIMPORTED_CV_on(gv);
5581 #endif /* PERL_EXTERNAL_GLOB */
5583 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5584 append_elem(OP_GLOB, o,
5585 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5586 o->op_type = OP_LIST;
5587 o->op_ppaddr = PL_ppaddr[OP_LIST];
5588 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5589 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5590 cLISTOPo->op_first->op_targ = 0;
5591 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5592 append_elem(OP_LIST, o,
5593 scalar(newUNOP(OP_RV2CV, 0,
5594 newGVOP(OP_GV, 0, gv)))));
5595 o = newUNOP(OP_NULL, 0, ck_subr(o));
5596 o->op_targ = OP_GLOB; /* hint at what it used to be */
5599 gv = newGVgen("main");
5601 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5607 Perl_ck_grep(pTHX_ OP *o)
5612 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5615 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5616 NewOp(1101, gwop, 1, LOGOP);
5618 if (o->op_flags & OPf_STACKED) {
5621 kid = cLISTOPo->op_first->op_sibling;
5622 if (!cUNOPx(kid)->op_next)
5623 Perl_croak(aTHX_ "panic: ck_grep");
5624 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
5627 kid->op_next = (OP*)gwop;
5628 o->op_flags &= ~OPf_STACKED;
5630 kid = cLISTOPo->op_first->op_sibling;
5631 if (type == OP_MAPWHILE)
5638 kid = cLISTOPo->op_first->op_sibling;
5639 if (kid->op_type != OP_NULL)
5640 Perl_croak(aTHX_ "panic: ck_grep");
5641 kid = kUNOP->op_first;
5643 gwop->op_type = type;
5644 gwop->op_ppaddr = PL_ppaddr[type];
5645 gwop->op_first = listkids(o);
5646 gwop->op_flags |= OPf_KIDS;
5647 gwop->op_other = LINKLIST(kid);
5648 kid->op_next = (OP*)gwop;
5649 offset = pad_findmy("$_");
5650 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
5651 o->op_private = gwop->op_private = 0;
5652 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5655 o->op_private = gwop->op_private = OPpGREP_LEX;
5656 gwop->op_targ = o->op_targ = offset;
5659 kid = cLISTOPo->op_first->op_sibling;
5660 if (!kid || !kid->op_sibling)
5661 return too_few_arguments(o,OP_DESC(o));
5662 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5663 mod(kid, OP_GREPSTART);
5669 Perl_ck_index(pTHX_ OP *o)
5671 if (o->op_flags & OPf_KIDS) {
5672 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5674 kid = kid->op_sibling; /* get past "big" */
5675 if (kid && kid->op_type == OP_CONST)
5676 fbm_compile(((SVOP*)kid)->op_sv, 0);
5682 Perl_ck_lengthconst(pTHX_ OP *o)
5684 /* XXX length optimization goes here */
5689 Perl_ck_lfun(pTHX_ OP *o)
5691 const OPCODE type = o->op_type;
5692 return modkids(ck_fun(o), type);
5696 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5698 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5699 switch (cUNOPo->op_first->op_type) {
5701 /* This is needed for
5702 if (defined %stash::)
5703 to work. Do not break Tk.
5705 break; /* Globals via GV can be undef */
5707 case OP_AASSIGN: /* Is this a good idea? */
5708 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5709 "defined(@array) is deprecated");
5710 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5711 "\t(Maybe you should just omit the defined()?)\n");
5714 /* This is needed for
5715 if (defined %stash::)
5716 to work. Do not break Tk.
5718 break; /* Globals via GV can be undef */
5720 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5721 "defined(%%hash) is deprecated");
5722 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5723 "\t(Maybe you should just omit the defined()?)\n");
5734 Perl_ck_rfun(pTHX_ OP *o)
5736 const OPCODE type = o->op_type;
5737 return refkids(ck_fun(o), type);
5741 Perl_ck_listiob(pTHX_ OP *o)
5745 kid = cLISTOPo->op_first;
5748 kid = cLISTOPo->op_first;
5750 if (kid->op_type == OP_PUSHMARK)
5751 kid = kid->op_sibling;
5752 if (kid && o->op_flags & OPf_STACKED)
5753 kid = kid->op_sibling;
5754 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5755 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5756 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5757 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5758 cLISTOPo->op_first->op_sibling = kid;
5759 cLISTOPo->op_last = kid;
5760 kid = kid->op_sibling;
5765 append_elem(o->op_type, o, newDEFSVOP());
5771 Perl_ck_sassign(pTHX_ OP *o)
5773 OP *kid = cLISTOPo->op_first;
5774 /* has a disposable target? */
5775 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5776 && !(kid->op_flags & OPf_STACKED)
5777 /* Cannot steal the second time! */
5778 && !(kid->op_private & OPpTARGET_MY))
5780 OP *kkid = kid->op_sibling;
5782 /* Can just relocate the target. */
5783 if (kkid && kkid->op_type == OP_PADSV
5784 && !(kkid->op_private & OPpLVAL_INTRO))
5786 kid->op_targ = kkid->op_targ;
5788 /* Now we do not need PADSV and SASSIGN. */
5789 kid->op_sibling = o->op_sibling; /* NULL */
5790 cLISTOPo->op_first = NULL;
5793 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
5797 /* optimise C<my $x = undef> to C<my $x> */
5798 if (kid->op_type == OP_UNDEF) {
5799 OP *kkid = kid->op_sibling;
5800 if (kkid && kkid->op_type == OP_PADSV
5801 && (kkid->op_private & OPpLVAL_INTRO))
5803 cLISTOPo->op_first = NULL;
5804 kid->op_sibling = NULL;
5814 Perl_ck_match(pTHX_ OP *o)
5816 if (o->op_type != OP_QR) {
5817 const I32 offset = pad_findmy("$_");
5818 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS(offset) & SVpad_OUR)) {
5819 o->op_targ = offset;
5820 o->op_private |= OPpTARGET_MY;
5823 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
5824 o->op_private |= OPpRUNTIME;
5829 Perl_ck_method(pTHX_ OP *o)
5831 OP *kid = cUNOPo->op_first;
5832 if (kid->op_type == OP_CONST) {
5833 SV* sv = kSVOP->op_sv;
5834 if (!(strchr(SvPVX_const(sv), ':') || strchr(SvPVX_const(sv), '\''))) {
5836 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5837 sv = newSVpvn_share(SvPVX_const(sv), SvCUR(sv), 0);
5840 kSVOP->op_sv = Nullsv;
5842 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5851 Perl_ck_null(pTHX_ OP *o)
5857 Perl_ck_open(pTHX_ OP *o)
5859 HV *table = GvHV(PL_hintgv);
5863 svp = hv_fetch(table, "open_IN", 7, FALSE);
5865 mode = mode_from_discipline(*svp);
5866 if (mode & O_BINARY)
5867 o->op_private |= OPpOPEN_IN_RAW;
5868 else if (mode & O_TEXT)
5869 o->op_private |= OPpOPEN_IN_CRLF;
5872 svp = hv_fetch(table, "open_OUT", 8, FALSE);
5874 mode = mode_from_discipline(*svp);
5875 if (mode & O_BINARY)
5876 o->op_private |= OPpOPEN_OUT_RAW;
5877 else if (mode & O_TEXT)
5878 o->op_private |= OPpOPEN_OUT_CRLF;
5881 if (o->op_type == OP_BACKTICK)
5884 /* In case of three-arg dup open remove strictness
5885 * from the last arg if it is a bareword. */
5886 OP *first = cLISTOPx(o)->op_first; /* The pushmark. */
5887 OP *last = cLISTOPx(o)->op_last; /* The bareword. */
5891 if ((last->op_type == OP_CONST) && /* The bareword. */
5892 (last->op_private & OPpCONST_BARE) &&
5893 (last->op_private & OPpCONST_STRICT) &&
5894 (oa = first->op_sibling) && /* The fh. */
5895 (oa = oa->op_sibling) && /* The mode. */
5896 SvPOK(((SVOP*)oa)->op_sv) &&
5897 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
5898 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
5899 (last == oa->op_sibling)) /* The bareword. */
5900 last->op_private &= ~OPpCONST_STRICT;
5906 Perl_ck_repeat(pTHX_ OP *o)
5908 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5909 o->op_private |= OPpREPEAT_DOLIST;
5910 cBINOPo->op_first = force_list(cBINOPo->op_first);
5918 Perl_ck_require(pTHX_ OP *o)
5922 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
5923 SVOP *kid = (SVOP*)cUNOPo->op_first;
5925 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5927 for (s = SvPVX(kid->op_sv); *s; s++) {
5928 if (*s == ':' && s[1] == ':') {
5930 Move(s+2, s+1, strlen(s+2)+1, char);
5931 SvCUR_set(kid->op_sv, SvCUR(kid->op_sv) - 1);
5934 if (SvREADONLY(kid->op_sv)) {
5935 SvREADONLY_off(kid->op_sv);
5936 sv_catpvn(kid->op_sv, ".pm", 3);
5937 SvREADONLY_on(kid->op_sv);
5940 sv_catpvn(kid->op_sv, ".pm", 3);
5944 /* handle override, if any */
5945 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
5946 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
5947 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
5949 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5950 OP *kid = cUNOPo->op_first;
5951 cUNOPo->op_first = 0;
5953 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5954 append_elem(OP_LIST, kid,
5955 scalar(newUNOP(OP_RV2CV, 0,
5964 Perl_ck_return(pTHX_ OP *o)
5966 if (CvLVALUE(PL_compcv)) {
5968 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5969 mod(kid, OP_LEAVESUBLV);
5976 Perl_ck_retarget(pTHX_ OP *o)
5978 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5985 Perl_ck_select(pTHX_ OP *o)
5989 if (o->op_flags & OPf_KIDS) {
5990 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5991 if (kid && kid->op_sibling) {
5992 o->op_type = OP_SSELECT;
5993 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
5995 return fold_constants(o);
5999 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6000 if (kid && kid->op_type == OP_RV2GV)
6001 kid->op_private &= ~HINT_STRICT_REFS;
6006 Perl_ck_shift(pTHX_ OP *o)
6008 const I32 type = o->op_type;
6010 if (!(o->op_flags & OPf_KIDS)) {
6014 argop = newUNOP(OP_RV2AV, 0,
6015 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
6016 return newUNOP(type, 0, scalar(argop));
6018 return scalar(modkids(ck_fun(o), type));
6022 Perl_ck_sort(pTHX_ OP *o)
6026 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6028 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6029 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6031 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6033 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6035 if (kid->op_type == OP_SCOPE) {
6039 else if (kid->op_type == OP_LEAVE) {
6040 if (o->op_type == OP_SORT) {
6041 op_null(kid); /* wipe out leave */
6044 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6045 if (k->op_next == kid)
6047 /* don't descend into loops */
6048 else if (k->op_type == OP_ENTERLOOP
6049 || k->op_type == OP_ENTERITER)
6051 k = cLOOPx(k)->op_lastop;
6056 kid->op_next = 0; /* just disconnect the leave */
6057 k = kLISTOP->op_first;
6062 if (o->op_type == OP_SORT) {
6063 /* provide scalar context for comparison function/block */
6069 o->op_flags |= OPf_SPECIAL;
6071 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6074 firstkid = firstkid->op_sibling;
6077 /* provide list context for arguments */
6078 if (o->op_type == OP_SORT)
6085 S_simplify_sort(pTHX_ OP *o)
6087 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6092 if (!(o->op_flags & OPf_STACKED))
6094 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6095 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6096 kid = kUNOP->op_first; /* get past null */
6097 if (kid->op_type != OP_SCOPE)
6099 kid = kLISTOP->op_last; /* get past scope */
6100 switch(kid->op_type) {
6108 k = kid; /* remember this node*/
6109 if (kBINOP->op_first->op_type != OP_RV2SV)
6111 kid = kBINOP->op_first; /* get past cmp */
6112 if (kUNOP->op_first->op_type != OP_GV)
6114 kid = kUNOP->op_first; /* get past rv2sv */
6116 if (GvSTASH(gv) != PL_curstash)
6118 gvname = GvNAME(gv);
6119 if (*gvname == 'a' && gvname[1] == '\0')
6121 else if (*gvname == 'b' && gvname[1] == '\0')
6126 kid = k; /* back to cmp */
6127 if (kBINOP->op_last->op_type != OP_RV2SV)
6129 kid = kBINOP->op_last; /* down to 2nd arg */
6130 if (kUNOP->op_first->op_type != OP_GV)
6132 kid = kUNOP->op_first; /* get past rv2sv */
6134 if (GvSTASH(gv) != PL_curstash)
6136 gvname = GvNAME(gv);
6138 ? !(*gvname == 'a' && gvname[1] == '\0')
6139 : !(*gvname == 'b' && gvname[1] == '\0'))
6141 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6143 o->op_private |= OPpSORT_DESCEND;
6144 if (k->op_type == OP_NCMP)
6145 o->op_private |= OPpSORT_NUMERIC;
6146 if (k->op_type == OP_I_NCMP)
6147 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6148 kid = cLISTOPo->op_first->op_sibling;
6149 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6150 op_free(kid); /* then delete it */
6154 Perl_ck_split(pTHX_ OP *o)
6159 if (o->op_flags & OPf_STACKED)
6160 return no_fh_allowed(o);
6162 kid = cLISTOPo->op_first;
6163 if (kid->op_type != OP_NULL)
6164 Perl_croak(aTHX_ "panic: ck_split");
6165 kid = kid->op_sibling;
6166 op_free(cLISTOPo->op_first);
6167 cLISTOPo->op_first = kid;
6169 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6170 cLISTOPo->op_last = kid; /* There was only one element previously */
6173 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6174 OP *sibl = kid->op_sibling;
6175 kid->op_sibling = 0;
6176 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
6177 if (cLISTOPo->op_first == cLISTOPo->op_last)
6178 cLISTOPo->op_last = kid;
6179 cLISTOPo->op_first = kid;
6180 kid->op_sibling = sibl;
6183 kid->op_type = OP_PUSHRE;
6184 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6186 if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
6187 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
6188 "Use of /g modifier is meaningless in split");
6191 if (!kid->op_sibling)
6192 append_elem(OP_SPLIT, o, newDEFSVOP());
6194 kid = kid->op_sibling;
6197 if (!kid->op_sibling)
6198 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6200 kid = kid->op_sibling;
6203 if (kid->op_sibling)
6204 return too_many_arguments(o,OP_DESC(o));
6210 Perl_ck_join(pTHX_ OP *o)
6212 if (ckWARN(WARN_SYNTAX)) {
6213 const OP *kid = cLISTOPo->op_first->op_sibling;
6214 if (kid && kid->op_type == OP_MATCH) {
6215 const REGEXP *re = PM_GETRE(kPMOP);
6216 const char *pmstr = re ? re->precomp : "STRING";
6217 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6218 "/%s/ should probably be written as \"%s\"",
6226 Perl_ck_subr(pTHX_ OP *o)
6228 OP *prev = ((cUNOPo->op_first->op_sibling)
6229 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6230 OP *o2 = prev->op_sibling;
6237 I32 contextclass = 0;
6242 o->op_private |= OPpENTERSUB_HASTARG;
6243 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6244 if (cvop->op_type == OP_RV2CV) {
6246 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6247 op_null(cvop); /* disable rv2cv */
6248 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6249 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6250 GV *gv = cGVOPx_gv(tmpop);
6253 tmpop->op_private |= OPpEARLY_CV;
6256 namegv = CvANON(cv) ? gv : CvGV(cv);
6257 proto = SvPV((SV*)cv, n_a);
6259 if (CvASSERTION(cv)) {
6260 if (PL_hints & HINT_ASSERTING) {
6261 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
6262 o->op_private |= OPpENTERSUB_DB;
6266 if (ckWARN(WARN_ASSERTIONS) && !(PL_hints & HINT_ASSERTIONSSEEN)) {
6267 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
6268 "Impossible to activate assertion call");
6275 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6276 if (o2->op_type == OP_CONST)
6277 o2->op_private &= ~OPpCONST_STRICT;
6278 else if (o2->op_type == OP_LIST) {
6279 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6280 if (o && o->op_type == OP_CONST)
6281 o->op_private &= ~OPpCONST_STRICT;
6284 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6285 if (PERLDB_SUB && PL_curstash != PL_debstash)
6286 o->op_private |= OPpENTERSUB_DB;
6287 while (o2 != cvop) {
6291 return too_many_arguments(o, gv_ename(namegv));
6309 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6311 arg == 1 ? "block or sub {}" : "sub {}",
6312 gv_ename(namegv), o2);
6315 /* '*' allows any scalar type, including bareword */
6318 if (o2->op_type == OP_RV2GV)
6319 goto wrapref; /* autoconvert GLOB -> GLOBref */
6320 else if (o2->op_type == OP_CONST)
6321 o2->op_private &= ~OPpCONST_STRICT;
6322 else if (o2->op_type == OP_ENTERSUB) {
6323 /* accidental subroutine, revert to bareword */
6324 OP *gvop = ((UNOP*)o2)->op_first;
6325 if (gvop && gvop->op_type == OP_NULL) {
6326 gvop = ((UNOP*)gvop)->op_first;
6328 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6331 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6332 (gvop = ((UNOP*)gvop)->op_first) &&
6333 gvop->op_type == OP_GV)
6335 GV *gv = cGVOPx_gv(gvop);
6336 OP *sibling = o2->op_sibling;
6337 SV *n = newSVpvn("",0);
6339 gv_fullname4(n, gv, "", FALSE);
6340 o2 = newSVOP(OP_CONST, 0, n);
6341 prev->op_sibling = o2;
6342 o2->op_sibling = sibling;
6358 if (contextclass++ == 0) {
6359 e = strchr(proto, ']');
6360 if (!e || e == proto)
6373 while (*--p != '[');
6374 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6375 gv_ename(namegv), o2);
6381 if (o2->op_type == OP_RV2GV)
6384 bad_type(arg, "symbol", gv_ename(namegv), o2);
6387 if (o2->op_type == OP_ENTERSUB)
6390 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6393 if (o2->op_type == OP_RV2SV ||
6394 o2->op_type == OP_PADSV ||
6395 o2->op_type == OP_HELEM ||
6396 o2->op_type == OP_AELEM ||
6397 o2->op_type == OP_THREADSV)
6400 bad_type(arg, "scalar", gv_ename(namegv), o2);
6403 if (o2->op_type == OP_RV2AV ||
6404 o2->op_type == OP_PADAV)
6407 bad_type(arg, "array", gv_ename(namegv), o2);
6410 if (o2->op_type == OP_RV2HV ||
6411 o2->op_type == OP_PADHV)
6414 bad_type(arg, "hash", gv_ename(namegv), o2);
6419 OP* sib = kid->op_sibling;
6420 kid->op_sibling = 0;
6421 o2 = newUNOP(OP_REFGEN, 0, kid);
6422 o2->op_sibling = sib;
6423 prev->op_sibling = o2;
6425 if (contextclass && e) {
6440 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6441 gv_ename(namegv), cv);
6446 mod(o2, OP_ENTERSUB);
6448 o2 = o2->op_sibling;
6450 if (proto && !optional &&
6451 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6452 return too_few_arguments(o, gv_ename(namegv));
6455 o=newSVOP(OP_CONST, 0, newSViv(0));
6461 Perl_ck_svconst(pTHX_ OP *o)
6463 SvREADONLY_on(cSVOPo->op_sv);
6468 Perl_ck_trunc(pTHX_ OP *o)
6470 if (o->op_flags & OPf_KIDS) {
6471 SVOP *kid = (SVOP*)cUNOPo->op_first;
6473 if (kid->op_type == OP_NULL)
6474 kid = (SVOP*)kid->op_sibling;
6475 if (kid && kid->op_type == OP_CONST &&
6476 (kid->op_private & OPpCONST_BARE))
6478 o->op_flags |= OPf_SPECIAL;
6479 kid->op_private &= ~OPpCONST_STRICT;
6486 Perl_ck_unpack(pTHX_ OP *o)
6488 OP *kid = cLISTOPo->op_first;
6489 if (kid->op_sibling) {
6490 kid = kid->op_sibling;
6491 if (!kid->op_sibling)
6492 kid->op_sibling = newDEFSVOP();
6498 Perl_ck_substr(pTHX_ OP *o)
6501 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6502 OP *kid = cLISTOPo->op_first;
6504 if (kid->op_type == OP_NULL)
6505 kid = kid->op_sibling;
6507 kid->op_flags |= OPf_MOD;
6513 /* A peephole optimizer. We visit the ops in the order they're to execute.
6514 * See the comments at the top of this file for more details about when
6515 * peep() is called */
6518 Perl_peep(pTHX_ register OP *o)
6521 register OP* oldop = 0;
6523 if (!o || o->op_opt)
6527 SAVEVPTR(PL_curcop);
6528 for (; o; o = o->op_next) {
6532 switch (o->op_type) {
6536 PL_curcop = ((COP*)o); /* for warnings */
6541 if (cSVOPo->op_private & OPpCONST_STRICT)
6542 no_bareword_allowed(o);
6544 case OP_METHOD_NAMED:
6545 /* Relocate sv to the pad for thread safety.
6546 * Despite being a "constant", the SV is written to,
6547 * for reference counts, sv_upgrade() etc. */
6549 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6550 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6551 /* If op_sv is already a PADTMP then it is being used by
6552 * some pad, so make a copy. */
6553 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6554 SvREADONLY_on(PAD_SVl(ix));
6555 SvREFCNT_dec(cSVOPo->op_sv);
6558 SvREFCNT_dec(PAD_SVl(ix));
6559 SvPADTMP_on(cSVOPo->op_sv);
6560 PAD_SETSV(ix, cSVOPo->op_sv);
6561 /* XXX I don't know how this isn't readonly already. */
6562 SvREADONLY_on(PAD_SVl(ix));
6564 cSVOPo->op_sv = Nullsv;
6572 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6573 if (o->op_next->op_private & OPpTARGET_MY) {
6574 if (o->op_flags & OPf_STACKED) /* chained concats */
6575 goto ignore_optimization;
6577 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6578 o->op_targ = o->op_next->op_targ;
6579 o->op_next->op_targ = 0;
6580 o->op_private |= OPpTARGET_MY;
6583 op_null(o->op_next);
6585 ignore_optimization:
6589 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6591 break; /* Scalar stub must produce undef. List stub is noop */
6595 if (o->op_targ == OP_NEXTSTATE
6596 || o->op_targ == OP_DBSTATE
6597 || o->op_targ == OP_SETSTATE)
6599 PL_curcop = ((COP*)o);
6601 /* XXX: We avoid setting op_seq here to prevent later calls
6602 to peep() from mistakenly concluding that optimisation
6603 has already occurred. This doesn't fix the real problem,
6604 though (See 20010220.007). AMS 20010719 */
6605 /* op_seq functionality is now replaced by op_opt */
6606 if (oldop && o->op_next) {
6607 oldop->op_next = o->op_next;
6615 if (oldop && o->op_next) {
6616 oldop->op_next = o->op_next;
6624 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
6625 OP* pop = (o->op_type == OP_PADAV) ?
6626 o->op_next : o->op_next->op_next;
6628 if (pop && pop->op_type == OP_CONST &&
6629 ((PL_op = pop->op_next)) &&
6630 pop->op_next->op_type == OP_AELEM &&
6631 !(pop->op_next->op_private &
6632 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6633 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6638 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
6639 no_bareword_allowed(pop);
6640 if (o->op_type == OP_GV)
6641 op_null(o->op_next);
6642 op_null(pop->op_next);
6644 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6645 o->op_next = pop->op_next->op_next;
6646 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6647 o->op_private = (U8)i;
6648 if (o->op_type == OP_GV) {
6653 o->op_flags |= OPf_SPECIAL;
6654 o->op_type = OP_AELEMFAST;
6660 if (o->op_next->op_type == OP_RV2SV) {
6661 if (!(o->op_next->op_private & OPpDEREF)) {
6662 op_null(o->op_next);
6663 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6665 o->op_next = o->op_next->op_next;
6666 o->op_type = OP_GVSV;
6667 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6670 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6672 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
6673 /* XXX could check prototype here instead of just carping */
6674 SV *sv = sv_newmortal();
6675 gv_efullname3(sv, gv, Nullch);
6676 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6677 "%"SVf"() called too early to check prototype",
6681 else if (o->op_next->op_type == OP_READLINE
6682 && o->op_next->op_next->op_type == OP_CONCAT
6683 && (o->op_next->op_next->op_flags & OPf_STACKED))
6685 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6686 o->op_type = OP_RCATLINE;
6687 o->op_flags |= OPf_STACKED;
6688 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6689 op_null(o->op_next->op_next);
6690 op_null(o->op_next);
6707 while (cLOGOP->op_other->op_type == OP_NULL)
6708 cLOGOP->op_other = cLOGOP->op_other->op_next;
6709 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6715 while (cLOOP->op_redoop->op_type == OP_NULL)
6716 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6717 peep(cLOOP->op_redoop);
6718 while (cLOOP->op_nextop->op_type == OP_NULL)
6719 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6720 peep(cLOOP->op_nextop);
6721 while (cLOOP->op_lastop->op_type == OP_NULL)
6722 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6723 peep(cLOOP->op_lastop);
6730 while (cPMOP->op_pmreplstart &&
6731 cPMOP->op_pmreplstart->op_type == OP_NULL)
6732 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6733 peep(cPMOP->op_pmreplstart);
6738 if (ckWARN(WARN_SYNTAX) && o->op_next
6739 && o->op_next->op_type == OP_NEXTSTATE) {
6740 if (o->op_next->op_sibling &&
6741 o->op_next->op_sibling->op_type != OP_EXIT &&
6742 o->op_next->op_sibling->op_type != OP_WARN &&
6743 o->op_next->op_sibling->op_type != OP_DIE) {
6744 const line_t oldline = CopLINE(PL_curcop);
6746 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6747 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6748 "Statement unlikely to be reached");
6749 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6750 "\t(Maybe you meant system() when you said exec()?)\n");
6751 CopLINE_set(PL_curcop, oldline);
6766 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6769 /* Make the CONST have a shared SV */
6770 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6771 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6772 key = SvPV(sv, keylen);
6773 lexname = newSVpvn_share(key,
6774 SvUTF8(sv) ? -(I32)keylen : keylen,
6780 if ((o->op_private & (OPpLVAL_INTRO)))
6783 rop = (UNOP*)((BINOP*)o)->op_first;
6784 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6786 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6787 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6789 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6790 if (!fields || !GvHV(*fields))
6792 key = SvPV(*svp, keylen);
6793 if (!hv_fetch(GvHV(*fields), key,
6794 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
6796 Perl_croak(aTHX_ "No such class field \"%s\" "
6797 "in variable %s of type %s",
6798 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
6811 SVOP *first_key_op, *key_op;
6813 if ((o->op_private & (OPpLVAL_INTRO))
6814 /* I bet there's always a pushmark... */
6815 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6816 /* hmmm, no optimization if list contains only one key. */
6818 rop = (UNOP*)((LISTOP*)o)->op_last;
6819 if (rop->op_type != OP_RV2HV)
6821 if (rop->op_first->op_type == OP_PADSV)
6822 /* @$hash{qw(keys here)} */
6823 rop = (UNOP*)rop->op_first;
6825 /* @{$hash}{qw(keys here)} */
6826 if (rop->op_first->op_type == OP_SCOPE
6827 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
6829 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
6835 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
6836 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6838 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6839 if (!fields || !GvHV(*fields))
6841 /* Again guessing that the pushmark can be jumped over.... */
6842 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
6843 ->op_first->op_sibling;
6844 for (key_op = first_key_op; key_op;
6845 key_op = (SVOP*)key_op->op_sibling) {
6846 if (key_op->op_type != OP_CONST)
6848 svp = cSVOPx_svp(key_op);
6849 key = SvPV(*svp, keylen);
6850 if (!hv_fetch(GvHV(*fields), key,
6851 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
6853 Perl_croak(aTHX_ "No such class field \"%s\" "
6854 "in variable %s of type %s",
6855 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
6862 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
6866 /* check that RHS of sort is a single plain array */
6867 oright = cUNOPo->op_first;
6868 if (!oright || oright->op_type != OP_PUSHMARK)
6871 /* reverse sort ... can be optimised. */
6872 if (!cUNOPo->op_sibling) {
6873 /* Nothing follows us on the list. */
6874 OP *reverse = o->op_next;
6876 if (reverse->op_type == OP_REVERSE &&
6877 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
6878 OP *pushmark = cUNOPx(reverse)->op_first;
6879 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
6880 && (cUNOPx(pushmark)->op_sibling == o)) {
6881 /* reverse -> pushmark -> sort */
6882 o->op_private |= OPpSORT_REVERSE;
6884 pushmark->op_next = oright->op_next;
6890 /* make @a = sort @a act in-place */
6894 oright = cUNOPx(oright)->op_sibling;
6897 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
6898 oright = cUNOPx(oright)->op_sibling;
6902 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
6903 || oright->op_next != o
6904 || (oright->op_private & OPpLVAL_INTRO)
6908 /* o2 follows the chain of op_nexts through the LHS of the
6909 * assign (if any) to the aassign op itself */
6911 if (!o2 || o2->op_type != OP_NULL)
6914 if (!o2 || o2->op_type != OP_PUSHMARK)
6917 if (o2 && o2->op_type == OP_GV)
6920 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
6921 || (o2->op_private & OPpLVAL_INTRO)
6926 if (!o2 || o2->op_type != OP_NULL)
6929 if (!o2 || o2->op_type != OP_AASSIGN
6930 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
6933 /* check that the sort is the first arg on RHS of assign */
6935 o2 = cUNOPx(o2)->op_first;
6936 if (!o2 || o2->op_type != OP_NULL)
6938 o2 = cUNOPx(o2)->op_first;
6939 if (!o2 || o2->op_type != OP_PUSHMARK)
6941 if (o2->op_sibling != o)
6944 /* check the array is the same on both sides */
6945 if (oleft->op_type == OP_RV2AV) {
6946 if (oright->op_type != OP_RV2AV
6947 || !cUNOPx(oright)->op_first
6948 || cUNOPx(oright)->op_first->op_type != OP_GV
6949 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
6950 cGVOPx_gv(cUNOPx(oright)->op_first)
6954 else if (oright->op_type != OP_PADAV
6955 || oright->op_targ != oleft->op_targ
6959 /* transfer MODishness etc from LHS arg to RHS arg */
6960 oright->op_flags = oleft->op_flags;
6961 o->op_private |= OPpSORT_INPLACE;
6963 /* excise push->gv->rv2av->null->aassign */
6964 o2 = o->op_next->op_next;
6965 op_null(o2); /* PUSHMARK */
6967 if (o2->op_type == OP_GV) {
6968 op_null(o2); /* GV */
6971 op_null(o2); /* RV2AV or PADAV */
6972 o2 = o2->op_next->op_next;
6973 op_null(o2); /* AASSIGN */
6975 o->op_next = o2->op_next;
6981 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
6983 LISTOP *enter, *exlist;
6986 enter = (LISTOP *) o->op_next;
6989 if (enter->op_type == OP_NULL) {
6990 enter = (LISTOP *) enter->op_next;
6994 /* for $a (...) will have OP_GV then OP_RV2GV here.
6995 for (...) just has an OP_GV. */
6996 if (enter->op_type == OP_GV) {
6997 gvop = (OP *) enter;
6998 enter = (LISTOP *) enter->op_next;
7001 if (enter->op_type == OP_RV2GV) {
7002 enter = (LISTOP *) enter->op_next;
7008 if (enter->op_type != OP_ENTERITER)
7011 iter = enter->op_next;
7012 if (!iter || iter->op_type != OP_ITER)
7015 expushmark = enter->op_first;
7016 if (!expushmark || expushmark->op_type != OP_NULL
7017 || expushmark->op_targ != OP_PUSHMARK)
7020 exlist = (LISTOP *) expushmark->op_sibling;
7021 if (!exlist || exlist->op_type != OP_NULL
7022 || exlist->op_targ != OP_LIST)
7025 if (exlist->op_last != o) {
7026 /* Mmm. Was expecting to point back to this op. */
7029 theirmark = exlist->op_first;
7030 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
7033 if (theirmark->op_sibling != o) {
7034 /* There's something between the mark and the reverse, eg
7035 for (1, reverse (...))
7040 ourmark = ((LISTOP *)o)->op_first;
7041 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
7044 ourlast = ((LISTOP *)o)->op_last;
7045 if (!ourlast || ourlast->op_next != o)
7048 rv2av = ourmark->op_sibling;
7049 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
7050 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
7051 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
7052 /* We're just reversing a single array. */
7053 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
7054 enter->op_flags |= OPf_STACKED;
7057 /* We don't have control over who points to theirmark, so sacrifice
7059 theirmark->op_next = ourmark->op_next;
7060 theirmark->op_flags = ourmark->op_flags;
7061 ourlast->op_next = gvop ? gvop : (OP *) enter;
7064 enter->op_private |= OPpITER_REVERSED;
7065 iter->op_private |= OPpITER_REVERSED;
7080 Perl_custom_op_name(pTHX_ const OP* o)
7082 const IV index = PTR2IV(o->op_ppaddr);
7086 if (!PL_custom_op_names) /* This probably shouldn't happen */
7087 return (char *)PL_op_name[OP_CUSTOM];
7089 keysv = sv_2mortal(newSViv(index));
7091 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7093 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7095 return SvPV_nolen(HeVAL(he));
7099 Perl_custom_op_desc(pTHX_ const OP* o)
7101 const IV index = PTR2IV(o->op_ppaddr);
7105 if (!PL_custom_op_descs)
7106 return (char *)PL_op_desc[OP_CUSTOM];
7108 keysv = sv_2mortal(newSViv(index));
7110 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7112 return (char *)PL_op_desc[OP_CUSTOM];
7114 return SvPV_nolen(HeVAL(he));
7119 /* Efficient sub that returns a constant scalar value. */
7121 const_sv_xsub(pTHX_ CV* cv)
7126 Perl_croak(aTHX_ "usage: %s::%s()",
7127 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7131 ST(0) = (SV*)XSANY.any_ptr;
7137 * c-indentation-style: bsd
7139 * indent-tabs-mode: t
7142 * ex: set ts=8 sts=4 sw=4 noet: