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 argnum)
1384 switch (o->op_type) {
1392 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1405 Perl_refkids(pTHX_ OP *o, I32 type)
1407 if (o && o->op_flags & OPf_KIDS) {
1409 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1416 Perl_ref(pTHX_ OP *o, I32 type)
1421 if (!o || PL_error_count)
1424 switch (o->op_type) {
1426 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1427 !(o->op_flags & OPf_STACKED)) {
1428 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1429 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1430 assert(cUNOPo->op_first->op_type == OP_NULL);
1431 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1432 o->op_flags |= OPf_SPECIAL;
1437 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1441 if (type == OP_DEFINED)
1442 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1443 ref(cUNOPo->op_first, o->op_type);
1446 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1447 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1448 : type == OP_RV2HV ? OPpDEREF_HV
1450 o->op_flags |= OPf_MOD;
1455 o->op_flags |= OPf_MOD; /* XXX ??? */
1460 o->op_flags |= OPf_REF;
1463 if (type == OP_DEFINED)
1464 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1465 ref(cUNOPo->op_first, o->op_type);
1470 o->op_flags |= OPf_REF;
1475 if (!(o->op_flags & OPf_KIDS))
1477 ref(cBINOPo->op_first, type);
1481 ref(cBINOPo->op_first, o->op_type);
1482 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1483 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1484 : type == OP_RV2HV ? OPpDEREF_HV
1486 o->op_flags |= OPf_MOD;
1494 if (!(o->op_flags & OPf_KIDS))
1496 ref(cLISTOPo->op_last, type);
1506 S_dup_attrlist(pTHX_ OP *o)
1510 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1511 * where the first kid is OP_PUSHMARK and the remaining ones
1512 * are OP_CONST. We need to push the OP_CONST values.
1514 if (o->op_type == OP_CONST)
1515 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1517 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1518 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1519 if (o->op_type == OP_CONST)
1520 rop = append_elem(OP_LIST, rop,
1521 newSVOP(OP_CONST, o->op_flags,
1522 SvREFCNT_inc(cSVOPo->op_sv)));
1529 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1534 /* fake up C<use attributes $pkg,$rv,@attrs> */
1535 ENTER; /* need to protect against side-effects of 'use' */
1538 stashsv = newSVpv(HvNAME(stash), 0);
1540 stashsv = &PL_sv_no;
1542 #define ATTRSMODULE "attributes"
1543 #define ATTRSMODULE_PM "attributes.pm"
1547 /* Don't force the C<use> if we don't need it. */
1548 svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
1549 sizeof(ATTRSMODULE_PM)-1, 0);
1550 if (svp && *svp != &PL_sv_undef)
1551 ; /* already in %INC */
1553 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1554 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1558 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1559 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1561 prepend_elem(OP_LIST,
1562 newSVOP(OP_CONST, 0, stashsv),
1563 prepend_elem(OP_LIST,
1564 newSVOP(OP_CONST, 0,
1566 dup_attrlist(attrs))));
1572 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1574 OP *pack, *imop, *arg;
1580 assert(target->op_type == OP_PADSV ||
1581 target->op_type == OP_PADHV ||
1582 target->op_type == OP_PADAV);
1584 /* Ensure that attributes.pm is loaded. */
1585 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1587 /* Need package name for method call. */
1588 pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
1590 /* Build up the real arg-list. */
1592 stashsv = newSVpv(HvNAME(stash), 0);
1594 stashsv = &PL_sv_no;
1595 arg = newOP(OP_PADSV, 0);
1596 arg->op_targ = target->op_targ;
1597 arg = prepend_elem(OP_LIST,
1598 newSVOP(OP_CONST, 0, stashsv),
1599 prepend_elem(OP_LIST,
1600 newUNOP(OP_REFGEN, 0,
1601 mod(arg, OP_REFGEN)),
1602 dup_attrlist(attrs)));
1604 /* Fake up a method call to import */
1605 meth = newSVpvn("import", 6);
1606 (void)SvUPGRADE(meth, SVt_PVIV);
1607 (void)SvIOK_on(meth);
1610 PERL_HASH(hash, SvPVX_const(meth), SvCUR(meth));
1611 SvUV_set(meth, hash);
1613 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1614 append_elem(OP_LIST,
1615 prepend_elem(OP_LIST, pack, list(arg)),
1616 newSVOP(OP_METHOD_NAMED, 0, meth)));
1617 imop->op_private |= OPpENTERSUB_NOMOD;
1619 /* Combine the ops. */
1620 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1624 =notfor apidoc apply_attrs_string
1626 Attempts to apply a list of attributes specified by the C<attrstr> and
1627 C<len> arguments to the subroutine identified by the C<cv> argument which
1628 is expected to be associated with the package identified by the C<stashpv>
1629 argument (see L<attributes>). It gets this wrong, though, in that it
1630 does not correctly identify the boundaries of the individual attribute
1631 specifications within C<attrstr>. This is not really intended for the
1632 public API, but has to be listed here for systems such as AIX which
1633 need an explicit export list for symbols. (It's called from XS code
1634 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1635 to respect attribute syntax properly would be welcome.
1641 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1642 const char *attrstr, STRLEN len)
1647 len = strlen(attrstr);
1651 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1653 const char *sstr = attrstr;
1654 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1655 attrs = append_elem(OP_LIST, attrs,
1656 newSVOP(OP_CONST, 0,
1657 newSVpvn(sstr, attrstr-sstr)));
1661 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1662 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1663 Nullsv, prepend_elem(OP_LIST,
1664 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1665 prepend_elem(OP_LIST,
1666 newSVOP(OP_CONST, 0,
1672 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1676 if (!o || PL_error_count)
1680 if (type == OP_LIST) {
1682 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1683 my_kid(kid, attrs, imopsp);
1684 } else if (type == OP_UNDEF) {
1686 } else if (type == OP_RV2SV || /* "our" declaration */
1688 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1689 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1690 yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
1691 OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
1693 GV *gv = cGVOPx_gv(cUNOPo->op_first);
1695 PL_in_my_stash = Nullhv;
1696 apply_attrs(GvSTASH(gv),
1697 (type == OP_RV2SV ? GvSV(gv) :
1698 type == OP_RV2AV ? (SV*)GvAV(gv) :
1699 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1702 o->op_private |= OPpOUR_INTRO;
1705 else if (type != OP_PADSV &&
1708 type != OP_PUSHMARK)
1710 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1712 PL_in_my == KEY_our ? "our" : "my"));
1715 else if (attrs && type != OP_PUSHMARK) {
1719 PL_in_my_stash = Nullhv;
1721 /* check for C<my Dog $spot> when deciding package */
1722 stash = PAD_COMPNAME_TYPE(o->op_targ);
1724 stash = PL_curstash;
1725 apply_attrs_my(stash, o, attrs, imopsp);
1727 o->op_flags |= OPf_MOD;
1728 o->op_private |= OPpLVAL_INTRO;
1733 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1736 int maybe_scalar = 0;
1738 /* [perl #17376]: this appears to be premature, and results in code such as
1739 C< our(%x); > executing in list mode rather than void mode */
1741 if (o->op_flags & OPf_PARENS)
1750 o = my_kid(o, attrs, &rops);
1752 if (maybe_scalar && o->op_type == OP_PADSV) {
1753 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1754 o->op_private |= OPpLVAL_INTRO;
1757 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1760 PL_in_my_stash = Nullhv;
1765 Perl_my(pTHX_ OP *o)
1767 return my_attrs(o, Nullop);
1771 Perl_sawparens(pTHX_ OP *o)
1774 o->op_flags |= OPf_PARENS;
1779 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1784 if (ckWARN(WARN_MISC) &&
1785 (left->op_type == OP_RV2AV ||
1786 left->op_type == OP_RV2HV ||
1787 left->op_type == OP_PADAV ||
1788 left->op_type == OP_PADHV)) {
1789 const char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
1790 right->op_type == OP_TRANS)
1791 ? right->op_type : OP_MATCH];
1792 const char *sample = ((left->op_type == OP_RV2AV ||
1793 left->op_type == OP_PADAV)
1794 ? "@array" : "%hash");
1795 Perl_warner(aTHX_ packWARN(WARN_MISC),
1796 "Applying %s to %s will act on scalar(%s)",
1797 desc, sample, sample);
1800 if (right->op_type == OP_CONST &&
1801 cSVOPx(right)->op_private & OPpCONST_BARE &&
1802 cSVOPx(right)->op_private & OPpCONST_STRICT)
1804 no_bareword_allowed(right);
1807 ismatchop = right->op_type == OP_MATCH ||
1808 right->op_type == OP_SUBST ||
1809 right->op_type == OP_TRANS;
1810 if (ismatchop && right->op_private & OPpTARGET_MY) {
1812 right->op_private &= ~OPpTARGET_MY;
1814 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1815 right->op_flags |= OPf_STACKED;
1816 if (right->op_type != OP_MATCH &&
1817 ! (right->op_type == OP_TRANS &&
1818 right->op_private & OPpTRANS_IDENTICAL))
1819 left = mod(left, right->op_type);
1820 if (right->op_type == OP_TRANS)
1821 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
1823 o = prepend_elem(right->op_type, scalar(left), right);
1825 return newUNOP(OP_NOT, 0, scalar(o));
1829 return bind_match(type, left,
1830 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
1834 Perl_invert(pTHX_ OP *o)
1838 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
1839 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1843 Perl_scope(pTHX_ OP *o)
1847 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1848 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1849 o->op_type = OP_LEAVE;
1850 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1852 else if (o->op_type == OP_LINESEQ) {
1854 o->op_type = OP_SCOPE;
1855 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1856 kid = ((LISTOP*)o)->op_first;
1857 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
1861 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
1866 /* XXX kept for BINCOMPAT only */
1868 Perl_save_hints(pTHX)
1870 Perl_croak(aTHX_ "internal error: obsolete function save_hints() called");
1874 Perl_block_start(pTHX_ int full)
1876 const int retval = PL_savestack_ix;
1877 pad_block_start(full);
1879 PL_hints &= ~HINT_BLOCK_SCOPE;
1880 SAVESPTR(PL_compiling.cop_warnings);
1881 if (! specialWARN(PL_compiling.cop_warnings)) {
1882 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1883 SAVEFREESV(PL_compiling.cop_warnings) ;
1885 SAVESPTR(PL_compiling.cop_io);
1886 if (! specialCopIO(PL_compiling.cop_io)) {
1887 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1888 SAVEFREESV(PL_compiling.cop_io) ;
1894 Perl_block_end(pTHX_ I32 floor, OP *seq)
1896 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1897 OP* retval = scalarseq(seq);
1899 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
1901 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
1909 const I32 offset = pad_findmy("$_");
1910 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
1911 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1914 OP *o = newOP(OP_PADSV, 0);
1915 o->op_targ = offset;
1921 Perl_newPROG(pTHX_ OP *o)
1926 PL_eval_root = newUNOP(OP_LEAVEEVAL,
1927 ((PL_in_eval & EVAL_KEEPERR)
1928 ? OPf_SPECIAL : 0), o);
1929 PL_eval_start = linklist(PL_eval_root);
1930 PL_eval_root->op_private |= OPpREFCOUNTED;
1931 OpREFCNT_set(PL_eval_root, 1);
1932 PL_eval_root->op_next = 0;
1933 CALL_PEEP(PL_eval_start);
1936 if (o->op_type == OP_STUB) {
1937 PL_comppad_name = 0;
1942 PL_main_root = scope(sawparens(scalarvoid(o)));
1943 PL_curcop = &PL_compiling;
1944 PL_main_start = LINKLIST(PL_main_root);
1945 PL_main_root->op_private |= OPpREFCOUNTED;
1946 OpREFCNT_set(PL_main_root, 1);
1947 PL_main_root->op_next = 0;
1948 CALL_PEEP(PL_main_start);
1951 /* Register with debugger */
1953 CV *cv = get_cv("DB::postponed", FALSE);
1957 XPUSHs((SV*)CopFILEGV(&PL_compiling));
1959 call_sv((SV*)cv, G_DISCARD);
1966 Perl_localize(pTHX_ OP *o, I32 lex)
1968 if (o->op_flags & OPf_PARENS)
1969 /* [perl #17376]: this appears to be premature, and results in code such as
1970 C< our(%x); > executing in list mode rather than void mode */
1977 if (ckWARN(WARN_PARENTHESIS)
1978 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
1980 char *s = PL_bufptr;
1983 /* some heuristics to detect a potential error */
1984 while (*s && (strchr(", \t\n", *s)))
1988 if (*s && strchr("@$%*", *s) && *++s
1989 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
1992 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
1994 while (*s && (strchr(", \t\n", *s)))
2000 if (sigil && (*s == ';' || *s == '=')) {
2001 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2002 "Parentheses missing around \"%s\" list",
2003 lex ? (PL_in_my == KEY_our ? "our" : "my")
2011 o = mod(o, OP_NULL); /* a bit kludgey */
2013 PL_in_my_stash = Nullhv;
2018 Perl_jmaybe(pTHX_ OP *o)
2020 if (o->op_type == OP_LIST) {
2022 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2023 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2029 Perl_fold_constants(pTHX_ register OP *o)
2033 I32 type = o->op_type;
2036 if (PL_opargs[type] & OA_RETSCALAR)
2038 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2039 o->op_targ = pad_alloc(type, SVs_PADTMP);
2041 /* integerize op, unless it happens to be C<-foo>.
2042 * XXX should pp_i_negate() do magic string negation instead? */
2043 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2044 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2045 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2047 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2050 if (!(PL_opargs[type] & OA_FOLDCONST))
2055 /* XXX might want a ck_negate() for this */
2056 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2068 /* XXX what about the numeric ops? */
2069 if (PL_hints & HINT_LOCALE)
2074 goto nope; /* Don't try to run w/ errors */
2076 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2077 if ((curop->op_type != OP_CONST ||
2078 (curop->op_private & OPpCONST_BARE)) &&
2079 curop->op_type != OP_LIST &&
2080 curop->op_type != OP_SCALAR &&
2081 curop->op_type != OP_NULL &&
2082 curop->op_type != OP_PUSHMARK)
2088 curop = LINKLIST(o);
2092 sv = *(PL_stack_sp--);
2093 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2094 pad_swipe(o->op_targ, FALSE);
2095 else if (SvTEMP(sv)) { /* grab mortal temp? */
2096 (void)SvREFCNT_inc(sv);
2100 if (type == OP_RV2GV)
2101 return newGVOP(OP_GV, 0, (GV*)sv);
2102 return newSVOP(OP_CONST, 0, sv);
2109 Perl_gen_constant_list(pTHX_ register OP *o)
2113 const I32 oldtmps_floor = PL_tmps_floor;
2117 return o; /* Don't attempt to run with errors */
2119 PL_op = curop = LINKLIST(o);
2126 PL_tmps_floor = oldtmps_floor;
2128 o->op_type = OP_RV2AV;
2129 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2130 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2131 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2132 o->op_opt = 0; /* needs to be revisited in peep() */
2133 curop = ((UNOP*)o)->op_first;
2134 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2141 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2144 if (!o || o->op_type != OP_LIST)
2145 o = newLISTOP(OP_LIST, 0, o, Nullop);
2147 o->op_flags &= ~OPf_WANT;
2149 if (!(PL_opargs[type] & OA_MARK))
2150 op_null(cLISTOPo->op_first);
2152 o->op_type = (OPCODE)type;
2153 o->op_ppaddr = PL_ppaddr[type];
2154 o->op_flags |= flags;
2156 o = CHECKOP(type, o);
2157 if (o->op_type != (unsigned)type)
2160 return fold_constants(o);
2163 /* List constructors */
2166 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2174 if (first->op_type != (unsigned)type
2175 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2177 return newLISTOP(type, 0, first, last);
2180 if (first->op_flags & OPf_KIDS)
2181 ((LISTOP*)first)->op_last->op_sibling = last;
2183 first->op_flags |= OPf_KIDS;
2184 ((LISTOP*)first)->op_first = last;
2186 ((LISTOP*)first)->op_last = last;
2191 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2199 if (first->op_type != (unsigned)type)
2200 return prepend_elem(type, (OP*)first, (OP*)last);
2202 if (last->op_type != (unsigned)type)
2203 return append_elem(type, (OP*)first, (OP*)last);
2205 first->op_last->op_sibling = last->op_first;
2206 first->op_last = last->op_last;
2207 first->op_flags |= (last->op_flags & OPf_KIDS);
2215 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2223 if (last->op_type == (unsigned)type) {
2224 if (type == OP_LIST) { /* already a PUSHMARK there */
2225 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2226 ((LISTOP*)last)->op_first->op_sibling = first;
2227 if (!(first->op_flags & OPf_PARENS))
2228 last->op_flags &= ~OPf_PARENS;
2231 if (!(last->op_flags & OPf_KIDS)) {
2232 ((LISTOP*)last)->op_last = first;
2233 last->op_flags |= OPf_KIDS;
2235 first->op_sibling = ((LISTOP*)last)->op_first;
2236 ((LISTOP*)last)->op_first = first;
2238 last->op_flags |= OPf_KIDS;
2242 return newLISTOP(type, 0, first, last);
2248 Perl_newNULLLIST(pTHX)
2250 return newOP(OP_STUB, 0);
2254 Perl_force_list(pTHX_ OP *o)
2256 if (!o || o->op_type != OP_LIST)
2257 o = newLISTOP(OP_LIST, 0, o, Nullop);
2263 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2268 NewOp(1101, listop, 1, LISTOP);
2270 listop->op_type = (OPCODE)type;
2271 listop->op_ppaddr = PL_ppaddr[type];
2274 listop->op_flags = (U8)flags;
2278 else if (!first && last)
2281 first->op_sibling = last;
2282 listop->op_first = first;
2283 listop->op_last = last;
2284 if (type == OP_LIST) {
2286 pushop = newOP(OP_PUSHMARK, 0);
2287 pushop->op_sibling = first;
2288 listop->op_first = pushop;
2289 listop->op_flags |= OPf_KIDS;
2291 listop->op_last = pushop;
2294 return CHECKOP(type, listop);
2298 Perl_newOP(pTHX_ I32 type, I32 flags)
2302 NewOp(1101, o, 1, OP);
2303 o->op_type = (OPCODE)type;
2304 o->op_ppaddr = PL_ppaddr[type];
2305 o->op_flags = (U8)flags;
2308 o->op_private = (U8)(0 | (flags >> 8));
2309 if (PL_opargs[type] & OA_RETSCALAR)
2311 if (PL_opargs[type] & OA_TARGET)
2312 o->op_targ = pad_alloc(type, SVs_PADTMP);
2313 return CHECKOP(type, o);
2317 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2323 first = newOP(OP_STUB, 0);
2324 if (PL_opargs[type] & OA_MARK)
2325 first = force_list(first);
2327 NewOp(1101, unop, 1, UNOP);
2328 unop->op_type = (OPCODE)type;
2329 unop->op_ppaddr = PL_ppaddr[type];
2330 unop->op_first = first;
2331 unop->op_flags = flags | OPf_KIDS;
2332 unop->op_private = (U8)(1 | (flags >> 8));
2333 unop = (UNOP*) CHECKOP(type, unop);
2337 return fold_constants((OP *) unop);
2341 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2345 NewOp(1101, binop, 1, BINOP);
2348 first = newOP(OP_NULL, 0);
2350 binop->op_type = (OPCODE)type;
2351 binop->op_ppaddr = PL_ppaddr[type];
2352 binop->op_first = first;
2353 binop->op_flags = flags | OPf_KIDS;
2356 binop->op_private = (U8)(1 | (flags >> 8));
2359 binop->op_private = (U8)(2 | (flags >> 8));
2360 first->op_sibling = last;
2363 binop = (BINOP*)CHECKOP(type, binop);
2364 if (binop->op_next || binop->op_type != (OPCODE)type)
2367 binop->op_last = binop->op_first->op_sibling;
2369 return fold_constants((OP *)binop);
2372 static int uvcompare(const void *a, const void *b) __attribute__nonnull__(1) __attribute__nonnull__(2) __attribute__pure__;
2373 static int uvcompare(const void *a, const void *b)
2375 if (*((const UV *)a) < (*(const UV *)b))
2377 if (*((const UV *)a) > (*(const UV *)b))
2379 if (*((const UV *)a+1) < (*(const UV *)b+1))
2381 if (*((const UV *)a+1) > (*(const UV *)b+1))
2387 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2389 SV *tstr = ((SVOP*)expr)->op_sv;
2390 SV *rstr = ((SVOP*)repl)->op_sv;
2393 U8 *t = (U8*)SvPV(tstr, tlen);
2394 U8 *r = (U8*)SvPV(rstr, rlen);
2401 register short *tbl;
2403 PL_hints |= HINT_BLOCK_SCOPE;
2404 complement = o->op_private & OPpTRANS_COMPLEMENT;
2405 del = o->op_private & OPpTRANS_DELETE;
2406 squash = o->op_private & OPpTRANS_SQUASH;
2409 o->op_private |= OPpTRANS_FROM_UTF;
2412 o->op_private |= OPpTRANS_TO_UTF;
2414 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2415 SV* listsv = newSVpvn("# comment\n",10);
2417 U8* tend = t + tlen;
2418 U8* rend = r + rlen;
2432 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2433 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2439 tsave = t = bytes_to_utf8(t, &len);
2442 if (!to_utf && rlen) {
2444 rsave = r = bytes_to_utf8(r, &len);
2448 /* There are several snags with this code on EBCDIC:
2449 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2450 2. scan_const() in toke.c has encoded chars in native encoding which makes
2451 ranges at least in EBCDIC 0..255 range the bottom odd.
2455 U8 tmpbuf[UTF8_MAXBYTES+1];
2458 New(1109, cp, 2*tlen, UV);
2460 transv = newSVpvn("",0);
2462 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2464 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2466 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2470 cp[2*i+1] = cp[2*i];
2474 qsort(cp, i, 2*sizeof(UV), uvcompare);
2475 for (j = 0; j < i; j++) {
2477 diff = val - nextmin;
2479 t = uvuni_to_utf8(tmpbuf,nextmin);
2480 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2482 U8 range_mark = UTF_TO_NATIVE(0xff);
2483 t = uvuni_to_utf8(tmpbuf, val - 1);
2484 sv_catpvn(transv, (char *)&range_mark, 1);
2485 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2492 t = uvuni_to_utf8(tmpbuf,nextmin);
2493 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2495 U8 range_mark = UTF_TO_NATIVE(0xff);
2496 sv_catpvn(transv, (char *)&range_mark, 1);
2498 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2499 UNICODE_ALLOW_SUPER);
2500 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2501 t = (U8*)SvPVX(transv);
2502 tlen = SvCUR(transv);
2506 else if (!rlen && !del) {
2507 r = t; rlen = tlen; rend = tend;
2510 if ((!rlen && !del) || t == r ||
2511 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2513 o->op_private |= OPpTRANS_IDENTICAL;
2517 while (t < tend || tfirst <= tlast) {
2518 /* see if we need more "t" chars */
2519 if (tfirst > tlast) {
2520 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2522 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2524 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2531 /* now see if we need more "r" chars */
2532 if (rfirst > rlast) {
2534 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2536 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2538 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2547 rfirst = rlast = 0xffffffff;
2551 /* now see which range will peter our first, if either. */
2552 tdiff = tlast - tfirst;
2553 rdiff = rlast - rfirst;
2560 if (rfirst == 0xffffffff) {
2561 diff = tdiff; /* oops, pretend rdiff is infinite */
2563 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2564 (long)tfirst, (long)tlast);
2566 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2570 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2571 (long)tfirst, (long)(tfirst + diff),
2574 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2575 (long)tfirst, (long)rfirst);
2577 if (rfirst + diff > max)
2578 max = rfirst + diff;
2580 grows = (tfirst < rfirst &&
2581 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2593 else if (max > 0xff)
2598 Safefree(cPVOPo->op_pv);
2599 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2600 SvREFCNT_dec(listsv);
2602 SvREFCNT_dec(transv);
2604 if (!del && havefinal && rlen)
2605 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2606 newSVuv((UV)final), 0);
2609 o->op_private |= OPpTRANS_GROWS;
2621 tbl = (short*)cPVOPo->op_pv;
2623 Zero(tbl, 256, short);
2624 for (i = 0; i < (I32)tlen; i++)
2626 for (i = 0, j = 0; i < 256; i++) {
2628 if (j >= (I32)rlen) {
2637 if (i < 128 && r[j] >= 128)
2647 o->op_private |= OPpTRANS_IDENTICAL;
2649 else if (j >= (I32)rlen)
2652 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2653 tbl[0x100] = rlen - j;
2654 for (i=0; i < (I32)rlen - j; i++)
2655 tbl[0x101+i] = r[j+i];
2659 if (!rlen && !del) {
2662 o->op_private |= OPpTRANS_IDENTICAL;
2664 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2665 o->op_private |= OPpTRANS_IDENTICAL;
2667 for (i = 0; i < 256; i++)
2669 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
2670 if (j >= (I32)rlen) {
2672 if (tbl[t[i]] == -1)
2678 if (tbl[t[i]] == -1) {
2679 if (t[i] < 128 && r[j] >= 128)
2686 o->op_private |= OPpTRANS_GROWS;
2694 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2699 NewOp(1101, pmop, 1, PMOP);
2700 pmop->op_type = (OPCODE)type;
2701 pmop->op_ppaddr = PL_ppaddr[type];
2702 pmop->op_flags = (U8)flags;
2703 pmop->op_private = (U8)(0 | (flags >> 8));
2705 if (PL_hints & HINT_RE_TAINT)
2706 pmop->op_pmpermflags |= PMf_RETAINT;
2707 if (PL_hints & HINT_LOCALE)
2708 pmop->op_pmpermflags |= PMf_LOCALE;
2709 pmop->op_pmflags = pmop->op_pmpermflags;
2714 if(av_len((AV*) PL_regex_pad[0]) > -1) {
2715 repointer = av_pop((AV*)PL_regex_pad[0]);
2716 pmop->op_pmoffset = SvIV(repointer);
2717 SvREPADTMP_off(repointer);
2718 sv_setiv(repointer,0);
2720 repointer = newSViv(0);
2721 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2722 pmop->op_pmoffset = av_len(PL_regex_padav);
2723 PL_regex_pad = AvARRAY(PL_regex_padav);
2728 /* link into pm list */
2729 if (type != OP_TRANS && PL_curstash) {
2730 MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab);
2733 mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0);
2735 pmop->op_pmnext = (PMOP*)mg->mg_obj;
2736 mg->mg_obj = (SV*)pmop;
2737 PmopSTASH_set(pmop,PL_curstash);
2740 return CHECKOP(type, pmop);
2743 /* Given some sort of match op o, and an expression expr containing a
2744 * pattern, either compile expr into a regex and attach it to o (if it's
2745 * constant), or convert expr into a runtime regcomp op sequence (if it's
2748 * isreg indicates that the pattern is part of a regex construct, eg
2749 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
2750 * split "pattern", which aren't. In the former case, expr will be a list
2751 * if the pattern contains more than one term (eg /a$b/) or if it contains
2752 * a replacement, ie s/// or tr///.
2756 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
2761 I32 repl_has_vars = 0;
2765 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
2766 /* last element in list is the replacement; pop it */
2768 repl = cLISTOPx(expr)->op_last;
2769 kid = cLISTOPx(expr)->op_first;
2770 while (kid->op_sibling != repl)
2771 kid = kid->op_sibling;
2772 kid->op_sibling = Nullop;
2773 cLISTOPx(expr)->op_last = kid;
2776 if (isreg && expr->op_type == OP_LIST &&
2777 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
2779 /* convert single element list to element */
2781 expr = cLISTOPx(oe)->op_first->op_sibling;
2782 cLISTOPx(oe)->op_first->op_sibling = Nullop;
2783 cLISTOPx(oe)->op_last = Nullop;
2787 if (o->op_type == OP_TRANS) {
2788 return pmtrans(o, expr, repl);
2791 reglist = isreg && expr->op_type == OP_LIST;
2795 PL_hints |= HINT_BLOCK_SCOPE;
2798 if (expr->op_type == OP_CONST) {
2800 SV *pat = ((SVOP*)expr)->op_sv;
2801 char *p = SvPV(pat, plen);
2802 if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
2803 sv_setpvn(pat, "\\s+", 3);
2804 p = SvPV(pat, plen);
2805 pm->op_pmflags |= PMf_SKIPWHITE;
2808 pm->op_pmdynflags |= PMdf_UTF8;
2809 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
2810 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
2811 pm->op_pmflags |= PMf_WHITE;
2815 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2816 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2818 : OP_REGCMAYBE),0,expr);
2820 NewOp(1101, rcop, 1, LOGOP);
2821 rcop->op_type = OP_REGCOMP;
2822 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2823 rcop->op_first = scalar(expr);
2824 rcop->op_flags |= OPf_KIDS
2825 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
2826 | (reglist ? OPf_STACKED : 0);
2827 rcop->op_private = 1;
2830 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
2832 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
2835 /* establish postfix order */
2836 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2838 rcop->op_next = expr;
2839 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2842 rcop->op_next = LINKLIST(expr);
2843 expr->op_next = (OP*)rcop;
2846 prepend_elem(o->op_type, scalar((OP*)rcop), o);
2851 if (pm->op_pmflags & PMf_EVAL) {
2853 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
2854 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
2856 else if (repl->op_type == OP_CONST)
2860 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
2861 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
2862 if (curop->op_type == OP_GV) {
2863 GV *gv = cGVOPx_gv(curop);
2865 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
2868 else if (curop->op_type == OP_RV2CV)
2870 else if (curop->op_type == OP_RV2SV ||
2871 curop->op_type == OP_RV2AV ||
2872 curop->op_type == OP_RV2HV ||
2873 curop->op_type == OP_RV2GV) {
2874 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2877 else if (curop->op_type == OP_PADSV ||
2878 curop->op_type == OP_PADAV ||
2879 curop->op_type == OP_PADHV ||
2880 curop->op_type == OP_PADANY) {
2883 else if (curop->op_type == OP_PUSHRE)
2884 ; /* Okay here, dangerous in newASSIGNOP */
2894 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
2895 pm->op_pmflags |= PMf_CONST; /* const for long enough */
2896 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
2897 prepend_elem(o->op_type, scalar(repl), o);
2900 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
2901 pm->op_pmflags |= PMf_MAYBE_CONST;
2902 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2904 NewOp(1101, rcop, 1, LOGOP);
2905 rcop->op_type = OP_SUBSTCONT;
2906 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
2907 rcop->op_first = scalar(repl);
2908 rcop->op_flags |= OPf_KIDS;
2909 rcop->op_private = 1;
2912 /* establish postfix order */
2913 rcop->op_next = LINKLIST(repl);
2914 repl->op_next = (OP*)rcop;
2916 pm->op_pmreplroot = scalar((OP*)rcop);
2917 pm->op_pmreplstart = LINKLIST(rcop);
2926 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
2930 NewOp(1101, svop, 1, SVOP);
2931 svop->op_type = (OPCODE)type;
2932 svop->op_ppaddr = PL_ppaddr[type];
2934 svop->op_next = (OP*)svop;
2935 svop->op_flags = (U8)flags;
2936 if (PL_opargs[type] & OA_RETSCALAR)
2938 if (PL_opargs[type] & OA_TARGET)
2939 svop->op_targ = pad_alloc(type, SVs_PADTMP);
2940 return CHECKOP(type, svop);
2944 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2948 NewOp(1101, padop, 1, PADOP);
2949 padop->op_type = (OPCODE)type;
2950 padop->op_ppaddr = PL_ppaddr[type];
2951 padop->op_padix = pad_alloc(type, SVs_PADTMP);
2952 SvREFCNT_dec(PAD_SVl(padop->op_padix));
2953 PAD_SETSV(padop->op_padix, sv);
2956 padop->op_next = (OP*)padop;
2957 padop->op_flags = (U8)flags;
2958 if (PL_opargs[type] & OA_RETSCALAR)
2960 if (PL_opargs[type] & OA_TARGET)
2961 padop->op_targ = pad_alloc(type, SVs_PADTMP);
2962 return CHECKOP(type, padop);
2966 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
2972 return newPADOP(type, flags, SvREFCNT_inc(gv));
2974 return newSVOP(type, flags, SvREFCNT_inc(gv));
2979 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
2983 NewOp(1101, pvop, 1, PVOP);
2984 pvop->op_type = (OPCODE)type;
2985 pvop->op_ppaddr = PL_ppaddr[type];
2987 pvop->op_next = (OP*)pvop;
2988 pvop->op_flags = (U8)flags;
2989 if (PL_opargs[type] & OA_RETSCALAR)
2991 if (PL_opargs[type] & OA_TARGET)
2992 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
2993 return CHECKOP(type, pvop);
2997 Perl_package(pTHX_ OP *o)
3002 save_hptr(&PL_curstash);
3003 save_item(PL_curstname);
3005 name = SvPV(cSVOPo->op_sv, len);
3006 PL_curstash = gv_stashpvn(name, len, TRUE);
3007 sv_setpvn(PL_curstname, name, len);
3010 PL_hints |= HINT_BLOCK_SCOPE;
3011 PL_copline = NOLINE;
3016 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3022 if (idop->op_type != OP_CONST)
3023 Perl_croak(aTHX_ "Module name must be constant");
3027 if (version != Nullop) {
3028 SV *vesv = ((SVOP*)version)->op_sv;
3030 if (arg == Nullop && !SvNIOKp(vesv)) {
3037 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3038 Perl_croak(aTHX_ "Version number must be constant number");
3040 /* Make copy of idop so we don't free it twice */
3041 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3043 /* Fake up a method call to VERSION */
3044 meth = newSVpvn("VERSION",7);
3045 sv_upgrade(meth, SVt_PVIV);
3046 (void)SvIOK_on(meth);
3049 PERL_HASH(hash, SvPVX_const(meth), SvCUR(meth));
3050 SvUV_set(meth, hash);
3052 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3053 append_elem(OP_LIST,
3054 prepend_elem(OP_LIST, pack, list(version)),
3055 newSVOP(OP_METHOD_NAMED, 0, meth)));
3059 /* Fake up an import/unimport */
3060 if (arg && arg->op_type == OP_STUB)
3061 imop = arg; /* no import on explicit () */
3062 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3063 imop = Nullop; /* use 5.0; */
3068 /* Make copy of idop so we don't free it twice */
3069 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3071 /* Fake up a method call to import/unimport */
3072 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);
3073 (void)SvUPGRADE(meth, SVt_PVIV);
3074 (void)SvIOK_on(meth);
3077 PERL_HASH(hash, SvPVX_const(meth), SvCUR(meth));
3078 SvUV_set(meth, hash);
3080 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3081 append_elem(OP_LIST,
3082 prepend_elem(OP_LIST, pack, list(arg)),
3083 newSVOP(OP_METHOD_NAMED, 0, meth)));
3086 /* Fake up the BEGIN {}, which does its thing immediately. */
3088 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3091 append_elem(OP_LINESEQ,
3092 append_elem(OP_LINESEQ,
3093 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, idop)),
3094 newSTATEOP(0, Nullch, veop)),
3095 newSTATEOP(0, Nullch, imop) ));
3097 /* The "did you use incorrect case?" warning used to be here.
3098 * The problem is that on case-insensitive filesystems one
3099 * might get false positives for "use" (and "require"):
3100 * "use Strict" or "require CARP" will work. This causes
3101 * portability problems for the script: in case-strict
3102 * filesystems the script will stop working.
3104 * The "incorrect case" warning checked whether "use Foo"
3105 * imported "Foo" to your namespace, but that is wrong, too:
3106 * there is no requirement nor promise in the language that
3107 * a Foo.pm should or would contain anything in package "Foo".
3109 * There is very little Configure-wise that can be done, either:
3110 * the case-sensitivity of the build filesystem of Perl does not
3111 * help in guessing the case-sensitivity of the runtime environment.
3114 PL_hints |= HINT_BLOCK_SCOPE;
3115 PL_copline = NOLINE;
3117 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3121 =head1 Embedding Functions
3123 =for apidoc load_module
3125 Loads the module whose name is pointed to by the string part of name.
3126 Note that the actual module name, not its filename, should be given.
3127 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3128 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3129 (or 0 for no flags). ver, if specified, provides version semantics
3130 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3131 arguments can be used to specify arguments to the module's import()
3132 method, similar to C<use Foo::Bar VERSION LIST>.
3137 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3140 va_start(args, ver);
3141 vload_module(flags, name, ver, &args);
3145 #ifdef PERL_IMPLICIT_CONTEXT
3147 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3151 va_start(args, ver);
3152 vload_module(flags, name, ver, &args);
3158 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3160 OP *modname, *veop, *imop;
3162 modname = newSVOP(OP_CONST, 0, name);
3163 modname->op_private |= OPpCONST_BARE;
3165 veop = newSVOP(OP_CONST, 0, ver);
3169 if (flags & PERL_LOADMOD_NOIMPORT) {
3170 imop = sawparens(newNULLLIST());
3172 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3173 imop = va_arg(*args, OP*);
3178 sv = va_arg(*args, SV*);
3180 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3181 sv = va_arg(*args, SV*);
3185 const line_t ocopline = PL_copline;
3186 COP * const ocurcop = PL_curcop;
3187 const int oexpect = PL_expect;
3189 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3190 veop, modname, imop);
3191 PL_expect = oexpect;
3192 PL_copline = ocopline;
3193 PL_curcop = ocurcop;
3198 Perl_dofile(pTHX_ OP *term)
3203 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3204 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
3205 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3207 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3208 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3209 append_elem(OP_LIST, term,
3210 scalar(newUNOP(OP_RV2CV, 0,
3215 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3221 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3223 return newBINOP(OP_LSLICE, flags,
3224 list(force_list(subscript)),
3225 list(force_list(listval)) );
3229 S_list_assignment(pTHX_ register const OP *o)
3234 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3235 o = cUNOPo->op_first;
3237 if (o->op_type == OP_COND_EXPR) {
3238 const I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3239 const I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3244 yyerror("Assignment to both a list and a scalar");
3248 if (o->op_type == OP_LIST &&
3249 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3250 o->op_private & OPpLVAL_INTRO)
3253 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3254 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3255 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3258 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3261 if (o->op_type == OP_RV2SV)
3268 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3273 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3274 return newLOGOP(optype, 0,
3275 mod(scalar(left), optype),
3276 newUNOP(OP_SASSIGN, 0, scalar(right)));
3279 return newBINOP(optype, OPf_STACKED,
3280 mod(scalar(left), optype), scalar(right));
3284 if (list_assignment(left)) {
3288 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3289 left = mod(left, OP_AASSIGN);
3297 /* optimise C<my @x = ()> to C<my @x>, and likewise for hashes */
3298 if ((left->op_type == OP_PADAV || left->op_type == OP_PADHV)
3299 && right->op_type == OP_STUB
3300 && (left->op_private & OPpLVAL_INTRO))
3303 left->op_flags &= ~(OPf_REF|OPf_SPECIAL);
3306 curop = list(force_list(left));
3307 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3308 o->op_private = (U8)(0 | (flags >> 8));
3310 /* PL_generation sorcery:
3311 * an assignment like ($a,$b) = ($c,$d) is easier than
3312 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3313 * To detect whether there are common vars, the global var
3314 * PL_generation is incremented for each assign op we compile.
3315 * Then, while compiling the assign op, we run through all the
3316 * variables on both sides of the assignment, setting a spare slot
3317 * in each of them to PL_generation. If any of them already have
3318 * that value, we know we've got commonality. We could use a
3319 * single bit marker, but then we'd have to make 2 passes, first
3320 * to clear the flag, then to test and set it. To find somewhere
3321 * to store these values, evil chicanery is done with SvCUR().
3324 if (!(left->op_private & OPpLVAL_INTRO)) {
3327 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3328 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3329 if (curop->op_type == OP_GV) {
3330 GV *gv = cGVOPx_gv(curop);
3331 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3333 SvCUR_set(gv, PL_generation);
3335 else if (curop->op_type == OP_PADSV ||
3336 curop->op_type == OP_PADAV ||
3337 curop->op_type == OP_PADHV ||
3338 curop->op_type == OP_PADANY)
3340 if (PAD_COMPNAME_GEN(curop->op_targ)
3341 == (STRLEN)PL_generation)
3343 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
3346 else if (curop->op_type == OP_RV2CV)
3348 else if (curop->op_type == OP_RV2SV ||
3349 curop->op_type == OP_RV2AV ||
3350 curop->op_type == OP_RV2HV ||
3351 curop->op_type == OP_RV2GV) {
3352 if (lastop->op_type != OP_GV) /* funny deref? */
3355 else if (curop->op_type == OP_PUSHRE) {
3356 if (((PMOP*)curop)->op_pmreplroot) {
3358 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3359 ((PMOP*)curop)->op_pmreplroot));
3361 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3363 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3365 SvCUR_set(gv, PL_generation);
3374 o->op_private |= OPpASSIGN_COMMON;
3376 if (right && right->op_type == OP_SPLIT) {
3378 if ((tmpop = ((LISTOP*)right)->op_first) &&
3379 tmpop->op_type == OP_PUSHRE)
3381 PMOP *pm = (PMOP*)tmpop;
3382 if (left->op_type == OP_RV2AV &&
3383 !(left->op_private & OPpLVAL_INTRO) &&
3384 !(o->op_private & OPpASSIGN_COMMON) )
3386 tmpop = ((UNOP*)left)->op_first;
3387 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3389 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3390 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3392 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3393 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3395 pm->op_pmflags |= PMf_ONCE;
3396 tmpop = cUNOPo->op_first; /* to list (nulled) */
3397 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3398 tmpop->op_sibling = Nullop; /* don't free split */
3399 right->op_next = tmpop->op_next; /* fix starting loc */
3400 op_free(o); /* blow off assign */
3401 right->op_flags &= ~OPf_WANT;
3402 /* "I don't know and I don't care." */
3407 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3408 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3410 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3412 sv_setiv(sv, PL_modcount+1);
3420 right = newOP(OP_UNDEF, 0);
3421 if (right->op_type == OP_READLINE) {
3422 right->op_flags |= OPf_STACKED;
3423 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3426 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3427 o = newBINOP(OP_SASSIGN, flags,
3428 scalar(right), mod(scalar(left), OP_SASSIGN) );
3440 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3443 const U32 seq = intro_my();
3446 NewOp(1101, cop, 1, COP);
3447 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3448 cop->op_type = OP_DBSTATE;
3449 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3452 cop->op_type = OP_NEXTSTATE;
3453 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3455 cop->op_flags = (U8)flags;
3456 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3458 cop->op_private |= NATIVE_HINTS;
3460 PL_compiling.op_private = cop->op_private;
3461 cop->op_next = (OP*)cop;
3464 cop->cop_label = label;
3465 PL_hints |= HINT_BLOCK_SCOPE;
3468 cop->cop_arybase = PL_curcop->cop_arybase;
3469 if (specialWARN(PL_curcop->cop_warnings))
3470 cop->cop_warnings = PL_curcop->cop_warnings ;
3472 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3473 if (specialCopIO(PL_curcop->cop_io))
3474 cop->cop_io = PL_curcop->cop_io;
3476 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3479 if (PL_copline == NOLINE)
3480 CopLINE_set(cop, CopLINE(PL_curcop));
3482 CopLINE_set(cop, PL_copline);
3483 PL_copline = NOLINE;
3486 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3488 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3490 CopSTASH_set(cop, PL_curstash);
3492 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3493 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3494 if (svp && *svp != &PL_sv_undef ) {
3495 (void)SvIOK_on(*svp);
3496 SvIV_set(*svp, PTR2IV(cop));
3500 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3505 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3508 return new_logop(type, flags, &first, &other);
3512 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3517 OP *first = *firstp;
3518 OP *other = *otherp;
3520 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3521 return newBINOP(type, flags, scalar(first), scalar(other));
3523 scalarboolean(first);
3524 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3525 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3526 if (type == OP_AND || type == OP_OR) {
3532 first = *firstp = cUNOPo->op_first;
3534 first->op_next = o->op_next;
3535 cUNOPo->op_first = Nullop;
3539 if (first->op_type == OP_CONST) {
3540 if (first->op_private & OPpCONST_STRICT)
3541 no_bareword_allowed(first);
3542 else if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3543 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3544 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
3545 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
3546 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
3549 if (other->op_type == OP_CONST)
3550 other->op_private |= OPpCONST_SHORTCIRCUIT;
3554 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
3555 const OP *o2 = other;
3556 if ( ! (o2->op_type == OP_LIST
3557 && (( o2 = cUNOPx(o2)->op_first))
3558 && o2->op_type == OP_PUSHMARK
3559 && (( o2 = o2->op_sibling)) )
3562 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
3563 || o2->op_type == OP_PADHV)
3564 && o2->op_private & OPpLVAL_INTRO
3565 && ckWARN(WARN_DEPRECATED))
3567 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
3568 "Deprecated use of my() in false conditional");
3573 if (first->op_type == OP_CONST)
3574 first->op_private |= OPpCONST_SHORTCIRCUIT;
3578 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS) &&
3579 type != OP_DOR) /* [#24076] Don't warn for <FH> err FOO. */
3581 const OP *k1 = ((UNOP*)first)->op_first;
3582 const OP *k2 = k1->op_sibling;
3584 switch (first->op_type)
3587 if (k2 && k2->op_type == OP_READLINE
3588 && (k2->op_flags & OPf_STACKED)
3589 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3591 warnop = k2->op_type;
3596 if (k1->op_type == OP_READDIR
3597 || k1->op_type == OP_GLOB
3598 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3599 || k1->op_type == OP_EACH)
3601 warnop = ((k1->op_type == OP_NULL)
3602 ? (OPCODE)k1->op_targ : k1->op_type);
3607 const line_t oldline = CopLINE(PL_curcop);
3608 CopLINE_set(PL_curcop, PL_copline);
3609 Perl_warner(aTHX_ packWARN(WARN_MISC),
3610 "Value of %s%s can be \"0\"; test with defined()",
3612 ((warnop == OP_READLINE || warnop == OP_GLOB)
3613 ? " construct" : "() operator"));
3614 CopLINE_set(PL_curcop, oldline);
3621 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3622 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3624 NewOp(1101, logop, 1, LOGOP);
3626 logop->op_type = (OPCODE)type;
3627 logop->op_ppaddr = PL_ppaddr[type];
3628 logop->op_first = first;
3629 logop->op_flags = flags | OPf_KIDS;
3630 logop->op_other = LINKLIST(other);
3631 logop->op_private = (U8)(1 | (flags >> 8));
3633 /* establish postfix order */
3634 logop->op_next = LINKLIST(first);
3635 first->op_next = (OP*)logop;
3636 first->op_sibling = other;
3638 CHECKOP(type,logop);
3640 o = newUNOP(OP_NULL, 0, (OP*)logop);
3647 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3655 return newLOGOP(OP_AND, 0, first, trueop);
3657 return newLOGOP(OP_OR, 0, first, falseop);
3659 scalarboolean(first);
3660 if (first->op_type == OP_CONST) {
3661 if (first->op_private & OPpCONST_BARE &&
3662 first->op_private & OPpCONST_STRICT) {
3663 no_bareword_allowed(first);
3665 if (SvTRUE(((SVOP*)first)->op_sv)) {
3676 NewOp(1101, logop, 1, LOGOP);
3677 logop->op_type = OP_COND_EXPR;
3678 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3679 logop->op_first = first;
3680 logop->op_flags = flags | OPf_KIDS;
3681 logop->op_private = (U8)(1 | (flags >> 8));
3682 logop->op_other = LINKLIST(trueop);
3683 logop->op_next = LINKLIST(falseop);
3685 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
3688 /* establish postfix order */
3689 start = LINKLIST(first);
3690 first->op_next = (OP*)logop;
3692 first->op_sibling = trueop;
3693 trueop->op_sibling = falseop;
3694 o = newUNOP(OP_NULL, 0, (OP*)logop);
3696 trueop->op_next = falseop->op_next = o;
3703 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3712 NewOp(1101, range, 1, LOGOP);
3714 range->op_type = OP_RANGE;
3715 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3716 range->op_first = left;
3717 range->op_flags = OPf_KIDS;
3718 leftstart = LINKLIST(left);
3719 range->op_other = LINKLIST(right);
3720 range->op_private = (U8)(1 | (flags >> 8));
3722 left->op_sibling = right;
3724 range->op_next = (OP*)range;
3725 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3726 flop = newUNOP(OP_FLOP, 0, flip);
3727 o = newUNOP(OP_NULL, 0, flop);
3729 range->op_next = leftstart;
3731 left->op_next = flip;
3732 right->op_next = flop;
3734 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3735 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3736 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3737 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3739 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3740 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3743 if (!flip->op_private || !flop->op_private)
3744 linklist(o); /* blow off optimizer unless constant */
3750 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3754 const bool once = block && block->op_flags & OPf_SPECIAL &&
3755 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3759 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3760 return block; /* do {} while 0 does once */
3761 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3762 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3763 expr = newUNOP(OP_DEFINED, 0,
3764 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3765 } else if (expr->op_flags & OPf_KIDS) {
3766 const OP *k1 = ((UNOP*)expr)->op_first;
3767 const OP *k2 = (k1) ? k1->op_sibling : NULL;
3768 switch (expr->op_type) {
3770 if (k2 && k2->op_type == OP_READLINE
3771 && (k2->op_flags & OPf_STACKED)
3772 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3773 expr = newUNOP(OP_DEFINED, 0, expr);
3777 if (k1->op_type == OP_READDIR
3778 || k1->op_type == OP_GLOB
3779 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3780 || k1->op_type == OP_EACH)
3781 expr = newUNOP(OP_DEFINED, 0, expr);
3787 /* if block is null, the next append_elem() would put UNSTACK, a scalar
3788 * op, in listop. This is wrong. [perl #27024] */
3790 block = newOP(OP_NULL, 0);
3791 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3792 o = new_logop(OP_AND, 0, &expr, &listop);
3795 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3797 if (once && o != listop)
3798 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3801 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3803 o->op_flags |= flags;
3805 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3810 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
3811 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
3821 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3822 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3823 expr = newUNOP(OP_DEFINED, 0,
3824 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3825 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3826 const OP *k1 = ((UNOP*)expr)->op_first;
3827 const OP *k2 = (k1) ? k1->op_sibling : NULL;
3828 switch (expr->op_type) {
3830 if (k2 && k2->op_type == OP_READLINE
3831 && (k2->op_flags & OPf_STACKED)
3832 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3833 expr = newUNOP(OP_DEFINED, 0, expr);
3837 if (k1->op_type == OP_READDIR
3838 || k1->op_type == OP_GLOB
3839 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3840 || k1->op_type == OP_EACH)
3841 expr = newUNOP(OP_DEFINED, 0, expr);
3847 block = newOP(OP_NULL, 0);
3848 else if (cont || has_my) {
3849 block = scope(block);
3853 next = LINKLIST(cont);
3856 OP *unstack = newOP(OP_UNSTACK, 0);
3859 cont = append_elem(OP_LINESEQ, cont, unstack);
3862 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3863 redo = LINKLIST(listop);
3866 PL_copline = (line_t)whileline;
3868 o = new_logop(OP_AND, 0, &expr, &listop);
3869 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3870 op_free(expr); /* oops, it's a while (0) */
3872 return Nullop; /* listop already freed by new_logop */
3875 ((LISTOP*)listop)->op_last->op_next =
3876 (o == listop ? redo : LINKLIST(o));
3882 NewOp(1101,loop,1,LOOP);
3883 loop->op_type = OP_ENTERLOOP;
3884 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3885 loop->op_private = 0;
3886 loop->op_next = (OP*)loop;
3889 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3891 loop->op_redoop = redo;
3892 loop->op_lastop = o;
3893 o->op_private |= loopflags;
3896 loop->op_nextop = next;
3898 loop->op_nextop = o;
3900 o->op_flags |= flags;
3901 o->op_private |= (flags >> 8);
3906 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
3911 PADOFFSET padoff = 0;
3916 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
3917 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
3918 sv->op_type = OP_RV2GV;
3919 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3921 else if (sv->op_type == OP_PADSV) { /* private variable */
3922 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
3923 padoff = sv->op_targ;
3928 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3929 padoff = sv->op_targ;
3931 iterflags |= OPf_SPECIAL;
3936 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3939 const I32 offset = pad_findmy("$_");
3940 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
3941 sv = newGVOP(OP_GV, 0, PL_defgv);
3947 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3948 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3949 iterflags |= OPf_STACKED;
3951 else if (expr->op_type == OP_NULL &&
3952 (expr->op_flags & OPf_KIDS) &&
3953 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3955 /* Basically turn for($x..$y) into the same as for($x,$y), but we
3956 * set the STACKED flag to indicate that these values are to be
3957 * treated as min/max values by 'pp_iterinit'.
3959 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
3960 LOGOP* range = (LOGOP*) flip->op_first;
3961 OP* left = range->op_first;
3962 OP* right = left->op_sibling;
3965 range->op_flags &= ~OPf_KIDS;
3966 range->op_first = Nullop;
3968 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
3969 listop->op_first->op_next = range->op_next;
3970 left->op_next = range->op_other;
3971 right->op_next = (OP*)listop;
3972 listop->op_next = listop->op_first;
3975 expr = (OP*)(listop);
3977 iterflags |= OPf_STACKED;
3980 expr = mod(force_list(expr), OP_GREPSTART);
3983 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
3984 append_elem(OP_LIST, expr, scalar(sv))));
3985 assert(!loop->op_next);
3986 /* for my $x () sets OPpLVAL_INTRO;
3987 * for our $x () sets OPpOUR_INTRO */
3988 loop->op_private = (U8)iterpflags;
3989 #ifdef PL_OP_SLAB_ALLOC
3992 NewOp(1234,tmp,1,LOOP);
3993 Copy(loop,tmp,1,LISTOP);
3998 Renew(loop, 1, LOOP);
4000 loop->op_targ = padoff;
4001 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4002 PL_copline = forline;
4003 return newSTATEOP(0, label, wop);
4007 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4012 if (type != OP_GOTO || label->op_type == OP_CONST) {
4013 /* "last()" means "last" */
4014 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4015 o = newOP(type, OPf_SPECIAL);
4017 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4018 ? SvPVx(((SVOP*)label)->op_sv, n_a)
4024 /* Check whether it's going to be a goto &function */
4025 if (label->op_type == OP_ENTERSUB
4026 && !(label->op_flags & OPf_STACKED))
4027 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4028 o = newUNOP(type, OPf_STACKED, label);
4030 PL_hints |= HINT_BLOCK_SCOPE;
4035 =for apidoc cv_undef
4037 Clear out all the active components of a CV. This can happen either
4038 by an explicit C<undef &foo>, or by the reference count going to zero.
4039 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4040 children can still follow the full lexical scope chain.
4046 Perl_cv_undef(pTHX_ CV *cv)
4050 if (CvFILE(cv) && !CvXSUB(cv)) {
4051 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4052 Safefree(CvFILE(cv));
4057 if (!CvXSUB(cv) && CvROOT(cv)) {
4059 Perl_croak(aTHX_ "Can't undef active subroutine");
4062 PAD_SAVE_SETNULLPAD();
4064 op_free(CvROOT(cv));
4065 CvROOT(cv) = Nullop;
4068 SvPOK_off((SV*)cv); /* forget prototype */
4073 /* remove CvOUTSIDE unless this is an undef rather than a free */
4074 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4075 if (!CvWEAKOUTSIDE(cv))
4076 SvREFCNT_dec(CvOUTSIDE(cv));
4077 CvOUTSIDE(cv) = Nullcv;
4080 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4086 /* delete all flags except WEAKOUTSIDE */
4087 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4091 Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p)
4093 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX_const(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4094 SV* msg = sv_newmortal();
4098 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4099 sv_setpv(msg, "Prototype mismatch:");
4101 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4103 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (const SV *)cv);
4105 Perl_sv_catpv(aTHX_ msg, ": none");
4106 sv_catpv(msg, " vs ");
4108 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4110 sv_catpv(msg, "none");
4111 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
4115 static void const_sv_xsub(pTHX_ CV* cv);
4119 =head1 Optree Manipulation Functions
4121 =for apidoc cv_const_sv
4123 If C<cv> is a constant sub eligible for inlining. returns the constant
4124 value returned by the sub. Otherwise, returns NULL.
4126 Constant subs can be created with C<newCONSTSUB> or as described in
4127 L<perlsub/"Constant Functions">.
4132 Perl_cv_const_sv(pTHX_ CV *cv)
4134 if (!cv || !CvCONST(cv))
4136 return (SV*)CvXSUBANY(cv).any_ptr;
4139 /* op_const_sv: examine an optree to determine whether it's in-lineable.
4140 * Can be called in 3 ways:
4143 * look for a single OP_CONST with attached value: return the value
4145 * cv && CvCLONE(cv) && !CvCONST(cv)
4147 * examine the clone prototype, and if contains only a single
4148 * OP_CONST referencing a pad const, or a single PADSV referencing
4149 * an outer lexical, return a non-zero value to indicate the CV is
4150 * a candidate for "constizing" at clone time
4154 * We have just cloned an anon prototype that was marked as a const
4155 * candidiate. Try to grab the current value, and in the case of
4156 * PADSV, ignore it if it has multiple references. Return the value.
4160 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
4167 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4168 o = cLISTOPo->op_first->op_sibling;
4170 for (; o; o = o->op_next) {
4171 OPCODE type = o->op_type;
4173 if (sv && o->op_next == o)
4175 if (o->op_next != o) {
4176 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4178 if (type == OP_DBSTATE)
4181 if (type == OP_LEAVESUB || type == OP_RETURN)
4185 if (type == OP_CONST && cSVOPo->op_sv)
4187 else if (cv && type == OP_CONST) {
4188 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4192 else if (cv && type == OP_PADSV) {
4193 if (CvCONST(cv)) { /* newly cloned anon */
4194 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4195 /* the candidate should have 1 ref from this pad and 1 ref
4196 * from the parent */
4197 if (!sv || SvREFCNT(sv) != 2)
4204 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4205 sv = &PL_sv_undef; /* an arbitrary non-null value */
4216 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4227 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4231 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4233 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4237 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4248 const char * const name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4251 assert(proto->op_type == OP_CONST);
4252 ps = SvPVx(((SVOP*)proto)->op_sv, ps_len);
4257 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4258 SV *sv = sv_newmortal();
4259 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4260 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4261 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4262 aname = SvPVX_const(sv);
4266 gv = name ? gv_fetchsv(cSVOPo->op_sv,
4267 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4269 : gv_fetchpv(aname ? aname
4270 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4271 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4281 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4282 maximum a prototype before. */
4283 if (SvTYPE(gv) > SVt_NULL) {
4284 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4285 && ckWARN_d(WARN_PROTOTYPE))
4287 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4289 cv_ckproto((CV*)gv, NULL, ps);
4292 sv_setpvn((SV*)gv, ps, ps_len);
4294 sv_setiv((SV*)gv, -1);
4295 SvREFCNT_dec(PL_compcv);
4296 cv = PL_compcv = NULL;
4297 PL_sub_generation++;
4301 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4303 #ifdef GV_UNIQUE_CHECK
4304 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4305 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4309 if (!block || !ps || *ps || attrs)
4312 const_sv = op_const_sv(block, Nullcv);
4315 const bool exists = CvROOT(cv) || CvXSUB(cv);
4317 #ifdef GV_UNIQUE_CHECK
4318 if (exists && GvUNIQUE(gv)) {
4319 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4323 /* if the subroutine doesn't exist and wasn't pre-declared
4324 * with a prototype, assume it will be AUTOLOADed,
4325 * skipping the prototype check
4327 if (exists || SvPOK(cv))
4328 cv_ckproto(cv, gv, ps);
4329 /* already defined (or promised)? */
4330 if (exists || GvASSUMECV(gv)) {
4331 if (!block && !attrs) {
4332 if (CvFLAGS(PL_compcv)) {
4333 /* might have had built-in attrs applied */
4334 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4336 /* just a "sub foo;" when &foo is already defined */
4337 SAVEFREESV(PL_compcv);
4340 /* ahem, death to those who redefine active sort subs */
4341 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4342 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4344 if (ckWARN(WARN_REDEFINE)
4346 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4348 const line_t oldline = CopLINE(PL_curcop);
4349 if (PL_copline != NOLINE)
4350 CopLINE_set(PL_curcop, PL_copline);
4351 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4352 CvCONST(cv) ? "Constant subroutine %s redefined"
4353 : "Subroutine %s redefined", name);
4354 CopLINE_set(PL_curcop, oldline);
4362 (void)SvREFCNT_inc(const_sv);
4364 assert(!CvROOT(cv) && !CvCONST(cv));
4365 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
4366 CvXSUBANY(cv).any_ptr = const_sv;
4367 CvXSUB(cv) = const_sv_xsub;
4372 cv = newCONSTSUB(NULL, name, const_sv);
4375 SvREFCNT_dec(PL_compcv);
4377 PL_sub_generation++;
4384 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4385 * before we clobber PL_compcv.
4389 /* Might have had built-in attributes applied -- propagate them. */
4390 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4391 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4392 stash = GvSTASH(CvGV(cv));
4393 else if (CvSTASH(cv))
4394 stash = CvSTASH(cv);
4396 stash = PL_curstash;
4399 /* possibly about to re-define existing subr -- ignore old cv */
4400 rcv = (SV*)PL_compcv;
4401 if (name && GvSTASH(gv))
4402 stash = GvSTASH(gv);
4404 stash = PL_curstash;
4406 apply_attrs(stash, rcv, attrs, FALSE);
4408 if (cv) { /* must reuse cv if autoloaded */
4410 /* got here with just attrs -- work done, so bug out */
4411 SAVEFREESV(PL_compcv);
4414 /* transfer PL_compcv to cv */
4416 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4417 if (!CvWEAKOUTSIDE(cv))
4418 SvREFCNT_dec(CvOUTSIDE(cv));
4419 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4420 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4421 CvOUTSIDE(PL_compcv) = 0;
4422 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4423 CvPADLIST(PL_compcv) = 0;
4424 /* inner references to PL_compcv must be fixed up ... */
4425 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4426 /* ... before we throw it away */
4427 SvREFCNT_dec(PL_compcv);
4429 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4430 ++PL_sub_generation;
4437 PL_sub_generation++;
4441 CvFILE_set_from_cop(cv, PL_curcop);
4442 CvSTASH(cv) = PL_curstash;
4445 sv_setpvn((SV*)cv, ps, ps_len);
4447 if (PL_error_count) {
4451 const char *s = strrchr(name, ':');
4453 if (strEQ(s, "BEGIN")) {
4454 const char not_safe[] =
4455 "BEGIN not safe after errors--compilation aborted";
4456 if (PL_in_eval & EVAL_KEEPERR)
4457 Perl_croak(aTHX_ not_safe);
4459 /* force display of errors found but not reported */
4460 sv_catpv(ERRSV, not_safe);
4461 Perl_croak(aTHX_ "%"SVf, ERRSV);
4470 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4471 mod(scalarseq(block), OP_LEAVESUBLV));
4474 /* This makes sub {}; work as expected. */
4475 if (block->op_type == OP_STUB) {
4477 block = newSTATEOP(0, Nullch, 0);
4479 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4481 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4482 OpREFCNT_set(CvROOT(cv), 1);
4483 CvSTART(cv) = LINKLIST(CvROOT(cv));
4484 CvROOT(cv)->op_next = 0;
4485 CALL_PEEP(CvSTART(cv));
4487 /* now that optimizer has done its work, adjust pad values */
4489 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4492 assert(!CvCONST(cv));
4493 if (ps && !*ps && op_const_sv(block, cv))
4497 if (name || aname) {
4499 const char *tname = (name ? name : aname);
4501 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4502 SV *sv = NEWSV(0,0);
4503 SV *tmpstr = sv_newmortal();
4504 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4508 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4510 (long)PL_subline, (long)CopLINE(PL_curcop));
4511 gv_efullname3(tmpstr, gv, Nullch);
4512 hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
4513 hv = GvHVn(db_postponed);
4514 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))
4515 && (pcv = GvCV(db_postponed)))
4521 call_sv((SV*)pcv, G_DISCARD);
4525 if ((s = strrchr(tname,':')))
4530 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4533 if (strEQ(s, "BEGIN") && !PL_error_count) {
4534 const I32 oldscope = PL_scopestack_ix;
4536 SAVECOPFILE(&PL_compiling);
4537 SAVECOPLINE(&PL_compiling);
4540 PL_beginav = newAV();
4541 DEBUG_x( dump_sub(gv) );
4542 av_push(PL_beginav, (SV*)cv);
4543 GvCV(gv) = 0; /* cv has been hijacked */
4544 call_list(oldscope, PL_beginav);
4546 PL_curcop = &PL_compiling;
4547 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4550 else if (strEQ(s, "END") && !PL_error_count) {
4553 DEBUG_x( dump_sub(gv) );
4554 av_unshift(PL_endav, 1);
4555 av_store(PL_endav, 0, (SV*)cv);
4556 GvCV(gv) = 0; /* cv has been hijacked */
4558 else if (strEQ(s, "CHECK") && !PL_error_count) {
4560 PL_checkav = newAV();
4561 DEBUG_x( dump_sub(gv) );
4562 if (PL_main_start && ckWARN(WARN_VOID))
4563 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4564 av_unshift(PL_checkav, 1);
4565 av_store(PL_checkav, 0, (SV*)cv);
4566 GvCV(gv) = 0; /* cv has been hijacked */
4568 else if (strEQ(s, "INIT") && !PL_error_count) {
4570 PL_initav = newAV();
4571 DEBUG_x( dump_sub(gv) );
4572 if (PL_main_start && ckWARN(WARN_VOID))
4573 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4574 av_push(PL_initav, (SV*)cv);
4575 GvCV(gv) = 0; /* cv has been hijacked */
4580 PL_copline = NOLINE;
4585 /* XXX unsafe for threads if eval_owner isn't held */
4587 =for apidoc newCONSTSUB
4589 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4590 eligible for inlining at compile-time.
4596 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
4603 SAVECOPLINE(PL_curcop);
4604 CopLINE_set(PL_curcop, PL_copline);
4607 PL_hints &= ~HINT_BLOCK_SCOPE;
4610 SAVESPTR(PL_curstash);
4611 SAVECOPSTASH(PL_curcop);
4612 PL_curstash = stash;
4613 CopSTASH_set(PL_curcop,stash);
4616 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4617 CvXSUBANY(cv).any_ptr = sv;
4619 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
4622 CopSTASH_free(PL_curcop);
4630 =for apidoc U||newXS
4632 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4638 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
4640 GV *gv = gv_fetchpv(name ? name :
4641 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4642 GV_ADDMULTI, SVt_PVCV);
4646 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4648 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4650 /* just a cached method */
4654 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4655 /* already defined (or promised) */
4656 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4657 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4658 const line_t oldline = CopLINE(PL_curcop);
4659 if (PL_copline != NOLINE)
4660 CopLINE_set(PL_curcop, PL_copline);
4661 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4662 CvCONST(cv) ? "Constant subroutine %s redefined"
4663 : "Subroutine %s redefined"
4665 CopLINE_set(PL_curcop, oldline);
4672 if (cv) /* must reuse cv if autoloaded */
4675 cv = (CV*)NEWSV(1105,0);
4676 sv_upgrade((SV *)cv, SVt_PVCV);
4680 PL_sub_generation++;
4684 (void)gv_fetchfile(filename);
4685 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
4686 an external constant string */
4687 CvXSUB(cv) = subaddr;
4690 const char *s = strrchr(name,':');
4696 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4699 if (strEQ(s, "BEGIN")) {
4701 PL_beginav = newAV();
4702 av_push(PL_beginav, (SV*)cv);
4703 GvCV(gv) = 0; /* cv has been hijacked */
4705 else if (strEQ(s, "END")) {
4708 av_unshift(PL_endav, 1);
4709 av_store(PL_endav, 0, (SV*)cv);
4710 GvCV(gv) = 0; /* cv has been hijacked */
4712 else if (strEQ(s, "CHECK")) {
4714 PL_checkav = newAV();
4715 if (PL_main_start && ckWARN(WARN_VOID))
4716 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4717 av_unshift(PL_checkav, 1);
4718 av_store(PL_checkav, 0, (SV*)cv);
4719 GvCV(gv) = 0; /* cv has been hijacked */
4721 else if (strEQ(s, "INIT")) {
4723 PL_initav = newAV();
4724 if (PL_main_start && ckWARN(WARN_VOID))
4725 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4726 av_push(PL_initav, (SV*)cv);
4727 GvCV(gv) = 0; /* cv has been hijacked */
4738 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4744 gv = gv_fetchsv(cSVOPo->op_sv, TRUE, SVt_PVFM);
4746 gv = gv_fetchpv("STDOUT", TRUE, SVt_PVFM);
4748 #ifdef GV_UNIQUE_CHECK
4750 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4754 if ((cv = GvFORM(gv))) {
4755 if (ckWARN(WARN_REDEFINE)) {
4756 const line_t oldline = CopLINE(PL_curcop);
4757 if (PL_copline != NOLINE)
4758 CopLINE_set(PL_curcop, PL_copline);
4759 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4760 o ? "Format %"SVf" redefined"
4761 : "Format STDOUT redefined" ,cSVOPo->op_sv);
4762 CopLINE_set(PL_curcop, oldline);
4769 CvFILE_set_from_cop(cv, PL_curcop);
4772 pad_tidy(padtidy_FORMAT);
4773 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4774 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4775 OpREFCNT_set(CvROOT(cv), 1);
4776 CvSTART(cv) = LINKLIST(CvROOT(cv));
4777 CvROOT(cv)->op_next = 0;
4778 CALL_PEEP(CvSTART(cv));
4780 PL_copline = NOLINE;
4785 Perl_newANONLIST(pTHX_ OP *o)
4787 return newUNOP(OP_REFGEN, 0,
4788 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4792 Perl_newANONHASH(pTHX_ OP *o)
4794 return newUNOP(OP_REFGEN, 0,
4795 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4799 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4801 return newANONATTRSUB(floor, proto, Nullop, block);
4805 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4807 return newUNOP(OP_REFGEN, 0,
4808 newSVOP(OP_ANONCODE, 0,
4809 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
4813 Perl_oopsAV(pTHX_ OP *o)
4816 switch (o->op_type) {
4818 o->op_type = OP_PADAV;
4819 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4820 return ref(o, OP_RV2AV);
4823 o->op_type = OP_RV2AV;
4824 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4829 if (ckWARN_d(WARN_INTERNAL))
4830 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
4837 Perl_oopsHV(pTHX_ OP *o)
4840 switch (o->op_type) {
4843 o->op_type = OP_PADHV;
4844 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4845 return ref(o, OP_RV2HV);
4849 o->op_type = OP_RV2HV;
4850 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
4855 if (ckWARN_d(WARN_INTERNAL))
4856 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
4863 Perl_newAVREF(pTHX_ OP *o)
4866 if (o->op_type == OP_PADANY) {
4867 o->op_type = OP_PADAV;
4868 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4871 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
4872 && ckWARN(WARN_DEPRECATED)) {
4873 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4874 "Using an array as a reference is deprecated");
4876 return newUNOP(OP_RV2AV, 0, scalar(o));
4880 Perl_newGVREF(pTHX_ I32 type, OP *o)
4882 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
4883 return newUNOP(OP_NULL, 0, o);
4884 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
4888 Perl_newHVREF(pTHX_ OP *o)
4891 if (o->op_type == OP_PADANY) {
4892 o->op_type = OP_PADHV;
4893 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4896 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
4897 && ckWARN(WARN_DEPRECATED)) {
4898 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4899 "Using a hash as a reference is deprecated");
4901 return newUNOP(OP_RV2HV, 0, scalar(o));
4905 Perl_oopsCV(pTHX_ OP *o)
4907 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
4910 NORETURN_FUNCTION_END;
4914 Perl_newCVREF(pTHX_ I32 flags, OP *o)
4916 return newUNOP(OP_RV2CV, flags, scalar(o));
4920 Perl_newSVREF(pTHX_ OP *o)
4923 if (o->op_type == OP_PADANY) {
4924 o->op_type = OP_PADSV;
4925 o->op_ppaddr = PL_ppaddr[OP_PADSV];
4928 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4929 o->op_flags |= OPpDONE_SVREF;
4932 return newUNOP(OP_RV2SV, 0, scalar(o));
4935 /* Check routines. See the comments at the top of this file for details
4936 * on when these are called */
4939 Perl_ck_anoncode(pTHX_ OP *o)
4941 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
4942 cSVOPo->op_sv = Nullsv;
4947 Perl_ck_bitop(pTHX_ OP *o)
4949 #define OP_IS_NUMCOMPARE(op) \
4950 ((op) == OP_LT || (op) == OP_I_LT || \
4951 (op) == OP_GT || (op) == OP_I_GT || \
4952 (op) == OP_LE || (op) == OP_I_LE || \
4953 (op) == OP_GE || (op) == OP_I_GE || \
4954 (op) == OP_EQ || (op) == OP_I_EQ || \
4955 (op) == OP_NE || (op) == OP_I_NE || \
4956 (op) == OP_NCMP || (op) == OP_I_NCMP)
4957 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4958 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
4959 && (o->op_type == OP_BIT_OR
4960 || o->op_type == OP_BIT_AND
4961 || o->op_type == OP_BIT_XOR))
4963 const OP * left = cBINOPo->op_first;
4964 const OP * right = left->op_sibling;
4965 if ((OP_IS_NUMCOMPARE(left->op_type) &&
4966 (left->op_flags & OPf_PARENS) == 0) ||
4967 (OP_IS_NUMCOMPARE(right->op_type) &&
4968 (right->op_flags & OPf_PARENS) == 0))
4969 if (ckWARN(WARN_PRECEDENCE))
4970 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4971 "Possible precedence problem on bitwise %c operator",
4972 o->op_type == OP_BIT_OR ? '|'
4973 : o->op_type == OP_BIT_AND ? '&' : '^'
4980 Perl_ck_concat(pTHX_ OP *o)
4982 const OP *kid = cUNOPo->op_first;
4983 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
4984 !(kUNOP->op_first->op_flags & OPf_MOD))
4985 o->op_flags |= OPf_STACKED;
4990 Perl_ck_spair(pTHX_ OP *o)
4993 if (o->op_flags & OPf_KIDS) {
4996 const OPCODE type = o->op_type;
4997 o = modkids(ck_fun(o), type);
4998 kid = cUNOPo->op_first;
4999 newop = kUNOP->op_first->op_sibling;
5001 (newop->op_sibling ||
5002 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5003 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5004 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5008 op_free(kUNOP->op_first);
5009 kUNOP->op_first = newop;
5011 o->op_ppaddr = PL_ppaddr[++o->op_type];
5016 Perl_ck_delete(pTHX_ OP *o)
5020 if (o->op_flags & OPf_KIDS) {
5021 OP *kid = cUNOPo->op_first;
5022 switch (kid->op_type) {
5024 o->op_flags |= OPf_SPECIAL;
5027 o->op_private |= OPpSLICE;
5030 o->op_flags |= OPf_SPECIAL;
5035 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5044 Perl_ck_die(pTHX_ OP *o)
5047 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5053 Perl_ck_eof(pTHX_ OP *o)
5055 const I32 type = o->op_type;
5057 if (o->op_flags & OPf_KIDS) {
5058 if (cLISTOPo->op_first->op_type == OP_STUB) {
5060 o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
5068 Perl_ck_eval(pTHX_ OP *o)
5071 PL_hints |= HINT_BLOCK_SCOPE;
5072 if (o->op_flags & OPf_KIDS) {
5073 SVOP *kid = (SVOP*)cUNOPo->op_first;
5076 o->op_flags &= ~OPf_KIDS;
5079 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
5082 cUNOPo->op_first = 0;
5085 NewOp(1101, enter, 1, LOGOP);
5086 enter->op_type = OP_ENTERTRY;
5087 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5088 enter->op_private = 0;
5090 /* establish postfix order */
5091 enter->op_next = (OP*)enter;
5093 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5094 o->op_type = OP_LEAVETRY;
5095 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5096 enter->op_other = o;
5106 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5108 o->op_targ = (PADOFFSET)PL_hints;
5113 Perl_ck_exit(pTHX_ OP *o)
5116 HV *table = GvHV(PL_hintgv);
5118 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5119 if (svp && *svp && SvTRUE(*svp))
5120 o->op_private |= OPpEXIT_VMSISH;
5122 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5128 Perl_ck_exec(pTHX_ OP *o)
5130 if (o->op_flags & OPf_STACKED) {
5133 kid = cUNOPo->op_first->op_sibling;
5134 if (kid->op_type == OP_RV2GV)
5143 Perl_ck_exists(pTHX_ OP *o)
5146 if (o->op_flags & OPf_KIDS) {
5147 OP *kid = cUNOPo->op_first;
5148 if (kid->op_type == OP_ENTERSUB) {
5149 (void) ref(kid, o->op_type);
5150 if (kid->op_type != OP_RV2CV && !PL_error_count)
5151 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5153 o->op_private |= OPpEXISTS_SUB;
5155 else if (kid->op_type == OP_AELEM)
5156 o->op_flags |= OPf_SPECIAL;
5157 else if (kid->op_type != OP_HELEM)
5158 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5167 Perl_ck_gvconst(pTHX_ register OP *o)
5169 o = fold_constants(o);
5170 if (o->op_type == OP_CONST)
5177 Perl_ck_rvconst(pTHX_ register OP *o)
5180 SVOP *kid = (SVOP*)cUNOPo->op_first;
5182 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5183 if (kid->op_type == OP_CONST) {
5186 SV *kidsv = kid->op_sv;
5188 /* Is it a constant from cv_const_sv()? */
5189 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5190 SV *rsv = SvRV(kidsv);
5191 int svtype = SvTYPE(rsv);
5192 const char *badtype = Nullch;
5194 switch (o->op_type) {
5196 if (svtype > SVt_PVMG)
5197 badtype = "a SCALAR";
5200 if (svtype != SVt_PVAV)
5201 badtype = "an ARRAY";
5204 if (svtype != SVt_PVHV)
5208 if (svtype != SVt_PVCV)
5213 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5216 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5217 const char *badthing = Nullch;
5218 switch (o->op_type) {
5220 badthing = "a SCALAR";
5223 badthing = "an ARRAY";
5226 badthing = "a HASH";
5231 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
5235 * This is a little tricky. We only want to add the symbol if we
5236 * didn't add it in the lexer. Otherwise we get duplicate strict
5237 * warnings. But if we didn't add it in the lexer, we must at
5238 * least pretend like we wanted to add it even if it existed before,
5239 * or we get possible typo warnings. OPpCONST_ENTERED says
5240 * whether the lexer already added THIS instance of this symbol.
5242 iscv = (o->op_type == OP_RV2CV) * 2;
5244 gv = gv_fetchsv(kidsv,
5245 iscv | !(kid->op_private & OPpCONST_ENTERED),
5248 : o->op_type == OP_RV2SV
5250 : o->op_type == OP_RV2AV
5252 : o->op_type == OP_RV2HV
5255 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5257 kid->op_type = OP_GV;
5258 SvREFCNT_dec(kid->op_sv);
5260 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5261 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5262 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
5264 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
5266 kid->op_sv = SvREFCNT_inc(gv);
5268 kid->op_private = 0;
5269 kid->op_ppaddr = PL_ppaddr[OP_GV];
5276 Perl_ck_ftst(pTHX_ OP *o)
5279 const I32 type = o->op_type;
5281 if (o->op_flags & OPf_REF) {
5284 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5285 SVOP *kid = (SVOP*)cUNOPo->op_first;
5287 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5288 OP *newop = newGVOP(type, OPf_REF,
5289 gv_fetchsv(kid->op_sv, TRUE, SVt_PVIO));
5295 if ((PL_hints & HINT_FILETEST_ACCESS) &&
5296 OP_IS_FILETEST_ACCESS(o))
5297 o->op_private |= OPpFT_ACCESS;
5299 if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
5300 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
5301 o->op_private |= OPpFT_STACKED;
5305 if (type == OP_FTTTY)
5306 o = newGVOP(type, OPf_REF, PL_stdingv);
5308 o = newUNOP(type, 0, newDEFSVOP());
5314 Perl_ck_fun(pTHX_ OP *o)
5316 const int type = o->op_type;
5317 register I32 oa = PL_opargs[type] >> OASHIFT;
5319 if (o->op_flags & OPf_STACKED) {
5320 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5323 return no_fh_allowed(o);
5326 if (o->op_flags & OPf_KIDS) {
5327 OP **tokid = &cLISTOPo->op_first;
5328 register OP *kid = cLISTOPo->op_first;
5332 if (kid->op_type == OP_PUSHMARK ||
5333 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5335 tokid = &kid->op_sibling;
5336 kid = kid->op_sibling;
5338 if (!kid && PL_opargs[type] & OA_DEFGV)
5339 *tokid = kid = newDEFSVOP();
5343 sibl = kid->op_sibling;
5346 /* list seen where single (scalar) arg expected? */
5347 if (numargs == 1 && !(oa >> 4)
5348 && kid->op_type == OP_LIST && type != OP_SCALAR)
5350 return too_many_arguments(o,PL_op_desc[type]);
5363 if ((type == OP_PUSH || type == OP_UNSHIFT)
5364 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5365 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5366 "Useless use of %s with no values",
5369 if (kid->op_type == OP_CONST &&
5370 (kid->op_private & OPpCONST_BARE))
5372 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5373 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVAV) ));
5374 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5375 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5376 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
5377 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5380 kid->op_sibling = sibl;
5383 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5384 bad_type(numargs, "array", PL_op_desc[type], kid);
5388 if (kid->op_type == OP_CONST &&
5389 (kid->op_private & OPpCONST_BARE))
5391 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5392 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVHV) ));
5393 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5394 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5395 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
5396 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5399 kid->op_sibling = sibl;
5402 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5403 bad_type(numargs, "hash", PL_op_desc[type], kid);
5408 OP *newop = newUNOP(OP_NULL, 0, kid);
5409 kid->op_sibling = 0;
5411 newop->op_next = newop;
5413 kid->op_sibling = sibl;
5418 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5419 if (kid->op_type == OP_CONST &&
5420 (kid->op_private & OPpCONST_BARE))
5422 OP *newop = newGVOP(OP_GV, 0,
5423 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVIO) );
5424 if (!(o->op_private & 1) && /* if not unop */
5425 kid == cLISTOPo->op_last)
5426 cLISTOPo->op_last = newop;
5430 else if (kid->op_type == OP_READLINE) {
5431 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5432 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5435 I32 flags = OPf_SPECIAL;
5439 /* is this op a FH constructor? */
5440 if (is_handle_constructor(o,numargs)) {
5441 const char *name = Nullch;
5445 /* Set a flag to tell rv2gv to vivify
5446 * need to "prove" flag does not mean something
5447 * else already - NI-S 1999/05/07
5450 if (kid->op_type == OP_PADSV) {
5451 name = PAD_COMPNAME_PV(kid->op_targ);
5452 /* SvCUR of a pad namesv can't be trusted
5453 * (see PL_generation), so calc its length
5459 else if (kid->op_type == OP_RV2SV
5460 && kUNOP->op_first->op_type == OP_GV)
5462 GV *gv = cGVOPx_gv(kUNOP->op_first);
5464 len = GvNAMELEN(gv);
5466 else if (kid->op_type == OP_AELEM
5467 || kid->op_type == OP_HELEM)
5472 if ((op = ((BINOP*)kid)->op_first)) {
5473 SV *tmpstr = Nullsv;
5475 kid->op_type == OP_AELEM ?
5477 if (((op->op_type == OP_RV2AV) ||
5478 (op->op_type == OP_RV2HV)) &&
5479 (op = ((UNOP*)op)->op_first) &&
5480 (op->op_type == OP_GV)) {
5481 /* packagevar $a[] or $h{} */
5482 GV *gv = cGVOPx_gv(op);
5490 else if (op->op_type == OP_PADAV
5491 || op->op_type == OP_PADHV) {
5492 /* lexicalvar $a[] or $h{} */
5493 const char *padname =
5494 PAD_COMPNAME_PV(op->op_targ);
5504 name = SvPV(tmpstr, len);
5509 name = "__ANONIO__";
5516 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5517 namesv = PAD_SVl(targ);
5518 (void)SvUPGRADE(namesv, SVt_PV);
5520 sv_setpvn(namesv, "$", 1);
5521 sv_catpvn(namesv, name, len);
5524 kid->op_sibling = 0;
5525 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5526 kid->op_targ = targ;
5527 kid->op_private |= priv;
5529 kid->op_sibling = sibl;
5535 mod(scalar(kid), type);
5539 tokid = &kid->op_sibling;
5540 kid = kid->op_sibling;
5542 o->op_private |= numargs;
5544 return too_many_arguments(o,OP_DESC(o));
5547 else if (PL_opargs[type] & OA_DEFGV) {
5549 return newUNOP(type, 0, newDEFSVOP());
5553 while (oa & OA_OPTIONAL)
5555 if (oa && oa != OA_LIST)
5556 return too_few_arguments(o,OP_DESC(o));
5562 Perl_ck_glob(pTHX_ OP *o)
5568 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5569 append_elem(OP_GLOB, o, newDEFSVOP());
5571 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5572 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5574 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5577 #if !defined(PERL_EXTERNAL_GLOB)
5578 /* XXX this can be tightened up and made more failsafe. */
5579 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5582 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5583 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5584 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5585 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5586 GvCV(gv) = GvCV(glob_gv);
5587 (void)SvREFCNT_inc((SV*)GvCV(gv));
5588 GvIMPORTED_CV_on(gv);
5591 #endif /* PERL_EXTERNAL_GLOB */
5593 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5594 append_elem(OP_GLOB, o,
5595 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5596 o->op_type = OP_LIST;
5597 o->op_ppaddr = PL_ppaddr[OP_LIST];
5598 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5599 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5600 cLISTOPo->op_first->op_targ = 0;
5601 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5602 append_elem(OP_LIST, o,
5603 scalar(newUNOP(OP_RV2CV, 0,
5604 newGVOP(OP_GV, 0, gv)))));
5605 o = newUNOP(OP_NULL, 0, ck_subr(o));
5606 o->op_targ = OP_GLOB; /* hint at what it used to be */
5609 gv = newGVgen("main");
5611 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5617 Perl_ck_grep(pTHX_ OP *o)
5622 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5625 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5626 NewOp(1101, gwop, 1, LOGOP);
5628 if (o->op_flags & OPf_STACKED) {
5631 kid = cLISTOPo->op_first->op_sibling;
5632 if (!cUNOPx(kid)->op_next)
5633 Perl_croak(aTHX_ "panic: ck_grep");
5634 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
5637 kid->op_next = (OP*)gwop;
5638 o->op_flags &= ~OPf_STACKED;
5640 kid = cLISTOPo->op_first->op_sibling;
5641 if (type == OP_MAPWHILE)
5648 kid = cLISTOPo->op_first->op_sibling;
5649 if (kid->op_type != OP_NULL)
5650 Perl_croak(aTHX_ "panic: ck_grep");
5651 kid = kUNOP->op_first;
5653 gwop->op_type = type;
5654 gwop->op_ppaddr = PL_ppaddr[type];
5655 gwop->op_first = listkids(o);
5656 gwop->op_flags |= OPf_KIDS;
5657 gwop->op_other = LINKLIST(kid);
5658 kid->op_next = (OP*)gwop;
5659 offset = pad_findmy("$_");
5660 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
5661 o->op_private = gwop->op_private = 0;
5662 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5665 o->op_private = gwop->op_private = OPpGREP_LEX;
5666 gwop->op_targ = o->op_targ = offset;
5669 kid = cLISTOPo->op_first->op_sibling;
5670 if (!kid || !kid->op_sibling)
5671 return too_few_arguments(o,OP_DESC(o));
5672 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5673 mod(kid, OP_GREPSTART);
5679 Perl_ck_index(pTHX_ OP *o)
5681 if (o->op_flags & OPf_KIDS) {
5682 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5684 kid = kid->op_sibling; /* get past "big" */
5685 if (kid && kid->op_type == OP_CONST)
5686 fbm_compile(((SVOP*)kid)->op_sv, 0);
5692 Perl_ck_lengthconst(pTHX_ OP *o)
5694 /* XXX length optimization goes here */
5699 Perl_ck_lfun(pTHX_ OP *o)
5701 const OPCODE type = o->op_type;
5702 return modkids(ck_fun(o), type);
5706 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5708 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5709 switch (cUNOPo->op_first->op_type) {
5711 /* This is needed for
5712 if (defined %stash::)
5713 to work. Do not break Tk.
5715 break; /* Globals via GV can be undef */
5717 case OP_AASSIGN: /* Is this a good idea? */
5718 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5719 "defined(@array) is deprecated");
5720 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5721 "\t(Maybe you should just omit the defined()?)\n");
5724 /* This is needed for
5725 if (defined %stash::)
5726 to work. Do not break Tk.
5728 break; /* Globals via GV can be undef */
5730 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5731 "defined(%%hash) is deprecated");
5732 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5733 "\t(Maybe you should just omit the defined()?)\n");
5744 Perl_ck_rfun(pTHX_ OP *o)
5746 const OPCODE type = o->op_type;
5747 return refkids(ck_fun(o), type);
5751 Perl_ck_listiob(pTHX_ OP *o)
5755 kid = cLISTOPo->op_first;
5758 kid = cLISTOPo->op_first;
5760 if (kid->op_type == OP_PUSHMARK)
5761 kid = kid->op_sibling;
5762 if (kid && o->op_flags & OPf_STACKED)
5763 kid = kid->op_sibling;
5764 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5765 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5766 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5767 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5768 cLISTOPo->op_first->op_sibling = kid;
5769 cLISTOPo->op_last = kid;
5770 kid = kid->op_sibling;
5775 append_elem(o->op_type, o, newDEFSVOP());
5781 Perl_ck_sassign(pTHX_ OP *o)
5783 OP *kid = cLISTOPo->op_first;
5784 /* has a disposable target? */
5785 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5786 && !(kid->op_flags & OPf_STACKED)
5787 /* Cannot steal the second time! */
5788 && !(kid->op_private & OPpTARGET_MY))
5790 OP *kkid = kid->op_sibling;
5792 /* Can just relocate the target. */
5793 if (kkid && kkid->op_type == OP_PADSV
5794 && !(kkid->op_private & OPpLVAL_INTRO))
5796 kid->op_targ = kkid->op_targ;
5798 /* Now we do not need PADSV and SASSIGN. */
5799 kid->op_sibling = o->op_sibling; /* NULL */
5800 cLISTOPo->op_first = NULL;
5803 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
5807 /* optimise C<my $x = undef> to C<my $x> */
5808 if (kid->op_type == OP_UNDEF) {
5809 OP *kkid = kid->op_sibling;
5810 if (kkid && kkid->op_type == OP_PADSV
5811 && (kkid->op_private & OPpLVAL_INTRO))
5813 cLISTOPo->op_first = NULL;
5814 kid->op_sibling = NULL;
5824 Perl_ck_match(pTHX_ OP *o)
5826 if (o->op_type != OP_QR) {
5827 const I32 offset = pad_findmy("$_");
5828 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS(offset) & SVpad_OUR)) {
5829 o->op_targ = offset;
5830 o->op_private |= OPpTARGET_MY;
5833 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
5834 o->op_private |= OPpRUNTIME;
5839 Perl_ck_method(pTHX_ OP *o)
5841 OP *kid = cUNOPo->op_first;
5842 if (kid->op_type == OP_CONST) {
5843 SV* sv = kSVOP->op_sv;
5844 if (!(strchr(SvPVX_const(sv), ':') || strchr(SvPVX_const(sv), '\''))) {
5846 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5847 sv = newSVpvn_share(SvPVX_const(sv), SvCUR(sv), 0);
5850 kSVOP->op_sv = Nullsv;
5852 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5861 Perl_ck_null(pTHX_ OP *o)
5867 Perl_ck_open(pTHX_ OP *o)
5869 HV *table = GvHV(PL_hintgv);
5873 svp = hv_fetch(table, "open_IN", 7, FALSE);
5875 mode = mode_from_discipline(*svp);
5876 if (mode & O_BINARY)
5877 o->op_private |= OPpOPEN_IN_RAW;
5878 else if (mode & O_TEXT)
5879 o->op_private |= OPpOPEN_IN_CRLF;
5882 svp = hv_fetch(table, "open_OUT", 8, FALSE);
5884 mode = mode_from_discipline(*svp);
5885 if (mode & O_BINARY)
5886 o->op_private |= OPpOPEN_OUT_RAW;
5887 else if (mode & O_TEXT)
5888 o->op_private |= OPpOPEN_OUT_CRLF;
5891 if (o->op_type == OP_BACKTICK)
5894 /* In case of three-arg dup open remove strictness
5895 * from the last arg if it is a bareword. */
5896 OP *first = cLISTOPx(o)->op_first; /* The pushmark. */
5897 OP *last = cLISTOPx(o)->op_last; /* The bareword. */
5901 if ((last->op_type == OP_CONST) && /* The bareword. */
5902 (last->op_private & OPpCONST_BARE) &&
5903 (last->op_private & OPpCONST_STRICT) &&
5904 (oa = first->op_sibling) && /* The fh. */
5905 (oa = oa->op_sibling) && /* The mode. */
5906 SvPOK(((SVOP*)oa)->op_sv) &&
5907 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
5908 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
5909 (last == oa->op_sibling)) /* The bareword. */
5910 last->op_private &= ~OPpCONST_STRICT;
5916 Perl_ck_repeat(pTHX_ OP *o)
5918 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5919 o->op_private |= OPpREPEAT_DOLIST;
5920 cBINOPo->op_first = force_list(cBINOPo->op_first);
5928 Perl_ck_require(pTHX_ OP *o)
5932 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
5933 SVOP *kid = (SVOP*)cUNOPo->op_first;
5935 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5937 for (s = SvPVX(kid->op_sv); *s; s++) {
5938 if (*s == ':' && s[1] == ':') {
5940 Move(s+2, s+1, strlen(s+2)+1, char);
5941 SvCUR_set(kid->op_sv, SvCUR(kid->op_sv) - 1);
5944 if (SvREADONLY(kid->op_sv)) {
5945 SvREADONLY_off(kid->op_sv);
5946 sv_catpvn(kid->op_sv, ".pm", 3);
5947 SvREADONLY_on(kid->op_sv);
5950 sv_catpvn(kid->op_sv, ".pm", 3);
5954 /* handle override, if any */
5955 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
5956 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
5957 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
5959 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5960 OP *kid = cUNOPo->op_first;
5961 cUNOPo->op_first = 0;
5963 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5964 append_elem(OP_LIST, kid,
5965 scalar(newUNOP(OP_RV2CV, 0,
5974 Perl_ck_return(pTHX_ OP *o)
5976 if (CvLVALUE(PL_compcv)) {
5978 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5979 mod(kid, OP_LEAVESUBLV);
5986 Perl_ck_retarget(pTHX_ OP *o)
5988 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5995 Perl_ck_select(pTHX_ OP *o)
5999 if (o->op_flags & OPf_KIDS) {
6000 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6001 if (kid && kid->op_sibling) {
6002 o->op_type = OP_SSELECT;
6003 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6005 return fold_constants(o);
6009 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6010 if (kid && kid->op_type == OP_RV2GV)
6011 kid->op_private &= ~HINT_STRICT_REFS;
6016 Perl_ck_shift(pTHX_ OP *o)
6018 const I32 type = o->op_type;
6020 if (!(o->op_flags & OPf_KIDS)) {
6024 argop = newUNOP(OP_RV2AV, 0,
6025 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
6026 return newUNOP(type, 0, scalar(argop));
6028 return scalar(modkids(ck_fun(o), type));
6032 Perl_ck_sort(pTHX_ OP *o)
6036 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6038 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6039 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6041 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6043 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6045 if (kid->op_type == OP_SCOPE) {
6049 else if (kid->op_type == OP_LEAVE) {
6050 if (o->op_type == OP_SORT) {
6051 op_null(kid); /* wipe out leave */
6054 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6055 if (k->op_next == kid)
6057 /* don't descend into loops */
6058 else if (k->op_type == OP_ENTERLOOP
6059 || k->op_type == OP_ENTERITER)
6061 k = cLOOPx(k)->op_lastop;
6066 kid->op_next = 0; /* just disconnect the leave */
6067 k = kLISTOP->op_first;
6072 if (o->op_type == OP_SORT) {
6073 /* provide scalar context for comparison function/block */
6079 o->op_flags |= OPf_SPECIAL;
6081 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6084 firstkid = firstkid->op_sibling;
6087 /* provide list context for arguments */
6088 if (o->op_type == OP_SORT)
6095 S_simplify_sort(pTHX_ OP *o)
6097 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6102 if (!(o->op_flags & OPf_STACKED))
6104 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6105 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6106 kid = kUNOP->op_first; /* get past null */
6107 if (kid->op_type != OP_SCOPE)
6109 kid = kLISTOP->op_last; /* get past scope */
6110 switch(kid->op_type) {
6118 k = kid; /* remember this node*/
6119 if (kBINOP->op_first->op_type != OP_RV2SV)
6121 kid = kBINOP->op_first; /* get past cmp */
6122 if (kUNOP->op_first->op_type != OP_GV)
6124 kid = kUNOP->op_first; /* get past rv2sv */
6126 if (GvSTASH(gv) != PL_curstash)
6128 gvname = GvNAME(gv);
6129 if (*gvname == 'a' && gvname[1] == '\0')
6131 else if (*gvname == 'b' && gvname[1] == '\0')
6136 kid = k; /* back to cmp */
6137 if (kBINOP->op_last->op_type != OP_RV2SV)
6139 kid = kBINOP->op_last; /* down to 2nd arg */
6140 if (kUNOP->op_first->op_type != OP_GV)
6142 kid = kUNOP->op_first; /* get past rv2sv */
6144 if (GvSTASH(gv) != PL_curstash)
6146 gvname = GvNAME(gv);
6148 ? !(*gvname == 'a' && gvname[1] == '\0')
6149 : !(*gvname == 'b' && gvname[1] == '\0'))
6151 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6153 o->op_private |= OPpSORT_DESCEND;
6154 if (k->op_type == OP_NCMP)
6155 o->op_private |= OPpSORT_NUMERIC;
6156 if (k->op_type == OP_I_NCMP)
6157 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6158 kid = cLISTOPo->op_first->op_sibling;
6159 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6160 op_free(kid); /* then delete it */
6164 Perl_ck_split(pTHX_ OP *o)
6169 if (o->op_flags & OPf_STACKED)
6170 return no_fh_allowed(o);
6172 kid = cLISTOPo->op_first;
6173 if (kid->op_type != OP_NULL)
6174 Perl_croak(aTHX_ "panic: ck_split");
6175 kid = kid->op_sibling;
6176 op_free(cLISTOPo->op_first);
6177 cLISTOPo->op_first = kid;
6179 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6180 cLISTOPo->op_last = kid; /* There was only one element previously */
6183 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6184 OP *sibl = kid->op_sibling;
6185 kid->op_sibling = 0;
6186 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
6187 if (cLISTOPo->op_first == cLISTOPo->op_last)
6188 cLISTOPo->op_last = kid;
6189 cLISTOPo->op_first = kid;
6190 kid->op_sibling = sibl;
6193 kid->op_type = OP_PUSHRE;
6194 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6196 if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
6197 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
6198 "Use of /g modifier is meaningless in split");
6201 if (!kid->op_sibling)
6202 append_elem(OP_SPLIT, o, newDEFSVOP());
6204 kid = kid->op_sibling;
6207 if (!kid->op_sibling)
6208 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6210 kid = kid->op_sibling;
6213 if (kid->op_sibling)
6214 return too_many_arguments(o,OP_DESC(o));
6220 Perl_ck_join(pTHX_ OP *o)
6222 if (ckWARN(WARN_SYNTAX)) {
6223 const OP *kid = cLISTOPo->op_first->op_sibling;
6224 if (kid && kid->op_type == OP_MATCH) {
6225 const REGEXP *re = PM_GETRE(kPMOP);
6226 const char *pmstr = re ? re->precomp : "STRING";
6227 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6228 "/%s/ should probably be written as \"%s\"",
6236 Perl_ck_subr(pTHX_ OP *o)
6238 OP *prev = ((cUNOPo->op_first->op_sibling)
6239 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6240 OP *o2 = prev->op_sibling;
6247 I32 contextclass = 0;
6252 o->op_private |= OPpENTERSUB_HASTARG;
6253 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6254 if (cvop->op_type == OP_RV2CV) {
6256 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6257 op_null(cvop); /* disable rv2cv */
6258 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6259 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6260 GV *gv = cGVOPx_gv(tmpop);
6263 tmpop->op_private |= OPpEARLY_CV;
6266 namegv = CvANON(cv) ? gv : CvGV(cv);
6267 proto = SvPV((SV*)cv, n_a);
6269 if (CvASSERTION(cv)) {
6270 if (PL_hints & HINT_ASSERTING) {
6271 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
6272 o->op_private |= OPpENTERSUB_DB;
6276 if (ckWARN(WARN_ASSERTIONS) && !(PL_hints & HINT_ASSERTIONSSEEN)) {
6277 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
6278 "Impossible to activate assertion call");
6285 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6286 if (o2->op_type == OP_CONST)
6287 o2->op_private &= ~OPpCONST_STRICT;
6288 else if (o2->op_type == OP_LIST) {
6289 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6290 if (o && o->op_type == OP_CONST)
6291 o->op_private &= ~OPpCONST_STRICT;
6294 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6295 if (PERLDB_SUB && PL_curstash != PL_debstash)
6296 o->op_private |= OPpENTERSUB_DB;
6297 while (o2 != cvop) {
6301 return too_many_arguments(o, gv_ename(namegv));
6319 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6321 arg == 1 ? "block or sub {}" : "sub {}",
6322 gv_ename(namegv), o2);
6325 /* '*' allows any scalar type, including bareword */
6328 if (o2->op_type == OP_RV2GV)
6329 goto wrapref; /* autoconvert GLOB -> GLOBref */
6330 else if (o2->op_type == OP_CONST)
6331 o2->op_private &= ~OPpCONST_STRICT;
6332 else if (o2->op_type == OP_ENTERSUB) {
6333 /* accidental subroutine, revert to bareword */
6334 OP *gvop = ((UNOP*)o2)->op_first;
6335 if (gvop && gvop->op_type == OP_NULL) {
6336 gvop = ((UNOP*)gvop)->op_first;
6338 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6341 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6342 (gvop = ((UNOP*)gvop)->op_first) &&
6343 gvop->op_type == OP_GV)
6345 GV *gv = cGVOPx_gv(gvop);
6346 OP *sibling = o2->op_sibling;
6347 SV *n = newSVpvn("",0);
6349 gv_fullname4(n, gv, "", FALSE);
6350 o2 = newSVOP(OP_CONST, 0, n);
6351 prev->op_sibling = o2;
6352 o2->op_sibling = sibling;
6368 if (contextclass++ == 0) {
6369 e = strchr(proto, ']');
6370 if (!e || e == proto)
6383 while (*--p != '[');
6384 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6385 gv_ename(namegv), o2);
6391 if (o2->op_type == OP_RV2GV)
6394 bad_type(arg, "symbol", gv_ename(namegv), o2);
6397 if (o2->op_type == OP_ENTERSUB)
6400 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6403 if (o2->op_type == OP_RV2SV ||
6404 o2->op_type == OP_PADSV ||
6405 o2->op_type == OP_HELEM ||
6406 o2->op_type == OP_AELEM ||
6407 o2->op_type == OP_THREADSV)
6410 bad_type(arg, "scalar", gv_ename(namegv), o2);
6413 if (o2->op_type == OP_RV2AV ||
6414 o2->op_type == OP_PADAV)
6417 bad_type(arg, "array", gv_ename(namegv), o2);
6420 if (o2->op_type == OP_RV2HV ||
6421 o2->op_type == OP_PADHV)
6424 bad_type(arg, "hash", gv_ename(namegv), o2);
6429 OP* sib = kid->op_sibling;
6430 kid->op_sibling = 0;
6431 o2 = newUNOP(OP_REFGEN, 0, kid);
6432 o2->op_sibling = sib;
6433 prev->op_sibling = o2;
6435 if (contextclass && e) {
6450 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6451 gv_ename(namegv), cv);
6456 mod(o2, OP_ENTERSUB);
6458 o2 = o2->op_sibling;
6460 if (proto && !optional &&
6461 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6462 return too_few_arguments(o, gv_ename(namegv));
6465 o=newSVOP(OP_CONST, 0, newSViv(0));
6471 Perl_ck_svconst(pTHX_ OP *o)
6473 SvREADONLY_on(cSVOPo->op_sv);
6478 Perl_ck_trunc(pTHX_ OP *o)
6480 if (o->op_flags & OPf_KIDS) {
6481 SVOP *kid = (SVOP*)cUNOPo->op_first;
6483 if (kid->op_type == OP_NULL)
6484 kid = (SVOP*)kid->op_sibling;
6485 if (kid && kid->op_type == OP_CONST &&
6486 (kid->op_private & OPpCONST_BARE))
6488 o->op_flags |= OPf_SPECIAL;
6489 kid->op_private &= ~OPpCONST_STRICT;
6496 Perl_ck_unpack(pTHX_ OP *o)
6498 OP *kid = cLISTOPo->op_first;
6499 if (kid->op_sibling) {
6500 kid = kid->op_sibling;
6501 if (!kid->op_sibling)
6502 kid->op_sibling = newDEFSVOP();
6508 Perl_ck_substr(pTHX_ OP *o)
6511 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6512 OP *kid = cLISTOPo->op_first;
6514 if (kid->op_type == OP_NULL)
6515 kid = kid->op_sibling;
6517 kid->op_flags |= OPf_MOD;
6523 /* A peephole optimizer. We visit the ops in the order they're to execute.
6524 * See the comments at the top of this file for more details about when
6525 * peep() is called */
6528 Perl_peep(pTHX_ register OP *o)
6531 register OP* oldop = 0;
6533 if (!o || o->op_opt)
6537 SAVEVPTR(PL_curcop);
6538 for (; o; o = o->op_next) {
6542 switch (o->op_type) {
6546 PL_curcop = ((COP*)o); /* for warnings */
6551 if (cSVOPo->op_private & OPpCONST_STRICT)
6552 no_bareword_allowed(o);
6554 case OP_METHOD_NAMED:
6555 /* Relocate sv to the pad for thread safety.
6556 * Despite being a "constant", the SV is written to,
6557 * for reference counts, sv_upgrade() etc. */
6559 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6560 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6561 /* If op_sv is already a PADTMP then it is being used by
6562 * some pad, so make a copy. */
6563 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6564 SvREADONLY_on(PAD_SVl(ix));
6565 SvREFCNT_dec(cSVOPo->op_sv);
6568 SvREFCNT_dec(PAD_SVl(ix));
6569 SvPADTMP_on(cSVOPo->op_sv);
6570 PAD_SETSV(ix, cSVOPo->op_sv);
6571 /* XXX I don't know how this isn't readonly already. */
6572 SvREADONLY_on(PAD_SVl(ix));
6574 cSVOPo->op_sv = Nullsv;
6582 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6583 if (o->op_next->op_private & OPpTARGET_MY) {
6584 if (o->op_flags & OPf_STACKED) /* chained concats */
6585 goto ignore_optimization;
6587 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6588 o->op_targ = o->op_next->op_targ;
6589 o->op_next->op_targ = 0;
6590 o->op_private |= OPpTARGET_MY;
6593 op_null(o->op_next);
6595 ignore_optimization:
6599 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6601 break; /* Scalar stub must produce undef. List stub is noop */
6605 if (o->op_targ == OP_NEXTSTATE
6606 || o->op_targ == OP_DBSTATE
6607 || o->op_targ == OP_SETSTATE)
6609 PL_curcop = ((COP*)o);
6611 /* XXX: We avoid setting op_seq here to prevent later calls
6612 to peep() from mistakenly concluding that optimisation
6613 has already occurred. This doesn't fix the real problem,
6614 though (See 20010220.007). AMS 20010719 */
6615 /* op_seq functionality is now replaced by op_opt */
6616 if (oldop && o->op_next) {
6617 oldop->op_next = o->op_next;
6625 if (oldop && o->op_next) {
6626 oldop->op_next = o->op_next;
6634 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
6635 OP* pop = (o->op_type == OP_PADAV) ?
6636 o->op_next : o->op_next->op_next;
6638 if (pop && pop->op_type == OP_CONST &&
6639 ((PL_op = pop->op_next)) &&
6640 pop->op_next->op_type == OP_AELEM &&
6641 !(pop->op_next->op_private &
6642 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6643 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6648 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
6649 no_bareword_allowed(pop);
6650 if (o->op_type == OP_GV)
6651 op_null(o->op_next);
6652 op_null(pop->op_next);
6654 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6655 o->op_next = pop->op_next->op_next;
6656 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6657 o->op_private = (U8)i;
6658 if (o->op_type == OP_GV) {
6663 o->op_flags |= OPf_SPECIAL;
6664 o->op_type = OP_AELEMFAST;
6670 if (o->op_next->op_type == OP_RV2SV) {
6671 if (!(o->op_next->op_private & OPpDEREF)) {
6672 op_null(o->op_next);
6673 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6675 o->op_next = o->op_next->op_next;
6676 o->op_type = OP_GVSV;
6677 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6680 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6682 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
6683 /* XXX could check prototype here instead of just carping */
6684 SV *sv = sv_newmortal();
6685 gv_efullname3(sv, gv, Nullch);
6686 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6687 "%"SVf"() called too early to check prototype",
6691 else if (o->op_next->op_type == OP_READLINE
6692 && o->op_next->op_next->op_type == OP_CONCAT
6693 && (o->op_next->op_next->op_flags & OPf_STACKED))
6695 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6696 o->op_type = OP_RCATLINE;
6697 o->op_flags |= OPf_STACKED;
6698 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6699 op_null(o->op_next->op_next);
6700 op_null(o->op_next);
6717 while (cLOGOP->op_other->op_type == OP_NULL)
6718 cLOGOP->op_other = cLOGOP->op_other->op_next;
6719 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6725 while (cLOOP->op_redoop->op_type == OP_NULL)
6726 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6727 peep(cLOOP->op_redoop);
6728 while (cLOOP->op_nextop->op_type == OP_NULL)
6729 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6730 peep(cLOOP->op_nextop);
6731 while (cLOOP->op_lastop->op_type == OP_NULL)
6732 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6733 peep(cLOOP->op_lastop);
6740 while (cPMOP->op_pmreplstart &&
6741 cPMOP->op_pmreplstart->op_type == OP_NULL)
6742 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6743 peep(cPMOP->op_pmreplstart);
6748 if (ckWARN(WARN_SYNTAX) && o->op_next
6749 && o->op_next->op_type == OP_NEXTSTATE) {
6750 if (o->op_next->op_sibling &&
6751 o->op_next->op_sibling->op_type != OP_EXIT &&
6752 o->op_next->op_sibling->op_type != OP_WARN &&
6753 o->op_next->op_sibling->op_type != OP_DIE) {
6754 const line_t oldline = CopLINE(PL_curcop);
6756 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6757 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6758 "Statement unlikely to be reached");
6759 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6760 "\t(Maybe you meant system() when you said exec()?)\n");
6761 CopLINE_set(PL_curcop, oldline);
6776 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6779 /* Make the CONST have a shared SV */
6780 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6781 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6782 key = SvPV(sv, keylen);
6783 lexname = newSVpvn_share(key,
6784 SvUTF8(sv) ? -(I32)keylen : keylen,
6790 if ((o->op_private & (OPpLVAL_INTRO)))
6793 rop = (UNOP*)((BINOP*)o)->op_first;
6794 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6796 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6797 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6799 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6800 if (!fields || !GvHV(*fields))
6802 key = SvPV(*svp, keylen);
6803 if (!hv_fetch(GvHV(*fields), key,
6804 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
6806 Perl_croak(aTHX_ "No such class field \"%s\" "
6807 "in variable %s of type %s",
6808 key, SvPV_nolen(lexname), HvNAME(SvSTASH(lexname)));
6821 SVOP *first_key_op, *key_op;
6823 if ((o->op_private & (OPpLVAL_INTRO))
6824 /* I bet there's always a pushmark... */
6825 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6826 /* hmmm, no optimization if list contains only one key. */
6828 rop = (UNOP*)((LISTOP*)o)->op_last;
6829 if (rop->op_type != OP_RV2HV)
6831 if (rop->op_first->op_type == OP_PADSV)
6832 /* @$hash{qw(keys here)} */
6833 rop = (UNOP*)rop->op_first;
6835 /* @{$hash}{qw(keys here)} */
6836 if (rop->op_first->op_type == OP_SCOPE
6837 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
6839 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
6845 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
6846 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6848 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6849 if (!fields || !GvHV(*fields))
6851 /* Again guessing that the pushmark can be jumped over.... */
6852 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
6853 ->op_first->op_sibling;
6854 for (key_op = first_key_op; key_op;
6855 key_op = (SVOP*)key_op->op_sibling) {
6856 if (key_op->op_type != OP_CONST)
6858 svp = cSVOPx_svp(key_op);
6859 key = SvPV(*svp, keylen);
6860 if (!hv_fetch(GvHV(*fields), key,
6861 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
6863 Perl_croak(aTHX_ "No such class field \"%s\" "
6864 "in variable %s of type %s",
6865 key, SvPV_nolen(lexname), HvNAME(SvSTASH(lexname)));
6872 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
6876 /* check that RHS of sort is a single plain array */
6877 oright = cUNOPo->op_first;
6878 if (!oright || oright->op_type != OP_PUSHMARK)
6881 /* reverse sort ... can be optimised. */
6882 if (!cUNOPo->op_sibling) {
6883 /* Nothing follows us on the list. */
6884 OP *reverse = o->op_next;
6886 if (reverse->op_type == OP_REVERSE &&
6887 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
6888 OP *pushmark = cUNOPx(reverse)->op_first;
6889 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
6890 && (cUNOPx(pushmark)->op_sibling == o)) {
6891 /* reverse -> pushmark -> sort */
6892 o->op_private |= OPpSORT_REVERSE;
6894 pushmark->op_next = oright->op_next;
6900 /* make @a = sort @a act in-place */
6904 oright = cUNOPx(oright)->op_sibling;
6907 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
6908 oright = cUNOPx(oright)->op_sibling;
6912 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
6913 || oright->op_next != o
6914 || (oright->op_private & OPpLVAL_INTRO)
6918 /* o2 follows the chain of op_nexts through the LHS of the
6919 * assign (if any) to the aassign op itself */
6921 if (!o2 || o2->op_type != OP_NULL)
6924 if (!o2 || o2->op_type != OP_PUSHMARK)
6927 if (o2 && o2->op_type == OP_GV)
6930 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
6931 || (o2->op_private & OPpLVAL_INTRO)
6936 if (!o2 || o2->op_type != OP_NULL)
6939 if (!o2 || o2->op_type != OP_AASSIGN
6940 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
6943 /* check that the sort is the first arg on RHS of assign */
6945 o2 = cUNOPx(o2)->op_first;
6946 if (!o2 || o2->op_type != OP_NULL)
6948 o2 = cUNOPx(o2)->op_first;
6949 if (!o2 || o2->op_type != OP_PUSHMARK)
6951 if (o2->op_sibling != o)
6954 /* check the array is the same on both sides */
6955 if (oleft->op_type == OP_RV2AV) {
6956 if (oright->op_type != OP_RV2AV
6957 || !cUNOPx(oright)->op_first
6958 || cUNOPx(oright)->op_first->op_type != OP_GV
6959 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
6960 cGVOPx_gv(cUNOPx(oright)->op_first)
6964 else if (oright->op_type != OP_PADAV
6965 || oright->op_targ != oleft->op_targ
6969 /* transfer MODishness etc from LHS arg to RHS arg */
6970 oright->op_flags = oleft->op_flags;
6971 o->op_private |= OPpSORT_INPLACE;
6973 /* excise push->gv->rv2av->null->aassign */
6974 o2 = o->op_next->op_next;
6975 op_null(o2); /* PUSHMARK */
6977 if (o2->op_type == OP_GV) {
6978 op_null(o2); /* GV */
6981 op_null(o2); /* RV2AV or PADAV */
6982 o2 = o2->op_next->op_next;
6983 op_null(o2); /* AASSIGN */
6985 o->op_next = o2->op_next;
6991 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
6993 LISTOP *enter, *exlist;
6996 enter = (LISTOP *) o->op_next;
6999 if (enter->op_type == OP_NULL) {
7000 enter = (LISTOP *) enter->op_next;
7004 /* for $a (...) will have OP_GV then OP_RV2GV here.
7005 for (...) just has an OP_GV. */
7006 if (enter->op_type == OP_GV) {
7007 gvop = (OP *) enter;
7008 enter = (LISTOP *) enter->op_next;
7011 if (enter->op_type == OP_RV2GV) {
7012 enter = (LISTOP *) enter->op_next;
7018 if (enter->op_type != OP_ENTERITER)
7021 iter = enter->op_next;
7022 if (!iter || iter->op_type != OP_ITER)
7025 expushmark = enter->op_first;
7026 if (!expushmark || expushmark->op_type != OP_NULL
7027 || expushmark->op_targ != OP_PUSHMARK)
7030 exlist = (LISTOP *) expushmark->op_sibling;
7031 if (!exlist || exlist->op_type != OP_NULL
7032 || exlist->op_targ != OP_LIST)
7035 if (exlist->op_last != o) {
7036 /* Mmm. Was expecting to point back to this op. */
7039 theirmark = exlist->op_first;
7040 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
7043 if (theirmark->op_sibling != o) {
7044 /* There's something between the mark and the reverse, eg
7045 for (1, reverse (...))
7050 ourmark = ((LISTOP *)o)->op_first;
7051 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
7054 ourlast = ((LISTOP *)o)->op_last;
7055 if (!ourlast || ourlast->op_next != o)
7058 rv2av = ourmark->op_sibling;
7059 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
7060 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
7061 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
7062 /* We're just reversing a single array. */
7063 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
7064 enter->op_flags |= OPf_STACKED;
7067 /* We don't have control over who points to theirmark, so sacrifice
7069 theirmark->op_next = ourmark->op_next;
7070 theirmark->op_flags = ourmark->op_flags;
7071 ourlast->op_next = gvop ? gvop : (OP *) enter;
7074 enter->op_private |= OPpITER_REVERSED;
7075 iter->op_private |= OPpITER_REVERSED;
7090 Perl_custom_op_name(pTHX_ const OP* o)
7092 const IV index = PTR2IV(o->op_ppaddr);
7096 if (!PL_custom_op_names) /* This probably shouldn't happen */
7097 return (char *)PL_op_name[OP_CUSTOM];
7099 keysv = sv_2mortal(newSViv(index));
7101 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7103 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7105 return SvPV_nolen(HeVAL(he));
7109 Perl_custom_op_desc(pTHX_ const OP* o)
7111 const IV index = PTR2IV(o->op_ppaddr);
7115 if (!PL_custom_op_descs)
7116 return (char *)PL_op_desc[OP_CUSTOM];
7118 keysv = sv_2mortal(newSViv(index));
7120 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7122 return (char *)PL_op_desc[OP_CUSTOM];
7124 return SvPV_nolen(HeVAL(he));
7129 /* Efficient sub that returns a constant scalar value. */
7131 const_sv_xsub(pTHX_ CV* cv)
7136 Perl_croak(aTHX_ "usage: %s::%s()",
7137 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7141 ST(0) = (SV*)XSANY.any_ptr;
7147 * c-indentation-style: bsd
7149 * indent-tabs-mode: t
7152 * ex: set ts=8 sts=4 sw=4 noet: