3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
13 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
14 * youngest of the Old Took's daughters); and Mr. Drogo was his second
15 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
16 * either way, as the saying is, if you follow me." --the Gaffer
19 /* This file contains the functions that create, manipulate and optimize
20 * the OP structures that hold a compiled perl program.
22 * A Perl program is compiled into a tree of OPs. Each op contains
23 * structural pointers (eg to its siblings and the next op in the
24 * execution sequence), a pointer to the function that would execute the
25 * op, plus any data specific to that op. For example, an OP_CONST op
26 * points to the pp_const() function and to an SV containing the constant
27 * value. When pp_const() is executed, its job is to push that SV onto the
30 * OPs are mainly created by the newFOO() functions, which are mainly
31 * called from the parser (in perly.y) as the code is parsed. For example
32 * the Perl code $a + $b * $c would cause the equivalent of the following
33 * to be called (oversimplifying a bit):
35 * newBINOP(OP_ADD, flags,
37 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
40 * Note that during the build of miniperl, a temporary copy of this file
41 * is made, called opmini.c.
45 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
49 An execution-order pass
51 The bottom-up pass is represented by all the "newOP" routines and
52 the ck_ routines. The bottom-upness is actually driven by yacc.
53 So at the point that a ck_ routine fires, we have no idea what the
54 context is, either upward in the syntax tree, or either forward or
55 backward in the execution order. (The bottom-up parser builds that
56 part of the execution order it knows about, but if you follow the "next"
57 links around, you'll find it's actually a closed loop through the
60 Whenever the bottom-up parser gets to a node that supplies context to
61 its components, it invokes that portion of the top-down pass that applies
62 to that part of the subtree (and marks the top node as processed, so
63 if a node further up supplies context, it doesn't have to take the
64 plunge again). As a particular subcase of this, as the new node is
65 built, it takes all the closed execution loops of its subcomponents
66 and links them into a new closed loop for the higher level node. But
67 it's still not the real execution order.
69 The actual execution order is not known till we get a grammar reduction
70 to a top-level unit like a subroutine or file that will be called by
71 "name" rather than via a "next" pointer. At that point, we can call
72 into peep() to do that code's portion of the 3rd pass. It has to be
73 recursive, but it's recursive on basic blocks, not on tree nodes.
81 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
83 #if defined(PL_OP_SLAB_ALLOC)
85 #ifndef PERL_SLAB_SIZE
86 #define PERL_SLAB_SIZE 2048
90 Perl_Slab_Alloc(pTHX_ int m, size_t sz)
93 * To make incrementing use count easy PL_OpSlab is an I32 *
94 * To make inserting the link to slab PL_OpPtr is I32 **
95 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
96 * Add an overhead for pointer to slab and round up as a number of pointers
98 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
99 if ((PL_OpSpace -= sz) < 0) {
100 PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*));
104 Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **);
105 /* We reserve the 0'th I32 sized chunk as a use count */
106 PL_OpSlab = (I32 *) PL_OpPtr;
107 /* Reduce size by the use count word, and by the size we need.
108 * Latter is to mimic the '-=' in the if() above
110 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
111 /* Allocation pointer starts at the top.
112 Theory: because we build leaves before trunk allocating at end
113 means that at run time access is cache friendly upward
115 PL_OpPtr += PERL_SLAB_SIZE;
117 assert( PL_OpSpace >= 0 );
118 /* Move the allocation pointer down */
120 assert( PL_OpPtr > (I32 **) PL_OpSlab );
121 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
122 (*PL_OpSlab)++; /* Increment use count of slab */
123 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
124 assert( *PL_OpSlab > 0 );
125 return (void *)(PL_OpPtr + 1);
129 Perl_Slab_Free(pTHX_ void *op)
131 I32 **ptr = (I32 **) op;
133 assert( ptr-1 > (I32 **) slab );
134 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
136 if (--(*slab) == 0) {
138 # define PerlMemShared PerlMem
141 PerlMemShared_free(slab);
142 if (slab == PL_OpSlab) {
149 * In the following definition, the ", Nullop" is just to make the compiler
150 * think the expression is of the right type: croak actually does a Siglongjmp.
152 #define CHECKOP(type,o) \
153 ((PL_op_mask && PL_op_mask[type]) \
154 ? ( op_free((OP*)o), \
155 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
157 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
159 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
162 S_gv_ename(pTHX_ GV *gv)
165 SV* tmpsv = sv_newmortal();
166 gv_efullname3(tmpsv, gv, Nullch);
167 return SvPV(tmpsv,n_a);
171 S_no_fh_allowed(pTHX_ OP *o)
173 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
179 S_too_few_arguments(pTHX_ OP *o, const char *name)
181 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
186 S_too_many_arguments(pTHX_ OP *o, const char *name)
188 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
193 S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
195 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
196 (int)n, name, t, OP_DESC(kid)));
200 S_no_bareword_allowed(pTHX_ const OP *o)
202 qerror(Perl_mess(aTHX_
203 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
207 /* "register" allocation */
210 Perl_allocmy(pTHX_ char *name)
214 /* complain about "my $<special_var>" etc etc */
215 if (!(PL_in_my == KEY_our ||
217 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
218 (name[1] == '_' && (*name == '$' || (int)strlen(name) > 2))))
220 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
221 /* 1999-02-27 mjd@plover.com */
223 p = strchr(name, '\0');
224 /* The next block assumes the buffer is at least 205 chars
225 long. At present, it's always at least 256 chars. */
227 strcpy(name+200, "...");
233 /* Move everything else down one character */
234 for (; p-name > 2; p--)
236 name[2] = toCTRL(name[1]);
239 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
242 /* check for duplicate declaration */
244 (bool)(PL_in_my == KEY_our),
245 (PL_curstash ? PL_curstash : PL_defstash)
248 if (PL_in_my_stash && *name != '$') {
249 yyerror(Perl_form(aTHX_
250 "Can't declare class for non-scalar %s in \"%s\"",
251 name, PL_in_my == KEY_our ? "our" : "my"));
254 /* allocate a spare slot and store the name in that slot */
256 off = pad_add_name(name,
259 /* $_ is always in main::, even with our */
260 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
271 Perl_op_free(pTHX_ OP *o)
277 if (!o || o->op_static)
280 if (o->op_private & OPpREFCOUNTED) {
281 switch (o->op_type) {
289 refcnt = OpREFCNT_dec(o);
299 if (o->op_flags & OPf_KIDS) {
300 register OP *kid, *nextkid;
301 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
302 nextkid = kid->op_sibling; /* Get before next freeing kid */
308 type = (OPCODE)o->op_targ;
310 /* COP* is not cleared by op_clear() so that we may track line
311 * numbers etc even after null() */
312 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
317 #ifdef DEBUG_LEAKING_SCALARS
324 Perl_op_clear(pTHX_ OP *o)
328 switch (o->op_type) {
329 case OP_NULL: /* Was holding old type, if any. */
330 case OP_ENTEREVAL: /* Was holding hints. */
334 if (!(o->op_flags & OPf_REF)
335 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
341 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
342 /* not an OP_PADAV replacement */
344 if (cPADOPo->op_padix > 0) {
345 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
346 * may still exist on the pad */
347 pad_swipe(cPADOPo->op_padix, TRUE);
348 cPADOPo->op_padix = 0;
351 SvREFCNT_dec(cSVOPo->op_sv);
352 cSVOPo->op_sv = Nullsv;
356 case OP_METHOD_NAMED:
358 SvREFCNT_dec(cSVOPo->op_sv);
359 cSVOPo->op_sv = Nullsv;
362 Even if op_clear does a pad_free for the target of the op,
363 pad_free doesn't actually remove the sv that exists in the pad;
364 instead it lives on. This results in that it could be reused as
365 a target later on when the pad was reallocated.
368 pad_swipe(o->op_targ,1);
377 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
381 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
382 SvREFCNT_dec(cSVOPo->op_sv);
383 cSVOPo->op_sv = Nullsv;
386 Safefree(cPVOPo->op_pv);
387 cPVOPo->op_pv = Nullch;
391 op_free(cPMOPo->op_pmreplroot);
395 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
396 /* No GvIN_PAD_off here, because other references may still
397 * exist on the pad */
398 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
401 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
408 HV *pmstash = PmopSTASH(cPMOPo);
409 if (pmstash && SvREFCNT(pmstash)) {
410 MAGIC *mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab);
412 PMOP *pmop = (PMOP*) mg->mg_obj;
413 PMOP *lastpmop = NULL;
415 if (cPMOPo == pmop) {
417 lastpmop->op_pmnext = pmop->op_pmnext;
419 mg->mg_obj = (SV*) pmop->op_pmnext;
423 pmop = pmop->op_pmnext;
427 PmopSTASH_free(cPMOPo);
429 cPMOPo->op_pmreplroot = Nullop;
430 /* we use the "SAFE" version of the PM_ macros here
431 * since sv_clean_all might release some PMOPs
432 * after PL_regex_padav has been cleared
433 * and the clearing of PL_regex_padav needs to
434 * happen before sv_clean_all
436 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
437 PM_SETRE_SAFE(cPMOPo, (REGEXP*)NULL);
439 if(PL_regex_pad) { /* We could be in destruction */
440 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
441 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
442 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
449 if (o->op_targ > 0) {
450 pad_free(o->op_targ);
456 S_cop_free(pTHX_ COP* cop)
458 Safefree(cop->cop_label); /* FIXME: treaddead ??? */
461 if (! specialWARN(cop->cop_warnings))
462 SvREFCNT_dec(cop->cop_warnings);
463 if (! specialCopIO(cop->cop_io)) {
467 char *s = SvPV(cop->cop_io,len);
468 Perl_warn(aTHX_ "io='%.*s'",(int) len,s); /* ??? --jhi */
471 SvREFCNT_dec(cop->cop_io);
477 Perl_op_null(pTHX_ OP *o)
480 if (o->op_type == OP_NULL)
483 o->op_targ = o->op_type;
484 o->op_type = OP_NULL;
485 o->op_ppaddr = PL_ppaddr[OP_NULL];
489 Perl_op_refcnt_lock(pTHX)
496 Perl_op_refcnt_unlock(pTHX)
502 /* Contextualizers */
504 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
507 Perl_linklist(pTHX_ OP *o)
513 /* establish postfix order */
514 if (cUNOPo->op_first) {
516 o->op_next = LINKLIST(cUNOPo->op_first);
517 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
519 kid->op_next = LINKLIST(kid->op_sibling);
531 Perl_scalarkids(pTHX_ OP *o)
533 if (o && o->op_flags & OPf_KIDS) {
535 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
542 S_scalarboolean(pTHX_ OP *o)
544 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
545 if (ckWARN(WARN_SYNTAX)) {
546 const line_t oldline = CopLINE(PL_curcop);
548 if (PL_copline != NOLINE)
549 CopLINE_set(PL_curcop, PL_copline);
550 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
551 CopLINE_set(PL_curcop, oldline);
558 Perl_scalar(pTHX_ OP *o)
563 /* assumes no premature commitment */
564 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
565 || o->op_type == OP_RETURN)
570 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
572 switch (o->op_type) {
574 scalar(cBINOPo->op_first);
579 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
583 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
584 if (!kPMOP->op_pmreplroot)
585 deprecate_old("implicit split to @_");
593 if (o->op_flags & OPf_KIDS) {
594 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
600 kid = cLISTOPo->op_first;
602 while ((kid = kid->op_sibling)) {
608 WITH_THR(PL_curcop = &PL_compiling);
613 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
619 WITH_THR(PL_curcop = &PL_compiling);
622 if (ckWARN(WARN_VOID))
623 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
629 Perl_scalarvoid(pTHX_ OP *o)
633 const char* useless = 0;
637 if (o->op_type == OP_NEXTSTATE
638 || o->op_type == OP_SETSTATE
639 || o->op_type == OP_DBSTATE
640 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
641 || o->op_targ == OP_SETSTATE
642 || o->op_targ == OP_DBSTATE)))
643 PL_curcop = (COP*)o; /* for warning below */
645 /* assumes no premature commitment */
646 want = o->op_flags & OPf_WANT;
647 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
648 || o->op_type == OP_RETURN)
653 if ((o->op_private & OPpTARGET_MY)
654 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
656 return scalar(o); /* As if inside SASSIGN */
659 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
661 switch (o->op_type) {
663 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
667 if (o->op_flags & OPf_STACKED)
671 if (o->op_private == 4)
743 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
744 useless = OP_DESC(o);
748 kid = cUNOPo->op_first;
749 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
750 kid->op_type != OP_TRANS) {
753 useless = "negative pattern binding (!~)";
760 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
761 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
762 useless = "a variable";
767 if (cSVOPo->op_private & OPpCONST_STRICT)
768 no_bareword_allowed(o);
770 if (ckWARN(WARN_VOID)) {
771 useless = "a constant";
772 /* don't warn on optimised away booleans, eg
773 * use constant Foo, 5; Foo || print; */
774 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
776 /* the constants 0 and 1 are permitted as they are
777 conventionally used as dummies in constructs like
778 1 while some_condition_with_side_effects; */
779 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
781 else if (SvPOK(sv)) {
782 /* perl4's way of mixing documentation and code
783 (before the invention of POD) was based on a
784 trick to mix nroff and perl code. The trick was
785 built upon these three nroff macros being used in
786 void context. The pink camel has the details in
787 the script wrapman near page 319. */
788 if (strnEQ(SvPVX(sv), "di", 2) ||
789 strnEQ(SvPVX(sv), "ds", 2) ||
790 strnEQ(SvPVX(sv), "ig", 2))
795 op_null(o); /* don't execute or even remember it */
799 o->op_type = OP_PREINC; /* pre-increment is faster */
800 o->op_ppaddr = PL_ppaddr[OP_PREINC];
804 o->op_type = OP_PREDEC; /* pre-decrement is faster */
805 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
812 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
817 if (o->op_flags & OPf_STACKED)
824 if (!(o->op_flags & OPf_KIDS))
833 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
840 /* all requires must return a boolean value */
841 o->op_flags &= ~OPf_WANT;
846 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
847 if (!kPMOP->op_pmreplroot)
848 deprecate_old("implicit split to @_");
852 if (useless && ckWARN(WARN_VOID))
853 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
858 Perl_listkids(pTHX_ OP *o)
860 if (o && o->op_flags & OPf_KIDS) {
862 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
869 Perl_list(pTHX_ OP *o)
874 /* assumes no premature commitment */
875 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
876 || o->op_type == OP_RETURN)
881 if ((o->op_private & OPpTARGET_MY)
882 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
884 return o; /* As if inside SASSIGN */
887 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
889 switch (o->op_type) {
892 list(cBINOPo->op_first);
897 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
905 if (!(o->op_flags & OPf_KIDS))
907 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
908 list(cBINOPo->op_first);
909 return gen_constant_list(o);
916 kid = cLISTOPo->op_first;
918 while ((kid = kid->op_sibling)) {
924 WITH_THR(PL_curcop = &PL_compiling);
928 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
934 WITH_THR(PL_curcop = &PL_compiling);
937 /* all requires must return a boolean value */
938 o->op_flags &= ~OPf_WANT;
945 Perl_scalarseq(pTHX_ OP *o)
948 if (o->op_type == OP_LINESEQ ||
949 o->op_type == OP_SCOPE ||
950 o->op_type == OP_LEAVE ||
951 o->op_type == OP_LEAVETRY)
954 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
955 if (kid->op_sibling) {
959 PL_curcop = &PL_compiling;
961 o->op_flags &= ~OPf_PARENS;
962 if (PL_hints & HINT_BLOCK_SCOPE)
963 o->op_flags |= OPf_PARENS;
966 o = newOP(OP_STUB, 0);
971 S_modkids(pTHX_ OP *o, I32 type)
973 if (o && o->op_flags & OPf_KIDS) {
975 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
981 /* Propagate lvalue ("modifiable") context to an op and it's children.
982 * 'type' represents the context type, roughly based on the type of op that
983 * would do the modifying, although local() is represented by OP_NULL.
984 * It's responsible for detecting things that can't be modified, flag
985 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
986 * might have to vivify a reference in $x), and so on.
988 * For example, "$a+1 = 2" would cause mod() to be called with o being
989 * OP_ADD and type being OP_SASSIGN, and would output an error.
993 Perl_mod(pTHX_ OP *o, I32 type)
997 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1000 if (!o || PL_error_count)
1003 if ((o->op_private & OPpTARGET_MY)
1004 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1009 switch (o->op_type) {
1015 if (!(o->op_private & (OPpCONST_ARYBASE)))
1017 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1018 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1022 SAVEI32(PL_compiling.cop_arybase);
1023 PL_compiling.cop_arybase = 0;
1025 else if (type == OP_REFGEN)
1028 Perl_croak(aTHX_ "That use of $[ is unsupported");
1031 if (o->op_flags & OPf_PARENS)
1035 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1036 !(o->op_flags & OPf_STACKED)) {
1037 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1038 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1039 assert(cUNOPo->op_first->op_type == OP_NULL);
1040 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1043 else if (o->op_private & OPpENTERSUB_NOMOD)
1045 else { /* lvalue subroutine call */
1046 o->op_private |= OPpLVAL_INTRO;
1047 PL_modcount = RETURN_UNLIMITED_NUMBER;
1048 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1049 /* Backward compatibility mode: */
1050 o->op_private |= OPpENTERSUB_INARGS;
1053 else { /* Compile-time error message: */
1054 OP *kid = cUNOPo->op_first;
1058 if (kid->op_type == OP_PUSHMARK)
1060 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1062 "panic: unexpected lvalue entersub "
1063 "args: type/targ %ld:%"UVuf,
1064 (long)kid->op_type, (UV)kid->op_targ);
1065 kid = kLISTOP->op_first;
1067 while (kid->op_sibling)
1068 kid = kid->op_sibling;
1069 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1071 if (kid->op_type == OP_METHOD_NAMED
1072 || kid->op_type == OP_METHOD)
1076 NewOp(1101, newop, 1, UNOP);
1077 newop->op_type = OP_RV2CV;
1078 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1079 newop->op_first = Nullop;
1080 newop->op_next = (OP*)newop;
1081 kid->op_sibling = (OP*)newop;
1082 newop->op_private |= OPpLVAL_INTRO;
1086 if (kid->op_type != OP_RV2CV)
1088 "panic: unexpected lvalue entersub "
1089 "entry via type/targ %ld:%"UVuf,
1090 (long)kid->op_type, (UV)kid->op_targ);
1091 kid->op_private |= OPpLVAL_INTRO;
1092 break; /* Postpone until runtime */
1096 kid = kUNOP->op_first;
1097 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1098 kid = kUNOP->op_first;
1099 if (kid->op_type == OP_NULL)
1101 "Unexpected constant lvalue entersub "
1102 "entry via type/targ %ld:%"UVuf,
1103 (long)kid->op_type, (UV)kid->op_targ);
1104 if (kid->op_type != OP_GV) {
1105 /* Restore RV2CV to check lvalueness */
1107 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1108 okid->op_next = kid->op_next;
1109 kid->op_next = okid;
1112 okid->op_next = Nullop;
1113 okid->op_type = OP_RV2CV;
1115 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1116 okid->op_private |= OPpLVAL_INTRO;
1120 cv = GvCV(kGVOP_gv);
1130 /* grep, foreach, subcalls, refgen */
1131 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1133 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1134 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1136 : (o->op_type == OP_ENTERSUB
1137 ? "non-lvalue subroutine call"
1139 type ? PL_op_desc[type] : "local"));
1153 case OP_RIGHT_SHIFT:
1162 if (!(o->op_flags & OPf_STACKED))
1169 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1175 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1176 PL_modcount = RETURN_UNLIMITED_NUMBER;
1177 return o; /* Treat \(@foo) like ordinary list. */
1181 if (scalar_mod_type(o, type))
1183 ref(cUNOPo->op_first, o->op_type);
1187 if (type == OP_LEAVESUBLV)
1188 o->op_private |= OPpMAYBE_LVSUB;
1194 PL_modcount = RETURN_UNLIMITED_NUMBER;
1197 ref(cUNOPo->op_first, o->op_type);
1202 PL_hints |= HINT_BLOCK_SCOPE;
1217 PL_modcount = RETURN_UNLIMITED_NUMBER;
1218 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1219 return o; /* Treat \(@foo) like ordinary list. */
1220 if (scalar_mod_type(o, type))
1222 if (type == OP_LEAVESUBLV)
1223 o->op_private |= OPpMAYBE_LVSUB;
1227 if (!type) /* local() */
1228 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1229 PAD_COMPNAME_PV(o->op_targ));
1237 if (type != OP_SASSIGN)
1241 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1246 if (type == OP_LEAVESUBLV)
1247 o->op_private |= OPpMAYBE_LVSUB;
1249 pad_free(o->op_targ);
1250 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1251 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1252 if (o->op_flags & OPf_KIDS)
1253 mod(cBINOPo->op_first->op_sibling, type);
1258 ref(cBINOPo->op_first, o->op_type);
1259 if (type == OP_ENTERSUB &&
1260 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1261 o->op_private |= OPpLVAL_DEFER;
1262 if (type == OP_LEAVESUBLV)
1263 o->op_private |= OPpMAYBE_LVSUB;
1273 if (o->op_flags & OPf_KIDS)
1274 mod(cLISTOPo->op_last, type);
1279 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1281 else if (!(o->op_flags & OPf_KIDS))
1283 if (o->op_targ != OP_LIST) {
1284 mod(cBINOPo->op_first, type);
1290 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1295 if (type != OP_LEAVESUBLV)
1297 break; /* mod()ing was handled by ck_return() */
1300 /* [20011101.069] File test operators interpret OPf_REF to mean that
1301 their argument is a filehandle; thus \stat(".") should not set
1303 if (type == OP_REFGEN &&
1304 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1307 if (type != OP_LEAVESUBLV)
1308 o->op_flags |= OPf_MOD;
1310 if (type == OP_AASSIGN || type == OP_SASSIGN)
1311 o->op_flags |= OPf_SPECIAL|OPf_REF;
1312 else if (!type) { /* local() */
1315 o->op_private |= OPpLVAL_INTRO;
1316 o->op_flags &= ~OPf_SPECIAL;
1317 PL_hints |= HINT_BLOCK_SCOPE;
1322 if (ckWARN(WARN_SYNTAX)) {
1323 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1324 "Useless localization of %s", OP_DESC(o));
1328 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1329 && type != OP_LEAVESUBLV)
1330 o->op_flags |= OPf_REF;
1335 S_scalar_mod_type(pTHX_ const OP *o, I32 type)
1339 if (o->op_type == OP_RV2GV)
1363 case OP_RIGHT_SHIFT:
1382 S_is_handle_constructor(pTHX_ const OP *o, I32 argnum)
1384 switch (o->op_type) {
1392 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1405 Perl_refkids(pTHX_ OP *o, I32 type)
1407 if (o && o->op_flags & OPf_KIDS) {
1409 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1416 Perl_ref(pTHX_ OP *o, I32 type)
1421 if (!o || PL_error_count)
1424 switch (o->op_type) {
1426 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1427 !(o->op_flags & OPf_STACKED)) {
1428 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1429 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1430 assert(cUNOPo->op_first->op_type == OP_NULL);
1431 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1432 o->op_flags |= OPf_SPECIAL;
1437 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1441 if (type == OP_DEFINED)
1442 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1443 ref(cUNOPo->op_first, o->op_type);
1446 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1447 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1448 : type == OP_RV2HV ? OPpDEREF_HV
1450 o->op_flags |= OPf_MOD;
1455 o->op_flags |= OPf_MOD; /* XXX ??? */
1460 o->op_flags |= OPf_REF;
1463 if (type == OP_DEFINED)
1464 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1465 ref(cUNOPo->op_first, o->op_type);
1470 o->op_flags |= OPf_REF;
1475 if (!(o->op_flags & OPf_KIDS))
1477 ref(cBINOPo->op_first, type);
1481 ref(cBINOPo->op_first, o->op_type);
1482 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1483 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1484 : type == OP_RV2HV ? OPpDEREF_HV
1486 o->op_flags |= OPf_MOD;
1494 if (!(o->op_flags & OPf_KIDS))
1496 ref(cLISTOPo->op_last, type);
1506 S_dup_attrlist(pTHX_ OP *o)
1510 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1511 * where the first kid is OP_PUSHMARK and the remaining ones
1512 * are OP_CONST. We need to push the OP_CONST values.
1514 if (o->op_type == OP_CONST)
1515 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1517 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1518 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1519 if (o->op_type == OP_CONST)
1520 rop = append_elem(OP_LIST, rop,
1521 newSVOP(OP_CONST, o->op_flags,
1522 SvREFCNT_inc(cSVOPo->op_sv)));
1529 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1534 /* fake up C<use attributes $pkg,$rv,@attrs> */
1535 ENTER; /* need to protect against side-effects of 'use' */
1538 stashsv = newSVpv(HvNAME(stash), 0);
1540 stashsv = &PL_sv_no;
1542 #define ATTRSMODULE "attributes"
1543 #define ATTRSMODULE_PM "attributes.pm"
1547 /* Don't force the C<use> if we don't need it. */
1548 svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
1549 sizeof(ATTRSMODULE_PM)-1, 0);
1550 if (svp && *svp != &PL_sv_undef)
1551 ; /* already in %INC */
1553 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1554 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1558 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1559 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1561 prepend_elem(OP_LIST,
1562 newSVOP(OP_CONST, 0, stashsv),
1563 prepend_elem(OP_LIST,
1564 newSVOP(OP_CONST, 0,
1566 dup_attrlist(attrs))));
1572 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1574 OP *pack, *imop, *arg;
1580 assert(target->op_type == OP_PADSV ||
1581 target->op_type == OP_PADHV ||
1582 target->op_type == OP_PADAV);
1584 /* Ensure that attributes.pm is loaded. */
1585 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1587 /* Need package name for method call. */
1588 pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
1590 /* Build up the real arg-list. */
1592 stashsv = newSVpv(HvNAME(stash), 0);
1594 stashsv = &PL_sv_no;
1595 arg = newOP(OP_PADSV, 0);
1596 arg->op_targ = target->op_targ;
1597 arg = prepend_elem(OP_LIST,
1598 newSVOP(OP_CONST, 0, stashsv),
1599 prepend_elem(OP_LIST,
1600 newUNOP(OP_REFGEN, 0,
1601 mod(arg, OP_REFGEN)),
1602 dup_attrlist(attrs)));
1604 /* Fake up a method call to import */
1605 meth = newSVpvn("import", 6);
1606 (void)SvUPGRADE(meth, SVt_PVIV);
1607 (void)SvIOK_on(meth);
1610 PERL_HASH(hash, SvPVX(meth), SvCUR(meth));
1611 SvUV_set(meth, hash);
1613 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1614 append_elem(OP_LIST,
1615 prepend_elem(OP_LIST, pack, list(arg)),
1616 newSVOP(OP_METHOD_NAMED, 0, meth)));
1617 imop->op_private |= OPpENTERSUB_NOMOD;
1619 /* Combine the ops. */
1620 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1624 =notfor apidoc apply_attrs_string
1626 Attempts to apply a list of attributes specified by the C<attrstr> and
1627 C<len> arguments to the subroutine identified by the C<cv> argument which
1628 is expected to be associated with the package identified by the C<stashpv>
1629 argument (see L<attributes>). It gets this wrong, though, in that it
1630 does not correctly identify the boundaries of the individual attribute
1631 specifications within C<attrstr>. This is not really intended for the
1632 public API, but has to be listed here for systems such as AIX which
1633 need an explicit export list for symbols. (It's called from XS code
1634 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1635 to respect attribute syntax properly would be welcome.
1641 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1642 const char *attrstr, STRLEN len)
1647 len = strlen(attrstr);
1651 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1653 const char *sstr = attrstr;
1654 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1655 attrs = append_elem(OP_LIST, attrs,
1656 newSVOP(OP_CONST, 0,
1657 newSVpvn(sstr, attrstr-sstr)));
1661 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1662 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1663 Nullsv, prepend_elem(OP_LIST,
1664 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1665 prepend_elem(OP_LIST,
1666 newSVOP(OP_CONST, 0,
1672 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1676 if (!o || PL_error_count)
1680 if (type == OP_LIST) {
1682 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1683 my_kid(kid, attrs, imopsp);
1684 } else if (type == OP_UNDEF) {
1686 } else if (type == OP_RV2SV || /* "our" declaration */
1688 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1689 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1690 yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
1691 OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
1693 GV *gv = cGVOPx_gv(cUNOPo->op_first);
1695 PL_in_my_stash = Nullhv;
1696 apply_attrs(GvSTASH(gv),
1697 (type == OP_RV2SV ? GvSV(gv) :
1698 type == OP_RV2AV ? (SV*)GvAV(gv) :
1699 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1702 o->op_private |= OPpOUR_INTRO;
1705 else if (type != OP_PADSV &&
1708 type != OP_PUSHMARK)
1710 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1712 PL_in_my == KEY_our ? "our" : "my"));
1715 else if (attrs && type != OP_PUSHMARK) {
1719 PL_in_my_stash = Nullhv;
1721 /* check for C<my Dog $spot> when deciding package */
1722 stash = PAD_COMPNAME_TYPE(o->op_targ);
1724 stash = PL_curstash;
1725 apply_attrs_my(stash, o, attrs, imopsp);
1727 o->op_flags |= OPf_MOD;
1728 o->op_private |= OPpLVAL_INTRO;
1733 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1736 int maybe_scalar = 0;
1738 /* [perl #17376]: this appears to be premature, and results in code such as
1739 C< our(%x); > executing in list mode rather than void mode */
1741 if (o->op_flags & OPf_PARENS)
1750 o = my_kid(o, attrs, &rops);
1752 if (maybe_scalar && o->op_type == OP_PADSV) {
1753 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1754 o->op_private |= OPpLVAL_INTRO;
1757 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1760 PL_in_my_stash = Nullhv;
1765 Perl_my(pTHX_ OP *o)
1767 return my_attrs(o, Nullop);
1771 Perl_sawparens(pTHX_ OP *o)
1774 o->op_flags |= OPf_PARENS;
1779 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1784 if (ckWARN(WARN_MISC) &&
1785 (left->op_type == OP_RV2AV ||
1786 left->op_type == OP_RV2HV ||
1787 left->op_type == OP_PADAV ||
1788 left->op_type == OP_PADHV)) {
1789 const char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
1790 right->op_type == OP_TRANS)
1791 ? right->op_type : OP_MATCH];
1792 const char *sample = ((left->op_type == OP_RV2AV ||
1793 left->op_type == OP_PADAV)
1794 ? "@array" : "%hash");
1795 Perl_warner(aTHX_ packWARN(WARN_MISC),
1796 "Applying %s to %s will act on scalar(%s)",
1797 desc, sample, sample);
1800 if (right->op_type == OP_CONST &&
1801 cSVOPx(right)->op_private & OPpCONST_BARE &&
1802 cSVOPx(right)->op_private & OPpCONST_STRICT)
1804 no_bareword_allowed(right);
1807 ismatchop = right->op_type == OP_MATCH ||
1808 right->op_type == OP_SUBST ||
1809 right->op_type == OP_TRANS;
1810 if (ismatchop && right->op_private & OPpTARGET_MY) {
1812 right->op_private &= ~OPpTARGET_MY;
1814 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1815 right->op_flags |= OPf_STACKED;
1816 if (right->op_type != OP_MATCH &&
1817 ! (right->op_type == OP_TRANS &&
1818 right->op_private & OPpTRANS_IDENTICAL))
1819 left = mod(left, right->op_type);
1820 if (right->op_type == OP_TRANS)
1821 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
1823 o = prepend_elem(right->op_type, scalar(left), right);
1825 return newUNOP(OP_NOT, 0, scalar(o));
1829 return bind_match(type, left,
1830 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
1834 Perl_invert(pTHX_ OP *o)
1838 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
1839 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1843 Perl_scope(pTHX_ OP *o)
1847 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1848 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1849 o->op_type = OP_LEAVE;
1850 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1852 else if (o->op_type == OP_LINESEQ) {
1854 o->op_type = OP_SCOPE;
1855 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1856 kid = ((LISTOP*)o)->op_first;
1857 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
1861 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
1866 /* XXX kept for BINCOMPAT only */
1868 Perl_save_hints(pTHX)
1870 Perl_croak(aTHX_ "internal error: obsolete function save_hints() called");
1874 Perl_block_start(pTHX_ int full)
1876 const int retval = PL_savestack_ix;
1877 pad_block_start(full);
1879 PL_hints &= ~HINT_BLOCK_SCOPE;
1880 SAVESPTR(PL_compiling.cop_warnings);
1881 if (! specialWARN(PL_compiling.cop_warnings)) {
1882 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1883 SAVEFREESV(PL_compiling.cop_warnings) ;
1885 SAVESPTR(PL_compiling.cop_io);
1886 if (! specialCopIO(PL_compiling.cop_io)) {
1887 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1888 SAVEFREESV(PL_compiling.cop_io) ;
1894 Perl_block_end(pTHX_ I32 floor, OP *seq)
1896 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1897 OP* retval = scalarseq(seq);
1899 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
1901 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
1909 const I32 offset = pad_findmy("$_");
1910 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
1911 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1914 OP *o = newOP(OP_PADSV, 0);
1915 o->op_targ = offset;
1921 Perl_newPROG(pTHX_ OP *o)
1926 PL_eval_root = newUNOP(OP_LEAVEEVAL,
1927 ((PL_in_eval & EVAL_KEEPERR)
1928 ? OPf_SPECIAL : 0), o);
1929 PL_eval_start = linklist(PL_eval_root);
1930 PL_eval_root->op_private |= OPpREFCOUNTED;
1931 OpREFCNT_set(PL_eval_root, 1);
1932 PL_eval_root->op_next = 0;
1933 CALL_PEEP(PL_eval_start);
1936 if (o->op_type == OP_STUB) {
1937 PL_comppad_name = 0;
1942 PL_main_root = scope(sawparens(scalarvoid(o)));
1943 PL_curcop = &PL_compiling;
1944 PL_main_start = LINKLIST(PL_main_root);
1945 PL_main_root->op_private |= OPpREFCOUNTED;
1946 OpREFCNT_set(PL_main_root, 1);
1947 PL_main_root->op_next = 0;
1948 CALL_PEEP(PL_main_start);
1951 /* Register with debugger */
1953 CV *cv = get_cv("DB::postponed", FALSE);
1957 XPUSHs((SV*)CopFILEGV(&PL_compiling));
1959 call_sv((SV*)cv, G_DISCARD);
1966 Perl_localize(pTHX_ OP *o, I32 lex)
1968 if (o->op_flags & OPf_PARENS)
1969 /* [perl #17376]: this appears to be premature, and results in code such as
1970 C< our(%x); > executing in list mode rather than void mode */
1977 if (ckWARN(WARN_PARENTHESIS)
1978 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
1980 char *s = PL_bufptr;
1983 /* some heuristics to detect a potential error */
1984 while (*s && (strchr(", \t\n", *s)))
1988 if (*s && strchr("@$%*", *s) && *++s
1989 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
1992 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
1994 while (*s && (strchr(", \t\n", *s)))
2000 if (sigil && (*s == ';' || *s == '=')) {
2001 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2002 "Parentheses missing around \"%s\" list",
2003 lex ? (PL_in_my == KEY_our ? "our" : "my")
2011 o = mod(o, OP_NULL); /* a bit kludgey */
2013 PL_in_my_stash = Nullhv;
2018 Perl_jmaybe(pTHX_ OP *o)
2020 if (o->op_type == OP_LIST) {
2022 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2023 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2029 Perl_fold_constants(pTHX_ register OP *o)
2033 I32 type = o->op_type;
2036 if (PL_opargs[type] & OA_RETSCALAR)
2038 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2039 o->op_targ = pad_alloc(type, SVs_PADTMP);
2041 /* integerize op, unless it happens to be C<-foo>.
2042 * XXX should pp_i_negate() do magic string negation instead? */
2043 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2044 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2045 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2047 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2050 if (!(PL_opargs[type] & OA_FOLDCONST))
2055 /* XXX might want a ck_negate() for this */
2056 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2068 /* XXX what about the numeric ops? */
2069 if (PL_hints & HINT_LOCALE)
2074 goto nope; /* Don't try to run w/ errors */
2076 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2077 if ((curop->op_type != OP_CONST ||
2078 (curop->op_private & OPpCONST_BARE)) &&
2079 curop->op_type != OP_LIST &&
2080 curop->op_type != OP_SCALAR &&
2081 curop->op_type != OP_NULL &&
2082 curop->op_type != OP_PUSHMARK)
2088 curop = LINKLIST(o);
2092 sv = *(PL_stack_sp--);
2093 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2094 pad_swipe(o->op_targ, FALSE);
2095 else if (SvTEMP(sv)) { /* grab mortal temp? */
2096 (void)SvREFCNT_inc(sv);
2100 if (type == OP_RV2GV)
2101 return newGVOP(OP_GV, 0, (GV*)sv);
2102 return newSVOP(OP_CONST, 0, sv);
2109 Perl_gen_constant_list(pTHX_ register OP *o)
2113 const I32 oldtmps_floor = PL_tmps_floor;
2117 return o; /* Don't attempt to run with errors */
2119 PL_op = curop = LINKLIST(o);
2126 PL_tmps_floor = oldtmps_floor;
2128 o->op_type = OP_RV2AV;
2129 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2130 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2131 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2132 o->op_opt = 0; /* needs to be revisited in peep() */
2133 curop = ((UNOP*)o)->op_first;
2134 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2141 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2144 if (!o || o->op_type != OP_LIST)
2145 o = newLISTOP(OP_LIST, 0, o, Nullop);
2147 o->op_flags &= ~OPf_WANT;
2149 if (!(PL_opargs[type] & OA_MARK))
2150 op_null(cLISTOPo->op_first);
2152 o->op_type = (OPCODE)type;
2153 o->op_ppaddr = PL_ppaddr[type];
2154 o->op_flags |= flags;
2156 o = CHECKOP(type, o);
2157 if (o->op_type != (unsigned)type)
2160 return fold_constants(o);
2163 /* List constructors */
2166 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2174 if (first->op_type != (unsigned)type
2175 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2177 return newLISTOP(type, 0, first, last);
2180 if (first->op_flags & OPf_KIDS)
2181 ((LISTOP*)first)->op_last->op_sibling = last;
2183 first->op_flags |= OPf_KIDS;
2184 ((LISTOP*)first)->op_first = last;
2186 ((LISTOP*)first)->op_last = last;
2191 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2199 if (first->op_type != (unsigned)type)
2200 return prepend_elem(type, (OP*)first, (OP*)last);
2202 if (last->op_type != (unsigned)type)
2203 return append_elem(type, (OP*)first, (OP*)last);
2205 first->op_last->op_sibling = last->op_first;
2206 first->op_last = last->op_last;
2207 first->op_flags |= (last->op_flags & OPf_KIDS);
2215 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2223 if (last->op_type == (unsigned)type) {
2224 if (type == OP_LIST) { /* already a PUSHMARK there */
2225 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2226 ((LISTOP*)last)->op_first->op_sibling = first;
2227 if (!(first->op_flags & OPf_PARENS))
2228 last->op_flags &= ~OPf_PARENS;
2231 if (!(last->op_flags & OPf_KIDS)) {
2232 ((LISTOP*)last)->op_last = first;
2233 last->op_flags |= OPf_KIDS;
2235 first->op_sibling = ((LISTOP*)last)->op_first;
2236 ((LISTOP*)last)->op_first = first;
2238 last->op_flags |= OPf_KIDS;
2242 return newLISTOP(type, 0, first, last);
2248 Perl_newNULLLIST(pTHX)
2250 return newOP(OP_STUB, 0);
2254 Perl_force_list(pTHX_ OP *o)
2256 if (!o || o->op_type != OP_LIST)
2257 o = newLISTOP(OP_LIST, 0, o, Nullop);
2263 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2268 NewOp(1101, listop, 1, LISTOP);
2270 listop->op_type = (OPCODE)type;
2271 listop->op_ppaddr = PL_ppaddr[type];
2274 listop->op_flags = (U8)flags;
2278 else if (!first && last)
2281 first->op_sibling = last;
2282 listop->op_first = first;
2283 listop->op_last = last;
2284 if (type == OP_LIST) {
2286 pushop = newOP(OP_PUSHMARK, 0);
2287 pushop->op_sibling = first;
2288 listop->op_first = pushop;
2289 listop->op_flags |= OPf_KIDS;
2291 listop->op_last = pushop;
2294 return CHECKOP(type, listop);
2298 Perl_newOP(pTHX_ I32 type, I32 flags)
2302 NewOp(1101, o, 1, OP);
2303 o->op_type = (OPCODE)type;
2304 o->op_ppaddr = PL_ppaddr[type];
2305 o->op_flags = (U8)flags;
2308 o->op_private = (U8)(0 | (flags >> 8));
2309 if (PL_opargs[type] & OA_RETSCALAR)
2311 if (PL_opargs[type] & OA_TARGET)
2312 o->op_targ = pad_alloc(type, SVs_PADTMP);
2313 return CHECKOP(type, o);
2317 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2323 first = newOP(OP_STUB, 0);
2324 if (PL_opargs[type] & OA_MARK)
2325 first = force_list(first);
2327 NewOp(1101, unop, 1, UNOP);
2328 unop->op_type = (OPCODE)type;
2329 unop->op_ppaddr = PL_ppaddr[type];
2330 unop->op_first = first;
2331 unop->op_flags = flags | OPf_KIDS;
2332 unop->op_private = (U8)(1 | (flags >> 8));
2333 unop = (UNOP*) CHECKOP(type, unop);
2337 return fold_constants((OP *) unop);
2341 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2345 NewOp(1101, binop, 1, BINOP);
2348 first = newOP(OP_NULL, 0);
2350 binop->op_type = (OPCODE)type;
2351 binop->op_ppaddr = PL_ppaddr[type];
2352 binop->op_first = first;
2353 binop->op_flags = flags | OPf_KIDS;
2356 binop->op_private = (U8)(1 | (flags >> 8));
2359 binop->op_private = (U8)(2 | (flags >> 8));
2360 first->op_sibling = last;
2363 binop = (BINOP*)CHECKOP(type, binop);
2364 if (binop->op_next || binop->op_type != (OPCODE)type)
2367 binop->op_last = binop->op_first->op_sibling;
2369 return fold_constants((OP *)binop);
2372 static int uvcompare(const void *a, const void *b) __attribute__nonnull__(1) __attribute__nonnull__(2) __attribute__pure__;
2373 static int uvcompare(const void *a, const void *b)
2375 if (*((const UV *)a) < (*(const UV *)b))
2377 if (*((const UV *)a) > (*(const UV *)b))
2379 if (*((const UV *)a+1) < (*(const UV *)b+1))
2381 if (*((const UV *)a+1) > (*(const UV *)b+1))
2387 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2389 SV *tstr = ((SVOP*)expr)->op_sv;
2390 SV *rstr = ((SVOP*)repl)->op_sv;
2393 U8 *t = (U8*)SvPV(tstr, tlen);
2394 U8 *r = (U8*)SvPV(rstr, rlen);
2401 register short *tbl;
2403 PL_hints |= HINT_BLOCK_SCOPE;
2404 complement = o->op_private & OPpTRANS_COMPLEMENT;
2405 del = o->op_private & OPpTRANS_DELETE;
2406 squash = o->op_private & OPpTRANS_SQUASH;
2409 o->op_private |= OPpTRANS_FROM_UTF;
2412 o->op_private |= OPpTRANS_TO_UTF;
2414 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2415 SV* listsv = newSVpvn("# comment\n",10);
2417 U8* tend = t + tlen;
2418 U8* rend = r + rlen;
2432 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2433 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2439 tsave = t = bytes_to_utf8(t, &len);
2442 if (!to_utf && rlen) {
2444 rsave = r = bytes_to_utf8(r, &len);
2448 /* There are several snags with this code on EBCDIC:
2449 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2450 2. scan_const() in toke.c has encoded chars in native encoding which makes
2451 ranges at least in EBCDIC 0..255 range the bottom odd.
2455 U8 tmpbuf[UTF8_MAXBYTES+1];
2458 New(1109, cp, 2*tlen, UV);
2460 transv = newSVpvn("",0);
2462 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2464 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2466 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2470 cp[2*i+1] = cp[2*i];
2474 qsort(cp, i, 2*sizeof(UV), uvcompare);
2475 for (j = 0; j < i; j++) {
2477 diff = val - nextmin;
2479 t = uvuni_to_utf8(tmpbuf,nextmin);
2480 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2482 U8 range_mark = UTF_TO_NATIVE(0xff);
2483 t = uvuni_to_utf8(tmpbuf, val - 1);
2484 sv_catpvn(transv, (char *)&range_mark, 1);
2485 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2492 t = uvuni_to_utf8(tmpbuf,nextmin);
2493 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2495 U8 range_mark = UTF_TO_NATIVE(0xff);
2496 sv_catpvn(transv, (char *)&range_mark, 1);
2498 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2499 UNICODE_ALLOW_SUPER);
2500 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2501 t = (U8*)SvPVX(transv);
2502 tlen = SvCUR(transv);
2506 else if (!rlen && !del) {
2507 r = t; rlen = tlen; rend = tend;
2510 if ((!rlen && !del) || t == r ||
2511 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2513 o->op_private |= OPpTRANS_IDENTICAL;
2517 while (t < tend || tfirst <= tlast) {
2518 /* see if we need more "t" chars */
2519 if (tfirst > tlast) {
2520 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2522 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2524 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2531 /* now see if we need more "r" chars */
2532 if (rfirst > rlast) {
2534 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2536 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2538 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2547 rfirst = rlast = 0xffffffff;
2551 /* now see which range will peter our first, if either. */
2552 tdiff = tlast - tfirst;
2553 rdiff = rlast - rfirst;
2560 if (rfirst == 0xffffffff) {
2561 diff = tdiff; /* oops, pretend rdiff is infinite */
2563 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2564 (long)tfirst, (long)tlast);
2566 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2570 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2571 (long)tfirst, (long)(tfirst + diff),
2574 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2575 (long)tfirst, (long)rfirst);
2577 if (rfirst + diff > max)
2578 max = rfirst + diff;
2580 grows = (tfirst < rfirst &&
2581 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2593 else if (max > 0xff)
2598 Safefree(cPVOPo->op_pv);
2599 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2600 SvREFCNT_dec(listsv);
2602 SvREFCNT_dec(transv);
2604 if (!del && havefinal && rlen)
2605 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2606 newSVuv((UV)final), 0);
2609 o->op_private |= OPpTRANS_GROWS;
2621 tbl = (short*)cPVOPo->op_pv;
2623 Zero(tbl, 256, short);
2624 for (i = 0; i < (I32)tlen; i++)
2626 for (i = 0, j = 0; i < 256; i++) {
2628 if (j >= (I32)rlen) {
2637 if (i < 128 && r[j] >= 128)
2647 o->op_private |= OPpTRANS_IDENTICAL;
2649 else if (j >= (I32)rlen)
2652 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2653 tbl[0x100] = rlen - j;
2654 for (i=0; i < (I32)rlen - j; i++)
2655 tbl[0x101+i] = r[j+i];
2659 if (!rlen && !del) {
2662 o->op_private |= OPpTRANS_IDENTICAL;
2664 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2665 o->op_private |= OPpTRANS_IDENTICAL;
2667 for (i = 0; i < 256; i++)
2669 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
2670 if (j >= (I32)rlen) {
2672 if (tbl[t[i]] == -1)
2678 if (tbl[t[i]] == -1) {
2679 if (t[i] < 128 && r[j] >= 128)
2686 o->op_private |= OPpTRANS_GROWS;
2694 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2699 NewOp(1101, pmop, 1, PMOP);
2700 pmop->op_type = (OPCODE)type;
2701 pmop->op_ppaddr = PL_ppaddr[type];
2702 pmop->op_flags = (U8)flags;
2703 pmop->op_private = (U8)(0 | (flags >> 8));
2705 if (PL_hints & HINT_RE_TAINT)
2706 pmop->op_pmpermflags |= PMf_RETAINT;
2707 if (PL_hints & HINT_LOCALE)
2708 pmop->op_pmpermflags |= PMf_LOCALE;
2709 pmop->op_pmflags = pmop->op_pmpermflags;
2714 if(av_len((AV*) PL_regex_pad[0]) > -1) {
2715 repointer = av_pop((AV*)PL_regex_pad[0]);
2716 pmop->op_pmoffset = SvIV(repointer);
2717 SvREPADTMP_off(repointer);
2718 sv_setiv(repointer,0);
2720 repointer = newSViv(0);
2721 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2722 pmop->op_pmoffset = av_len(PL_regex_padav);
2723 PL_regex_pad = AvARRAY(PL_regex_padav);
2728 /* link into pm list */
2729 if (type != OP_TRANS && PL_curstash) {
2730 MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab);
2733 mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0);
2735 pmop->op_pmnext = (PMOP*)mg->mg_obj;
2736 mg->mg_obj = (SV*)pmop;
2737 PmopSTASH_set(pmop,PL_curstash);
2740 return CHECKOP(type, pmop);
2743 /* Given some sort of match op o, and an expression expr containing a
2744 * pattern, either compile expr into a regex and attach it to o (if it's
2745 * constant), or convert expr into a runtime regcomp op sequence (if it's
2748 * isreg indicates that the pattern is part of a regex construct, eg
2749 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
2750 * split "pattern", which aren't. In the former case, expr will be a list
2751 * if the pattern contains more than one term (eg /a$b/) or if it contains
2752 * a replacement, ie s/// or tr///.
2756 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
2761 I32 repl_has_vars = 0;
2765 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
2766 /* last element in list is the replacement; pop it */
2768 repl = cLISTOPx(expr)->op_last;
2769 kid = cLISTOPx(expr)->op_first;
2770 while (kid->op_sibling != repl)
2771 kid = kid->op_sibling;
2772 kid->op_sibling = Nullop;
2773 cLISTOPx(expr)->op_last = kid;
2776 if (isreg && expr->op_type == OP_LIST &&
2777 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
2779 /* convert single element list to element */
2781 expr = cLISTOPx(oe)->op_first->op_sibling;
2782 cLISTOPx(oe)->op_first->op_sibling = Nullop;
2783 cLISTOPx(oe)->op_last = Nullop;
2787 if (o->op_type == OP_TRANS) {
2788 return pmtrans(o, expr, repl);
2791 reglist = isreg && expr->op_type == OP_LIST;
2795 PL_hints |= HINT_BLOCK_SCOPE;
2798 if (expr->op_type == OP_CONST) {
2800 SV *pat = ((SVOP*)expr)->op_sv;
2801 char *p = SvPV(pat, plen);
2802 if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
2803 sv_setpvn(pat, "\\s+", 3);
2804 p = SvPV(pat, plen);
2805 pm->op_pmflags |= PMf_SKIPWHITE;
2808 pm->op_pmdynflags |= PMdf_UTF8;
2809 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
2810 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
2811 pm->op_pmflags |= PMf_WHITE;
2815 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2816 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2818 : OP_REGCMAYBE),0,expr);
2820 NewOp(1101, rcop, 1, LOGOP);
2821 rcop->op_type = OP_REGCOMP;
2822 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2823 rcop->op_first = scalar(expr);
2824 rcop->op_flags |= OPf_KIDS
2825 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
2826 | (reglist ? OPf_STACKED : 0);
2827 rcop->op_private = 1;
2830 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
2832 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
2835 /* establish postfix order */
2836 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2838 rcop->op_next = expr;
2839 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2842 rcop->op_next = LINKLIST(expr);
2843 expr->op_next = (OP*)rcop;
2846 prepend_elem(o->op_type, scalar((OP*)rcop), o);
2851 if (pm->op_pmflags & PMf_EVAL) {
2853 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
2854 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
2856 else if (repl->op_type == OP_CONST)
2860 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
2861 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
2862 if (curop->op_type == OP_GV) {
2863 GV *gv = cGVOPx_gv(curop);
2865 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
2868 else if (curop->op_type == OP_RV2CV)
2870 else if (curop->op_type == OP_RV2SV ||
2871 curop->op_type == OP_RV2AV ||
2872 curop->op_type == OP_RV2HV ||
2873 curop->op_type == OP_RV2GV) {
2874 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2877 else if (curop->op_type == OP_PADSV ||
2878 curop->op_type == OP_PADAV ||
2879 curop->op_type == OP_PADHV ||
2880 curop->op_type == OP_PADANY) {
2883 else if (curop->op_type == OP_PUSHRE)
2884 ; /* Okay here, dangerous in newASSIGNOP */
2894 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
2895 pm->op_pmflags |= PMf_CONST; /* const for long enough */
2896 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
2897 prepend_elem(o->op_type, scalar(repl), o);
2900 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
2901 pm->op_pmflags |= PMf_MAYBE_CONST;
2902 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2904 NewOp(1101, rcop, 1, LOGOP);
2905 rcop->op_type = OP_SUBSTCONT;
2906 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
2907 rcop->op_first = scalar(repl);
2908 rcop->op_flags |= OPf_KIDS;
2909 rcop->op_private = 1;
2912 /* establish postfix order */
2913 rcop->op_next = LINKLIST(repl);
2914 repl->op_next = (OP*)rcop;
2916 pm->op_pmreplroot = scalar((OP*)rcop);
2917 pm->op_pmreplstart = LINKLIST(rcop);
2926 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
2930 NewOp(1101, svop, 1, SVOP);
2931 svop->op_type = (OPCODE)type;
2932 svop->op_ppaddr = PL_ppaddr[type];
2934 svop->op_next = (OP*)svop;
2935 svop->op_flags = (U8)flags;
2936 if (PL_opargs[type] & OA_RETSCALAR)
2938 if (PL_opargs[type] & OA_TARGET)
2939 svop->op_targ = pad_alloc(type, SVs_PADTMP);
2940 return CHECKOP(type, svop);
2944 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2948 NewOp(1101, padop, 1, PADOP);
2949 padop->op_type = (OPCODE)type;
2950 padop->op_ppaddr = PL_ppaddr[type];
2951 padop->op_padix = pad_alloc(type, SVs_PADTMP);
2952 SvREFCNT_dec(PAD_SVl(padop->op_padix));
2953 PAD_SETSV(padop->op_padix, sv);
2956 padop->op_next = (OP*)padop;
2957 padop->op_flags = (U8)flags;
2958 if (PL_opargs[type] & OA_RETSCALAR)
2960 if (PL_opargs[type] & OA_TARGET)
2961 padop->op_targ = pad_alloc(type, SVs_PADTMP);
2962 return CHECKOP(type, padop);
2966 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
2972 return newPADOP(type, flags, SvREFCNT_inc(gv));
2974 return newSVOP(type, flags, SvREFCNT_inc(gv));
2979 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
2983 NewOp(1101, pvop, 1, PVOP);
2984 pvop->op_type = (OPCODE)type;
2985 pvop->op_ppaddr = PL_ppaddr[type];
2987 pvop->op_next = (OP*)pvop;
2988 pvop->op_flags = (U8)flags;
2989 if (PL_opargs[type] & OA_RETSCALAR)
2991 if (PL_opargs[type] & OA_TARGET)
2992 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
2993 return CHECKOP(type, pvop);
2997 Perl_package(pTHX_ OP *o)
3002 save_hptr(&PL_curstash);
3003 save_item(PL_curstname);
3005 name = SvPV(cSVOPo->op_sv, len);
3006 PL_curstash = gv_stashpvn(name, len, TRUE);
3007 sv_setpvn(PL_curstname, name, len);
3010 PL_hints |= HINT_BLOCK_SCOPE;
3011 PL_copline = NOLINE;
3016 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3022 if (idop->op_type != OP_CONST)
3023 Perl_croak(aTHX_ "Module name must be constant");
3027 if (version != Nullop) {
3028 SV *vesv = ((SVOP*)version)->op_sv;
3030 if (arg == Nullop && !SvNIOKp(vesv)) {
3037 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3038 Perl_croak(aTHX_ "Version number must be constant number");
3040 /* Make copy of idop so we don't free it twice */
3041 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3043 /* Fake up a method call to VERSION */
3044 meth = newSVpvn("VERSION",7);
3045 sv_upgrade(meth, SVt_PVIV);
3046 (void)SvIOK_on(meth);
3049 PERL_HASH(hash, SvPVX(meth), SvCUR(meth));
3050 SvUV_set(meth, hash);
3052 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3053 append_elem(OP_LIST,
3054 prepend_elem(OP_LIST, pack, list(version)),
3055 newSVOP(OP_METHOD_NAMED, 0, meth)));
3059 /* Fake up an import/unimport */
3060 if (arg && arg->op_type == OP_STUB)
3061 imop = arg; /* no import on explicit () */
3062 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3063 imop = Nullop; /* use 5.0; */
3068 /* Make copy of idop so we don't free it twice */
3069 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3071 /* Fake up a method call to import/unimport */
3072 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);
3073 (void)SvUPGRADE(meth, SVt_PVIV);
3074 (void)SvIOK_on(meth);
3077 PERL_HASH(hash, SvPVX(meth), SvCUR(meth));
3078 SvUV_set(meth, hash);
3080 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3081 append_elem(OP_LIST,
3082 prepend_elem(OP_LIST, pack, list(arg)),
3083 newSVOP(OP_METHOD_NAMED, 0, meth)));
3086 /* Fake up the BEGIN {}, which does its thing immediately. */
3088 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3091 append_elem(OP_LINESEQ,
3092 append_elem(OP_LINESEQ,
3093 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, idop)),
3094 newSTATEOP(0, Nullch, veop)),
3095 newSTATEOP(0, Nullch, imop) ));
3097 /* The "did you use incorrect case?" warning used to be here.
3098 * The problem is that on case-insensitive filesystems one
3099 * might get false positives for "use" (and "require"):
3100 * "use Strict" or "require CARP" will work. This causes
3101 * portability problems for the script: in case-strict
3102 * filesystems the script will stop working.
3104 * The "incorrect case" warning checked whether "use Foo"
3105 * imported "Foo" to your namespace, but that is wrong, too:
3106 * there is no requirement nor promise in the language that
3107 * a Foo.pm should or would contain anything in package "Foo".
3109 * There is very little Configure-wise that can be done, either:
3110 * the case-sensitivity of the build filesystem of Perl does not
3111 * help in guessing the case-sensitivity of the runtime environment.
3114 PL_hints |= HINT_BLOCK_SCOPE;
3115 PL_copline = NOLINE;
3117 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3121 =head1 Embedding Functions
3123 =for apidoc load_module
3125 Loads the module whose name is pointed to by the string part of name.
3126 Note that the actual module name, not its filename, should be given.
3127 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3128 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3129 (or 0 for no flags). ver, if specified, provides version semantics
3130 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3131 arguments can be used to specify arguments to the module's import()
3132 method, similar to C<use Foo::Bar VERSION LIST>.
3137 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3140 va_start(args, ver);
3141 vload_module(flags, name, ver, &args);
3145 #ifdef PERL_IMPLICIT_CONTEXT
3147 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3151 va_start(args, ver);
3152 vload_module(flags, name, ver, &args);
3158 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3160 OP *modname, *veop, *imop;
3162 modname = newSVOP(OP_CONST, 0, name);
3163 modname->op_private |= OPpCONST_BARE;
3165 veop = newSVOP(OP_CONST, 0, ver);
3169 if (flags & PERL_LOADMOD_NOIMPORT) {
3170 imop = sawparens(newNULLLIST());
3172 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3173 imop = va_arg(*args, OP*);
3178 sv = va_arg(*args, SV*);
3180 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3181 sv = va_arg(*args, SV*);
3185 const line_t ocopline = PL_copline;
3186 COP * const ocurcop = PL_curcop;
3187 const int oexpect = PL_expect;
3189 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3190 veop, modname, imop);
3191 PL_expect = oexpect;
3192 PL_copline = ocopline;
3193 PL_curcop = ocurcop;
3198 Perl_dofile(pTHX_ OP *term)
3203 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3204 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
3205 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3207 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3208 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3209 append_elem(OP_LIST, term,
3210 scalar(newUNOP(OP_RV2CV, 0,
3215 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3221 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3223 return newBINOP(OP_LSLICE, flags,
3224 list(force_list(subscript)),
3225 list(force_list(listval)) );
3229 S_list_assignment(pTHX_ register const OP *o)
3234 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3235 o = cUNOPo->op_first;
3237 if (o->op_type == OP_COND_EXPR) {
3238 const I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3239 const I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3244 yyerror("Assignment to both a list and a scalar");
3248 if (o->op_type == OP_LIST &&
3249 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3250 o->op_private & OPpLVAL_INTRO)
3253 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3254 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3255 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3258 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3261 if (o->op_type == OP_RV2SV)
3268 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3273 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3274 return newLOGOP(optype, 0,
3275 mod(scalar(left), optype),
3276 newUNOP(OP_SASSIGN, 0, scalar(right)));
3279 return newBINOP(optype, OPf_STACKED,
3280 mod(scalar(left), optype), scalar(right));
3284 if (list_assignment(left)) {
3288 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3289 left = mod(left, OP_AASSIGN);
3297 /* optimise C<my @x = ()> to C<my @x>, and likewise for hashes */
3298 if ((left->op_type == OP_PADAV || left->op_type == OP_PADHV)
3299 && right->op_type == OP_STUB
3300 && (left->op_private & OPpLVAL_INTRO))
3303 left->op_flags &= ~(OPf_REF|OPf_SPECIAL);
3306 curop = list(force_list(left));
3307 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3308 o->op_private = (U8)(0 | (flags >> 8));
3310 /* PL_generation sorcery:
3311 * an assignment like ($a,$b) = ($c,$d) is easier than
3312 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3313 * To detect whether there are common vars, the global var
3314 * PL_generation is incremented for each assign op we compile.
3315 * Then, while compiling the assign op, we run through all the
3316 * variables on both sides of the assignment, setting a spare slot
3317 * in each of them to PL_generation. If any of them already have
3318 * that value, we know we've got commonality. We could use a
3319 * single bit marker, but then we'd have to make 2 passes, first
3320 * to clear the flag, then to test and set it. To find somewhere
3321 * to store these values, evil chicanery is done with SvCUR().
3324 if (!(left->op_private & OPpLVAL_INTRO)) {
3327 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3328 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3329 if (curop->op_type == OP_GV) {
3330 GV *gv = cGVOPx_gv(curop);
3331 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3333 SvCUR_set(gv, PL_generation);
3335 else if (curop->op_type == OP_PADSV ||
3336 curop->op_type == OP_PADAV ||
3337 curop->op_type == OP_PADHV ||
3338 curop->op_type == OP_PADANY)
3340 if (PAD_COMPNAME_GEN(curop->op_targ)
3341 == (STRLEN)PL_generation)
3343 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
3346 else if (curop->op_type == OP_RV2CV)
3348 else if (curop->op_type == OP_RV2SV ||
3349 curop->op_type == OP_RV2AV ||
3350 curop->op_type == OP_RV2HV ||
3351 curop->op_type == OP_RV2GV) {
3352 if (lastop->op_type != OP_GV) /* funny deref? */
3355 else if (curop->op_type == OP_PUSHRE) {
3356 if (((PMOP*)curop)->op_pmreplroot) {
3358 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3359 ((PMOP*)curop)->op_pmreplroot));
3361 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3363 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3365 SvCUR_set(gv, PL_generation);
3374 o->op_private |= OPpASSIGN_COMMON;
3376 if (right && right->op_type == OP_SPLIT) {
3378 if ((tmpop = ((LISTOP*)right)->op_first) &&
3379 tmpop->op_type == OP_PUSHRE)
3381 PMOP *pm = (PMOP*)tmpop;
3382 if (left->op_type == OP_RV2AV &&
3383 !(left->op_private & OPpLVAL_INTRO) &&
3384 !(o->op_private & OPpASSIGN_COMMON) )
3386 tmpop = ((UNOP*)left)->op_first;
3387 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3389 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3390 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3392 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3393 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3395 pm->op_pmflags |= PMf_ONCE;
3396 tmpop = cUNOPo->op_first; /* to list (nulled) */
3397 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3398 tmpop->op_sibling = Nullop; /* don't free split */
3399 right->op_next = tmpop->op_next; /* fix starting loc */
3400 op_free(o); /* blow off assign */
3401 right->op_flags &= ~OPf_WANT;
3402 /* "I don't know and I don't care." */
3407 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3408 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3410 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3412 sv_setiv(sv, PL_modcount+1);
3420 right = newOP(OP_UNDEF, 0);
3421 if (right->op_type == OP_READLINE) {
3422 right->op_flags |= OPf_STACKED;
3423 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3426 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3427 o = newBINOP(OP_SASSIGN, flags,
3428 scalar(right), mod(scalar(left), OP_SASSIGN) );
3440 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3443 const U32 seq = intro_my();
3446 NewOp(1101, cop, 1, COP);
3447 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3448 cop->op_type = OP_DBSTATE;
3449 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3452 cop->op_type = OP_NEXTSTATE;
3453 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3455 cop->op_flags = (U8)flags;
3456 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3458 cop->op_private |= NATIVE_HINTS;
3460 PL_compiling.op_private = cop->op_private;
3461 cop->op_next = (OP*)cop;
3464 cop->cop_label = label;
3465 PL_hints |= HINT_BLOCK_SCOPE;
3468 cop->cop_arybase = PL_curcop->cop_arybase;
3469 if (specialWARN(PL_curcop->cop_warnings))
3470 cop->cop_warnings = PL_curcop->cop_warnings ;
3472 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3473 if (specialCopIO(PL_curcop->cop_io))
3474 cop->cop_io = PL_curcop->cop_io;
3476 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3479 if (PL_copline == NOLINE)
3480 CopLINE_set(cop, CopLINE(PL_curcop));
3482 CopLINE_set(cop, PL_copline);
3483 PL_copline = NOLINE;
3486 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3488 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3490 CopSTASH_set(cop, PL_curstash);
3492 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3493 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3494 if (svp && *svp != &PL_sv_undef ) {
3495 (void)SvIOK_on(*svp);
3496 SvIV_set(*svp, PTR2IV(cop));
3500 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3505 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3508 return new_logop(type, flags, &first, &other);
3512 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3517 OP *first = *firstp;
3518 OP *other = *otherp;
3520 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3521 return newBINOP(type, flags, scalar(first), scalar(other));
3523 scalarboolean(first);
3524 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3525 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3526 if (type == OP_AND || type == OP_OR) {
3532 first = *firstp = cUNOPo->op_first;
3534 first->op_next = o->op_next;
3535 cUNOPo->op_first = Nullop;
3539 if (first->op_type == OP_CONST) {
3540 if (first->op_private & OPpCONST_STRICT)
3541 no_bareword_allowed(first);
3542 else if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3543 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3544 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
3545 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
3546 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
3549 if (other->op_type == OP_CONST)
3550 other->op_private |= OPpCONST_SHORTCIRCUIT;
3554 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
3555 const OP *o2 = other;
3556 if ( ! (o2->op_type == OP_LIST
3557 && (( o2 = cUNOPx(o2)->op_first))
3558 && o2->op_type == OP_PUSHMARK
3559 && (( o2 = o2->op_sibling)) )
3562 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
3563 || o2->op_type == OP_PADHV)
3564 && o2->op_private & OPpLVAL_INTRO
3565 && ckWARN(WARN_DEPRECATED))
3567 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
3568 "Deprecated use of my() in false conditional");
3573 if (first->op_type == OP_CONST)
3574 first->op_private |= OPpCONST_SHORTCIRCUIT;
3578 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS) &&
3579 type != OP_DOR) /* [#24076] Don't warn for <FH> err FOO. */
3581 const OP *k1 = ((UNOP*)first)->op_first;
3582 const OP *k2 = k1->op_sibling;
3584 switch (first->op_type)
3587 if (k2 && k2->op_type == OP_READLINE
3588 && (k2->op_flags & OPf_STACKED)
3589 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3591 warnop = k2->op_type;
3596 if (k1->op_type == OP_READDIR
3597 || k1->op_type == OP_GLOB
3598 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3599 || k1->op_type == OP_EACH)
3601 warnop = ((k1->op_type == OP_NULL)
3602 ? (OPCODE)k1->op_targ : k1->op_type);
3607 const line_t oldline = CopLINE(PL_curcop);
3608 CopLINE_set(PL_curcop, PL_copline);
3609 Perl_warner(aTHX_ packWARN(WARN_MISC),
3610 "Value of %s%s can be \"0\"; test with defined()",
3612 ((warnop == OP_READLINE || warnop == OP_GLOB)
3613 ? " construct" : "() operator"));
3614 CopLINE_set(PL_curcop, oldline);
3621 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3622 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3624 NewOp(1101, logop, 1, LOGOP);
3626 logop->op_type = (OPCODE)type;
3627 logop->op_ppaddr = PL_ppaddr[type];
3628 logop->op_first = first;
3629 logop->op_flags = flags | OPf_KIDS;
3630 logop->op_other = LINKLIST(other);
3631 logop->op_private = (U8)(1 | (flags >> 8));
3633 /* establish postfix order */
3634 logop->op_next = LINKLIST(first);
3635 first->op_next = (OP*)logop;
3636 first->op_sibling = other;
3638 CHECKOP(type,logop);
3640 o = newUNOP(OP_NULL, 0, (OP*)logop);
3647 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3655 return newLOGOP(OP_AND, 0, first, trueop);
3657 return newLOGOP(OP_OR, 0, first, falseop);
3659 scalarboolean(first);
3660 if (first->op_type == OP_CONST) {
3661 if (first->op_private & OPpCONST_BARE &&
3662 first->op_private & OPpCONST_STRICT) {
3663 no_bareword_allowed(first);
3665 if (SvTRUE(((SVOP*)first)->op_sv)) {
3676 NewOp(1101, logop, 1, LOGOP);
3677 logop->op_type = OP_COND_EXPR;
3678 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3679 logop->op_first = first;
3680 logop->op_flags = flags | OPf_KIDS;
3681 logop->op_private = (U8)(1 | (flags >> 8));
3682 logop->op_other = LINKLIST(trueop);
3683 logop->op_next = LINKLIST(falseop);
3685 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
3688 /* establish postfix order */
3689 start = LINKLIST(first);
3690 first->op_next = (OP*)logop;
3692 first->op_sibling = trueop;
3693 trueop->op_sibling = falseop;
3694 o = newUNOP(OP_NULL, 0, (OP*)logop);
3696 trueop->op_next = falseop->op_next = o;
3703 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3712 NewOp(1101, range, 1, LOGOP);
3714 range->op_type = OP_RANGE;
3715 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3716 range->op_first = left;
3717 range->op_flags = OPf_KIDS;
3718 leftstart = LINKLIST(left);
3719 range->op_other = LINKLIST(right);
3720 range->op_private = (U8)(1 | (flags >> 8));
3722 left->op_sibling = right;
3724 range->op_next = (OP*)range;
3725 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3726 flop = newUNOP(OP_FLOP, 0, flip);
3727 o = newUNOP(OP_NULL, 0, flop);
3729 range->op_next = leftstart;
3731 left->op_next = flip;
3732 right->op_next = flop;
3734 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3735 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3736 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3737 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3739 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3740 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3743 if (!flip->op_private || !flop->op_private)
3744 linklist(o); /* blow off optimizer unless constant */
3750 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3754 const bool once = block && block->op_flags & OPf_SPECIAL &&
3755 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3759 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3760 return block; /* do {} while 0 does once */
3761 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3762 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3763 expr = newUNOP(OP_DEFINED, 0,
3764 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3765 } else if (expr->op_flags & OPf_KIDS) {
3766 const OP *k1 = ((UNOP*)expr)->op_first;
3767 const OP *k2 = (k1) ? k1->op_sibling : NULL;
3768 switch (expr->op_type) {
3770 if (k2 && k2->op_type == OP_READLINE
3771 && (k2->op_flags & OPf_STACKED)
3772 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3773 expr = newUNOP(OP_DEFINED, 0, expr);
3777 if (k1->op_type == OP_READDIR
3778 || k1->op_type == OP_GLOB
3779 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3780 || k1->op_type == OP_EACH)
3781 expr = newUNOP(OP_DEFINED, 0, expr);
3787 /* if block is null, the next append_elem() would put UNSTACK, a scalar
3788 * op, in listop. This is wrong. [perl #27024] */
3790 block = newOP(OP_NULL, 0);
3791 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3792 o = new_logop(OP_AND, 0, &expr, &listop);
3795 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3797 if (once && o != listop)
3798 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3801 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3803 o->op_flags |= flags;
3805 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3810 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
3811 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
3821 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3822 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3823 expr = newUNOP(OP_DEFINED, 0,
3824 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3825 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3826 const OP *k1 = ((UNOP*)expr)->op_first;
3827 const OP *k2 = (k1) ? k1->op_sibling : NULL;
3828 switch (expr->op_type) {
3830 if (k2 && k2->op_type == OP_READLINE
3831 && (k2->op_flags & OPf_STACKED)
3832 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3833 expr = newUNOP(OP_DEFINED, 0, expr);
3837 if (k1->op_type == OP_READDIR
3838 || k1->op_type == OP_GLOB
3839 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3840 || k1->op_type == OP_EACH)
3841 expr = newUNOP(OP_DEFINED, 0, expr);
3847 block = newOP(OP_NULL, 0);
3848 else if (cont || has_my) {
3849 block = scope(block);
3853 next = LINKLIST(cont);
3856 OP *unstack = newOP(OP_UNSTACK, 0);
3859 cont = append_elem(OP_LINESEQ, cont, unstack);
3862 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3863 redo = LINKLIST(listop);
3866 PL_copline = (line_t)whileline;
3868 o = new_logop(OP_AND, 0, &expr, &listop);
3869 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3870 op_free(expr); /* oops, it's a while (0) */
3872 return Nullop; /* listop already freed by new_logop */
3875 ((LISTOP*)listop)->op_last->op_next =
3876 (o == listop ? redo : LINKLIST(o));
3882 NewOp(1101,loop,1,LOOP);
3883 loop->op_type = OP_ENTERLOOP;
3884 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3885 loop->op_private = 0;
3886 loop->op_next = (OP*)loop;
3889 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3891 loop->op_redoop = redo;
3892 loop->op_lastop = o;
3893 o->op_private |= loopflags;
3896 loop->op_nextop = next;
3898 loop->op_nextop = o;
3900 o->op_flags |= flags;
3901 o->op_private |= (flags >> 8);
3906 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
3911 PADOFFSET padoff = 0;
3916 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
3917 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
3918 sv->op_type = OP_RV2GV;
3919 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3921 else if (sv->op_type == OP_PADSV) { /* private variable */
3922 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
3923 padoff = sv->op_targ;
3928 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3929 padoff = sv->op_targ;
3931 iterflags |= OPf_SPECIAL;
3936 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3939 const I32 offset = pad_findmy("$_");
3940 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
3941 sv = newGVOP(OP_GV, 0, PL_defgv);
3947 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3948 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3949 iterflags |= OPf_STACKED;
3951 else if (expr->op_type == OP_NULL &&
3952 (expr->op_flags & OPf_KIDS) &&
3953 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3955 /* Basically turn for($x..$y) into the same as for($x,$y), but we
3956 * set the STACKED flag to indicate that these values are to be
3957 * treated as min/max values by 'pp_iterinit'.
3959 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
3960 LOGOP* range = (LOGOP*) flip->op_first;
3961 OP* left = range->op_first;
3962 OP* right = left->op_sibling;
3965 range->op_flags &= ~OPf_KIDS;
3966 range->op_first = Nullop;
3968 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
3969 listop->op_first->op_next = range->op_next;
3970 left->op_next = range->op_other;
3971 right->op_next = (OP*)listop;
3972 listop->op_next = listop->op_first;
3975 expr = (OP*)(listop);
3977 iterflags |= OPf_STACKED;
3980 expr = mod(force_list(expr), OP_GREPSTART);
3983 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
3984 append_elem(OP_LIST, expr, scalar(sv))));
3985 assert(!loop->op_next);
3986 /* for my $x () sets OPpLVAL_INTRO;
3987 * for our $x () sets OPpOUR_INTRO */
3988 loop->op_private = (U8)iterpflags;
3989 #ifdef PL_OP_SLAB_ALLOC
3992 NewOp(1234,tmp,1,LOOP);
3993 Copy(loop,tmp,1,LISTOP);
3998 Renew(loop, 1, LOOP);
4000 loop->op_targ = padoff;
4001 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4002 PL_copline = forline;
4003 return newSTATEOP(0, label, wop);
4007 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4012 if (type != OP_GOTO || label->op_type == OP_CONST) {
4013 /* "last()" means "last" */
4014 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4015 o = newOP(type, OPf_SPECIAL);
4017 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4018 ? SvPVx(((SVOP*)label)->op_sv, n_a)
4024 /* Check whether it's going to be a goto &function */
4025 if (label->op_type == OP_ENTERSUB
4026 && !(label->op_flags & OPf_STACKED))
4027 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4028 o = newUNOP(type, OPf_STACKED, label);
4030 PL_hints |= HINT_BLOCK_SCOPE;
4035 =for apidoc cv_undef
4037 Clear out all the active components of a CV. This can happen either
4038 by an explicit C<undef &foo>, or by the reference count going to zero.
4039 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4040 children can still follow the full lexical scope chain.
4046 Perl_cv_undef(pTHX_ CV *cv)
4050 if (CvFILE(cv) && !CvXSUB(cv)) {
4051 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4052 Safefree(CvFILE(cv));
4057 if (!CvXSUB(cv) && CvROOT(cv)) {
4059 Perl_croak(aTHX_ "Can't undef active subroutine");
4062 PAD_SAVE_SETNULLPAD();
4064 op_free(CvROOT(cv));
4065 CvROOT(cv) = Nullop;
4068 SvPOK_off((SV*)cv); /* forget prototype */
4073 /* remove CvOUTSIDE unless this is an undef rather than a free */
4074 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4075 if (!CvWEAKOUTSIDE(cv))
4076 SvREFCNT_dec(CvOUTSIDE(cv));
4077 CvOUTSIDE(cv) = Nullcv;
4080 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4086 /* delete all flags except WEAKOUTSIDE */
4087 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4091 Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p)
4093 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4094 SV* msg = sv_newmortal();
4098 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4099 sv_setpv(msg, "Prototype mismatch:");
4101 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4103 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (const SV *)cv);
4105 Perl_sv_catpv(aTHX_ msg, ": none");
4106 sv_catpv(msg, " vs ");
4108 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4110 sv_catpv(msg, "none");
4111 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
4115 static void const_sv_xsub(pTHX_ CV* cv);
4119 =head1 Optree Manipulation Functions
4121 =for apidoc cv_const_sv
4123 If C<cv> is a constant sub eligible for inlining. returns the constant
4124 value returned by the sub. Otherwise, returns NULL.
4126 Constant subs can be created with C<newCONSTSUB> or as described in
4127 L<perlsub/"Constant Functions">.
4132 Perl_cv_const_sv(pTHX_ CV *cv)
4134 if (!cv || !CvCONST(cv))
4136 return (SV*)CvXSUBANY(cv).any_ptr;
4139 /* op_const_sv: examine an optree to determine whether it's in-lineable.
4140 * Can be called in 3 ways:
4143 * look for a single OP_CONST with attached value: return the value
4145 * cv && CvCLONE(cv) && !CvCONST(cv)
4147 * examine the clone prototype, and if contains only a single
4148 * OP_CONST referencing a pad const, or a single PADSV referencing
4149 * an outer lexical, return a non-zero value to indicate the CV is
4150 * a candidate for "constizing" at clone time
4154 * We have just cloned an anon prototype that was marked as a const
4155 * candidiate. Try to grab the current value, and in the case of
4156 * PADSV, ignore it if it has multiple references. Return the value.
4160 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
4167 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4168 o = cLISTOPo->op_first->op_sibling;
4170 for (; o; o = o->op_next) {
4171 OPCODE type = o->op_type;
4173 if (sv && o->op_next == o)
4175 if (o->op_next != o) {
4176 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4178 if (type == OP_DBSTATE)
4181 if (type == OP_LEAVESUB || type == OP_RETURN)
4185 if (type == OP_CONST && cSVOPo->op_sv)
4187 else if (cv && type == OP_CONST) {
4188 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4192 else if (cv && type == OP_PADSV) {
4193 if (CvCONST(cv)) { /* newly cloned anon */
4194 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4195 /* the candidate should have 1 ref from this pad and 1 ref
4196 * from the parent */
4197 if (!sv || SvREFCNT(sv) != 2)
4204 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4205 sv = &PL_sv_undef; /* an arbitrary non-null value */
4216 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4227 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4231 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4233 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4237 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4248 const char * const name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4251 assert(proto->op_type == OP_CONST);
4252 ps = SvPVx(((SVOP*)proto)->op_sv, ps_len);
4257 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4258 SV *sv = sv_newmortal();
4259 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4260 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4261 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4266 gv = name ? gv_fetchsv(cSVOPo->op_sv,
4267 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4269 : gv_fetchpv(aname ? aname
4270 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4271 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4281 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4282 maximum a prototype before. */
4283 if (SvTYPE(gv) > SVt_NULL) {
4284 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4285 && ckWARN_d(WARN_PROTOTYPE))
4287 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4289 cv_ckproto((CV*)gv, NULL, ps);
4292 sv_setpvn((SV*)gv, ps, ps_len);
4294 sv_setiv((SV*)gv, -1);
4295 SvREFCNT_dec(PL_compcv);
4296 cv = PL_compcv = NULL;
4297 PL_sub_generation++;
4301 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4303 #ifdef GV_UNIQUE_CHECK
4304 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4305 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4309 if (!block || !ps || *ps || attrs)
4312 const_sv = op_const_sv(block, Nullcv);
4315 const bool exists = CvROOT(cv) || CvXSUB(cv);
4317 #ifdef GV_UNIQUE_CHECK
4318 if (exists && GvUNIQUE(gv)) {
4319 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4323 /* if the subroutine doesn't exist and wasn't pre-declared
4324 * with a prototype, assume it will be AUTOLOADed,
4325 * skipping the prototype check
4327 if (exists || SvPOK(cv))
4328 cv_ckproto(cv, gv, ps);
4329 /* already defined (or promised)? */
4330 if (exists || GvASSUMECV(gv)) {
4331 if (!block && !attrs) {
4332 if (CvFLAGS(PL_compcv)) {
4333 /* might have had built-in attrs applied */
4334 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4336 /* just a "sub foo;" when &foo is already defined */
4337 SAVEFREESV(PL_compcv);
4340 /* ahem, death to those who redefine active sort subs */
4341 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4342 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4344 if (ckWARN(WARN_REDEFINE)
4346 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4348 const line_t oldline = CopLINE(PL_curcop);
4349 if (PL_copline != NOLINE)
4350 CopLINE_set(PL_curcop, PL_copline);
4351 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4352 CvCONST(cv) ? "Constant subroutine %s redefined"
4353 : "Subroutine %s redefined", name);
4354 CopLINE_set(PL_curcop, oldline);
4362 (void)SvREFCNT_inc(const_sv);
4364 assert(!CvROOT(cv) && !CvCONST(cv));
4365 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
4366 CvXSUBANY(cv).any_ptr = const_sv;
4367 CvXSUB(cv) = const_sv_xsub;
4372 cv = newCONSTSUB(NULL, name, const_sv);
4375 SvREFCNT_dec(PL_compcv);
4377 PL_sub_generation++;
4384 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4385 * before we clobber PL_compcv.
4389 /* Might have had built-in attributes applied -- propagate them. */
4390 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4391 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4392 stash = GvSTASH(CvGV(cv));
4393 else if (CvSTASH(cv))
4394 stash = CvSTASH(cv);
4396 stash = PL_curstash;
4399 /* possibly about to re-define existing subr -- ignore old cv */
4400 rcv = (SV*)PL_compcv;
4401 if (name && GvSTASH(gv))
4402 stash = GvSTASH(gv);
4404 stash = PL_curstash;
4406 apply_attrs(stash, rcv, attrs, FALSE);
4408 if (cv) { /* must reuse cv if autoloaded */
4410 /* got here with just attrs -- work done, so bug out */
4411 SAVEFREESV(PL_compcv);
4414 /* transfer PL_compcv to cv */
4416 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4417 if (!CvWEAKOUTSIDE(cv))
4418 SvREFCNT_dec(CvOUTSIDE(cv));
4419 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4420 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4421 CvOUTSIDE(PL_compcv) = 0;
4422 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4423 CvPADLIST(PL_compcv) = 0;
4424 /* inner references to PL_compcv must be fixed up ... */
4425 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4426 /* ... before we throw it away */
4427 SvREFCNT_dec(PL_compcv);
4429 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4430 ++PL_sub_generation;
4437 PL_sub_generation++;
4441 CvFILE_set_from_cop(cv, PL_curcop);
4442 CvSTASH(cv) = PL_curstash;
4445 sv_setpvn((SV*)cv, ps, ps_len);
4447 if (PL_error_count) {
4451 const char *s = strrchr(name, ':');
4453 if (strEQ(s, "BEGIN")) {
4454 const char not_safe[] =
4455 "BEGIN not safe after errors--compilation aborted";
4456 if (PL_in_eval & EVAL_KEEPERR)
4457 Perl_croak(aTHX_ not_safe);
4459 /* force display of errors found but not reported */
4460 sv_catpv(ERRSV, not_safe);
4461 Perl_croak(aTHX_ "%"SVf, ERRSV);
4470 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4471 mod(scalarseq(block), OP_LEAVESUBLV));
4474 /* This makes sub {}; work as expected. */
4475 if (block->op_type == OP_STUB) {
4477 block = newSTATEOP(0, Nullch, 0);
4479 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4481 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4482 OpREFCNT_set(CvROOT(cv), 1);
4483 CvSTART(cv) = LINKLIST(CvROOT(cv));
4484 CvROOT(cv)->op_next = 0;
4485 CALL_PEEP(CvSTART(cv));
4487 /* now that optimizer has done its work, adjust pad values */
4489 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4492 assert(!CvCONST(cv));
4493 if (ps && !*ps && op_const_sv(block, cv))
4497 if (name || aname) {
4499 const char *tname = (name ? name : aname);
4501 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4502 SV *sv = NEWSV(0,0);
4503 SV *tmpstr = sv_newmortal();
4504 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4508 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4510 (long)PL_subline, (long)CopLINE(PL_curcop));
4511 gv_efullname3(tmpstr, gv, Nullch);
4512 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4513 hv = GvHVn(db_postponed);
4514 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4515 && (pcv = GvCV(db_postponed)))
4521 call_sv((SV*)pcv, G_DISCARD);
4525 if ((s = strrchr(tname,':')))
4530 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4533 if (strEQ(s, "BEGIN") && !PL_error_count) {
4534 const I32 oldscope = PL_scopestack_ix;
4536 SAVECOPFILE(&PL_compiling);
4537 SAVECOPLINE(&PL_compiling);
4540 PL_beginav = newAV();
4541 DEBUG_x( dump_sub(gv) );
4542 av_push(PL_beginav, (SV*)cv);
4543 GvCV(gv) = 0; /* cv has been hijacked */
4544 call_list(oldscope, PL_beginav);
4546 PL_curcop = &PL_compiling;
4547 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4550 else if (strEQ(s, "END") && !PL_error_count) {
4553 DEBUG_x( dump_sub(gv) );
4554 av_unshift(PL_endav, 1);
4555 av_store(PL_endav, 0, (SV*)cv);
4556 GvCV(gv) = 0; /* cv has been hijacked */
4558 else if (strEQ(s, "CHECK") && !PL_error_count) {
4560 PL_checkav = newAV();
4561 DEBUG_x( dump_sub(gv) );
4562 if (PL_main_start && ckWARN(WARN_VOID))
4563 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4564 av_unshift(PL_checkav, 1);
4565 av_store(PL_checkav, 0, (SV*)cv);
4566 GvCV(gv) = 0; /* cv has been hijacked */
4568 else if (strEQ(s, "INIT") && !PL_error_count) {
4570 PL_initav = newAV();
4571 DEBUG_x( dump_sub(gv) );
4572 if (PL_main_start && ckWARN(WARN_VOID))
4573 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4574 av_push(PL_initav, (SV*)cv);
4575 GvCV(gv) = 0; /* cv has been hijacked */
4580 PL_copline = NOLINE;
4585 /* XXX unsafe for threads if eval_owner isn't held */
4587 =for apidoc newCONSTSUB
4589 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4590 eligible for inlining at compile-time.
4596 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
4603 SAVECOPLINE(PL_curcop);
4604 CopLINE_set(PL_curcop, PL_copline);
4607 PL_hints &= ~HINT_BLOCK_SCOPE;
4610 SAVESPTR(PL_curstash);
4611 SAVECOPSTASH(PL_curcop);
4612 PL_curstash = stash;
4613 CopSTASH_set(PL_curcop,stash);
4616 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4617 CvXSUBANY(cv).any_ptr = sv;
4619 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
4622 CopSTASH_free(PL_curcop);
4630 =for apidoc U||newXS
4632 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4638 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
4640 GV *gv = gv_fetchpv(name ? name :
4641 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4642 GV_ADDMULTI, SVt_PVCV);
4646 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4648 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4650 /* just a cached method */
4654 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4655 /* already defined (or promised) */
4656 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4657 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4658 const line_t oldline = CopLINE(PL_curcop);
4659 if (PL_copline != NOLINE)
4660 CopLINE_set(PL_curcop, PL_copline);
4661 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4662 CvCONST(cv) ? "Constant subroutine %s redefined"
4663 : "Subroutine %s redefined"
4665 CopLINE_set(PL_curcop, oldline);
4672 if (cv) /* must reuse cv if autoloaded */
4675 cv = (CV*)NEWSV(1105,0);
4676 sv_upgrade((SV *)cv, SVt_PVCV);
4680 PL_sub_generation++;
4684 (void)gv_fetchfile(filename);
4685 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
4686 an external constant string */
4687 CvXSUB(cv) = subaddr;
4690 const char *s = strrchr(name,':');
4696 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4699 if (strEQ(s, "BEGIN")) {
4701 PL_beginav = newAV();
4702 av_push(PL_beginav, (SV*)cv);
4703 GvCV(gv) = 0; /* cv has been hijacked */
4705 else if (strEQ(s, "END")) {
4708 av_unshift(PL_endav, 1);
4709 av_store(PL_endav, 0, (SV*)cv);
4710 GvCV(gv) = 0; /* cv has been hijacked */
4712 else if (strEQ(s, "CHECK")) {
4714 PL_checkav = newAV();
4715 if (PL_main_start && ckWARN(WARN_VOID))
4716 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4717 av_unshift(PL_checkav, 1);
4718 av_store(PL_checkav, 0, (SV*)cv);
4719 GvCV(gv) = 0; /* cv has been hijacked */
4721 else if (strEQ(s, "INIT")) {
4723 PL_initav = newAV();
4724 if (PL_main_start && ckWARN(WARN_VOID))
4725 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4726 av_push(PL_initav, (SV*)cv);
4727 GvCV(gv) = 0; /* cv has been hijacked */
4738 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4744 gv = gv_fetchsv(cSVOPo->op_sv, TRUE, SVt_PVFM);
4746 gv = gv_fetchpv("STDOUT", TRUE, SVt_PVFM);
4748 #ifdef GV_UNIQUE_CHECK
4750 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4754 if ((cv = GvFORM(gv))) {
4755 if (ckWARN(WARN_REDEFINE)) {
4756 const line_t oldline = CopLINE(PL_curcop);
4757 if (PL_copline != NOLINE)
4758 CopLINE_set(PL_curcop, PL_copline);
4759 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4760 o ? "Format %"SVf" redefined"
4761 : "Format STDOUT redefined" ,cSVOPo->op_sv);
4762 CopLINE_set(PL_curcop, oldline);
4769 CvFILE_set_from_cop(cv, PL_curcop);
4772 pad_tidy(padtidy_FORMAT);
4773 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4774 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4775 OpREFCNT_set(CvROOT(cv), 1);
4776 CvSTART(cv) = LINKLIST(CvROOT(cv));
4777 CvROOT(cv)->op_next = 0;
4778 CALL_PEEP(CvSTART(cv));
4780 PL_copline = NOLINE;
4785 Perl_newANONLIST(pTHX_ OP *o)
4787 return newUNOP(OP_REFGEN, 0,
4788 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4792 Perl_newANONHASH(pTHX_ OP *o)
4794 return newUNOP(OP_REFGEN, 0,
4795 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4799 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4801 return newANONATTRSUB(floor, proto, Nullop, block);
4805 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4807 return newUNOP(OP_REFGEN, 0,
4808 newSVOP(OP_ANONCODE, 0,
4809 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
<