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)
892 Perl_mod(pTHX_ OP *o, I32 type)
896 if (!o || PL_error_count)
899 if ((o->op_private & OPpTARGET_MY)
900 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
905 switch (o->op_type) {
910 if (!(o->op_private & (OPpCONST_ARYBASE)))
912 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
913 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
917 SAVEI32(PL_compiling.cop_arybase);
918 PL_compiling.cop_arybase = 0;
920 else if (type == OP_REFGEN)
923 Perl_croak(aTHX_ "That use of $[ is unsupported");
926 if (o->op_flags & OPf_PARENS)
930 if ((type == OP_UNDEF || type == OP_REFGEN) &&
931 !(o->op_flags & OPf_STACKED)) {
932 o->op_type = OP_RV2CV; /* entersub => rv2cv */
933 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
934 assert(cUNOPo->op_first->op_type == OP_NULL);
935 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
938 else if (o->op_private & OPpENTERSUB_NOMOD)
940 else { /* lvalue subroutine call */
941 o->op_private |= OPpLVAL_INTRO;
942 PL_modcount = RETURN_UNLIMITED_NUMBER;
943 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
944 /* Backward compatibility mode: */
945 o->op_private |= OPpENTERSUB_INARGS;
948 else { /* Compile-time error message: */
949 OP *kid = cUNOPo->op_first;
953 if (kid->op_type == OP_PUSHMARK)
955 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
957 "panic: unexpected lvalue entersub "
958 "args: type/targ %ld:%"UVuf,
959 (long)kid->op_type, (UV)kid->op_targ);
960 kid = kLISTOP->op_first;
962 while (kid->op_sibling)
963 kid = kid->op_sibling;
964 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
966 if (kid->op_type == OP_METHOD_NAMED
967 || kid->op_type == OP_METHOD)
971 NewOp(1101, newop, 1, UNOP);
972 newop->op_type = OP_RV2CV;
973 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
974 newop->op_first = Nullop;
975 newop->op_next = (OP*)newop;
976 kid->op_sibling = (OP*)newop;
977 newop->op_private |= OPpLVAL_INTRO;
981 if (kid->op_type != OP_RV2CV)
983 "panic: unexpected lvalue entersub "
984 "entry via type/targ %ld:%"UVuf,
985 (long)kid->op_type, (UV)kid->op_targ);
986 kid->op_private |= OPpLVAL_INTRO;
987 break; /* Postpone until runtime */
991 kid = kUNOP->op_first;
992 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
993 kid = kUNOP->op_first;
994 if (kid->op_type == OP_NULL)
996 "Unexpected constant lvalue entersub "
997 "entry via type/targ %ld:%"UVuf,
998 (long)kid->op_type, (UV)kid->op_targ);
999 if (kid->op_type != OP_GV) {
1000 /* Restore RV2CV to check lvalueness */
1002 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1003 okid->op_next = kid->op_next;
1004 kid->op_next = okid;
1007 okid->op_next = Nullop;
1008 okid->op_type = OP_RV2CV;
1010 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1011 okid->op_private |= OPpLVAL_INTRO;
1015 cv = GvCV(kGVOP_gv);
1025 /* grep, foreach, subcalls, refgen */
1026 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1028 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1029 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1031 : (o->op_type == OP_ENTERSUB
1032 ? "non-lvalue subroutine call"
1034 type ? PL_op_desc[type] : "local"));
1048 case OP_RIGHT_SHIFT:
1057 if (!(o->op_flags & OPf_STACKED))
1063 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1069 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1070 PL_modcount = RETURN_UNLIMITED_NUMBER;
1071 return o; /* Treat \(@foo) like ordinary list. */
1075 if (scalar_mod_type(o, type))
1077 ref(cUNOPo->op_first, o->op_type);
1081 if (type == OP_LEAVESUBLV)
1082 o->op_private |= OPpMAYBE_LVSUB;
1087 PL_modcount = RETURN_UNLIMITED_NUMBER;
1090 ref(cUNOPo->op_first, o->op_type);
1094 PL_hints |= HINT_BLOCK_SCOPE;
1105 PL_modcount = RETURN_UNLIMITED_NUMBER;
1106 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1107 return o; /* Treat \(@foo) like ordinary list. */
1108 if (scalar_mod_type(o, type))
1110 if (type == OP_LEAVESUBLV)
1111 o->op_private |= OPpMAYBE_LVSUB;
1116 { /* XXX DAPM 2002.08.25 tmp assert test */
1117 /* XXX */ assert(av_fetch(PL_comppad_name, (o->op_targ), FALSE));
1118 /* XXX */ assert(*av_fetch(PL_comppad_name, (o->op_targ), FALSE));
1120 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1121 PAD_COMPNAME_PV(o->op_targ));
1129 if (type != OP_SASSIGN)
1133 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1138 if (type == OP_LEAVESUBLV)
1139 o->op_private |= OPpMAYBE_LVSUB;
1141 pad_free(o->op_targ);
1142 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1143 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1144 if (o->op_flags & OPf_KIDS)
1145 mod(cBINOPo->op_first->op_sibling, type);
1150 ref(cBINOPo->op_first, o->op_type);
1151 if (type == OP_ENTERSUB &&
1152 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1153 o->op_private |= OPpLVAL_DEFER;
1154 if (type == OP_LEAVESUBLV)
1155 o->op_private |= OPpMAYBE_LVSUB;
1163 if (o->op_flags & OPf_KIDS)
1164 mod(cLISTOPo->op_last, type);
1168 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1170 else if (!(o->op_flags & OPf_KIDS))
1172 if (o->op_targ != OP_LIST) {
1173 mod(cBINOPo->op_first, type);
1178 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1183 if (type != OP_LEAVESUBLV)
1185 break; /* mod()ing was handled by ck_return() */
1188 /* [20011101.069] File test operators interpret OPf_REF to mean that
1189 their argument is a filehandle; thus \stat(".") should not set
1191 if (type == OP_REFGEN &&
1192 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1195 if (type != OP_LEAVESUBLV)
1196 o->op_flags |= OPf_MOD;
1198 if (type == OP_AASSIGN || type == OP_SASSIGN)
1199 o->op_flags |= OPf_SPECIAL|OPf_REF;
1201 o->op_private |= OPpLVAL_INTRO;
1202 o->op_flags &= ~OPf_SPECIAL;
1203 PL_hints |= HINT_BLOCK_SCOPE;
1205 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1206 && type != OP_LEAVESUBLV)
1207 o->op_flags |= OPf_REF;
1212 S_scalar_mod_type(pTHX_ OP *o, I32 type)
1216 if (o->op_type == OP_RV2GV)
1240 case OP_RIGHT_SHIFT:
1259 S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
1261 switch (o->op_type) {
1269 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1282 Perl_refkids(pTHX_ OP *o, I32 type)
1285 if (o && o->op_flags & OPf_KIDS) {
1286 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1293 Perl_ref(pTHX_ OP *o, I32 type)
1297 if (!o || PL_error_count)
1300 switch (o->op_type) {
1302 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1303 !(o->op_flags & OPf_STACKED)) {
1304 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1305 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1306 assert(cUNOPo->op_first->op_type == OP_NULL);
1307 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1308 o->op_flags |= OPf_SPECIAL;
1313 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1317 if (type == OP_DEFINED)
1318 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1319 ref(cUNOPo->op_first, o->op_type);
1322 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1323 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1324 : type == OP_RV2HV ? OPpDEREF_HV
1326 o->op_flags |= OPf_MOD;
1331 o->op_flags |= OPf_MOD; /* XXX ??? */
1336 o->op_flags |= OPf_REF;
1339 if (type == OP_DEFINED)
1340 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1341 ref(cUNOPo->op_first, o->op_type);
1346 o->op_flags |= OPf_REF;
1351 if (!(o->op_flags & OPf_KIDS))
1353 ref(cBINOPo->op_first, type);
1357 ref(cBINOPo->op_first, o->op_type);
1358 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1359 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1360 : type == OP_RV2HV ? OPpDEREF_HV
1362 o->op_flags |= OPf_MOD;
1370 if (!(o->op_flags & OPf_KIDS))
1372 ref(cLISTOPo->op_last, type);
1382 S_dup_attrlist(pTHX_ OP *o)
1386 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1387 * where the first kid is OP_PUSHMARK and the remaining ones
1388 * are OP_CONST. We need to push the OP_CONST values.
1390 if (o->op_type == OP_CONST)
1391 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1393 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1394 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1395 if (o->op_type == OP_CONST)
1396 rop = append_elem(OP_LIST, rop,
1397 newSVOP(OP_CONST, o->op_flags,
1398 SvREFCNT_inc(cSVOPo->op_sv)));
1405 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1409 /* fake up C<use attributes $pkg,$rv,@attrs> */
1410 ENTER; /* need to protect against side-effects of 'use' */
1413 stashsv = newSVpv(HvNAME(stash), 0);
1415 stashsv = &PL_sv_no;
1417 #define ATTRSMODULE "attributes"
1418 #define ATTRSMODULE_PM "attributes.pm"
1422 /* Don't force the C<use> if we don't need it. */
1423 svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
1424 sizeof(ATTRSMODULE_PM)-1, 0);
1425 if (svp && *svp != &PL_sv_undef)
1426 ; /* already in %INC */
1428 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1429 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1433 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1434 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1436 prepend_elem(OP_LIST,
1437 newSVOP(OP_CONST, 0, stashsv),
1438 prepend_elem(OP_LIST,
1439 newSVOP(OP_CONST, 0,
1441 dup_attrlist(attrs))));
1447 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1449 OP *pack, *imop, *arg;
1455 assert(target->op_type == OP_PADSV ||
1456 target->op_type == OP_PADHV ||
1457 target->op_type == OP_PADAV);
1459 /* Ensure that attributes.pm is loaded. */
1460 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1462 /* Need package name for method call. */
1463 pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
1465 /* Build up the real arg-list. */
1467 stashsv = newSVpv(HvNAME(stash), 0);
1469 stashsv = &PL_sv_no;
1470 arg = newOP(OP_PADSV, 0);
1471 arg->op_targ = target->op_targ;
1472 arg = prepend_elem(OP_LIST,
1473 newSVOP(OP_CONST, 0, stashsv),
1474 prepend_elem(OP_LIST,
1475 newUNOP(OP_REFGEN, 0,
1476 mod(arg, OP_REFGEN)),
1477 dup_attrlist(attrs)));
1479 /* Fake up a method call to import */
1480 meth = newSVpvn("import", 6);
1481 (void)SvUPGRADE(meth, SVt_PVIV);
1482 (void)SvIOK_on(meth);
1483 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
1484 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1485 append_elem(OP_LIST,
1486 prepend_elem(OP_LIST, pack, list(arg)),
1487 newSVOP(OP_METHOD_NAMED, 0, meth)));
1488 imop->op_private |= OPpENTERSUB_NOMOD;
1490 /* Combine the ops. */
1491 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1495 =notfor apidoc apply_attrs_string
1497 Attempts to apply a list of attributes specified by the C<attrstr> and
1498 C<len> arguments to the subroutine identified by the C<cv> argument which
1499 is expected to be associated with the package identified by the C<stashpv>
1500 argument (see L<attributes>). It gets this wrong, though, in that it
1501 does not correctly identify the boundaries of the individual attribute
1502 specifications within C<attrstr>. This is not really intended for the
1503 public API, but has to be listed here for systems such as AIX which
1504 need an explicit export list for symbols. (It's called from XS code
1505 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1506 to respect attribute syntax properly would be welcome.
1512 Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
1513 char *attrstr, STRLEN len)
1518 len = strlen(attrstr);
1522 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1524 char *sstr = attrstr;
1525 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1526 attrs = append_elem(OP_LIST, attrs,
1527 newSVOP(OP_CONST, 0,
1528 newSVpvn(sstr, attrstr-sstr)));
1532 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1533 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1534 Nullsv, prepend_elem(OP_LIST,
1535 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1536 prepend_elem(OP_LIST,
1537 newSVOP(OP_CONST, 0,
1543 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1548 if (!o || PL_error_count)
1552 if (type == OP_LIST) {
1553 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1554 my_kid(kid, attrs, imopsp);
1555 } else if (type == OP_UNDEF) {
1557 } else if (type == OP_RV2SV || /* "our" declaration */
1559 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1560 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1561 yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
1562 OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
1564 GV *gv = cGVOPx_gv(cUNOPo->op_first);
1566 PL_in_my_stash = Nullhv;
1567 apply_attrs(GvSTASH(gv),
1568 (type == OP_RV2SV ? GvSV(gv) :
1569 type == OP_RV2AV ? (SV*)GvAV(gv) :
1570 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1573 o->op_private |= OPpOUR_INTRO;
1576 else if (type != OP_PADSV &&
1579 type != OP_PUSHMARK)
1581 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1583 PL_in_my == KEY_our ? "our" : "my"));
1586 else if (attrs && type != OP_PUSHMARK) {
1590 PL_in_my_stash = Nullhv;
1592 /* check for C<my Dog $spot> when deciding package */
1593 stash = PAD_COMPNAME_TYPE(o->op_targ);
1595 stash = PL_curstash;
1596 apply_attrs_my(stash, o, attrs, imopsp);
1598 o->op_flags |= OPf_MOD;
1599 o->op_private |= OPpLVAL_INTRO;
1604 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1607 int maybe_scalar = 0;
1609 /* [perl #17376]: this appears to be premature, and results in code such as
1610 C< our(%x); > executing in list mode rather than void mode */
1612 if (o->op_flags & OPf_PARENS)
1621 o = my_kid(o, attrs, &rops);
1623 if (maybe_scalar && o->op_type == OP_PADSV) {
1624 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1625 o->op_private |= OPpLVAL_INTRO;
1628 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1631 PL_in_my_stash = Nullhv;
1636 Perl_my(pTHX_ OP *o)
1638 return my_attrs(o, Nullop);
1642 Perl_sawparens(pTHX_ OP *o)
1645 o->op_flags |= OPf_PARENS;
1650 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1654 if (ckWARN(WARN_MISC) &&
1655 (left->op_type == OP_RV2AV ||
1656 left->op_type == OP_RV2HV ||
1657 left->op_type == OP_PADAV ||
1658 left->op_type == OP_PADHV)) {
1659 char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
1660 right->op_type == OP_TRANS)
1661 ? right->op_type : OP_MATCH];
1662 const char *sample = ((left->op_type == OP_RV2AV ||
1663 left->op_type == OP_PADAV)
1664 ? "@array" : "%hash");
1665 Perl_warner(aTHX_ packWARN(WARN_MISC),
1666 "Applying %s to %s will act on scalar(%s)",
1667 desc, sample, sample);
1670 if (right->op_type == OP_CONST &&
1671 cSVOPx(right)->op_private & OPpCONST_BARE &&
1672 cSVOPx(right)->op_private & OPpCONST_STRICT)
1674 no_bareword_allowed(right);
1677 if (!(right->op_flags & OPf_STACKED) &&
1678 (right->op_type == OP_MATCH ||
1679 right->op_type == OP_SUBST ||
1680 right->op_type == OP_TRANS)) {
1681 right->op_flags |= OPf_STACKED;
1682 if (right->op_type != OP_MATCH &&
1683 ! (right->op_type == OP_TRANS &&
1684 right->op_private & OPpTRANS_IDENTICAL))
1685 left = mod(left, right->op_type);
1686 if (right->op_type == OP_TRANS)
1687 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
1689 o = prepend_elem(right->op_type, scalar(left), right);
1691 return newUNOP(OP_NOT, 0, scalar(o));
1695 return bind_match(type, left,
1696 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
1700 Perl_invert(pTHX_ OP *o)
1704 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
1705 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1709 Perl_scope(pTHX_ OP *o)
1712 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1713 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1714 o->op_type = OP_LEAVE;
1715 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1717 else if (o->op_type == OP_LINESEQ) {
1719 o->op_type = OP_SCOPE;
1720 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1721 kid = ((LISTOP*)o)->op_first;
1722 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
1726 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
1732 Perl_save_hints(pTHX)
1735 SAVESPTR(GvHV(PL_hintgv));
1736 GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
1737 SAVEFREESV(GvHV(PL_hintgv));
1741 Perl_block_start(pTHX_ int full)
1743 int retval = PL_savestack_ix;
1744 /* If there were syntax errors, don't try to start a block */
1745 if (PL_yynerrs) return retval;
1747 pad_block_start(full);
1749 PL_hints &= ~HINT_BLOCK_SCOPE;
1750 SAVESPTR(PL_compiling.cop_warnings);
1751 if (! specialWARN(PL_compiling.cop_warnings)) {
1752 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1753 SAVEFREESV(PL_compiling.cop_warnings) ;
1755 SAVESPTR(PL_compiling.cop_io);
1756 if (! specialCopIO(PL_compiling.cop_io)) {
1757 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1758 SAVEFREESV(PL_compiling.cop_io) ;
1764 Perl_block_end(pTHX_ I32 floor, OP *seq)
1766 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1767 OP* retval = scalarseq(seq);
1768 /* If there were syntax errors, don't try to close a block */
1769 if (PL_yynerrs) return retval;
1771 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
1773 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
1781 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1785 Perl_newPROG(pTHX_ OP *o)
1790 PL_eval_root = newUNOP(OP_LEAVEEVAL,
1791 ((PL_in_eval & EVAL_KEEPERR)
1792 ? OPf_SPECIAL : 0), o);
1793 PL_eval_start = linklist(PL_eval_root);
1794 PL_eval_root->op_private |= OPpREFCOUNTED;
1795 OpREFCNT_set(PL_eval_root, 1);
1796 PL_eval_root->op_next = 0;
1797 CALL_PEEP(PL_eval_start);
1800 if (o->op_type == OP_STUB)
1802 PL_main_root = scope(sawparens(scalarvoid(o)));
1803 PL_curcop = &PL_compiling;
1804 PL_main_start = LINKLIST(PL_main_root);
1805 PL_main_root->op_private |= OPpREFCOUNTED;
1806 OpREFCNT_set(PL_main_root, 1);
1807 PL_main_root->op_next = 0;
1808 CALL_PEEP(PL_main_start);
1811 /* Register with debugger */
1813 CV *cv = get_cv("DB::postponed", FALSE);
1817 XPUSHs((SV*)CopFILEGV(&PL_compiling));
1819 call_sv((SV*)cv, G_DISCARD);
1826 Perl_localize(pTHX_ OP *o, I32 lex)
1828 if (o->op_flags & OPf_PARENS)
1829 /* [perl #17376]: this appears to be premature, and results in code such as
1830 C< our(%x); > executing in list mode rather than void mode */
1837 if (ckWARN(WARN_PARENTHESIS)
1838 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
1840 char *s = PL_bufptr;
1843 /* some heuristics to detect a potential error */
1844 while (*s && (strchr(", \t\n", *s)
1845 || (strchr("@$%*", *s) && ++sigil) ))
1848 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)
1849 || strchr("@$%*, \t\n", *s)))
1852 if (*s == ';' || *s == '=')
1853 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
1854 "Parentheses missing around \"%s\" list",
1855 lex ? (PL_in_my == KEY_our ? "our" : "my")
1863 o = mod(o, OP_NULL); /* a bit kludgey */
1865 PL_in_my_stash = Nullhv;
1870 Perl_jmaybe(pTHX_ OP *o)
1872 if (o->op_type == OP_LIST) {
1874 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
1875 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
1881 Perl_fold_constants(pTHX_ register OP *o)
1884 I32 type = o->op_type;
1887 if (PL_opargs[type] & OA_RETSCALAR)
1889 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
1890 o->op_targ = pad_alloc(type, SVs_PADTMP);
1892 /* integerize op, unless it happens to be C<-foo>.
1893 * XXX should pp_i_negate() do magic string negation instead? */
1894 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
1895 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
1896 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
1898 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
1901 if (!(PL_opargs[type] & OA_FOLDCONST))
1906 /* XXX might want a ck_negate() for this */
1907 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
1919 /* XXX what about the numeric ops? */
1920 if (PL_hints & HINT_LOCALE)
1925 goto nope; /* Don't try to run w/ errors */
1927 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
1928 if ((curop->op_type != OP_CONST ||
1929 (curop->op_private & OPpCONST_BARE)) &&
1930 curop->op_type != OP_LIST &&
1931 curop->op_type != OP_SCALAR &&
1932 curop->op_type != OP_NULL &&
1933 curop->op_type != OP_PUSHMARK)
1939 curop = LINKLIST(o);
1943 sv = *(PL_stack_sp--);
1944 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
1945 pad_swipe(o->op_targ, FALSE);
1946 else if (SvTEMP(sv)) { /* grab mortal temp? */
1947 (void)SvREFCNT_inc(sv);
1951 if (type == OP_RV2GV)
1952 return newGVOP(OP_GV, 0, (GV*)sv);
1953 return newSVOP(OP_CONST, 0, sv);
1960 Perl_gen_constant_list(pTHX_ register OP *o)
1963 I32 oldtmps_floor = PL_tmps_floor;
1967 return o; /* Don't attempt to run with errors */
1969 PL_op = curop = LINKLIST(o);
1976 PL_tmps_floor = oldtmps_floor;
1978 o->op_type = OP_RV2AV;
1979 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
1980 o->op_seq = 0; /* needs to be revisited in peep() */
1981 curop = ((UNOP*)o)->op_first;
1982 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
1989 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
1991 if (!o || o->op_type != OP_LIST)
1992 o = newLISTOP(OP_LIST, 0, o, Nullop);
1994 o->op_flags &= ~OPf_WANT;
1996 if (!(PL_opargs[type] & OA_MARK))
1997 op_null(cLISTOPo->op_first);
1999 o->op_type = (OPCODE)type;
2000 o->op_ppaddr = PL_ppaddr[type];
2001 o->op_flags |= flags;
2003 o = CHECKOP(type, o);
2004 if (o->op_type != type)
2007 return fold_constants(o);
2010 /* List constructors */
2013 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2021 if (first->op_type != type
2022 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2024 return newLISTOP(type, 0, first, last);
2027 if (first->op_flags & OPf_KIDS)
2028 ((LISTOP*)first)->op_last->op_sibling = last;
2030 first->op_flags |= OPf_KIDS;
2031 ((LISTOP*)first)->op_first = last;
2033 ((LISTOP*)first)->op_last = last;
2038 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2046 if (first->op_type != type)
2047 return prepend_elem(type, (OP*)first, (OP*)last);
2049 if (last->op_type != type)
2050 return append_elem(type, (OP*)first, (OP*)last);
2052 first->op_last->op_sibling = last->op_first;
2053 first->op_last = last->op_last;
2054 first->op_flags |= (last->op_flags & OPf_KIDS);
2062 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2070 if (last->op_type == type) {
2071 if (type == OP_LIST) { /* already a PUSHMARK there */
2072 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2073 ((LISTOP*)last)->op_first->op_sibling = first;
2074 if (!(first->op_flags & OPf_PARENS))
2075 last->op_flags &= ~OPf_PARENS;
2078 if (!(last->op_flags & OPf_KIDS)) {
2079 ((LISTOP*)last)->op_last = first;
2080 last->op_flags |= OPf_KIDS;
2082 first->op_sibling = ((LISTOP*)last)->op_first;
2083 ((LISTOP*)last)->op_first = first;
2085 last->op_flags |= OPf_KIDS;
2089 return newLISTOP(type, 0, first, last);
2095 Perl_newNULLLIST(pTHX)
2097 return newOP(OP_STUB, 0);
2101 Perl_force_list(pTHX_ OP *o)
2103 if (!o || o->op_type != OP_LIST)
2104 o = newLISTOP(OP_LIST, 0, o, Nullop);
2110 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2114 NewOp(1101, listop, 1, LISTOP);
2116 listop->op_type = (OPCODE)type;
2117 listop->op_ppaddr = PL_ppaddr[type];
2120 listop->op_flags = (U8)flags;
2124 else if (!first && last)
2127 first->op_sibling = last;
2128 listop->op_first = first;
2129 listop->op_last = last;
2130 if (type == OP_LIST) {
2132 pushop = newOP(OP_PUSHMARK, 0);
2133 pushop->op_sibling = first;
2134 listop->op_first = pushop;
2135 listop->op_flags |= OPf_KIDS;
2137 listop->op_last = pushop;
2144 Perl_newOP(pTHX_ I32 type, I32 flags)
2147 NewOp(1101, o, 1, OP);
2148 o->op_type = (OPCODE)type;
2149 o->op_ppaddr = PL_ppaddr[type];
2150 o->op_flags = (U8)flags;
2153 o->op_private = (U8)(0 | (flags >> 8));
2154 if (PL_opargs[type] & OA_RETSCALAR)
2156 if (PL_opargs[type] & OA_TARGET)
2157 o->op_targ = pad_alloc(type, SVs_PADTMP);
2158 return CHECKOP(type, o);
2162 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2167 first = newOP(OP_STUB, 0);
2168 if (PL_opargs[type] & OA_MARK)
2169 first = force_list(first);
2171 NewOp(1101, unop, 1, UNOP);
2172 unop->op_type = (OPCODE)type;
2173 unop->op_ppaddr = PL_ppaddr[type];
2174 unop->op_first = first;
2175 unop->op_flags = flags | OPf_KIDS;
2176 unop->op_private = (U8)(1 | (flags >> 8));
2177 unop = (UNOP*) CHECKOP(type, unop);
2181 return fold_constants((OP *) unop);
2185 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2188 NewOp(1101, binop, 1, BINOP);
2191 first = newOP(OP_NULL, 0);
2193 binop->op_type = (OPCODE)type;
2194 binop->op_ppaddr = PL_ppaddr[type];
2195 binop->op_first = first;
2196 binop->op_flags = flags | OPf_KIDS;
2199 binop->op_private = (U8)(1 | (flags >> 8));
2202 binop->op_private = (U8)(2 | (flags >> 8));
2203 first->op_sibling = last;
2206 binop = (BINOP*)CHECKOP(type, binop);
2207 if (binop->op_next || binop->op_type != (OPCODE)type)
2210 binop->op_last = binop->op_first->op_sibling;
2212 return fold_constants((OP *)binop);
2216 uvcompare(const void *a, const void *b)
2218 if (*((UV *)a) < (*(UV *)b))
2220 if (*((UV *)a) > (*(UV *)b))
2222 if (*((UV *)a+1) < (*(UV *)b+1))
2224 if (*((UV *)a+1) > (*(UV *)b+1))
2230 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2232 SV *tstr = ((SVOP*)expr)->op_sv;
2233 SV *rstr = ((SVOP*)repl)->op_sv;
2236 U8 *t = (U8*)SvPV(tstr, tlen);
2237 U8 *r = (U8*)SvPV(rstr, rlen);
2244 register short *tbl;
2246 PL_hints |= HINT_BLOCK_SCOPE;
2247 complement = o->op_private & OPpTRANS_COMPLEMENT;
2248 del = o->op_private & OPpTRANS_DELETE;
2249 squash = o->op_private & OPpTRANS_SQUASH;
2252 o->op_private |= OPpTRANS_FROM_UTF;
2255 o->op_private |= OPpTRANS_TO_UTF;
2257 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2258 SV* listsv = newSVpvn("# comment\n",10);
2260 U8* tend = t + tlen;
2261 U8* rend = r + rlen;
2275 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2276 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2282 tsave = t = bytes_to_utf8(t, &len);
2285 if (!to_utf && rlen) {
2287 rsave = r = bytes_to_utf8(r, &len);
2291 /* There are several snags with this code on EBCDIC:
2292 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2293 2. scan_const() in toke.c has encoded chars in native encoding which makes
2294 ranges at least in EBCDIC 0..255 range the bottom odd.
2298 U8 tmpbuf[UTF8_MAXLEN+1];
2301 New(1109, cp, 2*tlen, UV);
2303 transv = newSVpvn("",0);
2305 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2307 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2309 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2313 cp[2*i+1] = cp[2*i];
2317 qsort(cp, i, 2*sizeof(UV), uvcompare);
2318 for (j = 0; j < i; j++) {
2320 diff = val - nextmin;
2322 t = uvuni_to_utf8(tmpbuf,nextmin);
2323 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2325 U8 range_mark = UTF_TO_NATIVE(0xff);
2326 t = uvuni_to_utf8(tmpbuf, val - 1);
2327 sv_catpvn(transv, (char *)&range_mark, 1);
2328 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2335 t = uvuni_to_utf8(tmpbuf,nextmin);
2336 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2338 U8 range_mark = UTF_TO_NATIVE(0xff);
2339 sv_catpvn(transv, (char *)&range_mark, 1);
2341 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2342 UNICODE_ALLOW_SUPER);
2343 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2344 t = (U8*)SvPVX(transv);
2345 tlen = SvCUR(transv);
2349 else if (!rlen && !del) {
2350 r = t; rlen = tlen; rend = tend;
2353 if ((!rlen && !del) || t == r ||
2354 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2356 o->op_private |= OPpTRANS_IDENTICAL;
2360 while (t < tend || tfirst <= tlast) {
2361 /* see if we need more "t" chars */
2362 if (tfirst > tlast) {
2363 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2365 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2367 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2374 /* now see if we need more "r" chars */
2375 if (rfirst > rlast) {
2377 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2379 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2381 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2390 rfirst = rlast = 0xffffffff;
2394 /* now see which range will peter our first, if either. */
2395 tdiff = tlast - tfirst;
2396 rdiff = rlast - rfirst;
2403 if (rfirst == 0xffffffff) {
2404 diff = tdiff; /* oops, pretend rdiff is infinite */
2406 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2407 (long)tfirst, (long)tlast);
2409 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2413 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2414 (long)tfirst, (long)(tfirst + diff),
2417 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2418 (long)tfirst, (long)rfirst);
2420 if (rfirst + diff > max)
2421 max = rfirst + diff;
2423 grows = (tfirst < rfirst &&
2424 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2436 else if (max > 0xff)
2441 Safefree(cPVOPo->op_pv);
2442 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2443 SvREFCNT_dec(listsv);
2445 SvREFCNT_dec(transv);
2447 if (!del && havefinal && rlen)
2448 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2449 newSVuv((UV)final), 0);
2452 o->op_private |= OPpTRANS_GROWS;
2464 tbl = (short*)cPVOPo->op_pv;
2466 Zero(tbl, 256, short);
2467 for (i = 0; i < (I32)tlen; i++)
2469 for (i = 0, j = 0; i < 256; i++) {
2471 if (j >= (I32)rlen) {
2480 if (i < 128 && r[j] >= 128)
2490 o->op_private |= OPpTRANS_IDENTICAL;
2492 else if (j >= (I32)rlen)
2495 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2496 tbl[0x100] = rlen - j;
2497 for (i=0; i < (I32)rlen - j; i++)
2498 tbl[0x101+i] = r[j+i];
2502 if (!rlen && !del) {
2505 o->op_private |= OPpTRANS_IDENTICAL;
2507 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2508 o->op_private |= OPpTRANS_IDENTICAL;
2510 for (i = 0; i < 256; i++)
2512 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
2513 if (j >= (I32)rlen) {
2515 if (tbl[t[i]] == -1)
2521 if (tbl[t[i]] == -1) {
2522 if (t[i] < 128 && r[j] >= 128)
2529 o->op_private |= OPpTRANS_GROWS;
2537 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2541 NewOp(1101, pmop, 1, PMOP);
2542 pmop->op_type = (OPCODE)type;
2543 pmop->op_ppaddr = PL_ppaddr[type];
2544 pmop->op_flags = (U8)flags;
2545 pmop->op_private = (U8)(0 | (flags >> 8));
2547 if (PL_hints & HINT_RE_TAINT)
2548 pmop->op_pmpermflags |= PMf_RETAINT;
2549 if (PL_hints & HINT_LOCALE)
2550 pmop->op_pmpermflags |= PMf_LOCALE;
2551 pmop->op_pmflags = pmop->op_pmpermflags;
2556 if(av_len((AV*) PL_regex_pad[0]) > -1) {
2557 repointer = av_pop((AV*)PL_regex_pad[0]);
2558 pmop->op_pmoffset = SvIV(repointer);
2559 SvREPADTMP_off(repointer);
2560 sv_setiv(repointer,0);
2562 repointer = newSViv(0);
2563 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2564 pmop->op_pmoffset = av_len(PL_regex_padav);
2565 PL_regex_pad = AvARRAY(PL_regex_padav);
2570 /* link into pm list */
2571 if (type != OP_TRANS && PL_curstash) {
2572 pmop->op_pmnext = HvPMROOT(PL_curstash);
2573 HvPMROOT(PL_curstash) = pmop;
2574 PmopSTASH_set(pmop,PL_curstash);
2581 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
2585 I32 repl_has_vars = 0;
2587 if (o->op_type == OP_TRANS)
2588 return pmtrans(o, expr, repl);
2590 PL_hints |= HINT_BLOCK_SCOPE;
2593 if (expr->op_type == OP_CONST) {
2595 SV *pat = ((SVOP*)expr)->op_sv;
2596 char *p = SvPV(pat, plen);
2597 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
2598 sv_setpvn(pat, "\\s+", 3);
2599 p = SvPV(pat, plen);
2600 pm->op_pmflags |= PMf_SKIPWHITE;
2603 pm->op_pmdynflags |= PMdf_UTF8;
2604 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
2605 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
2606 pm->op_pmflags |= PMf_WHITE;
2610 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2611 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2613 : OP_REGCMAYBE),0,expr);
2615 NewOp(1101, rcop, 1, LOGOP);
2616 rcop->op_type = OP_REGCOMP;
2617 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2618 rcop->op_first = scalar(expr);
2619 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
2620 ? (OPf_SPECIAL | OPf_KIDS)
2622 rcop->op_private = 1;
2625 /* establish postfix order */
2626 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2628 rcop->op_next = expr;
2629 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2632 rcop->op_next = LINKLIST(expr);
2633 expr->op_next = (OP*)rcop;
2636 prepend_elem(o->op_type, scalar((OP*)rcop), o);
2641 if (pm->op_pmflags & PMf_EVAL) {
2643 if (CopLINE(PL_curcop) < PL_multi_end)
2644 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
2646 else if (repl->op_type == OP_CONST)
2650 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
2651 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
2652 if (curop->op_type == OP_GV) {
2653 GV *gv = cGVOPx_gv(curop);
2655 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
2658 else if (curop->op_type == OP_RV2CV)
2660 else if (curop->op_type == OP_RV2SV ||
2661 curop->op_type == OP_RV2AV ||
2662 curop->op_type == OP_RV2HV ||
2663 curop->op_type == OP_RV2GV) {
2664 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2667 else if (curop->op_type == OP_PADSV ||
2668 curop->op_type == OP_PADAV ||
2669 curop->op_type == OP_PADHV ||
2670 curop->op_type == OP_PADANY) {
2673 else if (curop->op_type == OP_PUSHRE)
2674 ; /* Okay here, dangerous in newASSIGNOP */
2684 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
2685 pm->op_pmflags |= PMf_CONST; /* const for long enough */
2686 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
2687 prepend_elem(o->op_type, scalar(repl), o);
2690 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
2691 pm->op_pmflags |= PMf_MAYBE_CONST;
2692 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2694 NewOp(1101, rcop, 1, LOGOP);
2695 rcop->op_type = OP_SUBSTCONT;
2696 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
2697 rcop->op_first = scalar(repl);
2698 rcop->op_flags |= OPf_KIDS;
2699 rcop->op_private = 1;
2702 /* establish postfix order */
2703 rcop->op_next = LINKLIST(repl);
2704 repl->op_next = (OP*)rcop;
2706 pm->op_pmreplroot = scalar((OP*)rcop);
2707 pm->op_pmreplstart = LINKLIST(rcop);
2716 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
2719 NewOp(1101, svop, 1, SVOP);
2720 svop->op_type = (OPCODE)type;
2721 svop->op_ppaddr = PL_ppaddr[type];
2723 svop->op_next = (OP*)svop;
2724 svop->op_flags = (U8)flags;
2725 if (PL_opargs[type] & OA_RETSCALAR)
2727 if (PL_opargs[type] & OA_TARGET)
2728 svop->op_targ = pad_alloc(type, SVs_PADTMP);
2729 return CHECKOP(type, svop);
2733 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2736 NewOp(1101, padop, 1, PADOP);
2737 padop->op_type = (OPCODE)type;
2738 padop->op_ppaddr = PL_ppaddr[type];
2739 padop->op_padix = pad_alloc(type, SVs_PADTMP);
2740 SvREFCNT_dec(PAD_SVl(padop->op_padix));
2741 PAD_SETSV(padop->op_padix, sv);
2744 padop->op_next = (OP*)padop;
2745 padop->op_flags = (U8)flags;
2746 if (PL_opargs[type] & OA_RETSCALAR)
2748 if (PL_opargs[type] & OA_TARGET)
2749 padop->op_targ = pad_alloc(type, SVs_PADTMP);
2750 return CHECKOP(type, padop);
2754 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
2759 return newPADOP(type, flags, SvREFCNT_inc(gv));
2761 return newSVOP(type, flags, SvREFCNT_inc(gv));
2766 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
2769 NewOp(1101, pvop, 1, PVOP);
2770 pvop->op_type = (OPCODE)type;
2771 pvop->op_ppaddr = PL_ppaddr[type];
2773 pvop->op_next = (OP*)pvop;
2774 pvop->op_flags = (U8)flags;
2775 if (PL_opargs[type] & OA_RETSCALAR)
2777 if (PL_opargs[type] & OA_TARGET)
2778 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
2779 return CHECKOP(type, pvop);
2783 Perl_package(pTHX_ OP *o)
2788 save_hptr(&PL_curstash);
2789 save_item(PL_curstname);
2791 name = SvPV(cSVOPo->op_sv, len);
2792 PL_curstash = gv_stashpvn(name, len, TRUE);
2793 sv_setpvn(PL_curstname, name, len);
2796 PL_hints |= HINT_BLOCK_SCOPE;
2797 PL_copline = NOLINE;
2802 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
2808 if (idop->op_type != OP_CONST)
2809 Perl_croak(aTHX_ "Module name must be constant");
2813 if (version != Nullop) {
2814 SV *vesv = ((SVOP*)version)->op_sv;
2816 if (arg == Nullop && !SvNIOKp(vesv)) {
2823 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
2824 Perl_croak(aTHX_ "Version number must be constant number");
2826 /* Make copy of idop so we don't free it twice */
2827 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
2829 /* Fake up a method call to VERSION */
2830 meth = newSVpvn("VERSION",7);
2831 sv_upgrade(meth, SVt_PVIV);
2832 (void)SvIOK_on(meth);
2833 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
2834 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2835 append_elem(OP_LIST,
2836 prepend_elem(OP_LIST, pack, list(version)),
2837 newSVOP(OP_METHOD_NAMED, 0, meth)));
2841 /* Fake up an import/unimport */
2842 if (arg && arg->op_type == OP_STUB)
2843 imop = arg; /* no import on explicit () */
2844 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
2845 imop = Nullop; /* use 5.0; */
2850 /* Make copy of idop so we don't free it twice */
2851 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
2853 /* Fake up a method call to import/unimport */
2854 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);
2855 (void)SvUPGRADE(meth, SVt_PVIV);
2856 (void)SvIOK_on(meth);
2857 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
2858 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2859 append_elem(OP_LIST,
2860 prepend_elem(OP_LIST, pack, list(arg)),
2861 newSVOP(OP_METHOD_NAMED, 0, meth)));
2864 /* Fake up the BEGIN {}, which does its thing immediately. */
2866 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
2869 append_elem(OP_LINESEQ,
2870 append_elem(OP_LINESEQ,
2871 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, idop)),
2872 newSTATEOP(0, Nullch, veop)),
2873 newSTATEOP(0, Nullch, imop) ));
2875 /* The "did you use incorrect case?" warning used to be here.
2876 * The problem is that on case-insensitive filesystems one
2877 * might get false positives for "use" (and "require"):
2878 * "use Strict" or "require CARP" will work. This causes
2879 * portability problems for the script: in case-strict
2880 * filesystems the script will stop working.
2882 * The "incorrect case" warning checked whether "use Foo"
2883 * imported "Foo" to your namespace, but that is wrong, too:
2884 * there is no requirement nor promise in the language that
2885 * a Foo.pm should or would contain anything in package "Foo".
2887 * There is very little Configure-wise that can be done, either:
2888 * the case-sensitivity of the build filesystem of Perl does not
2889 * help in guessing the case-sensitivity of the runtime environment.
2892 PL_hints |= HINT_BLOCK_SCOPE;
2893 PL_copline = NOLINE;
2898 =head1 Embedding Functions
2900 =for apidoc load_module
2902 Loads the module whose name is pointed to by the string part of name.
2903 Note that the actual module name, not its filename, should be given.
2904 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
2905 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
2906 (or 0 for no flags). ver, if specified, provides version semantics
2907 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
2908 arguments can be used to specify arguments to the module's import()
2909 method, similar to C<use Foo::Bar VERSION LIST>.
2914 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
2917 va_start(args, ver);
2918 vload_module(flags, name, ver, &args);
2922 #ifdef PERL_IMPLICIT_CONTEXT
2924 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
2928 va_start(args, ver);
2929 vload_module(flags, name, ver, &args);
2935 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
2937 OP *modname, *veop, *imop;
2939 modname = newSVOP(OP_CONST, 0, name);
2940 modname->op_private |= OPpCONST_BARE;
2942 veop = newSVOP(OP_CONST, 0, ver);
2946 if (flags & PERL_LOADMOD_NOIMPORT) {
2947 imop = sawparens(newNULLLIST());
2949 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
2950 imop = va_arg(*args, OP*);
2955 sv = va_arg(*args, SV*);
2957 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
2958 sv = va_arg(*args, SV*);
2962 line_t ocopline = PL_copline;
2963 COP *ocurcop = PL_curcop;
2964 int oexpect = PL_expect;
2966 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
2967 veop, modname, imop);
2968 PL_expect = oexpect;
2969 PL_copline = ocopline;
2970 PL_curcop = ocurcop;
2975 Perl_dofile(pTHX_ OP *term)
2980 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
2981 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
2982 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
2984 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
2985 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
2986 append_elem(OP_LIST, term,
2987 scalar(newUNOP(OP_RV2CV, 0,
2992 doop = newUNOP(OP_DOFILE, 0, scalar(term));
2998 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3000 return newBINOP(OP_LSLICE, flags,
3001 list(force_list(subscript)),
3002 list(force_list(listval)) );
3006 S_list_assignment(pTHX_ register OP *o)
3011 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3012 o = cUNOPo->op_first;
3014 if (o->op_type == OP_COND_EXPR) {
3015 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3016 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3021 yyerror("Assignment to both a list and a scalar");
3025 if (o->op_type == OP_LIST &&
3026 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3027 o->op_private & OPpLVAL_INTRO)
3030 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3031 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3032 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3035 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3038 if (o->op_type == OP_RV2SV)
3045 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3050 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3051 return newLOGOP(optype, 0,
3052 mod(scalar(left), optype),
3053 newUNOP(OP_SASSIGN, 0, scalar(right)));
3056 return newBINOP(optype, OPf_STACKED,
3057 mod(scalar(left), optype), scalar(right));
3061 if (list_assignment(left)) {
3065 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3066 left = mod(left, OP_AASSIGN);
3074 curop = list(force_list(left));
3075 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3076 o->op_private = (U8)(0 | (flags >> 8));
3078 /* PL_generation sorcery:
3079 * an assignment like ($a,$b) = ($c,$d) is easier than
3080 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3081 * To detect whether there are common vars, the global var
3082 * PL_generation is incremented for each assign op we compile.
3083 * Then, while compiling the assign op, we run through all the
3084 * variables on both sides of the assignment, setting a spare slot
3085 * in each of them to PL_generation. If any of them already have
3086 * that value, we know we've got commonality. We could use a
3087 * single bit marker, but then we'd have to make 2 passes, first
3088 * to clear the flag, then to test and set it. To find somewhere
3089 * to store these values, evil chicanery is done with SvCUR().
3092 if (!(left->op_private & OPpLVAL_INTRO)) {
3095 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3096 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3097 if (curop->op_type == OP_GV) {
3098 GV *gv = cGVOPx_gv(curop);
3099 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3101 SvCUR(gv) = PL_generation;
3103 else if (curop->op_type == OP_PADSV ||
3104 curop->op_type == OP_PADAV ||
3105 curop->op_type == OP_PADHV ||
3106 curop->op_type == OP_PADANY)
3108 if (PAD_COMPNAME_GEN(curop->op_targ)
3109 == (STRLEN)PL_generation)
3111 PAD_COMPNAME_GEN(curop->op_targ)
3115 else if (curop->op_type == OP_RV2CV)
3117 else if (curop->op_type == OP_RV2SV ||
3118 curop->op_type == OP_RV2AV ||
3119 curop->op_type == OP_RV2HV ||
3120 curop->op_type == OP_RV2GV) {
3121 if (lastop->op_type != OP_GV) /* funny deref? */
3124 else if (curop->op_type == OP_PUSHRE) {
3125 if (((PMOP*)curop)->op_pmreplroot) {
3127 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3128 ((PMOP*)curop)->op_pmreplroot));
3130 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3132 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3134 SvCUR(gv) = PL_generation;
3143 o->op_private |= OPpASSIGN_COMMON;
3145 if (right && right->op_type == OP_SPLIT) {
3147 if ((tmpop = ((LISTOP*)right)->op_first) &&
3148 tmpop->op_type == OP_PUSHRE)
3150 PMOP *pm = (PMOP*)tmpop;
3151 if (left->op_type == OP_RV2AV &&
3152 !(left->op_private & OPpLVAL_INTRO) &&
3153 !(o->op_private & OPpASSIGN_COMMON) )
3155 tmpop = ((UNOP*)left)->op_first;
3156 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3158 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3159 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3161 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3162 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3164 pm->op_pmflags |= PMf_ONCE;
3165 tmpop = cUNOPo->op_first; /* to list (nulled) */
3166 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3167 tmpop->op_sibling = Nullop; /* don't free split */
3168 right->op_next = tmpop->op_next; /* fix starting loc */
3169 op_free(o); /* blow off assign */
3170 right->op_flags &= ~OPf_WANT;
3171 /* "I don't know and I don't care." */
3176 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3177 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3179 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3181 sv_setiv(sv, PL_modcount+1);
3189 right = newOP(OP_UNDEF, 0);
3190 if (right->op_type == OP_READLINE) {
3191 right->op_flags |= OPf_STACKED;
3192 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3195 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3196 o = newBINOP(OP_SASSIGN, flags,
3197 scalar(right), mod(scalar(left), OP_SASSIGN) );
3209 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3211 U32 seq = intro_my();
3214 NewOp(1101, cop, 1, COP);
3215 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3216 cop->op_type = OP_DBSTATE;
3217 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3220 cop->op_type = OP_NEXTSTATE;
3221 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3223 cop->op_flags = (U8)flags;
3224 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3226 cop->op_private |= NATIVE_HINTS;
3228 PL_compiling.op_private = cop->op_private;
3229 cop->op_next = (OP*)cop;
3232 cop->cop_label = label;
3233 PL_hints |= HINT_BLOCK_SCOPE;
3236 cop->cop_arybase = PL_curcop->cop_arybase;
3237 if (specialWARN(PL_curcop->cop_warnings))
3238 cop->cop_warnings = PL_curcop->cop_warnings ;
3240 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3241 if (specialCopIO(PL_curcop->cop_io))
3242 cop->cop_io = PL_curcop->cop_io;
3244 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3247 if (PL_copline == NOLINE)
3248 CopLINE_set(cop, CopLINE(PL_curcop));
3250 CopLINE_set(cop, PL_copline);
3251 PL_copline = NOLINE;
3254 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3256 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3258 CopSTASH_set(cop, PL_curstash);
3260 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3261 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3262 if (svp && *svp != &PL_sv_undef ) {
3263 (void)SvIOK_on(*svp);
3264 SvIVX(*svp) = PTR2IV(cop);
3268 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3273 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3275 return new_logop(type, flags, &first, &other);
3279 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3283 OP *first = *firstp;
3284 OP *other = *otherp;
3286 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3287 return newBINOP(type, flags, scalar(first), scalar(other));
3289 scalarboolean(first);
3290 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3291 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3292 if (type == OP_AND || type == OP_OR) {
3298 first = *firstp = cUNOPo->op_first;
3300 first->op_next = o->op_next;
3301 cUNOPo->op_first = Nullop;
3305 if (first->op_type == OP_CONST) {
3306 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE)) {
3307 if (first->op_private & OPpCONST_STRICT)
3308 no_bareword_allowed(first);
3310 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3312 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3323 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3324 OP *k1 = ((UNOP*)first)->op_first;
3325 OP *k2 = k1->op_sibling;
3327 switch (first->op_type)
3330 if (k2 && k2->op_type == OP_READLINE
3331 && (k2->op_flags & OPf_STACKED)
3332 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3334 warnop = k2->op_type;
3339 if (k1->op_type == OP_READDIR
3340 || k1->op_type == OP_GLOB
3341 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3342 || k1->op_type == OP_EACH)
3344 warnop = ((k1->op_type == OP_NULL)
3345 ? (OPCODE)k1->op_targ : k1->op_type);
3350 line_t oldline = CopLINE(PL_curcop);
3351 CopLINE_set(PL_curcop, PL_copline);
3352 Perl_warner(aTHX_ packWARN(WARN_MISC),
3353 "Value of %s%s can be \"0\"; test with defined()",
3355 ((warnop == OP_READLINE || warnop == OP_GLOB)
3356 ? " construct" : "() operator"));
3357 CopLINE_set(PL_curcop, oldline);
3364 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3365 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3367 NewOp(1101, logop, 1, LOGOP);
3369 logop->op_type = (OPCODE)type;
3370 logop->op_ppaddr = PL_ppaddr[type];
3371 logop->op_first = first;
3372 logop->op_flags = flags | OPf_KIDS;
3373 logop->op_other = LINKLIST(other);
3374 logop->op_private = (U8)(1 | (flags >> 8));
3376 /* establish postfix order */
3377 logop->op_next = LINKLIST(first);
3378 first->op_next = (OP*)logop;
3379 first->op_sibling = other;
3381 o = newUNOP(OP_NULL, 0, (OP*)logop);
3388 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3395 return newLOGOP(OP_AND, 0, first, trueop);
3397 return newLOGOP(OP_OR, 0, first, falseop);
3399 scalarboolean(first);
3400 if (first->op_type == OP_CONST) {
3401 if (first->op_private & OPpCONST_BARE &&
3402 first->op_private & OPpCONST_STRICT) {
3403 no_bareword_allowed(first);
3405 if (SvTRUE(((SVOP*)first)->op_sv)) {
3416 NewOp(1101, logop, 1, LOGOP);
3417 logop->op_type = OP_COND_EXPR;
3418 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3419 logop->op_first = first;
3420 logop->op_flags = flags | OPf_KIDS;
3421 logop->op_private = (U8)(1 | (flags >> 8));
3422 logop->op_other = LINKLIST(trueop);
3423 logop->op_next = LINKLIST(falseop);
3426 /* establish postfix order */
3427 start = LINKLIST(first);
3428 first->op_next = (OP*)logop;
3430 first->op_sibling = trueop;
3431 trueop->op_sibling = falseop;
3432 o = newUNOP(OP_NULL, 0, (OP*)logop);
3434 trueop->op_next = falseop->op_next = o;
3441 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3449 NewOp(1101, range, 1, LOGOP);
3451 range->op_type = OP_RANGE;
3452 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3453 range->op_first = left;
3454 range->op_flags = OPf_KIDS;
3455 leftstart = LINKLIST(left);
3456 range->op_other = LINKLIST(right);
3457 range->op_private = (U8)(1 | (flags >> 8));
3459 left->op_sibling = right;
3461 range->op_next = (OP*)range;
3462 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3463 flop = newUNOP(OP_FLOP, 0, flip);
3464 o = newUNOP(OP_NULL, 0, flop);
3466 range->op_next = leftstart;
3468 left->op_next = flip;
3469 right->op_next = flop;
3471 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3472 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3473 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3474 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3476 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3477 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3480 if (!flip->op_private || !flop->op_private)
3481 linklist(o); /* blow off optimizer unless constant */
3487 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3491 int once = block && block->op_flags & OPf_SPECIAL &&
3492 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3495 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3496 return block; /* do {} while 0 does once */
3497 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3498 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3499 expr = newUNOP(OP_DEFINED, 0,
3500 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3501 } else if (expr->op_flags & OPf_KIDS) {
3502 OP *k1 = ((UNOP*)expr)->op_first;
3503 OP *k2 = (k1) ? k1->op_sibling : NULL;
3504 switch (expr->op_type) {
3506 if (k2 && k2->op_type == OP_READLINE
3507 && (k2->op_flags & OPf_STACKED)
3508 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3509 expr = newUNOP(OP_DEFINED, 0, expr);
3513 if (k1->op_type == OP_READDIR
3514 || k1->op_type == OP_GLOB
3515 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3516 || k1->op_type == OP_EACH)
3517 expr = newUNOP(OP_DEFINED, 0, expr);
3523 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3524 o = new_logop(OP_AND, 0, &expr, &listop);
3527 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3529 if (once && o != listop)
3530 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3533 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3535 o->op_flags |= flags;
3537 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3542 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3550 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3551 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3552 expr = newUNOP(OP_DEFINED, 0,
3553 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3554 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3555 OP *k1 = ((UNOP*)expr)->op_first;
3556 OP *k2 = (k1) ? k1->op_sibling : NULL;
3557 switch (expr->op_type) {
3559 if (k2 && k2->op_type == OP_READLINE
3560 && (k2->op_flags & OPf_STACKED)
3561 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3562 expr = newUNOP(OP_DEFINED, 0, expr);
3566 if (k1->op_type == OP_READDIR
3567 || k1->op_type == OP_GLOB
3568 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3569 || k1->op_type == OP_EACH)
3570 expr = newUNOP(OP_DEFINED, 0, expr);
3576 block = newOP(OP_NULL, 0);
3578 block = scope(block);
3582 next = LINKLIST(cont);
3585 OP *unstack = newOP(OP_UNSTACK, 0);
3588 cont = append_elem(OP_LINESEQ, cont, unstack);
3589 if ((line_t)whileline != NOLINE) {
3590 PL_copline = (line_t)whileline;
3591 cont = append_elem(OP_LINESEQ, cont,
3592 newSTATEOP(0, Nullch, Nullop));
3596 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3597 redo = LINKLIST(listop);
3600 PL_copline = (line_t)whileline;
3602 o = new_logop(OP_AND, 0, &expr, &listop);
3603 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3604 op_free(expr); /* oops, it's a while (0) */
3606 return Nullop; /* listop already freed by new_logop */
3609 ((LISTOP*)listop)->op_last->op_next =
3610 (o == listop ? redo : LINKLIST(o));
3616 NewOp(1101,loop,1,LOOP);
3617 loop->op_type = OP_ENTERLOOP;
3618 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3619 loop->op_private = 0;
3620 loop->op_next = (OP*)loop;
3623 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3625 loop->op_redoop = redo;
3626 loop->op_lastop = o;
3627 o->op_private |= loopflags;
3630 loop->op_nextop = next;
3632 loop->op_nextop = o;
3634 o->op_flags |= flags;
3635 o->op_private |= (flags >> 8);
3640 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
3644 PADOFFSET padoff = 0;
3648 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
3649 sv->op_type = OP_RV2GV;
3650 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3652 else if (sv->op_type == OP_PADSV) { /* private variable */
3653 padoff = sv->op_targ;
3658 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3659 padoff = sv->op_targ;
3661 iterflags |= OPf_SPECIAL;
3666 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3669 sv = newGVOP(OP_GV, 0, PL_defgv);
3671 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3672 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3673 iterflags |= OPf_STACKED;
3675 else if (expr->op_type == OP_NULL &&
3676 (expr->op_flags & OPf_KIDS) &&
3677 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3679 /* Basically turn for($x..$y) into the same as for($x,$y), but we
3680 * set the STACKED flag to indicate that these values are to be
3681 * treated as min/max values by 'pp_iterinit'.
3683 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
3684 LOGOP* range = (LOGOP*) flip->op_first;
3685 OP* left = range->op_first;
3686 OP* right = left->op_sibling;
3689 range->op_flags &= ~OPf_KIDS;
3690 range->op_first = Nullop;
3692 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
3693 listop->op_first->op_next = range->op_next;
3694 left->op_next = range->op_other;
3695 right->op_next = (OP*)listop;
3696 listop->op_next = listop->op_first;
3699 expr = (OP*)(listop);
3701 iterflags |= OPf_STACKED;
3704 expr = mod(force_list(expr), OP_GREPSTART);
3708 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
3709 append_elem(OP_LIST, expr, scalar(sv))));
3710 assert(!loop->op_next);
3711 #ifdef PL_OP_SLAB_ALLOC
3714 NewOp(1234,tmp,1,LOOP);
3715 Copy(loop,tmp,1,LOOP);
3720 Renew(loop, 1, LOOP);
3722 loop->op_targ = padoff;
3723 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
3724 PL_copline = forline;
3725 return newSTATEOP(0, label, wop);
3729 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
3734 if (type != OP_GOTO || label->op_type == OP_CONST) {
3735 /* "last()" means "last" */
3736 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
3737 o = newOP(type, OPf_SPECIAL);
3739 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
3740 ? SvPVx(((SVOP*)label)->op_sv, n_a)
3746 if (label->op_type == OP_ENTERSUB)
3747 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
3748 o = newUNOP(type, OPf_STACKED, label);
3750 PL_hints |= HINT_BLOCK_SCOPE;
3755 =for apidoc cv_undef
3757 Clear out all the active components of a CV. This can happen either
3758 by an explicit C<undef &foo>, or by the reference count going to zero.
3759 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
3760 children can still follow the full lexical scope chain.
3766 Perl_cv_undef(pTHX_ CV *cv)
3769 if (CvFILE(cv) && !CvXSUB(cv)) {
3770 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
3771 Safefree(CvFILE(cv));
3776 if (!CvXSUB(cv) && CvROOT(cv)) {
3778 Perl_croak(aTHX_ "Can't undef active subroutine");
3781 PAD_SAVE_SETNULLPAD();
3783 op_free(CvROOT(cv));
3784 CvROOT(cv) = Nullop;
3787 SvPOK_off((SV*)cv); /* forget prototype */
3792 /* remove CvOUTSIDE unless this is an undef rather than a free */
3793 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
3794 if (!CvWEAKOUTSIDE(cv))
3795 SvREFCNT_dec(CvOUTSIDE(cv));
3796 CvOUTSIDE(cv) = Nullcv;
3799 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
3805 /* delete all flags except WEAKOUTSIDE */
3806 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
3810 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
3812 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
3813 SV* msg = sv_newmortal();
3817 gv_efullname3(name = sv_newmortal(), gv, Nullch);
3818 sv_setpv(msg, "Prototype mismatch:");
3820 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
3822 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (SV *)cv);
3823 sv_catpv(msg, " vs ");
3825 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
3827 sv_catpv(msg, "none");
3828 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
3832 static void const_sv_xsub(pTHX_ CV* cv);
3836 =head1 Optree Manipulation Functions
3838 =for apidoc cv_const_sv
3840 If C<cv> is a constant sub eligible for inlining. returns the constant
3841 value returned by the sub. Otherwise, returns NULL.
3843 Constant subs can be created with C<newCONSTSUB> or as described in
3844 L<perlsub/"Constant Functions">.
3849 Perl_cv_const_sv(pTHX_ CV *cv)
3851 if (!cv || !CvCONST(cv))
3853 return (SV*)CvXSUBANY(cv).any_ptr;
3857 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
3864 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
3865 o = cLISTOPo->op_first->op_sibling;
3867 for (; o; o = o->op_next) {
3868 OPCODE type = o->op_type;
3870 if (sv && o->op_next == o)
3872 if (o->op_next != o) {
3873 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
3875 if (type == OP_DBSTATE)
3878 if (type == OP_LEAVESUB || type == OP_RETURN)
3882 if (type == OP_CONST && cSVOPo->op_sv)
3884 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
3885 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
3889 /* We get here only from cv_clone2() while creating a closure.
3890 Copy the const value here instead of in cv_clone2 so that
3891 SvREADONLY_on doesn't lead to problems when leaving
3896 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
3908 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
3918 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
3922 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
3924 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
3928 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
3934 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
3938 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
3939 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
3940 SV *sv = sv_newmortal();
3941 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
3942 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
3943 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3948 gv = gv_fetchpv(name ? name : (aname ? aname :
3949 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__")),
3950 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
3960 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
3961 maximum a prototype before. */
3962 if (SvTYPE(gv) > SVt_NULL) {
3963 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
3964 && ckWARN_d(WARN_PROTOTYPE))
3966 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
3968 cv_ckproto((CV*)gv, NULL, ps);
3971 sv_setpv((SV*)gv, ps);
3973 sv_setiv((SV*)gv, -1);
3974 SvREFCNT_dec(PL_compcv);
3975 cv = PL_compcv = NULL;
3976 PL_sub_generation++;
3980 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
3982 #ifdef GV_UNIQUE_CHECK
3983 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
3984 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
3988 if (!block || !ps || *ps || attrs)
3991 const_sv = op_const_sv(block, Nullcv);
3994 bool exists = CvROOT(cv) || CvXSUB(cv);
3996 #ifdef GV_UNIQUE_CHECK
3997 if (exists && GvUNIQUE(gv)) {
3998 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4002 /* if the subroutine doesn't exist and wasn't pre-declared
4003 * with a prototype, assume it will be AUTOLOADed,
4004 * skipping the prototype check
4006 if (exists || SvPOK(cv))
4007 cv_ckproto(cv, gv, ps);
4008 /* already defined (or promised)? */
4009 if (exists || GvASSUMECV(gv)) {
4010 if (!block && !attrs) {
4011 if (CvFLAGS(PL_compcv)) {
4012 /* might have had built-in attrs applied */
4013 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4015 /* just a "sub foo;" when &foo is already defined */
4016 SAVEFREESV(PL_compcv);
4019 /* ahem, death to those who redefine active sort subs */
4020 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4021 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4023 if (ckWARN(WARN_REDEFINE)
4025 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4027 line_t oldline = CopLINE(PL_curcop);
4028 if (PL_copline != NOLINE)
4029 CopLINE_set(PL_curcop, PL_copline);
4030 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4031 CvCONST(cv) ? "Constant subroutine %s redefined"
4032 : "Subroutine %s redefined", name);
4033 CopLINE_set(PL_curcop, oldline);
4041 SvREFCNT_inc(const_sv);
4043 assert(!CvROOT(cv) && !CvCONST(cv));
4044 sv_setpv((SV*)cv, ""); /* prototype is "" */
4045 CvXSUBANY(cv).any_ptr = const_sv;
4046 CvXSUB(cv) = const_sv_xsub;
4051 cv = newCONSTSUB(NULL, name, const_sv);
4054 SvREFCNT_dec(PL_compcv);
4056 PL_sub_generation++;
4063 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4064 * before we clobber PL_compcv.
4068 /* Might have had built-in attributes applied -- propagate them. */
4069 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4070 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4071 stash = GvSTASH(CvGV(cv));
4072 else if (CvSTASH(cv))
4073 stash = CvSTASH(cv);
4075 stash = PL_curstash;
4078 /* possibly about to re-define existing subr -- ignore old cv */
4079 rcv = (SV*)PL_compcv;
4080 if (name && GvSTASH(gv))
4081 stash = GvSTASH(gv);
4083 stash = PL_curstash;
4085 apply_attrs(stash, rcv, attrs, FALSE);
4087 if (cv) { /* must reuse cv if autoloaded */
4089 /* got here with just attrs -- work done, so bug out */
4090 SAVEFREESV(PL_compcv);
4093 /* transfer PL_compcv to cv */
4095 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4096 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4097 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4098 CvOUTSIDE(PL_compcv) = 0;
4099 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4100 CvPADLIST(PL_compcv) = 0;
4101 /* inner references to PL_compcv must be fixed up ... */
4102 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4103 /* ... before we throw it away */
4104 SvREFCNT_dec(PL_compcv);
4105 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4106 ++PL_sub_generation;
4113 PL_sub_generation++;
4117 CvFILE_set_from_cop(cv, PL_curcop);
4118 CvSTASH(cv) = PL_curstash;
4121 sv_setpv((SV*)cv, ps);
4123 if (PL_error_count) {
4127 char *s = strrchr(name, ':');
4129 if (strEQ(s, "BEGIN")) {
4131 "BEGIN not safe after errors--compilation aborted";
4132 if (PL_in_eval & EVAL_KEEPERR)
4133 Perl_croak(aTHX_ not_safe);
4135 /* force display of errors found but not reported */
4136 sv_catpv(ERRSV, not_safe);
4137 Perl_croak(aTHX_ "%"SVf, ERRSV);
4146 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4147 mod(scalarseq(block), OP_LEAVESUBLV));
4150 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4152 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4153 OpREFCNT_set(CvROOT(cv), 1);
4154 CvSTART(cv) = LINKLIST(CvROOT(cv));
4155 CvROOT(cv)->op_next = 0;
4156 CALL_PEEP(CvSTART(cv));
4158 /* now that optimizer has done its work, adjust pad values */
4160 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4163 assert(!CvCONST(cv));
4164 if (ps && !*ps && op_const_sv(block, cv))
4168 if (name || aname) {
4170 char *tname = (name ? name : aname);
4172 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4173 SV *sv = NEWSV(0,0);
4174 SV *tmpstr = sv_newmortal();
4175 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4179 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4181 (long)PL_subline, (long)CopLINE(PL_curcop));
4182 gv_efullname3(tmpstr, gv, Nullch);
4183 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4184 hv = GvHVn(db_postponed);
4185 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4186 && (pcv = GvCV(db_postponed)))
4192 call_sv((SV*)pcv, G_DISCARD);
4196 if ((s = strrchr(tname,':')))
4201 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4204 if (strEQ(s, "BEGIN") && !PL_error_count) {
4205 I32 oldscope = PL_scopestack_ix;
4207 SAVECOPFILE(&PL_compiling);
4208 SAVECOPLINE(&PL_compiling);
4211 PL_beginav = newAV();
4212 DEBUG_x( dump_sub(gv) );
4213 av_push(PL_beginav, (SV*)cv);
4214 GvCV(gv) = 0; /* cv has been hijacked */
4215 call_list(oldscope, PL_beginav);
4217 PL_curcop = &PL_compiling;
4218 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4221 else if (strEQ(s, "END") && !PL_error_count) {
4224 DEBUG_x( dump_sub(gv) );
4225 av_unshift(PL_endav, 1);
4226 av_store(PL_endav, 0, (SV*)cv);
4227 GvCV(gv) = 0; /* cv has been hijacked */
4229 else if (strEQ(s, "CHECK") && !PL_error_count) {
4231 PL_checkav = newAV();
4232 DEBUG_x( dump_sub(gv) );
4233 if (PL_main_start && ckWARN(WARN_VOID))
4234 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4235 av_unshift(PL_checkav, 1);
4236 av_store(PL_checkav, 0, (SV*)cv);
4237 GvCV(gv) = 0; /* cv has been hijacked */
4239 else if (strEQ(s, "INIT") && !PL_error_count) {
4241 PL_initav = newAV();
4242 DEBUG_x( dump_sub(gv) );
4243 if (PL_main_start && ckWARN(WARN_VOID))
4244 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4245 av_push(PL_initav, (SV*)cv);
4246 GvCV(gv) = 0; /* cv has been hijacked */
4251 PL_copline = NOLINE;
4256 /* XXX unsafe for threads if eval_owner isn't held */
4258 =for apidoc newCONSTSUB
4260 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4261 eligible for inlining at compile-time.
4267 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4273 SAVECOPLINE(PL_curcop);
4274 CopLINE_set(PL_curcop, PL_copline);
4277 PL_hints &= ~HINT_BLOCK_SCOPE;
4280 SAVESPTR(PL_curstash);
4281 SAVECOPSTASH(PL_curcop);
4282 PL_curstash = stash;
4283 CopSTASH_set(PL_curcop,stash);
4286 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4287 CvXSUBANY(cv).any_ptr = sv;
4289 sv_setpv((SV*)cv, ""); /* prototype is "" */
4297 =for apidoc U||newXS
4299 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4305 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
4307 GV *gv = gv_fetchpv(name ? name :
4308 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4309 GV_ADDMULTI, SVt_PVCV);
4313 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4315 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4317 /* just a cached method */
4321 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4322 /* already defined (or promised) */
4323 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4324 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4325 line_t oldline = CopLINE(PL_curcop);
4326 if (PL_copline != NOLINE)
4327 CopLINE_set(PL_curcop, PL_copline);
4328 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4329 CvCONST(cv) ? "Constant subroutine %s redefined"
4330 : "Subroutine %s redefined"
4332 CopLINE_set(PL_curcop, oldline);
4339 if (cv) /* must reuse cv if autoloaded */
4342 cv = (CV*)NEWSV(1105,0);
4343 sv_upgrade((SV *)cv, SVt_PVCV);
4347 PL_sub_generation++;
4351 (void)gv_fetchfile(filename);
4352 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
4353 an external constant string */
4354 CvXSUB(cv) = subaddr;
4357 char *s = strrchr(name,':');
4363 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4366 if (strEQ(s, "BEGIN")) {
4368 PL_beginav = newAV();
4369 av_push(PL_beginav, (SV*)cv);
4370 GvCV(gv) = 0; /* cv has been hijacked */
4372 else if (strEQ(s, "END")) {
4375 av_unshift(PL_endav, 1);
4376 av_store(PL_endav, 0, (SV*)cv);
4377 GvCV(gv) = 0; /* cv has been hijacked */
4379 else if (strEQ(s, "CHECK")) {
4381 PL_checkav = newAV();
4382 if (PL_main_start && ckWARN(WARN_VOID))
4383 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4384 av_unshift(PL_checkav, 1);
4385 av_store(PL_checkav, 0, (SV*)cv);
4386 GvCV(gv) = 0; /* cv has been hijacked */
4388 else if (strEQ(s, "INIT")) {
4390 PL_initav = newAV();
4391 if (PL_main_start && ckWARN(WARN_VOID))
4392 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4393 av_push(PL_initav, (SV*)cv);
4394 GvCV(gv) = 0; /* cv has been hijacked */
4405 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4413 name = SvPVx(cSVOPo->op_sv, n_a);
4416 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
4417 #ifdef GV_UNIQUE_CHECK
4419 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4423 if ((cv = GvFORM(gv))) {
4424 if (ckWARN(WARN_REDEFINE)) {
4425 line_t oldline = CopLINE(PL_curcop);
4426 if (PL_copline != NOLINE)
4427 CopLINE_set(PL_curcop, PL_copline);
4428 Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Format %s redefined",name);
4429 CopLINE_set(PL_curcop, oldline);
4436 CvFILE_set_from_cop(cv, PL_curcop);
4439 pad_tidy(padtidy_FORMAT);
4440 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4441 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4442 OpREFCNT_set(CvROOT(cv), 1);
4443 CvSTART(cv) = LINKLIST(CvROOT(cv));
4444 CvROOT(cv)->op_next = 0;
4445 CALL_PEEP(CvSTART(cv));
4447 PL_copline = NOLINE;
4452 Perl_newANONLIST(pTHX_ OP *o)
4454 return newUNOP(OP_REFGEN, 0,
4455 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4459 Perl_newANONHASH(pTHX_ OP *o)
4461 return newUNOP(OP_REFGEN, 0,
4462 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4466 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4468 return newANONATTRSUB(floor, proto, Nullop, block);
4472 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4474 return newUNOP(OP_REFGEN, 0,
4475 newSVOP(OP_ANONCODE, 0,
4476 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
4480 Perl_oopsAV(pTHX_ OP *o)
4482 switch (o->op_type) {
4484 o->op_type = OP_PADAV;
4485 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4486 return ref(o, OP_RV2AV);
4489 o->op_type = OP_RV2AV;
4490 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4495 if (ckWARN_d(WARN_INTERNAL))
4496 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
4503 Perl_oopsHV(pTHX_ OP *o)
4505 switch (o->op_type) {
4508 o->op_type = OP_PADHV;
4509 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4510 return ref(o, OP_RV2HV);
4514 o->op_type = OP_RV2HV;
4515 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
4520 if (ckWARN_d(WARN_INTERNAL))
4521 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
4528 Perl_newAVREF(pTHX_ OP *o)
4530 if (o->op_type == OP_PADANY) {
4531 o->op_type = OP_PADAV;
4532 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4535 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
4536 && ckWARN(WARN_DEPRECATED)) {
4537 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4538 "Using an array as a reference is deprecated");
4540 return newUNOP(OP_RV2AV, 0, scalar(o));
4544 Perl_newGVREF(pTHX_ I32 type, OP *o)
4546 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
4547 return newUNOP(OP_NULL, 0, o);
4548 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
4552 Perl_newHVREF(pTHX_ OP *o)
4554 if (o->op_type == OP_PADANY) {
4555 o->op_type = OP_PADHV;
4556 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4559 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
4560 && ckWARN(WARN_DEPRECATED)) {
4561 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4562 "Using a hash as a reference is deprecated");
4564 return newUNOP(OP_RV2HV, 0, scalar(o));
4568 Perl_oopsCV(pTHX_ OP *o)
4570 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
4576 Perl_newCVREF(pTHX_ I32 flags, OP *o)
4578 return newUNOP(OP_RV2CV, flags, scalar(o));
4582 Perl_newSVREF(pTHX_ OP *o)
4584 if (o->op_type == OP_PADANY) {
4585 o->op_type = OP_PADSV;
4586 o->op_ppaddr = PL_ppaddr[OP_PADSV];
4589 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4590 o->op_flags |= OPpDONE_SVREF;
4593 return newUNOP(OP_RV2SV, 0, scalar(o));
4596 /* Check routines. */
4599 Perl_ck_anoncode(pTHX_ OP *o)
4601 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
4602 cSVOPo->op_sv = Nullsv;
4607 Perl_ck_bitop(pTHX_ OP *o)
4609 #define OP_IS_NUMCOMPARE(op) \
4610 ((op) == OP_LT || (op) == OP_I_LT || \
4611 (op) == OP_GT || (op) == OP_I_GT || \
4612 (op) == OP_LE || (op) == OP_I_LE || \
4613 (op) == OP_GE || (op) == OP_I_GE || \
4614 (op) == OP_EQ || (op) == OP_I_EQ || \
4615 (op) == OP_NE || (op) == OP_I_NE || \
4616 (op) == OP_NCMP || (op) == OP_I_NCMP)
4617 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4618 if (o->op_type == OP_BIT_OR
4619 || o->op_type == OP_BIT_AND
4620 || o->op_type == OP_BIT_XOR)
4622 OPCODE typfirst = cBINOPo->op_first->op_type;
4623 OPCODE typlast = cBINOPo->op_first->op_sibling->op_type;
4624 if (OP_IS_NUMCOMPARE(typfirst) || OP_IS_NUMCOMPARE(typlast))
4625 if (ckWARN(WARN_PRECEDENCE))
4626 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4627 "Possible precedence problem on bitwise %c operator",
4628 o->op_type == OP_BIT_OR ? '|'
4629 : o->op_type == OP_BIT_AND ? '&' : '^'
4636 Perl_ck_concat(pTHX_ OP *o)
4638 if (cUNOPo->op_first->op_type == OP_CONCAT)
4639 o->op_flags |= OPf_STACKED;
4644 Perl_ck_spair(pTHX_ OP *o)
4646 if (o->op_flags & OPf_KIDS) {
4649 OPCODE type = o->op_type;
4650 o = modkids(ck_fun(o), type);
4651 kid = cUNOPo->op_first;
4652 newop = kUNOP->op_first->op_sibling;
4654 (newop->op_sibling ||
4655 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
4656 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
4657 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
4661 op_free(kUNOP->op_first);
4662 kUNOP->op_first = newop;
4664 o->op_ppaddr = PL_ppaddr[++o->op_type];
4669 Perl_ck_delete(pTHX_ OP *o)
4673 if (o->op_flags & OPf_KIDS) {
4674 OP *kid = cUNOPo->op_first;
4675 switch (kid->op_type) {
4677 o->op_flags |= OPf_SPECIAL;
4680 o->op_private |= OPpSLICE;
4683 o->op_flags |= OPf_SPECIAL;
4688 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
4697 Perl_ck_die(pTHX_ OP *o)
4700 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4706 Perl_ck_eof(pTHX_ OP *o)
4708 I32 type = o->op_type;
4710 if (o->op_flags & OPf_KIDS) {
4711 if (cLISTOPo->op_first->op_type == OP_STUB) {
4713 o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
4721 Perl_ck_eval(pTHX_ OP *o)
4723 PL_hints |= HINT_BLOCK_SCOPE;
4724 if (o->op_flags & OPf_KIDS) {
4725 SVOP *kid = (SVOP*)cUNOPo->op_first;
4728 o->op_flags &= ~OPf_KIDS;
4731 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
4734 cUNOPo->op_first = 0;
4737 NewOp(1101, enter, 1, LOGOP);
4738 enter->op_type = OP_ENTERTRY;
4739 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
4740 enter->op_private = 0;
4742 /* establish postfix order */
4743 enter->op_next = (OP*)enter;
4745 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
4746 o->op_type = OP_LEAVETRY;
4747 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
4748 enter->op_other = o;
4756 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
4758 o->op_targ = (PADOFFSET)PL_hints;
4763 Perl_ck_exit(pTHX_ OP *o)
4766 HV *table = GvHV(PL_hintgv);
4768 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
4769 if (svp && *svp && SvTRUE(*svp))
4770 o->op_private |= OPpEXIT_VMSISH;
4772 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4778 Perl_ck_exec(pTHX_ OP *o)
4781 if (o->op_flags & OPf_STACKED) {
4783 kid = cUNOPo->op_first->op_sibling;
4784 if (kid->op_type == OP_RV2GV)
4793 Perl_ck_exists(pTHX_ OP *o)
4796 if (o->op_flags & OPf_KIDS) {
4797 OP *kid = cUNOPo->op_first;
4798 if (kid->op_type == OP_ENTERSUB) {
4799 (void) ref(kid, o->op_type);
4800 if (kid->op_type != OP_RV2CV && !PL_error_count)
4801 Perl_croak(aTHX_ "%s argument is not a subroutine name",
4803 o->op_private |= OPpEXISTS_SUB;
4805 else if (kid->op_type == OP_AELEM)
4806 o->op_flags |= OPf_SPECIAL;
4807 else if (kid->op_type != OP_HELEM)
4808 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
4817 Perl_ck_gvconst(pTHX_ register OP *o)
4819 o = fold_constants(o);
4820 if (o->op_type == OP_CONST)
4827 Perl_ck_rvconst(pTHX_ register OP *o)
4829 SVOP *kid = (SVOP*)cUNOPo->op_first;
4831 o->op_private |= (PL_hints & HINT_STRICT_REFS);
4832 if (kid->op_type == OP_CONST) {
4836 SV *kidsv = kid->op_sv;
4839 /* Is it a constant from cv_const_sv()? */
4840 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
4841 SV *rsv = SvRV(kidsv);
4842 int svtype = SvTYPE(rsv);
4843 char *badtype = Nullch;
4845 switch (o->op_type) {
4847 if (svtype > SVt_PVMG)
4848 badtype = "a SCALAR";
4851 if (svtype != SVt_PVAV)
4852 badtype = "an ARRAY";
4855 if (svtype != SVt_PVHV)
4859 if (svtype != SVt_PVCV)
4864 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
4867 name = SvPV(kidsv, n_a);
4868 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
4869 char *badthing = Nullch;
4870 switch (o->op_type) {
4872 badthing = "a SCALAR";
4875 badthing = "an ARRAY";
4878 badthing = "a HASH";
4883 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
4887 * This is a little tricky. We only want to add the symbol if we
4888 * didn't add it in the lexer. Otherwise we get duplicate strict
4889 * warnings. But if we didn't add it in the lexer, we must at
4890 * least pretend like we wanted to add it even if it existed before,
4891 * or we get possible typo warnings. OPpCONST_ENTERED says
4892 * whether the lexer already added THIS instance of this symbol.
4894 iscv = (o->op_type == OP_RV2CV) * 2;
4896 gv = gv_fetchpv(name,
4897 iscv | !(kid->op_private & OPpCONST_ENTERED),
4900 : o->op_type == OP_RV2SV
4902 : o->op_type == OP_RV2AV
4904 : o->op_type == OP_RV2HV
4907 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
4909 kid->op_type = OP_GV;
4910 SvREFCNT_dec(kid->op_sv);
4912 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
4913 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
4914 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
4916 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
4918 kid->op_sv = SvREFCNT_inc(gv);
4920 kid->op_private = 0;
4921 kid->op_ppaddr = PL_ppaddr[OP_GV];
4928 Perl_ck_ftst(pTHX_ OP *o)
4930 I32 type = o->op_type;
4932 if (o->op_flags & OPf_REF) {
4935 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
4936 SVOP *kid = (SVOP*)cUNOPo->op_first;
4938 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
4940 OP *newop = newGVOP(type, OPf_REF,
4941 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
4946 if ((PL_hints & HINT_FILETEST_ACCESS) &&
4947 OP_IS_FILETEST_ACCESS(o))
4948 o->op_private |= OPpFT_ACCESS;
4953 if (type == OP_FTTTY)
4954 o = newGVOP(type, OPf_REF, PL_stdingv);
4956 o = newUNOP(type, 0, newDEFSVOP());
4962 Perl_ck_fun(pTHX_ OP *o)
4968 int type = o->op_type;
4969 register I32 oa = PL_opargs[type] >> OASHIFT;
4971 if (o->op_flags & OPf_STACKED) {
4972 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
4975 return no_fh_allowed(o);
4978 if (o->op_flags & OPf_KIDS) {
4980 tokid = &cLISTOPo->op_first;
4981 kid = cLISTOPo->op_first;
4982 if (kid->op_type == OP_PUSHMARK ||
4983 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
4985 tokid = &kid->op_sibling;
4986 kid = kid->op_sibling;
4988 if (!kid && PL_opargs[type] & OA_DEFGV)
4989 *tokid = kid = newDEFSVOP();
4993 sibl = kid->op_sibling;
4996 /* list seen where single (scalar) arg expected? */
4997 if (numargs == 1 && !(oa >> 4)
4998 && kid->op_type == OP_LIST && type != OP_SCALAR)
5000 return too_many_arguments(o,PL_op_desc[type]);
5013 if ((type == OP_PUSH || type == OP_UNSHIFT)
5014 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5015 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5016 "Useless use of %s with no values",
5019 if (kid->op_type == OP_CONST &&
5020 (kid->op_private & OPpCONST_BARE))
5022 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5023 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5024 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5025 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5026 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5027 "Array @%s missing the @ in argument %"IVdf" of %s()",
5028 name, (IV)numargs, PL_op_desc[type]);
5031 kid->op_sibling = sibl;
5034 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5035 bad_type(numargs, "array", PL_op_desc[type], kid);
5039 if (kid->op_type == OP_CONST &&
5040 (kid->op_private & OPpCONST_BARE))
5042 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5043 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5044 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5045 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5046 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5047 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5048 name, (IV)numargs, PL_op_desc[type]);
5051 kid->op_sibling = sibl;
5054 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5055 bad_type(numargs, "hash", PL_op_desc[type], kid);
5060 OP *newop = newUNOP(OP_NULL, 0, kid);
5061 kid->op_sibling = 0;
5063 newop->op_next = newop;
5065 kid->op_sibling = sibl;
5070 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5071 if (kid->op_type == OP_CONST &&
5072 (kid->op_private & OPpCONST_BARE))
5074 OP *newop = newGVOP(OP_GV, 0,
5075 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5077 if (!(o->op_private & 1) && /* if not unop */
5078 kid == cLISTOPo->op_last)
5079 cLISTOPo->op_last = newop;
5083 else if (kid->op_type == OP_READLINE) {
5084 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5085 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5088 I32 flags = OPf_SPECIAL;
5092 /* is this op a FH constructor? */
5093 if (is_handle_constructor(o,numargs)) {
5094 char *name = Nullch;
5098 /* Set a flag to tell rv2gv to vivify
5099 * need to "prove" flag does not mean something
5100 * else already - NI-S 1999/05/07
5103 if (kid->op_type == OP_PADSV) {
5104 /*XXX DAPM 2002.08.25 tmp assert test */
5105 /*XXX*/ assert(av_fetch(PL_comppad_name, (kid->op_targ), FALSE));
5106 /*XXX*/ assert(*av_fetch(PL_comppad_name, (kid->op_targ), FALSE));
5108 name = PAD_COMPNAME_PV(kid->op_targ);
5109 /* SvCUR of a pad namesv can't be trusted
5110 * (see PL_generation), so calc its length
5116 else if (kid->op_type == OP_RV2SV
5117 && kUNOP->op_first->op_type == OP_GV)
5119 GV *gv = cGVOPx_gv(kUNOP->op_first);
5121 len = GvNAMELEN(gv);
5123 else if (kid->op_type == OP_AELEM
5124 || kid->op_type == OP_HELEM)
5129 if ((op = ((BINOP*)kid)->op_first)) {
5130 SV *tmpstr = Nullsv;
5132 kid->op_type == OP_AELEM ?
5134 if (((op->op_type == OP_RV2AV) ||
5135 (op->op_type == OP_RV2HV)) &&
5136 (op = ((UNOP*)op)->op_first) &&
5137 (op->op_type == OP_GV)) {
5138 /* packagevar $a[] or $h{} */
5139 GV *gv = cGVOPx_gv(op);
5147 else if (op->op_type == OP_PADAV
5148 || op->op_type == OP_PADHV) {
5149 /* lexicalvar $a[] or $h{} */
5151 PAD_COMPNAME_PV(op->op_targ);
5161 name = savepv(SvPVX(tmpstr));
5167 name = "__ANONIO__";
5174 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5175 namesv = PAD_SVl(targ);
5176 (void)SvUPGRADE(namesv, SVt_PV);
5178 sv_setpvn(namesv, "$", 1);
5179 sv_catpvn(namesv, name, len);
5182 kid->op_sibling = 0;
5183 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5184 kid->op_targ = targ;
5185 kid->op_private |= priv;
5187 kid->op_sibling = sibl;
5193 mod(scalar(kid), type);
5197 tokid = &kid->op_sibling;
5198 kid = kid->op_sibling;
5200 o->op_private |= numargs;
5202 return too_many_arguments(o,OP_DESC(o));
5205 else if (PL_opargs[type] & OA_DEFGV) {
5207 return newUNOP(type, 0, newDEFSVOP());
5211 while (oa & OA_OPTIONAL)
5213 if (oa && oa != OA_LIST)
5214 return too_few_arguments(o,OP_DESC(o));
5220 Perl_ck_glob(pTHX_ OP *o)
5225 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5226 append_elem(OP_GLOB, o, newDEFSVOP());
5228 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5229 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5231 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5234 #if !defined(PERL_EXTERNAL_GLOB)
5235 /* XXX this can be tightened up and made more failsafe. */
5239 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5240 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5241 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5242 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5243 GvCV(gv) = GvCV(glob_gv);
5244 SvREFCNT_inc((SV*)GvCV(gv));
5245 GvIMPORTED_CV_on(gv);
5248 #endif /* PERL_EXTERNAL_GLOB */
5250 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5251 append_elem(OP_GLOB, o,
5252 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5253 o->op_type = OP_LIST;
5254 o->op_ppaddr = PL_ppaddr[OP_LIST];
5255 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5256 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5257 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5258 append_elem(OP_LIST, o,
5259 scalar(newUNOP(OP_RV2CV, 0,
5260 newGVOP(OP_GV, 0, gv)))));
5261 o = newUNOP(OP_NULL, 0, ck_subr(o));
5262 o->op_targ = OP_GLOB; /* hint at what it used to be */
5265 gv = newGVgen("main");
5267 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5273 Perl_ck_grep(pTHX_ OP *o)
5277 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5279 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5280 NewOp(1101, gwop, 1, LOGOP);
5282 if (o->op_flags & OPf_STACKED) {
5285 kid = cLISTOPo->op_first->op_sibling;
5286 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5289 kid->op_next = (OP*)gwop;
5290 o->op_flags &= ~OPf_STACKED;
5292 kid = cLISTOPo->op_first->op_sibling;
5293 if (type == OP_MAPWHILE)
5300 kid = cLISTOPo->op_first->op_sibling;
5301 if (kid->op_type != OP_NULL)
5302 Perl_croak(aTHX_ "panic: ck_grep");
5303 kid = kUNOP->op_first;
5305 gwop->op_type = type;
5306 gwop->op_ppaddr = PL_ppaddr[type];
5307 gwop->op_first = listkids(o);
5308 gwop->op_flags |= OPf_KIDS;
5309 gwop->op_private = 1;
5310 gwop->op_other = LINKLIST(kid);
5311 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5312 kid->op_next = (OP*)gwop;
5314 kid = cLISTOPo->op_first->op_sibling;
5315 if (!kid || !kid->op_sibling)
5316 return too_few_arguments(o,OP_DESC(o));
5317 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5318 mod(kid, OP_GREPSTART);
5324 Perl_ck_index(pTHX_ OP *o)
5326 if (o->op_flags & OPf_KIDS) {
5327 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5329 kid = kid->op_sibling; /* get past "big" */
5330 if (kid && kid->op_type == OP_CONST)
5331 fbm_compile(((SVOP*)kid)->op_sv, 0);
5337 Perl_ck_lengthconst(pTHX_ OP *o)
5339 /* XXX length optimization goes here */
5344 Perl_ck_lfun(pTHX_ OP *o)
5346 OPCODE type = o->op_type;
5347 return modkids(ck_fun(o), type);
5351 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5353 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5354 switch (cUNOPo->op_first->op_type) {
5356 /* This is needed for
5357 if (defined %stash::)
5358 to work. Do not break Tk.
5360 break; /* Globals via GV can be undef */
5362 case OP_AASSIGN: /* Is this a good idea? */
5363 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5364 "defined(@array) is deprecated");
5365 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5366 "\t(Maybe you should just omit the defined()?)\n");
5369 /* This is needed for
5370 if (defined %stash::)
5371 to work. Do not break Tk.
5373 break; /* Globals via GV can be undef */
5375 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5376 "defined(%%hash) is deprecated");
5377 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5378 "\t(Maybe you should just omit the defined()?)\n");
5389 Perl_ck_rfun(pTHX_ OP *o)
5391 OPCODE type = o->op_type;
5392 return refkids(ck_fun(o), type);
5396 Perl_ck_listiob(pTHX_ OP *o)
5400 kid = cLISTOPo->op_first;
5403 kid = cLISTOPo->op_first;
5405 if (kid->op_type == OP_PUSHMARK)
5406 kid = kid->op_sibling;
5407 if (kid && o->op_flags & OPf_STACKED)
5408 kid = kid->op_sibling;
5409 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5410 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5411 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5412 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5413 cLISTOPo->op_first->op_sibling = kid;
5414 cLISTOPo->op_last = kid;
5415 kid = kid->op_sibling;
5420 append_elem(o->op_type, o, newDEFSVOP());
5426 Perl_ck_sassign(pTHX_ OP *o)
5428 OP *kid = cLISTOPo->op_first;
5429 /* has a disposable target? */
5430 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5431 && !(kid->op_flags & OPf_STACKED)
5432 /* Cannot steal the second time! */
5433 && !(kid->op_private & OPpTARGET_MY))
5435 OP *kkid = kid->op_sibling;
5437 /* Can just relocate the target. */
5438 if (kkid && kkid->op_type == OP_PADSV
5439 && !(kkid->op_private & OPpLVAL_INTRO))
5441 kid->op_targ = kkid->op_targ;
5443 /* Now we do not need PADSV and SASSIGN. */
5444 kid->op_sibling = o->op_sibling; /* NULL */
5445 cLISTOPo->op_first = NULL;
5448 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
5456 Perl_ck_match(pTHX_ OP *o)
5458 o->op_private |= OPpRUNTIME;
5463 Perl_ck_method(pTHX_ OP *o)
5465 OP *kid = cUNOPo->op_first;
5466 if (kid->op_type == OP_CONST) {
5467 SV* sv = kSVOP->op_sv;
5468 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
5470 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5471 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
5474 kSVOP->op_sv = Nullsv;
5476 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5485 Perl_ck_null(pTHX_ OP *o)
5491 Perl_ck_open(pTHX_ OP *o)
5493 HV *table = GvHV(PL_hintgv);
5497 svp = hv_fetch(table, "open_IN", 7, FALSE);
5499 mode = mode_from_discipline(*svp);
5500 if (mode & O_BINARY)
5501 o->op_private |= OPpOPEN_IN_RAW;
5502 else if (mode & O_TEXT)
5503 o->op_private |= OPpOPEN_IN_CRLF;
5506 svp = hv_fetch(table, "open_OUT", 8, FALSE);
5508 mode = mode_from_discipline(*svp);
5509 if (mode & O_BINARY)
5510 o->op_private |= OPpOPEN_OUT_RAW;
5511 else if (mode & O_TEXT)
5512 o->op_private |= OPpOPEN_OUT_CRLF;
5515 if (o->op_type == OP_BACKTICK)
5518 /* In case of three-arg dup open remove strictness
5519 * from the last arg if it is a bareword. */
5520 OP *first = cLISTOPx(o)->op_first; /* The pushmark. */
5521 OP *last = cLISTOPx(o)->op_last; /* The bareword. */
5525 if ((last->op_type == OP_CONST) && /* The bareword. */
5526 (last->op_private & OPpCONST_BARE) &&
5527 (last->op_private & OPpCONST_STRICT) &&
5528 (oa = first->op_sibling) && /* The fh. */
5529 (oa = oa->op_sibling) && /* The mode. */
5530 SvPOK(((SVOP*)oa)->op_sv) &&
5531 (mode = SvPVX(((SVOP*)oa)->op_sv)) &&
5532 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
5533 (last == oa->op_sibling)) /* The bareword. */
5534 last->op_private &= ~OPpCONST_STRICT;
5540 Perl_ck_repeat(pTHX_ OP *o)
5542 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5543 o->op_private |= OPpREPEAT_DOLIST;
5544 cBINOPo->op_first = force_list(cBINOPo->op_first);
5552 Perl_ck_require(pTHX_ OP *o)
5556 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
5557 SVOP *kid = (SVOP*)cUNOPo->op_first;
5559 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5561 for (s = SvPVX(kid->op_sv); *s; s++) {
5562 if (*s == ':' && s[1] == ':') {
5564 Move(s+2, s+1, strlen(s+2)+1, char);
5565 --SvCUR(kid->op_sv);
5568 if (SvREADONLY(kid->op_sv)) {
5569 SvREADONLY_off(kid->op_sv);
5570 sv_catpvn(kid->op_sv, ".pm", 3);
5571 SvREADONLY_on(kid->op_sv);
5574 sv_catpvn(kid->op_sv, ".pm", 3);
5578 /* handle override, if any */
5579 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
5580 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
5581 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
5583 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5584 OP *kid = cUNOPo->op_first;
5585 cUNOPo->op_first = 0;
5587 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5588 append_elem(OP_LIST, kid,
5589 scalar(newUNOP(OP_RV2CV, 0,
5598 Perl_ck_return(pTHX_ OP *o)
5601 if (CvLVALUE(PL_compcv)) {
5602 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5603 mod(kid, OP_LEAVESUBLV);
5610 Perl_ck_retarget(pTHX_ OP *o)
5612 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5619 Perl_ck_select(pTHX_ OP *o)
5622 if (o->op_flags & OPf_KIDS) {
5623 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5624 if (kid && kid->op_sibling) {
5625 o->op_type = OP_SSELECT;
5626 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
5628 return fold_constants(o);
5632 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5633 if (kid && kid->op_type == OP_RV2GV)
5634 kid->op_private &= ~HINT_STRICT_REFS;
5639 Perl_ck_shift(pTHX_ OP *o)
5641 I32 type = o->op_type;
5643 if (!(o->op_flags & OPf_KIDS)) {
5647 argop = newUNOP(OP_RV2AV, 0,
5648 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
5649 return newUNOP(type, 0, scalar(argop));
5651 return scalar(modkids(ck_fun(o), type));
5655 Perl_ck_sort(pTHX_ OP *o)
5659 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
5661 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5662 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
5664 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
5666 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
5668 if (kid->op_type == OP_SCOPE) {
5672 else if (kid->op_type == OP_LEAVE) {
5673 if (o->op_type == OP_SORT) {
5674 op_null(kid); /* wipe out leave */
5677 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
5678 if (k->op_next == kid)
5680 /* don't descend into loops */
5681 else if (k->op_type == OP_ENTERLOOP
5682 || k->op_type == OP_ENTERITER)
5684 k = cLOOPx(k)->op_lastop;
5689 kid->op_next = 0; /* just disconnect the leave */
5690 k = kLISTOP->op_first;
5695 if (o->op_type == OP_SORT) {
5696 /* provide scalar context for comparison function/block */
5702 o->op_flags |= OPf_SPECIAL;
5704 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
5707 firstkid = firstkid->op_sibling;
5710 /* provide list context for arguments */
5711 if (o->op_type == OP_SORT)
5718 S_simplify_sort(pTHX_ OP *o)
5720 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5724 if (!(o->op_flags & OPf_STACKED))
5726 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
5727 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
5728 kid = kUNOP->op_first; /* get past null */
5729 if (kid->op_type != OP_SCOPE)
5731 kid = kLISTOP->op_last; /* get past scope */
5732 switch(kid->op_type) {
5740 k = kid; /* remember this node*/
5741 if (kBINOP->op_first->op_type != OP_RV2SV)
5743 kid = kBINOP->op_first; /* get past cmp */
5744 if (kUNOP->op_first->op_type != OP_GV)
5746 kid = kUNOP->op_first; /* get past rv2sv */
5748 if (GvSTASH(gv) != PL_curstash)
5750 if (strEQ(GvNAME(gv), "a"))
5752 else if (strEQ(GvNAME(gv), "b"))
5756 kid = k; /* back to cmp */
5757 if (kBINOP->op_last->op_type != OP_RV2SV)
5759 kid = kBINOP->op_last; /* down to 2nd arg */
5760 if (kUNOP->op_first->op_type != OP_GV)
5762 kid = kUNOP->op_first; /* get past rv2sv */
5764 if (GvSTASH(gv) != PL_curstash
5766 ? strNE(GvNAME(gv), "a")
5767 : strNE(GvNAME(gv), "b")))
5769 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
5771 o->op_private |= OPpSORT_REVERSE;
5772 if (k->op_type == OP_NCMP)
5773 o->op_private |= OPpSORT_NUMERIC;
5774 if (k->op_type == OP_I_NCMP)
5775 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
5776 kid = cLISTOPo->op_first->op_sibling;
5777 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
5778 op_free(kid); /* then delete it */
5782 Perl_ck_split(pTHX_ OP *o)
5786 if (o->op_flags & OPf_STACKED)
5787 return no_fh_allowed(o);
5789 kid = cLISTOPo->op_first;
5790 if (kid->op_type != OP_NULL)
5791 Perl_croak(aTHX_ "panic: ck_split");
5792 kid = kid->op_sibling;
5793 op_free(cLISTOPo->op_first);
5794 cLISTOPo->op_first = kid;
5796 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
5797 cLISTOPo->op_last = kid; /* There was only one element previously */
5800 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
5801 OP *sibl = kid->op_sibling;
5802 kid->op_sibling = 0;
5803 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
5804 if (cLISTOPo->op_first == cLISTOPo->op_last)
5805 cLISTOPo->op_last = kid;
5806 cLISTOPo->op_first = kid;
5807 kid->op_sibling = sibl;
5810 kid->op_type = OP_PUSHRE;
5811 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
5813 if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
5814 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
5815 "Use of /g modifier is meaningless in split");
5818 if (!kid->op_sibling)
5819 append_elem(OP_SPLIT, o, newDEFSVOP());
5821 kid = kid->op_sibling;
5824 if (!kid->op_sibling)
5825 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
5827 kid = kid->op_sibling;
5830 if (kid->op_sibling)
5831 return too_many_arguments(o,OP_DESC(o));
5837 Perl_ck_join(pTHX_ OP *o)
5839 if (ckWARN(WARN_SYNTAX)) {
5840 OP *kid = cLISTOPo->op_first->op_sibling;
5841 if (kid && kid->op_type == OP_MATCH) {
5842 char *pmstr = "STRING";
5843 if (PM_GETRE(kPMOP))
5844 pmstr = PM_GETRE(kPMOP)->precomp;
5845 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5846 "/%s/ should probably be written as \"%s\"",
5854 Perl_ck_subr(pTHX_ OP *o)
5856 OP *prev = ((cUNOPo->op_first->op_sibling)
5857 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
5858 OP *o2 = prev->op_sibling;
5865 I32 contextclass = 0;
5870 o->op_private |= OPpENTERSUB_HASTARG;
5871 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
5872 if (cvop->op_type == OP_RV2CV) {
5874 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
5875 op_null(cvop); /* disable rv2cv */
5876 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
5877 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
5878 GV *gv = cGVOPx_gv(tmpop);
5881 tmpop->op_private |= OPpEARLY_CV;
5884 namegv = CvANON(cv) ? gv : CvGV(cv);
5885 proto = SvPV((SV*)cv, n_a);
5887 if (CvASSERTION(cv)) {
5888 if (PL_hints & HINT_ASSERTING) {
5889 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
5890 o->op_private |= OPpENTERSUB_DB;
5894 if (ckWARN(WARN_ASSERTIONS) && !(PL_hints & HINT_ASSERTIONSSEEN)) {
5895 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
5896 "Impossible to activate assertion call");
5903 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
5904 if (o2->op_type == OP_CONST)
5905 o2->op_private &= ~OPpCONST_STRICT;
5906 else if (o2->op_type == OP_LIST) {
5907 OP *o = ((UNOP*)o2)->op_first->op_sibling;
5908 if (o && o->op_type == OP_CONST)
5909 o->op_private &= ~OPpCONST_STRICT;
5912 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5913 if (PERLDB_SUB && PL_curstash != PL_debstash)
5914 o->op_private |= OPpENTERSUB_DB;
5915 while (o2 != cvop) {
5919 return too_many_arguments(o, gv_ename(namegv));
5937 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
5939 arg == 1 ? "block or sub {}" : "sub {}",
5940 gv_ename(namegv), o2);
5943 /* '*' allows any scalar type, including bareword */
5946 if (o2->op_type == OP_RV2GV)
5947 goto wrapref; /* autoconvert GLOB -> GLOBref */
5948 else if (o2->op_type == OP_CONST)
5949 o2->op_private &= ~OPpCONST_STRICT;
5950 else if (o2->op_type == OP_ENTERSUB) {
5951 /* accidental subroutine, revert to bareword */
5952 OP *gvop = ((UNOP*)o2)->op_first;
5953 if (gvop && gvop->op_type == OP_NULL) {
5954 gvop = ((UNOP*)gvop)->op_first;
5956 for (; gvop->op_sibling; gvop = gvop->op_sibling)
5959 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
5960 (gvop = ((UNOP*)gvop)->op_first) &&
5961 gvop->op_type == OP_GV)
5963 GV *gv = cGVOPx_gv(gvop);
5964 OP *sibling = o2->op_sibling;
5965 SV *n = newSVpvn("",0);
5967 gv_fullname3(n, gv, "");
5968 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
5969 sv_chop(n, SvPVX(n)+6);
5970 o2 = newSVOP(OP_CONST, 0, n);
5971 prev->op_sibling = o2;
5972 o2->op_sibling = sibling;
5988 if (contextclass++ == 0) {
5989 e = strchr(proto, ']');
5990 if (!e || e == proto)
6003 while (*--p != '[');
6004 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6005 gv_ename(namegv), o2);
6011 if (o2->op_type == OP_RV2GV)
6014 bad_type(arg, "symbol", gv_ename(namegv), o2);
6017 if (o2->op_type == OP_ENTERSUB)
6020 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6023 if (o2->op_type == OP_RV2SV ||
6024 o2->op_type == OP_PADSV ||
6025 o2->op_type == OP_HELEM ||
6026 o2->op_type == OP_AELEM ||
6027 o2->op_type == OP_THREADSV)
6030 bad_type(arg, "scalar", gv_ename(namegv), o2);
6033 if (o2->op_type == OP_RV2AV ||
6034 o2->op_type == OP_PADAV)
6037 bad_type(arg, "array", gv_ename(namegv), o2);
6040 if (o2->op_type == OP_RV2HV ||
6041 o2->op_type == OP_PADHV)
6044 bad_type(arg, "hash", gv_ename(namegv), o2);
6049 OP* sib = kid->op_sibling;
6050 kid->op_sibling = 0;
6051 o2 = newUNOP(OP_REFGEN, 0, kid);
6052 o2->op_sibling = sib;
6053 prev->op_sibling = o2;
6055 if (contextclass && e) {
6070 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6071 gv_ename(namegv), cv);
6076 mod(o2, OP_ENTERSUB);
6078 o2 = o2->op_sibling;
6080 if (proto && !optional &&
6081 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6082 return too_few_arguments(o, gv_ename(namegv));
6085 o=newSVOP(OP_CONST, 0, newSViv(0));
6091 Perl_ck_svconst(pTHX_ OP *o)
6093 SvREADONLY_on(cSVOPo->op_sv);
6098 Perl_ck_trunc(pTHX_ OP *o)
6100 if (o->op_flags & OPf_KIDS) {
6101 SVOP *kid = (SVOP*)cUNOPo->op_first;
6103 if (kid->op_type == OP_NULL)
6104 kid = (SVOP*)kid->op_sibling;
6105 if (kid && kid->op_type == OP_CONST &&
6106 (kid->op_private & OPpCONST_BARE))
6108 o->op_flags |= OPf_SPECIAL;
6109 kid->op_private &= ~OPpCONST_STRICT;
6116 Perl_ck_substr(pTHX_ OP *o)
6119 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6120 OP *kid = cLISTOPo->op_first;
6122 if (kid->op_type == OP_NULL)
6123 kid = kid->op_sibling;
6125 kid->op_flags |= OPf_MOD;
6131 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6134 Perl_peep(pTHX_ register OP *o)
6136 register OP* oldop = 0;
6138 if (!o || o->op_seq)
6142 SAVEVPTR(PL_curcop);
6143 for (; o; o = o->op_next) {
6146 /* The special value -1 is used by the B::C compiler backend to indicate
6147 * that an op is statically defined and should not be freed */
6148 if (!PL_op_seqmax || PL_op_seqmax == (U16)-1)
6151 switch (o->op_type) {
6155 PL_curcop = ((COP*)o); /* for warnings */
6156 o->op_seq = PL_op_seqmax++;
6160 if (cSVOPo->op_private & OPpCONST_STRICT)
6161 no_bareword_allowed(o);
6163 case OP_METHOD_NAMED:
6164 /* Relocate sv to the pad for thread safety.
6165 * Despite being a "constant", the SV is written to,
6166 * for reference counts, sv_upgrade() etc. */
6168 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6169 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6170 /* If op_sv is already a PADTMP then it is being used by
6171 * some pad, so make a copy. */
6172 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6173 SvREADONLY_on(PAD_SVl(ix));
6174 SvREFCNT_dec(cSVOPo->op_sv);
6177 SvREFCNT_dec(PAD_SVl(ix));
6178 SvPADTMP_on(cSVOPo->op_sv);
6179 PAD_SETSV(ix, cSVOPo->op_sv);
6180 /* XXX I don't know how this isn't readonly already. */
6181 SvREADONLY_on(PAD_SVl(ix));
6183 cSVOPo->op_sv = Nullsv;
6187 o->op_seq = PL_op_seqmax++;
6191 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6192 if (o->op_next->op_private & OPpTARGET_MY) {
6193 if (o->op_flags & OPf_STACKED) /* chained concats */
6194 goto ignore_optimization;
6196 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6197 o->op_targ = o->op_next->op_targ;
6198 o->op_next->op_targ = 0;
6199 o->op_private |= OPpTARGET_MY;
6202 op_null(o->op_next);
6204 ignore_optimization:
6205 o->op_seq = PL_op_seqmax++;
6208 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6209 o->op_seq = PL_op_seqmax++;
6210 break; /* Scalar stub must produce undef. List stub is noop */
6214 if (o->op_targ == OP_NEXTSTATE
6215 || o->op_targ == OP_DBSTATE
6216 || o->op_targ == OP_SETSTATE)
6218 PL_curcop = ((COP*)o);
6220 /* XXX: We avoid setting op_seq here to prevent later calls
6221 to peep() from mistakenly concluding that optimisation
6222 has already occurred. This doesn't fix the real problem,
6223 though (See 20010220.007). AMS 20010719 */
6224 if (oldop && o->op_next) {
6225 oldop->op_next = o->op_next;
6233 if (oldop && o->op_next) {
6234 oldop->op_next = o->op_next;
6237 o->op_seq = PL_op_seqmax++;
6241 if (o->op_next->op_type == OP_RV2SV) {
6242 if (!(o->op_next->op_private & OPpDEREF)) {
6243 op_null(o->op_next);
6244 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6246 o->op_next = o->op_next->op_next;
6247 o->op_type = OP_GVSV;
6248 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6251 else if (o->op_next->op_type == OP_RV2AV) {
6252 OP* pop = o->op_next->op_next;
6254 if (pop && pop->op_type == OP_CONST &&
6255 (PL_op = pop->op_next) &&
6256 pop->op_next->op_type == OP_AELEM &&
6257 !(pop->op_next->op_private &
6258 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6259 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6264 op_null(o->op_next);
6265 op_null(pop->op_next);
6267 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6268 o->op_next = pop->op_next->op_next;
6269 o->op_type = OP_AELEMFAST;
6270 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6271 o->op_private = (U8)i;
6276 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6278 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6279 /* XXX could check prototype here instead of just carping */
6280 SV *sv = sv_newmortal();
6281 gv_efullname3(sv, gv, Nullch);
6282 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6283 "%"SVf"() called too early to check prototype",
6287 else if (o->op_next->op_type == OP_READLINE
6288 && o->op_next->op_next->op_type == OP_CONCAT
6289 && (o->op_next->op_next->op_flags & OPf_STACKED))
6291 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6292 o->op_type = OP_RCATLINE;
6293 o->op_flags |= OPf_STACKED;
6294 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6295 op_null(o->op_next->op_next);
6296 op_null(o->op_next);
6299 o->op_seq = PL_op_seqmax++;
6312 o->op_seq = PL_op_seqmax++;
6313 while (cLOGOP->op_other->op_type == OP_NULL)
6314 cLOGOP->op_other = cLOGOP->op_other->op_next;
6315 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6320 o->op_seq = PL_op_seqmax++;
6321 while (cLOOP->op_redoop->op_type == OP_NULL)
6322 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6323 peep(cLOOP->op_redoop);
6324 while (cLOOP->op_nextop->op_type == OP_NULL)
6325 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6326 peep(cLOOP->op_nextop);
6327 while (cLOOP->op_lastop->op_type == OP_NULL)
6328 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6329 peep(cLOOP->op_lastop);
6335 o->op_seq = PL_op_seqmax++;
6336 while (cPMOP->op_pmreplstart &&
6337 cPMOP->op_pmreplstart->op_type == OP_NULL)
6338 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6339 peep(cPMOP->op_pmreplstart);
6343 o->op_seq = PL_op_seqmax++;
6344 if (ckWARN(WARN_SYNTAX) && o->op_next
6345 && o->op_next->op_type == OP_NEXTSTATE) {
6346 if (o->op_next->op_sibling &&
6347 o->op_next->op_sibling->op_type != OP_EXIT &&
6348 o->op_next->op_sibling->op_type != OP_WARN &&
6349 o->op_next->op_sibling->op_type != OP_DIE) {
6350 line_t oldline = CopLINE(PL_curcop);
6352 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6353 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6354 "Statement unlikely to be reached");
6355 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6356 "\t(Maybe you meant system() when you said exec()?)\n");
6357 CopLINE_set(PL_curcop, oldline);
6368 o->op_seq = PL_op_seqmax++;
6370 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6373 /* Make the CONST have a shared SV */
6374 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6375 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6376 key = SvPV(sv, keylen);
6377 lexname = newSVpvn_share(key,
6378 SvUTF8(sv) ? -(I32)keylen : keylen,
6387 o->op_seq = PL_op_seqmax++;
6397 char* Perl_custom_op_name(pTHX_ OP* o)
6399 IV index = PTR2IV(o->op_ppaddr);
6403 if (!PL_custom_op_names) /* This probably shouldn't happen */
6404 return PL_op_name[OP_CUSTOM];
6406 keysv = sv_2mortal(newSViv(index));
6408 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
6410 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
6412 return SvPV_nolen(HeVAL(he));
6415 char* Perl_custom_op_desc(pTHX_ OP* o)
6417 IV index = PTR2IV(o->op_ppaddr);
6421 if (!PL_custom_op_descs)
6422 return PL_op_desc[OP_CUSTOM];
6424 keysv = sv_2mortal(newSViv(index));
6426 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
6428 return PL_op_desc[OP_CUSTOM];
6430 return SvPV_nolen(HeVAL(he));
6436 /* Efficient sub that returns a constant scalar value. */
6438 const_sv_xsub(pTHX_ CV* cv)
6443 Perl_croak(aTHX_ "usage: %s::%s()",
6444 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
6448 ST(0) = (SV*)XSANY.any_ptr;