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 OP * left = cBINOPo->op_first;
4623 OP * right = left->op_sibling;
4624 if ((OP_IS_NUMCOMPARE(left->op_type) &&
4625 (left->op_flags & OPf_PARENS) == 0) ||
4626 (OP_IS_NUMCOMPARE(right->op_type) &&
4627 (right->op_flags & OPf_PARENS) == 0))
4628 if (ckWARN(WARN_PRECEDENCE))
4629 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4630 "Possible precedence problem on bitwise %c operator",
4631 o->op_type == OP_BIT_OR ? '|'
4632 : o->op_type == OP_BIT_AND ? '&' : '^'
4639 Perl_ck_concat(pTHX_ OP *o)
4641 if (cUNOPo->op_first->op_type == OP_CONCAT)
4642 o->op_flags |= OPf_STACKED;
4647 Perl_ck_spair(pTHX_ OP *o)
4649 if (o->op_flags & OPf_KIDS) {
4652 OPCODE type = o->op_type;
4653 o = modkids(ck_fun(o), type);
4654 kid = cUNOPo->op_first;
4655 newop = kUNOP->op_first->op_sibling;
4657 (newop->op_sibling ||
4658 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
4659 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
4660 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
4664 op_free(kUNOP->op_first);
4665 kUNOP->op_first = newop;
4667 o->op_ppaddr = PL_ppaddr[++o->op_type];
4672 Perl_ck_delete(pTHX_ OP *o)
4676 if (o->op_flags & OPf_KIDS) {
4677 OP *kid = cUNOPo->op_first;
4678 switch (kid->op_type) {
4680 o->op_flags |= OPf_SPECIAL;
4683 o->op_private |= OPpSLICE;
4686 o->op_flags |= OPf_SPECIAL;
4691 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
4700 Perl_ck_die(pTHX_ OP *o)
4703 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4709 Perl_ck_eof(pTHX_ OP *o)
4711 I32 type = o->op_type;
4713 if (o->op_flags & OPf_KIDS) {
4714 if (cLISTOPo->op_first->op_type == OP_STUB) {
4716 o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
4724 Perl_ck_eval(pTHX_ OP *o)
4726 PL_hints |= HINT_BLOCK_SCOPE;
4727 if (o->op_flags & OPf_KIDS) {
4728 SVOP *kid = (SVOP*)cUNOPo->op_first;
4731 o->op_flags &= ~OPf_KIDS;
4734 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
4737 cUNOPo->op_first = 0;
4740 NewOp(1101, enter, 1, LOGOP);
4741 enter->op_type = OP_ENTERTRY;
4742 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
4743 enter->op_private = 0;
4745 /* establish postfix order */
4746 enter->op_next = (OP*)enter;
4748 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
4749 o->op_type = OP_LEAVETRY;
4750 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
4751 enter->op_other = o;
4759 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
4761 o->op_targ = (PADOFFSET)PL_hints;
4766 Perl_ck_exit(pTHX_ OP *o)
4769 HV *table = GvHV(PL_hintgv);
4771 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
4772 if (svp && *svp && SvTRUE(*svp))
4773 o->op_private |= OPpEXIT_VMSISH;
4775 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4781 Perl_ck_exec(pTHX_ OP *o)
4784 if (o->op_flags & OPf_STACKED) {
4786 kid = cUNOPo->op_first->op_sibling;
4787 if (kid->op_type == OP_RV2GV)
4796 Perl_ck_exists(pTHX_ OP *o)
4799 if (o->op_flags & OPf_KIDS) {
4800 OP *kid = cUNOPo->op_first;
4801 if (kid->op_type == OP_ENTERSUB) {
4802 (void) ref(kid, o->op_type);
4803 if (kid->op_type != OP_RV2CV && !PL_error_count)
4804 Perl_croak(aTHX_ "%s argument is not a subroutine name",
4806 o->op_private |= OPpEXISTS_SUB;
4808 else if (kid->op_type == OP_AELEM)
4809 o->op_flags |= OPf_SPECIAL;
4810 else if (kid->op_type != OP_HELEM)
4811 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
4820 Perl_ck_gvconst(pTHX_ register OP *o)
4822 o = fold_constants(o);
4823 if (o->op_type == OP_CONST)
4830 Perl_ck_rvconst(pTHX_ register OP *o)
4832 SVOP *kid = (SVOP*)cUNOPo->op_first;
4834 o->op_private |= (PL_hints & HINT_STRICT_REFS);
4835 if (kid->op_type == OP_CONST) {
4839 SV *kidsv = kid->op_sv;
4842 /* Is it a constant from cv_const_sv()? */
4843 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
4844 SV *rsv = SvRV(kidsv);
4845 int svtype = SvTYPE(rsv);
4846 char *badtype = Nullch;
4848 switch (o->op_type) {
4850 if (svtype > SVt_PVMG)
4851 badtype = "a SCALAR";
4854 if (svtype != SVt_PVAV)
4855 badtype = "an ARRAY";
4858 if (svtype != SVt_PVHV)
4862 if (svtype != SVt_PVCV)
4867 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
4870 name = SvPV(kidsv, n_a);
4871 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
4872 char *badthing = Nullch;
4873 switch (o->op_type) {
4875 badthing = "a SCALAR";
4878 badthing = "an ARRAY";
4881 badthing = "a HASH";
4886 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
4890 * This is a little tricky. We only want to add the symbol if we
4891 * didn't add it in the lexer. Otherwise we get duplicate strict
4892 * warnings. But if we didn't add it in the lexer, we must at
4893 * least pretend like we wanted to add it even if it existed before,
4894 * or we get possible typo warnings. OPpCONST_ENTERED says
4895 * whether the lexer already added THIS instance of this symbol.
4897 iscv = (o->op_type == OP_RV2CV) * 2;
4899 gv = gv_fetchpv(name,
4900 iscv | !(kid->op_private & OPpCONST_ENTERED),
4903 : o->op_type == OP_RV2SV
4905 : o->op_type == OP_RV2AV
4907 : o->op_type == OP_RV2HV
4910 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
4912 kid->op_type = OP_GV;
4913 SvREFCNT_dec(kid->op_sv);
4915 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
4916 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
4917 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
4919 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
4921 kid->op_sv = SvREFCNT_inc(gv);
4923 kid->op_private = 0;
4924 kid->op_ppaddr = PL_ppaddr[OP_GV];
4931 Perl_ck_ftst(pTHX_ OP *o)
4933 I32 type = o->op_type;
4935 if (o->op_flags & OPf_REF) {
4938 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
4939 SVOP *kid = (SVOP*)cUNOPo->op_first;
4941 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
4943 OP *newop = newGVOP(type, OPf_REF,
4944 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
4949 if ((PL_hints & HINT_FILETEST_ACCESS) &&
4950 OP_IS_FILETEST_ACCESS(o))
4951 o->op_private |= OPpFT_ACCESS;
4956 if (type == OP_FTTTY)
4957 o = newGVOP(type, OPf_REF, PL_stdingv);
4959 o = newUNOP(type, 0, newDEFSVOP());
4965 Perl_ck_fun(pTHX_ OP *o)
4971 int type = o->op_type;
4972 register I32 oa = PL_opargs[type] >> OASHIFT;
4974 if (o->op_flags & OPf_STACKED) {
4975 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
4978 return no_fh_allowed(o);
4981 if (o->op_flags & OPf_KIDS) {
4983 tokid = &cLISTOPo->op_first;
4984 kid = cLISTOPo->op_first;
4985 if (kid->op_type == OP_PUSHMARK ||
4986 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
4988 tokid = &kid->op_sibling;
4989 kid = kid->op_sibling;
4991 if (!kid && PL_opargs[type] & OA_DEFGV)
4992 *tokid = kid = newDEFSVOP();
4996 sibl = kid->op_sibling;
4999 /* list seen where single (scalar) arg expected? */
5000 if (numargs == 1 && !(oa >> 4)
5001 && kid->op_type == OP_LIST && type != OP_SCALAR)
5003 return too_many_arguments(o,PL_op_desc[type]);
5016 if ((type == OP_PUSH || type == OP_UNSHIFT)
5017 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5018 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5019 "Useless use of %s with no values",
5022 if (kid->op_type == OP_CONST &&
5023 (kid->op_private & OPpCONST_BARE))
5025 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5026 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5027 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5028 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5029 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5030 "Array @%s missing the @ in argument %"IVdf" of %s()",
5031 name, (IV)numargs, PL_op_desc[type]);
5034 kid->op_sibling = sibl;
5037 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5038 bad_type(numargs, "array", PL_op_desc[type], kid);
5042 if (kid->op_type == OP_CONST &&
5043 (kid->op_private & OPpCONST_BARE))
5045 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5046 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5047 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5048 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5049 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5050 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5051 name, (IV)numargs, PL_op_desc[type]);
5054 kid->op_sibling = sibl;
5057 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5058 bad_type(numargs, "hash", PL_op_desc[type], kid);
5063 OP *newop = newUNOP(OP_NULL, 0, kid);
5064 kid->op_sibling = 0;
5066 newop->op_next = newop;
5068 kid->op_sibling = sibl;
5073 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5074 if (kid->op_type == OP_CONST &&
5075 (kid->op_private & OPpCONST_BARE))
5077 OP *newop = newGVOP(OP_GV, 0,
5078 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5080 if (!(o->op_private & 1) && /* if not unop */
5081 kid == cLISTOPo->op_last)
5082 cLISTOPo->op_last = newop;
5086 else if (kid->op_type == OP_READLINE) {
5087 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5088 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5091 I32 flags = OPf_SPECIAL;
5095 /* is this op a FH constructor? */
5096 if (is_handle_constructor(o,numargs)) {
5097 char *name = Nullch;
5101 /* Set a flag to tell rv2gv to vivify
5102 * need to "prove" flag does not mean something
5103 * else already - NI-S 1999/05/07
5106 if (kid->op_type == OP_PADSV) {
5107 /*XXX DAPM 2002.08.25 tmp assert test */
5108 /*XXX*/ assert(av_fetch(PL_comppad_name, (kid->op_targ), FALSE));
5109 /*XXX*/ assert(*av_fetch(PL_comppad_name, (kid->op_targ), FALSE));
5111 name = PAD_COMPNAME_PV(kid->op_targ);
5112 /* SvCUR of a pad namesv can't be trusted
5113 * (see PL_generation), so calc its length
5119 else if (kid->op_type == OP_RV2SV
5120 && kUNOP->op_first->op_type == OP_GV)
5122 GV *gv = cGVOPx_gv(kUNOP->op_first);
5124 len = GvNAMELEN(gv);
5126 else if (kid->op_type == OP_AELEM
5127 || kid->op_type == OP_HELEM)
5132 if ((op = ((BINOP*)kid)->op_first)) {
5133 SV *tmpstr = Nullsv;
5135 kid->op_type == OP_AELEM ?
5137 if (((op->op_type == OP_RV2AV) ||
5138 (op->op_type == OP_RV2HV)) &&
5139 (op = ((UNOP*)op)->op_first) &&
5140 (op->op_type == OP_GV)) {
5141 /* packagevar $a[] or $h{} */
5142 GV *gv = cGVOPx_gv(op);
5150 else if (op->op_type == OP_PADAV
5151 || op->op_type == OP_PADHV) {
5152 /* lexicalvar $a[] or $h{} */
5154 PAD_COMPNAME_PV(op->op_targ);
5164 name = savepv(SvPVX(tmpstr));
5170 name = "__ANONIO__";
5177 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5178 namesv = PAD_SVl(targ);
5179 (void)SvUPGRADE(namesv, SVt_PV);
5181 sv_setpvn(namesv, "$", 1);
5182 sv_catpvn(namesv, name, len);
5185 kid->op_sibling = 0;
5186 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5187 kid->op_targ = targ;
5188 kid->op_private |= priv;
5190 kid->op_sibling = sibl;
5196 mod(scalar(kid), type);
5200 tokid = &kid->op_sibling;
5201 kid = kid->op_sibling;
5203 o->op_private |= numargs;
5205 return too_many_arguments(o,OP_DESC(o));
5208 else if (PL_opargs[type] & OA_DEFGV) {
5210 return newUNOP(type, 0, newDEFSVOP());
5214 while (oa & OA_OPTIONAL)
5216 if (oa && oa != OA_LIST)
5217 return too_few_arguments(o,OP_DESC(o));
5223 Perl_ck_glob(pTHX_ OP *o)
5228 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5229 append_elem(OP_GLOB, o, newDEFSVOP());
5231 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5232 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5234 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5237 #if !defined(PERL_EXTERNAL_GLOB)
5238 /* XXX this can be tightened up and made more failsafe. */
5242 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5243 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5244 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5245 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5246 GvCV(gv) = GvCV(glob_gv);
5247 SvREFCNT_inc((SV*)GvCV(gv));
5248 GvIMPORTED_CV_on(gv);
5251 #endif /* PERL_EXTERNAL_GLOB */
5253 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5254 append_elem(OP_GLOB, o,
5255 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5256 o->op_type = OP_LIST;
5257 o->op_ppaddr = PL_ppaddr[OP_LIST];
5258 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5259 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5260 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5261 append_elem(OP_LIST, o,
5262 scalar(newUNOP(OP_RV2CV, 0,
5263 newGVOP(OP_GV, 0, gv)))));
5264 o = newUNOP(OP_NULL, 0, ck_subr(o));
5265 o->op_targ = OP_GLOB; /* hint at what it used to be */
5268 gv = newGVgen("main");
5270 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5276 Perl_ck_grep(pTHX_ OP *o)
5280 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5282 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5283 NewOp(1101, gwop, 1, LOGOP);
5285 if (o->op_flags & OPf_STACKED) {
5288 kid = cLISTOPo->op_first->op_sibling;
5289 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5292 kid->op_next = (OP*)gwop;
5293 o->op_flags &= ~OPf_STACKED;
5295 kid = cLISTOPo->op_first->op_sibling;
5296 if (type == OP_MAPWHILE)
5303 kid = cLISTOPo->op_first->op_sibling;
5304 if (kid->op_type != OP_NULL)
5305 Perl_croak(aTHX_ "panic: ck_grep");
5306 kid = kUNOP->op_first;
5308 gwop->op_type = type;
5309 gwop->op_ppaddr = PL_ppaddr[type];
5310 gwop->op_first = listkids(o);
5311 gwop->op_flags |= OPf_KIDS;
5312 gwop->op_private = 1;
5313 gwop->op_other = LINKLIST(kid);
5314 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5315 kid->op_next = (OP*)gwop;
5317 kid = cLISTOPo->op_first->op_sibling;
5318 if (!kid || !kid->op_sibling)
5319 return too_few_arguments(o,OP_DESC(o));
5320 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5321 mod(kid, OP_GREPSTART);
5327 Perl_ck_index(pTHX_ OP *o)
5329 if (o->op_flags & OPf_KIDS) {
5330 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5332 kid = kid->op_sibling; /* get past "big" */
5333 if (kid && kid->op_type == OP_CONST)
5334 fbm_compile(((SVOP*)kid)->op_sv, 0);
5340 Perl_ck_lengthconst(pTHX_ OP *o)
5342 /* XXX length optimization goes here */
5347 Perl_ck_lfun(pTHX_ OP *o)
5349 OPCODE type = o->op_type;
5350 return modkids(ck_fun(o), type);
5354 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5356 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5357 switch (cUNOPo->op_first->op_type) {
5359 /* This is needed for
5360 if (defined %stash::)
5361 to work. Do not break Tk.
5363 break; /* Globals via GV can be undef */
5365 case OP_AASSIGN: /* Is this a good idea? */
5366 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5367 "defined(@array) is deprecated");
5368 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5369 "\t(Maybe you should just omit the defined()?)\n");
5372 /* This is needed for
5373 if (defined %stash::)
5374 to work. Do not break Tk.
5376 break; /* Globals via GV can be undef */
5378 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5379 "defined(%%hash) is deprecated");
5380 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5381 "\t(Maybe you should just omit the defined()?)\n");
5392 Perl_ck_rfun(pTHX_ OP *o)
5394 OPCODE type = o->op_type;
5395 return refkids(ck_fun(o), type);
5399 Perl_ck_listiob(pTHX_ OP *o)
5403 kid = cLISTOPo->op_first;
5406 kid = cLISTOPo->op_first;
5408 if (kid->op_type == OP_PUSHMARK)
5409 kid = kid->op_sibling;
5410 if (kid && o->op_flags & OPf_STACKED)
5411 kid = kid->op_sibling;
5412 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5413 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5414 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5415 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5416 cLISTOPo->op_first->op_sibling = kid;
5417 cLISTOPo->op_last = kid;
5418 kid = kid->op_sibling;
5423 append_elem(o->op_type, o, newDEFSVOP());
5429 Perl_ck_sassign(pTHX_ OP *o)
5431 OP *kid = cLISTOPo->op_first;
5432 /* has a disposable target? */
5433 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5434 && !(kid->op_flags & OPf_STACKED)
5435 /* Cannot steal the second time! */
5436 && !(kid->op_private & OPpTARGET_MY))
5438 OP *kkid = kid->op_sibling;
5440 /* Can just relocate the target. */
5441 if (kkid && kkid->op_type == OP_PADSV
5442 && !(kkid->op_private & OPpLVAL_INTRO))
5444 kid->op_targ = kkid->op_targ;
5446 /* Now we do not need PADSV and SASSIGN. */
5447 kid->op_sibling = o->op_sibling; /* NULL */
5448 cLISTOPo->op_first = NULL;
5451 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
5459 Perl_ck_match(pTHX_ OP *o)
5461 o->op_private |= OPpRUNTIME;
5466 Perl_ck_method(pTHX_ OP *o)
5468 OP *kid = cUNOPo->op_first;
5469 if (kid->op_type == OP_CONST) {
5470 SV* sv = kSVOP->op_sv;
5471 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
5473 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5474 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
5477 kSVOP->op_sv = Nullsv;
5479 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5488 Perl_ck_null(pTHX_ OP *o)
5494 Perl_ck_open(pTHX_ OP *o)
5496 HV *table = GvHV(PL_hintgv);
5500 svp = hv_fetch(table, "open_IN", 7, FALSE);
5502 mode = mode_from_discipline(*svp);
5503 if (mode & O_BINARY)
5504 o->op_private |= OPpOPEN_IN_RAW;
5505 else if (mode & O_TEXT)
5506 o->op_private |= OPpOPEN_IN_CRLF;
5509 svp = hv_fetch(table, "open_OUT", 8, FALSE);
5511 mode = mode_from_discipline(*svp);
5512 if (mode & O_BINARY)
5513 o->op_private |= OPpOPEN_OUT_RAW;
5514 else if (mode & O_TEXT)
5515 o->op_private |= OPpOPEN_OUT_CRLF;
5518 if (o->op_type == OP_BACKTICK)
5521 /* In case of three-arg dup open remove strictness
5522 * from the last arg if it is a bareword. */
5523 OP *first = cLISTOPx(o)->op_first; /* The pushmark. */
5524 OP *last = cLISTOPx(o)->op_last; /* The bareword. */
5528 if ((last->op_type == OP_CONST) && /* The bareword. */
5529 (last->op_private & OPpCONST_BARE) &&
5530 (last->op_private & OPpCONST_STRICT) &&
5531 (oa = first->op_sibling) && /* The fh. */
5532 (oa = oa->op_sibling) && /* The mode. */
5533 SvPOK(((SVOP*)oa)->op_sv) &&
5534 (mode = SvPVX(((SVOP*)oa)->op_sv)) &&
5535 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
5536 (last == oa->op_sibling)) /* The bareword. */
5537 last->op_private &= ~OPpCONST_STRICT;
5543 Perl_ck_repeat(pTHX_ OP *o)
5545 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5546 o->op_private |= OPpREPEAT_DOLIST;
5547 cBINOPo->op_first = force_list(cBINOPo->op_first);
5555 Perl_ck_require(pTHX_ OP *o)
5559 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
5560 SVOP *kid = (SVOP*)cUNOPo->op_first;
5562 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5564 for (s = SvPVX(kid->op_sv); *s; s++) {
5565 if (*s == ':' && s[1] == ':') {
5567 Move(s+2, s+1, strlen(s+2)+1, char);
5568 --SvCUR(kid->op_sv);
5571 if (SvREADONLY(kid->op_sv)) {
5572 SvREADONLY_off(kid->op_sv);
5573 sv_catpvn(kid->op_sv, ".pm", 3);
5574 SvREADONLY_on(kid->op_sv);
5577 sv_catpvn(kid->op_sv, ".pm", 3);
5581 /* handle override, if any */
5582 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
5583 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
5584 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
5586 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5587 OP *kid = cUNOPo->op_first;
5588 cUNOPo->op_first = 0;
5590 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5591 append_elem(OP_LIST, kid,
5592 scalar(newUNOP(OP_RV2CV, 0,
5601 Perl_ck_return(pTHX_ OP *o)
5604 if (CvLVALUE(PL_compcv)) {
5605 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5606 mod(kid, OP_LEAVESUBLV);
5613 Perl_ck_retarget(pTHX_ OP *o)
5615 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5622 Perl_ck_select(pTHX_ OP *o)
5625 if (o->op_flags & OPf_KIDS) {
5626 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5627 if (kid && kid->op_sibling) {
5628 o->op_type = OP_SSELECT;
5629 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
5631 return fold_constants(o);
5635 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5636 if (kid && kid->op_type == OP_RV2GV)
5637 kid->op_private &= ~HINT_STRICT_REFS;
5642 Perl_ck_shift(pTHX_ OP *o)
5644 I32 type = o->op_type;
5646 if (!(o->op_flags & OPf_KIDS)) {
5650 argop = newUNOP(OP_RV2AV, 0,
5651 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
5652 return newUNOP(type, 0, scalar(argop));
5654 return scalar(modkids(ck_fun(o), type));
5658 Perl_ck_sort(pTHX_ OP *o)
5662 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
5664 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5665 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
5667 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
5669 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
5671 if (kid->op_type == OP_SCOPE) {
5675 else if (kid->op_type == OP_LEAVE) {
5676 if (o->op_type == OP_SORT) {
5677 op_null(kid); /* wipe out leave */
5680 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
5681 if (k->op_next == kid)
5683 /* don't descend into loops */
5684 else if (k->op_type == OP_ENTERLOOP
5685 || k->op_type == OP_ENTERITER)
5687 k = cLOOPx(k)->op_lastop;
5692 kid->op_next = 0; /* just disconnect the leave */
5693 k = kLISTOP->op_first;
5698 if (o->op_type == OP_SORT) {
5699 /* provide scalar context for comparison function/block */
5705 o->op_flags |= OPf_SPECIAL;
5707 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
5710 firstkid = firstkid->op_sibling;
5713 /* provide list context for arguments */
5714 if (o->op_type == OP_SORT)
5721 S_simplify_sort(pTHX_ OP *o)
5723 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5727 if (!(o->op_flags & OPf_STACKED))
5729 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
5730 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
5731 kid = kUNOP->op_first; /* get past null */
5732 if (kid->op_type != OP_SCOPE)
5734 kid = kLISTOP->op_last; /* get past scope */
5735 switch(kid->op_type) {
5743 k = kid; /* remember this node*/
5744 if (kBINOP->op_first->op_type != OP_RV2SV)
5746 kid = kBINOP->op_first; /* get past cmp */
5747 if (kUNOP->op_first->op_type != OP_GV)
5749 kid = kUNOP->op_first; /* get past rv2sv */
5751 if (GvSTASH(gv) != PL_curstash)
5753 if (strEQ(GvNAME(gv), "a"))
5755 else if (strEQ(GvNAME(gv), "b"))
5759 kid = k; /* back to cmp */
5760 if (kBINOP->op_last->op_type != OP_RV2SV)
5762 kid = kBINOP->op_last; /* down to 2nd arg */
5763 if (kUNOP->op_first->op_type != OP_GV)
5765 kid = kUNOP->op_first; /* get past rv2sv */
5767 if (GvSTASH(gv) != PL_curstash
5769 ? strNE(GvNAME(gv), "a")
5770 : strNE(GvNAME(gv), "b")))
5772 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
5774 o->op_private |= OPpSORT_REVERSE;
5775 if (k->op_type == OP_NCMP)
5776 o->op_private |= OPpSORT_NUMERIC;
5777 if (k->op_type == OP_I_NCMP)
5778 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
5779 kid = cLISTOPo->op_first->op_sibling;
5780 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
5781 op_free(kid); /* then delete it */
5785 Perl_ck_split(pTHX_ OP *o)
5789 if (o->op_flags & OPf_STACKED)
5790 return no_fh_allowed(o);
5792 kid = cLISTOPo->op_first;
5793 if (kid->op_type != OP_NULL)
5794 Perl_croak(aTHX_ "panic: ck_split");
5795 kid = kid->op_sibling;
5796 op_free(cLISTOPo->op_first);
5797 cLISTOPo->op_first = kid;
5799 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
5800 cLISTOPo->op_last = kid; /* There was only one element previously */
5803 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
5804 OP *sibl = kid->op_sibling;
5805 kid->op_sibling = 0;
5806 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
5807 if (cLISTOPo->op_first == cLISTOPo->op_last)
5808 cLISTOPo->op_last = kid;
5809 cLISTOPo->op_first = kid;
5810 kid->op_sibling = sibl;
5813 kid->op_type = OP_PUSHRE;
5814 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
5816 if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
5817 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
5818 "Use of /g modifier is meaningless in split");
5821 if (!kid->op_sibling)
5822 append_elem(OP_SPLIT, o, newDEFSVOP());
5824 kid = kid->op_sibling;
5827 if (!kid->op_sibling)
5828 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
5830 kid = kid->op_sibling;
5833 if (kid->op_sibling)
5834 return too_many_arguments(o,OP_DESC(o));
5840 Perl_ck_join(pTHX_ OP *o)
5842 if (ckWARN(WARN_SYNTAX)) {
5843 OP *kid = cLISTOPo->op_first->op_sibling;
5844 if (kid && kid->op_type == OP_MATCH) {
5845 char *pmstr = "STRING";
5846 if (PM_GETRE(kPMOP))
5847 pmstr = PM_GETRE(kPMOP)->precomp;
5848 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5849 "/%s/ should probably be written as \"%s\"",
5857 Perl_ck_subr(pTHX_ OP *o)
5859 OP *prev = ((cUNOPo->op_first->op_sibling)
5860 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
5861 OP *o2 = prev->op_sibling;
5868 I32 contextclass = 0;
5873 o->op_private |= OPpENTERSUB_HASTARG;
5874 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
5875 if (cvop->op_type == OP_RV2CV) {
5877 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
5878 op_null(cvop); /* disable rv2cv */
5879 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
5880 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
5881 GV *gv = cGVOPx_gv(tmpop);
5884 tmpop->op_private |= OPpEARLY_CV;
5887 namegv = CvANON(cv) ? gv : CvGV(cv);
5888 proto = SvPV((SV*)cv, n_a);
5890 if (CvASSERTION(cv)) {
5891 if (PL_hints & HINT_ASSERTING) {
5892 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
5893 o->op_private |= OPpENTERSUB_DB;
5897 if (ckWARN(WARN_ASSERTIONS) && !(PL_hints & HINT_ASSERTIONSSEEN)) {
5898 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
5899 "Impossible to activate assertion call");
5906 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
5907 if (o2->op_type == OP_CONST)
5908 o2->op_private &= ~OPpCONST_STRICT;
5909 else if (o2->op_type == OP_LIST) {
5910 OP *o = ((UNOP*)o2)->op_first->op_sibling;
5911 if (o && o->op_type == OP_CONST)
5912 o->op_private &= ~OPpCONST_STRICT;
5915 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5916 if (PERLDB_SUB && PL_curstash != PL_debstash)
5917 o->op_private |= OPpENTERSUB_DB;
5918 while (o2 != cvop) {
5922 return too_many_arguments(o, gv_ename(namegv));
5940 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
5942 arg == 1 ? "block or sub {}" : "sub {}",
5943 gv_ename(namegv), o2);
5946 /* '*' allows any scalar type, including bareword */
5949 if (o2->op_type == OP_RV2GV)
5950 goto wrapref; /* autoconvert GLOB -> GLOBref */
5951 else if (o2->op_type == OP_CONST)
5952 o2->op_private &= ~OPpCONST_STRICT;
5953 else if (o2->op_type == OP_ENTERSUB) {
5954 /* accidental subroutine, revert to bareword */
5955 OP *gvop = ((UNOP*)o2)->op_first;
5956 if (gvop && gvop->op_type == OP_NULL) {
5957 gvop = ((UNOP*)gvop)->op_first;
5959 for (; gvop->op_sibling; gvop = gvop->op_sibling)
5962 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
5963 (gvop = ((UNOP*)gvop)->op_first) &&
5964 gvop->op_type == OP_GV)
5966 GV *gv = cGVOPx_gv(gvop);
5967 OP *sibling = o2->op_sibling;
5968 SV *n = newSVpvn("",0);
5970 gv_fullname3(n, gv, "");
5971 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
5972 sv_chop(n, SvPVX(n)+6);
5973 o2 = newSVOP(OP_CONST, 0, n);
5974 prev->op_sibling = o2;
5975 o2->op_sibling = sibling;
5991 if (contextclass++ == 0) {
5992 e = strchr(proto, ']');
5993 if (!e || e == proto)
6006 while (*--p != '[');
6007 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6008 gv_ename(namegv), o2);
6014 if (o2->op_type == OP_RV2GV)
6017 bad_type(arg, "symbol", gv_ename(namegv), o2);
6020 if (o2->op_type == OP_ENTERSUB)
6023 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6026 if (o2->op_type == OP_RV2SV ||
6027 o2->op_type == OP_PADSV ||
6028 o2->op_type == OP_HELEM ||
6029 o2->op_type == OP_AELEM ||
6030 o2->op_type == OP_THREADSV)
6033 bad_type(arg, "scalar", gv_ename(namegv), o2);
6036 if (o2->op_type == OP_RV2AV ||
6037 o2->op_type == OP_PADAV)
6040 bad_type(arg, "array", gv_ename(namegv), o2);
6043 if (o2->op_type == OP_RV2HV ||
6044 o2->op_type == OP_PADHV)
6047 bad_type(arg, "hash", gv_ename(namegv), o2);
6052 OP* sib = kid->op_sibling;
6053 kid->op_sibling = 0;
6054 o2 = newUNOP(OP_REFGEN, 0, kid);
6055 o2->op_sibling = sib;
6056 prev->op_sibling = o2;
6058 if (contextclass && e) {
6073 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6074 gv_ename(namegv), cv);
6079 mod(o2, OP_ENTERSUB);
6081 o2 = o2->op_sibling;
6083 if (proto && !optional &&
6084 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6085 return too_few_arguments(o, gv_ename(namegv));
6088 o=newSVOP(OP_CONST, 0, newSViv(0));
6094 Perl_ck_svconst(pTHX_ OP *o)
6096 SvREADONLY_on(cSVOPo->op_sv);
6101 Perl_ck_trunc(pTHX_ OP *o)
6103 if (o->op_flags & OPf_KIDS) {
6104 SVOP *kid = (SVOP*)cUNOPo->op_first;
6106 if (kid->op_type == OP_NULL)
6107 kid = (SVOP*)kid->op_sibling;
6108 if (kid && kid->op_type == OP_CONST &&
6109 (kid->op_private & OPpCONST_BARE))
6111 o->op_flags |= OPf_SPECIAL;
6112 kid->op_private &= ~OPpCONST_STRICT;
6119 Perl_ck_substr(pTHX_ OP *o)
6122 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6123 OP *kid = cLISTOPo->op_first;
6125 if (kid->op_type == OP_NULL)
6126 kid = kid->op_sibling;
6128 kid->op_flags |= OPf_MOD;
6134 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6137 Perl_peep(pTHX_ register OP *o)
6139 register OP* oldop = 0;
6141 if (!o || o->op_seq)
6145 SAVEVPTR(PL_curcop);
6146 for (; o; o = o->op_next) {
6149 /* The special value -1 is used by the B::C compiler backend to indicate
6150 * that an op is statically defined and should not be freed */
6151 if (!PL_op_seqmax || PL_op_seqmax == (U16)-1)
6154 switch (o->op_type) {
6158 PL_curcop = ((COP*)o); /* for warnings */
6159 o->op_seq = PL_op_seqmax++;
6163 if (cSVOPo->op_private & OPpCONST_STRICT)
6164 no_bareword_allowed(o);
6166 case OP_METHOD_NAMED:
6167 /* Relocate sv to the pad for thread safety.
6168 * Despite being a "constant", the SV is written to,
6169 * for reference counts, sv_upgrade() etc. */
6171 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6172 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6173 /* If op_sv is already a PADTMP then it is being used by
6174 * some pad, so make a copy. */
6175 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6176 SvREADONLY_on(PAD_SVl(ix));
6177 SvREFCNT_dec(cSVOPo->op_sv);
6180 SvREFCNT_dec(PAD_SVl(ix));
6181 SvPADTMP_on(cSVOPo->op_sv);
6182 PAD_SETSV(ix, cSVOPo->op_sv);
6183 /* XXX I don't know how this isn't readonly already. */
6184 SvREADONLY_on(PAD_SVl(ix));
6186 cSVOPo->op_sv = Nullsv;
6190 o->op_seq = PL_op_seqmax++;
6194 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6195 if (o->op_next->op_private & OPpTARGET_MY) {
6196 if (o->op_flags & OPf_STACKED) /* chained concats */
6197 goto ignore_optimization;
6199 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6200 o->op_targ = o->op_next->op_targ;
6201 o->op_next->op_targ = 0;
6202 o->op_private |= OPpTARGET_MY;
6205 op_null(o->op_next);
6207 ignore_optimization:
6208 o->op_seq = PL_op_seqmax++;
6211 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6212 o->op_seq = PL_op_seqmax++;
6213 break; /* Scalar stub must produce undef. List stub is noop */
6217 if (o->op_targ == OP_NEXTSTATE
6218 || o->op_targ == OP_DBSTATE
6219 || o->op_targ == OP_SETSTATE)
6221 PL_curcop = ((COP*)o);
6223 /* XXX: We avoid setting op_seq here to prevent later calls
6224 to peep() from mistakenly concluding that optimisation
6225 has already occurred. This doesn't fix the real problem,
6226 though (See 20010220.007). AMS 20010719 */
6227 if (oldop && o->op_next) {
6228 oldop->op_next = o->op_next;
6236 if (oldop && o->op_next) {
6237 oldop->op_next = o->op_next;
6240 o->op_seq = PL_op_seqmax++;
6244 if (o->op_next->op_type == OP_RV2SV) {
6245 if (!(o->op_next->op_private & OPpDEREF)) {
6246 op_null(o->op_next);
6247 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6249 o->op_next = o->op_next->op_next;
6250 o->op_type = OP_GVSV;
6251 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6254 else if (o->op_next->op_type == OP_RV2AV) {
6255 OP* pop = o->op_next->op_next;
6257 if (pop && pop->op_type == OP_CONST &&
6258 (PL_op = pop->op_next) &&
6259 pop->op_next->op_type == OP_AELEM &&
6260 !(pop->op_next->op_private &
6261 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6262 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6267 op_null(o->op_next);
6268 op_null(pop->op_next);
6270 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6271 o->op_next = pop->op_next->op_next;
6272 o->op_type = OP_AELEMFAST;
6273 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6274 o->op_private = (U8)i;
6279 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6281 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6282 /* XXX could check prototype here instead of just carping */
6283 SV *sv = sv_newmortal();
6284 gv_efullname3(sv, gv, Nullch);
6285 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6286 "%"SVf"() called too early to check prototype",
6290 else if (o->op_next->op_type == OP_READLINE
6291 && o->op_next->op_next->op_type == OP_CONCAT
6292 && (o->op_next->op_next->op_flags & OPf_STACKED))
6294 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6295 o->op_type = OP_RCATLINE;
6296 o->op_flags |= OPf_STACKED;
6297 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6298 op_null(o->op_next->op_next);
6299 op_null(o->op_next);
6302 o->op_seq = PL_op_seqmax++;
6315 o->op_seq = PL_op_seqmax++;
6316 while (cLOGOP->op_other->op_type == OP_NULL)
6317 cLOGOP->op_other = cLOGOP->op_other->op_next;
6318 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6323 o->op_seq = PL_op_seqmax++;
6324 while (cLOOP->op_redoop->op_type == OP_NULL)
6325 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6326 peep(cLOOP->op_redoop);
6327 while (cLOOP->op_nextop->op_type == OP_NULL)
6328 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6329 peep(cLOOP->op_nextop);
6330 while (cLOOP->op_lastop->op_type == OP_NULL)
6331 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6332 peep(cLOOP->op_lastop);
6338 o->op_seq = PL_op_seqmax++;
6339 while (cPMOP->op_pmreplstart &&
6340 cPMOP->op_pmreplstart->op_type == OP_NULL)
6341 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6342 peep(cPMOP->op_pmreplstart);
6346 o->op_seq = PL_op_seqmax++;
6347 if (ckWARN(WARN_SYNTAX) && o->op_next
6348 && o->op_next->op_type == OP_NEXTSTATE) {
6349 if (o->op_next->op_sibling &&
6350 o->op_next->op_sibling->op_type != OP_EXIT &&
6351 o->op_next->op_sibling->op_type != OP_WARN &&
6352 o->op_next->op_sibling->op_type != OP_DIE) {
6353 line_t oldline = CopLINE(PL_curcop);
6355 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6356 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6357 "Statement unlikely to be reached");
6358 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6359 "\t(Maybe you meant system() when you said exec()?)\n");
6360 CopLINE_set(PL_curcop, oldline);
6371 o->op_seq = PL_op_seqmax++;
6373 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6376 /* Make the CONST have a shared SV */
6377 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6378 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6379 key = SvPV(sv, keylen);
6380 lexname = newSVpvn_share(key,
6381 SvUTF8(sv) ? -(I32)keylen : keylen,
6390 o->op_seq = PL_op_seqmax++;
6400 char* Perl_custom_op_name(pTHX_ OP* o)
6402 IV index = PTR2IV(o->op_ppaddr);
6406 if (!PL_custom_op_names) /* This probably shouldn't happen */
6407 return PL_op_name[OP_CUSTOM];
6409 keysv = sv_2mortal(newSViv(index));
6411 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
6413 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
6415 return SvPV_nolen(HeVAL(he));
6418 char* Perl_custom_op_desc(pTHX_ OP* o)
6420 IV index = PTR2IV(o->op_ppaddr);
6424 if (!PL_custom_op_descs)
6425 return PL_op_desc[OP_CUSTOM];
6427 keysv = sv_2mortal(newSViv(index));
6429 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
6431 return PL_op_desc[OP_CUSTOM];
6433 return SvPV_nolen(HeVAL(he));
6439 /* Efficient sub that returns a constant scalar value. */
6441 const_sv_xsub(pTHX_ CV* cv)
6446 Perl_croak(aTHX_ "usage: %s::%s()",
6447 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
6451 ST(0) = (SV*)XSANY.any_ptr;