3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 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
25 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
27 #if defined(PL_OP_SLAB_ALLOC)
29 #ifndef PERL_SLAB_SIZE
30 #define PERL_SLAB_SIZE 2048
33 #define NewOp(m,var,c,type) \
34 STMT_START { var = (type *) Slab_Alloc(m,c*sizeof(type)); } STMT_END
36 #define FreeOp(p) Slab_Free(p)
39 S_Slab_Alloc(pTHX_ int m, size_t sz)
42 * To make incrementing use count easy PL_OpSlab is an I32 *
43 * To make inserting the link to slab PL_OpPtr is I32 **
44 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
45 * Add an overhead for pointer to slab and round up as a number of pointers
47 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
48 if ((PL_OpSpace -= sz) < 0) {
49 PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*));
53 Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **);
54 /* We reserve the 0'th I32 sized chunk as a use count */
55 PL_OpSlab = (I32 *) PL_OpPtr;
56 /* Reduce size by the use count word, and by the size we need.
57 * Latter is to mimic the '-=' in the if() above
59 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
60 /* Allocation pointer starts at the top.
61 Theory: because we build leaves before trunk allocating at end
62 means that at run time access is cache friendly upward
64 PL_OpPtr += PERL_SLAB_SIZE;
66 assert( PL_OpSpace >= 0 );
67 /* Move the allocation pointer down */
69 assert( PL_OpPtr > (I32 **) PL_OpSlab );
70 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
71 (*PL_OpSlab)++; /* Increment use count of slab */
72 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
73 assert( *PL_OpSlab > 0 );
74 return (void *)(PL_OpPtr + 1);
78 S_Slab_Free(pTHX_ void *op)
80 I32 **ptr = (I32 **) op;
82 assert( ptr-1 > (I32 **) slab );
83 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
87 #define PerlMemShared PerlMem
90 PerlMemShared_free(slab);
91 if (slab == PL_OpSlab) {
98 #define NewOp(m, var, c, type) Newz(m, var, c, type)
99 #define FreeOp(p) Safefree(p)
102 * In the following definition, the ", Nullop" is just to make the compiler
103 * think the expression is of the right type: croak actually does a Siglongjmp.
105 #define CHECKOP(type,o) \
106 ((PL_op_mask && PL_op_mask[type]) \
107 ? ( op_free((OP*)o), \
108 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
110 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
112 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
115 S_gv_ename(pTHX_ GV *gv)
118 SV* tmpsv = sv_newmortal();
119 gv_efullname3(tmpsv, gv, Nullch);
120 return SvPV(tmpsv,n_a);
124 S_no_fh_allowed(pTHX_ OP *o)
126 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
132 S_too_few_arguments(pTHX_ OP *o, char *name)
134 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
139 S_too_many_arguments(pTHX_ OP *o, char *name)
141 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
146 S_bad_type(pTHX_ I32 n, char *t, char *name, OP *kid)
148 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
149 (int)n, name, t, OP_DESC(kid)));
153 S_no_bareword_allowed(pTHX_ OP *o)
155 qerror(Perl_mess(aTHX_
156 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
160 /* "register" allocation */
163 Perl_allocmy(pTHX_ char *name)
167 /* complain about "my $_" etc etc */
168 if (!(PL_in_my == KEY_our ||
170 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
171 (name[1] == '_' && (int)strlen(name) > 2)))
173 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
174 /* 1999-02-27 mjd@plover.com */
176 p = strchr(name, '\0');
177 /* The next block assumes the buffer is at least 205 chars
178 long. At present, it's always at least 256 chars. */
180 strcpy(name+200, "...");
186 /* Move everything else down one character */
187 for (; p-name > 2; p--)
189 name[2] = toCTRL(name[1]);
192 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
195 /* check for duplicate declaration */
198 (PL_curstash ? PL_curstash : PL_defstash)
201 if (PL_in_my_stash && *name != '$') {
202 yyerror(Perl_form(aTHX_
203 "Can't declare class for non-scalar %s in \"%s\"",
204 name, PL_in_my == KEY_our ? "our" : "my"));
207 /* allocate a spare slot and store the name in that slot */
209 off = pad_add_name(name,
212 ? (PL_curstash ? PL_curstash : PL_defstash)
223 Perl_op_free(pTHX_ OP *o)
225 register OP *kid, *nextkid;
228 if (!o || o->op_seq == (U16)-1)
231 if (o->op_private & OPpREFCOUNTED) {
232 switch (o->op_type) {
240 if (OpREFCNT_dec(o)) {
251 if (o->op_flags & OPf_KIDS) {
252 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
253 nextkid = kid->op_sibling; /* Get before next freeing kid */
259 type = (OPCODE)o->op_targ;
261 /* COP* is not cleared by op_clear() so that we may track line
262 * numbers etc even after null() */
263 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
271 Perl_op_clear(pTHX_ OP *o)
274 switch (o->op_type) {
275 case OP_NULL: /* Was holding old type, if any. */
276 case OP_ENTEREVAL: /* Was holding hints. */
280 if (!(o->op_flags & OPf_REF)
281 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
288 if (cPADOPo->op_padix > 0) {
289 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
290 * may still exist on the pad */
291 pad_swipe(cPADOPo->op_padix, TRUE);
292 cPADOPo->op_padix = 0;
295 SvREFCNT_dec(cSVOPo->op_sv);
296 cSVOPo->op_sv = Nullsv;
299 case OP_METHOD_NAMED:
301 SvREFCNT_dec(cSVOPo->op_sv);
302 cSVOPo->op_sv = Nullsv;
305 Even if op_clear does a pad_free for the target of the op,
306 pad_free doesn't actually remove the sv that exists in the bad
307 instead it lives on. This results in that it could be reused as
308 a target later on when the pad was reallocated.
311 pad_swipe(o->op_targ,1);
320 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
324 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
325 SvREFCNT_dec(cSVOPo->op_sv);
326 cSVOPo->op_sv = Nullsv;
329 Safefree(cPVOPo->op_pv);
330 cPVOPo->op_pv = Nullch;
334 op_free(cPMOPo->op_pmreplroot);
338 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
339 /* No GvIN_PAD_off here, because other references may still
340 * exist on the pad */
341 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
344 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
351 HV *pmstash = PmopSTASH(cPMOPo);
352 if (pmstash && SvREFCNT(pmstash)) {
353 PMOP *pmop = HvPMROOT(pmstash);
354 PMOP *lastpmop = NULL;
356 if (cPMOPo == pmop) {
358 lastpmop->op_pmnext = pmop->op_pmnext;
360 HvPMROOT(pmstash) = pmop->op_pmnext;
364 pmop = pmop->op_pmnext;
367 PmopSTASH_free(cPMOPo);
369 cPMOPo->op_pmreplroot = Nullop;
370 /* we use the "SAFE" version of the PM_ macros here
371 * since sv_clean_all might release some PMOPs
372 * after PL_regex_padav has been cleared
373 * and the clearing of PL_regex_padav needs to
374 * happen before sv_clean_all
376 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
377 PM_SETRE_SAFE(cPMOPo, (REGEXP*)NULL);
379 if(PL_regex_pad) { /* We could be in destruction */
380 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
381 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
382 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
389 if (o->op_targ > 0) {
390 pad_free(o->op_targ);
396 S_cop_free(pTHX_ COP* cop)
398 Safefree(cop->cop_label); /* FIXME: treaddead ??? */
401 if (! specialWARN(cop->cop_warnings))
402 SvREFCNT_dec(cop->cop_warnings);
403 if (! specialCopIO(cop->cop_io)) {
407 char *s = SvPV(cop->cop_io,len);
408 Perl_warn(aTHX_ "io='%.*s'",(int) len,s); /* ??? --jhi */
411 SvREFCNT_dec(cop->cop_io);
417 Perl_op_null(pTHX_ OP *o)
419 if (o->op_type == OP_NULL)
422 o->op_targ = o->op_type;
423 o->op_type = OP_NULL;
424 o->op_ppaddr = PL_ppaddr[OP_NULL];
427 /* Contextualizers */
429 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
432 Perl_linklist(pTHX_ OP *o)
439 /* establish postfix order */
440 if (cUNOPo->op_first) {
441 o->op_next = LINKLIST(cUNOPo->op_first);
442 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
444 kid->op_next = LINKLIST(kid->op_sibling);
456 Perl_scalarkids(pTHX_ OP *o)
459 if (o && o->op_flags & OPf_KIDS) {
460 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
467 S_scalarboolean(pTHX_ OP *o)
469 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
470 if (ckWARN(WARN_SYNTAX)) {
471 line_t oldline = CopLINE(PL_curcop);
473 if (PL_copline != NOLINE)
474 CopLINE_set(PL_curcop, PL_copline);
475 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
476 CopLINE_set(PL_curcop, oldline);
483 Perl_scalar(pTHX_ OP *o)
487 /* assumes no premature commitment */
488 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
489 || o->op_type == OP_RETURN)
494 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
496 switch (o->op_type) {
498 scalar(cBINOPo->op_first);
503 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
507 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
508 if (!kPMOP->op_pmreplroot)
509 deprecate_old("implicit split to @_");
517 if (o->op_flags & OPf_KIDS) {
518 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
524 kid = cLISTOPo->op_first;
526 while ((kid = kid->op_sibling)) {
532 WITH_THR(PL_curcop = &PL_compiling);
537 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
543 WITH_THR(PL_curcop = &PL_compiling);
546 if (ckWARN(WARN_VOID))
547 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
553 Perl_scalarvoid(pTHX_ OP *o)
560 if (o->op_type == OP_NEXTSTATE
561 || o->op_type == OP_SETSTATE
562 || o->op_type == OP_DBSTATE
563 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
564 || o->op_targ == OP_SETSTATE
565 || o->op_targ == OP_DBSTATE)))
566 PL_curcop = (COP*)o; /* for warning below */
568 /* assumes no premature commitment */
569 want = o->op_flags & OPf_WANT;
570 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
571 || o->op_type == OP_RETURN)
576 if ((o->op_private & OPpTARGET_MY)
577 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
579 return scalar(o); /* As if inside SASSIGN */
582 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
584 switch (o->op_type) {
586 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
590 if (o->op_flags & OPf_STACKED)
594 if (o->op_private == 4)
666 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
667 useless = OP_DESC(o);
674 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
675 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
676 useless = "a variable";
681 if (cSVOPo->op_private & OPpCONST_STRICT)
682 no_bareword_allowed(o);
684 if (ckWARN(WARN_VOID)) {
685 useless = "a constant";
686 /* the constants 0 and 1 are permitted as they are
687 conventionally used as dummies in constructs like
688 1 while some_condition_with_side_effects; */
689 if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
691 else if (SvPOK(sv)) {
692 /* perl4's way of mixing documentation and code
693 (before the invention of POD) was based on a
694 trick to mix nroff and perl code. The trick was
695 built upon these three nroff macros being used in
696 void context. The pink camel has the details in
697 the script wrapman near page 319. */
698 if (strnEQ(SvPVX(sv), "di", 2) ||
699 strnEQ(SvPVX(sv), "ds", 2) ||
700 strnEQ(SvPVX(sv), "ig", 2))
705 op_null(o); /* don't execute or even remember it */
709 o->op_type = OP_PREINC; /* pre-increment is faster */
710 o->op_ppaddr = PL_ppaddr[OP_PREINC];
714 o->op_type = OP_PREDEC; /* pre-decrement is faster */
715 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
722 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
727 if (o->op_flags & OPf_STACKED)
734 if (!(o->op_flags & OPf_KIDS))
743 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
750 /* all requires must return a boolean value */
751 o->op_flags &= ~OPf_WANT;
756 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
757 if (!kPMOP->op_pmreplroot)
758 deprecate_old("implicit split to @_");
762 if (useless && ckWARN(WARN_VOID))
763 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
768 Perl_listkids(pTHX_ OP *o)
771 if (o && o->op_flags & OPf_KIDS) {
772 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
779 Perl_list(pTHX_ OP *o)
783 /* assumes no premature commitment */
784 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
785 || o->op_type == OP_RETURN)
790 if ((o->op_private & OPpTARGET_MY)
791 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
793 return o; /* As if inside SASSIGN */
796 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
798 switch (o->op_type) {
801 list(cBINOPo->op_first);
806 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
814 if (!(o->op_flags & OPf_KIDS))
816 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
817 list(cBINOPo->op_first);
818 return gen_constant_list(o);
825 kid = cLISTOPo->op_first;
827 while ((kid = kid->op_sibling)) {
833 WITH_THR(PL_curcop = &PL_compiling);
837 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
843 WITH_THR(PL_curcop = &PL_compiling);
846 /* all requires must return a boolean value */
847 o->op_flags &= ~OPf_WANT;
854 Perl_scalarseq(pTHX_ OP *o)
859 if (o->op_type == OP_LINESEQ ||
860 o->op_type == OP_SCOPE ||
861 o->op_type == OP_LEAVE ||
862 o->op_type == OP_LEAVETRY)
864 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
865 if (kid->op_sibling) {
869 PL_curcop = &PL_compiling;
871 o->op_flags &= ~OPf_PARENS;
872 if (PL_hints & HINT_BLOCK_SCOPE)
873 o->op_flags |= OPf_PARENS;
876 o = newOP(OP_STUB, 0);
881 S_modkids(pTHX_ OP *o, I32 type)
884 if (o && o->op_flags & OPf_KIDS) {
885 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
891 /* Propagate lvalue ("modifiable") context to an op and it's children.
892 * 'type' represents the context type, roughly based on the type of op that
893 * would do the modifying, although local() is represented by OP_NULL.
894 * It's responsible for detecting things that can't be modified, flag
895 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
896 * might have to vivify a reference in $x), and so on.
898 * For example, "$a+1 = 2" would cause mod() to be called with o being
899 * OP_ADD and type being OP_SASSIGN, and would output an error.
903 Perl_mod(pTHX_ OP *o, I32 type)
906 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
909 if (!o || PL_error_count)
912 if ((o->op_private & OPpTARGET_MY)
913 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
918 switch (o->op_type) {
924 if (!(o->op_private & (OPpCONST_ARYBASE)))
926 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
927 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
931 SAVEI32(PL_compiling.cop_arybase);
932 PL_compiling.cop_arybase = 0;
934 else if (type == OP_REFGEN)
937 Perl_croak(aTHX_ "That use of $[ is unsupported");
940 if (o->op_flags & OPf_PARENS)
944 if ((type == OP_UNDEF || type == OP_REFGEN) &&
945 !(o->op_flags & OPf_STACKED)) {
946 o->op_type = OP_RV2CV; /* entersub => rv2cv */
947 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
948 assert(cUNOPo->op_first->op_type == OP_NULL);
949 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
952 else if (o->op_private & OPpENTERSUB_NOMOD)
954 else { /* lvalue subroutine call */
955 o->op_private |= OPpLVAL_INTRO;
956 PL_modcount = RETURN_UNLIMITED_NUMBER;
957 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
958 /* Backward compatibility mode: */
959 o->op_private |= OPpENTERSUB_INARGS;
962 else { /* Compile-time error message: */
963 OP *kid = cUNOPo->op_first;
967 if (kid->op_type == OP_PUSHMARK)
969 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
971 "panic: unexpected lvalue entersub "
972 "args: type/targ %ld:%"UVuf,
973 (long)kid->op_type, (UV)kid->op_targ);
974 kid = kLISTOP->op_first;
976 while (kid->op_sibling)
977 kid = kid->op_sibling;
978 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
980 if (kid->op_type == OP_METHOD_NAMED
981 || kid->op_type == OP_METHOD)
985 NewOp(1101, newop, 1, UNOP);
986 newop->op_type = OP_RV2CV;
987 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
988 newop->op_first = Nullop;
989 newop->op_next = (OP*)newop;
990 kid->op_sibling = (OP*)newop;
991 newop->op_private |= OPpLVAL_INTRO;
995 if (kid->op_type != OP_RV2CV)
997 "panic: unexpected lvalue entersub "
998 "entry via type/targ %ld:%"UVuf,
999 (long)kid->op_type, (UV)kid->op_targ);
1000 kid->op_private |= OPpLVAL_INTRO;
1001 break; /* Postpone until runtime */
1005 kid = kUNOP->op_first;
1006 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1007 kid = kUNOP->op_first;
1008 if (kid->op_type == OP_NULL)
1010 "Unexpected constant lvalue entersub "
1011 "entry via type/targ %ld:%"UVuf,
1012 (long)kid->op_type, (UV)kid->op_targ);
1013 if (kid->op_type != OP_GV) {
1014 /* Restore RV2CV to check lvalueness */
1016 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1017 okid->op_next = kid->op_next;
1018 kid->op_next = okid;
1021 okid->op_next = Nullop;
1022 okid->op_type = OP_RV2CV;
1024 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1025 okid->op_private |= OPpLVAL_INTRO;
1029 cv = GvCV(kGVOP_gv);
1039 /* grep, foreach, subcalls, refgen */
1040 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1042 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1043 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1045 : (o->op_type == OP_ENTERSUB
1046 ? "non-lvalue subroutine call"
1048 type ? PL_op_desc[type] : "local"));
1062 case OP_RIGHT_SHIFT:
1071 if (!(o->op_flags & OPf_STACKED))
1078 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1084 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1085 PL_modcount = RETURN_UNLIMITED_NUMBER;
1086 return o; /* Treat \(@foo) like ordinary list. */
1090 if (scalar_mod_type(o, type))
1092 ref(cUNOPo->op_first, o->op_type);
1096 if (type == OP_LEAVESUBLV)
1097 o->op_private |= OPpMAYBE_LVSUB;
1103 PL_modcount = RETURN_UNLIMITED_NUMBER;
1106 ref(cUNOPo->op_first, o->op_type);
1111 PL_hints |= HINT_BLOCK_SCOPE;
1126 PL_modcount = RETURN_UNLIMITED_NUMBER;
1127 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1128 return o; /* Treat \(@foo) like ordinary list. */
1129 if (scalar_mod_type(o, type))
1131 if (type == OP_LEAVESUBLV)
1132 o->op_private |= OPpMAYBE_LVSUB;
1136 if (!type) /* local() */
1137 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1138 PAD_COMPNAME_PV(o->op_targ));
1146 if (type != OP_SASSIGN)
1150 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1155 if (type == OP_LEAVESUBLV)
1156 o->op_private |= OPpMAYBE_LVSUB;
1158 pad_free(o->op_targ);
1159 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1160 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1161 if (o->op_flags & OPf_KIDS)
1162 mod(cBINOPo->op_first->op_sibling, type);
1167 ref(cBINOPo->op_first, o->op_type);
1168 if (type == OP_ENTERSUB &&
1169 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1170 o->op_private |= OPpLVAL_DEFER;
1171 if (type == OP_LEAVESUBLV)
1172 o->op_private |= OPpMAYBE_LVSUB;
1182 if (o->op_flags & OPf_KIDS)
1183 mod(cLISTOPo->op_last, type);
1188 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1190 else if (!(o->op_flags & OPf_KIDS))
1192 if (o->op_targ != OP_LIST) {
1193 mod(cBINOPo->op_first, type);
1199 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1204 if (type != OP_LEAVESUBLV)
1206 break; /* mod()ing was handled by ck_return() */
1209 /* [20011101.069] File test operators interpret OPf_REF to mean that
1210 their argument is a filehandle; thus \stat(".") should not set
1212 if (type == OP_REFGEN &&
1213 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1216 if (type != OP_LEAVESUBLV)
1217 o->op_flags |= OPf_MOD;
1219 if (type == OP_AASSIGN || type == OP_SASSIGN)
1220 o->op_flags |= OPf_SPECIAL|OPf_REF;
1221 else if (!type) { /* local() */
1224 o->op_private |= OPpLVAL_INTRO;
1225 o->op_flags &= ~OPf_SPECIAL;
1226 PL_hints |= HINT_BLOCK_SCOPE;
1231 if (ckWARN(WARN_SYNTAX)) {
1232 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1233 "Useless localization of %s", OP_DESC(o));
1237 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1238 && type != OP_LEAVESUBLV)
1239 o->op_flags |= OPf_REF;
1244 S_scalar_mod_type(pTHX_ OP *o, I32 type)
1248 if (o->op_type == OP_RV2GV)
1272 case OP_RIGHT_SHIFT:
1291 S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
1293 switch (o->op_type) {
1301 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1314 Perl_refkids(pTHX_ OP *o, I32 type)
1317 if (o && o->op_flags & OPf_KIDS) {
1318 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1325 Perl_ref(pTHX_ OP *o, I32 type)
1329 if (!o || PL_error_count)
1332 switch (o->op_type) {
1334 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1335 !(o->op_flags & OPf_STACKED)) {
1336 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1337 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1338 assert(cUNOPo->op_first->op_type == OP_NULL);
1339 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1340 o->op_flags |= OPf_SPECIAL;
1345 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1349 if (type == OP_DEFINED)
1350 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1351 ref(cUNOPo->op_first, o->op_type);
1354 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1355 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1356 : type == OP_RV2HV ? OPpDEREF_HV
1358 o->op_flags |= OPf_MOD;
1363 o->op_flags |= OPf_MOD; /* XXX ??? */
1368 o->op_flags |= OPf_REF;
1371 if (type == OP_DEFINED)
1372 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1373 ref(cUNOPo->op_first, o->op_type);
1378 o->op_flags |= OPf_REF;
1383 if (!(o->op_flags & OPf_KIDS))
1385 ref(cBINOPo->op_first, type);
1389 ref(cBINOPo->op_first, o->op_type);
1390 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1391 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1392 : type == OP_RV2HV ? OPpDEREF_HV
1394 o->op_flags |= OPf_MOD;
1402 if (!(o->op_flags & OPf_KIDS))
1404 ref(cLISTOPo->op_last, type);
1414 S_dup_attrlist(pTHX_ OP *o)
1418 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1419 * where the first kid is OP_PUSHMARK and the remaining ones
1420 * are OP_CONST. We need to push the OP_CONST values.
1422 if (o->op_type == OP_CONST)
1423 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1425 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1426 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1427 if (o->op_type == OP_CONST)
1428 rop = append_elem(OP_LIST, rop,
1429 newSVOP(OP_CONST, o->op_flags,
1430 SvREFCNT_inc(cSVOPo->op_sv)));
1437 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1441 /* fake up C<use attributes $pkg,$rv,@attrs> */
1442 ENTER; /* need to protect against side-effects of 'use' */
1445 stashsv = newSVpv(HvNAME(stash), 0);
1447 stashsv = &PL_sv_no;
1449 #define ATTRSMODULE "attributes"
1450 #define ATTRSMODULE_PM "attributes.pm"
1454 /* Don't force the C<use> if we don't need it. */
1455 svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
1456 sizeof(ATTRSMODULE_PM)-1, 0);
1457 if (svp && *svp != &PL_sv_undef)
1458 ; /* already in %INC */
1460 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1461 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1465 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1466 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1468 prepend_elem(OP_LIST,
1469 newSVOP(OP_CONST, 0, stashsv),
1470 prepend_elem(OP_LIST,
1471 newSVOP(OP_CONST, 0,
1473 dup_attrlist(attrs))));
1479 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1481 OP *pack, *imop, *arg;
1487 assert(target->op_type == OP_PADSV ||
1488 target->op_type == OP_PADHV ||
1489 target->op_type == OP_PADAV);
1491 /* Ensure that attributes.pm is loaded. */
1492 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1494 /* Need package name for method call. */
1495 pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
1497 /* Build up the real arg-list. */
1499 stashsv = newSVpv(HvNAME(stash), 0);
1501 stashsv = &PL_sv_no;
1502 arg = newOP(OP_PADSV, 0);
1503 arg->op_targ = target->op_targ;
1504 arg = prepend_elem(OP_LIST,
1505 newSVOP(OP_CONST, 0, stashsv),
1506 prepend_elem(OP_LIST,
1507 newUNOP(OP_REFGEN, 0,
1508 mod(arg, OP_REFGEN)),
1509 dup_attrlist(attrs)));
1511 /* Fake up a method call to import */
1512 meth = newSVpvn("import", 6);
1513 (void)SvUPGRADE(meth, SVt_PVIV);
1514 (void)SvIOK_on(meth);
1515 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
1516 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1517 append_elem(OP_LIST,
1518 prepend_elem(OP_LIST, pack, list(arg)),
1519 newSVOP(OP_METHOD_NAMED, 0, meth)));
1520 imop->op_private |= OPpENTERSUB_NOMOD;
1522 /* Combine the ops. */
1523 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1527 =notfor apidoc apply_attrs_string
1529 Attempts to apply a list of attributes specified by the C<attrstr> and
1530 C<len> arguments to the subroutine identified by the C<cv> argument which
1531 is expected to be associated with the package identified by the C<stashpv>
1532 argument (see L<attributes>). It gets this wrong, though, in that it
1533 does not correctly identify the boundaries of the individual attribute
1534 specifications within C<attrstr>. This is not really intended for the
1535 public API, but has to be listed here for systems such as AIX which
1536 need an explicit export list for symbols. (It's called from XS code
1537 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1538 to respect attribute syntax properly would be welcome.
1544 Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
1545 char *attrstr, STRLEN len)
1550 len = strlen(attrstr);
1554 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1556 char *sstr = attrstr;
1557 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1558 attrs = append_elem(OP_LIST, attrs,
1559 newSVOP(OP_CONST, 0,
1560 newSVpvn(sstr, attrstr-sstr)));
1564 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1565 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1566 Nullsv, prepend_elem(OP_LIST,
1567 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1568 prepend_elem(OP_LIST,
1569 newSVOP(OP_CONST, 0,
1575 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1580 if (!o || PL_error_count)
1584 if (type == OP_LIST) {
1585 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1586 my_kid(kid, attrs, imopsp);
1587 } else if (type == OP_UNDEF) {
1589 } else if (type == OP_RV2SV || /* "our" declaration */
1591 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1592 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1593 yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
1594 OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
1596 GV *gv = cGVOPx_gv(cUNOPo->op_first);
1598 PL_in_my_stash = Nullhv;
1599 apply_attrs(GvSTASH(gv),
1600 (type == OP_RV2SV ? GvSV(gv) :
1601 type == OP_RV2AV ? (SV*)GvAV(gv) :
1602 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1605 o->op_private |= OPpOUR_INTRO;
1608 else if (type != OP_PADSV &&
1611 type != OP_PUSHMARK)
1613 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1615 PL_in_my == KEY_our ? "our" : "my"));
1618 else if (attrs && type != OP_PUSHMARK) {
1622 PL_in_my_stash = Nullhv;
1624 /* check for C<my Dog $spot> when deciding package */
1625 stash = PAD_COMPNAME_TYPE(o->op_targ);
1627 stash = PL_curstash;
1628 apply_attrs_my(stash, o, attrs, imopsp);
1630 o->op_flags |= OPf_MOD;
1631 o->op_private |= OPpLVAL_INTRO;
1636 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1639 int maybe_scalar = 0;
1641 /* [perl #17376]: this appears to be premature, and results in code such as
1642 C< our(%x); > executing in list mode rather than void mode */
1644 if (o->op_flags & OPf_PARENS)
1653 o = my_kid(o, attrs, &rops);
1655 if (maybe_scalar && o->op_type == OP_PADSV) {
1656 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1657 o->op_private |= OPpLVAL_INTRO;
1660 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1663 PL_in_my_stash = Nullhv;
1668 Perl_my(pTHX_ OP *o)
1670 return my_attrs(o, Nullop);
1674 Perl_sawparens(pTHX_ OP *o)
1677 o->op_flags |= OPf_PARENS;
1682 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1686 if (ckWARN(WARN_MISC) &&
1687 (left->op_type == OP_RV2AV ||
1688 left->op_type == OP_RV2HV ||
1689 left->op_type == OP_PADAV ||
1690 left->op_type == OP_PADHV)) {
1691 char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
1692 right->op_type == OP_TRANS)
1693 ? right->op_type : OP_MATCH];
1694 const char *sample = ((left->op_type == OP_RV2AV ||
1695 left->op_type == OP_PADAV)
1696 ? "@array" : "%hash");
1697 Perl_warner(aTHX_ packWARN(WARN_MISC),
1698 "Applying %s to %s will act on scalar(%s)",
1699 desc, sample, sample);
1702 if (right->op_type == OP_CONST &&
1703 cSVOPx(right)->op_private & OPpCONST_BARE &&
1704 cSVOPx(right)->op_private & OPpCONST_STRICT)
1706 no_bareword_allowed(right);
1709 if (!(right->op_flags & OPf_STACKED) &&
1710 (right->op_type == OP_MATCH ||
1711 right->op_type == OP_SUBST ||
1712 right->op_type == OP_TRANS)) {
1713 right->op_flags |= OPf_STACKED;
1714 if (right->op_type != OP_MATCH &&
1715 ! (right->op_type == OP_TRANS &&
1716 right->op_private & OPpTRANS_IDENTICAL))
1717 left = mod(left, right->op_type);
1718 if (right->op_type == OP_TRANS)
1719 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
1721 o = prepend_elem(right->op_type, scalar(left), right);
1723 return newUNOP(OP_NOT, 0, scalar(o));
1727 return bind_match(type, left,
1728 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
1732 Perl_invert(pTHX_ OP *o)
1736 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
1737 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1741 Perl_scope(pTHX_ OP *o)
1744 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1745 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1746 o->op_type = OP_LEAVE;
1747 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1749 else if (o->op_type == OP_LINESEQ) {
1751 o->op_type = OP_SCOPE;
1752 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1753 kid = ((LISTOP*)o)->op_first;
1754 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
1758 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
1764 Perl_save_hints(pTHX)
1767 SAVESPTR(GvHV(PL_hintgv));
1768 GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
1769 SAVEFREESV(GvHV(PL_hintgv));
1773 Perl_block_start(pTHX_ int full)
1775 int retval = PL_savestack_ix;
1776 /* If there were syntax errors, don't try to start a block */
1777 if (PL_yynerrs) return retval;
1779 pad_block_start(full);
1781 PL_hints &= ~HINT_BLOCK_SCOPE;
1782 SAVESPTR(PL_compiling.cop_warnings);
1783 if (! specialWARN(PL_compiling.cop_warnings)) {
1784 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1785 SAVEFREESV(PL_compiling.cop_warnings) ;
1787 SAVESPTR(PL_compiling.cop_io);
1788 if (! specialCopIO(PL_compiling.cop_io)) {
1789 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1790 SAVEFREESV(PL_compiling.cop_io) ;
1796 Perl_block_end(pTHX_ I32 floor, OP *seq)
1798 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1799 OP* retval = scalarseq(seq);
1800 /* If there were syntax errors, don't try to close a block */
1801 if (PL_yynerrs) return retval;
1803 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
1805 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
1813 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1817 Perl_newPROG(pTHX_ OP *o)
1822 PL_eval_root = newUNOP(OP_LEAVEEVAL,
1823 ((PL_in_eval & EVAL_KEEPERR)
1824 ? OPf_SPECIAL : 0), o);
1825 PL_eval_start = linklist(PL_eval_root);
1826 PL_eval_root->op_private |= OPpREFCOUNTED;
1827 OpREFCNT_set(PL_eval_root, 1);
1828 PL_eval_root->op_next = 0;
1829 CALL_PEEP(PL_eval_start);
1832 if (o->op_type == OP_STUB)
1834 PL_main_root = scope(sawparens(scalarvoid(o)));
1835 PL_curcop = &PL_compiling;
1836 PL_main_start = LINKLIST(PL_main_root);
1837 PL_main_root->op_private |= OPpREFCOUNTED;
1838 OpREFCNT_set(PL_main_root, 1);
1839 PL_main_root->op_next = 0;
1840 CALL_PEEP(PL_main_start);
1843 /* Register with debugger */
1845 CV *cv = get_cv("DB::postponed", FALSE);
1849 XPUSHs((SV*)CopFILEGV(&PL_compiling));
1851 call_sv((SV*)cv, G_DISCARD);
1858 Perl_localize(pTHX_ OP *o, I32 lex)
1860 if (o->op_flags & OPf_PARENS)
1861 /* [perl #17376]: this appears to be premature, and results in code such as
1862 C< our(%x); > executing in list mode rather than void mode */
1869 if (ckWARN(WARN_PARENTHESIS)
1870 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
1872 char *s = PL_bufptr;
1875 /* some heuristics to detect a potential error */
1876 while (*s && (strchr(", \t\n", *s)
1877 || (strchr("@$%*", *s) && ++sigil) ))
1880 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)
1881 || strchr("@$%*, \t\n", *s)))
1884 if (*s == ';' || *s == '=')
1885 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
1886 "Parentheses missing around \"%s\" list",
1887 lex ? (PL_in_my == KEY_our ? "our" : "my")
1895 o = mod(o, OP_NULL); /* a bit kludgey */
1897 PL_in_my_stash = Nullhv;
1902 Perl_jmaybe(pTHX_ OP *o)
1904 if (o->op_type == OP_LIST) {
1906 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
1907 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
1913 Perl_fold_constants(pTHX_ register OP *o)
1916 I32 type = o->op_type;
1919 if (PL_opargs[type] & OA_RETSCALAR)
1921 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
1922 o->op_targ = pad_alloc(type, SVs_PADTMP);
1924 /* integerize op, unless it happens to be C<-foo>.
1925 * XXX should pp_i_negate() do magic string negation instead? */
1926 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
1927 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
1928 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
1930 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
1933 if (!(PL_opargs[type] & OA_FOLDCONST))
1938 /* XXX might want a ck_negate() for this */
1939 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
1951 /* XXX what about the numeric ops? */
1952 if (PL_hints & HINT_LOCALE)
1957 goto nope; /* Don't try to run w/ errors */
1959 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
1960 if ((curop->op_type != OP_CONST ||
1961 (curop->op_private & OPpCONST_BARE)) &&
1962 curop->op_type != OP_LIST &&
1963 curop->op_type != OP_SCALAR &&
1964 curop->op_type != OP_NULL &&
1965 curop->op_type != OP_PUSHMARK)
1971 curop = LINKLIST(o);
1975 sv = *(PL_stack_sp--);
1976 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
1977 pad_swipe(o->op_targ, FALSE);
1978 else if (SvTEMP(sv)) { /* grab mortal temp? */
1979 (void)SvREFCNT_inc(sv);
1983 if (type == OP_RV2GV)
1984 return newGVOP(OP_GV, 0, (GV*)sv);
1985 return newSVOP(OP_CONST, 0, sv);
1992 Perl_gen_constant_list(pTHX_ register OP *o)
1995 I32 oldtmps_floor = PL_tmps_floor;
1999 return o; /* Don't attempt to run with errors */
2001 PL_op = curop = LINKLIST(o);
2008 PL_tmps_floor = oldtmps_floor;
2010 o->op_type = OP_RV2AV;
2011 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2012 o->op_seq = 0; /* needs to be revisited in peep() */
2013 curop = ((UNOP*)o)->op_first;
2014 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2021 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2023 if (!o || o->op_type != OP_LIST)
2024 o = newLISTOP(OP_LIST, 0, o, Nullop);
2026 o->op_flags &= ~OPf_WANT;
2028 if (!(PL_opargs[type] & OA_MARK))
2029 op_null(cLISTOPo->op_first);
2031 o->op_type = (OPCODE)type;
2032 o->op_ppaddr = PL_ppaddr[type];
2033 o->op_flags |= flags;
2035 o = CHECKOP(type, o);
2036 if (o->op_type != type)
2039 return fold_constants(o);
2042 /* List constructors */
2045 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2053 if (first->op_type != type
2054 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2056 return newLISTOP(type, 0, first, last);
2059 if (first->op_flags & OPf_KIDS)
2060 ((LISTOP*)first)->op_last->op_sibling = last;
2062 first->op_flags |= OPf_KIDS;
2063 ((LISTOP*)first)->op_first = last;
2065 ((LISTOP*)first)->op_last = last;
2070 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2078 if (first->op_type != type)
2079 return prepend_elem(type, (OP*)first, (OP*)last);
2081 if (last->op_type != type)
2082 return append_elem(type, (OP*)first, (OP*)last);
2084 first->op_last->op_sibling = last->op_first;
2085 first->op_last = last->op_last;
2086 first->op_flags |= (last->op_flags & OPf_KIDS);
2094 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2102 if (last->op_type == type) {
2103 if (type == OP_LIST) { /* already a PUSHMARK there */
2104 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2105 ((LISTOP*)last)->op_first->op_sibling = first;
2106 if (!(first->op_flags & OPf_PARENS))
2107 last->op_flags &= ~OPf_PARENS;
2110 if (!(last->op_flags & OPf_KIDS)) {
2111 ((LISTOP*)last)->op_last = first;
2112 last->op_flags |= OPf_KIDS;
2114 first->op_sibling = ((LISTOP*)last)->op_first;
2115 ((LISTOP*)last)->op_first = first;
2117 last->op_flags |= OPf_KIDS;
2121 return newLISTOP(type, 0, first, last);
2127 Perl_newNULLLIST(pTHX)
2129 return newOP(OP_STUB, 0);
2133 Perl_force_list(pTHX_ OP *o)
2135 if (!o || o->op_type != OP_LIST)
2136 o = newLISTOP(OP_LIST, 0, o, Nullop);
2142 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2146 NewOp(1101, listop, 1, LISTOP);
2148 listop->op_type = (OPCODE)type;
2149 listop->op_ppaddr = PL_ppaddr[type];
2152 listop->op_flags = (U8)flags;
2156 else if (!first && last)
2159 first->op_sibling = last;
2160 listop->op_first = first;
2161 listop->op_last = last;
2162 if (type == OP_LIST) {
2164 pushop = newOP(OP_PUSHMARK, 0);
2165 pushop->op_sibling = first;
2166 listop->op_first = pushop;
2167 listop->op_flags |= OPf_KIDS;
2169 listop->op_last = pushop;
2176 Perl_newOP(pTHX_ I32 type, I32 flags)
2179 NewOp(1101, o, 1, OP);
2180 o->op_type = (OPCODE)type;
2181 o->op_ppaddr = PL_ppaddr[type];
2182 o->op_flags = (U8)flags;
2185 o->op_private = (U8)(0 | (flags >> 8));
2186 if (PL_opargs[type] & OA_RETSCALAR)
2188 if (PL_opargs[type] & OA_TARGET)
2189 o->op_targ = pad_alloc(type, SVs_PADTMP);
2190 return CHECKOP(type, o);
2194 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2199 first = newOP(OP_STUB, 0);
2200 if (PL_opargs[type] & OA_MARK)
2201 first = force_list(first);
2203 NewOp(1101, unop, 1, UNOP);
2204 unop->op_type = (OPCODE)type;
2205 unop->op_ppaddr = PL_ppaddr[type];
2206 unop->op_first = first;
2207 unop->op_flags = flags | OPf_KIDS;
2208 unop->op_private = (U8)(1 | (flags >> 8));
2209 unop = (UNOP*) CHECKOP(type, unop);
2213 return fold_constants((OP *) unop);
2217 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2220 NewOp(1101, binop, 1, BINOP);
2223 first = newOP(OP_NULL, 0);
2225 binop->op_type = (OPCODE)type;
2226 binop->op_ppaddr = PL_ppaddr[type];
2227 binop->op_first = first;
2228 binop->op_flags = flags | OPf_KIDS;
2231 binop->op_private = (U8)(1 | (flags >> 8));
2234 binop->op_private = (U8)(2 | (flags >> 8));
2235 first->op_sibling = last;
2238 binop = (BINOP*)CHECKOP(type, binop);
2239 if (binop->op_next || binop->op_type != (OPCODE)type)
2242 binop->op_last = binop->op_first->op_sibling;
2244 return fold_constants((OP *)binop);
2248 uvcompare(const void *a, const void *b)
2250 if (*((UV *)a) < (*(UV *)b))
2252 if (*((UV *)a) > (*(UV *)b))
2254 if (*((UV *)a+1) < (*(UV *)b+1))
2256 if (*((UV *)a+1) > (*(UV *)b+1))
2262 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2264 SV *tstr = ((SVOP*)expr)->op_sv;
2265 SV *rstr = ((SVOP*)repl)->op_sv;
2268 U8 *t = (U8*)SvPV(tstr, tlen);
2269 U8 *r = (U8*)SvPV(rstr, rlen);
2276 register short *tbl;
2278 PL_hints |= HINT_BLOCK_SCOPE;
2279 complement = o->op_private & OPpTRANS_COMPLEMENT;
2280 del = o->op_private & OPpTRANS_DELETE;
2281 squash = o->op_private & OPpTRANS_SQUASH;
2284 o->op_private |= OPpTRANS_FROM_UTF;
2287 o->op_private |= OPpTRANS_TO_UTF;
2289 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2290 SV* listsv = newSVpvn("# comment\n",10);
2292 U8* tend = t + tlen;
2293 U8* rend = r + rlen;
2307 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2308 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2314 tsave = t = bytes_to_utf8(t, &len);
2317 if (!to_utf && rlen) {
2319 rsave = r = bytes_to_utf8(r, &len);
2323 /* There are several snags with this code on EBCDIC:
2324 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2325 2. scan_const() in toke.c has encoded chars in native encoding which makes
2326 ranges at least in EBCDIC 0..255 range the bottom odd.
2330 U8 tmpbuf[UTF8_MAXLEN+1];
2333 New(1109, cp, 2*tlen, UV);
2335 transv = newSVpvn("",0);
2337 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2339 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2341 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2345 cp[2*i+1] = cp[2*i];
2349 qsort(cp, i, 2*sizeof(UV), uvcompare);
2350 for (j = 0; j < i; j++) {
2352 diff = val - nextmin;
2354 t = uvuni_to_utf8(tmpbuf,nextmin);
2355 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2357 U8 range_mark = UTF_TO_NATIVE(0xff);
2358 t = uvuni_to_utf8(tmpbuf, val - 1);
2359 sv_catpvn(transv, (char *)&range_mark, 1);
2360 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2367 t = uvuni_to_utf8(tmpbuf,nextmin);
2368 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2370 U8 range_mark = UTF_TO_NATIVE(0xff);
2371 sv_catpvn(transv, (char *)&range_mark, 1);
2373 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2374 UNICODE_ALLOW_SUPER);
2375 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2376 t = (U8*)SvPVX(transv);
2377 tlen = SvCUR(transv);
2381 else if (!rlen && !del) {
2382 r = t; rlen = tlen; rend = tend;
2385 if ((!rlen && !del) || t == r ||
2386 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2388 o->op_private |= OPpTRANS_IDENTICAL;
2392 while (t < tend || tfirst <= tlast) {
2393 /* see if we need more "t" chars */
2394 if (tfirst > tlast) {
2395 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2397 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2399 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2406 /* now see if we need more "r" chars */
2407 if (rfirst > rlast) {
2409 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2411 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2413 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2422 rfirst = rlast = 0xffffffff;
2426 /* now see which range will peter our first, if either. */
2427 tdiff = tlast - tfirst;
2428 rdiff = rlast - rfirst;
2435 if (rfirst == 0xffffffff) {
2436 diff = tdiff; /* oops, pretend rdiff is infinite */
2438 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2439 (long)tfirst, (long)tlast);
2441 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2445 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2446 (long)tfirst, (long)(tfirst + diff),
2449 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2450 (long)tfirst, (long)rfirst);
2452 if (rfirst + diff > max)
2453 max = rfirst + diff;
2455 grows = (tfirst < rfirst &&
2456 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2468 else if (max > 0xff)
2473 Safefree(cPVOPo->op_pv);
2474 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2475 SvREFCNT_dec(listsv);
2477 SvREFCNT_dec(transv);
2479 if (!del && havefinal && rlen)
2480 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2481 newSVuv((UV)final), 0);
2484 o->op_private |= OPpTRANS_GROWS;
2496 tbl = (short*)cPVOPo->op_pv;
2498 Zero(tbl, 256, short);
2499 for (i = 0; i < (I32)tlen; i++)
2501 for (i = 0, j = 0; i < 256; i++) {
2503 if (j >= (I32)rlen) {
2512 if (i < 128 && r[j] >= 128)
2522 o->op_private |= OPpTRANS_IDENTICAL;
2524 else if (j >= (I32)rlen)
2527 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2528 tbl[0x100] = rlen - j;
2529 for (i=0; i < (I32)rlen - j; i++)
2530 tbl[0x101+i] = r[j+i];
2534 if (!rlen && !del) {
2537 o->op_private |= OPpTRANS_IDENTICAL;
2539 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2540 o->op_private |= OPpTRANS_IDENTICAL;
2542 for (i = 0; i < 256; i++)
2544 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
2545 if (j >= (I32)rlen) {
2547 if (tbl[t[i]] == -1)
2553 if (tbl[t[i]] == -1) {
2554 if (t[i] < 128 && r[j] >= 128)
2561 o->op_private |= OPpTRANS_GROWS;
2569 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2573 NewOp(1101, pmop, 1, PMOP);
2574 pmop->op_type = (OPCODE)type;
2575 pmop->op_ppaddr = PL_ppaddr[type];
2576 pmop->op_flags = (U8)flags;
2577 pmop->op_private = (U8)(0 | (flags >> 8));
2579 if (PL_hints & HINT_RE_TAINT)
2580 pmop->op_pmpermflags |= PMf_RETAINT;
2581 if (PL_hints & HINT_LOCALE)
2582 pmop->op_pmpermflags |= PMf_LOCALE;
2583 pmop->op_pmflags = pmop->op_pmpermflags;
2588 if(av_len((AV*) PL_regex_pad[0]) > -1) {
2589 repointer = av_pop((AV*)PL_regex_pad[0]);
2590 pmop->op_pmoffset = SvIV(repointer);
2591 SvREPADTMP_off(repointer);
2592 sv_setiv(repointer,0);
2594 repointer = newSViv(0);
2595 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2596 pmop->op_pmoffset = av_len(PL_regex_padav);
2597 PL_regex_pad = AvARRAY(PL_regex_padav);
2602 /* link into pm list */
2603 if (type != OP_TRANS && PL_curstash) {
2604 pmop->op_pmnext = HvPMROOT(PL_curstash);
2605 HvPMROOT(PL_curstash) = pmop;
2606 PmopSTASH_set(pmop,PL_curstash);
2613 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
2617 I32 repl_has_vars = 0;
2619 if (o->op_type == OP_TRANS)
2620 return pmtrans(o, expr, repl);
2622 PL_hints |= HINT_BLOCK_SCOPE;
2625 if (expr->op_type == OP_CONST) {
2627 SV *pat = ((SVOP*)expr)->op_sv;
2628 char *p = SvPV(pat, plen);
2629 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
2630 sv_setpvn(pat, "\\s+", 3);
2631 p = SvPV(pat, plen);
2632 pm->op_pmflags |= PMf_SKIPWHITE;
2635 pm->op_pmdynflags |= PMdf_UTF8;
2636 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
2637 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
2638 pm->op_pmflags |= PMf_WHITE;
2642 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2643 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2645 : OP_REGCMAYBE),0,expr);
2647 NewOp(1101, rcop, 1, LOGOP);
2648 rcop->op_type = OP_REGCOMP;
2649 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2650 rcop->op_first = scalar(expr);
2651 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
2652 ? (OPf_SPECIAL | OPf_KIDS)
2654 rcop->op_private = 1;
2657 /* establish postfix order */
2658 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2660 rcop->op_next = expr;
2661 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2664 rcop->op_next = LINKLIST(expr);
2665 expr->op_next = (OP*)rcop;
2668 prepend_elem(o->op_type, scalar((OP*)rcop), o);
2673 if (pm->op_pmflags & PMf_EVAL) {
2675 if (CopLINE(PL_curcop) < PL_multi_end)
2676 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
2678 else if (repl->op_type == OP_CONST)
2682 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
2683 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
2684 if (curop->op_type == OP_GV) {
2685 GV *gv = cGVOPx_gv(curop);
2687 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
2690 else if (curop->op_type == OP_RV2CV)
2692 else if (curop->op_type == OP_RV2SV ||
2693 curop->op_type == OP_RV2AV ||
2694 curop->op_type == OP_RV2HV ||
2695 curop->op_type == OP_RV2GV) {
2696 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2699 else if (curop->op_type == OP_PADSV ||
2700 curop->op_type == OP_PADAV ||
2701 curop->op_type == OP_PADHV ||
2702 curop->op_type == OP_PADANY) {
2705 else if (curop->op_type == OP_PUSHRE)
2706 ; /* Okay here, dangerous in newASSIGNOP */
2716 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
2717 pm->op_pmflags |= PMf_CONST; /* const for long enough */
2718 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
2719 prepend_elem(o->op_type, scalar(repl), o);
2722 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
2723 pm->op_pmflags |= PMf_MAYBE_CONST;
2724 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2726 NewOp(1101, rcop, 1, LOGOP);
2727 rcop->op_type = OP_SUBSTCONT;
2728 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
2729 rcop->op_first = scalar(repl);
2730 rcop->op_flags |= OPf_KIDS;
2731 rcop->op_private = 1;
2734 /* establish postfix order */
2735 rcop->op_next = LINKLIST(repl);
2736 repl->op_next = (OP*)rcop;
2738 pm->op_pmreplroot = scalar((OP*)rcop);
2739 pm->op_pmreplstart = LINKLIST(rcop);
2748 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
2751 NewOp(1101, svop, 1, SVOP);
2752 svop->op_type = (OPCODE)type;
2753 svop->op_ppaddr = PL_ppaddr[type];
2755 svop->op_next = (OP*)svop;
2756 svop->op_flags = (U8)flags;
2757 if (PL_opargs[type] & OA_RETSCALAR)
2759 if (PL_opargs[type] & OA_TARGET)
2760 svop->op_targ = pad_alloc(type, SVs_PADTMP);
2761 return CHECKOP(type, svop);
2765 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2768 NewOp(1101, padop, 1, PADOP);
2769 padop->op_type = (OPCODE)type;
2770 padop->op_ppaddr = PL_ppaddr[type];
2771 padop->op_padix = pad_alloc(type, SVs_PADTMP);
2772 SvREFCNT_dec(PAD_SVl(padop->op_padix));
2773 PAD_SETSV(padop->op_padix, sv);
2776 padop->op_next = (OP*)padop;
2777 padop->op_flags = (U8)flags;
2778 if (PL_opargs[type] & OA_RETSCALAR)
2780 if (PL_opargs[type] & OA_TARGET)
2781 padop->op_targ = pad_alloc(type, SVs_PADTMP);
2782 return CHECKOP(type, padop);
2786 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
2791 return newPADOP(type, flags, SvREFCNT_inc(gv));
2793 return newSVOP(type, flags, SvREFCNT_inc(gv));
2798 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
2801 NewOp(1101, pvop, 1, PVOP);
2802 pvop->op_type = (OPCODE)type;
2803 pvop->op_ppaddr = PL_ppaddr[type];
2805 pvop->op_next = (OP*)pvop;
2806 pvop->op_flags = (U8)flags;
2807 if (PL_opargs[type] & OA_RETSCALAR)
2809 if (PL_opargs[type] & OA_TARGET)
2810 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
2811 return CHECKOP(type, pvop);
2815 Perl_package(pTHX_ OP *o)
2820 save_hptr(&PL_curstash);
2821 save_item(PL_curstname);
2823 name = SvPV(cSVOPo->op_sv, len);
2824 PL_curstash = gv_stashpvn(name, len, TRUE);
2825 sv_setpvn(PL_curstname, name, len);
2828 PL_hints |= HINT_BLOCK_SCOPE;
2829 PL_copline = NOLINE;
2834 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
2840 if (idop->op_type != OP_CONST)
2841 Perl_croak(aTHX_ "Module name must be constant");
2845 if (version != Nullop) {
2846 SV *vesv = ((SVOP*)version)->op_sv;
2848 if (arg == Nullop && !SvNIOKp(vesv)) {
2855 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
2856 Perl_croak(aTHX_ "Version number must be constant number");
2858 /* Make copy of idop so we don't free it twice */
2859 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
2861 /* Fake up a method call to VERSION */
2862 meth = newSVpvn("VERSION",7);
2863 sv_upgrade(meth, SVt_PVIV);
2864 (void)SvIOK_on(meth);
2865 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
2866 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2867 append_elem(OP_LIST,
2868 prepend_elem(OP_LIST, pack, list(version)),
2869 newSVOP(OP_METHOD_NAMED, 0, meth)));
2873 /* Fake up an import/unimport */
2874 if (arg && arg->op_type == OP_STUB)
2875 imop = arg; /* no import on explicit () */
2876 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
2877 imop = Nullop; /* use 5.0; */
2882 /* Make copy of idop so we don't free it twice */
2883 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
2885 /* Fake up a method call to import/unimport */
2886 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);
2887 (void)SvUPGRADE(meth, SVt_PVIV);
2888 (void)SvIOK_on(meth);
2889 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
2890 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2891 append_elem(OP_LIST,
2892 prepend_elem(OP_LIST, pack, list(arg)),
2893 newSVOP(OP_METHOD_NAMED, 0, meth)));
2896 /* Fake up the BEGIN {}, which does its thing immediately. */
2898 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
2901 append_elem(OP_LINESEQ,
2902 append_elem(OP_LINESEQ,
2903 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, idop)),
2904 newSTATEOP(0, Nullch, veop)),
2905 newSTATEOP(0, Nullch, imop) ));
2907 /* The "did you use incorrect case?" warning used to be here.
2908 * The problem is that on case-insensitive filesystems one
2909 * might get false positives for "use" (and "require"):
2910 * "use Strict" or "require CARP" will work. This causes
2911 * portability problems for the script: in case-strict
2912 * filesystems the script will stop working.
2914 * The "incorrect case" warning checked whether "use Foo"
2915 * imported "Foo" to your namespace, but that is wrong, too:
2916 * there is no requirement nor promise in the language that
2917 * a Foo.pm should or would contain anything in package "Foo".
2919 * There is very little Configure-wise that can be done, either:
2920 * the case-sensitivity of the build filesystem of Perl does not
2921 * help in guessing the case-sensitivity of the runtime environment.
2924 PL_hints |= HINT_BLOCK_SCOPE;
2925 PL_copline = NOLINE;
2930 =head1 Embedding Functions
2932 =for apidoc load_module
2934 Loads the module whose name is pointed to by the string part of name.
2935 Note that the actual module name, not its filename, should be given.
2936 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
2937 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
2938 (or 0 for no flags). ver, if specified, provides version semantics
2939 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
2940 arguments can be used to specify arguments to the module's import()
2941 method, similar to C<use Foo::Bar VERSION LIST>.
2946 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
2949 va_start(args, ver);
2950 vload_module(flags, name, ver, &args);
2954 #ifdef PERL_IMPLICIT_CONTEXT
2956 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
2960 va_start(args, ver);
2961 vload_module(flags, name, ver, &args);
2967 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
2969 OP *modname, *veop, *imop;
2971 modname = newSVOP(OP_CONST, 0, name);
2972 modname->op_private |= OPpCONST_BARE;
2974 veop = newSVOP(OP_CONST, 0, ver);
2978 if (flags & PERL_LOADMOD_NOIMPORT) {
2979 imop = sawparens(newNULLLIST());
2981 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
2982 imop = va_arg(*args, OP*);
2987 sv = va_arg(*args, SV*);
2989 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
2990 sv = va_arg(*args, SV*);
2994 line_t ocopline = PL_copline;
2995 COP *ocurcop = PL_curcop;
2996 int oexpect = PL_expect;
2998 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
2999 veop, modname, imop);
3000 PL_expect = oexpect;
3001 PL_copline = ocopline;
3002 PL_curcop = ocurcop;
3007 Perl_dofile(pTHX_ OP *term)
3012 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3013 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
3014 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3016 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3017 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3018 append_elem(OP_LIST, term,
3019 scalar(newUNOP(OP_RV2CV, 0,
3024 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3030 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3032 return newBINOP(OP_LSLICE, flags,
3033 list(force_list(subscript)),
3034 list(force_list(listval)) );
3038 S_list_assignment(pTHX_ register OP *o)
3043 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3044 o = cUNOPo->op_first;
3046 if (o->op_type == OP_COND_EXPR) {
3047 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3048 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3053 yyerror("Assignment to both a list and a scalar");
3057 if (o->op_type == OP_LIST &&
3058 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3059 o->op_private & OPpLVAL_INTRO)
3062 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3063 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3064 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3067 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3070 if (o->op_type == OP_RV2SV)
3077 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3082 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3083 return newLOGOP(optype, 0,
3084 mod(scalar(left), optype),
3085 newUNOP(OP_SASSIGN, 0, scalar(right)));
3088 return newBINOP(optype, OPf_STACKED,
3089 mod(scalar(left), optype), scalar(right));
3093 if (list_assignment(left)) {
3097 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3098 left = mod(left, OP_AASSIGN);
3106 curop = list(force_list(left));
3107 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3108 o->op_private = (U8)(0 | (flags >> 8));
3110 /* PL_generation sorcery:
3111 * an assignment like ($a,$b) = ($c,$d) is easier than
3112 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3113 * To detect whether there are common vars, the global var
3114 * PL_generation is incremented for each assign op we compile.
3115 * Then, while compiling the assign op, we run through all the
3116 * variables on both sides of the assignment, setting a spare slot
3117 * in each of them to PL_generation. If any of them already have
3118 * that value, we know we've got commonality. We could use a
3119 * single bit marker, but then we'd have to make 2 passes, first
3120 * to clear the flag, then to test and set it. To find somewhere
3121 * to store these values, evil chicanery is done with SvCUR().
3124 if (!(left->op_private & OPpLVAL_INTRO)) {
3127 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3128 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3129 if (curop->op_type == OP_GV) {
3130 GV *gv = cGVOPx_gv(curop);
3131 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3133 SvCUR(gv) = PL_generation;
3135 else if (curop->op_type == OP_PADSV ||
3136 curop->op_type == OP_PADAV ||
3137 curop->op_type == OP_PADHV ||
3138 curop->op_type == OP_PADANY)
3140 if (PAD_COMPNAME_GEN(curop->op_targ)
3141 == (STRLEN)PL_generation)
3143 PAD_COMPNAME_GEN(curop->op_targ)
3147 else if (curop->op_type == OP_RV2CV)
3149 else if (curop->op_type == OP_RV2SV ||
3150 curop->op_type == OP_RV2AV ||
3151 curop->op_type == OP_RV2HV ||
3152 curop->op_type == OP_RV2GV) {
3153 if (lastop->op_type != OP_GV) /* funny deref? */
3156 else if (curop->op_type == OP_PUSHRE) {
3157 if (((PMOP*)curop)->op_pmreplroot) {
3159 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3160 ((PMOP*)curop)->op_pmreplroot));
3162 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3164 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3166 SvCUR(gv) = PL_generation;
3175 o->op_private |= OPpASSIGN_COMMON;
3177 if (right && right->op_type == OP_SPLIT) {
3179 if ((tmpop = ((LISTOP*)right)->op_first) &&
3180 tmpop->op_type == OP_PUSHRE)
3182 PMOP *pm = (PMOP*)tmpop;
3183 if (left->op_type == OP_RV2AV &&
3184 !(left->op_private & OPpLVAL_INTRO) &&
3185 !(o->op_private & OPpASSIGN_COMMON) )
3187 tmpop = ((UNOP*)left)->op_first;
3188 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3190 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3191 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3193 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3194 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3196 pm->op_pmflags |= PMf_ONCE;
3197 tmpop = cUNOPo->op_first; /* to list (nulled) */
3198 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3199 tmpop->op_sibling = Nullop; /* don't free split */
3200 right->op_next = tmpop->op_next; /* fix starting loc */
3201 op_free(o); /* blow off assign */
3202 right->op_flags &= ~OPf_WANT;
3203 /* "I don't know and I don't care." */
3208 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3209 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3211 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3213 sv_setiv(sv, PL_modcount+1);
3221 right = newOP(OP_UNDEF, 0);
3222 if (right->op_type == OP_READLINE) {
3223 right->op_flags |= OPf_STACKED;
3224 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3227 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3228 o = newBINOP(OP_SASSIGN, flags,
3229 scalar(right), mod(scalar(left), OP_SASSIGN) );
3241 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3243 U32 seq = intro_my();
3246 NewOp(1101, cop, 1, COP);
3247 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3248 cop->op_type = OP_DBSTATE;
3249 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3252 cop->op_type = OP_NEXTSTATE;
3253 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3255 cop->op_flags = (U8)flags;
3256 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3258 cop->op_private |= NATIVE_HINTS;
3260 PL_compiling.op_private = cop->op_private;
3261 cop->op_next = (OP*)cop;
3264 cop->cop_label = label;
3265 PL_hints |= HINT_BLOCK_SCOPE;
3268 cop->cop_arybase = PL_curcop->cop_arybase;
3269 if (specialWARN(PL_curcop->cop_warnings))
3270 cop->cop_warnings = PL_curcop->cop_warnings ;
3272 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3273 if (specialCopIO(PL_curcop->cop_io))
3274 cop->cop_io = PL_curcop->cop_io;
3276 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3279 if (PL_copline == NOLINE)
3280 CopLINE_set(cop, CopLINE(PL_curcop));
3282 CopLINE_set(cop, PL_copline);
3283 PL_copline = NOLINE;
3286 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3288 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3290 CopSTASH_set(cop, PL_curstash);
3292 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3293 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3294 if (svp && *svp != &PL_sv_undef ) {
3295 (void)SvIOK_on(*svp);
3296 SvIVX(*svp) = PTR2IV(cop);
3300 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3305 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3307 return new_logop(type, flags, &first, &other);
3311 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3315 OP *first = *firstp;
3316 OP *other = *otherp;
3318 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3319 return newBINOP(type, flags, scalar(first), scalar(other));
3321 scalarboolean(first);
3322 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3323 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3324 if (type == OP_AND || type == OP_OR) {
3330 first = *firstp = cUNOPo->op_first;
3332 first->op_next = o->op_next;
3333 cUNOPo->op_first = Nullop;
3337 if (first->op_type == OP_CONST) {
3338 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE)) {
3339 if (first->op_private & OPpCONST_STRICT)
3340 no_bareword_allowed(first);
3342 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3344 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3355 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3356 OP *k1 = ((UNOP*)first)->op_first;
3357 OP *k2 = k1->op_sibling;
3359 switch (first->op_type)
3362 if (k2 && k2->op_type == OP_READLINE
3363 && (k2->op_flags & OPf_STACKED)
3364 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3366 warnop = k2->op_type;
3371 if (k1->op_type == OP_READDIR
3372 || k1->op_type == OP_GLOB
3373 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3374 || k1->op_type == OP_EACH)
3376 warnop = ((k1->op_type == OP_NULL)
3377 ? (OPCODE)k1->op_targ : k1->op_type);
3382 line_t oldline = CopLINE(PL_curcop);
3383 CopLINE_set(PL_curcop, PL_copline);
3384 Perl_warner(aTHX_ packWARN(WARN_MISC),
3385 "Value of %s%s can be \"0\"; test with defined()",
3387 ((warnop == OP_READLINE || warnop == OP_GLOB)
3388 ? " construct" : "() operator"));
3389 CopLINE_set(PL_curcop, oldline);
3396 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3397 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3399 NewOp(1101, logop, 1, LOGOP);
3401 logop->op_type = (OPCODE)type;
3402 logop->op_ppaddr = PL_ppaddr[type];
3403 logop->op_first = first;
3404 logop->op_flags = flags | OPf_KIDS;
3405 logop->op_other = LINKLIST(other);
3406 logop->op_private = (U8)(1 | (flags >> 8));
3408 /* establish postfix order */
3409 logop->op_next = LINKLIST(first);
3410 first->op_next = (OP*)logop;
3411 first->op_sibling = other;
3413 o = newUNOP(OP_NULL, 0, (OP*)logop);
3420 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3427 return newLOGOP(OP_AND, 0, first, trueop);
3429 return newLOGOP(OP_OR, 0, first, falseop);
3431 scalarboolean(first);
3432 if (first->op_type == OP_CONST) {
3433 if (first->op_private & OPpCONST_BARE &&
3434 first->op_private & OPpCONST_STRICT) {
3435 no_bareword_allowed(first);
3437 if (SvTRUE(((SVOP*)first)->op_sv)) {
3448 NewOp(1101, logop, 1, LOGOP);
3449 logop->op_type = OP_COND_EXPR;
3450 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3451 logop->op_first = first;
3452 logop->op_flags = flags | OPf_KIDS;
3453 logop->op_private = (U8)(1 | (flags >> 8));
3454 logop->op_other = LINKLIST(trueop);
3455 logop->op_next = LINKLIST(falseop);
3458 /* establish postfix order */
3459 start = LINKLIST(first);
3460 first->op_next = (OP*)logop;
3462 first->op_sibling = trueop;
3463 trueop->op_sibling = falseop;
3464 o = newUNOP(OP_NULL, 0, (OP*)logop);
3466 trueop->op_next = falseop->op_next = o;
3473 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3481 NewOp(1101, range, 1, LOGOP);
3483 range->op_type = OP_RANGE;
3484 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3485 range->op_first = left;
3486 range->op_flags = OPf_KIDS;
3487 leftstart = LINKLIST(left);
3488 range->op_other = LINKLIST(right);
3489 range->op_private = (U8)(1 | (flags >> 8));
3491 left->op_sibling = right;
3493 range->op_next = (OP*)range;
3494 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3495 flop = newUNOP(OP_FLOP, 0, flip);
3496 o = newUNOP(OP_NULL, 0, flop);
3498 range->op_next = leftstart;
3500 left->op_next = flip;
3501 right->op_next = flop;
3503 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3504 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3505 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3506 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3508 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3509 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3512 if (!flip->op_private || !flop->op_private)
3513 linklist(o); /* blow off optimizer unless constant */
3519 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3523 int once = block && block->op_flags & OPf_SPECIAL &&
3524 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3527 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3528 return block; /* do {} while 0 does once */
3529 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3530 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3531 expr = newUNOP(OP_DEFINED, 0,
3532 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3533 } else if (expr->op_flags & OPf_KIDS) {
3534 OP *k1 = ((UNOP*)expr)->op_first;
3535 OP *k2 = (k1) ? k1->op_sibling : NULL;
3536 switch (expr->op_type) {
3538 if (k2 && k2->op_type == OP_READLINE
3539 && (k2->op_flags & OPf_STACKED)
3540 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3541 expr = newUNOP(OP_DEFINED, 0, expr);
3545 if (k1->op_type == OP_READDIR
3546 || k1->op_type == OP_GLOB
3547 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3548 || k1->op_type == OP_EACH)
3549 expr = newUNOP(OP_DEFINED, 0, expr);
3555 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3556 o = new_logop(OP_AND, 0, &expr, &listop);
3559 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3561 if (once && o != listop)
3562 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3565 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3567 o->op_flags |= flags;
3569 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3574 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3582 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3583 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3584 expr = newUNOP(OP_DEFINED, 0,
3585 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3586 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3587 OP *k1 = ((UNOP*)expr)->op_first;
3588 OP *k2 = (k1) ? k1->op_sibling : NULL;
3589 switch (expr->op_type) {
3591 if (k2 && k2->op_type == OP_READLINE
3592 && (k2->op_flags & OPf_STACKED)
3593 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3594 expr = newUNOP(OP_DEFINED, 0, expr);
3598 if (k1->op_type == OP_READDIR
3599 || k1->op_type == OP_GLOB
3600 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3601 || k1->op_type == OP_EACH)
3602 expr = newUNOP(OP_DEFINED, 0, expr);
3608 block = newOP(OP_NULL, 0);
3610 block = scope(block);
3614 next = LINKLIST(cont);
3617 OP *unstack = newOP(OP_UNSTACK, 0);
3620 cont = append_elem(OP_LINESEQ, cont, unstack);
3623 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3624 redo = LINKLIST(listop);
3627 PL_copline = (line_t)whileline;
3629 o = new_logop(OP_AND, 0, &expr, &listop);
3630 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3631 op_free(expr); /* oops, it's a while (0) */
3633 return Nullop; /* listop already freed by new_logop */
3636 ((LISTOP*)listop)->op_last->op_next =
3637 (o == listop ? redo : LINKLIST(o));
3643 NewOp(1101,loop,1,LOOP);
3644 loop->op_type = OP_ENTERLOOP;
3645 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3646 loop->op_private = 0;
3647 loop->op_next = (OP*)loop;
3650 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3652 loop->op_redoop = redo;
3653 loop->op_lastop = o;
3654 o->op_private |= loopflags;
3657 loop->op_nextop = next;
3659 loop->op_nextop = o;
3661 o->op_flags |= flags;
3662 o->op_private |= (flags >> 8);
3667 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
3671 PADOFFSET padoff = 0;
3676 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
3677 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
3678 sv->op_type = OP_RV2GV;
3679 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3681 else if (sv->op_type == OP_PADSV) { /* private variable */
3682 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
3683 padoff = sv->op_targ;
3688 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3689 padoff = sv->op_targ;
3691 iterflags |= OPf_SPECIAL;
3696 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3699 sv = newGVOP(OP_GV, 0, PL_defgv);
3701 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3702 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3703 iterflags |= OPf_STACKED;
3705 else if (expr->op_type == OP_NULL &&
3706 (expr->op_flags & OPf_KIDS) &&
3707 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3709 /* Basically turn for($x..$y) into the same as for($x,$y), but we
3710 * set the STACKED flag to indicate that these values are to be
3711 * treated as min/max values by 'pp_iterinit'.
3713 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
3714 LOGOP* range = (LOGOP*) flip->op_first;
3715 OP* left = range->op_first;
3716 OP* right = left->op_sibling;
3719 range->op_flags &= ~OPf_KIDS;
3720 range->op_first = Nullop;
3722 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
3723 listop->op_first->op_next = range->op_next;
3724 left->op_next = range->op_other;
3725 right->op_next = (OP*)listop;
3726 listop->op_next = listop->op_first;
3729 expr = (OP*)(listop);
3731 iterflags |= OPf_STACKED;
3734 expr = mod(force_list(expr), OP_GREPSTART);
3738 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
3739 append_elem(OP_LIST, expr, scalar(sv))));
3740 assert(!loop->op_next);
3741 /* for my $x () sets OPpLVAL_INTRO;
3742 * for our $x () sets OPpOUR_INTRO; both only used by Deparse.pm */
3743 loop->op_private = iterpflags;
3744 #ifdef PL_OP_SLAB_ALLOC
3747 NewOp(1234,tmp,1,LOOP);
3748 Copy(loop,tmp,1,LOOP);
3753 Renew(loop, 1, LOOP);
3755 loop->op_targ = padoff;
3756 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
3757 PL_copline = forline;
3758 return newSTATEOP(0, label, wop);
3762 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
3767 if (type != OP_GOTO || label->op_type == OP_CONST) {
3768 /* "last()" means "last" */
3769 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
3770 o = newOP(type, OPf_SPECIAL);
3772 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
3773 ? SvPVx(((SVOP*)label)->op_sv, n_a)
3779 if (label->op_type == OP_ENTERSUB)
3780 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
3781 o = newUNOP(type, OPf_STACKED, label);
3783 PL_hints |= HINT_BLOCK_SCOPE;
3788 =for apidoc cv_undef
3790 Clear out all the active components of a CV. This can happen either
3791 by an explicit C<undef &foo>, or by the reference count going to zero.
3792 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
3793 children can still follow the full lexical scope chain.
3799 Perl_cv_undef(pTHX_ CV *cv)
3802 if (CvFILE(cv) && !CvXSUB(cv)) {
3803 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
3804 Safefree(CvFILE(cv));
3809 if (!CvXSUB(cv) && CvROOT(cv)) {
3811 Perl_croak(aTHX_ "Can't undef active subroutine");
3814 PAD_SAVE_SETNULLPAD();
3816 op_free(CvROOT(cv));
3817 CvROOT(cv) = Nullop;
3820 SvPOK_off((SV*)cv); /* forget prototype */
3825 /* remove CvOUTSIDE unless this is an undef rather than a free */
3826 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
3827 if (!CvWEAKOUTSIDE(cv))
3828 SvREFCNT_dec(CvOUTSIDE(cv));
3829 CvOUTSIDE(cv) = Nullcv;
3832 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
3838 /* delete all flags except WEAKOUTSIDE */
3839 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
3843 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
3845 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
3846 SV* msg = sv_newmortal();
3850 gv_efullname3(name = sv_newmortal(), gv, Nullch);
3851 sv_setpv(msg, "Prototype mismatch:");
3853 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
3855 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (SV *)cv);
3856 sv_catpv(msg, " vs ");
3858 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
3860 sv_catpv(msg, "none");
3861 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
3865 static void const_sv_xsub(pTHX_ CV* cv);
3869 =head1 Optree Manipulation Functions
3871 =for apidoc cv_const_sv
3873 If C<cv> is a constant sub eligible for inlining. returns the constant
3874 value returned by the sub. Otherwise, returns NULL.
3876 Constant subs can be created with C<newCONSTSUB> or as described in
3877 L<perlsub/"Constant Functions">.
3882 Perl_cv_const_sv(pTHX_ CV *cv)
3884 if (!cv || !CvCONST(cv))
3886 return (SV*)CvXSUBANY(cv).any_ptr;
3890 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
3897 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
3898 o = cLISTOPo->op_first->op_sibling;
3900 for (; o; o = o->op_next) {
3901 OPCODE type = o->op_type;
3903 if (sv && o->op_next == o)
3905 if (o->op_next != o) {
3906 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
3908 if (type == OP_DBSTATE)
3911 if (type == OP_LEAVESUB || type == OP_RETURN)
3915 if (type == OP_CONST && cSVOPo->op_sv)
3917 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
3918 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
3922 /* We get here only from cv_clone2() while creating a closure.
3923 Copy the const value here instead of in cv_clone2 so that
3924 SvREADONLY_on doesn't lead to problems when leaving
3929 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
3941 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
3951 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
3955 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
3957 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
3961 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
3967 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
3971 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
3972 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
3973 SV *sv = sv_newmortal();
3974 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
3975 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
3976 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3981 gv = gv_fetchpv(name ? name : (aname ? aname :
3982 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__")),
3983 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
3993 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
3994 maximum a prototype before. */
3995 if (SvTYPE(gv) > SVt_NULL) {
3996 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
3997 && ckWARN_d(WARN_PROTOTYPE))
3999 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4001 cv_ckproto((CV*)gv, NULL, ps);
4004 sv_setpv((SV*)gv, ps);
4006 sv_setiv((SV*)gv, -1);
4007 SvREFCNT_dec(PL_compcv);
4008 cv = PL_compcv = NULL;
4009 PL_sub_generation++;
4013 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4015 #ifdef GV_UNIQUE_CHECK
4016 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4017 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4021 if (!block || !ps || *ps || attrs)
4024 const_sv = op_const_sv(block, Nullcv);
4027 bool exists = CvROOT(cv) || CvXSUB(cv);
4029 #ifdef GV_UNIQUE_CHECK
4030 if (exists && GvUNIQUE(gv)) {
4031 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4035 /* if the subroutine doesn't exist and wasn't pre-declared
4036 * with a prototype, assume it will be AUTOLOADed,
4037 * skipping the prototype check
4039 if (exists || SvPOK(cv))
4040 cv_ckproto(cv, gv, ps);
4041 /* already defined (or promised)? */
4042 if (exists || GvASSUMECV(gv)) {
4043 if (!block && !attrs) {
4044 if (CvFLAGS(PL_compcv)) {
4045 /* might have had built-in attrs applied */
4046 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4048 /* just a "sub foo;" when &foo is already defined */
4049 SAVEFREESV(PL_compcv);
4052 /* ahem, death to those who redefine active sort subs */
4053 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4054 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4056 if (ckWARN(WARN_REDEFINE)
4058 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4060 line_t oldline = CopLINE(PL_curcop);
4061 if (PL_copline != NOLINE)
4062 CopLINE_set(PL_curcop, PL_copline);
4063 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4064 CvCONST(cv) ? "Constant subroutine %s redefined"
4065 : "Subroutine %s redefined", name);
4066 CopLINE_set(PL_curcop, oldline);
4074 SvREFCNT_inc(const_sv);
4076 assert(!CvROOT(cv) && !CvCONST(cv));
4077 sv_setpv((SV*)cv, ""); /* prototype is "" */
4078 CvXSUBANY(cv).any_ptr = const_sv;
4079 CvXSUB(cv) = const_sv_xsub;
4084 cv = newCONSTSUB(NULL, name, const_sv);
4087 SvREFCNT_dec(PL_compcv);
4089 PL_sub_generation++;
4096 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4097 * before we clobber PL_compcv.
4101 /* Might have had built-in attributes applied -- propagate them. */
4102 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4103 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4104 stash = GvSTASH(CvGV(cv));
4105 else if (CvSTASH(cv))
4106 stash = CvSTASH(cv);
4108 stash = PL_curstash;
4111 /* possibly about to re-define existing subr -- ignore old cv */
4112 rcv = (SV*)PL_compcv;
4113 if (name && GvSTASH(gv))
4114 stash = GvSTASH(gv);
4116 stash = PL_curstash;
4118 apply_attrs(stash, rcv, attrs, FALSE);
4120 if (cv) { /* must reuse cv if autoloaded */
4122 /* got here with just attrs -- work done, so bug out */
4123 SAVEFREESV(PL_compcv);
4126 /* transfer PL_compcv to cv */
4128 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4129 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4130 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4131 CvOUTSIDE(PL_compcv) = 0;
4132 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4133 CvPADLIST(PL_compcv) = 0;
4134 /* inner references to PL_compcv must be fixed up ... */
4135 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4136 /* ... before we throw it away */
4137 SvREFCNT_dec(PL_compcv);
4138 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4139 ++PL_sub_generation;
4146 PL_sub_generation++;
4150 CvFILE_set_from_cop(cv, PL_curcop);
4151 CvSTASH(cv) = PL_curstash;
4154 sv_setpv((SV*)cv, ps);
4156 if (PL_error_count) {
4160 char *s = strrchr(name, ':');
4162 if (strEQ(s, "BEGIN")) {
4164 "BEGIN not safe after errors--compilation aborted";
4165 if (PL_in_eval & EVAL_KEEPERR)
4166 Perl_croak(aTHX_ not_safe);
4168 /* force display of errors found but not reported */
4169 sv_catpv(ERRSV, not_safe);
4170 Perl_croak(aTHX_ "%"SVf, ERRSV);
4179 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4180 mod(scalarseq(block), OP_LEAVESUBLV));
4183 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4185 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4186 OpREFCNT_set(CvROOT(cv), 1);
4187 CvSTART(cv) = LINKLIST(CvROOT(cv));
4188 CvROOT(cv)->op_next = 0;
4189 CALL_PEEP(CvSTART(cv));
4191 /* now that optimizer has done its work, adjust pad values */
4193 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4196 assert(!CvCONST(cv));
4197 if (ps && !*ps && op_const_sv(block, cv))
4201 if (name || aname) {
4203 char *tname = (name ? name : aname);
4205 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4206 SV *sv = NEWSV(0,0);
4207 SV *tmpstr = sv_newmortal();
4208 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4212 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4214 (long)PL_subline, (long)CopLINE(PL_curcop));
4215 gv_efullname3(tmpstr, gv, Nullch);
4216 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4217 hv = GvHVn(db_postponed);
4218 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4219 && (pcv = GvCV(db_postponed)))
4225 call_sv((SV*)pcv, G_DISCARD);
4229 if ((s = strrchr(tname,':')))
4234 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4237 if (strEQ(s, "BEGIN") && !PL_error_count) {
4238 I32 oldscope = PL_scopestack_ix;
4240 SAVECOPFILE(&PL_compiling);
4241 SAVECOPLINE(&PL_compiling);
4244 PL_beginav = newAV();
4245 DEBUG_x( dump_sub(gv) );
4246 av_push(PL_beginav, (SV*)cv);
4247 GvCV(gv) = 0; /* cv has been hijacked */
4248 call_list(oldscope, PL_beginav);
4250 PL_curcop = &PL_compiling;
4251 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4254 else if (strEQ(s, "END") && !PL_error_count) {
4257 DEBUG_x( dump_sub(gv) );
4258 av_unshift(PL_endav, 1);
4259 av_store(PL_endav, 0, (SV*)cv);
4260 GvCV(gv) = 0; /* cv has been hijacked */
4262 else if (strEQ(s, "CHECK") && !PL_error_count) {
4264 PL_checkav = newAV();
4265 DEBUG_x( dump_sub(gv) );
4266 if (PL_main_start && ckWARN(WARN_VOID))
4267 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4268 av_unshift(PL_checkav, 1);
4269 av_store(PL_checkav, 0, (SV*)cv);
4270 GvCV(gv) = 0; /* cv has been hijacked */
4272 else if (strEQ(s, "INIT") && !PL_error_count) {
4274 PL_initav = newAV();
4275 DEBUG_x( dump_sub(gv) );
4276 if (PL_main_start && ckWARN(WARN_VOID))
4277 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4278 av_push(PL_initav, (SV*)cv);
4279 GvCV(gv) = 0; /* cv has been hijacked */
4284 PL_copline = NOLINE;
4289 /* XXX unsafe for threads if eval_owner isn't held */
4291 =for apidoc newCONSTSUB
4293 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4294 eligible for inlining at compile-time.
4300 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4306 SAVECOPLINE(PL_curcop);
4307 CopLINE_set(PL_curcop, PL_copline);
4310 PL_hints &= ~HINT_BLOCK_SCOPE;
4313 SAVESPTR(PL_curstash);
4314 SAVECOPSTASH(PL_curcop);
4315 PL_curstash = stash;
4316 CopSTASH_set(PL_curcop,stash);
4319 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4320 CvXSUBANY(cv).any_ptr = sv;
4322 sv_setpv((SV*)cv, ""); /* prototype is "" */
4330 =for apidoc U||newXS
4332 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4338 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
4340 GV *gv = gv_fetchpv(name ? name :
4341 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4342 GV_ADDMULTI, SVt_PVCV);
4346 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4348 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4350 /* just a cached method */
4354 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4355 /* already defined (or promised) */
4356 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4357 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4358 line_t oldline = CopLINE(PL_curcop);
4359 if (PL_copline != NOLINE)
4360 CopLINE_set(PL_curcop, PL_copline);
4361 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4362 CvCONST(cv) ? "Constant subroutine %s redefined"
4363 : "Subroutine %s redefined"
4365 CopLINE_set(PL_curcop, oldline);
4372 if (cv) /* must reuse cv if autoloaded */
4375 cv = (CV*)NEWSV(1105,0);
4376 sv_upgrade((SV *)cv, SVt_PVCV);
4380 PL_sub_generation++;
4384 (void)gv_fetchfile(filename);
4385 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
4386 an external constant string */
4387 CvXSUB(cv) = subaddr;
4390 char *s = strrchr(name,':');
4396 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4399 if (strEQ(s, "BEGIN")) {
4401 PL_beginav = newAV();
4402 av_push(PL_beginav, (SV*)cv);
4403 GvCV(gv) = 0; /* cv has been hijacked */
4405 else if (strEQ(s, "END")) {
4408 av_unshift(PL_endav, 1);
4409 av_store(PL_endav, 0, (SV*)cv);
4410 GvCV(gv) = 0; /* cv has been hijacked */
4412 else if (strEQ(s, "CHECK")) {
4414 PL_checkav = newAV();
4415 if (PL_main_start && ckWARN(WARN_VOID))
4416 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4417 av_unshift(PL_checkav, 1);
4418 av_store(PL_checkav, 0, (SV*)cv);
4419 GvCV(gv) = 0; /* cv has been hijacked */
4421 else if (strEQ(s, "INIT")) {
4423 PL_initav = newAV();
4424 if (PL_main_start && ckWARN(WARN_VOID))
4425 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4426 av_push(PL_initav, (SV*)cv);
4427 GvCV(gv) = 0; /* cv has been hijacked */
4438 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4446 name = SvPVx(cSVOPo->op_sv, n_a);
4449 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
4450 #ifdef GV_UNIQUE_CHECK
4452 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4456 if ((cv = GvFORM(gv))) {
4457 if (ckWARN(WARN_REDEFINE)) {
4458 line_t oldline = CopLINE(PL_curcop);
4459 if (PL_copline != NOLINE)
4460 CopLINE_set(PL_curcop, PL_copline);
4461 Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Format %s redefined",name);
4462 CopLINE_set(PL_curcop, oldline);
4469 CvFILE_set_from_cop(cv, PL_curcop);
4472 pad_tidy(padtidy_FORMAT);
4473 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4474 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4475 OpREFCNT_set(CvROOT(cv), 1);
4476 CvSTART(cv) = LINKLIST(CvROOT(cv));
4477 CvROOT(cv)->op_next = 0;
4478 CALL_PEEP(CvSTART(cv));
4480 PL_copline = NOLINE;
4485 Perl_newANONLIST(pTHX_ OP *o)
4487 return newUNOP(OP_REFGEN, 0,
4488 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4492 Perl_newANONHASH(pTHX_ OP *o)
4494 return newUNOP(OP_REFGEN, 0,
4495 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4499 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4501 return newANONATTRSUB(floor, proto, Nullop, block);
4505 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4507 return newUNOP(OP_REFGEN, 0,
4508 newSVOP(OP_ANONCODE, 0,
4509 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
4513 Perl_oopsAV(pTHX_ OP *o)
4515 switch (o->op_type) {
4517 o->op_type = OP_PADAV;
4518 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4519 return ref(o, OP_RV2AV);
4522 o->op_type = OP_RV2AV;
4523 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4528 if (ckWARN_d(WARN_INTERNAL))
4529 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
4536 Perl_oopsHV(pTHX_ OP *o)
4538 switch (o->op_type) {
4541 o->op_type = OP_PADHV;
4542 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4543 return ref(o, OP_RV2HV);
4547 o->op_type = OP_RV2HV;
4548 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
4553 if (ckWARN_d(WARN_INTERNAL))
4554 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
4561 Perl_newAVREF(pTHX_ OP *o)
4563 if (o->op_type == OP_PADANY) {
4564 o->op_type = OP_PADAV;
4565 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4568 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
4569 && ckWARN(WARN_DEPRECATED)) {
4570 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4571 "Using an array as a reference is deprecated");
4573 return newUNOP(OP_RV2AV, 0, scalar(o));
4577 Perl_newGVREF(pTHX_ I32 type, OP *o)
4579 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
4580 return newUNOP(OP_NULL, 0, o);
4581 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
4585 Perl_newHVREF(pTHX_ OP *o)
4587 if (o->op_type == OP_PADANY) {
4588 o->op_type = OP_PADHV;
4589 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4592 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
4593 && ckWARN(WARN_DEPRECATED)) {
4594 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4595 "Using a hash as a reference is deprecated");
4597 return newUNOP(OP_RV2HV, 0, scalar(o));
4601 Perl_oopsCV(pTHX_ OP *o)
4603 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
4609 Perl_newCVREF(pTHX_ I32 flags, OP *o)
4611 return newUNOP(OP_RV2CV, flags, scalar(o));
4615 Perl_newSVREF(pTHX_ OP *o)
4617 if (o->op_type == OP_PADANY) {
4618 o->op_type = OP_PADSV;
4619 o->op_ppaddr = PL_ppaddr[OP_PADSV];
4622 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4623 o->op_flags |= OPpDONE_SVREF;
4626 return newUNOP(OP_RV2SV, 0, scalar(o));
4629 /* Check routines. */
4632 Perl_ck_anoncode(pTHX_ OP *o)
4634 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
4635 cSVOPo->op_sv = Nullsv;
4640 Perl_ck_bitop(pTHX_ OP *o)
4642 #define OP_IS_NUMCOMPARE(op) \
4643 ((op) == OP_LT || (op) == OP_I_LT || \
4644 (op) == OP_GT || (op) == OP_I_GT || \
4645 (op) == OP_LE || (op) == OP_I_LE || \
4646 (op) == OP_GE || (op) == OP_I_GE || \
4647 (op) == OP_EQ || (op) == OP_I_EQ || \
4648 (op) == OP_NE || (op) == OP_I_NE || \
4649 (op) == OP_NCMP || (op) == OP_I_NCMP)
4650 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4651 if (o->op_type == OP_BIT_OR
4652 || o->op_type == OP_BIT_AND
4653 || o->op_type == OP_BIT_XOR)
4655 OP * left = cBINOPo->op_first;
4656 OP * right = left->op_sibling;
4657 if ((OP_IS_NUMCOMPARE(left->op_type) &&
4658 (left->op_flags & OPf_PARENS) == 0) ||
4659 (OP_IS_NUMCOMPARE(right->op_type) &&
4660 (right->op_flags & OPf_PARENS) == 0))
4661 if (ckWARN(WARN_PRECEDENCE))
4662 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4663 "Possible precedence problem on bitwise %c operator",
4664 o->op_type == OP_BIT_OR ? '|'
4665 : o->op_type == OP_BIT_AND ? '&' : '^'
4672 Perl_ck_concat(pTHX_ OP *o)
4674 if (cUNOPo->op_first->op_type == OP_CONCAT)
4675 o->op_flags |= OPf_STACKED;
4680 Perl_ck_spair(pTHX_ OP *o)
4682 if (o->op_flags & OPf_KIDS) {
4685 OPCODE type = o->op_type;
4686 o = modkids(ck_fun(o), type);
4687 kid = cUNOPo->op_first;
4688 newop = kUNOP->op_first->op_sibling;
4690 (newop->op_sibling ||
4691 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
4692 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
4693 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
4697 op_free(kUNOP->op_first);
4698 kUNOP->op_first = newop;
4700 o->op_ppaddr = PL_ppaddr[++o->op_type];
4705 Perl_ck_delete(pTHX_ OP *o)
4709 if (o->op_flags & OPf_KIDS) {
4710 OP *kid = cUNOPo->op_first;
4711 switch (kid->op_type) {
4713 o->op_flags |= OPf_SPECIAL;
4716 o->op_private |= OPpSLICE;
4719 o->op_flags |= OPf_SPECIAL;
4724 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
4733 Perl_ck_die(pTHX_ OP *o)
4736 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4742 Perl_ck_eof(pTHX_ OP *o)
4744 I32 type = o->op_type;
4746 if (o->op_flags & OPf_KIDS) {
4747 if (cLISTOPo->op_first->op_type == OP_STUB) {
4749 o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
4757 Perl_ck_eval(pTHX_ OP *o)
4759 PL_hints |= HINT_BLOCK_SCOPE;
4760 if (o->op_flags & OPf_KIDS) {
4761 SVOP *kid = (SVOP*)cUNOPo->op_first;
4764 o->op_flags &= ~OPf_KIDS;
4767 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
4770 cUNOPo->op_first = 0;
4773 NewOp(1101, enter, 1, LOGOP);
4774 enter->op_type = OP_ENTERTRY;
4775 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
4776 enter->op_private = 0;
4778 /* establish postfix order */
4779 enter->op_next = (OP*)enter;
4781 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
4782 o->op_type = OP_LEAVETRY;
4783 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
4784 enter->op_other = o;
4792 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
4794 o->op_targ = (PADOFFSET)PL_hints;
4799 Perl_ck_exit(pTHX_ OP *o)
4802 HV *table = GvHV(PL_hintgv);
4804 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
4805 if (svp && *svp && SvTRUE(*svp))
4806 o->op_private |= OPpEXIT_VMSISH;
4808 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4814 Perl_ck_exec(pTHX_ OP *o)
4817 if (o->op_flags & OPf_STACKED) {
4819 kid = cUNOPo->op_first->op_sibling;
4820 if (kid->op_type == OP_RV2GV)
4829 Perl_ck_exists(pTHX_ OP *o)
4832 if (o->op_flags & OPf_KIDS) {
4833 OP *kid = cUNOPo->op_first;
4834 if (kid->op_type == OP_ENTERSUB) {
4835 (void) ref(kid, o->op_type);
4836 if (kid->op_type != OP_RV2CV && !PL_error_count)
4837 Perl_croak(aTHX_ "%s argument is not a subroutine name",
4839 o->op_private |= OPpEXISTS_SUB;
4841 else if (kid->op_type == OP_AELEM)
4842 o->op_flags |= OPf_SPECIAL;
4843 else if (kid->op_type != OP_HELEM)
4844 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
4853 Perl_ck_gvconst(pTHX_ register OP *o)
4855 o = fold_constants(o);
4856 if (o->op_type == OP_CONST)
4863 Perl_ck_rvconst(pTHX_ register OP *o)
4865 SVOP *kid = (SVOP*)cUNOPo->op_first;
4867 o->op_private |= (PL_hints & HINT_STRICT_REFS);
4868 if (kid->op_type == OP_CONST) {
4872 SV *kidsv = kid->op_sv;
4875 /* Is it a constant from cv_const_sv()? */
4876 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
4877 SV *rsv = SvRV(kidsv);
4878 int svtype = SvTYPE(rsv);
4879 char *badtype = Nullch;
4881 switch (o->op_type) {
4883 if (svtype > SVt_PVMG)
4884 badtype = "a SCALAR";
4887 if (svtype != SVt_PVAV)
4888 badtype = "an ARRAY";
4891 if (svtype != SVt_PVHV)
4895 if (svtype != SVt_PVCV)
4900 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
4903 name = SvPV(kidsv, n_a);
4904 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
4905 char *badthing = Nullch;
4906 switch (o->op_type) {
4908 badthing = "a SCALAR";
4911 badthing = "an ARRAY";
4914 badthing = "a HASH";
4919 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
4923 * This is a little tricky. We only want to add the symbol if we
4924 * didn't add it in the lexer. Otherwise we get duplicate strict
4925 * warnings. But if we didn't add it in the lexer, we must at
4926 * least pretend like we wanted to add it even if it existed before,
4927 * or we get possible typo warnings. OPpCONST_ENTERED says
4928 * whether the lexer already added THIS instance of this symbol.
4930 iscv = (o->op_type == OP_RV2CV) * 2;
4932 gv = gv_fetchpv(name,
4933 iscv | !(kid->op_private & OPpCONST_ENTERED),
4936 : o->op_type == OP_RV2SV
4938 : o->op_type == OP_RV2AV
4940 : o->op_type == OP_RV2HV
4943 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
4945 kid->op_type = OP_GV;
4946 SvREFCNT_dec(kid->op_sv);
4948 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
4949 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
4950 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
4952 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
4954 kid->op_sv = SvREFCNT_inc(gv);
4956 kid->op_private = 0;
4957 kid->op_ppaddr = PL_ppaddr[OP_GV];
4964 Perl_ck_ftst(pTHX_ OP *o)
4966 I32 type = o->op_type;
4968 if (o->op_flags & OPf_REF) {
4971 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
4972 SVOP *kid = (SVOP*)cUNOPo->op_first;
4974 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
4976 OP *newop = newGVOP(type, OPf_REF,
4977 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
4982 if ((PL_hints & HINT_FILETEST_ACCESS) &&
4983 OP_IS_FILETEST_ACCESS(o))
4984 o->op_private |= OPpFT_ACCESS;
4989 if (type == OP_FTTTY)
4990 o = newGVOP(type, OPf_REF, PL_stdingv);
4992 o = newUNOP(type, 0, newDEFSVOP());
4998 Perl_ck_fun(pTHX_ OP *o)
5004 int type = o->op_type;
5005 register I32 oa = PL_opargs[type] >> OASHIFT;
5007 if (o->op_flags & OPf_STACKED) {
5008 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5011 return no_fh_allowed(o);
5014 if (o->op_flags & OPf_KIDS) {
5016 tokid = &cLISTOPo->op_first;
5017 kid = cLISTOPo->op_first;
5018 if (kid->op_type == OP_PUSHMARK ||
5019 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5021 tokid = &kid->op_sibling;
5022 kid = kid->op_sibling;
5024 if (!kid && PL_opargs[type] & OA_DEFGV)
5025 *tokid = kid = newDEFSVOP();
5029 sibl = kid->op_sibling;
5032 /* list seen where single (scalar) arg expected? */
5033 if (numargs == 1 && !(oa >> 4)
5034 && kid->op_type == OP_LIST && type != OP_SCALAR)
5036 return too_many_arguments(o,PL_op_desc[type]);
5049 if ((type == OP_PUSH || type == OP_UNSHIFT)
5050 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5051 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5052 "Useless use of %s with no values",
5055 if (kid->op_type == OP_CONST &&
5056 (kid->op_private & OPpCONST_BARE))
5058 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5059 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5060 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5061 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5062 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5063 "Array @%s missing the @ in argument %"IVdf" of %s()",
5064 name, (IV)numargs, PL_op_desc[type]);
5067 kid->op_sibling = sibl;
5070 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5071 bad_type(numargs, "array", PL_op_desc[type], kid);
5075 if (kid->op_type == OP_CONST &&
5076 (kid->op_private & OPpCONST_BARE))
5078 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5079 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5080 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5081 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5082 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5083 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5084 name, (IV)numargs, PL_op_desc[type]);
5087 kid->op_sibling = sibl;
5090 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5091 bad_type(numargs, "hash", PL_op_desc[type], kid);
5096 OP *newop = newUNOP(OP_NULL, 0, kid);
5097 kid->op_sibling = 0;
5099 newop->op_next = newop;
5101 kid->op_sibling = sibl;
5106 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5107 if (kid->op_type == OP_CONST &&
5108 (kid->op_private & OPpCONST_BARE))
5110 OP *newop = newGVOP(OP_GV, 0,
5111 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5113 if (!(o->op_private & 1) && /* if not unop */
5114 kid == cLISTOPo->op_last)
5115 cLISTOPo->op_last = newop;
5119 else if (kid->op_type == OP_READLINE) {
5120 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5121 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5124 I32 flags = OPf_SPECIAL;
5128 /* is this op a FH constructor? */
5129 if (is_handle_constructor(o,numargs)) {
5130 char *name = Nullch;
5134 /* Set a flag to tell rv2gv to vivify
5135 * need to "prove" flag does not mean something
5136 * else already - NI-S 1999/05/07
5139 if (kid->op_type == OP_PADSV) {
5140 name = PAD_COMPNAME_PV(kid->op_targ);
5141 /* SvCUR of a pad namesv can't be trusted
5142 * (see PL_generation), so calc its length
5148 else if (kid->op_type == OP_RV2SV
5149 && kUNOP->op_first->op_type == OP_GV)
5151 GV *gv = cGVOPx_gv(kUNOP->op_first);
5153 len = GvNAMELEN(gv);
5155 else if (kid->op_type == OP_AELEM
5156 || kid->op_type == OP_HELEM)
5161 if ((op = ((BINOP*)kid)->op_first)) {
5162 SV *tmpstr = Nullsv;
5164 kid->op_type == OP_AELEM ?
5166 if (((op->op_type == OP_RV2AV) ||
5167 (op->op_type == OP_RV2HV)) &&
5168 (op = ((UNOP*)op)->op_first) &&
5169 (op->op_type == OP_GV)) {
5170 /* packagevar $a[] or $h{} */
5171 GV *gv = cGVOPx_gv(op);
5179 else if (op->op_type == OP_PADAV
5180 || op->op_type == OP_PADHV) {
5181 /* lexicalvar $a[] or $h{} */
5183 PAD_COMPNAME_PV(op->op_targ);
5193 name = savepv(SvPVX(tmpstr));
5199 name = "__ANONIO__";
5206 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5207 namesv = PAD_SVl(targ);
5208 (void)SvUPGRADE(namesv, SVt_PV);
5210 sv_setpvn(namesv, "$", 1);
5211 sv_catpvn(namesv, name, len);
5214 kid->op_sibling = 0;
5215 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5216 kid->op_targ = targ;
5217 kid->op_private |= priv;
5219 kid->op_sibling = sibl;
5225 mod(scalar(kid), type);
5229 tokid = &kid->op_sibling;
5230 kid = kid->op_sibling;
5232 o->op_private |= numargs;
5234 return too_many_arguments(o,OP_DESC(o));
5237 else if (PL_opargs[type] & OA_DEFGV) {
5239 return newUNOP(type, 0, newDEFSVOP());
5243 while (oa & OA_OPTIONAL)
5245 if (oa && oa != OA_LIST)
5246 return too_few_arguments(o,OP_DESC(o));
5252 Perl_ck_glob(pTHX_ OP *o)
5257 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5258 append_elem(OP_GLOB, o, newDEFSVOP());
5260 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5261 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5263 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5266 #if !defined(PERL_EXTERNAL_GLOB)
5267 /* XXX this can be tightened up and made more failsafe. */
5271 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5272 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5273 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5274 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5275 GvCV(gv) = GvCV(glob_gv);
5276 SvREFCNT_inc((SV*)GvCV(gv));
5277 GvIMPORTED_CV_on(gv);
5280 #endif /* PERL_EXTERNAL_GLOB */
5282 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5283 append_elem(OP_GLOB, o,
5284 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5285 o->op_type = OP_LIST;
5286 o->op_ppaddr = PL_ppaddr[OP_LIST];
5287 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5288 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5289 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5290 append_elem(OP_LIST, o,
5291 scalar(newUNOP(OP_RV2CV, 0,
5292 newGVOP(OP_GV, 0, gv)))));
5293 o = newUNOP(OP_NULL, 0, ck_subr(o));
5294 o->op_targ = OP_GLOB; /* hint at what it used to be */
5297 gv = newGVgen("main");
5299 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5305 Perl_ck_grep(pTHX_ OP *o)
5309 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5311 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5312 NewOp(1101, gwop, 1, LOGOP);
5314 if (o->op_flags & OPf_STACKED) {
5317 kid = cLISTOPo->op_first->op_sibling;
5318 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5321 kid->op_next = (OP*)gwop;
5322 o->op_flags &= ~OPf_STACKED;
5324 kid = cLISTOPo->op_first->op_sibling;
5325 if (type == OP_MAPWHILE)
5332 kid = cLISTOPo->op_first->op_sibling;
5333 if (kid->op_type != OP_NULL)
5334 Perl_croak(aTHX_ "panic: ck_grep");
5335 kid = kUNOP->op_first;
5337 gwop->op_type = type;
5338 gwop->op_ppaddr = PL_ppaddr[type];
5339 gwop->op_first = listkids(o);
5340 gwop->op_flags |= OPf_KIDS;
5341 gwop->op_private = 1;
5342 gwop->op_other = LINKLIST(kid);
5343 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5344 kid->op_next = (OP*)gwop;
5346 kid = cLISTOPo->op_first->op_sibling;
5347 if (!kid || !kid->op_sibling)
5348 return too_few_arguments(o,OP_DESC(o));
5349 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5350 mod(kid, OP_GREPSTART);
5356 Perl_ck_index(pTHX_ OP *o)
5358 if (o->op_flags & OPf_KIDS) {
5359 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5361 kid = kid->op_sibling; /* get past "big" */
5362 if (kid && kid->op_type == OP_CONST)
5363 fbm_compile(((SVOP*)kid)->op_sv, 0);
5369 Perl_ck_lengthconst(pTHX_ OP *o)
5371 /* XXX length optimization goes here */
5376 Perl_ck_lfun(pTHX_ OP *o)
5378 OPCODE type = o->op_type;
5379 return modkids(ck_fun(o), type);
5383 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5385 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5386 switch (cUNOPo->op_first->op_type) {
5388 /* This is needed for
5389 if (defined %stash::)
5390 to work. Do not break Tk.
5392 break; /* Globals via GV can be undef */
5394 case OP_AASSIGN: /* Is this a good idea? */
5395 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5396 "defined(@array) is deprecated");
5397 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5398 "\t(Maybe you should just omit the defined()?)\n");
5401 /* This is needed for
5402 if (defined %stash::)
5403 to work. Do not break Tk.
5405 break; /* Globals via GV can be undef */
5407 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5408 "defined(%%hash) is deprecated");
5409 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5410 "\t(Maybe you should just omit the defined()?)\n");
5421 Perl_ck_rfun(pTHX_ OP *o)
5423 OPCODE type = o->op_type;
5424 return refkids(ck_fun(o), type);
5428 Perl_ck_listiob(pTHX_ OP *o)
5432 kid = cLISTOPo->op_first;
5435 kid = cLISTOPo->op_first;
5437 if (kid->op_type == OP_PUSHMARK)
5438 kid = kid->op_sibling;
5439 if (kid && o->op_flags & OPf_STACKED)
5440 kid = kid->op_sibling;
5441 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5442 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5443 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5444 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5445 cLISTOPo->op_first->op_sibling = kid;
5446 cLISTOPo->op_last = kid;
5447 kid = kid->op_sibling;
5452 append_elem(o->op_type, o, newDEFSVOP());
5458 Perl_ck_sassign(pTHX_ OP *o)
5460 OP *kid = cLISTOPo->op_first;
5461 /* has a disposable target? */
5462 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5463 && !(kid->op_flags & OPf_STACKED)
5464 /* Cannot steal the second time! */
5465 && !(kid->op_private & OPpTARGET_MY))
5467 OP *kkid = kid->op_sibling;
5469 /* Can just relocate the target. */
5470 if (kkid && kkid->op_type == OP_PADSV
5471 && !(kkid->op_private & OPpLVAL_INTRO))
5473 kid->op_targ = kkid->op_targ;
5475 /* Now we do not need PADSV and SASSIGN. */
5476 kid->op_sibling = o->op_sibling; /* NULL */
5477 cLISTOPo->op_first = NULL;
5480 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
5488 Perl_ck_match(pTHX_ OP *o)
5490 o->op_private |= OPpRUNTIME;
5495 Perl_ck_method(pTHX_ OP *o)
5497 OP *kid = cUNOPo->op_first;
5498 if (kid->op_type == OP_CONST) {
5499 SV* sv = kSVOP->op_sv;
5500 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
5502 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5503 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
5506 kSVOP->op_sv = Nullsv;
5508 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5517 Perl_ck_null(pTHX_ OP *o)
5523 Perl_ck_open(pTHX_ OP *o)
5525 HV *table = GvHV(PL_hintgv);
5529 svp = hv_fetch(table, "open_IN", 7, FALSE);
5531 mode = mode_from_discipline(*svp);
5532 if (mode & O_BINARY)
5533 o->op_private |= OPpOPEN_IN_RAW;
5534 else if (mode & O_TEXT)
5535 o->op_private |= OPpOPEN_IN_CRLF;
5538 svp = hv_fetch(table, "open_OUT", 8, FALSE);
5540 mode = mode_from_discipline(*svp);
5541 if (mode & O_BINARY)
5542 o->op_private |= OPpOPEN_OUT_RAW;
5543 else if (mode & O_TEXT)
5544 o->op_private |= OPpOPEN_OUT_CRLF;
5547 if (o->op_type == OP_BACKTICK)
5550 /* In case of three-arg dup open remove strictness
5551 * from the last arg if it is a bareword. */
5552 OP *first = cLISTOPx(o)->op_first; /* The pushmark. */
5553 OP *last = cLISTOPx(o)->op_last; /* The bareword. */
5557 if ((last->op_type == OP_CONST) && /* The bareword. */
5558 (last->op_private & OPpCONST_BARE) &&
5559 (last->op_private & OPpCONST_STRICT) &&
5560 (oa = first->op_sibling) && /* The fh. */
5561 (oa = oa->op_sibling) && /* The mode. */
5562 SvPOK(((SVOP*)oa)->op_sv) &&
5563 (mode = SvPVX(((SVOP*)oa)->op_sv)) &&
5564 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
5565 (last == oa->op_sibling)) /* The bareword. */
5566 last->op_private &= ~OPpCONST_STRICT;
5572 Perl_ck_repeat(pTHX_ OP *o)
5574 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5575 o->op_private |= OPpREPEAT_DOLIST;
5576 cBINOPo->op_first = force_list(cBINOPo->op_first);
5584 Perl_ck_require(pTHX_ OP *o)
5588 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
5589 SVOP *kid = (SVOP*)cUNOPo->op_first;
5591 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5593 for (s = SvPVX(kid->op_sv); *s; s++) {
5594 if (*s == ':' && s[1] == ':') {
5596 Move(s+2, s+1, strlen(s+2)+1, char);
5597 --SvCUR(kid->op_sv);
5600 if (SvREADONLY(kid->op_sv)) {
5601 SvREADONLY_off(kid->op_sv);
5602 sv_catpvn(kid->op_sv, ".pm", 3);
5603 SvREADONLY_on(kid->op_sv);
5606 sv_catpvn(kid->op_sv, ".pm", 3);
5610 /* handle override, if any */
5611 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
5612 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
5613 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
5615 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5616 OP *kid = cUNOPo->op_first;
5617 cUNOPo->op_first = 0;
5619 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5620 append_elem(OP_LIST, kid,
5621 scalar(newUNOP(OP_RV2CV, 0,
5630 Perl_ck_return(pTHX_ OP *o)
5633 if (CvLVALUE(PL_compcv)) {
5634 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5635 mod(kid, OP_LEAVESUBLV);
5642 Perl_ck_retarget(pTHX_ OP *o)
5644 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5651 Perl_ck_select(pTHX_ OP *o)
5654 if (o->op_flags & OPf_KIDS) {
5655 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5656 if (kid && kid->op_sibling) {
5657 o->op_type = OP_SSELECT;
5658 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
5660 return fold_constants(o);
5664 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5665 if (kid && kid->op_type == OP_RV2GV)
5666 kid->op_private &= ~HINT_STRICT_REFS;
5671 Perl_ck_shift(pTHX_ OP *o)
5673 I32 type = o->op_type;
5675 if (!(o->op_flags & OPf_KIDS)) {
5679 argop = newUNOP(OP_RV2AV, 0,
5680 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
5681 return newUNOP(type, 0, scalar(argop));
5683 return scalar(modkids(ck_fun(o), type));
5687 Perl_ck_sort(pTHX_ OP *o)
5691 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
5693 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5694 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
5696 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
5698 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
5700 if (kid->op_type == OP_SCOPE) {
5704 else if (kid->op_type == OP_LEAVE) {
5705 if (o->op_type == OP_SORT) {
5706 op_null(kid); /* wipe out leave */
5709 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
5710 if (k->op_next == kid)
5712 /* don't descend into loops */
5713 else if (k->op_type == OP_ENTERLOOP
5714 || k->op_type == OP_ENTERITER)
5716 k = cLOOPx(k)->op_lastop;
5721 kid->op_next = 0; /* just disconnect the leave */
5722 k = kLISTOP->op_first;
5727 if (o->op_type == OP_SORT) {
5728 /* provide scalar context for comparison function/block */
5734 o->op_flags |= OPf_SPECIAL;
5736 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
5739 firstkid = firstkid->op_sibling;
5742 /* provide list context for arguments */
5743 if (o->op_type == OP_SORT)
5750 S_simplify_sort(pTHX_ OP *o)
5752 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5756 if (!(o->op_flags & OPf_STACKED))
5758 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
5759 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
5760 kid = kUNOP->op_first; /* get past null */
5761 if (kid->op_type != OP_SCOPE)
5763 kid = kLISTOP->op_last; /* get past scope */
5764 switch(kid->op_type) {
5772 k = kid; /* remember this node*/
5773 if (kBINOP->op_first->op_type != OP_RV2SV)
5775 kid = kBINOP->op_first; /* get past cmp */
5776 if (kUNOP->op_first->op_type != OP_GV)
5778 kid = kUNOP->op_first; /* get past rv2sv */
5780 if (GvSTASH(gv) != PL_curstash)
5782 if (strEQ(GvNAME(gv), "a"))
5784 else if (strEQ(GvNAME(gv), "b"))
5788 kid = k; /* back to cmp */
5789 if (kBINOP->op_last->op_type != OP_RV2SV)
5791 kid = kBINOP->op_last; /* down to 2nd arg */
5792 if (kUNOP->op_first->op_type != OP_GV)
5794 kid = kUNOP->op_first; /* get past rv2sv */
5796 if (GvSTASH(gv) != PL_curstash
5798 ? strNE(GvNAME(gv), "a")
5799 : strNE(GvNAME(gv), "b")))
5801 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
5803 o->op_private |= OPpSORT_REVERSE;
5804 if (k->op_type == OP_NCMP)
5805 o->op_private |= OPpSORT_NUMERIC;
5806 if (k->op_type == OP_I_NCMP)
5807 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
5808 kid = cLISTOPo->op_first->op_sibling;
5809 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
5810 op_free(kid); /* then delete it */
5814 Perl_ck_split(pTHX_ OP *o)
5818 if (o->op_flags & OPf_STACKED)
5819 return no_fh_allowed(o);
5821 kid = cLISTOPo->op_first;
5822 if (kid->op_type != OP_NULL)
5823 Perl_croak(aTHX_ "panic: ck_split");
5824 kid = kid->op_sibling;
5825 op_free(cLISTOPo->op_first);
5826 cLISTOPo->op_first = kid;
5828 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
5829 cLISTOPo->op_last = kid; /* There was only one element previously */
5832 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
5833 OP *sibl = kid->op_sibling;
5834 kid->op_sibling = 0;
5835 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
5836 if (cLISTOPo->op_first == cLISTOPo->op_last)
5837 cLISTOPo->op_last = kid;
5838 cLISTOPo->op_first = kid;
5839 kid->op_sibling = sibl;
5842 kid->op_type = OP_PUSHRE;
5843 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
5845 if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
5846 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
5847 "Use of /g modifier is meaningless in split");
5850 if (!kid->op_sibling)
5851 append_elem(OP_SPLIT, o, newDEFSVOP());
5853 kid = kid->op_sibling;
5856 if (!kid->op_sibling)
5857 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
5859 kid = kid->op_sibling;
5862 if (kid->op_sibling)
5863 return too_many_arguments(o,OP_DESC(o));
5869 Perl_ck_join(pTHX_ OP *o)
5871 if (ckWARN(WARN_SYNTAX)) {
5872 OP *kid = cLISTOPo->op_first->op_sibling;
5873 if (kid && kid->op_type == OP_MATCH) {
5874 char *pmstr = "STRING";
5875 if (PM_GETRE(kPMOP))
5876 pmstr = PM_GETRE(kPMOP)->precomp;
5877 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5878 "/%s/ should probably be written as \"%s\"",
5886 Perl_ck_subr(pTHX_ OP *o)
5888 OP *prev = ((cUNOPo->op_first->op_sibling)
5889 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
5890 OP *o2 = prev->op_sibling;
5897 I32 contextclass = 0;
5902 o->op_private |= OPpENTERSUB_HASTARG;
5903 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
5904 if (cvop->op_type == OP_RV2CV) {
5906 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
5907 op_null(cvop); /* disable rv2cv */
5908 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
5909 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
5910 GV *gv = cGVOPx_gv(tmpop);
5913 tmpop->op_private |= OPpEARLY_CV;
5916 namegv = CvANON(cv) ? gv : CvGV(cv);
5917 proto = SvPV((SV*)cv, n_a);
5919 if (CvASSERTION(cv)) {
5920 if (PL_hints & HINT_ASSERTING) {
5921 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
5922 o->op_private |= OPpENTERSUB_DB;
5926 if (ckWARN(WARN_ASSERTIONS) && !(PL_hints & HINT_ASSERTIONSSEEN)) {
5927 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
5928 "Impossible to activate assertion call");
5935 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
5936 if (o2->op_type == OP_CONST)
5937 o2->op_private &= ~OPpCONST_STRICT;
5938 else if (o2->op_type == OP_LIST) {
5939 OP *o = ((UNOP*)o2)->op_first->op_sibling;
5940 if (o && o->op_type == OP_CONST)
5941 o->op_private &= ~OPpCONST_STRICT;
5944 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5945 if (PERLDB_SUB && PL_curstash != PL_debstash)
5946 o->op_private |= OPpENTERSUB_DB;
5947 while (o2 != cvop) {
5951 return too_many_arguments(o, gv_ename(namegv));
5969 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
5971 arg == 1 ? "block or sub {}" : "sub {}",
5972 gv_ename(namegv), o2);
5975 /* '*' allows any scalar type, including bareword */
5978 if (o2->op_type == OP_RV2GV)
5979 goto wrapref; /* autoconvert GLOB -> GLOBref */
5980 else if (o2->op_type == OP_CONST)
5981 o2->op_private &= ~OPpCONST_STRICT;
5982 else if (o2->op_type == OP_ENTERSUB) {
5983 /* accidental subroutine, revert to bareword */
5984 OP *gvop = ((UNOP*)o2)->op_first;
5985 if (gvop && gvop->op_type == OP_NULL) {
5986 gvop = ((UNOP*)gvop)->op_first;
5988 for (; gvop->op_sibling; gvop = gvop->op_sibling)
5991 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
5992 (gvop = ((UNOP*)gvop)->op_first) &&
5993 gvop->op_type == OP_GV)
5995 GV *gv = cGVOPx_gv(gvop);
5996 OP *sibling = o2->op_sibling;
5997 SV *n = newSVpvn("",0);
5999 gv_fullname3(n, gv, "");
6000 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6001 sv_chop(n, SvPVX(n)+6);
6002 o2 = newSVOP(OP_CONST, 0, n);
6003 prev->op_sibling = o2;
6004 o2->op_sibling = sibling;
6020 if (contextclass++ == 0) {
6021 e = strchr(proto, ']');
6022 if (!e || e == proto)
6035 while (*--p != '[');
6036 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6037 gv_ename(namegv), o2);
6043 if (o2->op_type == OP_RV2GV)
6046 bad_type(arg, "symbol", gv_ename(namegv), o2);
6049 if (o2->op_type == OP_ENTERSUB)
6052 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6055 if (o2->op_type == OP_RV2SV ||
6056 o2->op_type == OP_PADSV ||
6057 o2->op_type == OP_HELEM ||
6058 o2->op_type == OP_AELEM ||
6059 o2->op_type == OP_THREADSV)
6062 bad_type(arg, "scalar", gv_ename(namegv), o2);
6065 if (o2->op_type == OP_RV2AV ||
6066 o2->op_type == OP_PADAV)
6069 bad_type(arg, "array", gv_ename(namegv), o2);
6072 if (o2->op_type == OP_RV2HV ||
6073 o2->op_type == OP_PADHV)
6076 bad_type(arg, "hash", gv_ename(namegv), o2);
6081 OP* sib = kid->op_sibling;
6082 kid->op_sibling = 0;
6083 o2 = newUNOP(OP_REFGEN, 0, kid);
6084 o2->op_sibling = sib;
6085 prev->op_sibling = o2;
6087 if (contextclass && e) {
6102 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6103 gv_ename(namegv), cv);
6108 mod(o2, OP_ENTERSUB);
6110 o2 = o2->op_sibling;
6112 if (proto && !optional &&
6113 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6114 return too_few_arguments(o, gv_ename(namegv));
6117 o=newSVOP(OP_CONST, 0, newSViv(0));
6123 Perl_ck_svconst(pTHX_ OP *o)
6125 SvREADONLY_on(cSVOPo->op_sv);
6130 Perl_ck_trunc(pTHX_ OP *o)
6132 if (o->op_flags & OPf_KIDS) {
6133 SVOP *kid = (SVOP*)cUNOPo->op_first;
6135 if (kid->op_type == OP_NULL)
6136 kid = (SVOP*)kid->op_sibling;
6137 if (kid && kid->op_type == OP_CONST &&
6138 (kid->op_private & OPpCONST_BARE))
6140 o->op_flags |= OPf_SPECIAL;
6141 kid->op_private &= ~OPpCONST_STRICT;
6148 Perl_ck_substr(pTHX_ OP *o)
6151 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6152 OP *kid = cLISTOPo->op_first;
6154 if (kid->op_type == OP_NULL)
6155 kid = kid->op_sibling;
6157 kid->op_flags |= OPf_MOD;
6163 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6166 Perl_peep(pTHX_ register OP *o)
6168 register OP* oldop = 0;
6170 if (!o || o->op_seq)
6174 SAVEVPTR(PL_curcop);
6175 for (; o; o = o->op_next) {
6178 /* The special value -1 is used by the B::C compiler backend to indicate
6179 * that an op is statically defined and should not be freed */
6180 if (!PL_op_seqmax || PL_op_seqmax == (U16)-1)
6183 switch (o->op_type) {
6187 PL_curcop = ((COP*)o); /* for warnings */
6188 o->op_seq = PL_op_seqmax++;
6192 if (cSVOPo->op_private & OPpCONST_STRICT)
6193 no_bareword_allowed(o);
6195 case OP_METHOD_NAMED:
6196 /* Relocate sv to the pad for thread safety.
6197 * Despite being a "constant", the SV is written to,
6198 * for reference counts, sv_upgrade() etc. */
6200 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6201 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6202 /* If op_sv is already a PADTMP then it is being used by
6203 * some pad, so make a copy. */
6204 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6205 SvREADONLY_on(PAD_SVl(ix));
6206 SvREFCNT_dec(cSVOPo->op_sv);
6209 SvREFCNT_dec(PAD_SVl(ix));
6210 SvPADTMP_on(cSVOPo->op_sv);
6211 PAD_SETSV(ix, cSVOPo->op_sv);
6212 /* XXX I don't know how this isn't readonly already. */
6213 SvREADONLY_on(PAD_SVl(ix));
6215 cSVOPo->op_sv = Nullsv;
6219 o->op_seq = PL_op_seqmax++;
6223 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6224 if (o->op_next->op_private & OPpTARGET_MY) {
6225 if (o->op_flags & OPf_STACKED) /* chained concats */
6226 goto ignore_optimization;
6228 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6229 o->op_targ = o->op_next->op_targ;
6230 o->op_next->op_targ = 0;
6231 o->op_private |= OPpTARGET_MY;
6234 op_null(o->op_next);
6236 ignore_optimization:
6237 o->op_seq = PL_op_seqmax++;
6240 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6241 o->op_seq = PL_op_seqmax++;
6242 break; /* Scalar stub must produce undef. List stub is noop */
6246 if (o->op_targ == OP_NEXTSTATE
6247 || o->op_targ == OP_DBSTATE
6248 || o->op_targ == OP_SETSTATE)
6250 PL_curcop = ((COP*)o);
6252 /* XXX: We avoid setting op_seq here to prevent later calls
6253 to peep() from mistakenly concluding that optimisation
6254 has already occurred. This doesn't fix the real problem,
6255 though (See 20010220.007). AMS 20010719 */
6256 if (oldop && o->op_next) {
6257 oldop->op_next = o->op_next;
6265 if (oldop && o->op_next) {
6266 oldop->op_next = o->op_next;
6269 o->op_seq = PL_op_seqmax++;
6273 if (o->op_next->op_type == OP_RV2SV) {
6274 if (!(o->op_next->op_private & OPpDEREF)) {
6275 op_null(o->op_next);
6276 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6278 o->op_next = o->op_next->op_next;
6279 o->op_type = OP_GVSV;
6280 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6283 else if (o->op_next->op_type == OP_RV2AV) {
6284 OP* pop = o->op_next->op_next;
6286 if (pop && pop->op_type == OP_CONST &&
6287 (PL_op = pop->op_next) &&
6288 pop->op_next->op_type == OP_AELEM &&
6289 !(pop->op_next->op_private &
6290 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6291 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6296 op_null(o->op_next);
6297 op_null(pop->op_next);
6299 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6300 o->op_next = pop->op_next->op_next;
6301 o->op_type = OP_AELEMFAST;
6302 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6303 o->op_private = (U8)i;
6308 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6310 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6311 /* XXX could check prototype here instead of just carping */
6312 SV *sv = sv_newmortal();
6313 gv_efullname3(sv, gv, Nullch);
6314 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6315 "%"SVf"() called too early to check prototype",
6319 else if (o->op_next->op_type == OP_READLINE
6320 && o->op_next->op_next->op_type == OP_CONCAT
6321 && (o->op_next->op_next->op_flags & OPf_STACKED))
6323 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6324 o->op_type = OP_RCATLINE;
6325 o->op_flags |= OPf_STACKED;
6326 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6327 op_null(o->op_next->op_next);
6328 op_null(o->op_next);
6331 o->op_seq = PL_op_seqmax++;
6344 o->op_seq = PL_op_seqmax++;
6345 while (cLOGOP->op_other->op_type == OP_NULL)
6346 cLOGOP->op_other = cLOGOP->op_other->op_next;
6347 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6352 o->op_seq = PL_op_seqmax++;
6353 while (cLOOP->op_redoop->op_type == OP_NULL)
6354 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6355 peep(cLOOP->op_redoop);
6356 while (cLOOP->op_nextop->op_type == OP_NULL)
6357 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6358 peep(cLOOP->op_nextop);
6359 while (cLOOP->op_lastop->op_type == OP_NULL)
6360 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6361 peep(cLOOP->op_lastop);
6367 o->op_seq = PL_op_seqmax++;
6368 while (cPMOP->op_pmreplstart &&
6369 cPMOP->op_pmreplstart->op_type == OP_NULL)
6370 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6371 peep(cPMOP->op_pmreplstart);
6375 o->op_seq = PL_op_seqmax++;
6376 if (ckWARN(WARN_SYNTAX) && o->op_next
6377 && o->op_next->op_type == OP_NEXTSTATE) {
6378 if (o->op_next->op_sibling &&
6379 o->op_next->op_sibling->op_type != OP_EXIT &&
6380 o->op_next->op_sibling->op_type != OP_WARN &&
6381 o->op_next->op_sibling->op_type != OP_DIE) {
6382 line_t oldline = CopLINE(PL_curcop);
6384 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6385 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6386 "Statement unlikely to be reached");
6387 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6388 "\t(Maybe you meant system() when you said exec()?)\n");
6389 CopLINE_set(PL_curcop, oldline);
6400 o->op_seq = PL_op_seqmax++;
6402 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6405 /* Make the CONST have a shared SV */
6406 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6407 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6408 key = SvPV(sv, keylen);
6409 lexname = newSVpvn_share(key,
6410 SvUTF8(sv) ? -(I32)keylen : keylen,
6419 o->op_seq = PL_op_seqmax++;
6429 char* Perl_custom_op_name(pTHX_ OP* o)
6431 IV index = PTR2IV(o->op_ppaddr);
6435 if (!PL_custom_op_names) /* This probably shouldn't happen */
6436 return PL_op_name[OP_CUSTOM];
6438 keysv = sv_2mortal(newSViv(index));
6440 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
6442 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
6444 return SvPV_nolen(HeVAL(he));
6447 char* Perl_custom_op_desc(pTHX_ OP* o)
6449 IV index = PTR2IV(o->op_ppaddr);
6453 if (!PL_custom_op_descs)
6454 return PL_op_desc[OP_CUSTOM];
6456 keysv = sv_2mortal(newSViv(index));
6458 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
6460 return PL_op_desc[OP_CUSTOM];
6462 return SvPV_nolen(HeVAL(he));
6468 /* Efficient sub that returns a constant scalar value. */
6470 const_sv_xsub(pTHX_ CV* cv)
6475 Perl_croak(aTHX_ "usage: %s::%s()",
6476 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
6480 ST(0) = (SV*)XSANY.any_ptr;