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 = newSVpv(HvNAME_get(stash), 0);
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 = newSVpv(HvNAME_get(stash), 0);
1593 stashsv = &PL_sv_no;
1594 arg = newOP(OP_PADSV, 0);
1595 arg->op_targ = target->op_targ;
1596 arg = prepend_elem(OP_LIST,
1597 newSVOP(OP_CONST, 0, stashsv),
1598 prepend_elem(OP_LIST,
1599 newUNOP(OP_REFGEN, 0,
1600 mod(arg, OP_REFGEN)),
1601 dup_attrlist(attrs)));
1603 /* Fake up a method call to import */
1604 meth = newSVpvn("import", 6);
1605 (void)SvUPGRADE(meth, SVt_PVIV);
1606 (void)SvIOK_on(meth);
1609 PERL_HASH(hash, SvPVX_const(meth), SvCUR(meth));
1610 SvUV_set(meth, hash);
1612 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1613 append_elem(OP_LIST,
1614 prepend_elem(OP_LIST, pack, list(arg)),
1615 newSVOP(OP_METHOD_NAMED, 0, meth)));
1616 imop->op_private |= OPpENTERSUB_NOMOD;
1618 /* Combine the ops. */
1619 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1623 =notfor apidoc apply_attrs_string
1625 Attempts to apply a list of attributes specified by the C<attrstr> and
1626 C<len> arguments to the subroutine identified by the C<cv> argument which
1627 is expected to be associated with the package identified by the C<stashpv>
1628 argument (see L<attributes>). It gets this wrong, though, in that it
1629 does not correctly identify the boundaries of the individual attribute
1630 specifications within C<attrstr>. This is not really intended for the
1631 public API, but has to be listed here for systems such as AIX which
1632 need an explicit export list for symbols. (It's called from XS code
1633 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1634 to respect attribute syntax properly would be welcome.
1640 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1641 const char *attrstr, STRLEN len)
1646 len = strlen(attrstr);
1650 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1652 const char *sstr = attrstr;
1653 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1654 attrs = append_elem(OP_LIST, attrs,
1655 newSVOP(OP_CONST, 0,
1656 newSVpvn(sstr, attrstr-sstr)));
1660 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1661 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1662 Nullsv, prepend_elem(OP_LIST,
1663 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1664 prepend_elem(OP_LIST,
1665 newSVOP(OP_CONST, 0,
1671 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1675 if (!o || PL_error_count)
1679 if (type == OP_LIST) {
1681 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1682 my_kid(kid, attrs, imopsp);
1683 } else if (type == OP_UNDEF) {
1685 } else if (type == OP_RV2SV || /* "our" declaration */
1687 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1688 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1689 yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
1690 OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
1692 GV *gv = cGVOPx_gv(cUNOPo->op_first);
1694 PL_in_my_stash = Nullhv;
1695 apply_attrs(GvSTASH(gv),
1696 (type == OP_RV2SV ? GvSV(gv) :
1697 type == OP_RV2AV ? (SV*)GvAV(gv) :
1698 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1701 o->op_private |= OPpOUR_INTRO;
1704 else if (type != OP_PADSV &&
1707 type != OP_PUSHMARK)
1709 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1711 PL_in_my == KEY_our ? "our" : "my"));
1714 else if (attrs && type != OP_PUSHMARK) {
1718 PL_in_my_stash = Nullhv;
1720 /* check for C<my Dog $spot> when deciding package */
1721 stash = PAD_COMPNAME_TYPE(o->op_targ);
1723 stash = PL_curstash;
1724 apply_attrs_my(stash, o, attrs, imopsp);
1726 o->op_flags |= OPf_MOD;
1727 o->op_private |= OPpLVAL_INTRO;
1732 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1735 int maybe_scalar = 0;
1737 /* [perl #17376]: this appears to be premature, and results in code such as
1738 C< our(%x); > executing in list mode rather than void mode */
1740 if (o->op_flags & OPf_PARENS)
1749 o = my_kid(o, attrs, &rops);
1751 if (maybe_scalar && o->op_type == OP_PADSV) {
1752 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1753 o->op_private |= OPpLVAL_INTRO;
1756 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1759 PL_in_my_stash = Nullhv;
1764 Perl_my(pTHX_ OP *o)
1766 return my_attrs(o, Nullop);
1770 Perl_sawparens(pTHX_ OP *o)
1773 o->op_flags |= OPf_PARENS;
1778 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1783 if (ckWARN(WARN_MISC) &&
1784 (left->op_type == OP_RV2AV ||
1785 left->op_type == OP_RV2HV ||
1786 left->op_type == OP_PADAV ||
1787 left->op_type == OP_PADHV)) {
1788 const char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
1789 right->op_type == OP_TRANS)
1790 ? right->op_type : OP_MATCH];
1791 const char *sample = ((left->op_type == OP_RV2AV ||
1792 left->op_type == OP_PADAV)
1793 ? "@array" : "%hash");
1794 Perl_warner(aTHX_ packWARN(WARN_MISC),
1795 "Applying %s to %s will act on scalar(%s)",
1796 desc, sample, sample);
1799 if (right->op_type == OP_CONST &&
1800 cSVOPx(right)->op_private & OPpCONST_BARE &&
1801 cSVOPx(right)->op_private & OPpCONST_STRICT)
1803 no_bareword_allowed(right);
1806 ismatchop = right->op_type == OP_MATCH ||
1807 right->op_type == OP_SUBST ||
1808 right->op_type == OP_TRANS;
1809 if (ismatchop && right->op_private & OPpTARGET_MY) {
1811 right->op_private &= ~OPpTARGET_MY;
1813 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1814 right->op_flags |= OPf_STACKED;
1815 if (right->op_type != OP_MATCH &&
1816 ! (right->op_type == OP_TRANS &&
1817 right->op_private & OPpTRANS_IDENTICAL))
1818 left = mod(left, right->op_type);
1819 if (right->op_type == OP_TRANS)
1820 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
1822 o = prepend_elem(right->op_type, scalar(left), right);
1824 return newUNOP(OP_NOT, 0, scalar(o));
1828 return bind_match(type, left,
1829 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
1833 Perl_invert(pTHX_ OP *o)
1837 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
1838 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1842 Perl_scope(pTHX_ OP *o)
1846 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1847 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1848 o->op_type = OP_LEAVE;
1849 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1851 else if (o->op_type == OP_LINESEQ) {
1853 o->op_type = OP_SCOPE;
1854 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1855 kid = ((LISTOP*)o)->op_first;
1856 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
1860 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
1865 /* XXX kept for BINCOMPAT only */
1867 Perl_save_hints(pTHX)
1869 Perl_croak(aTHX_ "internal error: obsolete function save_hints() called");
1873 Perl_block_start(pTHX_ int full)
1875 const int retval = PL_savestack_ix;
1876 pad_block_start(full);
1878 PL_hints &= ~HINT_BLOCK_SCOPE;
1879 SAVESPTR(PL_compiling.cop_warnings);
1880 if (! specialWARN(PL_compiling.cop_warnings)) {
1881 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1882 SAVEFREESV(PL_compiling.cop_warnings) ;
1884 SAVESPTR(PL_compiling.cop_io);
1885 if (! specialCopIO(PL_compiling.cop_io)) {
1886 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1887 SAVEFREESV(PL_compiling.cop_io) ;
1893 Perl_block_end(pTHX_ I32 floor, OP *seq)
1895 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1896 OP* retval = scalarseq(seq);
1898 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
1900 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
1908 const I32 offset = pad_findmy("$_");
1909 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
1910 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1913 OP *o = newOP(OP_PADSV, 0);
1914 o->op_targ = offset;
1920 Perl_newPROG(pTHX_ OP *o)
1925 PL_eval_root = newUNOP(OP_LEAVEEVAL,
1926 ((PL_in_eval & EVAL_KEEPERR)
1927 ? OPf_SPECIAL : 0), o);
1928 PL_eval_start = linklist(PL_eval_root);
1929 PL_eval_root->op_private |= OPpREFCOUNTED;
1930 OpREFCNT_set(PL_eval_root, 1);
1931 PL_eval_root->op_next = 0;
1932 CALL_PEEP(PL_eval_start);
1935 if (o->op_type == OP_STUB) {
1936 PL_comppad_name = 0;
1941 PL_main_root = scope(sawparens(scalarvoid(o)));
1942 PL_curcop = &PL_compiling;
1943 PL_main_start = LINKLIST(PL_main_root);
1944 PL_main_root->op_private |= OPpREFCOUNTED;
1945 OpREFCNT_set(PL_main_root, 1);
1946 PL_main_root->op_next = 0;
1947 CALL_PEEP(PL_main_start);
1950 /* Register with debugger */
1952 CV *cv = get_cv("DB::postponed", FALSE);
1956 XPUSHs((SV*)CopFILEGV(&PL_compiling));
1958 call_sv((SV*)cv, G_DISCARD);
1965 Perl_localize(pTHX_ OP *o, I32 lex)
1967 if (o->op_flags & OPf_PARENS)
1968 /* [perl #17376]: this appears to be premature, and results in code such as
1969 C< our(%x); > executing in list mode rather than void mode */
1976 if (ckWARN(WARN_PARENTHESIS)
1977 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
1979 char *s = PL_bufptr;
1982 /* some heuristics to detect a potential error */
1983 while (*s && (strchr(", \t\n", *s)))
1987 if (*s && strchr("@$%*", *s) && *++s
1988 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
1991 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
1993 while (*s && (strchr(", \t\n", *s)))
1999 if (sigil && (*s == ';' || *s == '=')) {
2000 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2001 "Parentheses missing around \"%s\" list",
2002 lex ? (PL_in_my == KEY_our ? "our" : "my")
2010 o = mod(o, OP_NULL); /* a bit kludgey */
2012 PL_in_my_stash = Nullhv;
2017 Perl_jmaybe(pTHX_ OP *o)
2019 if (o->op_type == OP_LIST) {
2021 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2022 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2028 Perl_fold_constants(pTHX_ register OP *o)
2032 I32 type = o->op_type;
2035 if (PL_opargs[type] & OA_RETSCALAR)
2037 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2038 o->op_targ = pad_alloc(type, SVs_PADTMP);
2040 /* integerize op, unless it happens to be C<-foo>.
2041 * XXX should pp_i_negate() do magic string negation instead? */
2042 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2043 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2044 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2046 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2049 if (!(PL_opargs[type] & OA_FOLDCONST))
2054 /* XXX might want a ck_negate() for this */
2055 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2067 /* XXX what about the numeric ops? */
2068 if (PL_hints & HINT_LOCALE)
2073 goto nope; /* Don't try to run w/ errors */
2075 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2076 if ((curop->op_type != OP_CONST ||
2077 (curop->op_private & OPpCONST_BARE)) &&
2078 curop->op_type != OP_LIST &&
2079 curop->op_type != OP_SCALAR &&
2080 curop->op_type != OP_NULL &&
2081 curop->op_type != OP_PUSHMARK)
2087 curop = LINKLIST(o);
2091 sv = *(PL_stack_sp--);
2092 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2093 pad_swipe(o->op_targ, FALSE);
2094 else if (SvTEMP(sv)) { /* grab mortal temp? */
2095 (void)SvREFCNT_inc(sv);
2099 if (type == OP_RV2GV)
2100 return newGVOP(OP_GV, 0, (GV*)sv);
2101 return newSVOP(OP_CONST, 0, sv);
2108 Perl_gen_constant_list(pTHX_ register OP *o)
2112 const I32 oldtmps_floor = PL_tmps_floor;
2116 return o; /* Don't attempt to run with errors */
2118 PL_op = curop = LINKLIST(o);
2125 PL_tmps_floor = oldtmps_floor;
2127 o->op_type = OP_RV2AV;
2128 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2129 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2130 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2131 o->op_opt = 0; /* needs to be revisited in peep() */
2132 curop = ((UNOP*)o)->op_first;
2133 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2140 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2143 if (!o || o->op_type != OP_LIST)
2144 o = newLISTOP(OP_LIST, 0, o, Nullop);
2146 o->op_flags &= ~OPf_WANT;
2148 if (!(PL_opargs[type] & OA_MARK))
2149 op_null(cLISTOPo->op_first);
2151 o->op_type = (OPCODE)type;
2152 o->op_ppaddr = PL_ppaddr[type];
2153 o->op_flags |= flags;
2155 o = CHECKOP(type, o);
2156 if (o->op_type != (unsigned)type)
2159 return fold_constants(o);
2162 /* List constructors */
2165 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2173 if (first->op_type != (unsigned)type
2174 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2176 return newLISTOP(type, 0, first, last);
2179 if (first->op_flags & OPf_KIDS)
2180 ((LISTOP*)first)->op_last->op_sibling = last;
2182 first->op_flags |= OPf_KIDS;
2183 ((LISTOP*)first)->op_first = last;
2185 ((LISTOP*)first)->op_last = last;
2190 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2198 if (first->op_type != (unsigned)type)
2199 return prepend_elem(type, (OP*)first, (OP*)last);
2201 if (last->op_type != (unsigned)type)
2202 return append_elem(type, (OP*)first, (OP*)last);
2204 first->op_last->op_sibling = last->op_first;
2205 first->op_last = last->op_last;
2206 first->op_flags |= (last->op_flags & OPf_KIDS);
2214 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2222 if (last->op_type == (unsigned)type) {
2223 if (type == OP_LIST) { /* already a PUSHMARK there */
2224 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2225 ((LISTOP*)last)->op_first->op_sibling = first;
2226 if (!(first->op_flags & OPf_PARENS))
2227 last->op_flags &= ~OPf_PARENS;
2230 if (!(last->op_flags & OPf_KIDS)) {
2231 ((LISTOP*)last)->op_last = first;
2232 last->op_flags |= OPf_KIDS;
2234 first->op_sibling = ((LISTOP*)last)->op_first;
2235 ((LISTOP*)last)->op_first = first;
2237 last->op_flags |= OPf_KIDS;
2241 return newLISTOP(type, 0, first, last);
2247 Perl_newNULLLIST(pTHX)
2249 return newOP(OP_STUB, 0);
2253 Perl_force_list(pTHX_ OP *o)
2255 if (!o || o->op_type != OP_LIST)
2256 o = newLISTOP(OP_LIST, 0, o, Nullop);
2262 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2267 NewOp(1101, listop, 1, LISTOP);
2269 listop->op_type = (OPCODE)type;
2270 listop->op_ppaddr = PL_ppaddr[type];
2273 listop->op_flags = (U8)flags;
2277 else if (!first && last)
2280 first->op_sibling = last;
2281 listop->op_first = first;
2282 listop->op_last = last;
2283 if (type == OP_LIST) {
2285 pushop = newOP(OP_PUSHMARK, 0);
2286 pushop->op_sibling = first;
2287 listop->op_first = pushop;
2288 listop->op_flags |= OPf_KIDS;
2290 listop->op_last = pushop;
2293 return CHECKOP(type, listop);
2297 Perl_newOP(pTHX_ I32 type, I32 flags)
2301 NewOp(1101, o, 1, OP);
2302 o->op_type = (OPCODE)type;
2303 o->op_ppaddr = PL_ppaddr[type];
2304 o->op_flags = (U8)flags;
2307 o->op_private = (U8)(0 | (flags >> 8));
2308 if (PL_opargs[type] & OA_RETSCALAR)
2310 if (PL_opargs[type] & OA_TARGET)
2311 o->op_targ = pad_alloc(type, SVs_PADTMP);
2312 return CHECKOP(type, o);
2316 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2322 first = newOP(OP_STUB, 0);
2323 if (PL_opargs[type] & OA_MARK)
2324 first = force_list(first);
2326 NewOp(1101, unop, 1, UNOP);
2327 unop->op_type = (OPCODE)type;
2328 unop->op_ppaddr = PL_ppaddr[type];
2329 unop->op_first = first;
2330 unop->op_flags = flags | OPf_KIDS;
2331 unop->op_private = (U8)(1 | (flags >> 8));
2332 unop = (UNOP*) CHECKOP(type, unop);
2336 return fold_constants((OP *) unop);
2340 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2344 NewOp(1101, binop, 1, BINOP);
2347 first = newOP(OP_NULL, 0);
2349 binop->op_type = (OPCODE)type;
2350 binop->op_ppaddr = PL_ppaddr[type];
2351 binop->op_first = first;
2352 binop->op_flags = flags | OPf_KIDS;
2355 binop->op_private = (U8)(1 | (flags >> 8));
2358 binop->op_private = (U8)(2 | (flags >> 8));
2359 first->op_sibling = last;
2362 binop = (BINOP*)CHECKOP(type, binop);
2363 if (binop->op_next || binop->op_type != (OPCODE)type)
2366 binop->op_last = binop->op_first->op_sibling;
2368 return fold_constants((OP *)binop);
2371 static int uvcompare(const void *a, const void *b) __attribute__nonnull__(1) __attribute__nonnull__(2) __attribute__pure__;
2372 static int uvcompare(const void *a, const void *b)
2374 if (*((const UV *)a) < (*(const UV *)b))
2376 if (*((const UV *)a) > (*(const UV *)b))
2378 if (*((const UV *)a+1) < (*(const UV *)b+1))
2380 if (*((const UV *)a+1) > (*(const UV *)b+1))
2386 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2388 SV *tstr = ((SVOP*)expr)->op_sv;
2389 SV *rstr = ((SVOP*)repl)->op_sv;
2392 U8 *t = (U8*)SvPV(tstr, tlen);
2393 U8 *r = (U8*)SvPV(rstr, rlen);
2400 register short *tbl;
2402 PL_hints |= HINT_BLOCK_SCOPE;
2403 complement = o->op_private & OPpTRANS_COMPLEMENT;
2404 del = o->op_private & OPpTRANS_DELETE;
2405 squash = o->op_private & OPpTRANS_SQUASH;
2408 o->op_private |= OPpTRANS_FROM_UTF;
2411 o->op_private |= OPpTRANS_TO_UTF;
2413 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2414 SV* listsv = newSVpvn("# comment\n",10);
2416 U8* tend = t + tlen;
2417 U8* rend = r + rlen;
2431 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2432 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2438 tsave = t = bytes_to_utf8(t, &len);
2441 if (!to_utf && rlen) {
2443 rsave = r = bytes_to_utf8(r, &len);
2447 /* There are several snags with this code on EBCDIC:
2448 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2449 2. scan_const() in toke.c has encoded chars in native encoding which makes
2450 ranges at least in EBCDIC 0..255 range the bottom odd.
2454 U8 tmpbuf[UTF8_MAXBYTES+1];
2457 New(1109, cp, 2*tlen, UV);
2459 transv = newSVpvn("",0);
2461 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2463 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2465 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2469 cp[2*i+1] = cp[2*i];
2473 qsort(cp, i, 2*sizeof(UV), uvcompare);
2474 for (j = 0; j < i; j++) {
2476 diff = val - nextmin;
2478 t = uvuni_to_utf8(tmpbuf,nextmin);
2479 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2481 U8 range_mark = UTF_TO_NATIVE(0xff);
2482 t = uvuni_to_utf8(tmpbuf, val - 1);
2483 sv_catpvn(transv, (char *)&range_mark, 1);
2484 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2491 t = uvuni_to_utf8(tmpbuf,nextmin);
2492 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2494 U8 range_mark = UTF_TO_NATIVE(0xff);
2495 sv_catpvn(transv, (char *)&range_mark, 1);
2497 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2498 UNICODE_ALLOW_SUPER);
2499 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2500 t = (U8*)SvPVX(transv);
2501 tlen = SvCUR(transv);
2505 else if (!rlen && !del) {
2506 r = t; rlen = tlen; rend = tend;
2509 if ((!rlen && !del) || t == r ||
2510 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2512 o->op_private |= OPpTRANS_IDENTICAL;
2516 while (t < tend || tfirst <= tlast) {
2517 /* see if we need more "t" chars */
2518 if (tfirst > tlast) {
2519 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2521 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2523 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2530 /* now see if we need more "r" chars */
2531 if (rfirst > rlast) {
2533 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2535 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2537 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2546 rfirst = rlast = 0xffffffff;
2550 /* now see which range will peter our first, if either. */
2551 tdiff = tlast - tfirst;
2552 rdiff = rlast - rfirst;
2559 if (rfirst == 0xffffffff) {
2560 diff = tdiff; /* oops, pretend rdiff is infinite */
2562 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2563 (long)tfirst, (long)tlast);
2565 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2569 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2570 (long)tfirst, (long)(tfirst + diff),
2573 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2574 (long)tfirst, (long)rfirst);
2576 if (rfirst + diff > max)
2577 max = rfirst + diff;
2579 grows = (tfirst < rfirst &&
2580 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2592 else if (max > 0xff)
2597 Safefree(cPVOPo->op_pv);
2598 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2599 SvREFCNT_dec(listsv);
2601 SvREFCNT_dec(transv);
2603 if (!del && havefinal && rlen)
2604 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2605 newSVuv((UV)final), 0);
2608 o->op_private |= OPpTRANS_GROWS;
2620 tbl = (short*)cPVOPo->op_pv;
2622 Zero(tbl, 256, short);
2623 for (i = 0; i < (I32)tlen; i++)
2625 for (i = 0, j = 0; i < 256; i++) {
2627 if (j >= (I32)rlen) {
2636 if (i < 128 && r[j] >= 128)
2646 o->op_private |= OPpTRANS_IDENTICAL;
2648 else if (j >= (I32)rlen)
2651 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2652 tbl[0x100] = rlen - j;
2653 for (i=0; i < (I32)rlen - j; i++)
2654 tbl[0x101+i] = r[j+i];
2658 if (!rlen && !del) {
2661 o->op_private |= OPpTRANS_IDENTICAL;
2663 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2664 o->op_private |= OPpTRANS_IDENTICAL;
2666 for (i = 0; i < 256; i++)
2668 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
2669 if (j >= (I32)rlen) {
2671 if (tbl[t[i]] == -1)
2677 if (tbl[t[i]] == -1) {
2678 if (t[i] < 128 && r[j] >= 128)
2685 o->op_private |= OPpTRANS_GROWS;
2693 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2698 NewOp(1101, pmop, 1, PMOP);
2699 pmop->op_type = (OPCODE)type;
2700 pmop->op_ppaddr = PL_ppaddr[type];
2701 pmop->op_flags = (U8)flags;
2702 pmop->op_private = (U8)(0 | (flags >> 8));
2704 if (PL_hints & HINT_RE_TAINT)
2705 pmop->op_pmpermflags |= PMf_RETAINT;
2706 if (PL_hints & HINT_LOCALE)
2707 pmop->op_pmpermflags |= PMf_LOCALE;
2708 pmop->op_pmflags = pmop->op_pmpermflags;
2713 if(av_len((AV*) PL_regex_pad[0]) > -1) {
2714 repointer = av_pop((AV*)PL_regex_pad[0]);
2715 pmop->op_pmoffset = SvIV(repointer);
2716 SvREPADTMP_off(repointer);
2717 sv_setiv(repointer,0);
2719 repointer = newSViv(0);
2720 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2721 pmop->op_pmoffset = av_len(PL_regex_padav);
2722 PL_regex_pad = AvARRAY(PL_regex_padav);
2727 /* link into pm list */
2728 if (type != OP_TRANS && PL_curstash) {
2729 MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab);
2732 mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0);
2734 pmop->op_pmnext = (PMOP*)mg->mg_obj;
2735 mg->mg_obj = (SV*)pmop;
2736 PmopSTASH_set(pmop,PL_curstash);
2739 return CHECKOP(type, pmop);
2742 /* Given some sort of match op o, and an expression expr containing a
2743 * pattern, either compile expr into a regex and attach it to o (if it's
2744 * constant), or convert expr into a runtime regcomp op sequence (if it's
2747 * isreg indicates that the pattern is part of a regex construct, eg
2748 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
2749 * split "pattern", which aren't. In the former case, expr will be a list
2750 * if the pattern contains more than one term (eg /a$b/) or if it contains
2751 * a replacement, ie s/// or tr///.
2755 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
2760 I32 repl_has_vars = 0;
2764 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
2765 /* last element in list is the replacement; pop it */
2767 repl = cLISTOPx(expr)->op_last;
2768 kid = cLISTOPx(expr)->op_first;
2769 while (kid->op_sibling != repl)
2770 kid = kid->op_sibling;
2771 kid->op_sibling = Nullop;
2772 cLISTOPx(expr)->op_last = kid;
2775 if (isreg && expr->op_type == OP_LIST &&
2776 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
2778 /* convert single element list to element */
2780 expr = cLISTOPx(oe)->op_first->op_sibling;
2781 cLISTOPx(oe)->op_first->op_sibling = Nullop;
2782 cLISTOPx(oe)->op_last = Nullop;
2786 if (o->op_type == OP_TRANS) {
2787 return pmtrans(o, expr, repl);
2790 reglist = isreg && expr->op_type == OP_LIST;
2794 PL_hints |= HINT_BLOCK_SCOPE;
2797 if (expr->op_type == OP_CONST) {
2799 SV *pat = ((SVOP*)expr)->op_sv;
2800 char *p = SvPV(pat, plen);
2801 if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
2802 sv_setpvn(pat, "\\s+", 3);
2803 p = SvPV(pat, plen);
2804 pm->op_pmflags |= PMf_SKIPWHITE;
2807 pm->op_pmdynflags |= PMdf_UTF8;
2808 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
2809 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
2810 pm->op_pmflags |= PMf_WHITE;
2814 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2815 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2817 : OP_REGCMAYBE),0,expr);
2819 NewOp(1101, rcop, 1, LOGOP);
2820 rcop->op_type = OP_REGCOMP;
2821 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2822 rcop->op_first = scalar(expr);
2823 rcop->op_flags |= OPf_KIDS
2824 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
2825 | (reglist ? OPf_STACKED : 0);
2826 rcop->op_private = 1;
2829 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
2831 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
2834 /* establish postfix order */
2835 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2837 rcop->op_next = expr;
2838 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2841 rcop->op_next = LINKLIST(expr);
2842 expr->op_next = (OP*)rcop;
2845 prepend_elem(o->op_type, scalar((OP*)rcop), o);
2850 if (pm->op_pmflags & PMf_EVAL) {
2852 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
2853 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
2855 else if (repl->op_type == OP_CONST)
2859 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
2860 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
2861 if (curop->op_type == OP_GV) {
2862 GV *gv = cGVOPx_gv(curop);
2864 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
2867 else if (curop->op_type == OP_RV2CV)
2869 else if (curop->op_type == OP_RV2SV ||
2870 curop->op_type == OP_RV2AV ||
2871 curop->op_type == OP_RV2HV ||
2872 curop->op_type == OP_RV2GV) {
2873 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2876 else if (curop->op_type == OP_PADSV ||
2877 curop->op_type == OP_PADAV ||
2878 curop->op_type == OP_PADHV ||
2879 curop->op_type == OP_PADANY) {
2882 else if (curop->op_type == OP_PUSHRE)
2883 ; /* Okay here, dangerous in newASSIGNOP */
2893 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
2894 pm->op_pmflags |= PMf_CONST; /* const for long enough */
2895 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
2896 prepend_elem(o->op_type, scalar(repl), o);
2899 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
2900 pm->op_pmflags |= PMf_MAYBE_CONST;
2901 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2903 NewOp(1101, rcop, 1, LOGOP);
2904 rcop->op_type = OP_SUBSTCONT;
2905 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
2906 rcop->op_first = scalar(repl);
2907 rcop->op_flags |= OPf_KIDS;
2908 rcop->op_private = 1;
2911 /* establish postfix order */
2912 rcop->op_next = LINKLIST(repl);
2913 repl->op_next = (OP*)rcop;
2915 pm->op_pmreplroot = scalar((OP*)rcop);
2916 pm->op_pmreplstart = LINKLIST(rcop);
2925 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
2929 NewOp(1101, svop, 1, SVOP);
2930 svop->op_type = (OPCODE)type;
2931 svop->op_ppaddr = PL_ppaddr[type];
2933 svop->op_next = (OP*)svop;
2934 svop->op_flags = (U8)flags;
2935 if (PL_opargs[type] & OA_RETSCALAR)
2937 if (PL_opargs[type] & OA_TARGET)
2938 svop->op_targ = pad_alloc(type, SVs_PADTMP);
2939 return CHECKOP(type, svop);
2943 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2947 NewOp(1101, padop, 1, PADOP);
2948 padop->op_type = (OPCODE)type;
2949 padop->op_ppaddr = PL_ppaddr[type];
2950 padop->op_padix = pad_alloc(type, SVs_PADTMP);
2951 SvREFCNT_dec(PAD_SVl(padop->op_padix));
2952 PAD_SETSV(padop->op_padix, sv);
2955 padop->op_next = (OP*)padop;
2956 padop->op_flags = (U8)flags;
2957 if (PL_opargs[type] & OA_RETSCALAR)
2959 if (PL_opargs[type] & OA_TARGET)
2960 padop->op_targ = pad_alloc(type, SVs_PADTMP);
2961 return CHECKOP(type, padop);
2965 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
2971 return newPADOP(type, flags, SvREFCNT_inc(gv));
2973 return newSVOP(type, flags, SvREFCNT_inc(gv));
2978 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
2982 NewOp(1101, pvop, 1, PVOP);
2983 pvop->op_type = (OPCODE)type;
2984 pvop->op_ppaddr = PL_ppaddr[type];
2986 pvop->op_next = (OP*)pvop;
2987 pvop->op_flags = (U8)flags;
2988 if (PL_opargs[type] & OA_RETSCALAR)
2990 if (PL_opargs[type] & OA_TARGET)
2991 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
2992 return CHECKOP(type, pvop);
2996 Perl_package(pTHX_ OP *o)
3001 save_hptr(&PL_curstash);
3002 save_item(PL_curstname);
3004 name = SvPV(cSVOPo->op_sv, len);
3005 PL_curstash = gv_stashpvn(name, len, TRUE);
3006 sv_setpvn(PL_curstname, name, len);
3009 PL_hints |= HINT_BLOCK_SCOPE;
3010 PL_copline = NOLINE;
3015 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3021 if (idop->op_type != OP_CONST)
3022 Perl_croak(aTHX_ "Module name must be constant");
3026 if (version != Nullop) {
3027 SV *vesv = ((SVOP*)version)->op_sv;
3029 if (arg == Nullop && !SvNIOKp(vesv)) {
3036 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3037 Perl_croak(aTHX_ "Version number must be constant number");
3039 /* Make copy of idop so we don't free it twice */
3040 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3042 /* Fake up a method call to VERSION */
3043 meth = newSVpvn("VERSION",7);
3044 sv_upgrade(meth, SVt_PVIV);
3045 (void)SvIOK_on(meth);
3048 PERL_HASH(hash, SvPVX_const(meth), SvCUR(meth));
3049 SvUV_set(meth, hash);
3051 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3052 append_elem(OP_LIST,
3053 prepend_elem(OP_LIST, pack, list(version)),
3054 newSVOP(OP_METHOD_NAMED, 0, meth)));
3058 /* Fake up an import/unimport */
3059 if (arg && arg->op_type == OP_STUB)
3060 imop = arg; /* no import on explicit () */
3061 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3062 imop = Nullop; /* use 5.0; */
3067 /* Make copy of idop so we don't free it twice */
3068 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3070 /* Fake up a method call to import/unimport */
3071 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);
3072 (void)SvUPGRADE(meth, SVt_PVIV);
3073 (void)SvIOK_on(meth);
3076 PERL_HASH(hash, SvPVX_const(meth), SvCUR(meth));
3077 SvUV_set(meth, hash);
3079 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3080 append_elem(OP_LIST,
3081 prepend_elem(OP_LIST, pack, list(arg)),
3082 newSVOP(OP_METHOD_NAMED, 0, meth)));
3085 /* Fake up the BEGIN {}, which does its thing immediately. */
3087 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3090 append_elem(OP_LINESEQ,
3091 append_elem(OP_LINESEQ,
3092 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, idop)),
3093 newSTATEOP(0, Nullch, veop)),
3094 newSTATEOP(0, Nullch, imop) ));
3096 /* The "did you use incorrect case?" warning used to be here.
3097 * The problem is that on case-insensitive filesystems one
3098 * might get false positives for "use" (and "require"):
3099 * "use Strict" or "require CARP" will work. This causes
3100 * portability problems for the script: in case-strict
3101 * filesystems the script will stop working.
3103 * The "incorrect case" warning checked whether "use Foo"
3104 * imported "Foo" to your namespace, but that is wrong, too:
3105 * there is no requirement nor promise in the language that
3106 * a Foo.pm should or would contain anything in package "Foo".
3108 * There is very little Configure-wise that can be done, either:
3109 * the case-sensitivity of the build filesystem of Perl does not
3110 * help in guessing the case-sensitivity of the runtime environment.
3113 PL_hints |= HINT_BLOCK_SCOPE;
3114 PL_copline = NOLINE;
3116 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3120 =head1 Embedding Functions
3122 =for apidoc load_module
3124 Loads the module whose name is pointed to by the string part of name.
3125 Note that the actual module name, not its filename, should be given.
3126 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3127 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3128 (or 0 for no flags). ver, if specified, provides version semantics
3129 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3130 arguments can be used to specify arguments to the module's import()
3131 method, similar to C<use Foo::Bar VERSION LIST>.
3136 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3139 va_start(args, ver);
3140 vload_module(flags, name, ver, &args);
3144 #ifdef PERL_IMPLICIT_CONTEXT
3146 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3150 va_start(args, ver);
3151 vload_module(flags, name, ver, &args);
3157 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3159 OP *modname, *veop, *imop;
3161 modname = newSVOP(OP_CONST, 0, name);
3162 modname->op_private |= OPpCONST_BARE;
3164 veop = newSVOP(OP_CONST, 0, ver);
3168 if (flags & PERL_LOADMOD_NOIMPORT) {
3169 imop = sawparens(newNULLLIST());
3171 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3172 imop = va_arg(*args, OP*);
3177 sv = va_arg(*args, SV*);
3179 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3180 sv = va_arg(*args, SV*);
3184 const line_t ocopline = PL_copline;
3185 COP * const ocurcop = PL_curcop;
3186 const int oexpect = PL_expect;
3188 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3189 veop, modname, imop);
3190 PL_expect = oexpect;
3191 PL_copline = ocopline;
3192 PL_curcop = ocurcop;
3197 Perl_dofile(pTHX_ OP *term)
3202 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3203 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
3204 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3206 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3207 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3208 append_elem(OP_LIST, term,
3209 scalar(newUNOP(OP_RV2CV, 0,
3214 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3220 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3222 return newBINOP(OP_LSLICE, flags,
3223 list(force_list(subscript)),
3224 list(force_list(listval)) );
3228 S_is_list_assignment(pTHX_ register const OP *o)
3233 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3234 o = cUNOPo->op_first;
3236 if (o->op_type == OP_COND_EXPR) {
3237 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3238 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3243 yyerror("Assignment to both a list and a scalar");
3247 if (o->op_type == OP_LIST &&
3248 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3249 o->op_private & OPpLVAL_INTRO)
3252 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3253 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3254 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3257 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3260 if (o->op_type == OP_RV2SV)
3267 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3272 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3273 return newLOGOP(optype, 0,
3274 mod(scalar(left), optype),
3275 newUNOP(OP_SASSIGN, 0, scalar(right)));
3278 return newBINOP(optype, OPf_STACKED,
3279 mod(scalar(left), optype), scalar(right));
3283 if (is_list_assignment(left)) {
3287 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3288 left = mod(left, OP_AASSIGN);
3296 /* optimise C<my @x = ()> to C<my @x>, and likewise for hashes */
3297 if ((left->op_type == OP_PADAV || left->op_type == OP_PADHV)
3298 && right->op_type == OP_STUB
3299 && (left->op_private & OPpLVAL_INTRO))
3302 left->op_flags &= ~(OPf_REF|OPf_SPECIAL);
3305 curop = list(force_list(left));
3306 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3307 o->op_private = (U8)(0 | (flags >> 8));
3309 /* PL_generation sorcery:
3310 * an assignment like ($a,$b) = ($c,$d) is easier than
3311 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3312 * To detect whether there are common vars, the global var
3313 * PL_generation is incremented for each assign op we compile.
3314 * Then, while compiling the assign op, we run through all the
3315 * variables on both sides of the assignment, setting a spare slot
3316 * in each of them to PL_generation. If any of them already have
3317 * that value, we know we've got commonality. We could use a
3318 * single bit marker, but then we'd have to make 2 passes, first
3319 * to clear the flag, then to test and set it. To find somewhere
3320 * to store these values, evil chicanery is done with SvCUR().
3323 if (!(left->op_private & OPpLVAL_INTRO)) {
3326 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3327 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3328 if (curop->op_type == OP_GV) {
3329 GV *gv = cGVOPx_gv(curop);
3330 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3332 SvCUR_set(gv, PL_generation);
3334 else if (curop->op_type == OP_PADSV ||
3335 curop->op_type == OP_PADAV ||
3336 curop->op_type == OP_PADHV ||
3337 curop->op_type == OP_PADANY)
3339 if (PAD_COMPNAME_GEN(curop->op_targ)
3340 == (STRLEN)PL_generation)
3342 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
3345 else if (curop->op_type == OP_RV2CV)
3347 else if (curop->op_type == OP_RV2SV ||
3348 curop->op_type == OP_RV2AV ||
3349 curop->op_type == OP_RV2HV ||
3350 curop->op_type == OP_RV2GV) {
3351 if (lastop->op_type != OP_GV) /* funny deref? */
3354 else if (curop->op_type == OP_PUSHRE) {
3355 if (((PMOP*)curop)->op_pmreplroot) {
3357 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3358 ((PMOP*)curop)->op_pmreplroot));
3360 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3362 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3364 SvCUR_set(gv, PL_generation);
3373 o->op_private |= OPpASSIGN_COMMON;
3375 if (right && right->op_type == OP_SPLIT) {
3377 if ((tmpop = ((LISTOP*)right)->op_first) &&
3378 tmpop->op_type == OP_PUSHRE)
3380 PMOP *pm = (PMOP*)tmpop;
3381 if (left->op_type == OP_RV2AV &&
3382 !(left->op_private & OPpLVAL_INTRO) &&
3383 !(o->op_private & OPpASSIGN_COMMON) )
3385 tmpop = ((UNOP*)left)->op_first;
3386 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3388 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3389 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3391 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3392 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3394 pm->op_pmflags |= PMf_ONCE;
3395 tmpop = cUNOPo->op_first; /* to list (nulled) */
3396 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3397 tmpop->op_sibling = Nullop; /* don't free split */
3398 right->op_next = tmpop->op_next; /* fix starting loc */
3399 op_free(o); /* blow off assign */
3400 right->op_flags &= ~OPf_WANT;
3401 /* "I don't know and I don't care." */
3406 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3407 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3409 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3411 sv_setiv(sv, PL_modcount+1);
3419 right = newOP(OP_UNDEF, 0);
3420 if (right->op_type == OP_READLINE) {
3421 right->op_flags |= OPf_STACKED;
3422 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3425 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3426 o = newBINOP(OP_SASSIGN, flags,
3427 scalar(right), mod(scalar(left), OP_SASSIGN) );
3439 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3442 const U32 seq = intro_my();
3445 NewOp(1101, cop, 1, COP);
3446 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3447 cop->op_type = OP_DBSTATE;
3448 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3451 cop->op_type = OP_NEXTSTATE;
3452 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3454 cop->op_flags = (U8)flags;
3455 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3457 cop->op_private |= NATIVE_HINTS;
3459 PL_compiling.op_private = cop->op_private;
3460 cop->op_next = (OP*)cop;
3463 cop->cop_label = label;
3464 PL_hints |= HINT_BLOCK_SCOPE;
3467 cop->cop_arybase = PL_curcop->cop_arybase;
3468 if (specialWARN(PL_curcop->cop_warnings))
3469 cop->cop_warnings = PL_curcop->cop_warnings ;
3471 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3472 if (specialCopIO(PL_curcop->cop_io))
3473 cop->cop_io = PL_curcop->cop_io;
3475 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3478 if (PL_copline == NOLINE)
3479 CopLINE_set(cop, CopLINE(PL_curcop));
3481 CopLINE_set(cop, PL_copline);
3482 PL_copline = NOLINE;
3485 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3487 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3489 CopSTASH_set(cop, PL_curstash);
3491 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3492 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3493 if (svp && *svp != &PL_sv_undef ) {
3494 (void)SvIOK_on(*svp);
3495 SvIV_set(*svp, PTR2IV(cop));
3499 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3504 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3507 return new_logop(type, flags, &first, &other);
3511 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3516 OP *first = *firstp;
3517 OP *other = *otherp;
3519 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3520 return newBINOP(type, flags, scalar(first), scalar(other));
3522 scalarboolean(first);
3523 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3524 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3525 if (type == OP_AND || type == OP_OR) {
3531 first = *firstp = cUNOPo->op_first;
3533 first->op_next = o->op_next;
3534 cUNOPo->op_first = Nullop;
3538 if (first->op_type == OP_CONST) {
3539 if (first->op_private & OPpCONST_STRICT)
3540 no_bareword_allowed(first);
3541 else if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3542 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3543 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
3544 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
3545 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
3548 if (other->op_type == OP_CONST)
3549 other->op_private |= OPpCONST_SHORTCIRCUIT;
3553 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
3554 const OP *o2 = other;
3555 if ( ! (o2->op_type == OP_LIST
3556 && (( o2 = cUNOPx(o2)->op_first))
3557 && o2->op_type == OP_PUSHMARK
3558 && (( o2 = o2->op_sibling)) )
3561 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
3562 || o2->op_type == OP_PADHV)
3563 && o2->op_private & OPpLVAL_INTRO
3564 && ckWARN(WARN_DEPRECATED))
3566 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
3567 "Deprecated use of my() in false conditional");
3572 if (first->op_type == OP_CONST)
3573 first->op_private |= OPpCONST_SHORTCIRCUIT;
3577 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS) &&
3578 type != OP_DOR) /* [#24076] Don't warn for <FH> err FOO. */
3580 const OP *k1 = ((UNOP*)first)->op_first;
3581 const OP *k2 = k1->op_sibling;
3583 switch (first->op_type)
3586 if (k2 && k2->op_type == OP_READLINE
3587 && (k2->op_flags & OPf_STACKED)
3588 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3590 warnop = k2->op_type;
3595 if (k1->op_type == OP_READDIR
3596 || k1->op_type == OP_GLOB
3597 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3598 || k1->op_type == OP_EACH)
3600 warnop = ((k1->op_type == OP_NULL)
3601 ? (OPCODE)k1->op_targ : k1->op_type);
3606 const line_t oldline = CopLINE(PL_curcop);
3607 CopLINE_set(PL_curcop, PL_copline);
3608 Perl_warner(aTHX_ packWARN(WARN_MISC),
3609 "Value of %s%s can be \"0\"; test with defined()",
3611 ((warnop == OP_READLINE || warnop == OP_GLOB)
3612 ? " construct" : "() operator"));
3613 CopLINE_set(PL_curcop, oldline);
3620 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3621 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3623 NewOp(1101, logop, 1, LOGOP);
3625 logop->op_type = (OPCODE)type;
3626 logop->op_ppaddr = PL_ppaddr[type];
3627 logop->op_first = first;
3628 logop->op_flags = flags | OPf_KIDS;
3629 logop->op_other = LINKLIST(other);
3630 logop->op_private = (U8)(1 | (flags >> 8));
3632 /* establish postfix order */
3633 logop->op_next = LINKLIST(first);
3634 first->op_next = (OP*)logop;
3635 first->op_sibling = other;
3637 CHECKOP(type,logop);
3639 o = newUNOP(OP_NULL, 0, (OP*)logop);
3646 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3654 return newLOGOP(OP_AND, 0, first, trueop);
3656 return newLOGOP(OP_OR, 0, first, falseop);
3658 scalarboolean(first);
3659 if (first->op_type == OP_CONST) {
3660 if (first->op_private & OPpCONST_BARE &&
3661 first->op_private & OPpCONST_STRICT) {
3662 no_bareword_allowed(first);
3664 if (SvTRUE(((SVOP*)first)->op_sv)) {
3675 NewOp(1101, logop, 1, LOGOP);
3676 logop->op_type = OP_COND_EXPR;
3677 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3678 logop->op_first = first;
3679 logop->op_flags = flags | OPf_KIDS;
3680 logop->op_private = (U8)(1 | (flags >> 8));
3681 logop->op_other = LINKLIST(trueop);
3682 logop->op_next = LINKLIST(falseop);
3684 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
3687 /* establish postfix order */
3688 start = LINKLIST(first);
3689 first->op_next = (OP*)logop;
3691 first->op_sibling = trueop;
3692 trueop->op_sibling = falseop;
3693 o = newUNOP(OP_NULL, 0, (OP*)logop);
3695 trueop->op_next = falseop->op_next = o;
3702 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3711 NewOp(1101, range, 1, LOGOP);
3713 range->op_type = OP_RANGE;
3714 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3715 range->op_first = left;
3716 range->op_flags = OPf_KIDS;
3717 leftstart = LINKLIST(left);
3718 range->op_other = LINKLIST(right);
3719 range->op_private = (U8)(1 | (flags >> 8));
3721 left->op_sibling = right;
3723 range->op_next = (OP*)range;
3724 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3725 flop = newUNOP(OP_FLOP, 0, flip);
3726 o = newUNOP(OP_NULL, 0, flop);
3728 range->op_next = leftstart;
3730 left->op_next = flip;
3731 right->op_next = flop;
3733 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3734 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3735 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3736 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3738 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3739 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3742 if (!flip->op_private || !flop->op_private)
3743 linklist(o); /* blow off optimizer unless constant */
3749 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3753 const bool once = block && block->op_flags & OPf_SPECIAL &&
3754 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3758 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3759 return block; /* do {} while 0 does once */
3760 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3761 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3762 expr = newUNOP(OP_DEFINED, 0,
3763 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3764 } else if (expr->op_flags & OPf_KIDS) {
3765 const OP *k1 = ((UNOP*)expr)->op_first;
3766 const OP *k2 = (k1) ? k1->op_sibling : NULL;
3767 switch (expr->op_type) {
3769 if (k2 && k2->op_type == OP_READLINE
3770 && (k2->op_flags & OPf_STACKED)
3771 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3772 expr = newUNOP(OP_DEFINED, 0, expr);
3776 if (k1->op_type == OP_READDIR
3777 || k1->op_type == OP_GLOB
3778 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3779 || k1->op_type == OP_EACH)
3780 expr = newUNOP(OP_DEFINED, 0, expr);
3786 /* if block is null, the next append_elem() would put UNSTACK, a scalar
3787 * op, in listop. This is wrong. [perl #27024] */
3789 block = newOP(OP_NULL, 0);
3790 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3791 o = new_logop(OP_AND, 0, &expr, &listop);
3794 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3796 if (once && o != listop)
3797 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3800 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3802 o->op_flags |= flags;
3804 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3809 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
3810 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
3820 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3821 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3822 expr = newUNOP(OP_DEFINED, 0,
3823 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3824 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3825 const OP *k1 = ((UNOP*)expr)->op_first;
3826 const OP *k2 = (k1) ? k1->op_sibling : NULL;
3827 switch (expr->op_type) {
3829 if (k2 && k2->op_type == OP_READLINE
3830 && (k2->op_flags & OPf_STACKED)
3831 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3832 expr = newUNOP(OP_DEFINED, 0, expr);
3836 if (k1->op_type == OP_READDIR
3837 || k1->op_type == OP_GLOB
3838 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3839 || k1->op_type == OP_EACH)
3840 expr = newUNOP(OP_DEFINED, 0, expr);
3846 block = newOP(OP_NULL, 0);
3847 else if (cont || has_my) {
3848 block = scope(block);
3852 next = LINKLIST(cont);
3855 OP *unstack = newOP(OP_UNSTACK, 0);
3858 cont = append_elem(OP_LINESEQ, cont, unstack);
3861 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3862 redo = LINKLIST(listop);
3865 PL_copline = (line_t)whileline;
3867 o = new_logop(OP_AND, 0, &expr, &listop);
3868 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3869 op_free(expr); /* oops, it's a while (0) */
3871 return Nullop; /* listop already freed by new_logop */
3874 ((LISTOP*)listop)->op_last->op_next =
3875 (o == listop ? redo : LINKLIST(o));
3881 NewOp(1101,loop,1,LOOP);
3882 loop->op_type = OP_ENTERLOOP;
3883 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3884 loop->op_private = 0;
3885 loop->op_next = (OP*)loop;
3888 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3890 loop->op_redoop = redo;
3891 loop->op_lastop = o;
3892 o->op_private |= loopflags;
3895 loop->op_nextop = next;
3897 loop->op_nextop = o;
3899 o->op_flags |= flags;
3900 o->op_private |= (flags >> 8);
3905 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
3910 PADOFFSET padoff = 0;
3915 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
3916 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
3917 sv->op_type = OP_RV2GV;
3918 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3920 else if (sv->op_type == OP_PADSV) { /* private variable */
3921 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
3922 padoff = sv->op_targ;
3927 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3928 padoff = sv->op_targ;
3930 iterflags |= OPf_SPECIAL;
3935 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3938 const I32 offset = pad_findmy("$_");
3939 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
3940 sv = newGVOP(OP_GV, 0, PL_defgv);
3946 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3947 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3948 iterflags |= OPf_STACKED;
3950 else if (expr->op_type == OP_NULL &&
3951 (expr->op_flags & OPf_KIDS) &&
3952 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3954 /* Basically turn for($x..$y) into the same as for($x,$y), but we
3955 * set the STACKED flag to indicate that these values are to be
3956 * treated as min/max values by 'pp_iterinit'.
3958 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
3959 LOGOP* range = (LOGOP*) flip->op_first;
3960 OP* left = range->op_first;
3961 OP* right = left->op_sibling;
3964 range->op_flags &= ~OPf_KIDS;
3965 range->op_first = Nullop;
3967 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
3968 listop->op_first->op_next = range->op_next;
3969 left->op_next = range->op_other;
3970 right->op_next = (OP*)listop;
3971 listop->op_next = listop->op_first;
3974 expr = (OP*)(listop);
3976 iterflags |= OPf_STACKED;
3979 expr = mod(force_list(expr), OP_GREPSTART);
3982 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
3983 append_elem(OP_LIST, expr, scalar(sv))));
3984 assert(!loop->op_next);
3985 /* for my $x () sets OPpLVAL_INTRO;
3986 * for our $x () sets OPpOUR_INTRO */
3987 loop->op_private = (U8)iterpflags;
3988 #ifdef PL_OP_SLAB_ALLOC
3991 NewOp(1234,tmp,1,LOOP);
3992 Copy(loop,tmp,1,LISTOP);
3997 Renew(loop, 1, LOOP);
3999 loop->op_targ = padoff;
4000 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4001 PL_copline = forline;
4002 return newSTATEOP(0, label, wop);
4006 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4011 if (type != OP_GOTO || label->op_type == OP_CONST) {
4012 /* "last()" means "last" */
4013 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4014 o = newOP(type, OPf_SPECIAL);
4016 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4017 ? SvPVx(((SVOP*)label)->op_sv, n_a)
4023 /* Check whether it's going to be a goto &function */
4024 if (label->op_type == OP_ENTERSUB
4025 && !(label->op_flags & OPf_STACKED))
4026 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4027 o = newUNOP(type, OPf_STACKED, label);
4029 PL_hints |= HINT_BLOCK_SCOPE;
4034 =for apidoc cv_undef
4036 Clear out all the active components of a CV. This can happen either
4037 by an explicit C<undef &foo>, or by the reference count going to zero.
4038 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4039 children can still follow the full lexical scope chain.
4045 Perl_cv_undef(pTHX_ CV *cv)
4049 if (CvFILE(cv) && !CvXSUB(cv)) {
4050 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4051 Safefree(CvFILE(cv));
4056 if (!CvXSUB(cv) && CvROOT(cv)) {
4058 Perl_croak(aTHX_ "Can't undef active subroutine");
4061 PAD_SAVE_SETNULLPAD();
4063 op_free(CvROOT(cv));
4064 CvROOT(cv) = Nullop;
4067 SvPOK_off((SV*)cv); /* forget prototype */
4072 /* remove CvOUTSIDE unless this is an undef rather than a free */
4073 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4074 if (!CvWEAKOUTSIDE(cv))
4075 SvREFCNT_dec(CvOUTSIDE(cv));
4076 CvOUTSIDE(cv) = Nullcv;
4079 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4085 /* delete all flags except WEAKOUTSIDE */
4086 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4090 Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p)
4092 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX_const(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4093 SV* msg = sv_newmortal();
4097 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4098 sv_setpv(msg, "Prototype mismatch:");
4100 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4102 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (const SV *)cv);
4104 Perl_sv_catpv(aTHX_ msg, ": none");
4105 sv_catpv(msg, " vs ");
4107 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4109 sv_catpv(msg, "none");
4110 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
4114 static void const_sv_xsub(pTHX_ CV* cv);
4118 =head1 Optree Manipulation Functions
4120 =for apidoc cv_const_sv
4122 If C<cv> is a constant sub eligible for inlining. returns the constant
4123 value returned by the sub. Otherwise, returns NULL.
4125 Constant subs can be created with C<newCONSTSUB> or as described in
4126 L<perlsub/"Constant Functions">.
4131 Perl_cv_const_sv(pTHX_ CV *cv)
4133 if (!cv || !CvCONST(cv))
4135 return (SV*)CvXSUBANY(cv).any_ptr;
4138 /* op_const_sv: examine an optree to determine whether it's in-lineable.
4139 * Can be called in 3 ways:
4142 * look for a single OP_CONST with attached value: return the value
4144 * cv && CvCLONE(cv) && !CvCONST(cv)
4146 * examine the clone prototype, and if contains only a single
4147 * OP_CONST referencing a pad const, or a single PADSV referencing
4148 * an outer lexical, return a non-zero value to indicate the CV is
4149 * a candidate for "constizing" at clone time
4153 * We have just cloned an anon prototype that was marked as a const
4154 * candidiate. Try to grab the current value, and in the case of
4155 * PADSV, ignore it if it has multiple references. Return the value.
4159 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
4166 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4167 o = cLISTOPo->op_first->op_sibling;
4169 for (; o; o = o->op_next) {
4170 OPCODE type = o->op_type;
4172 if (sv && o->op_next == o)
4174 if (o->op_next != o) {
4175 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4177 if (type == OP_DBSTATE)
4180 if (type == OP_LEAVESUB || type == OP_RETURN)
4184 if (type == OP_CONST && cSVOPo->op_sv)
4186 else if (cv && type == OP_CONST) {
4187 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4191 else if (cv && type == OP_PADSV) {
4192 if (CvCONST(cv)) { /* newly cloned anon */
4193 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4194 /* the candidate should have 1 ref from this pad and 1 ref
4195 * from the parent */
4196 if (!sv || SvREFCNT(sv) != 2)
4203 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4204 sv = &PL_sv_undef; /* an arbitrary non-null value */
4215 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4226 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4230 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4232 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4236 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4247 const char * const name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4250 assert(proto->op_type == OP_CONST);
4251 ps = SvPVx(((SVOP*)proto)->op_sv, ps_len);
4256 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4257 SV *sv = sv_newmortal();
4258 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4259 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4260 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4261 aname = SvPVX_const(sv);
4265 gv = name ? gv_fetchsv(cSVOPo->op_sv,
4266 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4268 : gv_fetchpv(aname ? aname
4269 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4270 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4280 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4281 maximum a prototype before. */
4282 if (SvTYPE(gv) > SVt_NULL) {
4283 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4284 && ckWARN_d(WARN_PROTOTYPE))
4286 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4288 cv_ckproto((CV*)gv, NULL, ps);
4291 sv_setpvn((SV*)gv, ps, ps_len);
4293 sv_setiv((SV*)gv, -1);
4294 SvREFCNT_dec(PL_compcv);
4295 cv = PL_compcv = NULL;
4296 PL_sub_generation++;
4300 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4302 #ifdef GV_UNIQUE_CHECK
4303 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4304 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4308 if (!block || !ps || *ps || attrs)
4311 const_sv = op_const_sv(block, Nullcv);
4314 const bool exists = CvROOT(cv) || CvXSUB(cv);
4316 #ifdef GV_UNIQUE_CHECK
4317 if (exists && GvUNIQUE(gv)) {
4318 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4322 /* if the subroutine doesn't exist and wasn't pre-declared
4323 * with a prototype, assume it will be AUTOLOADed,
4324 * skipping the prototype check
4326 if (exists || SvPOK(cv))
4327 cv_ckproto(cv, gv, ps);
4328 /* already defined (or promised)? */
4329 if (exists || GvASSUMECV(gv)) {
4330 if (!block && !attrs) {
4331 if (CvFLAGS(PL_compcv)) {
4332 /* might have had built-in attrs applied */
4333 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4335 /* just a "sub foo;" when &foo is already defined */
4336 SAVEFREESV(PL_compcv);
4339 /* ahem, death to those who redefine active sort subs */
4340 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4341 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4343 if (ckWARN(WARN_REDEFINE)
4345 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4347 const line_t oldline = CopLINE(PL_curcop);
4348 if (PL_copline != NOLINE)
4349 CopLINE_set(PL_curcop, PL_copline);
4350 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4351 CvCONST(cv) ? "Constant subroutine %s redefined"
4352 : "Subroutine %s redefined", name);
4353 CopLINE_set(PL_curcop, oldline);
4361 (void)SvREFCNT_inc(const_sv);
4363 assert(!CvROOT(cv) && !CvCONST(cv));
4364 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
4365 CvXSUBANY(cv).any_ptr = const_sv;
4366 CvXSUB(cv) = const_sv_xsub;
4371 cv = newCONSTSUB(NULL, name, const_sv);
4374 SvREFCNT_dec(PL_compcv);
4376 PL_sub_generation++;
4383 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4384 * before we clobber PL_compcv.
4388 /* Might have had built-in attributes applied -- propagate them. */
4389 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4390 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4391 stash = GvSTASH(CvGV(cv));
4392 else if (CvSTASH(cv))
4393 stash = CvSTASH(cv);
4395 stash = PL_curstash;
4398 /* possibly about to re-define existing subr -- ignore old cv */
4399 rcv = (SV*)PL_compcv;
4400 if (name && GvSTASH(gv))
4401 stash = GvSTASH(gv);
4403 stash = PL_curstash;
4405 apply_attrs(stash, rcv, attrs, FALSE);
4407 if (cv) { /* must reuse cv if autoloaded */
4409 /* got here with just attrs -- work done, so bug out */
4410 SAVEFREESV(PL_compcv);
4413 /* transfer PL_compcv to cv */
4415 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4416 if (!CvWEAKOUTSIDE(cv))
4417 SvREFCNT_dec(CvOUTSIDE(cv));
4418 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4419 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4420 CvOUTSIDE(PL_compcv) = 0;
4421 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4422 CvPADLIST(PL_compcv) = 0;
4423 /* inner references to PL_compcv must be fixed up ... */
4424 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4425 /* ... before we throw it away */
4426 SvREFCNT_dec(PL_compcv);
4428 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4429 ++PL_sub_generation;
4436 PL_sub_generation++;
4440 CvFILE_set_from_cop(cv, PL_curcop);
4441 CvSTASH(cv) = PL_curstash;
4444 sv_setpvn((SV*)cv, ps, ps_len);
4446 if (PL_error_count) {
4450 const char *s = strrchr(name, ':');
4452 if (strEQ(s, "BEGIN")) {
4453 const char not_safe[] =
4454 "BEGIN not safe after errors--compilation aborted";
4455 if (PL_in_eval & EVAL_KEEPERR)
4456 Perl_croak(aTHX_ not_safe);
4458 /* force display of errors found but not reported */
4459 sv_catpv(ERRSV, not_safe);
4460 Perl_croak(aTHX_ "%"SVf, ERRSV);
4469 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4470 mod(scalarseq(block), OP_LEAVESUBLV));
4473 /* This makes sub {}; work as expected. */
4474 if (block->op_type == OP_STUB) {
4476 block = newSTATEOP(0, Nullch, 0);
4478 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4480 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4481 OpREFCNT_set(CvROOT(cv), 1);
4482 CvSTART(cv) = LINKLIST(CvROOT(cv));
4483 CvROOT(cv)->op_next = 0;
4484 CALL_PEEP(CvSTART(cv));
4486 /* now that optimizer has done its work, adjust pad values */
4488 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4491 assert(!CvCONST(cv));
4492 if (ps && !*ps && op_const_sv(block, cv))
4496 if (name || aname) {
4498 const char *tname = (name ? name : aname);
4500 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4501 SV *sv = NEWSV(0,0);
4502 SV *tmpstr = sv_newmortal();
4503 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4507 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4509 (long)PL_subline, (long)CopLINE(PL_curcop));
4510 gv_efullname3(tmpstr, gv, Nullch);
4511 hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
4512 hv = GvHVn(db_postponed);
4513 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))
4514 && (pcv = GvCV(db_postponed)))
4520 call_sv((SV*)pcv, G_DISCARD);
4524 if ((s = strrchr(tname,':')))
4529 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4532 if (strEQ(s, "BEGIN") && !PL_error_count) {
4533 const I32 oldscope = PL_scopestack_ix;
4535 SAVECOPFILE(&PL_compiling);
4536 SAVECOPLINE(&PL_compiling);
4539 PL_beginav = newAV();
4540 DEBUG_x( dump_sub(gv) );
4541 av_push(PL_beginav, (SV*)cv);
4542 GvCV(gv) = 0; /* cv has been hijacked */
4543 call_list(oldscope, PL_beginav);
4545 PL_curcop = &PL_compiling;
4546 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4549 else if (strEQ(s, "END") && !PL_error_count) {
4552 DEBUG_x( dump_sub(gv) );
4553 av_unshift(PL_endav, 1);
4554 av_store(PL_endav, 0, (SV*)cv);
4555 GvCV(gv) = 0; /* cv has been hijacked */
4557 else if (strEQ(s, "CHECK") && !PL_error_count) {
4559 PL_checkav = newAV();
4560 DEBUG_x( dump_sub(gv) );
4561 if (PL_main_start && ckWARN(WARN_VOID))
4562 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4563 av_unshift(PL_checkav, 1);
4564 av_store(PL_checkav, 0, (SV*)cv);
4565 GvCV(gv) = 0; /* cv has been hijacked */
4567 else if (strEQ(s, "INIT") && !PL_error_count) {
4569 PL_initav = newAV();
4570 DEBUG_x( dump_sub(gv) );
4571 if (PL_main_start && ckWARN(WARN_VOID))
4572 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4573 av_push(PL_initav, (SV*)cv);
4574 GvCV(gv) = 0; /* cv has been hijacked */
4579 PL_copline = NOLINE;
4584 /* XXX unsafe for threads if eval_owner isn't held */
4586 =for apidoc newCONSTSUB
4588 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4589 eligible for inlining at compile-time.
4595 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
4602 SAVECOPLINE(PL_curcop);
4603 CopLINE_set(PL_curcop, PL_copline);
4606 PL_hints &= ~HINT_BLOCK_SCOPE;
4609 SAVESPTR(PL_curstash);
4610 SAVECOPSTASH(PL_curcop);
4611 PL_curstash = stash;
4612 CopSTASH_set(PL_curcop,stash);
4615 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4616 CvXSUBANY(cv).any_ptr = sv;
4618 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
4621 CopSTASH_free(PL_curcop);
4629 =for apidoc U||newXS
4631 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4637 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
4639 GV *gv = gv_fetchpv(name ? name :
4640 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4641 GV_ADDMULTI, SVt_PVCV);
4645 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4647 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4649 /* just a cached method */
4653 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4654 /* already defined (or promised) */
4655 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4656 && strEQ(HvNAME_get(GvSTASH(CvGV(cv))), "autouse"))) {
4657 const line_t oldline = CopLINE(PL_curcop);
4658 if (PL_copline != NOLINE)
4659 CopLINE_set(PL_curcop, PL_copline);
4660 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4661 CvCONST(cv) ? "Constant subroutine %s redefined"
4662 : "Subroutine %s redefined"
4664 CopLINE_set(PL_curcop, oldline);
4671 if (cv) /* must reuse cv if autoloaded */
4674 cv = (CV*)NEWSV(1105,0);
4675 sv_upgrade((SV *)cv, SVt_PVCV);
4679 PL_sub_generation++;
4683 (void)gv_fetchfile(filename);
4684 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
4685 an external constant string */
4686 CvXSUB(cv) = subaddr;
4689 const char *s = strrchr(name,':');
4695 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4698 if (strEQ(s, "BEGIN")) {
4700 PL_beginav = newAV();
4701 av_push(PL_beginav, (SV*)cv);
4702 GvCV(gv) = 0; /* cv has been hijacked */
4704 else if (strEQ(s, "END")) {
4707 av_unshift(PL_endav, 1);
4708 av_store(PL_endav, 0, (SV*)cv);
4709 GvCV(gv) = 0; /* cv has been hijacked */
4711 else if (strEQ(s, "CHECK")) {
4713 PL_checkav = newAV();
4714 if (PL_main_start && ckWARN(WARN_VOID))
4715 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4716 av_unshift(PL_checkav, 1);
4717 av_store(PL_checkav, 0, (SV*)cv);
4718 GvCV(gv) = 0; /* cv has been hijacked */
4720 else if (strEQ(s, "INIT")) {
4722 PL_initav = newAV();
4723 if (PL_main_start && ckWARN(WARN_VOID))
4724 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4725 av_push(PL_initav, (SV*)cv);
4726 GvCV(gv) = 0; /* cv has been hijacked */
4737 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4743 gv = gv_fetchsv(cSVOPo->op_sv, TRUE, SVt_PVFM);
4745 gv = gv_fetchpv("STDOUT", TRUE, SVt_PVFM);
4747 #ifdef GV_UNIQUE_CHECK
4749 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4753 if ((cv = GvFORM(gv))) {
4754 if (ckWARN(WARN_REDEFINE)) {
4755 const line_t oldline = CopLINE(PL_curcop);
4756 if (PL_copline != NOLINE)
4757 CopLINE_set(PL_curcop, PL_copline);
4758 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4759 o ? "Format %"SVf" redefined"
4760 : "Format STDOUT redefined" ,cSVOPo->op_sv);
4761 CopLINE_set(PL_curcop, oldline);
4768 CvFILE_set_from_cop(cv, PL_curcop);
4771 pad_tidy(padtidy_FORMAT);
4772 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4773 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4774 OpREFCNT_set(CvROOT(cv), 1);
4775 CvSTART(cv) = LINKLIST(CvROOT(cv));
4776 CvROOT(cv)->op_next = 0;
4777 CALL_PEEP(CvSTART(cv));
4779 PL_copline = NOLINE;
4784 Perl_newANONLIST(pTHX_ OP *o)
4786 return newUNOP(OP_REFGEN, 0,
4787 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4791 Perl_newANONHASH(pTHX_ OP *o)
4793 return newUNOP(OP_REFGEN, 0,
4794 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4798 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4800 return newANONATTRSUB(floor, proto, Nullop, block);
4804 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4806 return newUNOP(OP_REFGEN, 0,
4807 newSVOP(OP_ANONCODE, 0,
4808 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
4812 Perl_oopsAV(pTHX_ OP *o)
4815 switch (o->op_type) {
4817 o->op_type = OP_PADAV;
4818 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4819 return ref(o, OP_RV2AV);
4822 o->op_type = OP_RV2AV;
4823 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4828 if (ckWARN_d(WARN_INTERNAL))
4829 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
4836 Perl_oopsHV(pTHX_ OP *o)
4839 switch (o->op_type) {
4842 o->op_type = OP_PADHV;
4843 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4844 return ref(o, OP_RV2HV);
4848 o->op_type = OP_RV2HV;
4849 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
4854 if (ckWARN_d(WARN_INTERNAL))
4855 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
4862 Perl_newAVREF(pTHX_ OP *o)
4865 if (o->op_type == OP_PADANY) {
4866 o->op_type = OP_PADAV;
4867 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4870 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
4871 && ckWARN(WARN_DEPRECATED)) {
4872 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4873 "Using an array as a reference is deprecated");
4875 return newUNOP(OP_RV2AV, 0, scalar(o));
4879 Perl_newGVREF(pTHX_ I32 type, OP *o)
4881 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
4882 return newUNOP(OP_NULL, 0, o);
4883 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
4887 Perl_newHVREF(pTHX_ OP *o)
4890 if (o->op_type == OP_PADANY) {
4891 o->op_type = OP_PADHV;
4892 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4895 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
4896 && ckWARN(WARN_DEPRECATED)) {
4897 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4898 "Using a hash as a reference is deprecated");
4900 return newUNOP(OP_RV2HV, 0, scalar(o));
4904 Perl_oopsCV(pTHX_ OP *o)
4906 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
4909 NORETURN_FUNCTION_END;
4913 Perl_newCVREF(pTHX_ I32 flags, OP *o)
4915 return newUNOP(OP_RV2CV, flags, scalar(o));
4919 Perl_newSVREF(pTHX_ OP *o)
4922 if (o->op_type == OP_PADANY) {
4923 o->op_type = OP_PADSV;
4924 o->op_ppaddr = PL_ppaddr[OP_PADSV];
4927 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4928 o->op_flags |= OPpDONE_SVREF;
4931 return newUNOP(OP_RV2SV, 0, scalar(o));
4934 /* Check routines. See the comments at the top of this file for details
4935 * on when these are called */
4938 Perl_ck_anoncode(pTHX_ OP *o)
4940 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
4941 cSVOPo->op_sv = Nullsv;
4946 Perl_ck_bitop(pTHX_ OP *o)
4948 #define OP_IS_NUMCOMPARE(op) \
4949 ((op) == OP_LT || (op) == OP_I_LT || \
4950 (op) == OP_GT || (op) == OP_I_GT || \
4951 (op) == OP_LE || (op) == OP_I_LE || \
4952 (op) == OP_GE || (op) == OP_I_GE || \
4953 (op) == OP_EQ || (op) == OP_I_EQ || \
4954 (op) == OP_NE || (op) == OP_I_NE || \
4955 (op) == OP_NCMP || (op) == OP_I_NCMP)
4956 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4957 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
4958 && (o->op_type == OP_BIT_OR
4959 || o->op_type == OP_BIT_AND
4960 || o->op_type == OP_BIT_XOR))
4962 const OP * left = cBINOPo->op_first;
4963 const OP * right = left->op_sibling;
4964 if ((OP_IS_NUMCOMPARE(left->op_type) &&
4965 (left->op_flags & OPf_PARENS) == 0) ||
4966 (OP_IS_NUMCOMPARE(right->op_type) &&
4967 (right->op_flags & OPf_PARENS) == 0))
4968 if (ckWARN(WARN_PRECEDENCE))
4969 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4970 "Possible precedence problem on bitwise %c operator",
4971 o->op_type == OP_BIT_OR ? '|'
4972 : o->op_type == OP_BIT_AND ? '&' : '^'
4979 Perl_ck_concat(pTHX_ OP *o)
4981 const OP *kid = cUNOPo->op_first;
4982 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
4983 !(kUNOP->op_first->op_flags & OPf_MOD))
4984 o->op_flags |= OPf_STACKED;
4989 Perl_ck_spair(pTHX_ OP *o)
4992 if (o->op_flags & OPf_KIDS) {
4995 const OPCODE type = o->op_type;
4996 o = modkids(ck_fun(o), type);
4997 kid = cUNOPo->op_first;
4998 newop = kUNOP->op_first->op_sibling;
5000 (newop->op_sibling ||
5001 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5002 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5003 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5007 op_free(kUNOP->op_first);
5008 kUNOP->op_first = newop;
5010 o->op_ppaddr = PL_ppaddr[++o->op_type];
5015 Perl_ck_delete(pTHX_ OP *o)
5019 if (o->op_flags & OPf_KIDS) {
5020 OP *kid = cUNOPo->op_first;
5021 switch (kid->op_type) {
5023 o->op_flags |= OPf_SPECIAL;
5026 o->op_private |= OPpSLICE;
5029 o->op_flags |= OPf_SPECIAL;
5034 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5043 Perl_ck_die(pTHX_ OP *o)
5046 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5052 Perl_ck_eof(pTHX_ OP *o)
5054 const I32 type = o->op_type;
5056 if (o->op_flags & OPf_KIDS) {
5057 if (cLISTOPo->op_first->op_type == OP_STUB) {
5059 o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
5067 Perl_ck_eval(pTHX_ OP *o)
5070 PL_hints |= HINT_BLOCK_SCOPE;
5071 if (o->op_flags & OPf_KIDS) {
5072 SVOP *kid = (SVOP*)cUNOPo->op_first;
5075 o->op_flags &= ~OPf_KIDS;
5078 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
5081 cUNOPo->op_first = 0;
5084 NewOp(1101, enter, 1, LOGOP);
5085 enter->op_type = OP_ENTERTRY;
5086 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5087 enter->op_private = 0;
5089 /* establish postfix order */
5090 enter->op_next = (OP*)enter;
5092 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5093 o->op_type = OP_LEAVETRY;
5094 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5095 enter->op_other = o;
5105 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5107 o->op_targ = (PADOFFSET)PL_hints;
5112 Perl_ck_exit(pTHX_ OP *o)
5115 HV *table = GvHV(PL_hintgv);
5117 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5118 if (svp && *svp && SvTRUE(*svp))
5119 o->op_private |= OPpEXIT_VMSISH;
5121 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5127 Perl_ck_exec(pTHX_ OP *o)
5129 if (o->op_flags & OPf_STACKED) {
5132 kid = cUNOPo->op_first->op_sibling;
5133 if (kid->op_type == OP_RV2GV)
5142 Perl_ck_exists(pTHX_ OP *o)
5145 if (o->op_flags & OPf_KIDS) {
5146 OP *kid = cUNOPo->op_first;
5147 if (kid->op_type == OP_ENTERSUB) {
5148 (void) ref(kid, o->op_type);
5149 if (kid->op_type != OP_RV2CV && !PL_error_count)
5150 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5152 o->op_private |= OPpEXISTS_SUB;
5154 else if (kid->op_type == OP_AELEM)
5155 o->op_flags |= OPf_SPECIAL;
5156 else if (kid->op_type != OP_HELEM)
5157 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5165 Perl_ck_rvconst(pTHX_ register OP *o)
5168 SVOP *kid = (SVOP*)cUNOPo->op_first;
5170 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5171 if (kid->op_type == OP_CONST) {
5174 SV * const kidsv = kid->op_sv;
5176 /* Is it a constant from cv_const_sv()? */
5177 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5178 SV *rsv = SvRV(kidsv);
5179 const int svtype = SvTYPE(rsv);
5180 const char *badtype = Nullch;
5182 switch (o->op_type) {
5184 if (svtype > SVt_PVMG)
5185 badtype = "a SCALAR";
5188 if (svtype != SVt_PVAV)
5189 badtype = "an ARRAY";
5192 if (svtype != SVt_PVHV)
5196 if (svtype != SVt_PVCV)
5201 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5204 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5205 const char *badthing = Nullch;
5206 switch (o->op_type) {
5208 badthing = "a SCALAR";
5211 badthing = "an ARRAY";
5214 badthing = "a HASH";
5219 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
5223 * This is a little tricky. We only want to add the symbol if we
5224 * didn't add it in the lexer. Otherwise we get duplicate strict
5225 * warnings. But if we didn't add it in the lexer, we must at
5226 * least pretend like we wanted to add it even if it existed before,
5227 * or we get possible typo warnings. OPpCONST_ENTERED says
5228 * whether the lexer already added THIS instance of this symbol.
5230 iscv = (o->op_type == OP_RV2CV) * 2;
5232 gv = gv_fetchsv(kidsv,
5233 iscv | !(kid->op_private & OPpCONST_ENTERED),
5236 : o->op_type == OP_RV2SV
5238 : o->op_type == OP_RV2AV
5240 : o->op_type == OP_RV2HV
5243 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5245 kid->op_type = OP_GV;
5246 SvREFCNT_dec(kid->op_sv);
5248 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5249 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5250 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
5252 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
5254 kid->op_sv = SvREFCNT_inc(gv);
5256 kid->op_private = 0;
5257 kid->op_ppaddr = PL_ppaddr[OP_GV];
5264 Perl_ck_ftst(pTHX_ OP *o)
5267 const I32 type = o->op_type;
5269 if (o->op_flags & OPf_REF) {
5272 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5273 SVOP *kid = (SVOP*)cUNOPo->op_first;
5275 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5276 OP *newop = newGVOP(type, OPf_REF,
5277 gv_fetchsv(kid->op_sv, TRUE, SVt_PVIO));
5283 if ((PL_hints & HINT_FILETEST_ACCESS) &&
5284 OP_IS_FILETEST_ACCESS(o))
5285 o->op_private |= OPpFT_ACCESS;
5287 if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
5288 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
5289 o->op_private |= OPpFT_STACKED;
5293 if (type == OP_FTTTY)
5294 o = newGVOP(type, OPf_REF, PL_stdingv);
5296 o = newUNOP(type, 0, newDEFSVOP());
5302 Perl_ck_fun(pTHX_ OP *o)
5304 const int type = o->op_type;
5305 register I32 oa = PL_opargs[type] >> OASHIFT;
5307 if (o->op_flags & OPf_STACKED) {
5308 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5311 return no_fh_allowed(o);
5314 if (o->op_flags & OPf_KIDS) {
5315 OP **tokid = &cLISTOPo->op_first;
5316 register OP *kid = cLISTOPo->op_first;
5320 if (kid->op_type == OP_PUSHMARK ||
5321 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5323 tokid = &kid->op_sibling;
5324 kid = kid->op_sibling;
5326 if (!kid && PL_opargs[type] & OA_DEFGV)
5327 *tokid = kid = newDEFSVOP();
5331 sibl = kid->op_sibling;
5334 /* list seen where single (scalar) arg expected? */
5335 if (numargs == 1 && !(oa >> 4)
5336 && kid->op_type == OP_LIST && type != OP_SCALAR)
5338 return too_many_arguments(o,PL_op_desc[type]);
5351 if ((type == OP_PUSH || type == OP_UNSHIFT)
5352 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5353 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5354 "Useless use of %s with no values",
5357 if (kid->op_type == OP_CONST &&
5358 (kid->op_private & OPpCONST_BARE))
5360 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5361 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVAV) ));
5362 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5363 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5364 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
5365 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5368 kid->op_sibling = sibl;
5371 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5372 bad_type(numargs, "array", PL_op_desc[type], kid);
5376 if (kid->op_type == OP_CONST &&
5377 (kid->op_private & OPpCONST_BARE))
5379 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5380 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVHV) ));
5381 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5382 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5383 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
5384 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5387 kid->op_sibling = sibl;
5390 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5391 bad_type(numargs, "hash", PL_op_desc[type], kid);
5396 OP *newop = newUNOP(OP_NULL, 0, kid);
5397 kid->op_sibling = 0;
5399 newop->op_next = newop;
5401 kid->op_sibling = sibl;
5406 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5407 if (kid->op_type == OP_CONST &&
5408 (kid->op_private & OPpCONST_BARE))
5410 OP *newop = newGVOP(OP_GV, 0,
5411 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVIO) );
5412 if (!(o->op_private & 1) && /* if not unop */
5413 kid == cLISTOPo->op_last)
5414 cLISTOPo->op_last = newop;
5418 else if (kid->op_type == OP_READLINE) {
5419 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5420 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5423 I32 flags = OPf_SPECIAL;
5427 /* is this op a FH constructor? */
5428 if (is_handle_constructor(o,numargs)) {
5429 const char *name = Nullch;
5433 /* Set a flag to tell rv2gv to vivify
5434 * need to "prove" flag does not mean something
5435 * else already - NI-S 1999/05/07
5438 if (kid->op_type == OP_PADSV) {
5439 name = PAD_COMPNAME_PV(kid->op_targ);
5440 /* SvCUR of a pad namesv can't be trusted
5441 * (see PL_generation), so calc its length
5447 else if (kid->op_type == OP_RV2SV
5448 && kUNOP->op_first->op_type == OP_GV)
5450 GV *gv = cGVOPx_gv(kUNOP->op_first);
5452 len = GvNAMELEN(gv);
5454 else if (kid->op_type == OP_AELEM
5455 || kid->op_type == OP_HELEM)
5460 if ((op = ((BINOP*)kid)->op_first)) {
5461 SV *tmpstr = Nullsv;
5463 kid->op_type == OP_AELEM ?
5465 if (((op->op_type == OP_RV2AV) ||
5466 (op->op_type == OP_RV2HV)) &&
5467 (op = ((UNOP*)op)->op_first) &&
5468 (op->op_type == OP_GV)) {
5469 /* packagevar $a[] or $h{} */
5470 GV *gv = cGVOPx_gv(op);
5478 else if (op->op_type == OP_PADAV
5479 || op->op_type == OP_PADHV) {
5480 /* lexicalvar $a[] or $h{} */
5481 const char *padname =
5482 PAD_COMPNAME_PV(op->op_targ);
5492 name = SvPV(tmpstr, len);
5497 name = "__ANONIO__";
5504 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5505 namesv = PAD_SVl(targ);
5506 (void)SvUPGRADE(namesv, SVt_PV);
5508 sv_setpvn(namesv, "$", 1);
5509 sv_catpvn(namesv, name, len);
5512 kid->op_sibling = 0;
5513 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5514 kid->op_targ = targ;
5515 kid->op_private |= priv;
5517 kid->op_sibling = sibl;
5523 mod(scalar(kid), type);
5527 tokid = &kid->op_sibling;
5528 kid = kid->op_sibling;
5530 o->op_private |= numargs;
5532 return too_many_arguments(o,OP_DESC(o));
5535 else if (PL_opargs[type] & OA_DEFGV) {
5537 return newUNOP(type, 0, newDEFSVOP());
5541 while (oa & OA_OPTIONAL)
5543 if (oa && oa != OA_LIST)
5544 return too_few_arguments(o,OP_DESC(o));
5550 Perl_ck_glob(pTHX_ OP *o)
5556 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5557 append_elem(OP_GLOB, o, newDEFSVOP());
5559 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5560 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5562 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5565 #if !defined(PERL_EXTERNAL_GLOB)
5566 /* XXX this can be tightened up and made more failsafe. */
5567 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5570 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5571 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5572 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5573 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5574 GvCV(gv) = GvCV(glob_gv);
5575 (void)SvREFCNT_inc((SV*)GvCV(gv));
5576 GvIMPORTED_CV_on(gv);
5579 #endif /* PERL_EXTERNAL_GLOB */
5581 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5582 append_elem(OP_GLOB, o,
5583 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5584 o->op_type = OP_LIST;
5585 o->op_ppaddr = PL_ppaddr[OP_LIST];
5586 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5587 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5588 cLISTOPo->op_first->op_targ = 0;
5589 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5590 append_elem(OP_LIST, o,
5591 scalar(newUNOP(OP_RV2CV, 0,
5592 newGVOP(OP_GV, 0, gv)))));
5593 o = newUNOP(OP_NULL, 0, ck_subr(o));
5594 o->op_targ = OP_GLOB; /* hint at what it used to be */
5597 gv = newGVgen("main");
5599 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5605 Perl_ck_grep(pTHX_ OP *o)
5610 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5613 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5614 NewOp(1101, gwop, 1, LOGOP);
5616 if (o->op_flags & OPf_STACKED) {
5619 kid = cLISTOPo->op_first->op_sibling;
5620 if (!cUNOPx(kid)->op_next)
5621 Perl_croak(aTHX_ "panic: ck_grep");
5622 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
5625 kid->op_next = (OP*)gwop;
5626 o->op_flags &= ~OPf_STACKED;
5628 kid = cLISTOPo->op_first->op_sibling;
5629 if (type == OP_MAPWHILE)
5636 kid = cLISTOPo->op_first->op_sibling;
5637 if (kid->op_type != OP_NULL)
5638 Perl_croak(aTHX_ "panic: ck_grep");
5639 kid = kUNOP->op_first;
5641 gwop->op_type = type;
5642 gwop->op_ppaddr = PL_ppaddr[type];
5643 gwop->op_first = listkids(o);
5644 gwop->op_flags |= OPf_KIDS;
5645 gwop->op_other = LINKLIST(kid);
5646 kid->op_next = (OP*)gwop;
5647 offset = pad_findmy("$_");
5648 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
5649 o->op_private = gwop->op_private = 0;
5650 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5653 o->op_private = gwop->op_private = OPpGREP_LEX;
5654 gwop->op_targ = o->op_targ = offset;
5657 kid = cLISTOPo->op_first->op_sibling;
5658 if (!kid || !kid->op_sibling)
5659 return too_few_arguments(o,OP_DESC(o));
5660 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5661 mod(kid, OP_GREPSTART);
5667 Perl_ck_index(pTHX_ OP *o)
5669 if (o->op_flags & OPf_KIDS) {
5670 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5672 kid = kid->op_sibling; /* get past "big" */
5673 if (kid && kid->op_type == OP_CONST)
5674 fbm_compile(((SVOP*)kid)->op_sv, 0);
5680 Perl_ck_lengthconst(pTHX_ OP *o)
5682 /* XXX length optimization goes here */
5687 Perl_ck_lfun(pTHX_ OP *o)
5689 const OPCODE type = o->op_type;
5690 return modkids(ck_fun(o), type);
5694 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5696 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5697 switch (cUNOPo->op_first->op_type) {
5699 /* This is needed for
5700 if (defined %stash::)
5701 to work. Do not break Tk.
5703 break; /* Globals via GV can be undef */
5705 case OP_AASSIGN: /* Is this a good idea? */
5706 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5707 "defined(@array) is deprecated");
5708 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5709 "\t(Maybe you should just omit the defined()?)\n");
5712 /* This is needed for
5713 if (defined %stash::)
5714 to work. Do not break Tk.
5716 break; /* Globals via GV can be undef */
5718 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5719 "defined(%%hash) is deprecated");
5720 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5721 "\t(Maybe you should just omit the defined()?)\n");
5732 Perl_ck_rfun(pTHX_ OP *o)
5734 const OPCODE type = o->op_type;
5735 return refkids(ck_fun(o), type);
5739 Perl_ck_listiob(pTHX_ OP *o)
5743 kid = cLISTOPo->op_first;
5746 kid = cLISTOPo->op_first;
5748 if (kid->op_type == OP_PUSHMARK)
5749 kid = kid->op_sibling;
5750 if (kid && o->op_flags & OPf_STACKED)
5751 kid = kid->op_sibling;
5752 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5753 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5754 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5755 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5756 cLISTOPo->op_first->op_sibling = kid;
5757 cLISTOPo->op_last = kid;
5758 kid = kid->op_sibling;
5763 append_elem(o->op_type, o, newDEFSVOP());
5769 Perl_ck_sassign(pTHX_ OP *o)
5771 OP *kid = cLISTOPo->op_first;
5772 /* has a disposable target? */
5773 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5774 && !(kid->op_flags & OPf_STACKED)
5775 /* Cannot steal the second time! */
5776 && !(kid->op_private & OPpTARGET_MY))
5778 OP *kkid = kid->op_sibling;
5780 /* Can just relocate the target. */
5781 if (kkid && kkid->op_type == OP_PADSV
5782 && !(kkid->op_private & OPpLVAL_INTRO))
5784 kid->op_targ = kkid->op_targ;
5786 /* Now we do not need PADSV and SASSIGN. */
5787 kid->op_sibling = o->op_sibling; /* NULL */
5788 cLISTOPo->op_first = NULL;
5791 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
5795 /* optimise C<my $x = undef> to C<my $x> */
5796 if (kid->op_type == OP_UNDEF) {
5797 OP *kkid = kid->op_sibling;
5798 if (kkid && kkid->op_type == OP_PADSV
5799 && (kkid->op_private & OPpLVAL_INTRO))
5801 cLISTOPo->op_first = NULL;
5802 kid->op_sibling = NULL;
5812 Perl_ck_match(pTHX_ OP *o)
5814 if (o->op_type != OP_QR) {
5815 const I32 offset = pad_findmy("$_");
5816 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS(offset) & SVpad_OUR)) {
5817 o->op_targ = offset;
5818 o->op_private |= OPpTARGET_MY;
5821 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
5822 o->op_private |= OPpRUNTIME;
5827 Perl_ck_method(pTHX_ OP *o)
5829 OP *kid = cUNOPo->op_first;
5830 if (kid->op_type == OP_CONST) {
5831 SV* sv = kSVOP->op_sv;
5832 if (!(strchr(SvPVX_const(sv), ':') || strchr(SvPVX_const(sv), '\''))) {
5834 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5835 sv = newSVpvn_share(SvPVX_const(sv), SvCUR(sv), 0);
5838 kSVOP->op_sv = Nullsv;
5840 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5849 Perl_ck_null(pTHX_ OP *o)
5855 Perl_ck_open(pTHX_ OP *o)
5857 HV *table = GvHV(PL_hintgv);
5861 svp = hv_fetch(table, "open_IN", 7, FALSE);
5863 mode = mode_from_discipline(*svp);
5864 if (mode & O_BINARY)
5865 o->op_private |= OPpOPEN_IN_RAW;
5866 else if (mode & O_TEXT)
5867 o->op_private |= OPpOPEN_IN_CRLF;
5870 svp = hv_fetch(table, "open_OUT", 8, FALSE);
5872 mode = mode_from_discipline(*svp);
5873 if (mode & O_BINARY)
5874 o->op_private |= OPpOPEN_OUT_RAW;
5875 else if (mode & O_TEXT)
5876 o->op_private |= OPpOPEN_OUT_CRLF;
5879 if (o->op_type == OP_BACKTICK)
5882 /* In case of three-arg dup open remove strictness
5883 * from the last arg if it is a bareword. */
5884 OP *first = cLISTOPx(o)->op_first; /* The pushmark. */
5885 OP *last = cLISTOPx(o)->op_last; /* The bareword. */
5889 if ((last->op_type == OP_CONST) && /* The bareword. */
5890 (last->op_private & OPpCONST_BARE) &&
5891 (last->op_private & OPpCONST_STRICT) &&
5892 (oa = first->op_sibling) && /* The fh. */
5893 (oa = oa->op_sibling) && /* The mode. */
5894 SvPOK(((SVOP*)oa)->op_sv) &&
5895 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
5896 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
5897 (last == oa->op_sibling)) /* The bareword. */
5898 last->op_private &= ~OPpCONST_STRICT;
5904 Perl_ck_repeat(pTHX_ OP *o)
5906 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5907 o->op_private |= OPpREPEAT_DOLIST;
5908 cBINOPo->op_first = force_list(cBINOPo->op_first);
5916 Perl_ck_require(pTHX_ OP *o)
5920 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
5921 SVOP *kid = (SVOP*)cUNOPo->op_first;
5923 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5925 for (s = SvPVX(kid->op_sv); *s; s++) {
5926 if (*s == ':' && s[1] == ':') {
5928 Move(s+2, s+1, strlen(s+2)+1, char);
5929 SvCUR_set(kid->op_sv, SvCUR(kid->op_sv) - 1);
5932 if (SvREADONLY(kid->op_sv)) {
5933 SvREADONLY_off(kid->op_sv);
5934 sv_catpvn(kid->op_sv, ".pm", 3);
5935 SvREADONLY_on(kid->op_sv);
5938 sv_catpvn(kid->op_sv, ".pm", 3);
5942 /* handle override, if any */
5943 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
5944 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
5945 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
5947 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5948 OP *kid = cUNOPo->op_first;
5949 cUNOPo->op_first = 0;
5951 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5952 append_elem(OP_LIST, kid,
5953 scalar(newUNOP(OP_RV2CV, 0,
5962 Perl_ck_return(pTHX_ OP *o)
5964 if (CvLVALUE(PL_compcv)) {
5966 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5967 mod(kid, OP_LEAVESUBLV);
5974 Perl_ck_retarget(pTHX_ OP *o)
5976 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5983 Perl_ck_select(pTHX_ OP *o)
5987 if (o->op_flags & OPf_KIDS) {
5988 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5989 if (kid && kid->op_sibling) {
5990 o->op_type = OP_SSELECT;
5991 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
5993 return fold_constants(o);
5997 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5998 if (kid && kid->op_type == OP_RV2GV)
5999 kid->op_private &= ~HINT_STRICT_REFS;
6004 Perl_ck_shift(pTHX_ OP *o)
6006 const I32 type = o->op_type;
6008 if (!(o->op_flags & OPf_KIDS)) {
6012 argop = newUNOP(OP_RV2AV, 0,
6013 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
6014 return newUNOP(type, 0, scalar(argop));
6016 return scalar(modkids(ck_fun(o), type));
6020 Perl_ck_sort(pTHX_ OP *o)
6024 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6026 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6027 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6029 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6031 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6033 if (kid->op_type == OP_SCOPE) {
6037 else if (kid->op_type == OP_LEAVE) {
6038 if (o->op_type == OP_SORT) {
6039 op_null(kid); /* wipe out leave */
6042 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6043 if (k->op_next == kid)
6045 /* don't descend into loops */
6046 else if (k->op_type == OP_ENTERLOOP
6047 || k->op_type == OP_ENTERITER)
6049 k = cLOOPx(k)->op_lastop;
6054 kid->op_next = 0; /* just disconnect the leave */
6055 k = kLISTOP->op_first;
6060 if (o->op_type == OP_SORT) {
6061 /* provide scalar context for comparison function/block */
6067 o->op_flags |= OPf_SPECIAL;
6069 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6072 firstkid = firstkid->op_sibling;
6075 /* provide list context for arguments */
6076 if (o->op_type == OP_SORT)
6083 S_simplify_sort(pTHX_ OP *o)
6085 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6090 if (!(o->op_flags & OPf_STACKED))
6092 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6093 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6094 kid = kUNOP->op_first; /* get past null */
6095 if (kid->op_type != OP_SCOPE)
6097 kid = kLISTOP->op_last; /* get past scope */
6098 switch(kid->op_type) {
6106 k = kid; /* remember this node*/
6107 if (kBINOP->op_first->op_type != OP_RV2SV)
6109 kid = kBINOP->op_first; /* get past cmp */
6110 if (kUNOP->op_first->op_type != OP_GV)
6112 kid = kUNOP->op_first; /* get past rv2sv */
6114 if (GvSTASH(gv) != PL_curstash)
6116 gvname = GvNAME(gv);
6117 if (*gvname == 'a' && gvname[1] == '\0')
6119 else if (*gvname == 'b' && gvname[1] == '\0')
6124 kid = k; /* back to cmp */
6125 if (kBINOP->op_last->op_type != OP_RV2SV)
6127 kid = kBINOP->op_last; /* down to 2nd arg */
6128 if (kUNOP->op_first->op_type != OP_GV)
6130 kid = kUNOP->op_first; /* get past rv2sv */
6132 if (GvSTASH(gv) != PL_curstash)
6134 gvname = GvNAME(gv);
6136 ? !(*gvname == 'a' && gvname[1] == '\0')
6137 : !(*gvname == 'b' && gvname[1] == '\0'))
6139 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6141 o->op_private |= OPpSORT_DESCEND;
6142 if (k->op_type == OP_NCMP)
6143 o->op_private |= OPpSORT_NUMERIC;
6144 if (k->op_type == OP_I_NCMP)
6145 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6146 kid = cLISTOPo->op_first->op_sibling;
6147 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6148 op_free(kid); /* then delete it */
6152 Perl_ck_split(pTHX_ OP *o)
6157 if (o->op_flags & OPf_STACKED)
6158 return no_fh_allowed(o);
6160 kid = cLISTOPo->op_first;
6161 if (kid->op_type != OP_NULL)
6162 Perl_croak(aTHX_ "panic: ck_split");
6163 kid = kid->op_sibling;
6164 op_free(cLISTOPo->op_first);
6165 cLISTOPo->op_first = kid;
6167 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6168 cLISTOPo->op_last = kid; /* There was only one element previously */
6171 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6172 OP *sibl = kid->op_sibling;
6173 kid->op_sibling = 0;
6174 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
6175 if (cLISTOPo->op_first == cLISTOPo->op_last)
6176 cLISTOPo->op_last = kid;
6177 cLISTOPo->op_first = kid;
6178 kid->op_sibling = sibl;
6181 kid->op_type = OP_PUSHRE;
6182 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6184 if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
6185 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
6186 "Use of /g modifier is meaningless in split");
6189 if (!kid->op_sibling)
6190 append_elem(OP_SPLIT, o, newDEFSVOP());
6192 kid = kid->op_sibling;
6195 if (!kid->op_sibling)
6196 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6198 kid = kid->op_sibling;
6201 if (kid->op_sibling)
6202 return too_many_arguments(o,OP_DESC(o));
6208 Perl_ck_join(pTHX_ OP *o)
6210 if (ckWARN(WARN_SYNTAX)) {
6211 const OP *kid = cLISTOPo->op_first->op_sibling;
6212 if (kid && kid->op_type == OP_MATCH) {
6213 const REGEXP *re = PM_GETRE(kPMOP);
6214 const char *pmstr = re ? re->precomp : "STRING";
6215 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6216 "/%s/ should probably be written as \"%s\"",
6224 Perl_ck_subr(pTHX_ OP *o)
6226 OP *prev = ((cUNOPo->op_first->op_sibling)
6227 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6228 OP *o2 = prev->op_sibling;
6235 I32 contextclass = 0;
6240 o->op_private |= OPpENTERSUB_HASTARG;
6241 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6242 if (cvop->op_type == OP_RV2CV) {
6244 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6245 op_null(cvop); /* disable rv2cv */
6246 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6247 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6248 GV *gv = cGVOPx_gv(tmpop);
6251 tmpop->op_private |= OPpEARLY_CV;
6254 namegv = CvANON(cv) ? gv : CvGV(cv);
6255 proto = SvPV((SV*)cv, n_a);
6257 if (CvASSERTION(cv)) {
6258 if (PL_hints & HINT_ASSERTING) {
6259 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
6260 o->op_private |= OPpENTERSUB_DB;
6264 if (ckWARN(WARN_ASSERTIONS) && !(PL_hints & HINT_ASSERTIONSSEEN)) {
6265 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
6266 "Impossible to activate assertion call");
6273 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6274 if (o2->op_type == OP_CONST)
6275 o2->op_private &= ~OPpCONST_STRICT;
6276 else if (o2->op_type == OP_LIST) {
6277 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6278 if (o && o->op_type == OP_CONST)
6279 o->op_private &= ~OPpCONST_STRICT;
6282 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6283 if (PERLDB_SUB && PL_curstash != PL_debstash)
6284 o->op_private |= OPpENTERSUB_DB;
6285 while (o2 != cvop) {
6289 return too_many_arguments(o, gv_ename(namegv));
6307 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6309 arg == 1 ? "block or sub {}" : "sub {}",
6310 gv_ename(namegv), o2);
6313 /* '*' allows any scalar type, including bareword */
6316 if (o2->op_type == OP_RV2GV)
6317 goto wrapref; /* autoconvert GLOB -> GLOBref */
6318 else if (o2->op_type == OP_CONST)
6319 o2->op_private &= ~OPpCONST_STRICT;
6320 else if (o2->op_type == OP_ENTERSUB) {
6321 /* accidental subroutine, revert to bareword */
6322 OP *gvop = ((UNOP*)o2)->op_first;
6323 if (gvop && gvop->op_type == OP_NULL) {
6324 gvop = ((UNOP*)gvop)->op_first;
6326 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6329 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6330 (gvop = ((UNOP*)gvop)->op_first) &&
6331 gvop->op_type == OP_GV)
6333 GV *gv = cGVOPx_gv(gvop);
6334 OP *sibling = o2->op_sibling;
6335 SV *n = newSVpvn("",0);
6337 gv_fullname4(n, gv, "", FALSE);
6338 o2 = newSVOP(OP_CONST, 0, n);
6339 prev->op_sibling = o2;
6340 o2->op_sibling = sibling;
6356 if (contextclass++ == 0) {
6357 e = strchr(proto, ']');
6358 if (!e || e == proto)
6371 while (*--p != '[');
6372 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6373 gv_ename(namegv), o2);
6379 if (o2->op_type == OP_RV2GV)
6382 bad_type(arg, "symbol", gv_ename(namegv), o2);
6385 if (o2->op_type == OP_ENTERSUB)
6388 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6391 if (o2->op_type == OP_RV2SV ||
6392 o2->op_type == OP_PADSV ||
6393 o2->op_type == OP_HELEM ||
6394 o2->op_type == OP_AELEM ||
6395 o2->op_type == OP_THREADSV)
6398 bad_type(arg, "scalar", gv_ename(namegv), o2);
6401 if (o2->op_type == OP_RV2AV ||
6402 o2->op_type == OP_PADAV)
6405 bad_type(arg, "array", gv_ename(namegv), o2);
6408 if (o2->op_type == OP_RV2HV ||
6409 o2->op_type == OP_PADHV)
6412 bad_type(arg, "hash", gv_ename(namegv), o2);
6417 OP* sib = kid->op_sibling;
6418 kid->op_sibling = 0;
6419 o2 = newUNOP(OP_REFGEN, 0, kid);
6420 o2->op_sibling = sib;
6421 prev->op_sibling = o2;
6423 if (contextclass && e) {
6438 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6439 gv_ename(namegv), cv);
6444 mod(o2, OP_ENTERSUB);
6446 o2 = o2->op_sibling;
6448 if (proto && !optional &&
6449 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6450 return too_few_arguments(o, gv_ename(namegv));
6453 o=newSVOP(OP_CONST, 0, newSViv(0));
6459 Perl_ck_svconst(pTHX_ OP *o)
6461 SvREADONLY_on(cSVOPo->op_sv);
6466 Perl_ck_trunc(pTHX_ OP *o)
6468 if (o->op_flags & OPf_KIDS) {
6469 SVOP *kid = (SVOP*)cUNOPo->op_first;
6471 if (kid->op_type == OP_NULL)
6472 kid = (SVOP*)kid->op_sibling;
6473 if (kid && kid->op_type == OP_CONST &&
6474 (kid->op_private & OPpCONST_BARE))
6476 o->op_flags |= OPf_SPECIAL;
6477 kid->op_private &= ~OPpCONST_STRICT;
6484 Perl_ck_unpack(pTHX_ OP *o)
6486 OP *kid = cLISTOPo->op_first;
6487 if (kid->op_sibling) {
6488 kid = kid->op_sibling;
6489 if (!kid->op_sibling)
6490 kid->op_sibling = newDEFSVOP();
6496 Perl_ck_substr(pTHX_ OP *o)
6499 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6500 OP *kid = cLISTOPo->op_first;
6502 if (kid->op_type == OP_NULL)
6503 kid = kid->op_sibling;
6505 kid->op_flags |= OPf_MOD;
6511 /* A peephole optimizer. We visit the ops in the order they're to execute.
6512 * See the comments at the top of this file for more details about when
6513 * peep() is called */
6516 Perl_peep(pTHX_ register OP *o)
6519 register OP* oldop = 0;
6521 if (!o || o->op_opt)
6525 SAVEVPTR(PL_curcop);
6526 for (; o; o = o->op_next) {
6530 switch (o->op_type) {
6534 PL_curcop = ((COP*)o); /* for warnings */
6539 if (cSVOPo->op_private & OPpCONST_STRICT)
6540 no_bareword_allowed(o);
6542 case OP_METHOD_NAMED:
6543 /* Relocate sv to the pad for thread safety.
6544 * Despite being a "constant", the SV is written to,
6545 * for reference counts, sv_upgrade() etc. */
6547 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6548 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6549 /* If op_sv is already a PADTMP then it is being used by
6550 * some pad, so make a copy. */
6551 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6552 SvREADONLY_on(PAD_SVl(ix));
6553 SvREFCNT_dec(cSVOPo->op_sv);
6556 SvREFCNT_dec(PAD_SVl(ix));
6557 SvPADTMP_on(cSVOPo->op_sv);
6558 PAD_SETSV(ix, cSVOPo->op_sv);
6559 /* XXX I don't know how this isn't readonly already. */
6560 SvREADONLY_on(PAD_SVl(ix));
6562 cSVOPo->op_sv = Nullsv;
6570 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6571 if (o->op_next->op_private & OPpTARGET_MY) {
6572 if (o->op_flags & OPf_STACKED) /* chained concats */
6573 goto ignore_optimization;
6575 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6576 o->op_targ = o->op_next->op_targ;
6577 o->op_next->op_targ = 0;
6578 o->op_private |= OPpTARGET_MY;
6581 op_null(o->op_next);
6583 ignore_optimization:
6587 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6589 break; /* Scalar stub must produce undef. List stub is noop */
6593 if (o->op_targ == OP_NEXTSTATE
6594 || o->op_targ == OP_DBSTATE
6595 || o->op_targ == OP_SETSTATE)
6597 PL_curcop = ((COP*)o);
6599 /* XXX: We avoid setting op_seq here to prevent later calls
6600 to peep() from mistakenly concluding that optimisation
6601 has already occurred. This doesn't fix the real problem,
6602 though (See 20010220.007). AMS 20010719 */
6603 /* op_seq functionality is now replaced by op_opt */
6604 if (oldop && o->op_next) {
6605 oldop->op_next = o->op_next;
6613 if (oldop && o->op_next) {
6614 oldop->op_next = o->op_next;
6622 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
6623 OP* pop = (o->op_type == OP_PADAV) ?
6624 o->op_next : o->op_next->op_next;
6626 if (pop && pop->op_type == OP_CONST &&
6627 ((PL_op = pop->op_next)) &&
6628 pop->op_next->op_type == OP_AELEM &&
6629 !(pop->op_next->op_private &
6630 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6631 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6636 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
6637 no_bareword_allowed(pop);
6638 if (o->op_type == OP_GV)
6639 op_null(o->op_next);
6640 op_null(pop->op_next);
6642 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6643 o->op_next = pop->op_next->op_next;
6644 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6645 o->op_private = (U8)i;
6646 if (o->op_type == OP_GV) {
6651 o->op_flags |= OPf_SPECIAL;
6652 o->op_type = OP_AELEMFAST;
6658 if (o->op_next->op_type == OP_RV2SV) {
6659 if (!(o->op_next->op_private & OPpDEREF)) {
6660 op_null(o->op_next);
6661 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6663 o->op_next = o->op_next->op_next;
6664 o->op_type = OP_GVSV;
6665 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6668 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6670 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
6671 /* XXX could check prototype here instead of just carping */
6672 SV *sv = sv_newmortal();
6673 gv_efullname3(sv, gv, Nullch);
6674 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6675 "%"SVf"() called too early to check prototype",
6679 else if (o->op_next->op_type == OP_READLINE
6680 && o->op_next->op_next->op_type == OP_CONCAT
6681 && (o->op_next->op_next->op_flags & OPf_STACKED))
6683 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6684 o->op_type = OP_RCATLINE;
6685 o->op_flags |= OPf_STACKED;
6686 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6687 op_null(o->op_next->op_next);
6688 op_null(o->op_next);
6705 while (cLOGOP->op_other->op_type == OP_NULL)
6706 cLOGOP->op_other = cLOGOP->op_other->op_next;
6707 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6713 while (cLOOP->op_redoop->op_type == OP_NULL)
6714 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6715 peep(cLOOP->op_redoop);
6716 while (cLOOP->op_nextop->op_type == OP_NULL)
6717 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6718 peep(cLOOP->op_nextop);
6719 while (cLOOP->op_lastop->op_type == OP_NULL)
6720 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6721 peep(cLOOP->op_lastop);
6728 while (cPMOP->op_pmreplstart &&
6729 cPMOP->op_pmreplstart->op_type == OP_NULL)
6730 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6731 peep(cPMOP->op_pmreplstart);
6736 if (ckWARN(WARN_SYNTAX) && o->op_next
6737 && o->op_next->op_type == OP_NEXTSTATE) {
6738 if (o->op_next->op_sibling &&
6739 o->op_next->op_sibling->op_type != OP_EXIT &&
6740 o->op_next->op_sibling->op_type != OP_WARN &&
6741 o->op_next->op_sibling->op_type != OP_DIE) {
6742 const line_t oldline = CopLINE(PL_curcop);
6744 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6745 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6746 "Statement unlikely to be reached");
6747 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6748 "\t(Maybe you meant system() when you said exec()?)\n");
6749 CopLINE_set(PL_curcop, oldline);
6764 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6767 /* Make the CONST have a shared SV */
6768 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6769 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6770 key = SvPV(sv, keylen);
6771 lexname = newSVpvn_share(key,
6772 SvUTF8(sv) ? -(I32)keylen : keylen,
6778 if ((o->op_private & (OPpLVAL_INTRO)))
6781 rop = (UNOP*)((BINOP*)o)->op_first;
6782 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6784 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6785 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6787 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6788 if (!fields || !GvHV(*fields))
6790 key = SvPV(*svp, keylen);
6791 if (!hv_fetch(GvHV(*fields), key,
6792 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
6794 Perl_croak(aTHX_ "No such class field \"%s\" "
6795 "in variable %s of type %s",
6796 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
6809 SVOP *first_key_op, *key_op;
6811 if ((o->op_private & (OPpLVAL_INTRO))
6812 /* I bet there's always a pushmark... */
6813 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6814 /* hmmm, no optimization if list contains only one key. */
6816 rop = (UNOP*)((LISTOP*)o)->op_last;
6817 if (rop->op_type != OP_RV2HV)
6819 if (rop->op_first->op_type == OP_PADSV)
6820 /* @$hash{qw(keys here)} */
6821 rop = (UNOP*)rop->op_first;
6823 /* @{$hash}{qw(keys here)} */
6824 if (rop->op_first->op_type == OP_SCOPE
6825 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
6827 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
6833 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
6834 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6836 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6837 if (!fields || !GvHV(*fields))
6839 /* Again guessing that the pushmark can be jumped over.... */
6840 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
6841 ->op_first->op_sibling;
6842 for (key_op = first_key_op; key_op;
6843 key_op = (SVOP*)key_op->op_sibling) {
6844 if (key_op->op_type != OP_CONST)
6846 svp = cSVOPx_svp(key_op);
6847 key = SvPV(*svp, keylen);
6848 if (!hv_fetch(GvHV(*fields), key,
6849 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
6851 Perl_croak(aTHX_ "No such class field \"%s\" "
6852 "in variable %s of type %s",
6853 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
6860 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
6864 /* check that RHS of sort is a single plain array */
6865 oright = cUNOPo->op_first;
6866 if (!oright || oright->op_type != OP_PUSHMARK)
6869 /* reverse sort ... can be optimised. */
6870 if (!cUNOPo->op_sibling) {
6871 /* Nothing follows us on the list. */
6872 OP *reverse = o->op_next;
6874 if (reverse->op_type == OP_REVERSE &&
6875 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
6876 OP *pushmark = cUNOPx(reverse)->op_first;
6877 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
6878 && (cUNOPx(pushmark)->op_sibling == o)) {
6879 /* reverse -> pushmark -> sort */
6880 o->op_private |= OPpSORT_REVERSE;
6882 pushmark->op_next = oright->op_next;
6888 /* make @a = sort @a act in-place */
6892 oright = cUNOPx(oright)->op_sibling;
6895 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
6896 oright = cUNOPx(oright)->op_sibling;
6900 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
6901 || oright->op_next != o
6902 || (oright->op_private & OPpLVAL_INTRO)
6906 /* o2 follows the chain of op_nexts through the LHS of the
6907 * assign (if any) to the aassign op itself */
6909 if (!o2 || o2->op_type != OP_NULL)
6912 if (!o2 || o2->op_type != OP_PUSHMARK)
6915 if (o2 && o2->op_type == OP_GV)
6918 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
6919 || (o2->op_private & OPpLVAL_INTRO)
6924 if (!o2 || o2->op_type != OP_NULL)
6927 if (!o2 || o2->op_type != OP_AASSIGN
6928 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
6931 /* check that the sort is the first arg on RHS of assign */
6933 o2 = cUNOPx(o2)->op_first;
6934 if (!o2 || o2->op_type != OP_NULL)
6936 o2 = cUNOPx(o2)->op_first;
6937 if (!o2 || o2->op_type != OP_PUSHMARK)
6939 if (o2->op_sibling != o)
6942 /* check the array is the same on both sides */
6943 if (oleft->op_type == OP_RV2AV) {
6944 if (oright->op_type != OP_RV2AV
6945 || !cUNOPx(oright)->op_first
6946 || cUNOPx(oright)->op_first->op_type != OP_GV
6947 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
6948 cGVOPx_gv(cUNOPx(oright)->op_first)
6952 else if (oright->op_type != OP_PADAV
6953 || oright->op_targ != oleft->op_targ
6957 /* transfer MODishness etc from LHS arg to RHS arg */
6958 oright->op_flags = oleft->op_flags;
6959 o->op_private |= OPpSORT_INPLACE;
6961 /* excise push->gv->rv2av->null->aassign */
6962 o2 = o->op_next->op_next;
6963 op_null(o2); /* PUSHMARK */
6965 if (o2->op_type == OP_GV) {
6966 op_null(o2); /* GV */
6969 op_null(o2); /* RV2AV or PADAV */
6970 o2 = o2->op_next->op_next;
6971 op_null(o2); /* AASSIGN */
6973 o->op_next = o2->op_next;
6979 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
6981 LISTOP *enter, *exlist;
6984 enter = (LISTOP *) o->op_next;
6987 if (enter->op_type == OP_NULL) {
6988 enter = (LISTOP *) enter->op_next;
6992 /* for $a (...) will have OP_GV then OP_RV2GV here.
6993 for (...) just has an OP_GV. */
6994 if (enter->op_type == OP_GV) {
6995 gvop = (OP *) enter;
6996 enter = (LISTOP *) enter->op_next;
6999 if (enter->op_type == OP_RV2GV) {
7000 enter = (LISTOP *) enter->op_next;
7006 if (enter->op_type != OP_ENTERITER)
7009 iter = enter->op_next;
7010 if (!iter || iter->op_type != OP_ITER)
7013 expushmark = enter->op_first;
7014 if (!expushmark || expushmark->op_type != OP_NULL
7015 || expushmark->op_targ != OP_PUSHMARK)
7018 exlist = (LISTOP *) expushmark->op_sibling;
7019 if (!exlist || exlist->op_type != OP_NULL
7020 || exlist->op_targ != OP_LIST)
7023 if (exlist->op_last != o) {
7024 /* Mmm. Was expecting to point back to this op. */
7027 theirmark = exlist->op_first;
7028 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
7031 if (theirmark->op_sibling != o) {
7032 /* There's something between the mark and the reverse, eg
7033 for (1, reverse (...))
7038 ourmark = ((LISTOP *)o)->op_first;
7039 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
7042 ourlast = ((LISTOP *)o)->op_last;
7043 if (!ourlast || ourlast->op_next != o)
7046 rv2av = ourmark->op_sibling;
7047 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
7048 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
7049 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
7050 /* We're just reversing a single array. */
7051 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
7052 enter->op_flags |= OPf_STACKED;
7055 /* We don't have control over who points to theirmark, so sacrifice
7057 theirmark->op_next = ourmark->op_next;
7058 theirmark->op_flags = ourmark->op_flags;
7059 ourlast->op_next = gvop ? gvop : (OP *) enter;
7062 enter->op_private |= OPpITER_REVERSED;
7063 iter->op_private |= OPpITER_REVERSED;
7078 Perl_custom_op_name(pTHX_ const OP* o)
7080 const IV index = PTR2IV(o->op_ppaddr);
7084 if (!PL_custom_op_names) /* This probably shouldn't happen */
7085 return (char *)PL_op_name[OP_CUSTOM];
7087 keysv = sv_2mortal(newSViv(index));
7089 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7091 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7093 return SvPV_nolen(HeVAL(he));
7097 Perl_custom_op_desc(pTHX_ const OP* o)
7099 const IV index = PTR2IV(o->op_ppaddr);
7103 if (!PL_custom_op_descs)
7104 return (char *)PL_op_desc[OP_CUSTOM];
7106 keysv = sv_2mortal(newSViv(index));
7108 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7110 return (char *)PL_op_desc[OP_CUSTOM];
7112 return SvPV_nolen(HeVAL(he));
7117 /* Efficient sub that returns a constant scalar value. */
7119 const_sv_xsub(pTHX_ CV* cv)
7124 Perl_croak(aTHX_ "usage: %s::%s()",
7125 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7129 ST(0) = (SV*)XSANY.any_ptr;
7135 * c-indentation-style: bsd
7137 * indent-tabs-mode: t
7140 * ex: set ts=8 sts=4 sw=4 noet: