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));
4939 if (type == OP_FTTTY)
4940 o = newGVOP(type, OPf_REF, PL_stdingv);
4942 o = newUNOP(type, 0, newDEFSVOP());
4948 Perl_ck_fun(pTHX_ OP *o)
4954 int type = o->op_type;
4955 register I32 oa = PL_opargs[type] >> OASHIFT;
4957 if (o->op_flags & OPf_STACKED) {
4958 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
4961 return no_fh_allowed(o);
4964 if (o->op_flags & OPf_KIDS) {
4966 tokid = &cLISTOPo->op_first;
4967 kid = cLISTOPo->op_first;
4968 if (kid->op_type == OP_PUSHMARK ||
4969 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
4971 tokid = &kid->op_sibling;
4972 kid = kid->op_sibling;
4974 if (!kid && PL_opargs[type] & OA_DEFGV)
4975 *tokid = kid = newDEFSVOP();
4979 sibl = kid->op_sibling;
4982 /* list seen where single (scalar) arg expected? */
4983 if (numargs == 1 && !(oa >> 4)
4984 && kid->op_type == OP_LIST && type != OP_SCALAR)
4986 return too_many_arguments(o,PL_op_desc[type]);
4999 if ((type == OP_PUSH || type == OP_UNSHIFT)
5000 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5001 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5002 "Useless use of %s with no values",
5005 if (kid->op_type == OP_CONST &&
5006 (kid->op_private & OPpCONST_BARE))
5008 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5009 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5010 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5011 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5012 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5013 "Array @%s missing the @ in argument %"IVdf" of %s()",
5014 name, (IV)numargs, PL_op_desc[type]);
5017 kid->op_sibling = sibl;
5020 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5021 bad_type(numargs, "array", PL_op_desc[type], kid);
5025 if (kid->op_type == OP_CONST &&
5026 (kid->op_private & OPpCONST_BARE))
5028 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5029 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5030 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5031 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5032 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5033 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5034 name, (IV)numargs, PL_op_desc[type]);
5037 kid->op_sibling = sibl;
5040 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5041 bad_type(numargs, "hash", PL_op_desc[type], kid);
5046 OP *newop = newUNOP(OP_NULL, 0, kid);
5047 kid->op_sibling = 0;
5049 newop->op_next = newop;
5051 kid->op_sibling = sibl;
5056 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5057 if (kid->op_type == OP_CONST &&
5058 (kid->op_private & OPpCONST_BARE))
5060 OP *newop = newGVOP(OP_GV, 0,
5061 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5063 if (!(o->op_private & 1) && /* if not unop */
5064 kid == cLISTOPo->op_last)
5065 cLISTOPo->op_last = newop;
5069 else if (kid->op_type == OP_READLINE) {
5070 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5071 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5074 I32 flags = OPf_SPECIAL;
5078 /* is this op a FH constructor? */
5079 if (is_handle_constructor(o,numargs)) {
5080 char *name = Nullch;
5084 /* Set a flag to tell rv2gv to vivify
5085 * need to "prove" flag does not mean something
5086 * else already - NI-S 1999/05/07
5089 if (kid->op_type == OP_PADSV) {
5090 /*XXX DAPM 2002.08.25 tmp assert test */
5091 /*XXX*/ assert(av_fetch(PL_comppad_name, (kid->op_targ), FALSE));
5092 /*XXX*/ assert(*av_fetch(PL_comppad_name, (kid->op_targ), FALSE));
5094 name = PAD_COMPNAME_PV(kid->op_targ);
5095 /* SvCUR of a pad namesv can't be trusted
5096 * (see PL_generation), so calc its length
5102 else if (kid->op_type == OP_RV2SV
5103 && kUNOP->op_first->op_type == OP_GV)
5105 GV *gv = cGVOPx_gv(kUNOP->op_first);
5107 len = GvNAMELEN(gv);
5109 else if (kid->op_type == OP_AELEM
5110 || kid->op_type == OP_HELEM)
5115 if ((op = ((BINOP*)kid)->op_first)) {
5116 SV *tmpstr = Nullsv;
5118 kid->op_type == OP_AELEM ?
5120 if (((op->op_type == OP_RV2AV) ||
5121 (op->op_type == OP_RV2HV)) &&
5122 (op = ((UNOP*)op)->op_first) &&
5123 (op->op_type == OP_GV)) {
5124 /* packagevar $a[] or $h{} */
5125 GV *gv = cGVOPx_gv(op);
5133 else if (op->op_type == OP_PADAV
5134 || op->op_type == OP_PADHV) {
5135 /* lexicalvar $a[] or $h{} */
5137 PAD_COMPNAME_PV(op->op_targ);
5147 name = savepv(SvPVX(tmpstr));
5153 name = "__ANONIO__";
5160 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5161 namesv = PAD_SVl(targ);
5162 (void)SvUPGRADE(namesv, SVt_PV);
5164 sv_setpvn(namesv, "$", 1);
5165 sv_catpvn(namesv, name, len);
5168 kid->op_sibling = 0;
5169 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5170 kid->op_targ = targ;
5171 kid->op_private |= priv;
5173 kid->op_sibling = sibl;
5179 mod(scalar(kid), type);
5183 tokid = &kid->op_sibling;
5184 kid = kid->op_sibling;
5186 o->op_private |= numargs;
5188 return too_many_arguments(o,OP_DESC(o));
5191 else if (PL_opargs[type] & OA_DEFGV) {
5193 return newUNOP(type, 0, newDEFSVOP());
5197 while (oa & OA_OPTIONAL)
5199 if (oa && oa != OA_LIST)
5200 return too_few_arguments(o,OP_DESC(o));
5206 Perl_ck_glob(pTHX_ OP *o)
5211 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5212 append_elem(OP_GLOB, o, newDEFSVOP());
5214 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5215 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5217 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5220 #if !defined(PERL_EXTERNAL_GLOB)
5221 /* XXX this can be tightened up and made more failsafe. */
5225 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5226 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5227 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5228 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5229 GvCV(gv) = GvCV(glob_gv);
5230 SvREFCNT_inc((SV*)GvCV(gv));
5231 GvIMPORTED_CV_on(gv);
5234 #endif /* PERL_EXTERNAL_GLOB */
5236 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5237 append_elem(OP_GLOB, o,
5238 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5239 o->op_type = OP_LIST;
5240 o->op_ppaddr = PL_ppaddr[OP_LIST];
5241 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5242 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5243 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5244 append_elem(OP_LIST, o,
5245 scalar(newUNOP(OP_RV2CV, 0,
5246 newGVOP(OP_GV, 0, gv)))));
5247 o = newUNOP(OP_NULL, 0, ck_subr(o));
5248 o->op_targ = OP_GLOB; /* hint at what it used to be */
5251 gv = newGVgen("main");
5253 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5259 Perl_ck_grep(pTHX_ OP *o)
5263 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5265 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5266 NewOp(1101, gwop, 1, LOGOP);
5268 if (o->op_flags & OPf_STACKED) {
5271 kid = cLISTOPo->op_first->op_sibling;
5272 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5275 kid->op_next = (OP*)gwop;
5276 o->op_flags &= ~OPf_STACKED;
5278 kid = cLISTOPo->op_first->op_sibling;
5279 if (type == OP_MAPWHILE)
5286 kid = cLISTOPo->op_first->op_sibling;
5287 if (kid->op_type != OP_NULL)
5288 Perl_croak(aTHX_ "panic: ck_grep");
5289 kid = kUNOP->op_first;
5291 gwop->op_type = type;
5292 gwop->op_ppaddr = PL_ppaddr[type];
5293 gwop->op_first = listkids(o);
5294 gwop->op_flags |= OPf_KIDS;
5295 gwop->op_private = 1;
5296 gwop->op_other = LINKLIST(kid);
5297 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5298 kid->op_next = (OP*)gwop;
5300 kid = cLISTOPo->op_first->op_sibling;
5301 if (!kid || !kid->op_sibling)
5302 return too_few_arguments(o,OP_DESC(o));
5303 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5304 mod(kid, OP_GREPSTART);
5310 Perl_ck_index(pTHX_ OP *o)
5312 if (o->op_flags & OPf_KIDS) {
5313 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5315 kid = kid->op_sibling; /* get past "big" */
5316 if (kid && kid->op_type == OP_CONST)
5317 fbm_compile(((SVOP*)kid)->op_sv, 0);
5323 Perl_ck_lengthconst(pTHX_ OP *o)
5325 /* XXX length optimization goes here */
5330 Perl_ck_lfun(pTHX_ OP *o)
5332 OPCODE type = o->op_type;
5333 return modkids(ck_fun(o), type);
5337 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5339 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5340 switch (cUNOPo->op_first->op_type) {
5342 /* This is needed for
5343 if (defined %stash::)
5344 to work. Do not break Tk.
5346 break; /* Globals via GV can be undef */
5348 case OP_AASSIGN: /* Is this a good idea? */
5349 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5350 "defined(@array) is deprecated");
5351 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5352 "\t(Maybe you should just omit the defined()?)\n");
5355 /* This is needed for
5356 if (defined %stash::)
5357 to work. Do not break Tk.
5359 break; /* Globals via GV can be undef */
5361 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5362 "defined(%%hash) is deprecated");
5363 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5364 "\t(Maybe you should just omit the defined()?)\n");
5375 Perl_ck_rfun(pTHX_ OP *o)
5377 OPCODE type = o->op_type;
5378 return refkids(ck_fun(o), type);
5382 Perl_ck_listiob(pTHX_ OP *o)
5386 kid = cLISTOPo->op_first;
5389 kid = cLISTOPo->op_first;
5391 if (kid->op_type == OP_PUSHMARK)
5392 kid = kid->op_sibling;
5393 if (kid && o->op_flags & OPf_STACKED)
5394 kid = kid->op_sibling;
5395 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5396 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5397 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5398 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5399 cLISTOPo->op_first->op_sibling = kid;
5400 cLISTOPo->op_last = kid;
5401 kid = kid->op_sibling;
5406 append_elem(o->op_type, o, newDEFSVOP());
5412 Perl_ck_sassign(pTHX_ OP *o)
5414 OP *kid = cLISTOPo->op_first;
5415 /* has a disposable target? */
5416 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5417 && !(kid->op_flags & OPf_STACKED)
5418 /* Cannot steal the second time! */
5419 && !(kid->op_private & OPpTARGET_MY))
5421 OP *kkid = kid->op_sibling;
5423 /* Can just relocate the target. */
5424 if (kkid && kkid->op_type == OP_PADSV
5425 && !(kkid->op_private & OPpLVAL_INTRO))
5427 kid->op_targ = kkid->op_targ;
5429 /* Now we do not need PADSV and SASSIGN. */
5430 kid->op_sibling = o->op_sibling; /* NULL */
5431 cLISTOPo->op_first = NULL;
5434 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
5442 Perl_ck_match(pTHX_ OP *o)
5444 o->op_private |= OPpRUNTIME;
5449 Perl_ck_method(pTHX_ OP *o)
5451 OP *kid = cUNOPo->op_first;
5452 if (kid->op_type == OP_CONST) {
5453 SV* sv = kSVOP->op_sv;
5454 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
5456 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5457 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
5460 kSVOP->op_sv = Nullsv;
5462 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5471 Perl_ck_null(pTHX_ OP *o)
5477 Perl_ck_open(pTHX_ OP *o)
5479 HV *table = GvHV(PL_hintgv);
5483 svp = hv_fetch(table, "open_IN", 7, FALSE);
5485 mode = mode_from_discipline(*svp);
5486 if (mode & O_BINARY)
5487 o->op_private |= OPpOPEN_IN_RAW;
5488 else if (mode & O_TEXT)
5489 o->op_private |= OPpOPEN_IN_CRLF;
5492 svp = hv_fetch(table, "open_OUT", 8, FALSE);
5494 mode = mode_from_discipline(*svp);
5495 if (mode & O_BINARY)
5496 o->op_private |= OPpOPEN_OUT_RAW;
5497 else if (mode & O_TEXT)
5498 o->op_private |= OPpOPEN_OUT_CRLF;
5501 if (o->op_type == OP_BACKTICK)
5504 /* In case of three-arg dup open remove strictness
5505 * from the last arg if it is a bareword. */
5506 OP *first = cLISTOPx(o)->op_first; /* The pushmark. */
5507 OP *last = cLISTOPx(o)->op_last; /* The bareword. */
5511 if ((last->op_type == OP_CONST) && /* The bareword. */
5512 (last->op_private & OPpCONST_BARE) &&
5513 (last->op_private & OPpCONST_STRICT) &&
5514 (oa = first->op_sibling) && /* The fh. */
5515 (oa = oa->op_sibling) && /* The mode. */
5516 SvPOK(((SVOP*)oa)->op_sv) &&
5517 (mode = SvPVX(((SVOP*)oa)->op_sv)) &&
5518 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
5519 (last == oa->op_sibling)) /* The bareword. */
5520 last->op_private &= ~OPpCONST_STRICT;
5526 Perl_ck_repeat(pTHX_ OP *o)
5528 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5529 o->op_private |= OPpREPEAT_DOLIST;
5530 cBINOPo->op_first = force_list(cBINOPo->op_first);
5538 Perl_ck_require(pTHX_ OP *o)
5542 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
5543 SVOP *kid = (SVOP*)cUNOPo->op_first;
5545 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5547 for (s = SvPVX(kid->op_sv); *s; s++) {
5548 if (*s == ':' && s[1] == ':') {
5550 Move(s+2, s+1, strlen(s+2)+1, char);
5551 --SvCUR(kid->op_sv);
5554 if (SvREADONLY(kid->op_sv)) {
5555 SvREADONLY_off(kid->op_sv);
5556 sv_catpvn(kid->op_sv, ".pm", 3);
5557 SvREADONLY_on(kid->op_sv);
5560 sv_catpvn(kid->op_sv, ".pm", 3);
5564 /* handle override, if any */
5565 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
5566 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
5567 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
5569 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5570 OP *kid = cUNOPo->op_first;
5571 cUNOPo->op_first = 0;
5573 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5574 append_elem(OP_LIST, kid,
5575 scalar(newUNOP(OP_RV2CV, 0,
5584 Perl_ck_return(pTHX_ OP *o)
5587 if (CvLVALUE(PL_compcv)) {
5588 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5589 mod(kid, OP_LEAVESUBLV);
5596 Perl_ck_retarget(pTHX_ OP *o)
5598 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5605 Perl_ck_select(pTHX_ OP *o)
5608 if (o->op_flags & OPf_KIDS) {
5609 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5610 if (kid && kid->op_sibling) {
5611 o->op_type = OP_SSELECT;
5612 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
5614 return fold_constants(o);
5618 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5619 if (kid && kid->op_type == OP_RV2GV)
5620 kid->op_private &= ~HINT_STRICT_REFS;
5625 Perl_ck_shift(pTHX_ OP *o)
5627 I32 type = o->op_type;
5629 if (!(o->op_flags & OPf_KIDS)) {
5633 argop = newUNOP(OP_RV2AV, 0,
5634 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
5635 return newUNOP(type, 0, scalar(argop));
5637 return scalar(modkids(ck_fun(o), type));
5641 Perl_ck_sort(pTHX_ OP *o)
5645 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
5647 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5648 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
5650 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
5652 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
5654 if (kid->op_type == OP_SCOPE) {
5658 else if (kid->op_type == OP_LEAVE) {
5659 if (o->op_type == OP_SORT) {
5660 op_null(kid); /* wipe out leave */
5663 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
5664 if (k->op_next == kid)
5666 /* don't descend into loops */
5667 else if (k->op_type == OP_ENTERLOOP
5668 || k->op_type == OP_ENTERITER)
5670 k = cLOOPx(k)->op_lastop;
5675 kid->op_next = 0; /* just disconnect the leave */
5676 k = kLISTOP->op_first;
5681 if (o->op_type == OP_SORT) {
5682 /* provide scalar context for comparison function/block */
5688 o->op_flags |= OPf_SPECIAL;
5690 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
5693 firstkid = firstkid->op_sibling;
5696 /* provide list context for arguments */
5697 if (o->op_type == OP_SORT)
5704 S_simplify_sort(pTHX_ OP *o)
5706 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5710 if (!(o->op_flags & OPf_STACKED))
5712 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
5713 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
5714 kid = kUNOP->op_first; /* get past null */
5715 if (kid->op_type != OP_SCOPE)
5717 kid = kLISTOP->op_last; /* get past scope */
5718 switch(kid->op_type) {
5726 k = kid; /* remember this node*/
5727 if (kBINOP->op_first->op_type != OP_RV2SV)
5729 kid = kBINOP->op_first; /* get past cmp */
5730 if (kUNOP->op_first->op_type != OP_GV)
5732 kid = kUNOP->op_first; /* get past rv2sv */
5734 if (GvSTASH(gv) != PL_curstash)
5736 if (strEQ(GvNAME(gv), "a"))
5738 else if (strEQ(GvNAME(gv), "b"))
5742 kid = k; /* back to cmp */
5743 if (kBINOP->op_last->op_type != OP_RV2SV)
5745 kid = kBINOP->op_last; /* down to 2nd arg */
5746 if (kUNOP->op_first->op_type != OP_GV)
5748 kid = kUNOP->op_first; /* get past rv2sv */
5750 if (GvSTASH(gv) != PL_curstash
5752 ? strNE(GvNAME(gv), "a")
5753 : strNE(GvNAME(gv), "b")))
5755 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
5757 o->op_private |= OPpSORT_REVERSE;
5758 if (k->op_type == OP_NCMP)
5759 o->op_private |= OPpSORT_NUMERIC;
5760 if (k->op_type == OP_I_NCMP)
5761 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
5762 kid = cLISTOPo->op_first->op_sibling;
5763 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
5764 op_free(kid); /* then delete it */
5768 Perl_ck_split(pTHX_ OP *o)
5772 if (o->op_flags & OPf_STACKED)
5773 return no_fh_allowed(o);
5775 kid = cLISTOPo->op_first;
5776 if (kid->op_type != OP_NULL)
5777 Perl_croak(aTHX_ "panic: ck_split");
5778 kid = kid->op_sibling;
5779 op_free(cLISTOPo->op_first);
5780 cLISTOPo->op_first = kid;
5782 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
5783 cLISTOPo->op_last = kid; /* There was only one element previously */
5786 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
5787 OP *sibl = kid->op_sibling;
5788 kid->op_sibling = 0;
5789 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
5790 if (cLISTOPo->op_first == cLISTOPo->op_last)
5791 cLISTOPo->op_last = kid;
5792 cLISTOPo->op_first = kid;
5793 kid->op_sibling = sibl;
5796 kid->op_type = OP_PUSHRE;
5797 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
5799 if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
5800 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
5801 "Use of /g modifier is meaningless in split");
5804 if (!kid->op_sibling)
5805 append_elem(OP_SPLIT, o, newDEFSVOP());
5807 kid = kid->op_sibling;
5810 if (!kid->op_sibling)
5811 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
5813 kid = kid->op_sibling;
5816 if (kid->op_sibling)
5817 return too_many_arguments(o,OP_DESC(o));
5823 Perl_ck_join(pTHX_ OP *o)
5825 if (ckWARN(WARN_SYNTAX)) {
5826 OP *kid = cLISTOPo->op_first->op_sibling;
5827 if (kid && kid->op_type == OP_MATCH) {
5828 char *pmstr = "STRING";
5829 if (PM_GETRE(kPMOP))
5830 pmstr = PM_GETRE(kPMOP)->precomp;
5831 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5832 "/%s/ should probably be written as \"%s\"",
5840 Perl_ck_subr(pTHX_ OP *o)
5842 OP *prev = ((cUNOPo->op_first->op_sibling)
5843 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
5844 OP *o2 = prev->op_sibling;
5851 I32 contextclass = 0;
5856 o->op_private |= OPpENTERSUB_HASTARG;
5857 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
5858 if (cvop->op_type == OP_RV2CV) {
5860 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
5861 op_null(cvop); /* disable rv2cv */
5862 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
5863 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
5864 GV *gv = cGVOPx_gv(tmpop);
5867 tmpop->op_private |= OPpEARLY_CV;
5870 namegv = CvANON(cv) ? gv : CvGV(cv);
5871 proto = SvPV((SV*)cv, n_a);
5873 if (CvASSERTION(cv)) {
5874 if (PL_hints & HINT_ASSERTING) {
5875 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
5876 o->op_private |= OPpENTERSUB_DB;
5880 if (ckWARN(WARN_ASSERTIONS) && !(PL_hints & HINT_ASSERTIONSSEEN)) {
5881 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
5882 "Impossible to activate assertion call");
5889 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
5890 if (o2->op_type == OP_CONST)
5891 o2->op_private &= ~OPpCONST_STRICT;
5892 else if (o2->op_type == OP_LIST) {
5893 OP *o = ((UNOP*)o2)->op_first->op_sibling;
5894 if (o && o->op_type == OP_CONST)
5895 o->op_private &= ~OPpCONST_STRICT;
5898 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5899 if (PERLDB_SUB && PL_curstash != PL_debstash)
5900 o->op_private |= OPpENTERSUB_DB;
5901 while (o2 != cvop) {
5905 return too_many_arguments(o, gv_ename(namegv));
5923 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
5925 arg == 1 ? "block or sub {}" : "sub {}",
5926 gv_ename(namegv), o2);
5929 /* '*' allows any scalar type, including bareword */
5932 if (o2->op_type == OP_RV2GV)
5933 goto wrapref; /* autoconvert GLOB -> GLOBref */
5934 else if (o2->op_type == OP_CONST)
5935 o2->op_private &= ~OPpCONST_STRICT;
5936 else if (o2->op_type == OP_ENTERSUB) {
5937 /* accidental subroutine, revert to bareword */
5938 OP *gvop = ((UNOP*)o2)->op_first;
5939 if (gvop && gvop->op_type == OP_NULL) {
5940 gvop = ((UNOP*)gvop)->op_first;
5942 for (; gvop->op_sibling; gvop = gvop->op_sibling)
5945 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
5946 (gvop = ((UNOP*)gvop)->op_first) &&
5947 gvop->op_type == OP_GV)
5949 GV *gv = cGVOPx_gv(gvop);
5950 OP *sibling = o2->op_sibling;
5951 SV *n = newSVpvn("",0);
5953 gv_fullname3(n, gv, "");
5954 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
5955 sv_chop(n, SvPVX(n)+6);
5956 o2 = newSVOP(OP_CONST, 0, n);
5957 prev->op_sibling = o2;
5958 o2->op_sibling = sibling;
5974 if (contextclass++ == 0) {
5975 e = strchr(proto, ']');
5976 if (!e || e == proto)
5989 while (*--p != '[');
5990 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
5991 gv_ename(namegv), o2);
5997 if (o2->op_type == OP_RV2GV)
6000 bad_type(arg, "symbol", gv_ename(namegv), o2);
6003 if (o2->op_type == OP_ENTERSUB)
6006 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6009 if (o2->op_type == OP_RV2SV ||
6010 o2->op_type == OP_PADSV ||
6011 o2->op_type == OP_HELEM ||
6012 o2->op_type == OP_AELEM ||
6013 o2->op_type == OP_THREADSV)
6016 bad_type(arg, "scalar", gv_ename(namegv), o2);
6019 if (o2->op_type == OP_RV2AV ||
6020 o2->op_type == OP_PADAV)
6023 bad_type(arg, "array", gv_ename(namegv), o2);
6026 if (o2->op_type == OP_RV2HV ||
6027 o2->op_type == OP_PADHV)
6030 bad_type(arg, "hash", gv_ename(namegv), o2);
6035 OP* sib = kid->op_sibling;
6036 kid->op_sibling = 0;
6037 o2 = newUNOP(OP_REFGEN, 0, kid);
6038 o2->op_sibling = sib;
6039 prev->op_sibling = o2;
6041 if (contextclass && e) {
6056 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6057 gv_ename(namegv), cv);
6062 mod(o2, OP_ENTERSUB);
6064 o2 = o2->op_sibling;
6066 if (proto && !optional &&
6067 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6068 return too_few_arguments(o, gv_ename(namegv));
6071 o=newSVOP(OP_CONST, 0, newSViv(0));
6077 Perl_ck_svconst(pTHX_ OP *o)
6079 SvREADONLY_on(cSVOPo->op_sv);
6084 Perl_ck_trunc(pTHX_ OP *o)
6086 if (o->op_flags & OPf_KIDS) {
6087 SVOP *kid = (SVOP*)cUNOPo->op_first;
6089 if (kid->op_type == OP_NULL)
6090 kid = (SVOP*)kid->op_sibling;
6091 if (kid && kid->op_type == OP_CONST &&
6092 (kid->op_private & OPpCONST_BARE))
6094 o->op_flags |= OPf_SPECIAL;
6095 kid->op_private &= ~OPpCONST_STRICT;
6102 Perl_ck_substr(pTHX_ OP *o)
6105 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6106 OP *kid = cLISTOPo->op_first;
6108 if (kid->op_type == OP_NULL)
6109 kid = kid->op_sibling;
6111 kid->op_flags |= OPf_MOD;
6117 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6120 Perl_peep(pTHX_ register OP *o)
6122 register OP* oldop = 0;
6124 if (!o || o->op_seq)
6128 SAVEVPTR(PL_curcop);
6129 for (; o; o = o->op_next) {
6132 /* The special value -1 is used by the B::C compiler backend to indicate
6133 * that an op is statically defined and should not be freed */
6134 if (!PL_op_seqmax || PL_op_seqmax == (U16)-1)
6137 switch (o->op_type) {
6141 PL_curcop = ((COP*)o); /* for warnings */
6142 o->op_seq = PL_op_seqmax++;
6146 if (cSVOPo->op_private & OPpCONST_STRICT)
6147 no_bareword_allowed(o);
6149 case OP_METHOD_NAMED:
6150 /* Relocate sv to the pad for thread safety.
6151 * Despite being a "constant", the SV is written to,
6152 * for reference counts, sv_upgrade() etc. */
6154 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6155 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6156 /* If op_sv is already a PADTMP then it is being used by
6157 * some pad, so make a copy. */
6158 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6159 SvREADONLY_on(PAD_SVl(ix));
6160 SvREFCNT_dec(cSVOPo->op_sv);
6163 SvREFCNT_dec(PAD_SVl(ix));
6164 SvPADTMP_on(cSVOPo->op_sv);
6165 PAD_SETSV(ix, cSVOPo->op_sv);
6166 /* XXX I don't know how this isn't readonly already. */
6167 SvREADONLY_on(PAD_SVl(ix));
6169 cSVOPo->op_sv = Nullsv;
6173 o->op_seq = PL_op_seqmax++;
6177 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6178 if (o->op_next->op_private & OPpTARGET_MY) {
6179 if (o->op_flags & OPf_STACKED) /* chained concats */
6180 goto ignore_optimization;
6182 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6183 o->op_targ = o->op_next->op_targ;
6184 o->op_next->op_targ = 0;
6185 o->op_private |= OPpTARGET_MY;
6188 op_null(o->op_next);
6190 ignore_optimization:
6191 o->op_seq = PL_op_seqmax++;
6194 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6195 o->op_seq = PL_op_seqmax++;
6196 break; /* Scalar stub must produce undef. List stub is noop */
6200 if (o->op_targ == OP_NEXTSTATE
6201 || o->op_targ == OP_DBSTATE
6202 || o->op_targ == OP_SETSTATE)
6204 PL_curcop = ((COP*)o);
6206 /* XXX: We avoid setting op_seq here to prevent later calls
6207 to peep() from mistakenly concluding that optimisation
6208 has already occurred. This doesn't fix the real problem,
6209 though (See 20010220.007). AMS 20010719 */
6210 if (oldop && o->op_next) {
6211 oldop->op_next = o->op_next;
6219 if (oldop && o->op_next) {
6220 oldop->op_next = o->op_next;
6223 o->op_seq = PL_op_seqmax++;
6227 if (o->op_next->op_type == OP_RV2SV) {
6228 if (!(o->op_next->op_private & OPpDEREF)) {
6229 op_null(o->op_next);
6230 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6232 o->op_next = o->op_next->op_next;
6233 o->op_type = OP_GVSV;
6234 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6237 else if (o->op_next->op_type == OP_RV2AV) {
6238 OP* pop = o->op_next->op_next;
6240 if (pop && pop->op_type == OP_CONST &&
6241 (PL_op = pop->op_next) &&
6242 pop->op_next->op_type == OP_AELEM &&
6243 !(pop->op_next->op_private &
6244 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6245 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6250 op_null(o->op_next);
6251 op_null(pop->op_next);
6253 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6254 o->op_next = pop->op_next->op_next;
6255 o->op_type = OP_AELEMFAST;
6256 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6257 o->op_private = (U8)i;
6262 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6264 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6265 /* XXX could check prototype here instead of just carping */
6266 SV *sv = sv_newmortal();
6267 gv_efullname3(sv, gv, Nullch);
6268 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6269 "%"SVf"() called too early to check prototype",
6273 else if (o->op_next->op_type == OP_READLINE
6274 && o->op_next->op_next->op_type == OP_CONCAT
6275 && (o->op_next->op_next->op_flags & OPf_STACKED))
6277 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6278 o->op_type = OP_RCATLINE;
6279 o->op_flags |= OPf_STACKED;
6280 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6281 op_null(o->op_next->op_next);
6282 op_null(o->op_next);
6285 o->op_seq = PL_op_seqmax++;
6298 o->op_seq = PL_op_seqmax++;
6299 while (cLOGOP->op_other->op_type == OP_NULL)
6300 cLOGOP->op_other = cLOGOP->op_other->op_next;
6301 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6306 o->op_seq = PL_op_seqmax++;
6307 while (cLOOP->op_redoop->op_type == OP_NULL)
6308 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6309 peep(cLOOP->op_redoop);
6310 while (cLOOP->op_nextop->op_type == OP_NULL)
6311 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6312 peep(cLOOP->op_nextop);
6313 while (cLOOP->op_lastop->op_type == OP_NULL)
6314 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6315 peep(cLOOP->op_lastop);
6321 o->op_seq = PL_op_seqmax++;
6322 while (cPMOP->op_pmreplstart &&
6323 cPMOP->op_pmreplstart->op_type == OP_NULL)
6324 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6325 peep(cPMOP->op_pmreplstart);
6329 o->op_seq = PL_op_seqmax++;
6330 if (ckWARN(WARN_SYNTAX) && o->op_next
6331 && o->op_next->op_type == OP_NEXTSTATE) {
6332 if (o->op_next->op_sibling &&
6333 o->op_next->op_sibling->op_type != OP_EXIT &&
6334 o->op_next->op_sibling->op_type != OP_WARN &&
6335 o->op_next->op_sibling->op_type != OP_DIE) {
6336 line_t oldline = CopLINE(PL_curcop);
6338 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6339 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6340 "Statement unlikely to be reached");
6341 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6342 "\t(Maybe you meant system() when you said exec()?)\n");
6343 CopLINE_set(PL_curcop, oldline);
6354 o->op_seq = PL_op_seqmax++;
6356 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6359 /* Make the CONST have a shared SV */
6360 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6361 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6362 key = SvPV(sv, keylen);
6363 lexname = newSVpvn_share(key,
6364 SvUTF8(sv) ? -(I32)keylen : keylen,
6373 o->op_seq = PL_op_seqmax++;
6383 char* Perl_custom_op_name(pTHX_ OP* o)
6385 IV index = PTR2IV(o->op_ppaddr);
6389 if (!PL_custom_op_names) /* This probably shouldn't happen */
6390 return PL_op_name[OP_CUSTOM];
6392 keysv = sv_2mortal(newSViv(index));
6394 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
6396 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
6398 return SvPV_nolen(HeVAL(he));
6401 char* Perl_custom_op_desc(pTHX_ OP* o)
6403 IV index = PTR2IV(o->op_ppaddr);
6407 if (!PL_custom_op_descs)
6408 return PL_op_desc[OP_CUSTOM];
6410 keysv = sv_2mortal(newSViv(index));
6412 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
6414 return PL_op_desc[OP_CUSTOM];
6416 return SvPV_nolen(HeVAL(he));
6422 /* Efficient sub that returns a constant scalar value. */
6424 const_sv_xsub(pTHX_ CV* cv)
6429 Perl_croak(aTHX_ "usage: %s::%s()",
6430 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
6434 ST(0) = (SV*)XSANY.any_ptr;