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;
1842 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ", *s)))
1845 if (*s == ';' || *s == '=')
1846 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
1847 "Parentheses missing around \"%s\" list",
1848 lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
1854 o = mod(o, OP_NULL); /* a bit kludgey */
1856 PL_in_my_stash = Nullhv;
1861 Perl_jmaybe(pTHX_ OP *o)
1863 if (o->op_type == OP_LIST) {
1865 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
1866 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
1872 Perl_fold_constants(pTHX_ register OP *o)
1875 I32 type = o->op_type;
1878 if (PL_opargs[type] & OA_RETSCALAR)
1880 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
1881 o->op_targ = pad_alloc(type, SVs_PADTMP);
1883 /* integerize op, unless it happens to be C<-foo>.
1884 * XXX should pp_i_negate() do magic string negation instead? */
1885 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
1886 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
1887 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
1889 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
1892 if (!(PL_opargs[type] & OA_FOLDCONST))
1897 /* XXX might want a ck_negate() for this */
1898 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
1910 /* XXX what about the numeric ops? */
1911 if (PL_hints & HINT_LOCALE)
1916 goto nope; /* Don't try to run w/ errors */
1918 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
1919 if ((curop->op_type != OP_CONST ||
1920 (curop->op_private & OPpCONST_BARE)) &&
1921 curop->op_type != OP_LIST &&
1922 curop->op_type != OP_SCALAR &&
1923 curop->op_type != OP_NULL &&
1924 curop->op_type != OP_PUSHMARK)
1930 curop = LINKLIST(o);
1934 sv = *(PL_stack_sp--);
1935 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
1936 pad_swipe(o->op_targ, FALSE);
1937 else if (SvTEMP(sv)) { /* grab mortal temp? */
1938 (void)SvREFCNT_inc(sv);
1942 if (type == OP_RV2GV)
1943 return newGVOP(OP_GV, 0, (GV*)sv);
1944 return newSVOP(OP_CONST, 0, sv);
1951 Perl_gen_constant_list(pTHX_ register OP *o)
1954 I32 oldtmps_floor = PL_tmps_floor;
1958 return o; /* Don't attempt to run with errors */
1960 PL_op = curop = LINKLIST(o);
1967 PL_tmps_floor = oldtmps_floor;
1969 o->op_type = OP_RV2AV;
1970 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
1971 o->op_seq = 0; /* needs to be revisited in peep() */
1972 curop = ((UNOP*)o)->op_first;
1973 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
1980 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
1982 if (!o || o->op_type != OP_LIST)
1983 o = newLISTOP(OP_LIST, 0, o, Nullop);
1985 o->op_flags &= ~OPf_WANT;
1987 if (!(PL_opargs[type] & OA_MARK))
1988 op_null(cLISTOPo->op_first);
1990 o->op_type = (OPCODE)type;
1991 o->op_ppaddr = PL_ppaddr[type];
1992 o->op_flags |= flags;
1994 o = CHECKOP(type, o);
1995 if (o->op_type != type)
1998 return fold_constants(o);
2001 /* List constructors */
2004 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2012 if (first->op_type != type
2013 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2015 return newLISTOP(type, 0, first, last);
2018 if (first->op_flags & OPf_KIDS)
2019 ((LISTOP*)first)->op_last->op_sibling = last;
2021 first->op_flags |= OPf_KIDS;
2022 ((LISTOP*)first)->op_first = last;
2024 ((LISTOP*)first)->op_last = last;
2029 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2037 if (first->op_type != type)
2038 return prepend_elem(type, (OP*)first, (OP*)last);
2040 if (last->op_type != type)
2041 return append_elem(type, (OP*)first, (OP*)last);
2043 first->op_last->op_sibling = last->op_first;
2044 first->op_last = last->op_last;
2045 first->op_flags |= (last->op_flags & OPf_KIDS);
2053 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2061 if (last->op_type == type) {
2062 if (type == OP_LIST) { /* already a PUSHMARK there */
2063 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2064 ((LISTOP*)last)->op_first->op_sibling = first;
2065 if (!(first->op_flags & OPf_PARENS))
2066 last->op_flags &= ~OPf_PARENS;
2069 if (!(last->op_flags & OPf_KIDS)) {
2070 ((LISTOP*)last)->op_last = first;
2071 last->op_flags |= OPf_KIDS;
2073 first->op_sibling = ((LISTOP*)last)->op_first;
2074 ((LISTOP*)last)->op_first = first;
2076 last->op_flags |= OPf_KIDS;
2080 return newLISTOP(type, 0, first, last);
2086 Perl_newNULLLIST(pTHX)
2088 return newOP(OP_STUB, 0);
2092 Perl_force_list(pTHX_ OP *o)
2094 if (!o || o->op_type != OP_LIST)
2095 o = newLISTOP(OP_LIST, 0, o, Nullop);
2101 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2105 NewOp(1101, listop, 1, LISTOP);
2107 listop->op_type = (OPCODE)type;
2108 listop->op_ppaddr = PL_ppaddr[type];
2111 listop->op_flags = (U8)flags;
2115 else if (!first && last)
2118 first->op_sibling = last;
2119 listop->op_first = first;
2120 listop->op_last = last;
2121 if (type == OP_LIST) {
2123 pushop = newOP(OP_PUSHMARK, 0);
2124 pushop->op_sibling = first;
2125 listop->op_first = pushop;
2126 listop->op_flags |= OPf_KIDS;
2128 listop->op_last = pushop;
2135 Perl_newOP(pTHX_ I32 type, I32 flags)
2138 NewOp(1101, o, 1, OP);
2139 o->op_type = (OPCODE)type;
2140 o->op_ppaddr = PL_ppaddr[type];
2141 o->op_flags = (U8)flags;
2144 o->op_private = (U8)(0 | (flags >> 8));
2145 if (PL_opargs[type] & OA_RETSCALAR)
2147 if (PL_opargs[type] & OA_TARGET)
2148 o->op_targ = pad_alloc(type, SVs_PADTMP);
2149 return CHECKOP(type, o);
2153 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2158 first = newOP(OP_STUB, 0);
2159 if (PL_opargs[type] & OA_MARK)
2160 first = force_list(first);
2162 NewOp(1101, unop, 1, UNOP);
2163 unop->op_type = (OPCODE)type;
2164 unop->op_ppaddr = PL_ppaddr[type];
2165 unop->op_first = first;
2166 unop->op_flags = flags | OPf_KIDS;
2167 unop->op_private = (U8)(1 | (flags >> 8));
2168 unop = (UNOP*) CHECKOP(type, unop);
2172 return fold_constants((OP *) unop);
2176 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2179 NewOp(1101, binop, 1, BINOP);
2182 first = newOP(OP_NULL, 0);
2184 binop->op_type = (OPCODE)type;
2185 binop->op_ppaddr = PL_ppaddr[type];
2186 binop->op_first = first;
2187 binop->op_flags = flags | OPf_KIDS;
2190 binop->op_private = (U8)(1 | (flags >> 8));
2193 binop->op_private = (U8)(2 | (flags >> 8));
2194 first->op_sibling = last;
2197 binop = (BINOP*)CHECKOP(type, binop);
2198 if (binop->op_next || binop->op_type != (OPCODE)type)
2201 binop->op_last = binop->op_first->op_sibling;
2203 return fold_constants((OP *)binop);
2207 uvcompare(const void *a, const void *b)
2209 if (*((UV *)a) < (*(UV *)b))
2211 if (*((UV *)a) > (*(UV *)b))
2213 if (*((UV *)a+1) < (*(UV *)b+1))
2215 if (*((UV *)a+1) > (*(UV *)b+1))
2221 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2223 SV *tstr = ((SVOP*)expr)->op_sv;
2224 SV *rstr = ((SVOP*)repl)->op_sv;
2227 U8 *t = (U8*)SvPV(tstr, tlen);
2228 U8 *r = (U8*)SvPV(rstr, rlen);
2235 register short *tbl;
2237 PL_hints |= HINT_BLOCK_SCOPE;
2238 complement = o->op_private & OPpTRANS_COMPLEMENT;
2239 del = o->op_private & OPpTRANS_DELETE;
2240 squash = o->op_private & OPpTRANS_SQUASH;
2243 o->op_private |= OPpTRANS_FROM_UTF;
2246 o->op_private |= OPpTRANS_TO_UTF;
2248 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2249 SV* listsv = newSVpvn("# comment\n",10);
2251 U8* tend = t + tlen;
2252 U8* rend = r + rlen;
2266 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2267 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2273 tsave = t = bytes_to_utf8(t, &len);
2276 if (!to_utf && rlen) {
2278 rsave = r = bytes_to_utf8(r, &len);
2282 /* There are several snags with this code on EBCDIC:
2283 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2284 2. scan_const() in toke.c has encoded chars in native encoding which makes
2285 ranges at least in EBCDIC 0..255 range the bottom odd.
2289 U8 tmpbuf[UTF8_MAXLEN+1];
2292 New(1109, cp, 2*tlen, UV);
2294 transv = newSVpvn("",0);
2296 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2298 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2300 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2304 cp[2*i+1] = cp[2*i];
2308 qsort(cp, i, 2*sizeof(UV), uvcompare);
2309 for (j = 0; j < i; j++) {
2311 diff = val - nextmin;
2313 t = uvuni_to_utf8(tmpbuf,nextmin);
2314 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2316 U8 range_mark = UTF_TO_NATIVE(0xff);
2317 t = uvuni_to_utf8(tmpbuf, val - 1);
2318 sv_catpvn(transv, (char *)&range_mark, 1);
2319 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2326 t = uvuni_to_utf8(tmpbuf,nextmin);
2327 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2329 U8 range_mark = UTF_TO_NATIVE(0xff);
2330 sv_catpvn(transv, (char *)&range_mark, 1);
2332 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2333 UNICODE_ALLOW_SUPER);
2334 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2335 t = (U8*)SvPVX(transv);
2336 tlen = SvCUR(transv);
2340 else if (!rlen && !del) {
2341 r = t; rlen = tlen; rend = tend;
2344 if ((!rlen && !del) || t == r ||
2345 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2347 o->op_private |= OPpTRANS_IDENTICAL;
2351 while (t < tend || tfirst <= tlast) {
2352 /* see if we need more "t" chars */
2353 if (tfirst > tlast) {
2354 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2356 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2358 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2365 /* now see if we need more "r" chars */
2366 if (rfirst > rlast) {
2368 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2370 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2372 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2381 rfirst = rlast = 0xffffffff;
2385 /* now see which range will peter our first, if either. */
2386 tdiff = tlast - tfirst;
2387 rdiff = rlast - rfirst;
2394 if (rfirst == 0xffffffff) {
2395 diff = tdiff; /* oops, pretend rdiff is infinite */
2397 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2398 (long)tfirst, (long)tlast);
2400 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2404 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2405 (long)tfirst, (long)(tfirst + diff),
2408 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2409 (long)tfirst, (long)rfirst);
2411 if (rfirst + diff > max)
2412 max = rfirst + diff;
2414 grows = (tfirst < rfirst &&
2415 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2427 else if (max > 0xff)
2432 Safefree(cPVOPo->op_pv);
2433 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2434 SvREFCNT_dec(listsv);
2436 SvREFCNT_dec(transv);
2438 if (!del && havefinal && rlen)
2439 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2440 newSVuv((UV)final), 0);
2443 o->op_private |= OPpTRANS_GROWS;
2455 tbl = (short*)cPVOPo->op_pv;
2457 Zero(tbl, 256, short);
2458 for (i = 0; i < (I32)tlen; i++)
2460 for (i = 0, j = 0; i < 256; i++) {
2462 if (j >= (I32)rlen) {
2471 if (i < 128 && r[j] >= 128)
2481 o->op_private |= OPpTRANS_IDENTICAL;
2483 else if (j >= (I32)rlen)
2486 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2487 tbl[0x100] = rlen - j;
2488 for (i=0; i < (I32)rlen - j; i++)
2489 tbl[0x101+i] = r[j+i];
2493 if (!rlen && !del) {
2496 o->op_private |= OPpTRANS_IDENTICAL;
2498 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2499 o->op_private |= OPpTRANS_IDENTICAL;
2501 for (i = 0; i < 256; i++)
2503 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
2504 if (j >= (I32)rlen) {
2506 if (tbl[t[i]] == -1)
2512 if (tbl[t[i]] == -1) {
2513 if (t[i] < 128 && r[j] >= 128)
2520 o->op_private |= OPpTRANS_GROWS;
2528 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2532 NewOp(1101, pmop, 1, PMOP);
2533 pmop->op_type = (OPCODE)type;
2534 pmop->op_ppaddr = PL_ppaddr[type];
2535 pmop->op_flags = (U8)flags;
2536 pmop->op_private = (U8)(0 | (flags >> 8));
2538 if (PL_hints & HINT_RE_TAINT)
2539 pmop->op_pmpermflags |= PMf_RETAINT;
2540 if (PL_hints & HINT_LOCALE)
2541 pmop->op_pmpermflags |= PMf_LOCALE;
2542 pmop->op_pmflags = pmop->op_pmpermflags;
2547 if(av_len((AV*) PL_regex_pad[0]) > -1) {
2548 repointer = av_pop((AV*)PL_regex_pad[0]);
2549 pmop->op_pmoffset = SvIV(repointer);
2550 SvREPADTMP_off(repointer);
2551 sv_setiv(repointer,0);
2553 repointer = newSViv(0);
2554 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2555 pmop->op_pmoffset = av_len(PL_regex_padav);
2556 PL_regex_pad = AvARRAY(PL_regex_padav);
2561 /* link into pm list */
2562 if (type != OP_TRANS && PL_curstash) {
2563 pmop->op_pmnext = HvPMROOT(PL_curstash);
2564 HvPMROOT(PL_curstash) = pmop;
2565 PmopSTASH_set(pmop,PL_curstash);
2572 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
2576 I32 repl_has_vars = 0;
2578 if (o->op_type == OP_TRANS)
2579 return pmtrans(o, expr, repl);
2581 PL_hints |= HINT_BLOCK_SCOPE;
2584 if (expr->op_type == OP_CONST) {
2586 SV *pat = ((SVOP*)expr)->op_sv;
2587 char *p = SvPV(pat, plen);
2588 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
2589 sv_setpvn(pat, "\\s+", 3);
2590 p = SvPV(pat, plen);
2591 pm->op_pmflags |= PMf_SKIPWHITE;
2594 pm->op_pmdynflags |= PMdf_UTF8;
2595 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
2596 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
2597 pm->op_pmflags |= PMf_WHITE;
2601 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2602 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2604 : OP_REGCMAYBE),0,expr);
2606 NewOp(1101, rcop, 1, LOGOP);
2607 rcop->op_type = OP_REGCOMP;
2608 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2609 rcop->op_first = scalar(expr);
2610 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
2611 ? (OPf_SPECIAL | OPf_KIDS)
2613 rcop->op_private = 1;
2616 /* establish postfix order */
2617 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2619 rcop->op_next = expr;
2620 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2623 rcop->op_next = LINKLIST(expr);
2624 expr->op_next = (OP*)rcop;
2627 prepend_elem(o->op_type, scalar((OP*)rcop), o);
2632 if (pm->op_pmflags & PMf_EVAL) {
2634 if (CopLINE(PL_curcop) < PL_multi_end)
2635 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
2637 else if (repl->op_type == OP_CONST)
2641 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
2642 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
2643 if (curop->op_type == OP_GV) {
2644 GV *gv = cGVOPx_gv(curop);
2646 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
2649 else if (curop->op_type == OP_RV2CV)
2651 else if (curop->op_type == OP_RV2SV ||
2652 curop->op_type == OP_RV2AV ||
2653 curop->op_type == OP_RV2HV ||
2654 curop->op_type == OP_RV2GV) {
2655 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2658 else if (curop->op_type == OP_PADSV ||
2659 curop->op_type == OP_PADAV ||
2660 curop->op_type == OP_PADHV ||
2661 curop->op_type == OP_PADANY) {
2664 else if (curop->op_type == OP_PUSHRE)
2665 ; /* Okay here, dangerous in newASSIGNOP */
2675 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
2676 pm->op_pmflags |= PMf_CONST; /* const for long enough */
2677 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
2678 prepend_elem(o->op_type, scalar(repl), o);
2681 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
2682 pm->op_pmflags |= PMf_MAYBE_CONST;
2683 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2685 NewOp(1101, rcop, 1, LOGOP);
2686 rcop->op_type = OP_SUBSTCONT;
2687 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
2688 rcop->op_first = scalar(repl);
2689 rcop->op_flags |= OPf_KIDS;
2690 rcop->op_private = 1;
2693 /* establish postfix order */
2694 rcop->op_next = LINKLIST(repl);
2695 repl->op_next = (OP*)rcop;
2697 pm->op_pmreplroot = scalar((OP*)rcop);
2698 pm->op_pmreplstart = LINKLIST(rcop);
2707 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
2710 NewOp(1101, svop, 1, SVOP);
2711 svop->op_type = (OPCODE)type;
2712 svop->op_ppaddr = PL_ppaddr[type];
2714 svop->op_next = (OP*)svop;
2715 svop->op_flags = (U8)flags;
2716 if (PL_opargs[type] & OA_RETSCALAR)
2718 if (PL_opargs[type] & OA_TARGET)
2719 svop->op_targ = pad_alloc(type, SVs_PADTMP);
2720 return CHECKOP(type, svop);
2724 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2727 NewOp(1101, padop, 1, PADOP);
2728 padop->op_type = (OPCODE)type;
2729 padop->op_ppaddr = PL_ppaddr[type];
2730 padop->op_padix = pad_alloc(type, SVs_PADTMP);
2731 SvREFCNT_dec(PAD_SVl(padop->op_padix));
2732 PAD_SETSV(padop->op_padix, sv);
2735 padop->op_next = (OP*)padop;
2736 padop->op_flags = (U8)flags;
2737 if (PL_opargs[type] & OA_RETSCALAR)
2739 if (PL_opargs[type] & OA_TARGET)
2740 padop->op_targ = pad_alloc(type, SVs_PADTMP);
2741 return CHECKOP(type, padop);
2745 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
2750 return newPADOP(type, flags, SvREFCNT_inc(gv));
2752 return newSVOP(type, flags, SvREFCNT_inc(gv));
2757 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
2760 NewOp(1101, pvop, 1, PVOP);
2761 pvop->op_type = (OPCODE)type;
2762 pvop->op_ppaddr = PL_ppaddr[type];
2764 pvop->op_next = (OP*)pvop;
2765 pvop->op_flags = (U8)flags;
2766 if (PL_opargs[type] & OA_RETSCALAR)
2768 if (PL_opargs[type] & OA_TARGET)
2769 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
2770 return CHECKOP(type, pvop);
2774 Perl_package(pTHX_ OP *o)
2779 save_hptr(&PL_curstash);
2780 save_item(PL_curstname);
2782 name = SvPV(cSVOPo->op_sv, len);
2783 PL_curstash = gv_stashpvn(name, len, TRUE);
2784 sv_setpvn(PL_curstname, name, len);
2787 PL_hints |= HINT_BLOCK_SCOPE;
2788 PL_copline = NOLINE;
2793 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
2799 if (idop->op_type != OP_CONST)
2800 Perl_croak(aTHX_ "Module name must be constant");
2804 if (version != Nullop) {
2805 SV *vesv = ((SVOP*)version)->op_sv;
2807 if (arg == Nullop && !SvNIOKp(vesv)) {
2814 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
2815 Perl_croak(aTHX_ "Version number must be constant number");
2817 /* Make copy of idop so we don't free it twice */
2818 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
2820 /* Fake up a method call to VERSION */
2821 meth = newSVpvn("VERSION",7);
2822 sv_upgrade(meth, SVt_PVIV);
2823 (void)SvIOK_on(meth);
2824 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
2825 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2826 append_elem(OP_LIST,
2827 prepend_elem(OP_LIST, pack, list(version)),
2828 newSVOP(OP_METHOD_NAMED, 0, meth)));
2832 /* Fake up an import/unimport */
2833 if (arg && arg->op_type == OP_STUB)
2834 imop = arg; /* no import on explicit () */
2835 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
2836 imop = Nullop; /* use 5.0; */
2841 /* Make copy of idop so we don't free it twice */
2842 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
2844 /* Fake up a method call to import/unimport */
2845 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);
2846 (void)SvUPGRADE(meth, SVt_PVIV);
2847 (void)SvIOK_on(meth);
2848 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
2849 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2850 append_elem(OP_LIST,
2851 prepend_elem(OP_LIST, pack, list(arg)),
2852 newSVOP(OP_METHOD_NAMED, 0, meth)));
2855 /* Fake up the BEGIN {}, which does its thing immediately. */
2857 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
2860 append_elem(OP_LINESEQ,
2861 append_elem(OP_LINESEQ,
2862 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, idop)),
2863 newSTATEOP(0, Nullch, veop)),
2864 newSTATEOP(0, Nullch, imop) ));
2866 /* The "did you use incorrect case?" warning used to be here.
2867 * The problem is that on case-insensitive filesystems one
2868 * might get false positives for "use" (and "require"):
2869 * "use Strict" or "require CARP" will work. This causes
2870 * portability problems for the script: in case-strict
2871 * filesystems the script will stop working.
2873 * The "incorrect case" warning checked whether "use Foo"
2874 * imported "Foo" to your namespace, but that is wrong, too:
2875 * there is no requirement nor promise in the language that
2876 * a Foo.pm should or would contain anything in package "Foo".
2878 * There is very little Configure-wise that can be done, either:
2879 * the case-sensitivity of the build filesystem of Perl does not
2880 * help in guessing the case-sensitivity of the runtime environment.
2883 PL_hints |= HINT_BLOCK_SCOPE;
2884 PL_copline = NOLINE;
2889 =head1 Embedding Functions
2891 =for apidoc load_module
2893 Loads the module whose name is pointed to by the string part of name.
2894 Note that the actual module name, not its filename, should be given.
2895 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
2896 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
2897 (or 0 for no flags). ver, if specified, provides version semantics
2898 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
2899 arguments can be used to specify arguments to the module's import()
2900 method, similar to C<use Foo::Bar VERSION LIST>.
2905 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
2908 va_start(args, ver);
2909 vload_module(flags, name, ver, &args);
2913 #ifdef PERL_IMPLICIT_CONTEXT
2915 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
2919 va_start(args, ver);
2920 vload_module(flags, name, ver, &args);
2926 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
2928 OP *modname, *veop, *imop;
2930 modname = newSVOP(OP_CONST, 0, name);
2931 modname->op_private |= OPpCONST_BARE;
2933 veop = newSVOP(OP_CONST, 0, ver);
2937 if (flags & PERL_LOADMOD_NOIMPORT) {
2938 imop = sawparens(newNULLLIST());
2940 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
2941 imop = va_arg(*args, OP*);
2946 sv = va_arg(*args, SV*);
2948 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
2949 sv = va_arg(*args, SV*);
2953 line_t ocopline = PL_copline;
2954 COP *ocurcop = PL_curcop;
2955 int oexpect = PL_expect;
2957 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
2958 veop, modname, imop);
2959 PL_expect = oexpect;
2960 PL_copline = ocopline;
2961 PL_curcop = ocurcop;
2966 Perl_dofile(pTHX_ OP *term)
2971 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
2972 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
2973 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
2975 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
2976 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
2977 append_elem(OP_LIST, term,
2978 scalar(newUNOP(OP_RV2CV, 0,
2983 doop = newUNOP(OP_DOFILE, 0, scalar(term));
2989 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
2991 return newBINOP(OP_LSLICE, flags,
2992 list(force_list(subscript)),
2993 list(force_list(listval)) );
2997 S_list_assignment(pTHX_ register OP *o)
3002 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3003 o = cUNOPo->op_first;
3005 if (o->op_type == OP_COND_EXPR) {
3006 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3007 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3012 yyerror("Assignment to both a list and a scalar");
3016 if (o->op_type == OP_LIST &&
3017 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3018 o->op_private & OPpLVAL_INTRO)
3021 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3022 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3023 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3026 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3029 if (o->op_type == OP_RV2SV)
3036 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3041 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3042 return newLOGOP(optype, 0,
3043 mod(scalar(left), optype),
3044 newUNOP(OP_SASSIGN, 0, scalar(right)));
3047 return newBINOP(optype, OPf_STACKED,
3048 mod(scalar(left), optype), scalar(right));
3052 if (list_assignment(left)) {
3056 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3057 left = mod(left, OP_AASSIGN);
3065 curop = list(force_list(left));
3066 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3067 o->op_private = (U8)(0 | (flags >> 8));
3069 /* PL_generation sorcery:
3070 * an assignment like ($a,$b) = ($c,$d) is easier than
3071 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3072 * To detect whether there are common vars, the global var
3073 * PL_generation is incremented for each assign op we compile.
3074 * Then, while compiling the assign op, we run through all the
3075 * variables on both sides of the assignment, setting a spare slot
3076 * in each of them to PL_generation. If any of them already have
3077 * that value, we know we've got commonality. We could use a
3078 * single bit marker, but then we'd have to make 2 passes, first
3079 * to clear the flag, then to test and set it. To find somewhere
3080 * to store these values, evil chicanery is done with SvCUR().
3083 if (!(left->op_private & OPpLVAL_INTRO)) {
3086 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3087 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3088 if (curop->op_type == OP_GV) {
3089 GV *gv = cGVOPx_gv(curop);
3090 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3092 SvCUR(gv) = PL_generation;
3094 else if (curop->op_type == OP_PADSV ||
3095 curop->op_type == OP_PADAV ||
3096 curop->op_type == OP_PADHV ||
3097 curop->op_type == OP_PADANY)
3099 if (PAD_COMPNAME_GEN(curop->op_targ)
3100 == (STRLEN)PL_generation)
3102 PAD_COMPNAME_GEN(curop->op_targ)
3106 else if (curop->op_type == OP_RV2CV)
3108 else if (curop->op_type == OP_RV2SV ||
3109 curop->op_type == OP_RV2AV ||
3110 curop->op_type == OP_RV2HV ||
3111 curop->op_type == OP_RV2GV) {
3112 if (lastop->op_type != OP_GV) /* funny deref? */
3115 else if (curop->op_type == OP_PUSHRE) {
3116 if (((PMOP*)curop)->op_pmreplroot) {
3118 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3119 ((PMOP*)curop)->op_pmreplroot));
3121 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3123 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3125 SvCUR(gv) = PL_generation;
3134 o->op_private |= OPpASSIGN_COMMON;
3136 if (right && right->op_type == OP_SPLIT) {
3138 if ((tmpop = ((LISTOP*)right)->op_first) &&
3139 tmpop->op_type == OP_PUSHRE)
3141 PMOP *pm = (PMOP*)tmpop;
3142 if (left->op_type == OP_RV2AV &&
3143 !(left->op_private & OPpLVAL_INTRO) &&
3144 !(o->op_private & OPpASSIGN_COMMON) )
3146 tmpop = ((UNOP*)left)->op_first;
3147 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3149 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3150 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3152 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3153 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3155 pm->op_pmflags |= PMf_ONCE;
3156 tmpop = cUNOPo->op_first; /* to list (nulled) */
3157 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3158 tmpop->op_sibling = Nullop; /* don't free split */
3159 right->op_next = tmpop->op_next; /* fix starting loc */
3160 op_free(o); /* blow off assign */
3161 right->op_flags &= ~OPf_WANT;
3162 /* "I don't know and I don't care." */
3167 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3168 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3170 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3172 sv_setiv(sv, PL_modcount+1);
3180 right = newOP(OP_UNDEF, 0);
3181 if (right->op_type == OP_READLINE) {
3182 right->op_flags |= OPf_STACKED;
3183 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3186 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3187 o = newBINOP(OP_SASSIGN, flags,
3188 scalar(right), mod(scalar(left), OP_SASSIGN) );
3200 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3202 U32 seq = intro_my();
3205 NewOp(1101, cop, 1, COP);
3206 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3207 cop->op_type = OP_DBSTATE;
3208 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3211 cop->op_type = OP_NEXTSTATE;
3212 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3214 cop->op_flags = (U8)flags;
3215 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3217 cop->op_private |= NATIVE_HINTS;
3219 PL_compiling.op_private = cop->op_private;
3220 cop->op_next = (OP*)cop;
3223 cop->cop_label = label;
3224 PL_hints |= HINT_BLOCK_SCOPE;
3227 cop->cop_arybase = PL_curcop->cop_arybase;
3228 if (specialWARN(PL_curcop->cop_warnings))
3229 cop->cop_warnings = PL_curcop->cop_warnings ;
3231 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3232 if (specialCopIO(PL_curcop->cop_io))
3233 cop->cop_io = PL_curcop->cop_io;
3235 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3238 if (PL_copline == NOLINE)
3239 CopLINE_set(cop, CopLINE(PL_curcop));
3241 CopLINE_set(cop, PL_copline);
3242 PL_copline = NOLINE;
3245 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3247 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3249 CopSTASH_set(cop, PL_curstash);
3251 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3252 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3253 if (svp && *svp != &PL_sv_undef ) {
3254 (void)SvIOK_on(*svp);
3255 SvIVX(*svp) = PTR2IV(cop);
3259 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3264 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3266 return new_logop(type, flags, &first, &other);
3270 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3274 OP *first = *firstp;
3275 OP *other = *otherp;
3277 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3278 return newBINOP(type, flags, scalar(first), scalar(other));
3280 scalarboolean(first);
3281 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3282 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3283 if (type == OP_AND || type == OP_OR) {
3289 first = *firstp = cUNOPo->op_first;
3291 first->op_next = o->op_next;
3292 cUNOPo->op_first = Nullop;
3296 if (first->op_type == OP_CONST) {
3297 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE)) {
3298 if (first->op_private & OPpCONST_STRICT)
3299 no_bareword_allowed(first);
3301 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3303 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3314 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3315 OP *k1 = ((UNOP*)first)->op_first;
3316 OP *k2 = k1->op_sibling;
3318 switch (first->op_type)
3321 if (k2 && k2->op_type == OP_READLINE
3322 && (k2->op_flags & OPf_STACKED)
3323 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3325 warnop = k2->op_type;
3330 if (k1->op_type == OP_READDIR
3331 || k1->op_type == OP_GLOB
3332 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3333 || k1->op_type == OP_EACH)
3335 warnop = ((k1->op_type == OP_NULL)
3336 ? (OPCODE)k1->op_targ : k1->op_type);
3341 line_t oldline = CopLINE(PL_curcop);
3342 CopLINE_set(PL_curcop, PL_copline);
3343 Perl_warner(aTHX_ packWARN(WARN_MISC),
3344 "Value of %s%s can be \"0\"; test with defined()",
3346 ((warnop == OP_READLINE || warnop == OP_GLOB)
3347 ? " construct" : "() operator"));
3348 CopLINE_set(PL_curcop, oldline);
3355 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3356 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3358 NewOp(1101, logop, 1, LOGOP);
3360 logop->op_type = (OPCODE)type;
3361 logop->op_ppaddr = PL_ppaddr[type];
3362 logop->op_first = first;
3363 logop->op_flags = flags | OPf_KIDS;
3364 logop->op_other = LINKLIST(other);
3365 logop->op_private = (U8)(1 | (flags >> 8));
3367 /* establish postfix order */
3368 logop->op_next = LINKLIST(first);
3369 first->op_next = (OP*)logop;
3370 first->op_sibling = other;
3372 o = newUNOP(OP_NULL, 0, (OP*)logop);
3379 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3386 return newLOGOP(OP_AND, 0, first, trueop);
3388 return newLOGOP(OP_OR, 0, first, falseop);
3390 scalarboolean(first);
3391 if (first->op_type == OP_CONST) {
3392 if (first->op_private & OPpCONST_BARE &&
3393 first->op_private & OPpCONST_STRICT) {
3394 no_bareword_allowed(first);
3396 if (SvTRUE(((SVOP*)first)->op_sv)) {
3407 NewOp(1101, logop, 1, LOGOP);
3408 logop->op_type = OP_COND_EXPR;
3409 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3410 logop->op_first = first;
3411 logop->op_flags = flags | OPf_KIDS;
3412 logop->op_private = (U8)(1 | (flags >> 8));
3413 logop->op_other = LINKLIST(trueop);
3414 logop->op_next = LINKLIST(falseop);
3417 /* establish postfix order */
3418 start = LINKLIST(first);
3419 first->op_next = (OP*)logop;
3421 first->op_sibling = trueop;
3422 trueop->op_sibling = falseop;
3423 o = newUNOP(OP_NULL, 0, (OP*)logop);
3425 trueop->op_next = falseop->op_next = o;
3432 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3440 NewOp(1101, range, 1, LOGOP);
3442 range->op_type = OP_RANGE;
3443 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3444 range->op_first = left;
3445 range->op_flags = OPf_KIDS;
3446 leftstart = LINKLIST(left);
3447 range->op_other = LINKLIST(right);
3448 range->op_private = (U8)(1 | (flags >> 8));
3450 left->op_sibling = right;
3452 range->op_next = (OP*)range;
3453 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3454 flop = newUNOP(OP_FLOP, 0, flip);
3455 o = newUNOP(OP_NULL, 0, flop);
3457 range->op_next = leftstart;
3459 left->op_next = flip;
3460 right->op_next = flop;
3462 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3463 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3464 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3465 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3467 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3468 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3471 if (!flip->op_private || !flop->op_private)
3472 linklist(o); /* blow off optimizer unless constant */
3478 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3482 int once = block && block->op_flags & OPf_SPECIAL &&
3483 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3486 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3487 return block; /* do {} while 0 does once */
3488 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3489 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3490 expr = newUNOP(OP_DEFINED, 0,
3491 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3492 } else if (expr->op_flags & OPf_KIDS) {
3493 OP *k1 = ((UNOP*)expr)->op_first;
3494 OP *k2 = (k1) ? k1->op_sibling : NULL;
3495 switch (expr->op_type) {
3497 if (k2 && k2->op_type == OP_READLINE
3498 && (k2->op_flags & OPf_STACKED)
3499 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3500 expr = newUNOP(OP_DEFINED, 0, expr);
3504 if (k1->op_type == OP_READDIR
3505 || k1->op_type == OP_GLOB
3506 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3507 || k1->op_type == OP_EACH)
3508 expr = newUNOP(OP_DEFINED, 0, expr);
3514 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3515 o = new_logop(OP_AND, 0, &expr, &listop);
3518 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3520 if (once && o != listop)
3521 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3524 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3526 o->op_flags |= flags;
3528 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3533 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3541 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3542 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3543 expr = newUNOP(OP_DEFINED, 0,
3544 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3545 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3546 OP *k1 = ((UNOP*)expr)->op_first;
3547 OP *k2 = (k1) ? k1->op_sibling : NULL;
3548 switch (expr->op_type) {
3550 if (k2 && k2->op_type == OP_READLINE
3551 && (k2->op_flags & OPf_STACKED)
3552 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3553 expr = newUNOP(OP_DEFINED, 0, expr);
3557 if (k1->op_type == OP_READDIR
3558 || k1->op_type == OP_GLOB
3559 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3560 || k1->op_type == OP_EACH)
3561 expr = newUNOP(OP_DEFINED, 0, expr);
3567 block = newOP(OP_NULL, 0);
3569 block = scope(block);
3573 next = LINKLIST(cont);
3576 OP *unstack = newOP(OP_UNSTACK, 0);
3579 cont = append_elem(OP_LINESEQ, cont, unstack);
3580 if ((line_t)whileline != NOLINE) {
3581 PL_copline = (line_t)whileline;
3582 cont = append_elem(OP_LINESEQ, cont,
3583 newSTATEOP(0, Nullch, Nullop));
3587 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3588 redo = LINKLIST(listop);
3591 PL_copline = (line_t)whileline;
3593 o = new_logop(OP_AND, 0, &expr, &listop);
3594 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3595 op_free(expr); /* oops, it's a while (0) */
3597 return Nullop; /* listop already freed by new_logop */
3600 ((LISTOP*)listop)->op_last->op_next =
3601 (o == listop ? redo : LINKLIST(o));
3607 NewOp(1101,loop,1,LOOP);
3608 loop->op_type = OP_ENTERLOOP;
3609 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3610 loop->op_private = 0;
3611 loop->op_next = (OP*)loop;
3614 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3616 loop->op_redoop = redo;
3617 loop->op_lastop = o;
3618 o->op_private |= loopflags;
3621 loop->op_nextop = next;
3623 loop->op_nextop = o;
3625 o->op_flags |= flags;
3626 o->op_private |= (flags >> 8);
3631 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
3635 PADOFFSET padoff = 0;
3639 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
3640 sv->op_type = OP_RV2GV;
3641 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3643 else if (sv->op_type == OP_PADSV) { /* private variable */
3644 padoff = sv->op_targ;
3649 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3650 padoff = sv->op_targ;
3652 iterflags |= OPf_SPECIAL;
3657 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3660 sv = newGVOP(OP_GV, 0, PL_defgv);
3662 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3663 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3664 iterflags |= OPf_STACKED;
3666 else if (expr->op_type == OP_NULL &&
3667 (expr->op_flags & OPf_KIDS) &&
3668 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3670 /* Basically turn for($x..$y) into the same as for($x,$y), but we
3671 * set the STACKED flag to indicate that these values are to be
3672 * treated as min/max values by 'pp_iterinit'.
3674 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
3675 LOGOP* range = (LOGOP*) flip->op_first;
3676 OP* left = range->op_first;
3677 OP* right = left->op_sibling;
3680 range->op_flags &= ~OPf_KIDS;
3681 range->op_first = Nullop;
3683 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
3684 listop->op_first->op_next = range->op_next;
3685 left->op_next = range->op_other;
3686 right->op_next = (OP*)listop;
3687 listop->op_next = listop->op_first;
3690 expr = (OP*)(listop);
3692 iterflags |= OPf_STACKED;
3695 expr = mod(force_list(expr), OP_GREPSTART);
3699 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
3700 append_elem(OP_LIST, expr, scalar(sv))));
3701 assert(!loop->op_next);
3702 #ifdef PL_OP_SLAB_ALLOC
3705 NewOp(1234,tmp,1,LOOP);
3706 Copy(loop,tmp,1,LOOP);
3711 Renew(loop, 1, LOOP);
3713 loop->op_targ = padoff;
3714 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
3715 PL_copline = forline;
3716 return newSTATEOP(0, label, wop);
3720 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
3725 if (type != OP_GOTO || label->op_type == OP_CONST) {
3726 /* "last()" means "last" */
3727 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
3728 o = newOP(type, OPf_SPECIAL);
3730 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
3731 ? SvPVx(((SVOP*)label)->op_sv, n_a)
3737 if (label->op_type == OP_ENTERSUB)
3738 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
3739 o = newUNOP(type, OPf_STACKED, label);
3741 PL_hints |= HINT_BLOCK_SCOPE;
3746 =for apidoc cv_undef
3748 Clear out all the active components of a CV. This can happen either
3749 by an explicit C<undef &foo>, or by the reference count going to zero.
3750 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
3751 children can still follow the full lexical scope chain.
3757 Perl_cv_undef(pTHX_ CV *cv)
3760 if (CvFILE(cv) && !CvXSUB(cv)) {
3761 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
3762 Safefree(CvFILE(cv));
3767 if (!CvXSUB(cv) && CvROOT(cv)) {
3769 Perl_croak(aTHX_ "Can't undef active subroutine");
3772 PAD_SAVE_SETNULLPAD();
3774 op_free(CvROOT(cv));
3775 CvROOT(cv) = Nullop;
3778 SvPOK_off((SV*)cv); /* forget prototype */
3783 /* remove CvOUTSIDE unless this is an undef rather than a free */
3784 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
3785 if (!CvWEAKOUTSIDE(cv))
3786 SvREFCNT_dec(CvOUTSIDE(cv));
3787 CvOUTSIDE(cv) = Nullcv;
3790 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
3796 /* delete all flags except WEAKOUTSIDE */
3797 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
3801 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
3803 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
3804 SV* msg = sv_newmortal();
3808 gv_efullname3(name = sv_newmortal(), gv, Nullch);
3809 sv_setpv(msg, "Prototype mismatch:");
3811 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
3813 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (SV *)cv);
3814 sv_catpv(msg, " vs ");
3816 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
3818 sv_catpv(msg, "none");
3819 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
3823 static void const_sv_xsub(pTHX_ CV* cv);
3827 =head1 Optree Manipulation Functions
3829 =for apidoc cv_const_sv
3831 If C<cv> is a constant sub eligible for inlining. returns the constant
3832 value returned by the sub. Otherwise, returns NULL.
3834 Constant subs can be created with C<newCONSTSUB> or as described in
3835 L<perlsub/"Constant Functions">.
3840 Perl_cv_const_sv(pTHX_ CV *cv)
3842 if (!cv || !CvCONST(cv))
3844 return (SV*)CvXSUBANY(cv).any_ptr;
3848 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
3855 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
3856 o = cLISTOPo->op_first->op_sibling;
3858 for (; o; o = o->op_next) {
3859 OPCODE type = o->op_type;
3861 if (sv && o->op_next == o)
3863 if (o->op_next != o) {
3864 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
3866 if (type == OP_DBSTATE)
3869 if (type == OP_LEAVESUB || type == OP_RETURN)
3873 if (type == OP_CONST && cSVOPo->op_sv)
3875 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
3876 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
3880 /* We get here only from cv_clone2() while creating a closure.
3881 Copy the const value here instead of in cv_clone2 so that
3882 SvREADONLY_on doesn't lead to problems when leaving
3887 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
3899 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
3909 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
3913 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
3915 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
3919 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
3925 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
3929 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
3930 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
3931 SV *sv = sv_newmortal();
3932 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
3933 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
3934 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3939 gv = gv_fetchpv(name ? name : (aname ? aname :
3940 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__")),
3941 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
3951 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
3952 maximum a prototype before. */
3953 if (SvTYPE(gv) > SVt_NULL) {
3954 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
3955 && ckWARN_d(WARN_PROTOTYPE))
3957 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
3959 cv_ckproto((CV*)gv, NULL, ps);
3962 sv_setpv((SV*)gv, ps);
3964 sv_setiv((SV*)gv, -1);
3965 SvREFCNT_dec(PL_compcv);
3966 cv = PL_compcv = NULL;
3967 PL_sub_generation++;
3971 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
3973 #ifdef GV_UNIQUE_CHECK
3974 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
3975 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
3979 if (!block || !ps || *ps || attrs)
3982 const_sv = op_const_sv(block, Nullcv);
3985 bool exists = CvROOT(cv) || CvXSUB(cv);
3987 #ifdef GV_UNIQUE_CHECK
3988 if (exists && GvUNIQUE(gv)) {
3989 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
3993 /* if the subroutine doesn't exist and wasn't pre-declared
3994 * with a prototype, assume it will be AUTOLOADed,
3995 * skipping the prototype check
3997 if (exists || SvPOK(cv))
3998 cv_ckproto(cv, gv, ps);
3999 /* already defined (or promised)? */
4000 if (exists || GvASSUMECV(gv)) {
4001 if (!block && !attrs) {
4002 if (CvFLAGS(PL_compcv)) {
4003 /* might have had built-in attrs applied */
4004 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4006 /* just a "sub foo;" when &foo is already defined */
4007 SAVEFREESV(PL_compcv);
4010 /* ahem, death to those who redefine active sort subs */
4011 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4012 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4014 if (ckWARN(WARN_REDEFINE)
4016 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4018 line_t oldline = CopLINE(PL_curcop);
4019 if (PL_copline != NOLINE)
4020 CopLINE_set(PL_curcop, PL_copline);
4021 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4022 CvCONST(cv) ? "Constant subroutine %s redefined"
4023 : "Subroutine %s redefined", name);
4024 CopLINE_set(PL_curcop, oldline);
4032 SvREFCNT_inc(const_sv);
4034 assert(!CvROOT(cv) && !CvCONST(cv));
4035 sv_setpv((SV*)cv, ""); /* prototype is "" */
4036 CvXSUBANY(cv).any_ptr = const_sv;
4037 CvXSUB(cv) = const_sv_xsub;
4042 cv = newCONSTSUB(NULL, name, const_sv);
4045 SvREFCNT_dec(PL_compcv);
4047 PL_sub_generation++;
4054 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4055 * before we clobber PL_compcv.
4059 /* Might have had built-in attributes applied -- propagate them. */
4060 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4061 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4062 stash = GvSTASH(CvGV(cv));
4063 else if (CvSTASH(cv))
4064 stash = CvSTASH(cv);
4066 stash = PL_curstash;
4069 /* possibly about to re-define existing subr -- ignore old cv */
4070 rcv = (SV*)PL_compcv;
4071 if (name && GvSTASH(gv))
4072 stash = GvSTASH(gv);
4074 stash = PL_curstash;
4076 apply_attrs(stash, rcv, attrs, FALSE);
4078 if (cv) { /* must reuse cv if autoloaded */
4080 /* got here with just attrs -- work done, so bug out */
4081 SAVEFREESV(PL_compcv);
4084 /* transfer PL_compcv to cv */
4086 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4087 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4088 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4089 CvOUTSIDE(PL_compcv) = 0;
4090 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4091 CvPADLIST(PL_compcv) = 0;
4092 /* inner references to PL_compcv must be fixed up ... */
4093 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4094 /* ... before we throw it away */
4095 SvREFCNT_dec(PL_compcv);
4096 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4097 ++PL_sub_generation;
4104 PL_sub_generation++;
4108 CvFILE_set_from_cop(cv, PL_curcop);
4109 CvSTASH(cv) = PL_curstash;
4112 sv_setpv((SV*)cv, ps);
4114 if (PL_error_count) {
4118 char *s = strrchr(name, ':');
4120 if (strEQ(s, "BEGIN")) {
4122 "BEGIN not safe after errors--compilation aborted";
4123 if (PL_in_eval & EVAL_KEEPERR)
4124 Perl_croak(aTHX_ not_safe);
4126 /* force display of errors found but not reported */
4127 sv_catpv(ERRSV, not_safe);
4128 Perl_croak(aTHX_ "%"SVf, ERRSV);
4137 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4138 mod(scalarseq(block), OP_LEAVESUBLV));
4141 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4143 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4144 OpREFCNT_set(CvROOT(cv), 1);
4145 CvSTART(cv) = LINKLIST(CvROOT(cv));
4146 CvROOT(cv)->op_next = 0;
4147 CALL_PEEP(CvSTART(cv));
4149 /* now that optimizer has done its work, adjust pad values */
4151 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4154 assert(!CvCONST(cv));
4155 if (ps && !*ps && op_const_sv(block, cv))
4159 if (name || aname) {
4161 char *tname = (name ? name : aname);
4163 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4164 SV *sv = NEWSV(0,0);
4165 SV *tmpstr = sv_newmortal();
4166 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4170 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4172 (long)PL_subline, (long)CopLINE(PL_curcop));
4173 gv_efullname3(tmpstr, gv, Nullch);
4174 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4175 hv = GvHVn(db_postponed);
4176 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4177 && (pcv = GvCV(db_postponed)))
4183 call_sv((SV*)pcv, G_DISCARD);
4187 if ((s = strrchr(tname,':')))
4192 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4195 if (strEQ(s, "BEGIN") && !PL_error_count) {
4196 I32 oldscope = PL_scopestack_ix;
4198 SAVECOPFILE(&PL_compiling);
4199 SAVECOPLINE(&PL_compiling);
4202 PL_beginav = newAV();
4203 DEBUG_x( dump_sub(gv) );
4204 av_push(PL_beginav, (SV*)cv);
4205 GvCV(gv) = 0; /* cv has been hijacked */
4206 call_list(oldscope, PL_beginav);
4208 PL_curcop = &PL_compiling;
4209 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4212 else if (strEQ(s, "END") && !PL_error_count) {
4215 DEBUG_x( dump_sub(gv) );
4216 av_unshift(PL_endav, 1);
4217 av_store(PL_endav, 0, (SV*)cv);
4218 GvCV(gv) = 0; /* cv has been hijacked */
4220 else if (strEQ(s, "CHECK") && !PL_error_count) {
4222 PL_checkav = newAV();
4223 DEBUG_x( dump_sub(gv) );
4224 if (PL_main_start && ckWARN(WARN_VOID))
4225 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4226 av_unshift(PL_checkav, 1);
4227 av_store(PL_checkav, 0, (SV*)cv);
4228 GvCV(gv) = 0; /* cv has been hijacked */
4230 else if (strEQ(s, "INIT") && !PL_error_count) {
4232 PL_initav = newAV();
4233 DEBUG_x( dump_sub(gv) );
4234 if (PL_main_start && ckWARN(WARN_VOID))
4235 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4236 av_push(PL_initav, (SV*)cv);
4237 GvCV(gv) = 0; /* cv has been hijacked */
4242 PL_copline = NOLINE;
4247 /* XXX unsafe for threads if eval_owner isn't held */
4249 =for apidoc newCONSTSUB
4251 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4252 eligible for inlining at compile-time.
4258 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4264 SAVECOPLINE(PL_curcop);
4265 CopLINE_set(PL_curcop, PL_copline);
4268 PL_hints &= ~HINT_BLOCK_SCOPE;
4271 SAVESPTR(PL_curstash);
4272 SAVECOPSTASH(PL_curcop);
4273 PL_curstash = stash;
4274 CopSTASH_set(PL_curcop,stash);
4277 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4278 CvXSUBANY(cv).any_ptr = sv;
4280 sv_setpv((SV*)cv, ""); /* prototype is "" */
4288 =for apidoc U||newXS
4290 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4296 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
4298 GV *gv = gv_fetchpv(name ? name :
4299 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4300 GV_ADDMULTI, SVt_PVCV);
4304 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4306 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4308 /* just a cached method */
4312 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4313 /* already defined (or promised) */
4314 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4315 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4316 line_t oldline = CopLINE(PL_curcop);
4317 if (PL_copline != NOLINE)
4318 CopLINE_set(PL_curcop, PL_copline);
4319 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4320 CvCONST(cv) ? "Constant subroutine %s redefined"
4321 : "Subroutine %s redefined"
4323 CopLINE_set(PL_curcop, oldline);
4330 if (cv) /* must reuse cv if autoloaded */
4333 cv = (CV*)NEWSV(1105,0);
4334 sv_upgrade((SV *)cv, SVt_PVCV);
4338 PL_sub_generation++;
4342 (void)gv_fetchfile(filename);
4343 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
4344 an external constant string */
4345 CvXSUB(cv) = subaddr;
4348 char *s = strrchr(name,':');
4354 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4357 if (strEQ(s, "BEGIN")) {
4359 PL_beginav = newAV();
4360 av_push(PL_beginav, (SV*)cv);
4361 GvCV(gv) = 0; /* cv has been hijacked */
4363 else if (strEQ(s, "END")) {
4366 av_unshift(PL_endav, 1);
4367 av_store(PL_endav, 0, (SV*)cv);
4368 GvCV(gv) = 0; /* cv has been hijacked */
4370 else if (strEQ(s, "CHECK")) {
4372 PL_checkav = newAV();
4373 if (PL_main_start && ckWARN(WARN_VOID))
4374 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4375 av_unshift(PL_checkav, 1);
4376 av_store(PL_checkav, 0, (SV*)cv);
4377 GvCV(gv) = 0; /* cv has been hijacked */
4379 else if (strEQ(s, "INIT")) {
4381 PL_initav = newAV();
4382 if (PL_main_start && ckWARN(WARN_VOID))
4383 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4384 av_push(PL_initav, (SV*)cv);
4385 GvCV(gv) = 0; /* cv has been hijacked */
4396 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4404 name = SvPVx(cSVOPo->op_sv, n_a);
4407 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
4408 #ifdef GV_UNIQUE_CHECK
4410 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4414 if ((cv = GvFORM(gv))) {
4415 if (ckWARN(WARN_REDEFINE)) {
4416 line_t oldline = CopLINE(PL_curcop);
4417 if (PL_copline != NOLINE)
4418 CopLINE_set(PL_curcop, PL_copline);
4419 Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Format %s redefined",name);
4420 CopLINE_set(PL_curcop, oldline);
4427 CvFILE_set_from_cop(cv, PL_curcop);
4430 pad_tidy(padtidy_FORMAT);
4431 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4432 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4433 OpREFCNT_set(CvROOT(cv), 1);
4434 CvSTART(cv) = LINKLIST(CvROOT(cv));
4435 CvROOT(cv)->op_next = 0;
4436 CALL_PEEP(CvSTART(cv));
4438 PL_copline = NOLINE;
4443 Perl_newANONLIST(pTHX_ OP *o)
4445 return newUNOP(OP_REFGEN, 0,
4446 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4450 Perl_newANONHASH(pTHX_ OP *o)
4452 return newUNOP(OP_REFGEN, 0,
4453 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4457 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4459 return newANONATTRSUB(floor, proto, Nullop, block);
4463 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4465 return newUNOP(OP_REFGEN, 0,
4466 newSVOP(OP_ANONCODE, 0,
4467 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
4471 Perl_oopsAV(pTHX_ OP *o)
4473 switch (o->op_type) {
4475 o->op_type = OP_PADAV;
4476 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4477 return ref(o, OP_RV2AV);
4480 o->op_type = OP_RV2AV;
4481 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4486 if (ckWARN_d(WARN_INTERNAL))
4487 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
4494 Perl_oopsHV(pTHX_ OP *o)
4496 switch (o->op_type) {
4499 o->op_type = OP_PADHV;
4500 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4501 return ref(o, OP_RV2HV);
4505 o->op_type = OP_RV2HV;
4506 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
4511 if (ckWARN_d(WARN_INTERNAL))
4512 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
4519 Perl_newAVREF(pTHX_ OP *o)
4521 if (o->op_type == OP_PADANY) {
4522 o->op_type = OP_PADAV;
4523 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4526 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
4527 && ckWARN(WARN_DEPRECATED)) {
4528 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4529 "Using an array as a reference is deprecated");
4531 return newUNOP(OP_RV2AV, 0, scalar(o));
4535 Perl_newGVREF(pTHX_ I32 type, OP *o)
4537 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
4538 return newUNOP(OP_NULL, 0, o);
4539 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
4543 Perl_newHVREF(pTHX_ OP *o)
4545 if (o->op_type == OP_PADANY) {
4546 o->op_type = OP_PADHV;
4547 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4550 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
4551 && ckWARN(WARN_DEPRECATED)) {
4552 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4553 "Using a hash as a reference is deprecated");
4555 return newUNOP(OP_RV2HV, 0, scalar(o));
4559 Perl_oopsCV(pTHX_ OP *o)
4561 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
4567 Perl_newCVREF(pTHX_ I32 flags, OP *o)
4569 return newUNOP(OP_RV2CV, flags, scalar(o));
4573 Perl_newSVREF(pTHX_ OP *o)
4575 if (o->op_type == OP_PADANY) {
4576 o->op_type = OP_PADSV;
4577 o->op_ppaddr = PL_ppaddr[OP_PADSV];
4580 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4581 o->op_flags |= OPpDONE_SVREF;
4584 return newUNOP(OP_RV2SV, 0, scalar(o));
4587 /* Check routines. */
4590 Perl_ck_anoncode(pTHX_ OP *o)
4592 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
4593 cSVOPo->op_sv = Nullsv;
4598 Perl_ck_bitop(pTHX_ OP *o)
4600 #define OP_IS_NUMCOMPARE(op) \
4601 ((op) == OP_LT || (op) == OP_I_LT || \
4602 (op) == OP_GT || (op) == OP_I_GT || \
4603 (op) == OP_LE || (op) == OP_I_LE || \
4604 (op) == OP_GE || (op) == OP_I_GE || \
4605 (op) == OP_EQ || (op) == OP_I_EQ || \
4606 (op) == OP_NE || (op) == OP_I_NE || \
4607 (op) == OP_NCMP || (op) == OP_I_NCMP)
4608 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4609 if (o->op_type == OP_BIT_OR
4610 || o->op_type == OP_BIT_AND
4611 || o->op_type == OP_BIT_XOR)
4613 OPCODE typfirst = cBINOPo->op_first->op_type;
4614 OPCODE typlast = cBINOPo->op_first->op_sibling->op_type;
4615 if (OP_IS_NUMCOMPARE(typfirst) || OP_IS_NUMCOMPARE(typlast))
4616 if (ckWARN(WARN_PRECEDENCE))
4617 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4618 "Possible precedence problem on bitwise %c operator",
4619 o->op_type == OP_BIT_OR ? '|'
4620 : o->op_type == OP_BIT_AND ? '&' : '^'
4627 Perl_ck_concat(pTHX_ OP *o)
4629 if (cUNOPo->op_first->op_type == OP_CONCAT)
4630 o->op_flags |= OPf_STACKED;
4635 Perl_ck_spair(pTHX_ OP *o)
4637 if (o->op_flags & OPf_KIDS) {
4640 OPCODE type = o->op_type;
4641 o = modkids(ck_fun(o), type);
4642 kid = cUNOPo->op_first;
4643 newop = kUNOP->op_first->op_sibling;
4645 (newop->op_sibling ||
4646 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
4647 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
4648 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
4652 op_free(kUNOP->op_first);
4653 kUNOP->op_first = newop;
4655 o->op_ppaddr = PL_ppaddr[++o->op_type];
4660 Perl_ck_delete(pTHX_ OP *o)
4664 if (o->op_flags & OPf_KIDS) {
4665 OP *kid = cUNOPo->op_first;
4666 switch (kid->op_type) {
4668 o->op_flags |= OPf_SPECIAL;
4671 o->op_private |= OPpSLICE;
4674 o->op_flags |= OPf_SPECIAL;
4679 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
4688 Perl_ck_die(pTHX_ OP *o)
4691 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4697 Perl_ck_eof(pTHX_ OP *o)
4699 I32 type = o->op_type;
4701 if (o->op_flags & OPf_KIDS) {
4702 if (cLISTOPo->op_first->op_type == OP_STUB) {
4704 o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
4712 Perl_ck_eval(pTHX_ OP *o)
4714 PL_hints |= HINT_BLOCK_SCOPE;
4715 if (o->op_flags & OPf_KIDS) {
4716 SVOP *kid = (SVOP*)cUNOPo->op_first;
4719 o->op_flags &= ~OPf_KIDS;
4722 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
4725 cUNOPo->op_first = 0;
4728 NewOp(1101, enter, 1, LOGOP);
4729 enter->op_type = OP_ENTERTRY;
4730 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
4731 enter->op_private = 0;
4733 /* establish postfix order */
4734 enter->op_next = (OP*)enter;
4736 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
4737 o->op_type = OP_LEAVETRY;
4738 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
4739 enter->op_other = o;
4747 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
4749 o->op_targ = (PADOFFSET)PL_hints;
4754 Perl_ck_exit(pTHX_ OP *o)
4757 HV *table = GvHV(PL_hintgv);
4759 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
4760 if (svp && *svp && SvTRUE(*svp))
4761 o->op_private |= OPpEXIT_VMSISH;
4763 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4769 Perl_ck_exec(pTHX_ OP *o)
4772 if (o->op_flags & OPf_STACKED) {
4774 kid = cUNOPo->op_first->op_sibling;
4775 if (kid->op_type == OP_RV2GV)
4784 Perl_ck_exists(pTHX_ OP *o)
4787 if (o->op_flags & OPf_KIDS) {
4788 OP *kid = cUNOPo->op_first;
4789 if (kid->op_type == OP_ENTERSUB) {
4790 (void) ref(kid, o->op_type);
4791 if (kid->op_type != OP_RV2CV && !PL_error_count)
4792 Perl_croak(aTHX_ "%s argument is not a subroutine name",
4794 o->op_private |= OPpEXISTS_SUB;
4796 else if (kid->op_type == OP_AELEM)
4797 o->op_flags |= OPf_SPECIAL;
4798 else if (kid->op_type != OP_HELEM)
4799 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
4808 Perl_ck_gvconst(pTHX_ register OP *o)
4810 o = fold_constants(o);
4811 if (o->op_type == OP_CONST)
4818 Perl_ck_rvconst(pTHX_ register OP *o)
4820 SVOP *kid = (SVOP*)cUNOPo->op_first;
4822 o->op_private |= (PL_hints & HINT_STRICT_REFS);
4823 if (kid->op_type == OP_CONST) {
4827 SV *kidsv = kid->op_sv;
4830 /* Is it a constant from cv_const_sv()? */
4831 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
4832 SV *rsv = SvRV(kidsv);
4833 int svtype = SvTYPE(rsv);
4834 char *badtype = Nullch;
4836 switch (o->op_type) {
4838 if (svtype > SVt_PVMG)
4839 badtype = "a SCALAR";
4842 if (svtype != SVt_PVAV)
4843 badtype = "an ARRAY";
4846 if (svtype != SVt_PVHV)
4850 if (svtype != SVt_PVCV)
4855 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
4858 name = SvPV(kidsv, n_a);
4859 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
4860 char *badthing = Nullch;
4861 switch (o->op_type) {
4863 badthing = "a SCALAR";
4866 badthing = "an ARRAY";
4869 badthing = "a HASH";
4874 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
4878 * This is a little tricky. We only want to add the symbol if we
4879 * didn't add it in the lexer. Otherwise we get duplicate strict
4880 * warnings. But if we didn't add it in the lexer, we must at
4881 * least pretend like we wanted to add it even if it existed before,
4882 * or we get possible typo warnings. OPpCONST_ENTERED says
4883 * whether the lexer already added THIS instance of this symbol.
4885 iscv = (o->op_type == OP_RV2CV) * 2;
4887 gv = gv_fetchpv(name,
4888 iscv | !(kid->op_private & OPpCONST_ENTERED),
4891 : o->op_type == OP_RV2SV
4893 : o->op_type == OP_RV2AV
4895 : o->op_type == OP_RV2HV
4898 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
4900 kid->op_type = OP_GV;
4901 SvREFCNT_dec(kid->op_sv);
4903 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
4904 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
4905 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
4907 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
4909 kid->op_sv = SvREFCNT_inc(gv);
4911 kid->op_private = 0;
4912 kid->op_ppaddr = PL_ppaddr[OP_GV];
4919 Perl_ck_ftst(pTHX_ OP *o)
4921 I32 type = o->op_type;
4923 if (o->op_flags & OPf_REF) {
4926 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
4927 SVOP *kid = (SVOP*)cUNOPo->op_first;
4929 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
4931 OP *newop = newGVOP(type, OPf_REF,
4932 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
4937 if ((PL_hints & HINT_FILETEST_ACCESS) &&
4938 OP_IS_FILETEST_ACCESS(o))
4939 o->op_private |= OPpFT_ACCESS;
4944 if (type == OP_FTTTY)
4945 o = newGVOP(type, OPf_REF, PL_stdingv);
4947 o = newUNOP(type, 0, newDEFSVOP());
4953 Perl_ck_fun(pTHX_ OP *o)
4959 int type = o->op_type;
4960 register I32 oa = PL_opargs[type] >> OASHIFT;
4962 if (o->op_flags & OPf_STACKED) {
4963 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
4966 return no_fh_allowed(o);
4969 if (o->op_flags & OPf_KIDS) {
4971 tokid = &cLISTOPo->op_first;
4972 kid = cLISTOPo->op_first;
4973 if (kid->op_type == OP_PUSHMARK ||
4974 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
4976 tokid = &kid->op_sibling;
4977 kid = kid->op_sibling;
4979 if (!kid && PL_opargs[type] & OA_DEFGV)
4980 *tokid = kid = newDEFSVOP();
4984 sibl = kid->op_sibling;
4987 /* list seen where single (scalar) arg expected? */
4988 if (numargs == 1 && !(oa >> 4)
4989 && kid->op_type == OP_LIST && type != OP_SCALAR)
4991 return too_many_arguments(o,PL_op_desc[type]);
5004 if ((type == OP_PUSH || type == OP_UNSHIFT)
5005 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5006 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5007 "Useless use of %s with no values",
5010 if (kid->op_type == OP_CONST &&
5011 (kid->op_private & OPpCONST_BARE))
5013 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5014 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5015 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5016 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5017 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5018 "Array @%s missing the @ in argument %"IVdf" of %s()",
5019 name, (IV)numargs, PL_op_desc[type]);
5022 kid->op_sibling = sibl;
5025 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5026 bad_type(numargs, "array", PL_op_desc[type], kid);
5030 if (kid->op_type == OP_CONST &&
5031 (kid->op_private & OPpCONST_BARE))
5033 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5034 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5035 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5036 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5037 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5038 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5039 name, (IV)numargs, PL_op_desc[type]);
5042 kid->op_sibling = sibl;
5045 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5046 bad_type(numargs, "hash", PL_op_desc[type], kid);
5051 OP *newop = newUNOP(OP_NULL, 0, kid);
5052 kid->op_sibling = 0;
5054 newop->op_next = newop;
5056 kid->op_sibling = sibl;
5061 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5062 if (kid->op_type == OP_CONST &&
5063 (kid->op_private & OPpCONST_BARE))
5065 OP *newop = newGVOP(OP_GV, 0,
5066 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5068 if (!(o->op_private & 1) && /* if not unop */
5069 kid == cLISTOPo->op_last)
5070 cLISTOPo->op_last = newop;
5074 else if (kid->op_type == OP_READLINE) {
5075 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5076 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5079 I32 flags = OPf_SPECIAL;
5083 /* is this op a FH constructor? */
5084 if (is_handle_constructor(o,numargs)) {
5085 char *name = Nullch;
5089 /* Set a flag to tell rv2gv to vivify
5090 * need to "prove" flag does not mean something
5091 * else already - NI-S 1999/05/07
5094 if (kid->op_type == OP_PADSV) {
5095 /*XXX DAPM 2002.08.25 tmp assert test */
5096 /*XXX*/ assert(av_fetch(PL_comppad_name, (kid->op_targ), FALSE));
5097 /*XXX*/ assert(*av_fetch(PL_comppad_name, (kid->op_targ), FALSE));
5099 name = PAD_COMPNAME_PV(kid->op_targ);
5100 /* SvCUR of a pad namesv can't be trusted
5101 * (see PL_generation), so calc its length
5107 else if (kid->op_type == OP_RV2SV
5108 && kUNOP->op_first->op_type == OP_GV)
5110 GV *gv = cGVOPx_gv(kUNOP->op_first);
5112 len = GvNAMELEN(gv);
5114 else if (kid->op_type == OP_AELEM
5115 || kid->op_type == OP_HELEM)
5120 if ((op = ((BINOP*)kid)->op_first)) {
5121 SV *tmpstr = Nullsv;
5123 kid->op_type == OP_AELEM ?
5125 if (((op->op_type == OP_RV2AV) ||
5126 (op->op_type == OP_RV2HV)) &&
5127 (op = ((UNOP*)op)->op_first) &&
5128 (op->op_type == OP_GV)) {
5129 /* packagevar $a[] or $h{} */
5130 GV *gv = cGVOPx_gv(op);
5138 else if (op->op_type == OP_PADAV
5139 || op->op_type == OP_PADHV) {
5140 /* lexicalvar $a[] or $h{} */
5142 PAD_COMPNAME_PV(op->op_targ);
5152 name = savepv(SvPVX(tmpstr));
5158 name = "__ANONIO__";
5165 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5166 namesv = PAD_SVl(targ);
5167 (void)SvUPGRADE(namesv, SVt_PV);
5169 sv_setpvn(namesv, "$", 1);
5170 sv_catpvn(namesv, name, len);
5173 kid->op_sibling = 0;
5174 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5175 kid->op_targ = targ;
5176 kid->op_private |= priv;
5178 kid->op_sibling = sibl;
5184 mod(scalar(kid), type);
5188 tokid = &kid->op_sibling;
5189 kid = kid->op_sibling;
5191 o->op_private |= numargs;
5193 return too_many_arguments(o,OP_DESC(o));
5196 else if (PL_opargs[type] & OA_DEFGV) {
5198 return newUNOP(type, 0, newDEFSVOP());
5202 while (oa & OA_OPTIONAL)
5204 if (oa && oa != OA_LIST)
5205 return too_few_arguments(o,OP_DESC(o));
5211 Perl_ck_glob(pTHX_ OP *o)
5216 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5217 append_elem(OP_GLOB, o, newDEFSVOP());
5219 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5220 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5222 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5225 #if !defined(PERL_EXTERNAL_GLOB)
5226 /* XXX this can be tightened up and made more failsafe. */
5230 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5231 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5232 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5233 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5234 GvCV(gv) = GvCV(glob_gv);
5235 SvREFCNT_inc((SV*)GvCV(gv));
5236 GvIMPORTED_CV_on(gv);
5239 #endif /* PERL_EXTERNAL_GLOB */
5241 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5242 append_elem(OP_GLOB, o,
5243 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5244 o->op_type = OP_LIST;
5245 o->op_ppaddr = PL_ppaddr[OP_LIST];
5246 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5247 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5248 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5249 append_elem(OP_LIST, o,
5250 scalar(newUNOP(OP_RV2CV, 0,
5251 newGVOP(OP_GV, 0, gv)))));
5252 o = newUNOP(OP_NULL, 0, ck_subr(o));
5253 o->op_targ = OP_GLOB; /* hint at what it used to be */
5256 gv = newGVgen("main");
5258 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5264 Perl_ck_grep(pTHX_ OP *o)
5268 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5270 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5271 NewOp(1101, gwop, 1, LOGOP);
5273 if (o->op_flags & OPf_STACKED) {
5276 kid = cLISTOPo->op_first->op_sibling;
5277 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5280 kid->op_next = (OP*)gwop;
5281 o->op_flags &= ~OPf_STACKED;
5283 kid = cLISTOPo->op_first->op_sibling;
5284 if (type == OP_MAPWHILE)
5291 kid = cLISTOPo->op_first->op_sibling;
5292 if (kid->op_type != OP_NULL)
5293 Perl_croak(aTHX_ "panic: ck_grep");
5294 kid = kUNOP->op_first;
5296 gwop->op_type = type;
5297 gwop->op_ppaddr = PL_ppaddr[type];
5298 gwop->op_first = listkids(o);
5299 gwop->op_flags |= OPf_KIDS;
5300 gwop->op_private = 1;
5301 gwop->op_other = LINKLIST(kid);
5302 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5303 kid->op_next = (OP*)gwop;
5305 kid = cLISTOPo->op_first->op_sibling;
5306 if (!kid || !kid->op_sibling)
5307 return too_few_arguments(o,OP_DESC(o));
5308 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5309 mod(kid, OP_GREPSTART);
5315 Perl_ck_index(pTHX_ OP *o)
5317 if (o->op_flags & OPf_KIDS) {
5318 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5320 kid = kid->op_sibling; /* get past "big" */
5321 if (kid && kid->op_type == OP_CONST)
5322 fbm_compile(((SVOP*)kid)->op_sv, 0);
5328 Perl_ck_lengthconst(pTHX_ OP *o)
5330 /* XXX length optimization goes here */
5335 Perl_ck_lfun(pTHX_ OP *o)
5337 OPCODE type = o->op_type;
5338 return modkids(ck_fun(o), type);
5342 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5344 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5345 switch (cUNOPo->op_first->op_type) {
5347 /* This is needed for
5348 if (defined %stash::)
5349 to work. Do not break Tk.
5351 break; /* Globals via GV can be undef */
5353 case OP_AASSIGN: /* Is this a good idea? */
5354 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5355 "defined(@array) is deprecated");
5356 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5357 "\t(Maybe you should just omit the defined()?)\n");
5360 /* This is needed for
5361 if (defined %stash::)
5362 to work. Do not break Tk.
5364 break; /* Globals via GV can be undef */
5366 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5367 "defined(%%hash) is deprecated");
5368 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5369 "\t(Maybe you should just omit the defined()?)\n");
5380 Perl_ck_rfun(pTHX_ OP *o)
5382 OPCODE type = o->op_type;
5383 return refkids(ck_fun(o), type);
5387 Perl_ck_listiob(pTHX_ OP *o)
5391 kid = cLISTOPo->op_first;
5394 kid = cLISTOPo->op_first;
5396 if (kid->op_type == OP_PUSHMARK)
5397 kid = kid->op_sibling;
5398 if (kid && o->op_flags & OPf_STACKED)
5399 kid = kid->op_sibling;
5400 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5401 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5402 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5403 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5404 cLISTOPo->op_first->op_sibling = kid;
5405 cLISTOPo->op_last = kid;
5406 kid = kid->op_sibling;
5411 append_elem(o->op_type, o, newDEFSVOP());
5417 Perl_ck_sassign(pTHX_ OP *o)
5419 OP *kid = cLISTOPo->op_first;
5420 /* has a disposable target? */
5421 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5422 && !(kid->op_flags & OPf_STACKED)
5423 /* Cannot steal the second time! */
5424 && !(kid->op_private & OPpTARGET_MY))
5426 OP *kkid = kid->op_sibling;
5428 /* Can just relocate the target. */
5429 if (kkid && kkid->op_type == OP_PADSV
5430 && !(kkid->op_private & OPpLVAL_INTRO))
5432 kid->op_targ = kkid->op_targ;
5434 /* Now we do not need PADSV and SASSIGN. */
5435 kid->op_sibling = o->op_sibling; /* NULL */
5436 cLISTOPo->op_first = NULL;
5439 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
5447 Perl_ck_match(pTHX_ OP *o)
5449 o->op_private |= OPpRUNTIME;
5454 Perl_ck_method(pTHX_ OP *o)
5456 OP *kid = cUNOPo->op_first;
5457 if (kid->op_type == OP_CONST) {
5458 SV* sv = kSVOP->op_sv;
5459 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
5461 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5462 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
5465 kSVOP->op_sv = Nullsv;
5467 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5476 Perl_ck_null(pTHX_ OP *o)
5482 Perl_ck_open(pTHX_ OP *o)
5484 HV *table = GvHV(PL_hintgv);
5488 svp = hv_fetch(table, "open_IN", 7, FALSE);
5490 mode = mode_from_discipline(*svp);
5491 if (mode & O_BINARY)
5492 o->op_private |= OPpOPEN_IN_RAW;
5493 else if (mode & O_TEXT)
5494 o->op_private |= OPpOPEN_IN_CRLF;
5497 svp = hv_fetch(table, "open_OUT", 8, FALSE);
5499 mode = mode_from_discipline(*svp);
5500 if (mode & O_BINARY)
5501 o->op_private |= OPpOPEN_OUT_RAW;
5502 else if (mode & O_TEXT)
5503 o->op_private |= OPpOPEN_OUT_CRLF;
5506 if (o->op_type == OP_BACKTICK)
5509 /* In case of three-arg dup open remove strictness
5510 * from the last arg if it is a bareword. */
5511 OP *first = cLISTOPx(o)->op_first; /* The pushmark. */
5512 OP *last = cLISTOPx(o)->op_last; /* The bareword. */
5516 if ((last->op_type == OP_CONST) && /* The bareword. */
5517 (last->op_private & OPpCONST_BARE) &&
5518 (last->op_private & OPpCONST_STRICT) &&
5519 (oa = first->op_sibling) && /* The fh. */
5520 (oa = oa->op_sibling) && /* The mode. */
5521 SvPOK(((SVOP*)oa)->op_sv) &&
5522 (mode = SvPVX(((SVOP*)oa)->op_sv)) &&
5523 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
5524 (last == oa->op_sibling)) /* The bareword. */
5525 last->op_private &= ~OPpCONST_STRICT;
5531 Perl_ck_repeat(pTHX_ OP *o)
5533 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5534 o->op_private |= OPpREPEAT_DOLIST;
5535 cBINOPo->op_first = force_list(cBINOPo->op_first);
5543 Perl_ck_require(pTHX_ OP *o)
5547 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
5548 SVOP *kid = (SVOP*)cUNOPo->op_first;
5550 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5552 for (s = SvPVX(kid->op_sv); *s; s++) {
5553 if (*s == ':' && s[1] == ':') {
5555 Move(s+2, s+1, strlen(s+2)+1, char);
5556 --SvCUR(kid->op_sv);
5559 if (SvREADONLY(kid->op_sv)) {
5560 SvREADONLY_off(kid->op_sv);
5561 sv_catpvn(kid->op_sv, ".pm", 3);
5562 SvREADONLY_on(kid->op_sv);
5565 sv_catpvn(kid->op_sv, ".pm", 3);
5569 /* handle override, if any */
5570 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
5571 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
5572 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
5574 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5575 OP *kid = cUNOPo->op_first;
5576 cUNOPo->op_first = 0;
5578 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5579 append_elem(OP_LIST, kid,
5580 scalar(newUNOP(OP_RV2CV, 0,
5589 Perl_ck_return(pTHX_ OP *o)
5592 if (CvLVALUE(PL_compcv)) {
5593 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5594 mod(kid, OP_LEAVESUBLV);
5601 Perl_ck_retarget(pTHX_ OP *o)
5603 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5610 Perl_ck_select(pTHX_ OP *o)
5613 if (o->op_flags & OPf_KIDS) {
5614 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5615 if (kid && kid->op_sibling) {
5616 o->op_type = OP_SSELECT;
5617 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
5619 return fold_constants(o);
5623 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5624 if (kid && kid->op_type == OP_RV2GV)
5625 kid->op_private &= ~HINT_STRICT_REFS;
5630 Perl_ck_shift(pTHX_ OP *o)
5632 I32 type = o->op_type;
5634 if (!(o->op_flags & OPf_KIDS)) {
5638 argop = newUNOP(OP_RV2AV, 0,
5639 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
5640 return newUNOP(type, 0, scalar(argop));
5642 return scalar(modkids(ck_fun(o), type));
5646 Perl_ck_sort(pTHX_ OP *o)
5650 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
5652 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5653 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
5655 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
5657 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
5659 if (kid->op_type == OP_SCOPE) {
5663 else if (kid->op_type == OP_LEAVE) {
5664 if (o->op_type == OP_SORT) {
5665 op_null(kid); /* wipe out leave */
5668 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
5669 if (k->op_next == kid)
5671 /* don't descend into loops */
5672 else if (k->op_type == OP_ENTERLOOP
5673 || k->op_type == OP_ENTERITER)
5675 k = cLOOPx(k)->op_lastop;
5680 kid->op_next = 0; /* just disconnect the leave */
5681 k = kLISTOP->op_first;
5686 if (o->op_type == OP_SORT) {
5687 /* provide scalar context for comparison function/block */
5693 o->op_flags |= OPf_SPECIAL;
5695 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
5698 firstkid = firstkid->op_sibling;
5701 /* provide list context for arguments */
5702 if (o->op_type == OP_SORT)
5709 S_simplify_sort(pTHX_ OP *o)
5711 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5715 if (!(o->op_flags & OPf_STACKED))
5717 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
5718 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
5719 kid = kUNOP->op_first; /* get past null */
5720 if (kid->op_type != OP_SCOPE)
5722 kid = kLISTOP->op_last; /* get past scope */
5723 switch(kid->op_type) {
5731 k = kid; /* remember this node*/
5732 if (kBINOP->op_first->op_type != OP_RV2SV)
5734 kid = kBINOP->op_first; /* get past cmp */
5735 if (kUNOP->op_first->op_type != OP_GV)
5737 kid = kUNOP->op_first; /* get past rv2sv */
5739 if (GvSTASH(gv) != PL_curstash)
5741 if (strEQ(GvNAME(gv), "a"))
5743 else if (strEQ(GvNAME(gv), "b"))
5747 kid = k; /* back to cmp */
5748 if (kBINOP->op_last->op_type != OP_RV2SV)
5750 kid = kBINOP->op_last; /* down to 2nd arg */
5751 if (kUNOP->op_first->op_type != OP_GV)
5753 kid = kUNOP->op_first; /* get past rv2sv */
5755 if (GvSTASH(gv) != PL_curstash
5757 ? strNE(GvNAME(gv), "a")
5758 : strNE(GvNAME(gv), "b")))
5760 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
5762 o->op_private |= OPpSORT_REVERSE;
5763 if (k->op_type == OP_NCMP)
5764 o->op_private |= OPpSORT_NUMERIC;
5765 if (k->op_type == OP_I_NCMP)
5766 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
5767 kid = cLISTOPo->op_first->op_sibling;
5768 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
5769 op_free(kid); /* then delete it */
5773 Perl_ck_split(pTHX_ OP *o)
5777 if (o->op_flags & OPf_STACKED)
5778 return no_fh_allowed(o);
5780 kid = cLISTOPo->op_first;
5781 if (kid->op_type != OP_NULL)
5782 Perl_croak(aTHX_ "panic: ck_split");
5783 kid = kid->op_sibling;
5784 op_free(cLISTOPo->op_first);
5785 cLISTOPo->op_first = kid;
5787 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
5788 cLISTOPo->op_last = kid; /* There was only one element previously */
5791 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
5792 OP *sibl = kid->op_sibling;
5793 kid->op_sibling = 0;
5794 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
5795 if (cLISTOPo->op_first == cLISTOPo->op_last)
5796 cLISTOPo->op_last = kid;
5797 cLISTOPo->op_first = kid;
5798 kid->op_sibling = sibl;
5801 kid->op_type = OP_PUSHRE;
5802 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
5804 if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
5805 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
5806 "Use of /g modifier is meaningless in split");
5809 if (!kid->op_sibling)
5810 append_elem(OP_SPLIT, o, newDEFSVOP());
5812 kid = kid->op_sibling;
5815 if (!kid->op_sibling)
5816 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
5818 kid = kid->op_sibling;
5821 if (kid->op_sibling)
5822 return too_many_arguments(o,OP_DESC(o));
5828 Perl_ck_join(pTHX_ OP *o)
5830 if (ckWARN(WARN_SYNTAX)) {
5831 OP *kid = cLISTOPo->op_first->op_sibling;
5832 if (kid && kid->op_type == OP_MATCH) {
5833 char *pmstr = "STRING";
5834 if (PM_GETRE(kPMOP))
5835 pmstr = PM_GETRE(kPMOP)->precomp;
5836 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5837 "/%s/ should probably be written as \"%s\"",
5845 Perl_ck_subr(pTHX_ OP *o)
5847 OP *prev = ((cUNOPo->op_first->op_sibling)
5848 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
5849 OP *o2 = prev->op_sibling;
5856 I32 contextclass = 0;
5861 o->op_private |= OPpENTERSUB_HASTARG;
5862 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
5863 if (cvop->op_type == OP_RV2CV) {
5865 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
5866 op_null(cvop); /* disable rv2cv */
5867 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
5868 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
5869 GV *gv = cGVOPx_gv(tmpop);
5872 tmpop->op_private |= OPpEARLY_CV;
5875 namegv = CvANON(cv) ? gv : CvGV(cv);
5876 proto = SvPV((SV*)cv, n_a);
5878 if (CvASSERTION(cv)) {
5879 if (PL_hints & HINT_ASSERTING) {
5880 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
5881 o->op_private |= OPpENTERSUB_DB;
5885 if (ckWARN(WARN_ASSERTIONS) && !(PL_hints & HINT_ASSERTIONSSEEN)) {
5886 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
5887 "Impossible to activate assertion call");
5894 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
5895 if (o2->op_type == OP_CONST)
5896 o2->op_private &= ~OPpCONST_STRICT;
5897 else if (o2->op_type == OP_LIST) {
5898 OP *o = ((UNOP*)o2)->op_first->op_sibling;
5899 if (o && o->op_type == OP_CONST)
5900 o->op_private &= ~OPpCONST_STRICT;
5903 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5904 if (PERLDB_SUB && PL_curstash != PL_debstash)
5905 o->op_private |= OPpENTERSUB_DB;
5906 while (o2 != cvop) {
5910 return too_many_arguments(o, gv_ename(namegv));
5928 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
5930 arg == 1 ? "block or sub {}" : "sub {}",
5931 gv_ename(namegv), o2);
5934 /* '*' allows any scalar type, including bareword */
5937 if (o2->op_type == OP_RV2GV)
5938 goto wrapref; /* autoconvert GLOB -> GLOBref */
5939 else if (o2->op_type == OP_CONST)
5940 o2->op_private &= ~OPpCONST_STRICT;
5941 else if (o2->op_type == OP_ENTERSUB) {
5942 /* accidental subroutine, revert to bareword */
5943 OP *gvop = ((UNOP*)o2)->op_first;
5944 if (gvop && gvop->op_type == OP_NULL) {
5945 gvop = ((UNOP*)gvop)->op_first;
5947 for (; gvop->op_sibling; gvop = gvop->op_sibling)
5950 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
5951 (gvop = ((UNOP*)gvop)->op_first) &&
5952 gvop->op_type == OP_GV)
5954 GV *gv = cGVOPx_gv(gvop);
5955 OP *sibling = o2->op_sibling;
5956 SV *n = newSVpvn("",0);
5958 gv_fullname3(n, gv, "");
5959 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
5960 sv_chop(n, SvPVX(n)+6);
5961 o2 = newSVOP(OP_CONST, 0, n);
5962 prev->op_sibling = o2;
5963 o2->op_sibling = sibling;
5979 if (contextclass++ == 0) {
5980 e = strchr(proto, ']');
5981 if (!e || e == proto)
5994 while (*--p != '[');
5995 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
5996 gv_ename(namegv), o2);
6002 if (o2->op_type == OP_RV2GV)
6005 bad_type(arg, "symbol", gv_ename(namegv), o2);
6008 if (o2->op_type == OP_ENTERSUB)
6011 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6014 if (o2->op_type == OP_RV2SV ||
6015 o2->op_type == OP_PADSV ||
6016 o2->op_type == OP_HELEM ||
6017 o2->op_type == OP_AELEM ||
6018 o2->op_type == OP_THREADSV)
6021 bad_type(arg, "scalar", gv_ename(namegv), o2);
6024 if (o2->op_type == OP_RV2AV ||
6025 o2->op_type == OP_PADAV)
6028 bad_type(arg, "array", gv_ename(namegv), o2);
6031 if (o2->op_type == OP_RV2HV ||
6032 o2->op_type == OP_PADHV)
6035 bad_type(arg, "hash", gv_ename(namegv), o2);
6040 OP* sib = kid->op_sibling;
6041 kid->op_sibling = 0;
6042 o2 = newUNOP(OP_REFGEN, 0, kid);
6043 o2->op_sibling = sib;
6044 prev->op_sibling = o2;
6046 if (contextclass && e) {
6061 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6062 gv_ename(namegv), cv);
6067 mod(o2, OP_ENTERSUB);
6069 o2 = o2->op_sibling;
6071 if (proto && !optional &&
6072 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6073 return too_few_arguments(o, gv_ename(namegv));
6076 o=newSVOP(OP_CONST, 0, newSViv(0));
6082 Perl_ck_svconst(pTHX_ OP *o)
6084 SvREADONLY_on(cSVOPo->op_sv);
6089 Perl_ck_trunc(pTHX_ OP *o)
6091 if (o->op_flags & OPf_KIDS) {
6092 SVOP *kid = (SVOP*)cUNOPo->op_first;
6094 if (kid->op_type == OP_NULL)
6095 kid = (SVOP*)kid->op_sibling;
6096 if (kid && kid->op_type == OP_CONST &&
6097 (kid->op_private & OPpCONST_BARE))
6099 o->op_flags |= OPf_SPECIAL;
6100 kid->op_private &= ~OPpCONST_STRICT;
6107 Perl_ck_substr(pTHX_ OP *o)
6110 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6111 OP *kid = cLISTOPo->op_first;
6113 if (kid->op_type == OP_NULL)
6114 kid = kid->op_sibling;
6116 kid->op_flags |= OPf_MOD;
6122 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6125 Perl_peep(pTHX_ register OP *o)
6127 register OP* oldop = 0;
6129 if (!o || o->op_seq)
6133 SAVEVPTR(PL_curcop);
6134 for (; o; o = o->op_next) {
6137 /* The special value -1 is used by the B::C compiler backend to indicate
6138 * that an op is statically defined and should not be freed */
6139 if (!PL_op_seqmax || PL_op_seqmax == (U16)-1)
6142 switch (o->op_type) {
6146 PL_curcop = ((COP*)o); /* for warnings */
6147 o->op_seq = PL_op_seqmax++;
6151 if (cSVOPo->op_private & OPpCONST_STRICT)
6152 no_bareword_allowed(o);
6154 case OP_METHOD_NAMED:
6155 /* Relocate sv to the pad for thread safety.
6156 * Despite being a "constant", the SV is written to,
6157 * for reference counts, sv_upgrade() etc. */
6159 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6160 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6161 /* If op_sv is already a PADTMP then it is being used by
6162 * some pad, so make a copy. */
6163 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6164 SvREADONLY_on(PAD_SVl(ix));
6165 SvREFCNT_dec(cSVOPo->op_sv);
6168 SvREFCNT_dec(PAD_SVl(ix));
6169 SvPADTMP_on(cSVOPo->op_sv);
6170 PAD_SETSV(ix, cSVOPo->op_sv);
6171 /* XXX I don't know how this isn't readonly already. */
6172 SvREADONLY_on(PAD_SVl(ix));
6174 cSVOPo->op_sv = Nullsv;
6178 o->op_seq = PL_op_seqmax++;
6182 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6183 if (o->op_next->op_private & OPpTARGET_MY) {
6184 if (o->op_flags & OPf_STACKED) /* chained concats */
6185 goto ignore_optimization;
6187 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6188 o->op_targ = o->op_next->op_targ;
6189 o->op_next->op_targ = 0;
6190 o->op_private |= OPpTARGET_MY;
6193 op_null(o->op_next);
6195 ignore_optimization:
6196 o->op_seq = PL_op_seqmax++;
6199 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6200 o->op_seq = PL_op_seqmax++;
6201 break; /* Scalar stub must produce undef. List stub is noop */
6205 if (o->op_targ == OP_NEXTSTATE
6206 || o->op_targ == OP_DBSTATE
6207 || o->op_targ == OP_SETSTATE)
6209 PL_curcop = ((COP*)o);
6211 /* XXX: We avoid setting op_seq here to prevent later calls
6212 to peep() from mistakenly concluding that optimisation
6213 has already occurred. This doesn't fix the real problem,
6214 though (See 20010220.007). AMS 20010719 */
6215 if (oldop && o->op_next) {
6216 oldop->op_next = o->op_next;
6224 if (oldop && o->op_next) {
6225 oldop->op_next = o->op_next;
6228 o->op_seq = PL_op_seqmax++;
6232 if (o->op_next->op_type == OP_RV2SV) {
6233 if (!(o->op_next->op_private & OPpDEREF)) {
6234 op_null(o->op_next);
6235 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6237 o->op_next = o->op_next->op_next;
6238 o->op_type = OP_GVSV;
6239 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6242 else if (o->op_next->op_type == OP_RV2AV) {
6243 OP* pop = o->op_next->op_next;
6245 if (pop && pop->op_type == OP_CONST &&
6246 (PL_op = pop->op_next) &&
6247 pop->op_next->op_type == OP_AELEM &&
6248 !(pop->op_next->op_private &
6249 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6250 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6255 op_null(o->op_next);
6256 op_null(pop->op_next);
6258 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6259 o->op_next = pop->op_next->op_next;
6260 o->op_type = OP_AELEMFAST;
6261 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6262 o->op_private = (U8)i;
6267 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6269 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6270 /* XXX could check prototype here instead of just carping */
6271 SV *sv = sv_newmortal();
6272 gv_efullname3(sv, gv, Nullch);
6273 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6274 "%"SVf"() called too early to check prototype",
6278 else if (o->op_next->op_type == OP_READLINE
6279 && o->op_next->op_next->op_type == OP_CONCAT
6280 && (o->op_next->op_next->op_flags & OPf_STACKED))
6282 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6283 o->op_type = OP_RCATLINE;
6284 o->op_flags |= OPf_STACKED;
6285 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6286 op_null(o->op_next->op_next);
6287 op_null(o->op_next);
6290 o->op_seq = PL_op_seqmax++;
6303 o->op_seq = PL_op_seqmax++;
6304 while (cLOGOP->op_other->op_type == OP_NULL)
6305 cLOGOP->op_other = cLOGOP->op_other->op_next;
6306 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6311 o->op_seq = PL_op_seqmax++;
6312 while (cLOOP->op_redoop->op_type == OP_NULL)
6313 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6314 peep(cLOOP->op_redoop);
6315 while (cLOOP->op_nextop->op_type == OP_NULL)
6316 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6317 peep(cLOOP->op_nextop);
6318 while (cLOOP->op_lastop->op_type == OP_NULL)
6319 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6320 peep(cLOOP->op_lastop);
6326 o->op_seq = PL_op_seqmax++;
6327 while (cPMOP->op_pmreplstart &&
6328 cPMOP->op_pmreplstart->op_type == OP_NULL)
6329 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6330 peep(cPMOP->op_pmreplstart);
6334 o->op_seq = PL_op_seqmax++;
6335 if (ckWARN(WARN_SYNTAX) && o->op_next
6336 && o->op_next->op_type == OP_NEXTSTATE) {
6337 if (o->op_next->op_sibling &&
6338 o->op_next->op_sibling->op_type != OP_EXIT &&
6339 o->op_next->op_sibling->op_type != OP_WARN &&
6340 o->op_next->op_sibling->op_type != OP_DIE) {
6341 line_t oldline = CopLINE(PL_curcop);
6343 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6344 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6345 "Statement unlikely to be reached");
6346 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6347 "\t(Maybe you meant system() when you said exec()?)\n");
6348 CopLINE_set(PL_curcop, oldline);
6359 o->op_seq = PL_op_seqmax++;
6361 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6364 /* Make the CONST have a shared SV */
6365 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6366 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6367 key = SvPV(sv, keylen);
6368 lexname = newSVpvn_share(key,
6369 SvUTF8(sv) ? -(I32)keylen : keylen,
6378 o->op_seq = PL_op_seqmax++;
6388 char* Perl_custom_op_name(pTHX_ OP* o)
6390 IV index = PTR2IV(o->op_ppaddr);
6394 if (!PL_custom_op_names) /* This probably shouldn't happen */
6395 return PL_op_name[OP_CUSTOM];
6397 keysv = sv_2mortal(newSViv(index));
6399 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
6401 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
6403 return SvPV_nolen(HeVAL(he));
6406 char* Perl_custom_op_desc(pTHX_ OP* o)
6408 IV index = PTR2IV(o->op_ppaddr);
6412 if (!PL_custom_op_descs)
6413 return PL_op_desc[OP_CUSTOM];
6415 keysv = sv_2mortal(newSViv(index));
6417 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
6419 return PL_op_desc[OP_CUSTOM];
6421 return SvPV_nolen(HeVAL(he));
6427 /* Efficient sub that returns a constant scalar value. */
6429 const_sv_xsub(pTHX_ CV* cv)
6434 Perl_croak(aTHX_ "usage: %s::%s()",
6435 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
6439 ST(0) = (SV*)XSANY.any_ptr;