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' */
1537 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1539 #define ATTRSMODULE "attributes"
1540 #define ATTRSMODULE_PM "attributes.pm"
1543 /* Don't force the C<use> if we don't need it. */
1544 SV **svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
1545 sizeof(ATTRSMODULE_PM)-1, 0);
1546 if (svp && *svp != &PL_sv_undef)
1547 ; /* already in %INC */
1549 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1550 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1554 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1555 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1557 prepend_elem(OP_LIST,
1558 newSVOP(OP_CONST, 0, stashsv),
1559 prepend_elem(OP_LIST,
1560 newSVOP(OP_CONST, 0,
1562 dup_attrlist(attrs))));
1568 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1570 OP *pack, *imop, *arg;
1576 assert(target->op_type == OP_PADSV ||
1577 target->op_type == OP_PADHV ||
1578 target->op_type == OP_PADAV);
1580 /* Ensure that attributes.pm is loaded. */
1581 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1583 /* Need package name for method call. */
1584 pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
1586 /* Build up the real arg-list. */
1587 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1589 arg = newOP(OP_PADSV, 0);
1590 arg->op_targ = target->op_targ;
1591 arg = prepend_elem(OP_LIST,
1592 newSVOP(OP_CONST, 0, stashsv),
1593 prepend_elem(OP_LIST,
1594 newUNOP(OP_REFGEN, 0,
1595 mod(arg, OP_REFGEN)),
1596 dup_attrlist(attrs)));
1598 /* Fake up a method call to import */
1599 meth = newSVpvn("import", 6);
1600 (void)SvUPGRADE(meth, SVt_PVIV);
1601 (void)SvIOK_on(meth);
1604 PERL_HASH(hash, SvPVX_const(meth), SvCUR(meth));
1605 SvUV_set(meth, hash);
1607 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1608 append_elem(OP_LIST,
1609 prepend_elem(OP_LIST, pack, list(arg)),
1610 newSVOP(OP_METHOD_NAMED, 0, meth)));
1611 imop->op_private |= OPpENTERSUB_NOMOD;
1613 /* Combine the ops. */
1614 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1618 =notfor apidoc apply_attrs_string
1620 Attempts to apply a list of attributes specified by the C<attrstr> and
1621 C<len> arguments to the subroutine identified by the C<cv> argument which
1622 is expected to be associated with the package identified by the C<stashpv>
1623 argument (see L<attributes>). It gets this wrong, though, in that it
1624 does not correctly identify the boundaries of the individual attribute
1625 specifications within C<attrstr>. This is not really intended for the
1626 public API, but has to be listed here for systems such as AIX which
1627 need an explicit export list for symbols. (It's called from XS code
1628 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1629 to respect attribute syntax properly would be welcome.
1635 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1636 const char *attrstr, STRLEN len)
1641 len = strlen(attrstr);
1645 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1647 const char *sstr = attrstr;
1648 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1649 attrs = append_elem(OP_LIST, attrs,
1650 newSVOP(OP_CONST, 0,
1651 newSVpvn(sstr, attrstr-sstr)));
1655 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1656 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1657 Nullsv, prepend_elem(OP_LIST,
1658 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1659 prepend_elem(OP_LIST,
1660 newSVOP(OP_CONST, 0,
1666 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1670 if (!o || PL_error_count)
1674 if (type == OP_LIST) {
1676 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1677 my_kid(kid, attrs, imopsp);
1678 } else if (type == OP_UNDEF) {
1680 } else if (type == OP_RV2SV || /* "our" declaration */
1682 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1683 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1684 yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
1685 OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
1687 GV *gv = cGVOPx_gv(cUNOPo->op_first);
1689 PL_in_my_stash = Nullhv;
1690 apply_attrs(GvSTASH(gv),
1691 (type == OP_RV2SV ? GvSV(gv) :
1692 type == OP_RV2AV ? (SV*)GvAV(gv) :
1693 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1696 o->op_private |= OPpOUR_INTRO;
1699 else if (type != OP_PADSV &&
1702 type != OP_PUSHMARK)
1704 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1706 PL_in_my == KEY_our ? "our" : "my"));
1709 else if (attrs && type != OP_PUSHMARK) {
1713 PL_in_my_stash = Nullhv;
1715 /* check for C<my Dog $spot> when deciding package */
1716 stash = PAD_COMPNAME_TYPE(o->op_targ);
1718 stash = PL_curstash;
1719 apply_attrs_my(stash, o, attrs, imopsp);
1721 o->op_flags |= OPf_MOD;
1722 o->op_private |= OPpLVAL_INTRO;
1727 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1730 int maybe_scalar = 0;
1732 /* [perl #17376]: this appears to be premature, and results in code such as
1733 C< our(%x); > executing in list mode rather than void mode */
1735 if (o->op_flags & OPf_PARENS)
1744 o = my_kid(o, attrs, &rops);
1746 if (maybe_scalar && o->op_type == OP_PADSV) {
1747 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1748 o->op_private |= OPpLVAL_INTRO;
1751 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1754 PL_in_my_stash = Nullhv;
1759 Perl_my(pTHX_ OP *o)
1761 return my_attrs(o, Nullop);
1765 Perl_sawparens(pTHX_ OP *o)
1768 o->op_flags |= OPf_PARENS;
1773 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1778 if (ckWARN(WARN_MISC) &&
1779 (left->op_type == OP_RV2AV ||
1780 left->op_type == OP_RV2HV ||
1781 left->op_type == OP_PADAV ||
1782 left->op_type == OP_PADHV)) {
1783 const char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
1784 right->op_type == OP_TRANS)
1785 ? right->op_type : OP_MATCH];
1786 const char *sample = ((left->op_type == OP_RV2AV ||
1787 left->op_type == OP_PADAV)
1788 ? "@array" : "%hash");
1789 Perl_warner(aTHX_ packWARN(WARN_MISC),
1790 "Applying %s to %s will act on scalar(%s)",
1791 desc, sample, sample);
1794 if (right->op_type == OP_CONST &&
1795 cSVOPx(right)->op_private & OPpCONST_BARE &&
1796 cSVOPx(right)->op_private & OPpCONST_STRICT)
1798 no_bareword_allowed(right);
1801 ismatchop = right->op_type == OP_MATCH ||
1802 right->op_type == OP_SUBST ||
1803 right->op_type == OP_TRANS;
1804 if (ismatchop && right->op_private & OPpTARGET_MY) {
1806 right->op_private &= ~OPpTARGET_MY;
1808 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1809 right->op_flags |= OPf_STACKED;
1810 if (right->op_type != OP_MATCH &&
1811 ! (right->op_type == OP_TRANS &&
1812 right->op_private & OPpTRANS_IDENTICAL))
1813 left = mod(left, right->op_type);
1814 if (right->op_type == OP_TRANS)
1815 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
1817 o = prepend_elem(right->op_type, scalar(left), right);
1819 return newUNOP(OP_NOT, 0, scalar(o));
1823 return bind_match(type, left,
1824 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
1828 Perl_invert(pTHX_ OP *o)
1832 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
1833 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1837 Perl_scope(pTHX_ OP *o)
1841 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1842 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1843 o->op_type = OP_LEAVE;
1844 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1846 else if (o->op_type == OP_LINESEQ) {
1848 o->op_type = OP_SCOPE;
1849 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1850 kid = ((LISTOP*)o)->op_first;
1851 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
1855 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
1860 /* XXX kept for BINCOMPAT only */
1862 Perl_save_hints(pTHX)
1864 Perl_croak(aTHX_ "internal error: obsolete function save_hints() called");
1868 Perl_block_start(pTHX_ int full)
1870 const int retval = PL_savestack_ix;
1871 pad_block_start(full);
1873 PL_hints &= ~HINT_BLOCK_SCOPE;
1874 SAVESPTR(PL_compiling.cop_warnings);
1875 if (! specialWARN(PL_compiling.cop_warnings)) {
1876 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1877 SAVEFREESV(PL_compiling.cop_warnings) ;
1879 SAVESPTR(PL_compiling.cop_io);
1880 if (! specialCopIO(PL_compiling.cop_io)) {
1881 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1882 SAVEFREESV(PL_compiling.cop_io) ;
1888 Perl_block_end(pTHX_ I32 floor, OP *seq)
1890 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1891 OP* retval = scalarseq(seq);
1893 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
1895 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
1903 const I32 offset = pad_findmy("$_");
1904 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
1905 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1908 OP *o = newOP(OP_PADSV, 0);
1909 o->op_targ = offset;
1915 Perl_newPROG(pTHX_ OP *o)
1920 PL_eval_root = newUNOP(OP_LEAVEEVAL,
1921 ((PL_in_eval & EVAL_KEEPERR)
1922 ? OPf_SPECIAL : 0), o);
1923 PL_eval_start = linklist(PL_eval_root);
1924 PL_eval_root->op_private |= OPpREFCOUNTED;
1925 OpREFCNT_set(PL_eval_root, 1);
1926 PL_eval_root->op_next = 0;
1927 CALL_PEEP(PL_eval_start);
1930 if (o->op_type == OP_STUB) {
1931 PL_comppad_name = 0;
1936 PL_main_root = scope(sawparens(scalarvoid(o)));
1937 PL_curcop = &PL_compiling;
1938 PL_main_start = LINKLIST(PL_main_root);
1939 PL_main_root->op_private |= OPpREFCOUNTED;
1940 OpREFCNT_set(PL_main_root, 1);
1941 PL_main_root->op_next = 0;
1942 CALL_PEEP(PL_main_start);
1945 /* Register with debugger */
1947 CV *cv = get_cv("DB::postponed", FALSE);
1951 XPUSHs((SV*)CopFILEGV(&PL_compiling));
1953 call_sv((SV*)cv, G_DISCARD);
1960 Perl_localize(pTHX_ OP *o, I32 lex)
1962 if (o->op_flags & OPf_PARENS)
1963 /* [perl #17376]: this appears to be premature, and results in code such as
1964 C< our(%x); > executing in list mode rather than void mode */
1971 if (ckWARN(WARN_PARENTHESIS)
1972 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
1974 char *s = PL_bufptr;
1977 /* some heuristics to detect a potential error */
1978 while (*s && (strchr(", \t\n", *s)))
1982 if (*s && strchr("@$%*", *s) && *++s
1983 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
1986 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
1988 while (*s && (strchr(", \t\n", *s)))
1994 if (sigil && (*s == ';' || *s == '=')) {
1995 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
1996 "Parentheses missing around \"%s\" list",
1997 lex ? (PL_in_my == KEY_our ? "our" : "my")
2005 o = mod(o, OP_NULL); /* a bit kludgey */
2007 PL_in_my_stash = Nullhv;
2012 Perl_jmaybe(pTHX_ OP *o)
2014 if (o->op_type == OP_LIST) {
2016 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2017 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2023 Perl_fold_constants(pTHX_ register OP *o)
2027 I32 type = o->op_type;
2030 if (PL_opargs[type] & OA_RETSCALAR)
2032 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2033 o->op_targ = pad_alloc(type, SVs_PADTMP);
2035 /* integerize op, unless it happens to be C<-foo>.
2036 * XXX should pp_i_negate() do magic string negation instead? */
2037 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2038 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2039 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2041 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2044 if (!(PL_opargs[type] & OA_FOLDCONST))
2049 /* XXX might want a ck_negate() for this */
2050 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2062 /* XXX what about the numeric ops? */
2063 if (PL_hints & HINT_LOCALE)
2068 goto nope; /* Don't try to run w/ errors */
2070 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2071 if ((curop->op_type != OP_CONST ||
2072 (curop->op_private & OPpCONST_BARE)) &&
2073 curop->op_type != OP_LIST &&
2074 curop->op_type != OP_SCALAR &&
2075 curop->op_type != OP_NULL &&
2076 curop->op_type != OP_PUSHMARK)
2082 curop = LINKLIST(o);
2086 sv = *(PL_stack_sp--);
2087 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2088 pad_swipe(o->op_targ, FALSE);
2089 else if (SvTEMP(sv)) { /* grab mortal temp? */
2090 (void)SvREFCNT_inc(sv);
2094 if (type == OP_RV2GV)
2095 return newGVOP(OP_GV, 0, (GV*)sv);
2096 return newSVOP(OP_CONST, 0, sv);
2103 Perl_gen_constant_list(pTHX_ register OP *o)
2107 const I32 oldtmps_floor = PL_tmps_floor;
2111 return o; /* Don't attempt to run with errors */
2113 PL_op = curop = LINKLIST(o);
2120 PL_tmps_floor = oldtmps_floor;
2122 o->op_type = OP_RV2AV;
2123 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2124 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2125 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2126 o->op_opt = 0; /* needs to be revisited in peep() */
2127 curop = ((UNOP*)o)->op_first;
2128 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2135 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2138 if (!o || o->op_type != OP_LIST)
2139 o = newLISTOP(OP_LIST, 0, o, Nullop);
2141 o->op_flags &= ~OPf_WANT;
2143 if (!(PL_opargs[type] & OA_MARK))
2144 op_null(cLISTOPo->op_first);
2146 o->op_type = (OPCODE)type;
2147 o->op_ppaddr = PL_ppaddr[type];
2148 o->op_flags |= flags;
2150 o = CHECKOP(type, o);
2151 if (o->op_type != (unsigned)type)
2154 return fold_constants(o);
2157 /* List constructors */
2160 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2168 if (first->op_type != (unsigned)type
2169 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2171 return newLISTOP(type, 0, first, last);
2174 if (first->op_flags & OPf_KIDS)
2175 ((LISTOP*)first)->op_last->op_sibling = last;
2177 first->op_flags |= OPf_KIDS;
2178 ((LISTOP*)first)->op_first = last;
2180 ((LISTOP*)first)->op_last = last;
2185 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2193 if (first->op_type != (unsigned)type)
2194 return prepend_elem(type, (OP*)first, (OP*)last);
2196 if (last->op_type != (unsigned)type)
2197 return append_elem(type, (OP*)first, (OP*)last);
2199 first->op_last->op_sibling = last->op_first;
2200 first->op_last = last->op_last;
2201 first->op_flags |= (last->op_flags & OPf_KIDS);
2209 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2217 if (last->op_type == (unsigned)type) {
2218 if (type == OP_LIST) { /* already a PUSHMARK there */
2219 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2220 ((LISTOP*)last)->op_first->op_sibling = first;
2221 if (!(first->op_flags & OPf_PARENS))
2222 last->op_flags &= ~OPf_PARENS;
2225 if (!(last->op_flags & OPf_KIDS)) {
2226 ((LISTOP*)last)->op_last = first;
2227 last->op_flags |= OPf_KIDS;
2229 first->op_sibling = ((LISTOP*)last)->op_first;
2230 ((LISTOP*)last)->op_first = first;
2232 last->op_flags |= OPf_KIDS;
2236 return newLISTOP(type, 0, first, last);
2242 Perl_newNULLLIST(pTHX)
2244 return newOP(OP_STUB, 0);
2248 Perl_force_list(pTHX_ OP *o)
2250 if (!o || o->op_type != OP_LIST)
2251 o = newLISTOP(OP_LIST, 0, o, Nullop);
2257 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2262 NewOp(1101, listop, 1, LISTOP);
2264 listop->op_type = (OPCODE)type;
2265 listop->op_ppaddr = PL_ppaddr[type];
2268 listop->op_flags = (U8)flags;
2272 else if (!first && last)
2275 first->op_sibling = last;
2276 listop->op_first = first;
2277 listop->op_last = last;
2278 if (type == OP_LIST) {
2280 pushop = newOP(OP_PUSHMARK, 0);
2281 pushop->op_sibling = first;
2282 listop->op_first = pushop;
2283 listop->op_flags |= OPf_KIDS;
2285 listop->op_last = pushop;
2288 return CHECKOP(type, listop);
2292 Perl_newOP(pTHX_ I32 type, I32 flags)
2296 NewOp(1101, o, 1, OP);
2297 o->op_type = (OPCODE)type;
2298 o->op_ppaddr = PL_ppaddr[type];
2299 o->op_flags = (U8)flags;
2302 o->op_private = (U8)(0 | (flags >> 8));
2303 if (PL_opargs[type] & OA_RETSCALAR)
2305 if (PL_opargs[type] & OA_TARGET)
2306 o->op_targ = pad_alloc(type, SVs_PADTMP);
2307 return CHECKOP(type, o);
2311 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2317 first = newOP(OP_STUB, 0);
2318 if (PL_opargs[type] & OA_MARK)
2319 first = force_list(first);
2321 NewOp(1101, unop, 1, UNOP);
2322 unop->op_type = (OPCODE)type;
2323 unop->op_ppaddr = PL_ppaddr[type];
2324 unop->op_first = first;
2325 unop->op_flags = flags | OPf_KIDS;
2326 unop->op_private = (U8)(1 | (flags >> 8));
2327 unop = (UNOP*) CHECKOP(type, unop);
2331 return fold_constants((OP *) unop);
2335 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2339 NewOp(1101, binop, 1, BINOP);
2342 first = newOP(OP_NULL, 0);
2344 binop->op_type = (OPCODE)type;
2345 binop->op_ppaddr = PL_ppaddr[type];
2346 binop->op_first = first;
2347 binop->op_flags = flags | OPf_KIDS;
2350 binop->op_private = (U8)(1 | (flags >> 8));
2353 binop->op_private = (U8)(2 | (flags >> 8));
2354 first->op_sibling = last;
2357 binop = (BINOP*)CHECKOP(type, binop);
2358 if (binop->op_next || binop->op_type != (OPCODE)type)
2361 binop->op_last = binop->op_first->op_sibling;
2363 return fold_constants((OP *)binop);
2366 static int uvcompare(const void *a, const void *b) __attribute__nonnull__(1) __attribute__nonnull__(2) __attribute__pure__;
2367 static int uvcompare(const void *a, const void *b)
2369 if (*((const UV *)a) < (*(const UV *)b))
2371 if (*((const UV *)a) > (*(const UV *)b))
2373 if (*((const UV *)a+1) < (*(const UV *)b+1))
2375 if (*((const UV *)a+1) > (*(const UV *)b+1))
2381 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2383 SV *tstr = ((SVOP*)expr)->op_sv;
2384 SV *rstr = ((SVOP*)repl)->op_sv;
2387 U8 *t = (U8*)SvPV(tstr, tlen);
2388 U8 *r = (U8*)SvPV(rstr, rlen);
2395 register short *tbl;
2397 PL_hints |= HINT_BLOCK_SCOPE;
2398 complement = o->op_private & OPpTRANS_COMPLEMENT;
2399 del = o->op_private & OPpTRANS_DELETE;
2400 squash = o->op_private & OPpTRANS_SQUASH;
2403 o->op_private |= OPpTRANS_FROM_UTF;
2406 o->op_private |= OPpTRANS_TO_UTF;
2408 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2409 SV* listsv = newSVpvn("# comment\n",10);
2411 U8* tend = t + tlen;
2412 U8* rend = r + rlen;
2426 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2427 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2433 tsave = t = bytes_to_utf8(t, &len);
2436 if (!to_utf && rlen) {
2438 rsave = r = bytes_to_utf8(r, &len);
2442 /* There are several snags with this code on EBCDIC:
2443 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2444 2. scan_const() in toke.c has encoded chars in native encoding which makes
2445 ranges at least in EBCDIC 0..255 range the bottom odd.
2449 U8 tmpbuf[UTF8_MAXBYTES+1];
2452 New(1109, cp, 2*tlen, UV);
2454 transv = newSVpvn("",0);
2456 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2458 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2460 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2464 cp[2*i+1] = cp[2*i];
2468 qsort(cp, i, 2*sizeof(UV), uvcompare);
2469 for (j = 0; j < i; j++) {
2471 diff = val - nextmin;
2473 t = uvuni_to_utf8(tmpbuf,nextmin);
2474 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2476 U8 range_mark = UTF_TO_NATIVE(0xff);
2477 t = uvuni_to_utf8(tmpbuf, val - 1);
2478 sv_catpvn(transv, (char *)&range_mark, 1);
2479 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2486 t = uvuni_to_utf8(tmpbuf,nextmin);
2487 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2489 U8 range_mark = UTF_TO_NATIVE(0xff);
2490 sv_catpvn(transv, (char *)&range_mark, 1);
2492 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2493 UNICODE_ALLOW_SUPER);
2494 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2495 t = (U8*)SvPVX(transv);
2496 tlen = SvCUR(transv);
2500 else if (!rlen && !del) {
2501 r = t; rlen = tlen; rend = tend;
2504 if ((!rlen && !del) || t == r ||
2505 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2507 o->op_private |= OPpTRANS_IDENTICAL;
2511 while (t < tend || tfirst <= tlast) {
2512 /* see if we need more "t" chars */
2513 if (tfirst > tlast) {
2514 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2516 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2518 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2525 /* now see if we need more "r" chars */
2526 if (rfirst > rlast) {
2528 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2530 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2532 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2541 rfirst = rlast = 0xffffffff;
2545 /* now see which range will peter our first, if either. */
2546 tdiff = tlast - tfirst;
2547 rdiff = rlast - rfirst;
2554 if (rfirst == 0xffffffff) {
2555 diff = tdiff; /* oops, pretend rdiff is infinite */
2557 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2558 (long)tfirst, (long)tlast);
2560 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2564 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2565 (long)tfirst, (long)(tfirst + diff),
2568 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2569 (long)tfirst, (long)rfirst);
2571 if (rfirst + diff > max)
2572 max = rfirst + diff;
2574 grows = (tfirst < rfirst &&
2575 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2587 else if (max > 0xff)
2592 Safefree(cPVOPo->op_pv);
2593 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2594 SvREFCNT_dec(listsv);
2596 SvREFCNT_dec(transv);
2598 if (!del && havefinal && rlen)
2599 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2600 newSVuv((UV)final), 0);
2603 o->op_private |= OPpTRANS_GROWS;
2615 tbl = (short*)cPVOPo->op_pv;
2617 Zero(tbl, 256, short);
2618 for (i = 0; i < (I32)tlen; i++)
2620 for (i = 0, j = 0; i < 256; i++) {
2622 if (j >= (I32)rlen) {
2631 if (i < 128 && r[j] >= 128)
2641 o->op_private |= OPpTRANS_IDENTICAL;
2643 else if (j >= (I32)rlen)
2646 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2647 tbl[0x100] = rlen - j;
2648 for (i=0; i < (I32)rlen - j; i++)
2649 tbl[0x101+i] = r[j+i];
2653 if (!rlen && !del) {
2656 o->op_private |= OPpTRANS_IDENTICAL;
2658 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2659 o->op_private |= OPpTRANS_IDENTICAL;
2661 for (i = 0; i < 256; i++)
2663 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
2664 if (j >= (I32)rlen) {
2666 if (tbl[t[i]] == -1)
2672 if (tbl[t[i]] == -1) {
2673 if (t[i] < 128 && r[j] >= 128)
2680 o->op_private |= OPpTRANS_GROWS;
2688 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2693 NewOp(1101, pmop, 1, PMOP);
2694 pmop->op_type = (OPCODE)type;
2695 pmop->op_ppaddr = PL_ppaddr[type];
2696 pmop->op_flags = (U8)flags;
2697 pmop->op_private = (U8)(0 | (flags >> 8));
2699 if (PL_hints & HINT_RE_TAINT)
2700 pmop->op_pmpermflags |= PMf_RETAINT;
2701 if (PL_hints & HINT_LOCALE)
2702 pmop->op_pmpermflags |= PMf_LOCALE;
2703 pmop->op_pmflags = pmop->op_pmpermflags;
2708 if(av_len((AV*) PL_regex_pad[0]) > -1) {
2709 repointer = av_pop((AV*)PL_regex_pad[0]);
2710 pmop->op_pmoffset = SvIV(repointer);
2711 SvREPADTMP_off(repointer);
2712 sv_setiv(repointer,0);
2714 repointer = newSViv(0);
2715 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2716 pmop->op_pmoffset = av_len(PL_regex_padav);
2717 PL_regex_pad = AvARRAY(PL_regex_padav);
2722 /* link into pm list */
2723 if (type != OP_TRANS && PL_curstash) {
2724 MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab);
2727 mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0);
2729 pmop->op_pmnext = (PMOP*)mg->mg_obj;
2730 mg->mg_obj = (SV*)pmop;
2731 PmopSTASH_set(pmop,PL_curstash);
2734 return CHECKOP(type, pmop);
2737 /* Given some sort of match op o, and an expression expr containing a
2738 * pattern, either compile expr into a regex and attach it to o (if it's
2739 * constant), or convert expr into a runtime regcomp op sequence (if it's
2742 * isreg indicates that the pattern is part of a regex construct, eg
2743 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
2744 * split "pattern", which aren't. In the former case, expr will be a list
2745 * if the pattern contains more than one term (eg /a$b/) or if it contains
2746 * a replacement, ie s/// or tr///.
2750 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
2755 I32 repl_has_vars = 0;
2759 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
2760 /* last element in list is the replacement; pop it */
2762 repl = cLISTOPx(expr)->op_last;
2763 kid = cLISTOPx(expr)->op_first;
2764 while (kid->op_sibling != repl)
2765 kid = kid->op_sibling;
2766 kid->op_sibling = Nullop;
2767 cLISTOPx(expr)->op_last = kid;
2770 if (isreg && expr->op_type == OP_LIST &&
2771 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
2773 /* convert single element list to element */
2775 expr = cLISTOPx(oe)->op_first->op_sibling;
2776 cLISTOPx(oe)->op_first->op_sibling = Nullop;
2777 cLISTOPx(oe)->op_last = Nullop;
2781 if (o->op_type == OP_TRANS) {
2782 return pmtrans(o, expr, repl);
2785 reglist = isreg && expr->op_type == OP_LIST;
2789 PL_hints |= HINT_BLOCK_SCOPE;
2792 if (expr->op_type == OP_CONST) {
2794 SV *pat = ((SVOP*)expr)->op_sv;
2795 char *p = SvPV(pat, plen);
2796 if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
2797 sv_setpvn(pat, "\\s+", 3);
2798 p = SvPV(pat, plen);
2799 pm->op_pmflags |= PMf_SKIPWHITE;
2802 pm->op_pmdynflags |= PMdf_UTF8;
2803 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
2804 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
2805 pm->op_pmflags |= PMf_WHITE;
2809 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2810 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2812 : OP_REGCMAYBE),0,expr);
2814 NewOp(1101, rcop, 1, LOGOP);
2815 rcop->op_type = OP_REGCOMP;
2816 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2817 rcop->op_first = scalar(expr);
2818 rcop->op_flags |= OPf_KIDS
2819 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
2820 | (reglist ? OPf_STACKED : 0);
2821 rcop->op_private = 1;
2824 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
2826 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
2829 /* establish postfix order */
2830 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2832 rcop->op_next = expr;
2833 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2836 rcop->op_next = LINKLIST(expr);
2837 expr->op_next = (OP*)rcop;
2840 prepend_elem(o->op_type, scalar((OP*)rcop), o);
2845 if (pm->op_pmflags & PMf_EVAL) {
2847 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
2848 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
2850 else if (repl->op_type == OP_CONST)
2854 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
2855 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
2856 if (curop->op_type == OP_GV) {
2857 GV *gv = cGVOPx_gv(curop);
2859 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
2862 else if (curop->op_type == OP_RV2CV)
2864 else if (curop->op_type == OP_RV2SV ||
2865 curop->op_type == OP_RV2AV ||
2866 curop->op_type == OP_RV2HV ||
2867 curop->op_type == OP_RV2GV) {
2868 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2871 else if (curop->op_type == OP_PADSV ||
2872 curop->op_type == OP_PADAV ||
2873 curop->op_type == OP_PADHV ||
2874 curop->op_type == OP_PADANY) {
2877 else if (curop->op_type == OP_PUSHRE)
2878 ; /* Okay here, dangerous in newASSIGNOP */
2888 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
2889 pm->op_pmflags |= PMf_CONST; /* const for long enough */
2890 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
2891 prepend_elem(o->op_type, scalar(repl), o);
2894 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
2895 pm->op_pmflags |= PMf_MAYBE_CONST;
2896 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2898 NewOp(1101, rcop, 1, LOGOP);
2899 rcop->op_type = OP_SUBSTCONT;
2900 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
2901 rcop->op_first = scalar(repl);
2902 rcop->op_flags |= OPf_KIDS;
2903 rcop->op_private = 1;
2906 /* establish postfix order */
2907 rcop->op_next = LINKLIST(repl);
2908 repl->op_next = (OP*)rcop;
2910 pm->op_pmreplroot = scalar((OP*)rcop);
2911 pm->op_pmreplstart = LINKLIST(rcop);
2920 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
2924 NewOp(1101, svop, 1, SVOP);
2925 svop->op_type = (OPCODE)type;
2926 svop->op_ppaddr = PL_ppaddr[type];
2928 svop->op_next = (OP*)svop;
2929 svop->op_flags = (U8)flags;
2930 if (PL_opargs[type] & OA_RETSCALAR)
2932 if (PL_opargs[type] & OA_TARGET)
2933 svop->op_targ = pad_alloc(type, SVs_PADTMP);
2934 return CHECKOP(type, svop);
2938 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2942 NewOp(1101, padop, 1, PADOP);
2943 padop->op_type = (OPCODE)type;
2944 padop->op_ppaddr = PL_ppaddr[type];
2945 padop->op_padix = pad_alloc(type, SVs_PADTMP);
2946 SvREFCNT_dec(PAD_SVl(padop->op_padix));
2947 PAD_SETSV(padop->op_padix, sv);
2950 padop->op_next = (OP*)padop;
2951 padop->op_flags = (U8)flags;
2952 if (PL_opargs[type] & OA_RETSCALAR)
2954 if (PL_opargs[type] & OA_TARGET)
2955 padop->op_targ = pad_alloc(type, SVs_PADTMP);
2956 return CHECKOP(type, padop);
2960 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
2966 return newPADOP(type, flags, SvREFCNT_inc(gv));
2968 return newSVOP(type, flags, SvREFCNT_inc(gv));
2973 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
2977 NewOp(1101, pvop, 1, PVOP);
2978 pvop->op_type = (OPCODE)type;
2979 pvop->op_ppaddr = PL_ppaddr[type];
2981 pvop->op_next = (OP*)pvop;
2982 pvop->op_flags = (U8)flags;
2983 if (PL_opargs[type] & OA_RETSCALAR)
2985 if (PL_opargs[type] & OA_TARGET)
2986 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
2987 return CHECKOP(type, pvop);
2991 Perl_package(pTHX_ OP *o)
2996 save_hptr(&PL_curstash);
2997 save_item(PL_curstname);
2999 name = SvPV(cSVOPo->op_sv, len);
3000 PL_curstash = gv_stashpvn(name, len, TRUE);
3001 sv_setpvn(PL_curstname, name, len);
3004 PL_hints |= HINT_BLOCK_SCOPE;
3005 PL_copline = NOLINE;
3010 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3016 if (idop->op_type != OP_CONST)
3017 Perl_croak(aTHX_ "Module name must be constant");
3021 if (version != Nullop) {
3022 SV *vesv = ((SVOP*)version)->op_sv;
3024 if (arg == Nullop && !SvNIOKp(vesv)) {
3031 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3032 Perl_croak(aTHX_ "Version number must be constant number");
3034 /* Make copy of idop so we don't free it twice */
3035 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3037 /* Fake up a method call to VERSION */
3038 meth = newSVpvn("VERSION",7);
3039 sv_upgrade(meth, SVt_PVIV);
3040 (void)SvIOK_on(meth);
3043 PERL_HASH(hash, SvPVX_const(meth), SvCUR(meth));
3044 SvUV_set(meth, hash);
3046 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3047 append_elem(OP_LIST,
3048 prepend_elem(OP_LIST, pack, list(version)),
3049 newSVOP(OP_METHOD_NAMED, 0, meth)));
3053 /* Fake up an import/unimport */
3054 if (arg && arg->op_type == OP_STUB)
3055 imop = arg; /* no import on explicit () */
3056 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3057 imop = Nullop; /* use 5.0; */
3062 /* Make copy of idop so we don't free it twice */
3063 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3065 /* Fake up a method call to import/unimport */
3066 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);
3067 (void)SvUPGRADE(meth, SVt_PVIV);
3068 (void)SvIOK_on(meth);
3071 PERL_HASH(hash, SvPVX_const(meth), SvCUR(meth));
3072 SvUV_set(meth, hash);
3074 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3075 append_elem(OP_LIST,
3076 prepend_elem(OP_LIST, pack, list(arg)),
3077 newSVOP(OP_METHOD_NAMED, 0, meth)));
3080 /* Fake up the BEGIN {}, which does its thing immediately. */
3082 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3085 append_elem(OP_LINESEQ,
3086 append_elem(OP_LINESEQ,
3087 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, idop)),
3088 newSTATEOP(0, Nullch, veop)),
3089 newSTATEOP(0, Nullch, imop) ));
3091 /* The "did you use incorrect case?" warning used to be here.
3092 * The problem is that on case-insensitive filesystems one
3093 * might get false positives for "use" (and "require"):
3094 * "use Strict" or "require CARP" will work. This causes
3095 * portability problems for the script: in case-strict
3096 * filesystems the script will stop working.
3098 * The "incorrect case" warning checked whether "use Foo"
3099 * imported "Foo" to your namespace, but that is wrong, too:
3100 * there is no requirement nor promise in the language that
3101 * a Foo.pm should or would contain anything in package "Foo".
3103 * There is very little Configure-wise that can be done, either:
3104 * the case-sensitivity of the build filesystem of Perl does not
3105 * help in guessing the case-sensitivity of the runtime environment.
3108 PL_hints |= HINT_BLOCK_SCOPE;
3109 PL_copline = NOLINE;
3111 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3115 =head1 Embedding Functions
3117 =for apidoc load_module
3119 Loads the module whose name is pointed to by the string part of name.
3120 Note that the actual module name, not its filename, should be given.
3121 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3122 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3123 (or 0 for no flags). ver, if specified, provides version semantics
3124 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3125 arguments can be used to specify arguments to the module's import()
3126 method, similar to C<use Foo::Bar VERSION LIST>.
3131 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3134 va_start(args, ver);
3135 vload_module(flags, name, ver, &args);
3139 #ifdef PERL_IMPLICIT_CONTEXT
3141 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3145 va_start(args, ver);
3146 vload_module(flags, name, ver, &args);
3152 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3154 OP *modname, *veop, *imop;
3156 modname = newSVOP(OP_CONST, 0, name);
3157 modname->op_private |= OPpCONST_BARE;
3159 veop = newSVOP(OP_CONST, 0, ver);
3163 if (flags & PERL_LOADMOD_NOIMPORT) {
3164 imop = sawparens(newNULLLIST());
3166 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3167 imop = va_arg(*args, OP*);
3172 sv = va_arg(*args, SV*);
3174 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3175 sv = va_arg(*args, SV*);
3179 const line_t ocopline = PL_copline;
3180 COP * const ocurcop = PL_curcop;
3181 const int oexpect = PL_expect;
3183 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3184 veop, modname, imop);
3185 PL_expect = oexpect;
3186 PL_copline = ocopline;
3187 PL_curcop = ocurcop;
3192 Perl_dofile(pTHX_ OP *term)
3197 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3198 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
3199 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3201 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3202 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3203 append_elem(OP_LIST, term,
3204 scalar(newUNOP(OP_RV2CV, 0,
3209 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3215 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3217 return newBINOP(OP_LSLICE, flags,
3218 list(force_list(subscript)),
3219 list(force_list(listval)) );
3223 S_is_list_assignment(pTHX_ register const OP *o)
3228 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3229 o = cUNOPo->op_first;
3231 if (o->op_type == OP_COND_EXPR) {
3232 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3233 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3238 yyerror("Assignment to both a list and a scalar");
3242 if (o->op_type == OP_LIST &&
3243 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3244 o->op_private & OPpLVAL_INTRO)
3247 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3248 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3249 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3252 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3255 if (o->op_type == OP_RV2SV)
3262 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3267 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3268 return newLOGOP(optype, 0,
3269 mod(scalar(left), optype),
3270 newUNOP(OP_SASSIGN, 0, scalar(right)));
3273 return newBINOP(optype, OPf_STACKED,
3274 mod(scalar(left), optype), scalar(right));
3278 if (is_list_assignment(left)) {
3282 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3283 left = mod(left, OP_AASSIGN);
3291 /* optimise C<my @x = ()> to C<my @x>, and likewise for hashes */
3292 if ((left->op_type == OP_PADAV || left->op_type == OP_PADHV)
3293 && right->op_type == OP_STUB
3294 && (left->op_private & OPpLVAL_INTRO))
3297 left->op_flags &= ~(OPf_REF|OPf_SPECIAL);
3300 curop = list(force_list(left));
3301 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3302 o->op_private = (U8)(0 | (flags >> 8));
3304 /* PL_generation sorcery:
3305 * an assignment like ($a,$b) = ($c,$d) is easier than
3306 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3307 * To detect whether there are common vars, the global var
3308 * PL_generation is incremented for each assign op we compile.
3309 * Then, while compiling the assign op, we run through all the
3310 * variables on both sides of the assignment, setting a spare slot
3311 * in each of them to PL_generation. If any of them already have
3312 * that value, we know we've got commonality. We could use a
3313 * single bit marker, but then we'd have to make 2 passes, first
3314 * to clear the flag, then to test and set it. To find somewhere
3315 * to store these values, evil chicanery is done with SvCUR().
3318 if (!(left->op_private & OPpLVAL_INTRO)) {
3321 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3322 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3323 if (curop->op_type == OP_GV) {
3324 GV *gv = cGVOPx_gv(curop);
3325 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3327 SvCUR_set(gv, PL_generation);
3329 else if (curop->op_type == OP_PADSV ||
3330 curop->op_type == OP_PADAV ||
3331 curop->op_type == OP_PADHV ||
3332 curop->op_type == OP_PADANY)
3334 if (PAD_COMPNAME_GEN(curop->op_targ)
3335 == (STRLEN)PL_generation)
3337 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
3340 else if (curop->op_type == OP_RV2CV)
3342 else if (curop->op_type == OP_RV2SV ||
3343 curop->op_type == OP_RV2AV ||
3344 curop->op_type == OP_RV2HV ||
3345 curop->op_type == OP_RV2GV) {
3346 if (lastop->op_type != OP_GV) /* funny deref? */
3349 else if (curop->op_type == OP_PUSHRE) {
3350 if (((PMOP*)curop)->op_pmreplroot) {
3352 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3353 ((PMOP*)curop)->op_pmreplroot));
3355 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3357 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3359 SvCUR_set(gv, PL_generation);
3368 o->op_private |= OPpASSIGN_COMMON;
3370 if (right && right->op_type == OP_SPLIT) {
3372 if ((tmpop = ((LISTOP*)right)->op_first) &&
3373 tmpop->op_type == OP_PUSHRE)
3375 PMOP *pm = (PMOP*)tmpop;
3376 if (left->op_type == OP_RV2AV &&
3377 !(left->op_private & OPpLVAL_INTRO) &&
3378 !(o->op_private & OPpASSIGN_COMMON) )
3380 tmpop = ((UNOP*)left)->op_first;
3381 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3383 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3384 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3386 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3387 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3389 pm->op_pmflags |= PMf_ONCE;
3390 tmpop = cUNOPo->op_first; /* to list (nulled) */
3391 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3392 tmpop->op_sibling = Nullop; /* don't free split */
3393 right->op_next = tmpop->op_next; /* fix starting loc */
3394 op_free(o); /* blow off assign */
3395 right->op_flags &= ~OPf_WANT;
3396 /* "I don't know and I don't care." */
3401 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3402 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3404 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3406 sv_setiv(sv, PL_modcount+1);
3414 right = newOP(OP_UNDEF, 0);
3415 if (right->op_type == OP_READLINE) {
3416 right->op_flags |= OPf_STACKED;
3417 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3420 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3421 o = newBINOP(OP_SASSIGN, flags,
3422 scalar(right), mod(scalar(left), OP_SASSIGN) );
3434 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3437 const U32 seq = intro_my();
3440 NewOp(1101, cop, 1, COP);
3441 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3442 cop->op_type = OP_DBSTATE;
3443 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3446 cop->op_type = OP_NEXTSTATE;
3447 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3449 cop->op_flags = (U8)flags;
3450 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3452 cop->op_private |= NATIVE_HINTS;
3454 PL_compiling.op_private = cop->op_private;
3455 cop->op_next = (OP*)cop;
3458 cop->cop_label = label;
3459 PL_hints |= HINT_BLOCK_SCOPE;
3462 cop->cop_arybase = PL_curcop->cop_arybase;
3463 if (specialWARN(PL_curcop->cop_warnings))
3464 cop->cop_warnings = PL_curcop->cop_warnings ;
3466 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3467 if (specialCopIO(PL_curcop->cop_io))
3468 cop->cop_io = PL_curcop->cop_io;
3470 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3473 if (PL_copline == NOLINE)
3474 CopLINE_set(cop, CopLINE(PL_curcop));
3476 CopLINE_set(cop, PL_copline);
3477 PL_copline = NOLINE;
3480 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3482 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3484 CopSTASH_set(cop, PL_curstash);
3486 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3487 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3488 if (svp && *svp != &PL_sv_undef ) {
3489 (void)SvIOK_on(*svp);
3490 SvIV_set(*svp, PTR2IV(cop));
3494 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3499 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3502 return new_logop(type, flags, &first, &other);
3506 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3511 OP *first = *firstp;
3512 OP *other = *otherp;
3514 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3515 return newBINOP(type, flags, scalar(first), scalar(other));
3517 scalarboolean(first);
3518 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3519 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3520 if (type == OP_AND || type == OP_OR) {
3526 first = *firstp = cUNOPo->op_first;
3528 first->op_next = o->op_next;
3529 cUNOPo->op_first = Nullop;
3533 if (first->op_type == OP_CONST) {
3534 if (first->op_private & OPpCONST_STRICT)
3535 no_bareword_allowed(first);
3536 else if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3537 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3538 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
3539 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
3540 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
3543 if (other->op_type == OP_CONST)
3544 other->op_private |= OPpCONST_SHORTCIRCUIT;
3548 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
3549 const OP *o2 = other;
3550 if ( ! (o2->op_type == OP_LIST
3551 && (( o2 = cUNOPx(o2)->op_first))
3552 && o2->op_type == OP_PUSHMARK
3553 && (( o2 = o2->op_sibling)) )
3556 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
3557 || o2->op_type == OP_PADHV)
3558 && o2->op_private & OPpLVAL_INTRO
3559 && ckWARN(WARN_DEPRECATED))
3561 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
3562 "Deprecated use of my() in false conditional");
3567 if (first->op_type == OP_CONST)
3568 first->op_private |= OPpCONST_SHORTCIRCUIT;
3572 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS) &&
3573 type != OP_DOR) /* [#24076] Don't warn for <FH> err FOO. */
3575 const OP *k1 = ((UNOP*)first)->op_first;
3576 const OP *k2 = k1->op_sibling;
3578 switch (first->op_type)
3581 if (k2 && k2->op_type == OP_READLINE
3582 && (k2->op_flags & OPf_STACKED)
3583 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3585 warnop = k2->op_type;
3590 if (k1->op_type == OP_READDIR
3591 || k1->op_type == OP_GLOB
3592 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3593 || k1->op_type == OP_EACH)
3595 warnop = ((k1->op_type == OP_NULL)
3596 ? (OPCODE)k1->op_targ : k1->op_type);
3601 const line_t oldline = CopLINE(PL_curcop);
3602 CopLINE_set(PL_curcop, PL_copline);
3603 Perl_warner(aTHX_ packWARN(WARN_MISC),
3604 "Value of %s%s can be \"0\"; test with defined()",
3606 ((warnop == OP_READLINE || warnop == OP_GLOB)
3607 ? " construct" : "() operator"));
3608 CopLINE_set(PL_curcop, oldline);
3615 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3616 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3618 NewOp(1101, logop, 1, LOGOP);
3620 logop->op_type = (OPCODE)type;
3621 logop->op_ppaddr = PL_ppaddr[type];
3622 logop->op_first = first;
3623 logop->op_flags = flags | OPf_KIDS;
3624 logop->op_other = LINKLIST(other);
3625 logop->op_private = (U8)(1 | (flags >> 8));
3627 /* establish postfix order */
3628 logop->op_next = LINKLIST(first);
3629 first->op_next = (OP*)logop;
3630 first->op_sibling = other;
3632 CHECKOP(type,logop);
3634 o = newUNOP(OP_NULL, 0, (OP*)logop);
3641 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3649 return newLOGOP(OP_AND, 0, first, trueop);
3651 return newLOGOP(OP_OR, 0, first, falseop);
3653 scalarboolean(first);
3654 if (first->op_type == OP_CONST) {
3655 if (first->op_private & OPpCONST_BARE &&
3656 first->op_private & OPpCONST_STRICT) {
3657 no_bareword_allowed(first);
3659 if (SvTRUE(((SVOP*)first)->op_sv)) {
3670 NewOp(1101, logop, 1, LOGOP);
3671 logop->op_type = OP_COND_EXPR;
3672 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3673 logop->op_first = first;
3674 logop->op_flags = flags | OPf_KIDS;
3675 logop->op_private = (U8)(1 | (flags >> 8));
3676 logop->op_other = LINKLIST(trueop);
3677 logop->op_next = LINKLIST(falseop);
3679 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
3682 /* establish postfix order */
3683 start = LINKLIST(first);
3684 first->op_next = (OP*)logop;
3686 first->op_sibling = trueop;
3687 trueop->op_sibling = falseop;
3688 o = newUNOP(OP_NULL, 0, (OP*)logop);
3690 trueop->op_next = falseop->op_next = o;
3697 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3706 NewOp(1101, range, 1, LOGOP);
3708 range->op_type = OP_RANGE;
3709 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3710 range->op_first = left;
3711 range->op_flags = OPf_KIDS;
3712 leftstart = LINKLIST(left);
3713 range->op_other = LINKLIST(right);
3714 range->op_private = (U8)(1 | (flags >> 8));
3716 left->op_sibling = right;
3718 range->op_next = (OP*)range;
3719 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3720 flop = newUNOP(OP_FLOP, 0, flip);
3721 o = newUNOP(OP_NULL, 0, flop);
3723 range->op_next = leftstart;
3725 left->op_next = flip;
3726 right->op_next = flop;
3728 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3729 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3730 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3731 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3733 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3734 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3737 if (!flip->op_private || !flop->op_private)
3738 linklist(o); /* blow off optimizer unless constant */
3744 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3748 const bool once = block && block->op_flags & OPf_SPECIAL &&
3749 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3753 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3754 return block; /* do {} while 0 does once */
3755 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3756 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3757 expr = newUNOP(OP_DEFINED, 0,
3758 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3759 } else if (expr->op_flags & OPf_KIDS) {
3760 const OP *k1 = ((UNOP*)expr)->op_first;
3761 const OP *k2 = (k1) ? k1->op_sibling : NULL;
3762 switch (expr->op_type) {
3764 if (k2 && k2->op_type == OP_READLINE
3765 && (k2->op_flags & OPf_STACKED)
3766 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3767 expr = newUNOP(OP_DEFINED, 0, expr);
3771 if (k1->op_type == OP_READDIR
3772 || k1->op_type == OP_GLOB
3773 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3774 || k1->op_type == OP_EACH)
3775 expr = newUNOP(OP_DEFINED, 0, expr);
3781 /* if block is null, the next append_elem() would put UNSTACK, a scalar
3782 * op, in listop. This is wrong. [perl #27024] */
3784 block = newOP(OP_NULL, 0);
3785 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3786 o = new_logop(OP_AND, 0, &expr, &listop);
3789 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3791 if (once && o != listop)
3792 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3795 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3797 o->op_flags |= flags;
3799 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3804 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
3805 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
3815 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3816 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3817 expr = newUNOP(OP_DEFINED, 0,
3818 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3819 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3820 const OP *k1 = ((UNOP*)expr)->op_first;
3821 const OP *k2 = (k1) ? k1->op_sibling : NULL;
3822 switch (expr->op_type) {
3824 if (k2 && k2->op_type == OP_READLINE
3825 && (k2->op_flags & OPf_STACKED)
3826 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3827 expr = newUNOP(OP_DEFINED, 0, expr);
3831 if (k1->op_type == OP_READDIR
3832 || k1->op_type == OP_GLOB
3833 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3834 || k1->op_type == OP_EACH)
3835 expr = newUNOP(OP_DEFINED, 0, expr);
3841 block = newOP(OP_NULL, 0);
3842 else if (cont || has_my) {
3843 block = scope(block);
3847 next = LINKLIST(cont);
3850 OP *unstack = newOP(OP_UNSTACK, 0);
3853 cont = append_elem(OP_LINESEQ, cont, unstack);
3856 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3857 redo = LINKLIST(listop);
3860 PL_copline = (line_t)whileline;
3862 o = new_logop(OP_AND, 0, &expr, &listop);
3863 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3864 op_free(expr); /* oops, it's a while (0) */
3866 return Nullop; /* listop already freed by new_logop */
3869 ((LISTOP*)listop)->op_last->op_next =
3870 (o == listop ? redo : LINKLIST(o));
3876 NewOp(1101,loop,1,LOOP);
3877 loop->op_type = OP_ENTERLOOP;
3878 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3879 loop->op_private = 0;
3880 loop->op_next = (OP*)loop;
3883 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3885 loop->op_redoop = redo;
3886 loop->op_lastop = o;
3887 o->op_private |= loopflags;
3890 loop->op_nextop = next;
3892 loop->op_nextop = o;
3894 o->op_flags |= flags;
3895 o->op_private |= (flags >> 8);
3900 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
3905 PADOFFSET padoff = 0;
3910 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
3911 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
3912 sv->op_type = OP_RV2GV;
3913 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3915 else if (sv->op_type == OP_PADSV) { /* private variable */
3916 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
3917 padoff = sv->op_targ;
3922 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3923 padoff = sv->op_targ;
3925 iterflags |= OPf_SPECIAL;
3930 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3933 const I32 offset = pad_findmy("$_");
3934 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
3935 sv = newGVOP(OP_GV, 0, PL_defgv);
3941 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3942 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3943 iterflags |= OPf_STACKED;
3945 else if (expr->op_type == OP_NULL &&
3946 (expr->op_flags & OPf_KIDS) &&
3947 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3949 /* Basically turn for($x..$y) into the same as for($x,$y), but we
3950 * set the STACKED flag to indicate that these values are to be
3951 * treated as min/max values by 'pp_iterinit'.
3953 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
3954 LOGOP* range = (LOGOP*) flip->op_first;
3955 OP* left = range->op_first;
3956 OP* right = left->op_sibling;
3959 range->op_flags &= ~OPf_KIDS;
3960 range->op_first = Nullop;
3962 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
3963 listop->op_first->op_next = range->op_next;
3964 left->op_next = range->op_other;
3965 right->op_next = (OP*)listop;
3966 listop->op_next = listop->op_first;
3969 expr = (OP*)(listop);
3971 iterflags |= OPf_STACKED;
3974 expr = mod(force_list(expr), OP_GREPSTART);
3977 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
3978 append_elem(OP_LIST, expr, scalar(sv))));
3979 assert(!loop->op_next);
3980 /* for my $x () sets OPpLVAL_INTRO;
3981 * for our $x () sets OPpOUR_INTRO */
3982 loop->op_private = (U8)iterpflags;
3983 #ifdef PL_OP_SLAB_ALLOC
3986 NewOp(1234,tmp,1,LOOP);
3987 Copy(loop,tmp,1,LISTOP);
3992 Renew(loop, 1, LOOP);
3994 loop->op_targ = padoff;
3995 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
3996 PL_copline = forline;
3997 return newSTATEOP(0, label, wop);
4001 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4006 if (type != OP_GOTO || label->op_type == OP_CONST) {
4007 /* "last()" means "last" */
4008 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4009 o = newOP(type, OPf_SPECIAL);
4011 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4012 ? SvPVx(((SVOP*)label)->op_sv, n_a)
4018 /* Check whether it's going to be a goto &function */
4019 if (label->op_type == OP_ENTERSUB
4020 && !(label->op_flags & OPf_STACKED))
4021 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4022 o = newUNOP(type, OPf_STACKED, label);
4024 PL_hints |= HINT_BLOCK_SCOPE;
4029 =for apidoc cv_undef
4031 Clear out all the active components of a CV. This can happen either
4032 by an explicit C<undef &foo>, or by the reference count going to zero.
4033 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4034 children can still follow the full lexical scope chain.
4040 Perl_cv_undef(pTHX_ CV *cv)
4044 if (CvFILE(cv) && !CvXSUB(cv)) {
4045 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4046 Safefree(CvFILE(cv));
4051 if (!CvXSUB(cv) && CvROOT(cv)) {
4053 Perl_croak(aTHX_ "Can't undef active subroutine");
4056 PAD_SAVE_SETNULLPAD();
4058 op_free(CvROOT(cv));
4059 CvROOT(cv) = Nullop;
4060 CvSTART(cv) = Nullop;
4063 SvPOK_off((SV*)cv); /* forget prototype */
4068 /* remove CvOUTSIDE unless this is an undef rather than a free */
4069 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4070 if (!CvWEAKOUTSIDE(cv))
4071 SvREFCNT_dec(CvOUTSIDE(cv));
4072 CvOUTSIDE(cv) = Nullcv;
4075 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4081 /* delete all flags except WEAKOUTSIDE */
4082 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4086 Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p)
4088 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX_const(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4089 SV* msg = sv_newmortal();
4093 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4094 sv_setpv(msg, "Prototype mismatch:");
4096 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4098 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (const SV *)cv);
4100 Perl_sv_catpv(aTHX_ msg, ": none");
4101 sv_catpv(msg, " vs ");
4103 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4105 sv_catpv(msg, "none");
4106 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
4110 static void const_sv_xsub(pTHX_ CV* cv);
4114 =head1 Optree Manipulation Functions
4116 =for apidoc cv_const_sv
4118 If C<cv> is a constant sub eligible for inlining. returns the constant
4119 value returned by the sub. Otherwise, returns NULL.
4121 Constant subs can be created with C<newCONSTSUB> or as described in
4122 L<perlsub/"Constant Functions">.
4127 Perl_cv_const_sv(pTHX_ CV *cv)
4129 if (!cv || !CvCONST(cv))
4131 return (SV*)CvXSUBANY(cv).any_ptr;
4134 /* op_const_sv: examine an optree to determine whether it's in-lineable.
4135 * Can be called in 3 ways:
4138 * look for a single OP_CONST with attached value: return the value
4140 * cv && CvCLONE(cv) && !CvCONST(cv)
4142 * examine the clone prototype, and if contains only a single
4143 * OP_CONST referencing a pad const, or a single PADSV referencing
4144 * an outer lexical, return a non-zero value to indicate the CV is
4145 * a candidate for "constizing" at clone time
4149 * We have just cloned an anon prototype that was marked as a const
4150 * candidiate. Try to grab the current value, and in the case of
4151 * PADSV, ignore it if it has multiple references. Return the value.
4155 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
4162 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4163 o = cLISTOPo->op_first->op_sibling;
4165 for (; o; o = o->op_next) {
4166 OPCODE type = o->op_type;
4168 if (sv && o->op_next == o)
4170 if (o->op_next != o) {
4171 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4173 if (type == OP_DBSTATE)
4176 if (type == OP_LEAVESUB || type == OP_RETURN)
4180 if (type == OP_CONST && cSVOPo->op_sv)
4182 else if (cv && type == OP_CONST) {
4183 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4187 else if (cv && type == OP_PADSV) {
4188 if (CvCONST(cv)) { /* newly cloned anon */
4189 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4190 /* the candidate should have 1 ref from this pad and 1 ref
4191 * from the parent */
4192 if (!sv || SvREFCNT(sv) != 2)
4199 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4200 sv = &PL_sv_undef; /* an arbitrary non-null value */
4211 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4222 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4226 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4228 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4232 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4243 const char * const name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4246 assert(proto->op_type == OP_CONST);
4247 ps = SvPVx(((SVOP*)proto)->op_sv, ps_len);
4252 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4253 SV *sv = sv_newmortal();
4254 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4255 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4256 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4257 aname = SvPVX_const(sv);
4261 gv = name ? gv_fetchsv(cSVOPo->op_sv,
4262 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4264 : gv_fetchpv(aname ? aname
4265 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4266 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4276 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4277 maximum a prototype before. */
4278 if (SvTYPE(gv) > SVt_NULL) {
4279 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4280 && ckWARN_d(WARN_PROTOTYPE))
4282 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4284 cv_ckproto((CV*)gv, NULL, ps);
4287 sv_setpvn((SV*)gv, ps, ps_len);
4289 sv_setiv((SV*)gv, -1);
4290 SvREFCNT_dec(PL_compcv);
4291 cv = PL_compcv = NULL;
4292 PL_sub_generation++;
4296 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4298 #ifdef GV_UNIQUE_CHECK
4299 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4300 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4304 if (!block || !ps || *ps || attrs)
4307 const_sv = op_const_sv(block, Nullcv);
4310 const bool exists = CvROOT(cv) || CvXSUB(cv);
4312 #ifdef GV_UNIQUE_CHECK
4313 if (exists && GvUNIQUE(gv)) {
4314 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4318 /* if the subroutine doesn't exist and wasn't pre-declared
4319 * with a prototype, assume it will be AUTOLOADed,
4320 * skipping the prototype check
4322 if (exists || SvPOK(cv))
4323 cv_ckproto(cv, gv, ps);
4324 /* already defined (or promised)? */
4325 if (exists || GvASSUMECV(gv)) {
4326 if (!block && !attrs) {
4327 if (CvFLAGS(PL_compcv)) {
4328 /* might have had built-in attrs applied */
4329 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4331 /* just a "sub foo;" when &foo is already defined */
4332 SAVEFREESV(PL_compcv);
4335 /* ahem, death to those who redefine active sort subs */
4336 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4337 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4339 if (ckWARN(WARN_REDEFINE)
4341 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4343 const line_t oldline = CopLINE(PL_curcop);
4344 if (PL_copline != NOLINE)
4345 CopLINE_set(PL_curcop, PL_copline);
4346 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4347 CvCONST(cv) ? "Constant subroutine %s redefined"
4348 : "Subroutine %s redefined", name);
4349 CopLINE_set(PL_curcop, oldline);
4357 (void)SvREFCNT_inc(const_sv);
4359 assert(!CvROOT(cv) && !CvCONST(cv));
4360 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
4361 CvXSUBANY(cv).any_ptr = const_sv;
4362 CvXSUB(cv) = const_sv_xsub;
4367 cv = newCONSTSUB(NULL, name, const_sv);
4370 SvREFCNT_dec(PL_compcv);
4372 PL_sub_generation++;
4379 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4380 * before we clobber PL_compcv.
4384 /* Might have had built-in attributes applied -- propagate them. */
4385 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4386 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4387 stash = GvSTASH(CvGV(cv));
4388 else if (CvSTASH(cv))
4389 stash = CvSTASH(cv);
4391 stash = PL_curstash;
4394 /* possibly about to re-define existing subr -- ignore old cv */
4395 rcv = (SV*)PL_compcv;
4396 if (name && GvSTASH(gv))
4397 stash = GvSTASH(gv);
4399 stash = PL_curstash;
4401 apply_attrs(stash, rcv, attrs, FALSE);
4403 if (cv) { /* must reuse cv if autoloaded */
4405 /* got here with just attrs -- work done, so bug out */
4406 SAVEFREESV(PL_compcv);
4409 /* transfer PL_compcv to cv */
4411 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4412 if (!CvWEAKOUTSIDE(cv))
4413 SvREFCNT_dec(CvOUTSIDE(cv));
4414 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4415 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4416 CvOUTSIDE(PL_compcv) = 0;
4417 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4418 CvPADLIST(PL_compcv) = 0;
4419 /* inner references to PL_compcv must be fixed up ... */
4420 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4421 /* ... before we throw it away */
4422 SvREFCNT_dec(PL_compcv);
4424 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4425 ++PL_sub_generation;
4432 PL_sub_generation++;
4436 CvFILE_set_from_cop(cv, PL_curcop);
4437 CvSTASH(cv) = PL_curstash;
4440 sv_setpvn((SV*)cv, ps, ps_len);
4442 if (PL_error_count) {
4446 const char *s = strrchr(name, ':');
4448 if (strEQ(s, "BEGIN")) {
4449 const char not_safe[] =
4450 "BEGIN not safe after errors--compilation aborted";
4451 if (PL_in_eval & EVAL_KEEPERR)
4452 Perl_croak(aTHX_ not_safe);
4454 /* force display of errors found but not reported */
4455 sv_catpv(ERRSV, not_safe);
4456 Perl_croak(aTHX_ "%"SVf, ERRSV);
4465 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4466 mod(scalarseq(block), OP_LEAVESUBLV));
4469 /* This makes sub {}; work as expected. */
4470 if (block->op_type == OP_STUB) {
4472 block = newSTATEOP(0, Nullch, 0);
4474 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4476 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4477 OpREFCNT_set(CvROOT(cv), 1);
4478 CvSTART(cv) = LINKLIST(CvROOT(cv));
4479 CvROOT(cv)->op_next = 0;
4480 CALL_PEEP(CvSTART(cv));
4482 /* now that optimizer has done its work, adjust pad values */
4484 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4487 assert(!CvCONST(cv));
4488 if (ps && !*ps && op_const_sv(block, cv))
4492 if (name || aname) {
4494 const char *tname = (name ? name : aname);
4496 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4497 SV *sv = NEWSV(0,0);
4498 SV *tmpstr = sv_newmortal();
4499 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4503 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4505 (long)PL_subline, (long)CopLINE(PL_curcop));
4506 gv_efullname3(tmpstr, gv, Nullch);
4507 hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
4508 hv = GvHVn(db_postponed);
4509 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))
4510 && (pcv = GvCV(db_postponed)))
4516 call_sv((SV*)pcv, G_DISCARD);
4520 if ((s = strrchr(tname,':')))
4525 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4528 if (strEQ(s, "BEGIN") && !PL_error_count) {
4529 const I32 oldscope = PL_scopestack_ix;
4531 SAVECOPFILE(&PL_compiling);
4532 SAVECOPLINE(&PL_compiling);
4535 PL_beginav = newAV();
4536 DEBUG_x( dump_sub(gv) );
4537 av_push(PL_beginav, (SV*)cv);
4538 GvCV(gv) = 0; /* cv has been hijacked */
4539 call_list(oldscope, PL_beginav);
4541 PL_curcop = &PL_compiling;
4542 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4545 else if (strEQ(s, "END") && !PL_error_count) {
4548 DEBUG_x( dump_sub(gv) );
4549 av_unshift(PL_endav, 1);
4550 av_store(PL_endav, 0, (SV*)cv);
4551 GvCV(gv) = 0; /* cv has been hijacked */
4553 else if (strEQ(s, "CHECK") && !PL_error_count) {
4555 PL_checkav = newAV();
4556 DEBUG_x( dump_sub(gv) );
4557 if (PL_main_start && ckWARN(WARN_VOID))
4558 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4559 av_unshift(PL_checkav, 1);
4560 av_store(PL_checkav, 0, (SV*)cv);
4561 GvCV(gv) = 0; /* cv has been hijacked */
4563 else if (strEQ(s, "INIT") && !PL_error_count) {
4565 PL_initav = newAV();
4566 DEBUG_x( dump_sub(gv) );
4567 if (PL_main_start && ckWARN(WARN_VOID))
4568 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4569 av_push(PL_initav, (SV*)cv);
4570 GvCV(gv) = 0; /* cv has been hijacked */
4575 PL_copline = NOLINE;
4580 /* XXX unsafe for threads if eval_owner isn't held */
4582 =for apidoc newCONSTSUB
4584 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4585 eligible for inlining at compile-time.
4591 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
4598 SAVECOPLINE(PL_curcop);
4599 CopLINE_set(PL_curcop, PL_copline);
4602 PL_hints &= ~HINT_BLOCK_SCOPE;
4605 SAVESPTR(PL_curstash);
4606 SAVECOPSTASH(PL_curcop);
4607 PL_curstash = stash;
4608 CopSTASH_set(PL_curcop,stash);
4611 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4612 CvXSUBANY(cv).any_ptr = sv;
4614 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
4617 CopSTASH_free(PL_curcop);
4625 =for apidoc U||newXS
4627 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4633 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
4635 GV *gv = gv_fetchpv(name ? name :
4636 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4637 GV_ADDMULTI, SVt_PVCV);
4641 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4643 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4645 /* just a cached method */
4649 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4650 /* already defined (or promised) */
4651 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
4652 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4653 && strEQ(HvNAME_get(GvSTASH(CvGV(cv))), "autouse"))) {
4654 const line_t oldline = CopLINE(PL_curcop);
4655 if (PL_copline != NOLINE)
4656 CopLINE_set(PL_curcop, PL_copline);
4657 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4658 CvCONST(cv) ? "Constant subroutine %s redefined"
4659 : "Subroutine %s redefined"
4661 CopLINE_set(PL_curcop, oldline);
4668 if (cv) /* must reuse cv if autoloaded */
4671 cv = (CV*)NEWSV(1105,0);
4672 sv_upgrade((SV *)cv, SVt_PVCV);
4676 PL_sub_generation++;
4680 (void)gv_fetchfile(filename);
4681 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
4682 an external constant string */
4683 CvXSUB(cv) = subaddr;
4686 const char *s = strrchr(name,':');
4692 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4695 if (strEQ(s, "BEGIN")) {
4697 PL_beginav = newAV();
4698 av_push(PL_beginav, (SV*)cv);
4699 GvCV(gv) = 0; /* cv has been hijacked */
4701 else if (strEQ(s, "END")) {
4704 av_unshift(PL_endav, 1);
4705 av_store(PL_endav, 0, (SV*)cv);
4706 GvCV(gv) = 0; /* cv has been hijacked */
4708 else if (strEQ(s, "CHECK")) {
4710 PL_checkav = newAV();
4711 if (PL_main_start && ckWARN(WARN_VOID))
4712 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4713 av_unshift(PL_checkav, 1);
4714 av_store(PL_checkav, 0, (SV*)cv);
4715 GvCV(gv) = 0; /* cv has been hijacked */
4717 else if (strEQ(s, "INIT")) {
4719 PL_initav = newAV();
4720 if (PL_main_start && ckWARN(WARN_VOID))
4721 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4722 av_push(PL_initav, (SV*)cv);
4723 GvCV(gv) = 0; /* cv has been hijacked */
4734 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4740 gv = gv_fetchsv(cSVOPo->op_sv, TRUE, SVt_PVFM);
4742 gv = gv_fetchpv("STDOUT", TRUE, SVt_PVFM);
4744 #ifdef GV_UNIQUE_CHECK
4746 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4750 if ((cv = GvFORM(gv))) {
4751 if (ckWARN(WARN_REDEFINE)) {
4752 const line_t oldline = CopLINE(PL_curcop);
4753 if (PL_copline != NOLINE)
4754 CopLINE_set(PL_curcop, PL_copline);
4755 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4756 o ? "Format %"SVf" redefined"
4757 : "Format STDOUT redefined" ,cSVOPo->op_sv);
4758 CopLINE_set(PL_curcop, oldline);
4765 CvFILE_set_from_cop(cv, PL_curcop);
4768 pad_tidy(padtidy_FORMAT);
4769 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4770 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4771 OpREFCNT_set(CvROOT(cv), 1);
4772 CvSTART(cv) = LINKLIST(CvROOT(cv));
4773 CvROOT(cv)->op_next = 0;
4774 CALL_PEEP(CvSTART(cv));
4776 PL_copline = NOLINE;
4781 Perl_newANONLIST(pTHX_ OP *o)
4783 return newUNOP(OP_REFGEN, 0,
4784 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4788 Perl_newANONHASH(pTHX_ OP *o)
4790 return newUNOP(OP_REFGEN, 0,
4791 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4795 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4797 return newANONATTRSUB(floor, proto, Nullop, block);
4801 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4803 return newUNOP(OP_REFGEN, 0,
4804 newSVOP(OP_ANONCODE, 0,
4805 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
4809 Perl_oopsAV(pTHX_ OP *o)
4812 switch (o->op_type) {
4814 o->op_type = OP_PADAV;
4815 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4816 return ref(o, OP_RV2AV);
4819 o->op_type = OP_RV2AV;
4820 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4825 if (ckWARN_d(WARN_INTERNAL))
4826 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
4833 Perl_oopsHV(pTHX_ OP *o)
4836 switch (o->op_type) {
4839 o->op_type = OP_PADHV;
4840 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4841 return ref(o, OP_RV2HV);
4845 o->op_type = OP_RV2HV;
4846 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
4851 if (ckWARN_d(WARN_INTERNAL))
4852 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
4859 Perl_newAVREF(pTHX_ OP *o)
4862 if (o->op_type == OP_PADANY) {
4863 o->op_type = OP_PADAV;
4864 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4867 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
4868 && ckWARN(WARN_DEPRECATED)) {
4869 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4870 "Using an array as a reference is deprecated");
4872 return newUNOP(OP_RV2AV, 0, scalar(o));
4876 Perl_newGVREF(pTHX_ I32 type, OP *o)
4878 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
4879 return newUNOP(OP_NULL, 0, o);
4880 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
4884 Perl_newHVREF(pTHX_ OP *o)
4887 if (o->op_type == OP_PADANY) {
4888 o->op_type = OP_PADHV;
4889 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4892 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
4893 && ckWARN(WARN_DEPRECATED)) {
4894 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4895 "Using a hash as a reference is deprecated");
4897 return newUNOP(OP_RV2HV, 0, scalar(o));
4901 Perl_oopsCV(pTHX_ OP *o)
4903 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
4906 NORETURN_FUNCTION_END;
4910 Perl_newCVREF(pTHX_ I32 flags, OP *o)
4912 return newUNOP(OP_RV2CV, flags, scalar(o));
4916 Perl_newSVREF(pTHX_ OP *o)
4919 if (o->op_type == OP_PADANY) {
4920 o->op_type = OP_PADSV;
4921 o->op_ppaddr = PL_ppaddr[OP_PADSV];
4924 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4925 o->op_flags |= OPpDONE_SVREF;
4928 return newUNOP(OP_RV2SV, 0, scalar(o));
4931 /* Check routines. See the comments at the top of this file for details
4932 * on when these are called */
4935 Perl_ck_anoncode(pTHX_ OP *o)
4937 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
4938 cSVOPo->op_sv = Nullsv;
4943 Perl_ck_bitop(pTHX_ OP *o)
4945 #define OP_IS_NUMCOMPARE(op) \
4946 ((op) == OP_LT || (op) == OP_I_LT || \
4947 (op) == OP_GT || (op) == OP_I_GT || \
4948 (op) == OP_LE || (op) == OP_I_LE || \
4949 (op) == OP_GE || (op) == OP_I_GE || \
4950 (op) == OP_EQ || (op) == OP_I_EQ || \
4951 (op) == OP_NE || (op) == OP_I_NE || \
4952 (op) == OP_NCMP || (op) == OP_I_NCMP)
4953 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4954 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
4955 && (o->op_type == OP_BIT_OR
4956 || o->op_type == OP_BIT_AND
4957 || o->op_type == OP_BIT_XOR))
4959 const OP * const left = cBINOPo->op_first;
4960 const OP * const right = left->op_sibling;
4961 if ((OP_IS_NUMCOMPARE(left->op_type) &&
4962 (left->op_flags & OPf_PARENS) == 0) ||
4963 (OP_IS_NUMCOMPARE(right->op_type) &&
4964 (right->op_flags & OPf_PARENS) == 0))
4965 if (ckWARN(WARN_PRECEDENCE))
4966 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4967 "Possible precedence problem on bitwise %c operator",
4968 o->op_type == OP_BIT_OR ? '|'
4969 : o->op_type == OP_BIT_AND ? '&' : '^'
4976 Perl_ck_concat(pTHX_ OP *o)
4978 const OP *kid = cUNOPo->op_first;
4979 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
4980 !(kUNOP->op_first->op_flags & OPf_MOD))
4981 o->op_flags |= OPf_STACKED;
4986 Perl_ck_spair(pTHX_ OP *o)
4989 if (o->op_flags & OPf_KIDS) {
4992 const OPCODE type = o->op_type;
4993 o = modkids(ck_fun(o), type);
4994 kid = cUNOPo->op_first;
4995 newop = kUNOP->op_first->op_sibling;
4997 (newop->op_sibling ||
4998 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
4999 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5000 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5004 op_free(kUNOP->op_first);
5005 kUNOP->op_first = newop;
5007 o->op_ppaddr = PL_ppaddr[++o->op_type];
5012 Perl_ck_delete(pTHX_ OP *o)
5016 if (o->op_flags & OPf_KIDS) {
5017 OP *kid = cUNOPo->op_first;
5018 switch (kid->op_type) {
5020 o->op_flags |= OPf_SPECIAL;
5023 o->op_private |= OPpSLICE;
5026 o->op_flags |= OPf_SPECIAL;
5031 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5040 Perl_ck_die(pTHX_ OP *o)
5043 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5049 Perl_ck_eof(pTHX_ OP *o)
5051 const I32 type = o->op_type;
5053 if (o->op_flags & OPf_KIDS) {
5054 if (cLISTOPo->op_first->op_type == OP_STUB) {
5056 o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
5064 Perl_ck_eval(pTHX_ OP *o)
5067 PL_hints |= HINT_BLOCK_SCOPE;
5068 if (o->op_flags & OPf_KIDS) {
5069 SVOP *kid = (SVOP*)cUNOPo->op_first;
5072 o->op_flags &= ~OPf_KIDS;
5075 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
5078 cUNOPo->op_first = 0;
5081 NewOp(1101, enter, 1, LOGOP);
5082 enter->op_type = OP_ENTERTRY;
5083 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5084 enter->op_private = 0;
5086 /* establish postfix order */
5087 enter->op_next = (OP*)enter;
5089 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5090 o->op_type = OP_LEAVETRY;
5091 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5092 enter->op_other = o;
5102 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5104 o->op_targ = (PADOFFSET)PL_hints;
5109 Perl_ck_exit(pTHX_ OP *o)
5112 HV *table = GvHV(PL_hintgv);
5114 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5115 if (svp && *svp && SvTRUE(*svp))
5116 o->op_private |= OPpEXIT_VMSISH;
5118 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5124 Perl_ck_exec(pTHX_ OP *o)
5126 if (o->op_flags & OPf_STACKED) {
5129 kid = cUNOPo->op_first->op_sibling;
5130 if (kid->op_type == OP_RV2GV)
5139 Perl_ck_exists(pTHX_ OP *o)
5142 if (o->op_flags & OPf_KIDS) {
5143 OP *kid = cUNOPo->op_first;
5144 if (kid->op_type == OP_ENTERSUB) {
5145 (void) ref(kid, o->op_type);
5146 if (kid->op_type != OP_RV2CV && !PL_error_count)
5147 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5149 o->op_private |= OPpEXISTS_SUB;
5151 else if (kid->op_type == OP_AELEM)
5152 o->op_flags |= OPf_SPECIAL;
5153 else if (kid->op_type != OP_HELEM)
5154 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5162 Perl_ck_rvconst(pTHX_ register OP *o)
5165 SVOP *kid = (SVOP*)cUNOPo->op_first;
5167 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5168 if (kid->op_type == OP_CONST) {
5171 SV * const kidsv = kid->op_sv;
5173 /* Is it a constant from cv_const_sv()? */
5174 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5175 SV *rsv = SvRV(kidsv);
5176 const int svtype = SvTYPE(rsv);
5177 const char *badtype = Nullch;
5179 switch (o->op_type) {
5181 if (svtype > SVt_PVMG)
5182 badtype = "a SCALAR";
5185 if (svtype != SVt_PVAV)
5186 badtype = "an ARRAY";
5189 if (svtype != SVt_PVHV)
5193 if (svtype != SVt_PVCV)
5198 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5201 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5202 const char *badthing = Nullch;
5203 switch (o->op_type) {
5205 badthing = "a SCALAR";
5208 badthing = "an ARRAY";
5211 badthing = "a HASH";
5216 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
5220 * This is a little tricky. We only want to add the symbol if we
5221 * didn't add it in the lexer. Otherwise we get duplicate strict
5222 * warnings. But if we didn't add it in the lexer, we must at
5223 * least pretend like we wanted to add it even if it existed before,
5224 * or we get possible typo warnings. OPpCONST_ENTERED says
5225 * whether the lexer already added THIS instance of this symbol.
5227 iscv = (o->op_type == OP_RV2CV) * 2;
5229 gv = gv_fetchsv(kidsv,
5230 iscv | !(kid->op_private & OPpCONST_ENTERED),
5233 : o->op_type == OP_RV2SV
5235 : o->op_type == OP_RV2AV
5237 : o->op_type == OP_RV2HV
5240 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5242 kid->op_type = OP_GV;
5243 SvREFCNT_dec(kid->op_sv);
5245 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5246 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5247 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
5249 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
5251 kid->op_sv = SvREFCNT_inc(gv);
5253 kid->op_private = 0;
5254 kid->op_ppaddr = PL_ppaddr[OP_GV];
5261 Perl_ck_ftst(pTHX_ OP *o)
5264 const I32 type = o->op_type;
5266 if (o->op_flags & OPf_REF) {
5269 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5270 SVOP *kid = (SVOP*)cUNOPo->op_first;
5272 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5273 OP *newop = newGVOP(type, OPf_REF,
5274 gv_fetchsv(kid->op_sv, TRUE, SVt_PVIO));
5280 if ((PL_hints & HINT_FILETEST_ACCESS) &&
5281 OP_IS_FILETEST_ACCESS(o))
5282 o->op_private |= OPpFT_ACCESS;
5284 if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
5285 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
5286 o->op_private |= OPpFT_STACKED;
5290 if (type == OP_FTTTY)
5291 o = newGVOP(type, OPf_REF, PL_stdingv);
5293 o = newUNOP(type, 0, newDEFSVOP());
5299 Perl_ck_fun(pTHX_ OP *o)
5301 const int type = o->op_type;
5302 register I32 oa = PL_opargs[type] >> OASHIFT;
5304 if (o->op_flags & OPf_STACKED) {
5305 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5308 return no_fh_allowed(o);
5311 if (o->op_flags & OPf_KIDS) {
5312 OP **tokid = &cLISTOPo->op_first;
5313 register OP *kid = cLISTOPo->op_first;
5317 if (kid->op_type == OP_PUSHMARK ||
5318 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5320 tokid = &kid->op_sibling;
5321 kid = kid->op_sibling;
5323 if (!kid && PL_opargs[type] & OA_DEFGV)
5324 *tokid = kid = newDEFSVOP();
5328 sibl = kid->op_sibling;
5331 /* list seen where single (scalar) arg expected? */
5332 if (numargs == 1 && !(oa >> 4)
5333 && kid->op_type == OP_LIST && type != OP_SCALAR)
5335 return too_many_arguments(o,PL_op_desc[type]);
5348 if ((type == OP_PUSH || type == OP_UNSHIFT)
5349 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5350 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5351 "Useless use of %s with no values",
5354 if (kid->op_type == OP_CONST &&
5355 (kid->op_private & OPpCONST_BARE))
5357 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5358 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVAV) ));
5359 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5360 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5361 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
5362 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5365 kid->op_sibling = sibl;
5368 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5369 bad_type(numargs, "array", PL_op_desc[type], kid);
5373 if (kid->op_type == OP_CONST &&
5374 (kid->op_private & OPpCONST_BARE))
5376 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5377 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVHV) ));
5378 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5379 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5380 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
5381 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5384 kid->op_sibling = sibl;
5387 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5388 bad_type(numargs, "hash", PL_op_desc[type], kid);
5393 OP *newop = newUNOP(OP_NULL, 0, kid);
5394 kid->op_sibling = 0;
5396 newop->op_next = newop;
5398 kid->op_sibling = sibl;
5403 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5404 if (kid->op_type == OP_CONST &&
5405 (kid->op_private & OPpCONST_BARE))
5407 OP *newop = newGVOP(OP_GV, 0,
5408 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVIO) );
5409 if (!(o->op_private & 1) && /* if not unop */
5410 kid == cLISTOPo->op_last)
5411 cLISTOPo->op_last = newop;
5415 else if (kid->op_type == OP_READLINE) {
5416 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5417 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5420 I32 flags = OPf_SPECIAL;
5424 /* is this op a FH constructor? */
5425 if (is_handle_constructor(o,numargs)) {
5426 const char *name = Nullch;
5430 /* Set a flag to tell rv2gv to vivify
5431 * need to "prove" flag does not mean something
5432 * else already - NI-S 1999/05/07
5435 if (kid->op_type == OP_PADSV) {
5436 name = PAD_COMPNAME_PV(kid->op_targ);
5437 /* SvCUR of a pad namesv can't be trusted
5438 * (see PL_generation), so calc its length
5444 else if (kid->op_type == OP_RV2SV
5445 && kUNOP->op_first->op_type == OP_GV)
5447 GV *gv = cGVOPx_gv(kUNOP->op_first);
5449 len = GvNAMELEN(gv);
5451 else if (kid->op_type == OP_AELEM
5452 || kid->op_type == OP_HELEM)
5457 if ((op = ((BINOP*)kid)->op_first)) {
5458 SV *tmpstr = Nullsv;
5460 kid->op_type == OP_AELEM ?
5462 if (((op->op_type == OP_RV2AV) ||
5463 (op->op_type == OP_RV2HV)) &&
5464 (op = ((UNOP*)op)->op_first) &&
5465 (op->op_type == OP_GV)) {
5466 /* packagevar $a[] or $h{} */
5467 GV *gv = cGVOPx_gv(op);
5475 else if (op->op_type == OP_PADAV
5476 || op->op_type == OP_PADHV) {
5477 /* lexicalvar $a[] or $h{} */
5478 const char *padname =
5479 PAD_COMPNAME_PV(op->op_targ);
5489 name = SvPV(tmpstr, len);
5494 name = "__ANONIO__";
5501 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5502 namesv = PAD_SVl(targ);
5503 (void)SvUPGRADE(namesv, SVt_PV);
5505 sv_setpvn(namesv, "$", 1);
5506 sv_catpvn(namesv, name, len);
5509 kid->op_sibling = 0;
5510 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5511 kid->op_targ = targ;
5512 kid->op_private |= priv;
5514 kid->op_sibling = sibl;
5520 mod(scalar(kid), type);
5524 tokid = &kid->op_sibling;
5525 kid = kid->op_sibling;
5527 o->op_private |= numargs;
5529 return too_many_arguments(o,OP_DESC(o));
5532 else if (PL_opargs[type] & OA_DEFGV) {
5534 return newUNOP(type, 0, newDEFSVOP());
5538 while (oa & OA_OPTIONAL)
5540 if (oa && oa != OA_LIST)
5541 return too_few_arguments(o,OP_DESC(o));
5547 Perl_ck_glob(pTHX_ OP *o)
5553 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5554 append_elem(OP_GLOB, o, newDEFSVOP());
5556 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5557 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5559 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5562 #if !defined(PERL_EXTERNAL_GLOB)
5563 /* XXX this can be tightened up and made more failsafe. */
5564 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5567 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5568 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5569 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5570 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5571 GvCV(gv) = GvCV(glob_gv);
5572 (void)SvREFCNT_inc((SV*)GvCV(gv));
5573 GvIMPORTED_CV_on(gv);
5576 #endif /* PERL_EXTERNAL_GLOB */
5578 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5579 append_elem(OP_GLOB, o,
5580 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5581 o->op_type = OP_LIST;
5582 o->op_ppaddr = PL_ppaddr[OP_LIST];
5583 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5584 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5585 cLISTOPo->op_first->op_targ = 0;
5586 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5587 append_elem(OP_LIST, o,
5588 scalar(newUNOP(OP_RV2CV, 0,
5589 newGVOP(OP_GV, 0, gv)))));
5590 o = newUNOP(OP_NULL, 0, ck_subr(o));
5591 o->op_targ = OP_GLOB; /* hint at what it used to be */
5594 gv = newGVgen("main");
5596 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5602 Perl_ck_grep(pTHX_ OP *o)
5607 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5610 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5611 NewOp(1101, gwop, 1, LOGOP);
5613 if (o->op_flags & OPf_STACKED) {
5616 kid = cLISTOPo->op_first->op_sibling;
5617 if (!cUNOPx(kid)->op_next)
5618 Perl_croak(aTHX_ "panic: ck_grep");
5619 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
5622 kid->op_next = (OP*)gwop;
5623 o->op_flags &= ~OPf_STACKED;
5625 kid = cLISTOPo->op_first->op_sibling;
5626 if (type == OP_MAPWHILE)
5633 kid = cLISTOPo->op_first->op_sibling;
5634 if (kid->op_type != OP_NULL)
5635 Perl_croak(aTHX_ "panic: ck_grep");
5636 kid = kUNOP->op_first;
5638 gwop->op_type = type;
5639 gwop->op_ppaddr = PL_ppaddr[type];
5640 gwop->op_first = listkids(o);
5641 gwop->op_flags |= OPf_KIDS;
5642 gwop->op_other = LINKLIST(kid);
5643 kid->op_next = (OP*)gwop;
5644 offset = pad_findmy("$_");
5645 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
5646 o->op_private = gwop->op_private = 0;
5647 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5650 o->op_private = gwop->op_private = OPpGREP_LEX;
5651 gwop->op_targ = o->op_targ = offset;
5654 kid = cLISTOPo->op_first->op_sibling;
5655 if (!kid || !kid->op_sibling)
5656 return too_few_arguments(o,OP_DESC(o));
5657 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5658 mod(kid, OP_GREPSTART);
5664 Perl_ck_index(pTHX_ OP *o)
5666 if (o->op_flags & OPf_KIDS) {
5667 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5669 kid = kid->op_sibling; /* get past "big" */
5670 if (kid && kid->op_type == OP_CONST)
5671 fbm_compile(((SVOP*)kid)->op_sv, 0);
5677 Perl_ck_lengthconst(pTHX_ OP *o)
5679 /* XXX length optimization goes here */
5684 Perl_ck_lfun(pTHX_ OP *o)
5686 const OPCODE type = o->op_type;
5687 return modkids(ck_fun(o), type);
5691 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5693 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5694 switch (cUNOPo->op_first->op_type) {
5696 /* This is needed for
5697 if (defined %stash::)
5698 to work. Do not break Tk.
5700 break; /* Globals via GV can be undef */
5702 case OP_AASSIGN: /* Is this a good idea? */
5703 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5704 "defined(@array) is deprecated");
5705 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5706 "\t(Maybe you should just omit the defined()?)\n");
5709 /* This is needed for
5710 if (defined %stash::)
5711 to work. Do not break Tk.
5713 break; /* Globals via GV can be undef */
5715 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5716 "defined(%%hash) is deprecated");
5717 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5718 "\t(Maybe you should just omit the defined()?)\n");
5729 Perl_ck_rfun(pTHX_ OP *o)
5731 const OPCODE type = o->op_type;
5732 return refkids(ck_fun(o), type);
5736 Perl_ck_listiob(pTHX_ OP *o)
5740 kid = cLISTOPo->op_first;
5743 kid = cLISTOPo->op_first;
5745 if (kid->op_type == OP_PUSHMARK)
5746 kid = kid->op_sibling;
5747 if (kid && o->op_flags & OPf_STACKED)
5748 kid = kid->op_sibling;
5749 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5750 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5751 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5752 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5753 cLISTOPo->op_first->op_sibling = kid;
5754 cLISTOPo->op_last = kid;
5755 kid = kid->op_sibling;
5760 append_elem(o->op_type, o, newDEFSVOP());
5766 Perl_ck_sassign(pTHX_ OP *o)
5768 OP *kid = cLISTOPo->op_first;
5769 /* has a disposable target? */
5770 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5771 && !(kid->op_flags & OPf_STACKED)
5772 /* Cannot steal the second time! */
5773 && !(kid->op_private & OPpTARGET_MY))
5775 OP *kkid = kid->op_sibling;
5777 /* Can just relocate the target. */
5778 if (kkid && kkid->op_type == OP_PADSV
5779 && !(kkid->op_private & OPpLVAL_INTRO))
5781 kid->op_targ = kkid->op_targ;
5783 /* Now we do not need PADSV and SASSIGN. */
5784 kid->op_sibling = o->op_sibling; /* NULL */
5785 cLISTOPo->op_first = NULL;
5788 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
5792 /* optimise C<my $x = undef> to C<my $x> */
5793 if (kid->op_type == OP_UNDEF) {
5794 OP *kkid = kid->op_sibling;
5795 if (kkid && kkid->op_type == OP_PADSV
5796 && (kkid->op_private & OPpLVAL_INTRO))
5798 cLISTOPo->op_first = NULL;
5799 kid->op_sibling = NULL;
5809 Perl_ck_match(pTHX_ OP *o)
5811 if (o->op_type != OP_QR) {
5812 const I32 offset = pad_findmy("$_");
5813 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS(offset) & SVpad_OUR)) {
5814 o->op_targ = offset;
5815 o->op_private |= OPpTARGET_MY;
5818 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
5819 o->op_private |= OPpRUNTIME;
5824 Perl_ck_method(pTHX_ OP *o)
5826 OP *kid = cUNOPo->op_first;
5827 if (kid->op_type == OP_CONST) {
5828 SV* sv = kSVOP->op_sv;
5829 if (!(strchr(SvPVX_const(sv), ':') || strchr(SvPVX_const(sv), '\''))) {
5831 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5832 sv = newSVpvn_share(SvPVX_const(sv), SvCUR(sv), 0);
5835 kSVOP->op_sv = Nullsv;
5837 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5846 Perl_ck_null(pTHX_ OP *o)
5852 Perl_ck_open(pTHX_ OP *o)
5854 HV *table = GvHV(PL_hintgv);
5858 svp = hv_fetch(table, "open_IN", 7, FALSE);
5860 mode = mode_from_discipline(*svp);
5861 if (mode & O_BINARY)
5862 o->op_private |= OPpOPEN_IN_RAW;
5863 else if (mode & O_TEXT)
5864 o->op_private |= OPpOPEN_IN_CRLF;
5867 svp = hv_fetch(table, "open_OUT", 8, FALSE);
5869 mode = mode_from_discipline(*svp);
5870 if (mode & O_BINARY)
5871 o->op_private |= OPpOPEN_OUT_RAW;
5872 else if (mode & O_TEXT)
5873 o->op_private |= OPpOPEN_OUT_CRLF;
5876 if (o->op_type == OP_BACKTICK)
5879 /* In case of three-arg dup open remove strictness
5880 * from the last arg if it is a bareword. */
5881 OP *first = cLISTOPx(o)->op_first; /* The pushmark. */
5882 OP *last = cLISTOPx(o)->op_last; /* The bareword. */
5886 if ((last->op_type == OP_CONST) && /* The bareword. */
5887 (last->op_private & OPpCONST_BARE) &&
5888 (last->op_private & OPpCONST_STRICT) &&
5889 (oa = first->op_sibling) && /* The fh. */
5890 (oa = oa->op_sibling) && /* The mode. */
5891 SvPOK(((SVOP*)oa)->op_sv) &&
5892 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
5893 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
5894 (last == oa->op_sibling)) /* The bareword. */
5895 last->op_private &= ~OPpCONST_STRICT;
5901 Perl_ck_repeat(pTHX_ OP *o)
5903 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5904 o->op_private |= OPpREPEAT_DOLIST;
5905 cBINOPo->op_first = force_list(cBINOPo->op_first);
5913 Perl_ck_require(pTHX_ OP *o)
5917 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
5918 SVOP *kid = (SVOP*)cUNOPo->op_first;
5920 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5922 for (s = SvPVX(kid->op_sv); *s; s++) {
5923 if (*s == ':' && s[1] == ':') {
5925 Move(s+2, s+1, strlen(s+2)+1, char);
5926 SvCUR_set(kid->op_sv, SvCUR(kid->op_sv) - 1);
5929 if (SvREADONLY(kid->op_sv)) {
5930 SvREADONLY_off(kid->op_sv);
5931 sv_catpvn(kid->op_sv, ".pm", 3);
5932 SvREADONLY_on(kid->op_sv);
5935 sv_catpvn(kid->op_sv, ".pm", 3);
5939 /* handle override, if any */
5940 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
5941 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
5942 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
5944 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5945 OP *kid = cUNOPo->op_first;
5946 cUNOPo->op_first = 0;
5948 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5949 append_elem(OP_LIST, kid,
5950 scalar(newUNOP(OP_RV2CV, 0,
5959 Perl_ck_return(pTHX_ OP *o)
5961 if (CvLVALUE(PL_compcv)) {
5963 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5964 mod(kid, OP_LEAVESUBLV);
5971 Perl_ck_retarget(pTHX_ OP *o)
5973 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5980 Perl_ck_select(pTHX_ OP *o)
5984 if (o->op_flags & OPf_KIDS) {
5985 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5986 if (kid && kid->op_sibling) {
5987 o->op_type = OP_SSELECT;
5988 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
5990 return fold_constants(o);
5994 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5995 if (kid && kid->op_type == OP_RV2GV)
5996 kid->op_private &= ~HINT_STRICT_REFS;
6001 Perl_ck_shift(pTHX_ OP *o)
6003 const I32 type = o->op_type;
6005 if (!(o->op_flags & OPf_KIDS)) {
6009 argop = newUNOP(OP_RV2AV, 0,
6010 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
6011 return newUNOP(type, 0, scalar(argop));
6013 return scalar(modkids(ck_fun(o), type));
6017 Perl_ck_sort(pTHX_ OP *o)
6021 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6023 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6024 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6026 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6028 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6030 if (kid->op_type == OP_SCOPE) {
6034 else if (kid->op_type == OP_LEAVE) {
6035 if (o->op_type == OP_SORT) {
6036 op_null(kid); /* wipe out leave */
6039 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6040 if (k->op_next == kid)
6042 /* don't descend into loops */
6043 else if (k->op_type == OP_ENTERLOOP
6044 || k->op_type == OP_ENTERITER)
6046 k = cLOOPx(k)->op_lastop;
6051 kid->op_next = 0; /* just disconnect the leave */
6052 k = kLISTOP->op_first;
6057 if (o->op_type == OP_SORT) {
6058 /* provide scalar context for comparison function/block */
6064 o->op_flags |= OPf_SPECIAL;
6066 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6069 firstkid = firstkid->op_sibling;
6072 /* provide list context for arguments */
6073 if (o->op_type == OP_SORT)
6080 S_simplify_sort(pTHX_ OP *o)
6082 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6087 if (!(o->op_flags & OPf_STACKED))
6089 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6090 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6091 kid = kUNOP->op_first; /* get past null */
6092 if (kid->op_type != OP_SCOPE)
6094 kid = kLISTOP->op_last; /* get past scope */
6095 switch(kid->op_type) {
6103 k = kid; /* remember this node*/
6104 if (kBINOP->op_first->op_type != OP_RV2SV)
6106 kid = kBINOP->op_first; /* get past cmp */
6107 if (kUNOP->op_first->op_type != OP_GV)
6109 kid = kUNOP->op_first; /* get past rv2sv */
6111 if (GvSTASH(gv) != PL_curstash)
6113 gvname = GvNAME(gv);
6114 if (*gvname == 'a' && gvname[1] == '\0')
6116 else if (*gvname == 'b' && gvname[1] == '\0')
6121 kid = k; /* back to cmp */
6122 if (kBINOP->op_last->op_type != OP_RV2SV)
6124 kid = kBINOP->op_last; /* down to 2nd arg */
6125 if (kUNOP->op_first->op_type != OP_GV)
6127 kid = kUNOP->op_first; /* get past rv2sv */
6129 if (GvSTASH(gv) != PL_curstash)
6131 gvname = GvNAME(gv);
6133 ? !(*gvname == 'a' && gvname[1] == '\0')
6134 : !(*gvname == 'b' && gvname[1] == '\0'))
6136 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6138 o->op_private |= OPpSORT_DESCEND;
6139 if (k->op_type == OP_NCMP)
6140 o->op_private |= OPpSORT_NUMERIC;
6141 if (k->op_type == OP_I_NCMP)
6142 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6143 kid = cLISTOPo->op_first->op_sibling;
6144 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6145 op_free(kid); /* then delete it */
6149 Perl_ck_split(pTHX_ OP *o)
6154 if (o->op_flags & OPf_STACKED)
6155 return no_fh_allowed(o);
6157 kid = cLISTOPo->op_first;
6158 if (kid->op_type != OP_NULL)
6159 Perl_croak(aTHX_ "panic: ck_split");
6160 kid = kid->op_sibling;
6161 op_free(cLISTOPo->op_first);
6162 cLISTOPo->op_first = kid;
6164 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6165 cLISTOPo->op_last = kid; /* There was only one element previously */
6168 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6169 OP *sibl = kid->op_sibling;
6170 kid->op_sibling = 0;
6171 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
6172 if (cLISTOPo->op_first == cLISTOPo->op_last)
6173 cLISTOPo->op_last = kid;
6174 cLISTOPo->op_first = kid;
6175 kid->op_sibling = sibl;
6178 kid->op_type = OP_PUSHRE;
6179 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6181 if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
6182 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
6183 "Use of /g modifier is meaningless in split");
6186 if (!kid->op_sibling)
6187 append_elem(OP_SPLIT, o, newDEFSVOP());
6189 kid = kid->op_sibling;
6192 if (!kid->op_sibling)
6193 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6195 kid = kid->op_sibling;
6198 if (kid->op_sibling)
6199 return too_many_arguments(o,OP_DESC(o));
6205 Perl_ck_join(pTHX_ OP *o)
6207 if (ckWARN(WARN_SYNTAX)) {
6208 const OP *kid = cLISTOPo->op_first->op_sibling;
6209 if (kid && kid->op_type == OP_MATCH) {
6210 const REGEXP *re = PM_GETRE(kPMOP);
6211 const char *pmstr = re ? re->precomp : "STRING";
6212 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6213 "/%s/ should probably be written as \"%s\"",
6221 Perl_ck_subr(pTHX_ OP *o)
6223 OP *prev = ((cUNOPo->op_first->op_sibling)
6224 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6225 OP *o2 = prev->op_sibling;
6232 I32 contextclass = 0;
6237 o->op_private |= OPpENTERSUB_HASTARG;
6238 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6239 if (cvop->op_type == OP_RV2CV) {
6241 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6242 op_null(cvop); /* disable rv2cv */
6243 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6244 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6245 GV *gv = cGVOPx_gv(tmpop);
6248 tmpop->op_private |= OPpEARLY_CV;
6251 namegv = CvANON(cv) ? gv : CvGV(cv);
6252 proto = SvPV((SV*)cv, n_a);
6254 if (CvASSERTION(cv)) {
6255 if (PL_hints & HINT_ASSERTING) {
6256 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
6257 o->op_private |= OPpENTERSUB_DB;
6261 if (ckWARN(WARN_ASSERTIONS) && !(PL_hints & HINT_ASSERTIONSSEEN)) {
6262 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
6263 "Impossible to activate assertion call");
6270 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6271 if (o2->op_type == OP_CONST)
6272 o2->op_private &= ~OPpCONST_STRICT;
6273 else if (o2->op_type == OP_LIST) {
6274 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6275 if (o && o->op_type == OP_CONST)
6276 o->op_private &= ~OPpCONST_STRICT;
6279 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6280 if (PERLDB_SUB && PL_curstash != PL_debstash)
6281 o->op_private |= OPpENTERSUB_DB;
6282 while (o2 != cvop) {
6286 return too_many_arguments(o, gv_ename(namegv));
6304 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6306 arg == 1 ? "block or sub {}" : "sub {}",
6307 gv_ename(namegv), o2);
6310 /* '*' allows any scalar type, including bareword */
6313 if (o2->op_type == OP_RV2GV)
6314 goto wrapref; /* autoconvert GLOB -> GLOBref */
6315 else if (o2->op_type == OP_CONST)
6316 o2->op_private &= ~OPpCONST_STRICT;
6317 else if (o2->op_type == OP_ENTERSUB) {
6318 /* accidental subroutine, revert to bareword */
6319 OP *gvop = ((UNOP*)o2)->op_first;
6320 if (gvop && gvop->op_type == OP_NULL) {
6321 gvop = ((UNOP*)gvop)->op_first;
6323 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6326 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6327 (gvop = ((UNOP*)gvop)->op_first) &&
6328 gvop->op_type == OP_GV)
6330 GV *gv = cGVOPx_gv(gvop);
6331 OP *sibling = o2->op_sibling;
6332 SV *n = newSVpvn("",0);
6334 gv_fullname4(n, gv, "", FALSE);
6335 o2 = newSVOP(OP_CONST, 0, n);
6336 prev->op_sibling = o2;
6337 o2->op_sibling = sibling;
6353 if (contextclass++ == 0) {
6354 e = strchr(proto, ']');
6355 if (!e || e == proto)
6368 while (*--p != '[');
6369 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6370 gv_ename(namegv), o2);
6376 if (o2->op_type == OP_RV2GV)
6379 bad_type(arg, "symbol", gv_ename(namegv), o2);
6382 if (o2->op_type == OP_ENTERSUB)
6385 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6388 if (o2->op_type == OP_RV2SV ||
6389 o2->op_type == OP_PADSV ||
6390 o2->op_type == OP_HELEM ||
6391 o2->op_type == OP_AELEM ||
6392 o2->op_type == OP_THREADSV)
6395 bad_type(arg, "scalar", gv_ename(namegv), o2);
6398 if (o2->op_type == OP_RV2AV ||
6399 o2->op_type == OP_PADAV)
6402 bad_type(arg, "array", gv_ename(namegv), o2);
6405 if (o2->op_type == OP_RV2HV ||
6406 o2->op_type == OP_PADHV)
6409 bad_type(arg, "hash", gv_ename(namegv), o2);
6414 OP* sib = kid->op_sibling;
6415 kid->op_sibling = 0;
6416 o2 = newUNOP(OP_REFGEN, 0, kid);
6417 o2->op_sibling = sib;
6418 prev->op_sibling = o2;
6420 if (contextclass && e) {
6435 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6436 gv_ename(namegv), cv);
6441 mod(o2, OP_ENTERSUB);
6443 o2 = o2->op_sibling;
6445 if (proto && !optional &&
6446 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6447 return too_few_arguments(o, gv_ename(namegv));
6450 o=newSVOP(OP_CONST, 0, newSViv(0));
6456 Perl_ck_svconst(pTHX_ OP *o)
6458 SvREADONLY_on(cSVOPo->op_sv);
6463 Perl_ck_trunc(pTHX_ OP *o)
6465 if (o->op_flags & OPf_KIDS) {
6466 SVOP *kid = (SVOP*)cUNOPo->op_first;
6468 if (kid->op_type == OP_NULL)
6469 kid = (SVOP*)kid->op_sibling;
6470 if (kid && kid->op_type == OP_CONST &&
6471 (kid->op_private & OPpCONST_BARE))
6473 o->op_flags |= OPf_SPECIAL;
6474 kid->op_private &= ~OPpCONST_STRICT;
6481 Perl_ck_unpack(pTHX_ OP *o)
6483 OP *kid = cLISTOPo->op_first;
6484 if (kid->op_sibling) {
6485 kid = kid->op_sibling;
6486 if (!kid->op_sibling)
6487 kid->op_sibling = newDEFSVOP();
6493 Perl_ck_substr(pTHX_ OP *o)
6496 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6497 OP *kid = cLISTOPo->op_first;
6499 if (kid->op_type == OP_NULL)
6500 kid = kid->op_sibling;
6502 kid->op_flags |= OPf_MOD;
6508 /* A peephole optimizer. We visit the ops in the order they're to execute.
6509 * See the comments at the top of this file for more details about when
6510 * peep() is called */
6513 Perl_peep(pTHX_ register OP *o)
6516 register OP* oldop = 0;
6518 if (!o || o->op_opt)
6522 SAVEVPTR(PL_curcop);
6523 for (; o; o = o->op_next) {
6527 switch (o->op_type) {
6531 PL_curcop = ((COP*)o); /* for warnings */
6536 if (cSVOPo->op_private & OPpCONST_STRICT)
6537 no_bareword_allowed(o);
6539 case OP_METHOD_NAMED:
6540 /* Relocate sv to the pad for thread safety.
6541 * Despite being a "constant", the SV is written to,
6542 * for reference counts, sv_upgrade() etc. */
6544 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6545 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6546 /* If op_sv is already a PADTMP then it is being used by
6547 * some pad, so make a copy. */
6548 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6549 SvREADONLY_on(PAD_SVl(ix));
6550 SvREFCNT_dec(cSVOPo->op_sv);
6553 SvREFCNT_dec(PAD_SVl(ix));
6554 SvPADTMP_on(cSVOPo->op_sv);
6555 PAD_SETSV(ix, cSVOPo->op_sv);
6556 /* XXX I don't know how this isn't readonly already. */
6557 SvREADONLY_on(PAD_SVl(ix));
6559 cSVOPo->op_sv = Nullsv;
6567 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6568 if (o->op_next->op_private & OPpTARGET_MY) {
6569 if (o->op_flags & OPf_STACKED) /* chained concats */
6570 goto ignore_optimization;
6572 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6573 o->op_targ = o->op_next->op_targ;
6574 o->op_next->op_targ = 0;
6575 o->op_private |= OPpTARGET_MY;
6578 op_null(o->op_next);
6580 ignore_optimization:
6584 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6586 break; /* Scalar stub must produce undef. List stub is noop */
6590 if (o->op_targ == OP_NEXTSTATE
6591 || o->op_targ == OP_DBSTATE
6592 || o->op_targ == OP_SETSTATE)
6594 PL_curcop = ((COP*)o);
6596 /* XXX: We avoid setting op_seq here to prevent later calls
6597 to peep() from mistakenly concluding that optimisation
6598 has already occurred. This doesn't fix the real problem,
6599 though (See 20010220.007). AMS 20010719 */
6600 /* op_seq functionality is now replaced by op_opt */
6601 if (oldop && o->op_next) {
6602 oldop->op_next = o->op_next;
6610 if (oldop && o->op_next) {
6611 oldop->op_next = o->op_next;
6619 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
6620 OP* pop = (o->op_type == OP_PADAV) ?
6621 o->op_next : o->op_next->op_next;
6623 if (pop && pop->op_type == OP_CONST &&
6624 ((PL_op = pop->op_next)) &&
6625 pop->op_next->op_type == OP_AELEM &&
6626 !(pop->op_next->op_private &
6627 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6628 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6633 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
6634 no_bareword_allowed(pop);
6635 if (o->op_type == OP_GV)
6636 op_null(o->op_next);
6637 op_null(pop->op_next);
6639 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6640 o->op_next = pop->op_next->op_next;
6641 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6642 o->op_private = (U8)i;
6643 if (o->op_type == OP_GV) {
6648 o->op_flags |= OPf_SPECIAL;
6649 o->op_type = OP_AELEMFAST;
6655 if (o->op_next->op_type == OP_RV2SV) {
6656 if (!(o->op_next->op_private & OPpDEREF)) {
6657 op_null(o->op_next);
6658 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6660 o->op_next = o->op_next->op_next;
6661 o->op_type = OP_GVSV;
6662 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6665 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6667 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
6668 /* XXX could check prototype here instead of just carping */
6669 SV *sv = sv_newmortal();
6670 gv_efullname3(sv, gv, Nullch);
6671 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6672 "%"SVf"() called too early to check prototype",
6676 else if (o->op_next->op_type == OP_READLINE
6677 && o->op_next->op_next->op_type == OP_CONCAT
6678 && (o->op_next->op_next->op_flags & OPf_STACKED))
6680 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6681 o->op_type = OP_RCATLINE;
6682 o->op_flags |= OPf_STACKED;
6683 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6684 op_null(o->op_next->op_next);
6685 op_null(o->op_next);
6702 while (cLOGOP->op_other->op_type == OP_NULL)
6703 cLOGOP->op_other = cLOGOP->op_other->op_next;
6704 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6710 while (cLOOP->op_redoop->op_type == OP_NULL)
6711 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6712 peep(cLOOP->op_redoop);
6713 while (cLOOP->op_nextop->op_type == OP_NULL)
6714 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6715 peep(cLOOP->op_nextop);
6716 while (cLOOP->op_lastop->op_type == OP_NULL)
6717 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6718 peep(cLOOP->op_lastop);
6725 while (cPMOP->op_pmreplstart &&
6726 cPMOP->op_pmreplstart->op_type == OP_NULL)
6727 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6728 peep(cPMOP->op_pmreplstart);
6733 if (ckWARN(WARN_SYNTAX) && o->op_next
6734 && o->op_next->op_type == OP_NEXTSTATE) {
6735 if (o->op_next->op_sibling &&
6736 o->op_next->op_sibling->op_type != OP_EXIT &&
6737 o->op_next->op_sibling->op_type != OP_WARN &&
6738 o->op_next->op_sibling->op_type != OP_DIE) {
6739 const line_t oldline = CopLINE(PL_curcop);
6741 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6742 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6743 "Statement unlikely to be reached");
6744 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6745 "\t(Maybe you meant system() when you said exec()?)\n");
6746 CopLINE_set(PL_curcop, oldline);
6761 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6764 /* Make the CONST have a shared SV */
6765 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6766 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6767 key = SvPV(sv, keylen);
6768 lexname = newSVpvn_share(key,
6769 SvUTF8(sv) ? -(I32)keylen : keylen,
6775 if ((o->op_private & (OPpLVAL_INTRO)))
6778 rop = (UNOP*)((BINOP*)o)->op_first;
6779 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6781 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6782 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6784 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6785 if (!fields || !GvHV(*fields))
6787 key = SvPV(*svp, keylen);
6788 if (!hv_fetch(GvHV(*fields), key,
6789 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
6791 Perl_croak(aTHX_ "No such class field \"%s\" "
6792 "in variable %s of type %s",
6793 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
6806 SVOP *first_key_op, *key_op;
6808 if ((o->op_private & (OPpLVAL_INTRO))
6809 /* I bet there's always a pushmark... */
6810 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6811 /* hmmm, no optimization if list contains only one key. */
6813 rop = (UNOP*)((LISTOP*)o)->op_last;
6814 if (rop->op_type != OP_RV2HV)
6816 if (rop->op_first->op_type == OP_PADSV)
6817 /* @$hash{qw(keys here)} */
6818 rop = (UNOP*)rop->op_first;
6820 /* @{$hash}{qw(keys here)} */
6821 if (rop->op_first->op_type == OP_SCOPE
6822 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
6824 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
6830 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
6831 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6833 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6834 if (!fields || !GvHV(*fields))
6836 /* Again guessing that the pushmark can be jumped over.... */
6837 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
6838 ->op_first->op_sibling;
6839 for (key_op = first_key_op; key_op;
6840 key_op = (SVOP*)key_op->op_sibling) {
6841 if (key_op->op_type != OP_CONST)
6843 svp = cSVOPx_svp(key_op);
6844 key = SvPV(*svp, keylen);
6845 if (!hv_fetch(GvHV(*fields), key,
6846 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
6848 Perl_croak(aTHX_ "No such class field \"%s\" "
6849 "in variable %s of type %s",
6850 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
6857 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
6861 /* check that RHS of sort is a single plain array */
6862 oright = cUNOPo->op_first;
6863 if (!oright || oright->op_type != OP_PUSHMARK)
6866 /* reverse sort ... can be optimised. */
6867 if (!cUNOPo->op_sibling) {
6868 /* Nothing follows us on the list. */
6869 OP *reverse = o->op_next;
6871 if (reverse->op_type == OP_REVERSE &&
6872 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
6873 OP *pushmark = cUNOPx(reverse)->op_first;
6874 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
6875 && (cUNOPx(pushmark)->op_sibling == o)) {
6876 /* reverse -> pushmark -> sort */
6877 o->op_private |= OPpSORT_REVERSE;
6879 pushmark->op_next = oright->op_next;
6885 /* make @a = sort @a act in-place */
6889 oright = cUNOPx(oright)->op_sibling;
6892 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
6893 oright = cUNOPx(oright)->op_sibling;
6897 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
6898 || oright->op_next != o
6899 || (oright->op_private & OPpLVAL_INTRO)
6903 /* o2 follows the chain of op_nexts through the LHS of the
6904 * assign (if any) to the aassign op itself */
6906 if (!o2 || o2->op_type != OP_NULL)
6909 if (!o2 || o2->op_type != OP_PUSHMARK)
6912 if (o2 && o2->op_type == OP_GV)
6915 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
6916 || (o2->op_private & OPpLVAL_INTRO)
6921 if (!o2 || o2->op_type != OP_NULL)
6924 if (!o2 || o2->op_type != OP_AASSIGN
6925 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
6928 /* check that the sort is the first arg on RHS of assign */
6930 o2 = cUNOPx(o2)->op_first;
6931 if (!o2 || o2->op_type != OP_NULL)
6933 o2 = cUNOPx(o2)->op_first;
6934 if (!o2 || o2->op_type != OP_PUSHMARK)
6936 if (o2->op_sibling != o)
6939 /* check the array is the same on both sides */
6940 if (oleft->op_type == OP_RV2AV) {
6941 if (oright->op_type != OP_RV2AV
6942 || !cUNOPx(oright)->op_first
6943 || cUNOPx(oright)->op_first->op_type != OP_GV
6944 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
6945 cGVOPx_gv(cUNOPx(oright)->op_first)
6949 else if (oright->op_type != OP_PADAV
6950 || oright->op_targ != oleft->op_targ
6954 /* transfer MODishness etc from LHS arg to RHS arg */
6955 oright->op_flags = oleft->op_flags;
6956 o->op_private |= OPpSORT_INPLACE;
6958 /* excise push->gv->rv2av->null->aassign */
6959 o2 = o->op_next->op_next;
6960 op_null(o2); /* PUSHMARK */
6962 if (o2->op_type == OP_GV) {
6963 op_null(o2); /* GV */
6966 op_null(o2); /* RV2AV or PADAV */
6967 o2 = o2->op_next->op_next;
6968 op_null(o2); /* AASSIGN */
6970 o->op_next = o2->op_next;
6976 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
6978 LISTOP *enter, *exlist;
6981 enter = (LISTOP *) o->op_next;
6984 if (enter->op_type == OP_NULL) {
6985 enter = (LISTOP *) enter->op_next;
6989 /* for $a (...) will have OP_GV then OP_RV2GV here.
6990 for (...) just has an OP_GV. */
6991 if (enter->op_type == OP_GV) {
6992 gvop = (OP *) enter;
6993 enter = (LISTOP *) enter->op_next;
6996 if (enter->op_type == OP_RV2GV) {
6997 enter = (LISTOP *) enter->op_next;
7003 if (enter->op_type != OP_ENTERITER)
7006 iter = enter->op_next;
7007 if (!iter || iter->op_type != OP_ITER)
7010 expushmark = enter->op_first;
7011 if (!expushmark || expushmark->op_type != OP_NULL
7012 || expushmark->op_targ != OP_PUSHMARK)
7015 exlist = (LISTOP *) expushmark->op_sibling;
7016 if (!exlist || exlist->op_type != OP_NULL
7017 || exlist->op_targ != OP_LIST)
7020 if (exlist->op_last != o) {
7021 /* Mmm. Was expecting to point back to this op. */
7024 theirmark = exlist->op_first;
7025 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
7028 if (theirmark->op_sibling != o) {
7029 /* There's something between the mark and the reverse, eg
7030 for (1, reverse (...))
7035 ourmark = ((LISTOP *)o)->op_first;
7036 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
7039 ourlast = ((LISTOP *)o)->op_last;
7040 if (!ourlast || ourlast->op_next != o)
7043 rv2av = ourmark->op_sibling;
7044 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
7045 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
7046 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
7047 /* We're just reversing a single array. */
7048 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
7049 enter->op_flags |= OPf_STACKED;
7052 /* We don't have control over who points to theirmark, so sacrifice
7054 theirmark->op_next = ourmark->op_next;
7055 theirmark->op_flags = ourmark->op_flags;
7056 ourlast->op_next = gvop ? gvop : (OP *) enter;
7059 enter->op_private |= OPpITER_REVERSED;
7060 iter->op_private |= OPpITER_REVERSED;
7075 Perl_custom_op_name(pTHX_ const OP* o)
7077 const IV index = PTR2IV(o->op_ppaddr);
7081 if (!PL_custom_op_names) /* This probably shouldn't happen */
7082 return (char *)PL_op_name[OP_CUSTOM];
7084 keysv = sv_2mortal(newSViv(index));
7086 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7088 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7090 return SvPV_nolen(HeVAL(he));
7094 Perl_custom_op_desc(pTHX_ const OP* o)
7096 const IV index = PTR2IV(o->op_ppaddr);
7100 if (!PL_custom_op_descs)
7101 return (char *)PL_op_desc[OP_CUSTOM];
7103 keysv = sv_2mortal(newSViv(index));
7105 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7107 return (char *)PL_op_desc[OP_CUSTOM];
7109 return SvPV_nolen(HeVAL(he));
7114 /* Efficient sub that returns a constant scalar value. */
7116 const_sv_xsub(pTHX_ CV* cv)
7121 Perl_croak(aTHX_ "usage: %s::%s()",
7122 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7126 ST(0) = (SV*)XSANY.any_ptr;
7132 * c-indentation-style: bsd
7134 * indent-tabs-mode: t
7137 * ex: set ts=8 sts=4 sw=4 noet: