3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 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.
49 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
51 #if defined(PL_OP_SLAB_ALLOC)
53 #ifndef PERL_SLAB_SIZE
54 #define PERL_SLAB_SIZE 2048
58 Perl_Slab_Alloc(pTHX_ int m, size_t sz)
61 * To make incrementing use count easy PL_OpSlab is an I32 *
62 * To make inserting the link to slab PL_OpPtr is I32 **
63 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
64 * Add an overhead for pointer to slab and round up as a number of pointers
66 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
67 if ((PL_OpSpace -= sz) < 0) {
68 PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*));
72 Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **);
73 /* We reserve the 0'th I32 sized chunk as a use count */
74 PL_OpSlab = (I32 *) PL_OpPtr;
75 /* Reduce size by the use count word, and by the size we need.
76 * Latter is to mimic the '-=' in the if() above
78 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
79 /* Allocation pointer starts at the top.
80 Theory: because we build leaves before trunk allocating at end
81 means that at run time access is cache friendly upward
83 PL_OpPtr += PERL_SLAB_SIZE;
85 assert( PL_OpSpace >= 0 );
86 /* Move the allocation pointer down */
88 assert( PL_OpPtr > (I32 **) PL_OpSlab );
89 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
90 (*PL_OpSlab)++; /* Increment use count of slab */
91 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
92 assert( *PL_OpSlab > 0 );
93 return (void *)(PL_OpPtr + 1);
97 Perl_Slab_Free(pTHX_ void *op)
99 I32 **ptr = (I32 **) op;
101 assert( ptr-1 > (I32 **) slab );
102 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
104 if (--(*slab) == 0) {
106 # define PerlMemShared PerlMem
109 PerlMemShared_free(slab);
110 if (slab == PL_OpSlab) {
117 * In the following definition, the ", Nullop" is just to make the compiler
118 * think the expression is of the right type: croak actually does a Siglongjmp.
120 #define CHECKOP(type,o) \
121 ((PL_op_mask && PL_op_mask[type]) \
122 ? ( op_free((OP*)o), \
123 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
125 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
127 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
130 S_gv_ename(pTHX_ GV *gv)
133 SV* tmpsv = sv_newmortal();
134 gv_efullname3(tmpsv, gv, Nullch);
135 return SvPV(tmpsv,n_a);
139 S_no_fh_allowed(pTHX_ OP *o)
141 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
147 S_too_few_arguments(pTHX_ OP *o, char *name)
149 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
154 S_too_many_arguments(pTHX_ OP *o, char *name)
156 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
161 S_bad_type(pTHX_ I32 n, char *t, char *name, OP *kid)
163 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
164 (int)n, name, t, OP_DESC(kid)));
168 S_no_bareword_allowed(pTHX_ OP *o)
170 qerror(Perl_mess(aTHX_
171 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
175 /* "register" allocation */
178 Perl_allocmy(pTHX_ char *name)
182 /* complain about "my $<special_var>" etc etc */
183 if (!(PL_in_my == KEY_our ||
185 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
186 (name[1] == '_' && (*name == '$' || (int)strlen(name) > 2))))
188 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
189 /* 1999-02-27 mjd@plover.com */
191 p = strchr(name, '\0');
192 /* The next block assumes the buffer is at least 205 chars
193 long. At present, it's always at least 256 chars. */
195 strcpy(name+200, "...");
201 /* Move everything else down one character */
202 for (; p-name > 2; p--)
204 name[2] = toCTRL(name[1]);
207 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
210 /* check for duplicate declaration */
212 (bool)(PL_in_my == KEY_our),
213 (PL_curstash ? PL_curstash : PL_defstash)
216 if (PL_in_my_stash && *name != '$') {
217 yyerror(Perl_form(aTHX_
218 "Can't declare class for non-scalar %s in \"%s\"",
219 name, PL_in_my == KEY_our ? "our" : "my"));
222 /* allocate a spare slot and store the name in that slot */
224 off = pad_add_name(name,
227 ? (PL_curstash ? PL_curstash : PL_defstash)
238 Perl_op_free(pTHX_ OP *o)
240 register OP *kid, *nextkid;
243 if (!o || o->op_static)
246 if (o->op_private & OPpREFCOUNTED) {
247 switch (o->op_type) {
255 if (OpREFCNT_dec(o)) {
266 if (o->op_flags & OPf_KIDS) {
267 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
268 nextkid = kid->op_sibling; /* Get before next freeing kid */
274 type = (OPCODE)o->op_targ;
276 /* COP* is not cleared by op_clear() so that we may track line
277 * numbers etc even after null() */
278 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
286 Perl_op_clear(pTHX_ OP *o)
289 switch (o->op_type) {
290 case OP_NULL: /* Was holding old type, if any. */
291 case OP_ENTEREVAL: /* Was holding hints. */
295 if (!(o->op_flags & OPf_REF)
296 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
302 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
303 /* not an OP_PADAV replacement */
305 if (cPADOPo->op_padix > 0) {
306 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
307 * may still exist on the pad */
308 pad_swipe(cPADOPo->op_padix, TRUE);
309 cPADOPo->op_padix = 0;
312 SvREFCNT_dec(cSVOPo->op_sv);
313 cSVOPo->op_sv = Nullsv;
317 case OP_METHOD_NAMED:
319 SvREFCNT_dec(cSVOPo->op_sv);
320 cSVOPo->op_sv = Nullsv;
323 Even if op_clear does a pad_free for the target of the op,
324 pad_free doesn't actually remove the sv that exists in the pad;
325 instead it lives on. This results in that it could be reused as
326 a target later on when the pad was reallocated.
329 pad_swipe(o->op_targ,1);
338 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
342 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
343 SvREFCNT_dec(cSVOPo->op_sv);
344 cSVOPo->op_sv = Nullsv;
347 Safefree(cPVOPo->op_pv);
348 cPVOPo->op_pv = Nullch;
352 op_free(cPMOPo->op_pmreplroot);
356 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
357 /* No GvIN_PAD_off here, because other references may still
358 * exist on the pad */
359 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
362 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
369 HV *pmstash = PmopSTASH(cPMOPo);
370 if (pmstash && SvREFCNT(pmstash)) {
371 PMOP *pmop = HvPMROOT(pmstash);
372 PMOP *lastpmop = NULL;
374 if (cPMOPo == pmop) {
376 lastpmop->op_pmnext = pmop->op_pmnext;
378 HvPMROOT(pmstash) = pmop->op_pmnext;
382 pmop = pmop->op_pmnext;
385 PmopSTASH_free(cPMOPo);
387 cPMOPo->op_pmreplroot = Nullop;
388 /* we use the "SAFE" version of the PM_ macros here
389 * since sv_clean_all might release some PMOPs
390 * after PL_regex_padav has been cleared
391 * and the clearing of PL_regex_padav needs to
392 * happen before sv_clean_all
394 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
395 PM_SETRE_SAFE(cPMOPo, (REGEXP*)NULL);
397 if(PL_regex_pad) { /* We could be in destruction */
398 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
399 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
400 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
407 if (o->op_targ > 0) {
408 pad_free(o->op_targ);
414 S_cop_free(pTHX_ COP* cop)
416 Safefree(cop->cop_label); /* FIXME: treaddead ??? */
419 if (! specialWARN(cop->cop_warnings))
420 SvREFCNT_dec(cop->cop_warnings);
421 if (! specialCopIO(cop->cop_io)) {
425 char *s = SvPV(cop->cop_io,len);
426 Perl_warn(aTHX_ "io='%.*s'",(int) len,s); /* ??? --jhi */
429 SvREFCNT_dec(cop->cop_io);
435 Perl_op_null(pTHX_ OP *o)
437 if (o->op_type == OP_NULL)
440 o->op_targ = o->op_type;
441 o->op_type = OP_NULL;
442 o->op_ppaddr = PL_ppaddr[OP_NULL];
445 /* Contextualizers */
447 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
450 Perl_linklist(pTHX_ OP *o)
457 /* establish postfix order */
458 if (cUNOPo->op_first) {
459 o->op_next = LINKLIST(cUNOPo->op_first);
460 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
462 kid->op_next = LINKLIST(kid->op_sibling);
474 Perl_scalarkids(pTHX_ OP *o)
477 if (o && o->op_flags & OPf_KIDS) {
478 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
485 S_scalarboolean(pTHX_ OP *o)
487 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
488 if (ckWARN(WARN_SYNTAX)) {
489 line_t oldline = CopLINE(PL_curcop);
491 if (PL_copline != NOLINE)
492 CopLINE_set(PL_curcop, PL_copline);
493 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
494 CopLINE_set(PL_curcop, oldline);
501 Perl_scalar(pTHX_ OP *o)
505 /* assumes no premature commitment */
506 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
507 || o->op_type == OP_RETURN)
512 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
514 switch (o->op_type) {
516 scalar(cBINOPo->op_first);
521 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
525 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
526 if (!kPMOP->op_pmreplroot)
527 deprecate_old("implicit split to @_");
535 if (o->op_flags & OPf_KIDS) {
536 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
542 kid = cLISTOPo->op_first;
544 while ((kid = kid->op_sibling)) {
550 WITH_THR(PL_curcop = &PL_compiling);
555 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
561 WITH_THR(PL_curcop = &PL_compiling);
564 if (ckWARN(WARN_VOID))
565 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
571 Perl_scalarvoid(pTHX_ OP *o)
578 if (o->op_type == OP_NEXTSTATE
579 || o->op_type == OP_SETSTATE
580 || o->op_type == OP_DBSTATE
581 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
582 || o->op_targ == OP_SETSTATE
583 || o->op_targ == OP_DBSTATE)))
584 PL_curcop = (COP*)o; /* for warning below */
586 /* assumes no premature commitment */
587 want = o->op_flags & OPf_WANT;
588 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
589 || o->op_type == OP_RETURN)
594 if ((o->op_private & OPpTARGET_MY)
595 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
597 return scalar(o); /* As if inside SASSIGN */
600 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
602 switch (o->op_type) {
604 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
608 if (o->op_flags & OPf_STACKED)
612 if (o->op_private == 4)
684 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
685 useless = OP_DESC(o);
689 kid = cUNOPo->op_first;
690 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
691 kid->op_type != OP_TRANS) {
694 useless = "negative pattern binding (!~)";
701 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
702 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
703 useless = "a variable";
708 if (cSVOPo->op_private & OPpCONST_STRICT)
709 no_bareword_allowed(o);
711 if (ckWARN(WARN_VOID)) {
712 useless = "a constant";
713 /* don't warn on optimised away booleans, eg
714 * use constant Foo, 5; Foo || print; */
715 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
717 /* the constants 0 and 1 are permitted as they are
718 conventionally used as dummies in constructs like
719 1 while some_condition_with_side_effects; */
720 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
722 else if (SvPOK(sv)) {
723 /* perl4's way of mixing documentation and code
724 (before the invention of POD) was based on a
725 trick to mix nroff and perl code. The trick was
726 built upon these three nroff macros being used in
727 void context. The pink camel has the details in
728 the script wrapman near page 319. */
729 if (strnEQ(SvPVX(sv), "di", 2) ||
730 strnEQ(SvPVX(sv), "ds", 2) ||
731 strnEQ(SvPVX(sv), "ig", 2))
736 op_null(o); /* don't execute or even remember it */
740 o->op_type = OP_PREINC; /* pre-increment is faster */
741 o->op_ppaddr = PL_ppaddr[OP_PREINC];
745 o->op_type = OP_PREDEC; /* pre-decrement is faster */
746 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
753 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
758 if (o->op_flags & OPf_STACKED)
765 if (!(o->op_flags & OPf_KIDS))
774 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
781 /* all requires must return a boolean value */
782 o->op_flags &= ~OPf_WANT;
787 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
788 if (!kPMOP->op_pmreplroot)
789 deprecate_old("implicit split to @_");
793 if (useless && ckWARN(WARN_VOID))
794 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
799 Perl_listkids(pTHX_ OP *o)
802 if (o && o->op_flags & OPf_KIDS) {
803 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
810 Perl_list(pTHX_ OP *o)
814 /* assumes no premature commitment */
815 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
816 || o->op_type == OP_RETURN)
821 if ((o->op_private & OPpTARGET_MY)
822 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
824 return o; /* As if inside SASSIGN */
827 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
829 switch (o->op_type) {
832 list(cBINOPo->op_first);
837 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
845 if (!(o->op_flags & OPf_KIDS))
847 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
848 list(cBINOPo->op_first);
849 return gen_constant_list(o);
856 kid = cLISTOPo->op_first;
858 while ((kid = kid->op_sibling)) {
864 WITH_THR(PL_curcop = &PL_compiling);
868 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
874 WITH_THR(PL_curcop = &PL_compiling);
877 /* all requires must return a boolean value */
878 o->op_flags &= ~OPf_WANT;
885 Perl_scalarseq(pTHX_ OP *o)
890 if (o->op_type == OP_LINESEQ ||
891 o->op_type == OP_SCOPE ||
892 o->op_type == OP_LEAVE ||
893 o->op_type == OP_LEAVETRY)
895 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
896 if (kid->op_sibling) {
900 PL_curcop = &PL_compiling;
902 o->op_flags &= ~OPf_PARENS;
903 if (PL_hints & HINT_BLOCK_SCOPE)
904 o->op_flags |= OPf_PARENS;
907 o = newOP(OP_STUB, 0);
912 S_modkids(pTHX_ OP *o, I32 type)
915 if (o && o->op_flags & OPf_KIDS) {
916 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
922 /* Propagate lvalue ("modifiable") context to an op and it's children.
923 * 'type' represents the context type, roughly based on the type of op that
924 * would do the modifying, although local() is represented by OP_NULL.
925 * It's responsible for detecting things that can't be modified, flag
926 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
927 * might have to vivify a reference in $x), and so on.
929 * For example, "$a+1 = 2" would cause mod() to be called with o being
930 * OP_ADD and type being OP_SASSIGN, and would output an error.
934 Perl_mod(pTHX_ OP *o, I32 type)
937 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
940 if (!o || PL_error_count)
943 if ((o->op_private & OPpTARGET_MY)
944 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
949 switch (o->op_type) {
955 if (!(o->op_private & (OPpCONST_ARYBASE)))
957 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
958 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
962 SAVEI32(PL_compiling.cop_arybase);
963 PL_compiling.cop_arybase = 0;
965 else if (type == OP_REFGEN)
968 Perl_croak(aTHX_ "That use of $[ is unsupported");
971 if (o->op_flags & OPf_PARENS)
975 if ((type == OP_UNDEF || type == OP_REFGEN) &&
976 !(o->op_flags & OPf_STACKED)) {
977 o->op_type = OP_RV2CV; /* entersub => rv2cv */
978 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
979 assert(cUNOPo->op_first->op_type == OP_NULL);
980 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
983 else if (o->op_private & OPpENTERSUB_NOMOD)
985 else { /* lvalue subroutine call */
986 o->op_private |= OPpLVAL_INTRO;
987 PL_modcount = RETURN_UNLIMITED_NUMBER;
988 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
989 /* Backward compatibility mode: */
990 o->op_private |= OPpENTERSUB_INARGS;
993 else { /* Compile-time error message: */
994 OP *kid = cUNOPo->op_first;
998 if (kid->op_type == OP_PUSHMARK)
1000 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1002 "panic: unexpected lvalue entersub "
1003 "args: type/targ %ld:%"UVuf,
1004 (long)kid->op_type, (UV)kid->op_targ);
1005 kid = kLISTOP->op_first;
1007 while (kid->op_sibling)
1008 kid = kid->op_sibling;
1009 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1011 if (kid->op_type == OP_METHOD_NAMED
1012 || kid->op_type == OP_METHOD)
1016 NewOp(1101, newop, 1, UNOP);
1017 newop->op_type = OP_RV2CV;
1018 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1019 newop->op_first = Nullop;
1020 newop->op_next = (OP*)newop;
1021 kid->op_sibling = (OP*)newop;
1022 newop->op_private |= OPpLVAL_INTRO;
1026 if (kid->op_type != OP_RV2CV)
1028 "panic: unexpected lvalue entersub "
1029 "entry via type/targ %ld:%"UVuf,
1030 (long)kid->op_type, (UV)kid->op_targ);
1031 kid->op_private |= OPpLVAL_INTRO;
1032 break; /* Postpone until runtime */
1036 kid = kUNOP->op_first;
1037 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1038 kid = kUNOP->op_first;
1039 if (kid->op_type == OP_NULL)
1041 "Unexpected constant lvalue entersub "
1042 "entry via type/targ %ld:%"UVuf,
1043 (long)kid->op_type, (UV)kid->op_targ);
1044 if (kid->op_type != OP_GV) {
1045 /* Restore RV2CV to check lvalueness */
1047 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1048 okid->op_next = kid->op_next;
1049 kid->op_next = okid;
1052 okid->op_next = Nullop;
1053 okid->op_type = OP_RV2CV;
1055 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1056 okid->op_private |= OPpLVAL_INTRO;
1060 cv = GvCV(kGVOP_gv);
1070 /* grep, foreach, subcalls, refgen */
1071 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1073 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1074 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1076 : (o->op_type == OP_ENTERSUB
1077 ? "non-lvalue subroutine call"
1079 type ? PL_op_desc[type] : "local"));
1093 case OP_RIGHT_SHIFT:
1102 if (!(o->op_flags & OPf_STACKED))
1109 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1115 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1116 PL_modcount = RETURN_UNLIMITED_NUMBER;
1117 return o; /* Treat \(@foo) like ordinary list. */
1121 if (scalar_mod_type(o, type))
1123 ref(cUNOPo->op_first, o->op_type);
1127 if (type == OP_LEAVESUBLV)
1128 o->op_private |= OPpMAYBE_LVSUB;
1134 PL_modcount = RETURN_UNLIMITED_NUMBER;
1137 ref(cUNOPo->op_first, o->op_type);
1142 PL_hints |= HINT_BLOCK_SCOPE;
1157 PL_modcount = RETURN_UNLIMITED_NUMBER;
1158 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1159 return o; /* Treat \(@foo) like ordinary list. */
1160 if (scalar_mod_type(o, type))
1162 if (type == OP_LEAVESUBLV)
1163 o->op_private |= OPpMAYBE_LVSUB;
1167 if (!type) /* local() */
1168 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1169 PAD_COMPNAME_PV(o->op_targ));
1177 if (type != OP_SASSIGN)
1181 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1186 if (type == OP_LEAVESUBLV)
1187 o->op_private |= OPpMAYBE_LVSUB;
1189 pad_free(o->op_targ);
1190 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1191 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1192 if (o->op_flags & OPf_KIDS)
1193 mod(cBINOPo->op_first->op_sibling, type);
1198 ref(cBINOPo->op_first, o->op_type);
1199 if (type == OP_ENTERSUB &&
1200 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1201 o->op_private |= OPpLVAL_DEFER;
1202 if (type == OP_LEAVESUBLV)
1203 o->op_private |= OPpMAYBE_LVSUB;
1213 if (o->op_flags & OPf_KIDS)
1214 mod(cLISTOPo->op_last, type);
1219 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1221 else if (!(o->op_flags & OPf_KIDS))
1223 if (o->op_targ != OP_LIST) {
1224 mod(cBINOPo->op_first, type);
1230 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1235 if (type != OP_LEAVESUBLV)
1237 break; /* mod()ing was handled by ck_return() */
1240 /* [20011101.069] File test operators interpret OPf_REF to mean that
1241 their argument is a filehandle; thus \stat(".") should not set
1243 if (type == OP_REFGEN &&
1244 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1247 if (type != OP_LEAVESUBLV)
1248 o->op_flags |= OPf_MOD;
1250 if (type == OP_AASSIGN || type == OP_SASSIGN)
1251 o->op_flags |= OPf_SPECIAL|OPf_REF;
1252 else if (!type) { /* local() */
1255 o->op_private |= OPpLVAL_INTRO;
1256 o->op_flags &= ~OPf_SPECIAL;
1257 PL_hints |= HINT_BLOCK_SCOPE;
1262 if (ckWARN(WARN_SYNTAX)) {
1263 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1264 "Useless localization of %s", OP_DESC(o));
1268 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1269 && type != OP_LEAVESUBLV)
1270 o->op_flags |= OPf_REF;
1275 S_scalar_mod_type(pTHX_ OP *o, I32 type)
1279 if (o->op_type == OP_RV2GV)
1303 case OP_RIGHT_SHIFT:
1322 S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
1324 switch (o->op_type) {
1332 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1345 Perl_refkids(pTHX_ OP *o, I32 type)
1348 if (o && o->op_flags & OPf_KIDS) {
1349 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1356 Perl_ref(pTHX_ OP *o, I32 type)
1360 if (!o || PL_error_count)
1363 switch (o->op_type) {
1365 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1366 !(o->op_flags & OPf_STACKED)) {
1367 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1368 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1369 assert(cUNOPo->op_first->op_type == OP_NULL);
1370 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1371 o->op_flags |= OPf_SPECIAL;
1376 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1380 if (type == OP_DEFINED)
1381 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1382 ref(cUNOPo->op_first, o->op_type);
1385 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1386 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1387 : type == OP_RV2HV ? OPpDEREF_HV
1389 o->op_flags |= OPf_MOD;
1394 o->op_flags |= OPf_MOD; /* XXX ??? */
1399 o->op_flags |= OPf_REF;
1402 if (type == OP_DEFINED)
1403 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1404 ref(cUNOPo->op_first, o->op_type);
1409 o->op_flags |= OPf_REF;
1414 if (!(o->op_flags & OPf_KIDS))
1416 ref(cBINOPo->op_first, type);
1420 ref(cBINOPo->op_first, o->op_type);
1421 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1422 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1423 : type == OP_RV2HV ? OPpDEREF_HV
1425 o->op_flags |= OPf_MOD;
1433 if (!(o->op_flags & OPf_KIDS))
1435 ref(cLISTOPo->op_last, type);
1445 S_dup_attrlist(pTHX_ OP *o)
1449 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1450 * where the first kid is OP_PUSHMARK and the remaining ones
1451 * are OP_CONST. We need to push the OP_CONST values.
1453 if (o->op_type == OP_CONST)
1454 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1456 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1457 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1458 if (o->op_type == OP_CONST)
1459 rop = append_elem(OP_LIST, rop,
1460 newSVOP(OP_CONST, o->op_flags,
1461 SvREFCNT_inc(cSVOPo->op_sv)));
1468 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1472 /* fake up C<use attributes $pkg,$rv,@attrs> */
1473 ENTER; /* need to protect against side-effects of 'use' */
1476 stashsv = newSVpv(HvNAME(stash), 0);
1478 stashsv = &PL_sv_no;
1480 #define ATTRSMODULE "attributes"
1481 #define ATTRSMODULE_PM "attributes.pm"
1485 /* Don't force the C<use> if we don't need it. */
1486 svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
1487 sizeof(ATTRSMODULE_PM)-1, 0);
1488 if (svp && *svp != &PL_sv_undef)
1489 ; /* already in %INC */
1491 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1492 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1496 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1497 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1499 prepend_elem(OP_LIST,
1500 newSVOP(OP_CONST, 0, stashsv),
1501 prepend_elem(OP_LIST,
1502 newSVOP(OP_CONST, 0,
1504 dup_attrlist(attrs))));
1510 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1512 OP *pack, *imop, *arg;
1518 assert(target->op_type == OP_PADSV ||
1519 target->op_type == OP_PADHV ||
1520 target->op_type == OP_PADAV);
1522 /* Ensure that attributes.pm is loaded. */
1523 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1525 /* Need package name for method call. */
1526 pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
1528 /* Build up the real arg-list. */
1530 stashsv = newSVpv(HvNAME(stash), 0);
1532 stashsv = &PL_sv_no;
1533 arg = newOP(OP_PADSV, 0);
1534 arg->op_targ = target->op_targ;
1535 arg = prepend_elem(OP_LIST,
1536 newSVOP(OP_CONST, 0, stashsv),
1537 prepend_elem(OP_LIST,
1538 newUNOP(OP_REFGEN, 0,
1539 mod(arg, OP_REFGEN)),
1540 dup_attrlist(attrs)));
1542 /* Fake up a method call to import */
1543 meth = newSVpvn("import", 6);
1544 (void)SvUPGRADE(meth, SVt_PVIV);
1545 (void)SvIOK_on(meth);
1546 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
1547 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1548 append_elem(OP_LIST,
1549 prepend_elem(OP_LIST, pack, list(arg)),
1550 newSVOP(OP_METHOD_NAMED, 0, meth)));
1551 imop->op_private |= OPpENTERSUB_NOMOD;
1553 /* Combine the ops. */
1554 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1558 =notfor apidoc apply_attrs_string
1560 Attempts to apply a list of attributes specified by the C<attrstr> and
1561 C<len> arguments to the subroutine identified by the C<cv> argument which
1562 is expected to be associated with the package identified by the C<stashpv>
1563 argument (see L<attributes>). It gets this wrong, though, in that it
1564 does not correctly identify the boundaries of the individual attribute
1565 specifications within C<attrstr>. This is not really intended for the
1566 public API, but has to be listed here for systems such as AIX which
1567 need an explicit export list for symbols. (It's called from XS code
1568 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1569 to respect attribute syntax properly would be welcome.
1575 Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
1576 char *attrstr, STRLEN len)
1581 len = strlen(attrstr);
1585 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1587 char *sstr = attrstr;
1588 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1589 attrs = append_elem(OP_LIST, attrs,
1590 newSVOP(OP_CONST, 0,
1591 newSVpvn(sstr, attrstr-sstr)));
1595 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1596 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1597 Nullsv, prepend_elem(OP_LIST,
1598 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1599 prepend_elem(OP_LIST,
1600 newSVOP(OP_CONST, 0,
1606 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1611 if (!o || PL_error_count)
1615 if (type == OP_LIST) {
1616 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1617 my_kid(kid, attrs, imopsp);
1618 } else if (type == OP_UNDEF) {
1620 } else if (type == OP_RV2SV || /* "our" declaration */
1622 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1623 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1624 yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
1625 OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
1627 GV *gv = cGVOPx_gv(cUNOPo->op_first);
1629 PL_in_my_stash = Nullhv;
1630 apply_attrs(GvSTASH(gv),
1631 (type == OP_RV2SV ? GvSV(gv) :
1632 type == OP_RV2AV ? (SV*)GvAV(gv) :
1633 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1636 o->op_private |= OPpOUR_INTRO;
1639 else if (type != OP_PADSV &&
1642 type != OP_PUSHMARK)
1644 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1646 PL_in_my == KEY_our ? "our" : "my"));
1649 else if (attrs && type != OP_PUSHMARK) {
1653 PL_in_my_stash = Nullhv;
1655 /* check for C<my Dog $spot> when deciding package */
1656 stash = PAD_COMPNAME_TYPE(o->op_targ);
1658 stash = PL_curstash;
1659 apply_attrs_my(stash, o, attrs, imopsp);
1661 o->op_flags |= OPf_MOD;
1662 o->op_private |= OPpLVAL_INTRO;
1667 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1670 int maybe_scalar = 0;
1672 /* [perl #17376]: this appears to be premature, and results in code such as
1673 C< our(%x); > executing in list mode rather than void mode */
1675 if (o->op_flags & OPf_PARENS)
1684 o = my_kid(o, attrs, &rops);
1686 if (maybe_scalar && o->op_type == OP_PADSV) {
1687 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1688 o->op_private |= OPpLVAL_INTRO;
1691 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1694 PL_in_my_stash = Nullhv;
1699 Perl_my(pTHX_ OP *o)
1701 return my_attrs(o, Nullop);
1705 Perl_sawparens(pTHX_ OP *o)
1708 o->op_flags |= OPf_PARENS;
1713 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1718 if (ckWARN(WARN_MISC) &&
1719 (left->op_type == OP_RV2AV ||
1720 left->op_type == OP_RV2HV ||
1721 left->op_type == OP_PADAV ||
1722 left->op_type == OP_PADHV)) {
1723 char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
1724 right->op_type == OP_TRANS)
1725 ? right->op_type : OP_MATCH];
1726 const char *sample = ((left->op_type == OP_RV2AV ||
1727 left->op_type == OP_PADAV)
1728 ? "@array" : "%hash");
1729 Perl_warner(aTHX_ packWARN(WARN_MISC),
1730 "Applying %s to %s will act on scalar(%s)",
1731 desc, sample, sample);
1734 if (right->op_type == OP_CONST &&
1735 cSVOPx(right)->op_private & OPpCONST_BARE &&
1736 cSVOPx(right)->op_private & OPpCONST_STRICT)
1738 no_bareword_allowed(right);
1741 ismatchop = right->op_type == OP_MATCH ||
1742 right->op_type == OP_SUBST ||
1743 right->op_type == OP_TRANS;
1744 if (ismatchop && right->op_private & OPpTARGET_MY) {
1746 right->op_private &= ~OPpTARGET_MY;
1748 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1749 right->op_flags |= OPf_STACKED;
1750 if (right->op_type != OP_MATCH &&
1751 ! (right->op_type == OP_TRANS &&
1752 right->op_private & OPpTRANS_IDENTICAL))
1753 left = mod(left, right->op_type);
1754 if (right->op_type == OP_TRANS)
1755 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
1757 o = prepend_elem(right->op_type, scalar(left), right);
1759 return newUNOP(OP_NOT, 0, scalar(o));
1763 return bind_match(type, left,
1764 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
1768 Perl_invert(pTHX_ OP *o)
1772 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
1773 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1777 Perl_scope(pTHX_ OP *o)
1780 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1781 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1782 o->op_type = OP_LEAVE;
1783 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1785 else if (o->op_type == OP_LINESEQ) {
1787 o->op_type = OP_SCOPE;
1788 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1789 kid = ((LISTOP*)o)->op_first;
1790 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
1794 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
1799 /* XXX kept for BINCOMPAT only */
1801 Perl_save_hints(pTHX)
1803 Perl_croak(aTHX_ "internal error: obsolete function save_hints() called");
1807 Perl_block_start(pTHX_ int full)
1809 int retval = PL_savestack_ix;
1810 pad_block_start(full);
1812 PL_hints &= ~HINT_BLOCK_SCOPE;
1813 SAVESPTR(PL_compiling.cop_warnings);
1814 if (! specialWARN(PL_compiling.cop_warnings)) {
1815 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1816 SAVEFREESV(PL_compiling.cop_warnings) ;
1818 SAVESPTR(PL_compiling.cop_io);
1819 if (! specialCopIO(PL_compiling.cop_io)) {
1820 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1821 SAVEFREESV(PL_compiling.cop_io) ;
1827 Perl_block_end(pTHX_ I32 floor, OP *seq)
1829 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1830 OP* retval = scalarseq(seq);
1832 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
1834 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
1842 I32 offset = pad_findmy("$_");
1843 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
1844 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1847 OP *o = newOP(OP_PADSV, 0);
1848 o->op_targ = offset;
1854 Perl_newPROG(pTHX_ OP *o)
1859 PL_eval_root = newUNOP(OP_LEAVEEVAL,
1860 ((PL_in_eval & EVAL_KEEPERR)
1861 ? OPf_SPECIAL : 0), o);
1862 PL_eval_start = linklist(PL_eval_root);
1863 PL_eval_root->op_private |= OPpREFCOUNTED;
1864 OpREFCNT_set(PL_eval_root, 1);
1865 PL_eval_root->op_next = 0;
1866 CALL_PEEP(PL_eval_start);
1869 if (o->op_type == OP_STUB) {
1870 PL_comppad_name = 0;
1875 PL_main_root = scope(sawparens(scalarvoid(o)));
1876 PL_curcop = &PL_compiling;
1877 PL_main_start = LINKLIST(PL_main_root);
1878 PL_main_root->op_private |= OPpREFCOUNTED;
1879 OpREFCNT_set(PL_main_root, 1);
1880 PL_main_root->op_next = 0;
1881 CALL_PEEP(PL_main_start);
1884 /* Register with debugger */
1886 CV *cv = get_cv("DB::postponed", FALSE);
1890 XPUSHs((SV*)CopFILEGV(&PL_compiling));
1892 call_sv((SV*)cv, G_DISCARD);
1899 Perl_localize(pTHX_ OP *o, I32 lex)
1901 if (o->op_flags & OPf_PARENS)
1902 /* [perl #17376]: this appears to be premature, and results in code such as
1903 C< our(%x); > executing in list mode rather than void mode */
1910 if (ckWARN(WARN_PARENTHESIS)
1911 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
1913 char *s = PL_bufptr;
1916 /* some heuristics to detect a potential error */
1917 while (*s && (strchr(", \t\n", *s)))
1921 if (*s && strchr("@$%*", *s) && *++s
1922 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
1925 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
1927 while (*s && (strchr(", \t\n", *s)))
1933 if (sigil && (*s == ';' || *s == '=')) {
1934 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
1935 "Parentheses missing around \"%s\" list",
1936 lex ? (PL_in_my == KEY_our ? "our" : "my")
1944 o = mod(o, OP_NULL); /* a bit kludgey */
1946 PL_in_my_stash = Nullhv;
1951 Perl_jmaybe(pTHX_ OP *o)
1953 if (o->op_type == OP_LIST) {
1955 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
1956 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
1962 Perl_fold_constants(pTHX_ register OP *o)
1965 I32 type = o->op_type;
1968 if (PL_opargs[type] & OA_RETSCALAR)
1970 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
1971 o->op_targ = pad_alloc(type, SVs_PADTMP);
1973 /* integerize op, unless it happens to be C<-foo>.
1974 * XXX should pp_i_negate() do magic string negation instead? */
1975 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
1976 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
1977 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
1979 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
1982 if (!(PL_opargs[type] & OA_FOLDCONST))
1987 /* XXX might want a ck_negate() for this */
1988 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2000 /* XXX what about the numeric ops? */
2001 if (PL_hints & HINT_LOCALE)
2006 goto nope; /* Don't try to run w/ errors */
2008 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2009 if ((curop->op_type != OP_CONST ||
2010 (curop->op_private & OPpCONST_BARE)) &&
2011 curop->op_type != OP_LIST &&
2012 curop->op_type != OP_SCALAR &&
2013 curop->op_type != OP_NULL &&
2014 curop->op_type != OP_PUSHMARK)
2020 curop = LINKLIST(o);
2024 sv = *(PL_stack_sp--);
2025 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2026 pad_swipe(o->op_targ, FALSE);
2027 else if (SvTEMP(sv)) { /* grab mortal temp? */
2028 (void)SvREFCNT_inc(sv);
2032 if (type == OP_RV2GV)
2033 return newGVOP(OP_GV, 0, (GV*)sv);
2034 return newSVOP(OP_CONST, 0, sv);
2041 Perl_gen_constant_list(pTHX_ register OP *o)
2044 I32 oldtmps_floor = PL_tmps_floor;
2048 return o; /* Don't attempt to run with errors */
2050 PL_op = curop = LINKLIST(o);
2057 PL_tmps_floor = oldtmps_floor;
2059 o->op_type = OP_RV2AV;
2060 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2061 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2062 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2063 o->op_opt = 0; /* needs to be revisited in peep() */
2064 curop = ((UNOP*)o)->op_first;
2065 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2072 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2074 if (!o || o->op_type != OP_LIST)
2075 o = newLISTOP(OP_LIST, 0, o, Nullop);
2077 o->op_flags &= ~OPf_WANT;
2079 if (!(PL_opargs[type] & OA_MARK))
2080 op_null(cLISTOPo->op_first);
2082 o->op_type = (OPCODE)type;
2083 o->op_ppaddr = PL_ppaddr[type];
2084 o->op_flags |= flags;
2086 o = CHECKOP(type, o);
2087 if (o->op_type != type)
2090 return fold_constants(o);
2093 /* List constructors */
2096 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2104 if (first->op_type != type
2105 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2107 return newLISTOP(type, 0, first, last);
2110 if (first->op_flags & OPf_KIDS)
2111 ((LISTOP*)first)->op_last->op_sibling = last;
2113 first->op_flags |= OPf_KIDS;
2114 ((LISTOP*)first)->op_first = last;
2116 ((LISTOP*)first)->op_last = last;
2121 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2129 if (first->op_type != type)
2130 return prepend_elem(type, (OP*)first, (OP*)last);
2132 if (last->op_type != type)
2133 return append_elem(type, (OP*)first, (OP*)last);
2135 first->op_last->op_sibling = last->op_first;
2136 first->op_last = last->op_last;
2137 first->op_flags |= (last->op_flags & OPf_KIDS);
2145 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2153 if (last->op_type == type) {
2154 if (type == OP_LIST) { /* already a PUSHMARK there */
2155 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2156 ((LISTOP*)last)->op_first->op_sibling = first;
2157 if (!(first->op_flags & OPf_PARENS))
2158 last->op_flags &= ~OPf_PARENS;
2161 if (!(last->op_flags & OPf_KIDS)) {
2162 ((LISTOP*)last)->op_last = first;
2163 last->op_flags |= OPf_KIDS;
2165 first->op_sibling = ((LISTOP*)last)->op_first;
2166 ((LISTOP*)last)->op_first = first;
2168 last->op_flags |= OPf_KIDS;
2172 return newLISTOP(type, 0, first, last);
2178 Perl_newNULLLIST(pTHX)
2180 return newOP(OP_STUB, 0);
2184 Perl_force_list(pTHX_ OP *o)
2186 if (!o || o->op_type != OP_LIST)
2187 o = newLISTOP(OP_LIST, 0, o, Nullop);
2193 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2197 NewOp(1101, listop, 1, LISTOP);
2199 listop->op_type = (OPCODE)type;
2200 listop->op_ppaddr = PL_ppaddr[type];
2203 listop->op_flags = (U8)flags;
2207 else if (!first && last)
2210 first->op_sibling = last;
2211 listop->op_first = first;
2212 listop->op_last = last;
2213 if (type == OP_LIST) {
2215 pushop = newOP(OP_PUSHMARK, 0);
2216 pushop->op_sibling = first;
2217 listop->op_first = pushop;
2218 listop->op_flags |= OPf_KIDS;
2220 listop->op_last = pushop;
2223 return CHECKOP(type, listop);
2227 Perl_newOP(pTHX_ I32 type, I32 flags)
2230 NewOp(1101, o, 1, OP);
2231 o->op_type = (OPCODE)type;
2232 o->op_ppaddr = PL_ppaddr[type];
2233 o->op_flags = (U8)flags;
2236 o->op_private = (U8)(0 | (flags >> 8));
2237 if (PL_opargs[type] & OA_RETSCALAR)
2239 if (PL_opargs[type] & OA_TARGET)
2240 o->op_targ = pad_alloc(type, SVs_PADTMP);
2241 return CHECKOP(type, o);
2245 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2250 first = newOP(OP_STUB, 0);
2251 if (PL_opargs[type] & OA_MARK)
2252 first = force_list(first);
2254 NewOp(1101, unop, 1, UNOP);
2255 unop->op_type = (OPCODE)type;
2256 unop->op_ppaddr = PL_ppaddr[type];
2257 unop->op_first = first;
2258 unop->op_flags = flags | OPf_KIDS;
2259 unop->op_private = (U8)(1 | (flags >> 8));
2260 unop = (UNOP*) CHECKOP(type, unop);
2264 return fold_constants((OP *) unop);
2268 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2271 NewOp(1101, binop, 1, BINOP);
2274 first = newOP(OP_NULL, 0);
2276 binop->op_type = (OPCODE)type;
2277 binop->op_ppaddr = PL_ppaddr[type];
2278 binop->op_first = first;
2279 binop->op_flags = flags | OPf_KIDS;
2282 binop->op_private = (U8)(1 | (flags >> 8));
2285 binop->op_private = (U8)(2 | (flags >> 8));
2286 first->op_sibling = last;
2289 binop = (BINOP*)CHECKOP(type, binop);
2290 if (binop->op_next || binop->op_type != (OPCODE)type)
2293 binop->op_last = binop->op_first->op_sibling;
2295 return fold_constants((OP *)binop);
2299 uvcompare(const void *a, const void *b)
2301 if (*((UV *)a) < (*(UV *)b))
2303 if (*((UV *)a) > (*(UV *)b))
2305 if (*((UV *)a+1) < (*(UV *)b+1))
2307 if (*((UV *)a+1) > (*(UV *)b+1))
2313 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2315 SV *tstr = ((SVOP*)expr)->op_sv;
2316 SV *rstr = ((SVOP*)repl)->op_sv;
2319 U8 *t = (U8*)SvPV(tstr, tlen);
2320 U8 *r = (U8*)SvPV(rstr, rlen);
2327 register short *tbl;
2329 PL_hints |= HINT_BLOCK_SCOPE;
2330 complement = o->op_private & OPpTRANS_COMPLEMENT;
2331 del = o->op_private & OPpTRANS_DELETE;
2332 squash = o->op_private & OPpTRANS_SQUASH;
2335 o->op_private |= OPpTRANS_FROM_UTF;
2338 o->op_private |= OPpTRANS_TO_UTF;
2340 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2341 SV* listsv = newSVpvn("# comment\n",10);
2343 U8* tend = t + tlen;
2344 U8* rend = r + rlen;
2358 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2359 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2365 tsave = t = bytes_to_utf8(t, &len);
2368 if (!to_utf && rlen) {
2370 rsave = r = bytes_to_utf8(r, &len);
2374 /* There are several snags with this code on EBCDIC:
2375 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2376 2. scan_const() in toke.c has encoded chars in native encoding which makes
2377 ranges at least in EBCDIC 0..255 range the bottom odd.
2381 U8 tmpbuf[UTF8_MAXLEN+1];
2384 New(1109, cp, 2*tlen, UV);
2386 transv = newSVpvn("",0);
2388 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2390 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2392 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2396 cp[2*i+1] = cp[2*i];
2400 qsort(cp, i, 2*sizeof(UV), uvcompare);
2401 for (j = 0; j < i; j++) {
2403 diff = val - nextmin;
2405 t = uvuni_to_utf8(tmpbuf,nextmin);
2406 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2408 U8 range_mark = UTF_TO_NATIVE(0xff);
2409 t = uvuni_to_utf8(tmpbuf, val - 1);
2410 sv_catpvn(transv, (char *)&range_mark, 1);
2411 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2418 t = uvuni_to_utf8(tmpbuf,nextmin);
2419 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2421 U8 range_mark = UTF_TO_NATIVE(0xff);
2422 sv_catpvn(transv, (char *)&range_mark, 1);
2424 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2425 UNICODE_ALLOW_SUPER);
2426 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2427 t = (U8*)SvPVX(transv);
2428 tlen = SvCUR(transv);
2432 else if (!rlen && !del) {
2433 r = t; rlen = tlen; rend = tend;
2436 if ((!rlen && !del) || t == r ||
2437 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2439 o->op_private |= OPpTRANS_IDENTICAL;
2443 while (t < tend || tfirst <= tlast) {
2444 /* see if we need more "t" chars */
2445 if (tfirst > tlast) {
2446 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2448 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2450 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2457 /* now see if we need more "r" chars */
2458 if (rfirst > rlast) {
2460 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2462 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2464 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2473 rfirst = rlast = 0xffffffff;
2477 /* now see which range will peter our first, if either. */
2478 tdiff = tlast - tfirst;
2479 rdiff = rlast - rfirst;
2486 if (rfirst == 0xffffffff) {
2487 diff = tdiff; /* oops, pretend rdiff is infinite */
2489 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2490 (long)tfirst, (long)tlast);
2492 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2496 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2497 (long)tfirst, (long)(tfirst + diff),
2500 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2501 (long)tfirst, (long)rfirst);
2503 if (rfirst + diff > max)
2504 max = rfirst + diff;
2506 grows = (tfirst < rfirst &&
2507 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2519 else if (max > 0xff)
2524 Safefree(cPVOPo->op_pv);
2525 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2526 SvREFCNT_dec(listsv);
2528 SvREFCNT_dec(transv);
2530 if (!del && havefinal && rlen)
2531 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2532 newSVuv((UV)final), 0);
2535 o->op_private |= OPpTRANS_GROWS;
2547 tbl = (short*)cPVOPo->op_pv;
2549 Zero(tbl, 256, short);
2550 for (i = 0; i < (I32)tlen; i++)
2552 for (i = 0, j = 0; i < 256; i++) {
2554 if (j >= (I32)rlen) {
2563 if (i < 128 && r[j] >= 128)
2573 o->op_private |= OPpTRANS_IDENTICAL;
2575 else if (j >= (I32)rlen)
2578 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2579 tbl[0x100] = rlen - j;
2580 for (i=0; i < (I32)rlen - j; i++)
2581 tbl[0x101+i] = r[j+i];
2585 if (!rlen && !del) {
2588 o->op_private |= OPpTRANS_IDENTICAL;
2590 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2591 o->op_private |= OPpTRANS_IDENTICAL;
2593 for (i = 0; i < 256; i++)
2595 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
2596 if (j >= (I32)rlen) {
2598 if (tbl[t[i]] == -1)
2604 if (tbl[t[i]] == -1) {
2605 if (t[i] < 128 && r[j] >= 128)
2612 o->op_private |= OPpTRANS_GROWS;
2620 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2624 NewOp(1101, pmop, 1, PMOP);
2625 pmop->op_type = (OPCODE)type;
2626 pmop->op_ppaddr = PL_ppaddr[type];
2627 pmop->op_flags = (U8)flags;
2628 pmop->op_private = (U8)(0 | (flags >> 8));
2630 if (PL_hints & HINT_RE_TAINT)
2631 pmop->op_pmpermflags |= PMf_RETAINT;
2632 if (PL_hints & HINT_LOCALE)
2633 pmop->op_pmpermflags |= PMf_LOCALE;
2634 pmop->op_pmflags = pmop->op_pmpermflags;
2639 if(av_len((AV*) PL_regex_pad[0]) > -1) {
2640 repointer = av_pop((AV*)PL_regex_pad[0]);
2641 pmop->op_pmoffset = SvIV(repointer);
2642 SvREPADTMP_off(repointer);
2643 sv_setiv(repointer,0);
2645 repointer = newSViv(0);
2646 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2647 pmop->op_pmoffset = av_len(PL_regex_padav);
2648 PL_regex_pad = AvARRAY(PL_regex_padav);
2653 /* link into pm list */
2654 if (type != OP_TRANS && PL_curstash) {
2655 pmop->op_pmnext = HvPMROOT(PL_curstash);
2656 HvPMROOT(PL_curstash) = pmop;
2657 PmopSTASH_set(pmop,PL_curstash);
2660 return CHECKOP(type, pmop);
2663 /* Given some sort of match op o, and an expression expr containing a
2664 * pattern, either compile expr into a regex and attach it to o (if it's
2665 * constant), or convert expr into a runtime regcomp op sequence (if it's
2668 * isreg indicates that the pattern is part of a regex construct, eg
2669 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
2670 * split "pattern", which aren't. In the former case, expr will be a list
2671 * if the pattern contains more than one term (eg /a$b/) or if it contains
2672 * a replacement, ie s/// or tr///.
2676 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
2680 I32 repl_has_vars = 0;
2684 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
2685 /* last element in list is the replacement; pop it */
2687 repl = cLISTOPx(expr)->op_last;
2688 kid = cLISTOPx(expr)->op_first;
2689 while (kid->op_sibling != repl)
2690 kid = kid->op_sibling;
2691 kid->op_sibling = Nullop;
2692 cLISTOPx(expr)->op_last = kid;
2695 if (isreg && expr->op_type == OP_LIST &&
2696 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
2698 /* convert single element list to element */
2700 expr = cLISTOPx(oe)->op_first->op_sibling;
2701 cLISTOPx(oe)->op_first->op_sibling = Nullop;
2702 cLISTOPx(oe)->op_last = Nullop;
2706 if (o->op_type == OP_TRANS) {
2707 return pmtrans(o, expr, repl);
2710 reglist = isreg && expr->op_type == OP_LIST;
2714 PL_hints |= HINT_BLOCK_SCOPE;
2717 if (expr->op_type == OP_CONST) {
2719 SV *pat = ((SVOP*)expr)->op_sv;
2720 char *p = SvPV(pat, plen);
2721 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
2722 sv_setpvn(pat, "\\s+", 3);
2723 p = SvPV(pat, plen);
2724 pm->op_pmflags |= PMf_SKIPWHITE;
2727 pm->op_pmdynflags |= PMdf_UTF8;
2728 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
2729 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
2730 pm->op_pmflags |= PMf_WHITE;
2734 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2735 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2737 : OP_REGCMAYBE),0,expr);
2739 NewOp(1101, rcop, 1, LOGOP);
2740 rcop->op_type = OP_REGCOMP;
2741 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2742 rcop->op_first = scalar(expr);
2743 rcop->op_flags |= OPf_KIDS
2744 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
2745 | (reglist ? OPf_STACKED : 0);
2746 rcop->op_private = 1;
2749 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
2751 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
2754 /* establish postfix order */
2755 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2757 rcop->op_next = expr;
2758 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2761 rcop->op_next = LINKLIST(expr);
2762 expr->op_next = (OP*)rcop;
2765 prepend_elem(o->op_type, scalar((OP*)rcop), o);
2770 if (pm->op_pmflags & PMf_EVAL) {
2772 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
2773 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
2775 else if (repl->op_type == OP_CONST)
2779 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
2780 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
2781 if (curop->op_type == OP_GV) {
2782 GV *gv = cGVOPx_gv(curop);
2784 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
2787 else if (curop->op_type == OP_RV2CV)
2789 else if (curop->op_type == OP_RV2SV ||
2790 curop->op_type == OP_RV2AV ||
2791 curop->op_type == OP_RV2HV ||
2792 curop->op_type == OP_RV2GV) {
2793 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2796 else if (curop->op_type == OP_PADSV ||
2797 curop->op_type == OP_PADAV ||
2798 curop->op_type == OP_PADHV ||
2799 curop->op_type == OP_PADANY) {
2802 else if (curop->op_type == OP_PUSHRE)
2803 ; /* Okay here, dangerous in newASSIGNOP */
2813 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
2814 pm->op_pmflags |= PMf_CONST; /* const for long enough */
2815 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
2816 prepend_elem(o->op_type, scalar(repl), o);
2819 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
2820 pm->op_pmflags |= PMf_MAYBE_CONST;
2821 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2823 NewOp(1101, rcop, 1, LOGOP);
2824 rcop->op_type = OP_SUBSTCONT;
2825 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
2826 rcop->op_first = scalar(repl);
2827 rcop->op_flags |= OPf_KIDS;
2828 rcop->op_private = 1;
2831 /* establish postfix order */
2832 rcop->op_next = LINKLIST(repl);
2833 repl->op_next = (OP*)rcop;
2835 pm->op_pmreplroot = scalar((OP*)rcop);
2836 pm->op_pmreplstart = LINKLIST(rcop);
2845 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
2848 NewOp(1101, svop, 1, SVOP);
2849 svop->op_type = (OPCODE)type;
2850 svop->op_ppaddr = PL_ppaddr[type];
2852 svop->op_next = (OP*)svop;
2853 svop->op_flags = (U8)flags;
2854 if (PL_opargs[type] & OA_RETSCALAR)
2856 if (PL_opargs[type] & OA_TARGET)
2857 svop->op_targ = pad_alloc(type, SVs_PADTMP);
2858 return CHECKOP(type, svop);
2862 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2865 NewOp(1101, padop, 1, PADOP);
2866 padop->op_type = (OPCODE)type;
2867 padop->op_ppaddr = PL_ppaddr[type];
2868 padop->op_padix = pad_alloc(type, SVs_PADTMP);
2869 SvREFCNT_dec(PAD_SVl(padop->op_padix));
2870 PAD_SETSV(padop->op_padix, sv);
2873 padop->op_next = (OP*)padop;
2874 padop->op_flags = (U8)flags;
2875 if (PL_opargs[type] & OA_RETSCALAR)
2877 if (PL_opargs[type] & OA_TARGET)
2878 padop->op_targ = pad_alloc(type, SVs_PADTMP);
2879 return CHECKOP(type, padop);
2883 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
2888 return newPADOP(type, flags, SvREFCNT_inc(gv));
2890 return newSVOP(type, flags, SvREFCNT_inc(gv));
2895 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
2898 NewOp(1101, pvop, 1, PVOP);
2899 pvop->op_type = (OPCODE)type;
2900 pvop->op_ppaddr = PL_ppaddr[type];
2902 pvop->op_next = (OP*)pvop;
2903 pvop->op_flags = (U8)flags;
2904 if (PL_opargs[type] & OA_RETSCALAR)
2906 if (PL_opargs[type] & OA_TARGET)
2907 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
2908 return CHECKOP(type, pvop);
2912 Perl_package(pTHX_ OP *o)
2917 save_hptr(&PL_curstash);
2918 save_item(PL_curstname);
2920 name = SvPV(cSVOPo->op_sv, len);
2921 PL_curstash = gv_stashpvn(name, len, TRUE);
2922 sv_setpvn(PL_curstname, name, len);
2925 PL_hints |= HINT_BLOCK_SCOPE;
2926 PL_copline = NOLINE;
2931 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
2937 if (idop->op_type != OP_CONST)
2938 Perl_croak(aTHX_ "Module name must be constant");
2942 if (version != Nullop) {
2943 SV *vesv = ((SVOP*)version)->op_sv;
2945 if (arg == Nullop && !SvNIOKp(vesv)) {
2952 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
2953 Perl_croak(aTHX_ "Version number must be constant number");
2955 /* Make copy of idop so we don't free it twice */
2956 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
2958 /* Fake up a method call to VERSION */
2959 meth = newSVpvn("VERSION",7);
2960 sv_upgrade(meth, SVt_PVIV);
2961 (void)SvIOK_on(meth);
2962 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
2963 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2964 append_elem(OP_LIST,
2965 prepend_elem(OP_LIST, pack, list(version)),
2966 newSVOP(OP_METHOD_NAMED, 0, meth)));
2970 /* Fake up an import/unimport */
2971 if (arg && arg->op_type == OP_STUB)
2972 imop = arg; /* no import on explicit () */
2973 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
2974 imop = Nullop; /* use 5.0; */
2979 /* Make copy of idop so we don't free it twice */
2980 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
2982 /* Fake up a method call to import/unimport */
2983 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);
2984 (void)SvUPGRADE(meth, SVt_PVIV);
2985 (void)SvIOK_on(meth);
2986 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
2987 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2988 append_elem(OP_LIST,
2989 prepend_elem(OP_LIST, pack, list(arg)),
2990 newSVOP(OP_METHOD_NAMED, 0, meth)));
2993 /* Fake up the BEGIN {}, which does its thing immediately. */
2995 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
2998 append_elem(OP_LINESEQ,
2999 append_elem(OP_LINESEQ,
3000 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, idop)),
3001 newSTATEOP(0, Nullch, veop)),
3002 newSTATEOP(0, Nullch, imop) ));
3004 /* The "did you use incorrect case?" warning used to be here.
3005 * The problem is that on case-insensitive filesystems one
3006 * might get false positives for "use" (and "require"):
3007 * "use Strict" or "require CARP" will work. This causes
3008 * portability problems for the script: in case-strict
3009 * filesystems the script will stop working.
3011 * The "incorrect case" warning checked whether "use Foo"
3012 * imported "Foo" to your namespace, but that is wrong, too:
3013 * there is no requirement nor promise in the language that
3014 * a Foo.pm should or would contain anything in package "Foo".
3016 * There is very little Configure-wise that can be done, either:
3017 * the case-sensitivity of the build filesystem of Perl does not
3018 * help in guessing the case-sensitivity of the runtime environment.
3021 PL_hints |= HINT_BLOCK_SCOPE;
3022 PL_copline = NOLINE;
3024 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3028 =head1 Embedding Functions
3030 =for apidoc load_module
3032 Loads the module whose name is pointed to by the string part of name.
3033 Note that the actual module name, not its filename, should be given.
3034 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3035 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3036 (or 0 for no flags). ver, if specified, provides version semantics
3037 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3038 arguments can be used to specify arguments to the module's import()
3039 method, similar to C<use Foo::Bar VERSION LIST>.
3044 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3047 va_start(args, ver);
3048 vload_module(flags, name, ver, &args);
3052 #ifdef PERL_IMPLICIT_CONTEXT
3054 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3058 va_start(args, ver);
3059 vload_module(flags, name, ver, &args);
3065 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3067 OP *modname, *veop, *imop;
3069 modname = newSVOP(OP_CONST, 0, name);
3070 modname->op_private |= OPpCONST_BARE;
3072 veop = newSVOP(OP_CONST, 0, ver);
3076 if (flags & PERL_LOADMOD_NOIMPORT) {
3077 imop = sawparens(newNULLLIST());
3079 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3080 imop = va_arg(*args, OP*);
3085 sv = va_arg(*args, SV*);
3087 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3088 sv = va_arg(*args, SV*);
3092 line_t ocopline = PL_copline;
3093 COP *ocurcop = PL_curcop;
3094 int oexpect = PL_expect;
3096 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3097 veop, modname, imop);
3098 PL_expect = oexpect;
3099 PL_copline = ocopline;
3100 PL_curcop = ocurcop;
3105 Perl_dofile(pTHX_ OP *term)
3110 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3111 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
3112 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3114 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3115 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3116 append_elem(OP_LIST, term,
3117 scalar(newUNOP(OP_RV2CV, 0,
3122 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3128 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3130 return newBINOP(OP_LSLICE, flags,
3131 list(force_list(subscript)),
3132 list(force_list(listval)) );
3136 S_list_assignment(pTHX_ register OP *o)
3141 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3142 o = cUNOPo->op_first;
3144 if (o->op_type == OP_COND_EXPR) {
3145 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3146 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3151 yyerror("Assignment to both a list and a scalar");
3155 if (o->op_type == OP_LIST &&
3156 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3157 o->op_private & OPpLVAL_INTRO)
3160 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3161 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3162 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3165 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3168 if (o->op_type == OP_RV2SV)
3175 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3180 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3181 return newLOGOP(optype, 0,
3182 mod(scalar(left), optype),
3183 newUNOP(OP_SASSIGN, 0, scalar(right)));
3186 return newBINOP(optype, OPf_STACKED,
3187 mod(scalar(left), optype), scalar(right));
3191 if (list_assignment(left)) {
3195 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3196 left = mod(left, OP_AASSIGN);
3204 /* optimise C<my @x = ()> to C<my @x>, and likewise for hashes */
3205 if ((left->op_type == OP_PADAV || left->op_type == OP_PADHV)
3206 && right->op_type == OP_STUB
3207 && (left->op_private & OPpLVAL_INTRO))
3210 left->op_flags &= ~(OPf_REF|OPf_SPECIAL);
3213 curop = list(force_list(left));
3214 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3215 o->op_private = (U8)(0 | (flags >> 8));
3217 /* PL_generation sorcery:
3218 * an assignment like ($a,$b) = ($c,$d) is easier than
3219 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3220 * To detect whether there are common vars, the global var
3221 * PL_generation is incremented for each assign op we compile.
3222 * Then, while compiling the assign op, we run through all the
3223 * variables on both sides of the assignment, setting a spare slot
3224 * in each of them to PL_generation. If any of them already have
3225 * that value, we know we've got commonality. We could use a
3226 * single bit marker, but then we'd have to make 2 passes, first
3227 * to clear the flag, then to test and set it. To find somewhere
3228 * to store these values, evil chicanery is done with SvCUR().
3231 if (!(left->op_private & OPpLVAL_INTRO)) {
3234 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3235 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3236 if (curop->op_type == OP_GV) {
3237 GV *gv = cGVOPx_gv(curop);
3238 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3240 SvCUR(gv) = PL_generation;
3242 else if (curop->op_type == OP_PADSV ||
3243 curop->op_type == OP_PADAV ||
3244 curop->op_type == OP_PADHV ||
3245 curop->op_type == OP_PADANY)
3247 if (PAD_COMPNAME_GEN(curop->op_targ)
3248 == (STRLEN)PL_generation)
3250 PAD_COMPNAME_GEN(curop->op_targ)
3254 else if (curop->op_type == OP_RV2CV)
3256 else if (curop->op_type == OP_RV2SV ||
3257 curop->op_type == OP_RV2AV ||
3258 curop->op_type == OP_RV2HV ||
3259 curop->op_type == OP_RV2GV) {
3260 if (lastop->op_type != OP_GV) /* funny deref? */
3263 else if (curop->op_type == OP_PUSHRE) {
3264 if (((PMOP*)curop)->op_pmreplroot) {
3266 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3267 ((PMOP*)curop)->op_pmreplroot));
3269 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3271 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3273 SvCUR(gv) = PL_generation;
3282 o->op_private |= OPpASSIGN_COMMON;
3284 if (right && right->op_type == OP_SPLIT) {
3286 if ((tmpop = ((LISTOP*)right)->op_first) &&
3287 tmpop->op_type == OP_PUSHRE)
3289 PMOP *pm = (PMOP*)tmpop;
3290 if (left->op_type == OP_RV2AV &&
3291 !(left->op_private & OPpLVAL_INTRO) &&
3292 !(o->op_private & OPpASSIGN_COMMON) )
3294 tmpop = ((UNOP*)left)->op_first;
3295 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3297 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3298 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3300 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3301 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3303 pm->op_pmflags |= PMf_ONCE;
3304 tmpop = cUNOPo->op_first; /* to list (nulled) */
3305 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3306 tmpop->op_sibling = Nullop; /* don't free split */
3307 right->op_next = tmpop->op_next; /* fix starting loc */
3308 op_free(o); /* blow off assign */
3309 right->op_flags &= ~OPf_WANT;
3310 /* "I don't know and I don't care." */
3315 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3316 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3318 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3320 sv_setiv(sv, PL_modcount+1);
3328 right = newOP(OP_UNDEF, 0);
3329 if (right->op_type == OP_READLINE) {
3330 right->op_flags |= OPf_STACKED;
3331 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3334 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3335 o = newBINOP(OP_SASSIGN, flags,
3336 scalar(right), mod(scalar(left), OP_SASSIGN) );
3348 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3350 U32 seq = intro_my();
3353 NewOp(1101, cop, 1, COP);
3354 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3355 cop->op_type = OP_DBSTATE;
3356 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3359 cop->op_type = OP_NEXTSTATE;
3360 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3362 cop->op_flags = (U8)flags;
3363 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3365 cop->op_private |= NATIVE_HINTS;
3367 PL_compiling.op_private = cop->op_private;
3368 cop->op_next = (OP*)cop;
3371 cop->cop_label = label;
3372 PL_hints |= HINT_BLOCK_SCOPE;
3375 cop->cop_arybase = PL_curcop->cop_arybase;
3376 if (specialWARN(PL_curcop->cop_warnings))
3377 cop->cop_warnings = PL_curcop->cop_warnings ;
3379 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3380 if (specialCopIO(PL_curcop->cop_io))
3381 cop->cop_io = PL_curcop->cop_io;
3383 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3386 if (PL_copline == NOLINE)
3387 CopLINE_set(cop, CopLINE(PL_curcop));
3389 CopLINE_set(cop, PL_copline);
3390 PL_copline = NOLINE;
3393 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3395 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3397 CopSTASH_set(cop, PL_curstash);
3399 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3400 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3401 if (svp && *svp != &PL_sv_undef ) {
3402 (void)SvIOK_on(*svp);
3403 SvIVX(*svp) = PTR2IV(cop);
3407 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3412 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3414 return new_logop(type, flags, &first, &other);
3418 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3422 OP *first = *firstp;
3423 OP *other = *otherp;
3425 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3426 return newBINOP(type, flags, scalar(first), scalar(other));
3428 scalarboolean(first);
3429 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3430 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3431 if (type == OP_AND || type == OP_OR) {
3437 first = *firstp = cUNOPo->op_first;
3439 first->op_next = o->op_next;
3440 cUNOPo->op_first = Nullop;
3444 if (first->op_type == OP_CONST) {
3445 if (first->op_private & OPpCONST_STRICT)
3446 no_bareword_allowed(first);
3447 else if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3448 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3449 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
3450 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
3451 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
3454 if (other->op_type == OP_CONST)
3455 other->op_private |= OPpCONST_SHORTCIRCUIT;
3459 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
3461 if ( ! (o2->op_type == OP_LIST
3462 && (( o2 = cUNOPx(o2)->op_first))
3463 && o2->op_type == OP_PUSHMARK
3464 && (( o2 = o2->op_sibling)) )
3467 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
3468 || o2->op_type == OP_PADHV)
3469 && o2->op_private & OPpLVAL_INTRO
3470 && ckWARN(WARN_DEPRECATED))
3472 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
3473 "Deprecated use of my() in false conditional");
3478 if (first->op_type == OP_CONST)
3479 first->op_private |= OPpCONST_SHORTCIRCUIT;
3483 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS) &&
3484 type != OP_DOR) /* [#24076] Don't warn for <FH> err FOO. */
3486 OP *k1 = ((UNOP*)first)->op_first;
3487 OP *k2 = k1->op_sibling;
3489 switch (first->op_type)
3492 if (k2 && k2->op_type == OP_READLINE
3493 && (k2->op_flags & OPf_STACKED)
3494 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3496 warnop = k2->op_type;
3501 if (k1->op_type == OP_READDIR
3502 || k1->op_type == OP_GLOB
3503 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3504 || k1->op_type == OP_EACH)
3506 warnop = ((k1->op_type == OP_NULL)
3507 ? (OPCODE)k1->op_targ : k1->op_type);
3512 line_t oldline = CopLINE(PL_curcop);
3513 CopLINE_set(PL_curcop, PL_copline);
3514 Perl_warner(aTHX_ packWARN(WARN_MISC),
3515 "Value of %s%s can be \"0\"; test with defined()",
3517 ((warnop == OP_READLINE || warnop == OP_GLOB)
3518 ? " construct" : "() operator"));
3519 CopLINE_set(PL_curcop, oldline);
3526 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3527 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3529 NewOp(1101, logop, 1, LOGOP);
3531 logop->op_type = (OPCODE)type;
3532 logop->op_ppaddr = PL_ppaddr[type];
3533 logop->op_first = first;
3534 logop->op_flags = flags | OPf_KIDS;
3535 logop->op_other = LINKLIST(other);
3536 logop->op_private = (U8)(1 | (flags >> 8));
3538 /* establish postfix order */
3539 logop->op_next = LINKLIST(first);
3540 first->op_next = (OP*)logop;
3541 first->op_sibling = other;
3543 CHECKOP(type,logop);
3545 o = newUNOP(OP_NULL, 0, (OP*)logop);
3552 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3559 return newLOGOP(OP_AND, 0, first, trueop);
3561 return newLOGOP(OP_OR, 0, first, falseop);
3563 scalarboolean(first);
3564 if (first->op_type == OP_CONST) {
3565 if (first->op_private & OPpCONST_BARE &&
3566 first->op_private & OPpCONST_STRICT) {
3567 no_bareword_allowed(first);
3569 if (SvTRUE(((SVOP*)first)->op_sv)) {
3580 NewOp(1101, logop, 1, LOGOP);
3581 logop->op_type = OP_COND_EXPR;
3582 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3583 logop->op_first = first;
3584 logop->op_flags = flags | OPf_KIDS;
3585 logop->op_private = (U8)(1 | (flags >> 8));
3586 logop->op_other = LINKLIST(trueop);
3587 logop->op_next = LINKLIST(falseop);
3589 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
3592 /* establish postfix order */
3593 start = LINKLIST(first);
3594 first->op_next = (OP*)logop;
3596 first->op_sibling = trueop;
3597 trueop->op_sibling = falseop;
3598 o = newUNOP(OP_NULL, 0, (OP*)logop);
3600 trueop->op_next = falseop->op_next = o;
3607 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3615 NewOp(1101, range, 1, LOGOP);
3617 range->op_type = OP_RANGE;
3618 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3619 range->op_first = left;
3620 range->op_flags = OPf_KIDS;
3621 leftstart = LINKLIST(left);
3622 range->op_other = LINKLIST(right);
3623 range->op_private = (U8)(1 | (flags >> 8));
3625 left->op_sibling = right;
3627 range->op_next = (OP*)range;
3628 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3629 flop = newUNOP(OP_FLOP, 0, flip);
3630 o = newUNOP(OP_NULL, 0, flop);
3632 range->op_next = leftstart;
3634 left->op_next = flip;
3635 right->op_next = flop;
3637 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3638 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3639 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3640 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3642 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3643 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3646 if (!flip->op_private || !flop->op_private)
3647 linklist(o); /* blow off optimizer unless constant */
3653 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3657 int once = block && block->op_flags & OPf_SPECIAL &&
3658 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3661 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3662 return block; /* do {} while 0 does once */
3663 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3664 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3665 expr = newUNOP(OP_DEFINED, 0,
3666 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3667 } else if (expr->op_flags & OPf_KIDS) {
3668 OP *k1 = ((UNOP*)expr)->op_first;
3669 OP *k2 = (k1) ? k1->op_sibling : NULL;
3670 switch (expr->op_type) {
3672 if (k2 && k2->op_type == OP_READLINE
3673 && (k2->op_flags & OPf_STACKED)
3674 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3675 expr = newUNOP(OP_DEFINED, 0, expr);
3679 if (k1->op_type == OP_READDIR
3680 || k1->op_type == OP_GLOB
3681 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3682 || k1->op_type == OP_EACH)
3683 expr = newUNOP(OP_DEFINED, 0, expr);
3689 /* if block is null, the next append_elem() would put UNSTACK, a scalar
3690 * op, in listop. This is wrong. [perl #27024] */
3692 block = newOP(OP_NULL, 0);
3693 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3694 o = new_logop(OP_AND, 0, &expr, &listop);
3697 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3699 if (once && o != listop)
3700 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3703 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3705 o->op_flags |= flags;
3707 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3712 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3720 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3721 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3722 expr = newUNOP(OP_DEFINED, 0,
3723 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3724 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3725 OP *k1 = ((UNOP*)expr)->op_first;
3726 OP *k2 = (k1) ? k1->op_sibling : NULL;
3727 switch (expr->op_type) {
3729 if (k2 && k2->op_type == OP_READLINE
3730 && (k2->op_flags & OPf_STACKED)
3731 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3732 expr = newUNOP(OP_DEFINED, 0, expr);
3736 if (k1->op_type == OP_READDIR
3737 || k1->op_type == OP_GLOB
3738 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3739 || k1->op_type == OP_EACH)
3740 expr = newUNOP(OP_DEFINED, 0, expr);
3746 block = newOP(OP_NULL, 0);
3748 block = scope(block);
3752 next = LINKLIST(cont);
3755 OP *unstack = newOP(OP_UNSTACK, 0);
3758 cont = append_elem(OP_LINESEQ, cont, unstack);
3761 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3762 redo = LINKLIST(listop);
3765 PL_copline = (line_t)whileline;
3767 o = new_logop(OP_AND, 0, &expr, &listop);
3768 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3769 op_free(expr); /* oops, it's a while (0) */
3771 return Nullop; /* listop already freed by new_logop */
3774 ((LISTOP*)listop)->op_last->op_next =
3775 (o == listop ? redo : LINKLIST(o));
3781 NewOp(1101,loop,1,LOOP);
3782 loop->op_type = OP_ENTERLOOP;
3783 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3784 loop->op_private = 0;
3785 loop->op_next = (OP*)loop;
3788 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3790 loop->op_redoop = redo;
3791 loop->op_lastop = o;
3792 o->op_private |= loopflags;
3795 loop->op_nextop = next;
3797 loop->op_nextop = o;
3799 o->op_flags |= flags;
3800 o->op_private |= (flags >> 8);
3805 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
3809 PADOFFSET padoff = 0;
3814 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
3815 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
3816 sv->op_type = OP_RV2GV;
3817 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3819 else if (sv->op_type == OP_PADSV) { /* private variable */
3820 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
3821 padoff = sv->op_targ;
3826 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3827 padoff = sv->op_targ;
3829 iterflags |= OPf_SPECIAL;
3834 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3837 I32 offset = pad_findmy("$_");
3838 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
3839 sv = newGVOP(OP_GV, 0, PL_defgv);
3845 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3846 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3847 iterflags |= OPf_STACKED;
3849 else if (expr->op_type == OP_NULL &&
3850 (expr->op_flags & OPf_KIDS) &&
3851 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3853 /* Basically turn for($x..$y) into the same as for($x,$y), but we
3854 * set the STACKED flag to indicate that these values are to be
3855 * treated as min/max values by 'pp_iterinit'.
3857 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
3858 LOGOP* range = (LOGOP*) flip->op_first;
3859 OP* left = range->op_first;
3860 OP* right = left->op_sibling;
3863 range->op_flags &= ~OPf_KIDS;
3864 range->op_first = Nullop;
3866 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
3867 listop->op_first->op_next = range->op_next;
3868 left->op_next = range->op_other;
3869 right->op_next = (OP*)listop;
3870 listop->op_next = listop->op_first;
3873 expr = (OP*)(listop);
3875 iterflags |= OPf_STACKED;
3878 expr = mod(force_list(expr), OP_GREPSTART);
3882 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
3883 append_elem(OP_LIST, expr, scalar(sv))));
3884 assert(!loop->op_next);
3885 /* for my $x () sets OPpLVAL_INTRO;
3886 * for our $x () sets OPpOUR_INTRO */
3887 loop->op_private = (U8)iterpflags;
3888 #ifdef PL_OP_SLAB_ALLOC
3891 NewOp(1234,tmp,1,LOOP);
3892 Copy(loop,tmp,1,LOOP);
3897 Renew(loop, 1, LOOP);
3899 loop->op_targ = padoff;
3900 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
3901 PL_copline = forline;
3902 return newSTATEOP(0, label, wop);
3906 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
3911 if (type != OP_GOTO || label->op_type == OP_CONST) {
3912 /* "last()" means "last" */
3913 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
3914 o = newOP(type, OPf_SPECIAL);
3916 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
3917 ? SvPVx(((SVOP*)label)->op_sv, n_a)
3923 /* Check whether it's going to be a goto &function */
3924 if (label->op_type == OP_ENTERSUB
3925 && !(label->op_flags & OPf_STACKED))
3926 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
3927 o = newUNOP(type, OPf_STACKED, label);
3929 PL_hints |= HINT_BLOCK_SCOPE;
3934 =for apidoc cv_undef
3936 Clear out all the active components of a CV. This can happen either
3937 by an explicit C<undef &foo>, or by the reference count going to zero.
3938 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
3939 children can still follow the full lexical scope chain.
3945 Perl_cv_undef(pTHX_ CV *cv)
3948 if (CvFILE(cv) && !CvXSUB(cv)) {
3949 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
3950 Safefree(CvFILE(cv));
3955 if (!CvXSUB(cv) && CvROOT(cv)) {
3957 Perl_croak(aTHX_ "Can't undef active subroutine");
3960 PAD_SAVE_SETNULLPAD();
3962 op_free(CvROOT(cv));
3963 CvROOT(cv) = Nullop;
3966 SvPOK_off((SV*)cv); /* forget prototype */
3971 /* remove CvOUTSIDE unless this is an undef rather than a free */
3972 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
3973 if (!CvWEAKOUTSIDE(cv))
3974 SvREFCNT_dec(CvOUTSIDE(cv));
3975 CvOUTSIDE(cv) = Nullcv;
3978 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
3984 /* delete all flags except WEAKOUTSIDE */
3985 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
3989 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
3991 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
3992 SV* msg = sv_newmortal();
3996 gv_efullname3(name = sv_newmortal(), gv, Nullch);
3997 sv_setpv(msg, "Prototype mismatch:");
3999 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4001 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (SV *)cv);
4003 Perl_sv_catpvf(aTHX_ msg, ": none");
4004 sv_catpv(msg, " vs ");
4006 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4008 sv_catpv(msg, "none");
4009 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
4013 static void const_sv_xsub(pTHX_ CV* cv);
4017 =head1 Optree Manipulation Functions
4019 =for apidoc cv_const_sv
4021 If C<cv> is a constant sub eligible for inlining. returns the constant
4022 value returned by the sub. Otherwise, returns NULL.
4024 Constant subs can be created with C<newCONSTSUB> or as described in
4025 L<perlsub/"Constant Functions">.
4030 Perl_cv_const_sv(pTHX_ CV *cv)
4032 if (!cv || !CvCONST(cv))
4034 return (SV*)CvXSUBANY(cv).any_ptr;
4037 /* op_const_sv: examine an optree to determine whether it's in-lineable.
4038 * Can be called in 3 ways:
4041 * look for a single OP_CONST with attached value: return the value
4043 * cv && CvCLONE(cv) && !CvCONST(cv)
4045 * examine the clone prototype, and if contains only a single
4046 * OP_CONST referencing a pad const, or a single PADSV referencing
4047 * an outer lexical, return a non-zero value to indicate the CV is
4048 * a candidate for "constizing" at clone time
4052 * We have just cloned an anon prototype that was marked as a const
4053 * candidiate. Try to grab the current value, and in the case of
4054 * PADSV, ignore it if it has multiple references. Return the value.
4058 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4065 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4066 o = cLISTOPo->op_first->op_sibling;
4068 for (; o; o = o->op_next) {
4069 OPCODE type = o->op_type;
4071 if (sv && o->op_next == o)
4073 if (o->op_next != o) {
4074 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4076 if (type == OP_DBSTATE)
4079 if (type == OP_LEAVESUB || type == OP_RETURN)
4083 if (type == OP_CONST && cSVOPo->op_sv)
4085 else if (cv && type == OP_CONST) {
4086 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4090 else if (cv && type == OP_PADSV) {
4091 if (CvCONST(cv)) { /* newly cloned anon */
4092 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4093 /* the candidate should have 1 ref from this pad and 1 ref
4094 * from the parent */
4095 if (!sv || SvREFCNT(sv) != 2)
4102 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4103 sv = &PL_sv_undef; /* an arbitrary non-null value */
4114 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4124 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4128 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4130 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4134 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4144 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4147 assert(proto->op_type == OP_CONST);
4148 ps = SvPVx(((SVOP*)proto)->op_sv, n_a);
4153 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4154 SV *sv = sv_newmortal();
4155 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4156 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4157 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4162 gv = gv_fetchpv(name ? name : (aname ? aname :
4163 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__")),
4164 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4174 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4175 maximum a prototype before. */
4176 if (SvTYPE(gv) > SVt_NULL) {
4177 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4178 && ckWARN_d(WARN_PROTOTYPE))
4180 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4182 cv_ckproto((CV*)gv, NULL, ps);
4185 sv_setpv((SV*)gv, ps);
4187 sv_setiv((SV*)gv, -1);
4188 SvREFCNT_dec(PL_compcv);
4189 cv = PL_compcv = NULL;
4190 PL_sub_generation++;
4194 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4196 #ifdef GV_UNIQUE_CHECK
4197 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4198 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4202 if (!block || !ps || *ps || attrs)
4205 const_sv = op_const_sv(block, Nullcv);
4208 bool exists = CvROOT(cv) || CvXSUB(cv);
4210 #ifdef GV_UNIQUE_CHECK
4211 if (exists && GvUNIQUE(gv)) {
4212 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4216 /* if the subroutine doesn't exist and wasn't pre-declared
4217 * with a prototype, assume it will be AUTOLOADed,
4218 * skipping the prototype check
4220 if (exists || SvPOK(cv))
4221 cv_ckproto(cv, gv, ps);
4222 /* already defined (or promised)? */
4223 if (exists || GvASSUMECV(gv)) {
4224 if (!block && !attrs) {
4225 if (CvFLAGS(PL_compcv)) {
4226 /* might have had built-in attrs applied */
4227 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4229 /* just a "sub foo;" when &foo is already defined */
4230 SAVEFREESV(PL_compcv);
4233 /* ahem, death to those who redefine active sort subs */
4234 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4235 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4237 if (ckWARN(WARN_REDEFINE)
4239 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4241 line_t oldline = CopLINE(PL_curcop);
4242 if (PL_copline != NOLINE)
4243 CopLINE_set(PL_curcop, PL_copline);
4244 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4245 CvCONST(cv) ? "Constant subroutine %s redefined"
4246 : "Subroutine %s redefined", name);
4247 CopLINE_set(PL_curcop, oldline);
4255 SvREFCNT_inc(const_sv);
4257 assert(!CvROOT(cv) && !CvCONST(cv));
4258 sv_setpv((SV*)cv, ""); /* prototype is "" */
4259 CvXSUBANY(cv).any_ptr = const_sv;
4260 CvXSUB(cv) = const_sv_xsub;
4265 cv = newCONSTSUB(NULL, name, const_sv);
4268 SvREFCNT_dec(PL_compcv);
4270 PL_sub_generation++;
4277 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4278 * before we clobber PL_compcv.
4282 /* Might have had built-in attributes applied -- propagate them. */
4283 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4284 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4285 stash = GvSTASH(CvGV(cv));
4286 else if (CvSTASH(cv))
4287 stash = CvSTASH(cv);
4289 stash = PL_curstash;
4292 /* possibly about to re-define existing subr -- ignore old cv */
4293 rcv = (SV*)PL_compcv;
4294 if (name && GvSTASH(gv))
4295 stash = GvSTASH(gv);
4297 stash = PL_curstash;
4299 apply_attrs(stash, rcv, attrs, FALSE);
4301 if (cv) { /* must reuse cv if autoloaded */
4303 /* got here with just attrs -- work done, so bug out */
4304 SAVEFREESV(PL_compcv);
4307 /* transfer PL_compcv to cv */
4309 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4310 if (!CvWEAKOUTSIDE(cv))
4311 SvREFCNT_dec(CvOUTSIDE(cv));
4312 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4313 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4314 CvOUTSIDE(PL_compcv) = 0;
4315 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4316 CvPADLIST(PL_compcv) = 0;
4317 /* inner references to PL_compcv must be fixed up ... */
4318 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4319 /* ... before we throw it away */
4320 SvREFCNT_dec(PL_compcv);
4322 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4323 ++PL_sub_generation;
4330 PL_sub_generation++;
4334 CvFILE_set_from_cop(cv, PL_curcop);
4335 CvSTASH(cv) = PL_curstash;
4338 sv_setpv((SV*)cv, ps);
4340 if (PL_error_count) {
4344 char *s = strrchr(name, ':');
4346 if (strEQ(s, "BEGIN")) {
4348 "BEGIN not safe after errors--compilation aborted";
4349 if (PL_in_eval & EVAL_KEEPERR)
4350 Perl_croak(aTHX_ not_safe);
4352 /* force display of errors found but not reported */
4353 sv_catpv(ERRSV, not_safe);
4354 Perl_croak(aTHX_ "%"SVf, ERRSV);
4363 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4364 mod(scalarseq(block), OP_LEAVESUBLV));
4367 /* This makes sub {}; work as expected. */
4368 if (block->op_type == OP_STUB) {
4370 block = newSTATEOP(0, Nullch, 0);
4372 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4374 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4375 OpREFCNT_set(CvROOT(cv), 1);
4376 CvSTART(cv) = LINKLIST(CvROOT(cv));
4377 CvROOT(cv)->op_next = 0;
4378 CALL_PEEP(CvSTART(cv));
4380 /* now that optimizer has done its work, adjust pad values */
4382 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4385 assert(!CvCONST(cv));
4386 if (ps && !*ps && op_const_sv(block, cv))
4390 if (name || aname) {
4392 char *tname = (name ? name : aname);
4394 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4395 SV *sv = NEWSV(0,0);
4396 SV *tmpstr = sv_newmortal();
4397 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4401 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4403 (long)PL_subline, (long)CopLINE(PL_curcop));
4404 gv_efullname3(tmpstr, gv, Nullch);
4405 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4406 hv = GvHVn(db_postponed);
4407 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4408 && (pcv = GvCV(db_postponed)))
4414 call_sv((SV*)pcv, G_DISCARD);
4418 if ((s = strrchr(tname,':')))
4423 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4426 if (strEQ(s, "BEGIN") && !PL_error_count) {
4427 I32 oldscope = PL_scopestack_ix;
4429 SAVECOPFILE(&PL_compiling);
4430 SAVECOPLINE(&PL_compiling);
4433 PL_beginav = newAV();
4434 DEBUG_x( dump_sub(gv) );
4435 av_push(PL_beginav, (SV*)cv);
4436 GvCV(gv) = 0; /* cv has been hijacked */
4437 call_list(oldscope, PL_beginav);
4439 PL_curcop = &PL_compiling;
4440 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4443 else if (strEQ(s, "END") && !PL_error_count) {
4446 DEBUG_x( dump_sub(gv) );
4447 av_unshift(PL_endav, 1);
4448 av_store(PL_endav, 0, (SV*)cv);
4449 GvCV(gv) = 0; /* cv has been hijacked */
4451 else if (strEQ(s, "CHECK") && !PL_error_count) {
4453 PL_checkav = newAV();
4454 DEBUG_x( dump_sub(gv) );
4455 if (PL_main_start && ckWARN(WARN_VOID))
4456 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4457 av_unshift(PL_checkav, 1);
4458 av_store(PL_checkav, 0, (SV*)cv);
4459 GvCV(gv) = 0; /* cv has been hijacked */
4461 else if (strEQ(s, "INIT") && !PL_error_count) {
4463 PL_initav = newAV();
4464 DEBUG_x( dump_sub(gv) );
4465 if (PL_main_start && ckWARN(WARN_VOID))
4466 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4467 av_push(PL_initav, (SV*)cv);
4468 GvCV(gv) = 0; /* cv has been hijacked */
4473 PL_copline = NOLINE;
4478 /* XXX unsafe for threads if eval_owner isn't held */
4480 =for apidoc newCONSTSUB
4482 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4483 eligible for inlining at compile-time.
4489 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4495 SAVECOPLINE(PL_curcop);
4496 CopLINE_set(PL_curcop, PL_copline);
4499 PL_hints &= ~HINT_BLOCK_SCOPE;
4502 SAVESPTR(PL_curstash);
4503 SAVECOPSTASH(PL_curcop);
4504 PL_curstash = stash;
4505 CopSTASH_set(PL_curcop,stash);
4508 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4509 CvXSUBANY(cv).any_ptr = sv;
4511 sv_setpv((SV*)cv, ""); /* prototype is "" */
4514 CopSTASH_free(PL_curcop);
4522 =for apidoc U||newXS
4524 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4530 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
4532 GV *gv = gv_fetchpv(name ? name :
4533 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4534 GV_ADDMULTI, SVt_PVCV);
4538 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4540 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4542 /* just a cached method */
4546 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4547 /* already defined (or promised) */
4548 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4549 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4550 line_t oldline = CopLINE(PL_curcop);
4551 if (PL_copline != NOLINE)
4552 CopLINE_set(PL_curcop, PL_copline);
4553 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4554 CvCONST(cv) ? "Constant subroutine %s redefined"
4555 : "Subroutine %s redefined"
4557 CopLINE_set(PL_curcop, oldline);
4564 if (cv) /* must reuse cv if autoloaded */
4567 cv = (CV*)NEWSV(1105,0);
4568 sv_upgrade((SV *)cv, SVt_PVCV);
4572 PL_sub_generation++;
4576 (void)gv_fetchfile(filename);
4577 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
4578 an external constant string */
4579 CvXSUB(cv) = subaddr;
4582 char *s = strrchr(name,':');
4588 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4591 if (strEQ(s, "BEGIN")) {
4593 PL_beginav = newAV();
4594 av_push(PL_beginav, (SV*)cv);
4595 GvCV(gv) = 0; /* cv has been hijacked */
4597 else if (strEQ(s, "END")) {
4600 av_unshift(PL_endav, 1);
4601 av_store(PL_endav, 0, (SV*)cv);
4602 GvCV(gv) = 0; /* cv has been hijacked */
4604 else if (strEQ(s, "CHECK")) {
4606 PL_checkav = newAV();
4607 if (PL_main_start && ckWARN(WARN_VOID))
4608 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4609 av_unshift(PL_checkav, 1);
4610 av_store(PL_checkav, 0, (SV*)cv);
4611 GvCV(gv) = 0; /* cv has been hijacked */
4613 else if (strEQ(s, "INIT")) {
4615 PL_initav = newAV();
4616 if (PL_main_start && ckWARN(WARN_VOID))
4617 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4618 av_push(PL_initav, (SV*)cv);
4619 GvCV(gv) = 0; /* cv has been hijacked */
4630 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4638 name = SvPVx(cSVOPo->op_sv, n_a);
4641 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
4642 #ifdef GV_UNIQUE_CHECK
4644 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4648 if ((cv = GvFORM(gv))) {
4649 if (ckWARN(WARN_REDEFINE)) {
4650 line_t oldline = CopLINE(PL_curcop);
4651 if (PL_copline != NOLINE)
4652 CopLINE_set(PL_curcop, PL_copline);
4653 Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Format %s redefined",name);
4654 CopLINE_set(PL_curcop, oldline);
4661 CvFILE_set_from_cop(cv, PL_curcop);
4664 pad_tidy(padtidy_FORMAT);
4665 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4666 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4667 OpREFCNT_set(CvROOT(cv), 1);
4668 CvSTART(cv) = LINKLIST(CvROOT(cv));
4669 CvROOT(cv)->op_next = 0;
4670 CALL_PEEP(CvSTART(cv));
4672 PL_copline = NOLINE;
4677 Perl_newANONLIST(pTHX_ OP *o)
4679 return newUNOP(OP_REFGEN, 0,
4680 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4684 Perl_newANONHASH(pTHX_ OP *o)
4686 return newUNOP(OP_REFGEN, 0,
4687 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4691 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4693 return newANONATTRSUB(floor, proto, Nullop, block);
4697 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4699 return newUNOP(OP_REFGEN, 0,
4700 newSVOP(OP_ANONCODE, 0,
4701 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
4705 Perl_oopsAV(pTHX_ OP *o)
4707 switch (o->op_type) {
4709 o->op_type = OP_PADAV;
4710 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4711 return ref(o, OP_RV2AV);
4714 o->op_type = OP_RV2AV;
4715 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4720 if (ckWARN_d(WARN_INTERNAL))
4721 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
4728 Perl_oopsHV(pTHX_ OP *o)
4730 switch (o->op_type) {
4733 o->op_type = OP_PADHV;
4734 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4735 return ref(o, OP_RV2HV);
4739 o->op_type = OP_RV2HV;
4740 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
4745 if (ckWARN_d(WARN_INTERNAL))
4746 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
4753 Perl_newAVREF(pTHX_ OP *o)
4755 if (o->op_type == OP_PADANY) {
4756 o->op_type = OP_PADAV;
4757 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4760 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
4761 && ckWARN(WARN_DEPRECATED)) {
4762 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4763 "Using an array as a reference is deprecated");
4765 return newUNOP(OP_RV2AV, 0, scalar(o));
4769 Perl_newGVREF(pTHX_ I32 type, OP *o)
4771 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
4772 return newUNOP(OP_NULL, 0, o);
4773 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
4777 Perl_newHVREF(pTHX_ OP *o)
4779 if (o->op_type == OP_PADANY) {
4780 o->op_type = OP_PADHV;
4781 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4784 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
4785 && ckWARN(WARN_DEPRECATED)) {
4786 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4787 "Using a hash as a reference is deprecated");
4789 return newUNOP(OP_RV2HV, 0, scalar(o));
4793 Perl_oopsCV(pTHX_ OP *o)
4795 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
4801 Perl_newCVREF(pTHX_ I32 flags, OP *o)
4803 return newUNOP(OP_RV2CV, flags, scalar(o));
4807 Perl_newSVREF(pTHX_ OP *o)
4809 if (o->op_type == OP_PADANY) {
4810 o->op_type = OP_PADSV;
4811 o->op_ppaddr = PL_ppaddr[OP_PADSV];
4814 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4815 o->op_flags |= OPpDONE_SVREF;
4818 return newUNOP(OP_RV2SV, 0, scalar(o));
4821 /* Check routines. */
4824 Perl_ck_anoncode(pTHX_ OP *o)
4826 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
4827 cSVOPo->op_sv = Nullsv;
4832 Perl_ck_bitop(pTHX_ OP *o)
4834 #define OP_IS_NUMCOMPARE(op) \
4835 ((op) == OP_LT || (op) == OP_I_LT || \
4836 (op) == OP_GT || (op) == OP_I_GT || \
4837 (op) == OP_LE || (op) == OP_I_LE || \
4838 (op) == OP_GE || (op) == OP_I_GE || \
4839 (op) == OP_EQ || (op) == OP_I_EQ || \
4840 (op) == OP_NE || (op) == OP_I_NE || \
4841 (op) == OP_NCMP || (op) == OP_I_NCMP)
4842 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4843 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
4844 && (o->op_type == OP_BIT_OR
4845 || o->op_type == OP_BIT_AND
4846 || o->op_type == OP_BIT_XOR))
4848 OP * left = cBINOPo->op_first;
4849 OP * right = left->op_sibling;
4850 if ((OP_IS_NUMCOMPARE(left->op_type) &&
4851 (left->op_flags & OPf_PARENS) == 0) ||
4852 (OP_IS_NUMCOMPARE(right->op_type) &&
4853 (right->op_flags & OPf_PARENS) == 0))
4854 if (ckWARN(WARN_PRECEDENCE))
4855 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4856 "Possible precedence problem on bitwise %c operator",
4857 o->op_type == OP_BIT_OR ? '|'
4858 : o->op_type == OP_BIT_AND ? '&' : '^'
4865 Perl_ck_concat(pTHX_ OP *o)
4867 OP *kid = cUNOPo->op_first;
4868 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
4869 !(kUNOP->op_first->op_flags & OPf_MOD))
4870 o->op_flags |= OPf_STACKED;
4875 Perl_ck_spair(pTHX_ OP *o)
4877 if (o->op_flags & OPf_KIDS) {
4880 OPCODE type = o->op_type;
4881 o = modkids(ck_fun(o), type);
4882 kid = cUNOPo->op_first;
4883 newop = kUNOP->op_first->op_sibling;
4885 (newop->op_sibling ||
4886 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
4887 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
4888 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
4892 op_free(kUNOP->op_first);
4893 kUNOP->op_first = newop;
4895 o->op_ppaddr = PL_ppaddr[++o->op_type];
4900 Perl_ck_delete(pTHX_ OP *o)
4904 if (o->op_flags & OPf_KIDS) {
4905 OP *kid = cUNOPo->op_first;
4906 switch (kid->op_type) {
4908 o->op_flags |= OPf_SPECIAL;
4911 o->op_private |= OPpSLICE;
4914 o->op_flags |= OPf_SPECIAL;
4919 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
4928 Perl_ck_die(pTHX_ OP *o)
4931 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4937 Perl_ck_eof(pTHX_ OP *o)
4939 I32 type = o->op_type;
4941 if (o->op_flags & OPf_KIDS) {
4942 if (cLISTOPo->op_first->op_type == OP_STUB) {
4944 o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
4952 Perl_ck_eval(pTHX_ OP *o)
4954 PL_hints |= HINT_BLOCK_SCOPE;
4955 if (o->op_flags & OPf_KIDS) {
4956 SVOP *kid = (SVOP*)cUNOPo->op_first;
4959 o->op_flags &= ~OPf_KIDS;
4962 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
4965 cUNOPo->op_first = 0;
4968 NewOp(1101, enter, 1, LOGOP);
4969 enter->op_type = OP_ENTERTRY;
4970 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
4971 enter->op_private = 0;
4973 /* establish postfix order */
4974 enter->op_next = (OP*)enter;
4976 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
4977 o->op_type = OP_LEAVETRY;
4978 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
4979 enter->op_other = o;
4989 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
4991 o->op_targ = (PADOFFSET)PL_hints;
4996 Perl_ck_exit(pTHX_ OP *o)
4999 HV *table = GvHV(PL_hintgv);
5001 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5002 if (svp && *svp && SvTRUE(*svp))
5003 o->op_private |= OPpEXIT_VMSISH;
5005 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5011 Perl_ck_exec(pTHX_ OP *o)
5014 if (o->op_flags & OPf_STACKED) {
5016 kid = cUNOPo->op_first->op_sibling;
5017 if (kid->op_type == OP_RV2GV)
5026 Perl_ck_exists(pTHX_ OP *o)
5029 if (o->op_flags & OPf_KIDS) {
5030 OP *kid = cUNOPo->op_first;
5031 if (kid->op_type == OP_ENTERSUB) {
5032 (void) ref(kid, o->op_type);
5033 if (kid->op_type != OP_RV2CV && !PL_error_count)
5034 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5036 o->op_private |= OPpEXISTS_SUB;
5038 else if (kid->op_type == OP_AELEM)
5039 o->op_flags |= OPf_SPECIAL;
5040 else if (kid->op_type != OP_HELEM)
5041 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5050 Perl_ck_gvconst(pTHX_ register OP *o)
5052 o = fold_constants(o);
5053 if (o->op_type == OP_CONST)
5060 Perl_ck_rvconst(pTHX_ register OP *o)
5062 SVOP *kid = (SVOP*)cUNOPo->op_first;
5064 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5065 if (kid->op_type == OP_CONST) {
5069 SV *kidsv = kid->op_sv;
5072 /* Is it a constant from cv_const_sv()? */
5073 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5074 SV *rsv = SvRV(kidsv);
5075 int svtype = SvTYPE(rsv);
5076 char *badtype = Nullch;
5078 switch (o->op_type) {
5080 if (svtype > SVt_PVMG)
5081 badtype = "a SCALAR";
5084 if (svtype != SVt_PVAV)
5085 badtype = "an ARRAY";
5088 if (svtype != SVt_PVHV)
5092 if (svtype != SVt_PVCV)
5097 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5100 name = SvPV(kidsv, n_a);
5101 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5102 char *badthing = Nullch;
5103 switch (o->op_type) {
5105 badthing = "a SCALAR";
5108 badthing = "an ARRAY";
5111 badthing = "a HASH";
5116 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5120 * This is a little tricky. We only want to add the symbol if we
5121 * didn't add it in the lexer. Otherwise we get duplicate strict
5122 * warnings. But if we didn't add it in the lexer, we must at
5123 * least pretend like we wanted to add it even if it existed before,
5124 * or we get possible typo warnings. OPpCONST_ENTERED says
5125 * whether the lexer already added THIS instance of this symbol.
5127 iscv = (o->op_type == OP_RV2CV) * 2;
5129 gv = gv_fetchpv(name,
5130 iscv | !(kid->op_private & OPpCONST_ENTERED),
5133 : o->op_type == OP_RV2SV
5135 : o->op_type == OP_RV2AV
5137 : o->op_type == OP_RV2HV
5140 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5142 kid->op_type = OP_GV;
5143 SvREFCNT_dec(kid->op_sv);
5145 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5146 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5147 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
5149 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
5151 kid->op_sv = SvREFCNT_inc(gv);
5153 kid->op_private = 0;
5154 kid->op_ppaddr = PL_ppaddr[OP_GV];
5161 Perl_ck_ftst(pTHX_ OP *o)
5163 I32 type = o->op_type;
5165 if (o->op_flags & OPf_REF) {
5168 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5169 SVOP *kid = (SVOP*)cUNOPo->op_first;
5171 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5173 OP *newop = newGVOP(type, OPf_REF,
5174 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5180 if ((PL_hints & HINT_FILETEST_ACCESS) &&
5181 OP_IS_FILETEST_ACCESS(o))
5182 o->op_private |= OPpFT_ACCESS;
5184 if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
5185 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
5186 o->op_private |= OPpFT_STACKED;
5190 if (type == OP_FTTTY)
5191 o = newGVOP(type, OPf_REF, PL_stdingv);
5193 o = newUNOP(type, 0, newDEFSVOP());
5199 Perl_ck_fun(pTHX_ OP *o)
5205 int type = o->op_type;
5206 register I32 oa = PL_opargs[type] >> OASHIFT;
5208 if (o->op_flags & OPf_STACKED) {
5209 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5212 return no_fh_allowed(o);
5215 if (o->op_flags & OPf_KIDS) {
5217 tokid = &cLISTOPo->op_first;
5218 kid = cLISTOPo->op_first;
5219 if (kid->op_type == OP_PUSHMARK ||
5220 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5222 tokid = &kid->op_sibling;
5223 kid = kid->op_sibling;
5225 if (!kid && PL_opargs[type] & OA_DEFGV)
5226 *tokid = kid = newDEFSVOP();
5230 sibl = kid->op_sibling;
5233 /* list seen where single (scalar) arg expected? */
5234 if (numargs == 1 && !(oa >> 4)
5235 && kid->op_type == OP_LIST && type != OP_SCALAR)
5237 return too_many_arguments(o,PL_op_desc[type]);
5250 if ((type == OP_PUSH || type == OP_UNSHIFT)
5251 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5252 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5253 "Useless use of %s with no values",
5256 if (kid->op_type == OP_CONST &&
5257 (kid->op_private & OPpCONST_BARE))
5259 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5260 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5261 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5262 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5263 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5264 "Array @%s missing the @ in argument %"IVdf" of %s()",
5265 name, (IV)numargs, PL_op_desc[type]);
5268 kid->op_sibling = sibl;
5271 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5272 bad_type(numargs, "array", PL_op_desc[type], kid);
5276 if (kid->op_type == OP_CONST &&
5277 (kid->op_private & OPpCONST_BARE))
5279 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5280 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5281 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5282 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5283 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5284 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5285 name, (IV)numargs, PL_op_desc[type]);
5288 kid->op_sibling = sibl;
5291 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5292 bad_type(numargs, "hash", PL_op_desc[type], kid);
5297 OP *newop = newUNOP(OP_NULL, 0, kid);
5298 kid->op_sibling = 0;
5300 newop->op_next = newop;
5302 kid->op_sibling = sibl;
5307 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5308 if (kid->op_type == OP_CONST &&
5309 (kid->op_private & OPpCONST_BARE))
5311 OP *newop = newGVOP(OP_GV, 0,
5312 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5314 if (!(o->op_private & 1) && /* if not unop */
5315 kid == cLISTOPo->op_last)
5316 cLISTOPo->op_last = newop;
5320 else if (kid->op_type == OP_READLINE) {
5321 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5322 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5325 I32 flags = OPf_SPECIAL;
5329 /* is this op a FH constructor? */
5330 if (is_handle_constructor(o,numargs)) {
5331 char *name = Nullch;
5335 /* Set a flag to tell rv2gv to vivify
5336 * need to "prove" flag does not mean something
5337 * else already - NI-S 1999/05/07
5340 if (kid->op_type == OP_PADSV) {
5341 name = PAD_COMPNAME_PV(kid->op_targ);
5342 /* SvCUR of a pad namesv can't be trusted
5343 * (see PL_generation), so calc its length
5349 else if (kid->op_type == OP_RV2SV
5350 && kUNOP->op_first->op_type == OP_GV)
5352 GV *gv = cGVOPx_gv(kUNOP->op_first);
5354 len = GvNAMELEN(gv);
5356 else if (kid->op_type == OP_AELEM
5357 || kid->op_type == OP_HELEM)
5362 if ((op = ((BINOP*)kid)->op_first)) {
5363 SV *tmpstr = Nullsv;
5365 kid->op_type == OP_AELEM ?
5367 if (((op->op_type == OP_RV2AV) ||
5368 (op->op_type == OP_RV2HV)) &&
5369 (op = ((UNOP*)op)->op_first) &&
5370 (op->op_type == OP_GV)) {
5371 /* packagevar $a[] or $h{} */
5372 GV *gv = cGVOPx_gv(op);
5380 else if (op->op_type == OP_PADAV
5381 || op->op_type == OP_PADHV) {
5382 /* lexicalvar $a[] or $h{} */
5384 PAD_COMPNAME_PV(op->op_targ);
5394 name = SvPV(tmpstr, len);
5399 name = "__ANONIO__";
5406 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5407 namesv = PAD_SVl(targ);
5408 (void)SvUPGRADE(namesv, SVt_PV);
5410 sv_setpvn(namesv, "$", 1);
5411 sv_catpvn(namesv, name, len);
5414 kid->op_sibling = 0;
5415 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5416 kid->op_targ = targ;
5417 kid->op_private |= priv;
5419 kid->op_sibling = sibl;
5425 mod(scalar(kid), type);
5429 tokid = &kid->op_sibling;
5430 kid = kid->op_sibling;
5432 o->op_private |= numargs;
5434 return too_many_arguments(o,OP_DESC(o));
5437 else if (PL_opargs[type] & OA_DEFGV) {
5439 return newUNOP(type, 0, newDEFSVOP());
5443 while (oa & OA_OPTIONAL)
5445 if (oa && oa != OA_LIST)
5446 return too_few_arguments(o,OP_DESC(o));
5452 Perl_ck_glob(pTHX_ OP *o)
5457 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5458 append_elem(OP_GLOB, o, newDEFSVOP());
5460 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5461 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5463 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5466 #if !defined(PERL_EXTERNAL_GLOB)
5467 /* XXX this can be tightened up and made more failsafe. */
5468 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5471 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5472 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5473 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5474 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5475 GvCV(gv) = GvCV(glob_gv);
5476 SvREFCNT_inc((SV*)GvCV(gv));
5477 GvIMPORTED_CV_on(gv);
5480 #endif /* PERL_EXTERNAL_GLOB */
5482 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5483 append_elem(OP_GLOB, o,
5484 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5485 o->op_type = OP_LIST;
5486 o->op_ppaddr = PL_ppaddr[OP_LIST];
5487 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5488 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5489 cLISTOPo->op_first->op_targ = 0;
5490 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5491 append_elem(OP_LIST, o,
5492 scalar(newUNOP(OP_RV2CV, 0,
5493 newGVOP(OP_GV, 0, gv)))));
5494 o = newUNOP(OP_NULL, 0, ck_subr(o));
5495 o->op_targ = OP_GLOB; /* hint at what it used to be */
5498 gv = newGVgen("main");
5500 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5506 Perl_ck_grep(pTHX_ OP *o)
5510 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5513 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5514 NewOp(1101, gwop, 1, LOGOP);
5516 if (o->op_flags & OPf_STACKED) {
5519 kid = cLISTOPo->op_first->op_sibling;
5520 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
5523 kid->op_next = (OP*)gwop;
5524 o->op_flags &= ~OPf_STACKED;
5526 kid = cLISTOPo->op_first->op_sibling;
5527 if (type == OP_MAPWHILE)
5534 kid = cLISTOPo->op_first->op_sibling;
5535 if (kid->op_type != OP_NULL)
5536 Perl_croak(aTHX_ "panic: ck_grep");
5537 kid = kUNOP->op_first;
5539 gwop->op_type = type;
5540 gwop->op_ppaddr = PL_ppaddr[type];
5541 gwop->op_first = listkids(o);
5542 gwop->op_flags |= OPf_KIDS;
5543 gwop->op_other = LINKLIST(kid);
5544 kid->op_next = (OP*)gwop;
5545 offset = pad_findmy("$_");
5546 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
5547 o->op_private = gwop->op_private = 0;
5548 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5551 o->op_private = gwop->op_private = OPpGREP_LEX;
5552 gwop->op_targ = o->op_targ = offset;
5555 kid = cLISTOPo->op_first->op_sibling;
5556 if (!kid || !kid->op_sibling)
5557 return too_few_arguments(o,OP_DESC(o));
5558 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5559 mod(kid, OP_GREPSTART);
5565 Perl_ck_index(pTHX_ OP *o)
5567 if (o->op_flags & OPf_KIDS) {
5568 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5570 kid = kid->op_sibling; /* get past "big" */
5571 if (kid && kid->op_type == OP_CONST)
5572 fbm_compile(((SVOP*)kid)->op_sv, 0);
5578 Perl_ck_lengthconst(pTHX_ OP *o)
5580 /* XXX length optimization goes here */
5585 Perl_ck_lfun(pTHX_ OP *o)
5587 OPCODE type = o->op_type;
5588 return modkids(ck_fun(o), type);
5592 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5594 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5595 switch (cUNOPo->op_first->op_type) {
5597 /* This is needed for
5598 if (defined %stash::)
5599 to work. Do not break Tk.
5601 break; /* Globals via GV can be undef */
5603 case OP_AASSIGN: /* Is this a good idea? */
5604 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5605 "defined(@array) is deprecated");
5606 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5607 "\t(Maybe you should just omit the defined()?)\n");
5610 /* This is needed for
5611 if (defined %stash::)
5612 to work. Do not break Tk.
5614 break; /* Globals via GV can be undef */
5616 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5617 "defined(%%hash) is deprecated");
5618 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5619 "\t(Maybe you should just omit the defined()?)\n");
5630 Perl_ck_rfun(pTHX_ OP *o)
5632 OPCODE type = o->op_type;
5633 return refkids(ck_fun(o), type);
5637 Perl_ck_listiob(pTHX_ OP *o)
5641 kid = cLISTOPo->op_first;
5644 kid = cLISTOPo->op_first;
5646 if (kid->op_type == OP_PUSHMARK)
5647 kid = kid->op_sibling;
5648 if (kid && o->op_flags & OPf_STACKED)
5649 kid = kid->op_sibling;
5650 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5651 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5652 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5653 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5654 cLISTOPo->op_first->op_sibling = kid;
5655 cLISTOPo->op_last = kid;
5656 kid = kid->op_sibling;
5661 append_elem(o->op_type, o, newDEFSVOP());
5667 Perl_ck_sassign(pTHX_ OP *o)
5669 OP *kid = cLISTOPo->op_first;
5670 /* has a disposable target? */
5671 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5672 && !(kid->op_flags & OPf_STACKED)
5673 /* Cannot steal the second time! */
5674 && !(kid->op_private & OPpTARGET_MY))
5676 OP *kkid = kid->op_sibling;
5678 /* Can just relocate the target. */
5679 if (kkid && kkid->op_type == OP_PADSV
5680 && !(kkid->op_private & OPpLVAL_INTRO))
5682 kid->op_targ = kkid->op_targ;
5684 /* Now we do not need PADSV and SASSIGN. */
5685 kid->op_sibling = o->op_sibling; /* NULL */
5686 cLISTOPo->op_first = NULL;
5689 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
5693 /* optimise C<my $x = undef> to C<my $x> */
5694 if (kid->op_type == OP_UNDEF) {
5695 OP *kkid = kid->op_sibling;
5696 if (kkid && kkid->op_type == OP_PADSV
5697 && (kkid->op_private & OPpLVAL_INTRO))
5699 cLISTOPo->op_first = NULL;
5700 kid->op_sibling = NULL;
5710 Perl_ck_match(pTHX_ OP *o)
5712 if (o->op_type != OP_QR) {
5713 I32 offset = pad_findmy("$_");
5714 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS(offset) & SVpad_OUR)) {
5715 o->op_targ = offset;
5716 o->op_private |= OPpTARGET_MY;
5719 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
5720 o->op_private |= OPpRUNTIME;
5725 Perl_ck_method(pTHX_ OP *o)
5727 OP *kid = cUNOPo->op_first;
5728 if (kid->op_type == OP_CONST) {
5729 SV* sv = kSVOP->op_sv;
5730 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
5732 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5733 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
5736 kSVOP->op_sv = Nullsv;
5738 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5747 Perl_ck_null(pTHX_ OP *o)
5753 Perl_ck_open(pTHX_ OP *o)
5755 HV *table = GvHV(PL_hintgv);
5759 svp = hv_fetch(table, "open_IN", 7, FALSE);
5761 mode = mode_from_discipline(*svp);
5762 if (mode & O_BINARY)
5763 o->op_private |= OPpOPEN_IN_RAW;
5764 else if (mode & O_TEXT)
5765 o->op_private |= OPpOPEN_IN_CRLF;
5768 svp = hv_fetch(table, "open_OUT", 8, FALSE);
5770 mode = mode_from_discipline(*svp);
5771 if (mode & O_BINARY)
5772 o->op_private |= OPpOPEN_OUT_RAW;
5773 else if (mode & O_TEXT)
5774 o->op_private |= OPpOPEN_OUT_CRLF;
5777 if (o->op_type == OP_BACKTICK)
5780 /* In case of three-arg dup open remove strictness
5781 * from the last arg if it is a bareword. */
5782 OP *first = cLISTOPx(o)->op_first; /* The pushmark. */
5783 OP *last = cLISTOPx(o)->op_last; /* The bareword. */
5787 if ((last->op_type == OP_CONST) && /* The bareword. */
5788 (last->op_private & OPpCONST_BARE) &&
5789 (last->op_private & OPpCONST_STRICT) &&
5790 (oa = first->op_sibling) && /* The fh. */
5791 (oa = oa->op_sibling) && /* The mode. */
5792 SvPOK(((SVOP*)oa)->op_sv) &&
5793 (mode = SvPVX(((SVOP*)oa)->op_sv)) &&
5794 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
5795 (last == oa->op_sibling)) /* The bareword. */
5796 last->op_private &= ~OPpCONST_STRICT;
5802 Perl_ck_repeat(pTHX_ OP *o)
5804 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5805 o->op_private |= OPpREPEAT_DOLIST;
5806 cBINOPo->op_first = force_list(cBINOPo->op_first);
5814 Perl_ck_require(pTHX_ OP *o)
5818 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
5819 SVOP *kid = (SVOP*)cUNOPo->op_first;
5821 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5823 for (s = SvPVX(kid->op_sv); *s; s++) {
5824 if (*s == ':' && s[1] == ':') {
5826 Move(s+2, s+1, strlen(s+2)+1, char);
5827 --SvCUR(kid->op_sv);
5830 if (SvREADONLY(kid->op_sv)) {
5831 SvREADONLY_off(kid->op_sv);
5832 sv_catpvn(kid->op_sv, ".pm", 3);
5833 SvREADONLY_on(kid->op_sv);
5836 sv_catpvn(kid->op_sv, ".pm", 3);
5840 /* handle override, if any */
5841 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
5842 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
5843 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
5845 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5846 OP *kid = cUNOPo->op_first;
5847 cUNOPo->op_first = 0;
5849 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5850 append_elem(OP_LIST, kid,
5851 scalar(newUNOP(OP_RV2CV, 0,
5860 Perl_ck_return(pTHX_ OP *o)
5863 if (CvLVALUE(PL_compcv)) {
5864 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5865 mod(kid, OP_LEAVESUBLV);
5872 Perl_ck_retarget(pTHX_ OP *o)
5874 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5881 Perl_ck_select(pTHX_ OP *o)
5884 if (o->op_flags & OPf_KIDS) {
5885 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5886 if (kid && kid->op_sibling) {
5887 o->op_type = OP_SSELECT;
5888 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
5890 return fold_constants(o);
5894 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5895 if (kid && kid->op_type == OP_RV2GV)
5896 kid->op_private &= ~HINT_STRICT_REFS;
5901 Perl_ck_shift(pTHX_ OP *o)
5903 I32 type = o->op_type;
5905 if (!(o->op_flags & OPf_KIDS)) {
5909 argop = newUNOP(OP_RV2AV, 0,
5910 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
5911 return newUNOP(type, 0, scalar(argop));
5913 return scalar(modkids(ck_fun(o), type));
5917 Perl_ck_sort(pTHX_ OP *o)
5921 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
5923 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5924 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
5926 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
5928 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
5930 if (kid->op_type == OP_SCOPE) {
5934 else if (kid->op_type == OP_LEAVE) {
5935 if (o->op_type == OP_SORT) {
5936 op_null(kid); /* wipe out leave */
5939 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
5940 if (k->op_next == kid)
5942 /* don't descend into loops */
5943 else if (k->op_type == OP_ENTERLOOP
5944 || k->op_type == OP_ENTERITER)
5946 k = cLOOPx(k)->op_lastop;
5951 kid->op_next = 0; /* just disconnect the leave */
5952 k = kLISTOP->op_first;
5957 if (o->op_type == OP_SORT) {
5958 /* provide scalar context for comparison function/block */
5964 o->op_flags |= OPf_SPECIAL;
5966 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
5969 firstkid = firstkid->op_sibling;
5972 /* provide list context for arguments */
5973 if (o->op_type == OP_SORT)
5980 S_simplify_sort(pTHX_ OP *o)
5982 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5986 if (!(o->op_flags & OPf_STACKED))
5988 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
5989 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
5990 kid = kUNOP->op_first; /* get past null */
5991 if (kid->op_type != OP_SCOPE)
5993 kid = kLISTOP->op_last; /* get past scope */
5994 switch(kid->op_type) {
6002 k = kid; /* remember this node*/
6003 if (kBINOP->op_first->op_type != OP_RV2SV)
6005 kid = kBINOP->op_first; /* get past cmp */
6006 if (kUNOP->op_first->op_type != OP_GV)
6008 kid = kUNOP->op_first; /* get past rv2sv */
6010 if (GvSTASH(gv) != PL_curstash)
6012 if (strEQ(GvNAME(gv), "a"))
6014 else if (strEQ(GvNAME(gv), "b"))
6019 kid = k; /* back to cmp */
6020 if (kBINOP->op_last->op_type != OP_RV2SV)
6022 kid = kBINOP->op_last; /* down to 2nd arg */
6023 if (kUNOP->op_first->op_type != OP_GV)
6025 kid = kUNOP->op_first; /* get past rv2sv */
6027 if (GvSTASH(gv) != PL_curstash
6029 ? strNE(GvNAME(gv), "a")
6030 : strNE(GvNAME(gv), "b")))
6032 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6034 o->op_private |= OPpSORT_DESCEND;
6035 if (k->op_type == OP_NCMP)
6036 o->op_private |= OPpSORT_NUMERIC;
6037 if (k->op_type == OP_I_NCMP)
6038 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6039 kid = cLISTOPo->op_first->op_sibling;
6040 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6041 op_free(kid); /* then delete it */
6045 Perl_ck_split(pTHX_ OP *o)
6049 if (o->op_flags & OPf_STACKED)
6050 return no_fh_allowed(o);
6052 kid = cLISTOPo->op_first;
6053 if (kid->op_type != OP_NULL)
6054 Perl_croak(aTHX_ "panic: ck_split");
6055 kid = kid->op_sibling;
6056 op_free(cLISTOPo->op_first);
6057 cLISTOPo->op_first = kid;
6059 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6060 cLISTOPo->op_last = kid; /* There was only one element previously */
6063 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6064 OP *sibl = kid->op_sibling;
6065 kid->op_sibling = 0;
6066 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
6067 if (cLISTOPo->op_first == cLISTOPo->op_last)
6068 cLISTOPo->op_last = kid;
6069 cLISTOPo->op_first = kid;
6070 kid->op_sibling = sibl;
6073 kid->op_type = OP_PUSHRE;
6074 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6076 if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
6077 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
6078 "Use of /g modifier is meaningless in split");
6081 if (!kid->op_sibling)
6082 append_elem(OP_SPLIT, o, newDEFSVOP());
6084 kid = kid->op_sibling;
6087 if (!kid->op_sibling)
6088 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6090 kid = kid->op_sibling;
6093 if (kid->op_sibling)
6094 return too_many_arguments(o,OP_DESC(o));
6100 Perl_ck_join(pTHX_ OP *o)
6102 if (ckWARN(WARN_SYNTAX)) {
6103 OP *kid = cLISTOPo->op_first->op_sibling;
6104 if (kid && kid->op_type == OP_MATCH) {
6105 char *pmstr = "STRING";
6106 if (PM_GETRE(kPMOP))
6107 pmstr = PM_GETRE(kPMOP)->precomp;
6108 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6109 "/%s/ should probably be written as \"%s\"",
6117 Perl_ck_subr(pTHX_ OP *o)
6119 OP *prev = ((cUNOPo->op_first->op_sibling)
6120 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6121 OP *o2 = prev->op_sibling;
6128 I32 contextclass = 0;
6133 o->op_private |= OPpENTERSUB_HASTARG;
6134 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6135 if (cvop->op_type == OP_RV2CV) {
6137 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6138 op_null(cvop); /* disable rv2cv */
6139 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6140 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6141 GV *gv = cGVOPx_gv(tmpop);
6144 tmpop->op_private |= OPpEARLY_CV;
6147 namegv = CvANON(cv) ? gv : CvGV(cv);
6148 proto = SvPV((SV*)cv, n_a);
6150 if (CvASSERTION(cv)) {
6151 if (PL_hints & HINT_ASSERTING) {
6152 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
6153 o->op_private |= OPpENTERSUB_DB;
6157 if (ckWARN(WARN_ASSERTIONS) && !(PL_hints & HINT_ASSERTIONSSEEN)) {
6158 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
6159 "Impossible to activate assertion call");
6166 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6167 if (o2->op_type == OP_CONST)
6168 o2->op_private &= ~OPpCONST_STRICT;
6169 else if (o2->op_type == OP_LIST) {
6170 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6171 if (o && o->op_type == OP_CONST)
6172 o->op_private &= ~OPpCONST_STRICT;
6175 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6176 if (PERLDB_SUB && PL_curstash != PL_debstash)
6177 o->op_private |= OPpENTERSUB_DB;
6178 while (o2 != cvop) {
6182 return too_many_arguments(o, gv_ename(namegv));
6200 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6202 arg == 1 ? "block or sub {}" : "sub {}",
6203 gv_ename(namegv), o2);
6206 /* '*' allows any scalar type, including bareword */
6209 if (o2->op_type == OP_RV2GV)
6210 goto wrapref; /* autoconvert GLOB -> GLOBref */
6211 else if (o2->op_type == OP_CONST)
6212 o2->op_private &= ~OPpCONST_STRICT;
6213 else if (o2->op_type == OP_ENTERSUB) {
6214 /* accidental subroutine, revert to bareword */
6215 OP *gvop = ((UNOP*)o2)->op_first;
6216 if (gvop && gvop->op_type == OP_NULL) {
6217 gvop = ((UNOP*)gvop)->op_first;
6219 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6222 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6223 (gvop = ((UNOP*)gvop)->op_first) &&
6224 gvop->op_type == OP_GV)
6226 GV *gv = cGVOPx_gv(gvop);
6227 OP *sibling = o2->op_sibling;
6228 SV *n = newSVpvn("",0);
6230 gv_fullname3(n, gv, "");
6231 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6232 sv_chop(n, SvPVX(n)+6);
6233 o2 = newSVOP(OP_CONST, 0, n);
6234 prev->op_sibling = o2;
6235 o2->op_sibling = sibling;
6251 if (contextclass++ == 0) {
6252 e = strchr(proto, ']');
6253 if (!e || e == proto)
6266 while (*--p != '[');
6267 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6268 gv_ename(namegv), o2);
6274 if (o2->op_type == OP_RV2GV)
6277 bad_type(arg, "symbol", gv_ename(namegv), o2);
6280 if (o2->op_type == OP_ENTERSUB)
6283 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6286 if (o2->op_type == OP_RV2SV ||
6287 o2->op_type == OP_PADSV ||
6288 o2->op_type == OP_HELEM ||
6289 o2->op_type == OP_AELEM ||
6290 o2->op_type == OP_THREADSV)
6293 bad_type(arg, "scalar", gv_ename(namegv), o2);
6296 if (o2->op_type == OP_RV2AV ||
6297 o2->op_type == OP_PADAV)
6300 bad_type(arg, "array", gv_ename(namegv), o2);
6303 if (o2->op_type == OP_RV2HV ||
6304 o2->op_type == OP_PADHV)
6307 bad_type(arg, "hash", gv_ename(namegv), o2);
6312 OP* sib = kid->op_sibling;
6313 kid->op_sibling = 0;
6314 o2 = newUNOP(OP_REFGEN, 0, kid);
6315 o2->op_sibling = sib;
6316 prev->op_sibling = o2;
6318 if (contextclass && e) {
6333 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6334 gv_ename(namegv), cv);
6339 mod(o2, OP_ENTERSUB);
6341 o2 = o2->op_sibling;
6343 if (proto && !optional &&
6344 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6345 return too_few_arguments(o, gv_ename(namegv));
6348 o=newSVOP(OP_CONST, 0, newSViv(0));
6354 Perl_ck_svconst(pTHX_ OP *o)
6356 SvREADONLY_on(cSVOPo->op_sv);
6361 Perl_ck_trunc(pTHX_ OP *o)
6363 if (o->op_flags & OPf_KIDS) {
6364 SVOP *kid = (SVOP*)cUNOPo->op_first;
6366 if (kid->op_type == OP_NULL)
6367 kid = (SVOP*)kid->op_sibling;
6368 if (kid && kid->op_type == OP_CONST &&
6369 (kid->op_private & OPpCONST_BARE))
6371 o->op_flags |= OPf_SPECIAL;
6372 kid->op_private &= ~OPpCONST_STRICT;
6379 Perl_ck_unpack(pTHX_ OP *o)
6381 OP *kid = cLISTOPo->op_first;
6382 if (kid->op_sibling) {
6383 kid = kid->op_sibling;
6384 if (!kid->op_sibling)
6385 kid->op_sibling = newDEFSVOP();
6391 Perl_ck_substr(pTHX_ OP *o)
6394 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6395 OP *kid = cLISTOPo->op_first;
6397 if (kid->op_type == OP_NULL)
6398 kid = kid->op_sibling;
6400 kid->op_flags |= OPf_MOD;
6406 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6409 Perl_peep(pTHX_ register OP *o)
6411 register OP* oldop = 0;
6413 if (!o || o->op_opt)
6417 SAVEVPTR(PL_curcop);
6418 for (; o; o = o->op_next) {
6422 switch (o->op_type) {
6426 PL_curcop = ((COP*)o); /* for warnings */
6431 if (cSVOPo->op_private & OPpCONST_STRICT)
6432 no_bareword_allowed(o);
6434 case OP_METHOD_NAMED:
6435 /* Relocate sv to the pad for thread safety.
6436 * Despite being a "constant", the SV is written to,
6437 * for reference counts, sv_upgrade() etc. */
6439 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6440 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6441 /* If op_sv is already a PADTMP then it is being used by
6442 * some pad, so make a copy. */
6443 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6444 SvREADONLY_on(PAD_SVl(ix));
6445 SvREFCNT_dec(cSVOPo->op_sv);
6448 SvREFCNT_dec(PAD_SVl(ix));
6449 SvPADTMP_on(cSVOPo->op_sv);
6450 PAD_SETSV(ix, cSVOPo->op_sv);
6451 /* XXX I don't know how this isn't readonly already. */
6452 SvREADONLY_on(PAD_SVl(ix));
6454 cSVOPo->op_sv = Nullsv;
6462 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6463 if (o->op_next->op_private & OPpTARGET_MY) {
6464 if (o->op_flags & OPf_STACKED) /* chained concats */
6465 goto ignore_optimization;
6467 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6468 o->op_targ = o->op_next->op_targ;
6469 o->op_next->op_targ = 0;
6470 o->op_private |= OPpTARGET_MY;
6473 op_null(o->op_next);
6475 ignore_optimization:
6479 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6481 break; /* Scalar stub must produce undef. List stub is noop */
6485 if (o->op_targ == OP_NEXTSTATE
6486 || o->op_targ == OP_DBSTATE
6487 || o->op_targ == OP_SETSTATE)
6489 PL_curcop = ((COP*)o);
6491 /* XXX: We avoid setting op_seq here to prevent later calls
6492 to peep() from mistakenly concluding that optimisation
6493 has already occurred. This doesn't fix the real problem,
6494 though (See 20010220.007). AMS 20010719 */
6495 /* op_seq functionality is now replaced by op_opt */
6496 if (oldop && o->op_next) {
6497 oldop->op_next = o->op_next;
6505 if (oldop && o->op_next) {
6506 oldop->op_next = o->op_next;
6514 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
6515 OP* pop = (o->op_type == OP_PADAV) ?
6516 o->op_next : o->op_next->op_next;
6518 if (pop && pop->op_type == OP_CONST &&
6519 ((PL_op = pop->op_next)) &&
6520 pop->op_next->op_type == OP_AELEM &&
6521 !(pop->op_next->op_private &
6522 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6523 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6528 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
6529 no_bareword_allowed(pop);
6530 if (o->op_type == OP_GV)
6531 op_null(o->op_next);
6532 op_null(pop->op_next);
6534 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6535 o->op_next = pop->op_next->op_next;
6536 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6537 o->op_private = (U8)i;
6538 if (o->op_type == OP_GV) {
6543 o->op_flags |= OPf_SPECIAL;
6544 o->op_type = OP_AELEMFAST;
6550 if (o->op_next->op_type == OP_RV2SV) {
6551 if (!(o->op_next->op_private & OPpDEREF)) {
6552 op_null(o->op_next);
6553 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6555 o->op_next = o->op_next->op_next;
6556 o->op_type = OP_GVSV;
6557 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6560 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6562 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6563 /* XXX could check prototype here instead of just carping */
6564 SV *sv = sv_newmortal();
6565 gv_efullname3(sv, gv, Nullch);
6566 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6567 "%"SVf"() called too early to check prototype",
6571 else if (o->op_next->op_type == OP_READLINE
6572 && o->op_next->op_next->op_type == OP_CONCAT
6573 && (o->op_next->op_next->op_flags & OPf_STACKED))
6575 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6576 o->op_type = OP_RCATLINE;
6577 o->op_flags |= OPf_STACKED;
6578 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6579 op_null(o->op_next->op_next);
6580 op_null(o->op_next);
6597 while (cLOGOP->op_other->op_type == OP_NULL)
6598 cLOGOP->op_other = cLOGOP->op_other->op_next;
6599 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6605 while (cLOOP->op_redoop->op_type == OP_NULL)
6606 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6607 peep(cLOOP->op_redoop);
6608 while (cLOOP->op_nextop->op_type == OP_NULL)
6609 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6610 peep(cLOOP->op_nextop);
6611 while (cLOOP->op_lastop->op_type == OP_NULL)
6612 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6613 peep(cLOOP->op_lastop);
6620 while (cPMOP->op_pmreplstart &&
6621 cPMOP->op_pmreplstart->op_type == OP_NULL)
6622 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6623 peep(cPMOP->op_pmreplstart);
6628 if (ckWARN(WARN_SYNTAX) && o->op_next
6629 && o->op_next->op_type == OP_NEXTSTATE) {
6630 if (o->op_next->op_sibling &&
6631 o->op_next->op_sibling->op_type != OP_EXIT &&
6632 o->op_next->op_sibling->op_type != OP_WARN &&
6633 o->op_next->op_sibling->op_type != OP_DIE) {
6634 line_t oldline = CopLINE(PL_curcop);
6636 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6637 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6638 "Statement unlikely to be reached");
6639 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6640 "\t(Maybe you meant system() when you said exec()?)\n");
6641 CopLINE_set(PL_curcop, oldline);
6656 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6659 /* Make the CONST have a shared SV */
6660 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6661 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6662 key = SvPV(sv, keylen);
6663 lexname = newSVpvn_share(key,
6664 SvUTF8(sv) ? -(I32)keylen : keylen,
6670 if ((o->op_private & (OPpLVAL_INTRO)))
6673 rop = (UNOP*)((BINOP*)o)->op_first;
6674 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6676 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6677 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6679 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6680 if (!fields || !GvHV(*fields))
6682 key = SvPV(*svp, keylen);
6683 if (!hv_fetch(GvHV(*fields), key,
6684 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
6686 Perl_croak(aTHX_ "No such class field \"%s\" "
6687 "in variable %s of type %s",
6688 key, SvPV_nolen(lexname), HvNAME(SvSTASH(lexname)));
6701 SVOP *first_key_op, *key_op;
6703 if ((o->op_private & (OPpLVAL_INTRO))
6704 /* I bet there's always a pushmark... */
6705 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6706 /* hmmm, no optimization if list contains only one key. */
6708 rop = (UNOP*)((LISTOP*)o)->op_last;
6709 if (rop->op_type != OP_RV2HV)
6711 if (rop->op_first->op_type == OP_PADSV)
6712 /* @$hash{qw(keys here)} */
6713 rop = (UNOP*)rop->op_first;
6715 /* @{$hash}{qw(keys here)} */
6716 if (rop->op_first->op_type == OP_SCOPE
6717 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
6719 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
6725 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
6726 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6728 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6729 if (!fields || !GvHV(*fields))
6731 /* Again guessing that the pushmark can be jumped over.... */
6732 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
6733 ->op_first->op_sibling;
6734 for (key_op = first_key_op; key_op;
6735 key_op = (SVOP*)key_op->op_sibling) {
6736 if (key_op->op_type != OP_CONST)
6738 svp = cSVOPx_svp(key_op);
6739 key = SvPV(*svp, keylen);
6740 if (!hv_fetch(GvHV(*fields), key,
6741 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
6743 Perl_croak(aTHX_ "No such class field \"%s\" "
6744 "in variable %s of type %s",
6745 key, SvPV_nolen(lexname), HvNAME(SvSTASH(lexname)));
6752 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
6756 /* check that RHS of sort is a single plain array */
6757 oright = cUNOPo->op_first;
6758 if (!oright || oright->op_type != OP_PUSHMARK)
6761 /* reverse sort ... can be optimised. */
6762 if (!cUNOPo->op_sibling) {
6763 /* Nothing follows us on the list. */
6764 OP *reverse = o->op_next;
6766 if (reverse->op_type == OP_REVERSE &&
6767 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
6768 OP *pushmark = cUNOPx(reverse)->op_first;
6769 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
6770 && (cUNOPx(pushmark)->op_sibling == o)) {
6771 /* reverse -> pushmark -> sort */
6772 o->op_private |= OPpSORT_REVERSE;
6774 pushmark->op_next = oright->op_next;
6780 /* make @a = sort @a act in-place */
6784 oright = cUNOPx(oright)->op_sibling;
6787 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
6788 oright = cUNOPx(oright)->op_sibling;
6792 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
6793 || oright->op_next != o
6794 || (oright->op_private & OPpLVAL_INTRO)
6798 /* o2 follows the chain of op_nexts through the LHS of the
6799 * assign (if any) to the aassign op itself */
6801 if (!o2 || o2->op_type != OP_NULL)
6804 if (!o2 || o2->op_type != OP_PUSHMARK)
6807 if (o2 && o2->op_type == OP_GV)
6810 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
6811 || (o2->op_private & OPpLVAL_INTRO)
6816 if (!o2 || o2->op_type != OP_NULL)
6819 if (!o2 || o2->op_type != OP_AASSIGN
6820 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
6823 /* check that the sort is the first arg on RHS of assign */
6825 o2 = cUNOPx(o2)->op_first;
6826 if (!o2 || o2->op_type != OP_NULL)
6828 o2 = cUNOPx(o2)->op_first;
6829 if (!o2 || o2->op_type != OP_PUSHMARK)
6831 if (o2->op_sibling != o)
6834 /* check the array is the same on both sides */
6835 if (oleft->op_type == OP_RV2AV) {
6836 if (oright->op_type != OP_RV2AV
6837 || !cUNOPx(oright)->op_first
6838 || cUNOPx(oright)->op_first->op_type != OP_GV
6839 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
6840 cGVOPx_gv(cUNOPx(oright)->op_first)
6844 else if (oright->op_type != OP_PADAV
6845 || oright->op_targ != oleft->op_targ
6849 /* transfer MODishness etc from LHS arg to RHS arg */
6850 oright->op_flags = oleft->op_flags;
6851 o->op_private |= OPpSORT_INPLACE;
6853 /* excise push->gv->rv2av->null->aassign */
6854 o2 = o->op_next->op_next;
6855 op_null(o2); /* PUSHMARK */
6857 if (o2->op_type == OP_GV) {
6858 op_null(o2); /* GV */
6861 op_null(o2); /* RV2AV or PADAV */
6862 o2 = o2->op_next->op_next;
6863 op_null(o2); /* AASSIGN */
6865 o->op_next = o2->op_next;
6871 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
6873 LISTOP *enter, *exlist;
6876 enter = (LISTOP *) o->op_next;
6879 if (enter->op_type == OP_NULL) {
6880 enter = (LISTOP *) enter->op_next;
6884 /* for $a (...) will have OP_GV then OP_RV2GV here.
6885 for (...) just has an OP_GV. */
6886 if (enter->op_type == OP_GV) {
6887 gvop = (OP *) enter;
6888 enter = (LISTOP *) enter->op_next;
6891 if (enter->op_type == OP_RV2GV) {
6892 enter = (LISTOP *) enter->op_next;
6898 if (enter->op_type != OP_ENTERITER)
6901 iter = enter->op_next;
6902 if (!iter || iter->op_type != OP_ITER)
6905 expushmark = enter->op_first;
6906 if (!expushmark || expushmark->op_type != OP_NULL
6907 || expushmark->op_targ != OP_PUSHMARK)
6910 exlist = (LISTOP *) expushmark->op_sibling;
6911 if (!exlist || exlist->op_type != OP_NULL
6912 || exlist->op_targ != OP_LIST)
6915 if (exlist->op_last != o) {
6916 /* Mmm. Was expecting to point back to this op. */
6919 theirmark = exlist->op_first;
6920 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
6923 if (theirmark->op_sibling != o) {
6924 /* There's something between the mark and the reverse, eg
6925 for (1, reverse (...))
6930 ourmark = ((LISTOP *)o)->op_first;
6931 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
6934 ourlast = ((LISTOP *)o)->op_last;
6935 if (!ourlast || ourlast->op_next != o)
6938 rv2av = ourmark->op_sibling;
6939 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
6940 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
6941 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
6942 /* We're just reversing a single array. */
6943 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
6944 enter->op_flags |= OPf_STACKED;
6947 /* We don't have control over who points to theirmark, so sacrifice
6949 theirmark->op_next = ourmark->op_next;
6950 theirmark->op_flags = ourmark->op_flags;
6951 ourlast->op_next = gvop ? gvop : (OP *) enter;
6954 enter->op_private |= OPpITER_REVERSED;
6955 iter->op_private |= OPpITER_REVERSED;
6971 char* Perl_custom_op_name(pTHX_ OP* o)
6973 IV index = PTR2IV(o->op_ppaddr);
6977 if (!PL_custom_op_names) /* This probably shouldn't happen */
6978 return PL_op_name[OP_CUSTOM];
6980 keysv = sv_2mortal(newSViv(index));
6982 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
6984 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
6986 return SvPV_nolen(HeVAL(he));
6989 char* Perl_custom_op_desc(pTHX_ OP* o)
6991 IV index = PTR2IV(o->op_ppaddr);
6995 if (!PL_custom_op_descs)
6996 return PL_op_desc[OP_CUSTOM];
6998 keysv = sv_2mortal(newSViv(index));
7000 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7002 return PL_op_desc[OP_CUSTOM];
7004 return SvPV_nolen(HeVAL(he));
7010 /* Efficient sub that returns a constant scalar value. */
7012 const_sv_xsub(pTHX_ CV* cv)
7017 Perl_croak(aTHX_ "usage: %s::%s()",
7018 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7022 ST(0) = (SV*)XSANY.any_ptr;