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 * const * const ptr = (I32 **) op;
132 I32 * const slab = ptr[-1];
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)
164 SV* const tmpsv = sv_newmortal();
165 gv_efullname3(tmpsv, gv, Nullch);
166 return SvPV_nolen_const(tmpsv);
170 S_no_fh_allowed(pTHX_ OP *o)
172 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
178 S_too_few_arguments(pTHX_ OP *o, const char *name)
180 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
185 S_too_many_arguments(pTHX_ OP *o, const char *name)
187 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
192 S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
194 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
195 (int)n, name, t, OP_DESC(kid)));
199 S_no_bareword_allowed(pTHX_ const OP *o)
201 qerror(Perl_mess(aTHX_
202 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
206 /* "register" allocation */
209 Perl_allocmy(pTHX_ char *name)
213 /* complain about "my $<special_var>" etc etc */
215 !(PL_in_my == KEY_our ||
217 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
218 (name[1] == '_' && (*name == '$' || name[2]))))
220 /* name[2] is true if strlen(name) > 2 */
221 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
222 /* 1999-02-27 mjd@plover.com */
224 p = strchr(name, '\0');
225 /* The next block assumes the buffer is at least 205 chars
226 long. At present, it's always at least 256 chars. */
228 strcpy(name+200, "...");
234 /* Move everything else down one character */
235 for (; p-name > 2; p--)
237 name[2] = toCTRL(name[1]);
240 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
243 /* check for duplicate declaration */
245 (bool)(PL_in_my == KEY_our),
246 (PL_curstash ? PL_curstash : PL_defstash)
249 if (PL_in_my_stash && *name != '$') {
250 yyerror(Perl_form(aTHX_
251 "Can't declare class for non-scalar %s in \"%s\"",
252 name, PL_in_my == KEY_our ? "our" : "my"));
255 /* allocate a spare slot and store the name in that slot */
257 off = pad_add_name(name,
260 /* $_ is always in main::, even with our */
261 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
272 Perl_op_free(pTHX_ OP *o)
278 if (!o || o->op_static)
281 if (o->op_private & OPpREFCOUNTED) {
282 switch (o->op_type) {
290 refcnt = OpREFCNT_dec(o);
300 if (o->op_flags & OPf_KIDS) {
301 register OP *kid, *nextkid;
302 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
303 nextkid = kid->op_sibling; /* Get before next freeing kid */
309 type = (OPCODE)o->op_targ;
311 /* COP* is not cleared by op_clear() so that we may track line
312 * numbers etc even after null() */
313 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
318 #ifdef DEBUG_LEAKING_SCALARS
325 Perl_op_clear(pTHX_ OP *o)
329 switch (o->op_type) {
330 case OP_NULL: /* Was holding old type, if any. */
331 case OP_ENTEREVAL: /* Was holding hints. */
335 if (!(o->op_flags & OPf_REF)
336 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
342 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
343 /* not an OP_PADAV replacement */
345 if (cPADOPo->op_padix > 0) {
346 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
347 * may still exist on the pad */
348 pad_swipe(cPADOPo->op_padix, TRUE);
349 cPADOPo->op_padix = 0;
352 SvREFCNT_dec(cSVOPo->op_sv);
353 cSVOPo->op_sv = Nullsv;
357 case OP_METHOD_NAMED:
359 SvREFCNT_dec(cSVOPo->op_sv);
360 cSVOPo->op_sv = Nullsv;
363 Even if op_clear does a pad_free for the target of the op,
364 pad_free doesn't actually remove the sv that exists in the pad;
365 instead it lives on. This results in that it could be reused as
366 a target later on when the pad was reallocated.
369 pad_swipe(o->op_targ,1);
378 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
382 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
383 SvREFCNT_dec(cSVOPo->op_sv);
384 cSVOPo->op_sv = Nullsv;
387 Safefree(cPVOPo->op_pv);
388 cPVOPo->op_pv = Nullch;
392 op_free(cPMOPo->op_pmreplroot);
396 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
397 /* No GvIN_PAD_off here, because other references may still
398 * exist on the pad */
399 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
402 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
409 HV * const pmstash = PmopSTASH(cPMOPo);
410 if (pmstash && !SvIS_FREED(pmstash)) {
411 MAGIC * const mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab);
413 PMOP *pmop = (PMOP*) mg->mg_obj;
414 PMOP *lastpmop = NULL;
416 if (cPMOPo == pmop) {
418 lastpmop->op_pmnext = pmop->op_pmnext;
420 mg->mg_obj = (SV*) pmop->op_pmnext;
424 pmop = pmop->op_pmnext;
428 PmopSTASH_free(cPMOPo);
430 cPMOPo->op_pmreplroot = Nullop;
431 /* we use the "SAFE" version of the PM_ macros here
432 * since sv_clean_all might release some PMOPs
433 * after PL_regex_padav has been cleared
434 * and the clearing of PL_regex_padav needs to
435 * happen before sv_clean_all
437 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
438 PM_SETRE_SAFE(cPMOPo, (REGEXP*)NULL);
440 if(PL_regex_pad) { /* We could be in destruction */
441 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
442 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
443 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
450 if (o->op_targ > 0) {
451 pad_free(o->op_targ);
457 S_cop_free(pTHX_ COP* cop)
459 Safefree(cop->cop_label); /* FIXME: treaddead ??? */
462 if (! specialWARN(cop->cop_warnings))
463 SvREFCNT_dec(cop->cop_warnings);
464 if (! specialCopIO(cop->cop_io)) {
468 char *s = SvPV(cop->cop_io,len);
469 Perl_warn(aTHX_ "io='%.*s'",(int) len,s); /* ??? --jhi */
472 SvREFCNT_dec(cop->cop_io);
478 Perl_op_null(pTHX_ OP *o)
481 if (o->op_type == OP_NULL)
484 o->op_targ = o->op_type;
485 o->op_type = OP_NULL;
486 o->op_ppaddr = PL_ppaddr[OP_NULL];
490 Perl_op_refcnt_lock(pTHX)
497 Perl_op_refcnt_unlock(pTHX)
503 /* Contextualizers */
505 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
508 Perl_linklist(pTHX_ OP *o)
514 /* establish postfix order */
515 if (cUNOPo->op_first) {
517 o->op_next = LINKLIST(cUNOPo->op_first);
518 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
520 kid->op_next = LINKLIST(kid->op_sibling);
532 Perl_scalarkids(pTHX_ OP *o)
534 if (o && o->op_flags & OPf_KIDS) {
536 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
543 S_scalarboolean(pTHX_ OP *o)
545 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
546 if (ckWARN(WARN_SYNTAX)) {
547 const line_t oldline = CopLINE(PL_curcop);
549 if (PL_copline != NOLINE)
550 CopLINE_set(PL_curcop, PL_copline);
551 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
552 CopLINE_set(PL_curcop, oldline);
559 Perl_scalar(pTHX_ OP *o)
564 /* assumes no premature commitment */
565 if (!o || PL_error_count || (o->op_flags & OPf_WANT)
566 || o->op_type == OP_RETURN)
571 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
573 switch (o->op_type) {
575 scalar(cBINOPo->op_first);
580 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
584 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
585 if (!kPMOP->op_pmreplroot)
586 deprecate_old("implicit split to @_");
594 if (o->op_flags & OPf_KIDS) {
595 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
601 kid = cLISTOPo->op_first;
603 while ((kid = kid->op_sibling)) {
609 WITH_THR(PL_curcop = &PL_compiling);
614 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
620 WITH_THR(PL_curcop = &PL_compiling);
623 if (ckWARN(WARN_VOID))
624 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
630 Perl_scalarvoid(pTHX_ OP *o)
634 const char* useless = NULL;
638 if (o->op_type == OP_NEXTSTATE
639 || o->op_type == OP_SETSTATE
640 || o->op_type == OP_DBSTATE
641 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
642 || o->op_targ == OP_SETSTATE
643 || o->op_targ == OP_DBSTATE)))
644 PL_curcop = (COP*)o; /* for warning below */
646 /* assumes no premature commitment */
647 want = o->op_flags & OPf_WANT;
648 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
649 || o->op_type == OP_RETURN)
654 if ((o->op_private & OPpTARGET_MY)
655 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
657 return scalar(o); /* As if inside SASSIGN */
660 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
662 switch (o->op_type) {
664 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
668 if (o->op_flags & OPf_STACKED)
672 if (o->op_private == 4)
744 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
745 useless = OP_DESC(o);
749 kid = cUNOPo->op_first;
750 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
751 kid->op_type != OP_TRANS) {
754 useless = "negative pattern binding (!~)";
761 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
762 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
763 useless = "a variable";
768 if (cSVOPo->op_private & OPpCONST_STRICT)
769 no_bareword_allowed(o);
771 if (ckWARN(WARN_VOID)) {
772 useless = "a constant";
773 /* don't warn on optimised away booleans, eg
774 * use constant Foo, 5; Foo || print; */
775 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
777 /* the constants 0 and 1 are permitted as they are
778 conventionally used as dummies in constructs like
779 1 while some_condition_with_side_effects; */
780 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
782 else if (SvPOK(sv)) {
783 /* perl4's way of mixing documentation and code
784 (before the invention of POD) was based on a
785 trick to mix nroff and perl code. The trick was
786 built upon these three nroff macros being used in
787 void context. The pink camel has the details in
788 the script wrapman near page 319. */
789 if (strnEQ(SvPVX_const(sv), "di", 2) ||
790 strnEQ(SvPVX_const(sv), "ds", 2) ||
791 strnEQ(SvPVX_const(sv), "ig", 2))
796 op_null(o); /* don't execute or even remember it */
800 o->op_type = OP_PREINC; /* pre-increment is faster */
801 o->op_ppaddr = PL_ppaddr[OP_PREINC];
805 o->op_type = OP_PREDEC; /* pre-decrement is faster */
806 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
810 o->op_type = OP_I_PREINC; /* pre-increment is faster */
811 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
815 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
816 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
825 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
830 if (o->op_flags & OPf_STACKED)
837 if (!(o->op_flags & OPf_KIDS))
848 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
855 /* all requires must return a boolean value */
856 o->op_flags &= ~OPf_WANT;
861 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
862 if (!kPMOP->op_pmreplroot)
863 deprecate_old("implicit split to @_");
867 if (useless && ckWARN(WARN_VOID))
868 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
873 Perl_listkids(pTHX_ OP *o)
875 if (o && o->op_flags & OPf_KIDS) {
877 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
884 Perl_list(pTHX_ OP *o)
889 /* assumes no premature commitment */
890 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
891 || o->op_type == OP_RETURN)
896 if ((o->op_private & OPpTARGET_MY)
897 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
899 return o; /* As if inside SASSIGN */
902 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
904 switch (o->op_type) {
907 list(cBINOPo->op_first);
912 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
920 if (!(o->op_flags & OPf_KIDS))
922 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
923 list(cBINOPo->op_first);
924 return gen_constant_list(o);
931 kid = cLISTOPo->op_first;
933 while ((kid = kid->op_sibling)) {
939 WITH_THR(PL_curcop = &PL_compiling);
943 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
949 WITH_THR(PL_curcop = &PL_compiling);
952 /* all requires must return a boolean value */
953 o->op_flags &= ~OPf_WANT;
960 Perl_scalarseq(pTHX_ OP *o)
963 if (o->op_type == OP_LINESEQ ||
964 o->op_type == OP_SCOPE ||
965 o->op_type == OP_LEAVE ||
966 o->op_type == OP_LEAVETRY)
969 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
970 if (kid->op_sibling) {
974 PL_curcop = &PL_compiling;
976 o->op_flags &= ~OPf_PARENS;
977 if (PL_hints & HINT_BLOCK_SCOPE)
978 o->op_flags |= OPf_PARENS;
981 o = newOP(OP_STUB, 0);
986 S_modkids(pTHX_ OP *o, I32 type)
988 if (o && o->op_flags & OPf_KIDS) {
990 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
996 /* Propagate lvalue ("modifiable") context to an op and its children.
997 * 'type' represents the context type, roughly based on the type of op that
998 * would do the modifying, although local() is represented by OP_NULL.
999 * It's responsible for detecting things that can't be modified, flag
1000 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1001 * might have to vivify a reference in $x), and so on.
1003 * For example, "$a+1 = 2" would cause mod() to be called with o being
1004 * OP_ADD and type being OP_SASSIGN, and would output an error.
1008 Perl_mod(pTHX_ OP *o, I32 type)
1012 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1015 if (!o || PL_error_count)
1018 if ((o->op_private & OPpTARGET_MY)
1019 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1024 switch (o->op_type) {
1030 if (!(o->op_private & (OPpCONST_ARYBASE)))
1032 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1033 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1037 SAVEI32(PL_compiling.cop_arybase);
1038 PL_compiling.cop_arybase = 0;
1040 else if (type == OP_REFGEN)
1043 Perl_croak(aTHX_ "That use of $[ is unsupported");
1046 if (o->op_flags & OPf_PARENS)
1050 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1051 !(o->op_flags & OPf_STACKED)) {
1052 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1053 /* The default is to set op_private to the number of children,
1054 which for a UNOP such as RV2CV is always 1. And w're using
1055 the bit for a flag in RV2CV, so we need it clear. */
1056 o->op_private &= ~1;
1057 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1058 assert(cUNOPo->op_first->op_type == OP_NULL);
1059 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1062 else if (o->op_private & OPpENTERSUB_NOMOD)
1064 else { /* lvalue subroutine call */
1065 o->op_private |= OPpLVAL_INTRO;
1066 PL_modcount = RETURN_UNLIMITED_NUMBER;
1067 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1068 /* Backward compatibility mode: */
1069 o->op_private |= OPpENTERSUB_INARGS;
1072 else { /* Compile-time error message: */
1073 OP *kid = cUNOPo->op_first;
1077 if (kid->op_type == OP_PUSHMARK)
1079 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1081 "panic: unexpected lvalue entersub "
1082 "args: type/targ %ld:%"UVuf,
1083 (long)kid->op_type, (UV)kid->op_targ);
1084 kid = kLISTOP->op_first;
1086 while (kid->op_sibling)
1087 kid = kid->op_sibling;
1088 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1090 if (kid->op_type == OP_METHOD_NAMED
1091 || kid->op_type == OP_METHOD)
1095 NewOp(1101, newop, 1, UNOP);
1096 newop->op_type = OP_RV2CV;
1097 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1098 newop->op_first = Nullop;
1099 newop->op_next = (OP*)newop;
1100 kid->op_sibling = (OP*)newop;
1101 newop->op_private |= OPpLVAL_INTRO;
1102 newop->op_private &= ~1;
1106 if (kid->op_type != OP_RV2CV)
1108 "panic: unexpected lvalue entersub "
1109 "entry via type/targ %ld:%"UVuf,
1110 (long)kid->op_type, (UV)kid->op_targ);
1111 kid->op_private |= OPpLVAL_INTRO;
1112 break; /* Postpone until runtime */
1116 kid = kUNOP->op_first;
1117 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1118 kid = kUNOP->op_first;
1119 if (kid->op_type == OP_NULL)
1121 "Unexpected constant lvalue entersub "
1122 "entry via type/targ %ld:%"UVuf,
1123 (long)kid->op_type, (UV)kid->op_targ);
1124 if (kid->op_type != OP_GV) {
1125 /* Restore RV2CV to check lvalueness */
1127 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1128 okid->op_next = kid->op_next;
1129 kid->op_next = okid;
1132 okid->op_next = Nullop;
1133 okid->op_type = OP_RV2CV;
1135 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1136 okid->op_private |= OPpLVAL_INTRO;
1137 okid->op_private &= ~1;
1141 cv = GvCV(kGVOP_gv);
1151 /* grep, foreach, subcalls, refgen, m//g */
1152 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN
1153 || type == OP_MATCH)
1155 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1156 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1158 : (o->op_type == OP_ENTERSUB
1159 ? "non-lvalue subroutine call"
1161 type ? PL_op_desc[type] : "local"));
1175 case OP_RIGHT_SHIFT:
1184 if (!(o->op_flags & OPf_STACKED))
1191 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1197 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1198 PL_modcount = RETURN_UNLIMITED_NUMBER;
1199 return o; /* Treat \(@foo) like ordinary list. */
1203 if (scalar_mod_type(o, type))
1205 ref(cUNOPo->op_first, o->op_type);
1209 if (type == OP_LEAVESUBLV)
1210 o->op_private |= OPpMAYBE_LVSUB;
1216 PL_modcount = RETURN_UNLIMITED_NUMBER;
1219 ref(cUNOPo->op_first, o->op_type);
1224 PL_hints |= HINT_BLOCK_SCOPE;
1239 PL_modcount = RETURN_UNLIMITED_NUMBER;
1240 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1241 return o; /* Treat \(@foo) like ordinary list. */
1242 if (scalar_mod_type(o, type))
1244 if (type == OP_LEAVESUBLV)
1245 o->op_private |= OPpMAYBE_LVSUB;
1249 if (!type) /* local() */
1250 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1251 PAD_COMPNAME_PV(o->op_targ));
1259 if (type != OP_SASSIGN)
1263 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1268 if (type == OP_LEAVESUBLV)
1269 o->op_private |= OPpMAYBE_LVSUB;
1271 pad_free(o->op_targ);
1272 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1273 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1274 if (o->op_flags & OPf_KIDS)
1275 mod(cBINOPo->op_first->op_sibling, type);
1280 ref(cBINOPo->op_first, o->op_type);
1281 if (type == OP_ENTERSUB &&
1282 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1283 o->op_private |= OPpLVAL_DEFER;
1284 if (type == OP_LEAVESUBLV)
1285 o->op_private |= OPpMAYBE_LVSUB;
1295 if (o->op_flags & OPf_KIDS)
1296 mod(cLISTOPo->op_last, type);
1301 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1303 else if (!(o->op_flags & OPf_KIDS))
1305 if (o->op_targ != OP_LIST) {
1306 mod(cBINOPo->op_first, type);
1312 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1317 if (type != OP_LEAVESUBLV)
1319 break; /* mod()ing was handled by ck_return() */
1322 /* [20011101.069] File test operators interpret OPf_REF to mean that
1323 their argument is a filehandle; thus \stat(".") should not set
1325 if (type == OP_REFGEN &&
1326 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1329 if (type != OP_LEAVESUBLV)
1330 o->op_flags |= OPf_MOD;
1332 if (type == OP_AASSIGN || type == OP_SASSIGN)
1333 o->op_flags |= OPf_SPECIAL|OPf_REF;
1334 else if (!type) { /* local() */
1337 o->op_private |= OPpLVAL_INTRO;
1338 o->op_flags &= ~OPf_SPECIAL;
1339 PL_hints |= HINT_BLOCK_SCOPE;
1344 if (ckWARN(WARN_SYNTAX)) {
1345 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1346 "Useless localization of %s", OP_DESC(o));
1350 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1351 && type != OP_LEAVESUBLV)
1352 o->op_flags |= OPf_REF;
1357 S_scalar_mod_type(pTHX_ const OP *o, I32 type)
1361 if (o->op_type == OP_RV2GV)
1385 case OP_RIGHT_SHIFT:
1404 S_is_handle_constructor(pTHX_ const OP *o, I32 numargs)
1406 switch (o->op_type) {
1414 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1427 Perl_refkids(pTHX_ OP *o, I32 type)
1429 if (o && o->op_flags & OPf_KIDS) {
1431 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1438 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1443 if (!o || PL_error_count)
1446 switch (o->op_type) {
1448 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1449 !(o->op_flags & OPf_STACKED)) {
1450 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1451 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1452 assert(cUNOPo->op_first->op_type == OP_NULL);
1453 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1454 o->op_flags |= OPf_SPECIAL;
1455 o->op_private &= ~1;
1460 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1461 doref(kid, type, set_op_ref);
1464 if (type == OP_DEFINED)
1465 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1466 doref(cUNOPo->op_first, o->op_type, set_op_ref);
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;
1478 o->op_flags |= OPf_MOD; /* XXX ??? */
1484 o->op_flags |= OPf_REF;
1487 if (type == OP_DEFINED)
1488 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1489 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1495 o->op_flags |= OPf_REF;
1500 if (!(o->op_flags & OPf_KIDS))
1502 doref(cBINOPo->op_first, type, set_op_ref);
1506 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1507 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1508 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1509 : type == OP_RV2HV ? OPpDEREF_HV
1511 o->op_flags |= OPf_MOD;
1521 if (!(o->op_flags & OPf_KIDS))
1523 doref(cLISTOPo->op_last, type, set_op_ref);
1533 S_dup_attrlist(pTHX_ OP *o)
1537 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1538 * where the first kid is OP_PUSHMARK and the remaining ones
1539 * are OP_CONST. We need to push the OP_CONST values.
1541 if (o->op_type == OP_CONST)
1542 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1544 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1546 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1547 if (o->op_type == OP_CONST)
1548 rop = append_elem(OP_LIST, rop,
1549 newSVOP(OP_CONST, o->op_flags,
1550 SvREFCNT_inc(cSVOPo->op_sv)));
1557 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1562 /* fake up C<use attributes $pkg,$rv,@attrs> */
1563 ENTER; /* need to protect against side-effects of 'use' */
1565 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1567 #define ATTRSMODULE "attributes"
1568 #define ATTRSMODULE_PM "attributes.pm"
1571 /* Don't force the C<use> if we don't need it. */
1572 SV * const * const svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
1573 sizeof(ATTRSMODULE_PM)-1, 0);
1574 if (svp && *svp != &PL_sv_undef)
1575 ; /* already in %INC */
1577 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1578 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1582 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1583 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1585 prepend_elem(OP_LIST,
1586 newSVOP(OP_CONST, 0, stashsv),
1587 prepend_elem(OP_LIST,
1588 newSVOP(OP_CONST, 0,
1590 dup_attrlist(attrs))));
1596 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1598 OP *pack, *imop, *arg;
1604 assert(target->op_type == OP_PADSV ||
1605 target->op_type == OP_PADHV ||
1606 target->op_type == OP_PADAV);
1608 /* Ensure that attributes.pm is loaded. */
1609 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1611 /* Need package name for method call. */
1612 pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
1614 /* Build up the real arg-list. */
1615 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1617 arg = newOP(OP_PADSV, 0);
1618 arg->op_targ = target->op_targ;
1619 arg = prepend_elem(OP_LIST,
1620 newSVOP(OP_CONST, 0, stashsv),
1621 prepend_elem(OP_LIST,
1622 newUNOP(OP_REFGEN, 0,
1623 mod(arg, OP_REFGEN)),
1624 dup_attrlist(attrs)));
1626 /* Fake up a method call to import */
1627 meth = newSVpvn_share("import", 6, 0);
1628 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1629 append_elem(OP_LIST,
1630 prepend_elem(OP_LIST, pack, list(arg)),
1631 newSVOP(OP_METHOD_NAMED, 0, meth)));
1632 imop->op_private |= OPpENTERSUB_NOMOD;
1634 /* Combine the ops. */
1635 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1639 =notfor apidoc apply_attrs_string
1641 Attempts to apply a list of attributes specified by the C<attrstr> and
1642 C<len> arguments to the subroutine identified by the C<cv> argument which
1643 is expected to be associated with the package identified by the C<stashpv>
1644 argument (see L<attributes>). It gets this wrong, though, in that it
1645 does not correctly identify the boundaries of the individual attribute
1646 specifications within C<attrstr>. This is not really intended for the
1647 public API, but has to be listed here for systems such as AIX which
1648 need an explicit export list for symbols. (It's called from XS code
1649 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1650 to respect attribute syntax properly would be welcome.
1656 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1657 const char *attrstr, STRLEN len)
1662 len = strlen(attrstr);
1666 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1668 const char * const sstr = attrstr;
1669 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1670 attrs = append_elem(OP_LIST, attrs,
1671 newSVOP(OP_CONST, 0,
1672 newSVpvn(sstr, attrstr-sstr)));
1676 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1677 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1678 Nullsv, prepend_elem(OP_LIST,
1679 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1680 prepend_elem(OP_LIST,
1681 newSVOP(OP_CONST, 0,
1687 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1691 if (!o || PL_error_count)
1695 if (type == OP_LIST) {
1697 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1698 my_kid(kid, attrs, imopsp);
1699 } else if (type == OP_UNDEF) {
1701 } else if (type == OP_RV2SV || /* "our" declaration */
1703 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1704 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1705 yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
1706 OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
1708 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
1710 PL_in_my_stash = NULL;
1711 apply_attrs(GvSTASH(gv),
1712 (type == OP_RV2SV ? GvSV(gv) :
1713 type == OP_RV2AV ? (SV*)GvAV(gv) :
1714 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1717 o->op_private |= OPpOUR_INTRO;
1720 else if (type != OP_PADSV &&
1723 type != OP_PUSHMARK)
1725 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1727 PL_in_my == KEY_our ? "our" : "my"));
1730 else if (attrs && type != OP_PUSHMARK) {
1734 PL_in_my_stash = NULL;
1736 /* check for C<my Dog $spot> when deciding package */
1737 stash = PAD_COMPNAME_TYPE(o->op_targ);
1739 stash = PL_curstash;
1740 apply_attrs_my(stash, o, attrs, imopsp);
1742 o->op_flags |= OPf_MOD;
1743 o->op_private |= OPpLVAL_INTRO;
1748 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1751 int maybe_scalar = 0;
1753 /* [perl #17376]: this appears to be premature, and results in code such as
1754 C< our(%x); > executing in list mode rather than void mode */
1756 if (o->op_flags & OPf_PARENS)
1766 o = my_kid(o, attrs, &rops);
1768 if (maybe_scalar && o->op_type == OP_PADSV) {
1769 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1770 o->op_private |= OPpLVAL_INTRO;
1773 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1776 PL_in_my_stash = NULL;
1781 Perl_my(pTHX_ OP *o)
1783 return my_attrs(o, Nullop);
1787 Perl_sawparens(pTHX_ OP *o)
1790 o->op_flags |= OPf_PARENS;
1795 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1800 if ( (left->op_type == OP_RV2AV ||
1801 left->op_type == OP_RV2HV ||
1802 left->op_type == OP_PADAV ||
1803 left->op_type == OP_PADHV)
1804 && ckWARN(WARN_MISC))
1806 const char * const desc = PL_op_desc[(right->op_type == OP_SUBST ||
1807 right->op_type == OP_TRANS)
1808 ? right->op_type : OP_MATCH];
1809 const char * const sample = ((left->op_type == OP_RV2AV ||
1810 left->op_type == OP_PADAV)
1811 ? "@array" : "%hash");
1812 Perl_warner(aTHX_ packWARN(WARN_MISC),
1813 "Applying %s to %s will act on scalar(%s)",
1814 desc, sample, sample);
1817 if (right->op_type == OP_CONST &&
1818 cSVOPx(right)->op_private & OPpCONST_BARE &&
1819 cSVOPx(right)->op_private & OPpCONST_STRICT)
1821 no_bareword_allowed(right);
1824 ismatchop = right->op_type == OP_MATCH ||
1825 right->op_type == OP_SUBST ||
1826 right->op_type == OP_TRANS;
1827 if (ismatchop && right->op_private & OPpTARGET_MY) {
1829 right->op_private &= ~OPpTARGET_MY;
1831 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1832 right->op_flags |= OPf_STACKED;
1833 /* s/// and tr/// modify their arg.
1834 * m//g also indirectly modifies the arg by setting pos magic on it */
1835 if ( (right->op_type == OP_MATCH &&
1836 (cPMOPx(right)->op_pmflags & PMf_GLOBAL))
1837 || (right->op_type == OP_SUBST)
1838 || (right->op_type == OP_TRANS &&
1839 ! (right->op_private & OPpTRANS_IDENTICAL))
1841 left = mod(left, right->op_type);
1842 if (right->op_type == OP_TRANS)
1843 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
1845 o = prepend_elem(right->op_type, scalar(left), right);
1847 return newUNOP(OP_NOT, 0, scalar(o));
1851 return bind_match(type, left,
1852 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
1856 Perl_invert(pTHX_ OP *o)
1860 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
1861 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1865 Perl_scope(pTHX_ OP *o)
1869 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1870 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1871 o->op_type = OP_LEAVE;
1872 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1874 else if (o->op_type == OP_LINESEQ) {
1876 o->op_type = OP_SCOPE;
1877 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1878 kid = ((LISTOP*)o)->op_first;
1879 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
1882 /* The following deals with things like 'do {1 for 1}' */
1883 kid = kid->op_sibling;
1885 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
1890 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
1896 Perl_block_start(pTHX_ int full)
1898 const int retval = PL_savestack_ix;
1899 pad_block_start(full);
1901 PL_hints &= ~HINT_BLOCK_SCOPE;
1902 SAVESPTR(PL_compiling.cop_warnings);
1903 if (! specialWARN(PL_compiling.cop_warnings)) {
1904 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1905 SAVEFREESV(PL_compiling.cop_warnings) ;
1907 SAVESPTR(PL_compiling.cop_io);
1908 if (! specialCopIO(PL_compiling.cop_io)) {
1909 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1910 SAVEFREESV(PL_compiling.cop_io) ;
1916 Perl_block_end(pTHX_ I32 floor, OP *seq)
1918 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1919 OP* const retval = scalarseq(seq);
1921 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
1923 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
1931 const I32 offset = pad_findmy("$_");
1932 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
1933 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1936 OP * const o = newOP(OP_PADSV, 0);
1937 o->op_targ = offset;
1943 Perl_newPROG(pTHX_ OP *o)
1948 PL_eval_root = newUNOP(OP_LEAVEEVAL,
1949 ((PL_in_eval & EVAL_KEEPERR)
1950 ? OPf_SPECIAL : 0), o);
1951 PL_eval_start = linklist(PL_eval_root);
1952 PL_eval_root->op_private |= OPpREFCOUNTED;
1953 OpREFCNT_set(PL_eval_root, 1);
1954 PL_eval_root->op_next = 0;
1955 CALL_PEEP(PL_eval_start);
1958 if (o->op_type == OP_STUB) {
1959 PL_comppad_name = 0;
1964 PL_main_root = scope(sawparens(scalarvoid(o)));
1965 PL_curcop = &PL_compiling;
1966 PL_main_start = LINKLIST(PL_main_root);
1967 PL_main_root->op_private |= OPpREFCOUNTED;
1968 OpREFCNT_set(PL_main_root, 1);
1969 PL_main_root->op_next = 0;
1970 CALL_PEEP(PL_main_start);
1973 /* Register with debugger */
1975 CV * const cv = get_cv("DB::postponed", FALSE);
1979 XPUSHs((SV*)CopFILEGV(&PL_compiling));
1981 call_sv((SV*)cv, G_DISCARD);
1988 Perl_localize(pTHX_ OP *o, I32 lex)
1990 if (o->op_flags & OPf_PARENS)
1991 /* [perl #17376]: this appears to be premature, and results in code such as
1992 C< our(%x); > executing in list mode rather than void mode */
1999 if ( PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ','
2000 && ckWARN(WARN_PARENTHESIS))
2002 char *s = PL_bufptr;
2005 /* some heuristics to detect a potential error */
2006 while (*s && (strchr(", \t\n", *s)))
2010 if (*s && strchr("@$%*", *s) && *++s
2011 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2014 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2016 while (*s && (strchr(", \t\n", *s)))
2022 if (sigil && (*s == ';' || *s == '=')) {
2023 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2024 "Parentheses missing around \"%s\" list",
2025 lex ? (PL_in_my == KEY_our ? "our" : "my")
2033 o = mod(o, OP_NULL); /* a bit kludgey */
2035 PL_in_my_stash = NULL;
2040 Perl_jmaybe(pTHX_ OP *o)
2042 if (o->op_type == OP_LIST) {
2044 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", GV_ADD, SVt_PV))),
2045 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2051 Perl_fold_constants(pTHX_ register OP *o)
2055 I32 type = o->op_type;
2058 if (PL_opargs[type] & OA_RETSCALAR)
2060 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2061 o->op_targ = pad_alloc(type, SVs_PADTMP);
2063 /* integerize op, unless it happens to be C<-foo>.
2064 * XXX should pp_i_negate() do magic string negation instead? */
2065 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2066 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2067 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2069 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2072 if (!(PL_opargs[type] & OA_FOLDCONST))
2077 /* XXX might want a ck_negate() for this */
2078 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2089 /* XXX what about the numeric ops? */
2090 if (PL_hints & HINT_LOCALE)
2095 goto nope; /* Don't try to run w/ errors */
2097 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2098 if ((curop->op_type != OP_CONST ||
2099 (curop->op_private & OPpCONST_BARE)) &&
2100 curop->op_type != OP_LIST &&
2101 curop->op_type != OP_SCALAR &&
2102 curop->op_type != OP_NULL &&
2103 curop->op_type != OP_PUSHMARK)
2109 curop = LINKLIST(o);
2113 sv = *(PL_stack_sp--);
2114 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2115 pad_swipe(o->op_targ, FALSE);
2116 else if (SvTEMP(sv)) { /* grab mortal temp? */
2117 (void)SvREFCNT_inc(sv);
2121 if (type == OP_RV2GV)
2122 return newGVOP(OP_GV, 0, (GV*)sv);
2123 return newSVOP(OP_CONST, 0, sv);
2130 Perl_gen_constant_list(pTHX_ register OP *o)
2134 const I32 oldtmps_floor = PL_tmps_floor;
2138 return o; /* Don't attempt to run with errors */
2140 PL_op = curop = LINKLIST(o);
2147 PL_tmps_floor = oldtmps_floor;
2149 o->op_type = OP_RV2AV;
2150 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2151 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2152 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2153 o->op_opt = 0; /* needs to be revisited in peep() */
2154 curop = ((UNOP*)o)->op_first;
2155 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2162 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2165 if (!o || o->op_type != OP_LIST)
2166 o = newLISTOP(OP_LIST, 0, o, Nullop);
2168 o->op_flags &= ~OPf_WANT;
2170 if (!(PL_opargs[type] & OA_MARK))
2171 op_null(cLISTOPo->op_first);
2173 o->op_type = (OPCODE)type;
2174 o->op_ppaddr = PL_ppaddr[type];
2175 o->op_flags |= flags;
2177 o = CHECKOP(type, o);
2178 if (o->op_type != (unsigned)type)
2181 return fold_constants(o);
2184 /* List constructors */
2187 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2195 if (first->op_type != (unsigned)type
2196 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2198 return newLISTOP(type, 0, first, last);
2201 if (first->op_flags & OPf_KIDS)
2202 ((LISTOP*)first)->op_last->op_sibling = last;
2204 first->op_flags |= OPf_KIDS;
2205 ((LISTOP*)first)->op_first = last;
2207 ((LISTOP*)first)->op_last = last;
2212 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2220 if (first->op_type != (unsigned)type)
2221 return prepend_elem(type, (OP*)first, (OP*)last);
2223 if (last->op_type != (unsigned)type)
2224 return append_elem(type, (OP*)first, (OP*)last);
2226 first->op_last->op_sibling = last->op_first;
2227 first->op_last = last->op_last;
2228 first->op_flags |= (last->op_flags & OPf_KIDS);
2236 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2244 if (last->op_type == (unsigned)type) {
2245 if (type == OP_LIST) { /* already a PUSHMARK there */
2246 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2247 ((LISTOP*)last)->op_first->op_sibling = first;
2248 if (!(first->op_flags & OPf_PARENS))
2249 last->op_flags &= ~OPf_PARENS;
2252 if (!(last->op_flags & OPf_KIDS)) {
2253 ((LISTOP*)last)->op_last = first;
2254 last->op_flags |= OPf_KIDS;
2256 first->op_sibling = ((LISTOP*)last)->op_first;
2257 ((LISTOP*)last)->op_first = first;
2259 last->op_flags |= OPf_KIDS;
2263 return newLISTOP(type, 0, first, last);
2269 Perl_newNULLLIST(pTHX)
2271 return newOP(OP_STUB, 0);
2275 Perl_force_list(pTHX_ OP *o)
2277 if (!o || o->op_type != OP_LIST)
2278 o = newLISTOP(OP_LIST, 0, o, Nullop);
2284 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2289 NewOp(1101, listop, 1, LISTOP);
2291 listop->op_type = (OPCODE)type;
2292 listop->op_ppaddr = PL_ppaddr[type];
2295 listop->op_flags = (U8)flags;
2299 else if (!first && last)
2302 first->op_sibling = last;
2303 listop->op_first = first;
2304 listop->op_last = last;
2305 if (type == OP_LIST) {
2306 OP* const pushop = newOP(OP_PUSHMARK, 0);
2307 pushop->op_sibling = first;
2308 listop->op_first = pushop;
2309 listop->op_flags |= OPf_KIDS;
2311 listop->op_last = pushop;
2314 return CHECKOP(type, listop);
2318 Perl_newOP(pTHX_ I32 type, I32 flags)
2322 NewOp(1101, o, 1, OP);
2323 o->op_type = (OPCODE)type;
2324 o->op_ppaddr = PL_ppaddr[type];
2325 o->op_flags = (U8)flags;
2328 o->op_private = (U8)(0 | (flags >> 8));
2329 if (PL_opargs[type] & OA_RETSCALAR)
2331 if (PL_opargs[type] & OA_TARGET)
2332 o->op_targ = pad_alloc(type, SVs_PADTMP);
2333 return CHECKOP(type, o);
2337 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2343 first = newOP(OP_STUB, 0);
2344 if (PL_opargs[type] & OA_MARK)
2345 first = force_list(first);
2347 NewOp(1101, unop, 1, UNOP);
2348 unop->op_type = (OPCODE)type;
2349 unop->op_ppaddr = PL_ppaddr[type];
2350 unop->op_first = first;
2351 unop->op_flags = (U8)(flags | OPf_KIDS);
2352 unop->op_private = (U8)(1 | (flags >> 8));
2353 unop = (UNOP*) CHECKOP(type, unop);
2357 return fold_constants((OP *) unop);
2361 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2365 NewOp(1101, binop, 1, BINOP);
2368 first = newOP(OP_NULL, 0);
2370 binop->op_type = (OPCODE)type;
2371 binop->op_ppaddr = PL_ppaddr[type];
2372 binop->op_first = first;
2373 binop->op_flags = (U8)(flags | OPf_KIDS);
2376 binop->op_private = (U8)(1 | (flags >> 8));
2379 binop->op_private = (U8)(2 | (flags >> 8));
2380 first->op_sibling = last;
2383 binop = (BINOP*)CHECKOP(type, binop);
2384 if (binop->op_next || binop->op_type != (OPCODE)type)
2387 binop->op_last = binop->op_first->op_sibling;
2389 return fold_constants((OP *)binop);
2392 static int uvcompare(const void *a, const void *b) __attribute__nonnull__(1) __attribute__nonnull__(2) __attribute__pure__;
2393 static int uvcompare(const void *a, const void *b)
2395 if (*((const UV *)a) < (*(const UV *)b))
2397 if (*((const UV *)a) > (*(const UV *)b))
2399 if (*((const UV *)a+1) < (*(const UV *)b+1))
2401 if (*((const UV *)a+1) > (*(const UV *)b+1))
2407 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2409 SV * const tstr = ((SVOP*)expr)->op_sv;
2410 SV * const rstr = ((SVOP*)repl)->op_sv;
2413 const U8 *t = (U8*)SvPV_const(tstr, tlen);
2414 const U8 *r = (U8*)SvPV_const(rstr, rlen);
2418 register short *tbl;
2420 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
2421 const I32 squash = o->op_private & OPpTRANS_SQUASH;
2422 I32 del = o->op_private & OPpTRANS_DELETE;
2423 PL_hints |= HINT_BLOCK_SCOPE;
2426 o->op_private |= OPpTRANS_FROM_UTF;
2429 o->op_private |= OPpTRANS_TO_UTF;
2431 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2432 SV* const listsv = newSVpvn("# comment\n",10);
2434 const U8* tend = t + tlen;
2435 const U8* rend = r + rlen;
2449 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2450 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2456 t = tsave = bytes_to_utf8(t, &len);
2459 if (!to_utf && rlen) {
2461 r = rsave = bytes_to_utf8(r, &len);
2465 /* There are several snags with this code on EBCDIC:
2466 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2467 2. scan_const() in toke.c has encoded chars in native encoding which makes
2468 ranges at least in EBCDIC 0..255 range the bottom odd.
2472 U8 tmpbuf[UTF8_MAXBYTES+1];
2475 Newx(cp, 2*tlen, UV);
2477 transv = newSVpvn("",0);
2479 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2481 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2483 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2487 cp[2*i+1] = cp[2*i];
2491 qsort(cp, i, 2*sizeof(UV), uvcompare);
2492 for (j = 0; j < i; j++) {
2494 diff = val - nextmin;
2496 t = uvuni_to_utf8(tmpbuf,nextmin);
2497 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2499 U8 range_mark = UTF_TO_NATIVE(0xff);
2500 t = uvuni_to_utf8(tmpbuf, val - 1);
2501 sv_catpvn(transv, (char *)&range_mark, 1);
2502 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2509 t = uvuni_to_utf8(tmpbuf,nextmin);
2510 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2512 U8 range_mark = UTF_TO_NATIVE(0xff);
2513 sv_catpvn(transv, (char *)&range_mark, 1);
2515 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2516 UNICODE_ALLOW_SUPER);
2517 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2518 t = (const U8*)SvPVX_const(transv);
2519 tlen = SvCUR(transv);
2523 else if (!rlen && !del) {
2524 r = t; rlen = tlen; rend = tend;
2527 if ((!rlen && !del) || t == r ||
2528 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2530 o->op_private |= OPpTRANS_IDENTICAL;
2534 while (t < tend || tfirst <= tlast) {
2535 /* see if we need more "t" chars */
2536 if (tfirst > tlast) {
2537 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2539 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2541 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2548 /* now see if we need more "r" chars */
2549 if (rfirst > rlast) {
2551 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2553 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2555 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2564 rfirst = rlast = 0xffffffff;
2568 /* now see which range will peter our first, if either. */
2569 tdiff = tlast - tfirst;
2570 rdiff = rlast - rfirst;
2577 if (rfirst == 0xffffffff) {
2578 diff = tdiff; /* oops, pretend rdiff is infinite */
2580 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2581 (long)tfirst, (long)tlast);
2583 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2587 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2588 (long)tfirst, (long)(tfirst + diff),
2591 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2592 (long)tfirst, (long)rfirst);
2594 if (rfirst + diff > max)
2595 max = rfirst + diff;
2597 grows = (tfirst < rfirst &&
2598 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2610 else if (max > 0xff)
2615 Safefree(cPVOPo->op_pv);
2616 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2617 SvREFCNT_dec(listsv);
2619 SvREFCNT_dec(transv);
2621 if (!del && havefinal && rlen)
2622 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2623 newSVuv((UV)final), 0);
2626 o->op_private |= OPpTRANS_GROWS;
2638 tbl = (short*)cPVOPo->op_pv;
2640 Zero(tbl, 256, short);
2641 for (i = 0; i < (I32)tlen; i++)
2643 for (i = 0, j = 0; i < 256; i++) {
2645 if (j >= (I32)rlen) {
2654 if (i < 128 && r[j] >= 128)
2664 o->op_private |= OPpTRANS_IDENTICAL;
2666 else if (j >= (I32)rlen)
2669 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2670 tbl[0x100] = (short)(rlen - j);
2671 for (i=0; i < (I32)rlen - j; i++)
2672 tbl[0x101+i] = r[j+i];
2676 if (!rlen && !del) {
2679 o->op_private |= OPpTRANS_IDENTICAL;
2681 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2682 o->op_private |= OPpTRANS_IDENTICAL;
2684 for (i = 0; i < 256; i++)
2686 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
2687 if (j >= (I32)rlen) {
2689 if (tbl[t[i]] == -1)
2695 if (tbl[t[i]] == -1) {
2696 if (t[i] < 128 && r[j] >= 128)
2703 o->op_private |= OPpTRANS_GROWS;
2711 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2716 NewOp(1101, pmop, 1, PMOP);
2717 pmop->op_type = (OPCODE)type;
2718 pmop->op_ppaddr = PL_ppaddr[type];
2719 pmop->op_flags = (U8)flags;
2720 pmop->op_private = (U8)(0 | (flags >> 8));
2722 if (PL_hints & HINT_RE_TAINT)
2723 pmop->op_pmpermflags |= PMf_RETAINT;
2724 if (PL_hints & HINT_LOCALE)
2725 pmop->op_pmpermflags |= PMf_LOCALE;
2726 pmop->op_pmflags = pmop->op_pmpermflags;
2729 if (av_len((AV*) PL_regex_pad[0]) > -1) {
2730 SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
2731 pmop->op_pmoffset = SvIV(repointer);
2732 SvREPADTMP_off(repointer);
2733 sv_setiv(repointer,0);
2735 SV * const repointer = newSViv(0);
2736 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2737 pmop->op_pmoffset = av_len(PL_regex_padav);
2738 PL_regex_pad = AvARRAY(PL_regex_padav);
2742 /* link into pm list */
2743 if (type != OP_TRANS && PL_curstash) {
2744 MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab);
2747 mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0);
2749 pmop->op_pmnext = (PMOP*)mg->mg_obj;
2750 mg->mg_obj = (SV*)pmop;
2751 PmopSTASH_set(pmop,PL_curstash);
2754 return CHECKOP(type, pmop);
2757 /* Given some sort of match op o, and an expression expr containing a
2758 * pattern, either compile expr into a regex and attach it to o (if it's
2759 * constant), or convert expr into a runtime regcomp op sequence (if it's
2762 * isreg indicates that the pattern is part of a regex construct, eg
2763 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
2764 * split "pattern", which aren't. In the former case, expr will be a list
2765 * if the pattern contains more than one term (eg /a$b/) or if it contains
2766 * a replacement, ie s/// or tr///.
2770 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
2775 I32 repl_has_vars = 0;
2779 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
2780 /* last element in list is the replacement; pop it */
2782 repl = cLISTOPx(expr)->op_last;
2783 kid = cLISTOPx(expr)->op_first;
2784 while (kid->op_sibling != repl)
2785 kid = kid->op_sibling;
2786 kid->op_sibling = Nullop;
2787 cLISTOPx(expr)->op_last = kid;
2790 if (isreg && expr->op_type == OP_LIST &&
2791 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
2793 /* convert single element list to element */
2794 OP* const oe = expr;
2795 expr = cLISTOPx(oe)->op_first->op_sibling;
2796 cLISTOPx(oe)->op_first->op_sibling = Nullop;
2797 cLISTOPx(oe)->op_last = Nullop;
2801 if (o->op_type == OP_TRANS) {
2802 return pmtrans(o, expr, repl);
2805 reglist = isreg && expr->op_type == OP_LIST;
2809 PL_hints |= HINT_BLOCK_SCOPE;
2812 if (expr->op_type == OP_CONST) {
2814 SV *pat = ((SVOP*)expr)->op_sv;
2815 const char *p = SvPV_const(pat, plen);
2816 if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
2817 U32 was_readonly = SvREADONLY(pat);
2821 sv_force_normal_flags(pat, 0);
2822 assert(!SvREADONLY(pat));
2825 SvREADONLY_off(pat);
2829 sv_setpvn(pat, "\\s+", 3);
2831 SvFLAGS(pat) |= was_readonly;
2833 p = SvPV_const(pat, plen);
2834 pm->op_pmflags |= PMf_SKIPWHITE;
2837 pm->op_pmdynflags |= PMdf_UTF8;
2838 /* FIXME - can we make this function take const char * args? */
2839 PM_SETRE(pm, CALLREGCOMP(aTHX_ (char*)p, (char*)p + plen, pm));
2840 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
2841 pm->op_pmflags |= PMf_WHITE;
2845 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2846 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2848 : OP_REGCMAYBE),0,expr);
2850 NewOp(1101, rcop, 1, LOGOP);
2851 rcop->op_type = OP_REGCOMP;
2852 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2853 rcop->op_first = scalar(expr);
2854 rcop->op_flags |= OPf_KIDS
2855 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
2856 | (reglist ? OPf_STACKED : 0);
2857 rcop->op_private = 1;
2860 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
2862 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
2865 /* establish postfix order */
2866 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2868 rcop->op_next = expr;
2869 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2872 rcop->op_next = LINKLIST(expr);
2873 expr->op_next = (OP*)rcop;
2876 prepend_elem(o->op_type, scalar((OP*)rcop), o);
2881 if (pm->op_pmflags & PMf_EVAL) {
2883 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
2884 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
2886 else if (repl->op_type == OP_CONST)
2890 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
2891 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
2892 if (curop->op_type == OP_GV) {
2893 GV *gv = cGVOPx_gv(curop);
2895 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
2898 else if (curop->op_type == OP_RV2CV)
2900 else if (curop->op_type == OP_RV2SV ||
2901 curop->op_type == OP_RV2AV ||
2902 curop->op_type == OP_RV2HV ||
2903 curop->op_type == OP_RV2GV) {
2904 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2907 else if (curop->op_type == OP_PADSV ||
2908 curop->op_type == OP_PADAV ||
2909 curop->op_type == OP_PADHV ||
2910 curop->op_type == OP_PADANY) {
2913 else if (curop->op_type == OP_PUSHRE)
2914 ; /* Okay here, dangerous in newASSIGNOP */
2924 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
2925 pm->op_pmflags |= PMf_CONST; /* const for long enough */
2926 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
2927 prepend_elem(o->op_type, scalar(repl), o);
2930 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
2931 pm->op_pmflags |= PMf_MAYBE_CONST;
2932 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2934 NewOp(1101, rcop, 1, LOGOP);
2935 rcop->op_type = OP_SUBSTCONT;
2936 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
2937 rcop->op_first = scalar(repl);
2938 rcop->op_flags |= OPf_KIDS;
2939 rcop->op_private = 1;
2942 /* establish postfix order */
2943 rcop->op_next = LINKLIST(repl);
2944 repl->op_next = (OP*)rcop;
2946 pm->op_pmreplroot = scalar((OP*)rcop);
2947 pm->op_pmreplstart = LINKLIST(rcop);
2956 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
2960 NewOp(1101, svop, 1, SVOP);
2961 svop->op_type = (OPCODE)type;
2962 svop->op_ppaddr = PL_ppaddr[type];
2964 svop->op_next = (OP*)svop;
2965 svop->op_flags = (U8)flags;
2966 if (PL_opargs[type] & OA_RETSCALAR)
2968 if (PL_opargs[type] & OA_TARGET)
2969 svop->op_targ = pad_alloc(type, SVs_PADTMP);
2970 return CHECKOP(type, svop);
2974 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2978 NewOp(1101, padop, 1, PADOP);
2979 padop->op_type = (OPCODE)type;
2980 padop->op_ppaddr = PL_ppaddr[type];
2981 padop->op_padix = pad_alloc(type, SVs_PADTMP);
2982 SvREFCNT_dec(PAD_SVl(padop->op_padix));
2983 PAD_SETSV(padop->op_padix, sv);
2986 padop->op_next = (OP*)padop;
2987 padop->op_flags = (U8)flags;
2988 if (PL_opargs[type] & OA_RETSCALAR)
2990 if (PL_opargs[type] & OA_TARGET)
2991 padop->op_targ = pad_alloc(type, SVs_PADTMP);
2992 return CHECKOP(type, padop);
2996 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3002 return newPADOP(type, flags, SvREFCNT_inc(gv));
3004 return newSVOP(type, flags, SvREFCNT_inc(gv));
3009 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3013 NewOp(1101, pvop, 1, PVOP);
3014 pvop->op_type = (OPCODE)type;
3015 pvop->op_ppaddr = PL_ppaddr[type];
3017 pvop->op_next = (OP*)pvop;
3018 pvop->op_flags = (U8)flags;
3019 if (PL_opargs[type] & OA_RETSCALAR)
3021 if (PL_opargs[type] & OA_TARGET)
3022 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3023 return CHECKOP(type, pvop);
3027 Perl_package(pTHX_ OP *o)
3032 save_hptr(&PL_curstash);
3033 save_item(PL_curstname);
3035 name = SvPV_const(cSVOPo->op_sv, len);
3036 PL_curstash = gv_stashpvn(name, len, TRUE);
3037 sv_setpvn(PL_curstname, name, len);
3040 PL_hints |= HINT_BLOCK_SCOPE;
3041 PL_copline = NOLINE;
3046 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3052 if (idop->op_type != OP_CONST)
3053 Perl_croak(aTHX_ "Module name must be constant");
3058 SV * const vesv = ((SVOP*)version)->op_sv;
3060 if (!arg && !SvNIOKp(vesv)) {
3067 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3068 Perl_croak(aTHX_ "Version number must be constant number");
3070 /* Make copy of idop so we don't free it twice */
3071 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3073 /* Fake up a method call to VERSION */
3074 meth = newSVpvn_share("VERSION", 7, 0);
3075 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3076 append_elem(OP_LIST,
3077 prepend_elem(OP_LIST, pack, list(version)),
3078 newSVOP(OP_METHOD_NAMED, 0, meth)));
3082 /* Fake up an import/unimport */
3083 if (arg && arg->op_type == OP_STUB)
3084 imop = arg; /* no import on explicit () */
3085 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3086 imop = Nullop; /* use 5.0; */
3088 idop->op_private |= OPpCONST_NOVER;
3093 /* Make copy of idop so we don't free it twice */
3094 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3096 /* Fake up a method call to import/unimport */
3098 ? newSVpvn_share("import",6, 0) : newSVpvn_share("unimport", 8, 0);
3099 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3100 append_elem(OP_LIST,
3101 prepend_elem(OP_LIST, pack, list(arg)),
3102 newSVOP(OP_METHOD_NAMED, 0, meth)));
3105 /* Fake up the BEGIN {}, which does its thing immediately. */
3107 newSVOP(OP_CONST, 0, newSVpvn_share("BEGIN", 5, 0)),
3110 append_elem(OP_LINESEQ,
3111 append_elem(OP_LINESEQ,
3112 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, idop)),
3113 newSTATEOP(0, Nullch, veop)),
3114 newSTATEOP(0, Nullch, imop) ));
3116 /* The "did you use incorrect case?" warning used to be here.
3117 * The problem is that on case-insensitive filesystems one
3118 * might get false positives for "use" (and "require"):
3119 * "use Strict" or "require CARP" will work. This causes
3120 * portability problems for the script: in case-strict
3121 * filesystems the script will stop working.
3123 * The "incorrect case" warning checked whether "use Foo"
3124 * imported "Foo" to your namespace, but that is wrong, too:
3125 * there is no requirement nor promise in the language that
3126 * a Foo.pm should or would contain anything in package "Foo".
3128 * There is very little Configure-wise that can be done, either:
3129 * the case-sensitivity of the build filesystem of Perl does not
3130 * help in guessing the case-sensitivity of the runtime environment.
3133 PL_hints |= HINT_BLOCK_SCOPE;
3134 PL_copline = NOLINE;
3136 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3140 =head1 Embedding Functions
3142 =for apidoc load_module
3144 Loads the module whose name is pointed to by the string part of name.
3145 Note that the actual module name, not its filename, should be given.
3146 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3147 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3148 (or 0 for no flags). ver, if specified, provides version semantics
3149 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3150 arguments can be used to specify arguments to the module's import()
3151 method, similar to C<use Foo::Bar VERSION LIST>.
3156 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3159 va_start(args, ver);
3160 vload_module(flags, name, ver, &args);
3164 #ifdef PERL_IMPLICIT_CONTEXT
3166 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3170 va_start(args, ver);
3171 vload_module(flags, name, ver, &args);
3177 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3181 OP * const modname = newSVOP(OP_CONST, 0, name);
3182 modname->op_private |= OPpCONST_BARE;
3184 veop = newSVOP(OP_CONST, 0, ver);
3188 if (flags & PERL_LOADMOD_NOIMPORT) {
3189 imop = sawparens(newNULLLIST());
3191 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3192 imop = va_arg(*args, OP*);
3197 sv = va_arg(*args, SV*);
3199 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3200 sv = va_arg(*args, SV*);
3204 const line_t ocopline = PL_copline;
3205 COP * const ocurcop = PL_curcop;
3206 const int oexpect = PL_expect;
3208 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3209 veop, modname, imop);
3210 PL_expect = oexpect;
3211 PL_copline = ocopline;
3212 PL_curcop = ocurcop;
3217 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
3222 if (!force_builtin) {
3223 gv = gv_fetchpv("do", 0, SVt_PVCV);
3224 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
3225 GV * const * const gvp = (GV**)hv_fetch(PL_globalstash, "do", 2, FALSE);
3226 gv = gvp ? *gvp : Nullgv;
3230 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3231 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3232 append_elem(OP_LIST, term,
3233 scalar(newUNOP(OP_RV2CV, 0,
3238 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3244 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3246 return newBINOP(OP_LSLICE, flags,
3247 list(force_list(subscript)),
3248 list(force_list(listval)) );
3252 S_is_list_assignment(pTHX_ register const OP *o)
3257 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3258 o = cUNOPo->op_first;
3260 if (o->op_type == OP_COND_EXPR) {
3261 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3262 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3267 yyerror("Assignment to both a list and a scalar");
3271 if (o->op_type == OP_LIST &&
3272 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3273 o->op_private & OPpLVAL_INTRO)
3276 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3277 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3278 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3281 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3284 if (o->op_type == OP_RV2SV)
3291 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3296 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3297 return newLOGOP(optype, 0,
3298 mod(scalar(left), optype),
3299 newUNOP(OP_SASSIGN, 0, scalar(right)));
3302 return newBINOP(optype, OPf_STACKED,
3303 mod(scalar(left), optype), scalar(right));
3307 if (is_list_assignment(left)) {
3311 /* Grandfathering $[ assignment here. Bletch.*/
3312 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
3313 PL_eval_start = (left->op_type == OP_CONST) ? right : 0;
3314 left = mod(left, OP_AASSIGN);
3317 else if (left->op_type == OP_CONST) {
3318 /* Result of assignment is always 1 (or we'd be dead already) */
3319 return newSVOP(OP_CONST, 0, newSViv(1));
3321 curop = list(force_list(left));
3322 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3323 o->op_private = (U8)(0 | (flags >> 8));
3325 /* PL_generation sorcery:
3326 * an assignment like ($a,$b) = ($c,$d) is easier than
3327 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3328 * To detect whether there are common vars, the global var
3329 * PL_generation is incremented for each assign op we compile.
3330 * Then, while compiling the assign op, we run through all the
3331 * variables on both sides of the assignment, setting a spare slot
3332 * in each of them to PL_generation. If any of them already have
3333 * that value, we know we've got commonality. We could use a
3334 * single bit marker, but then we'd have to make 2 passes, first
3335 * to clear the flag, then to test and set it. To find somewhere
3336 * to store these values, evil chicanery is done with SvCUR().
3339 if (!(left->op_private & OPpLVAL_INTRO)) {
3342 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3343 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3344 if (curop->op_type == OP_GV) {
3345 GV *gv = cGVOPx_gv(curop);
3346 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3348 SvCUR_set(gv, PL_generation);
3350 else if (curop->op_type == OP_PADSV ||
3351 curop->op_type == OP_PADAV ||
3352 curop->op_type == OP_PADHV ||
3353 curop->op_type == OP_PADANY)
3355 if (PAD_COMPNAME_GEN(curop->op_targ)
3356 == (STRLEN)PL_generation)
3358 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
3361 else if (curop->op_type == OP_RV2CV)
3363 else if (curop->op_type == OP_RV2SV ||
3364 curop->op_type == OP_RV2AV ||
3365 curop->op_type == OP_RV2HV ||
3366 curop->op_type == OP_RV2GV) {
3367 if (lastop->op_type != OP_GV) /* funny deref? */
3370 else if (curop->op_type == OP_PUSHRE) {
3371 if (((PMOP*)curop)->op_pmreplroot) {
3373 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3374 ((PMOP*)curop)->op_pmreplroot));
3376 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3378 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3380 SvCUR_set(gv, PL_generation);
3389 o->op_private |= OPpASSIGN_COMMON;
3391 if (right && right->op_type == OP_SPLIT) {
3393 if ((tmpop = ((LISTOP*)right)->op_first) &&
3394 tmpop->op_type == OP_PUSHRE)
3396 PMOP * const pm = (PMOP*)tmpop;
3397 if (left->op_type == OP_RV2AV &&
3398 !(left->op_private & OPpLVAL_INTRO) &&
3399 !(o->op_private & OPpASSIGN_COMMON) )
3401 tmpop = ((UNOP*)left)->op_first;
3402 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3404 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3405 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3407 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3408 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3410 pm->op_pmflags |= PMf_ONCE;
3411 tmpop = cUNOPo->op_first; /* to list (nulled) */
3412 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3413 tmpop->op_sibling = Nullop; /* don't free split */
3414 right->op_next = tmpop->op_next; /* fix starting loc */
3415 op_free(o); /* blow off assign */
3416 right->op_flags &= ~OPf_WANT;
3417 /* "I don't know and I don't care." */
3422 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3423 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3425 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3427 sv_setiv(sv, PL_modcount+1);
3435 right = newOP(OP_UNDEF, 0);
3436 if (right->op_type == OP_READLINE) {
3437 right->op_flags |= OPf_STACKED;
3438 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3441 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3442 o = newBINOP(OP_SASSIGN, flags,
3443 scalar(right), mod(scalar(left), OP_SASSIGN) );
3447 o = newSVOP(OP_CONST, 0, newSViv(PL_compiling.cop_arybase));
3454 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3457 const U32 seq = intro_my();
3460 NewOp(1101, cop, 1, COP);
3461 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3462 cop->op_type = OP_DBSTATE;
3463 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3466 cop->op_type = OP_NEXTSTATE;
3467 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3469 cop->op_flags = (U8)flags;
3470 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3472 cop->op_private |= NATIVE_HINTS;
3474 PL_compiling.op_private = cop->op_private;
3475 cop->op_next = (OP*)cop;
3478 cop->cop_label = label;
3479 PL_hints |= HINT_BLOCK_SCOPE;
3482 cop->cop_arybase = PL_curcop->cop_arybase;
3483 if (specialWARN(PL_curcop->cop_warnings))
3484 cop->cop_warnings = PL_curcop->cop_warnings ;
3486 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3487 if (specialCopIO(PL_curcop->cop_io))
3488 cop->cop_io = PL_curcop->cop_io;
3490 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3493 if (PL_copline == NOLINE)
3494 CopLINE_set(cop, CopLINE(PL_curcop));
3496 CopLINE_set(cop, PL_copline);
3497 PL_copline = NOLINE;
3500 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3502 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3504 CopSTASH_set(cop, PL_curstash);
3506 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3507 SV * const * const svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3508 if (svp && *svp != &PL_sv_undef ) {
3509 (void)SvIOK_on(*svp);
3510 SvIV_set(*svp, PTR2IV(cop));
3514 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3519 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3522 return new_logop(type, flags, &first, &other);
3526 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3531 OP *first = *firstp;
3532 OP * const other = *otherp;
3534 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3535 return newBINOP(type, flags, scalar(first), scalar(other));
3537 scalarboolean(first);
3538 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3539 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3540 if (type == OP_AND || type == OP_OR) {
3546 first = *firstp = cUNOPo->op_first;
3548 first->op_next = o->op_next;
3549 cUNOPo->op_first = Nullop;
3553 if (first->op_type == OP_CONST) {
3554 if (first->op_private & OPpCONST_STRICT)
3555 no_bareword_allowed(first);
3556 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
3557 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3558 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
3559 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
3560 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
3563 if (other->op_type == OP_CONST)
3564 other->op_private |= OPpCONST_SHORTCIRCUIT;
3568 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
3569 const OP *o2 = other;
3570 if ( ! (o2->op_type == OP_LIST
3571 && (( o2 = cUNOPx(o2)->op_first))
3572 && o2->op_type == OP_PUSHMARK
3573 && (( o2 = o2->op_sibling)) )
3576 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
3577 || o2->op_type == OP_PADHV)
3578 && o2->op_private & OPpLVAL_INTRO
3579 && ckWARN(WARN_DEPRECATED))
3581 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
3582 "Deprecated use of my() in false conditional");
3587 if (first->op_type == OP_CONST)
3588 first->op_private |= OPpCONST_SHORTCIRCUIT;
3592 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
3593 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
3595 const OP * const k1 = ((UNOP*)first)->op_first;
3596 const OP * const k2 = k1->op_sibling;
3598 switch (first->op_type)
3601 if (k2 && k2->op_type == OP_READLINE
3602 && (k2->op_flags & OPf_STACKED)
3603 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3605 warnop = k2->op_type;
3610 if (k1->op_type == OP_READDIR
3611 || k1->op_type == OP_GLOB
3612 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3613 || k1->op_type == OP_EACH)
3615 warnop = ((k1->op_type == OP_NULL)
3616 ? (OPCODE)k1->op_targ : k1->op_type);
3621 const line_t oldline = CopLINE(PL_curcop);
3622 CopLINE_set(PL_curcop, PL_copline);
3623 Perl_warner(aTHX_ packWARN(WARN_MISC),
3624 "Value of %s%s can be \"0\"; test with defined()",
3626 ((warnop == OP_READLINE || warnop == OP_GLOB)
3627 ? " construct" : "() operator"));
3628 CopLINE_set(PL_curcop, oldline);
3635 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3636 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3638 NewOp(1101, logop, 1, LOGOP);
3640 logop->op_type = (OPCODE)type;
3641 logop->op_ppaddr = PL_ppaddr[type];
3642 logop->op_first = first;
3643 logop->op_flags = (U8)(flags | OPf_KIDS);
3644 logop->op_other = LINKLIST(other);
3645 logop->op_private = (U8)(1 | (flags >> 8));
3647 /* establish postfix order */
3648 logop->op_next = LINKLIST(first);
3649 first->op_next = (OP*)logop;
3650 first->op_sibling = other;
3652 CHECKOP(type,logop);
3654 o = newUNOP(OP_NULL, 0, (OP*)logop);
3661 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3669 return newLOGOP(OP_AND, 0, first, trueop);
3671 return newLOGOP(OP_OR, 0, first, falseop);
3673 scalarboolean(first);
3674 if (first->op_type == OP_CONST) {
3675 if (first->op_private & OPpCONST_BARE &&
3676 first->op_private & OPpCONST_STRICT) {
3677 no_bareword_allowed(first);
3679 if (SvTRUE(((SVOP*)first)->op_sv)) {
3690 NewOp(1101, logop, 1, LOGOP);
3691 logop->op_type = OP_COND_EXPR;
3692 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3693 logop->op_first = first;
3694 logop->op_flags = (U8)(flags | OPf_KIDS);
3695 logop->op_private = (U8)(1 | (flags >> 8));
3696 logop->op_other = LINKLIST(trueop);
3697 logop->op_next = LINKLIST(falseop);
3699 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
3702 /* establish postfix order */
3703 start = LINKLIST(first);
3704 first->op_next = (OP*)logop;
3706 first->op_sibling = trueop;
3707 trueop->op_sibling = falseop;
3708 o = newUNOP(OP_NULL, 0, (OP*)logop);
3710 trueop->op_next = falseop->op_next = o;
3717 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3726 NewOp(1101, range, 1, LOGOP);
3728 range->op_type = OP_RANGE;
3729 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3730 range->op_first = left;
3731 range->op_flags = OPf_KIDS;
3732 leftstart = LINKLIST(left);
3733 range->op_other = LINKLIST(right);
3734 range->op_private = (U8)(1 | (flags >> 8));
3736 left->op_sibling = right;
3738 range->op_next = (OP*)range;
3739 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3740 flop = newUNOP(OP_FLOP, 0, flip);
3741 o = newUNOP(OP_NULL, 0, flop);
3743 range->op_next = leftstart;
3745 left->op_next = flip;
3746 right->op_next = flop;
3748 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3749 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3750 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3751 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3753 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3754 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3757 if (!flip->op_private || !flop->op_private)
3758 linklist(o); /* blow off optimizer unless constant */
3764 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3768 const bool once = block && block->op_flags & OPf_SPECIAL &&
3769 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3771 PERL_UNUSED_ARG(debuggable);
3774 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3775 return block; /* do {} while 0 does once */
3776 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3777 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3778 expr = newUNOP(OP_DEFINED, 0,
3779 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3780 } else if (expr->op_flags & OPf_KIDS) {
3781 const OP * const k1 = ((UNOP*)expr)->op_first;
3782 const OP * const k2 = k1 ? k1->op_sibling : NULL;
3783 switch (expr->op_type) {
3785 if (k2 && k2->op_type == OP_READLINE
3786 && (k2->op_flags & OPf_STACKED)
3787 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3788 expr = newUNOP(OP_DEFINED, 0, expr);
3792 if (k1->op_type == OP_READDIR
3793 || k1->op_type == OP_GLOB
3794 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3795 || k1->op_type == OP_EACH)
3796 expr = newUNOP(OP_DEFINED, 0, expr);
3802 /* if block is null, the next append_elem() would put UNSTACK, a scalar
3803 * op, in listop. This is wrong. [perl #27024] */
3805 block = newOP(OP_NULL, 0);
3806 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3807 o = new_logop(OP_AND, 0, &expr, &listop);
3810 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3812 if (once && o != listop)
3813 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3816 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3818 o->op_flags |= flags;
3820 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3825 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
3826 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
3835 PERL_UNUSED_ARG(debuggable);
3838 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3839 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3840 expr = newUNOP(OP_DEFINED, 0,
3841 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3842 } else if (expr->op_flags & OPf_KIDS) {
3843 const OP * const k1 = ((UNOP*)expr)->op_first;
3844 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
3845 switch (expr->op_type) {
3847 if (k2 && k2->op_type == OP_READLINE
3848 && (k2->op_flags & OPf_STACKED)
3849 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3850 expr = newUNOP(OP_DEFINED, 0, expr);
3854 if (k1->op_type == OP_READDIR
3855 || k1->op_type == OP_GLOB
3856 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3857 || k1->op_type == OP_EACH)
3858 expr = newUNOP(OP_DEFINED, 0, expr);
3865 block = newOP(OP_NULL, 0);
3866 else if (cont || has_my) {
3867 block = scope(block);
3871 next = LINKLIST(cont);
3874 OP * const unstack = newOP(OP_UNSTACK, 0);
3877 cont = append_elem(OP_LINESEQ, cont, unstack);
3880 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3881 redo = LINKLIST(listop);
3884 PL_copline = (line_t)whileline;
3886 o = new_logop(OP_AND, 0, &expr, &listop);
3887 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3888 op_free(expr); /* oops, it's a while (0) */
3890 return Nullop; /* listop already freed by new_logop */
3893 ((LISTOP*)listop)->op_last->op_next =
3894 (o == listop ? redo : LINKLIST(o));
3900 NewOp(1101,loop,1,LOOP);
3901 loop->op_type = OP_ENTERLOOP;
3902 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3903 loop->op_private = 0;
3904 loop->op_next = (OP*)loop;
3907 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3909 loop->op_redoop = redo;
3910 loop->op_lastop = o;
3911 o->op_private |= loopflags;
3914 loop->op_nextop = next;
3916 loop->op_nextop = o;
3918 o->op_flags |= flags;
3919 o->op_private |= (flags >> 8);
3924 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
3929 PADOFFSET padoff = 0;
3934 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
3935 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
3936 sv->op_type = OP_RV2GV;
3937 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3938 if (cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
3939 iterpflags |= OPpITER_DEF;
3941 else if (sv->op_type == OP_PADSV) { /* private variable */
3942 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
3943 padoff = sv->op_targ;
3948 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3949 padoff = sv->op_targ;
3951 iterflags |= OPf_SPECIAL;
3956 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3957 if (padoff && strEQ(PAD_COMPNAME_PV(padoff), "$_"))
3958 iterpflags |= OPpITER_DEF;
3961 const I32 offset = pad_findmy("$_");
3962 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
3963 sv = newGVOP(OP_GV, 0, PL_defgv);
3968 iterpflags |= OPpITER_DEF;
3970 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3971 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3972 iterflags |= OPf_STACKED;
3974 else if (expr->op_type == OP_NULL &&
3975 (expr->op_flags & OPf_KIDS) &&
3976 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3978 /* Basically turn for($x..$y) into the same as for($x,$y), but we
3979 * set the STACKED flag to indicate that these values are to be
3980 * treated as min/max values by 'pp_iterinit'.
3982 UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
3983 LOGOP* const range = (LOGOP*) flip->op_first;
3984 OP* const left = range->op_first;
3985 OP* const right = left->op_sibling;
3988 range->op_flags &= ~OPf_KIDS;
3989 range->op_first = Nullop;
3991 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
3992 listop->op_first->op_next = range->op_next;
3993 left->op_next = range->op_other;
3994 right->op_next = (OP*)listop;
3995 listop->op_next = listop->op_first;
3998 expr = (OP*)(listop);
4000 iterflags |= OPf_STACKED;
4003 expr = mod(force_list(expr), OP_GREPSTART);
4006 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4007 append_elem(OP_LIST, expr, scalar(sv))));
4008 assert(!loop->op_next);
4009 /* for my $x () sets OPpLVAL_INTRO;
4010 * for our $x () sets OPpOUR_INTRO */
4011 loop->op_private = (U8)iterpflags;
4012 #ifdef PL_OP_SLAB_ALLOC
4015 NewOp(1234,tmp,1,LOOP);
4016 Copy(loop,tmp,1,LISTOP);
4021 Renew(loop, 1, LOOP);
4023 loop->op_targ = padoff;
4024 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4025 PL_copline = forline;
4026 return newSTATEOP(0, label, wop);
4030 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4034 if (type != OP_GOTO || label->op_type == OP_CONST) {
4035 /* "last()" means "last" */
4036 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4037 o = newOP(type, OPf_SPECIAL);
4039 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4040 ? SvPVx_nolen_const(((SVOP*)label)->op_sv)
4046 /* Check whether it's going to be a goto &function */
4047 if (label->op_type == OP_ENTERSUB
4048 && !(label->op_flags & OPf_STACKED))
4049 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4050 o = newUNOP(type, OPf_STACKED, label);
4052 PL_hints |= HINT_BLOCK_SCOPE;
4056 /* if the condition is a literal array or hash
4057 (or @{ ... } etc), make a reference to it.
4060 S_ref_array_or_hash(pTHX_ OP *cond)
4063 && (cond->op_type == OP_RV2AV
4064 || cond->op_type == OP_PADAV
4065 || cond->op_type == OP_RV2HV
4066 || cond->op_type == OP_PADHV))
4068 return newUNOP(OP_REFGEN,
4069 0, mod(cond, OP_REFGEN));
4075 /* These construct the optree fragments representing given()
4078 entergiven and enterwhen are LOGOPs; the op_other pointer
4079 points up to the associated leave op. We need this so we
4080 can put it in the context and make break/continue work.
4081 (Also, of course, pp_enterwhen will jump straight to
4082 op_other if the match fails.)
4087 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
4088 I32 enter_opcode, I32 leave_opcode,
4089 PADOFFSET entertarg)
4094 NewOp(1101, enterop, 1, LOGOP);
4095 enterop->op_type = enter_opcode;
4096 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
4097 enterop->op_flags = (U8) OPf_KIDS;
4098 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
4099 enterop->op_private = 0;
4101 o = newUNOP(leave_opcode, 0, (OP *) enterop);
4104 enterop->op_first = scalar(cond);
4105 cond->op_sibling = block;
4107 o->op_next = LINKLIST(cond);
4108 cond->op_next = (OP *) enterop;
4111 /* This is a default {} block */
4112 enterop->op_first = block;
4113 enterop->op_flags |= OPf_SPECIAL;
4115 o->op_next = (OP *) enterop;
4118 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
4119 entergiven and enterwhen both
4122 enterop->op_next = LINKLIST(block);
4123 block->op_next = enterop->op_other = o;
4128 /* Does this look like a boolean operation? For these purposes
4129 a boolean operation is:
4130 - a subroutine call [*]
4131 - a logical connective
4132 - a comparison operator
4133 - a filetest operator, with the exception of -s -M -A -C
4134 - defined(), exists() or eof()
4135 - /$re/ or $foo =~ /$re/
4137 [*] possibly surprising
4141 S_looks_like_bool(pTHX_ OP *o)
4143 switch(o->op_type) {
4145 return looks_like_bool(cLOGOPo->op_first);
4149 looks_like_bool(cLOGOPo->op_first)
4150 && looks_like_bool(cLOGOPo->op_first->op_sibling));
4154 case OP_NOT: case OP_XOR:
4155 /* Note that OP_DOR is not here */
4157 case OP_EQ: case OP_NE: case OP_LT:
4158 case OP_GT: case OP_LE: case OP_GE:
4160 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
4161 case OP_I_GT: case OP_I_LE: case OP_I_GE:
4163 case OP_SEQ: case OP_SNE: case OP_SLT:
4164 case OP_SGT: case OP_SLE: case OP_SGE:
4168 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
4169 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
4170 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
4171 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
4172 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
4173 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
4174 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
4175 case OP_FTTEXT: case OP_FTBINARY:
4177 case OP_DEFINED: case OP_EXISTS:
4178 case OP_MATCH: case OP_EOF:
4183 /* Detect comparisons that have been optimized away */
4184 if (cSVOPo->op_sv == &PL_sv_yes
4185 || cSVOPo->op_sv == &PL_sv_no)
4196 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
4199 return newGIVWHENOP(
4200 ref_array_or_hash(cond),
4202 OP_ENTERGIVEN, OP_LEAVEGIVEN,
4206 /* If cond is null, this is a default {} block */
4208 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
4210 bool cond_llb = (!cond || looks_like_bool(cond));
4216 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
4218 scalar(ref_array_or_hash(cond)));
4221 return newGIVWHENOP(
4223 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
4224 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
4228 =for apidoc cv_undef
4230 Clear out all the active components of a CV. This can happen either
4231 by an explicit C<undef &foo>, or by the reference count going to zero.
4232 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4233 children can still follow the full lexical scope chain.
4239 Perl_cv_undef(pTHX_ CV *cv)
4243 if (CvFILE(cv) && !CvXSUB(cv)) {
4244 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4245 Safefree(CvFILE(cv));
4250 if (!CvXSUB(cv) && CvROOT(cv)) {
4252 Perl_croak(aTHX_ "Can't undef active subroutine");
4255 PAD_SAVE_SETNULLPAD();
4257 op_free(CvROOT(cv));
4258 CvROOT(cv) = Nullop;
4259 CvSTART(cv) = Nullop;
4262 SvPOK_off((SV*)cv); /* forget prototype */
4267 /* remove CvOUTSIDE unless this is an undef rather than a free */
4268 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4269 if (!CvWEAKOUTSIDE(cv))
4270 SvREFCNT_dec(CvOUTSIDE(cv));
4271 CvOUTSIDE(cv) = Nullcv;
4274 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4280 /* delete all flags except WEAKOUTSIDE */
4281 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4285 Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p)
4287 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX_const(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4288 SV* const msg = sv_newmortal();
4292 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4293 sv_setpv(msg, "Prototype mismatch:");
4295 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4297 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (const SV *)cv);
4299 Perl_sv_catpv(aTHX_ msg, ": none");
4300 sv_catpv(msg, " vs ");
4302 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4304 sv_catpv(msg, "none");
4305 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
4309 static void const_sv_xsub(pTHX_ CV* cv);
4313 =head1 Optree Manipulation Functions
4315 =for apidoc cv_const_sv
4317 If C<cv> is a constant sub eligible for inlining. returns the constant
4318 value returned by the sub. Otherwise, returns NULL.
4320 Constant subs can be created with C<newCONSTSUB> or as described in
4321 L<perlsub/"Constant Functions">.
4326 Perl_cv_const_sv(pTHX_ CV *cv)
4330 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
4332 return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
4335 /* op_const_sv: examine an optree to determine whether it's in-lineable.
4336 * Can be called in 3 ways:
4339 * look for a single OP_CONST with attached value: return the value
4341 * cv && CvCLONE(cv) && !CvCONST(cv)
4343 * examine the clone prototype, and if contains only a single
4344 * OP_CONST referencing a pad const, or a single PADSV referencing
4345 * an outer lexical, return a non-zero value to indicate the CV is
4346 * a candidate for "constizing" at clone time
4350 * We have just cloned an anon prototype that was marked as a const
4351 * candidiate. Try to grab the current value, and in the case of
4352 * PADSV, ignore it if it has multiple references. Return the value.
4356 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
4363 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4364 o = cLISTOPo->op_first->op_sibling;
4366 for (; o; o = o->op_next) {
4367 const OPCODE type = o->op_type;
4369 if (sv && o->op_next == o)
4371 if (o->op_next != o) {
4372 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4374 if (type == OP_DBSTATE)
4377 if (type == OP_LEAVESUB || type == OP_RETURN)
4381 if (type == OP_CONST && cSVOPo->op_sv)
4383 else if (cv && type == OP_CONST) {
4384 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4388 else if (cv && type == OP_PADSV) {
4389 if (CvCONST(cv)) { /* newly cloned anon */
4390 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4391 /* the candidate should have 1 ref from this pad and 1 ref
4392 * from the parent */
4393 if (!sv || SvREFCNT(sv) != 2)
4400 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4401 sv = &PL_sv_undef; /* an arbitrary non-null value */
4412 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4414 PERL_UNUSED_ARG(floor);
4424 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4428 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4430 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4434 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4441 register CV *cv = NULL;
4445 const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : Nullch;
4448 assert(proto->op_type == OP_CONST);
4449 ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len);
4454 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4455 SV * const sv = sv_newmortal();
4456 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4457 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4458 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4459 aname = SvPVX_const(sv);
4464 gv_fetch_flags = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
4465 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
4466 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
4467 : gv_fetchpv(aname ? aname
4468 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4469 gv_fetch_flags, SVt_PVCV);
4478 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4479 maximum a prototype before. */
4480 if (SvTYPE(gv) > SVt_NULL) {
4481 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4482 && ckWARN_d(WARN_PROTOTYPE))
4484 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4486 cv_ckproto((CV*)gv, NULL, ps);
4489 sv_setpvn((SV*)gv, ps, ps_len);
4491 sv_setiv((SV*)gv, -1);
4492 SvREFCNT_dec(PL_compcv);
4493 cv = PL_compcv = NULL;
4494 PL_sub_generation++;
4498 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4500 #ifdef GV_UNIQUE_CHECK
4501 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4502 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4506 if (!block || !ps || *ps || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
4509 const_sv = op_const_sv(block, Nullcv);
4512 const bool exists = CvROOT(cv) || CvXSUB(cv);
4514 #ifdef GV_UNIQUE_CHECK
4515 if (exists && GvUNIQUE(gv)) {
4516 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4520 /* if the subroutine doesn't exist and wasn't pre-declared
4521 * with a prototype, assume it will be AUTOLOADed,
4522 * skipping the prototype check
4524 if (exists || SvPOK(cv))
4525 cv_ckproto(cv, gv, ps);
4526 /* already defined (or promised)? */
4527 if (exists || GvASSUMECV(gv)) {
4528 if (!block && !attrs) {
4529 if (CvFLAGS(PL_compcv)) {
4530 /* might have had built-in attrs applied */
4531 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4533 /* just a "sub foo;" when &foo is already defined */
4534 SAVEFREESV(PL_compcv);
4538 if (ckWARN(WARN_REDEFINE)
4540 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4542 const line_t oldline = CopLINE(PL_curcop);
4543 if (PL_copline != NOLINE)
4544 CopLINE_set(PL_curcop, PL_copline);
4545 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4546 CvCONST(cv) ? "Constant subroutine %s redefined"
4547 : "Subroutine %s redefined", name);
4548 CopLINE_set(PL_curcop, oldline);
4556 (void)SvREFCNT_inc(const_sv);
4558 assert(!CvROOT(cv) && !CvCONST(cv));
4559 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
4560 CvXSUBANY(cv).any_ptr = const_sv;
4561 CvXSUB(cv) = const_sv_xsub;
4566 cv = newCONSTSUB(NULL, name, const_sv);
4569 SvREFCNT_dec(PL_compcv);
4571 PL_sub_generation++;
4578 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4579 * before we clobber PL_compcv.
4583 /* Might have had built-in attributes applied -- propagate them. */
4584 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4585 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4586 stash = GvSTASH(CvGV(cv));
4587 else if (CvSTASH(cv))
4588 stash = CvSTASH(cv);
4590 stash = PL_curstash;
4593 /* possibly about to re-define existing subr -- ignore old cv */
4594 rcv = (SV*)PL_compcv;
4595 if (name && GvSTASH(gv))
4596 stash = GvSTASH(gv);
4598 stash = PL_curstash;
4600 apply_attrs(stash, rcv, attrs, FALSE);
4602 if (cv) { /* must reuse cv if autoloaded */
4604 /* got here with just attrs -- work done, so bug out */
4605 SAVEFREESV(PL_compcv);
4608 /* transfer PL_compcv to cv */
4610 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4611 if (!CvWEAKOUTSIDE(cv))
4612 SvREFCNT_dec(CvOUTSIDE(cv));
4613 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4614 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4615 CvOUTSIDE(PL_compcv) = 0;
4616 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4617 CvPADLIST(PL_compcv) = 0;
4618 /* inner references to PL_compcv must be fixed up ... */
4619 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4620 /* ... before we throw it away */
4621 SvREFCNT_dec(PL_compcv);
4623 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4624 ++PL_sub_generation;
4631 PL_sub_generation++;
4635 CvFILE_set_from_cop(cv, PL_curcop);
4636 CvSTASH(cv) = PL_curstash;
4639 sv_setpvn((SV*)cv, ps, ps_len);
4641 if (PL_error_count) {
4645 const char *s = strrchr(name, ':');
4647 if (strEQ(s, "BEGIN")) {
4648 const char not_safe[] =
4649 "BEGIN not safe after errors--compilation aborted";
4650 if (PL_in_eval & EVAL_KEEPERR)
4651 Perl_croak(aTHX_ not_safe);
4653 /* force display of errors found but not reported */
4654 sv_catpv(ERRSV, not_safe);
4655 Perl_croak(aTHX_ "%"SVf, ERRSV);
4664 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4665 mod(scalarseq(block), OP_LEAVESUBLV));
4668 /* This makes sub {}; work as expected. */
4669 if (block->op_type == OP_STUB) {
4671 block = newSTATEOP(0, Nullch, 0);
4673 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4675 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4676 OpREFCNT_set(CvROOT(cv), 1);
4677 CvSTART(cv) = LINKLIST(CvROOT(cv));
4678 CvROOT(cv)->op_next = 0;
4679 CALL_PEEP(CvSTART(cv));
4681 /* now that optimizer has done its work, adjust pad values */
4683 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4686 assert(!CvCONST(cv));
4687 if (ps && !*ps && op_const_sv(block, cv))
4691 if (name || aname) {
4693 const char * const tname = (name ? name : aname);
4695 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4696 SV * const sv = NEWSV(0,0);
4697 SV * const tmpstr = sv_newmortal();
4698 GV * const db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4701 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4703 (long)PL_subline, (long)CopLINE(PL_curcop));
4704 gv_efullname3(tmpstr, gv, Nullch);
4705 hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
4706 hv = GvHVn(db_postponed);
4707 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
4708 CV * const pcv = GvCV(db_postponed);
4714 call_sv((SV*)pcv, G_DISCARD);
4719 if ((s = strrchr(tname,':')))
4724 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4727 if (strEQ(s, "BEGIN") && !PL_error_count) {
4728 const I32 oldscope = PL_scopestack_ix;
4730 SAVECOPFILE(&PL_compiling);
4731 SAVECOPLINE(&PL_compiling);
4734 PL_beginav = newAV();
4735 DEBUG_x( dump_sub(gv) );
4736 av_push(PL_beginav, (SV*)cv);
4737 GvCV(gv) = 0; /* cv has been hijacked */
4738 call_list(oldscope, PL_beginav);
4740 PL_curcop = &PL_compiling;
4741 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4744 else if (strEQ(s, "END") && !PL_error_count) {
4747 DEBUG_x( dump_sub(gv) );
4748 av_unshift(PL_endav, 1);
4749 av_store(PL_endav, 0, (SV*)cv);
4750 GvCV(gv) = 0; /* cv has been hijacked */
4752 else if (strEQ(s, "CHECK") && !PL_error_count) {
4754 PL_checkav = newAV();
4755 DEBUG_x( dump_sub(gv) );
4756 if (PL_main_start && ckWARN(WARN_VOID))
4757 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4758 av_unshift(PL_checkav, 1);
4759 av_store(PL_checkav, 0, (SV*)cv);
4760 GvCV(gv) = 0; /* cv has been hijacked */
4762 else if (strEQ(s, "INIT") && !PL_error_count) {
4764 PL_initav = newAV();
4765 DEBUG_x( dump_sub(gv) );
4766 if (PL_main_start && ckWARN(WARN_VOID))
4767 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4768 av_push(PL_initav, (SV*)cv);
4769 GvCV(gv) = 0; /* cv has been hijacked */
4774 PL_copline = NOLINE;
4779 /* XXX unsafe for threads if eval_owner isn't held */
4781 =for apidoc newCONSTSUB
4783 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4784 eligible for inlining at compile-time.
4790 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
4797 SAVECOPLINE(PL_curcop);
4798 CopLINE_set(PL_curcop, PL_copline);
4801 PL_hints &= ~HINT_BLOCK_SCOPE;
4804 SAVESPTR(PL_curstash);
4805 SAVECOPSTASH(PL_curcop);
4806 PL_curstash = stash;
4807 CopSTASH_set(PL_curcop,stash);
4810 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4811 CvXSUBANY(cv).any_ptr = sv;
4813 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
4817 CopSTASH_free(PL_curcop);
4825 =for apidoc U||newXS
4827 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4833 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
4835 GV * const gv = gv_fetchpv(name ? name :
4836 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4837 GV_ADDMULTI, SVt_PVCV);
4841 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4843 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4845 /* just a cached method */
4849 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4850 /* already defined (or promised) */
4851 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
4852 if (ckWARN(WARN_REDEFINE)) {
4853 GV * const gvcv = CvGV(cv);
4855 HV * const stash = GvSTASH(gvcv);
4857 const char *name = HvNAME_get(stash);
4858 if ( strEQ(name,"autouse") ) {
4859 const line_t oldline = CopLINE(PL_curcop);
4860 if (PL_copline != NOLINE)
4861 CopLINE_set(PL_curcop, PL_copline);
4862 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4863 CvCONST(cv) ? "Constant subroutine %s redefined"
4864 : "Subroutine %s redefined"
4866 CopLINE_set(PL_curcop, oldline);
4876 if (cv) /* must reuse cv if autoloaded */
4879 cv = (CV*)NEWSV(1105,0);
4880 sv_upgrade((SV *)cv, SVt_PVCV);
4884 PL_sub_generation++;
4888 (void)gv_fetchfile(filename);
4889 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
4890 an external constant string */
4891 CvXSUB(cv) = subaddr;
4894 const char *s = strrchr(name,':');
4900 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4903 if (strEQ(s, "BEGIN")) {
4905 PL_beginav = newAV();
4906 av_push(PL_beginav, (SV*)cv);
4907 GvCV(gv) = 0; /* cv has been hijacked */
4909 else if (strEQ(s, "END")) {
4912 av_unshift(PL_endav, 1);
4913 av_store(PL_endav, 0, (SV*)cv);
4914 GvCV(gv) = 0; /* cv has been hijacked */
4916 else if (strEQ(s, "CHECK")) {
4918 PL_checkav = newAV();
4919 if (PL_main_start && ckWARN(WARN_VOID))
4920 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4921 av_unshift(PL_checkav, 1);
4922 av_store(PL_checkav, 0, (SV*)cv);
4923 GvCV(gv) = 0; /* cv has been hijacked */
4925 else if (strEQ(s, "INIT")) {
4927 PL_initav = newAV();
4928 if (PL_main_start && ckWARN(WARN_VOID))
4929 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4930 av_push(PL_initav, (SV*)cv);
4931 GvCV(gv) = 0; /* cv has been hijacked */
4942 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4947 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
4948 : gv_fetchpv("STDOUT", GV_ADD, SVt_PVFM);
4950 #ifdef GV_UNIQUE_CHECK
4952 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4956 if ((cv = GvFORM(gv))) {
4957 if (ckWARN(WARN_REDEFINE)) {
4958 const line_t oldline = CopLINE(PL_curcop);
4959 if (PL_copline != NOLINE)
4960 CopLINE_set(PL_curcop, PL_copline);
4961 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4962 o ? "Format %"SVf" redefined"
4963 : "Format STDOUT redefined" ,cSVOPo->op_sv);
4964 CopLINE_set(PL_curcop, oldline);
4971 CvFILE_set_from_cop(cv, PL_curcop);
4974 pad_tidy(padtidy_FORMAT);
4975 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4976 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4977 OpREFCNT_set(CvROOT(cv), 1);
4978 CvSTART(cv) = LINKLIST(CvROOT(cv));
4979 CvROOT(cv)->op_next = 0;
4980 CALL_PEEP(CvSTART(cv));
4982 PL_copline = NOLINE;
4987 Perl_newANONLIST(pTHX_ OP *o)
4989 return newUNOP(OP_REFGEN, 0,
4990 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4994 Perl_newANONHASH(pTHX_ OP *o)
4996 return newUNOP(OP_REFGEN, 0,
4997 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5001 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5003 return newANONATTRSUB(floor, proto, Nullop, block);
5007 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5009 return newUNOP(OP_REFGEN, 0,
5010 newSVOP(OP_ANONCODE, 0,
5011 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5015 Perl_oopsAV(pTHX_ OP *o)
5018 switch (o->op_type) {
5020 o->op_type = OP_PADAV;
5021 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5022 return ref(o, OP_RV2AV);
5025 o->op_type = OP_RV2AV;
5026 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5031 if (ckWARN_d(WARN_INTERNAL))
5032 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
5039 Perl_oopsHV(pTHX_ OP *o)
5042 switch (o->op_type) {
5045 o->op_type = OP_PADHV;
5046 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5047 return ref(o, OP_RV2HV);
5051 o->op_type = OP_RV2HV;
5052 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5057 if (ckWARN_d(WARN_INTERNAL))
5058 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
5065 Perl_newAVREF(pTHX_ OP *o)
5068 if (o->op_type == OP_PADANY) {
5069 o->op_type = OP_PADAV;
5070 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5073 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5074 && ckWARN(WARN_DEPRECATED)) {
5075 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5076 "Using an array as a reference is deprecated");
5078 return newUNOP(OP_RV2AV, 0, scalar(o));
5082 Perl_newGVREF(pTHX_ I32 type, OP *o)
5084 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5085 return newUNOP(OP_NULL, 0, o);
5086 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5090 Perl_newHVREF(pTHX_ OP *o)
5093 if (o->op_type == OP_PADANY) {
5094 o->op_type = OP_PADHV;
5095 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5098 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5099 && ckWARN(WARN_DEPRECATED)) {
5100 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5101 "Using a hash as a reference is deprecated");
5103 return newUNOP(OP_RV2HV, 0, scalar(o));
5107 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5109 return newUNOP(OP_RV2CV, flags, scalar(o));
5113 Perl_newSVREF(pTHX_ OP *o)
5116 if (o->op_type == OP_PADANY) {
5117 o->op_type = OP_PADSV;
5118 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5121 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5122 o->op_flags |= OPpDONE_SVREF;
5125 return newUNOP(OP_RV2SV, 0, scalar(o));
5128 /* Check routines. See the comments at the top of this file for details
5129 * on when these are called */
5132 Perl_ck_anoncode(pTHX_ OP *o)
5134 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
5135 cSVOPo->op_sv = Nullsv;
5140 Perl_ck_bitop(pTHX_ OP *o)
5142 #define OP_IS_NUMCOMPARE(op) \
5143 ((op) == OP_LT || (op) == OP_I_LT || \
5144 (op) == OP_GT || (op) == OP_I_GT || \
5145 (op) == OP_LE || (op) == OP_I_LE || \
5146 (op) == OP_GE || (op) == OP_I_GE || \
5147 (op) == OP_EQ || (op) == OP_I_EQ || \
5148 (op) == OP_NE || (op) == OP_I_NE || \
5149 (op) == OP_NCMP || (op) == OP_I_NCMP)
5150 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
5151 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
5152 && (o->op_type == OP_BIT_OR
5153 || o->op_type == OP_BIT_AND
5154 || o->op_type == OP_BIT_XOR))
5156 const OP * const left = cBINOPo->op_first;
5157 const OP * const right = left->op_sibling;
5158 if ((OP_IS_NUMCOMPARE(left->op_type) &&
5159 (left->op_flags & OPf_PARENS) == 0) ||
5160 (OP_IS_NUMCOMPARE(right->op_type) &&
5161 (right->op_flags & OPf_PARENS) == 0))
5162 if (ckWARN(WARN_PRECEDENCE))
5163 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
5164 "Possible precedence problem on bitwise %c operator",
5165 o->op_type == OP_BIT_OR ? '|'
5166 : o->op_type == OP_BIT_AND ? '&' : '^'
5173 Perl_ck_concat(pTHX_ OP *o)
5175 const OP * const kid = cUNOPo->op_first;
5176 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
5177 !(kUNOP->op_first->op_flags & OPf_MOD))
5178 o->op_flags |= OPf_STACKED;
5183 Perl_ck_spair(pTHX_ OP *o)
5186 if (o->op_flags & OPf_KIDS) {
5189 const OPCODE type = o->op_type;
5190 o = modkids(ck_fun(o), type);
5191 kid = cUNOPo->op_first;
5192 newop = kUNOP->op_first->op_sibling;
5194 (newop->op_sibling ||
5195 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5196 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5197 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5201 op_free(kUNOP->op_first);
5202 kUNOP->op_first = newop;
5204 o->op_ppaddr = PL_ppaddr[++o->op_type];
5209 Perl_ck_delete(pTHX_ OP *o)
5213 if (o->op_flags & OPf_KIDS) {
5214 OP * const kid = cUNOPo->op_first;
5215 switch (kid->op_type) {
5217 o->op_flags |= OPf_SPECIAL;
5220 o->op_private |= OPpSLICE;
5223 o->op_flags |= OPf_SPECIAL;
5228 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5237 Perl_ck_die(pTHX_ OP *o)
5240 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5246 Perl_ck_eof(pTHX_ OP *o)
5248 const I32 type = o->op_type;
5250 if (o->op_flags & OPf_KIDS) {
5251 if (cLISTOPo->op_first->op_type == OP_STUB) {
5253 o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
5261 Perl_ck_eval(pTHX_ OP *o)
5264 PL_hints |= HINT_BLOCK_SCOPE;
5265 if (o->op_flags & OPf_KIDS) {
5266 SVOP * const kid = (SVOP*)cUNOPo->op_first;
5269 o->op_flags &= ~OPf_KIDS;
5272 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
5275 cUNOPo->op_first = 0;
5278 NewOp(1101, enter, 1, LOGOP);
5279 enter->op_type = OP_ENTERTRY;
5280 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5281 enter->op_private = 0;
5283 /* establish postfix order */
5284 enter->op_next = (OP*)enter;
5286 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5287 o->op_type = OP_LEAVETRY;
5288 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5289 enter->op_other = o;
5299 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5301 o->op_targ = (PADOFFSET)PL_hints;
5302 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
5303 /* Store a copy of %^H that pp_entereval can pick up */
5304 OP *hhop = newSVOP(OP_CONST, 0, (SV*)newHVhv(GvHV(PL_hintgv)));
5305 cUNOPo->op_first->op_sibling = hhop;
5306 o->op_private |= OPpEVAL_HAS_HH;
5312 Perl_ck_exit(pTHX_ OP *o)
5315 HV * const table = GvHV(PL_hintgv);
5317 SV * const * const svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5318 if (svp && *svp && SvTRUE(*svp))
5319 o->op_private |= OPpEXIT_VMSISH;
5321 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5327 Perl_ck_exec(pTHX_ OP *o)
5329 if (o->op_flags & OPf_STACKED) {
5332 kid = cUNOPo->op_first->op_sibling;
5333 if (kid->op_type == OP_RV2GV)
5342 Perl_ck_exists(pTHX_ OP *o)
5345 if (o->op_flags & OPf_KIDS) {
5346 OP * const kid = cUNOPo->op_first;
5347 if (kid->op_type == OP_ENTERSUB) {
5348 (void) ref(kid, o->op_type);
5349 if (kid->op_type != OP_RV2CV && !PL_error_count)
5350 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5352 o->op_private |= OPpEXISTS_SUB;
5354 else if (kid->op_type == OP_AELEM)
5355 o->op_flags |= OPf_SPECIAL;
5356 else if (kid->op_type != OP_HELEM)
5357 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5365 Perl_ck_rvconst(pTHX_ register OP *o)
5368 SVOP * const kid = (SVOP*)cUNOPo->op_first;
5370 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5371 if (o->op_type == OP_RV2CV)
5372 o->op_private &= ~1;
5374 if (kid->op_type == OP_CONST) {
5377 SV * const kidsv = kid->op_sv;
5379 /* Is it a constant from cv_const_sv()? */
5380 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5381 SV * const rsv = SvRV(kidsv);
5382 const int svtype = SvTYPE(rsv);
5383 const char *badtype = Nullch;
5385 switch (o->op_type) {
5387 if (svtype > SVt_PVMG)
5388 badtype = "a SCALAR";
5391 if (svtype != SVt_PVAV)
5392 badtype = "an ARRAY";
5395 if (svtype != SVt_PVHV)
5399 if (svtype != SVt_PVCV)
5404 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5407 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5408 const char *badthing = Nullch;
5409 switch (o->op_type) {
5411 badthing = "a SCALAR";
5414 badthing = "an ARRAY";
5417 badthing = "a HASH";
5422 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
5426 * This is a little tricky. We only want to add the symbol if we
5427 * didn't add it in the lexer. Otherwise we get duplicate strict
5428 * warnings. But if we didn't add it in the lexer, we must at
5429 * least pretend like we wanted to add it even if it existed before,
5430 * or we get possible typo warnings. OPpCONST_ENTERED says
5431 * whether the lexer already added THIS instance of this symbol.
5433 iscv = (o->op_type == OP_RV2CV) * 2;
5435 gv = gv_fetchsv(kidsv,
5436 iscv | !(kid->op_private & OPpCONST_ENTERED),
5439 : o->op_type == OP_RV2SV
5441 : o->op_type == OP_RV2AV
5443 : o->op_type == OP_RV2HV
5446 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5448 kid->op_type = OP_GV;
5449 SvREFCNT_dec(kid->op_sv);
5451 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5452 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5453 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
5455 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
5457 kid->op_sv = SvREFCNT_inc(gv);
5459 kid->op_private = 0;
5460 kid->op_ppaddr = PL_ppaddr[OP_GV];
5467 Perl_ck_ftst(pTHX_ OP *o)
5470 const I32 type = o->op_type;
5472 if (o->op_flags & OPf_REF) {
5475 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5476 SVOP * const kid = (SVOP*)cUNOPo->op_first;
5478 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5479 OP * const newop = newGVOP(type, OPf_REF,
5480 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
5486 if ((PL_hints & HINT_FILETEST_ACCESS) &&
5487 OP_IS_FILETEST_ACCESS(o))
5488 o->op_private |= OPpFT_ACCESS;
5490 if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
5491 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
5492 o->op_private |= OPpFT_STACKED;
5496 if (type == OP_FTTTY)
5497 o = newGVOP(type, OPf_REF, PL_stdingv);
5499 o = newUNOP(type, 0, newDEFSVOP());
5505 Perl_ck_fun(pTHX_ OP *o)
5507 const int type = o->op_type;
5508 register I32 oa = PL_opargs[type] >> OASHIFT;
5510 if (o->op_flags & OPf_STACKED) {
5511 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5514 return no_fh_allowed(o);
5517 if (o->op_flags & OPf_KIDS) {
5518 OP **tokid = &cLISTOPo->op_first;
5519 register OP *kid = cLISTOPo->op_first;
5523 if (kid->op_type == OP_PUSHMARK ||
5524 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5526 tokid = &kid->op_sibling;
5527 kid = kid->op_sibling;
5529 if (!kid && PL_opargs[type] & OA_DEFGV)
5530 *tokid = kid = newDEFSVOP();
5534 sibl = kid->op_sibling;
5537 /* list seen where single (scalar) arg expected? */
5538 if (numargs == 1 && !(oa >> 4)
5539 && kid->op_type == OP_LIST && type != OP_SCALAR)
5541 return too_many_arguments(o,PL_op_desc[type]);
5554 if ((type == OP_PUSH || type == OP_UNSHIFT)
5555 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5556 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5557 "Useless use of %s with no values",
5560 if (kid->op_type == OP_CONST &&
5561 (kid->op_private & OPpCONST_BARE))
5563 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
5564 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
5565 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5566 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5567 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
5568 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5571 kid->op_sibling = sibl;
5574 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5575 bad_type(numargs, "array", PL_op_desc[type], kid);
5579 if (kid->op_type == OP_CONST &&
5580 (kid->op_private & OPpCONST_BARE))
5582 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
5583 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
5584 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5585 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5586 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
5587 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5590 kid->op_sibling = sibl;
5593 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5594 bad_type(numargs, "hash", PL_op_desc[type], kid);
5599 OP * const newop = newUNOP(OP_NULL, 0, kid);
5600 kid->op_sibling = 0;
5602 newop->op_next = newop;
5604 kid->op_sibling = sibl;
5609 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5610 if (kid->op_type == OP_CONST &&
5611 (kid->op_private & OPpCONST_BARE))
5613 OP * const newop = newGVOP(OP_GV, 0,
5614 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
5615 if (!(o->op_private & 1) && /* if not unop */
5616 kid == cLISTOPo->op_last)
5617 cLISTOPo->op_last = newop;
5621 else if (kid->op_type == OP_READLINE) {
5622 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5623 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5626 I32 flags = OPf_SPECIAL;
5630 /* is this op a FH constructor? */
5631 if (is_handle_constructor(o,numargs)) {
5632 const char *name = Nullch;
5636 /* Set a flag to tell rv2gv to vivify
5637 * need to "prove" flag does not mean something
5638 * else already - NI-S 1999/05/07
5641 if (kid->op_type == OP_PADSV) {
5642 name = PAD_COMPNAME_PV(kid->op_targ);
5643 /* SvCUR of a pad namesv can't be trusted
5644 * (see PL_generation), so calc its length
5650 else if (kid->op_type == OP_RV2SV
5651 && kUNOP->op_first->op_type == OP_GV)
5653 GV * const gv = cGVOPx_gv(kUNOP->op_first);
5655 len = GvNAMELEN(gv);
5657 else if (kid->op_type == OP_AELEM
5658 || kid->op_type == OP_HELEM)
5660 OP *op = ((BINOP*)kid)->op_first;
5663 SV *tmpstr = Nullsv;
5664 const char * const a =
5665 kid->op_type == OP_AELEM ?
5667 if (((op->op_type == OP_RV2AV) ||
5668 (op->op_type == OP_RV2HV)) &&
5669 (op = ((UNOP*)op)->op_first) &&
5670 (op->op_type == OP_GV)) {
5671 /* packagevar $a[] or $h{} */
5672 GV * const gv = cGVOPx_gv(op);
5680 else if (op->op_type == OP_PADAV
5681 || op->op_type == OP_PADHV) {
5682 /* lexicalvar $a[] or $h{} */
5683 const char * const padname =
5684 PAD_COMPNAME_PV(op->op_targ);
5693 name = SvPV_const(tmpstr, len);
5698 name = "__ANONIO__";
5705 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5706 namesv = PAD_SVl(targ);
5707 SvUPGRADE(namesv, SVt_PV);
5709 sv_setpvn(namesv, "$", 1);
5710 sv_catpvn(namesv, name, len);
5713 kid->op_sibling = 0;
5714 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5715 kid->op_targ = targ;
5716 kid->op_private |= priv;
5718 kid->op_sibling = sibl;
5724 mod(scalar(kid), type);
5728 tokid = &kid->op_sibling;
5729 kid = kid->op_sibling;
5731 o->op_private |= numargs;
5733 return too_many_arguments(o,OP_DESC(o));
5736 else if (PL_opargs[type] & OA_DEFGV) {
5738 return newUNOP(type, 0, newDEFSVOP());
5742 while (oa & OA_OPTIONAL)
5744 if (oa && oa != OA_LIST)
5745 return too_few_arguments(o,OP_DESC(o));
5751 Perl_ck_glob(pTHX_ OP *o)
5757 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5758 append_elem(OP_GLOB, o, newDEFSVOP());
5760 if (!((gv = gv_fetchpv("glob", 0, SVt_PVCV))
5761 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5763 gv = gv_fetchpv("CORE::GLOBAL::glob", 0, SVt_PVCV);
5766 #if !defined(PERL_EXTERNAL_GLOB)
5767 /* XXX this can be tightened up and made more failsafe. */
5768 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5771 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5772 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5773 gv = gv_fetchpv("CORE::GLOBAL::glob", 0, SVt_PVCV);
5774 glob_gv = gv_fetchpv("File::Glob::csh_glob", 0, SVt_PVCV);
5775 GvCV(gv) = GvCV(glob_gv);
5776 (void)SvREFCNT_inc((SV*)GvCV(gv));
5777 GvIMPORTED_CV_on(gv);
5780 #endif /* PERL_EXTERNAL_GLOB */
5782 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5783 append_elem(OP_GLOB, o,
5784 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5785 o->op_type = OP_LIST;
5786 o->op_ppaddr = PL_ppaddr[OP_LIST];
5787 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5788 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5789 cLISTOPo->op_first->op_targ = 0;
5790 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5791 append_elem(OP_LIST, o,
5792 scalar(newUNOP(OP_RV2CV, 0,
5793 newGVOP(OP_GV, 0, gv)))));
5794 o = newUNOP(OP_NULL, 0, ck_subr(o));
5795 o->op_targ = OP_GLOB; /* hint at what it used to be */
5798 gv = newGVgen("main");
5800 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5806 Perl_ck_grep(pTHX_ OP *o)
5811 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5814 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5815 NewOp(1101, gwop, 1, LOGOP);
5817 if (o->op_flags & OPf_STACKED) {
5820 kid = cLISTOPo->op_first->op_sibling;
5821 if (!cUNOPx(kid)->op_next)
5822 Perl_croak(aTHX_ "panic: ck_grep");
5823 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
5826 kid->op_next = (OP*)gwop;
5827 o->op_flags &= ~OPf_STACKED;
5829 kid = cLISTOPo->op_first->op_sibling;
5830 if (type == OP_MAPWHILE)
5837 kid = cLISTOPo->op_first->op_sibling;
5838 if (kid->op_type != OP_NULL)
5839 Perl_croak(aTHX_ "panic: ck_grep");
5840 kid = kUNOP->op_first;
5842 gwop->op_type = type;
5843 gwop->op_ppaddr = PL_ppaddr[type];
5844 gwop->op_first = listkids(o);
5845 gwop->op_flags |= OPf_KIDS;
5846 gwop->op_other = LINKLIST(kid);
5847 kid->op_next = (OP*)gwop;
5848 offset = pad_findmy("$_");
5849 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
5850 o->op_private = gwop->op_private = 0;
5851 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5854 o->op_private = gwop->op_private = OPpGREP_LEX;
5855 gwop->op_targ = o->op_targ = offset;
5858 kid = cLISTOPo->op_first->op_sibling;
5859 if (!kid || !kid->op_sibling)
5860 return too_few_arguments(o,OP_DESC(o));
5861 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5862 mod(kid, OP_GREPSTART);
5868 Perl_ck_index(pTHX_ OP *o)
5870 if (o->op_flags & OPf_KIDS) {
5871 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5873 kid = kid->op_sibling; /* get past "big" */
5874 if (kid && kid->op_type == OP_CONST)
5875 fbm_compile(((SVOP*)kid)->op_sv, 0);
5881 Perl_ck_lengthconst(pTHX_ OP *o)
5883 /* XXX length optimization goes here */
5888 Perl_ck_lfun(pTHX_ OP *o)
5890 const OPCODE type = o->op_type;
5891 return modkids(ck_fun(o), type);
5895 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5897 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5898 switch (cUNOPo->op_first->op_type) {
5900 /* This is needed for
5901 if (defined %stash::)
5902 to work. Do not break Tk.
5904 break; /* Globals via GV can be undef */
5906 case OP_AASSIGN: /* Is this a good idea? */
5907 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5908 "defined(@array) is deprecated");
5909 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5910 "\t(Maybe you should just omit the defined()?)\n");
5913 /* This is needed for
5914 if (defined %stash::)
5915 to work. Do not break Tk.
5917 break; /* Globals via GV can be undef */
5919 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5920 "defined(%%hash) is deprecated");
5921 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5922 "\t(Maybe you should just omit the defined()?)\n");
5933 Perl_ck_rfun(pTHX_ OP *o)
5935 const OPCODE type = o->op_type;
5936 return refkids(ck_fun(o), type);
5940 Perl_ck_listiob(pTHX_ OP *o)
5944 kid = cLISTOPo->op_first;
5947 kid = cLISTOPo->op_first;
5949 if (kid->op_type == OP_PUSHMARK)
5950 kid = kid->op_sibling;
5951 if (kid && o->op_flags & OPf_STACKED)
5952 kid = kid->op_sibling;
5953 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5954 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5955 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5956 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5957 cLISTOPo->op_first->op_sibling = kid;
5958 cLISTOPo->op_last = kid;
5959 kid = kid->op_sibling;
5964 append_elem(o->op_type, o, newDEFSVOP());
5970 Perl_ck_say(pTHX_ OP *o)
5973 o->op_type = OP_PRINT;
5974 cLISTOPo->op_last = cLISTOPo->op_last->op_sibling
5975 = newSVOP(OP_CONST, 0, newSVpvn("\n", 1));
5980 Perl_ck_smartmatch(pTHX_ OP *o)
5982 if (0 == (o->op_flags & OPf_SPECIAL)) {
5983 OP *first = cBINOPo->op_first;
5984 OP *second = first->op_sibling;
5986 /* Implicitly take a reference to an array or hash */
5987 first->op_sibling = Nullop;
5988 first = cBINOPo->op_first = ref_array_or_hash(first);
5989 second = first->op_sibling = ref_array_or_hash(second);
5991 /* Implicitly take a reference to a regular expression */
5992 if (first->op_type == OP_MATCH) {
5993 first->op_type = OP_QR;
5994 first->op_ppaddr = PL_ppaddr[OP_QR];
5996 if (second->op_type == OP_MATCH) {
5997 second->op_type = OP_QR;
5998 second->op_ppaddr = PL_ppaddr[OP_QR];
6007 Perl_ck_sassign(pTHX_ OP *o)
6009 OP *kid = cLISTOPo->op_first;
6010 /* has a disposable target? */
6011 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6012 && !(kid->op_flags & OPf_STACKED)
6013 /* Cannot steal the second time! */
6014 && !(kid->op_private & OPpTARGET_MY))
6016 OP * const kkid = kid->op_sibling;
6018 /* Can just relocate the target. */
6019 if (kkid && kkid->op_type == OP_PADSV
6020 && !(kkid->op_private & OPpLVAL_INTRO))
6022 kid->op_targ = kkid->op_targ;
6024 /* Now we do not need PADSV and SASSIGN. */
6025 kid->op_sibling = o->op_sibling; /* NULL */
6026 cLISTOPo->op_first = NULL;
6029 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6037 Perl_ck_match(pTHX_ OP *o)
6039 if (o->op_type != OP_QR && PL_compcv) {
6040 const I32 offset = pad_findmy("$_");
6041 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS(offset) & SVpad_OUR)) {
6042 o->op_targ = offset;
6043 o->op_private |= OPpTARGET_MY;
6046 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
6047 o->op_private |= OPpRUNTIME;
6052 Perl_ck_method(pTHX_ OP *o)
6054 OP * const kid = cUNOPo->op_first;
6055 if (kid->op_type == OP_CONST) {
6056 SV* sv = kSVOP->op_sv;
6057 if (!(strchr(SvPVX_const(sv), ':') || strchr(SvPVX_const(sv), '\''))) {
6059 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6060 sv = newSVpvn_share(SvPVX_const(sv), SvCUR(sv), 0);
6063 kSVOP->op_sv = Nullsv;
6065 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6074 Perl_ck_null(pTHX_ OP *o)
6080 Perl_ck_open(pTHX_ OP *o)
6082 HV * const table = GvHV(PL_hintgv);
6084 SV **svp = hv_fetch(table, "open_IN", 7, FALSE);
6086 const I32 mode = mode_from_discipline(*svp);
6087 if (mode & O_BINARY)
6088 o->op_private |= OPpOPEN_IN_RAW;
6089 else if (mode & O_TEXT)
6090 o->op_private |= OPpOPEN_IN_CRLF;
6093 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6095 const I32 mode = mode_from_discipline(*svp);
6096 if (mode & O_BINARY)
6097 o->op_private |= OPpOPEN_OUT_RAW;
6098 else if (mode & O_TEXT)
6099 o->op_private |= OPpOPEN_OUT_CRLF;
6102 if (o->op_type == OP_BACKTICK)
6105 /* In case of three-arg dup open remove strictness
6106 * from the last arg if it is a bareword. */
6107 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
6108 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
6112 if ((last->op_type == OP_CONST) && /* The bareword. */
6113 (last->op_private & OPpCONST_BARE) &&
6114 (last->op_private & OPpCONST_STRICT) &&
6115 (oa = first->op_sibling) && /* The fh. */
6116 (oa = oa->op_sibling) && /* The mode. */
6117 (oa->op_type == OP_CONST) &&
6118 SvPOK(((SVOP*)oa)->op_sv) &&
6119 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
6120 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
6121 (last == oa->op_sibling)) /* The bareword. */
6122 last->op_private &= ~OPpCONST_STRICT;
6128 Perl_ck_repeat(pTHX_ OP *o)
6130 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6131 o->op_private |= OPpREPEAT_DOLIST;
6132 cBINOPo->op_first = force_list(cBINOPo->op_first);
6140 Perl_ck_require(pTHX_ OP *o)
6144 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6145 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6147 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6148 SV * const sv = kid->op_sv;
6149 U32 was_readonly = SvREADONLY(sv);
6154 sv_force_normal_flags(sv, 0);
6155 assert(!SvREADONLY(sv));
6162 for (s = SvPVX(sv); *s; s++) {
6163 if (*s == ':' && s[1] == ':') {
6164 const STRLEN len = strlen(s+2)+1;
6166 Move(s+2, s+1, len, char);
6167 SvCUR_set(sv, SvCUR(sv) - 1);
6170 sv_catpvn(sv, ".pm", 3);
6171 SvFLAGS(sv) |= was_readonly;
6175 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
6176 /* handle override, if any */
6177 gv = gv_fetchpv("require", 0, SVt_PVCV);
6178 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6179 GV * const * const gvp = (GV**)hv_fetch(PL_globalstash, "require", 7, FALSE);
6180 gv = gvp ? *gvp : Nullgv;
6184 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6185 OP * const kid = cUNOPo->op_first;
6186 cUNOPo->op_first = 0;
6188 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6189 append_elem(OP_LIST, kid,
6190 scalar(newUNOP(OP_RV2CV, 0,
6199 Perl_ck_return(pTHX_ OP *o)
6201 if (CvLVALUE(PL_compcv)) {
6203 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6204 mod(kid, OP_LEAVESUBLV);
6210 Perl_ck_select(pTHX_ OP *o)
6214 if (o->op_flags & OPf_KIDS) {
6215 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6216 if (kid && kid->op_sibling) {
6217 o->op_type = OP_SSELECT;
6218 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6220 return fold_constants(o);
6224 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6225 if (kid && kid->op_type == OP_RV2GV)
6226 kid->op_private &= ~HINT_STRICT_REFS;
6231 Perl_ck_shift(pTHX_ OP *o)
6233 const I32 type = o->op_type;
6235 if (!(o->op_flags & OPf_KIDS)) {
6239 argop = newUNOP(OP_RV2AV, 0,
6240 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
6241 return newUNOP(type, 0, scalar(argop));
6243 return scalar(modkids(ck_fun(o), type));
6247 Perl_ck_sort(pTHX_ OP *o)
6251 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0)
6253 HV *hinthv = GvHV(PL_hintgv);
6255 SV **svp = hv_fetch(hinthv, "sort", 4, 0);
6257 I32 sorthints = (I32)SvIV(*svp);
6258 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
6259 o->op_private |= OPpSORT_QSORT;
6260 if ((sorthints & HINT_SORT_STABLE) != 0)
6261 o->op_private |= OPpSORT_STABLE;
6266 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6268 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6269 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6271 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6273 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6275 if (kid->op_type == OP_SCOPE) {
6279 else if (kid->op_type == OP_LEAVE) {
6280 if (o->op_type == OP_SORT) {
6281 op_null(kid); /* wipe out leave */
6284 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6285 if (k->op_next == kid)
6287 /* don't descend into loops */
6288 else if (k->op_type == OP_ENTERLOOP
6289 || k->op_type == OP_ENTERITER)
6291 k = cLOOPx(k)->op_lastop;
6296 kid->op_next = 0; /* just disconnect the leave */
6297 k = kLISTOP->op_first;
6302 if (o->op_type == OP_SORT) {
6303 /* provide scalar context for comparison function/block */
6309 o->op_flags |= OPf_SPECIAL;
6311 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6314 firstkid = firstkid->op_sibling;
6317 /* provide list context for arguments */
6318 if (o->op_type == OP_SORT)
6325 S_simplify_sort(pTHX_ OP *o)
6327 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6332 if (!(o->op_flags & OPf_STACKED))
6334 GvMULTI_on(gv_fetchpv("a", GV_ADD, SVt_PV));
6335 GvMULTI_on(gv_fetchpv("b", GV_ADD, SVt_PV));
6336 kid = kUNOP->op_first; /* get past null */
6337 if (kid->op_type != OP_SCOPE)
6339 kid = kLISTOP->op_last; /* get past scope */
6340 switch(kid->op_type) {
6348 k = kid; /* remember this node*/
6349 if (kBINOP->op_first->op_type != OP_RV2SV)
6351 kid = kBINOP->op_first; /* get past cmp */
6352 if (kUNOP->op_first->op_type != OP_GV)
6354 kid = kUNOP->op_first; /* get past rv2sv */
6356 if (GvSTASH(gv) != PL_curstash)
6358 gvname = GvNAME(gv);
6359 if (*gvname == 'a' && gvname[1] == '\0')
6361 else if (*gvname == 'b' && gvname[1] == '\0')
6366 kid = k; /* back to cmp */
6367 if (kBINOP->op_last->op_type != OP_RV2SV)
6369 kid = kBINOP->op_last; /* down to 2nd arg */
6370 if (kUNOP->op_first->op_type != OP_GV)
6372 kid = kUNOP->op_first; /* get past rv2sv */
6374 if (GvSTASH(gv) != PL_curstash)
6376 gvname = GvNAME(gv);
6378 ? !(*gvname == 'a' && gvname[1] == '\0')
6379 : !(*gvname == 'b' && gvname[1] == '\0'))
6381 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6383 o->op_private |= OPpSORT_DESCEND;
6384 if (k->op_type == OP_NCMP)
6385 o->op_private |= OPpSORT_NUMERIC;
6386 if (k->op_type == OP_I_NCMP)
6387 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6388 kid = cLISTOPo->op_first->op_sibling;
6389 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6390 op_free(kid); /* then delete it */
6394 Perl_ck_split(pTHX_ OP *o)
6399 if (o->op_flags & OPf_STACKED)
6400 return no_fh_allowed(o);
6402 kid = cLISTOPo->op_first;
6403 if (kid->op_type != OP_NULL)
6404 Perl_croak(aTHX_ "panic: ck_split");
6405 kid = kid->op_sibling;
6406 op_free(cLISTOPo->op_first);
6407 cLISTOPo->op_first = kid;
6409 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6410 cLISTOPo->op_last = kid; /* There was only one element previously */
6413 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6414 OP * const sibl = kid->op_sibling;
6415 kid->op_sibling = 0;
6416 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
6417 if (cLISTOPo->op_first == cLISTOPo->op_last)
6418 cLISTOPo->op_last = kid;
6419 cLISTOPo->op_first = kid;
6420 kid->op_sibling = sibl;
6423 kid->op_type = OP_PUSHRE;
6424 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6426 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
6427 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
6428 "Use of /g modifier is meaningless in split");
6431 if (!kid->op_sibling)
6432 append_elem(OP_SPLIT, o, newDEFSVOP());
6434 kid = kid->op_sibling;
6437 if (!kid->op_sibling)
6438 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6440 kid = kid->op_sibling;
6443 if (kid->op_sibling)
6444 return too_many_arguments(o,OP_DESC(o));
6450 Perl_ck_join(pTHX_ OP *o)
6452 const OP * const kid = cLISTOPo->op_first->op_sibling;
6453 if (kid && kid->op_type == OP_MATCH) {
6454 if (ckWARN(WARN_SYNTAX)) {
6455 const REGEXP *re = PM_GETRE(kPMOP);
6456 const char *pmstr = re ? re->precomp : "STRING";
6457 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6458 "/%s/ should probably be written as \"%s\"",
6466 Perl_ck_subr(pTHX_ OP *o)
6468 OP *prev = ((cUNOPo->op_first->op_sibling)
6469 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6470 OP *o2 = prev->op_sibling;
6477 I32 contextclass = 0;
6481 o->op_private |= OPpENTERSUB_HASTARG;
6482 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6483 if (cvop->op_type == OP_RV2CV) {
6485 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6486 op_null(cvop); /* disable rv2cv */
6487 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6488 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6489 GV *gv = cGVOPx_gv(tmpop);
6492 tmpop->op_private |= OPpEARLY_CV;
6495 namegv = CvANON(cv) ? gv : CvGV(cv);
6496 proto = SvPV_nolen((SV*)cv);
6498 if (CvASSERTION(cv)) {
6499 if (PL_hints & HINT_ASSERTING) {
6500 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
6501 o->op_private |= OPpENTERSUB_DB;
6505 if (!(PL_hints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
6506 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
6507 "Impossible to activate assertion call");
6514 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6515 if (o2->op_type == OP_CONST)
6516 o2->op_private &= ~OPpCONST_STRICT;
6517 else if (o2->op_type == OP_LIST) {
6518 OP * const o = ((UNOP*)o2)->op_first->op_sibling;
6519 if (o && o->op_type == OP_CONST)
6520 o->op_private &= ~OPpCONST_STRICT;
6523 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6524 if (PERLDB_SUB && PL_curstash != PL_debstash)
6525 o->op_private |= OPpENTERSUB_DB;
6526 while (o2 != cvop) {
6530 return too_many_arguments(o, gv_ename(namegv));
6548 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6550 arg == 1 ? "block or sub {}" : "sub {}",
6551 gv_ename(namegv), o2);
6554 /* '*' allows any scalar type, including bareword */
6557 if (o2->op_type == OP_RV2GV)
6558 goto wrapref; /* autoconvert GLOB -> GLOBref */
6559 else if (o2->op_type == OP_CONST)
6560 o2->op_private &= ~OPpCONST_STRICT;
6561 else if (o2->op_type == OP_ENTERSUB) {
6562 /* accidental subroutine, revert to bareword */
6563 OP *gvop = ((UNOP*)o2)->op_first;
6564 if (gvop && gvop->op_type == OP_NULL) {
6565 gvop = ((UNOP*)gvop)->op_first;
6567 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6570 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6571 (gvop = ((UNOP*)gvop)->op_first) &&
6572 gvop->op_type == OP_GV)
6574 GV * const gv = cGVOPx_gv(gvop);
6575 OP * const sibling = o2->op_sibling;
6576 SV * const n = newSVpvn("",0);
6578 gv_fullname4(n, gv, "", FALSE);
6579 o2 = newSVOP(OP_CONST, 0, n);
6580 prev->op_sibling = o2;
6581 o2->op_sibling = sibling;
6597 if (contextclass++ == 0) {
6598 e = strchr(proto, ']');
6599 if (!e || e == proto)
6608 /* XXX We shouldn't be modifying proto, so we can const proto */
6613 while (*--p != '[');
6614 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6615 gv_ename(namegv), o2);
6621 if (o2->op_type == OP_RV2GV)
6624 bad_type(arg, "symbol", gv_ename(namegv), o2);
6627 if (o2->op_type == OP_ENTERSUB)
6630 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6633 if (o2->op_type == OP_RV2SV ||
6634 o2->op_type == OP_PADSV ||
6635 o2->op_type == OP_HELEM ||
6636 o2->op_type == OP_AELEM ||
6637 o2->op_type == OP_THREADSV)
6640 bad_type(arg, "scalar", gv_ename(namegv), o2);
6643 if (o2->op_type == OP_RV2AV ||
6644 o2->op_type == OP_PADAV)
6647 bad_type(arg, "array", gv_ename(namegv), o2);
6650 if (o2->op_type == OP_RV2HV ||
6651 o2->op_type == OP_PADHV)
6654 bad_type(arg, "hash", gv_ename(namegv), o2);
6659 OP* const sib = kid->op_sibling;
6660 kid->op_sibling = 0;
6661 o2 = newUNOP(OP_REFGEN, 0, kid);
6662 o2->op_sibling = sib;
6663 prev->op_sibling = o2;
6665 if (contextclass && e) {
6680 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6681 gv_ename(namegv), cv);
6686 mod(o2, OP_ENTERSUB);
6688 o2 = o2->op_sibling;
6690 if (proto && !optional &&
6691 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6692 return too_few_arguments(o, gv_ename(namegv));
6695 o=newSVOP(OP_CONST, 0, newSViv(0));
6701 Perl_ck_svconst(pTHX_ OP *o)
6703 SvREADONLY_on(cSVOPo->op_sv);
6708 Perl_ck_trunc(pTHX_ OP *o)
6710 if (o->op_flags & OPf_KIDS) {
6711 SVOP *kid = (SVOP*)cUNOPo->op_first;
6713 if (kid->op_type == OP_NULL)
6714 kid = (SVOP*)kid->op_sibling;
6715 if (kid && kid->op_type == OP_CONST &&
6716 (kid->op_private & OPpCONST_BARE))
6718 o->op_flags |= OPf_SPECIAL;
6719 kid->op_private &= ~OPpCONST_STRICT;
6726 Perl_ck_unpack(pTHX_ OP *o)
6728 OP *kid = cLISTOPo->op_first;
6729 if (kid->op_sibling) {
6730 kid = kid->op_sibling;
6731 if (!kid->op_sibling)
6732 kid->op_sibling = newDEFSVOP();
6738 Perl_ck_substr(pTHX_ OP *o)
6741 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6742 OP *kid = cLISTOPo->op_first;
6744 if (kid->op_type == OP_NULL)
6745 kid = kid->op_sibling;
6747 kid->op_flags |= OPf_MOD;
6753 /* A peephole optimizer. We visit the ops in the order they're to execute.
6754 * See the comments at the top of this file for more details about when
6755 * peep() is called */
6758 Perl_peep(pTHX_ register OP *o)
6761 register OP* oldop = NULL;
6763 if (!o || o->op_opt)
6767 SAVEVPTR(PL_curcop);
6768 for (; o; o = o->op_next) {
6772 switch (o->op_type) {
6776 PL_curcop = ((COP*)o); /* for warnings */
6781 if (cSVOPo->op_private & OPpCONST_STRICT)
6782 no_bareword_allowed(o);
6784 case OP_METHOD_NAMED:
6785 /* Relocate sv to the pad for thread safety.
6786 * Despite being a "constant", the SV is written to,
6787 * for reference counts, sv_upgrade() etc. */
6789 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6790 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6791 /* If op_sv is already a PADTMP then it is being used by
6792 * some pad, so make a copy. */
6793 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6794 SvREADONLY_on(PAD_SVl(ix));
6795 SvREFCNT_dec(cSVOPo->op_sv);
6798 SvREFCNT_dec(PAD_SVl(ix));
6799 SvPADTMP_on(cSVOPo->op_sv);
6800 PAD_SETSV(ix, cSVOPo->op_sv);
6801 /* XXX I don't know how this isn't readonly already. */
6802 SvREADONLY_on(PAD_SVl(ix));
6804 cSVOPo->op_sv = Nullsv;
6812 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6813 if (o->op_next->op_private & OPpTARGET_MY) {
6814 if (o->op_flags & OPf_STACKED) /* chained concats */
6815 goto ignore_optimization;
6817 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6818 o->op_targ = o->op_next->op_targ;
6819 o->op_next->op_targ = 0;
6820 o->op_private |= OPpTARGET_MY;
6823 op_null(o->op_next);
6825 ignore_optimization:
6829 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6831 break; /* Scalar stub must produce undef. List stub is noop */
6835 if (o->op_targ == OP_NEXTSTATE
6836 || o->op_targ == OP_DBSTATE
6837 || o->op_targ == OP_SETSTATE)
6839 PL_curcop = ((COP*)o);
6841 /* XXX: We avoid setting op_seq here to prevent later calls
6842 to peep() from mistakenly concluding that optimisation
6843 has already occurred. This doesn't fix the real problem,
6844 though (See 20010220.007). AMS 20010719 */
6845 /* op_seq functionality is now replaced by op_opt */
6846 if (oldop && o->op_next) {
6847 oldop->op_next = o->op_next;
6855 if (oldop && o->op_next) {
6856 oldop->op_next = o->op_next;
6864 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
6865 OP* const pop = (o->op_type == OP_PADAV) ?
6866 o->op_next : o->op_next->op_next;
6868 if (pop && pop->op_type == OP_CONST &&
6869 ((PL_op = pop->op_next)) &&
6870 pop->op_next->op_type == OP_AELEM &&
6871 !(pop->op_next->op_private &
6872 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6873 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6878 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
6879 no_bareword_allowed(pop);
6880 if (o->op_type == OP_GV)
6881 op_null(o->op_next);
6882 op_null(pop->op_next);
6884 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6885 o->op_next = pop->op_next->op_next;
6886 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6887 o->op_private = (U8)i;
6888 if (o->op_type == OP_GV) {
6893 o->op_flags |= OPf_SPECIAL;
6894 o->op_type = OP_AELEMFAST;
6900 if (o->op_next->op_type == OP_RV2SV) {
6901 if (!(o->op_next->op_private & OPpDEREF)) {
6902 op_null(o->op_next);
6903 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6905 o->op_next = o->op_next->op_next;
6906 o->op_type = OP_GVSV;
6907 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6910 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6911 GV * const gv = cGVOPo_gv;
6912 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
6913 /* XXX could check prototype here instead of just carping */
6914 SV * const sv = sv_newmortal();
6915 gv_efullname3(sv, gv, Nullch);
6916 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6917 "%"SVf"() called too early to check prototype",
6921 else if (o->op_next->op_type == OP_READLINE
6922 && o->op_next->op_next->op_type == OP_CONCAT
6923 && (o->op_next->op_next->op_flags & OPf_STACKED))
6925 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6926 o->op_type = OP_RCATLINE;
6927 o->op_flags |= OPf_STACKED;
6928 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6929 op_null(o->op_next->op_next);
6930 op_null(o->op_next);
6947 while (cLOGOP->op_other->op_type == OP_NULL)
6948 cLOGOP->op_other = cLOGOP->op_other->op_next;
6949 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6955 while (cLOOP->op_redoop->op_type == OP_NULL)
6956 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6957 peep(cLOOP->op_redoop);
6958 while (cLOOP->op_nextop->op_type == OP_NULL)
6959 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6960 peep(cLOOP->op_nextop);
6961 while (cLOOP->op_lastop->op_type == OP_NULL)
6962 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6963 peep(cLOOP->op_lastop);
6970 while (cPMOP->op_pmreplstart &&
6971 cPMOP->op_pmreplstart->op_type == OP_NULL)
6972 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6973 peep(cPMOP->op_pmreplstart);
6978 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
6979 && ckWARN(WARN_SYNTAX))
6981 if (o->op_next->op_sibling &&
6982 o->op_next->op_sibling->op_type != OP_EXIT &&
6983 o->op_next->op_sibling->op_type != OP_WARN &&
6984 o->op_next->op_sibling->op_type != OP_DIE) {
6985 const line_t oldline = CopLINE(PL_curcop);
6987 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6988 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6989 "Statement unlikely to be reached");
6990 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6991 "\t(Maybe you meant system() when you said exec()?)\n");
6992 CopLINE_set(PL_curcop, oldline);
7002 const char *key = NULL;
7007 if (((BINOP*)o)->op_last->op_type != OP_CONST)
7010 /* Make the CONST have a shared SV */
7011 svp = cSVOPx_svp(((BINOP*)o)->op_last);
7012 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7013 key = SvPV_const(sv, keylen);
7014 lexname = newSVpvn_share(key,
7015 SvUTF8(sv) ? -(I32)keylen : keylen,
7021 if ((o->op_private & (OPpLVAL_INTRO)))
7024 rop = (UNOP*)((BINOP*)o)->op_first;
7025 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7027 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7028 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7030 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7031 if (!fields || !GvHV(*fields))
7033 key = SvPV_const(*svp, keylen);
7034 if (!hv_fetch(GvHV(*fields), key,
7035 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
7037 Perl_croak(aTHX_ "No such class field \"%s\" "
7038 "in variable %s of type %s",
7039 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
7052 SVOP *first_key_op, *key_op;
7054 if ((o->op_private & (OPpLVAL_INTRO))
7055 /* I bet there's always a pushmark... */
7056 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7057 /* hmmm, no optimization if list contains only one key. */
7059 rop = (UNOP*)((LISTOP*)o)->op_last;
7060 if (rop->op_type != OP_RV2HV)
7062 if (rop->op_first->op_type == OP_PADSV)
7063 /* @$hash{qw(keys here)} */
7064 rop = (UNOP*)rop->op_first;
7066 /* @{$hash}{qw(keys here)} */
7067 if (rop->op_first->op_type == OP_SCOPE
7068 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
7070 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
7076 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
7077 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7079 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7080 if (!fields || !GvHV(*fields))
7082 /* Again guessing that the pushmark can be jumped over.... */
7083 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7084 ->op_first->op_sibling;
7085 for (key_op = first_key_op; key_op;
7086 key_op = (SVOP*)key_op->op_sibling) {
7087 if (key_op->op_type != OP_CONST)
7089 svp = cSVOPx_svp(key_op);
7090 key = SvPV_const(*svp, keylen);
7091 if (!hv_fetch(GvHV(*fields), key,
7092 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
7094 Perl_croak(aTHX_ "No such class field \"%s\" "
7095 "in variable %s of type %s",
7096 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
7103 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
7107 /* check that RHS of sort is a single plain array */
7108 OP *oright = cUNOPo->op_first;
7109 if (!oright || oright->op_type != OP_PUSHMARK)
7112 /* reverse sort ... can be optimised. */
7113 if (!cUNOPo->op_sibling) {
7114 /* Nothing follows us on the list. */
7115 OP * const reverse = o->op_next;
7117 if (reverse->op_type == OP_REVERSE &&
7118 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
7119 OP * const pushmark = cUNOPx(reverse)->op_first;
7120 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
7121 && (cUNOPx(pushmark)->op_sibling == o)) {
7122 /* reverse -> pushmark -> sort */
7123 o->op_private |= OPpSORT_REVERSE;
7125 pushmark->op_next = oright->op_next;
7131 /* make @a = sort @a act in-place */
7135 oright = cUNOPx(oright)->op_sibling;
7138 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
7139 oright = cUNOPx(oright)->op_sibling;
7143 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
7144 || oright->op_next != o
7145 || (oright->op_private & OPpLVAL_INTRO)
7149 /* o2 follows the chain of op_nexts through the LHS of the
7150 * assign (if any) to the aassign op itself */
7152 if (!o2 || o2->op_type != OP_NULL)
7155 if (!o2 || o2->op_type != OP_PUSHMARK)
7158 if (o2 && o2->op_type == OP_GV)
7161 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
7162 || (o2->op_private & OPpLVAL_INTRO)
7167 if (!o2 || o2->op_type != OP_NULL)
7170 if (!o2 || o2->op_type != OP_AASSIGN
7171 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
7174 /* check that the sort is the first arg on RHS of assign */
7176 o2 = cUNOPx(o2)->op_first;
7177 if (!o2 || o2->op_type != OP_NULL)
7179 o2 = cUNOPx(o2)->op_first;
7180 if (!o2 || o2->op_type != OP_PUSHMARK)
7182 if (o2->op_sibling != o)
7185 /* check the array is the same on both sides */
7186 if (oleft->op_type == OP_RV2AV) {
7187 if (oright->op_type != OP_RV2AV
7188 || !cUNOPx(oright)->op_first
7189 || cUNOPx(oright)->op_first->op_type != OP_GV
7190 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
7191 cGVOPx_gv(cUNOPx(oright)->op_first)
7195 else if (oright->op_type != OP_PADAV
7196 || oright->op_targ != oleft->op_targ
7200 /* transfer MODishness etc from LHS arg to RHS arg */
7201 oright->op_flags = oleft->op_flags;
7202 o->op_private |= OPpSORT_INPLACE;
7204 /* excise push->gv->rv2av->null->aassign */
7205 o2 = o->op_next->op_next;
7206 op_null(o2); /* PUSHMARK */
7208 if (o2->op_type == OP_GV) {
7209 op_null(o2); /* GV */
7212 op_null(o2); /* RV2AV or PADAV */
7213 o2 = o2->op_next->op_next;
7214 op_null(o2); /* AASSIGN */
7216 o->op_next = o2->op_next;
7222 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
7224 LISTOP *enter, *exlist;
7227 enter = (LISTOP *) o->op_next;
7230 if (enter->op_type == OP_NULL) {
7231 enter = (LISTOP *) enter->op_next;
7235 /* for $a (...) will have OP_GV then OP_RV2GV here.
7236 for (...) just has an OP_GV. */
7237 if (enter->op_type == OP_GV) {
7238 gvop = (OP *) enter;
7239 enter = (LISTOP *) enter->op_next;
7242 if (enter->op_type == OP_RV2GV) {
7243 enter = (LISTOP *) enter->op_next;
7249 if (enter->op_type != OP_ENTERITER)
7252 iter = enter->op_next;
7253 if (!iter || iter->op_type != OP_ITER)
7256 expushmark = enter->op_first;
7257 if (!expushmark || expushmark->op_type != OP_NULL
7258 || expushmark->op_targ != OP_PUSHMARK)
7261 exlist = (LISTOP *) expushmark->op_sibling;
7262 if (!exlist || exlist->op_type != OP_NULL
7263 || exlist->op_targ != OP_LIST)
7266 if (exlist->op_last != o) {
7267 /* Mmm. Was expecting to point back to this op. */
7270 theirmark = exlist->op_first;
7271 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
7274 if (theirmark->op_sibling != o) {
7275 /* There's something between the mark and the reverse, eg
7276 for (1, reverse (...))
7281 ourmark = ((LISTOP *)o)->op_first;
7282 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
7285 ourlast = ((LISTOP *)o)->op_last;
7286 if (!ourlast || ourlast->op_next != o)
7289 rv2av = ourmark->op_sibling;
7290 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
7291 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
7292 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
7293 /* We're just reversing a single array. */
7294 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
7295 enter->op_flags |= OPf_STACKED;
7298 /* We don't have control over who points to theirmark, so sacrifice
7300 theirmark->op_next = ourmark->op_next;
7301 theirmark->op_flags = ourmark->op_flags;
7302 ourlast->op_next = gvop ? gvop : (OP *) enter;
7305 enter->op_private |= OPpITER_REVERSED;
7306 iter->op_private |= OPpITER_REVERSED;
7313 UNOP *refgen, *rv2cv;
7316 /* I do not understand this, but if o->op_opt isn't set to 1,
7317 various tests in ext/B/t/bytecode.t fail with no readily
7323 if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID)
7326 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
7329 rv2gv = ((BINOP *)o)->op_last;
7330 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
7333 refgen = (UNOP *)((BINOP *)o)->op_first;
7335 if (!refgen || refgen->op_type != OP_REFGEN)
7338 exlist = (LISTOP *)refgen->op_first;
7339 if (!exlist || exlist->op_type != OP_NULL
7340 || exlist->op_targ != OP_LIST)
7343 if (exlist->op_first->op_type != OP_PUSHMARK)
7346 rv2cv = (UNOP*)exlist->op_last;
7348 if (rv2cv->op_type != OP_RV2CV)
7351 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
7352 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
7353 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
7355 o->op_private |= OPpASSIGN_CV_TO_GV;
7356 rv2gv->op_private |= OPpDONT_INIT_GV;
7357 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
7373 Perl_custom_op_name(pTHX_ const OP* o)
7375 const IV index = PTR2IV(o->op_ppaddr);
7379 if (!PL_custom_op_names) /* This probably shouldn't happen */
7380 return (char *)PL_op_name[OP_CUSTOM];
7382 keysv = sv_2mortal(newSViv(index));
7384 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7386 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7388 return SvPV_nolen(HeVAL(he));
7392 Perl_custom_op_desc(pTHX_ const OP* o)
7394 const IV index = PTR2IV(o->op_ppaddr);
7398 if (!PL_custom_op_descs)
7399 return (char *)PL_op_desc[OP_CUSTOM];
7401 keysv = sv_2mortal(newSViv(index));
7403 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7405 return (char *)PL_op_desc[OP_CUSTOM];
7407 return SvPV_nolen(HeVAL(he));
7412 /* Efficient sub that returns a constant scalar value. */
7414 const_sv_xsub(pTHX_ CV* cv)
7419 Perl_croak(aTHX_ "usage: %s::%s()",
7420 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7424 ST(0) = (SV*)XSANY.any_ptr;
7430 * c-indentation-style: bsd
7432 * indent-tabs-mode: t
7435 * ex: set ts=8 sts=4 sw=4 noet: