3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
13 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
14 * youngest of the Old Took's daughters); and Mr. Drogo was his second
15 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
16 * either way, as the saying is, if you follow me." --the Gaffer
19 /* This file contains the functions that create, manipulate and optimize
20 * the OP structures that hold a compiled perl program.
22 * A Perl program is compiled into a tree of OPs. Each op contains
23 * structural pointers (eg to its siblings and the next op in the
24 * execution sequence), a pointer to the function that would execute the
25 * op, plus any data specific to that op. For example, an OP_CONST op
26 * points to the pp_const() function and to an SV containing the constant
27 * value. When pp_const() is executed, its job is to push that SV onto the
30 * OPs are mainly created by the newFOO() functions, which are mainly
31 * called from the parser (in perly.y) as the code is parsed. For example
32 * the Perl code $a + $b * $c would cause the equivalent of the following
33 * to be called (oversimplifying a bit):
35 * newBINOP(OP_ADD, flags,
37 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
40 * Note that during the build of miniperl, a temporary copy of this file
41 * is made, called opmini.c.
45 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
49 An execution-order pass
51 The bottom-up pass is represented by all the "newOP" routines and
52 the ck_ routines. The bottom-upness is actually driven by yacc.
53 So at the point that a ck_ routine fires, we have no idea what the
54 context is, either upward in the syntax tree, or either forward or
55 backward in the execution order. (The bottom-up parser builds that
56 part of the execution order it knows about, but if you follow the "next"
57 links around, you'll find it's actually a closed loop through the
60 Whenever the bottom-up parser gets to a node that supplies context to
61 its components, it invokes that portion of the top-down pass that applies
62 to that part of the subtree (and marks the top node as processed, so
63 if a node further up supplies context, it doesn't have to take the
64 plunge again). As a particular subcase of this, as the new node is
65 built, it takes all the closed execution loops of its subcomponents
66 and links them into a new closed loop for the higher level node. But
67 it's still not the real execution order.
69 The actual execution order is not known till we get a grammar reduction
70 to a top-level unit like a subroutine or file that will be called by
71 "name" rather than via a "next" pointer. At that point, we can call
72 into peep() to do that code's portion of the 3rd pass. It has to be
73 recursive, but it's recursive on basic blocks, not on tree nodes.
81 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
83 #if defined(PL_OP_SLAB_ALLOC)
85 #ifndef PERL_SLAB_SIZE
86 #define PERL_SLAB_SIZE 2048
90 Perl_Slab_Alloc(pTHX_ int m, size_t sz)
93 * To make incrementing use count easy PL_OpSlab is an I32 *
94 * To make inserting the link to slab PL_OpPtr is I32 **
95 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
96 * Add an overhead for pointer to slab and round up as a number of pointers
98 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
99 if ((PL_OpSpace -= sz) < 0) {
100 PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*));
104 Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **);
105 /* We reserve the 0'th I32 sized chunk as a use count */
106 PL_OpSlab = (I32 *) PL_OpPtr;
107 /* Reduce size by the use count word, and by the size we need.
108 * Latter is to mimic the '-=' in the if() above
110 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
111 /* Allocation pointer starts at the top.
112 Theory: because we build leaves before trunk allocating at end
113 means that at run time access is cache friendly upward
115 PL_OpPtr += PERL_SLAB_SIZE;
117 assert( PL_OpSpace >= 0 );
118 /* Move the allocation pointer down */
120 assert( PL_OpPtr > (I32 **) PL_OpSlab );
121 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
122 (*PL_OpSlab)++; /* Increment use count of slab */
123 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
124 assert( *PL_OpSlab > 0 );
125 return (void *)(PL_OpPtr + 1);
129 Perl_Slab_Free(pTHX_ void *op)
131 I32 **ptr = (I32 **) op;
133 assert( ptr-1 > (I32 **) slab );
134 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
136 if (--(*slab) == 0) {
138 # define PerlMemShared PerlMem
141 PerlMemShared_free(slab);
142 if (slab == PL_OpSlab) {
149 * In the following definition, the ", Nullop" is just to make the compiler
150 * think the expression is of the right type: croak actually does a Siglongjmp.
152 #define CHECKOP(type,o) \
153 ((PL_op_mask && PL_op_mask[type]) \
154 ? ( op_free((OP*)o), \
155 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
157 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
159 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
162 S_gv_ename(pTHX_ GV *gv)
165 SV* tmpsv = sv_newmortal();
166 gv_efullname3(tmpsv, gv, Nullch);
167 return SvPV(tmpsv,n_a);
171 S_no_fh_allowed(pTHX_ OP *o)
173 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
179 S_too_few_arguments(pTHX_ OP *o, const char *name)
181 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
186 S_too_many_arguments(pTHX_ OP *o, const char *name)
188 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
193 S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
195 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
196 (int)n, name, t, OP_DESC(kid)));
200 S_no_bareword_allowed(pTHX_ const OP *o)
202 qerror(Perl_mess(aTHX_
203 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
207 /* "register" allocation */
210 Perl_allocmy(pTHX_ char *name)
214 /* complain about "my $<special_var>" etc etc */
215 if (!(PL_in_my == KEY_our ||
217 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
218 (name[1] == '_' && (*name == '$' || (int)strlen(name) > 2))))
220 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
221 /* 1999-02-27 mjd@plover.com */
223 p = strchr(name, '\0');
224 /* The next block assumes the buffer is at least 205 chars
225 long. At present, it's always at least 256 chars. */
227 strcpy(name+200, "...");
233 /* Move everything else down one character */
234 for (; p-name > 2; p--)
236 name[2] = toCTRL(name[1]);
239 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
242 /* check for duplicate declaration */
244 (bool)(PL_in_my == KEY_our),
245 (PL_curstash ? PL_curstash : PL_defstash)
248 if (PL_in_my_stash && *name != '$') {
249 yyerror(Perl_form(aTHX_
250 "Can't declare class for non-scalar %s in \"%s\"",
251 name, PL_in_my == KEY_our ? "our" : "my"));
254 /* allocate a spare slot and store the name in that slot */
256 off = pad_add_name(name,
259 /* $_ is always in main::, even with our */
260 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
271 Perl_op_free(pTHX_ OP *o)
277 if (!o || o->op_static)
280 if (o->op_private & OPpREFCOUNTED) {
281 switch (o->op_type) {
289 refcnt = OpREFCNT_dec(o);
299 if (o->op_flags & OPf_KIDS) {
300 register OP *kid, *nextkid;
301 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
302 nextkid = kid->op_sibling; /* Get before next freeing kid */
308 type = (OPCODE)o->op_targ;
310 /* COP* is not cleared by op_clear() so that we may track line
311 * numbers etc even after null() */
312 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
317 #ifdef DEBUG_LEAKING_SCALARS
324 Perl_op_clear(pTHX_ OP *o)
328 switch (o->op_type) {
329 case OP_NULL: /* Was holding old type, if any. */
330 case OP_ENTEREVAL: /* Was holding hints. */
334 if (!(o->op_flags & OPf_REF)
335 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
341 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
342 /* not an OP_PADAV replacement */
344 if (cPADOPo->op_padix > 0) {
345 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
346 * may still exist on the pad */
347 pad_swipe(cPADOPo->op_padix, TRUE);
348 cPADOPo->op_padix = 0;
351 SvREFCNT_dec(cSVOPo->op_sv);
352 cSVOPo->op_sv = Nullsv;
356 case OP_METHOD_NAMED:
358 SvREFCNT_dec(cSVOPo->op_sv);
359 cSVOPo->op_sv = Nullsv;
362 Even if op_clear does a pad_free for the target of the op,
363 pad_free doesn't actually remove the sv that exists in the pad;
364 instead it lives on. This results in that it could be reused as
365 a target later on when the pad was reallocated.
368 pad_swipe(o->op_targ,1);
377 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
381 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
382 SvREFCNT_dec(cSVOPo->op_sv);
383 cSVOPo->op_sv = Nullsv;
386 Safefree(cPVOPo->op_pv);
387 cPVOPo->op_pv = Nullch;
391 op_free(cPMOPo->op_pmreplroot);
395 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
396 /* No GvIN_PAD_off here, because other references may still
397 * exist on the pad */
398 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
401 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
408 HV *pmstash = PmopSTASH(cPMOPo);
409 if (pmstash && SvREFCNT(pmstash)) {
410 MAGIC *mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab);
412 PMOP *pmop = (PMOP*) mg->mg_obj;
413 PMOP *lastpmop = NULL;
415 if (cPMOPo == pmop) {
417 lastpmop->op_pmnext = pmop->op_pmnext;
419 mg->mg_obj = (SV*) pmop->op_pmnext;
423 pmop = pmop->op_pmnext;
427 PmopSTASH_free(cPMOPo);
429 cPMOPo->op_pmreplroot = Nullop;
430 /* we use the "SAFE" version of the PM_ macros here
431 * since sv_clean_all might release some PMOPs
432 * after PL_regex_padav has been cleared
433 * and the clearing of PL_regex_padav needs to
434 * happen before sv_clean_all
436 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
437 PM_SETRE_SAFE(cPMOPo, (REGEXP*)NULL);
439 if(PL_regex_pad) { /* We could be in destruction */
440 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
441 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
442 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
449 if (o->op_targ > 0) {
450 pad_free(o->op_targ);
456 S_cop_free(pTHX_ COP* cop)
458 Safefree(cop->cop_label); /* FIXME: treaddead ??? */
461 if (! specialWARN(cop->cop_warnings))
462 SvREFCNT_dec(cop->cop_warnings);
463 if (! specialCopIO(cop->cop_io)) {
467 char *s = SvPV(cop->cop_io,len);
468 Perl_warn(aTHX_ "io='%.*s'",(int) len,s); /* ??? --jhi */
471 SvREFCNT_dec(cop->cop_io);
477 Perl_op_null(pTHX_ OP *o)
480 if (o->op_type == OP_NULL)
483 o->op_targ = o->op_type;
484 o->op_type = OP_NULL;
485 o->op_ppaddr = PL_ppaddr[OP_NULL];
489 Perl_op_refcnt_lock(pTHX)
496 Perl_op_refcnt_unlock(pTHX)
502 /* Contextualizers */
504 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
507 Perl_linklist(pTHX_ OP *o)
513 /* establish postfix order */
514 if (cUNOPo->op_first) {
516 o->op_next = LINKLIST(cUNOPo->op_first);
517 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
519 kid->op_next = LINKLIST(kid->op_sibling);
531 Perl_scalarkids(pTHX_ OP *o)
533 if (o && o->op_flags & OPf_KIDS) {
535 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
542 S_scalarboolean(pTHX_ OP *o)
544 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
545 if (ckWARN(WARN_SYNTAX)) {
546 const line_t oldline = CopLINE(PL_curcop);
548 if (PL_copline != NOLINE)
549 CopLINE_set(PL_curcop, PL_copline);
550 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
551 CopLINE_set(PL_curcop, oldline);
558 Perl_scalar(pTHX_ OP *o)
563 /* assumes no premature commitment */
564 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
565 || o->op_type == OP_RETURN)
570 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
572 switch (o->op_type) {
574 scalar(cBINOPo->op_first);
579 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
583 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
584 if (!kPMOP->op_pmreplroot)
585 deprecate_old("implicit split to @_");
593 if (o->op_flags & OPf_KIDS) {
594 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
600 kid = cLISTOPo->op_first;
602 while ((kid = kid->op_sibling)) {
608 WITH_THR(PL_curcop = &PL_compiling);
613 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
619 WITH_THR(PL_curcop = &PL_compiling);
622 if (ckWARN(WARN_VOID))
623 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
629 Perl_scalarvoid(pTHX_ OP *o)
633 const char* useless = 0;
637 if (o->op_type == OP_NEXTSTATE
638 || o->op_type == OP_SETSTATE
639 || o->op_type == OP_DBSTATE
640 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
641 || o->op_targ == OP_SETSTATE
642 || o->op_targ == OP_DBSTATE)))
643 PL_curcop = (COP*)o; /* for warning below */
645 /* assumes no premature commitment */
646 want = o->op_flags & OPf_WANT;
647 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
648 || o->op_type == OP_RETURN)
653 if ((o->op_private & OPpTARGET_MY)
654 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
656 return scalar(o); /* As if inside SASSIGN */
659 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
661 switch (o->op_type) {
663 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
667 if (o->op_flags & OPf_STACKED)
671 if (o->op_private == 4)
743 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
744 useless = OP_DESC(o);
748 kid = cUNOPo->op_first;
749 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
750 kid->op_type != OP_TRANS) {
753 useless = "negative pattern binding (!~)";
760 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
761 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
762 useless = "a variable";
767 if (cSVOPo->op_private & OPpCONST_STRICT)
768 no_bareword_allowed(o);
770 if (ckWARN(WARN_VOID)) {
771 useless = "a constant";
772 /* don't warn on optimised away booleans, eg
773 * use constant Foo, 5; Foo || print; */
774 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
776 /* the constants 0 and 1 are permitted as they are
777 conventionally used as dummies in constructs like
778 1 while some_condition_with_side_effects; */
779 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
781 else if (SvPOK(sv)) {
782 /* perl4's way of mixing documentation and code
783 (before the invention of POD) was based on a
784 trick to mix nroff and perl code. The trick was
785 built upon these three nroff macros being used in
786 void context. The pink camel has the details in
787 the script wrapman near page 319. */
788 if (strnEQ(SvPVX_const(sv), "di", 2) ||
789 strnEQ(SvPVX_const(sv), "ds", 2) ||
790 strnEQ(SvPVX_const(sv), "ig", 2))
795 op_null(o); /* don't execute or even remember it */
799 o->op_type = OP_PREINC; /* pre-increment is faster */
800 o->op_ppaddr = PL_ppaddr[OP_PREINC];
804 o->op_type = OP_PREDEC; /* pre-decrement is faster */
805 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
812 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
817 if (o->op_flags & OPf_STACKED)
824 if (!(o->op_flags & OPf_KIDS))
833 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
840 /* all requires must return a boolean value */
841 o->op_flags &= ~OPf_WANT;
846 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
847 if (!kPMOP->op_pmreplroot)
848 deprecate_old("implicit split to @_");
852 if (useless && ckWARN(WARN_VOID))
853 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
858 Perl_listkids(pTHX_ OP *o)
860 if (o && o->op_flags & OPf_KIDS) {
862 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
869 Perl_list(pTHX_ OP *o)
874 /* assumes no premature commitment */
875 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
876 || o->op_type == OP_RETURN)
881 if ((o->op_private & OPpTARGET_MY)
882 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
884 return o; /* As if inside SASSIGN */
887 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
889 switch (o->op_type) {
892 list(cBINOPo->op_first);
897 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
905 if (!(o->op_flags & OPf_KIDS))
907 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
908 list(cBINOPo->op_first);
909 return gen_constant_list(o);
916 kid = cLISTOPo->op_first;
918 while ((kid = kid->op_sibling)) {
924 WITH_THR(PL_curcop = &PL_compiling);
928 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
934 WITH_THR(PL_curcop = &PL_compiling);
937 /* all requires must return a boolean value */
938 o->op_flags &= ~OPf_WANT;
945 Perl_scalarseq(pTHX_ OP *o)
948 if (o->op_type == OP_LINESEQ ||
949 o->op_type == OP_SCOPE ||
950 o->op_type == OP_LEAVE ||
951 o->op_type == OP_LEAVETRY)
954 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
955 if (kid->op_sibling) {
959 PL_curcop = &PL_compiling;
961 o->op_flags &= ~OPf_PARENS;
962 if (PL_hints & HINT_BLOCK_SCOPE)
963 o->op_flags |= OPf_PARENS;
966 o = newOP(OP_STUB, 0);
971 S_modkids(pTHX_ OP *o, I32 type)
973 if (o && o->op_flags & OPf_KIDS) {
975 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
981 /* Propagate lvalue ("modifiable") context to an op and it's children.
982 * 'type' represents the context type, roughly based on the type of op that
983 * would do the modifying, although local() is represented by OP_NULL.
984 * It's responsible for detecting things that can't be modified, flag
985 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
986 * might have to vivify a reference in $x), and so on.
988 * For example, "$a+1 = 2" would cause mod() to be called with o being
989 * OP_ADD and type being OP_SASSIGN, and would output an error.
993 Perl_mod(pTHX_ OP *o, I32 type)
997 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1000 if (!o || PL_error_count)
1003 if ((o->op_private & OPpTARGET_MY)
1004 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1009 switch (o->op_type) {
1015 if (!(o->op_private & (OPpCONST_ARYBASE)))
1017 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1018 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1022 SAVEI32(PL_compiling.cop_arybase);
1023 PL_compiling.cop_arybase = 0;
1025 else if (type == OP_REFGEN)
1028 Perl_croak(aTHX_ "That use of $[ is unsupported");
1031 if (o->op_flags & OPf_PARENS)
1035 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1036 !(o->op_flags & OPf_STACKED)) {
1037 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1038 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1039 assert(cUNOPo->op_first->op_type == OP_NULL);
1040 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1043 else if (o->op_private & OPpENTERSUB_NOMOD)
1045 else { /* lvalue subroutine call */
1046 o->op_private |= OPpLVAL_INTRO;
1047 PL_modcount = RETURN_UNLIMITED_NUMBER;
1048 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1049 /* Backward compatibility mode: */
1050 o->op_private |= OPpENTERSUB_INARGS;
1053 else { /* Compile-time error message: */
1054 OP *kid = cUNOPo->op_first;
1058 if (kid->op_type == OP_PUSHMARK)
1060 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1062 "panic: unexpected lvalue entersub "
1063 "args: type/targ %ld:%"UVuf,
1064 (long)kid->op_type, (UV)kid->op_targ);
1065 kid = kLISTOP->op_first;
1067 while (kid->op_sibling)
1068 kid = kid->op_sibling;
1069 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1071 if (kid->op_type == OP_METHOD_NAMED
1072 || kid->op_type == OP_METHOD)
1076 NewOp(1101, newop, 1, UNOP);
1077 newop->op_type = OP_RV2CV;
1078 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1079 newop->op_first = Nullop;
1080 newop->op_next = (OP*)newop;
1081 kid->op_sibling = (OP*)newop;
1082 newop->op_private |= OPpLVAL_INTRO;
1086 if (kid->op_type != OP_RV2CV)
1088 "panic: unexpected lvalue entersub "
1089 "entry via type/targ %ld:%"UVuf,
1090 (long)kid->op_type, (UV)kid->op_targ);
1091 kid->op_private |= OPpLVAL_INTRO;
1092 break; /* Postpone until runtime */
1096 kid = kUNOP->op_first;
1097 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1098 kid = kUNOP->op_first;
1099 if (kid->op_type == OP_NULL)
1101 "Unexpected constant lvalue entersub "
1102 "entry via type/targ %ld:%"UVuf,
1103 (long)kid->op_type, (UV)kid->op_targ);
1104 if (kid->op_type != OP_GV) {
1105 /* Restore RV2CV to check lvalueness */
1107 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1108 okid->op_next = kid->op_next;
1109 kid->op_next = okid;
1112 okid->op_next = Nullop;
1113 okid->op_type = OP_RV2CV;
1115 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1116 okid->op_private |= OPpLVAL_INTRO;
1120 cv = GvCV(kGVOP_gv);
1130 /* grep, foreach, subcalls, refgen */
1131 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1133 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1134 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1136 : (o->op_type == OP_ENTERSUB
1137 ? "non-lvalue subroutine call"
1139 type ? PL_op_desc[type] : "local"));
1153 case OP_RIGHT_SHIFT:
1162 if (!(o->op_flags & OPf_STACKED))
1169 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1175 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1176 PL_modcount = RETURN_UNLIMITED_NUMBER;
1177 return o; /* Treat \(@foo) like ordinary list. */
1181 if (scalar_mod_type(o, type))
1183 ref(cUNOPo->op_first, o->op_type);
1187 if (type == OP_LEAVESUBLV)
1188 o->op_private |= OPpMAYBE_LVSUB;
1194 PL_modcount = RETURN_UNLIMITED_NUMBER;
1197 ref(cUNOPo->op_first, o->op_type);
1202 PL_hints |= HINT_BLOCK_SCOPE;
1217 PL_modcount = RETURN_UNLIMITED_NUMBER;
1218 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1219 return o; /* Treat \(@foo) like ordinary list. */
1220 if (scalar_mod_type(o, type))
1222 if (type == OP_LEAVESUBLV)
1223 o->op_private |= OPpMAYBE_LVSUB;
1227 if (!type) /* local() */
1228 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1229 PAD_COMPNAME_PV(o->op_targ));
1237 if (type != OP_SASSIGN)
1241 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1246 if (type == OP_LEAVESUBLV)
1247 o->op_private |= OPpMAYBE_LVSUB;
1249 pad_free(o->op_targ);
1250 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1251 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1252 if (o->op_flags & OPf_KIDS)
1253 mod(cBINOPo->op_first->op_sibling, type);
1258 ref(cBINOPo->op_first, o->op_type);
1259 if (type == OP_ENTERSUB &&
1260 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1261 o->op_private |= OPpLVAL_DEFER;
1262 if (type == OP_LEAVESUBLV)
1263 o->op_private |= OPpMAYBE_LVSUB;
1273 if (o->op_flags & OPf_KIDS)
1274 mod(cLISTOPo->op_last, type);
1279 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1281 else if (!(o->op_flags & OPf_KIDS))
1283 if (o->op_targ != OP_LIST) {
1284 mod(cBINOPo->op_first, type);
1290 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1295 if (type != OP_LEAVESUBLV)
1297 break; /* mod()ing was handled by ck_return() */
1300 /* [20011101.069] File test operators interpret OPf_REF to mean that
1301 their argument is a filehandle; thus \stat(".") should not set
1303 if (type == OP_REFGEN &&
1304 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1307 if (type != OP_LEAVESUBLV)
1308 o->op_flags |= OPf_MOD;
1310 if (type == OP_AASSIGN || type == OP_SASSIGN)
1311 o->op_flags |= OPf_SPECIAL|OPf_REF;
1312 else if (!type) { /* local() */
1315 o->op_private |= OPpLVAL_INTRO;
1316 o->op_flags &= ~OPf_SPECIAL;
1317 PL_hints |= HINT_BLOCK_SCOPE;
1322 if (ckWARN(WARN_SYNTAX)) {
1323 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1324 "Useless localization of %s", OP_DESC(o));
1328 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1329 && type != OP_LEAVESUBLV)
1330 o->op_flags |= OPf_REF;
1335 S_scalar_mod_type(pTHX_ const OP *o, I32 type)
1339 if (o->op_type == OP_RV2GV)
1363 case OP_RIGHT_SHIFT:
1382 S_is_handle_constructor(pTHX_ const OP *o, I32 numargs)
1384 switch (o->op_type) {
1392 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1405 Perl_refkids(pTHX_ OP *o, I32 type)
1407 if (o && o->op_flags & OPf_KIDS) {
1409 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1416 Perl_ref(pTHX_ OP *o, I32 type)
1421 if (!o || PL_error_count)
1424 switch (o->op_type) {
1426 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1427 !(o->op_flags & OPf_STACKED)) {
1428 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1429 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1430 assert(cUNOPo->op_first->op_type == OP_NULL);
1431 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1432 o->op_flags |= OPf_SPECIAL;
1437 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1441 if (type == OP_DEFINED)
1442 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1443 ref(cUNOPo->op_first, o->op_type);
1446 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1447 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1448 : type == OP_RV2HV ? OPpDEREF_HV
1450 o->op_flags |= OPf_MOD;
1455 o->op_flags |= OPf_MOD; /* XXX ??? */
1460 o->op_flags |= OPf_REF;
1463 if (type == OP_DEFINED)
1464 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1465 ref(cUNOPo->op_first, o->op_type);
1470 o->op_flags |= OPf_REF;
1475 if (!(o->op_flags & OPf_KIDS))
1477 ref(cBINOPo->op_first, type);
1481 ref(cBINOPo->op_first, o->op_type);
1482 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1483 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1484 : type == OP_RV2HV ? OPpDEREF_HV
1486 o->op_flags |= OPf_MOD;
1494 if (!(o->op_flags & OPf_KIDS))
1496 ref(cLISTOPo->op_last, type);
1506 S_dup_attrlist(pTHX_ OP *o)
1510 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1511 * where the first kid is OP_PUSHMARK and the remaining ones
1512 * are OP_CONST. We need to push the OP_CONST values.
1514 if (o->op_type == OP_CONST)
1515 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1517 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1518 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1519 if (o->op_type == OP_CONST)
1520 rop = append_elem(OP_LIST, rop,
1521 newSVOP(OP_CONST, o->op_flags,
1522 SvREFCNT_inc(cSVOPo->op_sv)));
1529 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1534 /* fake up C<use attributes $pkg,$rv,@attrs> */
1535 ENTER; /* need to protect against side-effects of 'use' */
1537 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1539 #define ATTRSMODULE "attributes"
1540 #define ATTRSMODULE_PM "attributes.pm"
1543 /* Don't force the C<use> if we don't need it. */
1544 SV **svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
1545 sizeof(ATTRSMODULE_PM)-1, 0);
1546 if (svp && *svp != &PL_sv_undef)
1547 ; /* already in %INC */
1549 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1550 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1554 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1555 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1557 prepend_elem(OP_LIST,
1558 newSVOP(OP_CONST, 0, stashsv),
1559 prepend_elem(OP_LIST,
1560 newSVOP(OP_CONST, 0,
1562 dup_attrlist(attrs))));
1568 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1570 OP *pack, *imop, *arg;
1576 assert(target->op_type == OP_PADSV ||
1577 target->op_type == OP_PADHV ||
1578 target->op_type == OP_PADAV);
1580 /* Ensure that attributes.pm is loaded. */
1581 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1583 /* Need package name for method call. */
1584 pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
1586 /* Build up the real arg-list. */
1587 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1589 arg = newOP(OP_PADSV, 0);
1590 arg->op_targ = target->op_targ;
1591 arg = prepend_elem(OP_LIST,
1592 newSVOP(OP_CONST, 0, stashsv),
1593 prepend_elem(OP_LIST,
1594 newUNOP(OP_REFGEN, 0,
1595 mod(arg, OP_REFGEN)),
1596 dup_attrlist(attrs)));
1598 /* Fake up a method call to import */
1599 meth = newSVpvn("import", 6);
1600 SvUPGRADE(meth, SVt_PVIV);
1601 (void)SvIOK_on(meth);
1604 PERL_HASH(hash, SvPVX_const(meth), SvCUR(meth));
1605 SvUV_set(meth, hash);
1607 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1608 append_elem(OP_LIST,
1609 prepend_elem(OP_LIST, pack, list(arg)),
1610 newSVOP(OP_METHOD_NAMED, 0, meth)));
1611 imop->op_private |= OPpENTERSUB_NOMOD;
1613 /* Combine the ops. */
1614 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1618 =notfor apidoc apply_attrs_string
1620 Attempts to apply a list of attributes specified by the C<attrstr> and
1621 C<len> arguments to the subroutine identified by the C<cv> argument which
1622 is expected to be associated with the package identified by the C<stashpv>
1623 argument (see L<attributes>). It gets this wrong, though, in that it
1624 does not correctly identify the boundaries of the individual attribute
1625 specifications within C<attrstr>. This is not really intended for the
1626 public API, but has to be listed here for systems such as AIX which
1627 need an explicit export list for symbols. (It's called from XS code
1628 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1629 to respect attribute syntax properly would be welcome.
1635 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1636 const char *attrstr, STRLEN len)
1641 len = strlen(attrstr);
1645 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1647 const char *sstr = attrstr;
1648 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1649 attrs = append_elem(OP_LIST, attrs,
1650 newSVOP(OP_CONST, 0,
1651 newSVpvn(sstr, attrstr-sstr)));
1655 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1656 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1657 Nullsv, prepend_elem(OP_LIST,
1658 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1659 prepend_elem(OP_LIST,
1660 newSVOP(OP_CONST, 0,
1666 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1670 if (!o || PL_error_count)
1674 if (type == OP_LIST) {
1676 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1677 my_kid(kid, attrs, imopsp);
1678 } else if (type == OP_UNDEF) {
1680 } else if (type == OP_RV2SV || /* "our" declaration */
1682 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1683 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1684 yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
1685 OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
1687 GV *gv = cGVOPx_gv(cUNOPo->op_first);
1689 PL_in_my_stash = Nullhv;
1690 apply_attrs(GvSTASH(gv),
1691 (type == OP_RV2SV ? GvSV(gv) :
1692 type == OP_RV2AV ? (SV*)GvAV(gv) :
1693 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1696 o->op_private |= OPpOUR_INTRO;
1699 else if (type != OP_PADSV &&
1702 type != OP_PUSHMARK)
1704 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1706 PL_in_my == KEY_our ? "our" : "my"));
1709 else if (attrs && type != OP_PUSHMARK) {
1713 PL_in_my_stash = Nullhv;
1715 /* check for C<my Dog $spot> when deciding package */
1716 stash = PAD_COMPNAME_TYPE(o->op_targ);
1718 stash = PL_curstash;
1719 apply_attrs_my(stash, o, attrs, imopsp);
1721 o->op_flags |= OPf_MOD;
1722 o->op_private |= OPpLVAL_INTRO;
1727 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1730 int maybe_scalar = 0;
1732 /* [perl #17376]: this appears to be premature, and results in code such as
1733 C< our(%x); > executing in list mode rather than void mode */
1735 if (o->op_flags & OPf_PARENS)
1744 o = my_kid(o, attrs, &rops);
1746 if (maybe_scalar && o->op_type == OP_PADSV) {
1747 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1748 o->op_private |= OPpLVAL_INTRO;
1751 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1754 PL_in_my_stash = Nullhv;
1759 Perl_my(pTHX_ OP *o)
1761 return my_attrs(o, Nullop);
1765 Perl_sawparens(pTHX_ OP *o)
1768 o->op_flags |= OPf_PARENS;
1773 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1778 if (ckWARN(WARN_MISC) &&
1779 (left->op_type == OP_RV2AV ||
1780 left->op_type == OP_RV2HV ||
1781 left->op_type == OP_PADAV ||
1782 left->op_type == OP_PADHV)) {
1783 const char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
1784 right->op_type == OP_TRANS)
1785 ? right->op_type : OP_MATCH];
1786 const char *sample = ((left->op_type == OP_RV2AV ||
1787 left->op_type == OP_PADAV)
1788 ? "@array" : "%hash");
1789 Perl_warner(aTHX_ packWARN(WARN_MISC),
1790 "Applying %s to %s will act on scalar(%s)",
1791 desc, sample, sample);
1794 if (right->op_type == OP_CONST &&
1795 cSVOPx(right)->op_private & OPpCONST_BARE &&
1796 cSVOPx(right)->op_private & OPpCONST_STRICT)
1798 no_bareword_allowed(right);
1801 ismatchop = right->op_type == OP_MATCH ||
1802 right->op_type == OP_SUBST ||
1803 right->op_type == OP_TRANS;
1804 if (ismatchop && right->op_private & OPpTARGET_MY) {
1806 right->op_private &= ~OPpTARGET_MY;
1808 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1809 right->op_flags |= OPf_STACKED;
1810 if (right->op_type != OP_MATCH &&
1811 ! (right->op_type == OP_TRANS &&
1812 right->op_private & OPpTRANS_IDENTICAL))
1813 left = mod(left, right->op_type);
1814 if (right->op_type == OP_TRANS)
1815 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
1817 o = prepend_elem(right->op_type, scalar(left), right);
1819 return newUNOP(OP_NOT, 0, scalar(o));
1823 return bind_match(type, left,
1824 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
1828 Perl_invert(pTHX_ OP *o)
1832 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
1833 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1837 Perl_scope(pTHX_ OP *o)
1841 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1842 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1843 o->op_type = OP_LEAVE;
1844 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1846 else if (o->op_type == OP_LINESEQ) {
1848 o->op_type = OP_SCOPE;
1849 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1850 kid = ((LISTOP*)o)->op_first;
1851 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
1855 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
1860 /* XXX kept for BINCOMPAT only */
1862 Perl_save_hints(pTHX)
1864 Perl_croak(aTHX_ "internal error: obsolete function save_hints() called");
1868 Perl_block_start(pTHX_ int full)
1870 const int retval = PL_savestack_ix;
1871 pad_block_start(full);
1873 PL_hints &= ~HINT_BLOCK_SCOPE;
1874 SAVESPTR(PL_compiling.cop_warnings);
1875 if (! specialWARN(PL_compiling.cop_warnings)) {
1876 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1877 SAVEFREESV(PL_compiling.cop_warnings) ;
1879 SAVESPTR(PL_compiling.cop_io);
1880 if (! specialCopIO(PL_compiling.cop_io)) {
1881 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1882 SAVEFREESV(PL_compiling.cop_io) ;
1888 Perl_block_end(pTHX_ I32 floor, OP *seq)
1890 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1891 OP* retval = scalarseq(seq);
1893 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
1895 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
1903 const I32 offset = pad_findmy("$_");
1904 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
1905 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1908 OP *o = newOP(OP_PADSV, 0);
1909 o->op_targ = offset;
1915 Perl_newPROG(pTHX_ OP *o)
1920 PL_eval_root = newUNOP(OP_LEAVEEVAL,
1921 ((PL_in_eval & EVAL_KEEPERR)
1922 ? OPf_SPECIAL : 0), o);
1923 PL_eval_start = linklist(PL_eval_root);
1924 PL_eval_root->op_private |= OPpREFCOUNTED;
1925 OpREFCNT_set(PL_eval_root, 1);
1926 PL_eval_root->op_next = 0;
1927 CALL_PEEP(PL_eval_start);
1930 if (o->op_type == OP_STUB) {
1931 PL_comppad_name = 0;
1936 PL_main_root = scope(sawparens(scalarvoid(o)));
1937 PL_curcop = &PL_compiling;
1938 PL_main_start = LINKLIST(PL_main_root);
1939 PL_main_root->op_private |= OPpREFCOUNTED;
1940 OpREFCNT_set(PL_main_root, 1);
1941 PL_main_root->op_next = 0;
1942 CALL_PEEP(PL_main_start);
1945 /* Register with debugger */
1947 CV *cv = get_cv("DB::postponed", FALSE);
1951 XPUSHs((SV*)CopFILEGV(&PL_compiling));
1953 call_sv((SV*)cv, G_DISCARD);
1960 Perl_localize(pTHX_ OP *o, I32 lex)
1962 if (o->op_flags & OPf_PARENS)
1963 /* [perl #17376]: this appears to be premature, and results in code such as
1964 C< our(%x); > executing in list mode rather than void mode */
1971 if (ckWARN(WARN_PARENTHESIS)
1972 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
1974 char *s = PL_bufptr;
1977 /* some heuristics to detect a potential error */
1978 while (*s && (strchr(", \t\n", *s)))
1982 if (*s && strchr("@$%*", *s) && *++s
1983 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
1986 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
1988 while (*s && (strchr(", \t\n", *s)))
1994 if (sigil && (*s == ';' || *s == '=')) {
1995 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
1996 "Parentheses missing around \"%s\" list",
1997 lex ? (PL_in_my == KEY_our ? "our" : "my")
2005 o = mod(o, OP_NULL); /* a bit kludgey */
2007 PL_in_my_stash = Nullhv;
2012 Perl_jmaybe(pTHX_ OP *o)
2014 if (o->op_type == OP_LIST) {
2016 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2017 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2023 Perl_fold_constants(pTHX_ register OP *o)
2027 I32 type = o->op_type;
2030 if (PL_opargs[type] & OA_RETSCALAR)
2032 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2033 o->op_targ = pad_alloc(type, SVs_PADTMP);
2035 /* integerize op, unless it happens to be C<-foo>.
2036 * XXX should pp_i_negate() do magic string negation instead? */
2037 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2038 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2039 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2041 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2044 if (!(PL_opargs[type] & OA_FOLDCONST))
2049 /* XXX might want a ck_negate() for this */
2050 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2062 /* XXX what about the numeric ops? */
2063 if (PL_hints & HINT_LOCALE)
2068 goto nope; /* Don't try to run w/ errors */
2070 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2071 if ((curop->op_type != OP_CONST ||
2072 (curop->op_private & OPpCONST_BARE)) &&
2073 curop->op_type != OP_LIST &&
2074 curop->op_type != OP_SCALAR &&
2075 curop->op_type != OP_NULL &&
2076 curop->op_type != OP_PUSHMARK)
2082 curop = LINKLIST(o);
2086 sv = *(PL_stack_sp--);
2087 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2088 pad_swipe(o->op_targ, FALSE);
2089 else if (SvTEMP(sv)) { /* grab mortal temp? */
2090 (void)SvREFCNT_inc(sv);
2094 if (type == OP_RV2GV)
2095 return newGVOP(OP_GV, 0, (GV*)sv);
2096 return newSVOP(OP_CONST, 0, sv);
2103 Perl_gen_constant_list(pTHX_ register OP *o)
2107 const I32 oldtmps_floor = PL_tmps_floor;
2111 return o; /* Don't attempt to run with errors */
2113 PL_op = curop = LINKLIST(o);
2120 PL_tmps_floor = oldtmps_floor;
2122 o->op_type = OP_RV2AV;
2123 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2124 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2125 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2126 o->op_opt = 0; /* needs to be revisited in peep() */
2127 curop = ((UNOP*)o)->op_first;
2128 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2135 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2138 if (!o || o->op_type != OP_LIST)
2139 o = newLISTOP(OP_LIST, 0, o, Nullop);
2141 o->op_flags &= ~OPf_WANT;
2143 if (!(PL_opargs[type] & OA_MARK))
2144 op_null(cLISTOPo->op_first);
2146 o->op_type = (OPCODE)type;
2147 o->op_ppaddr = PL_ppaddr[type];
2148 o->op_flags |= flags;
2150 o = CHECKOP(type, o);
2151 if (o->op_type != (unsigned)type)
2154 return fold_constants(o);
2157 /* List constructors */
2160 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2168 if (first->op_type != (unsigned)type
2169 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2171 return newLISTOP(type, 0, first, last);
2174 if (first->op_flags & OPf_KIDS)
2175 ((LISTOP*)first)->op_last->op_sibling = last;
2177 first->op_flags |= OPf_KIDS;
2178 ((LISTOP*)first)->op_first = last;
2180 ((LISTOP*)first)->op_last = last;
2185 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2193 if (first->op_type != (unsigned)type)
2194 return prepend_elem(type, (OP*)first, (OP*)last);
2196 if (last->op_type != (unsigned)type)
2197 return append_elem(type, (OP*)first, (OP*)last);
2199 first->op_last->op_sibling = last->op_first;
2200 first->op_last = last->op_last;
2201 first->op_flags |= (last->op_flags & OPf_KIDS);
2209 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2217 if (last->op_type == (unsigned)type) {
2218 if (type == OP_LIST) { /* already a PUSHMARK there */
2219 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2220 ((LISTOP*)last)->op_first->op_sibling = first;
2221 if (!(first->op_flags & OPf_PARENS))
2222 last->op_flags &= ~OPf_PARENS;
2225 if (!(last->op_flags & OPf_KIDS)) {
2226 ((LISTOP*)last)->op_last = first;
2227 last->op_flags |= OPf_KIDS;
2229 first->op_sibling = ((LISTOP*)last)->op_first;
2230 ((LISTOP*)last)->op_first = first;
2232 last->op_flags |= OPf_KIDS;
2236 return newLISTOP(type, 0, first, last);
2242 Perl_newNULLLIST(pTHX)
2244 return newOP(OP_STUB, 0);
2248 Perl_force_list(pTHX_ OP *o)
2250 if (!o || o->op_type != OP_LIST)
2251 o = newLISTOP(OP_LIST, 0, o, Nullop);
2257 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2262 NewOp(1101, listop, 1, LISTOP);
2264 listop->op_type = (OPCODE)type;
2265 listop->op_ppaddr = PL_ppaddr[type];
2268 listop->op_flags = (U8)flags;
2272 else if (!first && last)
2275 first->op_sibling = last;
2276 listop->op_first = first;
2277 listop->op_last = last;
2278 if (type == OP_LIST) {
2280 pushop = newOP(OP_PUSHMARK, 0);
2281 pushop->op_sibling = first;
2282 listop->op_first = pushop;
2283 listop->op_flags |= OPf_KIDS;
2285 listop->op_last = pushop;
2288 return CHECKOP(type, listop);
2292 Perl_newOP(pTHX_ I32 type, I32 flags)
2296 NewOp(1101, o, 1, OP);
2297 o->op_type = (OPCODE)type;
2298 o->op_ppaddr = PL_ppaddr[type];
2299 o->op_flags = (U8)flags;
2302 o->op_private = (U8)(0 | (flags >> 8));
2303 if (PL_opargs[type] & OA_RETSCALAR)
2305 if (PL_opargs[type] & OA_TARGET)
2306 o->op_targ = pad_alloc(type, SVs_PADTMP);
2307 return CHECKOP(type, o);
2311 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2317 first = newOP(OP_STUB, 0);
2318 if (PL_opargs[type] & OA_MARK)
2319 first = force_list(first);
2321 NewOp(1101, unop, 1, UNOP);
2322 unop->op_type = (OPCODE)type;
2323 unop->op_ppaddr = PL_ppaddr[type];
2324 unop->op_first = first;
2325 unop->op_flags = flags | OPf_KIDS;
2326 unop->op_private = (U8)(1 | (flags >> 8));
2327 unop = (UNOP*) CHECKOP(type, unop);
2331 return fold_constants((OP *) unop);
2335 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2339 NewOp(1101, binop, 1, BINOP);
2342 first = newOP(OP_NULL, 0);
2344 binop->op_type = (OPCODE)type;
2345 binop->op_ppaddr = PL_ppaddr[type];
2346 binop->op_first = first;
2347 binop->op_flags = flags | OPf_KIDS;
2350 binop->op_private = (U8)(1 | (flags >> 8));
2353 binop->op_private = (U8)(2 | (flags >> 8));
2354 first->op_sibling = last;
2357 binop = (BINOP*)CHECKOP(type, binop);
2358 if (binop->op_next || binop->op_type != (OPCODE)type)
2361 binop->op_last = binop->op_first->op_sibling;
2363 return fold_constants((OP *)binop);
2366 static int uvcompare(const void *a, const void *b) __attribute__nonnull__(1) __attribute__nonnull__(2) __attribute__pure__;
2367 static int uvcompare(const void *a, const void *b)
2369 if (*((const UV *)a) < (*(const UV *)b))
2371 if (*((const UV *)a) > (*(const UV *)b))
2373 if (*((const UV *)a+1) < (*(const UV *)b+1))
2375 if (*((const UV *)a+1) > (*(const UV *)b+1))
2381 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2383 SV *tstr = ((SVOP*)expr)->op_sv;
2384 SV *rstr = ((SVOP*)repl)->op_sv;
2387 const U8 *t = (U8*)SvPV_const(tstr, tlen);
2388 const U8 *r = (U8*)SvPV_const(rstr, rlen);
2395 register short *tbl;
2397 PL_hints |= HINT_BLOCK_SCOPE;
2398 complement = o->op_private & OPpTRANS_COMPLEMENT;
2399 del = o->op_private & OPpTRANS_DELETE;
2400 squash = o->op_private & OPpTRANS_SQUASH;
2403 o->op_private |= OPpTRANS_FROM_UTF;
2406 o->op_private |= OPpTRANS_TO_UTF;
2408 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2409 SV* listsv = newSVpvn("# comment\n",10);
2411 const U8* tend = t + tlen;
2412 const U8* rend = r + rlen;
2426 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2427 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2433 t = tsave = bytes_to_utf8(t, &len);
2436 if (!to_utf && rlen) {
2438 r = rsave = bytes_to_utf8(r, &len);
2442 /* There are several snags with this code on EBCDIC:
2443 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2444 2. scan_const() in toke.c has encoded chars in native encoding which makes
2445 ranges at least in EBCDIC 0..255 range the bottom odd.
2449 U8 tmpbuf[UTF8_MAXBYTES+1];
2452 New(1109, cp, 2*tlen, UV);
2454 transv = newSVpvn("",0);
2456 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2458 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2460 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2464 cp[2*i+1] = cp[2*i];
2468 qsort(cp, i, 2*sizeof(UV), uvcompare);
2469 for (j = 0; j < i; j++) {
2471 diff = val - nextmin;
2473 t = uvuni_to_utf8(tmpbuf,nextmin);
2474 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2476 U8 range_mark = UTF_TO_NATIVE(0xff);
2477 t = uvuni_to_utf8(tmpbuf, val - 1);
2478 sv_catpvn(transv, (char *)&range_mark, 1);
2479 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2486 t = uvuni_to_utf8(tmpbuf,nextmin);
2487 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2489 U8 range_mark = UTF_TO_NATIVE(0xff);
2490 sv_catpvn(transv, (char *)&range_mark, 1);
2492 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2493 UNICODE_ALLOW_SUPER);
2494 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2495 t = (U8*)SvPVX(transv);
2496 tlen = SvCUR(transv);
2500 else if (!rlen && !del) {
2501 r = t; rlen = tlen; rend = tend;
2504 if ((!rlen && !del) || t == r ||
2505 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2507 o->op_private |= OPpTRANS_IDENTICAL;
2511 while (t < tend || tfirst <= tlast) {
2512 /* see if we need more "t" chars */
2513 if (tfirst > tlast) {
2514 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2516 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2518 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2525 /* now see if we need more "r" chars */
2526 if (rfirst > rlast) {
2528 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2530 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2532 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2541 rfirst = rlast = 0xffffffff;
2545 /* now see which range will peter our first, if either. */
2546 tdiff = tlast - tfirst;
2547 rdiff = rlast - rfirst;
2554 if (rfirst == 0xffffffff) {
2555 diff = tdiff; /* oops, pretend rdiff is infinite */
2557 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2558 (long)tfirst, (long)tlast);
2560 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2564 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2565 (long)tfirst, (long)(tfirst + diff),
2568 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2569 (long)tfirst, (long)rfirst);
2571 if (rfirst + diff > max)
2572 max = rfirst + diff;
2574 grows = (tfirst < rfirst &&
2575 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2587 else if (max > 0xff)
2592 Safefree(cPVOPo->op_pv);
2593 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2594 SvREFCNT_dec(listsv);
2596 SvREFCNT_dec(transv);
2598 if (!del && havefinal && rlen)
2599 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2600 newSVuv((UV)final), 0);
2603 o->op_private |= OPpTRANS_GROWS;
2615 tbl = (short*)cPVOPo->op_pv;
2617 Zero(tbl, 256, short);
2618 for (i = 0; i < (I32)tlen; i++)
2620 for (i = 0, j = 0; i < 256; i++) {
2622 if (j >= (I32)rlen) {
2631 if (i < 128 && r[j] >= 128)
2641 o->op_private |= OPpTRANS_IDENTICAL;
2643 else if (j >= (I32)rlen)
2646 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2647 tbl[0x100] = rlen - j;
2648 for (i=0; i < (I32)rlen - j; i++)
2649 tbl[0x101+i] = r[j+i];
2653 if (!rlen && !del) {
2656 o->op_private |= OPpTRANS_IDENTICAL;
2658 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2659 o->op_private |= OPpTRANS_IDENTICAL;
2661 for (i = 0; i < 256; i++)
2663 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
2664 if (j >= (I32)rlen) {
2666 if (tbl[t[i]] == -1)
2672 if (tbl[t[i]] == -1) {
2673 if (t[i] < 128 && r[j] >= 128)
2680 o->op_private |= OPpTRANS_GROWS;
2688 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2693 NewOp(1101, pmop, 1, PMOP);
2694 pmop->op_type = (OPCODE)type;
2695 pmop->op_ppaddr = PL_ppaddr[type];
2696 pmop->op_flags = (U8)flags;
2697 pmop->op_private = (U8)(0 | (flags >> 8));
2699 if (PL_hints & HINT_RE_TAINT)
2700 pmop->op_pmpermflags |= PMf_RETAINT;
2701 if (PL_hints & HINT_LOCALE)
2702 pmop->op_pmpermflags |= PMf_LOCALE;
2703 pmop->op_pmflags = pmop->op_pmpermflags;
2708 if(av_len((AV*) PL_regex_pad[0]) > -1) {
2709 repointer = av_pop((AV*)PL_regex_pad[0]);
2710 pmop->op_pmoffset = SvIV(repointer);
2711 SvREPADTMP_off(repointer);
2712 sv_setiv(repointer,0);
2714 repointer = newSViv(0);
2715 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2716 pmop->op_pmoffset = av_len(PL_regex_padav);
2717 PL_regex_pad = AvARRAY(PL_regex_padav);
2722 /* link into pm list */
2723 if (type != OP_TRANS && PL_curstash) {
2724 MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab);
2727 mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0);
2729 pmop->op_pmnext = (PMOP*)mg->mg_obj;
2730 mg->mg_obj = (SV*)pmop;
2731 PmopSTASH_set(pmop,PL_curstash);
2734 return CHECKOP(type, pmop);
2737 /* Given some sort of match op o, and an expression expr containing a
2738 * pattern, either compile expr into a regex and attach it to o (if it's
2739 * constant), or convert expr into a runtime regcomp op sequence (if it's
2742 * isreg indicates that the pattern is part of a regex construct, eg
2743 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
2744 * split "pattern", which aren't. In the former case, expr will be a list
2745 * if the pattern contains more than one term (eg /a$b/) or if it contains
2746 * a replacement, ie s/// or tr///.
2750 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
2755 I32 repl_has_vars = 0;
2759 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
2760 /* last element in list is the replacement; pop it */
2762 repl = cLISTOPx(expr)->op_last;
2763 kid = cLISTOPx(expr)->op_first;
2764 while (kid->op_sibling != repl)
2765 kid = kid->op_sibling;
2766 kid->op_sibling = Nullop;
2767 cLISTOPx(expr)->op_last = kid;
2770 if (isreg && expr->op_type == OP_LIST &&
2771 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
2773 /* convert single element list to element */
2775 expr = cLISTOPx(oe)->op_first->op_sibling;
2776 cLISTOPx(oe)->op_first->op_sibling = Nullop;
2777 cLISTOPx(oe)->op_last = Nullop;
2781 if (o->op_type == OP_TRANS) {
2782 return pmtrans(o, expr, repl);
2785 reglist = isreg && expr->op_type == OP_LIST;
2789 PL_hints |= HINT_BLOCK_SCOPE;
2792 if (expr->op_type == OP_CONST) {
2794 SV *pat = ((SVOP*)expr)->op_sv;
2795 const char *p = SvPV_const(pat, plen);
2796 if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
2797 U32 was_readonly = SvREADONLY(pat);
2801 sv_force_normal_flags(pat, 0);
2802 assert(!SvREADONLY(pat));
2805 SvREADONLY_off(pat);
2809 sv_setpvn(pat, "\\s+", 3);
2811 SvFLAGS(pat) |= was_readonly;
2813 p = SvPV_const(pat, plen);
2814 pm->op_pmflags |= PMf_SKIPWHITE;
2817 pm->op_pmdynflags |= PMdf_UTF8;
2818 /* FIXME - can we make this function take const char * args? */
2819 PM_SETRE(pm, CALLREGCOMP(aTHX_ (char*)p, (char*)p + plen, pm));
2820 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
2821 pm->op_pmflags |= PMf_WHITE;
2825 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2826 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2828 : OP_REGCMAYBE),0,expr);
2830 NewOp(1101, rcop, 1, LOGOP);
2831 rcop->op_type = OP_REGCOMP;
2832 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2833 rcop->op_first = scalar(expr);
2834 rcop->op_flags |= OPf_KIDS
2835 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
2836 | (reglist ? OPf_STACKED : 0);
2837 rcop->op_private = 1;
2840 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
2842 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
2845 /* establish postfix order */
2846 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2848 rcop->op_next = expr;
2849 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2852 rcop->op_next = LINKLIST(expr);
2853 expr->op_next = (OP*)rcop;
2856 prepend_elem(o->op_type, scalar((OP*)rcop), o);
2861 if (pm->op_pmflags & PMf_EVAL) {
2863 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
2864 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
2866 else if (repl->op_type == OP_CONST)
2870 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
2871 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
2872 if (curop->op_type == OP_GV) {
2873 GV *gv = cGVOPx_gv(curop);
2875 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
2878 else if (curop->op_type == OP_RV2CV)
2880 else if (curop->op_type == OP_RV2SV ||
2881 curop->op_type == OP_RV2AV ||
2882 curop->op_type == OP_RV2HV ||
2883 curop->op_type == OP_RV2GV) {
2884 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2887 else if (curop->op_type == OP_PADSV ||
2888 curop->op_type == OP_PADAV ||
2889 curop->op_type == OP_PADHV ||
2890 curop->op_type == OP_PADANY) {
2893 else if (curop->op_type == OP_PUSHRE)
2894 ; /* Okay here, dangerous in newASSIGNOP */
2904 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
2905 pm->op_pmflags |= PMf_CONST; /* const for long enough */
2906 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
2907 prepend_elem(o->op_type, scalar(repl), o);
2910 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
2911 pm->op_pmflags |= PMf_MAYBE_CONST;
2912 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2914 NewOp(1101, rcop, 1, LOGOP);
2915 rcop->op_type = OP_SUBSTCONT;
2916 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
2917 rcop->op_first = scalar(repl);
2918 rcop->op_flags |= OPf_KIDS;
2919 rcop->op_private = 1;
2922 /* establish postfix order */
2923 rcop->op_next = LINKLIST(repl);
2924 repl->op_next = (OP*)rcop;
2926 pm->op_pmreplroot = scalar((OP*)rcop);
2927 pm->op_pmreplstart = LINKLIST(rcop);
2936 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
2940 NewOp(1101, svop, 1, SVOP);
2941 svop->op_type = (OPCODE)type;
2942 svop->op_ppaddr = PL_ppaddr[type];
2944 svop->op_next = (OP*)svop;
2945 svop->op_flags = (U8)flags;
2946 if (PL_opargs[type] & OA_RETSCALAR)
2948 if (PL_opargs[type] & OA_TARGET)
2949 svop->op_targ = pad_alloc(type, SVs_PADTMP);
2950 return CHECKOP(type, svop);
2954 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2958 NewOp(1101, padop, 1, PADOP);
2959 padop->op_type = (OPCODE)type;
2960 padop->op_ppaddr = PL_ppaddr[type];
2961 padop->op_padix = pad_alloc(type, SVs_PADTMP);
2962 SvREFCNT_dec(PAD_SVl(padop->op_padix));
2963 PAD_SETSV(padop->op_padix, sv);
2966 padop->op_next = (OP*)padop;
2967 padop->op_flags = (U8)flags;
2968 if (PL_opargs[type] & OA_RETSCALAR)
2970 if (PL_opargs[type] & OA_TARGET)
2971 padop->op_targ = pad_alloc(type, SVs_PADTMP);
2972 return CHECKOP(type, padop);
2976 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
2982 return newPADOP(type, flags, SvREFCNT_inc(gv));
2984 return newSVOP(type, flags, SvREFCNT_inc(gv));
2989 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
2993 NewOp(1101, pvop, 1, PVOP);
2994 pvop->op_type = (OPCODE)type;
2995 pvop->op_ppaddr = PL_ppaddr[type];
2997 pvop->op_next = (OP*)pvop;
2998 pvop->op_flags = (U8)flags;
2999 if (PL_opargs[type] & OA_RETSCALAR)
3001 if (PL_opargs[type] & OA_TARGET)
3002 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3003 return CHECKOP(type, pvop);
3007 Perl_package(pTHX_ OP *o)
3012 save_hptr(&PL_curstash);
3013 save_item(PL_curstname);
3015 name = SvPV_const(cSVOPo->op_sv, len);
3016 PL_curstash = gv_stashpvn(name, len, TRUE);
3017 sv_setpvn(PL_curstname, name, len);
3020 PL_hints |= HINT_BLOCK_SCOPE;
3021 PL_copline = NOLINE;
3026 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3032 if (idop->op_type != OP_CONST)
3033 Perl_croak(aTHX_ "Module name must be constant");
3037 if (version != Nullop) {
3038 SV *vesv = ((SVOP*)version)->op_sv;
3040 if (arg == Nullop && !SvNIOKp(vesv)) {
3047 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3048 Perl_croak(aTHX_ "Version number must be constant number");
3050 /* Make copy of idop so we don't free it twice */
3051 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3053 /* Fake up a method call to VERSION */
3054 meth = newSVpvn("VERSION",7);
3055 sv_upgrade(meth, SVt_PVIV);
3056 (void)SvIOK_on(meth);
3059 PERL_HASH(hash, SvPVX_const(meth), SvCUR(meth));
3060 SvUV_set(meth, hash);
3062 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3063 append_elem(OP_LIST,
3064 prepend_elem(OP_LIST, pack, list(version)),
3065 newSVOP(OP_METHOD_NAMED, 0, meth)));
3069 /* Fake up an import/unimport */
3070 if (arg && arg->op_type == OP_STUB)
3071 imop = arg; /* no import on explicit () */
3072 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3073 imop = Nullop; /* use 5.0; */
3078 /* Make copy of idop so we don't free it twice */
3079 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3081 /* Fake up a method call to import/unimport */
3082 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);
3083 SvUPGRADE(meth, SVt_PVIV);
3084 (void)SvIOK_on(meth);
3087 PERL_HASH(hash, SvPVX_const(meth), SvCUR(meth));
3088 SvUV_set(meth, hash);
3090 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3091 append_elem(OP_LIST,
3092 prepend_elem(OP_LIST, pack, list(arg)),
3093 newSVOP(OP_METHOD_NAMED, 0, meth)));
3096 /* Fake up the BEGIN {}, which does its thing immediately. */
3098 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3101 append_elem(OP_LINESEQ,
3102 append_elem(OP_LINESEQ,
3103 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, idop)),
3104 newSTATEOP(0, Nullch, veop)),
3105 newSTATEOP(0, Nullch, imop) ));
3107 /* The "did you use incorrect case?" warning used to be here.
3108 * The problem is that on case-insensitive filesystems one
3109 * might get false positives for "use" (and "require"):
3110 * "use Strict" or "require CARP" will work. This causes
3111 * portability problems for the script: in case-strict
3112 * filesystems the script will stop working.
3114 * The "incorrect case" warning checked whether "use Foo"
3115 * imported "Foo" to your namespace, but that is wrong, too:
3116 * there is no requirement nor promise in the language that
3117 * a Foo.pm should or would contain anything in package "Foo".
3119 * There is very little Configure-wise that can be done, either:
3120 * the case-sensitivity of the build filesystem of Perl does not
3121 * help in guessing the case-sensitivity of the runtime environment.
3124 PL_hints |= HINT_BLOCK_SCOPE;
3125 PL_copline = NOLINE;
3127 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3131 =head1 Embedding Functions
3133 =for apidoc load_module
3135 Loads the module whose name is pointed to by the string part of name.
3136 Note that the actual module name, not its filename, should be given.
3137 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3138 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3139 (or 0 for no flags). ver, if specified, provides version semantics
3140 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3141 arguments can be used to specify arguments to the module's import()
3142 method, similar to C<use Foo::Bar VERSION LIST>.
3147 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3150 va_start(args, ver);
3151 vload_module(flags, name, ver, &args);
3155 #ifdef PERL_IMPLICIT_CONTEXT
3157 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3161 va_start(args, ver);
3162 vload_module(flags, name, ver, &args);
3168 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3170 OP *modname, *veop, *imop;
3172 modname = newSVOP(OP_CONST, 0, name);
3173 modname->op_private |= OPpCONST_BARE;
3175 veop = newSVOP(OP_CONST, 0, ver);
3179 if (flags & PERL_LOADMOD_NOIMPORT) {
3180 imop = sawparens(newNULLLIST());
3182 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3183 imop = va_arg(*args, OP*);
3188 sv = va_arg(*args, SV*);
3190 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3191 sv = va_arg(*args, SV*);
3195 const line_t ocopline = PL_copline;
3196 COP * const ocurcop = PL_curcop;
3197 const int oexpect = PL_expect;
3199 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3200 veop, modname, imop);
3201 PL_expect = oexpect;
3202 PL_copline = ocopline;
3203 PL_curcop = ocurcop;
3208 Perl_dofile(pTHX_ OP *term)
3213 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3214 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
3215 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3217 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3218 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3219 append_elem(OP_LIST, term,
3220 scalar(newUNOP(OP_RV2CV, 0,
3225 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3231 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3233 return newBINOP(OP_LSLICE, flags,
3234 list(force_list(subscript)),
3235 list(force_list(listval)) );
3239 S_is_list_assignment(pTHX_ register const OP *o)
3244 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3245 o = cUNOPo->op_first;
3247 if (o->op_type == OP_COND_EXPR) {
3248 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3249 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3254 yyerror("Assignment to both a list and a scalar");
3258 if (o->op_type == OP_LIST &&
3259 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3260 o->op_private & OPpLVAL_INTRO)
3263 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3264 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3265 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3268 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3271 if (o->op_type == OP_RV2SV)
3278 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3283 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3284 return newLOGOP(optype, 0,
3285 mod(scalar(left), optype),
3286 newUNOP(OP_SASSIGN, 0, scalar(right)));
3289 return newBINOP(optype, OPf_STACKED,
3290 mod(scalar(left), optype), scalar(right));
3294 if (is_list_assignment(left)) {
3298 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3299 left = mod(left, OP_AASSIGN);
3307 /* optimise C<my @x = ()> to C<my @x>, and likewise for hashes */
3308 if ((left->op_type == OP_PADAV || left->op_type == OP_PADHV)
3309 && right->op_type == OP_STUB
3310 && (left->op_private & OPpLVAL_INTRO))
3313 left->op_flags &= ~(OPf_REF|OPf_SPECIAL);
3316 curop = list(force_list(left));
3317 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3318 o->op_private = (U8)(0 | (flags >> 8));
3320 /* PL_generation sorcery:
3321 * an assignment like ($a,$b) = ($c,$d) is easier than
3322 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3323 * To detect whether there are common vars, the global var
3324 * PL_generation is incremented for each assign op we compile.
3325 * Then, while compiling the assign op, we run through all the
3326 * variables on both sides of the assignment, setting a spare slot
3327 * in each of them to PL_generation. If any of them already have
3328 * that value, we know we've got commonality. We could use a
3329 * single bit marker, but then we'd have to make 2 passes, first
3330 * to clear the flag, then to test and set it. To find somewhere
3331 * to store these values, evil chicanery is done with SvCUR().
3334 if (!(left->op_private & OPpLVAL_INTRO)) {
3337 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3338 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3339 if (curop->op_type == OP_GV) {
3340 GV *gv = cGVOPx_gv(curop);
3341 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3343 SvCUR_set(gv, PL_generation);
3345 else if (curop->op_type == OP_PADSV ||
3346 curop->op_type == OP_PADAV ||
3347 curop->op_type == OP_PADHV ||
3348 curop->op_type == OP_PADANY)
3350 if (PAD_COMPNAME_GEN(curop->op_targ)
3351 == (STRLEN)PL_generation)
3353 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
3356 else if (curop->op_type == OP_RV2CV)
3358 else if (curop->op_type == OP_RV2SV ||
3359 curop->op_type == OP_RV2AV ||
3360 curop->op_type == OP_RV2HV ||
3361 curop->op_type == OP_RV2GV) {
3362 if (lastop->op_type != OP_GV) /* funny deref? */
3365 else if (curop->op_type == OP_PUSHRE) {
3366 if (((PMOP*)curop)->op_pmreplroot) {
3368 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3369 ((PMOP*)curop)->op_pmreplroot));
3371 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3373 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3375 SvCUR_set(gv, PL_generation);
3384 o->op_private |= OPpASSIGN_COMMON;
3386 if (right && right->op_type == OP_SPLIT) {
3388 if ((tmpop = ((LISTOP*)right)->op_first) &&
3389 tmpop->op_type == OP_PUSHRE)
3391 PMOP *pm = (PMOP*)tmpop;
3392 if (left->op_type == OP_RV2AV &&
3393 !(left->op_private & OPpLVAL_INTRO) &&
3394 !(o->op_private & OPpASSIGN_COMMON) )
3396 tmpop = ((UNOP*)left)->op_first;
3397 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3399 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3400 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3402 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3403 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3405 pm->op_pmflags |= PMf_ONCE;
3406 tmpop = cUNOPo->op_first; /* to list (nulled) */
3407 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3408 tmpop->op_sibling = Nullop; /* don't free split */
3409 right->op_next = tmpop->op_next; /* fix starting loc */
3410 op_free(o); /* blow off assign */
3411 right->op_flags &= ~OPf_WANT;
3412 /* "I don't know and I don't care." */
3417 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3418 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3420 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3422 sv_setiv(sv, PL_modcount+1);
3430 right = newOP(OP_UNDEF, 0);
3431 if (right->op_type == OP_READLINE) {
3432 right->op_flags |= OPf_STACKED;
3433 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3436 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3437 o = newBINOP(OP_SASSIGN, flags,
3438 scalar(right), mod(scalar(left), OP_SASSIGN) );
3450 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3453 const U32 seq = intro_my();
3456 NewOp(1101, cop, 1, COP);
3457 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3458 cop->op_type = OP_DBSTATE;
3459 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3462 cop->op_type = OP_NEXTSTATE;
3463 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3465 cop->op_flags = (U8)flags;
3466 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3468 cop->op_private |= NATIVE_HINTS;
3470 PL_compiling.op_private = cop->op_private;
3471 cop->op_next = (OP*)cop;
3474 cop->cop_label = label;
3475 PL_hints |= HINT_BLOCK_SCOPE;
3478 cop->cop_arybase = PL_curcop->cop_arybase;
3479 if (specialWARN(PL_curcop->cop_warnings))
3480 cop->cop_warnings = PL_curcop->cop_warnings ;
3482 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3483 if (specialCopIO(PL_curcop->cop_io))
3484 cop->cop_io = PL_curcop->cop_io;
3486 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3489 if (PL_copline == NOLINE)
3490 CopLINE_set(cop, CopLINE(PL_curcop));
3492 CopLINE_set(cop, PL_copline);
3493 PL_copline = NOLINE;
3496 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3498 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3500 CopSTASH_set(cop, PL_curstash);
3502 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3503 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3504 if (svp && *svp != &PL_sv_undef ) {
3505 (void)SvIOK_on(*svp);
3506 SvIV_set(*svp, PTR2IV(cop));
3510 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3515 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3518 return new_logop(type, flags, &first, &other);
3522 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3527 OP *first = *firstp;
3528 OP *other = *otherp;
3530 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3531 return newBINOP(type, flags, scalar(first), scalar(other));
3533 scalarboolean(first);
3534 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3535 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3536 if (type == OP_AND || type == OP_OR) {
3542 first = *firstp = cUNOPo->op_first;
3544 first->op_next = o->op_next;
3545 cUNOPo->op_first = Nullop;
3549 if (first->op_type == OP_CONST) {
3550 if (first->op_private & OPpCONST_STRICT)
3551 no_bareword_allowed(first);
3552 else if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3553 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3554 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
3555 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
3556 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
3559 if (other->op_type == OP_CONST)
3560 other->op_private |= OPpCONST_SHORTCIRCUIT;
3564 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
3565 const OP *o2 = other;
3566 if ( ! (o2->op_type == OP_LIST
3567 && (( o2 = cUNOPx(o2)->op_first))
3568 && o2->op_type == OP_PUSHMARK
3569 && (( o2 = o2->op_sibling)) )
3572 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
3573 || o2->op_type == OP_PADHV)
3574 && o2->op_private & OPpLVAL_INTRO
3575 && ckWARN(WARN_DEPRECATED))
3577 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
3578 "Deprecated use of my() in false conditional");
3583 if (first->op_type == OP_CONST)
3584 first->op_private |= OPpCONST_SHORTCIRCUIT;
3588 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS) &&
3589 type != OP_DOR) /* [#24076] Don't warn for <FH> err FOO. */
3591 const OP *k1 = ((UNOP*)first)->op_first;
3592 const OP *k2 = k1->op_sibling;
3594 switch (first->op_type)
3597 if (k2 && k2->op_type == OP_READLINE
3598 && (k2->op_flags & OPf_STACKED)
3599 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3601 warnop = k2->op_type;
3606 if (k1->op_type == OP_READDIR
3607 || k1->op_type == OP_GLOB
3608 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3609 || k1->op_type == OP_EACH)
3611 warnop = ((k1->op_type == OP_NULL)
3612 ? (OPCODE)k1->op_targ : k1->op_type);
3617 const line_t oldline = CopLINE(PL_curcop);
3618 CopLINE_set(PL_curcop, PL_copline);
3619 Perl_warner(aTHX_ packWARN(WARN_MISC),
3620 "Value of %s%s can be \"0\"; test with defined()",
3622 ((warnop == OP_READLINE || warnop == OP_GLOB)
3623 ? " construct" : "() operator"));
3624 CopLINE_set(PL_curcop, oldline);
3631 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3632 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3634 NewOp(1101, logop, 1, LOGOP);
3636 logop->op_type = (OPCODE)type;
3637 logop->op_ppaddr = PL_ppaddr[type];
3638 logop->op_first = first;
3639 logop->op_flags = flags | OPf_KIDS;
3640 logop->op_other = LINKLIST(other);
3641 logop->op_private = (U8)(1 | (flags >> 8));
3643 /* establish postfix order */
3644 logop->op_next = LINKLIST(first);
3645 first->op_next = (OP*)logop;
3646 first->op_sibling = other;
3648 CHECKOP(type,logop);
3650 o = newUNOP(OP_NULL, 0, (OP*)logop);
3657 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3665 return newLOGOP(OP_AND, 0, first, trueop);
3667 return newLOGOP(OP_OR, 0, first, falseop);
3669 scalarboolean(first);
3670 if (first->op_type == OP_CONST) {
3671 if (first->op_private & OPpCONST_BARE &&
3672 first->op_private & OPpCONST_STRICT) {
3673 no_bareword_allowed(first);
3675 if (SvTRUE(((SVOP*)first)->op_sv)) {
3686 NewOp(1101, logop, 1, LOGOP);
3687 logop->op_type = OP_COND_EXPR;
3688 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3689 logop->op_first = first;
3690 logop->op_flags = flags | OPf_KIDS;
3691 logop->op_private = (U8)(1 | (flags >> 8));
3692 logop->op_other = LINKLIST(trueop);
3693 logop->op_next = LINKLIST(falseop);
3695 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
3698 /* establish postfix order */
3699 start = LINKLIST(first);
3700 first->op_next = (OP*)logop;
3702 first->op_sibling = trueop;
3703 trueop->op_sibling = falseop;
3704 o = newUNOP(OP_NULL, 0, (OP*)logop);
3706 trueop->op_next = falseop->op_next = o;
3713 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3722 NewOp(1101, range, 1, LOGOP);
3724 range->op_type = OP_RANGE;
3725 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3726 range->op_first = left;
3727 range->op_flags = OPf_KIDS;
3728 leftstart = LINKLIST(left);
3729 range->op_other = LINKLIST(right);
3730 range->op_private = (U8)(1 | (flags >> 8));
3732 left->op_sibling = right;
3734 range->op_next = (OP*)range;
3735 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3736 flop = newUNOP(OP_FLOP, 0, flip);
3737 o = newUNOP(OP_NULL, 0, flop);
3739 range->op_next = leftstart;
3741 left->op_next = flip;
3742 right->op_next = flop;
3744 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3745 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3746 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3747 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3749 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3750 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3753 if (!flip->op_private || !flop->op_private)
3754 linklist(o); /* blow off optimizer unless constant */
3760 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3764 const bool once = block && block->op_flags & OPf_SPECIAL &&
3765 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3769 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3770 return block; /* do {} while 0 does once */
3771 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3772 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3773 expr = newUNOP(OP_DEFINED, 0,
3774 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3775 } else if (expr->op_flags & OPf_KIDS) {
3776 const OP *k1 = ((UNOP*)expr)->op_first;
3777 const OP *k2 = (k1) ? k1->op_sibling : NULL;
3778 switch (expr->op_type) {
3780 if (k2 && k2->op_type == OP_READLINE
3781 && (k2->op_flags & OPf_STACKED)
3782 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3783 expr = newUNOP(OP_DEFINED, 0, expr);
3787 if (k1->op_type == OP_READDIR
3788 || k1->op_type == OP_GLOB
3789 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3790 || k1->op_type == OP_EACH)
3791 expr = newUNOP(OP_DEFINED, 0, expr);
3797 /* if block is null, the next append_elem() would put UNSTACK, a scalar
3798 * op, in listop. This is wrong. [perl #27024] */
3800 block = newOP(OP_NULL, 0);
3801 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3802 o = new_logop(OP_AND, 0, &expr, &listop);
3805 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3807 if (once && o != listop)
3808 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3811 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3813 o->op_flags |= flags;
3815 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3820 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
3821 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
3831 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3832 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3833 expr = newUNOP(OP_DEFINED, 0,
3834 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3835 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3836 const OP *k1 = ((UNOP*)expr)->op_first;
3837 const OP *k2 = (k1) ? k1->op_sibling : NULL;
3838 switch (expr->op_type) {
3840 if (k2 && k2->op_type == OP_READLINE
3841 && (k2->op_flags & OPf_STACKED)
3842 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3843 expr = newUNOP(OP_DEFINED, 0, expr);
3847 if (k1->op_type == OP_READDIR
3848 || k1->op_type == OP_GLOB
3849 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3850 || k1->op_type == OP_EACH)
3851 expr = newUNOP(OP_DEFINED, 0, expr);
3857 block = newOP(OP_NULL, 0);
3858 else if (cont || has_my) {
3859 block = scope(block);
3863 next = LINKLIST(cont);
3866 OP *unstack = newOP(OP_UNSTACK, 0);
3869 cont = append_elem(OP_LINESEQ, cont, unstack);
3872 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3873 redo = LINKLIST(listop);
3876 PL_copline = (line_t)whileline;
3878 o = new_logop(OP_AND, 0, &expr, &listop);
3879 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3880 op_free(expr); /* oops, it's a while (0) */
3882 return Nullop; /* listop already freed by new_logop */
3885 ((LISTOP*)listop)->op_last->op_next =
3886 (o == listop ? redo : LINKLIST(o));
3892 NewOp(1101,loop,1,LOOP);
3893 loop->op_type = OP_ENTERLOOP;
3894 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3895 loop->op_private = 0;
3896 loop->op_next = (OP*)loop;
3899 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3901 loop->op_redoop = redo;
3902 loop->op_lastop = o;
3903 o->op_private |= loopflags;
3906 loop->op_nextop = next;
3908 loop->op_nextop = o;
3910 o->op_flags |= flags;
3911 o->op_private |= (flags >> 8);
3916 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
3921 PADOFFSET padoff = 0;
3926 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
3927 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
3928 sv->op_type = OP_RV2GV;
3929 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3931 else if (sv->op_type == OP_PADSV) { /* private variable */
3932 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
3933 padoff = sv->op_targ;
3938 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3939 padoff = sv->op_targ;
3941 iterflags |= OPf_SPECIAL;
3946 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3949 const I32 offset = pad_findmy("$_");
3950 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
3951 sv = newGVOP(OP_GV, 0, PL_defgv);
3957 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3958 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3959 iterflags |= OPf_STACKED;
3961 else if (expr->op_type == OP_NULL &&
3962 (expr->op_flags & OPf_KIDS) &&
3963 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3965 /* Basically turn for($x..$y) into the same as for($x,$y), but we
3966 * set the STACKED flag to indicate that these values are to be
3967 * treated as min/max values by 'pp_iterinit'.
3969 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
3970 LOGOP* range = (LOGOP*) flip->op_first;
3971 OP* left = range->op_first;
3972 OP* right = left->op_sibling;
3975 range->op_flags &= ~OPf_KIDS;
3976 range->op_first = Nullop;
3978 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
3979 listop->op_first->op_next = range->op_next;
3980 left->op_next = range->op_other;
3981 right->op_next = (OP*)listop;
3982 listop->op_next = listop->op_first;
3985 expr = (OP*)(listop);
3987 iterflags |= OPf_STACKED;
3990 expr = mod(force_list(expr), OP_GREPSTART);
3993 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
3994 append_elem(OP_LIST, expr, scalar(sv))));
3995 assert(!loop->op_next);
3996 /* for my $x () sets OPpLVAL_INTRO;
3997 * for our $x () sets OPpOUR_INTRO */
3998 loop->op_private = (U8)iterpflags;
3999 #ifdef PL_OP_SLAB_ALLOC
4002 NewOp(1234,tmp,1,LOOP);
4003 Copy(loop,tmp,1,LISTOP);
4008 Renew(loop, 1, LOOP);
4010 loop->op_targ = padoff;
4011 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4012 PL_copline = forline;
4013 return newSTATEOP(0, label, wop);
4017 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4022 if (type != OP_GOTO || label->op_type == OP_CONST) {
4023 /* "last()" means "last" */
4024 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4025 o = newOP(type, OPf_SPECIAL);
4027 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4028 ? SvPVx_const(((SVOP*)label)->op_sv, n_a)
4034 /* Check whether it's going to be a goto &function */
4035 if (label->op_type == OP_ENTERSUB
4036 && !(label->op_flags & OPf_STACKED))
4037 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4038 o = newUNOP(type, OPf_STACKED, label);
4040 PL_hints |= HINT_BLOCK_SCOPE;
4045 =for apidoc cv_undef
4047 Clear out all the active components of a CV. This can happen either
4048 by an explicit C<undef &foo>, or by the reference count going to zero.
4049 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4050 children can still follow the full lexical scope chain.
4056 Perl_cv_undef(pTHX_ CV *cv)
4060 if (CvFILE(cv) && !CvXSUB(cv)) {
4061 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4062 Safefree(CvFILE(cv));
4067 if (!CvXSUB(cv) && CvROOT(cv)) {
4069 Perl_croak(aTHX_ "Can't undef active subroutine");
4072 PAD_SAVE_SETNULLPAD();
4074 op_free(CvROOT(cv));
4075 CvROOT(cv) = Nullop;
4076 CvSTART(cv) = Nullop;
4079 SvPOK_off((SV*)cv); /* forget prototype */
4084 /* remove CvOUTSIDE unless this is an undef rather than a free */
4085 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4086 if (!CvWEAKOUTSIDE(cv))
4087 SvREFCNT_dec(CvOUTSIDE(cv));
4088 CvOUTSIDE(cv) = Nullcv;
4091 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4097 /* delete all flags except WEAKOUTSIDE */
4098 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4102 Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p)
4104 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX_const(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4105 SV* msg = sv_newmortal();
4109 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4110 sv_setpv(msg, "Prototype mismatch:");
4112 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4114 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (const SV *)cv);
4116 Perl_sv_catpv(aTHX_ msg, ": none");
4117 sv_catpv(msg, " vs ");
4119 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4121 sv_catpv(msg, "none");
4122 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
4126 static void const_sv_xsub(pTHX_ CV* cv);
4130 =head1 Optree Manipulation Functions
4132 =for apidoc cv_const_sv
4134 If C<cv> is a constant sub eligible for inlining. returns the constant
4135 value returned by the sub. Otherwise, returns NULL.
4137 Constant subs can be created with C<newCONSTSUB> or as described in
4138 L<perlsub/"Constant Functions">.
4143 Perl_cv_const_sv(pTHX_ CV *cv)
4145 if (!cv || !CvCONST(cv))
4147 return (SV*)CvXSUBANY(cv).any_ptr;
4150 /* op_const_sv: examine an optree to determine whether it's in-lineable.
4151 * Can be called in 3 ways:
4154 * look for a single OP_CONST with attached value: return the value
4156 * cv && CvCLONE(cv) && !CvCONST(cv)
4158 * examine the clone prototype, and if contains only a single
4159 * OP_CONST referencing a pad const, or a single PADSV referencing
4160 * an outer lexical, return a non-zero value to indicate the CV is
4161 * a candidate for "constizing" at clone time
4165 * We have just cloned an anon prototype that was marked as a const
4166 * candidiate. Try to grab the current value, and in the case of
4167 * PADSV, ignore it if it has multiple references. Return the value.
4171 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
4178 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4179 o = cLISTOPo->op_first->op_sibling;
4181 for (; o; o = o->op_next) {
4182 OPCODE type = o->op_type;
4184 if (sv && o->op_next == o)
4186 if (o->op_next != o) {
4187 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4189 if (type == OP_DBSTATE)
4192 if (type == OP_LEAVESUB || type == OP_RETURN)
4196 if (type == OP_CONST && cSVOPo->op_sv)
4198 else if (cv && type == OP_CONST) {
4199 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4203 else if (cv && type == OP_PADSV) {
4204 if (CvCONST(cv)) { /* newly cloned anon */
4205 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4206 /* the candidate should have 1 ref from this pad and 1 ref
4207 * from the parent */
4208 if (!sv || SvREFCNT(sv) != 2)
4215 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4216 sv = &PL_sv_undef; /* an arbitrary non-null value */
4227 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4238 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4242 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4244 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4248 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4259 const char * const name = o ? SvPVx_const(cSVOPo->op_sv, n_a) : Nullch;
4262 assert(proto->op_type == OP_CONST);
4263 ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len);
4268 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4269 SV *sv = sv_newmortal();
4270 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4271 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4272 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4273 aname = SvPVX_const(sv);
4277 gv = name ? gv_fetchsv(cSVOPo->op_sv,
4278 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4280 : gv_fetchpv(aname ? aname
4281 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4282 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4292 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4293 maximum a prototype before. */
4294 if (SvTYPE(gv) > SVt_NULL) {
4295 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4296 && ckWARN_d(WARN_PROTOTYPE))
4298 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4300 cv_ckproto((CV*)gv, NULL, ps);
4303 sv_setpvn((SV*)gv, ps, ps_len);
4305 sv_setiv((SV*)gv, -1);
4306 SvREFCNT_dec(PL_compcv);
4307 cv = PL_compcv = NULL;
4308 PL_sub_generation++;
4312 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4314 #ifdef GV_UNIQUE_CHECK
4315 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4316 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4320 if (!block || !ps || *ps || attrs)
4323 const_sv = op_const_sv(block, Nullcv);
4326 const bool exists = CvROOT(cv) || CvXSUB(cv);
4328 #ifdef GV_UNIQUE_CHECK
4329 if (exists && GvUNIQUE(gv)) {
4330 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4334 /* if the subroutine doesn't exist and wasn't pre-declared
4335 * with a prototype, assume it will be AUTOLOADed,
4336 * skipping the prototype check
4338 if (exists || SvPOK(cv))
4339 cv_ckproto(cv, gv, ps);
4340 /* already defined (or promised)? */
4341 if (exists || GvASSUMECV(gv)) {
4342 if (!block && !attrs) {
4343 if (CvFLAGS(PL_compcv)) {
4344 /* might have had built-in attrs applied */
4345 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4347 /* just a "sub foo;" when &foo is already defined */
4348 SAVEFREESV(PL_compcv);
4351 /* ahem, death to those who redefine active sort subs */
4352 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4353 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4355 if (ckWARN(WARN_REDEFINE)
4357 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4359 const line_t oldline = CopLINE(PL_curcop);
4360 if (PL_copline != NOLINE)
4361 CopLINE_set(PL_curcop, PL_copline);
4362 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4363 CvCONST(cv) ? "Constant subroutine %s redefined"
4364 : "Subroutine %s redefined", name);
4365 CopLINE_set(PL_curcop, oldline);
4373 (void)SvREFCNT_inc(const_sv);
4375 assert(!CvROOT(cv) && !CvCONST(cv));
4376 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
4377 CvXSUBANY(cv).any_ptr = const_sv;
4378 CvXSUB(cv) = const_sv_xsub;
4383 cv = newCONSTSUB(NULL, name, const_sv);
4386 SvREFCNT_dec(PL_compcv);
4388 PL_sub_generation++;
4395 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4396 * before we clobber PL_compcv.
4400 /* Might have had built-in attributes applied -- propagate them. */
4401 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4402 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4403 stash = GvSTASH(CvGV(cv));
4404 else if (CvSTASH(cv))
4405 stash = CvSTASH(cv);
4407 stash = PL_curstash;
4410 /* possibly about to re-define existing subr -- ignore old cv */
4411 rcv = (SV*)PL_compcv;
4412 if (name && GvSTASH(gv))
4413 stash = GvSTASH(gv);
4415 stash = PL_curstash;
4417 apply_attrs(stash, rcv, attrs, FALSE);
4419 if (cv) { /* must reuse cv if autoloaded */
4421 /* got here with just attrs -- work done, so bug out */
4422 SAVEFREESV(PL_compcv);
4425 /* transfer PL_compcv to cv */
4427 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4428 if (!CvWEAKOUTSIDE(cv))
4429 SvREFCNT_dec(CvOUTSIDE(cv));
4430 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4431 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4432 CvOUTSIDE(PL_compcv) = 0;
4433 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4434 CvPADLIST(PL_compcv) = 0;
4435 /* inner references to PL_compcv must be fixed up ... */
4436 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4437 /* ... before we throw it away */
4438 SvREFCNT_dec(PL_compcv);
4440 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4441 ++PL_sub_generation;
4448 PL_sub_generation++;
4452 CvFILE_set_from_cop(cv, PL_curcop);
4453 CvSTASH(cv) = PL_curstash;
4456 sv_setpvn((SV*)cv, ps, ps_len);
4458 if (PL_error_count) {
4462 const char *s = strrchr(name, ':');
4464 if (strEQ(s, "BEGIN")) {
4465 const char not_safe[] =
4466 "BEGIN not safe after errors--compilation aborted";
4467 if (PL_in_eval & EVAL_KEEPERR)
4468 Perl_croak(aTHX_ not_safe);
4470 /* force display of errors found but not reported */
4471 sv_catpv(ERRSV, not_safe);
4472 Perl_croak(aTHX_ "%"SVf, ERRSV);
4481 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4482 mod(scalarseq(block), OP_LEAVESUBLV));
4485 /* This makes sub {}; work as expected. */
4486 if (block->op_type == OP_STUB) {
4488 block = newSTATEOP(0, Nullch, 0);
4490 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4492 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4493 OpREFCNT_set(CvROOT(cv), 1);
4494 CvSTART(cv) = LINKLIST(CvROOT(cv));
4495 CvROOT(cv)->op_next = 0;
4496 CALL_PEEP(CvSTART(cv));
4498 /* now that optimizer has done its work, adjust pad values */
4500 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4503 assert(!CvCONST(cv));
4504 if (ps && !*ps && op_const_sv(block, cv))
4508 if (name || aname) {
4510 const char *tname = (name ? name : aname);
4512 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4513 SV *sv = NEWSV(0,0);
4514 SV *tmpstr = sv_newmortal();
4515 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4519 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4521 (long)PL_subline, (long)CopLINE(PL_curcop));
4522 gv_efullname3(tmpstr, gv, Nullch);
4523 hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
4524 hv = GvHVn(db_postponed);
4525 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))
4526 && (pcv = GvCV(db_postponed)))
4532 call_sv((SV*)pcv, G_DISCARD);
4536 if ((s = strrchr(tname,':')))
4541 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4544 if (strEQ(s, "BEGIN") && !PL_error_count) {
4545 const I32 oldscope = PL_scopestack_ix;
4547 SAVECOPFILE(&PL_compiling);
4548 SAVECOPLINE(&PL_compiling);
4551 PL_beginav = newAV();
4552 DEBUG_x( dump_sub(gv) );
4553 av_push(PL_beginav, (SV*)cv);
4554 GvCV(gv) = 0; /* cv has been hijacked */
4555 call_list(oldscope, PL_beginav);
4557 PL_curcop = &PL_compiling;
4558 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4561 else if (strEQ(s, "END") && !PL_error_count) {
4564 DEBUG_x( dump_sub(gv) );
4565 av_unshift(PL_endav, 1);
4566 av_store(PL_endav, 0, (SV*)cv);
4567 GvCV(gv) = 0; /* cv has been hijacked */
4569 else if (strEQ(s, "CHECK") && !PL_error_count) {
4571 PL_checkav = newAV();
4572 DEBUG_x( dump_sub(gv) );
4573 if (PL_main_start && ckWARN(WARN_VOID))
4574 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4575 av_unshift(PL_checkav, 1);
4576 av_store(PL_checkav, 0, (SV*)cv);
4577 GvCV(gv) = 0; /* cv has been hijacked */
4579 else if (strEQ(s, "INIT") && !PL_error_count) {
4581 PL_initav = newAV();
4582 DEBUG_x( dump_sub(gv) );
4583 if (PL_main_start && ckWARN(WARN_VOID))
4584 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4585 av_push(PL_initav, (SV*)cv);
4586 GvCV(gv) = 0; /* cv has been hijacked */
4591 PL_copline = NOLINE;
4596 /* XXX unsafe for threads if eval_owner isn't held */
4598 =for apidoc newCONSTSUB
4600 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4601 eligible for inlining at compile-time.
4607 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
4614 SAVECOPLINE(PL_curcop);
4615 CopLINE_set(PL_curcop, PL_copline);
4618 PL_hints &= ~HINT_BLOCK_SCOPE;
4621 SAVESPTR(PL_curstash);
4622 SAVECOPSTASH(PL_curcop);
4623 PL_curstash = stash;
4624 CopSTASH_set(PL_curcop,stash);
4627 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4628 CvXSUBANY(cv).any_ptr = sv;
4630 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
4633 CopSTASH_free(PL_curcop);
4641 =for apidoc U||newXS
4643 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4649 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
4651 GV *gv = gv_fetchpv(name ? name :
4652 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4653 GV_ADDMULTI, SVt_PVCV);
4657 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4659 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4661 /* just a cached method */
4665 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4666 /* already defined (or promised) */
4667 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
4668 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4669 && strEQ(HvNAME_get(GvSTASH(CvGV(cv))), "autouse"))) {
4670 const line_t oldline = CopLINE(PL_curcop);
4671 if (PL_copline != NOLINE)
4672 CopLINE_set(PL_curcop, PL_copline);
4673 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4674 CvCONST(cv) ? "Constant subroutine %s redefined"
4675 : "Subroutine %s redefined"
4677 CopLINE_set(PL_curcop, oldline);
4684 if (cv) /* must reuse cv if autoloaded */
4687 cv = (CV*)NEWSV(1105,0);
4688 sv_upgrade((SV *)cv, SVt_PVCV);
4692 PL_sub_generation++;
4696 (void)gv_fetchfile(filename);
4697 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
4698 an external constant string */
4699 CvXSUB(cv) = subaddr;
4702 const char *s = strrchr(name,':');
4708 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4711 if (strEQ(s, "BEGIN")) {
4713 PL_beginav = newAV();
4714 av_push(PL_beginav, (SV*)cv);
4715 GvCV(gv) = 0; /* cv has been hijacked */
4717 else if (strEQ(s, "END")) {
4720 av_unshift(PL_endav, 1);
4721 av_store(PL_endav, 0, (SV*)cv);
4722 GvCV(gv) = 0; /* cv has been hijacked */
4724 else if (strEQ(s, "CHECK")) {
4726 PL_checkav = newAV();
4727 if (PL_main_start && ckWARN(WARN_VOID))
4728 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4729 av_unshift(PL_checkav, 1);
4730 av_store(PL_checkav, 0, (SV*)cv);
4731 GvCV(gv) = 0; /* cv has been hijacked */
4733 else if (strEQ(s, "INIT")) {
4735 PL_initav = newAV();
4736 if (PL_main_start && ckWARN(WARN_VOID))
4737 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4738 av_push(PL_initav, (SV*)cv);
4739 GvCV(gv) = 0; /* cv has been hijacked */
4750 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4756 gv = gv_fetchsv(cSVOPo->op_sv, TRUE, SVt_PVFM);
4758 gv = gv_fetchpv("STDOUT", TRUE, SVt_PVFM);
4760 #ifdef GV_UNIQUE_CHECK
4762 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4766 if ((cv = GvFORM(gv))) {
4767 if (ckWARN(WARN_REDEFINE)) {
4768 const line_t oldline = CopLINE(PL_curcop);
4769 if (PL_copline != NOLINE)
4770 CopLINE_set(PL_curcop, PL_copline);
4771 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4772 o ? "Format %"SVf" redefined"
4773 : "Format STDOUT redefined" ,cSVOPo->op_sv);
4774 CopLINE_set(PL_curcop, oldline);
4781 CvFILE_set_from_cop(cv, PL_curcop);
4784 pad_tidy(padtidy_FORMAT);
4785 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4786 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4787 OpREFCNT_set(CvROOT(cv), 1);
4788 CvSTART(cv) = LINKLIST(CvROOT(cv));
4789 CvROOT(cv)->op_next = 0;
4790 CALL_PEEP(CvSTART(cv));
4792 PL_copline = NOLINE;
4797 Perl_newANONLIST(pTHX_ OP *o)
4799 return newUNOP(OP_REFGEN, 0,
4800 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4804 Perl_newANONHASH(pTHX_ OP *o)
4806 return newUNOP(OP_REFGEN, 0,
4807 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4811 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4813 return newANONATTRSUB(floor, proto, Nullop, block);
4817 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4819 return newUNOP(OP_REFGEN, 0,
4820 newSVOP(OP_ANONCODE, 0,
4821 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
4825 Perl_oopsAV(pTHX_ OP *o)
4828 switch (o->op_type) {
4830 o->op_type = OP_PADAV;
4831 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4832 return ref(o, OP_RV2AV);
4835 o->op_type = OP_RV2AV;
4836 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4841 if (ckWARN_d(WARN_INTERNAL))
4842 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
4849 Perl_oopsHV(pTHX_ OP *o)
4852 switch (o->op_type) {
4855 o->op_type = OP_PADHV;
4856 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4857 return ref(o, OP_RV2HV);
4861 o->op_type = OP_RV2HV;
4862 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
4867 if (ckWARN_d(WARN_INTERNAL))
4868 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
4875 Perl_newAVREF(pTHX_ OP *o)
4878 if (o->op_type == OP_PADANY) {
4879 o->op_type = OP_PADAV;
4880 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4883 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
4884 && ckWARN(WARN_DEPRECATED)) {
4885 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4886 "Using an array as a reference is deprecated");
4888 return newUNOP(OP_RV2AV, 0, scalar(o));
4892 Perl_newGVREF(pTHX_ I32 type, OP *o)
4894 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
4895 return newUNOP(OP_NULL, 0, o);
4896 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
4900 Perl_newHVREF(pTHX_ OP *o)
4903 if (o->op_type == OP_PADANY) {
4904 o->op_type = OP_PADHV;
4905 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4908 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
4909 && ckWARN(WARN_DEPRECATED)) {
4910 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4911 "Using a hash as a reference is deprecated");
4913 return newUNOP(OP_RV2HV, 0, scalar(o));
4917 Perl_oopsCV(pTHX_ OP *o)
4919 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
4922 NORETURN_FUNCTION_END;
4926 Perl_newCVREF(pTHX_ I32 flags, OP *o)
4928 return newUNOP(OP_RV2CV, flags, scalar(o));
4932 Perl_newSVREF(pTHX_ OP *o)
4935 if (o->op_type == OP_PADANY) {
4936 o->op_type = OP_PADSV;
4937 o->op_ppaddr = PL_ppaddr[OP_PADSV];
4940 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4941 o->op_flags |= OPpDONE_SVREF;
4944 return newUNOP(OP_RV2SV, 0, scalar(o));
4947 /* Check routines. See the comments at the top of this file for details
4948 * on when these are called */
4951 Perl_ck_anoncode(pTHX_ OP *o)
4953 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
4954 cSVOPo->op_sv = Nullsv;
4959 Perl_ck_bitop(pTHX_ OP *o)
4961 #define OP_IS_NUMCOMPARE(op) \
4962 ((op) == OP_LT || (op) == OP_I_LT || \
4963 (op) == OP_GT || (op) == OP_I_GT || \
4964 (op) == OP_LE || (op) == OP_I_LE || \
4965 (op) == OP_GE || (op) == OP_I_GE || \
4966 (op) == OP_EQ || (op) == OP_I_EQ || \
4967 (op) == OP_NE || (op) == OP_I_NE || \
4968 (op) == OP_NCMP || (op) == OP_I_NCMP)
4969 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4970 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
4971 && (o->op_type == OP_BIT_OR
4972 || o->op_type == OP_BIT_AND
4973 || o->op_type == OP_BIT_XOR))
4975 const OP * const left = cBINOPo->op_first;
4976 const OP * const right = left->op_sibling;
4977 if ((OP_IS_NUMCOMPARE(left->op_type) &&
4978 (left->op_flags & OPf_PARENS) == 0) ||
4979 (OP_IS_NUMCOMPARE(right->op_type) &&
4980 (right->op_flags & OPf_PARENS) == 0))
4981 if (ckWARN(WARN_PRECEDENCE))
4982 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4983 "Possible precedence problem on bitwise %c operator",
4984 o->op_type == OP_BIT_OR ? '|'
4985 : o->op_type == OP_BIT_AND ? '&' : '^'
4992 Perl_ck_concat(pTHX_ OP *o)
4994 const OP *kid = cUNOPo->op_first;
4995 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
4996 !(kUNOP->op_first->op_flags & OPf_MOD))
4997 o->op_flags |= OPf_STACKED;
5002 Perl_ck_spair(pTHX_ OP *o)
5005 if (o->op_flags & OPf_KIDS) {
5008 const OPCODE type = o->op_type;
5009 o = modkids(ck_fun(o), type);
5010 kid = cUNOPo->op_first;
5011 newop = kUNOP->op_first->op_sibling;
5013 (newop->op_sibling ||
5014 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5015 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5016 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5020 op_free(kUNOP->op_first);
5021 kUNOP->op_first = newop;
5023 o->op_ppaddr = PL_ppaddr[++o->op_type];
5028 Perl_ck_delete(pTHX_ OP *o)
5032 if (o->op_flags & OPf_KIDS) {
5033 OP *kid = cUNOPo->op_first;
5034 switch (kid->op_type) {
5036 o->op_flags |= OPf_SPECIAL;
5039 o->op_private |= OPpSLICE;
5042 o->op_flags |= OPf_SPECIAL;
5047 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5056 Perl_ck_die(pTHX_ OP *o)
5059 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5065 Perl_ck_eof(pTHX_ OP *o)
5067 const I32 type = o->op_type;
5069 if (o->op_flags & OPf_KIDS) {
5070 if (cLISTOPo->op_first->op_type == OP_STUB) {
5072 o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
5080 Perl_ck_eval(pTHX_ OP *o)
5083 PL_hints |= HINT_BLOCK_SCOPE;
5084 if (o->op_flags & OPf_KIDS) {
5085 SVOP *kid = (SVOP*)cUNOPo->op_first;
5088 o->op_flags &= ~OPf_KIDS;
5091 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
5094 cUNOPo->op_first = 0;
5097 NewOp(1101, enter, 1, LOGOP);
5098 enter->op_type = OP_ENTERTRY;
5099 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5100 enter->op_private = 0;
5102 /* establish postfix order */
5103 enter->op_next = (OP*)enter;
5105 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5106 o->op_type = OP_LEAVETRY;
5107 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5108 enter->op_other = o;
5118 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5120 o->op_targ = (PADOFFSET)PL_hints;
5125 Perl_ck_exit(pTHX_ OP *o)
5128 HV *table = GvHV(PL_hintgv);
5130 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5131 if (svp && *svp && SvTRUE(*svp))
5132 o->op_private |= OPpEXIT_VMSISH;
5134 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5140 Perl_ck_exec(pTHX_ OP *o)
5142 if (o->op_flags & OPf_STACKED) {
5145 kid = cUNOPo->op_first->op_sibling;
5146 if (kid->op_type == OP_RV2GV)
5155 Perl_ck_exists(pTHX_ OP *o)
5158 if (o->op_flags & OPf_KIDS) {
5159 OP *kid = cUNOPo->op_first;
5160 if (kid->op_type == OP_ENTERSUB) {
5161 (void) ref(kid, o->op_type);
5162 if (kid->op_type != OP_RV2CV && !PL_error_count)
5163 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5165 o->op_private |= OPpEXISTS_SUB;
5167 else if (kid->op_type == OP_AELEM)
5168 o->op_flags |= OPf_SPECIAL;
5169 else if (kid->op_type != OP_HELEM)
5170 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5178 Perl_ck_rvconst(pTHX_ register OP *o)
5181 SVOP *kid = (SVOP*)cUNOPo->op_first;
5183 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5184 if (kid->op_type == OP_CONST) {
5187 SV * const kidsv = kid->op_sv;
5189 /* Is it a constant from cv_const_sv()? */
5190 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5191 SV *rsv = SvRV(kidsv);
5192 const int svtype = SvTYPE(rsv);
5193 const char *badtype = Nullch;
5195 switch (o->op_type) {
5197 if (svtype > SVt_PVMG)
5198 badtype = "a SCALAR";
5201 if (svtype != SVt_PVAV)
5202 badtype = "an ARRAY";
5205 if (svtype != SVt_PVHV)
5209 if (svtype != SVt_PVCV)
5214 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5217 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5218 const char *badthing = Nullch;
5219 switch (o->op_type) {
5221 badthing = "a SCALAR";
5224 badthing = "an ARRAY";
5227 badthing = "a HASH";
5232 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
5236 * This is a little tricky. We only want to add the symbol if we
5237 * didn't add it in the lexer. Otherwise we get duplicate strict
5238 * warnings. But if we didn't add it in the lexer, we must at
5239 * least pretend like we wanted to add it even if it existed before,
5240 * or we get possible typo warnings. OPpCONST_ENTERED says
5241 * whether the lexer already added THIS instance of this symbol.
5243 iscv = (o->op_type == OP_RV2CV) * 2;
5245 gv = gv_fetchsv(kidsv,
5246 iscv | !(kid->op_private & OPpCONST_ENTERED),
5249 : o->op_type == OP_RV2SV
5251 : o->op_type == OP_RV2AV
5253 : o->op_type == OP_RV2HV
5256 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5258 kid->op_type = OP_GV;
5259 SvREFCNT_dec(kid->op_sv);
5261 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5262 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5263 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
5265 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
5267 kid->op_sv = SvREFCNT_inc(gv);
5269 kid->op_private = 0;
5270 kid->op_ppaddr = PL_ppaddr[OP_GV];
5277 Perl_ck_ftst(pTHX_ OP *o)
5280 const I32 type = o->op_type;
5282 if (o->op_flags & OPf_REF) {
5285 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5286 SVOP *kid = (SVOP*)cUNOPo->op_first;
5288 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5289 OP *newop = newGVOP(type, OPf_REF,
5290 gv_fetchsv(kid->op_sv, TRUE, SVt_PVIO));
5296 if ((PL_hints & HINT_FILETEST_ACCESS) &&
5297 OP_IS_FILETEST_ACCESS(o))
5298 o->op_private |= OPpFT_ACCESS;
5300 if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
5301 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
5302 o->op_private |= OPpFT_STACKED;
5306 if (type == OP_FTTTY)
5307 o = newGVOP(type, OPf_REF, PL_stdingv);
5309 o = newUNOP(type, 0, newDEFSVOP());
5315 Perl_ck_fun(pTHX_ OP *o)
5317 const int type = o->op_type;
5318 register I32 oa = PL_opargs[type] >> OASHIFT;
5320 if (o->op_flags & OPf_STACKED) {
5321 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5324 return no_fh_allowed(o);
5327 if (o->op_flags & OPf_KIDS) {
5328 OP **tokid = &cLISTOPo->op_first;
5329 register OP *kid = cLISTOPo->op_first;
5333 if (kid->op_type == OP_PUSHMARK ||
5334 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5336 tokid = &kid->op_sibling;
5337 kid = kid->op_sibling;
5339 if (!kid && PL_opargs[type] & OA_DEFGV)
5340 *tokid = kid = newDEFSVOP();
5344 sibl = kid->op_sibling;
5347 /* list seen where single (scalar) arg expected? */
5348 if (numargs == 1 && !(oa >> 4)
5349 && kid->op_type == OP_LIST && type != OP_SCALAR)
5351 return too_many_arguments(o,PL_op_desc[type]);
5364 if ((type == OP_PUSH || type == OP_UNSHIFT)
5365 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5366 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5367 "Useless use of %s with no values",
5370 if (kid->op_type == OP_CONST &&
5371 (kid->op_private & OPpCONST_BARE))
5373 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5374 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVAV) ));
5375 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5376 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5377 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
5378 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5381 kid->op_sibling = sibl;
5384 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5385 bad_type(numargs, "array", PL_op_desc[type], kid);
5389 if (kid->op_type == OP_CONST &&
5390 (kid->op_private & OPpCONST_BARE))
5392 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5393 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVHV) ));
5394 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5395 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5396 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
5397 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5400 kid->op_sibling = sibl;
5403 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5404 bad_type(numargs, "hash", PL_op_desc[type], kid);
5409 OP *newop = newUNOP(OP_NULL, 0, kid);
5410 kid->op_sibling = 0;
5412 newop->op_next = newop;
5414 kid->op_sibling = sibl;
5419 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5420 if (kid->op_type == OP_CONST &&
5421 (kid->op_private & OPpCONST_BARE))
5423 OP *newop = newGVOP(OP_GV, 0,
5424 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVIO) );
5425 if (!(o->op_private & 1) && /* if not unop */
5426 kid == cLISTOPo->op_last)
5427 cLISTOPo->op_last = newop;
5431 else if (kid->op_type == OP_READLINE) {
5432 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5433 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5436 I32 flags = OPf_SPECIAL;
5440 /* is this op a FH constructor? */
5441 if (is_handle_constructor(o,numargs)) {
5442 const char *name = Nullch;
5446 /* Set a flag to tell rv2gv to vivify
5447 * need to "prove" flag does not mean something
5448 * else already - NI-S 1999/05/07
5451 if (kid->op_type == OP_PADSV) {
5452 name = PAD_COMPNAME_PV(kid->op_targ);
5453 /* SvCUR of a pad namesv can't be trusted
5454 * (see PL_generation), so calc its length
5460 else if (kid->op_type == OP_RV2SV
5461 && kUNOP->op_first->op_type == OP_GV)
5463 GV *gv = cGVOPx_gv(kUNOP->op_first);
5465 len = GvNAMELEN(gv);
5467 else if (kid->op_type == OP_AELEM
5468 || kid->op_type == OP_HELEM)
5473 if ((op = ((BINOP*)kid)->op_first)) {
5474 SV *tmpstr = Nullsv;
5476 kid->op_type == OP_AELEM ?
5478 if (((op->op_type == OP_RV2AV) ||
5479 (op->op_type == OP_RV2HV)) &&
5480 (op = ((UNOP*)op)->op_first) &&
5481 (op->op_type == OP_GV)) {
5482 /* packagevar $a[] or $h{} */
5483 GV *gv = cGVOPx_gv(op);
5491 else if (op->op_type == OP_PADAV
5492 || op->op_type == OP_PADHV) {
5493 /* lexicalvar $a[] or $h{} */
5494 const char *padname =
5495 PAD_COMPNAME_PV(op->op_targ);
5505 name = SvPV(tmpstr, len);
5510 name = "__ANONIO__";
5517 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5518 namesv = PAD_SVl(targ);
5519 SvUPGRADE(namesv, SVt_PV);
5521 sv_setpvn(namesv, "$", 1);
5522 sv_catpvn(namesv, name, len);
5525 kid->op_sibling = 0;
5526 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5527 kid->op_targ = targ;
5528 kid->op_private |= priv;
5530 kid->op_sibling = sibl;
5536 mod(scalar(kid), type);
5540 tokid = &kid->op_sibling;
5541 kid = kid->op_sibling;
5543 o->op_private |= numargs;
5545 return too_many_arguments(o,OP_DESC(o));
5548 else if (PL_opargs[type] & OA_DEFGV) {
5550 return newUNOP(type, 0, newDEFSVOP());
5554 while (oa & OA_OPTIONAL)
5556 if (oa && oa != OA_LIST)
5557 return too_few_arguments(o,OP_DESC(o));
5563 Perl_ck_glob(pTHX_ OP *o)
5569 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5570 append_elem(OP_GLOB, o, newDEFSVOP());
5572 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5573 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5575 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5578 #if !defined(PERL_EXTERNAL_GLOB)
5579 /* XXX this can be tightened up and made more failsafe. */
5580 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5583 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5584 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5585 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5586 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5587 GvCV(gv) = GvCV(glob_gv);
5588 (void)SvREFCNT_inc((SV*)GvCV(gv));
5589 GvIMPORTED_CV_on(gv);
5592 #endif /* PERL_EXTERNAL_GLOB */
5594 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5595 append_elem(OP_GLOB, o,
5596 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5597 o->op_type = OP_LIST;
5598 o->op_ppaddr = PL_ppaddr[OP_LIST];
5599 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5600 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5601 cLISTOPo->op_first->op_targ = 0;
5602 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5603 append_elem(OP_LIST, o,
5604 scalar(newUNOP(OP_RV2CV, 0,
5605 newGVOP(OP_GV, 0, gv)))));
5606 o = newUNOP(OP_NULL, 0, ck_subr(o));
5607 o->op_targ = OP_GLOB; /* hint at what it used to be */
5610 gv = newGVgen("main");
5612 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5618 Perl_ck_grep(pTHX_ OP *o)
5623 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5626 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5627 NewOp(1101, gwop, 1, LOGOP);
5629 if (o->op_flags & OPf_STACKED) {
5632 kid = cLISTOPo->op_first->op_sibling;
5633 if (!cUNOPx(kid)->op_next)
5634 Perl_croak(aTHX_ "panic: ck_grep");
5635 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
5638 kid->op_next = (OP*)gwop;
5639 o->op_flags &= ~OPf_STACKED;
5641 kid = cLISTOPo->op_first->op_sibling;
5642 if (type == OP_MAPWHILE)
5649 kid = cLISTOPo->op_first->op_sibling;
5650 if (kid->op_type != OP_NULL)
5651 Perl_croak(aTHX_ "panic: ck_grep");
5652 kid = kUNOP->op_first;
5654 gwop->op_type = type;
5655 gwop->op_ppaddr = PL_ppaddr[type];
5656 gwop->op_first = listkids(o);
5657 gwop->op_flags |= OPf_KIDS;
5658 gwop->op_other = LINKLIST(kid);
5659 kid->op_next = (OP*)gwop;
5660 offset = pad_findmy("$_");
5661 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
5662 o->op_private = gwop->op_private = 0;
5663 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5666 o->op_private = gwop->op_private = OPpGREP_LEX;
5667 gwop->op_targ = o->op_targ = offset;
5670 kid = cLISTOPo->op_first->op_sibling;
5671 if (!kid || !kid->op_sibling)
5672 return too_few_arguments(o,OP_DESC(o));
5673 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5674 mod(kid, OP_GREPSTART);
5680 Perl_ck_index(pTHX_ OP *o)
5682 if (o->op_flags & OPf_KIDS) {
5683 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5685 kid = kid->op_sibling; /* get past "big" */
5686 if (kid && kid->op_type == OP_CONST)
5687 fbm_compile(((SVOP*)kid)->op_sv, 0);
5693 Perl_ck_lengthconst(pTHX_ OP *o)
5695 /* XXX length optimization goes here */
5700 Perl_ck_lfun(pTHX_ OP *o)
5702 const OPCODE type = o->op_type;
5703 return modkids(ck_fun(o), type);
5707 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5709 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5710 switch (cUNOPo->op_first->op_type) {
5712 /* This is needed for
5713 if (defined %stash::)
5714 to work. Do not break Tk.
5716 break; /* Globals via GV can be undef */
5718 case OP_AASSIGN: /* Is this a good idea? */
5719 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5720 "defined(@array) is deprecated");
5721 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5722 "\t(Maybe you should just omit the defined()?)\n");
5725 /* This is needed for
5726 if (defined %stash::)
5727 to work. Do not break Tk.
5729 break; /* Globals via GV can be undef */
5731 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5732 "defined(%%hash) is deprecated");
5733 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5734 "\t(Maybe you should just omit the defined()?)\n");
5745 Perl_ck_rfun(pTHX_ OP *o)
5747 const OPCODE type = o->op_type;
5748 return refkids(ck_fun(o), type);
5752 Perl_ck_listiob(pTHX_ OP *o)
5756 kid = cLISTOPo->op_first;
5759 kid = cLISTOPo->op_first;
5761 if (kid->op_type == OP_PUSHMARK)
5762 kid = kid->op_sibling;
5763 if (kid && o->op_flags & OPf_STACKED)
5764 kid = kid->op_sibling;
5765 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5766 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5767 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5768 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5769 cLISTOPo->op_first->op_sibling = kid;
5770 cLISTOPo->op_last = kid;
5771 kid = kid->op_sibling;
5776 append_elem(o->op_type, o, newDEFSVOP());
5782 Perl_ck_sassign(pTHX_ OP *o)
5784 OP *kid = cLISTOPo->op_first;
5785 /* has a disposable target? */
5786 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5787 && !(kid->op_flags & OPf_STACKED)
5788 /* Cannot steal the second time! */
5789 && !(kid->op_private & OPpTARGET_MY))
5791 OP *kkid = kid->op_sibling;
5793 /* Can just relocate the target. */
5794 if (kkid && kkid->op_type == OP_PADSV
5795 && !(kkid->op_private & OPpLVAL_INTRO))
5797 kid->op_targ = kkid->op_targ;
5799 /* Now we do not need PADSV and SASSIGN. */
5800 kid->op_sibling = o->op_sibling; /* NULL */
5801 cLISTOPo->op_first = NULL;
5804 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
5808 /* optimise C<my $x = undef> to C<my $x> */
5809 if (kid->op_type == OP_UNDEF) {
5810 OP *kkid = kid->op_sibling;
5811 if (kkid && kkid->op_type == OP_PADSV
5812 && (kkid->op_private & OPpLVAL_INTRO))
5814 cLISTOPo->op_first = NULL;
5815 kid->op_sibling = NULL;
5825 Perl_ck_match(pTHX_ OP *o)
5827 if (o->op_type != OP_QR) {
5828 const I32 offset = pad_findmy("$_");
5829 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS(offset) & SVpad_OUR)) {
5830 o->op_targ = offset;
5831 o->op_private |= OPpTARGET_MY;
5834 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
5835 o->op_private |= OPpRUNTIME;
5840 Perl_ck_method(pTHX_ OP *o)
5842 OP *kid = cUNOPo->op_first;
5843 if (kid->op_type == OP_CONST) {
5844 SV* sv = kSVOP->op_sv;
5845 if (!(strchr(SvPVX_const(sv), ':') || strchr(SvPVX_const(sv), '\''))) {
5847 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5848 sv = newSVpvn_share(SvPVX_const(sv), SvCUR(sv), 0);
5851 kSVOP->op_sv = Nullsv;
5853 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5862 Perl_ck_null(pTHX_ OP *o)
5868 Perl_ck_open(pTHX_ OP *o)
5870 HV *table = GvHV(PL_hintgv);
5874 svp = hv_fetch(table, "open_IN", 7, FALSE);
5876 mode = mode_from_discipline(*svp);
5877 if (mode & O_BINARY)
5878 o->op_private |= OPpOPEN_IN_RAW;
5879 else if (mode & O_TEXT)
5880 o->op_private |= OPpOPEN_IN_CRLF;
5883 svp = hv_fetch(table, "open_OUT", 8, FALSE);
5885 mode = mode_from_discipline(*svp);
5886 if (mode & O_BINARY)
5887 o->op_private |= OPpOPEN_OUT_RAW;
5888 else if (mode & O_TEXT)
5889 o->op_private |= OPpOPEN_OUT_CRLF;
5892 if (o->op_type == OP_BACKTICK)
5895 /* In case of three-arg dup open remove strictness
5896 * from the last arg if it is a bareword. */
5897 OP *first = cLISTOPx(o)->op_first; /* The pushmark. */
5898 OP *last = cLISTOPx(o)->op_last; /* The bareword. */
5902 if ((last->op_type == OP_CONST) && /* The bareword. */
5903 (last->op_private & OPpCONST_BARE) &&
5904 (last->op_private & OPpCONST_STRICT) &&
5905 (oa = first->op_sibling) && /* The fh. */
5906 (oa = oa->op_sibling) && /* The mode. */
5907 SvPOK(((SVOP*)oa)->op_sv) &&
5908 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
5909 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
5910 (last == oa->op_sibling)) /* The bareword. */
5911 last->op_private &= ~OPpCONST_STRICT;
5917 Perl_ck_repeat(pTHX_ OP *o)
5919 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5920 o->op_private |= OPpREPEAT_DOLIST;
5921 cBINOPo->op_first = force_list(cBINOPo->op_first);
5929 Perl_ck_require(pTHX_ OP *o)
5933 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
5934 SVOP *kid = (SVOP*)cUNOPo->op_first;
5936 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5937 SV *sv = kid->op_sv;
5938 U32 was_readonly = SvREADONLY(sv);
5943 sv_force_normal_flags(sv, 0);
5944 assert(!SvREADONLY(sv));
5951 for (s = SvPVX(sv); *s; s++) {
5952 if (*s == ':' && s[1] == ':') {
5954 Move(s+2, s+1, strlen(s+2)+1, char);
5955 SvCUR_set(sv, SvCUR(sv) - 1);
5958 sv_catpvn(sv, ".pm", 3);
5959 SvFLAGS(sv) |= was_readonly;
5963 /* handle override, if any */
5964 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
5965 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
5966 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
5968 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5969 OP *kid = cUNOPo->op_first;
5970 cUNOPo->op_first = 0;
5972 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5973 append_elem(OP_LIST, kid,
5974 scalar(newUNOP(OP_RV2CV, 0,
5983 Perl_ck_return(pTHX_ OP *o)
5985 if (CvLVALUE(PL_compcv)) {
5987 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5988 mod(kid, OP_LEAVESUBLV);
5995 Perl_ck_retarget(pTHX_ OP *o)
5997 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6004 Perl_ck_select(pTHX_ OP *o)
6008 if (o->op_flags & OPf_KIDS) {
6009 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6010 if (kid && kid->op_sibling) {
6011 o->op_type = OP_SSELECT;
6012 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6014 return fold_constants(o);
6018 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6019 if (kid && kid->op_type == OP_RV2GV)
6020 kid->op_private &= ~HINT_STRICT_REFS;
6025 Perl_ck_shift(pTHX_ OP *o)
6027 const I32 type = o->op_type;
6029 if (!(o->op_flags & OPf_KIDS)) {
6033 argop = newUNOP(OP_RV2AV, 0,
6034 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
6035 return newUNOP(type, 0, scalar(argop));
6037 return scalar(modkids(ck_fun(o), type));
6041 Perl_ck_sort(pTHX_ OP *o)
6045 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6047 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6048 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6050 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6052 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6054 if (kid->op_type == OP_SCOPE) {
6058 else if (kid->op_type == OP_LEAVE) {
6059 if (o->op_type == OP_SORT) {
6060 op_null(kid); /* wipe out leave */
6063 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6064 if (k->op_next == kid)
6066 /* don't descend into loops */
6067 else if (k->op_type == OP_ENTERLOOP
6068 || k->op_type == OP_ENTERITER)
6070 k = cLOOPx(k)->op_lastop;
6075 kid->op_next = 0; /* just disconnect the leave */
6076 k = kLISTOP->op_first;
6081 if (o->op_type == OP_SORT) {
6082 /* provide scalar context for comparison function/block */
6088 o->op_flags |= OPf_SPECIAL;
6090 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6093 firstkid = firstkid->op_sibling;
6096 /* provide list context for arguments */
6097 if (o->op_type == OP_SORT)
6104 S_simplify_sort(pTHX_ OP *o)
6106 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6111 if (!(o->op_flags & OPf_STACKED))
6113 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6114 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6115 kid = kUNOP->op_first; /* get past null */
6116 if (kid->op_type != OP_SCOPE)
6118 kid = kLISTOP->op_last; /* get past scope */
6119 switch(kid->op_type) {
6127 k = kid; /* remember this node*/
6128 if (kBINOP->op_first->op_type != OP_RV2SV)
6130 kid = kBINOP->op_first; /* get past cmp */
6131 if (kUNOP->op_first->op_type != OP_GV)
6133 kid = kUNOP->op_first; /* get past rv2sv */
6135 if (GvSTASH(gv) != PL_curstash)
6137 gvname = GvNAME(gv);
6138 if (*gvname == 'a' && gvname[1] == '\0')
6140 else if (*gvname == 'b' && gvname[1] == '\0')
6145 kid = k; /* back to cmp */
6146 if (kBINOP->op_last->op_type != OP_RV2SV)
6148 kid = kBINOP->op_last; /* down to 2nd arg */
6149 if (kUNOP->op_first->op_type != OP_GV)
6151 kid = kUNOP->op_first; /* get past rv2sv */
6153 if (GvSTASH(gv) != PL_curstash)
6155 gvname = GvNAME(gv);
6157 ? !(*gvname == 'a' && gvname[1] == '\0')
6158 : !(*gvname == 'b' && gvname[1] == '\0'))
6160 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6162 o->op_private |= OPpSORT_DESCEND;
6163 if (k->op_type == OP_NCMP)
6164 o->op_private |= OPpSORT_NUMERIC;
6165 if (k->op_type == OP_I_NCMP)
6166 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6167 kid = cLISTOPo->op_first->op_sibling;
6168 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6169 op_free(kid); /* then delete it */
6173 Perl_ck_split(pTHX_ OP *o)
6178 if (o->op_flags & OPf_STACKED)
6179 return no_fh_allowed(o);
6181 kid = cLISTOPo->op_first;
6182 if (kid->op_type != OP_NULL)
6183 Perl_croak(aTHX_ "panic: ck_split");
6184 kid = kid->op_sibling;
6185 op_free(cLISTOPo->op_first);
6186 cLISTOPo->op_first = kid;
6188 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6189 cLISTOPo->op_last = kid; /* There was only one element previously */
6192 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6193 OP *sibl = kid->op_sibling;
6194 kid->op_sibling = 0;
6195 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
6196 if (cLISTOPo->op_first == cLISTOPo->op_last)
6197 cLISTOPo->op_last = kid;
6198 cLISTOPo->op_first = kid;
6199 kid->op_sibling = sibl;
6202 kid->op_type = OP_PUSHRE;
6203 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6205 if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
6206 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
6207 "Use of /g modifier is meaningless in split");
6210 if (!kid->op_sibling)
6211 append_elem(OP_SPLIT, o, newDEFSVOP());
6213 kid = kid->op_sibling;
6216 if (!kid->op_sibling)
6217 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6219 kid = kid->op_sibling;
6222 if (kid->op_sibling)
6223 return too_many_arguments(o,OP_DESC(o));
6229 Perl_ck_join(pTHX_ OP *o)
6231 if (ckWARN(WARN_SYNTAX)) {
6232 const OP *kid = cLISTOPo->op_first->op_sibling;
6233 if (kid && kid->op_type == OP_MATCH) {
6234 const REGEXP *re = PM_GETRE(kPMOP);
6235 const char *pmstr = re ? re->precomp : "STRING";
6236 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6237 "/%s/ should probably be written as \"%s\"",
6245 Perl_ck_subr(pTHX_ OP *o)
6247 OP *prev = ((cUNOPo->op_first->op_sibling)
6248 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6249 OP *o2 = prev->op_sibling;
6256 I32 contextclass = 0;
6261 o->op_private |= OPpENTERSUB_HASTARG;
6262 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6263 if (cvop->op_type == OP_RV2CV) {
6265 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6266 op_null(cvop); /* disable rv2cv */
6267 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6268 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6269 GV *gv = cGVOPx_gv(tmpop);
6272 tmpop->op_private |= OPpEARLY_CV;
6275 namegv = CvANON(cv) ? gv : CvGV(cv);
6276 proto = SvPV((SV*)cv, n_a);
6278 if (CvASSERTION(cv)) {
6279 if (PL_hints & HINT_ASSERTING) {
6280 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
6281 o->op_private |= OPpENTERSUB_DB;
6285 if (ckWARN(WARN_ASSERTIONS) && !(PL_hints & HINT_ASSERTIONSSEEN)) {
6286 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
6287 "Impossible to activate assertion call");
6294 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6295 if (o2->op_type == OP_CONST)
6296 o2->op_private &= ~OPpCONST_STRICT;
6297 else if (o2->op_type == OP_LIST) {
6298 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6299 if (o && o->op_type == OP_CONST)
6300 o->op_private &= ~OPpCONST_STRICT;
6303 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6304 if (PERLDB_SUB && PL_curstash != PL_debstash)
6305 o->op_private |= OPpENTERSUB_DB;
6306 while (o2 != cvop) {
6310 return too_many_arguments(o, gv_ename(namegv));
6328 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6330 arg == 1 ? "block or sub {}" : "sub {}",
6331 gv_ename(namegv), o2);
6334 /* '*' allows any scalar type, including bareword */
6337 if (o2->op_type == OP_RV2GV)
6338 goto wrapref; /* autoconvert GLOB -> GLOBref */
6339 else if (o2->op_type == OP_CONST)
6340 o2->op_private &= ~OPpCONST_STRICT;
6341 else if (o2->op_type == OP_ENTERSUB) {
6342 /* accidental subroutine, revert to bareword */
6343 OP *gvop = ((UNOP*)o2)->op_first;
6344 if (gvop && gvop->op_type == OP_NULL) {
6345 gvop = ((UNOP*)gvop)->op_first;
6347 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6350 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6351 (gvop = ((UNOP*)gvop)->op_first) &&
6352 gvop->op_type == OP_GV)
6354 GV *gv = cGVOPx_gv(gvop);
6355 OP *sibling = o2->op_sibling;
6356 SV *n = newSVpvn("",0);
6358 gv_fullname4(n, gv, "", FALSE);
6359 o2 = newSVOP(OP_CONST, 0, n);
6360 prev->op_sibling = o2;
6361 o2->op_sibling = sibling;
6377 if (contextclass++ == 0) {
6378 e = strchr(proto, ']');
6379 if (!e || e == proto)
6392 while (*--p != '[');
6393 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6394 gv_ename(namegv), o2);
6400 if (o2->op_type == OP_RV2GV)
6403 bad_type(arg, "symbol", gv_ename(namegv), o2);
6406 if (o2->op_type == OP_ENTERSUB)
6409 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6412 if (o2->op_type == OP_RV2SV ||
6413 o2->op_type == OP_PADSV ||
6414 o2->op_type == OP_HELEM ||
6415 o2->op_type == OP_AELEM ||
6416 o2->op_type == OP_THREADSV)
6419 bad_type(arg, "scalar", gv_ename(namegv), o2);
6422 if (o2->op_type == OP_RV2AV ||
6423 o2->op_type == OP_PADAV)
6426 bad_type(arg, "array", gv_ename(namegv), o2);
6429 if (o2->op_type == OP_RV2HV ||
6430 o2->op_type == OP_PADHV)
6433 bad_type(arg, "hash", gv_ename(namegv), o2);
6438 OP* sib = kid->op_sibling;
6439 kid->op_sibling = 0;
6440 o2 = newUNOP(OP_REFGEN, 0, kid);
6441 o2->op_sibling = sib;
6442 prev->op_sibling = o2;
6444 if (contextclass && e) {
6459 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6460 gv_ename(namegv), cv);
6465 mod(o2, OP_ENTERSUB);
6467 o2 = o2->op_sibling;
6469 if (proto && !optional &&
6470 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6471 return too_few_arguments(o, gv_ename(namegv));
6474 o=newSVOP(OP_CONST, 0, newSViv(0));
6480 Perl_ck_svconst(pTHX_ OP *o)
6482 SvREADONLY_on(cSVOPo->op_sv);
6487 Perl_ck_trunc(pTHX_ OP *o)
6489 if (o->op_flags & OPf_KIDS) {
6490 SVOP *kid = (SVOP*)cUNOPo->op_first;
6492 if (kid->op_type == OP_NULL)
6493 kid = (SVOP*)kid->op_sibling;
6494 if (kid && kid->op_type == OP_CONST &&
6495 (kid->op_private & OPpCONST_BARE))
6497 o->op_flags |= OPf_SPECIAL;
6498 kid->op_private &= ~OPpCONST_STRICT;
6505 Perl_ck_unpack(pTHX_ OP *o)
6507 OP *kid = cLISTOPo->op_first;
6508 if (kid->op_sibling) {
6509 kid = kid->op_sibling;
6510 if (!kid->op_sibling)
6511 kid->op_sibling = newDEFSVOP();
6517 Perl_ck_substr(pTHX_ OP *o)
6520 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6521 OP *kid = cLISTOPo->op_first;
6523 if (kid->op_type == OP_NULL)
6524 kid = kid->op_sibling;
6526 kid->op_flags |= OPf_MOD;
6532 /* A peephole optimizer. We visit the ops in the order they're to execute.
6533 * See the comments at the top of this file for more details about when
6534 * peep() is called */
6537 Perl_peep(pTHX_ register OP *o)
6540 register OP* oldop = 0;
6542 if (!o || o->op_opt)
6546 SAVEVPTR(PL_curcop);
6547 for (; o; o = o->op_next) {
6551 switch (o->op_type) {
6555 PL_curcop = ((COP*)o); /* for warnings */
6560 if (cSVOPo->op_private & OPpCONST_STRICT)
6561 no_bareword_allowed(o);
6563 case OP_METHOD_NAMED:
6564 /* Relocate sv to the pad for thread safety.
6565 * Despite being a "constant", the SV is written to,
6566 * for reference counts, sv_upgrade() etc. */
6568 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6569 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6570 /* If op_sv is already a PADTMP then it is being used by
6571 * some pad, so make a copy. */
6572 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6573 SvREADONLY_on(PAD_SVl(ix));
6574 SvREFCNT_dec(cSVOPo->op_sv);
6577 SvREFCNT_dec(PAD_SVl(ix));
6578 SvPADTMP_on(cSVOPo->op_sv);
6579 PAD_SETSV(ix, cSVOPo->op_sv);
6580 /* XXX I don't know how this isn't readonly already. */
6581 SvREADONLY_on(PAD_SVl(ix));
6583 cSVOPo->op_sv = Nullsv;
6591 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6592 if (o->op_next->op_private & OPpTARGET_MY) {
6593 if (o->op_flags & OPf_STACKED) /* chained concats */
6594 goto ignore_optimization;
6596 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6597 o->op_targ = o->op_next->op_targ;
6598 o->op_next->op_targ = 0;
6599 o->op_private |= OPpTARGET_MY;
6602 op_null(o->op_next);
6604 ignore_optimization:
6608 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6610 break; /* Scalar stub must produce undef. List stub is noop */
6614 if (o->op_targ == OP_NEXTSTATE
6615 || o->op_targ == OP_DBSTATE
6616 || o->op_targ == OP_SETSTATE)
6618 PL_curcop = ((COP*)o);
6620 /* XXX: We avoid setting op_seq here to prevent later calls
6621 to peep() from mistakenly concluding that optimisation
6622 has already occurred. This doesn't fix the real problem,
6623 though (See 20010220.007). AMS 20010719 */
6624 /* op_seq functionality is now replaced by op_opt */
6625 if (oldop && o->op_next) {
6626 oldop->op_next = o->op_next;
6634 if (oldop && o->op_next) {
6635 oldop->op_next = o->op_next;
6643 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
6644 OP* pop = (o->op_type == OP_PADAV) ?
6645 o->op_next : o->op_next->op_next;
6647 if (pop && pop->op_type == OP_CONST &&
6648 ((PL_op = pop->op_next)) &&
6649 pop->op_next->op_type == OP_AELEM &&
6650 !(pop->op_next->op_private &
6651 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6652 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6657 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
6658 no_bareword_allowed(pop);
6659 if (o->op_type == OP_GV)
6660 op_null(o->op_next);
6661 op_null(pop->op_next);
6663 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6664 o->op_next = pop->op_next->op_next;
6665 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6666 o->op_private = (U8)i;
6667 if (o->op_type == OP_GV) {
6672 o->op_flags |= OPf_SPECIAL;
6673 o->op_type = OP_AELEMFAST;
6679 if (o->op_next->op_type == OP_RV2SV) {
6680 if (!(o->op_next->op_private & OPpDEREF)) {
6681 op_null(o->op_next);
6682 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6684 o->op_next = o->op_next->op_next;
6685 o->op_type = OP_GVSV;
6686 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6689 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6691 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
6692 /* XXX could check prototype here instead of just carping */
6693 SV *sv = sv_newmortal();
6694 gv_efullname3(sv, gv, Nullch);
6695 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6696 "%"SVf"() called too early to check prototype",
6700 else if (o->op_next->op_type == OP_READLINE
6701 && o->op_next->op_next->op_type == OP_CONCAT
6702 && (o->op_next->op_next->op_flags & OPf_STACKED))
6704 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6705 o->op_type = OP_RCATLINE;
6706 o->op_flags |= OPf_STACKED;
6707 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6708 op_null(o->op_next->op_next);
6709 op_null(o->op_next);
6726 while (cLOGOP->op_other->op_type == OP_NULL)
6727 cLOGOP->op_other = cLOGOP->op_other->op_next;
6728 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6734 while (cLOOP->op_redoop->op_type == OP_NULL)
6735 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6736 peep(cLOOP->op_redoop);
6737 while (cLOOP->op_nextop->op_type == OP_NULL)
6738 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6739 peep(cLOOP->op_nextop);
6740 while (cLOOP->op_lastop->op_type == OP_NULL)
6741 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6742 peep(cLOOP->op_lastop);
6749 while (cPMOP->op_pmreplstart &&
6750 cPMOP->op_pmreplstart->op_type == OP_NULL)
6751 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6752 peep(cPMOP->op_pmreplstart);
6757 if (ckWARN(WARN_SYNTAX) && o->op_next
6758 && o->op_next->op_type == OP_NEXTSTATE) {
6759 if (o->op_next->op_sibling &&
6760 o->op_next->op_sibling->op_type != OP_EXIT &&
6761 o->op_next->op_sibling->op_type != OP_WARN &&
6762 o->op_next->op_sibling->op_type != OP_DIE) {
6763 const line_t oldline = CopLINE(PL_curcop);
6765 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6766 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6767 "Statement unlikely to be reached");
6768 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6769 "\t(Maybe you meant system() when you said exec()?)\n");
6770 CopLINE_set(PL_curcop, oldline);
6785 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6788 /* Make the CONST have a shared SV */
6789 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6790 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6791 key = SvPV(sv, keylen);
6792 lexname = newSVpvn_share(key,
6793 SvUTF8(sv) ? -(I32)keylen : keylen,
6799 if ((o->op_private & (OPpLVAL_INTRO)))
6802 rop = (UNOP*)((BINOP*)o)->op_first;
6803 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6805 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6806 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6808 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6809 if (!fields || !GvHV(*fields))
6811 key = SvPV(*svp, keylen);
6812 if (!hv_fetch(GvHV(*fields), key,
6813 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
6815 Perl_croak(aTHX_ "No such class field \"%s\" "
6816 "in variable %s of type %s",
6817 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
6830 SVOP *first_key_op, *key_op;
6832 if ((o->op_private & (OPpLVAL_INTRO))
6833 /* I bet there's always a pushmark... */
6834 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6835 /* hmmm, no optimization if list contains only one key. */
6837 rop = (UNOP*)((LISTOP*)o)->op_last;
6838 if (rop->op_type != OP_RV2HV)
6840 if (rop->op_first->op_type == OP_PADSV)
6841 /* @$hash{qw(keys here)} */
6842 rop = (UNOP*)rop->op_first;
6844 /* @{$hash}{qw(keys here)} */
6845 if (rop->op_first->op_type == OP_SCOPE
6846 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
6848 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
6854 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
6855 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6857 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6858 if (!fields || !GvHV(*fields))
6860 /* Again guessing that the pushmark can be jumped over.... */
6861 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
6862 ->op_first->op_sibling;
6863 for (key_op = first_key_op; key_op;
6864 key_op = (SVOP*)key_op->op_sibling) {
6865 if (key_op->op_type != OP_CONST)
6867 svp = cSVOPx_svp(key_op);
6868 key = SvPV(*svp, keylen);
6869 if (!hv_fetch(GvHV(*fields), key,
6870 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
6872 Perl_croak(aTHX_ "No such class field \"%s\" "
6873 "in variable %s of type %s",
6874 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
6881 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
6885 /* check that RHS of sort is a single plain array */
6886 oright = cUNOPo->op_first;
6887 if (!oright || oright->op_type != OP_PUSHMARK)
6890 /* reverse sort ... can be optimised. */
6891 if (!cUNOPo->op_sibling) {
6892 /* Nothing follows us on the list. */
6893 OP *reverse = o->op_next;
6895 if (reverse->op_type == OP_REVERSE &&
6896 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
6897 OP *pushmark = cUNOPx(reverse)->op_first;
6898 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
6899 && (cUNOPx(pushmark)->op_sibling == o)) {
6900 /* reverse -> pushmark -> sort */
6901 o->op_private |= OPpSORT_REVERSE;
6903 pushmark->op_next = oright->op_next;
6909 /* make @a = sort @a act in-place */
6913 oright = cUNOPx(oright)->op_sibling;
6916 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
6917 oright = cUNOPx(oright)->op_sibling;
6921 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
6922 || oright->op_next != o
6923 || (oright->op_private & OPpLVAL_INTRO)
6927 /* o2 follows the chain of op_nexts through the LHS of the
6928 * assign (if any) to the aassign op itself */
6930 if (!o2 || o2->op_type != OP_NULL)
6933 if (!o2 || o2->op_type != OP_PUSHMARK)
6936 if (o2 && o2->op_type == OP_GV)
6939 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
6940 || (o2->op_private & OPpLVAL_INTRO)
6945 if (!o2 || o2->op_type != OP_NULL)
6948 if (!o2 || o2->op_type != OP_AASSIGN
6949 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
6952 /* check that the sort is the first arg on RHS of assign */
6954 o2 = cUNOPx(o2)->op_first;
6955 if (!o2 || o2->op_type != OP_NULL)
6957 o2 = cUNOPx(o2)->op_first;
6958 if (!o2 || o2->op_type != OP_PUSHMARK)
6960 if (o2->op_sibling != o)
6963 /* check the array is the same on both sides */
6964 if (oleft->op_type == OP_RV2AV) {
6965 if (oright->op_type != OP_RV2AV
6966 || !cUNOPx(oright)->op_first
6967 || cUNOPx(oright)->op_first->op_type != OP_GV
6968 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
6969 cGVOPx_gv(cUNOPx(oright)->op_first)
6973 else if (oright->op_type != OP_PADAV
6974 || oright->op_targ != oleft->op_targ
6978 /* transfer MODishness etc from LHS arg to RHS arg */
6979 oright->op_flags = oleft->op_flags;
6980 o->op_private |= OPpSORT_INPLACE;
6982 /* excise push->gv->rv2av->null->aassign */
6983 o2 = o->op_next->op_next;
6984 op_null(o2); /* PUSHMARK */
6986 if (o2->op_type == OP_GV) {
6987 op_null(o2); /* GV */
6990 op_null(o2); /* RV2AV or PADAV */
6991 o2 = o2->op_next->op_next;
6992 op_null(o2); /* AASSIGN */
6994 o->op_next = o2->op_next;
7000 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
7002 LISTOP *enter, *exlist;
7005 enter = (LISTOP *) o->op_next;
7008 if (enter->op_type == OP_NULL) {
7009 enter = (LISTOP *) enter->op_next;
7013 /* for $a (...) will have OP_GV then OP_RV2GV here.
7014 for (...) just has an OP_GV. */
7015 if (enter->op_type == OP_GV) {
7016 gvop = (OP *) enter;
7017 enter = (LISTOP *) enter->op_next;
7020 if (enter->op_type == OP_RV2GV) {
7021 enter = (LISTOP *) enter->op_next;
7027 if (enter->op_type != OP_ENTERITER)
7030 iter = enter->op_next;
7031 if (!iter || iter->op_type != OP_ITER)
7034 expushmark = enter->op_first;
7035 if (!expushmark || expushmark->op_type != OP_NULL
7036 || expushmark->op_targ != OP_PUSHMARK)
7039 exlist = (LISTOP *) expushmark->op_sibling;
7040 if (!exlist || exlist->op_type != OP_NULL
7041 || exlist->op_targ != OP_LIST)
7044 if (exlist->op_last != o) {
7045 /* Mmm. Was expecting to point back to this op. */
7048 theirmark = exlist->op_first;
7049 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
7052 if (theirmark->op_sibling != o) {
7053 /* There's something between the mark and the reverse, eg
7054 for (1, reverse (...))
7059 ourmark = ((LISTOP *)o)->op_first;
7060 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
7063 ourlast = ((LISTOP *)o)->op_last;
7064 if (!ourlast || ourlast->op_next != o)
7067 rv2av = ourmark->op_sibling;
7068 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
7069 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
7070 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
7071 /* We're just reversing a single array. */
7072 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
7073 enter->op_flags |= OPf_STACKED;
7076 /* We don't have control over who points to theirmark, so sacrifice
7078 theirmark->op_next = ourmark->op_next;
7079 theirmark->op_flags = ourmark->op_flags;
7080 ourlast->op_next = gvop ? gvop : (OP *) enter;
7083 enter->op_private |= OPpITER_REVERSED;
7084 iter->op_private |= OPpITER_REVERSED;
7099 Perl_custom_op_name(pTHX_ const OP* o)
7101 const IV index = PTR2IV(o->op_ppaddr);
7105 if (!PL_custom_op_names) /* This probably shouldn't happen */
7106 return (char *)PL_op_name[OP_CUSTOM];
7108 keysv = sv_2mortal(newSViv(index));
7110 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7112 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7114 return SvPV_nolen(HeVAL(he));
7118 Perl_custom_op_desc(pTHX_ const OP* o)
7120 const IV index = PTR2IV(o->op_ppaddr);
7124 if (!PL_custom_op_descs)
7125 return (char *)PL_op_desc[OP_CUSTOM];
7127 keysv = sv_2mortal(newSViv(index));
7129 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7131 return (char *)PL_op_desc[OP_CUSTOM];
7133 return SvPV_nolen(HeVAL(he));
7138 /* Efficient sub that returns a constant scalar value. */
7140 const_sv_xsub(pTHX_ CV* cv)
7145 Perl_croak(aTHX_ "usage: %s::%s()",
7146 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7150 ST(0) = (SV*)XSANY.any_ptr;
7156 * c-indentation-style: bsd
7158 * indent-tabs-mode: t
7161 * ex: set ts=8 sts=4 sw=4 noet: