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, Nullop));
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);
2664 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
2668 I32 repl_has_vars = 0;
2670 if (o->op_type == OP_TRANS)
2671 return pmtrans(o, expr, repl);
2673 PL_hints |= HINT_BLOCK_SCOPE;
2676 if (expr->op_type == OP_CONST) {
2678 SV *pat = ((SVOP*)expr)->op_sv;
2679 char *p = SvPV(pat, plen);
2680 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
2681 sv_setpvn(pat, "\\s+", 3);
2682 p = SvPV(pat, plen);
2683 pm->op_pmflags |= PMf_SKIPWHITE;
2686 pm->op_pmdynflags |= PMdf_UTF8;
2687 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
2688 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
2689 pm->op_pmflags |= PMf_WHITE;
2693 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2694 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2696 : OP_REGCMAYBE),0,expr);
2698 NewOp(1101, rcop, 1, LOGOP);
2699 rcop->op_type = OP_REGCOMP;
2700 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2701 rcop->op_first = scalar(expr);
2702 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
2703 ? (OPf_SPECIAL | OPf_KIDS)
2705 rcop->op_private = 1;
2707 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
2710 /* establish postfix order */
2711 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2713 rcop->op_next = expr;
2714 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2717 rcop->op_next = LINKLIST(expr);
2718 expr->op_next = (OP*)rcop;
2721 prepend_elem(o->op_type, scalar((OP*)rcop), o);
2726 if (pm->op_pmflags & PMf_EVAL) {
2728 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
2729 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
2731 else if (repl->op_type == OP_CONST)
2735 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
2736 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
2737 if (curop->op_type == OP_GV) {
2738 GV *gv = cGVOPx_gv(curop);
2740 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
2743 else if (curop->op_type == OP_RV2CV)
2745 else if (curop->op_type == OP_RV2SV ||
2746 curop->op_type == OP_RV2AV ||
2747 curop->op_type == OP_RV2HV ||
2748 curop->op_type == OP_RV2GV) {
2749 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2752 else if (curop->op_type == OP_PADSV ||
2753 curop->op_type == OP_PADAV ||
2754 curop->op_type == OP_PADHV ||
2755 curop->op_type == OP_PADANY) {
2758 else if (curop->op_type == OP_PUSHRE)
2759 ; /* Okay here, dangerous in newASSIGNOP */
2769 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
2770 pm->op_pmflags |= PMf_CONST; /* const for long enough */
2771 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
2772 prepend_elem(o->op_type, scalar(repl), o);
2775 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
2776 pm->op_pmflags |= PMf_MAYBE_CONST;
2777 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2779 NewOp(1101, rcop, 1, LOGOP);
2780 rcop->op_type = OP_SUBSTCONT;
2781 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
2782 rcop->op_first = scalar(repl);
2783 rcop->op_flags |= OPf_KIDS;
2784 rcop->op_private = 1;
2787 /* establish postfix order */
2788 rcop->op_next = LINKLIST(repl);
2789 repl->op_next = (OP*)rcop;
2791 pm->op_pmreplroot = scalar((OP*)rcop);
2792 pm->op_pmreplstart = LINKLIST(rcop);
2801 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
2804 NewOp(1101, svop, 1, SVOP);
2805 svop->op_type = (OPCODE)type;
2806 svop->op_ppaddr = PL_ppaddr[type];
2808 svop->op_next = (OP*)svop;
2809 svop->op_flags = (U8)flags;
2810 if (PL_opargs[type] & OA_RETSCALAR)
2812 if (PL_opargs[type] & OA_TARGET)
2813 svop->op_targ = pad_alloc(type, SVs_PADTMP);
2814 return CHECKOP(type, svop);
2818 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2821 NewOp(1101, padop, 1, PADOP);
2822 padop->op_type = (OPCODE)type;
2823 padop->op_ppaddr = PL_ppaddr[type];
2824 padop->op_padix = pad_alloc(type, SVs_PADTMP);
2825 SvREFCNT_dec(PAD_SVl(padop->op_padix));
2826 PAD_SETSV(padop->op_padix, sv);
2829 padop->op_next = (OP*)padop;
2830 padop->op_flags = (U8)flags;
2831 if (PL_opargs[type] & OA_RETSCALAR)
2833 if (PL_opargs[type] & OA_TARGET)
2834 padop->op_targ = pad_alloc(type, SVs_PADTMP);
2835 return CHECKOP(type, padop);
2839 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
2844 return newPADOP(type, flags, SvREFCNT_inc(gv));
2846 return newSVOP(type, flags, SvREFCNT_inc(gv));
2851 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
2854 NewOp(1101, pvop, 1, PVOP);
2855 pvop->op_type = (OPCODE)type;
2856 pvop->op_ppaddr = PL_ppaddr[type];
2858 pvop->op_next = (OP*)pvop;
2859 pvop->op_flags = (U8)flags;
2860 if (PL_opargs[type] & OA_RETSCALAR)
2862 if (PL_opargs[type] & OA_TARGET)
2863 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
2864 return CHECKOP(type, pvop);
2868 Perl_package(pTHX_ OP *o)
2873 save_hptr(&PL_curstash);
2874 save_item(PL_curstname);
2876 name = SvPV(cSVOPo->op_sv, len);
2877 PL_curstash = gv_stashpvn(name, len, TRUE);
2878 sv_setpvn(PL_curstname, name, len);
2881 PL_hints |= HINT_BLOCK_SCOPE;
2882 PL_copline = NOLINE;
2887 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
2893 if (idop->op_type != OP_CONST)
2894 Perl_croak(aTHX_ "Module name must be constant");
2898 if (version != Nullop) {
2899 SV *vesv = ((SVOP*)version)->op_sv;
2901 if (arg == Nullop && !SvNIOKp(vesv)) {
2908 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
2909 Perl_croak(aTHX_ "Version number must be constant number");
2911 /* Make copy of idop so we don't free it twice */
2912 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
2914 /* Fake up a method call to VERSION */
2915 meth = newSVpvn("VERSION",7);
2916 sv_upgrade(meth, SVt_PVIV);
2917 (void)SvIOK_on(meth);
2918 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
2919 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2920 append_elem(OP_LIST,
2921 prepend_elem(OP_LIST, pack, list(version)),
2922 newSVOP(OP_METHOD_NAMED, 0, meth)));
2926 /* Fake up an import/unimport */
2927 if (arg && arg->op_type == OP_STUB)
2928 imop = arg; /* no import on explicit () */
2929 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
2930 imop = Nullop; /* use 5.0; */
2935 /* Make copy of idop so we don't free it twice */
2936 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
2938 /* Fake up a method call to import/unimport */
2939 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);
2940 (void)SvUPGRADE(meth, SVt_PVIV);
2941 (void)SvIOK_on(meth);
2942 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
2943 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2944 append_elem(OP_LIST,
2945 prepend_elem(OP_LIST, pack, list(arg)),
2946 newSVOP(OP_METHOD_NAMED, 0, meth)));
2949 /* Fake up the BEGIN {}, which does its thing immediately. */
2951 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
2954 append_elem(OP_LINESEQ,
2955 append_elem(OP_LINESEQ,
2956 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, idop)),
2957 newSTATEOP(0, Nullch, veop)),
2958 newSTATEOP(0, Nullch, imop) ));
2960 /* The "did you use incorrect case?" warning used to be here.
2961 * The problem is that on case-insensitive filesystems one
2962 * might get false positives for "use" (and "require"):
2963 * "use Strict" or "require CARP" will work. This causes
2964 * portability problems for the script: in case-strict
2965 * filesystems the script will stop working.
2967 * The "incorrect case" warning checked whether "use Foo"
2968 * imported "Foo" to your namespace, but that is wrong, too:
2969 * there is no requirement nor promise in the language that
2970 * a Foo.pm should or would contain anything in package "Foo".
2972 * There is very little Configure-wise that can be done, either:
2973 * the case-sensitivity of the build filesystem of Perl does not
2974 * help in guessing the case-sensitivity of the runtime environment.
2977 PL_hints |= HINT_BLOCK_SCOPE;
2978 PL_copline = NOLINE;
2980 PL_cop_seqmax++; /* Purely for B::*'s benefit */
2984 =head1 Embedding Functions
2986 =for apidoc load_module
2988 Loads the module whose name is pointed to by the string part of name.
2989 Note that the actual module name, not its filename, should be given.
2990 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
2991 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
2992 (or 0 for no flags). ver, if specified, provides version semantics
2993 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
2994 arguments can be used to specify arguments to the module's import()
2995 method, similar to C<use Foo::Bar VERSION LIST>.
3000 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3003 va_start(args, ver);
3004 vload_module(flags, name, ver, &args);
3008 #ifdef PERL_IMPLICIT_CONTEXT
3010 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3014 va_start(args, ver);
3015 vload_module(flags, name, ver, &args);
3021 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3023 OP *modname, *veop, *imop;
3025 modname = newSVOP(OP_CONST, 0, name);
3026 modname->op_private |= OPpCONST_BARE;
3028 veop = newSVOP(OP_CONST, 0, ver);
3032 if (flags & PERL_LOADMOD_NOIMPORT) {
3033 imop = sawparens(newNULLLIST());
3035 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3036 imop = va_arg(*args, OP*);
3041 sv = va_arg(*args, SV*);
3043 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3044 sv = va_arg(*args, SV*);
3048 line_t ocopline = PL_copline;
3049 COP *ocurcop = PL_curcop;
3050 int oexpect = PL_expect;
3052 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3053 veop, modname, imop);
3054 PL_expect = oexpect;
3055 PL_copline = ocopline;
3056 PL_curcop = ocurcop;
3061 Perl_dofile(pTHX_ OP *term)
3066 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3067 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
3068 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3070 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3071 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3072 append_elem(OP_LIST, term,
3073 scalar(newUNOP(OP_RV2CV, 0,
3078 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3084 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3086 return newBINOP(OP_LSLICE, flags,
3087 list(force_list(subscript)),
3088 list(force_list(listval)) );
3092 S_list_assignment(pTHX_ register OP *o)
3097 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3098 o = cUNOPo->op_first;
3100 if (o->op_type == OP_COND_EXPR) {
3101 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3102 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3107 yyerror("Assignment to both a list and a scalar");
3111 if (o->op_type == OP_LIST &&
3112 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3113 o->op_private & OPpLVAL_INTRO)
3116 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3117 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3118 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3121 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3124 if (o->op_type == OP_RV2SV)
3131 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3136 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3137 return newLOGOP(optype, 0,
3138 mod(scalar(left), optype),
3139 newUNOP(OP_SASSIGN, 0, scalar(right)));
3142 return newBINOP(optype, OPf_STACKED,
3143 mod(scalar(left), optype), scalar(right));
3147 if (list_assignment(left)) {
3151 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3152 left = mod(left, OP_AASSIGN);
3160 /* optimise C<my @x = ()> to C<my @x>, and likewise for hashes */
3161 if ((left->op_type == OP_PADAV || left->op_type == OP_PADHV)
3162 && right->op_type == OP_STUB
3163 && (left->op_private & OPpLVAL_INTRO))
3166 left->op_flags &= ~(OPf_REF|OPf_SPECIAL);
3169 curop = list(force_list(left));
3170 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3171 o->op_private = (U8)(0 | (flags >> 8));
3173 /* PL_generation sorcery:
3174 * an assignment like ($a,$b) = ($c,$d) is easier than
3175 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3176 * To detect whether there are common vars, the global var
3177 * PL_generation is incremented for each assign op we compile.
3178 * Then, while compiling the assign op, we run through all the
3179 * variables on both sides of the assignment, setting a spare slot
3180 * in each of them to PL_generation. If any of them already have
3181 * that value, we know we've got commonality. We could use a
3182 * single bit marker, but then we'd have to make 2 passes, first
3183 * to clear the flag, then to test and set it. To find somewhere
3184 * to store these values, evil chicanery is done with SvCUR().
3187 if (!(left->op_private & OPpLVAL_INTRO)) {
3190 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3191 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3192 if (curop->op_type == OP_GV) {
3193 GV *gv = cGVOPx_gv(curop);
3194 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3196 SvCUR(gv) = PL_generation;
3198 else if (curop->op_type == OP_PADSV ||
3199 curop->op_type == OP_PADAV ||
3200 curop->op_type == OP_PADHV ||
3201 curop->op_type == OP_PADANY)
3203 if (PAD_COMPNAME_GEN(curop->op_targ)
3204 == (STRLEN)PL_generation)
3206 PAD_COMPNAME_GEN(curop->op_targ)
3210 else if (curop->op_type == OP_RV2CV)
3212 else if (curop->op_type == OP_RV2SV ||
3213 curop->op_type == OP_RV2AV ||
3214 curop->op_type == OP_RV2HV ||
3215 curop->op_type == OP_RV2GV) {
3216 if (lastop->op_type != OP_GV) /* funny deref? */
3219 else if (curop->op_type == OP_PUSHRE) {
3220 if (((PMOP*)curop)->op_pmreplroot) {
3222 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3223 ((PMOP*)curop)->op_pmreplroot));
3225 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3227 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3229 SvCUR(gv) = PL_generation;
3238 o->op_private |= OPpASSIGN_COMMON;
3240 if (right && right->op_type == OP_SPLIT) {
3242 if ((tmpop = ((LISTOP*)right)->op_first) &&
3243 tmpop->op_type == OP_PUSHRE)
3245 PMOP *pm = (PMOP*)tmpop;
3246 if (left->op_type == OP_RV2AV &&
3247 !(left->op_private & OPpLVAL_INTRO) &&
3248 !(o->op_private & OPpASSIGN_COMMON) )
3250 tmpop = ((UNOP*)left)->op_first;
3251 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3253 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3254 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3256 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3257 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3259 pm->op_pmflags |= PMf_ONCE;
3260 tmpop = cUNOPo->op_first; /* to list (nulled) */
3261 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3262 tmpop->op_sibling = Nullop; /* don't free split */
3263 right->op_next = tmpop->op_next; /* fix starting loc */
3264 op_free(o); /* blow off assign */
3265 right->op_flags &= ~OPf_WANT;
3266 /* "I don't know and I don't care." */
3271 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3272 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3274 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3276 sv_setiv(sv, PL_modcount+1);
3284 right = newOP(OP_UNDEF, 0);
3285 if (right->op_type == OP_READLINE) {
3286 right->op_flags |= OPf_STACKED;
3287 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3290 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3291 o = newBINOP(OP_SASSIGN, flags,
3292 scalar(right), mod(scalar(left), OP_SASSIGN) );
3304 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3306 U32 seq = intro_my();
3309 NewOp(1101, cop, 1, COP);
3310 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3311 cop->op_type = OP_DBSTATE;
3312 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3315 cop->op_type = OP_NEXTSTATE;
3316 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3318 cop->op_flags = (U8)flags;
3319 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3321 cop->op_private |= NATIVE_HINTS;
3323 PL_compiling.op_private = cop->op_private;
3324 cop->op_next = (OP*)cop;
3327 cop->cop_label = label;
3328 PL_hints |= HINT_BLOCK_SCOPE;
3331 cop->cop_arybase = PL_curcop->cop_arybase;
3332 if (specialWARN(PL_curcop->cop_warnings))
3333 cop->cop_warnings = PL_curcop->cop_warnings ;
3335 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3336 if (specialCopIO(PL_curcop->cop_io))
3337 cop->cop_io = PL_curcop->cop_io;
3339 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3342 if (PL_copline == NOLINE)
3343 CopLINE_set(cop, CopLINE(PL_curcop));
3345 CopLINE_set(cop, PL_copline);
3346 PL_copline = NOLINE;
3349 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3351 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3353 CopSTASH_set(cop, PL_curstash);
3355 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3356 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3357 if (svp && *svp != &PL_sv_undef ) {
3358 (void)SvIOK_on(*svp);
3359 SvIVX(*svp) = PTR2IV(cop);
3363 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3368 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3370 return new_logop(type, flags, &first, &other);
3374 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3378 OP *first = *firstp;
3379 OP *other = *otherp;
3381 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3382 return newBINOP(type, flags, scalar(first), scalar(other));
3384 scalarboolean(first);
3385 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3386 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3387 if (type == OP_AND || type == OP_OR) {
3393 first = *firstp = cUNOPo->op_first;
3395 first->op_next = o->op_next;
3396 cUNOPo->op_first = Nullop;
3400 if (first->op_type == OP_CONST) {
3401 if (first->op_private & OPpCONST_STRICT)
3402 no_bareword_allowed(first);
3403 else if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3404 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3405 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
3406 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
3407 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
3410 if (other->op_type == OP_CONST)
3411 other->op_private |= OPpCONST_SHORTCIRCUIT;
3415 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
3417 if ( ! (o2->op_type == OP_LIST
3418 && (( o2 = cUNOPx(o2)->op_first))
3419 && o2->op_type == OP_PUSHMARK
3420 && (( o2 = o2->op_sibling)) )
3423 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
3424 || o2->op_type == OP_PADHV)
3425 && o2->op_private & OPpLVAL_INTRO
3426 && ckWARN(WARN_DEPRECATED))
3428 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
3429 "Deprecated use of my() in false conditional");
3434 if (first->op_type == OP_CONST)
3435 first->op_private |= OPpCONST_SHORTCIRCUIT;
3439 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS) &&
3440 type != OP_DOR) /* [#24076] Don't warn for <FH> err FOO. */
3442 OP *k1 = ((UNOP*)first)->op_first;
3443 OP *k2 = k1->op_sibling;
3445 switch (first->op_type)
3448 if (k2 && k2->op_type == OP_READLINE
3449 && (k2->op_flags & OPf_STACKED)
3450 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3452 warnop = k2->op_type;
3457 if (k1->op_type == OP_READDIR
3458 || k1->op_type == OP_GLOB
3459 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3460 || k1->op_type == OP_EACH)
3462 warnop = ((k1->op_type == OP_NULL)
3463 ? (OPCODE)k1->op_targ : k1->op_type);
3468 line_t oldline = CopLINE(PL_curcop);
3469 CopLINE_set(PL_curcop, PL_copline);
3470 Perl_warner(aTHX_ packWARN(WARN_MISC),
3471 "Value of %s%s can be \"0\"; test with defined()",
3473 ((warnop == OP_READLINE || warnop == OP_GLOB)
3474 ? " construct" : "() operator"));
3475 CopLINE_set(PL_curcop, oldline);
3482 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3483 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3485 NewOp(1101, logop, 1, LOGOP);
3487 logop->op_type = (OPCODE)type;
3488 logop->op_ppaddr = PL_ppaddr[type];
3489 logop->op_first = first;
3490 logop->op_flags = flags | OPf_KIDS;
3491 logop->op_other = LINKLIST(other);
3492 logop->op_private = (U8)(1 | (flags >> 8));
3494 /* establish postfix order */
3495 logop->op_next = LINKLIST(first);
3496 first->op_next = (OP*)logop;
3497 first->op_sibling = other;
3499 CHECKOP(type,logop);
3501 o = newUNOP(OP_NULL, 0, (OP*)logop);
3508 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3515 return newLOGOP(OP_AND, 0, first, trueop);
3517 return newLOGOP(OP_OR, 0, first, falseop);
3519 scalarboolean(first);
3520 if (first->op_type == OP_CONST) {
3521 if (first->op_private & OPpCONST_BARE &&
3522 first->op_private & OPpCONST_STRICT) {
3523 no_bareword_allowed(first);
3525 if (SvTRUE(((SVOP*)first)->op_sv)) {
3536 NewOp(1101, logop, 1, LOGOP);
3537 logop->op_type = OP_COND_EXPR;
3538 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3539 logop->op_first = first;
3540 logop->op_flags = flags | OPf_KIDS;
3541 logop->op_private = (U8)(1 | (flags >> 8));
3542 logop->op_other = LINKLIST(trueop);
3543 logop->op_next = LINKLIST(falseop);
3545 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
3548 /* establish postfix order */
3549 start = LINKLIST(first);
3550 first->op_next = (OP*)logop;
3552 first->op_sibling = trueop;
3553 trueop->op_sibling = falseop;
3554 o = newUNOP(OP_NULL, 0, (OP*)logop);
3556 trueop->op_next = falseop->op_next = o;
3563 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3571 NewOp(1101, range, 1, LOGOP);
3573 range->op_type = OP_RANGE;
3574 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3575 range->op_first = left;
3576 range->op_flags = OPf_KIDS;
3577 leftstart = LINKLIST(left);
3578 range->op_other = LINKLIST(right);
3579 range->op_private = (U8)(1 | (flags >> 8));
3581 left->op_sibling = right;
3583 range->op_next = (OP*)range;
3584 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3585 flop = newUNOP(OP_FLOP, 0, flip);
3586 o = newUNOP(OP_NULL, 0, flop);
3588 range->op_next = leftstart;
3590 left->op_next = flip;
3591 right->op_next = flop;
3593 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3594 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3595 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3596 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3598 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3599 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3602 if (!flip->op_private || !flop->op_private)
3603 linklist(o); /* blow off optimizer unless constant */
3609 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3613 int once = block && block->op_flags & OPf_SPECIAL &&
3614 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3617 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3618 return block; /* do {} while 0 does once */
3619 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3620 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3621 expr = newUNOP(OP_DEFINED, 0,
3622 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3623 } else if (expr->op_flags & OPf_KIDS) {
3624 OP *k1 = ((UNOP*)expr)->op_first;
3625 OP *k2 = (k1) ? k1->op_sibling : NULL;
3626 switch (expr->op_type) {
3628 if (k2 && k2->op_type == OP_READLINE
3629 && (k2->op_flags & OPf_STACKED)
3630 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3631 expr = newUNOP(OP_DEFINED, 0, expr);
3635 if (k1->op_type == OP_READDIR
3636 || k1->op_type == OP_GLOB
3637 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3638 || k1->op_type == OP_EACH)
3639 expr = newUNOP(OP_DEFINED, 0, expr);
3645 /* if block is null, the next append_elem() would put UNSTACK, a scalar
3646 * op, in listop. This is wrong. [perl #27024] */
3648 block = newOP(OP_NULL, 0);
3649 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3650 o = new_logop(OP_AND, 0, &expr, &listop);
3653 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3655 if (once && o != listop)
3656 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3659 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3661 o->op_flags |= flags;
3663 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3668 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3676 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3677 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3678 expr = newUNOP(OP_DEFINED, 0,
3679 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3680 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3681 OP *k1 = ((UNOP*)expr)->op_first;
3682 OP *k2 = (k1) ? k1->op_sibling : NULL;
3683 switch (expr->op_type) {
3685 if (k2 && k2->op_type == OP_READLINE
3686 && (k2->op_flags & OPf_STACKED)
3687 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3688 expr = newUNOP(OP_DEFINED, 0, expr);
3692 if (k1->op_type == OP_READDIR
3693 || k1->op_type == OP_GLOB
3694 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3695 || k1->op_type == OP_EACH)
3696 expr = newUNOP(OP_DEFINED, 0, expr);
3702 block = newOP(OP_NULL, 0);
3704 block = scope(block);
3708 next = LINKLIST(cont);
3711 OP *unstack = newOP(OP_UNSTACK, 0);
3714 cont = append_elem(OP_LINESEQ, cont, unstack);
3717 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3718 redo = LINKLIST(listop);
3721 PL_copline = (line_t)whileline;
3723 o = new_logop(OP_AND, 0, &expr, &listop);
3724 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3725 op_free(expr); /* oops, it's a while (0) */
3727 return Nullop; /* listop already freed by new_logop */
3730 ((LISTOP*)listop)->op_last->op_next =
3731 (o == listop ? redo : LINKLIST(o));
3737 NewOp(1101,loop,1,LOOP);
3738 loop->op_type = OP_ENTERLOOP;
3739 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3740 loop->op_private = 0;
3741 loop->op_next = (OP*)loop;
3744 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3746 loop->op_redoop = redo;
3747 loop->op_lastop = o;
3748 o->op_private |= loopflags;
3751 loop->op_nextop = next;
3753 loop->op_nextop = o;
3755 o->op_flags |= flags;
3756 o->op_private |= (flags >> 8);
3761 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
3765 PADOFFSET padoff = 0;
3770 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
3771 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
3772 sv->op_type = OP_RV2GV;
3773 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3775 else if (sv->op_type == OP_PADSV) { /* private variable */
3776 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
3777 padoff = sv->op_targ;
3782 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3783 padoff = sv->op_targ;
3785 iterflags |= OPf_SPECIAL;
3790 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3793 I32 offset = pad_findmy("$_");
3794 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
3795 sv = newGVOP(OP_GV, 0, PL_defgv);
3801 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3802 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3803 iterflags |= OPf_STACKED;
3805 else if (expr->op_type == OP_NULL &&
3806 (expr->op_flags & OPf_KIDS) &&
3807 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3809 /* Basically turn for($x..$y) into the same as for($x,$y), but we
3810 * set the STACKED flag to indicate that these values are to be
3811 * treated as min/max values by 'pp_iterinit'.
3813 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
3814 LOGOP* range = (LOGOP*) flip->op_first;
3815 OP* left = range->op_first;
3816 OP* right = left->op_sibling;
3819 range->op_flags &= ~OPf_KIDS;
3820 range->op_first = Nullop;
3822 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
3823 listop->op_first->op_next = range->op_next;
3824 left->op_next = range->op_other;
3825 right->op_next = (OP*)listop;
3826 listop->op_next = listop->op_first;
3829 expr = (OP*)(listop);
3831 iterflags |= OPf_STACKED;
3834 expr = mod(force_list(expr), OP_GREPSTART);
3838 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
3839 append_elem(OP_LIST, expr, scalar(sv))));
3840 assert(!loop->op_next);
3841 /* for my $x () sets OPpLVAL_INTRO;
3842 * for our $x () sets OPpOUR_INTRO */
3843 loop->op_private = (U8)iterpflags;
3844 #ifdef PL_OP_SLAB_ALLOC
3847 NewOp(1234,tmp,1,LOOP);
3848 Copy(loop,tmp,1,LOOP);
3853 Renew(loop, 1, LOOP);
3855 loop->op_targ = padoff;
3856 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
3857 PL_copline = forline;
3858 return newSTATEOP(0, label, wop);
3862 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
3867 if (type != OP_GOTO || label->op_type == OP_CONST) {
3868 /* "last()" means "last" */
3869 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
3870 o = newOP(type, OPf_SPECIAL);
3872 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
3873 ? SvPVx(((SVOP*)label)->op_sv, n_a)
3879 /* Check whether it's going to be a goto &function */
3880 if (label->op_type == OP_ENTERSUB
3881 && !(label->op_flags & OPf_STACKED))
3882 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
3883 o = newUNOP(type, OPf_STACKED, label);
3885 PL_hints |= HINT_BLOCK_SCOPE;
3890 =for apidoc cv_undef
3892 Clear out all the active components of a CV. This can happen either
3893 by an explicit C<undef &foo>, or by the reference count going to zero.
3894 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
3895 children can still follow the full lexical scope chain.
3901 Perl_cv_undef(pTHX_ CV *cv)
3904 if (CvFILE(cv) && !CvXSUB(cv)) {
3905 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
3906 Safefree(CvFILE(cv));
3911 if (!CvXSUB(cv) && CvROOT(cv)) {
3913 Perl_croak(aTHX_ "Can't undef active subroutine");
3916 PAD_SAVE_SETNULLPAD();
3918 op_free(CvROOT(cv));
3919 CvROOT(cv) = Nullop;
3922 SvPOK_off((SV*)cv); /* forget prototype */
3927 /* remove CvOUTSIDE unless this is an undef rather than a free */
3928 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
3929 if (!CvWEAKOUTSIDE(cv))
3930 SvREFCNT_dec(CvOUTSIDE(cv));
3931 CvOUTSIDE(cv) = Nullcv;
3934 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
3940 /* delete all flags except WEAKOUTSIDE */
3941 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
3945 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
3947 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
3948 SV* msg = sv_newmortal();
3952 gv_efullname3(name = sv_newmortal(), gv, Nullch);
3953 sv_setpv(msg, "Prototype mismatch:");
3955 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
3957 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (SV *)cv);
3959 Perl_sv_catpvf(aTHX_ msg, ": none");
3960 sv_catpv(msg, " vs ");
3962 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
3964 sv_catpv(msg, "none");
3965 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
3969 static void const_sv_xsub(pTHX_ CV* cv);
3973 =head1 Optree Manipulation Functions
3975 =for apidoc cv_const_sv
3977 If C<cv> is a constant sub eligible for inlining. returns the constant
3978 value returned by the sub. Otherwise, returns NULL.
3980 Constant subs can be created with C<newCONSTSUB> or as described in
3981 L<perlsub/"Constant Functions">.
3986 Perl_cv_const_sv(pTHX_ CV *cv)
3988 if (!cv || !CvCONST(cv))
3990 return (SV*)CvXSUBANY(cv).any_ptr;
3993 /* op_const_sv: examine an optree to determine whether it's in-lineable.
3994 * Can be called in 3 ways:
3997 * look for a single OP_CONST with attached value: return the value
3999 * cv && CvCLONE(cv) && !CvCONST(cv)
4001 * examine the clone prototype, and if contains only a single
4002 * OP_CONST referencing a pad const, or a single PADSV referencing
4003 * an outer lexical, return a non-zero value to indicate the CV is
4004 * a candidate for "constizing" at clone time
4008 * We have just cloned an anon prototype that was marked as a const
4009 * candidiate. Try to grab the current value, and in the case of
4010 * PADSV, ignore it if it has multiple references. Return the value.
4014 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4021 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4022 o = cLISTOPo->op_first->op_sibling;
4024 for (; o; o = o->op_next) {
4025 OPCODE type = o->op_type;
4027 if (sv && o->op_next == o)
4029 if (o->op_next != o) {
4030 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4032 if (type == OP_DBSTATE)
4035 if (type == OP_LEAVESUB || type == OP_RETURN)
4039 if (type == OP_CONST && cSVOPo->op_sv)
4041 else if (cv && type == OP_CONST) {
4042 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4046 else if (cv && type == OP_PADSV) {
4047 if (CvCONST(cv)) { /* newly cloned anon */
4048 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4049 /* the candidate should have 1 ref from this pad and 1 ref
4050 * from the parent */
4051 if (!sv || SvREFCNT(sv) != 2)
4058 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4059 sv = &PL_sv_undef; /* an arbitrary non-null value */
4070 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4080 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4084 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4086 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4090 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4100 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4103 assert(proto->op_type == OP_CONST);
4104 ps = SvPVx(((SVOP*)proto)->op_sv, n_a);
4109 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4110 SV *sv = sv_newmortal();
4111 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4112 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4113 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4118 gv = gv_fetchpv(name ? name : (aname ? aname :
4119 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__")),
4120 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4130 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4131 maximum a prototype before. */
4132 if (SvTYPE(gv) > SVt_NULL) {
4133 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4134 && ckWARN_d(WARN_PROTOTYPE))
4136 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4138 cv_ckproto((CV*)gv, NULL, ps);
4141 sv_setpv((SV*)gv, ps);
4143 sv_setiv((SV*)gv, -1);
4144 SvREFCNT_dec(PL_compcv);
4145 cv = PL_compcv = NULL;
4146 PL_sub_generation++;
4150 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4152 #ifdef GV_UNIQUE_CHECK
4153 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4154 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4158 if (!block || !ps || *ps || attrs)
4161 const_sv = op_const_sv(block, Nullcv);
4164 bool exists = CvROOT(cv) || CvXSUB(cv);
4166 #ifdef GV_UNIQUE_CHECK
4167 if (exists && GvUNIQUE(gv)) {
4168 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4172 /* if the subroutine doesn't exist and wasn't pre-declared
4173 * with a prototype, assume it will be AUTOLOADed,
4174 * skipping the prototype check
4176 if (exists || SvPOK(cv))
4177 cv_ckproto(cv, gv, ps);
4178 /* already defined (or promised)? */
4179 if (exists || GvASSUMECV(gv)) {
4180 if (!block && !attrs) {
4181 if (CvFLAGS(PL_compcv)) {
4182 /* might have had built-in attrs applied */
4183 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4185 /* just a "sub foo;" when &foo is already defined */
4186 SAVEFREESV(PL_compcv);
4189 /* ahem, death to those who redefine active sort subs */
4190 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4191 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4193 if (ckWARN(WARN_REDEFINE)
4195 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4197 line_t oldline = CopLINE(PL_curcop);
4198 if (PL_copline != NOLINE)
4199 CopLINE_set(PL_curcop, PL_copline);
4200 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4201 CvCONST(cv) ? "Constant subroutine %s redefined"
4202 : "Subroutine %s redefined", name);
4203 CopLINE_set(PL_curcop, oldline);
4211 SvREFCNT_inc(const_sv);
4213 assert(!CvROOT(cv) && !CvCONST(cv));
4214 sv_setpv((SV*)cv, ""); /* prototype is "" */
4215 CvXSUBANY(cv).any_ptr = const_sv;
4216 CvXSUB(cv) = const_sv_xsub;
4221 cv = newCONSTSUB(NULL, name, const_sv);
4224 SvREFCNT_dec(PL_compcv);
4226 PL_sub_generation++;
4233 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4234 * before we clobber PL_compcv.
4238 /* Might have had built-in attributes applied -- propagate them. */
4239 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4240 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4241 stash = GvSTASH(CvGV(cv));
4242 else if (CvSTASH(cv))
4243 stash = CvSTASH(cv);
4245 stash = PL_curstash;
4248 /* possibly about to re-define existing subr -- ignore old cv */
4249 rcv = (SV*)PL_compcv;
4250 if (name && GvSTASH(gv))
4251 stash = GvSTASH(gv);
4253 stash = PL_curstash;
4255 apply_attrs(stash, rcv, attrs, FALSE);
4257 if (cv) { /* must reuse cv if autoloaded */
4259 /* got here with just attrs -- work done, so bug out */
4260 SAVEFREESV(PL_compcv);
4263 /* transfer PL_compcv to cv */
4265 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4266 if (!CvWEAKOUTSIDE(cv))
4267 SvREFCNT_dec(CvOUTSIDE(cv));
4268 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4269 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4270 CvOUTSIDE(PL_compcv) = 0;
4271 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4272 CvPADLIST(PL_compcv) = 0;
4273 /* inner references to PL_compcv must be fixed up ... */
4274 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4275 /* ... before we throw it away */
4276 SvREFCNT_dec(PL_compcv);
4278 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4279 ++PL_sub_generation;
4286 PL_sub_generation++;
4290 CvFILE_set_from_cop(cv, PL_curcop);
4291 CvSTASH(cv) = PL_curstash;
4294 sv_setpv((SV*)cv, ps);
4296 if (PL_error_count) {
4300 char *s = strrchr(name, ':');
4302 if (strEQ(s, "BEGIN")) {
4304 "BEGIN not safe after errors--compilation aborted";
4305 if (PL_in_eval & EVAL_KEEPERR)
4306 Perl_croak(aTHX_ not_safe);
4308 /* force display of errors found but not reported */
4309 sv_catpv(ERRSV, not_safe);
4310 Perl_croak(aTHX_ "%"SVf, ERRSV);
4319 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4320 mod(scalarseq(block), OP_LEAVESUBLV));
4323 /* This makes sub {}; work as expected. */
4324 if (block->op_type == OP_STUB) {
4326 block = newSTATEOP(0, Nullch, 0);
4328 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4330 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4331 OpREFCNT_set(CvROOT(cv), 1);
4332 CvSTART(cv) = LINKLIST(CvROOT(cv));
4333 CvROOT(cv)->op_next = 0;
4334 CALL_PEEP(CvSTART(cv));
4336 /* now that optimizer has done its work, adjust pad values */
4338 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4341 assert(!CvCONST(cv));
4342 if (ps && !*ps && op_const_sv(block, cv))
4346 if (name || aname) {
4348 char *tname = (name ? name : aname);
4350 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4351 SV *sv = NEWSV(0,0);
4352 SV *tmpstr = sv_newmortal();
4353 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4357 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4359 (long)PL_subline, (long)CopLINE(PL_curcop));
4360 gv_efullname3(tmpstr, gv, Nullch);
4361 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4362 hv = GvHVn(db_postponed);
4363 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4364 && (pcv = GvCV(db_postponed)))
4370 call_sv((SV*)pcv, G_DISCARD);
4374 if ((s = strrchr(tname,':')))
4379 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4382 if (strEQ(s, "BEGIN") && !PL_error_count) {
4383 I32 oldscope = PL_scopestack_ix;
4385 SAVECOPFILE(&PL_compiling);
4386 SAVECOPLINE(&PL_compiling);
4389 PL_beginav = newAV();
4390 DEBUG_x( dump_sub(gv) );
4391 av_push(PL_beginav, (SV*)cv);
4392 GvCV(gv) = 0; /* cv has been hijacked */
4393 call_list(oldscope, PL_beginav);
4395 PL_curcop = &PL_compiling;
4396 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4399 else if (strEQ(s, "END") && !PL_error_count) {
4402 DEBUG_x( dump_sub(gv) );
4403 av_unshift(PL_endav, 1);
4404 av_store(PL_endav, 0, (SV*)cv);
4405 GvCV(gv) = 0; /* cv has been hijacked */
4407 else if (strEQ(s, "CHECK") && !PL_error_count) {
4409 PL_checkav = newAV();
4410 DEBUG_x( dump_sub(gv) );
4411 if (PL_main_start && ckWARN(WARN_VOID))
4412 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4413 av_unshift(PL_checkav, 1);
4414 av_store(PL_checkav, 0, (SV*)cv);
4415 GvCV(gv) = 0; /* cv has been hijacked */
4417 else if (strEQ(s, "INIT") && !PL_error_count) {
4419 PL_initav = newAV();
4420 DEBUG_x( dump_sub(gv) );
4421 if (PL_main_start && ckWARN(WARN_VOID))
4422 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4423 av_push(PL_initav, (SV*)cv);
4424 GvCV(gv) = 0; /* cv has been hijacked */
4429 PL_copline = NOLINE;
4434 /* XXX unsafe for threads if eval_owner isn't held */
4436 =for apidoc newCONSTSUB
4438 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4439 eligible for inlining at compile-time.
4445 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4451 SAVECOPLINE(PL_curcop);
4452 CopLINE_set(PL_curcop, PL_copline);
4455 PL_hints &= ~HINT_BLOCK_SCOPE;
4458 SAVESPTR(PL_curstash);
4459 SAVECOPSTASH(PL_curcop);
4460 PL_curstash = stash;
4461 CopSTASH_set(PL_curcop,stash);
4464 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4465 CvXSUBANY(cv).any_ptr = sv;
4467 sv_setpv((SV*)cv, ""); /* prototype is "" */
4470 CopSTASH_free(PL_curcop);
4478 =for apidoc U||newXS
4480 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4486 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
4488 GV *gv = gv_fetchpv(name ? name :
4489 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4490 GV_ADDMULTI, SVt_PVCV);
4494 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4496 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4498 /* just a cached method */
4502 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4503 /* already defined (or promised) */
4504 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4505 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4506 line_t oldline = CopLINE(PL_curcop);
4507 if (PL_copline != NOLINE)
4508 CopLINE_set(PL_curcop, PL_copline);
4509 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4510 CvCONST(cv) ? "Constant subroutine %s redefined"
4511 : "Subroutine %s redefined"
4513 CopLINE_set(PL_curcop, oldline);
4520 if (cv) /* must reuse cv if autoloaded */
4523 cv = (CV*)NEWSV(1105,0);
4524 sv_upgrade((SV *)cv, SVt_PVCV);
4528 PL_sub_generation++;
4532 (void)gv_fetchfile(filename);
4533 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
4534 an external constant string */
4535 CvXSUB(cv) = subaddr;
4538 char *s = strrchr(name,':');
4544 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4547 if (strEQ(s, "BEGIN")) {
4549 PL_beginav = newAV();
4550 av_push(PL_beginav, (SV*)cv);
4551 GvCV(gv) = 0; /* cv has been hijacked */
4553 else if (strEQ(s, "END")) {
4556 av_unshift(PL_endav, 1);
4557 av_store(PL_endav, 0, (SV*)cv);
4558 GvCV(gv) = 0; /* cv has been hijacked */
4560 else if (strEQ(s, "CHECK")) {
4562 PL_checkav = newAV();
4563 if (PL_main_start && ckWARN(WARN_VOID))
4564 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4565 av_unshift(PL_checkav, 1);
4566 av_store(PL_checkav, 0, (SV*)cv);
4567 GvCV(gv) = 0; /* cv has been hijacked */
4569 else if (strEQ(s, "INIT")) {
4571 PL_initav = newAV();
4572 if (PL_main_start && ckWARN(WARN_VOID))
4573 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4574 av_push(PL_initav, (SV*)cv);
4575 GvCV(gv) = 0; /* cv has been hijacked */
4586 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4594 name = SvPVx(cSVOPo->op_sv, n_a);
4597 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
4598 #ifdef GV_UNIQUE_CHECK
4600 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4604 if ((cv = GvFORM(gv))) {
4605 if (ckWARN(WARN_REDEFINE)) {
4606 line_t oldline = CopLINE(PL_curcop);
4607 if (PL_copline != NOLINE)
4608 CopLINE_set(PL_curcop, PL_copline);
4609 Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Format %s redefined",name);
4610 CopLINE_set(PL_curcop, oldline);
4617 CvFILE_set_from_cop(cv, PL_curcop);
4620 pad_tidy(padtidy_FORMAT);
4621 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4622 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4623 OpREFCNT_set(CvROOT(cv), 1);
4624 CvSTART(cv) = LINKLIST(CvROOT(cv));
4625 CvROOT(cv)->op_next = 0;
4626 CALL_PEEP(CvSTART(cv));
4628 PL_copline = NOLINE;
4633 Perl_newANONLIST(pTHX_ OP *o)
4635 return newUNOP(OP_REFGEN, 0,
4636 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4640 Perl_newANONHASH(pTHX_ OP *o)
4642 return newUNOP(OP_REFGEN, 0,
4643 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4647 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4649 return newANONATTRSUB(floor, proto, Nullop, block);
4653 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4655 return newUNOP(OP_REFGEN, 0,
4656 newSVOP(OP_ANONCODE, 0,
4657 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
4661 Perl_oopsAV(pTHX_ OP *o)
4663 switch (o->op_type) {
4665 o->op_type = OP_PADAV;
4666 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4667 return ref(o, OP_RV2AV);
4670 o->op_type = OP_RV2AV;
4671 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4676 if (ckWARN_d(WARN_INTERNAL))
4677 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
4684 Perl_oopsHV(pTHX_ OP *o)
4686 switch (o->op_type) {
4689 o->op_type = OP_PADHV;
4690 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4691 return ref(o, OP_RV2HV);
4695 o->op_type = OP_RV2HV;
4696 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
4701 if (ckWARN_d(WARN_INTERNAL))
4702 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
4709 Perl_newAVREF(pTHX_ OP *o)
4711 if (o->op_type == OP_PADANY) {
4712 o->op_type = OP_PADAV;
4713 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4716 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
4717 && ckWARN(WARN_DEPRECATED)) {
4718 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4719 "Using an array as a reference is deprecated");
4721 return newUNOP(OP_RV2AV, 0, scalar(o));
4725 Perl_newGVREF(pTHX_ I32 type, OP *o)
4727 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
4728 return newUNOP(OP_NULL, 0, o);
4729 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
4733 Perl_newHVREF(pTHX_ OP *o)
4735 if (o->op_type == OP_PADANY) {
4736 o->op_type = OP_PADHV;
4737 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4740 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
4741 && ckWARN(WARN_DEPRECATED)) {
4742 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4743 "Using a hash as a reference is deprecated");
4745 return newUNOP(OP_RV2HV, 0, scalar(o));
4749 Perl_oopsCV(pTHX_ OP *o)
4751 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
4757 Perl_newCVREF(pTHX_ I32 flags, OP *o)
4759 return newUNOP(OP_RV2CV, flags, scalar(o));
4763 Perl_newSVREF(pTHX_ OP *o)
4765 if (o->op_type == OP_PADANY) {
4766 o->op_type = OP_PADSV;
4767 o->op_ppaddr = PL_ppaddr[OP_PADSV];
4770 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4771 o->op_flags |= OPpDONE_SVREF;
4774 return newUNOP(OP_RV2SV, 0, scalar(o));
4777 /* Check routines. */
4780 Perl_ck_anoncode(pTHX_ OP *o)
4782 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
4783 cSVOPo->op_sv = Nullsv;
4788 Perl_ck_bitop(pTHX_ OP *o)
4790 #define OP_IS_NUMCOMPARE(op) \
4791 ((op) == OP_LT || (op) == OP_I_LT || \
4792 (op) == OP_GT || (op) == OP_I_GT || \
4793 (op) == OP_LE || (op) == OP_I_LE || \
4794 (op) == OP_GE || (op) == OP_I_GE || \
4795 (op) == OP_EQ || (op) == OP_I_EQ || \
4796 (op) == OP_NE || (op) == OP_I_NE || \
4797 (op) == OP_NCMP || (op) == OP_I_NCMP)
4798 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4799 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
4800 && (o->op_type == OP_BIT_OR
4801 || o->op_type == OP_BIT_AND
4802 || o->op_type == OP_BIT_XOR))
4804 OP * left = cBINOPo->op_first;
4805 OP * right = left->op_sibling;
4806 if ((OP_IS_NUMCOMPARE(left->op_type) &&
4807 (left->op_flags & OPf_PARENS) == 0) ||
4808 (OP_IS_NUMCOMPARE(right->op_type) &&
4809 (right->op_flags & OPf_PARENS) == 0))
4810 if (ckWARN(WARN_PRECEDENCE))
4811 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4812 "Possible precedence problem on bitwise %c operator",
4813 o->op_type == OP_BIT_OR ? '|'
4814 : o->op_type == OP_BIT_AND ? '&' : '^'
4821 Perl_ck_concat(pTHX_ OP *o)
4823 OP *kid = cUNOPo->op_first;
4824 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
4825 !(kUNOP->op_first->op_flags & OPf_MOD))
4826 o->op_flags |= OPf_STACKED;
4831 Perl_ck_spair(pTHX_ OP *o)
4833 if (o->op_flags & OPf_KIDS) {
4836 OPCODE type = o->op_type;
4837 o = modkids(ck_fun(o), type);
4838 kid = cUNOPo->op_first;
4839 newop = kUNOP->op_first->op_sibling;
4841 (newop->op_sibling ||
4842 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
4843 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
4844 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
4848 op_free(kUNOP->op_first);
4849 kUNOP->op_first = newop;
4851 o->op_ppaddr = PL_ppaddr[++o->op_type];
4856 Perl_ck_delete(pTHX_ OP *o)
4860 if (o->op_flags & OPf_KIDS) {
4861 OP *kid = cUNOPo->op_first;
4862 switch (kid->op_type) {
4864 o->op_flags |= OPf_SPECIAL;
4867 o->op_private |= OPpSLICE;
4870 o->op_flags |= OPf_SPECIAL;
4875 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
4884 Perl_ck_die(pTHX_ OP *o)
4887 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4893 Perl_ck_eof(pTHX_ OP *o)
4895 I32 type = o->op_type;
4897 if (o->op_flags & OPf_KIDS) {
4898 if (cLISTOPo->op_first->op_type == OP_STUB) {
4900 o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
4908 Perl_ck_eval(pTHX_ OP *o)
4910 PL_hints |= HINT_BLOCK_SCOPE;
4911 if (o->op_flags & OPf_KIDS) {
4912 SVOP *kid = (SVOP*)cUNOPo->op_first;
4915 o->op_flags &= ~OPf_KIDS;
4918 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
4921 cUNOPo->op_first = 0;
4924 NewOp(1101, enter, 1, LOGOP);
4925 enter->op_type = OP_ENTERTRY;
4926 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
4927 enter->op_private = 0;
4929 /* establish postfix order */
4930 enter->op_next = (OP*)enter;
4932 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
4933 o->op_type = OP_LEAVETRY;
4934 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
4935 enter->op_other = o;
4945 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
4947 o->op_targ = (PADOFFSET)PL_hints;
4952 Perl_ck_exit(pTHX_ OP *o)
4955 HV *table = GvHV(PL_hintgv);
4957 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
4958 if (svp && *svp && SvTRUE(*svp))
4959 o->op_private |= OPpEXIT_VMSISH;
4961 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4967 Perl_ck_exec(pTHX_ OP *o)
4970 if (o->op_flags & OPf_STACKED) {
4972 kid = cUNOPo->op_first->op_sibling;
4973 if (kid->op_type == OP_RV2GV)
4982 Perl_ck_exists(pTHX_ OP *o)
4985 if (o->op_flags & OPf_KIDS) {
4986 OP *kid = cUNOPo->op_first;
4987 if (kid->op_type == OP_ENTERSUB) {
4988 (void) ref(kid, o->op_type);
4989 if (kid->op_type != OP_RV2CV && !PL_error_count)
4990 Perl_croak(aTHX_ "%s argument is not a subroutine name",
4992 o->op_private |= OPpEXISTS_SUB;
4994 else if (kid->op_type == OP_AELEM)
4995 o->op_flags |= OPf_SPECIAL;
4996 else if (kid->op_type != OP_HELEM)
4997 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5006 Perl_ck_gvconst(pTHX_ register OP *o)
5008 o = fold_constants(o);
5009 if (o->op_type == OP_CONST)
5016 Perl_ck_rvconst(pTHX_ register OP *o)
5018 SVOP *kid = (SVOP*)cUNOPo->op_first;
5020 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5021 if (kid->op_type == OP_CONST) {
5025 SV *kidsv = kid->op_sv;
5028 /* Is it a constant from cv_const_sv()? */
5029 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5030 SV *rsv = SvRV(kidsv);
5031 int svtype = SvTYPE(rsv);
5032 char *badtype = Nullch;
5034 switch (o->op_type) {
5036 if (svtype > SVt_PVMG)
5037 badtype = "a SCALAR";
5040 if (svtype != SVt_PVAV)
5041 badtype = "an ARRAY";
5044 if (svtype != SVt_PVHV)
5048 if (svtype != SVt_PVCV)
5053 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5056 name = SvPV(kidsv, n_a);
5057 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5058 char *badthing = Nullch;
5059 switch (o->op_type) {
5061 badthing = "a SCALAR";
5064 badthing = "an ARRAY";
5067 badthing = "a HASH";
5072 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5076 * This is a little tricky. We only want to add the symbol if we
5077 * didn't add it in the lexer. Otherwise we get duplicate strict
5078 * warnings. But if we didn't add it in the lexer, we must at
5079 * least pretend like we wanted to add it even if it existed before,
5080 * or we get possible typo warnings. OPpCONST_ENTERED says
5081 * whether the lexer already added THIS instance of this symbol.
5083 iscv = (o->op_type == OP_RV2CV) * 2;
5085 gv = gv_fetchpv(name,
5086 iscv | !(kid->op_private & OPpCONST_ENTERED),
5089 : o->op_type == OP_RV2SV
5091 : o->op_type == OP_RV2AV
5093 : o->op_type == OP_RV2HV
5096 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5098 kid->op_type = OP_GV;
5099 SvREFCNT_dec(kid->op_sv);
5101 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5102 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5103 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
5105 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
5107 kid->op_sv = SvREFCNT_inc(gv);
5109 kid->op_private = 0;
5110 kid->op_ppaddr = PL_ppaddr[OP_GV];
5117 Perl_ck_ftst(pTHX_ OP *o)
5119 I32 type = o->op_type;
5121 if (o->op_flags & OPf_REF) {
5124 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5125 SVOP *kid = (SVOP*)cUNOPo->op_first;
5127 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5129 OP *newop = newGVOP(type, OPf_REF,
5130 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5136 if ((PL_hints & HINT_FILETEST_ACCESS) &&
5137 OP_IS_FILETEST_ACCESS(o))
5138 o->op_private |= OPpFT_ACCESS;
5140 if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
5141 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
5142 o->op_private |= OPpFT_STACKED;
5146 if (type == OP_FTTTY)
5147 o = newGVOP(type, OPf_REF, PL_stdingv);
5149 o = newUNOP(type, 0, newDEFSVOP());
5155 Perl_ck_fun(pTHX_ OP *o)
5161 int type = o->op_type;
5162 register I32 oa = PL_opargs[type] >> OASHIFT;
5164 if (o->op_flags & OPf_STACKED) {
5165 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5168 return no_fh_allowed(o);
5171 if (o->op_flags & OPf_KIDS) {
5173 tokid = &cLISTOPo->op_first;
5174 kid = cLISTOPo->op_first;
5175 if (kid->op_type == OP_PUSHMARK ||
5176 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5178 tokid = &kid->op_sibling;
5179 kid = kid->op_sibling;
5181 if (!kid && PL_opargs[type] & OA_DEFGV)
5182 *tokid = kid = newDEFSVOP();
5186 sibl = kid->op_sibling;
5189 /* list seen where single (scalar) arg expected? */
5190 if (numargs == 1 && !(oa >> 4)
5191 && kid->op_type == OP_LIST && type != OP_SCALAR)
5193 return too_many_arguments(o,PL_op_desc[type]);
5206 if ((type == OP_PUSH || type == OP_UNSHIFT)
5207 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5208 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5209 "Useless use of %s with no values",
5212 if (kid->op_type == OP_CONST &&
5213 (kid->op_private & OPpCONST_BARE))
5215 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5216 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5217 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5218 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5219 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5220 "Array @%s missing the @ in argument %"IVdf" of %s()",
5221 name, (IV)numargs, PL_op_desc[type]);
5224 kid->op_sibling = sibl;
5227 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5228 bad_type(numargs, "array", PL_op_desc[type], kid);
5232 if (kid->op_type == OP_CONST &&
5233 (kid->op_private & OPpCONST_BARE))
5235 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5236 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5237 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5238 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5239 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5240 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5241 name, (IV)numargs, PL_op_desc[type]);
5244 kid->op_sibling = sibl;
5247 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5248 bad_type(numargs, "hash", PL_op_desc[type], kid);
5253 OP *newop = newUNOP(OP_NULL, 0, kid);
5254 kid->op_sibling = 0;
5256 newop->op_next = newop;
5258 kid->op_sibling = sibl;
5263 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5264 if (kid->op_type == OP_CONST &&
5265 (kid->op_private & OPpCONST_BARE))
5267 OP *newop = newGVOP(OP_GV, 0,
5268 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5270 if (!(o->op_private & 1) && /* if not unop */
5271 kid == cLISTOPo->op_last)
5272 cLISTOPo->op_last = newop;
5276 else if (kid->op_type == OP_READLINE) {
5277 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5278 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5281 I32 flags = OPf_SPECIAL;
5285 /* is this op a FH constructor? */
5286 if (is_handle_constructor(o,numargs)) {
5287 char *name = Nullch;
5291 /* Set a flag to tell rv2gv to vivify
5292 * need to "prove" flag does not mean something
5293 * else already - NI-S 1999/05/07
5296 if (kid->op_type == OP_PADSV) {
5297 name = PAD_COMPNAME_PV(kid->op_targ);
5298 /* SvCUR of a pad namesv can't be trusted
5299 * (see PL_generation), so calc its length
5305 else if (kid->op_type == OP_RV2SV
5306 && kUNOP->op_first->op_type == OP_GV)
5308 GV *gv = cGVOPx_gv(kUNOP->op_first);
5310 len = GvNAMELEN(gv);
5312 else if (kid->op_type == OP_AELEM
5313 || kid->op_type == OP_HELEM)
5318 if ((op = ((BINOP*)kid)->op_first)) {
5319 SV *tmpstr = Nullsv;
5321 kid->op_type == OP_AELEM ?
5323 if (((op->op_type == OP_RV2AV) ||
5324 (op->op_type == OP_RV2HV)) &&
5325 (op = ((UNOP*)op)->op_first) &&
5326 (op->op_type == OP_GV)) {
5327 /* packagevar $a[] or $h{} */
5328 GV *gv = cGVOPx_gv(op);
5336 else if (op->op_type == OP_PADAV
5337 || op->op_type == OP_PADHV) {
5338 /* lexicalvar $a[] or $h{} */
5340 PAD_COMPNAME_PV(op->op_targ);
5350 name = SvPV(tmpstr, len);
5355 name = "__ANONIO__";
5362 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5363 namesv = PAD_SVl(targ);
5364 (void)SvUPGRADE(namesv, SVt_PV);
5366 sv_setpvn(namesv, "$", 1);
5367 sv_catpvn(namesv, name, len);
5370 kid->op_sibling = 0;
5371 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5372 kid->op_targ = targ;
5373 kid->op_private |= priv;
5375 kid->op_sibling = sibl;
5381 mod(scalar(kid), type);
5385 tokid = &kid->op_sibling;
5386 kid = kid->op_sibling;
5388 o->op_private |= numargs;
5390 return too_many_arguments(o,OP_DESC(o));
5393 else if (PL_opargs[type] & OA_DEFGV) {
5395 return newUNOP(type, 0, newDEFSVOP());
5399 while (oa & OA_OPTIONAL)
5401 if (oa && oa != OA_LIST)
5402 return too_few_arguments(o,OP_DESC(o));
5408 Perl_ck_glob(pTHX_ OP *o)
5413 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5414 append_elem(OP_GLOB, o, newDEFSVOP());
5416 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5417 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5419 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5422 #if !defined(PERL_EXTERNAL_GLOB)
5423 /* XXX this can be tightened up and made more failsafe. */
5424 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5427 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5428 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5429 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5430 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5431 GvCV(gv) = GvCV(glob_gv);
5432 SvREFCNT_inc((SV*)GvCV(gv));
5433 GvIMPORTED_CV_on(gv);
5436 #endif /* PERL_EXTERNAL_GLOB */
5438 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5439 append_elem(OP_GLOB, o,
5440 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5441 o->op_type = OP_LIST;
5442 o->op_ppaddr = PL_ppaddr[OP_LIST];
5443 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5444 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5445 cLISTOPo->op_first->op_targ = 0;
5446 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5447 append_elem(OP_LIST, o,
5448 scalar(newUNOP(OP_RV2CV, 0,
5449 newGVOP(OP_GV, 0, gv)))));
5450 o = newUNOP(OP_NULL, 0, ck_subr(o));
5451 o->op_targ = OP_GLOB; /* hint at what it used to be */
5454 gv = newGVgen("main");
5456 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5462 Perl_ck_grep(pTHX_ OP *o)
5466 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5469 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5470 NewOp(1101, gwop, 1, LOGOP);
5472 if (o->op_flags & OPf_STACKED) {
5475 kid = cLISTOPo->op_first->op_sibling;
5476 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
5479 kid->op_next = (OP*)gwop;
5480 o->op_flags &= ~OPf_STACKED;
5482 kid = cLISTOPo->op_first->op_sibling;
5483 if (type == OP_MAPWHILE)
5490 kid = cLISTOPo->op_first->op_sibling;
5491 if (kid->op_type != OP_NULL)
5492 Perl_croak(aTHX_ "panic: ck_grep");
5493 kid = kUNOP->op_first;
5495 gwop->op_type = type;
5496 gwop->op_ppaddr = PL_ppaddr[type];
5497 gwop->op_first = listkids(o);
5498 gwop->op_flags |= OPf_KIDS;
5499 gwop->op_other = LINKLIST(kid);
5500 kid->op_next = (OP*)gwop;
5501 offset = pad_findmy("$_");
5502 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
5503 o->op_private = gwop->op_private = 0;
5504 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5507 o->op_private = gwop->op_private = OPpGREP_LEX;
5508 gwop->op_targ = o->op_targ = offset;
5511 kid = cLISTOPo->op_first->op_sibling;
5512 if (!kid || !kid->op_sibling)
5513 return too_few_arguments(o,OP_DESC(o));
5514 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5515 mod(kid, OP_GREPSTART);
5521 Perl_ck_index(pTHX_ OP *o)
5523 if (o->op_flags & OPf_KIDS) {
5524 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5526 kid = kid->op_sibling; /* get past "big" */
5527 if (kid && kid->op_type == OP_CONST)
5528 fbm_compile(((SVOP*)kid)->op_sv, 0);
5534 Perl_ck_lengthconst(pTHX_ OP *o)
5536 /* XXX length optimization goes here */
5541 Perl_ck_lfun(pTHX_ OP *o)
5543 OPCODE type = o->op_type;
5544 return modkids(ck_fun(o), type);
5548 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5550 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5551 switch (cUNOPo->op_first->op_type) {
5553 /* This is needed for
5554 if (defined %stash::)
5555 to work. Do not break Tk.
5557 break; /* Globals via GV can be undef */
5559 case OP_AASSIGN: /* Is this a good idea? */
5560 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5561 "defined(@array) is deprecated");
5562 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5563 "\t(Maybe you should just omit the defined()?)\n");
5566 /* This is needed for
5567 if (defined %stash::)
5568 to work. Do not break Tk.
5570 break; /* Globals via GV can be undef */
5572 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5573 "defined(%%hash) is deprecated");
5574 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5575 "\t(Maybe you should just omit the defined()?)\n");
5586 Perl_ck_rfun(pTHX_ OP *o)
5588 OPCODE type = o->op_type;
5589 return refkids(ck_fun(o), type);
5593 Perl_ck_listiob(pTHX_ OP *o)
5597 kid = cLISTOPo->op_first;
5600 kid = cLISTOPo->op_first;
5602 if (kid->op_type == OP_PUSHMARK)
5603 kid = kid->op_sibling;
5604 if (kid && o->op_flags & OPf_STACKED)
5605 kid = kid->op_sibling;
5606 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5607 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5608 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5609 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5610 cLISTOPo->op_first->op_sibling = kid;
5611 cLISTOPo->op_last = kid;
5612 kid = kid->op_sibling;
5617 append_elem(o->op_type, o, newDEFSVOP());
5623 Perl_ck_sassign(pTHX_ OP *o)
5625 OP *kid = cLISTOPo->op_first;
5626 /* has a disposable target? */
5627 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5628 && !(kid->op_flags & OPf_STACKED)
5629 /* Cannot steal the second time! */
5630 && !(kid->op_private & OPpTARGET_MY))
5632 OP *kkid = kid->op_sibling;
5634 /* Can just relocate the target. */
5635 if (kkid && kkid->op_type == OP_PADSV
5636 && !(kkid->op_private & OPpLVAL_INTRO))
5638 kid->op_targ = kkid->op_targ;
5640 /* Now we do not need PADSV and SASSIGN. */
5641 kid->op_sibling = o->op_sibling; /* NULL */
5642 cLISTOPo->op_first = NULL;
5645 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
5649 /* optimise C<my $x = undef> to C<my $x> */
5650 if (kid->op_type == OP_UNDEF) {
5651 OP *kkid = kid->op_sibling;
5652 if (kkid && kkid->op_type == OP_PADSV
5653 && (kkid->op_private & OPpLVAL_INTRO))
5655 cLISTOPo->op_first = NULL;
5656 kid->op_sibling = NULL;
5666 Perl_ck_match(pTHX_ OP *o)
5668 if (o->op_type != OP_QR) {
5669 I32 offset = pad_findmy("$_");
5670 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS(offset) & SVpad_OUR)) {
5671 o->op_targ = offset;
5672 o->op_private |= OPpTARGET_MY;
5675 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
5676 o->op_private |= OPpRUNTIME;
5681 Perl_ck_method(pTHX_ OP *o)
5683 OP *kid = cUNOPo->op_first;
5684 if (kid->op_type == OP_CONST) {
5685 SV* sv = kSVOP->op_sv;
5686 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
5688 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5689 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
5692 kSVOP->op_sv = Nullsv;
5694 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5703 Perl_ck_null(pTHX_ OP *o)
5709 Perl_ck_open(pTHX_ OP *o)
5711 HV *table = GvHV(PL_hintgv);
5715 svp = hv_fetch(table, "open_IN", 7, FALSE);
5717 mode = mode_from_discipline(*svp);
5718 if (mode & O_BINARY)
5719 o->op_private |= OPpOPEN_IN_RAW;
5720 else if (mode & O_TEXT)
5721 o->op_private |= OPpOPEN_IN_CRLF;
5724 svp = hv_fetch(table, "open_OUT", 8, FALSE);
5726 mode = mode_from_discipline(*svp);
5727 if (mode & O_BINARY)
5728 o->op_private |= OPpOPEN_OUT_RAW;
5729 else if (mode & O_TEXT)
5730 o->op_private |= OPpOPEN_OUT_CRLF;
5733 if (o->op_type == OP_BACKTICK)
5736 /* In case of three-arg dup open remove strictness
5737 * from the last arg if it is a bareword. */
5738 OP *first = cLISTOPx(o)->op_first; /* The pushmark. */
5739 OP *last = cLISTOPx(o)->op_last; /* The bareword. */
5743 if ((last->op_type == OP_CONST) && /* The bareword. */
5744 (last->op_private & OPpCONST_BARE) &&
5745 (last->op_private & OPpCONST_STRICT) &&
5746 (oa = first->op_sibling) && /* The fh. */
5747 (oa = oa->op_sibling) && /* The mode. */
5748 SvPOK(((SVOP*)oa)->op_sv) &&
5749 (mode = SvPVX(((SVOP*)oa)->op_sv)) &&
5750 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
5751 (last == oa->op_sibling)) /* The bareword. */
5752 last->op_private &= ~OPpCONST_STRICT;
5758 Perl_ck_repeat(pTHX_ OP *o)
5760 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5761 o->op_private |= OPpREPEAT_DOLIST;
5762 cBINOPo->op_first = force_list(cBINOPo->op_first);
5770 Perl_ck_require(pTHX_ OP *o)
5774 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
5775 SVOP *kid = (SVOP*)cUNOPo->op_first;
5777 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5779 for (s = SvPVX(kid->op_sv); *s; s++) {
5780 if (*s == ':' && s[1] == ':') {
5782 Move(s+2, s+1, strlen(s+2)+1, char);
5783 --SvCUR(kid->op_sv);
5786 if (SvREADONLY(kid->op_sv)) {
5787 SvREADONLY_off(kid->op_sv);
5788 sv_catpvn(kid->op_sv, ".pm", 3);
5789 SvREADONLY_on(kid->op_sv);
5792 sv_catpvn(kid->op_sv, ".pm", 3);
5796 /* handle override, if any */
5797 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
5798 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
5799 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
5801 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5802 OP *kid = cUNOPo->op_first;
5803 cUNOPo->op_first = 0;
5805 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5806 append_elem(OP_LIST, kid,
5807 scalar(newUNOP(OP_RV2CV, 0,
5816 Perl_ck_return(pTHX_ OP *o)
5819 if (CvLVALUE(PL_compcv)) {
5820 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5821 mod(kid, OP_LEAVESUBLV);
5828 Perl_ck_retarget(pTHX_ OP *o)
5830 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5837 Perl_ck_select(pTHX_ OP *o)
5840 if (o->op_flags & OPf_KIDS) {
5841 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5842 if (kid && kid->op_sibling) {
5843 o->op_type = OP_SSELECT;
5844 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
5846 return fold_constants(o);
5850 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5851 if (kid && kid->op_type == OP_RV2GV)
5852 kid->op_private &= ~HINT_STRICT_REFS;
5857 Perl_ck_shift(pTHX_ OP *o)
5859 I32 type = o->op_type;
5861 if (!(o->op_flags & OPf_KIDS)) {
5865 argop = newUNOP(OP_RV2AV, 0,
5866 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
5867 return newUNOP(type, 0, scalar(argop));
5869 return scalar(modkids(ck_fun(o), type));
5873 Perl_ck_sort(pTHX_ OP *o)
5877 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
5879 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5880 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
5882 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
5884 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
5886 if (kid->op_type == OP_SCOPE) {
5890 else if (kid->op_type == OP_LEAVE) {
5891 if (o->op_type == OP_SORT) {
5892 op_null(kid); /* wipe out leave */
5895 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
5896 if (k->op_next == kid)
5898 /* don't descend into loops */
5899 else if (k->op_type == OP_ENTERLOOP
5900 || k->op_type == OP_ENTERITER)
5902 k = cLOOPx(k)->op_lastop;
5907 kid->op_next = 0; /* just disconnect the leave */
5908 k = kLISTOP->op_first;
5913 if (o->op_type == OP_SORT) {
5914 /* provide scalar context for comparison function/block */
5920 o->op_flags |= OPf_SPECIAL;
5922 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
5925 firstkid = firstkid->op_sibling;
5928 /* provide list context for arguments */
5929 if (o->op_type == OP_SORT)
5936 S_simplify_sort(pTHX_ OP *o)
5938 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5942 if (!(o->op_flags & OPf_STACKED))
5944 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
5945 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
5946 kid = kUNOP->op_first; /* get past null */
5947 if (kid->op_type != OP_SCOPE)
5949 kid = kLISTOP->op_last; /* get past scope */
5950 switch(kid->op_type) {
5958 k = kid; /* remember this node*/
5959 if (kBINOP->op_first->op_type != OP_RV2SV)
5961 kid = kBINOP->op_first; /* get past cmp */
5962 if (kUNOP->op_first->op_type != OP_GV)
5964 kid = kUNOP->op_first; /* get past rv2sv */
5966 if (GvSTASH(gv) != PL_curstash)
5968 if (strEQ(GvNAME(gv), "a"))
5970 else if (strEQ(GvNAME(gv), "b"))
5975 kid = k; /* back to cmp */
5976 if (kBINOP->op_last->op_type != OP_RV2SV)
5978 kid = kBINOP->op_last; /* down to 2nd arg */
5979 if (kUNOP->op_first->op_type != OP_GV)
5981 kid = kUNOP->op_first; /* get past rv2sv */
5983 if (GvSTASH(gv) != PL_curstash
5985 ? strNE(GvNAME(gv), "a")
5986 : strNE(GvNAME(gv), "b")))
5988 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
5990 o->op_private |= OPpSORT_DESCEND;
5991 if (k->op_type == OP_NCMP)
5992 o->op_private |= OPpSORT_NUMERIC;
5993 if (k->op_type == OP_I_NCMP)
5994 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
5995 kid = cLISTOPo->op_first->op_sibling;
5996 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
5997 op_free(kid); /* then delete it */
6001 Perl_ck_split(pTHX_ OP *o)
6005 if (o->op_flags & OPf_STACKED)
6006 return no_fh_allowed(o);
6008 kid = cLISTOPo->op_first;
6009 if (kid->op_type != OP_NULL)
6010 Perl_croak(aTHX_ "panic: ck_split");
6011 kid = kid->op_sibling;
6012 op_free(cLISTOPo->op_first);
6013 cLISTOPo->op_first = kid;
6015 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6016 cLISTOPo->op_last = kid; /* There was only one element previously */
6019 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6020 OP *sibl = kid->op_sibling;
6021 kid->op_sibling = 0;
6022 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6023 if (cLISTOPo->op_first == cLISTOPo->op_last)
6024 cLISTOPo->op_last = kid;
6025 cLISTOPo->op_first = kid;
6026 kid->op_sibling = sibl;
6029 kid->op_type = OP_PUSHRE;
6030 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6032 if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
6033 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
6034 "Use of /g modifier is meaningless in split");
6037 if (!kid->op_sibling)
6038 append_elem(OP_SPLIT, o, newDEFSVOP());
6040 kid = kid->op_sibling;
6043 if (!kid->op_sibling)
6044 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6046 kid = kid->op_sibling;
6049 if (kid->op_sibling)
6050 return too_many_arguments(o,OP_DESC(o));
6056 Perl_ck_join(pTHX_ OP *o)
6058 if (ckWARN(WARN_SYNTAX)) {
6059 OP *kid = cLISTOPo->op_first->op_sibling;
6060 if (kid && kid->op_type == OP_MATCH) {
6061 char *pmstr = "STRING";
6062 if (PM_GETRE(kPMOP))
6063 pmstr = PM_GETRE(kPMOP)->precomp;
6064 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6065 "/%s/ should probably be written as \"%s\"",
6073 Perl_ck_subr(pTHX_ OP *o)
6075 OP *prev = ((cUNOPo->op_first->op_sibling)
6076 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6077 OP *o2 = prev->op_sibling;
6084 I32 contextclass = 0;
6089 o->op_private |= OPpENTERSUB_HASTARG;
6090 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6091 if (cvop->op_type == OP_RV2CV) {
6093 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6094 op_null(cvop); /* disable rv2cv */
6095 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6096 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6097 GV *gv = cGVOPx_gv(tmpop);
6100 tmpop->op_private |= OPpEARLY_CV;
6103 namegv = CvANON(cv) ? gv : CvGV(cv);
6104 proto = SvPV((SV*)cv, n_a);
6106 if (CvASSERTION(cv)) {
6107 if (PL_hints & HINT_ASSERTING) {
6108 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
6109 o->op_private |= OPpENTERSUB_DB;
6113 if (ckWARN(WARN_ASSERTIONS) && !(PL_hints & HINT_ASSERTIONSSEEN)) {
6114 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
6115 "Impossible to activate assertion call");
6122 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6123 if (o2->op_type == OP_CONST)
6124 o2->op_private &= ~OPpCONST_STRICT;
6125 else if (o2->op_type == OP_LIST) {
6126 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6127 if (o && o->op_type == OP_CONST)
6128 o->op_private &= ~OPpCONST_STRICT;
6131 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6132 if (PERLDB_SUB && PL_curstash != PL_debstash)
6133 o->op_private |= OPpENTERSUB_DB;
6134 while (o2 != cvop) {
6138 return too_many_arguments(o, gv_ename(namegv));
6156 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6158 arg == 1 ? "block or sub {}" : "sub {}",
6159 gv_ename(namegv), o2);
6162 /* '*' allows any scalar type, including bareword */
6165 if (o2->op_type == OP_RV2GV)
6166 goto wrapref; /* autoconvert GLOB -> GLOBref */
6167 else if (o2->op_type == OP_CONST)
6168 o2->op_private &= ~OPpCONST_STRICT;
6169 else if (o2->op_type == OP_ENTERSUB) {
6170 /* accidental subroutine, revert to bareword */
6171 OP *gvop = ((UNOP*)o2)->op_first;
6172 if (gvop && gvop->op_type == OP_NULL) {
6173 gvop = ((UNOP*)gvop)->op_first;
6175 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6178 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6179 (gvop = ((UNOP*)gvop)->op_first) &&
6180 gvop->op_type == OP_GV)
6182 GV *gv = cGVOPx_gv(gvop);
6183 OP *sibling = o2->op_sibling;
6184 SV *n = newSVpvn("",0);
6186 gv_fullname3(n, gv, "");
6187 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6188 sv_chop(n, SvPVX(n)+6);
6189 o2 = newSVOP(OP_CONST, 0, n);
6190 prev->op_sibling = o2;
6191 o2->op_sibling = sibling;
6207 if (contextclass++ == 0) {
6208 e = strchr(proto, ']');
6209 if (!e || e == proto)
6222 while (*--p != '[');
6223 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6224 gv_ename(namegv), o2);
6230 if (o2->op_type == OP_RV2GV)
6233 bad_type(arg, "symbol", gv_ename(namegv), o2);
6236 if (o2->op_type == OP_ENTERSUB)
6239 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6242 if (o2->op_type == OP_RV2SV ||
6243 o2->op_type == OP_PADSV ||
6244 o2->op_type == OP_HELEM ||
6245 o2->op_type == OP_AELEM ||
6246 o2->op_type == OP_THREADSV)
6249 bad_type(arg, "scalar", gv_ename(namegv), o2);
6252 if (o2->op_type == OP_RV2AV ||
6253 o2->op_type == OP_PADAV)
6256 bad_type(arg, "array", gv_ename(namegv), o2);
6259 if (o2->op_type == OP_RV2HV ||
6260 o2->op_type == OP_PADHV)
6263 bad_type(arg, "hash", gv_ename(namegv), o2);
6268 OP* sib = kid->op_sibling;
6269 kid->op_sibling = 0;
6270 o2 = newUNOP(OP_REFGEN, 0, kid);
6271 o2->op_sibling = sib;
6272 prev->op_sibling = o2;
6274 if (contextclass && e) {
6289 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6290 gv_ename(namegv), cv);
6295 mod(o2, OP_ENTERSUB);
6297 o2 = o2->op_sibling;
6299 if (proto && !optional &&
6300 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6301 return too_few_arguments(o, gv_ename(namegv));
6304 o=newSVOP(OP_CONST, 0, newSViv(0));
6310 Perl_ck_svconst(pTHX_ OP *o)
6312 SvREADONLY_on(cSVOPo->op_sv);
6317 Perl_ck_trunc(pTHX_ OP *o)
6319 if (o->op_flags & OPf_KIDS) {
6320 SVOP *kid = (SVOP*)cUNOPo->op_first;
6322 if (kid->op_type == OP_NULL)
6323 kid = (SVOP*)kid->op_sibling;
6324 if (kid && kid->op_type == OP_CONST &&
6325 (kid->op_private & OPpCONST_BARE))
6327 o->op_flags |= OPf_SPECIAL;
6328 kid->op_private &= ~OPpCONST_STRICT;
6335 Perl_ck_unpack(pTHX_ OP *o)
6337 OP *kid = cLISTOPo->op_first;
6338 if (kid->op_sibling) {
6339 kid = kid->op_sibling;
6340 if (!kid->op_sibling)
6341 kid->op_sibling = newDEFSVOP();
6347 Perl_ck_substr(pTHX_ OP *o)
6350 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6351 OP *kid = cLISTOPo->op_first;
6353 if (kid->op_type == OP_NULL)
6354 kid = kid->op_sibling;
6356 kid->op_flags |= OPf_MOD;
6362 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6365 Perl_peep(pTHX_ register OP *o)
6367 register OP* oldop = 0;
6369 if (!o || o->op_opt)
6373 SAVEVPTR(PL_curcop);
6374 for (; o; o = o->op_next) {
6378 switch (o->op_type) {
6382 PL_curcop = ((COP*)o); /* for warnings */
6387 if (cSVOPo->op_private & OPpCONST_STRICT)
6388 no_bareword_allowed(o);
6390 case OP_METHOD_NAMED:
6391 /* Relocate sv to the pad for thread safety.
6392 * Despite being a "constant", the SV is written to,
6393 * for reference counts, sv_upgrade() etc. */
6395 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6396 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6397 /* If op_sv is already a PADTMP then it is being used by
6398 * some pad, so make a copy. */
6399 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6400 SvREADONLY_on(PAD_SVl(ix));
6401 SvREFCNT_dec(cSVOPo->op_sv);
6404 SvREFCNT_dec(PAD_SVl(ix));
6405 SvPADTMP_on(cSVOPo->op_sv);
6406 PAD_SETSV(ix, cSVOPo->op_sv);
6407 /* XXX I don't know how this isn't readonly already. */
6408 SvREADONLY_on(PAD_SVl(ix));
6410 cSVOPo->op_sv = Nullsv;
6418 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6419 if (o->op_next->op_private & OPpTARGET_MY) {
6420 if (o->op_flags & OPf_STACKED) /* chained concats */
6421 goto ignore_optimization;
6423 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6424 o->op_targ = o->op_next->op_targ;
6425 o->op_next->op_targ = 0;
6426 o->op_private |= OPpTARGET_MY;
6429 op_null(o->op_next);
6431 ignore_optimization:
6435 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6437 break; /* Scalar stub must produce undef. List stub is noop */
6441 if (o->op_targ == OP_NEXTSTATE
6442 || o->op_targ == OP_DBSTATE
6443 || o->op_targ == OP_SETSTATE)
6445 PL_curcop = ((COP*)o);
6447 /* XXX: We avoid setting op_seq here to prevent later calls
6448 to peep() from mistakenly concluding that optimisation
6449 has already occurred. This doesn't fix the real problem,
6450 though (See 20010220.007). AMS 20010719 */
6451 /* op_seq functionality is now replaced by op_opt */
6452 if (oldop && o->op_next) {
6453 oldop->op_next = o->op_next;
6461 if (oldop && o->op_next) {
6462 oldop->op_next = o->op_next;
6470 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
6471 OP* pop = (o->op_type == OP_PADAV) ?
6472 o->op_next : o->op_next->op_next;
6474 if (pop && pop->op_type == OP_CONST &&
6475 ((PL_op = pop->op_next)) &&
6476 pop->op_next->op_type == OP_AELEM &&
6477 !(pop->op_next->op_private &
6478 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6479 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6484 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
6485 no_bareword_allowed(pop);
6486 if (o->op_type == OP_GV)
6487 op_null(o->op_next);
6488 op_null(pop->op_next);
6490 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6491 o->op_next = pop->op_next->op_next;
6492 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6493 o->op_private = (U8)i;
6494 if (o->op_type == OP_GV) {
6499 o->op_flags |= OPf_SPECIAL;
6500 o->op_type = OP_AELEMFAST;
6506 if (o->op_next->op_type == OP_RV2SV) {
6507 if (!(o->op_next->op_private & OPpDEREF)) {
6508 op_null(o->op_next);
6509 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6511 o->op_next = o->op_next->op_next;
6512 o->op_type = OP_GVSV;
6513 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6516 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6518 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6519 /* XXX could check prototype here instead of just carping */
6520 SV *sv = sv_newmortal();
6521 gv_efullname3(sv, gv, Nullch);
6522 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6523 "%"SVf"() called too early to check prototype",
6527 else if (o->op_next->op_type == OP_READLINE
6528 && o->op_next->op_next->op_type == OP_CONCAT
6529 && (o->op_next->op_next->op_flags & OPf_STACKED))
6531 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6532 o->op_type = OP_RCATLINE;
6533 o->op_flags |= OPf_STACKED;
6534 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6535 op_null(o->op_next->op_next);
6536 op_null(o->op_next);
6553 while (cLOGOP->op_other->op_type == OP_NULL)
6554 cLOGOP->op_other = cLOGOP->op_other->op_next;
6555 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6561 while (cLOOP->op_redoop->op_type == OP_NULL)
6562 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6563 peep(cLOOP->op_redoop);
6564 while (cLOOP->op_nextop->op_type == OP_NULL)
6565 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6566 peep(cLOOP->op_nextop);
6567 while (cLOOP->op_lastop->op_type == OP_NULL)
6568 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6569 peep(cLOOP->op_lastop);
6576 while (cPMOP->op_pmreplstart &&
6577 cPMOP->op_pmreplstart->op_type == OP_NULL)
6578 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6579 peep(cPMOP->op_pmreplstart);
6584 if (ckWARN(WARN_SYNTAX) && o->op_next
6585 && o->op_next->op_type == OP_NEXTSTATE) {
6586 if (o->op_next->op_sibling &&
6587 o->op_next->op_sibling->op_type != OP_EXIT &&
6588 o->op_next->op_sibling->op_type != OP_WARN &&
6589 o->op_next->op_sibling->op_type != OP_DIE) {
6590 line_t oldline = CopLINE(PL_curcop);
6592 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6593 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6594 "Statement unlikely to be reached");
6595 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6596 "\t(Maybe you meant system() when you said exec()?)\n");
6597 CopLINE_set(PL_curcop, oldline);
6610 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6613 /* Make the CONST have a shared SV */
6614 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6615 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6616 key = SvPV(sv, keylen);
6617 lexname = newSVpvn_share(key,
6618 SvUTF8(sv) ? -(I32)keylen : keylen,
6627 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
6631 /* check that RHS of sort is a single plain array */
6632 oright = cUNOPo->op_first;
6633 if (!oright || oright->op_type != OP_PUSHMARK)
6636 /* reverse sort ... can be optimised. */
6637 if (!cUNOPo->op_sibling) {
6638 /* Nothing follows us on the list. */
6639 OP *reverse = o->op_next;
6641 if (reverse->op_type == OP_REVERSE &&
6642 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
6643 OP *pushmark = cUNOPx(reverse)->op_first;
6644 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
6645 && (cUNOPx(pushmark)->op_sibling == o)) {
6646 /* reverse -> pushmark -> sort */
6647 o->op_private |= OPpSORT_REVERSE;
6649 pushmark->op_next = oright->op_next;
6655 /* make @a = sort @a act in-place */
6659 oright = cUNOPx(oright)->op_sibling;
6662 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
6663 oright = cUNOPx(oright)->op_sibling;
6667 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
6668 || oright->op_next != o
6669 || (oright->op_private & OPpLVAL_INTRO)
6673 /* o2 follows the chain of op_nexts through the LHS of the
6674 * assign (if any) to the aassign op itself */
6676 if (!o2 || o2->op_type != OP_NULL)
6679 if (!o2 || o2->op_type != OP_PUSHMARK)
6682 if (o2 && o2->op_type == OP_GV)
6685 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
6686 || (o2->op_private & OPpLVAL_INTRO)
6691 if (!o2 || o2->op_type != OP_NULL)
6694 if (!o2 || o2->op_type != OP_AASSIGN
6695 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
6698 /* check that the sort is the first arg on RHS of assign */
6700 o2 = cUNOPx(o2)->op_first;
6701 if (!o2 || o2->op_type != OP_NULL)
6703 o2 = cUNOPx(o2)->op_first;
6704 if (!o2 || o2->op_type != OP_PUSHMARK)
6706 if (o2->op_sibling != o)
6709 /* check the array is the same on both sides */
6710 if (oleft->op_type == OP_RV2AV) {
6711 if (oright->op_type != OP_RV2AV
6712 || !cUNOPx(oright)->op_first
6713 || cUNOPx(oright)->op_first->op_type != OP_GV
6714 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
6715 cGVOPx_gv(cUNOPx(oright)->op_first)
6719 else if (oright->op_type != OP_PADAV
6720 || oright->op_targ != oleft->op_targ
6724 /* transfer MODishness etc from LHS arg to RHS arg */
6725 oright->op_flags = oleft->op_flags;
6726 o->op_private |= OPpSORT_INPLACE;
6728 /* excise push->gv->rv2av->null->aassign */
6729 o2 = o->op_next->op_next;
6730 op_null(o2); /* PUSHMARK */
6732 if (o2->op_type == OP_GV) {
6733 op_null(o2); /* GV */
6736 op_null(o2); /* RV2AV or PADAV */
6737 o2 = o2->op_next->op_next;
6738 op_null(o2); /* AASSIGN */
6740 o->op_next = o2->op_next;
6746 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
6748 LISTOP *enter, *exlist;
6751 enter = (LISTOP *) o->op_next;
6754 if (enter->op_type == OP_NULL) {
6755 enter = (LISTOP *) enter->op_next;
6759 /* for $a (...) will have OP_GV then OP_RV2GV here.
6760 for (...) just has an OP_GV. */
6761 if (enter->op_type == OP_GV) {
6762 gvop = (OP *) enter;
6763 enter = (LISTOP *) enter->op_next;
6766 if (enter->op_type == OP_RV2GV) {
6767 enter = (LISTOP *) enter->op_next;
6773 if (enter->op_type != OP_ENTERITER)
6776 iter = enter->op_next;
6777 if (!iter || iter->op_type != OP_ITER)
6780 expushmark = enter->op_first;
6781 if (!expushmark || expushmark->op_type != OP_NULL
6782 || expushmark->op_targ != OP_PUSHMARK)
6785 exlist = (LISTOP *) expushmark->op_sibling;
6786 if (!exlist || exlist->op_type != OP_NULL
6787 || exlist->op_targ != OP_LIST)
6790 if (exlist->op_last != o) {
6791 /* Mmm. Was expecting to point back to this op. */
6794 theirmark = exlist->op_first;
6795 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
6798 if (theirmark->op_sibling != o) {
6799 /* There's something between the mark and the reverse, eg
6800 for (1, reverse (...))
6805 ourmark = ((LISTOP *)o)->op_first;
6806 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
6809 ourlast = ((LISTOP *)o)->op_last;
6810 if (!ourlast || ourlast->op_next != o)
6813 rv2av = ourmark->op_sibling;
6814 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
6815 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
6816 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
6817 /* We're just reversing a single array. */
6818 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
6819 enter->op_flags |= OPf_STACKED;
6822 /* We don't have control over who points to theirmark, so sacrifice
6824 theirmark->op_next = ourmark->op_next;
6825 theirmark->op_flags = ourmark->op_flags;
6826 ourlast->op_next = gvop ? gvop : (OP *) enter;
6829 enter->op_private |= OPpITER_REVERSED;
6830 iter->op_private |= OPpITER_REVERSED;
6846 char* Perl_custom_op_name(pTHX_ OP* o)
6848 IV index = PTR2IV(o->op_ppaddr);
6852 if (!PL_custom_op_names) /* This probably shouldn't happen */
6853 return PL_op_name[OP_CUSTOM];
6855 keysv = sv_2mortal(newSViv(index));
6857 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
6859 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
6861 return SvPV_nolen(HeVAL(he));
6864 char* Perl_custom_op_desc(pTHX_ OP* o)
6866 IV index = PTR2IV(o->op_ppaddr);
6870 if (!PL_custom_op_descs)
6871 return PL_op_desc[OP_CUSTOM];
6873 keysv = sv_2mortal(newSViv(index));
6875 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
6877 return PL_op_desc[OP_CUSTOM];
6879 return SvPV_nolen(HeVAL(he));
6885 /* Efficient sub that returns a constant scalar value. */
6887 const_sv_xsub(pTHX_ CV* cv)
6892 Perl_croak(aTHX_ "usage: %s::%s()",
6893 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
6897 ST(0) = (SV*)XSANY.any_ptr;