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* const left = range->op_first;
3972 OP* const 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)) {
4669 GV * const gvcv = CvGV(cv);
4671 HV * const stash = GvSTASH(gvcv);
4673 const char *name = HvNAME_get(stash);
4674 if ( strEQ(name,"autouse") ) {
4675 const line_t oldline = CopLINE(PL_curcop);
4676 if (PL_copline != NOLINE)
4677 CopLINE_set(PL_curcop, PL_copline);
4678 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4679 CvCONST(cv) ? "Constant subroutine %s redefined"
4680 : "Subroutine %s redefined"
4682 CopLINE_set(PL_curcop, oldline);
4692 if (cv) /* must reuse cv if autoloaded */
4695 cv = (CV*)NEWSV(1105,0);
4696 sv_upgrade((SV *)cv, SVt_PVCV);
4700 PL_sub_generation++;
4704 (void)gv_fetchfile(filename);
4705 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
4706 an external constant string */
4707 CvXSUB(cv) = subaddr;
4710 const char *s = strrchr(name,':');
4716 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4719 if (strEQ(s, "BEGIN")) {
4721 PL_beginav = newAV();
4722 av_push(PL_beginav, (SV*)cv);
4723 GvCV(gv) = 0; /* cv has been hijacked */
4725 else if (strEQ(s, "END")) {
4728 av_unshift(PL_endav, 1);
4729 av_store(PL_endav, 0, (SV*)cv);
4730 GvCV(gv) = 0; /* cv has been hijacked */
4732 else if (strEQ(s, "CHECK")) {
4734 PL_checkav = newAV();
4735 if (PL_main_start && ckWARN(WARN_VOID))
4736 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4737 av_unshift(PL_checkav, 1);
4738 av_store(PL_checkav, 0, (SV*)cv);
4739 GvCV(gv) = 0; /* cv has been hijacked */
4741 else if (strEQ(s, "INIT")) {
4743 PL_initav = newAV();
4744 if (PL_main_start && ckWARN(WARN_VOID))
4745 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4746 av_push(PL_initav, (SV*)cv);
4747 GvCV(gv) = 0; /* cv has been hijacked */
4758 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4764 gv = gv_fetchsv(cSVOPo->op_sv, TRUE, SVt_PVFM);
4766 gv = gv_fetchpv("STDOUT", TRUE, SVt_PVFM);
4768 #ifdef GV_UNIQUE_CHECK
4770 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4774 if ((cv = GvFORM(gv))) {
4775 if (ckWARN(WARN_REDEFINE)) {
4776 const line_t oldline = CopLINE(PL_curcop);
4777 if (PL_copline != NOLINE)
4778 CopLINE_set(PL_curcop, PL_copline);
4779 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4780 o ? "Format %"SVf" redefined"
4781 : "Format STDOUT redefined" ,cSVOPo->op_sv);
4782 CopLINE_set(PL_curcop, oldline);
4789 CvFILE_set_from_cop(cv, PL_curcop);
4792 pad_tidy(padtidy_FORMAT);
4793 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4794 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4795 OpREFCNT_set(CvROOT(cv), 1);
4796 CvSTART(cv) = LINKLIST(CvROOT(cv));
4797 CvROOT(cv)->op_next = 0;
4798 CALL_PEEP(CvSTART(cv));
4800 PL_copline = NOLINE;
4805 Perl_newANONLIST(pTHX_ OP *o)
4807 return newUNOP(OP_REFGEN, 0,
4808 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4812 Perl_newANONHASH(pTHX_ OP *o)
4814 return newUNOP(OP_REFGEN, 0,
4815 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4819 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4821 return newANONATTRSUB(floor, proto, Nullop, block);
4825 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4827 return newUNOP(OP_REFGEN, 0,
4828 newSVOP(OP_ANONCODE, 0,
4829 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
4833 Perl_oopsAV(pTHX_ OP *o)
4836 switch (o->op_type) {
4838 o->op_type = OP_PADAV;
4839 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4840 return ref(o, OP_RV2AV);
4843 o->op_type = OP_RV2AV;
4844 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4849 if (ckWARN_d(WARN_INTERNAL))
4850 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
4857 Perl_oopsHV(pTHX_ OP *o)
4860 switch (o->op_type) {
4863 o->op_type = OP_PADHV;
4864 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4865 return ref(o, OP_RV2HV);
4869 o->op_type = OP_RV2HV;
4870 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
4875 if (ckWARN_d(WARN_INTERNAL))
4876 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
4883 Perl_newAVREF(pTHX_ OP *o)
4886 if (o->op_type == OP_PADANY) {
4887 o->op_type = OP_PADAV;
4888 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4891 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
4892 && ckWARN(WARN_DEPRECATED)) {
4893 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4894 "Using an array as a reference is deprecated");
4896 return newUNOP(OP_RV2AV, 0, scalar(o));
4900 Perl_newGVREF(pTHX_ I32 type, OP *o)
4902 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
4903 return newUNOP(OP_NULL, 0, o);
4904 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
4908 Perl_newHVREF(pTHX_ OP *o)
4911 if (o->op_type == OP_PADANY) {
4912 o->op_type = OP_PADHV;
4913 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4916 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
4917 && ckWARN(WARN_DEPRECATED)) {
4918 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4919 "Using a hash as a reference is deprecated");
4921 return newUNOP(OP_RV2HV, 0, scalar(o));
4925 Perl_oopsCV(pTHX_ OP *o)
4927 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
4930 NORETURN_FUNCTION_END;
4934 Perl_newCVREF(pTHX_ I32 flags, OP *o)
4936 return newUNOP(OP_RV2CV, flags, scalar(o));
4940 Perl_newSVREF(pTHX_ OP *o)
4943 if (o->op_type == OP_PADANY) {
4944 o->op_type = OP_PADSV;
4945 o->op_ppaddr = PL_ppaddr[OP_PADSV];
4948 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4949 o->op_flags |= OPpDONE_SVREF;
4952 return newUNOP(OP_RV2SV, 0, scalar(o));
4955 /* Check routines. See the comments at the top of this file for details
4956 * on when these are called */
4959 Perl_ck_anoncode(pTHX_ OP *o)
4961 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
4962 cSVOPo->op_sv = Nullsv;
4967 Perl_ck_bitop(pTHX_ OP *o)
4969 #define OP_IS_NUMCOMPARE(op) \
4970 ((op) == OP_LT || (op) == OP_I_LT || \
4971 (op) == OP_GT || (op) == OP_I_GT || \
4972 (op) == OP_LE || (op) == OP_I_LE || \
4973 (op) == OP_GE || (op) == OP_I_GE || \
4974 (op) == OP_EQ || (op) == OP_I_EQ || \
4975 (op) == OP_NE || (op) == OP_I_NE || \
4976 (op) == OP_NCMP || (op) == OP_I_NCMP)
4977 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4978 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
4979 && (o->op_type == OP_BIT_OR
4980 || o->op_type == OP_BIT_AND
4981 || o->op_type == OP_BIT_XOR))
4983 const OP * const left = cBINOPo->op_first;
4984 const OP * const right = left->op_sibling;
4985 if ((OP_IS_NUMCOMPARE(left->op_type) &&
4986 (left->op_flags & OPf_PARENS) == 0) ||
4987 (OP_IS_NUMCOMPARE(right->op_type) &&
4988 (right->op_flags & OPf_PARENS) == 0))
4989 if (ckWARN(WARN_PRECEDENCE))
4990 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4991 "Possible precedence problem on bitwise %c operator",
4992 o->op_type == OP_BIT_OR ? '|'
4993 : o->op_type == OP_BIT_AND ? '&' : '^'
5000 Perl_ck_concat(pTHX_ OP *o)
5002 const OP *kid = cUNOPo->op_first;
5003 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
5004 !(kUNOP->op_first->op_flags & OPf_MOD))
5005 o->op_flags |= OPf_STACKED;
5010 Perl_ck_spair(pTHX_ OP *o)
5013 if (o->op_flags & OPf_KIDS) {
5016 const OPCODE type = o->op_type;
5017 o = modkids(ck_fun(o), type);
5018 kid = cUNOPo->op_first;
5019 newop = kUNOP->op_first->op_sibling;
5021 (newop->op_sibling ||
5022 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5023 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5024 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5028 op_free(kUNOP->op_first);
5029 kUNOP->op_first = newop;
5031 o->op_ppaddr = PL_ppaddr[++o->op_type];
5036 Perl_ck_delete(pTHX_ OP *o)
5040 if (o->op_flags & OPf_KIDS) {
5041 OP *kid = cUNOPo->op_first;
5042 switch (kid->op_type) {
5044 o->op_flags |= OPf_SPECIAL;
5047 o->op_private |= OPpSLICE;
5050 o->op_flags |= OPf_SPECIAL;
5055 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5064 Perl_ck_die(pTHX_ OP *o)
5067 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5073 Perl_ck_eof(pTHX_ OP *o)
5075 const I32 type = o->op_type;
5077 if (o->op_flags & OPf_KIDS) {
5078 if (cLISTOPo->op_first->op_type == OP_STUB) {
5080 o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
5088 Perl_ck_eval(pTHX_ OP *o)
5091 PL_hints |= HINT_BLOCK_SCOPE;
5092 if (o->op_flags & OPf_KIDS) {
5093 SVOP *kid = (SVOP*)cUNOPo->op_first;
5096 o->op_flags &= ~OPf_KIDS;
5099 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
5102 cUNOPo->op_first = 0;
5105 NewOp(1101, enter, 1, LOGOP);
5106 enter->op_type = OP_ENTERTRY;
5107 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5108 enter->op_private = 0;
5110 /* establish postfix order */
5111 enter->op_next = (OP*)enter;
5113 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5114 o->op_type = OP_LEAVETRY;
5115 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5116 enter->op_other = o;
5126 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5128 o->op_targ = (PADOFFSET)PL_hints;
5133 Perl_ck_exit(pTHX_ OP *o)
5136 HV *table = GvHV(PL_hintgv);
5138 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5139 if (svp && *svp && SvTRUE(*svp))
5140 o->op_private |= OPpEXIT_VMSISH;
5142 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5148 Perl_ck_exec(pTHX_ OP *o)
5150 if (o->op_flags & OPf_STACKED) {
5153 kid = cUNOPo->op_first->op_sibling;
5154 if (kid->op_type == OP_RV2GV)
5163 Perl_ck_exists(pTHX_ OP *o)
5166 if (o->op_flags & OPf_KIDS) {
5167 OP *kid = cUNOPo->op_first;
5168 if (kid->op_type == OP_ENTERSUB) {
5169 (void) ref(kid, o->op_type);
5170 if (kid->op_type != OP_RV2CV && !PL_error_count)
5171 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5173 o->op_private |= OPpEXISTS_SUB;
5175 else if (kid->op_type == OP_AELEM)
5176 o->op_flags |= OPf_SPECIAL;
5177 else if (kid->op_type != OP_HELEM)
5178 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5186 Perl_ck_rvconst(pTHX_ register OP *o)
5189 SVOP *kid = (SVOP*)cUNOPo->op_first;
5191 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5192 if (kid->op_type == OP_CONST) {
5195 SV * const kidsv = kid->op_sv;
5197 /* Is it a constant from cv_const_sv()? */
5198 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5199 SV *rsv = SvRV(kidsv);
5200 const int svtype = SvTYPE(rsv);
5201 const char *badtype = Nullch;
5203 switch (o->op_type) {
5205 if (svtype > SVt_PVMG)
5206 badtype = "a SCALAR";
5209 if (svtype != SVt_PVAV)
5210 badtype = "an ARRAY";
5213 if (svtype != SVt_PVHV)
5217 if (svtype != SVt_PVCV)
5222 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5225 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5226 const char *badthing = Nullch;
5227 switch (o->op_type) {
5229 badthing = "a SCALAR";
5232 badthing = "an ARRAY";
5235 badthing = "a HASH";
5240 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
5244 * This is a little tricky. We only want to add the symbol if we
5245 * didn't add it in the lexer. Otherwise we get duplicate strict
5246 * warnings. But if we didn't add it in the lexer, we must at
5247 * least pretend like we wanted to add it even if it existed before,
5248 * or we get possible typo warnings. OPpCONST_ENTERED says
5249 * whether the lexer already added THIS instance of this symbol.
5251 iscv = (o->op_type == OP_RV2CV) * 2;
5253 gv = gv_fetchsv(kidsv,
5254 iscv | !(kid->op_private & OPpCONST_ENTERED),
5257 : o->op_type == OP_RV2SV
5259 : o->op_type == OP_RV2AV
5261 : o->op_type == OP_RV2HV
5264 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5266 kid->op_type = OP_GV;
5267 SvREFCNT_dec(kid->op_sv);
5269 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5270 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5271 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
5273 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
5275 kid->op_sv = SvREFCNT_inc(gv);
5277 kid->op_private = 0;
5278 kid->op_ppaddr = PL_ppaddr[OP_GV];
5285 Perl_ck_ftst(pTHX_ OP *o)
5288 const I32 type = o->op_type;
5290 if (o->op_flags & OPf_REF) {
5293 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5294 SVOP *kid = (SVOP*)cUNOPo->op_first;
5296 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5297 OP *newop = newGVOP(type, OPf_REF,
5298 gv_fetchsv(kid->op_sv, TRUE, SVt_PVIO));
5304 if ((PL_hints & HINT_FILETEST_ACCESS) &&
5305 OP_IS_FILETEST_ACCESS(o))
5306 o->op_private |= OPpFT_ACCESS;
5308 if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
5309 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
5310 o->op_private |= OPpFT_STACKED;
5314 if (type == OP_FTTTY)
5315 o = newGVOP(type, OPf_REF, PL_stdingv);
5317 o = newUNOP(type, 0, newDEFSVOP());
5323 Perl_ck_fun(pTHX_ OP *o)
5325 const int type = o->op_type;
5326 register I32 oa = PL_opargs[type] >> OASHIFT;
5328 if (o->op_flags & OPf_STACKED) {
5329 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5332 return no_fh_allowed(o);
5335 if (o->op_flags & OPf_KIDS) {
5336 OP **tokid = &cLISTOPo->op_first;
5337 register OP *kid = cLISTOPo->op_first;
5341 if (kid->op_type == OP_PUSHMARK ||
5342 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5344 tokid = &kid->op_sibling;
5345 kid = kid->op_sibling;
5347 if (!kid && PL_opargs[type] & OA_DEFGV)
5348 *tokid = kid = newDEFSVOP();
5352 sibl = kid->op_sibling;
5355 /* list seen where single (scalar) arg expected? */
5356 if (numargs == 1 && !(oa >> 4)
5357 && kid->op_type == OP_LIST && type != OP_SCALAR)
5359 return too_many_arguments(o,PL_op_desc[type]);
5372 if ((type == OP_PUSH || type == OP_UNSHIFT)
5373 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5374 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5375 "Useless use of %s with no values",
5378 if (kid->op_type == OP_CONST &&
5379 (kid->op_private & OPpCONST_BARE))
5381 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5382 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVAV) ));
5383 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5384 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5385 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
5386 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5389 kid->op_sibling = sibl;
5392 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5393 bad_type(numargs, "array", PL_op_desc[type], kid);
5397 if (kid->op_type == OP_CONST &&
5398 (kid->op_private & OPpCONST_BARE))
5400 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5401 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVHV) ));
5402 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5403 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5404 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
5405 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5408 kid->op_sibling = sibl;
5411 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5412 bad_type(numargs, "hash", PL_op_desc[type], kid);
5417 OP *newop = newUNOP(OP_NULL, 0, kid);
5418 kid->op_sibling = 0;
5420 newop->op_next = newop;
5422 kid->op_sibling = sibl;
5427 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5428 if (kid->op_type == OP_CONST &&
5429 (kid->op_private & OPpCONST_BARE))
5431 OP *newop = newGVOP(OP_GV, 0,
5432 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVIO) );
5433 if (!(o->op_private & 1) && /* if not unop */
5434 kid == cLISTOPo->op_last)
5435 cLISTOPo->op_last = newop;
5439 else if (kid->op_type == OP_READLINE) {
5440 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5441 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5444 I32 flags = OPf_SPECIAL;
5448 /* is this op a FH constructor? */
5449 if (is_handle_constructor(o,numargs)) {
5450 const char *name = Nullch;
5454 /* Set a flag to tell rv2gv to vivify
5455 * need to "prove" flag does not mean something
5456 * else already - NI-S 1999/05/07
5459 if (kid->op_type == OP_PADSV) {
5460 name = PAD_COMPNAME_PV(kid->op_targ);
5461 /* SvCUR of a pad namesv can't be trusted
5462 * (see PL_generation), so calc its length
5468 else if (kid->op_type == OP_RV2SV
5469 && kUNOP->op_first->op_type == OP_GV)
5471 GV *gv = cGVOPx_gv(kUNOP->op_first);
5473 len = GvNAMELEN(gv);
5475 else if (kid->op_type == OP_AELEM
5476 || kid->op_type == OP_HELEM)
5481 if ((op = ((BINOP*)kid)->op_first)) {
5482 SV *tmpstr = Nullsv;
5484 kid->op_type == OP_AELEM ?
5486 if (((op->op_type == OP_RV2AV) ||
5487 (op->op_type == OP_RV2HV)) &&
5488 (op = ((UNOP*)op)->op_first) &&
5489 (op->op_type == OP_GV)) {
5490 /* packagevar $a[] or $h{} */
5491 GV *gv = cGVOPx_gv(op);
5499 else if (op->op_type == OP_PADAV
5500 || op->op_type == OP_PADHV) {
5501 /* lexicalvar $a[] or $h{} */
5502 const char *padname =
5503 PAD_COMPNAME_PV(op->op_targ);
5513 name = SvPV(tmpstr, len);
5518 name = "__ANONIO__";
5525 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5526 namesv = PAD_SVl(targ);
5527 SvUPGRADE(namesv, SVt_PV);
5529 sv_setpvn(namesv, "$", 1);
5530 sv_catpvn(namesv, name, len);
5533 kid->op_sibling = 0;
5534 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5535 kid->op_targ = targ;
5536 kid->op_private |= priv;
5538 kid->op_sibling = sibl;
5544 mod(scalar(kid), type);
5548 tokid = &kid->op_sibling;
5549 kid = kid->op_sibling;
5551 o->op_private |= numargs;
5553 return too_many_arguments(o,OP_DESC(o));
5556 else if (PL_opargs[type] & OA_DEFGV) {
5558 return newUNOP(type, 0, newDEFSVOP());
5562 while (oa & OA_OPTIONAL)
5564 if (oa && oa != OA_LIST)
5565 return too_few_arguments(o,OP_DESC(o));
5571 Perl_ck_glob(pTHX_ OP *o)
5577 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5578 append_elem(OP_GLOB, o, newDEFSVOP());
5580 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5581 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5583 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5586 #if !defined(PERL_EXTERNAL_GLOB)
5587 /* XXX this can be tightened up and made more failsafe. */
5588 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5591 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5592 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5593 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5594 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5595 GvCV(gv) = GvCV(glob_gv);
5596 (void)SvREFCNT_inc((SV*)GvCV(gv));
5597 GvIMPORTED_CV_on(gv);
5600 #endif /* PERL_EXTERNAL_GLOB */
5602 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5603 append_elem(OP_GLOB, o,
5604 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5605 o->op_type = OP_LIST;
5606 o->op_ppaddr = PL_ppaddr[OP_LIST];
5607 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5608 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5609 cLISTOPo->op_first->op_targ = 0;
5610 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5611 append_elem(OP_LIST, o,
5612 scalar(newUNOP(OP_RV2CV, 0,
5613 newGVOP(OP_GV, 0, gv)))));
5614 o = newUNOP(OP_NULL, 0, ck_subr(o));
5615 o->op_targ = OP_GLOB; /* hint at what it used to be */
5618 gv = newGVgen("main");
5620 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5626 Perl_ck_grep(pTHX_ OP *o)
5631 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5634 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5635 NewOp(1101, gwop, 1, LOGOP);
5637 if (o->op_flags & OPf_STACKED) {
5640 kid = cLISTOPo->op_first->op_sibling;
5641 if (!cUNOPx(kid)->op_next)
5642 Perl_croak(aTHX_ "panic: ck_grep");
5643 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
5646 kid->op_next = (OP*)gwop;
5647 o->op_flags &= ~OPf_STACKED;
5649 kid = cLISTOPo->op_first->op_sibling;
5650 if (type == OP_MAPWHILE)
5657 kid = cLISTOPo->op_first->op_sibling;
5658 if (kid->op_type != OP_NULL)
5659 Perl_croak(aTHX_ "panic: ck_grep");
5660 kid = kUNOP->op_first;
5662 gwop->op_type = type;
5663 gwop->op_ppaddr = PL_ppaddr[type];
5664 gwop->op_first = listkids(o);
5665 gwop->op_flags |= OPf_KIDS;
5666 gwop->op_other = LINKLIST(kid);
5667 kid->op_next = (OP*)gwop;
5668 offset = pad_findmy("$_");
5669 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
5670 o->op_private = gwop->op_private = 0;
5671 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5674 o->op_private = gwop->op_private = OPpGREP_LEX;
5675 gwop->op_targ = o->op_targ = offset;
5678 kid = cLISTOPo->op_first->op_sibling;
5679 if (!kid || !kid->op_sibling)
5680 return too_few_arguments(o,OP_DESC(o));
5681 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5682 mod(kid, OP_GREPSTART);
5688 Perl_ck_index(pTHX_ OP *o)
5690 if (o->op_flags & OPf_KIDS) {
5691 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5693 kid = kid->op_sibling; /* get past "big" */
5694 if (kid && kid->op_type == OP_CONST)
5695 fbm_compile(((SVOP*)kid)->op_sv, 0);
5701 Perl_ck_lengthconst(pTHX_ OP *o)
5703 /* XXX length optimization goes here */
5708 Perl_ck_lfun(pTHX_ OP *o)
5710 const OPCODE type = o->op_type;
5711 return modkids(ck_fun(o), type);
5715 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5717 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5718 switch (cUNOPo->op_first->op_type) {
5720 /* This is needed for
5721 if (defined %stash::)
5722 to work. Do not break Tk.
5724 break; /* Globals via GV can be undef */
5726 case OP_AASSIGN: /* Is this a good idea? */
5727 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5728 "defined(@array) is deprecated");
5729 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5730 "\t(Maybe you should just omit the defined()?)\n");
5733 /* This is needed for
5734 if (defined %stash::)
5735 to work. Do not break Tk.
5737 break; /* Globals via GV can be undef */
5739 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5740 "defined(%%hash) is deprecated");
5741 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5742 "\t(Maybe you should just omit the defined()?)\n");
5753 Perl_ck_rfun(pTHX_ OP *o)
5755 const OPCODE type = o->op_type;
5756 return refkids(ck_fun(o), type);
5760 Perl_ck_listiob(pTHX_ OP *o)
5764 kid = cLISTOPo->op_first;
5767 kid = cLISTOPo->op_first;
5769 if (kid->op_type == OP_PUSHMARK)
5770 kid = kid->op_sibling;
5771 if (kid && o->op_flags & OPf_STACKED)
5772 kid = kid->op_sibling;
5773 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5774 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5775 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5776 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5777 cLISTOPo->op_first->op_sibling = kid;
5778 cLISTOPo->op_last = kid;
5779 kid = kid->op_sibling;
5784 append_elem(o->op_type, o, newDEFSVOP());
5790 Perl_ck_sassign(pTHX_ OP *o)
5792 OP *kid = cLISTOPo->op_first;
5793 /* has a disposable target? */
5794 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5795 && !(kid->op_flags & OPf_STACKED)
5796 /* Cannot steal the second time! */
5797 && !(kid->op_private & OPpTARGET_MY))
5799 OP *kkid = kid->op_sibling;
5801 /* Can just relocate the target. */
5802 if (kkid && kkid->op_type == OP_PADSV
5803 && !(kkid->op_private & OPpLVAL_INTRO))
5805 kid->op_targ = kkid->op_targ;
5807 /* Now we do not need PADSV and SASSIGN. */
5808 kid->op_sibling = o->op_sibling; /* NULL */
5809 cLISTOPo->op_first = NULL;
5812 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
5816 /* optimise C<my $x = undef> to C<my $x> */
5817 if (kid->op_type == OP_UNDEF) {
5818 OP *kkid = kid->op_sibling;
5819 if (kkid && kkid->op_type == OP_PADSV
5820 && (kkid->op_private & OPpLVAL_INTRO))
5822 cLISTOPo->op_first = NULL;
5823 kid->op_sibling = NULL;
5833 Perl_ck_match(pTHX_ OP *o)
5835 if (o->op_type != OP_QR) {
5836 const I32 offset = pad_findmy("$_");
5837 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS(offset) & SVpad_OUR)) {
5838 o->op_targ = offset;
5839 o->op_private |= OPpTARGET_MY;
5842 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
5843 o->op_private |= OPpRUNTIME;
5848 Perl_ck_method(pTHX_ OP *o)
5850 OP *kid = cUNOPo->op_first;
5851 if (kid->op_type == OP_CONST) {
5852 SV* sv = kSVOP->op_sv;
5853 if (!(strchr(SvPVX_const(sv), ':') || strchr(SvPVX_const(sv), '\''))) {
5855 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5856 sv = newSVpvn_share(SvPVX_const(sv), SvCUR(sv), 0);
5859 kSVOP->op_sv = Nullsv;
5861 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5870 Perl_ck_null(pTHX_ OP *o)
5876 Perl_ck_open(pTHX_ OP *o)
5878 HV *table = GvHV(PL_hintgv);
5882 svp = hv_fetch(table, "open_IN", 7, FALSE);
5884 mode = mode_from_discipline(*svp);
5885 if (mode & O_BINARY)
5886 o->op_private |= OPpOPEN_IN_RAW;
5887 else if (mode & O_TEXT)
5888 o->op_private |= OPpOPEN_IN_CRLF;
5891 svp = hv_fetch(table, "open_OUT", 8, FALSE);
5893 mode = mode_from_discipline(*svp);
5894 if (mode & O_BINARY)
5895 o->op_private |= OPpOPEN_OUT_RAW;
5896 else if (mode & O_TEXT)
5897 o->op_private |= OPpOPEN_OUT_CRLF;
5900 if (o->op_type == OP_BACKTICK)
5903 /* In case of three-arg dup open remove strictness
5904 * from the last arg if it is a bareword. */
5905 OP *first = cLISTOPx(o)->op_first; /* The pushmark. */
5906 OP *last = cLISTOPx(o)->op_last; /* The bareword. */
5910 if ((last->op_type == OP_CONST) && /* The bareword. */
5911 (last->op_private & OPpCONST_BARE) &&
5912 (last->op_private & OPpCONST_STRICT) &&
5913 (oa = first->op_sibling) && /* The fh. */
5914 (oa = oa->op_sibling) && /* The mode. */
5915 SvPOK(((SVOP*)oa)->op_sv) &&
5916 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
5917 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
5918 (last == oa->op_sibling)) /* The bareword. */
5919 last->op_private &= ~OPpCONST_STRICT;
5925 Perl_ck_repeat(pTHX_ OP *o)
5927 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5928 o->op_private |= OPpREPEAT_DOLIST;
5929 cBINOPo->op_first = force_list(cBINOPo->op_first);
5937 Perl_ck_require(pTHX_ OP *o)
5941 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
5942 SVOP *kid = (SVOP*)cUNOPo->op_first;
5944 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5945 SV *sv = kid->op_sv;
5946 U32 was_readonly = SvREADONLY(sv);
5951 sv_force_normal_flags(sv, 0);
5952 assert(!SvREADONLY(sv));
5959 for (s = SvPVX(sv); *s; s++) {
5960 if (*s == ':' && s[1] == ':') {
5962 Move(s+2, s+1, strlen(s+2)+1, char);
5963 SvCUR_set(sv, SvCUR(sv) - 1);
5966 sv_catpvn(sv, ".pm", 3);
5967 SvFLAGS(sv) |= was_readonly;
5971 /* handle override, if any */
5972 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
5973 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
5974 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
5976 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5977 OP *kid = cUNOPo->op_first;
5978 cUNOPo->op_first = 0;
5980 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5981 append_elem(OP_LIST, kid,
5982 scalar(newUNOP(OP_RV2CV, 0,
5991 Perl_ck_return(pTHX_ OP *o)
5993 if (CvLVALUE(PL_compcv)) {
5995 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5996 mod(kid, OP_LEAVESUBLV);
6003 Perl_ck_retarget(pTHX_ OP *o)
6005 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6012 Perl_ck_select(pTHX_ OP *o)
6016 if (o->op_flags & OPf_KIDS) {
6017 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6018 if (kid && kid->op_sibling) {
6019 o->op_type = OP_SSELECT;
6020 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6022 return fold_constants(o);
6026 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6027 if (kid && kid->op_type == OP_RV2GV)
6028 kid->op_private &= ~HINT_STRICT_REFS;
6033 Perl_ck_shift(pTHX_ OP *o)
6035 const I32 type = o->op_type;
6037 if (!(o->op_flags & OPf_KIDS)) {
6041 argop = newUNOP(OP_RV2AV, 0,
6042 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
6043 return newUNOP(type, 0, scalar(argop));
6045 return scalar(modkids(ck_fun(o), type));
6049 Perl_ck_sort(pTHX_ OP *o)
6053 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6055 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6056 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6058 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6060 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6062 if (kid->op_type == OP_SCOPE) {
6066 else if (kid->op_type == OP_LEAVE) {
6067 if (o->op_type == OP_SORT) {
6068 op_null(kid); /* wipe out leave */
6071 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6072 if (k->op_next == kid)
6074 /* don't descend into loops */
6075 else if (k->op_type == OP_ENTERLOOP
6076 || k->op_type == OP_ENTERITER)
6078 k = cLOOPx(k)->op_lastop;
6083 kid->op_next = 0; /* just disconnect the leave */
6084 k = kLISTOP->op_first;
6089 if (o->op_type == OP_SORT) {
6090 /* provide scalar context for comparison function/block */
6096 o->op_flags |= OPf_SPECIAL;
6098 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6101 firstkid = firstkid->op_sibling;
6104 /* provide list context for arguments */
6105 if (o->op_type == OP_SORT)
6112 S_simplify_sort(pTHX_ OP *o)
6114 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6119 if (!(o->op_flags & OPf_STACKED))
6121 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6122 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6123 kid = kUNOP->op_first; /* get past null */
6124 if (kid->op_type != OP_SCOPE)
6126 kid = kLISTOP->op_last; /* get past scope */
6127 switch(kid->op_type) {
6135 k = kid; /* remember this node*/
6136 if (kBINOP->op_first->op_type != OP_RV2SV)
6138 kid = kBINOP->op_first; /* get past cmp */
6139 if (kUNOP->op_first->op_type != OP_GV)
6141 kid = kUNOP->op_first; /* get past rv2sv */
6143 if (GvSTASH(gv) != PL_curstash)
6145 gvname = GvNAME(gv);
6146 if (*gvname == 'a' && gvname[1] == '\0')
6148 else if (*gvname == 'b' && gvname[1] == '\0')
6153 kid = k; /* back to cmp */
6154 if (kBINOP->op_last->op_type != OP_RV2SV)
6156 kid = kBINOP->op_last; /* down to 2nd arg */
6157 if (kUNOP->op_first->op_type != OP_GV)
6159 kid = kUNOP->op_first; /* get past rv2sv */
6161 if (GvSTASH(gv) != PL_curstash)
6163 gvname = GvNAME(gv);
6165 ? !(*gvname == 'a' && gvname[1] == '\0')
6166 : !(*gvname == 'b' && gvname[1] == '\0'))
6168 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6170 o->op_private |= OPpSORT_DESCEND;
6171 if (k->op_type == OP_NCMP)
6172 o->op_private |= OPpSORT_NUMERIC;
6173 if (k->op_type == OP_I_NCMP)
6174 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6175 kid = cLISTOPo->op_first->op_sibling;
6176 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6177 op_free(kid); /* then delete it */
6181 Perl_ck_split(pTHX_ OP *o)
6186 if (o->op_flags & OPf_STACKED)
6187 return no_fh_allowed(o);
6189 kid = cLISTOPo->op_first;
6190 if (kid->op_type != OP_NULL)
6191 Perl_croak(aTHX_ "panic: ck_split");
6192 kid = kid->op_sibling;
6193 op_free(cLISTOPo->op_first);
6194 cLISTOPo->op_first = kid;
6196 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6197 cLISTOPo->op_last = kid; /* There was only one element previously */
6200 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6201 OP *sibl = kid->op_sibling;
6202 kid->op_sibling = 0;
6203 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
6204 if (cLISTOPo->op_first == cLISTOPo->op_last)
6205 cLISTOPo->op_last = kid;
6206 cLISTOPo->op_first = kid;
6207 kid->op_sibling = sibl;
6210 kid->op_type = OP_PUSHRE;
6211 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6213 if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
6214 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
6215 "Use of /g modifier is meaningless in split");
6218 if (!kid->op_sibling)
6219 append_elem(OP_SPLIT, o, newDEFSVOP());
6221 kid = kid->op_sibling;
6224 if (!kid->op_sibling)
6225 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6227 kid = kid->op_sibling;
6230 if (kid->op_sibling)
6231 return too_many_arguments(o,OP_DESC(o));
6237 Perl_ck_join(pTHX_ OP *o)
6239 if (ckWARN(WARN_SYNTAX)) {
6240 const OP *kid = cLISTOPo->op_first->op_sibling;
6241 if (kid && kid->op_type == OP_MATCH) {
6242 const REGEXP *re = PM_GETRE(kPMOP);
6243 const char *pmstr = re ? re->precomp : "STRING";
6244 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6245 "/%s/ should probably be written as \"%s\"",
6253 Perl_ck_subr(pTHX_ OP *o)
6255 OP *prev = ((cUNOPo->op_first->op_sibling)
6256 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6257 OP *o2 = prev->op_sibling;
6264 I32 contextclass = 0;
6269 o->op_private |= OPpENTERSUB_HASTARG;
6270 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6271 if (cvop->op_type == OP_RV2CV) {
6273 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6274 op_null(cvop); /* disable rv2cv */
6275 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6276 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6277 GV *gv = cGVOPx_gv(tmpop);
6280 tmpop->op_private |= OPpEARLY_CV;
6283 namegv = CvANON(cv) ? gv : CvGV(cv);
6284 proto = SvPV((SV*)cv, n_a);
6286 if (CvASSERTION(cv)) {
6287 if (PL_hints & HINT_ASSERTING) {
6288 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
6289 o->op_private |= OPpENTERSUB_DB;
6293 if (ckWARN(WARN_ASSERTIONS) && !(PL_hints & HINT_ASSERTIONSSEEN)) {
6294 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
6295 "Impossible to activate assertion call");
6302 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6303 if (o2->op_type == OP_CONST)
6304 o2->op_private &= ~OPpCONST_STRICT;
6305 else if (o2->op_type == OP_LIST) {
6306 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6307 if (o && o->op_type == OP_CONST)
6308 o->op_private &= ~OPpCONST_STRICT;
6311 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6312 if (PERLDB_SUB && PL_curstash != PL_debstash)
6313 o->op_private |= OPpENTERSUB_DB;
6314 while (o2 != cvop) {
6318 return too_many_arguments(o, gv_ename(namegv));
6336 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6338 arg == 1 ? "block or sub {}" : "sub {}",
6339 gv_ename(namegv), o2);
6342 /* '*' allows any scalar type, including bareword */
6345 if (o2->op_type == OP_RV2GV)
6346 goto wrapref; /* autoconvert GLOB -> GLOBref */
6347 else if (o2->op_type == OP_CONST)
6348 o2->op_private &= ~OPpCONST_STRICT;
6349 else if (o2->op_type == OP_ENTERSUB) {
6350 /* accidental subroutine, revert to bareword */
6351 OP *gvop = ((UNOP*)o2)->op_first;
6352 if (gvop && gvop->op_type == OP_NULL) {
6353 gvop = ((UNOP*)gvop)->op_first;
6355 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6358 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6359 (gvop = ((UNOP*)gvop)->op_first) &&
6360 gvop->op_type == OP_GV)
6362 GV *gv = cGVOPx_gv(gvop);
6363 OP *sibling = o2->op_sibling;
6364 SV *n = newSVpvn("",0);
6366 gv_fullname4(n, gv, "", FALSE);
6367 o2 = newSVOP(OP_CONST, 0, n);
6368 prev->op_sibling = o2;
6369 o2->op_sibling = sibling;
6385 if (contextclass++ == 0) {
6386 e = strchr(proto, ']');
6387 if (!e || e == proto)
6400 while (*--p != '[');
6401 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6402 gv_ename(namegv), o2);
6408 if (o2->op_type == OP_RV2GV)
6411 bad_type(arg, "symbol", gv_ename(namegv), o2);
6414 if (o2->op_type == OP_ENTERSUB)
6417 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6420 if (o2->op_type == OP_RV2SV ||
6421 o2->op_type == OP_PADSV ||
6422 o2->op_type == OP_HELEM ||
6423 o2->op_type == OP_AELEM ||
6424 o2->op_type == OP_THREADSV)
6427 bad_type(arg, "scalar", gv_ename(namegv), o2);
6430 if (o2->op_type == OP_RV2AV ||
6431 o2->op_type == OP_PADAV)
6434 bad_type(arg, "array", gv_ename(namegv), o2);
6437 if (o2->op_type == OP_RV2HV ||
6438 o2->op_type == OP_PADHV)
6441 bad_type(arg, "hash", gv_ename(namegv), o2);
6446 OP* sib = kid->op_sibling;
6447 kid->op_sibling = 0;
6448 o2 = newUNOP(OP_REFGEN, 0, kid);
6449 o2->op_sibling = sib;
6450 prev->op_sibling = o2;
6452 if (contextclass && e) {
6467 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6468 gv_ename(namegv), cv);
6473 mod(o2, OP_ENTERSUB);
6475 o2 = o2->op_sibling;
6477 if (proto && !optional &&
6478 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6479 return too_few_arguments(o, gv_ename(namegv));
6482 o=newSVOP(OP_CONST, 0, newSViv(0));
6488 Perl_ck_svconst(pTHX_ OP *o)
6490 SvREADONLY_on(cSVOPo->op_sv);
6495 Perl_ck_trunc(pTHX_ OP *o)
6497 if (o->op_flags & OPf_KIDS) {
6498 SVOP *kid = (SVOP*)cUNOPo->op_first;
6500 if (kid->op_type == OP_NULL)
6501 kid = (SVOP*)kid->op_sibling;
6502 if (kid && kid->op_type == OP_CONST &&
6503 (kid->op_private & OPpCONST_BARE))
6505 o->op_flags |= OPf_SPECIAL;
6506 kid->op_private &= ~OPpCONST_STRICT;
6513 Perl_ck_unpack(pTHX_ OP *o)
6515 OP *kid = cLISTOPo->op_first;
6516 if (kid->op_sibling) {
6517 kid = kid->op_sibling;
6518 if (!kid->op_sibling)
6519 kid->op_sibling = newDEFSVOP();
6525 Perl_ck_substr(pTHX_ OP *o)
6528 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6529 OP *kid = cLISTOPo->op_first;
6531 if (kid->op_type == OP_NULL)
6532 kid = kid->op_sibling;
6534 kid->op_flags |= OPf_MOD;
6540 /* A peephole optimizer. We visit the ops in the order they're to execute.
6541 * See the comments at the top of this file for more details about when
6542 * peep() is called */
6545 Perl_peep(pTHX_ register OP *o)
6548 register OP* oldop = 0;
6550 if (!o || o->op_opt)
6554 SAVEVPTR(PL_curcop);
6555 for (; o; o = o->op_next) {
6559 switch (o->op_type) {
6563 PL_curcop = ((COP*)o); /* for warnings */
6568 if (cSVOPo->op_private & OPpCONST_STRICT)
6569 no_bareword_allowed(o);
6571 case OP_METHOD_NAMED:
6572 /* Relocate sv to the pad for thread safety.
6573 * Despite being a "constant", the SV is written to,
6574 * for reference counts, sv_upgrade() etc. */
6576 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6577 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6578 /* If op_sv is already a PADTMP then it is being used by
6579 * some pad, so make a copy. */
6580 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6581 SvREADONLY_on(PAD_SVl(ix));
6582 SvREFCNT_dec(cSVOPo->op_sv);
6585 SvREFCNT_dec(PAD_SVl(ix));
6586 SvPADTMP_on(cSVOPo->op_sv);
6587 PAD_SETSV(ix, cSVOPo->op_sv);
6588 /* XXX I don't know how this isn't readonly already. */
6589 SvREADONLY_on(PAD_SVl(ix));
6591 cSVOPo->op_sv = Nullsv;
6599 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6600 if (o->op_next->op_private & OPpTARGET_MY) {
6601 if (o->op_flags & OPf_STACKED) /* chained concats */
6602 goto ignore_optimization;
6604 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6605 o->op_targ = o->op_next->op_targ;
6606 o->op_next->op_targ = 0;
6607 o->op_private |= OPpTARGET_MY;
6610 op_null(o->op_next);
6612 ignore_optimization:
6616 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6618 break; /* Scalar stub must produce undef. List stub is noop */
6622 if (o->op_targ == OP_NEXTSTATE
6623 || o->op_targ == OP_DBSTATE
6624 || o->op_targ == OP_SETSTATE)
6626 PL_curcop = ((COP*)o);
6628 /* XXX: We avoid setting op_seq here to prevent later calls
6629 to peep() from mistakenly concluding that optimisation
6630 has already occurred. This doesn't fix the real problem,
6631 though (See 20010220.007). AMS 20010719 */
6632 /* op_seq functionality is now replaced by op_opt */
6633 if (oldop && o->op_next) {
6634 oldop->op_next = o->op_next;
6642 if (oldop && o->op_next) {
6643 oldop->op_next = o->op_next;
6651 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
6652 OP* pop = (o->op_type == OP_PADAV) ?
6653 o->op_next : o->op_next->op_next;
6655 if (pop && pop->op_type == OP_CONST &&
6656 ((PL_op = pop->op_next)) &&
6657 pop->op_next->op_type == OP_AELEM &&
6658 !(pop->op_next->op_private &
6659 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6660 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6665 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
6666 no_bareword_allowed(pop);
6667 if (o->op_type == OP_GV)
6668 op_null(o->op_next);
6669 op_null(pop->op_next);
6671 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6672 o->op_next = pop->op_next->op_next;
6673 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6674 o->op_private = (U8)i;
6675 if (o->op_type == OP_GV) {
6680 o->op_flags |= OPf_SPECIAL;
6681 o->op_type = OP_AELEMFAST;
6687 if (o->op_next->op_type == OP_RV2SV) {
6688 if (!(o->op_next->op_private & OPpDEREF)) {
6689 op_null(o->op_next);
6690 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6692 o->op_next = o->op_next->op_next;
6693 o->op_type = OP_GVSV;
6694 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6697 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6699 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
6700 /* XXX could check prototype here instead of just carping */
6701 SV *sv = sv_newmortal();
6702 gv_efullname3(sv, gv, Nullch);
6703 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6704 "%"SVf"() called too early to check prototype",
6708 else if (o->op_next->op_type == OP_READLINE
6709 && o->op_next->op_next->op_type == OP_CONCAT
6710 && (o->op_next->op_next->op_flags & OPf_STACKED))
6712 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6713 o->op_type = OP_RCATLINE;
6714 o->op_flags |= OPf_STACKED;
6715 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6716 op_null(o->op_next->op_next);
6717 op_null(o->op_next);
6734 while (cLOGOP->op_other->op_type == OP_NULL)
6735 cLOGOP->op_other = cLOGOP->op_other->op_next;
6736 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6742 while (cLOOP->op_redoop->op_type == OP_NULL)
6743 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6744 peep(cLOOP->op_redoop);
6745 while (cLOOP->op_nextop->op_type == OP_NULL)
6746 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6747 peep(cLOOP->op_nextop);
6748 while (cLOOP->op_lastop->op_type == OP_NULL)
6749 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6750 peep(cLOOP->op_lastop);
6757 while (cPMOP->op_pmreplstart &&
6758 cPMOP->op_pmreplstart->op_type == OP_NULL)
6759 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6760 peep(cPMOP->op_pmreplstart);
6765 if (ckWARN(WARN_SYNTAX) && o->op_next
6766 && o->op_next->op_type == OP_NEXTSTATE) {
6767 if (o->op_next->op_sibling &&
6768 o->op_next->op_sibling->op_type != OP_EXIT &&
6769 o->op_next->op_sibling->op_type != OP_WARN &&
6770 o->op_next->op_sibling->op_type != OP_DIE) {
6771 const line_t oldline = CopLINE(PL_curcop);
6773 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6774 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6775 "Statement unlikely to be reached");
6776 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6777 "\t(Maybe you meant system() when you said exec()?)\n");
6778 CopLINE_set(PL_curcop, oldline);
6793 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6796 /* Make the CONST have a shared SV */
6797 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6798 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6799 key = SvPV(sv, keylen);
6800 lexname = newSVpvn_share(key,
6801 SvUTF8(sv) ? -(I32)keylen : keylen,
6807 if ((o->op_private & (OPpLVAL_INTRO)))
6810 rop = (UNOP*)((BINOP*)o)->op_first;
6811 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6813 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6814 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6816 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6817 if (!fields || !GvHV(*fields))
6819 key = SvPV(*svp, keylen);
6820 if (!hv_fetch(GvHV(*fields), key,
6821 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
6823 Perl_croak(aTHX_ "No such class field \"%s\" "
6824 "in variable %s of type %s",
6825 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
6838 SVOP *first_key_op, *key_op;
6840 if ((o->op_private & (OPpLVAL_INTRO))
6841 /* I bet there's always a pushmark... */
6842 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6843 /* hmmm, no optimization if list contains only one key. */
6845 rop = (UNOP*)((LISTOP*)o)->op_last;
6846 if (rop->op_type != OP_RV2HV)
6848 if (rop->op_first->op_type == OP_PADSV)
6849 /* @$hash{qw(keys here)} */
6850 rop = (UNOP*)rop->op_first;
6852 /* @{$hash}{qw(keys here)} */
6853 if (rop->op_first->op_type == OP_SCOPE
6854 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
6856 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
6862 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
6863 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6865 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6866 if (!fields || !GvHV(*fields))
6868 /* Again guessing that the pushmark can be jumped over.... */
6869 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
6870 ->op_first->op_sibling;
6871 for (key_op = first_key_op; key_op;
6872 key_op = (SVOP*)key_op->op_sibling) {
6873 if (key_op->op_type != OP_CONST)
6875 svp = cSVOPx_svp(key_op);
6876 key = SvPV(*svp, keylen);
6877 if (!hv_fetch(GvHV(*fields), key,
6878 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
6880 Perl_croak(aTHX_ "No such class field \"%s\" "
6881 "in variable %s of type %s",
6882 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
6889 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
6893 /* check that RHS of sort is a single plain array */
6894 oright = cUNOPo->op_first;
6895 if (!oright || oright->op_type != OP_PUSHMARK)
6898 /* reverse sort ... can be optimised. */
6899 if (!cUNOPo->op_sibling) {
6900 /* Nothing follows us on the list. */
6901 OP *reverse = o->op_next;
6903 if (reverse->op_type == OP_REVERSE &&
6904 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
6905 OP *pushmark = cUNOPx(reverse)->op_first;
6906 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
6907 && (cUNOPx(pushmark)->op_sibling == o)) {
6908 /* reverse -> pushmark -> sort */
6909 o->op_private |= OPpSORT_REVERSE;
6911 pushmark->op_next = oright->op_next;
6917 /* make @a = sort @a act in-place */
6921 oright = cUNOPx(oright)->op_sibling;
6924 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
6925 oright = cUNOPx(oright)->op_sibling;
6929 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
6930 || oright->op_next != o
6931 || (oright->op_private & OPpLVAL_INTRO)
6935 /* o2 follows the chain of op_nexts through the LHS of the
6936 * assign (if any) to the aassign op itself */
6938 if (!o2 || o2->op_type != OP_NULL)
6941 if (!o2 || o2->op_type != OP_PUSHMARK)
6944 if (o2 && o2->op_type == OP_GV)
6947 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
6948 || (o2->op_private & OPpLVAL_INTRO)
6953 if (!o2 || o2->op_type != OP_NULL)
6956 if (!o2 || o2->op_type != OP_AASSIGN
6957 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
6960 /* check that the sort is the first arg on RHS of assign */
6962 o2 = cUNOPx(o2)->op_first;
6963 if (!o2 || o2->op_type != OP_NULL)
6965 o2 = cUNOPx(o2)->op_first;
6966 if (!o2 || o2->op_type != OP_PUSHMARK)
6968 if (o2->op_sibling != o)
6971 /* check the array is the same on both sides */
6972 if (oleft->op_type == OP_RV2AV) {
6973 if (oright->op_type != OP_RV2AV
6974 || !cUNOPx(oright)->op_first
6975 || cUNOPx(oright)->op_first->op_type != OP_GV
6976 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
6977 cGVOPx_gv(cUNOPx(oright)->op_first)
6981 else if (oright->op_type != OP_PADAV
6982 || oright->op_targ != oleft->op_targ
6986 /* transfer MODishness etc from LHS arg to RHS arg */
6987 oright->op_flags = oleft->op_flags;
6988 o->op_private |= OPpSORT_INPLACE;
6990 /* excise push->gv->rv2av->null->aassign */
6991 o2 = o->op_next->op_next;
6992 op_null(o2); /* PUSHMARK */
6994 if (o2->op_type == OP_GV) {
6995 op_null(o2); /* GV */
6998 op_null(o2); /* RV2AV or PADAV */
6999 o2 = o2->op_next->op_next;
7000 op_null(o2); /* AASSIGN */
7002 o->op_next = o2->op_next;
7008 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
7010 LISTOP *enter, *exlist;
7013 enter = (LISTOP *) o->op_next;
7016 if (enter->op_type == OP_NULL) {
7017 enter = (LISTOP *) enter->op_next;
7021 /* for $a (...) will have OP_GV then OP_RV2GV here.
7022 for (...) just has an OP_GV. */
7023 if (enter->op_type == OP_GV) {
7024 gvop = (OP *) enter;
7025 enter = (LISTOP *) enter->op_next;
7028 if (enter->op_type == OP_RV2GV) {
7029 enter = (LISTOP *) enter->op_next;
7035 if (enter->op_type != OP_ENTERITER)
7038 iter = enter->op_next;
7039 if (!iter || iter->op_type != OP_ITER)
7042 expushmark = enter->op_first;
7043 if (!expushmark || expushmark->op_type != OP_NULL
7044 || expushmark->op_targ != OP_PUSHMARK)
7047 exlist = (LISTOP *) expushmark->op_sibling;
7048 if (!exlist || exlist->op_type != OP_NULL
7049 || exlist->op_targ != OP_LIST)
7052 if (exlist->op_last != o) {
7053 /* Mmm. Was expecting to point back to this op. */
7056 theirmark = exlist->op_first;
7057 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
7060 if (theirmark->op_sibling != o) {
7061 /* There's something between the mark and the reverse, eg
7062 for (1, reverse (...))
7067 ourmark = ((LISTOP *)o)->op_first;
7068 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
7071 ourlast = ((LISTOP *)o)->op_last;
7072 if (!ourlast || ourlast->op_next != o)
7075 rv2av = ourmark->op_sibling;
7076 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
7077 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
7078 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
7079 /* We're just reversing a single array. */
7080 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
7081 enter->op_flags |= OPf_STACKED;
7084 /* We don't have control over who points to theirmark, so sacrifice
7086 theirmark->op_next = ourmark->op_next;
7087 theirmark->op_flags = ourmark->op_flags;
7088 ourlast->op_next = gvop ? gvop : (OP *) enter;
7091 enter->op_private |= OPpITER_REVERSED;
7092 iter->op_private |= OPpITER_REVERSED;
7107 Perl_custom_op_name(pTHX_ const OP* o)
7109 const IV index = PTR2IV(o->op_ppaddr);
7113 if (!PL_custom_op_names) /* This probably shouldn't happen */
7114 return (char *)PL_op_name[OP_CUSTOM];
7116 keysv = sv_2mortal(newSViv(index));
7118 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7120 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7122 return SvPV_nolen(HeVAL(he));
7126 Perl_custom_op_desc(pTHX_ const OP* o)
7128 const IV index = PTR2IV(o->op_ppaddr);
7132 if (!PL_custom_op_descs)
7133 return (char *)PL_op_desc[OP_CUSTOM];
7135 keysv = sv_2mortal(newSViv(index));
7137 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7139 return (char *)PL_op_desc[OP_CUSTOM];
7141 return SvPV_nolen(HeVAL(he));
7146 /* Efficient sub that returns a constant scalar value. */
7148 const_sv_xsub(pTHX_ CV* cv)
7153 Perl_croak(aTHX_ "usage: %s::%s()",
7154 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7158 ST(0) = (SV*)XSANY.any_ptr;
7164 * c-indentation-style: bsd
7166 * indent-tabs-mode: t
7169 * ex: set ts=8 sts=4 sw=4 noet: