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)
276 if (!o || o->op_static)
279 if (o->op_private & OPpREFCOUNTED) {
280 switch (o->op_type) {
288 refcnt = OpREFCNT_dec(o);
298 if (o->op_flags & OPf_KIDS) {
299 register OP *kid, *nextkid;
300 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
301 nextkid = kid->op_sibling; /* Get before next freeing kid */
307 type = (OPCODE)o->op_targ;
309 /* COP* is not cleared by op_clear() so that we may track line
310 * numbers etc even after null() */
311 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
316 #ifdef DEBUG_LEAKING_SCALARS
323 Perl_op_clear(pTHX_ OP *o)
326 switch (o->op_type) {
327 case OP_NULL: /* Was holding old type, if any. */
328 case OP_ENTEREVAL: /* Was holding hints. */
332 if (!(o->op_flags & OPf_REF)
333 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
339 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
340 /* not an OP_PADAV replacement */
342 if (cPADOPo->op_padix > 0) {
343 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
344 * may still exist on the pad */
345 pad_swipe(cPADOPo->op_padix, TRUE);
346 cPADOPo->op_padix = 0;
349 SvREFCNT_dec(cSVOPo->op_sv);
350 cSVOPo->op_sv = Nullsv;
354 case OP_METHOD_NAMED:
356 SvREFCNT_dec(cSVOPo->op_sv);
357 cSVOPo->op_sv = Nullsv;
360 Even if op_clear does a pad_free for the target of the op,
361 pad_free doesn't actually remove the sv that exists in the pad;
362 instead it lives on. This results in that it could be reused as
363 a target later on when the pad was reallocated.
366 pad_swipe(o->op_targ,1);
375 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
379 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
380 SvREFCNT_dec(cSVOPo->op_sv);
381 cSVOPo->op_sv = Nullsv;
384 Safefree(cPVOPo->op_pv);
385 cPVOPo->op_pv = Nullch;
389 op_free(cPMOPo->op_pmreplroot);
393 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
394 /* No GvIN_PAD_off here, because other references may still
395 * exist on the pad */
396 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
399 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
406 HV *pmstash = PmopSTASH(cPMOPo);
407 if (pmstash && SvREFCNT(pmstash)) {
408 PMOP *pmop = HvPMROOT(pmstash);
409 PMOP *lastpmop = NULL;
411 if (cPMOPo == pmop) {
413 lastpmop->op_pmnext = pmop->op_pmnext;
415 HvPMROOT(pmstash) = pmop->op_pmnext;
419 pmop = pmop->op_pmnext;
422 PmopSTASH_free(cPMOPo);
424 cPMOPo->op_pmreplroot = Nullop;
425 /* we use the "SAFE" version of the PM_ macros here
426 * since sv_clean_all might release some PMOPs
427 * after PL_regex_padav has been cleared
428 * and the clearing of PL_regex_padav needs to
429 * happen before sv_clean_all
431 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
432 PM_SETRE_SAFE(cPMOPo, (REGEXP*)NULL);
434 if(PL_regex_pad) { /* We could be in destruction */
435 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
436 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
437 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
444 if (o->op_targ > 0) {
445 pad_free(o->op_targ);
451 S_cop_free(pTHX_ COP* cop)
453 Safefree(cop->cop_label); /* FIXME: treaddead ??? */
456 if (! specialWARN(cop->cop_warnings))
457 SvREFCNT_dec(cop->cop_warnings);
458 if (! specialCopIO(cop->cop_io)) {
462 char *s = SvPV(cop->cop_io,len);
463 Perl_warn(aTHX_ "io='%.*s'",(int) len,s); /* ??? --jhi */
466 SvREFCNT_dec(cop->cop_io);
472 Perl_op_null(pTHX_ OP *o)
474 if (o->op_type == OP_NULL)
477 o->op_targ = o->op_type;
478 o->op_type = OP_NULL;
479 o->op_ppaddr = PL_ppaddr[OP_NULL];
483 Perl_op_refcnt_lock(pTHX)
489 Perl_op_refcnt_unlock(pTHX)
494 /* Contextualizers */
496 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
499 Perl_linklist(pTHX_ OP *o)
505 /* establish postfix order */
506 if (cUNOPo->op_first) {
508 o->op_next = LINKLIST(cUNOPo->op_first);
509 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
511 kid->op_next = LINKLIST(kid->op_sibling);
523 Perl_scalarkids(pTHX_ OP *o)
525 if (o && o->op_flags & OPf_KIDS) {
527 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
534 S_scalarboolean(pTHX_ OP *o)
536 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
537 if (ckWARN(WARN_SYNTAX)) {
538 const line_t oldline = CopLINE(PL_curcop);
540 if (PL_copline != NOLINE)
541 CopLINE_set(PL_curcop, PL_copline);
542 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
543 CopLINE_set(PL_curcop, oldline);
550 Perl_scalar(pTHX_ OP *o)
554 /* assumes no premature commitment */
555 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
556 || o->op_type == OP_RETURN)
561 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
563 switch (o->op_type) {
565 scalar(cBINOPo->op_first);
570 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
574 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
575 if (!kPMOP->op_pmreplroot)
576 deprecate_old("implicit split to @_");
584 if (o->op_flags & OPf_KIDS) {
585 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
591 kid = cLISTOPo->op_first;
593 while ((kid = kid->op_sibling)) {
599 WITH_THR(PL_curcop = &PL_compiling);
604 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
610 WITH_THR(PL_curcop = &PL_compiling);
613 if (ckWARN(WARN_VOID))
614 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
620 Perl_scalarvoid(pTHX_ OP *o)
623 const char* useless = 0;
627 if (o->op_type == OP_NEXTSTATE
628 || o->op_type == OP_SETSTATE
629 || o->op_type == OP_DBSTATE
630 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
631 || o->op_targ == OP_SETSTATE
632 || o->op_targ == OP_DBSTATE)))
633 PL_curcop = (COP*)o; /* for warning below */
635 /* assumes no premature commitment */
636 want = o->op_flags & OPf_WANT;
637 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
638 || o->op_type == OP_RETURN)
643 if ((o->op_private & OPpTARGET_MY)
644 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
646 return scalar(o); /* As if inside SASSIGN */
649 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
651 switch (o->op_type) {
653 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
657 if (o->op_flags & OPf_STACKED)
661 if (o->op_private == 4)
733 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
734 useless = OP_DESC(o);
738 kid = cUNOPo->op_first;
739 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
740 kid->op_type != OP_TRANS) {
743 useless = "negative pattern binding (!~)";
750 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
751 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
752 useless = "a variable";
757 if (cSVOPo->op_private & OPpCONST_STRICT)
758 no_bareword_allowed(o);
760 if (ckWARN(WARN_VOID)) {
761 useless = "a constant";
762 /* don't warn on optimised away booleans, eg
763 * use constant Foo, 5; Foo || print; */
764 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
766 /* the constants 0 and 1 are permitted as they are
767 conventionally used as dummies in constructs like
768 1 while some_condition_with_side_effects; */
769 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
771 else if (SvPOK(sv)) {
772 /* perl4's way of mixing documentation and code
773 (before the invention of POD) was based on a
774 trick to mix nroff and perl code. The trick was
775 built upon these three nroff macros being used in
776 void context. The pink camel has the details in
777 the script wrapman near page 319. */
778 if (strnEQ(SvPVX(sv), "di", 2) ||
779 strnEQ(SvPVX(sv), "ds", 2) ||
780 strnEQ(SvPVX(sv), "ig", 2))
785 op_null(o); /* don't execute or even remember it */
789 o->op_type = OP_PREINC; /* pre-increment is faster */
790 o->op_ppaddr = PL_ppaddr[OP_PREINC];
794 o->op_type = OP_PREDEC; /* pre-decrement is faster */
795 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
802 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
807 if (o->op_flags & OPf_STACKED)
814 if (!(o->op_flags & OPf_KIDS))
823 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
830 /* all requires must return a boolean value */
831 o->op_flags &= ~OPf_WANT;
836 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
837 if (!kPMOP->op_pmreplroot)
838 deprecate_old("implicit split to @_");
842 if (useless && ckWARN(WARN_VOID))
843 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
848 Perl_listkids(pTHX_ OP *o)
850 if (o && o->op_flags & OPf_KIDS) {
852 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
859 Perl_list(pTHX_ OP *o)
863 /* assumes no premature commitment */
864 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
865 || o->op_type == OP_RETURN)
870 if ((o->op_private & OPpTARGET_MY)
871 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
873 return o; /* As if inside SASSIGN */
876 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
878 switch (o->op_type) {
881 list(cBINOPo->op_first);
886 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
894 if (!(o->op_flags & OPf_KIDS))
896 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
897 list(cBINOPo->op_first);
898 return gen_constant_list(o);
905 kid = cLISTOPo->op_first;
907 while ((kid = kid->op_sibling)) {
913 WITH_THR(PL_curcop = &PL_compiling);
917 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
923 WITH_THR(PL_curcop = &PL_compiling);
926 /* all requires must return a boolean value */
927 o->op_flags &= ~OPf_WANT;
934 Perl_scalarseq(pTHX_ OP *o)
937 if (o->op_type == OP_LINESEQ ||
938 o->op_type == OP_SCOPE ||
939 o->op_type == OP_LEAVE ||
940 o->op_type == OP_LEAVETRY)
943 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
944 if (kid->op_sibling) {
948 PL_curcop = &PL_compiling;
950 o->op_flags &= ~OPf_PARENS;
951 if (PL_hints & HINT_BLOCK_SCOPE)
952 o->op_flags |= OPf_PARENS;
955 o = newOP(OP_STUB, 0);
960 S_modkids(pTHX_ OP *o, I32 type)
962 if (o && o->op_flags & OPf_KIDS) {
964 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
970 /* Propagate lvalue ("modifiable") context to an op and it's children.
971 * 'type' represents the context type, roughly based on the type of op that
972 * would do the modifying, although local() is represented by OP_NULL.
973 * It's responsible for detecting things that can't be modified, flag
974 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
975 * might have to vivify a reference in $x), and so on.
977 * For example, "$a+1 = 2" would cause mod() to be called with o being
978 * OP_ADD and type being OP_SASSIGN, and would output an error.
982 Perl_mod(pTHX_ OP *o, I32 type)
985 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
988 if (!o || PL_error_count)
991 if ((o->op_private & OPpTARGET_MY)
992 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
997 switch (o->op_type) {
1003 if (!(o->op_private & (OPpCONST_ARYBASE)))
1005 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1006 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1010 SAVEI32(PL_compiling.cop_arybase);
1011 PL_compiling.cop_arybase = 0;
1013 else if (type == OP_REFGEN)
1016 Perl_croak(aTHX_ "That use of $[ is unsupported");
1019 if (o->op_flags & OPf_PARENS)
1023 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1024 !(o->op_flags & OPf_STACKED)) {
1025 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1026 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1027 assert(cUNOPo->op_first->op_type == OP_NULL);
1028 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1031 else if (o->op_private & OPpENTERSUB_NOMOD)
1033 else { /* lvalue subroutine call */
1034 o->op_private |= OPpLVAL_INTRO;
1035 PL_modcount = RETURN_UNLIMITED_NUMBER;
1036 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1037 /* Backward compatibility mode: */
1038 o->op_private |= OPpENTERSUB_INARGS;
1041 else { /* Compile-time error message: */
1042 OP *kid = cUNOPo->op_first;
1046 if (kid->op_type == OP_PUSHMARK)
1048 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1050 "panic: unexpected lvalue entersub "
1051 "args: type/targ %ld:%"UVuf,
1052 (long)kid->op_type, (UV)kid->op_targ);
1053 kid = kLISTOP->op_first;
1055 while (kid->op_sibling)
1056 kid = kid->op_sibling;
1057 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1059 if (kid->op_type == OP_METHOD_NAMED
1060 || kid->op_type == OP_METHOD)
1064 NewOp(1101, newop, 1, UNOP);
1065 newop->op_type = OP_RV2CV;
1066 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1067 newop->op_first = Nullop;
1068 newop->op_next = (OP*)newop;
1069 kid->op_sibling = (OP*)newop;
1070 newop->op_private |= OPpLVAL_INTRO;
1074 if (kid->op_type != OP_RV2CV)
1076 "panic: unexpected lvalue entersub "
1077 "entry via type/targ %ld:%"UVuf,
1078 (long)kid->op_type, (UV)kid->op_targ);
1079 kid->op_private |= OPpLVAL_INTRO;
1080 break; /* Postpone until runtime */
1084 kid = kUNOP->op_first;
1085 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1086 kid = kUNOP->op_first;
1087 if (kid->op_type == OP_NULL)
1089 "Unexpected constant lvalue entersub "
1090 "entry via type/targ %ld:%"UVuf,
1091 (long)kid->op_type, (UV)kid->op_targ);
1092 if (kid->op_type != OP_GV) {
1093 /* Restore RV2CV to check lvalueness */
1095 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1096 okid->op_next = kid->op_next;
1097 kid->op_next = okid;
1100 okid->op_next = Nullop;
1101 okid->op_type = OP_RV2CV;
1103 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1104 okid->op_private |= OPpLVAL_INTRO;
1108 cv = GvCV(kGVOP_gv);
1118 /* grep, foreach, subcalls, refgen */
1119 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1121 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1122 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1124 : (o->op_type == OP_ENTERSUB
1125 ? "non-lvalue subroutine call"
1127 type ? PL_op_desc[type] : "local"));
1141 case OP_RIGHT_SHIFT:
1150 if (!(o->op_flags & OPf_STACKED))
1157 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1163 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1164 PL_modcount = RETURN_UNLIMITED_NUMBER;
1165 return o; /* Treat \(@foo) like ordinary list. */
1169 if (scalar_mod_type(o, type))
1171 ref(cUNOPo->op_first, o->op_type);
1175 if (type == OP_LEAVESUBLV)
1176 o->op_private |= OPpMAYBE_LVSUB;
1182 PL_modcount = RETURN_UNLIMITED_NUMBER;
1185 ref(cUNOPo->op_first, o->op_type);
1190 PL_hints |= HINT_BLOCK_SCOPE;
1205 PL_modcount = RETURN_UNLIMITED_NUMBER;
1206 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1207 return o; /* Treat \(@foo) like ordinary list. */
1208 if (scalar_mod_type(o, type))
1210 if (type == OP_LEAVESUBLV)
1211 o->op_private |= OPpMAYBE_LVSUB;
1215 if (!type) /* local() */
1216 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1217 PAD_COMPNAME_PV(o->op_targ));
1225 if (type != OP_SASSIGN)
1229 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1234 if (type == OP_LEAVESUBLV)
1235 o->op_private |= OPpMAYBE_LVSUB;
1237 pad_free(o->op_targ);
1238 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1239 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1240 if (o->op_flags & OPf_KIDS)
1241 mod(cBINOPo->op_first->op_sibling, type);
1246 ref(cBINOPo->op_first, o->op_type);
1247 if (type == OP_ENTERSUB &&
1248 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1249 o->op_private |= OPpLVAL_DEFER;
1250 if (type == OP_LEAVESUBLV)
1251 o->op_private |= OPpMAYBE_LVSUB;
1261 if (o->op_flags & OPf_KIDS)
1262 mod(cLISTOPo->op_last, type);
1267 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1269 else if (!(o->op_flags & OPf_KIDS))
1271 if (o->op_targ != OP_LIST) {
1272 mod(cBINOPo->op_first, type);
1278 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1283 if (type != OP_LEAVESUBLV)
1285 break; /* mod()ing was handled by ck_return() */
1288 /* [20011101.069] File test operators interpret OPf_REF to mean that
1289 their argument is a filehandle; thus \stat(".") should not set
1291 if (type == OP_REFGEN &&
1292 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1295 if (type != OP_LEAVESUBLV)
1296 o->op_flags |= OPf_MOD;
1298 if (type == OP_AASSIGN || type == OP_SASSIGN)
1299 o->op_flags |= OPf_SPECIAL|OPf_REF;
1300 else if (!type) { /* local() */
1303 o->op_private |= OPpLVAL_INTRO;
1304 o->op_flags &= ~OPf_SPECIAL;
1305 PL_hints |= HINT_BLOCK_SCOPE;
1310 if (ckWARN(WARN_SYNTAX)) {
1311 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1312 "Useless localization of %s", OP_DESC(o));
1316 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1317 && type != OP_LEAVESUBLV)
1318 o->op_flags |= OPf_REF;
1323 S_scalar_mod_type(pTHX_ const OP *o, I32 type)
1327 if (o->op_type == OP_RV2GV)
1351 case OP_RIGHT_SHIFT:
1370 S_is_handle_constructor(pTHX_ const OP *o, I32 argnum)
1372 switch (o->op_type) {
1380 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1393 Perl_refkids(pTHX_ OP *o, I32 type)
1395 if (o && o->op_flags & OPf_KIDS) {
1397 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1404 Perl_ref(pTHX_ OP *o, I32 type)
1408 if (!o || PL_error_count)
1411 switch (o->op_type) {
1413 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1414 !(o->op_flags & OPf_STACKED)) {
1415 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1416 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1417 assert(cUNOPo->op_first->op_type == OP_NULL);
1418 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1419 o->op_flags |= OPf_SPECIAL;
1424 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1428 if (type == OP_DEFINED)
1429 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1430 ref(cUNOPo->op_first, o->op_type);
1433 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1434 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1435 : type == OP_RV2HV ? OPpDEREF_HV
1437 o->op_flags |= OPf_MOD;
1442 o->op_flags |= OPf_MOD; /* XXX ??? */
1447 o->op_flags |= OPf_REF;
1450 if (type == OP_DEFINED)
1451 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1452 ref(cUNOPo->op_first, o->op_type);
1457 o->op_flags |= OPf_REF;
1462 if (!(o->op_flags & OPf_KIDS))
1464 ref(cBINOPo->op_first, type);
1468 ref(cBINOPo->op_first, o->op_type);
1469 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1470 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1471 : type == OP_RV2HV ? OPpDEREF_HV
1473 o->op_flags |= OPf_MOD;
1481 if (!(o->op_flags & OPf_KIDS))
1483 ref(cLISTOPo->op_last, type);
1493 S_dup_attrlist(pTHX_ OP *o)
1497 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1498 * where the first kid is OP_PUSHMARK and the remaining ones
1499 * are OP_CONST. We need to push the OP_CONST values.
1501 if (o->op_type == OP_CONST)
1502 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1504 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1505 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1506 if (o->op_type == OP_CONST)
1507 rop = append_elem(OP_LIST, rop,
1508 newSVOP(OP_CONST, o->op_flags,
1509 SvREFCNT_inc(cSVOPo->op_sv)));
1516 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1520 /* fake up C<use attributes $pkg,$rv,@attrs> */
1521 ENTER; /* need to protect against side-effects of 'use' */
1524 stashsv = newSVpv(HvNAME(stash), 0);
1526 stashsv = &PL_sv_no;
1528 #define ATTRSMODULE "attributes"
1529 #define ATTRSMODULE_PM "attributes.pm"
1533 /* Don't force the C<use> if we don't need it. */
1534 svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
1535 sizeof(ATTRSMODULE_PM)-1, 0);
1536 if (svp && *svp != &PL_sv_undef)
1537 ; /* already in %INC */
1539 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1540 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1544 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1545 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1547 prepend_elem(OP_LIST,
1548 newSVOP(OP_CONST, 0, stashsv),
1549 prepend_elem(OP_LIST,
1550 newSVOP(OP_CONST, 0,
1552 dup_attrlist(attrs))));
1558 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1560 OP *pack, *imop, *arg;
1566 assert(target->op_type == OP_PADSV ||
1567 target->op_type == OP_PADHV ||
1568 target->op_type == OP_PADAV);
1570 /* Ensure that attributes.pm is loaded. */
1571 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1573 /* Need package name for method call. */
1574 pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
1576 /* Build up the real arg-list. */
1578 stashsv = newSVpv(HvNAME(stash), 0);
1580 stashsv = &PL_sv_no;
1581 arg = newOP(OP_PADSV, 0);
1582 arg->op_targ = target->op_targ;
1583 arg = prepend_elem(OP_LIST,
1584 newSVOP(OP_CONST, 0, stashsv),
1585 prepend_elem(OP_LIST,
1586 newUNOP(OP_REFGEN, 0,
1587 mod(arg, OP_REFGEN)),
1588 dup_attrlist(attrs)));
1590 /* Fake up a method call to import */
1591 meth = newSVpvn("import", 6);
1592 (void)SvUPGRADE(meth, SVt_PVIV);
1593 (void)SvIOK_on(meth);
1596 PERL_HASH(hash, SvPVX(meth), SvCUR(meth));
1597 SvUV_set(meth, hash);
1599 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1600 append_elem(OP_LIST,
1601 prepend_elem(OP_LIST, pack, list(arg)),
1602 newSVOP(OP_METHOD_NAMED, 0, meth)));
1603 imop->op_private |= OPpENTERSUB_NOMOD;
1605 /* Combine the ops. */
1606 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1610 =notfor apidoc apply_attrs_string
1612 Attempts to apply a list of attributes specified by the C<attrstr> and
1613 C<len> arguments to the subroutine identified by the C<cv> argument which
1614 is expected to be associated with the package identified by the C<stashpv>
1615 argument (see L<attributes>). It gets this wrong, though, in that it
1616 does not correctly identify the boundaries of the individual attribute
1617 specifications within C<attrstr>. This is not really intended for the
1618 public API, but has to be listed here for systems such as AIX which
1619 need an explicit export list for symbols. (It's called from XS code
1620 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1621 to respect attribute syntax properly would be welcome.
1627 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1628 const char *attrstr, STRLEN len)
1633 len = strlen(attrstr);
1637 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1639 const char *sstr = attrstr;
1640 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1641 attrs = append_elem(OP_LIST, attrs,
1642 newSVOP(OP_CONST, 0,
1643 newSVpvn(sstr, attrstr-sstr)));
1647 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1648 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1649 Nullsv, prepend_elem(OP_LIST,
1650 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1651 prepend_elem(OP_LIST,
1652 newSVOP(OP_CONST, 0,
1658 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1662 if (!o || PL_error_count)
1666 if (type == OP_LIST) {
1668 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1669 my_kid(kid, attrs, imopsp);
1670 } else if (type == OP_UNDEF) {
1672 } else if (type == OP_RV2SV || /* "our" declaration */
1674 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1675 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1676 yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
1677 OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
1679 GV *gv = cGVOPx_gv(cUNOPo->op_first);
1681 PL_in_my_stash = Nullhv;
1682 apply_attrs(GvSTASH(gv),
1683 (type == OP_RV2SV ? GvSV(gv) :
1684 type == OP_RV2AV ? (SV*)GvAV(gv) :
1685 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1688 o->op_private |= OPpOUR_INTRO;
1691 else if (type != OP_PADSV &&
1694 type != OP_PUSHMARK)
1696 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1698 PL_in_my == KEY_our ? "our" : "my"));
1701 else if (attrs && type != OP_PUSHMARK) {
1705 PL_in_my_stash = Nullhv;
1707 /* check for C<my Dog $spot> when deciding package */
1708 stash = PAD_COMPNAME_TYPE(o->op_targ);
1710 stash = PL_curstash;
1711 apply_attrs_my(stash, o, attrs, imopsp);
1713 o->op_flags |= OPf_MOD;
1714 o->op_private |= OPpLVAL_INTRO;
1719 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1722 int maybe_scalar = 0;
1724 /* [perl #17376]: this appears to be premature, and results in code such as
1725 C< our(%x); > executing in list mode rather than void mode */
1727 if (o->op_flags & OPf_PARENS)
1736 o = my_kid(o, attrs, &rops);
1738 if (maybe_scalar && o->op_type == OP_PADSV) {
1739 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1740 o->op_private |= OPpLVAL_INTRO;
1743 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1746 PL_in_my_stash = Nullhv;
1751 Perl_my(pTHX_ OP *o)
1753 return my_attrs(o, Nullop);
1757 Perl_sawparens(pTHX_ OP *o)
1760 o->op_flags |= OPf_PARENS;
1765 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1770 if (ckWARN(WARN_MISC) &&
1771 (left->op_type == OP_RV2AV ||
1772 left->op_type == OP_RV2HV ||
1773 left->op_type == OP_PADAV ||
1774 left->op_type == OP_PADHV)) {
1775 const char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
1776 right->op_type == OP_TRANS)
1777 ? right->op_type : OP_MATCH];
1778 const char *sample = ((left->op_type == OP_RV2AV ||
1779 left->op_type == OP_PADAV)
1780 ? "@array" : "%hash");
1781 Perl_warner(aTHX_ packWARN(WARN_MISC),
1782 "Applying %s to %s will act on scalar(%s)",
1783 desc, sample, sample);
1786 if (right->op_type == OP_CONST &&
1787 cSVOPx(right)->op_private & OPpCONST_BARE &&
1788 cSVOPx(right)->op_private & OPpCONST_STRICT)
1790 no_bareword_allowed(right);
1793 ismatchop = right->op_type == OP_MATCH ||
1794 right->op_type == OP_SUBST ||
1795 right->op_type == OP_TRANS;
1796 if (ismatchop && right->op_private & OPpTARGET_MY) {
1798 right->op_private &= ~OPpTARGET_MY;
1800 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1801 right->op_flags |= OPf_STACKED;
1802 if (right->op_type != OP_MATCH &&
1803 ! (right->op_type == OP_TRANS &&
1804 right->op_private & OPpTRANS_IDENTICAL))
1805 left = mod(left, right->op_type);
1806 if (right->op_type == OP_TRANS)
1807 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
1809 o = prepend_elem(right->op_type, scalar(left), right);
1811 return newUNOP(OP_NOT, 0, scalar(o));
1815 return bind_match(type, left,
1816 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
1820 Perl_invert(pTHX_ OP *o)
1824 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
1825 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1829 Perl_scope(pTHX_ OP *o)
1832 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1833 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1834 o->op_type = OP_LEAVE;
1835 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1837 else if (o->op_type == OP_LINESEQ) {
1839 o->op_type = OP_SCOPE;
1840 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1841 kid = ((LISTOP*)o)->op_first;
1842 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
1846 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
1851 /* XXX kept for BINCOMPAT only */
1853 Perl_save_hints(pTHX)
1855 Perl_croak(aTHX_ "internal error: obsolete function save_hints() called");
1859 Perl_block_start(pTHX_ int full)
1861 const int retval = PL_savestack_ix;
1862 pad_block_start(full);
1864 PL_hints &= ~HINT_BLOCK_SCOPE;
1865 SAVESPTR(PL_compiling.cop_warnings);
1866 if (! specialWARN(PL_compiling.cop_warnings)) {
1867 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1868 SAVEFREESV(PL_compiling.cop_warnings) ;
1870 SAVESPTR(PL_compiling.cop_io);
1871 if (! specialCopIO(PL_compiling.cop_io)) {
1872 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1873 SAVEFREESV(PL_compiling.cop_io) ;
1879 Perl_block_end(pTHX_ I32 floor, OP *seq)
1881 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1882 OP* retval = scalarseq(seq);
1884 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
1886 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
1894 const I32 offset = pad_findmy("$_");
1895 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
1896 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1899 OP *o = newOP(OP_PADSV, 0);
1900 o->op_targ = offset;
1906 Perl_newPROG(pTHX_ OP *o)
1911 PL_eval_root = newUNOP(OP_LEAVEEVAL,
1912 ((PL_in_eval & EVAL_KEEPERR)
1913 ? OPf_SPECIAL : 0), o);
1914 PL_eval_start = linklist(PL_eval_root);
1915 PL_eval_root->op_private |= OPpREFCOUNTED;
1916 OpREFCNT_set(PL_eval_root, 1);
1917 PL_eval_root->op_next = 0;
1918 CALL_PEEP(PL_eval_start);
1921 if (o->op_type == OP_STUB) {
1922 PL_comppad_name = 0;
1927 PL_main_root = scope(sawparens(scalarvoid(o)));
1928 PL_curcop = &PL_compiling;
1929 PL_main_start = LINKLIST(PL_main_root);
1930 PL_main_root->op_private |= OPpREFCOUNTED;
1931 OpREFCNT_set(PL_main_root, 1);
1932 PL_main_root->op_next = 0;
1933 CALL_PEEP(PL_main_start);
1936 /* Register with debugger */
1938 CV *cv = get_cv("DB::postponed", FALSE);
1942 XPUSHs((SV*)CopFILEGV(&PL_compiling));
1944 call_sv((SV*)cv, G_DISCARD);
1951 Perl_localize(pTHX_ OP *o, I32 lex)
1953 if (o->op_flags & OPf_PARENS)
1954 /* [perl #17376]: this appears to be premature, and results in code such as
1955 C< our(%x); > executing in list mode rather than void mode */
1962 if (ckWARN(WARN_PARENTHESIS)
1963 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
1965 char *s = PL_bufptr;
1968 /* some heuristics to detect a potential error */
1969 while (*s && (strchr(", \t\n", *s)))
1973 if (*s && strchr("@$%*", *s) && *++s
1974 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
1977 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
1979 while (*s && (strchr(", \t\n", *s)))
1985 if (sigil && (*s == ';' || *s == '=')) {
1986 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
1987 "Parentheses missing around \"%s\" list",
1988 lex ? (PL_in_my == KEY_our ? "our" : "my")
1996 o = mod(o, OP_NULL); /* a bit kludgey */
1998 PL_in_my_stash = Nullhv;
2003 Perl_jmaybe(pTHX_ OP *o)
2005 if (o->op_type == OP_LIST) {
2007 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2008 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2014 Perl_fold_constants(pTHX_ register OP *o)
2017 I32 type = o->op_type;
2020 if (PL_opargs[type] & OA_RETSCALAR)
2022 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2023 o->op_targ = pad_alloc(type, SVs_PADTMP);
2025 /* integerize op, unless it happens to be C<-foo>.
2026 * XXX should pp_i_negate() do magic string negation instead? */
2027 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2028 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2029 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2031 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2034 if (!(PL_opargs[type] & OA_FOLDCONST))
2039 /* XXX might want a ck_negate() for this */
2040 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2052 /* XXX what about the numeric ops? */
2053 if (PL_hints & HINT_LOCALE)
2058 goto nope; /* Don't try to run w/ errors */
2060 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2061 if ((curop->op_type != OP_CONST ||
2062 (curop->op_private & OPpCONST_BARE)) &&
2063 curop->op_type != OP_LIST &&
2064 curop->op_type != OP_SCALAR &&
2065 curop->op_type != OP_NULL &&
2066 curop->op_type != OP_PUSHMARK)
2072 curop = LINKLIST(o);
2076 sv = *(PL_stack_sp--);
2077 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2078 pad_swipe(o->op_targ, FALSE);
2079 else if (SvTEMP(sv)) { /* grab mortal temp? */
2080 (void)SvREFCNT_inc(sv);
2084 if (type == OP_RV2GV)
2085 return newGVOP(OP_GV, 0, (GV*)sv);
2086 return newSVOP(OP_CONST, 0, sv);
2093 Perl_gen_constant_list(pTHX_ register OP *o)
2096 const I32 oldtmps_floor = PL_tmps_floor;
2100 return o; /* Don't attempt to run with errors */
2102 PL_op = curop = LINKLIST(o);
2109 PL_tmps_floor = oldtmps_floor;
2111 o->op_type = OP_RV2AV;
2112 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2113 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2114 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2115 o->op_opt = 0; /* needs to be revisited in peep() */
2116 curop = ((UNOP*)o)->op_first;
2117 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2124 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2126 if (!o || o->op_type != OP_LIST)
2127 o = newLISTOP(OP_LIST, 0, o, Nullop);
2129 o->op_flags &= ~OPf_WANT;
2131 if (!(PL_opargs[type] & OA_MARK))
2132 op_null(cLISTOPo->op_first);
2134 o->op_type = (OPCODE)type;
2135 o->op_ppaddr = PL_ppaddr[type];
2136 o->op_flags |= flags;
2138 o = CHECKOP(type, o);
2139 if (o->op_type != (unsigned)type)
2142 return fold_constants(o);
2145 /* List constructors */
2148 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2156 if (first->op_type != (unsigned)type
2157 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2159 return newLISTOP(type, 0, first, last);
2162 if (first->op_flags & OPf_KIDS)
2163 ((LISTOP*)first)->op_last->op_sibling = last;
2165 first->op_flags |= OPf_KIDS;
2166 ((LISTOP*)first)->op_first = last;
2168 ((LISTOP*)first)->op_last = last;
2173 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2181 if (first->op_type != (unsigned)type)
2182 return prepend_elem(type, (OP*)first, (OP*)last);
2184 if (last->op_type != (unsigned)type)
2185 return append_elem(type, (OP*)first, (OP*)last);
2187 first->op_last->op_sibling = last->op_first;
2188 first->op_last = last->op_last;
2189 first->op_flags |= (last->op_flags & OPf_KIDS);
2197 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2205 if (last->op_type == (unsigned)type) {
2206 if (type == OP_LIST) { /* already a PUSHMARK there */
2207 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2208 ((LISTOP*)last)->op_first->op_sibling = first;
2209 if (!(first->op_flags & OPf_PARENS))
2210 last->op_flags &= ~OPf_PARENS;
2213 if (!(last->op_flags & OPf_KIDS)) {
2214 ((LISTOP*)last)->op_last = first;
2215 last->op_flags |= OPf_KIDS;
2217 first->op_sibling = ((LISTOP*)last)->op_first;
2218 ((LISTOP*)last)->op_first = first;
2220 last->op_flags |= OPf_KIDS;
2224 return newLISTOP(type, 0, first, last);
2230 Perl_newNULLLIST(pTHX)
2232 return newOP(OP_STUB, 0);
2236 Perl_force_list(pTHX_ OP *o)
2238 if (!o || o->op_type != OP_LIST)
2239 o = newLISTOP(OP_LIST, 0, o, Nullop);
2245 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2249 NewOp(1101, listop, 1, LISTOP);
2251 listop->op_type = (OPCODE)type;
2252 listop->op_ppaddr = PL_ppaddr[type];
2255 listop->op_flags = (U8)flags;
2259 else if (!first && last)
2262 first->op_sibling = last;
2263 listop->op_first = first;
2264 listop->op_last = last;
2265 if (type == OP_LIST) {
2267 pushop = newOP(OP_PUSHMARK, 0);
2268 pushop->op_sibling = first;
2269 listop->op_first = pushop;
2270 listop->op_flags |= OPf_KIDS;
2272 listop->op_last = pushop;
2275 return CHECKOP(type, listop);
2279 Perl_newOP(pTHX_ I32 type, I32 flags)
2282 NewOp(1101, o, 1, OP);
2283 o->op_type = (OPCODE)type;
2284 o->op_ppaddr = PL_ppaddr[type];
2285 o->op_flags = (U8)flags;
2288 o->op_private = (U8)(0 | (flags >> 8));
2289 if (PL_opargs[type] & OA_RETSCALAR)
2291 if (PL_opargs[type] & OA_TARGET)
2292 o->op_targ = pad_alloc(type, SVs_PADTMP);
2293 return CHECKOP(type, o);
2297 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2302 first = newOP(OP_STUB, 0);
2303 if (PL_opargs[type] & OA_MARK)
2304 first = force_list(first);
2306 NewOp(1101, unop, 1, UNOP);
2307 unop->op_type = (OPCODE)type;
2308 unop->op_ppaddr = PL_ppaddr[type];
2309 unop->op_first = first;
2310 unop->op_flags = flags | OPf_KIDS;
2311 unop->op_private = (U8)(1 | (flags >> 8));
2312 unop = (UNOP*) CHECKOP(type, unop);
2316 return fold_constants((OP *) unop);
2320 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2323 NewOp(1101, binop, 1, BINOP);
2326 first = newOP(OP_NULL, 0);
2328 binop->op_type = (OPCODE)type;
2329 binop->op_ppaddr = PL_ppaddr[type];
2330 binop->op_first = first;
2331 binop->op_flags = flags | OPf_KIDS;
2334 binop->op_private = (U8)(1 | (flags >> 8));
2337 binop->op_private = (U8)(2 | (flags >> 8));
2338 first->op_sibling = last;
2341 binop = (BINOP*)CHECKOP(type, binop);
2342 if (binop->op_next || binop->op_type != (OPCODE)type)
2345 binop->op_last = binop->op_first->op_sibling;
2347 return fold_constants((OP *)binop);
2351 uvcompare(const void *a, const void *b)
2353 if (*((const UV *)a) < (*(const UV *)b))
2355 if (*((const UV *)a) > (*(const UV *)b))
2357 if (*((const UV *)a+1) < (*(const UV *)b+1))
2359 if (*((const UV *)a+1) > (*(const UV *)b+1))
2365 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2367 SV *tstr = ((SVOP*)expr)->op_sv;
2368 SV *rstr = ((SVOP*)repl)->op_sv;
2371 U8 *t = (U8*)SvPV(tstr, tlen);
2372 U8 *r = (U8*)SvPV(rstr, rlen);
2379 register short *tbl;
2381 PL_hints |= HINT_BLOCK_SCOPE;
2382 complement = o->op_private & OPpTRANS_COMPLEMENT;
2383 del = o->op_private & OPpTRANS_DELETE;
2384 squash = o->op_private & OPpTRANS_SQUASH;
2387 o->op_private |= OPpTRANS_FROM_UTF;
2390 o->op_private |= OPpTRANS_TO_UTF;
2392 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2393 SV* listsv = newSVpvn("# comment\n",10);
2395 U8* tend = t + tlen;
2396 U8* rend = r + rlen;
2410 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2411 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2417 tsave = t = bytes_to_utf8(t, &len);
2420 if (!to_utf && rlen) {
2422 rsave = r = bytes_to_utf8(r, &len);
2426 /* There are several snags with this code on EBCDIC:
2427 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2428 2. scan_const() in toke.c has encoded chars in native encoding which makes
2429 ranges at least in EBCDIC 0..255 range the bottom odd.
2433 U8 tmpbuf[UTF8_MAXBYTES+1];
2436 New(1109, cp, 2*tlen, UV);
2438 transv = newSVpvn("",0);
2440 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2442 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2444 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2448 cp[2*i+1] = cp[2*i];
2452 qsort(cp, i, 2*sizeof(UV), uvcompare);
2453 for (j = 0; j < i; j++) {
2455 diff = val - nextmin;
2457 t = uvuni_to_utf8(tmpbuf,nextmin);
2458 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2460 U8 range_mark = UTF_TO_NATIVE(0xff);
2461 t = uvuni_to_utf8(tmpbuf, val - 1);
2462 sv_catpvn(transv, (char *)&range_mark, 1);
2463 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2470 t = uvuni_to_utf8(tmpbuf,nextmin);
2471 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2473 U8 range_mark = UTF_TO_NATIVE(0xff);
2474 sv_catpvn(transv, (char *)&range_mark, 1);
2476 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2477 UNICODE_ALLOW_SUPER);
2478 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2479 t = (U8*)SvPVX(transv);
2480 tlen = SvCUR(transv);
2484 else if (!rlen && !del) {
2485 r = t; rlen = tlen; rend = tend;
2488 if ((!rlen && !del) || t == r ||
2489 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2491 o->op_private |= OPpTRANS_IDENTICAL;
2495 while (t < tend || tfirst <= tlast) {
2496 /* see if we need more "t" chars */
2497 if (tfirst > tlast) {
2498 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2500 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2502 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2509 /* now see if we need more "r" chars */
2510 if (rfirst > rlast) {
2512 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2514 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2516 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2525 rfirst = rlast = 0xffffffff;
2529 /* now see which range will peter our first, if either. */
2530 tdiff = tlast - tfirst;
2531 rdiff = rlast - rfirst;
2538 if (rfirst == 0xffffffff) {
2539 diff = tdiff; /* oops, pretend rdiff is infinite */
2541 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2542 (long)tfirst, (long)tlast);
2544 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2548 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2549 (long)tfirst, (long)(tfirst + diff),
2552 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2553 (long)tfirst, (long)rfirst);
2555 if (rfirst + diff > max)
2556 max = rfirst + diff;
2558 grows = (tfirst < rfirst &&
2559 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2571 else if (max > 0xff)
2576 Safefree(cPVOPo->op_pv);
2577 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2578 SvREFCNT_dec(listsv);
2580 SvREFCNT_dec(transv);
2582 if (!del && havefinal && rlen)
2583 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2584 newSVuv((UV)final), 0);
2587 o->op_private |= OPpTRANS_GROWS;
2599 tbl = (short*)cPVOPo->op_pv;
2601 Zero(tbl, 256, short);
2602 for (i = 0; i < (I32)tlen; i++)
2604 for (i = 0, j = 0; i < 256; i++) {
2606 if (j >= (I32)rlen) {
2615 if (i < 128 && r[j] >= 128)
2625 o->op_private |= OPpTRANS_IDENTICAL;
2627 else if (j >= (I32)rlen)
2630 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2631 tbl[0x100] = rlen - j;
2632 for (i=0; i < (I32)rlen - j; i++)
2633 tbl[0x101+i] = r[j+i];
2637 if (!rlen && !del) {
2640 o->op_private |= OPpTRANS_IDENTICAL;
2642 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2643 o->op_private |= OPpTRANS_IDENTICAL;
2645 for (i = 0; i < 256; i++)
2647 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
2648 if (j >= (I32)rlen) {
2650 if (tbl[t[i]] == -1)
2656 if (tbl[t[i]] == -1) {
2657 if (t[i] < 128 && r[j] >= 128)
2664 o->op_private |= OPpTRANS_GROWS;
2672 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2676 NewOp(1101, pmop, 1, PMOP);
2677 pmop->op_type = (OPCODE)type;
2678 pmop->op_ppaddr = PL_ppaddr[type];
2679 pmop->op_flags = (U8)flags;
2680 pmop->op_private = (U8)(0 | (flags >> 8));
2682 if (PL_hints & HINT_RE_TAINT)
2683 pmop->op_pmpermflags |= PMf_RETAINT;
2684 if (PL_hints & HINT_LOCALE)
2685 pmop->op_pmpermflags |= PMf_LOCALE;
2686 pmop->op_pmflags = pmop->op_pmpermflags;
2691 if(av_len((AV*) PL_regex_pad[0]) > -1) {
2692 repointer = av_pop((AV*)PL_regex_pad[0]);
2693 pmop->op_pmoffset = SvIV(repointer);
2694 SvREPADTMP_off(repointer);
2695 sv_setiv(repointer,0);
2697 repointer = newSViv(0);
2698 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2699 pmop->op_pmoffset = av_len(PL_regex_padav);
2700 PL_regex_pad = AvARRAY(PL_regex_padav);
2705 /* link into pm list */
2706 if (type != OP_TRANS && PL_curstash) {
2707 pmop->op_pmnext = HvPMROOT(PL_curstash);
2708 HvPMROOT(PL_curstash) = pmop;
2709 PmopSTASH_set(pmop,PL_curstash);
2712 return CHECKOP(type, pmop);
2715 /* Given some sort of match op o, and an expression expr containing a
2716 * pattern, either compile expr into a regex and attach it to o (if it's
2717 * constant), or convert expr into a runtime regcomp op sequence (if it's
2720 * isreg indicates that the pattern is part of a regex construct, eg
2721 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
2722 * split "pattern", which aren't. In the former case, expr will be a list
2723 * if the pattern contains more than one term (eg /a$b/) or if it contains
2724 * a replacement, ie s/// or tr///.
2728 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
2732 I32 repl_has_vars = 0;
2736 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
2737 /* last element in list is the replacement; pop it */
2739 repl = cLISTOPx(expr)->op_last;
2740 kid = cLISTOPx(expr)->op_first;
2741 while (kid->op_sibling != repl)
2742 kid = kid->op_sibling;
2743 kid->op_sibling = Nullop;
2744 cLISTOPx(expr)->op_last = kid;
2747 if (isreg && expr->op_type == OP_LIST &&
2748 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
2750 /* convert single element list to element */
2752 expr = cLISTOPx(oe)->op_first->op_sibling;
2753 cLISTOPx(oe)->op_first->op_sibling = Nullop;
2754 cLISTOPx(oe)->op_last = Nullop;
2758 if (o->op_type == OP_TRANS) {
2759 return pmtrans(o, expr, repl);
2762 reglist = isreg && expr->op_type == OP_LIST;
2766 PL_hints |= HINT_BLOCK_SCOPE;
2769 if (expr->op_type == OP_CONST) {
2771 SV *pat = ((SVOP*)expr)->op_sv;
2772 char *p = SvPV(pat, plen);
2773 if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
2774 sv_setpvn(pat, "\\s+", 3);
2775 p = SvPV(pat, plen);
2776 pm->op_pmflags |= PMf_SKIPWHITE;
2779 pm->op_pmdynflags |= PMdf_UTF8;
2780 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
2781 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
2782 pm->op_pmflags |= PMf_WHITE;
2786 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2787 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2789 : OP_REGCMAYBE),0,expr);
2791 NewOp(1101, rcop, 1, LOGOP);
2792 rcop->op_type = OP_REGCOMP;
2793 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2794 rcop->op_first = scalar(expr);
2795 rcop->op_flags |= OPf_KIDS
2796 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
2797 | (reglist ? OPf_STACKED : 0);
2798 rcop->op_private = 1;
2801 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
2803 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
2806 /* establish postfix order */
2807 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2809 rcop->op_next = expr;
2810 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2813 rcop->op_next = LINKLIST(expr);
2814 expr->op_next = (OP*)rcop;
2817 prepend_elem(o->op_type, scalar((OP*)rcop), o);
2822 if (pm->op_pmflags & PMf_EVAL) {
2824 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
2825 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
2827 else if (repl->op_type == OP_CONST)
2831 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
2832 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
2833 if (curop->op_type == OP_GV) {
2834 GV *gv = cGVOPx_gv(curop);
2836 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
2839 else if (curop->op_type == OP_RV2CV)
2841 else if (curop->op_type == OP_RV2SV ||
2842 curop->op_type == OP_RV2AV ||
2843 curop->op_type == OP_RV2HV ||
2844 curop->op_type == OP_RV2GV) {
2845 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2848 else if (curop->op_type == OP_PADSV ||
2849 curop->op_type == OP_PADAV ||
2850 curop->op_type == OP_PADHV ||
2851 curop->op_type == OP_PADANY) {
2854 else if (curop->op_type == OP_PUSHRE)
2855 ; /* Okay here, dangerous in newASSIGNOP */
2865 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
2866 pm->op_pmflags |= PMf_CONST; /* const for long enough */
2867 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
2868 prepend_elem(o->op_type, scalar(repl), o);
2871 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
2872 pm->op_pmflags |= PMf_MAYBE_CONST;
2873 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2875 NewOp(1101, rcop, 1, LOGOP);
2876 rcop->op_type = OP_SUBSTCONT;
2877 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
2878 rcop->op_first = scalar(repl);
2879 rcop->op_flags |= OPf_KIDS;
2880 rcop->op_private = 1;
2883 /* establish postfix order */
2884 rcop->op_next = LINKLIST(repl);
2885 repl->op_next = (OP*)rcop;
2887 pm->op_pmreplroot = scalar((OP*)rcop);
2888 pm->op_pmreplstart = LINKLIST(rcop);
2897 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
2900 NewOp(1101, svop, 1, SVOP);
2901 svop->op_type = (OPCODE)type;
2902 svop->op_ppaddr = PL_ppaddr[type];
2904 svop->op_next = (OP*)svop;
2905 svop->op_flags = (U8)flags;
2906 if (PL_opargs[type] & OA_RETSCALAR)
2908 if (PL_opargs[type] & OA_TARGET)
2909 svop->op_targ = pad_alloc(type, SVs_PADTMP);
2910 return CHECKOP(type, svop);
2914 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2917 NewOp(1101, padop, 1, PADOP);
2918 padop->op_type = (OPCODE)type;
2919 padop->op_ppaddr = PL_ppaddr[type];
2920 padop->op_padix = pad_alloc(type, SVs_PADTMP);
2921 SvREFCNT_dec(PAD_SVl(padop->op_padix));
2922 PAD_SETSV(padop->op_padix, sv);
2925 padop->op_next = (OP*)padop;
2926 padop->op_flags = (U8)flags;
2927 if (PL_opargs[type] & OA_RETSCALAR)
2929 if (PL_opargs[type] & OA_TARGET)
2930 padop->op_targ = pad_alloc(type, SVs_PADTMP);
2931 return CHECKOP(type, padop);
2935 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
2940 return newPADOP(type, flags, SvREFCNT_inc(gv));
2942 return newSVOP(type, flags, SvREFCNT_inc(gv));
2947 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
2950 NewOp(1101, pvop, 1, PVOP);
2951 pvop->op_type = (OPCODE)type;
2952 pvop->op_ppaddr = PL_ppaddr[type];
2954 pvop->op_next = (OP*)pvop;
2955 pvop->op_flags = (U8)flags;
2956 if (PL_opargs[type] & OA_RETSCALAR)
2958 if (PL_opargs[type] & OA_TARGET)
2959 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
2960 return CHECKOP(type, pvop);
2964 Perl_package(pTHX_ OP *o)
2969 save_hptr(&PL_curstash);
2970 save_item(PL_curstname);
2972 name = SvPV(cSVOPo->op_sv, len);
2973 PL_curstash = gv_stashpvn(name, len, TRUE);
2974 sv_setpvn(PL_curstname, name, len);
2977 PL_hints |= HINT_BLOCK_SCOPE;
2978 PL_copline = NOLINE;
2983 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
2989 if (idop->op_type != OP_CONST)
2990 Perl_croak(aTHX_ "Module name must be constant");
2994 if (version != Nullop) {
2995 SV *vesv = ((SVOP*)version)->op_sv;
2997 if (arg == Nullop && !SvNIOKp(vesv)) {
3004 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3005 Perl_croak(aTHX_ "Version number must be constant number");
3007 /* Make copy of idop so we don't free it twice */
3008 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3010 /* Fake up a method call to VERSION */
3011 meth = newSVpvn("VERSION",7);
3012 sv_upgrade(meth, SVt_PVIV);
3013 (void)SvIOK_on(meth);
3016 PERL_HASH(hash, SvPVX(meth), SvCUR(meth));
3017 SvUV_set(meth, hash);
3019 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3020 append_elem(OP_LIST,
3021 prepend_elem(OP_LIST, pack, list(version)),
3022 newSVOP(OP_METHOD_NAMED, 0, meth)));
3026 /* Fake up an import/unimport */
3027 if (arg && arg->op_type == OP_STUB)
3028 imop = arg; /* no import on explicit () */
3029 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3030 imop = Nullop; /* use 5.0; */
3035 /* Make copy of idop so we don't free it twice */
3036 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3038 /* Fake up a method call to import/unimport */
3039 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);
3040 (void)SvUPGRADE(meth, SVt_PVIV);
3041 (void)SvIOK_on(meth);
3044 PERL_HASH(hash, SvPVX(meth), SvCUR(meth));
3045 SvUV_set(meth, hash);
3047 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3048 append_elem(OP_LIST,
3049 prepend_elem(OP_LIST, pack, list(arg)),
3050 newSVOP(OP_METHOD_NAMED, 0, meth)));
3053 /* Fake up the BEGIN {}, which does its thing immediately. */
3055 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3058 append_elem(OP_LINESEQ,
3059 append_elem(OP_LINESEQ,
3060 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, idop)),
3061 newSTATEOP(0, Nullch, veop)),
3062 newSTATEOP(0, Nullch, imop) ));
3064 /* The "did you use incorrect case?" warning used to be here.
3065 * The problem is that on case-insensitive filesystems one
3066 * might get false positives for "use" (and "require"):
3067 * "use Strict" or "require CARP" will work. This causes
3068 * portability problems for the script: in case-strict
3069 * filesystems the script will stop working.
3071 * The "incorrect case" warning checked whether "use Foo"
3072 * imported "Foo" to your namespace, but that is wrong, too:
3073 * there is no requirement nor promise in the language that
3074 * a Foo.pm should or would contain anything in package "Foo".
3076 * There is very little Configure-wise that can be done, either:
3077 * the case-sensitivity of the build filesystem of Perl does not
3078 * help in guessing the case-sensitivity of the runtime environment.
3081 PL_hints |= HINT_BLOCK_SCOPE;
3082 PL_copline = NOLINE;
3084 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3088 =head1 Embedding Functions
3090 =for apidoc load_module
3092 Loads the module whose name is pointed to by the string part of name.
3093 Note that the actual module name, not its filename, should be given.
3094 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3095 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3096 (or 0 for no flags). ver, if specified, provides version semantics
3097 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3098 arguments can be used to specify arguments to the module's import()
3099 method, similar to C<use Foo::Bar VERSION LIST>.
3104 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3107 va_start(args, ver);
3108 vload_module(flags, name, ver, &args);
3112 #ifdef PERL_IMPLICIT_CONTEXT
3114 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3118 va_start(args, ver);
3119 vload_module(flags, name, ver, &args);
3125 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3127 OP *modname, *veop, *imop;
3129 modname = newSVOP(OP_CONST, 0, name);
3130 modname->op_private |= OPpCONST_BARE;
3132 veop = newSVOP(OP_CONST, 0, ver);
3136 if (flags & PERL_LOADMOD_NOIMPORT) {
3137 imop = sawparens(newNULLLIST());
3139 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3140 imop = va_arg(*args, OP*);
3145 sv = va_arg(*args, SV*);
3147 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3148 sv = va_arg(*args, SV*);
3152 const line_t ocopline = PL_copline;
3153 COP * const ocurcop = PL_curcop;
3154 const int oexpect = PL_expect;
3156 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3157 veop, modname, imop);
3158 PL_expect = oexpect;
3159 PL_copline = ocopline;
3160 PL_curcop = ocurcop;
3165 Perl_dofile(pTHX_ OP *term)
3170 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3171 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
3172 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3174 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3175 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3176 append_elem(OP_LIST, term,
3177 scalar(newUNOP(OP_RV2CV, 0,
3182 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3188 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3190 return newBINOP(OP_LSLICE, flags,
3191 list(force_list(subscript)),
3192 list(force_list(listval)) );
3196 S_list_assignment(pTHX_ register const OP *o)
3201 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3202 o = cUNOPo->op_first;
3204 if (o->op_type == OP_COND_EXPR) {
3205 const I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3206 const I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3211 yyerror("Assignment to both a list and a scalar");
3215 if (o->op_type == OP_LIST &&
3216 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3217 o->op_private & OPpLVAL_INTRO)
3220 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3221 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3222 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3225 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3228 if (o->op_type == OP_RV2SV)
3235 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3240 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3241 return newLOGOP(optype, 0,
3242 mod(scalar(left), optype),
3243 newUNOP(OP_SASSIGN, 0, scalar(right)));
3246 return newBINOP(optype, OPf_STACKED,
3247 mod(scalar(left), optype), scalar(right));
3251 if (list_assignment(left)) {
3255 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3256 left = mod(left, OP_AASSIGN);
3264 /* optimise C<my @x = ()> to C<my @x>, and likewise for hashes */
3265 if ((left->op_type == OP_PADAV || left->op_type == OP_PADHV)
3266 && right->op_type == OP_STUB
3267 && (left->op_private & OPpLVAL_INTRO))
3270 left->op_flags &= ~(OPf_REF|OPf_SPECIAL);
3273 curop = list(force_list(left));
3274 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3275 o->op_private = (U8)(0 | (flags >> 8));
3277 /* PL_generation sorcery:
3278 * an assignment like ($a,$b) = ($c,$d) is easier than
3279 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3280 * To detect whether there are common vars, the global var
3281 * PL_generation is incremented for each assign op we compile.
3282 * Then, while compiling the assign op, we run through all the
3283 * variables on both sides of the assignment, setting a spare slot
3284 * in each of them to PL_generation. If any of them already have
3285 * that value, we know we've got commonality. We could use a
3286 * single bit marker, but then we'd have to make 2 passes, first
3287 * to clear the flag, then to test and set it. To find somewhere
3288 * to store these values, evil chicanery is done with SvCUR().
3291 if (!(left->op_private & OPpLVAL_INTRO)) {
3294 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3295 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3296 if (curop->op_type == OP_GV) {
3297 GV *gv = cGVOPx_gv(curop);
3298 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3300 SvCUR_set(gv, PL_generation);
3302 else if (curop->op_type == OP_PADSV ||
3303 curop->op_type == OP_PADAV ||
3304 curop->op_type == OP_PADHV ||
3305 curop->op_type == OP_PADANY)
3307 if (PAD_COMPNAME_GEN(curop->op_targ)
3308 == (STRLEN)PL_generation)
3310 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
3313 else if (curop->op_type == OP_RV2CV)
3315 else if (curop->op_type == OP_RV2SV ||
3316 curop->op_type == OP_RV2AV ||
3317 curop->op_type == OP_RV2HV ||
3318 curop->op_type == OP_RV2GV) {
3319 if (lastop->op_type != OP_GV) /* funny deref? */
3322 else if (curop->op_type == OP_PUSHRE) {
3323 if (((PMOP*)curop)->op_pmreplroot) {
3325 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3326 ((PMOP*)curop)->op_pmreplroot));
3328 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3330 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3332 SvCUR_set(gv, PL_generation);
3341 o->op_private |= OPpASSIGN_COMMON;
3343 if (right && right->op_type == OP_SPLIT) {
3345 if ((tmpop = ((LISTOP*)right)->op_first) &&
3346 tmpop->op_type == OP_PUSHRE)
3348 PMOP *pm = (PMOP*)tmpop;
3349 if (left->op_type == OP_RV2AV &&
3350 !(left->op_private & OPpLVAL_INTRO) &&
3351 !(o->op_private & OPpASSIGN_COMMON) )
3353 tmpop = ((UNOP*)left)->op_first;
3354 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3356 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3357 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3359 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3360 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3362 pm->op_pmflags |= PMf_ONCE;
3363 tmpop = cUNOPo->op_first; /* to list (nulled) */
3364 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3365 tmpop->op_sibling = Nullop; /* don't free split */
3366 right->op_next = tmpop->op_next; /* fix starting loc */
3367 op_free(o); /* blow off assign */
3368 right->op_flags &= ~OPf_WANT;
3369 /* "I don't know and I don't care." */
3374 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3375 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3377 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3379 sv_setiv(sv, PL_modcount+1);
3387 right = newOP(OP_UNDEF, 0);
3388 if (right->op_type == OP_READLINE) {
3389 right->op_flags |= OPf_STACKED;
3390 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3393 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3394 o = newBINOP(OP_SASSIGN, flags,
3395 scalar(right), mod(scalar(left), OP_SASSIGN) );
3407 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3409 const U32 seq = intro_my();
3412 NewOp(1101, cop, 1, COP);
3413 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3414 cop->op_type = OP_DBSTATE;
3415 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3418 cop->op_type = OP_NEXTSTATE;
3419 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3421 cop->op_flags = (U8)flags;
3422 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3424 cop->op_private |= NATIVE_HINTS;
3426 PL_compiling.op_private = cop->op_private;
3427 cop->op_next = (OP*)cop;
3430 cop->cop_label = label;
3431 PL_hints |= HINT_BLOCK_SCOPE;
3434 cop->cop_arybase = PL_curcop->cop_arybase;
3435 if (specialWARN(PL_curcop->cop_warnings))
3436 cop->cop_warnings = PL_curcop->cop_warnings ;
3438 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3439 if (specialCopIO(PL_curcop->cop_io))
3440 cop->cop_io = PL_curcop->cop_io;
3442 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3445 if (PL_copline == NOLINE)
3446 CopLINE_set(cop, CopLINE(PL_curcop));
3448 CopLINE_set(cop, PL_copline);
3449 PL_copline = NOLINE;
3452 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3454 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3456 CopSTASH_set(cop, PL_curstash);
3458 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3459 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3460 if (svp && *svp != &PL_sv_undef ) {
3461 (void)SvIOK_on(*svp);
3462 SvIV_set(*svp, PTR2IV(cop));
3466 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3471 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3473 return new_logop(type, flags, &first, &other);
3477 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3481 OP *first = *firstp;
3482 OP *other = *otherp;
3484 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3485 return newBINOP(type, flags, scalar(first), scalar(other));
3487 scalarboolean(first);
3488 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3489 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3490 if (type == OP_AND || type == OP_OR) {
3496 first = *firstp = cUNOPo->op_first;
3498 first->op_next = o->op_next;
3499 cUNOPo->op_first = Nullop;
3503 if (first->op_type == OP_CONST) {
3504 if (first->op_private & OPpCONST_STRICT)
3505 no_bareword_allowed(first);
3506 else if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3507 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3508 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
3509 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
3510 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
3513 if (other->op_type == OP_CONST)
3514 other->op_private |= OPpCONST_SHORTCIRCUIT;
3518 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
3519 const OP *o2 = other;
3520 if ( ! (o2->op_type == OP_LIST
3521 && (( o2 = cUNOPx(o2)->op_first))
3522 && o2->op_type == OP_PUSHMARK
3523 && (( o2 = o2->op_sibling)) )
3526 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
3527 || o2->op_type == OP_PADHV)
3528 && o2->op_private & OPpLVAL_INTRO
3529 && ckWARN(WARN_DEPRECATED))
3531 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
3532 "Deprecated use of my() in false conditional");
3537 if (first->op_type == OP_CONST)
3538 first->op_private |= OPpCONST_SHORTCIRCUIT;
3542 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS) &&
3543 type != OP_DOR) /* [#24076] Don't warn for <FH> err FOO. */
3545 const OP *k1 = ((UNOP*)first)->op_first;
3546 const OP *k2 = k1->op_sibling;
3548 switch (first->op_type)
3551 if (k2 && k2->op_type == OP_READLINE
3552 && (k2->op_flags & OPf_STACKED)
3553 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3555 warnop = k2->op_type;
3560 if (k1->op_type == OP_READDIR
3561 || k1->op_type == OP_GLOB
3562 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3563 || k1->op_type == OP_EACH)
3565 warnop = ((k1->op_type == OP_NULL)
3566 ? (OPCODE)k1->op_targ : k1->op_type);
3571 const line_t oldline = CopLINE(PL_curcop);
3572 CopLINE_set(PL_curcop, PL_copline);
3573 Perl_warner(aTHX_ packWARN(WARN_MISC),
3574 "Value of %s%s can be \"0\"; test with defined()",
3576 ((warnop == OP_READLINE || warnop == OP_GLOB)
3577 ? " construct" : "() operator"));
3578 CopLINE_set(PL_curcop, oldline);
3585 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3586 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3588 NewOp(1101, logop, 1, LOGOP);
3590 logop->op_type = (OPCODE)type;
3591 logop->op_ppaddr = PL_ppaddr[type];
3592 logop->op_first = first;
3593 logop->op_flags = flags | OPf_KIDS;
3594 logop->op_other = LINKLIST(other);
3595 logop->op_private = (U8)(1 | (flags >> 8));
3597 /* establish postfix order */
3598 logop->op_next = LINKLIST(first);
3599 first->op_next = (OP*)logop;
3600 first->op_sibling = other;
3602 CHECKOP(type,logop);
3604 o = newUNOP(OP_NULL, 0, (OP*)logop);
3611 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3618 return newLOGOP(OP_AND, 0, first, trueop);
3620 return newLOGOP(OP_OR, 0, first, falseop);
3622 scalarboolean(first);
3623 if (first->op_type == OP_CONST) {
3624 if (first->op_private & OPpCONST_BARE &&
3625 first->op_private & OPpCONST_STRICT) {
3626 no_bareword_allowed(first);
3628 if (SvTRUE(((SVOP*)first)->op_sv)) {
3639 NewOp(1101, logop, 1, LOGOP);
3640 logop->op_type = OP_COND_EXPR;
3641 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3642 logop->op_first = first;
3643 logop->op_flags = flags | OPf_KIDS;
3644 logop->op_private = (U8)(1 | (flags >> 8));
3645 logop->op_other = LINKLIST(trueop);
3646 logop->op_next = LINKLIST(falseop);
3648 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
3651 /* establish postfix order */
3652 start = LINKLIST(first);
3653 first->op_next = (OP*)logop;
3655 first->op_sibling = trueop;
3656 trueop->op_sibling = falseop;
3657 o = newUNOP(OP_NULL, 0, (OP*)logop);
3659 trueop->op_next = falseop->op_next = o;
3666 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3674 NewOp(1101, range, 1, LOGOP);
3676 range->op_type = OP_RANGE;
3677 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3678 range->op_first = left;
3679 range->op_flags = OPf_KIDS;
3680 leftstart = LINKLIST(left);
3681 range->op_other = LINKLIST(right);
3682 range->op_private = (U8)(1 | (flags >> 8));
3684 left->op_sibling = right;
3686 range->op_next = (OP*)range;
3687 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3688 flop = newUNOP(OP_FLOP, 0, flip);
3689 o = newUNOP(OP_NULL, 0, flop);
3691 range->op_next = leftstart;
3693 left->op_next = flip;
3694 right->op_next = flop;
3696 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3697 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3698 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3699 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3701 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3702 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3705 if (!flip->op_private || !flop->op_private)
3706 linklist(o); /* blow off optimizer unless constant */
3712 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3716 const bool once = block && block->op_flags & OPf_SPECIAL &&
3717 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3721 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3722 return block; /* do {} while 0 does once */
3723 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3724 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3725 expr = newUNOP(OP_DEFINED, 0,
3726 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3727 } else if (expr->op_flags & OPf_KIDS) {
3728 const OP *k1 = ((UNOP*)expr)->op_first;
3729 const OP *k2 = (k1) ? k1->op_sibling : NULL;
3730 switch (expr->op_type) {
3732 if (k2 && k2->op_type == OP_READLINE
3733 && (k2->op_flags & OPf_STACKED)
3734 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3735 expr = newUNOP(OP_DEFINED, 0, expr);
3739 if (k1->op_type == OP_READDIR
3740 || k1->op_type == OP_GLOB
3741 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3742 || k1->op_type == OP_EACH)
3743 expr = newUNOP(OP_DEFINED, 0, expr);
3749 /* if block is null, the next append_elem() would put UNSTACK, a scalar
3750 * op, in listop. This is wrong. [perl #27024] */
3752 block = newOP(OP_NULL, 0);
3753 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3754 o = new_logop(OP_AND, 0, &expr, &listop);
3757 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3759 if (once && o != listop)
3760 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3763 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3765 o->op_flags |= flags;
3767 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3772 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3781 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3782 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3783 expr = newUNOP(OP_DEFINED, 0,
3784 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3785 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3786 const OP *k1 = ((UNOP*)expr)->op_first;
3787 const OP *k2 = (k1) ? k1->op_sibling : NULL;
3788 switch (expr->op_type) {
3790 if (k2 && k2->op_type == OP_READLINE
3791 && (k2->op_flags & OPf_STACKED)
3792 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3793 expr = newUNOP(OP_DEFINED, 0, expr);
3797 if (k1->op_type == OP_READDIR
3798 || k1->op_type == OP_GLOB
3799 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3800 || k1->op_type == OP_EACH)
3801 expr = newUNOP(OP_DEFINED, 0, expr);
3807 block = newOP(OP_NULL, 0);
3809 block = scope(block);
3813 next = LINKLIST(cont);
3816 OP *unstack = newOP(OP_UNSTACK, 0);
3819 cont = append_elem(OP_LINESEQ, cont, unstack);
3822 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3823 redo = LINKLIST(listop);
3826 PL_copline = (line_t)whileline;
3828 o = new_logop(OP_AND, 0, &expr, &listop);
3829 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3830 op_free(expr); /* oops, it's a while (0) */
3832 return Nullop; /* listop already freed by new_logop */
3835 ((LISTOP*)listop)->op_last->op_next =
3836 (o == listop ? redo : LINKLIST(o));
3842 NewOp(1101,loop,1,LOOP);
3843 loop->op_type = OP_ENTERLOOP;
3844 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3845 loop->op_private = 0;
3846 loop->op_next = (OP*)loop;
3849 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3851 loop->op_redoop = redo;
3852 loop->op_lastop = o;
3853 o->op_private |= loopflags;
3856 loop->op_nextop = next;
3858 loop->op_nextop = o;
3860 o->op_flags |= flags;
3861 o->op_private |= (flags >> 8);
3866 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
3870 PADOFFSET padoff = 0;
3875 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
3876 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
3877 sv->op_type = OP_RV2GV;
3878 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3880 else if (sv->op_type == OP_PADSV) { /* private variable */
3881 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
3882 padoff = sv->op_targ;
3887 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3888 padoff = sv->op_targ;
3890 iterflags |= OPf_SPECIAL;
3895 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3898 const I32 offset = pad_findmy("$_");
3899 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
3900 sv = newGVOP(OP_GV, 0, PL_defgv);
3906 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3907 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3908 iterflags |= OPf_STACKED;
3910 else if (expr->op_type == OP_NULL &&
3911 (expr->op_flags & OPf_KIDS) &&
3912 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3914 /* Basically turn for($x..$y) into the same as for($x,$y), but we
3915 * set the STACKED flag to indicate that these values are to be
3916 * treated as min/max values by 'pp_iterinit'.
3918 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
3919 LOGOP* range = (LOGOP*) flip->op_first;
3920 OP* left = range->op_first;
3921 OP* right = left->op_sibling;
3924 range->op_flags &= ~OPf_KIDS;
3925 range->op_first = Nullop;
3927 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
3928 listop->op_first->op_next = range->op_next;
3929 left->op_next = range->op_other;
3930 right->op_next = (OP*)listop;
3931 listop->op_next = listop->op_first;
3934 expr = (OP*)(listop);
3936 iterflags |= OPf_STACKED;
3939 expr = mod(force_list(expr), OP_GREPSTART);
3942 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
3943 append_elem(OP_LIST, expr, scalar(sv))));
3944 assert(!loop->op_next);
3945 /* for my $x () sets OPpLVAL_INTRO;
3946 * for our $x () sets OPpOUR_INTRO */
3947 loop->op_private = (U8)iterpflags;
3948 #ifdef PL_OP_SLAB_ALLOC
3951 NewOp(1234,tmp,1,LOOP);
3952 Copy(loop,tmp,1,LISTOP);
3957 Renew(loop, 1, LOOP);
3959 loop->op_targ = padoff;
3960 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
3961 PL_copline = forline;
3962 return newSTATEOP(0, label, wop);
3966 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
3971 if (type != OP_GOTO || label->op_type == OP_CONST) {
3972 /* "last()" means "last" */
3973 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
3974 o = newOP(type, OPf_SPECIAL);
3976 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
3977 ? SvPVx(((SVOP*)label)->op_sv, n_a)
3983 /* Check whether it's going to be a goto &function */
3984 if (label->op_type == OP_ENTERSUB
3985 && !(label->op_flags & OPf_STACKED))
3986 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
3987 o = newUNOP(type, OPf_STACKED, label);
3989 PL_hints |= HINT_BLOCK_SCOPE;
3994 =for apidoc cv_undef
3996 Clear out all the active components of a CV. This can happen either
3997 by an explicit C<undef &foo>, or by the reference count going to zero.
3998 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
3999 children can still follow the full lexical scope chain.
4005 Perl_cv_undef(pTHX_ CV *cv)
4008 if (CvFILE(cv) && !CvXSUB(cv)) {
4009 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4010 Safefree(CvFILE(cv));
4015 if (!CvXSUB(cv) && CvROOT(cv)) {
4017 Perl_croak(aTHX_ "Can't undef active subroutine");
4020 PAD_SAVE_SETNULLPAD();
4022 op_free(CvROOT(cv));
4023 CvROOT(cv) = Nullop;
4026 SvPOK_off((SV*)cv); /* forget prototype */
4031 /* remove CvOUTSIDE unless this is an undef rather than a free */
4032 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4033 if (!CvWEAKOUTSIDE(cv))
4034 SvREFCNT_dec(CvOUTSIDE(cv));
4035 CvOUTSIDE(cv) = Nullcv;
4038 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4044 /* delete all flags except WEAKOUTSIDE */
4045 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4049 Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p)
4051 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4052 SV* msg = sv_newmortal();
4056 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4057 sv_setpv(msg, "Prototype mismatch:");
4059 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4061 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (const SV *)cv);
4063 Perl_sv_catpv(aTHX_ msg, ": none");
4064 sv_catpv(msg, " vs ");
4066 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4068 sv_catpv(msg, "none");
4069 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
4073 static void const_sv_xsub(pTHX_ CV* cv);
4077 =head1 Optree Manipulation Functions
4079 =for apidoc cv_const_sv
4081 If C<cv> is a constant sub eligible for inlining. returns the constant
4082 value returned by the sub. Otherwise, returns NULL.
4084 Constant subs can be created with C<newCONSTSUB> or as described in
4085 L<perlsub/"Constant Functions">.
4090 Perl_cv_const_sv(pTHX_ CV *cv)
4092 if (!cv || !CvCONST(cv))
4094 return (SV*)CvXSUBANY(cv).any_ptr;
4097 /* op_const_sv: examine an optree to determine whether it's in-lineable.
4098 * Can be called in 3 ways:
4101 * look for a single OP_CONST with attached value: return the value
4103 * cv && CvCLONE(cv) && !CvCONST(cv)
4105 * examine the clone prototype, and if contains only a single
4106 * OP_CONST referencing a pad const, or a single PADSV referencing
4107 * an outer lexical, return a non-zero value to indicate the CV is
4108 * a candidate for "constizing" at clone time
4112 * We have just cloned an anon prototype that was marked as a const
4113 * candidiate. Try to grab the current value, and in the case of
4114 * PADSV, ignore it if it has multiple references. Return the value.
4118 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
4125 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4126 o = cLISTOPo->op_first->op_sibling;
4128 for (; o; o = o->op_next) {
4129 OPCODE type = o->op_type;
4131 if (sv && o->op_next == o)
4133 if (o->op_next != o) {
4134 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4136 if (type == OP_DBSTATE)
4139 if (type == OP_LEAVESUB || type == OP_RETURN)
4143 if (type == OP_CONST && cSVOPo->op_sv)
4145 else if (cv && type == OP_CONST) {
4146 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4150 else if (cv && type == OP_PADSV) {
4151 if (CvCONST(cv)) { /* newly cloned anon */
4152 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4153 /* the candidate should have 1 ref from this pad and 1 ref
4154 * from the parent */
4155 if (!sv || SvREFCNT(sv) != 2)
4162 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4163 sv = &PL_sv_undef; /* an arbitrary non-null value */
4174 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4185 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4189 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4191 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4195 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4205 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4208 assert(proto->op_type == OP_CONST);
4209 ps = SvPVx(((SVOP*)proto)->op_sv, n_a);
4214 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4215 SV *sv = sv_newmortal();
4216 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4217 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4218 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4223 gv = name ? gv_fetchsv(cSVOPo->op_sv,
4224 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4226 : gv_fetchpv(aname ? aname
4227 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4228 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4238 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4239 maximum a prototype before. */
4240 if (SvTYPE(gv) > SVt_NULL) {
4241 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4242 && ckWARN_d(WARN_PROTOTYPE))
4244 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4246 cv_ckproto((CV*)gv, NULL, ps);
4249 sv_setpv((SV*)gv, ps);
4251 sv_setiv((SV*)gv, -1);
4252 SvREFCNT_dec(PL_compcv);
4253 cv = PL_compcv = NULL;
4254 PL_sub_generation++;
4258 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4260 #ifdef GV_UNIQUE_CHECK
4261 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4262 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4266 if (!block || !ps || *ps || attrs)
4269 const_sv = op_const_sv(block, Nullcv);
4272 const bool exists = CvROOT(cv) || CvXSUB(cv);
4274 #ifdef GV_UNIQUE_CHECK
4275 if (exists && GvUNIQUE(gv)) {
4276 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4280 /* if the subroutine doesn't exist and wasn't pre-declared
4281 * with a prototype, assume it will be AUTOLOADed,
4282 * skipping the prototype check
4284 if (exists || SvPOK(cv))
4285 cv_ckproto(cv, gv, ps);
4286 /* already defined (or promised)? */
4287 if (exists || GvASSUMECV(gv)) {
4288 if (!block && !attrs) {
4289 if (CvFLAGS(PL_compcv)) {
4290 /* might have had built-in attrs applied */
4291 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4293 /* just a "sub foo;" when &foo is already defined */
4294 SAVEFREESV(PL_compcv);
4297 /* ahem, death to those who redefine active sort subs */
4298 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4299 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4301 if (ckWARN(WARN_REDEFINE)
4303 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4305 const line_t oldline = CopLINE(PL_curcop);
4306 if (PL_copline != NOLINE)
4307 CopLINE_set(PL_curcop, PL_copline);
4308 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4309 CvCONST(cv) ? "Constant subroutine %s redefined"
4310 : "Subroutine %s redefined", name);
4311 CopLINE_set(PL_curcop, oldline);
4319 (void)SvREFCNT_inc(const_sv);
4321 assert(!CvROOT(cv) && !CvCONST(cv));
4322 sv_setpv((SV*)cv, ""); /* prototype is "" */
4323 CvXSUBANY(cv).any_ptr = const_sv;
4324 CvXSUB(cv) = const_sv_xsub;
4329 cv = newCONSTSUB(NULL, name, const_sv);
4332 SvREFCNT_dec(PL_compcv);
4334 PL_sub_generation++;
4341 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4342 * before we clobber PL_compcv.
4346 /* Might have had built-in attributes applied -- propagate them. */
4347 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4348 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4349 stash = GvSTASH(CvGV(cv));
4350 else if (CvSTASH(cv))
4351 stash = CvSTASH(cv);
4353 stash = PL_curstash;
4356 /* possibly about to re-define existing subr -- ignore old cv */
4357 rcv = (SV*)PL_compcv;
4358 if (name && GvSTASH(gv))
4359 stash = GvSTASH(gv);
4361 stash = PL_curstash;
4363 apply_attrs(stash, rcv, attrs, FALSE);
4365 if (cv) { /* must reuse cv if autoloaded */
4367 /* got here with just attrs -- work done, so bug out */
4368 SAVEFREESV(PL_compcv);
4371 /* transfer PL_compcv to cv */
4373 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4374 if (!CvWEAKOUTSIDE(cv))
4375 SvREFCNT_dec(CvOUTSIDE(cv));
4376 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4377 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4378 CvOUTSIDE(PL_compcv) = 0;
4379 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4380 CvPADLIST(PL_compcv) = 0;
4381 /* inner references to PL_compcv must be fixed up ... */
4382 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4383 /* ... before we throw it away */
4384 SvREFCNT_dec(PL_compcv);
4386 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4387 ++PL_sub_generation;
4394 PL_sub_generation++;
4398 CvFILE_set_from_cop(cv, PL_curcop);
4399 CvSTASH(cv) = PL_curstash;
4402 sv_setpv((SV*)cv, ps);
4404 if (PL_error_count) {
4408 const char *s = strrchr(name, ':');
4410 if (strEQ(s, "BEGIN")) {
4411 const char not_safe[] =
4412 "BEGIN not safe after errors--compilation aborted";
4413 if (PL_in_eval & EVAL_KEEPERR)
4414 Perl_croak(aTHX_ not_safe);
4416 /* force display of errors found but not reported */
4417 sv_catpv(ERRSV, not_safe);
4418 Perl_croak(aTHX_ "%"SVf, ERRSV);
4427 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4428 mod(scalarseq(block), OP_LEAVESUBLV));
4431 /* This makes sub {}; work as expected. */
4432 if (block->op_type == OP_STUB) {
4434 block = newSTATEOP(0, Nullch, 0);
4436 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4438 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4439 OpREFCNT_set(CvROOT(cv), 1);
4440 CvSTART(cv) = LINKLIST(CvROOT(cv));
4441 CvROOT(cv)->op_next = 0;
4442 CALL_PEEP(CvSTART(cv));
4444 /* now that optimizer has done its work, adjust pad values */
4446 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4449 assert(!CvCONST(cv));
4450 if (ps && !*ps && op_const_sv(block, cv))
4454 if (name || aname) {
4456 const char *tname = (name ? name : aname);
4458 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4459 SV *sv = NEWSV(0,0);
4460 SV *tmpstr = sv_newmortal();
4461 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4465 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4467 (long)PL_subline, (long)CopLINE(PL_curcop));
4468 gv_efullname3(tmpstr, gv, Nullch);
4469 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4470 hv = GvHVn(db_postponed);
4471 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4472 && (pcv = GvCV(db_postponed)))
4478 call_sv((SV*)pcv, G_DISCARD);
4482 if ((s = strrchr(tname,':')))
4487 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4490 if (strEQ(s, "BEGIN") && !PL_error_count) {
4491 const I32 oldscope = PL_scopestack_ix;
4493 SAVECOPFILE(&PL_compiling);
4494 SAVECOPLINE(&PL_compiling);
4497 PL_beginav = newAV();
4498 DEBUG_x( dump_sub(gv) );
4499 av_push(PL_beginav, (SV*)cv);
4500 GvCV(gv) = 0; /* cv has been hijacked */
4501 call_list(oldscope, PL_beginav);
4503 PL_curcop = &PL_compiling;
4504 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4507 else if (strEQ(s, "END") && !PL_error_count) {
4510 DEBUG_x( dump_sub(gv) );
4511 av_unshift(PL_endav, 1);
4512 av_store(PL_endav, 0, (SV*)cv);
4513 GvCV(gv) = 0; /* cv has been hijacked */
4515 else if (strEQ(s, "CHECK") && !PL_error_count) {
4517 PL_checkav = newAV();
4518 DEBUG_x( dump_sub(gv) );
4519 if (PL_main_start && ckWARN(WARN_VOID))
4520 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4521 av_unshift(PL_checkav, 1);
4522 av_store(PL_checkav, 0, (SV*)cv);
4523 GvCV(gv) = 0; /* cv has been hijacked */
4525 else if (strEQ(s, "INIT") && !PL_error_count) {
4527 PL_initav = newAV();
4528 DEBUG_x( dump_sub(gv) );
4529 if (PL_main_start && ckWARN(WARN_VOID))
4530 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4531 av_push(PL_initav, (SV*)cv);
4532 GvCV(gv) = 0; /* cv has been hijacked */
4537 PL_copline = NOLINE;
4542 /* XXX unsafe for threads if eval_owner isn't held */
4544 =for apidoc newCONSTSUB
4546 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4547 eligible for inlining at compile-time.
4553 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
4559 SAVECOPLINE(PL_curcop);
4560 CopLINE_set(PL_curcop, PL_copline);
4563 PL_hints &= ~HINT_BLOCK_SCOPE;
4566 SAVESPTR(PL_curstash);
4567 SAVECOPSTASH(PL_curcop);
4568 PL_curstash = stash;
4569 CopSTASH_set(PL_curcop,stash);
4572 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4573 CvXSUBANY(cv).any_ptr = sv;
4575 sv_setpv((SV*)cv, ""); /* prototype is "" */
4578 CopSTASH_free(PL_curcop);
4586 =for apidoc U||newXS
4588 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4594 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
4596 GV *gv = gv_fetchpv(name ? name :
4597 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4598 GV_ADDMULTI, SVt_PVCV);
4602 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4604 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4606 /* just a cached method */
4610 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4611 /* already defined (or promised) */
4612 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4613 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4614 const line_t oldline = CopLINE(PL_curcop);
4615 if (PL_copline != NOLINE)
4616 CopLINE_set(PL_curcop, PL_copline);
4617 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4618 CvCONST(cv) ? "Constant subroutine %s redefined"
4619 : "Subroutine %s redefined"
4621 CopLINE_set(PL_curcop, oldline);
4628 if (cv) /* must reuse cv if autoloaded */
4631 cv = (CV*)NEWSV(1105,0);
4632 sv_upgrade((SV *)cv, SVt_PVCV);
4636 PL_sub_generation++;
4640 (void)gv_fetchfile(filename);
4641 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
4642 an external constant string */
4643 CvXSUB(cv) = subaddr;
4646 const char *s = strrchr(name,':');
4652 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4655 if (strEQ(s, "BEGIN")) {
4657 PL_beginav = newAV();
4658 av_push(PL_beginav, (SV*)cv);
4659 GvCV(gv) = 0; /* cv has been hijacked */
4661 else if (strEQ(s, "END")) {
4664 av_unshift(PL_endav, 1);
4665 av_store(PL_endav, 0, (SV*)cv);
4666 GvCV(gv) = 0; /* cv has been hijacked */
4668 else if (strEQ(s, "CHECK")) {
4670 PL_checkav = newAV();
4671 if (PL_main_start && ckWARN(WARN_VOID))
4672 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4673 av_unshift(PL_checkav, 1);
4674 av_store(PL_checkav, 0, (SV*)cv);
4675 GvCV(gv) = 0; /* cv has been hijacked */
4677 else if (strEQ(s, "INIT")) {
4679 PL_initav = newAV();
4680 if (PL_main_start && ckWARN(WARN_VOID))
4681 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4682 av_push(PL_initav, (SV*)cv);
4683 GvCV(gv) = 0; /* cv has been hijacked */
4694 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4700 gv = gv_fetchsv(cSVOPo->op_sv, TRUE, SVt_PVFM);
4702 gv = gv_fetchpv("STDOUT", TRUE, SVt_PVFM);
4704 #ifdef GV_UNIQUE_CHECK
4706 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4710 if ((cv = GvFORM(gv))) {
4711 if (ckWARN(WARN_REDEFINE)) {
4712 const line_t oldline = CopLINE(PL_curcop);
4713 if (PL_copline != NOLINE)
4714 CopLINE_set(PL_curcop, PL_copline);
4715 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4716 o ? "Format %"SVf" redefined"
4717 : "Format STDOUT redefined" ,cSVOPo->op_sv);
4718 CopLINE_set(PL_curcop, oldline);
4725 CvFILE_set_from_cop(cv, PL_curcop);
4728 pad_tidy(padtidy_FORMAT);
4729 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4730 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4731 OpREFCNT_set(CvROOT(cv), 1);
4732 CvSTART(cv) = LINKLIST(CvROOT(cv));
4733 CvROOT(cv)->op_next = 0;
4734 CALL_PEEP(CvSTART(cv));
4736 PL_copline = NOLINE;
4741 Perl_newANONLIST(pTHX_ OP *o)
4743 return newUNOP(OP_REFGEN, 0,
4744 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4748 Perl_newANONHASH(pTHX_ OP *o)
4750 return newUNOP(OP_REFGEN, 0,
4751 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4755 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4757 return newANONATTRSUB(floor, proto, Nullop, block);
4761 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4763 return newUNOP(OP_REFGEN, 0,
4764 newSVOP(OP_ANONCODE, 0,
4765 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
4769 Perl_oopsAV(pTHX_ OP *o)
4771 switch (o->op_type) {
4773 o->op_type = OP_PADAV;
4774 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4775 return ref(o, OP_RV2AV);
4778 o->op_type = OP_RV2AV;
4779 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4784 if (ckWARN_d(WARN_INTERNAL))
4785 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
4792 Perl_oopsHV(pTHX_ OP *o)
4794 switch (o->op_type) {
4797 o->op_type = OP_PADHV;
4798 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4799 return ref(o, OP_RV2HV);
4803 o->op_type = OP_RV2HV;
4804 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
4809 if (ckWARN_d(WARN_INTERNAL))
4810 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
4817 Perl_newAVREF(pTHX_ OP *o)
4819 if (o->op_type == OP_PADANY) {
4820 o->op_type = OP_PADAV;
4821 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4824 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
4825 && ckWARN(WARN_DEPRECATED)) {
4826 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4827 "Using an array as a reference is deprecated");
4829 return newUNOP(OP_RV2AV, 0, scalar(o));
4833 Perl_newGVREF(pTHX_ I32 type, OP *o)
4835 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
4836 return newUNOP(OP_NULL, 0, o);
4837 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
4841 Perl_newHVREF(pTHX_ OP *o)
4843 if (o->op_type == OP_PADANY) {
4844 o->op_type = OP_PADHV;
4845 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4848 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
4849 && ckWARN(WARN_DEPRECATED)) {
4850 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4851 "Using a hash as a reference is deprecated");
4853 return newUNOP(OP_RV2HV, 0, scalar(o));
4857 Perl_oopsCV(pTHX_ OP *o)
4859 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
4862 #ifndef HASATTRIBUTE
4863 /* No __attribute__, so the compiler doesn't know that croak never returns
4870 Perl_newCVREF(pTHX_ I32 flags, OP *o)
4872 return newUNOP(OP_RV2CV, flags, scalar(o));
4876 Perl_newSVREF(pTHX_ OP *o)
4878 if (o->op_type == OP_PADANY) {
4879 o->op_type = OP_PADSV;
4880 o->op_ppaddr = PL_ppaddr[OP_PADSV];
4883 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4884 o->op_flags |= OPpDONE_SVREF;
4887 return newUNOP(OP_RV2SV, 0, scalar(o));
4890 /* Check routines. See the comments at the top of this file for details
4891 * on when these are called */
4894 Perl_ck_anoncode(pTHX_ OP *o)
4896 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
4897 cSVOPo->op_sv = Nullsv;
4902 Perl_ck_bitop(pTHX_ OP *o)
4904 #define OP_IS_NUMCOMPARE(op) \
4905 ((op) == OP_LT || (op) == OP_I_LT || \
4906 (op) == OP_GT || (op) == OP_I_GT || \
4907 (op) == OP_LE || (op) == OP_I_LE || \
4908 (op) == OP_GE || (op) == OP_I_GE || \
4909 (op) == OP_EQ || (op) == OP_I_EQ || \
4910 (op) == OP_NE || (op) == OP_I_NE || \
4911 (op) == OP_NCMP || (op) == OP_I_NCMP)
4912 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4913 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
4914 && (o->op_type == OP_BIT_OR
4915 || o->op_type == OP_BIT_AND
4916 || o->op_type == OP_BIT_XOR))
4918 const OP * left = cBINOPo->op_first;
4919 const OP * right = left->op_sibling;
4920 if ((OP_IS_NUMCOMPARE(left->op_type) &&
4921 (left->op_flags & OPf_PARENS) == 0) ||
4922 (OP_IS_NUMCOMPARE(right->op_type) &&
4923 (right->op_flags & OPf_PARENS) == 0))
4924 if (ckWARN(WARN_PRECEDENCE))
4925 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4926 "Possible precedence problem on bitwise %c operator",
4927 o->op_type == OP_BIT_OR ? '|'
4928 : o->op_type == OP_BIT_AND ? '&' : '^'
4935 Perl_ck_concat(pTHX_ OP *o)
4937 const OP *kid = cUNOPo->op_first;
4938 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
4939 !(kUNOP->op_first->op_flags & OPf_MOD))
4940 o->op_flags |= OPf_STACKED;
4945 Perl_ck_spair(pTHX_ OP *o)
4947 if (o->op_flags & OPf_KIDS) {
4950 const OPCODE type = o->op_type;
4951 o = modkids(ck_fun(o), type);
4952 kid = cUNOPo->op_first;
4953 newop = kUNOP->op_first->op_sibling;
4955 (newop->op_sibling ||
4956 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
4957 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
4958 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
4962 op_free(kUNOP->op_first);
4963 kUNOP->op_first = newop;
4965 o->op_ppaddr = PL_ppaddr[++o->op_type];
4970 Perl_ck_delete(pTHX_ OP *o)
4974 if (o->op_flags & OPf_KIDS) {
4975 OP *kid = cUNOPo->op_first;
4976 switch (kid->op_type) {
4978 o->op_flags |= OPf_SPECIAL;
4981 o->op_private |= OPpSLICE;
4984 o->op_flags |= OPf_SPECIAL;
4989 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
4998 Perl_ck_die(pTHX_ OP *o)
5001 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5007 Perl_ck_eof(pTHX_ OP *o)
5009 const I32 type = o->op_type;
5011 if (o->op_flags & OPf_KIDS) {
5012 if (cLISTOPo->op_first->op_type == OP_STUB) {
5014 o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
5022 Perl_ck_eval(pTHX_ OP *o)
5024 PL_hints |= HINT_BLOCK_SCOPE;
5025 if (o->op_flags & OPf_KIDS) {
5026 SVOP *kid = (SVOP*)cUNOPo->op_first;
5029 o->op_flags &= ~OPf_KIDS;
5032 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
5035 cUNOPo->op_first = 0;
5038 NewOp(1101, enter, 1, LOGOP);
5039 enter->op_type = OP_ENTERTRY;
5040 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5041 enter->op_private = 0;
5043 /* establish postfix order */
5044 enter->op_next = (OP*)enter;
5046 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5047 o->op_type = OP_LEAVETRY;
5048 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5049 enter->op_other = o;
5059 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5061 o->op_targ = (PADOFFSET)PL_hints;
5066 Perl_ck_exit(pTHX_ OP *o)
5069 HV *table = GvHV(PL_hintgv);
5071 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5072 if (svp && *svp && SvTRUE(*svp))
5073 o->op_private |= OPpEXIT_VMSISH;
5075 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5081 Perl_ck_exec(pTHX_ OP *o)
5083 if (o->op_flags & OPf_STACKED) {
5086 kid = cUNOPo->op_first->op_sibling;
5087 if (kid->op_type == OP_RV2GV)
5096 Perl_ck_exists(pTHX_ OP *o)
5099 if (o->op_flags & OPf_KIDS) {
5100 OP *kid = cUNOPo->op_first;
5101 if (kid->op_type == OP_ENTERSUB) {
5102 (void) ref(kid, o->op_type);
5103 if (kid->op_type != OP_RV2CV && !PL_error_count)
5104 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5106 o->op_private |= OPpEXISTS_SUB;
5108 else if (kid->op_type == OP_AELEM)
5109 o->op_flags |= OPf_SPECIAL;
5110 else if (kid->op_type != OP_HELEM)
5111 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5120 Perl_ck_gvconst(pTHX_ register OP *o)
5122 o = fold_constants(o);
5123 if (o->op_type == OP_CONST)
5130 Perl_ck_rvconst(pTHX_ register OP *o)
5132 SVOP *kid = (SVOP*)cUNOPo->op_first;
5134 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5135 if (kid->op_type == OP_CONST) {
5138 SV *kidsv = kid->op_sv;
5140 /* Is it a constant from cv_const_sv()? */
5141 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5142 SV *rsv = SvRV(kidsv);
5143 int svtype = SvTYPE(rsv);
5144 const char *badtype = Nullch;
5146 switch (o->op_type) {
5148 if (svtype > SVt_PVMG)
5149 badtype = "a SCALAR";
5152 if (svtype != SVt_PVAV)
5153 badtype = "an ARRAY";
5156 if (svtype != SVt_PVHV)
5160 if (svtype != SVt_PVCV)
5165 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5168 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5169 const char *badthing = Nullch;
5170 switch (o->op_type) {
5172 badthing = "a SCALAR";
5175 badthing = "an ARRAY";
5178 badthing = "a HASH";
5183 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
5187 * This is a little tricky. We only want to add the symbol if we
5188 * didn't add it in the lexer. Otherwise we get duplicate strict
5189 * warnings. But if we didn't add it in the lexer, we must at
5190 * least pretend like we wanted to add it even if it existed before,
5191 * or we get possible typo warnings. OPpCONST_ENTERED says
5192 * whether the lexer already added THIS instance of this symbol.
5194 iscv = (o->op_type == OP_RV2CV) * 2;
5196 gv = gv_fetchsv(kidsv,
5197 iscv | !(kid->op_private & OPpCONST_ENTERED),
5200 : o->op_type == OP_RV2SV
5202 : o->op_type == OP_RV2AV
5204 : o->op_type == OP_RV2HV
5207 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5209 kid->op_type = OP_GV;
5210 SvREFCNT_dec(kid->op_sv);
5212 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5213 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5214 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
5216 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
5218 kid->op_sv = SvREFCNT_inc(gv);
5220 kid->op_private = 0;
5221 kid->op_ppaddr = PL_ppaddr[OP_GV];
5228 Perl_ck_ftst(pTHX_ OP *o)
5230 const I32 type = o->op_type;
5232 if (o->op_flags & OPf_REF) {
5235 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5236 SVOP *kid = (SVOP*)cUNOPo->op_first;
5238 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5239 OP *newop = newGVOP(type, OPf_REF,
5240 gv_fetchsv(kid->op_sv, TRUE, SVt_PVIO));
5246 if ((PL_hints & HINT_FILETEST_ACCESS) &&
5247 OP_IS_FILETEST_ACCESS(o))
5248 o->op_private |= OPpFT_ACCESS;
5250 if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
5251 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
5252 o->op_private |= OPpFT_STACKED;
5256 if (type == OP_FTTTY)
5257 o = newGVOP(type, OPf_REF, PL_stdingv);
5259 o = newUNOP(type, 0, newDEFSVOP());
5265 Perl_ck_fun(pTHX_ OP *o)
5267 const int type = o->op_type;
5268 register I32 oa = PL_opargs[type] >> OASHIFT;
5270 if (o->op_flags & OPf_STACKED) {
5271 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5274 return no_fh_allowed(o);
5277 if (o->op_flags & OPf_KIDS) {
5278 OP **tokid = &cLISTOPo->op_first;
5279 register OP *kid = cLISTOPo->op_first;
5283 if (kid->op_type == OP_PUSHMARK ||
5284 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5286 tokid = &kid->op_sibling;
5287 kid = kid->op_sibling;
5289 if (!kid && PL_opargs[type] & OA_DEFGV)
5290 *tokid = kid = newDEFSVOP();
5294 sibl = kid->op_sibling;
5297 /* list seen where single (scalar) arg expected? */
5298 if (numargs == 1 && !(oa >> 4)
5299 && kid->op_type == OP_LIST && type != OP_SCALAR)
5301 return too_many_arguments(o,PL_op_desc[type]);
5314 if ((type == OP_PUSH || type == OP_UNSHIFT)
5315 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5316 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5317 "Useless use of %s with no values",
5320 if (kid->op_type == OP_CONST &&
5321 (kid->op_private & OPpCONST_BARE))
5323 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5324 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVAV) ));
5325 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5326 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5327 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
5328 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5331 kid->op_sibling = sibl;
5334 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5335 bad_type(numargs, "array", PL_op_desc[type], kid);
5339 if (kid->op_type == OP_CONST &&
5340 (kid->op_private & OPpCONST_BARE))
5342 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5343 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVHV) ));
5344 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5345 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5346 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
5347 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5350 kid->op_sibling = sibl;
5353 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5354 bad_type(numargs, "hash", PL_op_desc[type], kid);
5359 OP *newop = newUNOP(OP_NULL, 0, kid);
5360 kid->op_sibling = 0;
5362 newop->op_next = newop;
5364 kid->op_sibling = sibl;
5369 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5370 if (kid->op_type == OP_CONST &&
5371 (kid->op_private & OPpCONST_BARE))
5373 OP *newop = newGVOP(OP_GV, 0,
5374 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVIO) );
5375 if (!(o->op_private & 1) && /* if not unop */
5376 kid == cLISTOPo->op_last)
5377 cLISTOPo->op_last = newop;
5381 else if (kid->op_type == OP_READLINE) {
5382 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5383 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5386 I32 flags = OPf_SPECIAL;
5390 /* is this op a FH constructor? */
5391 if (is_handle_constructor(o,numargs)) {
5392 const char *name = Nullch;
5396 /* Set a flag to tell rv2gv to vivify
5397 * need to "prove" flag does not mean something
5398 * else already - NI-S 1999/05/07
5401 if (kid->op_type == OP_PADSV) {
5402 name = PAD_COMPNAME_PV(kid->op_targ);
5403 /* SvCUR of a pad namesv can't be trusted
5404 * (see PL_generation), so calc its length
5410 else if (kid->op_type == OP_RV2SV
5411 && kUNOP->op_first->op_type == OP_GV)
5413 GV *gv = cGVOPx_gv(kUNOP->op_first);
5415 len = GvNAMELEN(gv);
5417 else if (kid->op_type == OP_AELEM
5418 || kid->op_type == OP_HELEM)
5423 if ((op = ((BINOP*)kid)->op_first)) {
5424 SV *tmpstr = Nullsv;
5426 kid->op_type == OP_AELEM ?
5428 if (((op->op_type == OP_RV2AV) ||
5429 (op->op_type == OP_RV2HV)) &&
5430 (op = ((UNOP*)op)->op_first) &&
5431 (op->op_type == OP_GV)) {
5432 /* packagevar $a[] or $h{} */
5433 GV *gv = cGVOPx_gv(op);
5441 else if (op->op_type == OP_PADAV
5442 || op->op_type == OP_PADHV) {
5443 /* lexicalvar $a[] or $h{} */
5444 const char *padname =
5445 PAD_COMPNAME_PV(op->op_targ);
5455 name = SvPV(tmpstr, len);
5460 name = "__ANONIO__";
5467 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5468 namesv = PAD_SVl(targ);
5469 (void)SvUPGRADE(namesv, SVt_PV);
5471 sv_setpvn(namesv, "$", 1);
5472 sv_catpvn(namesv, name, len);
5475 kid->op_sibling = 0;
5476 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5477 kid->op_targ = targ;
5478 kid->op_private |= priv;
5480 kid->op_sibling = sibl;
5486 mod(scalar(kid), type);
5490 tokid = &kid->op_sibling;
5491 kid = kid->op_sibling;
5493 o->op_private |= numargs;
5495 return too_many_arguments(o,OP_DESC(o));
5498 else if (PL_opargs[type] & OA_DEFGV) {
5500 return newUNOP(type, 0, newDEFSVOP());
5504 while (oa & OA_OPTIONAL)
5506 if (oa && oa != OA_LIST)
5507 return too_few_arguments(o,OP_DESC(o));
5513 Perl_ck_glob(pTHX_ OP *o)
5518 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5519 append_elem(OP_GLOB, o, newDEFSVOP());
5521 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5522 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5524 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5527 #if !defined(PERL_EXTERNAL_GLOB)
5528 /* XXX this can be tightened up and made more failsafe. */
5529 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5532 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5533 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5534 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5535 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5536 GvCV(gv) = GvCV(glob_gv);
5537 (void)SvREFCNT_inc((SV*)GvCV(gv));
5538 GvIMPORTED_CV_on(gv);
5541 #endif /* PERL_EXTERNAL_GLOB */
5543 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5544 append_elem(OP_GLOB, o,
5545 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5546 o->op_type = OP_LIST;
5547 o->op_ppaddr = PL_ppaddr[OP_LIST];
5548 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5549 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5550 cLISTOPo->op_first->op_targ = 0;
5551 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5552 append_elem(OP_LIST, o,
5553 scalar(newUNOP(OP_RV2CV, 0,
5554 newGVOP(OP_GV, 0, gv)))));
5555 o = newUNOP(OP_NULL, 0, ck_subr(o));
5556 o->op_targ = OP_GLOB; /* hint at what it used to be */
5559 gv = newGVgen("main");
5561 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5567 Perl_ck_grep(pTHX_ OP *o)
5571 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5574 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5575 NewOp(1101, gwop, 1, LOGOP);
5577 if (o->op_flags & OPf_STACKED) {
5580 kid = cLISTOPo->op_first->op_sibling;
5581 if (!cUNOPx(kid)->op_next)
5582 Perl_croak(aTHX_ "panic: ck_grep");
5583 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
5586 kid->op_next = (OP*)gwop;
5587 o->op_flags &= ~OPf_STACKED;
5589 kid = cLISTOPo->op_first->op_sibling;
5590 if (type == OP_MAPWHILE)
5597 kid = cLISTOPo->op_first->op_sibling;
5598 if (kid->op_type != OP_NULL)
5599 Perl_croak(aTHX_ "panic: ck_grep");
5600 kid = kUNOP->op_first;
5602 gwop->op_type = type;
5603 gwop->op_ppaddr = PL_ppaddr[type];
5604 gwop->op_first = listkids(o);
5605 gwop->op_flags |= OPf_KIDS;
5606 gwop->op_other = LINKLIST(kid);
5607 kid->op_next = (OP*)gwop;
5608 offset = pad_findmy("$_");
5609 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
5610 o->op_private = gwop->op_private = 0;
5611 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5614 o->op_private = gwop->op_private = OPpGREP_LEX;
5615 gwop->op_targ = o->op_targ = offset;
5618 kid = cLISTOPo->op_first->op_sibling;
5619 if (!kid || !kid->op_sibling)
5620 return too_few_arguments(o,OP_DESC(o));
5621 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5622 mod(kid, OP_GREPSTART);
5628 Perl_ck_index(pTHX_ OP *o)
5630 if (o->op_flags & OPf_KIDS) {
5631 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5633 kid = kid->op_sibling; /* get past "big" */
5634 if (kid && kid->op_type == OP_CONST)
5635 fbm_compile(((SVOP*)kid)->op_sv, 0);
5641 Perl_ck_lengthconst(pTHX_ OP *o)
5643 /* XXX length optimization goes here */
5648 Perl_ck_lfun(pTHX_ OP *o)
5650 const OPCODE type = o->op_type;
5651 return modkids(ck_fun(o), type);
5655 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5657 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5658 switch (cUNOPo->op_first->op_type) {
5660 /* This is needed for
5661 if (defined %stash::)
5662 to work. Do not break Tk.
5664 break; /* Globals via GV can be undef */
5666 case OP_AASSIGN: /* Is this a good idea? */
5667 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5668 "defined(@array) is deprecated");
5669 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5670 "\t(Maybe you should just omit the defined()?)\n");
5673 /* This is needed for
5674 if (defined %stash::)
5675 to work. Do not break Tk.
5677 break; /* Globals via GV can be undef */
5679 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5680 "defined(%%hash) is deprecated");
5681 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5682 "\t(Maybe you should just omit the defined()?)\n");
5693 Perl_ck_rfun(pTHX_ OP *o)
5695 const OPCODE type = o->op_type;
5696 return refkids(ck_fun(o), type);
5700 Perl_ck_listiob(pTHX_ OP *o)
5704 kid = cLISTOPo->op_first;
5707 kid = cLISTOPo->op_first;
5709 if (kid->op_type == OP_PUSHMARK)
5710 kid = kid->op_sibling;
5711 if (kid && o->op_flags & OPf_STACKED)
5712 kid = kid->op_sibling;
5713 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5714 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5715 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5716 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5717 cLISTOPo->op_first->op_sibling = kid;
5718 cLISTOPo->op_last = kid;
5719 kid = kid->op_sibling;
5724 append_elem(o->op_type, o, newDEFSVOP());
5730 Perl_ck_sassign(pTHX_ OP *o)
5732 OP *kid = cLISTOPo->op_first;
5733 /* has a disposable target? */
5734 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5735 && !(kid->op_flags & OPf_STACKED)
5736 /* Cannot steal the second time! */
5737 && !(kid->op_private & OPpTARGET_MY))
5739 OP *kkid = kid->op_sibling;
5741 /* Can just relocate the target. */
5742 if (kkid && kkid->op_type == OP_PADSV
5743 && !(kkid->op_private & OPpLVAL_INTRO))
5745 kid->op_targ = kkid->op_targ;
5747 /* Now we do not need PADSV and SASSIGN. */
5748 kid->op_sibling = o->op_sibling; /* NULL */
5749 cLISTOPo->op_first = NULL;
5752 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
5756 /* optimise C<my $x = undef> to C<my $x> */
5757 if (kid->op_type == OP_UNDEF) {
5758 OP *kkid = kid->op_sibling;
5759 if (kkid && kkid->op_type == OP_PADSV
5760 && (kkid->op_private & OPpLVAL_INTRO))
5762 cLISTOPo->op_first = NULL;
5763 kid->op_sibling = NULL;
5773 Perl_ck_match(pTHX_ OP *o)
5775 if (o->op_type != OP_QR) {
5776 const I32 offset = pad_findmy("$_");
5777 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS(offset) & SVpad_OUR)) {
5778 o->op_targ = offset;
5779 o->op_private |= OPpTARGET_MY;
5782 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
5783 o->op_private |= OPpRUNTIME;
5788 Perl_ck_method(pTHX_ OP *o)
5790 OP *kid = cUNOPo->op_first;
5791 if (kid->op_type == OP_CONST) {
5792 SV* sv = kSVOP->op_sv;
5793 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
5795 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5796 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
5799 kSVOP->op_sv = Nullsv;
5801 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5810 Perl_ck_null(pTHX_ OP *o)
5816 Perl_ck_open(pTHX_ OP *o)
5818 HV *table = GvHV(PL_hintgv);
5822 svp = hv_fetch(table, "open_IN", 7, FALSE);
5824 mode = mode_from_discipline(*svp);
5825 if (mode & O_BINARY)
5826 o->op_private |= OPpOPEN_IN_RAW;
5827 else if (mode & O_TEXT)
5828 o->op_private |= OPpOPEN_IN_CRLF;
5831 svp = hv_fetch(table, "open_OUT", 8, FALSE);
5833 mode = mode_from_discipline(*svp);
5834 if (mode & O_BINARY)
5835 o->op_private |= OPpOPEN_OUT_RAW;
5836 else if (mode & O_TEXT)
5837 o->op_private |= OPpOPEN_OUT_CRLF;
5840 if (o->op_type == OP_BACKTICK)
5843 /* In case of three-arg dup open remove strictness
5844 * from the last arg if it is a bareword. */
5845 OP *first = cLISTOPx(o)->op_first; /* The pushmark. */
5846 OP *last = cLISTOPx(o)->op_last; /* The bareword. */
5850 if ((last->op_type == OP_CONST) && /* The bareword. */
5851 (last->op_private & OPpCONST_BARE) &&
5852 (last->op_private & OPpCONST_STRICT) &&
5853 (oa = first->op_sibling) && /* The fh. */
5854 (oa = oa->op_sibling) && /* The mode. */
5855 SvPOK(((SVOP*)oa)->op_sv) &&
5856 (mode = SvPVX(((SVOP*)oa)->op_sv)) &&
5857 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
5858 (last == oa->op_sibling)) /* The bareword. */
5859 last->op_private &= ~OPpCONST_STRICT;
5865 Perl_ck_repeat(pTHX_ OP *o)
5867 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5868 o->op_private |= OPpREPEAT_DOLIST;
5869 cBINOPo->op_first = force_list(cBINOPo->op_first);
5877 Perl_ck_require(pTHX_ OP *o)
5881 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
5882 SVOP *kid = (SVOP*)cUNOPo->op_first;
5884 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5886 for (s = SvPVX(kid->op_sv); *s; s++) {
5887 if (*s == ':' && s[1] == ':') {
5889 Move(s+2, s+1, strlen(s+2)+1, char);
5890 SvCUR_set(kid->op_sv, SvCUR(kid->op_sv) - 1);
5893 if (SvREADONLY(kid->op_sv)) {
5894 SvREADONLY_off(kid->op_sv);
5895 sv_catpvn(kid->op_sv, ".pm", 3);
5896 SvREADONLY_on(kid->op_sv);
5899 sv_catpvn(kid->op_sv, ".pm", 3);
5903 /* handle override, if any */
5904 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
5905 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
5906 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
5908 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5909 OP *kid = cUNOPo->op_first;
5910 cUNOPo->op_first = 0;
5912 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5913 append_elem(OP_LIST, kid,
5914 scalar(newUNOP(OP_RV2CV, 0,
5923 Perl_ck_return(pTHX_ OP *o)
5925 if (CvLVALUE(PL_compcv)) {
5927 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5928 mod(kid, OP_LEAVESUBLV);
5935 Perl_ck_retarget(pTHX_ OP *o)
5937 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5944 Perl_ck_select(pTHX_ OP *o)
5947 if (o->op_flags & OPf_KIDS) {
5948 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5949 if (kid && kid->op_sibling) {
5950 o->op_type = OP_SSELECT;
5951 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
5953 return fold_constants(o);
5957 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5958 if (kid && kid->op_type == OP_RV2GV)
5959 kid->op_private &= ~HINT_STRICT_REFS;
5964 Perl_ck_shift(pTHX_ OP *o)
5966 const I32 type = o->op_type;
5968 if (!(o->op_flags & OPf_KIDS)) {
5972 argop = newUNOP(OP_RV2AV, 0,
5973 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
5974 return newUNOP(type, 0, scalar(argop));
5976 return scalar(modkids(ck_fun(o), type));
5980 Perl_ck_sort(pTHX_ OP *o)
5984 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
5986 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5987 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
5989 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
5991 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
5993 if (kid->op_type == OP_SCOPE) {
5997 else if (kid->op_type == OP_LEAVE) {
5998 if (o->op_type == OP_SORT) {
5999 op_null(kid); /* wipe out leave */
6002 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6003 if (k->op_next == kid)
6005 /* don't descend into loops */
6006 else if (k->op_type == OP_ENTERLOOP
6007 || k->op_type == OP_ENTERITER)
6009 k = cLOOPx(k)->op_lastop;
6014 kid->op_next = 0; /* just disconnect the leave */
6015 k = kLISTOP->op_first;
6020 if (o->op_type == OP_SORT) {
6021 /* provide scalar context for comparison function/block */
6027 o->op_flags |= OPf_SPECIAL;
6029 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6032 firstkid = firstkid->op_sibling;
6035 /* provide list context for arguments */
6036 if (o->op_type == OP_SORT)
6043 S_simplify_sort(pTHX_ OP *o)
6045 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6050 if (!(o->op_flags & OPf_STACKED))
6052 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6053 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6054 kid = kUNOP->op_first; /* get past null */
6055 if (kid->op_type != OP_SCOPE)
6057 kid = kLISTOP->op_last; /* get past scope */
6058 switch(kid->op_type) {
6066 k = kid; /* remember this node*/
6067 if (kBINOP->op_first->op_type != OP_RV2SV)
6069 kid = kBINOP->op_first; /* get past cmp */
6070 if (kUNOP->op_first->op_type != OP_GV)
6072 kid = kUNOP->op_first; /* get past rv2sv */
6074 if (GvSTASH(gv) != PL_curstash)
6076 gvname = GvNAME(gv);
6077 if (*gvname == 'a' && gvname[1] == '\0')
6079 else if (*gvname == 'b' && gvname[1] == '\0')
6084 kid = k; /* back to cmp */
6085 if (kBINOP->op_last->op_type != OP_RV2SV)
6087 kid = kBINOP->op_last; /* down to 2nd arg */
6088 if (kUNOP->op_first->op_type != OP_GV)
6090 kid = kUNOP->op_first; /* get past rv2sv */
6092 if (GvSTASH(gv) != PL_curstash)
6094 gvname = GvNAME(gv);
6096 ? !(*gvname == 'a' && gvname[1] == '\0')
6097 : !(*gvname == 'b' && gvname[1] == '\0'))
6099 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6101 o->op_private |= OPpSORT_DESCEND;
6102 if (k->op_type == OP_NCMP)
6103 o->op_private |= OPpSORT_NUMERIC;
6104 if (k->op_type == OP_I_NCMP)
6105 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6106 kid = cLISTOPo->op_first->op_sibling;
6107 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6108 op_free(kid); /* then delete it */
6112 Perl_ck_split(pTHX_ OP *o)
6116 if (o->op_flags & OPf_STACKED)
6117 return no_fh_allowed(o);
6119 kid = cLISTOPo->op_first;
6120 if (kid->op_type != OP_NULL)
6121 Perl_croak(aTHX_ "panic: ck_split");
6122 kid = kid->op_sibling;
6123 op_free(cLISTOPo->op_first);
6124 cLISTOPo->op_first = kid;
6126 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6127 cLISTOPo->op_last = kid; /* There was only one element previously */
6130 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6131 OP *sibl = kid->op_sibling;
6132 kid->op_sibling = 0;
6133 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
6134 if (cLISTOPo->op_first == cLISTOPo->op_last)
6135 cLISTOPo->op_last = kid;
6136 cLISTOPo->op_first = kid;
6137 kid->op_sibling = sibl;
6140 kid->op_type = OP_PUSHRE;
6141 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6143 if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
6144 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
6145 "Use of /g modifier is meaningless in split");
6148 if (!kid->op_sibling)
6149 append_elem(OP_SPLIT, o, newDEFSVOP());
6151 kid = kid->op_sibling;
6154 if (!kid->op_sibling)
6155 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6157 kid = kid->op_sibling;
6160 if (kid->op_sibling)
6161 return too_many_arguments(o,OP_DESC(o));
6167 Perl_ck_join(pTHX_ OP *o)
6169 if (ckWARN(WARN_SYNTAX)) {
6170 const OP *kid = cLISTOPo->op_first->op_sibling;
6171 if (kid && kid->op_type == OP_MATCH) {
6172 const REGEXP *re = PM_GETRE(kPMOP);
6173 const char *pmstr = re ? re->precomp : "STRING";
6174 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6175 "/%s/ should probably be written as \"%s\"",
6183 Perl_ck_subr(pTHX_ OP *o)
6185 OP *prev = ((cUNOPo->op_first->op_sibling)
6186 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6187 OP *o2 = prev->op_sibling;
6194 I32 contextclass = 0;
6199 o->op_private |= OPpENTERSUB_HASTARG;
6200 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6201 if (cvop->op_type == OP_RV2CV) {
6203 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6204 op_null(cvop); /* disable rv2cv */
6205 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6206 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6207 GV *gv = cGVOPx_gv(tmpop);
6210 tmpop->op_private |= OPpEARLY_CV;
6213 namegv = CvANON(cv) ? gv : CvGV(cv);
6214 proto = SvPV((SV*)cv, n_a);
6216 if (CvASSERTION(cv)) {
6217 if (PL_hints & HINT_ASSERTING) {
6218 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
6219 o->op_private |= OPpENTERSUB_DB;
6223 if (ckWARN(WARN_ASSERTIONS) && !(PL_hints & HINT_ASSERTIONSSEEN)) {
6224 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
6225 "Impossible to activate assertion call");
6232 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6233 if (o2->op_type == OP_CONST)
6234 o2->op_private &= ~OPpCONST_STRICT;
6235 else if (o2->op_type == OP_LIST) {
6236 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6237 if (o && o->op_type == OP_CONST)
6238 o->op_private &= ~OPpCONST_STRICT;
6241 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6242 if (PERLDB_SUB && PL_curstash != PL_debstash)
6243 o->op_private |= OPpENTERSUB_DB;
6244 while (o2 != cvop) {
6248 return too_many_arguments(o, gv_ename(namegv));
6266 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6268 arg == 1 ? "block or sub {}" : "sub {}",
6269 gv_ename(namegv), o2);
6272 /* '*' allows any scalar type, including bareword */
6275 if (o2->op_type == OP_RV2GV)
6276 goto wrapref; /* autoconvert GLOB -> GLOBref */
6277 else if (o2->op_type == OP_CONST)
6278 o2->op_private &= ~OPpCONST_STRICT;
6279 else if (o2->op_type == OP_ENTERSUB) {
6280 /* accidental subroutine, revert to bareword */
6281 OP *gvop = ((UNOP*)o2)->op_first;
6282 if (gvop && gvop->op_type == OP_NULL) {
6283 gvop = ((UNOP*)gvop)->op_first;
6285 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6288 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6289 (gvop = ((UNOP*)gvop)->op_first) &&
6290 gvop->op_type == OP_GV)
6292 GV *gv = cGVOPx_gv(gvop);
6293 OP *sibling = o2->op_sibling;
6294 SV *n = newSVpvn("",0);
6296 gv_fullname4(n, gv, "", FALSE);
6297 o2 = newSVOP(OP_CONST, 0, n);
6298 prev->op_sibling = o2;
6299 o2->op_sibling = sibling;
6315 if (contextclass++ == 0) {
6316 e = strchr(proto, ']');
6317 if (!e || e == proto)
6330 while (*--p != '[');
6331 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6332 gv_ename(namegv), o2);
6338 if (o2->op_type == OP_RV2GV)
6341 bad_type(arg, "symbol", gv_ename(namegv), o2);
6344 if (o2->op_type == OP_ENTERSUB)
6347 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6350 if (o2->op_type == OP_RV2SV ||
6351 o2->op_type == OP_PADSV ||
6352 o2->op_type == OP_HELEM ||
6353 o2->op_type == OP_AELEM ||
6354 o2->op_type == OP_THREADSV)
6357 bad_type(arg, "scalar", gv_ename(namegv), o2);
6360 if (o2->op_type == OP_RV2AV ||
6361 o2->op_type == OP_PADAV)
6364 bad_type(arg, "array", gv_ename(namegv), o2);
6367 if (o2->op_type == OP_RV2HV ||
6368 o2->op_type == OP_PADHV)
6371 bad_type(arg, "hash", gv_ename(namegv), o2);
6376 OP* sib = kid->op_sibling;
6377 kid->op_sibling = 0;
6378 o2 = newUNOP(OP_REFGEN, 0, kid);
6379 o2->op_sibling = sib;
6380 prev->op_sibling = o2;
6382 if (contextclass && e) {
6397 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6398 gv_ename(namegv), cv);
6403 mod(o2, OP_ENTERSUB);
6405 o2 = o2->op_sibling;
6407 if (proto && !optional &&
6408 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6409 return too_few_arguments(o, gv_ename(namegv));
6412 o=newSVOP(OP_CONST, 0, newSViv(0));
6418 Perl_ck_svconst(pTHX_ OP *o)
6420 SvREADONLY_on(cSVOPo->op_sv);
6425 Perl_ck_trunc(pTHX_ OP *o)
6427 if (o->op_flags & OPf_KIDS) {
6428 SVOP *kid = (SVOP*)cUNOPo->op_first;
6430 if (kid->op_type == OP_NULL)
6431 kid = (SVOP*)kid->op_sibling;
6432 if (kid && kid->op_type == OP_CONST &&
6433 (kid->op_private & OPpCONST_BARE))
6435 o->op_flags |= OPf_SPECIAL;
6436 kid->op_private &= ~OPpCONST_STRICT;
6443 Perl_ck_unpack(pTHX_ OP *o)
6445 OP *kid = cLISTOPo->op_first;
6446 if (kid->op_sibling) {
6447 kid = kid->op_sibling;
6448 if (!kid->op_sibling)
6449 kid->op_sibling = newDEFSVOP();
6455 Perl_ck_substr(pTHX_ OP *o)
6458 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6459 OP *kid = cLISTOPo->op_first;
6461 if (kid->op_type == OP_NULL)
6462 kid = kid->op_sibling;
6464 kid->op_flags |= OPf_MOD;
6470 /* A peephole optimizer. We visit the ops in the order they're to execute.
6471 * See the comments at the top of this file for more details about when
6472 * peep() is called */
6475 Perl_peep(pTHX_ register OP *o)
6477 register OP* oldop = 0;
6479 if (!o || o->op_opt)
6483 SAVEVPTR(PL_curcop);
6484 for (; o; o = o->op_next) {
6488 switch (o->op_type) {
6492 PL_curcop = ((COP*)o); /* for warnings */
6497 if (cSVOPo->op_private & OPpCONST_STRICT)
6498 no_bareword_allowed(o);
6500 case OP_METHOD_NAMED:
6501 /* Relocate sv to the pad for thread safety.
6502 * Despite being a "constant", the SV is written to,
6503 * for reference counts, sv_upgrade() etc. */
6505 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6506 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6507 /* If op_sv is already a PADTMP then it is being used by
6508 * some pad, so make a copy. */
6509 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6510 SvREADONLY_on(PAD_SVl(ix));
6511 SvREFCNT_dec(cSVOPo->op_sv);
6514 SvREFCNT_dec(PAD_SVl(ix));
6515 SvPADTMP_on(cSVOPo->op_sv);
6516 PAD_SETSV(ix, cSVOPo->op_sv);
6517 /* XXX I don't know how this isn't readonly already. */
6518 SvREADONLY_on(PAD_SVl(ix));
6520 cSVOPo->op_sv = Nullsv;
6528 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6529 if (o->op_next->op_private & OPpTARGET_MY) {
6530 if (o->op_flags & OPf_STACKED) /* chained concats */
6531 goto ignore_optimization;
6533 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6534 o->op_targ = o->op_next->op_targ;
6535 o->op_next->op_targ = 0;
6536 o->op_private |= OPpTARGET_MY;
6539 op_null(o->op_next);
6541 ignore_optimization:
6545 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6547 break; /* Scalar stub must produce undef. List stub is noop */
6551 if (o->op_targ == OP_NEXTSTATE
6552 || o->op_targ == OP_DBSTATE
6553 || o->op_targ == OP_SETSTATE)
6555 PL_curcop = ((COP*)o);
6557 /* XXX: We avoid setting op_seq here to prevent later calls
6558 to peep() from mistakenly concluding that optimisation
6559 has already occurred. This doesn't fix the real problem,
6560 though (See 20010220.007). AMS 20010719 */
6561 /* op_seq functionality is now replaced by op_opt */
6562 if (oldop && o->op_next) {
6563 oldop->op_next = o->op_next;
6571 if (oldop && o->op_next) {
6572 oldop->op_next = o->op_next;
6580 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
6581 OP* pop = (o->op_type == OP_PADAV) ?
6582 o->op_next : o->op_next->op_next;
6584 if (pop && pop->op_type == OP_CONST &&
6585 ((PL_op = pop->op_next)) &&
6586 pop->op_next->op_type == OP_AELEM &&
6587 !(pop->op_next->op_private &
6588 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6589 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6594 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
6595 no_bareword_allowed(pop);
6596 if (o->op_type == OP_GV)
6597 op_null(o->op_next);
6598 op_null(pop->op_next);
6600 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6601 o->op_next = pop->op_next->op_next;
6602 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6603 o->op_private = (U8)i;
6604 if (o->op_type == OP_GV) {
6609 o->op_flags |= OPf_SPECIAL;
6610 o->op_type = OP_AELEMFAST;
6616 if (o->op_next->op_type == OP_RV2SV) {
6617 if (!(o->op_next->op_private & OPpDEREF)) {
6618 op_null(o->op_next);
6619 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6621 o->op_next = o->op_next->op_next;
6622 o->op_type = OP_GVSV;
6623 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6626 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6628 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6629 /* XXX could check prototype here instead of just carping */
6630 SV *sv = sv_newmortal();
6631 gv_efullname3(sv, gv, Nullch);
6632 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6633 "%"SVf"() called too early to check prototype",
6637 else if (o->op_next->op_type == OP_READLINE
6638 && o->op_next->op_next->op_type == OP_CONCAT
6639 && (o->op_next->op_next->op_flags & OPf_STACKED))
6641 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6642 o->op_type = OP_RCATLINE;
6643 o->op_flags |= OPf_STACKED;
6644 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6645 op_null(o->op_next->op_next);
6646 op_null(o->op_next);
6663 while (cLOGOP->op_other->op_type == OP_NULL)
6664 cLOGOP->op_other = cLOGOP->op_other->op_next;
6665 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6671 while (cLOOP->op_redoop->op_type == OP_NULL)
6672 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6673 peep(cLOOP->op_redoop);
6674 while (cLOOP->op_nextop->op_type == OP_NULL)
6675 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6676 peep(cLOOP->op_nextop);
6677 while (cLOOP->op_lastop->op_type == OP_NULL)
6678 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6679 peep(cLOOP->op_lastop);
6686 while (cPMOP->op_pmreplstart &&
6687 cPMOP->op_pmreplstart->op_type == OP_NULL)
6688 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6689 peep(cPMOP->op_pmreplstart);
6694 if (ckWARN(WARN_SYNTAX) && o->op_next
6695 && o->op_next->op_type == OP_NEXTSTATE) {
6696 if (o->op_next->op_sibling &&
6697 o->op_next->op_sibling->op_type != OP_EXIT &&
6698 o->op_next->op_sibling->op_type != OP_WARN &&
6699 o->op_next->op_sibling->op_type != OP_DIE) {
6700 const line_t oldline = CopLINE(PL_curcop);
6702 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6703 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6704 "Statement unlikely to be reached");
6705 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6706 "\t(Maybe you meant system() when you said exec()?)\n");
6707 CopLINE_set(PL_curcop, oldline);
6722 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6725 /* Make the CONST have a shared SV */
6726 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6727 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6728 key = SvPV(sv, keylen);
6729 lexname = newSVpvn_share(key,
6730 SvUTF8(sv) ? -(I32)keylen : keylen,
6736 if ((o->op_private & (OPpLVAL_INTRO)))
6739 rop = (UNOP*)((BINOP*)o)->op_first;
6740 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6742 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6743 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6745 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6746 if (!fields || !GvHV(*fields))
6748 key = SvPV(*svp, keylen);
6749 if (!hv_fetch(GvHV(*fields), key,
6750 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
6752 Perl_croak(aTHX_ "No such class field \"%s\" "
6753 "in variable %s of type %s",
6754 key, SvPV_nolen(lexname), HvNAME(SvSTASH(lexname)));
6767 SVOP *first_key_op, *key_op;
6769 if ((o->op_private & (OPpLVAL_INTRO))
6770 /* I bet there's always a pushmark... */
6771 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6772 /* hmmm, no optimization if list contains only one key. */
6774 rop = (UNOP*)((LISTOP*)o)->op_last;
6775 if (rop->op_type != OP_RV2HV)
6777 if (rop->op_first->op_type == OP_PADSV)
6778 /* @$hash{qw(keys here)} */
6779 rop = (UNOP*)rop->op_first;
6781 /* @{$hash}{qw(keys here)} */
6782 if (rop->op_first->op_type == OP_SCOPE
6783 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
6785 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
6791 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
6792 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6794 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6795 if (!fields || !GvHV(*fields))
6797 /* Again guessing that the pushmark can be jumped over.... */
6798 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
6799 ->op_first->op_sibling;
6800 for (key_op = first_key_op; key_op;
6801 key_op = (SVOP*)key_op->op_sibling) {
6802 if (key_op->op_type != OP_CONST)
6804 svp = cSVOPx_svp(key_op);
6805 key = SvPV(*svp, keylen);
6806 if (!hv_fetch(GvHV(*fields), key,
6807 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
6809 Perl_croak(aTHX_ "No such class field \"%s\" "
6810 "in variable %s of type %s",
6811 key, SvPV_nolen(lexname), HvNAME(SvSTASH(lexname)));
6818 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
6822 /* check that RHS of sort is a single plain array */
6823 oright = cUNOPo->op_first;
6824 if (!oright || oright->op_type != OP_PUSHMARK)
6827 /* reverse sort ... can be optimised. */
6828 if (!cUNOPo->op_sibling) {
6829 /* Nothing follows us on the list. */
6830 OP *reverse = o->op_next;
6832 if (reverse->op_type == OP_REVERSE &&
6833 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
6834 OP *pushmark = cUNOPx(reverse)->op_first;
6835 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
6836 && (cUNOPx(pushmark)->op_sibling == o)) {
6837 /* reverse -> pushmark -> sort */
6838 o->op_private |= OPpSORT_REVERSE;
6840 pushmark->op_next = oright->op_next;
6846 /* make @a = sort @a act in-place */
6850 oright = cUNOPx(oright)->op_sibling;
6853 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
6854 oright = cUNOPx(oright)->op_sibling;
6858 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
6859 || oright->op_next != o
6860 || (oright->op_private & OPpLVAL_INTRO)
6864 /* o2 follows the chain of op_nexts through the LHS of the
6865 * assign (if any) to the aassign op itself */
6867 if (!o2 || o2->op_type != OP_NULL)
6870 if (!o2 || o2->op_type != OP_PUSHMARK)
6873 if (o2 && o2->op_type == OP_GV)
6876 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
6877 || (o2->op_private & OPpLVAL_INTRO)
6882 if (!o2 || o2->op_type != OP_NULL)
6885 if (!o2 || o2->op_type != OP_AASSIGN
6886 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
6889 /* check that the sort is the first arg on RHS of assign */
6891 o2 = cUNOPx(o2)->op_first;
6892 if (!o2 || o2->op_type != OP_NULL)
6894 o2 = cUNOPx(o2)->op_first;
6895 if (!o2 || o2->op_type != OP_PUSHMARK)
6897 if (o2->op_sibling != o)
6900 /* check the array is the same on both sides */
6901 if (oleft->op_type == OP_RV2AV) {
6902 if (oright->op_type != OP_RV2AV
6903 || !cUNOPx(oright)->op_first
6904 || cUNOPx(oright)->op_first->op_type != OP_GV
6905 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
6906 cGVOPx_gv(cUNOPx(oright)->op_first)
6910 else if (oright->op_type != OP_PADAV
6911 || oright->op_targ != oleft->op_targ
6915 /* transfer MODishness etc from LHS arg to RHS arg */
6916 oright->op_flags = oleft->op_flags;
6917 o->op_private |= OPpSORT_INPLACE;
6919 /* excise push->gv->rv2av->null->aassign */
6920 o2 = o->op_next->op_next;
6921 op_null(o2); /* PUSHMARK */
6923 if (o2->op_type == OP_GV) {
6924 op_null(o2); /* GV */
6927 op_null(o2); /* RV2AV or PADAV */
6928 o2 = o2->op_next->op_next;
6929 op_null(o2); /* AASSIGN */
6931 o->op_next = o2->op_next;
6937 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
6939 LISTOP *enter, *exlist;
6942 enter = (LISTOP *) o->op_next;
6945 if (enter->op_type == OP_NULL) {
6946 enter = (LISTOP *) enter->op_next;
6950 /* for $a (...) will have OP_GV then OP_RV2GV here.
6951 for (...) just has an OP_GV. */
6952 if (enter->op_type == OP_GV) {
6953 gvop = (OP *) enter;
6954 enter = (LISTOP *) enter->op_next;
6957 if (enter->op_type == OP_RV2GV) {
6958 enter = (LISTOP *) enter->op_next;
6964 if (enter->op_type != OP_ENTERITER)
6967 iter = enter->op_next;
6968 if (!iter || iter->op_type != OP_ITER)
6971 expushmark = enter->op_first;
6972 if (!expushmark || expushmark->op_type != OP_NULL
6973 || expushmark->op_targ != OP_PUSHMARK)
6976 exlist = (LISTOP *) expushmark->op_sibling;
6977 if (!exlist || exlist->op_type != OP_NULL
6978 || exlist->op_targ != OP_LIST)
6981 if (exlist->op_last != o) {
6982 /* Mmm. Was expecting to point back to this op. */
6985 theirmark = exlist->op_first;
6986 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
6989 if (theirmark->op_sibling != o) {
6990 /* There's something between the mark and the reverse, eg
6991 for (1, reverse (...))
6996 ourmark = ((LISTOP *)o)->op_first;
6997 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
7000 ourlast = ((LISTOP *)o)->op_last;
7001 if (!ourlast || ourlast->op_next != o)
7004 rv2av = ourmark->op_sibling;
7005 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
7006 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
7007 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
7008 /* We're just reversing a single array. */
7009 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
7010 enter->op_flags |= OPf_STACKED;
7013 /* We don't have control over who points to theirmark, so sacrifice
7015 theirmark->op_next = ourmark->op_next;
7016 theirmark->op_flags = ourmark->op_flags;
7017 ourlast->op_next = gvop ? gvop : (OP *) enter;
7020 enter->op_private |= OPpITER_REVERSED;
7021 iter->op_private |= OPpITER_REVERSED;
7036 Perl_custom_op_name(pTHX_ const OP* o)
7038 const IV index = PTR2IV(o->op_ppaddr);
7042 if (!PL_custom_op_names) /* This probably shouldn't happen */
7043 return PL_op_name[OP_CUSTOM];
7045 keysv = sv_2mortal(newSViv(index));
7047 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7049 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7051 return SvPV_nolen(HeVAL(he));
7055 Perl_custom_op_desc(pTHX_ const OP* o)
7057 const IV index = PTR2IV(o->op_ppaddr);
7061 if (!PL_custom_op_descs)
7062 return PL_op_desc[OP_CUSTOM];
7064 keysv = sv_2mortal(newSViv(index));
7066 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7068 return PL_op_desc[OP_CUSTOM];
7070 return SvPV_nolen(HeVAL(he));
7075 /* Efficient sub that returns a constant scalar value. */
7077 const_sv_xsub(pTHX_ CV* cv)
7082 Perl_croak(aTHX_ "usage: %s::%s()",
7083 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7087 ST(0) = (SV*)XSANY.any_ptr;
7093 * c-indentation-style: bsd
7095 * indent-tabs-mode: t
7098 * vim: shiftwidth=4: