3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
13 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
14 * youngest of the Old Took's daughters); and Mr. Drogo was his second
15 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
16 * either way, as the saying is, if you follow me." --the Gaffer
25 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
27 #if defined(PL_OP_SLAB_ALLOC)
29 #ifndef PERL_SLAB_SIZE
30 #define PERL_SLAB_SIZE 2048
33 #define NewOp(m,var,c,type) \
34 STMT_START { var = (type *) Slab_Alloc(m,c*sizeof(type)); } STMT_END
36 #define FreeOp(p) Slab_Free(p)
39 S_Slab_Alloc(pTHX_ int m, size_t sz)
42 * To make incrementing use count easy PL_OpSlab is an I32 *
43 * To make inserting the link to slab PL_OpPtr is I32 **
44 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
45 * Add an overhead for pointer to slab and round up as a number of pointers
47 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
48 if ((PL_OpSpace -= sz) < 0) {
49 PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*));
53 Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **);
54 /* We reserve the 0'th I32 sized chunk as a use count */
55 PL_OpSlab = (I32 *) PL_OpPtr;
56 /* Reduce size by the use count word, and by the size we need.
57 * Latter is to mimic the '-=' in the if() above
59 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
60 /* Allocation pointer starts at the top.
61 Theory: because we build leaves before trunk allocating at end
62 means that at run time access is cache friendly upward
64 PL_OpPtr += PERL_SLAB_SIZE;
66 assert( PL_OpSpace >= 0 );
67 /* Move the allocation pointer down */
69 assert( PL_OpPtr > (I32 **) PL_OpSlab );
70 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
71 (*PL_OpSlab)++; /* Increment use count of slab */
72 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
73 assert( *PL_OpSlab > 0 );
74 return (void *)(PL_OpPtr + 1);
78 S_Slab_Free(pTHX_ void *op)
80 I32 **ptr = (I32 **) op;
82 assert( ptr-1 > (I32 **) slab );
83 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
87 #define PerlMemShared PerlMem
90 PerlMemShared_free(slab);
91 if (slab == PL_OpSlab) {
98 #define NewOp(m, var, c, type) Newz(m, var, c, type)
99 #define FreeOp(p) Safefree(p)
102 * In the following definition, the ", Nullop" is just to make the compiler
103 * think the expression is of the right type: croak actually does a Siglongjmp.
105 #define CHECKOP(type,o) \
106 ((PL_op_mask && PL_op_mask[type]) \
107 ? ( op_free((OP*)o), \
108 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
110 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
112 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
115 S_gv_ename(pTHX_ GV *gv)
118 SV* tmpsv = sv_newmortal();
119 gv_efullname3(tmpsv, gv, Nullch);
120 return SvPV(tmpsv,n_a);
124 S_no_fh_allowed(pTHX_ OP *o)
126 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
132 S_too_few_arguments(pTHX_ OP *o, char *name)
134 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
139 S_too_many_arguments(pTHX_ OP *o, char *name)
141 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
146 S_bad_type(pTHX_ I32 n, char *t, char *name, OP *kid)
148 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
149 (int)n, name, t, OP_DESC(kid)));
153 S_no_bareword_allowed(pTHX_ OP *o)
155 qerror(Perl_mess(aTHX_
156 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
160 /* "register" allocation */
163 Perl_allocmy(pTHX_ char *name)
167 /* complain about "my $_" etc etc */
168 if (!(PL_in_my == KEY_our ||
170 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
171 (name[1] == '_' && (int)strlen(name) > 2)))
173 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
174 /* 1999-02-27 mjd@plover.com */
176 p = strchr(name, '\0');
177 /* The next block assumes the buffer is at least 205 chars
178 long. At present, it's always at least 256 chars. */
180 strcpy(name+200, "...");
186 /* Move everything else down one character */
187 for (; p-name > 2; p--)
189 name[2] = toCTRL(name[1]);
192 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
195 /* check for duplicate declaration */
198 (PL_curstash ? PL_curstash : PL_defstash)
201 if (PL_in_my_stash && *name != '$') {
202 yyerror(Perl_form(aTHX_
203 "Can't declare class for non-scalar %s in \"%s\"",
204 name, PL_in_my == KEY_our ? "our" : "my"));
207 /* allocate a spare slot and store the name in that slot */
209 off = pad_add_name(name,
212 ? (PL_curstash ? PL_curstash : PL_defstash)
223 Perl_op_free(pTHX_ OP *o)
225 register OP *kid, *nextkid;
228 if (!o || o->op_seq == (U16)-1)
231 if (o->op_private & OPpREFCOUNTED) {
232 switch (o->op_type) {
240 if (OpREFCNT_dec(o)) {
251 if (o->op_flags & OPf_KIDS) {
252 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
253 nextkid = kid->op_sibling; /* Get before next freeing kid */
259 type = (OPCODE)o->op_targ;
261 /* COP* is not cleared by op_clear() so that we may track line
262 * numbers etc even after null() */
263 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
271 Perl_op_clear(pTHX_ OP *o)
274 switch (o->op_type) {
275 case OP_NULL: /* Was holding old type, if any. */
276 case OP_ENTEREVAL: /* Was holding hints. */
280 if (!(o->op_flags & OPf_REF)
281 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
288 if (cPADOPo->op_padix > 0) {
289 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
290 * may still exist on the pad */
291 pad_swipe(cPADOPo->op_padix, TRUE);
292 cPADOPo->op_padix = 0;
295 SvREFCNT_dec(cSVOPo->op_sv);
296 cSVOPo->op_sv = Nullsv;
299 case OP_METHOD_NAMED:
301 SvREFCNT_dec(cSVOPo->op_sv);
302 cSVOPo->op_sv = Nullsv;
305 Even if op_clear does a pad_free for the target of the op,
306 pad_free doesn't actually remove the sv that exists in the bad
307 instead it lives on. This results in that it could be reused as
308 a target later on when the pad was reallocated.
311 pad_swipe(o->op_targ,1);
320 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
324 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
325 SvREFCNT_dec(cSVOPo->op_sv);
326 cSVOPo->op_sv = Nullsv;
329 Safefree(cPVOPo->op_pv);
330 cPVOPo->op_pv = Nullch;
334 op_free(cPMOPo->op_pmreplroot);
338 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
339 /* No GvIN_PAD_off here, because other references may still
340 * exist on the pad */
341 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
344 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
351 HV *pmstash = PmopSTASH(cPMOPo);
352 if (pmstash && SvREFCNT(pmstash)) {
353 PMOP *pmop = HvPMROOT(pmstash);
354 PMOP *lastpmop = NULL;
356 if (cPMOPo == pmop) {
358 lastpmop->op_pmnext = pmop->op_pmnext;
360 HvPMROOT(pmstash) = pmop->op_pmnext;
364 pmop = pmop->op_pmnext;
367 PmopSTASH_free(cPMOPo);
369 cPMOPo->op_pmreplroot = Nullop;
370 /* we use the "SAFE" version of the PM_ macros here
371 * since sv_clean_all might release some PMOPs
372 * after PL_regex_padav has been cleared
373 * and the clearing of PL_regex_padav needs to
374 * happen before sv_clean_all
376 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
377 PM_SETRE_SAFE(cPMOPo, (REGEXP*)NULL);
379 if(PL_regex_pad) { /* We could be in destruction */
380 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
381 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
382 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
389 if (o->op_targ > 0) {
390 pad_free(o->op_targ);
396 S_cop_free(pTHX_ COP* cop)
398 Safefree(cop->cop_label); /* FIXME: treaddead ??? */
401 if (! specialWARN(cop->cop_warnings))
402 SvREFCNT_dec(cop->cop_warnings);
403 if (! specialCopIO(cop->cop_io)) {
407 char *s = SvPV(cop->cop_io,len);
408 Perl_warn(aTHX_ "io='%.*s'",(int) len,s); /* ??? --jhi */
411 SvREFCNT_dec(cop->cop_io);
417 Perl_op_null(pTHX_ OP *o)
419 if (o->op_type == OP_NULL)
422 o->op_targ = o->op_type;
423 o->op_type = OP_NULL;
424 o->op_ppaddr = PL_ppaddr[OP_NULL];
427 /* Contextualizers */
429 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
432 Perl_linklist(pTHX_ OP *o)
439 /* establish postfix order */
440 if (cUNOPo->op_first) {
441 o->op_next = LINKLIST(cUNOPo->op_first);
442 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
444 kid->op_next = LINKLIST(kid->op_sibling);
456 Perl_scalarkids(pTHX_ OP *o)
459 if (o && o->op_flags & OPf_KIDS) {
460 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
467 S_scalarboolean(pTHX_ OP *o)
469 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
470 if (ckWARN(WARN_SYNTAX)) {
471 line_t oldline = CopLINE(PL_curcop);
473 if (PL_copline != NOLINE)
474 CopLINE_set(PL_curcop, PL_copline);
475 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
476 CopLINE_set(PL_curcop, oldline);
483 Perl_scalar(pTHX_ OP *o)
487 /* assumes no premature commitment */
488 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
489 || o->op_type == OP_RETURN)
494 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
496 switch (o->op_type) {
498 scalar(cBINOPo->op_first);
503 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
507 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
508 if (!kPMOP->op_pmreplroot)
509 deprecate_old("implicit split to @_");
517 if (o->op_flags & OPf_KIDS) {
518 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
524 kid = cLISTOPo->op_first;
526 while ((kid = kid->op_sibling)) {
532 WITH_THR(PL_curcop = &PL_compiling);
537 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
543 WITH_THR(PL_curcop = &PL_compiling);
546 if (ckWARN(WARN_VOID))
547 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
553 Perl_scalarvoid(pTHX_ OP *o)
560 if (o->op_type == OP_NEXTSTATE
561 || o->op_type == OP_SETSTATE
562 || o->op_type == OP_DBSTATE
563 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
564 || o->op_targ == OP_SETSTATE
565 || o->op_targ == OP_DBSTATE)))
566 PL_curcop = (COP*)o; /* for warning below */
568 /* assumes no premature commitment */
569 want = o->op_flags & OPf_WANT;
570 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
571 || o->op_type == OP_RETURN)
576 if ((o->op_private & OPpTARGET_MY)
577 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
579 return scalar(o); /* As if inside SASSIGN */
582 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
584 switch (o->op_type) {
586 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
590 if (o->op_flags & OPf_STACKED)
594 if (o->op_private == 4)
666 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
667 useless = OP_DESC(o);
674 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
675 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
676 useless = "a variable";
681 if (cSVOPo->op_private & OPpCONST_STRICT)
682 no_bareword_allowed(o);
684 if (ckWARN(WARN_VOID)) {
685 useless = "a constant";
686 /* the constants 0 and 1 are permitted as they are
687 conventionally used as dummies in constructs like
688 1 while some_condition_with_side_effects; */
689 if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
691 else if (SvPOK(sv)) {
692 /* perl4's way of mixing documentation and code
693 (before the invention of POD) was based on a
694 trick to mix nroff and perl code. The trick was
695 built upon these three nroff macros being used in
696 void context. The pink camel has the details in
697 the script wrapman near page 319. */
698 if (strnEQ(SvPVX(sv), "di", 2) ||
699 strnEQ(SvPVX(sv), "ds", 2) ||
700 strnEQ(SvPVX(sv), "ig", 2))
705 op_null(o); /* don't execute or even remember it */
709 o->op_type = OP_PREINC; /* pre-increment is faster */
710 o->op_ppaddr = PL_ppaddr[OP_PREINC];
714 o->op_type = OP_PREDEC; /* pre-decrement is faster */
715 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
722 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
727 if (o->op_flags & OPf_STACKED)
734 if (!(o->op_flags & OPf_KIDS))
743 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
750 /* all requires must return a boolean value */
751 o->op_flags &= ~OPf_WANT;
756 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
757 if (!kPMOP->op_pmreplroot)
758 deprecate_old("implicit split to @_");
762 if (useless && ckWARN(WARN_VOID))
763 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
768 Perl_listkids(pTHX_ OP *o)
771 if (o && o->op_flags & OPf_KIDS) {
772 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
779 Perl_list(pTHX_ OP *o)
783 /* assumes no premature commitment */
784 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
785 || o->op_type == OP_RETURN)
790 if ((o->op_private & OPpTARGET_MY)
791 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
793 return o; /* As if inside SASSIGN */
796 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
798 switch (o->op_type) {
801 list(cBINOPo->op_first);
806 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
814 if (!(o->op_flags & OPf_KIDS))
816 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
817 list(cBINOPo->op_first);
818 return gen_constant_list(o);
825 kid = cLISTOPo->op_first;
827 while ((kid = kid->op_sibling)) {
833 WITH_THR(PL_curcop = &PL_compiling);
837 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
843 WITH_THR(PL_curcop = &PL_compiling);
846 /* all requires must return a boolean value */
847 o->op_flags &= ~OPf_WANT;
854 Perl_scalarseq(pTHX_ OP *o)
859 if (o->op_type == OP_LINESEQ ||
860 o->op_type == OP_SCOPE ||
861 o->op_type == OP_LEAVE ||
862 o->op_type == OP_LEAVETRY)
864 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
865 if (kid->op_sibling) {
869 PL_curcop = &PL_compiling;
871 o->op_flags &= ~OPf_PARENS;
872 if (PL_hints & HINT_BLOCK_SCOPE)
873 o->op_flags |= OPf_PARENS;
876 o = newOP(OP_STUB, 0);
881 S_modkids(pTHX_ OP *o, I32 type)
884 if (o && o->op_flags & OPf_KIDS) {
885 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
891 /* Propagate lvalue ("modifiable") context to an op and it's children.
892 * 'type' represents the context type, roughly based on the type of op that
893 * would do the modifying, although local() is represented by OP_NULL.
894 * It's responsible for detecting things that can't be modified, flag
895 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
896 * might have to vivify a reference in $x), and so on.
898 * For example, "$a+1 = 2" would cause mod() to be called with o being
899 * OP_ADD and type being OP_SASSIGN, and would output an error.
903 Perl_mod(pTHX_ OP *o, I32 type)
906 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
909 if (!o || PL_error_count)
912 if ((o->op_private & OPpTARGET_MY)
913 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
918 switch (o->op_type) {
924 if (!(o->op_private & (OPpCONST_ARYBASE)))
926 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
927 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
931 SAVEI32(PL_compiling.cop_arybase);
932 PL_compiling.cop_arybase = 0;
934 else if (type == OP_REFGEN)
937 Perl_croak(aTHX_ "That use of $[ is unsupported");
940 if (o->op_flags & OPf_PARENS)
944 if ((type == OP_UNDEF || type == OP_REFGEN) &&
945 !(o->op_flags & OPf_STACKED)) {
946 o->op_type = OP_RV2CV; /* entersub => rv2cv */
947 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
948 assert(cUNOPo->op_first->op_type == OP_NULL);
949 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
952 else if (o->op_private & OPpENTERSUB_NOMOD)
954 else { /* lvalue subroutine call */
955 o->op_private |= OPpLVAL_INTRO;
956 PL_modcount = RETURN_UNLIMITED_NUMBER;
957 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
958 /* Backward compatibility mode: */
959 o->op_private |= OPpENTERSUB_INARGS;
962 else { /* Compile-time error message: */
963 OP *kid = cUNOPo->op_first;
967 if (kid->op_type == OP_PUSHMARK)
969 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
971 "panic: unexpected lvalue entersub "
972 "args: type/targ %ld:%"UVuf,
973 (long)kid->op_type, (UV)kid->op_targ);
974 kid = kLISTOP->op_first;
976 while (kid->op_sibling)
977 kid = kid->op_sibling;
978 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
980 if (kid->op_type == OP_METHOD_NAMED
981 || kid->op_type == OP_METHOD)
985 NewOp(1101, newop, 1, UNOP);
986 newop->op_type = OP_RV2CV;
987 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
988 newop->op_first = Nullop;
989 newop->op_next = (OP*)newop;
990 kid->op_sibling = (OP*)newop;
991 newop->op_private |= OPpLVAL_INTRO;
995 if (kid->op_type != OP_RV2CV)
997 "panic: unexpected lvalue entersub "
998 "entry via type/targ %ld:%"UVuf,
999 (long)kid->op_type, (UV)kid->op_targ);
1000 kid->op_private |= OPpLVAL_INTRO;
1001 break; /* Postpone until runtime */
1005 kid = kUNOP->op_first;
1006 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1007 kid = kUNOP->op_first;
1008 if (kid->op_type == OP_NULL)
1010 "Unexpected constant lvalue entersub "
1011 "entry via type/targ %ld:%"UVuf,
1012 (long)kid->op_type, (UV)kid->op_targ);
1013 if (kid->op_type != OP_GV) {
1014 /* Restore RV2CV to check lvalueness */
1016 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1017 okid->op_next = kid->op_next;
1018 kid->op_next = okid;
1021 okid->op_next = Nullop;
1022 okid->op_type = OP_RV2CV;
1024 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1025 okid->op_private |= OPpLVAL_INTRO;
1029 cv = GvCV(kGVOP_gv);
1039 /* grep, foreach, subcalls, refgen */
1040 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1042 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1043 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1045 : (o->op_type == OP_ENTERSUB
1046 ? "non-lvalue subroutine call"
1048 type ? PL_op_desc[type] : "local"));
1062 case OP_RIGHT_SHIFT:
1071 if (!(o->op_flags & OPf_STACKED))
1078 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1084 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1085 PL_modcount = RETURN_UNLIMITED_NUMBER;
1086 return o; /* Treat \(@foo) like ordinary list. */
1090 if (scalar_mod_type(o, type))
1092 ref(cUNOPo->op_first, o->op_type);
1096 if (type == OP_LEAVESUBLV)
1097 o->op_private |= OPpMAYBE_LVSUB;
1103 PL_modcount = RETURN_UNLIMITED_NUMBER;
1106 ref(cUNOPo->op_first, o->op_type);
1111 PL_hints |= HINT_BLOCK_SCOPE;
1126 PL_modcount = RETURN_UNLIMITED_NUMBER;
1127 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1128 return o; /* Treat \(@foo) like ordinary list. */
1129 if (scalar_mod_type(o, type))
1131 if (type == OP_LEAVESUBLV)
1132 o->op_private |= OPpMAYBE_LVSUB;
1136 if (!type) /* local() */
1137 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1138 PAD_COMPNAME_PV(o->op_targ));
1146 if (type != OP_SASSIGN)
1150 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1155 if (type == OP_LEAVESUBLV)
1156 o->op_private |= OPpMAYBE_LVSUB;
1158 pad_free(o->op_targ);
1159 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1160 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1161 if (o->op_flags & OPf_KIDS)
1162 mod(cBINOPo->op_first->op_sibling, type);
1167 ref(cBINOPo->op_first, o->op_type);
1168 if (type == OP_ENTERSUB &&
1169 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1170 o->op_private |= OPpLVAL_DEFER;
1171 if (type == OP_LEAVESUBLV)
1172 o->op_private |= OPpMAYBE_LVSUB;
1182 if (o->op_flags & OPf_KIDS)
1183 mod(cLISTOPo->op_last, type);
1188 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1190 else if (!(o->op_flags & OPf_KIDS))
1192 if (o->op_targ != OP_LIST) {
1193 mod(cBINOPo->op_first, type);
1199 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1204 if (type != OP_LEAVESUBLV)
1206 break; /* mod()ing was handled by ck_return() */
1209 /* [20011101.069] File test operators interpret OPf_REF to mean that
1210 their argument is a filehandle; thus \stat(".") should not set
1212 if (type == OP_REFGEN &&
1213 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1216 if (type != OP_LEAVESUBLV)
1217 o->op_flags |= OPf_MOD;
1219 if (type == OP_AASSIGN || type == OP_SASSIGN)
1220 o->op_flags |= OPf_SPECIAL|OPf_REF;
1221 else if (!type) { /* local() */
1224 o->op_private |= OPpLVAL_INTRO;
1225 o->op_flags &= ~OPf_SPECIAL;
1226 PL_hints |= HINT_BLOCK_SCOPE;
1231 if (ckWARN(WARN_SYNTAX)) {
1232 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1233 "Useless localization of %s", OP_DESC(o));
1237 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1238 && type != OP_LEAVESUBLV)
1239 o->op_flags |= OPf_REF;
1244 S_scalar_mod_type(pTHX_ OP *o, I32 type)
1248 if (o->op_type == OP_RV2GV)
1272 case OP_RIGHT_SHIFT:
1291 S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
1293 switch (o->op_type) {
1301 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1314 Perl_refkids(pTHX_ OP *o, I32 type)
1317 if (o && o->op_flags & OPf_KIDS) {
1318 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1325 Perl_ref(pTHX_ OP *o, I32 type)
1329 if (!o || PL_error_count)
1332 switch (o->op_type) {
1334 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1335 !(o->op_flags & OPf_STACKED)) {
1336 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1337 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1338 assert(cUNOPo->op_first->op_type == OP_NULL);
1339 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1340 o->op_flags |= OPf_SPECIAL;
1345 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1349 if (type == OP_DEFINED)
1350 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1351 ref(cUNOPo->op_first, o->op_type);
1354 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1355 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1356 : type == OP_RV2HV ? OPpDEREF_HV
1358 o->op_flags |= OPf_MOD;
1363 o->op_flags |= OPf_MOD; /* XXX ??? */
1368 o->op_flags |= OPf_REF;
1371 if (type == OP_DEFINED)
1372 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1373 ref(cUNOPo->op_first, o->op_type);
1378 o->op_flags |= OPf_REF;
1383 if (!(o->op_flags & OPf_KIDS))
1385 ref(cBINOPo->op_first, type);
1389 ref(cBINOPo->op_first, o->op_type);
1390 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1391 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1392 : type == OP_RV2HV ? OPpDEREF_HV
1394 o->op_flags |= OPf_MOD;
1402 if (!(o->op_flags & OPf_KIDS))
1404 ref(cLISTOPo->op_last, type);
1414 S_dup_attrlist(pTHX_ OP *o)
1418 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1419 * where the first kid is OP_PUSHMARK and the remaining ones
1420 * are OP_CONST. We need to push the OP_CONST values.
1422 if (o->op_type == OP_CONST)
1423 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1425 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1426 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1427 if (o->op_type == OP_CONST)
1428 rop = append_elem(OP_LIST, rop,
1429 newSVOP(OP_CONST, o->op_flags,
1430 SvREFCNT_inc(cSVOPo->op_sv)));
1437 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1441 /* fake up C<use attributes $pkg,$rv,@attrs> */
1442 ENTER; /* need to protect against side-effects of 'use' */
1445 stashsv = newSVpv(HvNAME(stash), 0);
1447 stashsv = &PL_sv_no;
1449 #define ATTRSMODULE "attributes"
1450 #define ATTRSMODULE_PM "attributes.pm"
1454 /* Don't force the C<use> if we don't need it. */
1455 svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
1456 sizeof(ATTRSMODULE_PM)-1, 0);
1457 if (svp && *svp != &PL_sv_undef)
1458 ; /* already in %INC */
1460 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1461 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1465 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1466 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1468 prepend_elem(OP_LIST,
1469 newSVOP(OP_CONST, 0, stashsv),
1470 prepend_elem(OP_LIST,
1471 newSVOP(OP_CONST, 0,
1473 dup_attrlist(attrs))));
1479 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1481 OP *pack, *imop, *arg;
1487 assert(target->op_type == OP_PADSV ||
1488 target->op_type == OP_PADHV ||
1489 target->op_type == OP_PADAV);
1491 /* Ensure that attributes.pm is loaded. */
1492 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1494 /* Need package name for method call. */
1495 pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
1497 /* Build up the real arg-list. */
1499 stashsv = newSVpv(HvNAME(stash), 0);
1501 stashsv = &PL_sv_no;
1502 arg = newOP(OP_PADSV, 0);
1503 arg->op_targ = target->op_targ;
1504 arg = prepend_elem(OP_LIST,
1505 newSVOP(OP_CONST, 0, stashsv),
1506 prepend_elem(OP_LIST,
1507 newUNOP(OP_REFGEN, 0,
1508 mod(arg, OP_REFGEN)),
1509 dup_attrlist(attrs)));
1511 /* Fake up a method call to import */
1512 meth = newSVpvn("import", 6);
1513 (void)SvUPGRADE(meth, SVt_PVIV);
1514 (void)SvIOK_on(meth);
1515 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
1516 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1517 append_elem(OP_LIST,
1518 prepend_elem(OP_LIST, pack, list(arg)),
1519 newSVOP(OP_METHOD_NAMED, 0, meth)));
1520 imop->op_private |= OPpENTERSUB_NOMOD;
1522 /* Combine the ops. */
1523 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1527 =notfor apidoc apply_attrs_string
1529 Attempts to apply a list of attributes specified by the C<attrstr> and
1530 C<len> arguments to the subroutine identified by the C<cv> argument which
1531 is expected to be associated with the package identified by the C<stashpv>
1532 argument (see L<attributes>). It gets this wrong, though, in that it
1533 does not correctly identify the boundaries of the individual attribute
1534 specifications within C<attrstr>. This is not really intended for the
1535 public API, but has to be listed here for systems such as AIX which
1536 need an explicit export list for symbols. (It's called from XS code
1537 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1538 to respect attribute syntax properly would be welcome.
1544 Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
1545 char *attrstr, STRLEN len)
1550 len = strlen(attrstr);
1554 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1556 char *sstr = attrstr;
1557 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1558 attrs = append_elem(OP_LIST, attrs,
1559 newSVOP(OP_CONST, 0,
1560 newSVpvn(sstr, attrstr-sstr)));
1564 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1565 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1566 Nullsv, prepend_elem(OP_LIST,
1567 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1568 prepend_elem(OP_LIST,
1569 newSVOP(OP_CONST, 0,
1575 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1580 if (!o || PL_error_count)
1584 if (type == OP_LIST) {
1585 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1586 my_kid(kid, attrs, imopsp);
1587 } else if (type == OP_UNDEF) {
1589 } else if (type == OP_RV2SV || /* "our" declaration */
1591 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1592 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1593 yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
1594 OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
1596 GV *gv = cGVOPx_gv(cUNOPo->op_first);
1598 PL_in_my_stash = Nullhv;
1599 apply_attrs(GvSTASH(gv),
1600 (type == OP_RV2SV ? GvSV(gv) :
1601 type == OP_RV2AV ? (SV*)GvAV(gv) :
1602 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1605 o->op_private |= OPpOUR_INTRO;
1608 else if (type != OP_PADSV &&
1611 type != OP_PUSHMARK)
1613 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1615 PL_in_my == KEY_our ? "our" : "my"));
1618 else if (attrs && type != OP_PUSHMARK) {
1622 PL_in_my_stash = Nullhv;
1624 /* check for C<my Dog $spot> when deciding package */
1625 stash = PAD_COMPNAME_TYPE(o->op_targ);
1627 stash = PL_curstash;
1628 apply_attrs_my(stash, o, attrs, imopsp);
1630 o->op_flags |= OPf_MOD;
1631 o->op_private |= OPpLVAL_INTRO;
1636 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1639 int maybe_scalar = 0;
1641 /* [perl #17376]: this appears to be premature, and results in code such as
1642 C< our(%x); > executing in list mode rather than void mode */
1644 if (o->op_flags & OPf_PARENS)
1653 o = my_kid(o, attrs, &rops);
1655 if (maybe_scalar && o->op_type == OP_PADSV) {
1656 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1657 o->op_private |= OPpLVAL_INTRO;
1660 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1663 PL_in_my_stash = Nullhv;
1668 Perl_my(pTHX_ OP *o)
1670 return my_attrs(o, Nullop);
1674 Perl_sawparens(pTHX_ OP *o)
1677 o->op_flags |= OPf_PARENS;
1682 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1686 if (ckWARN(WARN_MISC) &&
1687 (left->op_type == OP_RV2AV ||
1688 left->op_type == OP_RV2HV ||
1689 left->op_type == OP_PADAV ||
1690 left->op_type == OP_PADHV)) {
1691 char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
1692 right->op_type == OP_TRANS)
1693 ? right->op_type : OP_MATCH];
1694 const char *sample = ((left->op_type == OP_RV2AV ||
1695 left->op_type == OP_PADAV)
1696 ? "@array" : "%hash");
1697 Perl_warner(aTHX_ packWARN(WARN_MISC),
1698 "Applying %s to %s will act on scalar(%s)",
1699 desc, sample, sample);
1702 if (right->op_type == OP_CONST &&
1703 cSVOPx(right)->op_private & OPpCONST_BARE &&
1704 cSVOPx(right)->op_private & OPpCONST_STRICT)
1706 no_bareword_allowed(right);
1709 if (!(right->op_flags & OPf_STACKED) &&
1710 (right->op_type == OP_MATCH ||
1711 right->op_type == OP_SUBST ||
1712 right->op_type == OP_TRANS)) {
1713 right->op_flags |= OPf_STACKED;
1714 if (right->op_type != OP_MATCH &&
1715 ! (right->op_type == OP_TRANS &&
1716 right->op_private & OPpTRANS_IDENTICAL))
1717 left = mod(left, right->op_type);
1718 if (right->op_type == OP_TRANS)
1719 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
1721 o = prepend_elem(right->op_type, scalar(left), right);
1723 return newUNOP(OP_NOT, 0, scalar(o));
1727 return bind_match(type, left,
1728 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
1732 Perl_invert(pTHX_ OP *o)
1736 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
1737 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1741 Perl_scope(pTHX_ OP *o)
1744 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1745 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1746 o->op_type = OP_LEAVE;
1747 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1749 else if (o->op_type == OP_LINESEQ) {
1751 o->op_type = OP_SCOPE;
1752 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1753 kid = ((LISTOP*)o)->op_first;
1754 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
1758 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
1764 Perl_save_hints(pTHX)
1767 SAVESPTR(GvHV(PL_hintgv));
1768 GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
1769 SAVEFREESV(GvHV(PL_hintgv));
1773 Perl_block_start(pTHX_ int full)
1775 int retval = PL_savestack_ix;
1776 /* If there were syntax errors, don't try to start a block */
1777 if (PL_yynerrs) return retval;
1779 pad_block_start(full);
1781 PL_hints &= ~HINT_BLOCK_SCOPE;
1782 SAVESPTR(PL_compiling.cop_warnings);
1783 if (! specialWARN(PL_compiling.cop_warnings)) {
1784 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1785 SAVEFREESV(PL_compiling.cop_warnings) ;
1787 SAVESPTR(PL_compiling.cop_io);
1788 if (! specialCopIO(PL_compiling.cop_io)) {
1789 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1790 SAVEFREESV(PL_compiling.cop_io) ;
1796 Perl_block_end(pTHX_ I32 floor, OP *seq)
1798 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1799 OP* retval = scalarseq(seq);
1800 /* If there were syntax errors, don't try to close a block */
1801 if (PL_yynerrs) return retval;
1803 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
1805 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
1813 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1817 Perl_newPROG(pTHX_ OP *o)
1822 PL_eval_root = newUNOP(OP_LEAVEEVAL,
1823 ((PL_in_eval & EVAL_KEEPERR)
1824 ? OPf_SPECIAL : 0), o);
1825 PL_eval_start = linklist(PL_eval_root);
1826 PL_eval_root->op_private |= OPpREFCOUNTED;
1827 OpREFCNT_set(PL_eval_root, 1);
1828 PL_eval_root->op_next = 0;
1829 CALL_PEEP(PL_eval_start);
1832 if (o->op_type == OP_STUB)
1834 PL_main_root = scope(sawparens(scalarvoid(o)));
1835 PL_curcop = &PL_compiling;
1836 PL_main_start = LINKLIST(PL_main_root);
1837 PL_main_root->op_private |= OPpREFCOUNTED;
1838 OpREFCNT_set(PL_main_root, 1);
1839 PL_main_root->op_next = 0;
1840 CALL_PEEP(PL_main_start);
1843 /* Register with debugger */
1845 CV *cv = get_cv("DB::postponed", FALSE);
1849 XPUSHs((SV*)CopFILEGV(&PL_compiling));
1851 call_sv((SV*)cv, G_DISCARD);
1858 Perl_localize(pTHX_ OP *o, I32 lex)
1860 if (o->op_flags & OPf_PARENS)
1861 /* [perl #17376]: this appears to be premature, and results in code such as
1862 C< our(%x); > executing in list mode rather than void mode */
1869 if (ckWARN(WARN_PARENTHESIS)
1870 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
1872 char *s = PL_bufptr;
1875 /* some heuristics to detect a potential error */
1876 while (*s && (strchr(", \t\n", *s)
1877 || (strchr("@$%*", *s) && ++sigil) ))
1880 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)
1881 || strchr("@$%*, \t\n", *s)))
1884 if (*s == ';' || *s == '=')
1885 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
1886 "Parentheses missing around \"%s\" list",
1887 lex ? (PL_in_my == KEY_our ? "our" : "my")
1895 o = mod(o, OP_NULL); /* a bit kludgey */
1897 PL_in_my_stash = Nullhv;
1902 Perl_jmaybe(pTHX_ OP *o)
1904 if (o->op_type == OP_LIST) {
1906 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
1907 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
1913 Perl_fold_constants(pTHX_ register OP *o)
1916 I32 type = o->op_type;
1919 if (PL_opargs[type] & OA_RETSCALAR)
1921 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
1922 o->op_targ = pad_alloc(type, SVs_PADTMP);
1924 /* integerize op, unless it happens to be C<-foo>.
1925 * XXX should pp_i_negate() do magic string negation instead? */
1926 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
1927 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
1928 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
1930 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
1933 if (!(PL_opargs[type] & OA_FOLDCONST))
1938 /* XXX might want a ck_negate() for this */
1939 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
1951 /* XXX what about the numeric ops? */
1952 if (PL_hints & HINT_LOCALE)
1957 goto nope; /* Don't try to run w/ errors */
1959 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
1960 if ((curop->op_type != OP_CONST ||
1961 (curop->op_private & OPpCONST_BARE)) &&
1962 curop->op_type != OP_LIST &&
1963 curop->op_type != OP_SCALAR &&
1964 curop->op_type != OP_NULL &&
1965 curop->op_type != OP_PUSHMARK)
1971 curop = LINKLIST(o);
1975 sv = *(PL_stack_sp--);
1976 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
1977 pad_swipe(o->op_targ, FALSE);
1978 else if (SvTEMP(sv)) { /* grab mortal temp? */
1979 (void)SvREFCNT_inc(sv);
1983 if (type == OP_RV2GV)
1984 return newGVOP(OP_GV, 0, (GV*)sv);
1985 return newSVOP(OP_CONST, 0, sv);
1992 Perl_gen_constant_list(pTHX_ register OP *o)
1995 I32 oldtmps_floor = PL_tmps_floor;
1999 return o; /* Don't attempt to run with errors */
2001 PL_op = curop = LINKLIST(o);
2008 PL_tmps_floor = oldtmps_floor;
2010 o->op_type = OP_RV2AV;
2011 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2012 o->op_seq = 0; /* needs to be revisited in peep() */
2013 curop = ((UNOP*)o)->op_first;
2014 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2021 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2023 if (!o || o->op_type != OP_LIST)
2024 o = newLISTOP(OP_LIST, 0, o, Nullop);
2026 o->op_flags &= ~OPf_WANT;
2028 if (!(PL_opargs[type] & OA_MARK))
2029 op_null(cLISTOPo->op_first);
2031 o->op_type = (OPCODE)type;
2032 o->op_ppaddr = PL_ppaddr[type];
2033 o->op_flags |= flags;
2035 o = CHECKOP(type, o);
2036 if (o->op_type != type)
2039 return fold_constants(o);
2042 /* List constructors */
2045 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2053 if (first->op_type != type
2054 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2056 return newLISTOP(type, 0, first, last);
2059 if (first->op_flags & OPf_KIDS)
2060 ((LISTOP*)first)->op_last->op_sibling = last;
2062 first->op_flags |= OPf_KIDS;
2063 ((LISTOP*)first)->op_first = last;
2065 ((LISTOP*)first)->op_last = last;
2070 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2078 if (first->op_type != type)
2079 return prepend_elem(type, (OP*)first, (OP*)last);
2081 if (last->op_type != type)
2082 return append_elem(type, (OP*)first, (OP*)last);
2084 first->op_last->op_sibling = last->op_first;
2085 first->op_last = last->op_last;
2086 first->op_flags |= (last->op_flags & OPf_KIDS);
2094 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2102 if (last->op_type == type) {
2103 if (type == OP_LIST) { /* already a PUSHMARK there */
2104 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2105 ((LISTOP*)last)->op_first->op_sibling = first;
2106 if (!(first->op_flags & OPf_PARENS))
2107 last->op_flags &= ~OPf_PARENS;
2110 if (!(last->op_flags & OPf_KIDS)) {
2111 ((LISTOP*)last)->op_last = first;
2112 last->op_flags |= OPf_KIDS;
2114 first->op_sibling = ((LISTOP*)last)->op_first;
2115 ((LISTOP*)last)->op_first = first;
2117 last->op_flags |= OPf_KIDS;
2121 return newLISTOP(type, 0, first, last);
2127 Perl_newNULLLIST(pTHX)
2129 return newOP(OP_STUB, 0);
2133 Perl_force_list(pTHX_ OP *o)
2135 if (!o || o->op_type != OP_LIST)
2136 o = newLISTOP(OP_LIST, 0, o, Nullop);
2142 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2146 NewOp(1101, listop, 1, LISTOP);
2148 listop->op_type = (OPCODE)type;
2149 listop->op_ppaddr = PL_ppaddr[type];
2152 listop->op_flags = (U8)flags;
2156 else if (!first && last)
2159 first->op_sibling = last;
2160 listop->op_first = first;
2161 listop->op_last = last;
2162 if (type == OP_LIST) {
2164 pushop = newOP(OP_PUSHMARK, 0);
2165 pushop->op_sibling = first;
2166 listop->op_first = pushop;
2167 listop->op_flags |= OPf_KIDS;
2169 listop->op_last = pushop;
2176 Perl_newOP(pTHX_ I32 type, I32 flags)
2179 NewOp(1101, o, 1, OP);
2180 o->op_type = (OPCODE)type;
2181 o->op_ppaddr = PL_ppaddr[type];
2182 o->op_flags = (U8)flags;
2185 o->op_private = (U8)(0 | (flags >> 8));
2186 if (PL_opargs[type] & OA_RETSCALAR)
2188 if (PL_opargs[type] & OA_TARGET)
2189 o->op_targ = pad_alloc(type, SVs_PADTMP);
2190 return CHECKOP(type, o);
2194 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2199 first = newOP(OP_STUB, 0);
2200 if (PL_opargs[type] & OA_MARK)
2201 first = force_list(first);
2203 NewOp(1101, unop, 1, UNOP);
2204 unop->op_type = (OPCODE)type;
2205 unop->op_ppaddr = PL_ppaddr[type];
2206 unop->op_first = first;
2207 unop->op_flags = flags | OPf_KIDS;
2208 unop->op_private = (U8)(1 | (flags >> 8));
2209 unop = (UNOP*) CHECKOP(type, unop);
2213 return fold_constants((OP *) unop);
2217 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2220 NewOp(1101, binop, 1, BINOP);
2223 first = newOP(OP_NULL, 0);
2225 binop->op_type = (OPCODE)type;
2226 binop->op_ppaddr = PL_ppaddr[type];
2227 binop->op_first = first;
2228 binop->op_flags = flags | OPf_KIDS;
2231 binop->op_private = (U8)(1 | (flags >> 8));
2234 binop->op_private = (U8)(2 | (flags >> 8));
2235 first->op_sibling = last;
2238 binop = (BINOP*)CHECKOP(type, binop);
2239 if (binop->op_next || binop->op_type != (OPCODE)type)
2242 binop->op_last = binop->op_first->op_sibling;
2244 return fold_constants((OP *)binop);
2248 uvcompare(const void *a, const void *b)
2250 if (*((UV *)a) < (*(UV *)b))
2252 if (*((UV *)a) > (*(UV *)b))
2254 if (*((UV *)a+1) < (*(UV *)b+1))
2256 if (*((UV *)a+1) > (*(UV *)b+1))
2262 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2264 SV *tstr = ((SVOP*)expr)->op_sv;
2265 SV *rstr = ((SVOP*)repl)->op_sv;
2268 U8 *t = (U8*)SvPV(tstr, tlen);
2269 U8 *r = (U8*)SvPV(rstr, rlen);
2276 register short *tbl;
2278 PL_hints |= HINT_BLOCK_SCOPE;
2279 complement = o->op_private & OPpTRANS_COMPLEMENT;
2280 del = o->op_private & OPpTRANS_DELETE;
2281 squash = o->op_private & OPpTRANS_SQUASH;
2284 o->op_private |= OPpTRANS_FROM_UTF;
2287 o->op_private |= OPpTRANS_TO_UTF;
2289 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2290 SV* listsv = newSVpvn("# comment\n",10);
2292 U8* tend = t + tlen;
2293 U8* rend = r + rlen;
2307 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2308 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2314 tsave = t = bytes_to_utf8(t, &len);
2317 if (!to_utf && rlen) {
2319 rsave = r = bytes_to_utf8(r, &len);
2323 /* There are several snags with this code on EBCDIC:
2324 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2325 2. scan_const() in toke.c has encoded chars in native encoding which makes
2326 ranges at least in EBCDIC 0..255 range the bottom odd.
2330 U8 tmpbuf[UTF8_MAXLEN+1];
2333 New(1109, cp, 2*tlen, UV);
2335 transv = newSVpvn("",0);
2337 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2339 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2341 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2345 cp[2*i+1] = cp[2*i];
2349 qsort(cp, i, 2*sizeof(UV), uvcompare);
2350 for (j = 0; j < i; j++) {
2352 diff = val - nextmin;
2354 t = uvuni_to_utf8(tmpbuf,nextmin);
2355 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2357 U8 range_mark = UTF_TO_NATIVE(0xff);
2358 t = uvuni_to_utf8(tmpbuf, val - 1);
2359 sv_catpvn(transv, (char *)&range_mark, 1);
2360 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2367 t = uvuni_to_utf8(tmpbuf,nextmin);
2368 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2370 U8 range_mark = UTF_TO_NATIVE(0xff);
2371 sv_catpvn(transv, (char *)&range_mark, 1);
2373 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2374 UNICODE_ALLOW_SUPER);
2375 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2376 t = (U8*)SvPVX(transv);
2377 tlen = SvCUR(transv);
2381 else if (!rlen && !del) {
2382 r = t; rlen = tlen; rend = tend;
2385 if ((!rlen && !del) || t == r ||
2386 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2388 o->op_private |= OPpTRANS_IDENTICAL;
2392 while (t < tend || tfirst <= tlast) {
2393 /* see if we need more "t" chars */
2394 if (tfirst > tlast) {
2395 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2397 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2399 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2406 /* now see if we need more "r" chars */
2407 if (rfirst > rlast) {
2409 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2411 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2413 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2422 rfirst = rlast = 0xffffffff;
2426 /* now see which range will peter our first, if either. */
2427 tdiff = tlast - tfirst;
2428 rdiff = rlast - rfirst;
2435 if (rfirst == 0xffffffff) {
2436 diff = tdiff; /* oops, pretend rdiff is infinite */
2438 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2439 (long)tfirst, (long)tlast);
2441 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2445 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2446 (long)tfirst, (long)(tfirst + diff),
2449 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2450 (long)tfirst, (long)rfirst);
2452 if (rfirst + diff > max)
2453 max = rfirst + diff;
2455 grows = (tfirst < rfirst &&
2456 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2468 else if (max > 0xff)
2473 Safefree(cPVOPo->op_pv);
2474 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2475 SvREFCNT_dec(listsv);
2477 SvREFCNT_dec(transv);
2479 if (!del && havefinal && rlen)
2480 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2481 newSVuv((UV)final), 0);
2484 o->op_private |= OPpTRANS_GROWS;
2496 tbl = (short*)cPVOPo->op_pv;
2498 Zero(tbl, 256, short);
2499 for (i = 0; i < (I32)tlen; i++)
2501 for (i = 0, j = 0; i < 256; i++) {
2503 if (j >= (I32)rlen) {
2512 if (i < 128 && r[j] >= 128)
2522 o->op_private |= OPpTRANS_IDENTICAL;
2524 else if (j >= (I32)rlen)
2527 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2528 tbl[0x100] = rlen - j;
2529 for (i=0; i < (I32)rlen - j; i++)
2530 tbl[0x101+i] = r[j+i];
2534 if (!rlen && !del) {
2537 o->op_private |= OPpTRANS_IDENTICAL;
2539 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2540 o->op_private |= OPpTRANS_IDENTICAL;
2542 for (i = 0; i < 256; i++)
2544 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
2545 if (j >= (I32)rlen) {
2547 if (tbl[t[i]] == -1)
2553 if (tbl[t[i]] == -1) {
2554 if (t[i] < 128 && r[j] >= 128)
2561 o->op_private |= OPpTRANS_GROWS;
2569 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2573 NewOp(1101, pmop, 1, PMOP);
2574 pmop->op_type = (OPCODE)type;
2575 pmop->op_ppaddr = PL_ppaddr[type];
2576 pmop->op_flags = (U8)flags;
2577 pmop->op_private = (U8)(0 | (flags >> 8));
2579 if (PL_hints & HINT_RE_TAINT)
2580 pmop->op_pmpermflags |= PMf_RETAINT;
2581 if (PL_hints & HINT_LOCALE)
2582 pmop->op_pmpermflags |= PMf_LOCALE;
2583 pmop->op_pmflags = pmop->op_pmpermflags;
2588 if(av_len((AV*) PL_regex_pad[0]) > -1) {
2589 repointer = av_pop((AV*)PL_regex_pad[0]);
2590 pmop->op_pmoffset = SvIV(repointer);
2591 SvREPADTMP_off(repointer);
2592 sv_setiv(repointer,0);
2594 repointer = newSViv(0);
2595 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2596 pmop->op_pmoffset = av_len(PL_regex_padav);
2597 PL_regex_pad = AvARRAY(PL_regex_padav);
2602 /* link into pm list */
2603 if (type != OP_TRANS && PL_curstash) {
2604 pmop->op_pmnext = HvPMROOT(PL_curstash);
2605 HvPMROOT(PL_curstash) = pmop;
2606 PmopSTASH_set(pmop,PL_curstash);
2613 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
2617 I32 repl_has_vars = 0;
2619 if (o->op_type == OP_TRANS)
2620 return pmtrans(o, expr, repl);
2622 PL_hints |= HINT_BLOCK_SCOPE;
2625 if (expr->op_type == OP_CONST) {
2627 SV *pat = ((SVOP*)expr)->op_sv;
2628 char *p = SvPV(pat, plen);
2629 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
2630 sv_setpvn(pat, "\\s+", 3);
2631 p = SvPV(pat, plen);
2632 pm->op_pmflags |= PMf_SKIPWHITE;
2635 pm->op_pmdynflags |= PMdf_UTF8;
2636 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
2637 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
2638 pm->op_pmflags |= PMf_WHITE;
2642 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2643 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2645 : OP_REGCMAYBE),0,expr);
2647 NewOp(1101, rcop, 1, LOGOP);
2648 rcop->op_type = OP_REGCOMP;
2649 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2650 rcop->op_first = scalar(expr);
2651 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
2652 ? (OPf_SPECIAL | OPf_KIDS)
2654 rcop->op_private = 1;
2656 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
2659 /* establish postfix order */
2660 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2662 rcop->op_next = expr;
2663 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2666 rcop->op_next = LINKLIST(expr);
2667 expr->op_next = (OP*)rcop;
2670 prepend_elem(o->op_type, scalar((OP*)rcop), o);
2675 if (pm->op_pmflags & PMf_EVAL) {
2677 if (CopLINE(PL_curcop) < PL_multi_end)
2678 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
2680 else if (repl->op_type == OP_CONST)
2684 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
2685 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
2686 if (curop->op_type == OP_GV) {
2687 GV *gv = cGVOPx_gv(curop);
2689 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
2692 else if (curop->op_type == OP_RV2CV)
2694 else if (curop->op_type == OP_RV2SV ||
2695 curop->op_type == OP_RV2AV ||
2696 curop->op_type == OP_RV2HV ||
2697 curop->op_type == OP_RV2GV) {
2698 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2701 else if (curop->op_type == OP_PADSV ||
2702 curop->op_type == OP_PADAV ||
2703 curop->op_type == OP_PADHV ||
2704 curop->op_type == OP_PADANY) {
2707 else if (curop->op_type == OP_PUSHRE)
2708 ; /* Okay here, dangerous in newASSIGNOP */
2718 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
2719 pm->op_pmflags |= PMf_CONST; /* const for long enough */
2720 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
2721 prepend_elem(o->op_type, scalar(repl), o);
2724 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
2725 pm->op_pmflags |= PMf_MAYBE_CONST;
2726 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2728 NewOp(1101, rcop, 1, LOGOP);
2729 rcop->op_type = OP_SUBSTCONT;
2730 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
2731 rcop->op_first = scalar(repl);
2732 rcop->op_flags |= OPf_KIDS;
2733 rcop->op_private = 1;
2736 /* establish postfix order */
2737 rcop->op_next = LINKLIST(repl);
2738 repl->op_next = (OP*)rcop;
2740 pm->op_pmreplroot = scalar((OP*)rcop);
2741 pm->op_pmreplstart = LINKLIST(rcop);
2750 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
2753 NewOp(1101, svop, 1, SVOP);
2754 svop->op_type = (OPCODE)type;
2755 svop->op_ppaddr = PL_ppaddr[type];
2757 svop->op_next = (OP*)svop;
2758 svop->op_flags = (U8)flags;
2759 if (PL_opargs[type] & OA_RETSCALAR)
2761 if (PL_opargs[type] & OA_TARGET)
2762 svop->op_targ = pad_alloc(type, SVs_PADTMP);
2763 return CHECKOP(type, svop);
2767 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2770 NewOp(1101, padop, 1, PADOP);
2771 padop->op_type = (OPCODE)type;
2772 padop->op_ppaddr = PL_ppaddr[type];
2773 padop->op_padix = pad_alloc(type, SVs_PADTMP);
2774 SvREFCNT_dec(PAD_SVl(padop->op_padix));
2775 PAD_SETSV(padop->op_padix, sv);
2778 padop->op_next = (OP*)padop;
2779 padop->op_flags = (U8)flags;
2780 if (PL_opargs[type] & OA_RETSCALAR)
2782 if (PL_opargs[type] & OA_TARGET)
2783 padop->op_targ = pad_alloc(type, SVs_PADTMP);
2784 return CHECKOP(type, padop);
2788 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
2793 return newPADOP(type, flags, SvREFCNT_inc(gv));
2795 return newSVOP(type, flags, SvREFCNT_inc(gv));
2800 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
2803 NewOp(1101, pvop, 1, PVOP);
2804 pvop->op_type = (OPCODE)type;
2805 pvop->op_ppaddr = PL_ppaddr[type];
2807 pvop->op_next = (OP*)pvop;
2808 pvop->op_flags = (U8)flags;
2809 if (PL_opargs[type] & OA_RETSCALAR)
2811 if (PL_opargs[type] & OA_TARGET)
2812 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
2813 return CHECKOP(type, pvop);
2817 Perl_package(pTHX_ OP *o)
2822 save_hptr(&PL_curstash);
2823 save_item(PL_curstname);
2825 name = SvPV(cSVOPo->op_sv, len);
2826 PL_curstash = gv_stashpvn(name, len, TRUE);
2827 sv_setpvn(PL_curstname, name, len);
2830 PL_hints |= HINT_BLOCK_SCOPE;
2831 PL_copline = NOLINE;
2836 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
2842 if (idop->op_type != OP_CONST)
2843 Perl_croak(aTHX_ "Module name must be constant");
2847 if (version != Nullop) {
2848 SV *vesv = ((SVOP*)version)->op_sv;
2850 if (arg == Nullop && !SvNIOKp(vesv)) {
2857 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
2858 Perl_croak(aTHX_ "Version number must be constant number");
2860 /* Make copy of idop so we don't free it twice */
2861 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
2863 /* Fake up a method call to VERSION */
2864 meth = newSVpvn("VERSION",7);
2865 sv_upgrade(meth, SVt_PVIV);
2866 (void)SvIOK_on(meth);
2867 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
2868 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2869 append_elem(OP_LIST,
2870 prepend_elem(OP_LIST, pack, list(version)),
2871 newSVOP(OP_METHOD_NAMED, 0, meth)));
2875 /* Fake up an import/unimport */
2876 if (arg && arg->op_type == OP_STUB)
2877 imop = arg; /* no import on explicit () */
2878 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
2879 imop = Nullop; /* use 5.0; */
2884 /* Make copy of idop so we don't free it twice */
2885 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
2887 /* Fake up a method call to import/unimport */
2888 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);
2889 (void)SvUPGRADE(meth, SVt_PVIV);
2890 (void)SvIOK_on(meth);
2891 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
2892 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2893 append_elem(OP_LIST,
2894 prepend_elem(OP_LIST, pack, list(arg)),
2895 newSVOP(OP_METHOD_NAMED, 0, meth)));
2898 /* Fake up the BEGIN {}, which does its thing immediately. */
2900 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
2903 append_elem(OP_LINESEQ,
2904 append_elem(OP_LINESEQ,
2905 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, idop)),
2906 newSTATEOP(0, Nullch, veop)),
2907 newSTATEOP(0, Nullch, imop) ));
2909 /* The "did you use incorrect case?" warning used to be here.
2910 * The problem is that on case-insensitive filesystems one
2911 * might get false positives for "use" (and "require"):
2912 * "use Strict" or "require CARP" will work. This causes
2913 * portability problems for the script: in case-strict
2914 * filesystems the script will stop working.
2916 * The "incorrect case" warning checked whether "use Foo"
2917 * imported "Foo" to your namespace, but that is wrong, too:
2918 * there is no requirement nor promise in the language that
2919 * a Foo.pm should or would contain anything in package "Foo".
2921 * There is very little Configure-wise that can be done, either:
2922 * the case-sensitivity of the build filesystem of Perl does not
2923 * help in guessing the case-sensitivity of the runtime environment.
2926 PL_hints |= HINT_BLOCK_SCOPE;
2927 PL_copline = NOLINE;
2932 =head1 Embedding Functions
2934 =for apidoc load_module
2936 Loads the module whose name is pointed to by the string part of name.
2937 Note that the actual module name, not its filename, should be given.
2938 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
2939 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
2940 (or 0 for no flags). ver, if specified, provides version semantics
2941 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
2942 arguments can be used to specify arguments to the module's import()
2943 method, similar to C<use Foo::Bar VERSION LIST>.
2948 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
2951 va_start(args, ver);
2952 vload_module(flags, name, ver, &args);
2956 #ifdef PERL_IMPLICIT_CONTEXT
2958 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
2962 va_start(args, ver);
2963 vload_module(flags, name, ver, &args);
2969 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
2971 OP *modname, *veop, *imop;
2973 modname = newSVOP(OP_CONST, 0, name);
2974 modname->op_private |= OPpCONST_BARE;
2976 veop = newSVOP(OP_CONST, 0, ver);
2980 if (flags & PERL_LOADMOD_NOIMPORT) {
2981 imop = sawparens(newNULLLIST());
2983 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
2984 imop = va_arg(*args, OP*);
2989 sv = va_arg(*args, SV*);
2991 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
2992 sv = va_arg(*args, SV*);
2996 line_t ocopline = PL_copline;
2997 COP *ocurcop = PL_curcop;
2998 int oexpect = PL_expect;
3000 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3001 veop, modname, imop);
3002 PL_expect = oexpect;
3003 PL_copline = ocopline;
3004 PL_curcop = ocurcop;
3009 Perl_dofile(pTHX_ OP *term)
3014 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3015 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
3016 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3018 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3019 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3020 append_elem(OP_LIST, term,
3021 scalar(newUNOP(OP_RV2CV, 0,
3026 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3032 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3034 return newBINOP(OP_LSLICE, flags,
3035 list(force_list(subscript)),
3036 list(force_list(listval)) );
3040 S_list_assignment(pTHX_ register OP *o)
3045 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3046 o = cUNOPo->op_first;
3048 if (o->op_type == OP_COND_EXPR) {
3049 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3050 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3055 yyerror("Assignment to both a list and a scalar");
3059 if (o->op_type == OP_LIST &&
3060 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3061 o->op_private & OPpLVAL_INTRO)
3064 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3065 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3066 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3069 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3072 if (o->op_type == OP_RV2SV)
3079 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3084 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3085 return newLOGOP(optype, 0,
3086 mod(scalar(left), optype),
3087 newUNOP(OP_SASSIGN, 0, scalar(right)));
3090 return newBINOP(optype, OPf_STACKED,
3091 mod(scalar(left), optype), scalar(right));
3095 if (list_assignment(left)) {
3099 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3100 left = mod(left, OP_AASSIGN);
3108 curop = list(force_list(left));
3109 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3110 o->op_private = (U8)(0 | (flags >> 8));
3112 /* PL_generation sorcery:
3113 * an assignment like ($a,$b) = ($c,$d) is easier than
3114 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3115 * To detect whether there are common vars, the global var
3116 * PL_generation is incremented for each assign op we compile.
3117 * Then, while compiling the assign op, we run through all the
3118 * variables on both sides of the assignment, setting a spare slot
3119 * in each of them to PL_generation. If any of them already have
3120 * that value, we know we've got commonality. We could use a
3121 * single bit marker, but then we'd have to make 2 passes, first
3122 * to clear the flag, then to test and set it. To find somewhere
3123 * to store these values, evil chicanery is done with SvCUR().
3126 if (!(left->op_private & OPpLVAL_INTRO)) {
3129 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3130 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3131 if (curop->op_type == OP_GV) {
3132 GV *gv = cGVOPx_gv(curop);
3133 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3135 SvCUR(gv) = PL_generation;
3137 else if (curop->op_type == OP_PADSV ||
3138 curop->op_type == OP_PADAV ||
3139 curop->op_type == OP_PADHV ||
3140 curop->op_type == OP_PADANY)
3142 if (PAD_COMPNAME_GEN(curop->op_targ)
3143 == (STRLEN)PL_generation)
3145 PAD_COMPNAME_GEN(curop->op_targ)
3149 else if (curop->op_type == OP_RV2CV)
3151 else if (curop->op_type == OP_RV2SV ||
3152 curop->op_type == OP_RV2AV ||
3153 curop->op_type == OP_RV2HV ||
3154 curop->op_type == OP_RV2GV) {
3155 if (lastop->op_type != OP_GV) /* funny deref? */
3158 else if (curop->op_type == OP_PUSHRE) {
3159 if (((PMOP*)curop)->op_pmreplroot) {
3161 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3162 ((PMOP*)curop)->op_pmreplroot));
3164 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3166 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3168 SvCUR(gv) = PL_generation;
3177 o->op_private |= OPpASSIGN_COMMON;
3179 if (right && right->op_type == OP_SPLIT) {
3181 if ((tmpop = ((LISTOP*)right)->op_first) &&
3182 tmpop->op_type == OP_PUSHRE)
3184 PMOP *pm = (PMOP*)tmpop;
3185 if (left->op_type == OP_RV2AV &&
3186 !(left->op_private & OPpLVAL_INTRO) &&
3187 !(o->op_private & OPpASSIGN_COMMON) )
3189 tmpop = ((UNOP*)left)->op_first;
3190 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3192 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3193 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3195 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3196 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3198 pm->op_pmflags |= PMf_ONCE;
3199 tmpop = cUNOPo->op_first; /* to list (nulled) */
3200 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3201 tmpop->op_sibling = Nullop; /* don't free split */
3202 right->op_next = tmpop->op_next; /* fix starting loc */
3203 op_free(o); /* blow off assign */
3204 right->op_flags &= ~OPf_WANT;
3205 /* "I don't know and I don't care." */
3210 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3211 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3213 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3215 sv_setiv(sv, PL_modcount+1);
3223 right = newOP(OP_UNDEF, 0);
3224 if (right->op_type == OP_READLINE) {
3225 right->op_flags |= OPf_STACKED;
3226 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3229 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3230 o = newBINOP(OP_SASSIGN, flags,
3231 scalar(right), mod(scalar(left), OP_SASSIGN) );
3243 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3245 U32 seq = intro_my();
3248 NewOp(1101, cop, 1, COP);
3249 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3250 cop->op_type = OP_DBSTATE;
3251 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3254 cop->op_type = OP_NEXTSTATE;
3255 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3257 cop->op_flags = (U8)flags;
3258 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3260 cop->op_private |= NATIVE_HINTS;
3262 PL_compiling.op_private = cop->op_private;
3263 cop->op_next = (OP*)cop;
3266 cop->cop_label = label;
3267 PL_hints |= HINT_BLOCK_SCOPE;
3270 cop->cop_arybase = PL_curcop->cop_arybase;
3271 if (specialWARN(PL_curcop->cop_warnings))
3272 cop->cop_warnings = PL_curcop->cop_warnings ;
3274 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3275 if (specialCopIO(PL_curcop->cop_io))
3276 cop->cop_io = PL_curcop->cop_io;
3278 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3281 if (PL_copline == NOLINE)
3282 CopLINE_set(cop, CopLINE(PL_curcop));
3284 CopLINE_set(cop, PL_copline);
3285 PL_copline = NOLINE;
3288 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3290 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3292 CopSTASH_set(cop, PL_curstash);
3294 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3295 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3296 if (svp && *svp != &PL_sv_undef ) {
3297 (void)SvIOK_on(*svp);
3298 SvIVX(*svp) = PTR2IV(cop);
3302 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3307 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3309 return new_logop(type, flags, &first, &other);
3313 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3317 OP *first = *firstp;
3318 OP *other = *otherp;
3320 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3321 return newBINOP(type, flags, scalar(first), scalar(other));
3323 scalarboolean(first);
3324 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3325 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3326 if (type == OP_AND || type == OP_OR) {
3332 first = *firstp = cUNOPo->op_first;
3334 first->op_next = o->op_next;
3335 cUNOPo->op_first = Nullop;
3339 if (first->op_type == OP_CONST) {
3340 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE)) {
3341 if (first->op_private & OPpCONST_STRICT)
3342 no_bareword_allowed(first);
3344 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3346 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3357 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3358 OP *k1 = ((UNOP*)first)->op_first;
3359 OP *k2 = k1->op_sibling;
3361 switch (first->op_type)
3364 if (k2 && k2->op_type == OP_READLINE
3365 && (k2->op_flags & OPf_STACKED)
3366 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3368 warnop = k2->op_type;
3373 if (k1->op_type == OP_READDIR
3374 || k1->op_type == OP_GLOB
3375 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3376 || k1->op_type == OP_EACH)
3378 warnop = ((k1->op_type == OP_NULL)
3379 ? (OPCODE)k1->op_targ : k1->op_type);
3384 line_t oldline = CopLINE(PL_curcop);
3385 CopLINE_set(PL_curcop, PL_copline);
3386 Perl_warner(aTHX_ packWARN(WARN_MISC),
3387 "Value of %s%s can be \"0\"; test with defined()",
3389 ((warnop == OP_READLINE || warnop == OP_GLOB)
3390 ? " construct" : "() operator"));
3391 CopLINE_set(PL_curcop, oldline);
3398 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3399 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3401 NewOp(1101, logop, 1, LOGOP);
3403 logop->op_type = (OPCODE)type;
3404 logop->op_ppaddr = PL_ppaddr[type];
3405 logop->op_first = first;
3406 logop->op_flags = flags | OPf_KIDS;
3407 logop->op_other = LINKLIST(other);
3408 logop->op_private = (U8)(1 | (flags >> 8));
3410 /* establish postfix order */
3411 logop->op_next = LINKLIST(first);
3412 first->op_next = (OP*)logop;
3413 first->op_sibling = other;
3415 o = newUNOP(OP_NULL, 0, (OP*)logop);
3422 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3429 return newLOGOP(OP_AND, 0, first, trueop);
3431 return newLOGOP(OP_OR, 0, first, falseop);
3433 scalarboolean(first);
3434 if (first->op_type == OP_CONST) {
3435 if (first->op_private & OPpCONST_BARE &&
3436 first->op_private & OPpCONST_STRICT) {
3437 no_bareword_allowed(first);
3439 if (SvTRUE(((SVOP*)first)->op_sv)) {
3450 NewOp(1101, logop, 1, LOGOP);
3451 logop->op_type = OP_COND_EXPR;
3452 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3453 logop->op_first = first;
3454 logop->op_flags = flags | OPf_KIDS;
3455 logop->op_private = (U8)(1 | (flags >> 8));
3456 logop->op_other = LINKLIST(trueop);
3457 logop->op_next = LINKLIST(falseop);
3460 /* establish postfix order */
3461 start = LINKLIST(first);
3462 first->op_next = (OP*)logop;
3464 first->op_sibling = trueop;
3465 trueop->op_sibling = falseop;
3466 o = newUNOP(OP_NULL, 0, (OP*)logop);
3468 trueop->op_next = falseop->op_next = o;
3475 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3483 NewOp(1101, range, 1, LOGOP);
3485 range->op_type = OP_RANGE;
3486 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3487 range->op_first = left;
3488 range->op_flags = OPf_KIDS;
3489 leftstart = LINKLIST(left);
3490 range->op_other = LINKLIST(right);
3491 range->op_private = (U8)(1 | (flags >> 8));
3493 left->op_sibling = right;
3495 range->op_next = (OP*)range;
3496 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3497 flop = newUNOP(OP_FLOP, 0, flip);
3498 o = newUNOP(OP_NULL, 0, flop);
3500 range->op_next = leftstart;
3502 left->op_next = flip;
3503 right->op_next = flop;
3505 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3506 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3507 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3508 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3510 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3511 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3514 if (!flip->op_private || !flop->op_private)
3515 linklist(o); /* blow off optimizer unless constant */
3521 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3525 int once = block && block->op_flags & OPf_SPECIAL &&
3526 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3529 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3530 return block; /* do {} while 0 does once */
3531 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3532 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3533 expr = newUNOP(OP_DEFINED, 0,
3534 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3535 } else if (expr->op_flags & OPf_KIDS) {
3536 OP *k1 = ((UNOP*)expr)->op_first;
3537 OP *k2 = (k1) ? k1->op_sibling : NULL;
3538 switch (expr->op_type) {
3540 if (k2 && k2->op_type == OP_READLINE
3541 && (k2->op_flags & OPf_STACKED)
3542 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3543 expr = newUNOP(OP_DEFINED, 0, expr);
3547 if (k1->op_type == OP_READDIR
3548 || k1->op_type == OP_GLOB
3549 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3550 || k1->op_type == OP_EACH)
3551 expr = newUNOP(OP_DEFINED, 0, expr);
3557 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3558 o = new_logop(OP_AND, 0, &expr, &listop);
3561 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3563 if (once && o != listop)
3564 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3567 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3569 o->op_flags |= flags;
3571 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3576 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3584 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3585 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3586 expr = newUNOP(OP_DEFINED, 0,
3587 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3588 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3589 OP *k1 = ((UNOP*)expr)->op_first;
3590 OP *k2 = (k1) ? k1->op_sibling : NULL;
3591 switch (expr->op_type) {
3593 if (k2 && k2->op_type == OP_READLINE
3594 && (k2->op_flags & OPf_STACKED)
3595 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3596 expr = newUNOP(OP_DEFINED, 0, expr);
3600 if (k1->op_type == OP_READDIR
3601 || k1->op_type == OP_GLOB
3602 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3603 || k1->op_type == OP_EACH)
3604 expr = newUNOP(OP_DEFINED, 0, expr);
3610 block = newOP(OP_NULL, 0);
3612 block = scope(block);
3616 next = LINKLIST(cont);
3619 OP *unstack = newOP(OP_UNSTACK, 0);
3622 cont = append_elem(OP_LINESEQ, cont, unstack);
3625 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3626 redo = LINKLIST(listop);
3629 PL_copline = (line_t)whileline;
3631 o = new_logop(OP_AND, 0, &expr, &listop);
3632 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3633 op_free(expr); /* oops, it's a while (0) */
3635 return Nullop; /* listop already freed by new_logop */
3638 ((LISTOP*)listop)->op_last->op_next =
3639 (o == listop ? redo : LINKLIST(o));
3645 NewOp(1101,loop,1,LOOP);
3646 loop->op_type = OP_ENTERLOOP;
3647 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3648 loop->op_private = 0;
3649 loop->op_next = (OP*)loop;
3652 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3654 loop->op_redoop = redo;
3655 loop->op_lastop = o;
3656 o->op_private |= loopflags;
3659 loop->op_nextop = next;
3661 loop->op_nextop = o;
3663 o->op_flags |= flags;
3664 o->op_private |= (flags >> 8);
3669 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
3673 PADOFFSET padoff = 0;
3678 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
3679 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
3680 sv->op_type = OP_RV2GV;
3681 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3683 else if (sv->op_type == OP_PADSV) { /* private variable */
3684 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
3685 padoff = sv->op_targ;
3690 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3691 padoff = sv->op_targ;
3693 iterflags |= OPf_SPECIAL;
3698 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3701 sv = newGVOP(OP_GV, 0, PL_defgv);
3703 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3704 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3705 iterflags |= OPf_STACKED;
3707 else if (expr->op_type == OP_NULL &&
3708 (expr->op_flags & OPf_KIDS) &&
3709 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3711 /* Basically turn for($x..$y) into the same as for($x,$y), but we
3712 * set the STACKED flag to indicate that these values are to be
3713 * treated as min/max values by 'pp_iterinit'.
3715 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
3716 LOGOP* range = (LOGOP*) flip->op_first;
3717 OP* left = range->op_first;
3718 OP* right = left->op_sibling;
3721 range->op_flags &= ~OPf_KIDS;
3722 range->op_first = Nullop;
3724 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
3725 listop->op_first->op_next = range->op_next;
3726 left->op_next = range->op_other;
3727 right->op_next = (OP*)listop;
3728 listop->op_next = listop->op_first;
3731 expr = (OP*)(listop);
3733 iterflags |= OPf_STACKED;
3736 expr = mod(force_list(expr), OP_GREPSTART);
3740 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
3741 append_elem(OP_LIST, expr, scalar(sv))));
3742 assert(!loop->op_next);
3743 /* for my $x () sets OPpLVAL_INTRO;
3744 * for our $x () sets OPpOUR_INTRO; both only used by Deparse.pm */
3745 loop->op_private = iterpflags;
3746 #ifdef PL_OP_SLAB_ALLOC
3749 NewOp(1234,tmp,1,LOOP);
3750 Copy(loop,tmp,1,LOOP);
3755 Renew(loop, 1, LOOP);
3757 loop->op_targ = padoff;
3758 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
3759 PL_copline = forline;
3760 return newSTATEOP(0, label, wop);
3764 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
3769 if (type != OP_GOTO || label->op_type == OP_CONST) {
3770 /* "last()" means "last" */
3771 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
3772 o = newOP(type, OPf_SPECIAL);
3774 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
3775 ? SvPVx(((SVOP*)label)->op_sv, n_a)
3781 if (label->op_type == OP_ENTERSUB)
3782 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
3783 o = newUNOP(type, OPf_STACKED, label);
3785 PL_hints |= HINT_BLOCK_SCOPE;
3790 =for apidoc cv_undef
3792 Clear out all the active components of a CV. This can happen either
3793 by an explicit C<undef &foo>, or by the reference count going to zero.
3794 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
3795 children can still follow the full lexical scope chain.
3801 Perl_cv_undef(pTHX_ CV *cv)
3804 if (CvFILE(cv) && !CvXSUB(cv)) {
3805 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
3806 Safefree(CvFILE(cv));
3811 if (!CvXSUB(cv) && CvROOT(cv)) {
3813 Perl_croak(aTHX_ "Can't undef active subroutine");
3816 PAD_SAVE_SETNULLPAD();
3818 op_free(CvROOT(cv));
3819 CvROOT(cv) = Nullop;
3822 SvPOK_off((SV*)cv); /* forget prototype */
3827 /* remove CvOUTSIDE unless this is an undef rather than a free */
3828 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
3829 if (!CvWEAKOUTSIDE(cv))
3830 SvREFCNT_dec(CvOUTSIDE(cv));
3831 CvOUTSIDE(cv) = Nullcv;
3834 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
3840 /* delete all flags except WEAKOUTSIDE */
3841 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
3845 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
3847 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
3848 SV* msg = sv_newmortal();
3852 gv_efullname3(name = sv_newmortal(), gv, Nullch);
3853 sv_setpv(msg, "Prototype mismatch:");
3855 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
3857 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (SV *)cv);
3858 sv_catpv(msg, " vs ");
3860 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
3862 sv_catpv(msg, "none");
3863 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
3867 static void const_sv_xsub(pTHX_ CV* cv);
3871 =head1 Optree Manipulation Functions
3873 =for apidoc cv_const_sv
3875 If C<cv> is a constant sub eligible for inlining. returns the constant
3876 value returned by the sub. Otherwise, returns NULL.
3878 Constant subs can be created with C<newCONSTSUB> or as described in
3879 L<perlsub/"Constant Functions">.
3884 Perl_cv_const_sv(pTHX_ CV *cv)
3886 if (!cv || !CvCONST(cv))
3888 return (SV*)CvXSUBANY(cv).any_ptr;
3891 /* op_const_sv: examine an optree to determine whether it's in-lineable.
3892 * Can be called in 3 ways:
3895 * look for a single OP_CONST with attached value: return the value
3897 * cv && CvCLONE(cv) && !CvCONST(cv)
3899 * examine the clone prototype, and if contains only a single
3900 * OP_CONST referencing a pad const, or a single PADSV referencing
3901 * an outer lexical, return a non-zero value to indicate the CV is
3902 * a candidate for "constizing" at clone time
3906 * We have just cloned an anon prototype that was marked as a const
3907 * candidiate. Try to grab the current value, and in the case of
3908 * PADSV, ignore it if it has multiple references. Return the value.
3912 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
3919 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
3920 o = cLISTOPo->op_first->op_sibling;
3922 for (; o; o = o->op_next) {
3923 OPCODE type = o->op_type;
3925 if (sv && o->op_next == o)
3927 if (o->op_next != o) {
3928 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
3930 if (type == OP_DBSTATE)
3933 if (type == OP_LEAVESUB || type == OP_RETURN)
3937 if (type == OP_CONST && cSVOPo->op_sv)
3939 else if (cv && type == OP_CONST) {
3940 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
3944 else if (cv && type == OP_PADSV) {
3945 if (CvCONST(cv)) { /* newly cloned anon */
3946 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
3947 /* the candidate should have 1 ref from this pad and 1 ref
3948 * from the parent */
3949 if (!sv || SvREFCNT(sv) != 2)
3956 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
3957 sv = &PL_sv_undef; /* an arbitrary non-null value */
3968 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
3978 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
3982 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
3984 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
3988 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
3994 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
3998 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
3999 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4000 SV *sv = sv_newmortal();
4001 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4002 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4003 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4008 gv = gv_fetchpv(name ? name : (aname ? aname :
4009 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__")),
4010 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4020 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4021 maximum a prototype before. */
4022 if (SvTYPE(gv) > SVt_NULL) {
4023 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4024 && ckWARN_d(WARN_PROTOTYPE))
4026 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4028 cv_ckproto((CV*)gv, NULL, ps);
4031 sv_setpv((SV*)gv, ps);
4033 sv_setiv((SV*)gv, -1);
4034 SvREFCNT_dec(PL_compcv);
4035 cv = PL_compcv = NULL;
4036 PL_sub_generation++;
4040 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4042 #ifdef GV_UNIQUE_CHECK
4043 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4044 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4048 if (!block || !ps || *ps || attrs)
4051 const_sv = op_const_sv(block, Nullcv);
4054 bool exists = CvROOT(cv) || CvXSUB(cv);
4056 #ifdef GV_UNIQUE_CHECK
4057 if (exists && GvUNIQUE(gv)) {
4058 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4062 /* if the subroutine doesn't exist and wasn't pre-declared
4063 * with a prototype, assume it will be AUTOLOADed,
4064 * skipping the prototype check
4066 if (exists || SvPOK(cv))
4067 cv_ckproto(cv, gv, ps);
4068 /* already defined (or promised)? */
4069 if (exists || GvASSUMECV(gv)) {
4070 if (!block && !attrs) {
4071 if (CvFLAGS(PL_compcv)) {
4072 /* might have had built-in attrs applied */
4073 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4075 /* just a "sub foo;" when &foo is already defined */
4076 SAVEFREESV(PL_compcv);
4079 /* ahem, death to those who redefine active sort subs */
4080 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4081 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4083 if (ckWARN(WARN_REDEFINE)
4085 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4087 line_t oldline = CopLINE(PL_curcop);
4088 if (PL_copline != NOLINE)
4089 CopLINE_set(PL_curcop, PL_copline);
4090 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4091 CvCONST(cv) ? "Constant subroutine %s redefined"
4092 : "Subroutine %s redefined", name);
4093 CopLINE_set(PL_curcop, oldline);
4101 SvREFCNT_inc(const_sv);
4103 assert(!CvROOT(cv) && !CvCONST(cv));
4104 sv_setpv((SV*)cv, ""); /* prototype is "" */
4105 CvXSUBANY(cv).any_ptr = const_sv;
4106 CvXSUB(cv) = const_sv_xsub;
4111 cv = newCONSTSUB(NULL, name, const_sv);
4114 SvREFCNT_dec(PL_compcv);
4116 PL_sub_generation++;
4123 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4124 * before we clobber PL_compcv.
4128 /* Might have had built-in attributes applied -- propagate them. */
4129 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4130 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4131 stash = GvSTASH(CvGV(cv));
4132 else if (CvSTASH(cv))
4133 stash = CvSTASH(cv);
4135 stash = PL_curstash;
4138 /* possibly about to re-define existing subr -- ignore old cv */
4139 rcv = (SV*)PL_compcv;
4140 if (name && GvSTASH(gv))
4141 stash = GvSTASH(gv);
4143 stash = PL_curstash;
4145 apply_attrs(stash, rcv, attrs, FALSE);
4147 if (cv) { /* must reuse cv if autoloaded */
4149 /* got here with just attrs -- work done, so bug out */
4150 SAVEFREESV(PL_compcv);
4153 /* transfer PL_compcv to cv */
4155 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4156 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4157 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4158 CvOUTSIDE(PL_compcv) = 0;
4159 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4160 CvPADLIST(PL_compcv) = 0;
4161 /* inner references to PL_compcv must be fixed up ... */
4162 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4163 /* ... before we throw it away */
4164 SvREFCNT_dec(PL_compcv);
4166 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4167 ++PL_sub_generation;
4174 PL_sub_generation++;
4178 CvFILE_set_from_cop(cv, PL_curcop);
4179 CvSTASH(cv) = PL_curstash;
4182 sv_setpv((SV*)cv, ps);
4184 if (PL_error_count) {
4188 char *s = strrchr(name, ':');
4190 if (strEQ(s, "BEGIN")) {
4192 "BEGIN not safe after errors--compilation aborted";
4193 if (PL_in_eval & EVAL_KEEPERR)
4194 Perl_croak(aTHX_ not_safe);
4196 /* force display of errors found but not reported */
4197 sv_catpv(ERRSV, not_safe);
4198 Perl_croak(aTHX_ "%"SVf, ERRSV);
4207 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4208 mod(scalarseq(block), OP_LEAVESUBLV));
4211 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4213 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4214 OpREFCNT_set(CvROOT(cv), 1);
4215 CvSTART(cv) = LINKLIST(CvROOT(cv));
4216 CvROOT(cv)->op_next = 0;
4217 CALL_PEEP(CvSTART(cv));
4219 /* now that optimizer has done its work, adjust pad values */
4221 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4224 assert(!CvCONST(cv));
4225 if (ps && !*ps && op_const_sv(block, cv))
4229 if (name || aname) {
4231 char *tname = (name ? name : aname);
4233 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4234 SV *sv = NEWSV(0,0);
4235 SV *tmpstr = sv_newmortal();
4236 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4240 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4242 (long)PL_subline, (long)CopLINE(PL_curcop));
4243 gv_efullname3(tmpstr, gv, Nullch);
4244 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4245 hv = GvHVn(db_postponed);
4246 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4247 && (pcv = GvCV(db_postponed)))
4253 call_sv((SV*)pcv, G_DISCARD);
4257 if ((s = strrchr(tname,':')))
4262 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4265 if (strEQ(s, "BEGIN") && !PL_error_count) {
4266 I32 oldscope = PL_scopestack_ix;
4268 SAVECOPFILE(&PL_compiling);
4269 SAVECOPLINE(&PL_compiling);
4272 PL_beginav = newAV();
4273 DEBUG_x( dump_sub(gv) );
4274 av_push(PL_beginav, (SV*)cv);
4275 GvCV(gv) = 0; /* cv has been hijacked */
4276 call_list(oldscope, PL_beginav);
4278 PL_curcop = &PL_compiling;
4279 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4282 else if (strEQ(s, "END") && !PL_error_count) {
4285 DEBUG_x( dump_sub(gv) );
4286 av_unshift(PL_endav, 1);
4287 av_store(PL_endav, 0, (SV*)cv);
4288 GvCV(gv) = 0; /* cv has been hijacked */
4290 else if (strEQ(s, "CHECK") && !PL_error_count) {
4292 PL_checkav = newAV();
4293 DEBUG_x( dump_sub(gv) );
4294 if (PL_main_start && ckWARN(WARN_VOID))
4295 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4296 av_unshift(PL_checkav, 1);
4297 av_store(PL_checkav, 0, (SV*)cv);
4298 GvCV(gv) = 0; /* cv has been hijacked */
4300 else if (strEQ(s, "INIT") && !PL_error_count) {
4302 PL_initav = newAV();
4303 DEBUG_x( dump_sub(gv) );
4304 if (PL_main_start && ckWARN(WARN_VOID))
4305 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4306 av_push(PL_initav, (SV*)cv);
4307 GvCV(gv) = 0; /* cv has been hijacked */
4312 PL_copline = NOLINE;
4317 /* XXX unsafe for threads if eval_owner isn't held */
4319 =for apidoc newCONSTSUB
4321 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4322 eligible for inlining at compile-time.
4328 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4334 SAVECOPLINE(PL_curcop);
4335 CopLINE_set(PL_curcop, PL_copline);
4338 PL_hints &= ~HINT_BLOCK_SCOPE;
4341 SAVESPTR(PL_curstash);
4342 SAVECOPSTASH(PL_curcop);
4343 PL_curstash = stash;
4344 CopSTASH_set(PL_curcop,stash);
4347 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4348 CvXSUBANY(cv).any_ptr = sv;
4350 sv_setpv((SV*)cv, ""); /* prototype is "" */
4358 =for apidoc U||newXS
4360 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4366 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
4368 GV *gv = gv_fetchpv(name ? name :
4369 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4370 GV_ADDMULTI, SVt_PVCV);
4374 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4376 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4378 /* just a cached method */
4382 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4383 /* already defined (or promised) */
4384 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4385 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4386 line_t oldline = CopLINE(PL_curcop);
4387 if (PL_copline != NOLINE)
4388 CopLINE_set(PL_curcop, PL_copline);
4389 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4390 CvCONST(cv) ? "Constant subroutine %s redefined"
4391 : "Subroutine %s redefined"
4393 CopLINE_set(PL_curcop, oldline);
4400 if (cv) /* must reuse cv if autoloaded */
4403 cv = (CV*)NEWSV(1105,0);
4404 sv_upgrade((SV *)cv, SVt_PVCV);
4408 PL_sub_generation++;
4412 (void)gv_fetchfile(filename);
4413 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
4414 an external constant string */
4415 CvXSUB(cv) = subaddr;
4418 char *s = strrchr(name,':');
4424 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4427 if (strEQ(s, "BEGIN")) {
4429 PL_beginav = newAV();
4430 av_push(PL_beginav, (SV*)cv);
4431 GvCV(gv) = 0; /* cv has been hijacked */
4433 else if (strEQ(s, "END")) {
4436 av_unshift(PL_endav, 1);
4437 av_store(PL_endav, 0, (SV*)cv);
4438 GvCV(gv) = 0; /* cv has been hijacked */
4440 else if (strEQ(s, "CHECK")) {
4442 PL_checkav = newAV();
4443 if (PL_main_start && ckWARN(WARN_VOID))
4444 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4445 av_unshift(PL_checkav, 1);
4446 av_store(PL_checkav, 0, (SV*)cv);
4447 GvCV(gv) = 0; /* cv has been hijacked */
4449 else if (strEQ(s, "INIT")) {
4451 PL_initav = newAV();
4452 if (PL_main_start && ckWARN(WARN_VOID))
4453 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4454 av_push(PL_initav, (SV*)cv);
4455 GvCV(gv) = 0; /* cv has been hijacked */
4466 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4474 name = SvPVx(cSVOPo->op_sv, n_a);
4477 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
4478 #ifdef GV_UNIQUE_CHECK
4480 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4484 if ((cv = GvFORM(gv))) {
4485 if (ckWARN(WARN_REDEFINE)) {
4486 line_t oldline = CopLINE(PL_curcop);
4487 if (PL_copline != NOLINE)
4488 CopLINE_set(PL_curcop, PL_copline);
4489 Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Format %s redefined",name);
4490 CopLINE_set(PL_curcop, oldline);
4497 CvFILE_set_from_cop(cv, PL_curcop);
4500 pad_tidy(padtidy_FORMAT);
4501 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4502 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4503 OpREFCNT_set(CvROOT(cv), 1);
4504 CvSTART(cv) = LINKLIST(CvROOT(cv));
4505 CvROOT(cv)->op_next = 0;
4506 CALL_PEEP(CvSTART(cv));
4508 PL_copline = NOLINE;
4513 Perl_newANONLIST(pTHX_ OP *o)
4515 return newUNOP(OP_REFGEN, 0,
4516 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4520 Perl_newANONHASH(pTHX_ OP *o)
4522 return newUNOP(OP_REFGEN, 0,
4523 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4527 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4529 return newANONATTRSUB(floor, proto, Nullop, block);
4533 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4535 return newUNOP(OP_REFGEN, 0,
4536 newSVOP(OP_ANONCODE, 0,
4537 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
4541 Perl_oopsAV(pTHX_ OP *o)
4543 switch (o->op_type) {
4545 o->op_type = OP_PADAV;
4546 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4547 return ref(o, OP_RV2AV);
4550 o->op_type = OP_RV2AV;
4551 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4556 if (ckWARN_d(WARN_INTERNAL))
4557 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
4564 Perl_oopsHV(pTHX_ OP *o)
4566 switch (o->op_type) {
4569 o->op_type = OP_PADHV;
4570 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4571 return ref(o, OP_RV2HV);
4575 o->op_type = OP_RV2HV;
4576 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
4581 if (ckWARN_d(WARN_INTERNAL))
4582 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
4589 Perl_newAVREF(pTHX_ OP *o)
4591 if (o->op_type == OP_PADANY) {
4592 o->op_type = OP_PADAV;
4593 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4596 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
4597 && ckWARN(WARN_DEPRECATED)) {
4598 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4599 "Using an array as a reference is deprecated");
4601 return newUNOP(OP_RV2AV, 0, scalar(o));
4605 Perl_newGVREF(pTHX_ I32 type, OP *o)
4607 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
4608 return newUNOP(OP_NULL, 0, o);
4609 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
4613 Perl_newHVREF(pTHX_ OP *o)
4615 if (o->op_type == OP_PADANY) {
4616 o->op_type = OP_PADHV;
4617 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4620 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
4621 && ckWARN(WARN_DEPRECATED)) {
4622 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4623 "Using a hash as a reference is deprecated");
4625 return newUNOP(OP_RV2HV, 0, scalar(o));
4629 Perl_oopsCV(pTHX_ OP *o)
4631 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
4637 Perl_newCVREF(pTHX_ I32 flags, OP *o)
4639 return newUNOP(OP_RV2CV, flags, scalar(o));
4643 Perl_newSVREF(pTHX_ OP *o)
4645 if (o->op_type == OP_PADANY) {
4646 o->op_type = OP_PADSV;
4647 o->op_ppaddr = PL_ppaddr[OP_PADSV];
4650 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4651 o->op_flags |= OPpDONE_SVREF;
4654 return newUNOP(OP_RV2SV, 0, scalar(o));
4657 /* Check routines. */
4660 Perl_ck_anoncode(pTHX_ OP *o)
4662 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
4663 cSVOPo->op_sv = Nullsv;
4668 Perl_ck_bitop(pTHX_ OP *o)
4670 #define OP_IS_NUMCOMPARE(op) \
4671 ((op) == OP_LT || (op) == OP_I_LT || \
4672 (op) == OP_GT || (op) == OP_I_GT || \
4673 (op) == OP_LE || (op) == OP_I_LE || \
4674 (op) == OP_GE || (op) == OP_I_GE || \
4675 (op) == OP_EQ || (op) == OP_I_EQ || \
4676 (op) == OP_NE || (op) == OP_I_NE || \
4677 (op) == OP_NCMP || (op) == OP_I_NCMP)
4678 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4679 if (o->op_type == OP_BIT_OR
4680 || o->op_type == OP_BIT_AND
4681 || o->op_type == OP_BIT_XOR)
4683 OP * left = cBINOPo->op_first;
4684 OP * right = left->op_sibling;
4685 if ((OP_IS_NUMCOMPARE(left->op_type) &&
4686 (left->op_flags & OPf_PARENS) == 0) ||
4687 (OP_IS_NUMCOMPARE(right->op_type) &&
4688 (right->op_flags & OPf_PARENS) == 0))
4689 if (ckWARN(WARN_PRECEDENCE))
4690 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4691 "Possible precedence problem on bitwise %c operator",
4692 o->op_type == OP_BIT_OR ? '|'
4693 : o->op_type == OP_BIT_AND ? '&' : '^'
4700 Perl_ck_concat(pTHX_ OP *o)
4702 if (cUNOPo->op_first->op_type == OP_CONCAT)
4703 o->op_flags |= OPf_STACKED;
4708 Perl_ck_spair(pTHX_ OP *o)
4710 if (o->op_flags & OPf_KIDS) {
4713 OPCODE type = o->op_type;
4714 o = modkids(ck_fun(o), type);
4715 kid = cUNOPo->op_first;
4716 newop = kUNOP->op_first->op_sibling;
4718 (newop->op_sibling ||
4719 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
4720 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
4721 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
4725 op_free(kUNOP->op_first);
4726 kUNOP->op_first = newop;
4728 o->op_ppaddr = PL_ppaddr[++o->op_type];
4733 Perl_ck_delete(pTHX_ OP *o)
4737 if (o->op_flags & OPf_KIDS) {
4738 OP *kid = cUNOPo->op_first;
4739 switch (kid->op_type) {
4741 o->op_flags |= OPf_SPECIAL;
4744 o->op_private |= OPpSLICE;
4747 o->op_flags |= OPf_SPECIAL;
4752 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
4761 Perl_ck_die(pTHX_ OP *o)
4764 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4770 Perl_ck_eof(pTHX_ OP *o)
4772 I32 type = o->op_type;
4774 if (o->op_flags & OPf_KIDS) {
4775 if (cLISTOPo->op_first->op_type == OP_STUB) {
4777 o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
4785 Perl_ck_eval(pTHX_ OP *o)
4787 PL_hints |= HINT_BLOCK_SCOPE;
4788 if (o->op_flags & OPf_KIDS) {
4789 SVOP *kid = (SVOP*)cUNOPo->op_first;
4792 o->op_flags &= ~OPf_KIDS;
4795 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
4798 cUNOPo->op_first = 0;
4801 NewOp(1101, enter, 1, LOGOP);
4802 enter->op_type = OP_ENTERTRY;
4803 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
4804 enter->op_private = 0;
4806 /* establish postfix order */
4807 enter->op_next = (OP*)enter;
4809 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
4810 o->op_type = OP_LEAVETRY;
4811 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
4812 enter->op_other = o;
4822 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
4824 o->op_targ = (PADOFFSET)PL_hints;
4829 Perl_ck_exit(pTHX_ OP *o)
4832 HV *table = GvHV(PL_hintgv);
4834 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
4835 if (svp && *svp && SvTRUE(*svp))
4836 o->op_private |= OPpEXIT_VMSISH;
4838 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4844 Perl_ck_exec(pTHX_ OP *o)
4847 if (o->op_flags & OPf_STACKED) {
4849 kid = cUNOPo->op_first->op_sibling;
4850 if (kid->op_type == OP_RV2GV)
4859 Perl_ck_exists(pTHX_ OP *o)
4862 if (o->op_flags & OPf_KIDS) {
4863 OP *kid = cUNOPo->op_first;
4864 if (kid->op_type == OP_ENTERSUB) {
4865 (void) ref(kid, o->op_type);
4866 if (kid->op_type != OP_RV2CV && !PL_error_count)
4867 Perl_croak(aTHX_ "%s argument is not a subroutine name",
4869 o->op_private |= OPpEXISTS_SUB;
4871 else if (kid->op_type == OP_AELEM)
4872 o->op_flags |= OPf_SPECIAL;
4873 else if (kid->op_type != OP_HELEM)
4874 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
4883 Perl_ck_gvconst(pTHX_ register OP *o)
4885 o = fold_constants(o);
4886 if (o->op_type == OP_CONST)
4893 Perl_ck_rvconst(pTHX_ register OP *o)
4895 SVOP *kid = (SVOP*)cUNOPo->op_first;
4897 o->op_private |= (PL_hints & HINT_STRICT_REFS);
4898 if (kid->op_type == OP_CONST) {
4902 SV *kidsv = kid->op_sv;
4905 /* Is it a constant from cv_const_sv()? */
4906 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
4907 SV *rsv = SvRV(kidsv);
4908 int svtype = SvTYPE(rsv);
4909 char *badtype = Nullch;
4911 switch (o->op_type) {
4913 if (svtype > SVt_PVMG)
4914 badtype = "a SCALAR";
4917 if (svtype != SVt_PVAV)
4918 badtype = "an ARRAY";
4921 if (svtype != SVt_PVHV)
4925 if (svtype != SVt_PVCV)
4930 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
4933 name = SvPV(kidsv, n_a);
4934 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
4935 char *badthing = Nullch;
4936 switch (o->op_type) {
4938 badthing = "a SCALAR";
4941 badthing = "an ARRAY";
4944 badthing = "a HASH";
4949 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
4953 * This is a little tricky. We only want to add the symbol if we
4954 * didn't add it in the lexer. Otherwise we get duplicate strict
4955 * warnings. But if we didn't add it in the lexer, we must at
4956 * least pretend like we wanted to add it even if it existed before,
4957 * or we get possible typo warnings. OPpCONST_ENTERED says
4958 * whether the lexer already added THIS instance of this symbol.
4960 iscv = (o->op_type == OP_RV2CV) * 2;
4962 gv = gv_fetchpv(name,
4963 iscv | !(kid->op_private & OPpCONST_ENTERED),
4966 : o->op_type == OP_RV2SV
4968 : o->op_type == OP_RV2AV
4970 : o->op_type == OP_RV2HV
4973 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
4975 kid->op_type = OP_GV;
4976 SvREFCNT_dec(kid->op_sv);
4978 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
4979 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
4980 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
4982 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
4984 kid->op_sv = SvREFCNT_inc(gv);
4986 kid->op_private = 0;
4987 kid->op_ppaddr = PL_ppaddr[OP_GV];
4994 Perl_ck_ftst(pTHX_ OP *o)
4996 I32 type = o->op_type;
4998 if (o->op_flags & OPf_REF) {
5001 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5002 SVOP *kid = (SVOP*)cUNOPo->op_first;
5004 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5006 OP *newop = newGVOP(type, OPf_REF,
5007 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5012 if ((PL_hints & HINT_FILETEST_ACCESS) &&
5013 OP_IS_FILETEST_ACCESS(o))
5014 o->op_private |= OPpFT_ACCESS;
5019 if (type == OP_FTTTY)
5020 o = newGVOP(type, OPf_REF, PL_stdingv);
5022 o = newUNOP(type, 0, newDEFSVOP());
5028 Perl_ck_fun(pTHX_ OP *o)
5034 int type = o->op_type;
5035 register I32 oa = PL_opargs[type] >> OASHIFT;
5037 if (o->op_flags & OPf_STACKED) {
5038 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5041 return no_fh_allowed(o);
5044 if (o->op_flags & OPf_KIDS) {
5046 tokid = &cLISTOPo->op_first;
5047 kid = cLISTOPo->op_first;
5048 if (kid->op_type == OP_PUSHMARK ||
5049 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5051 tokid = &kid->op_sibling;
5052 kid = kid->op_sibling;
5054 if (!kid && PL_opargs[type] & OA_DEFGV)
5055 *tokid = kid = newDEFSVOP();
5059 sibl = kid->op_sibling;
5062 /* list seen where single (scalar) arg expected? */
5063 if (numargs == 1 && !(oa >> 4)
5064 && kid->op_type == OP_LIST && type != OP_SCALAR)
5066 return too_many_arguments(o,PL_op_desc[type]);
5079 if ((type == OP_PUSH || type == OP_UNSHIFT)
5080 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5081 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5082 "Useless use of %s with no values",
5085 if (kid->op_type == OP_CONST &&
5086 (kid->op_private & OPpCONST_BARE))
5088 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5089 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5090 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5091 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5092 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5093 "Array @%s missing the @ in argument %"IVdf" of %s()",
5094 name, (IV)numargs, PL_op_desc[type]);
5097 kid->op_sibling = sibl;
5100 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5101 bad_type(numargs, "array", PL_op_desc[type], kid);
5105 if (kid->op_type == OP_CONST &&
5106 (kid->op_private & OPpCONST_BARE))
5108 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5109 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5110 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5111 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5112 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5113 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5114 name, (IV)numargs, PL_op_desc[type]);
5117 kid->op_sibling = sibl;
5120 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5121 bad_type(numargs, "hash", PL_op_desc[type], kid);
5126 OP *newop = newUNOP(OP_NULL, 0, kid);
5127 kid->op_sibling = 0;
5129 newop->op_next = newop;
5131 kid->op_sibling = sibl;
5136 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5137 if (kid->op_type == OP_CONST &&
5138 (kid->op_private & OPpCONST_BARE))
5140 OP *newop = newGVOP(OP_GV, 0,
5141 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5143 if (!(o->op_private & 1) && /* if not unop */
5144 kid == cLISTOPo->op_last)
5145 cLISTOPo->op_last = newop;
5149 else if (kid->op_type == OP_READLINE) {
5150 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5151 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5154 I32 flags = OPf_SPECIAL;
5158 /* is this op a FH constructor? */
5159 if (is_handle_constructor(o,numargs)) {
5160 char *name = Nullch;
5164 /* Set a flag to tell rv2gv to vivify
5165 * need to "prove" flag does not mean something
5166 * else already - NI-S 1999/05/07
5169 if (kid->op_type == OP_PADSV) {
5170 name = PAD_COMPNAME_PV(kid->op_targ);
5171 /* SvCUR of a pad namesv can't be trusted
5172 * (see PL_generation), so calc its length
5178 else if (kid->op_type == OP_RV2SV
5179 && kUNOP->op_first->op_type == OP_GV)
5181 GV *gv = cGVOPx_gv(kUNOP->op_first);
5183 len = GvNAMELEN(gv);
5185 else if (kid->op_type == OP_AELEM
5186 || kid->op_type == OP_HELEM)
5191 if ((op = ((BINOP*)kid)->op_first)) {
5192 SV *tmpstr = Nullsv;
5194 kid->op_type == OP_AELEM ?
5196 if (((op->op_type == OP_RV2AV) ||
5197 (op->op_type == OP_RV2HV)) &&
5198 (op = ((UNOP*)op)->op_first) &&
5199 (op->op_type == OP_GV)) {
5200 /* packagevar $a[] or $h{} */
5201 GV *gv = cGVOPx_gv(op);
5209 else if (op->op_type == OP_PADAV
5210 || op->op_type == OP_PADHV) {
5211 /* lexicalvar $a[] or $h{} */
5213 PAD_COMPNAME_PV(op->op_targ);
5223 name = savepv(SvPVX(tmpstr));
5229 name = "__ANONIO__";
5236 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5237 namesv = PAD_SVl(targ);
5238 (void)SvUPGRADE(namesv, SVt_PV);
5240 sv_setpvn(namesv, "$", 1);
5241 sv_catpvn(namesv, name, len);
5244 kid->op_sibling = 0;
5245 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5246 kid->op_targ = targ;
5247 kid->op_private |= priv;
5249 kid->op_sibling = sibl;
5255 mod(scalar(kid), type);
5259 tokid = &kid->op_sibling;
5260 kid = kid->op_sibling;
5262 o->op_private |= numargs;
5264 return too_many_arguments(o,OP_DESC(o));
5267 else if (PL_opargs[type] & OA_DEFGV) {
5269 return newUNOP(type, 0, newDEFSVOP());
5273 while (oa & OA_OPTIONAL)
5275 if (oa && oa != OA_LIST)
5276 return too_few_arguments(o,OP_DESC(o));
5282 Perl_ck_glob(pTHX_ OP *o)
5287 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5288 append_elem(OP_GLOB, o, newDEFSVOP());
5290 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5291 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5293 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5296 #if !defined(PERL_EXTERNAL_GLOB)
5297 /* XXX this can be tightened up and made more failsafe. */
5301 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5302 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5303 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5304 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5305 GvCV(gv) = GvCV(glob_gv);
5306 SvREFCNT_inc((SV*)GvCV(gv));
5307 GvIMPORTED_CV_on(gv);
5310 #endif /* PERL_EXTERNAL_GLOB */
5312 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5313 append_elem(OP_GLOB, o,
5314 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5315 o->op_type = OP_LIST;
5316 o->op_ppaddr = PL_ppaddr[OP_LIST];
5317 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5318 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5319 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5320 append_elem(OP_LIST, o,
5321 scalar(newUNOP(OP_RV2CV, 0,
5322 newGVOP(OP_GV, 0, gv)))));
5323 o = newUNOP(OP_NULL, 0, ck_subr(o));
5324 o->op_targ = OP_GLOB; /* hint at what it used to be */
5327 gv = newGVgen("main");
5329 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5335 Perl_ck_grep(pTHX_ OP *o)
5339 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5341 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5342 NewOp(1101, gwop, 1, LOGOP);
5344 if (o->op_flags & OPf_STACKED) {
5347 kid = cLISTOPo->op_first->op_sibling;
5348 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5351 kid->op_next = (OP*)gwop;
5352 o->op_flags &= ~OPf_STACKED;
5354 kid = cLISTOPo->op_first->op_sibling;
5355 if (type == OP_MAPWHILE)
5362 kid = cLISTOPo->op_first->op_sibling;
5363 if (kid->op_type != OP_NULL)
5364 Perl_croak(aTHX_ "panic: ck_grep");
5365 kid = kUNOP->op_first;
5367 gwop->op_type = type;
5368 gwop->op_ppaddr = PL_ppaddr[type];
5369 gwop->op_first = listkids(o);
5370 gwop->op_flags |= OPf_KIDS;
5371 gwop->op_private = 1;
5372 gwop->op_other = LINKLIST(kid);
5373 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5374 kid->op_next = (OP*)gwop;
5376 kid = cLISTOPo->op_first->op_sibling;
5377 if (!kid || !kid->op_sibling)
5378 return too_few_arguments(o,OP_DESC(o));
5379 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5380 mod(kid, OP_GREPSTART);
5386 Perl_ck_index(pTHX_ OP *o)
5388 if (o->op_flags & OPf_KIDS) {
5389 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5391 kid = kid->op_sibling; /* get past "big" */
5392 if (kid && kid->op_type == OP_CONST)
5393 fbm_compile(((SVOP*)kid)->op_sv, 0);
5399 Perl_ck_lengthconst(pTHX_ OP *o)
5401 /* XXX length optimization goes here */
5406 Perl_ck_lfun(pTHX_ OP *o)
5408 OPCODE type = o->op_type;
5409 return modkids(ck_fun(o), type);
5413 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5415 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5416 switch (cUNOPo->op_first->op_type) {
5418 /* This is needed for
5419 if (defined %stash::)
5420 to work. Do not break Tk.
5422 break; /* Globals via GV can be undef */
5424 case OP_AASSIGN: /* Is this a good idea? */
5425 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5426 "defined(@array) is deprecated");
5427 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5428 "\t(Maybe you should just omit the defined()?)\n");
5431 /* This is needed for
5432 if (defined %stash::)
5433 to work. Do not break Tk.
5435 break; /* Globals via GV can be undef */
5437 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5438 "defined(%%hash) is deprecated");
5439 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5440 "\t(Maybe you should just omit the defined()?)\n");
5451 Perl_ck_rfun(pTHX_ OP *o)
5453 OPCODE type = o->op_type;
5454 return refkids(ck_fun(o), type);
5458 Perl_ck_listiob(pTHX_ OP *o)
5462 kid = cLISTOPo->op_first;
5465 kid = cLISTOPo->op_first;
5467 if (kid->op_type == OP_PUSHMARK)
5468 kid = kid->op_sibling;
5469 if (kid && o->op_flags & OPf_STACKED)
5470 kid = kid->op_sibling;
5471 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5472 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5473 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5474 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5475 cLISTOPo->op_first->op_sibling = kid;
5476 cLISTOPo->op_last = kid;
5477 kid = kid->op_sibling;
5482 append_elem(o->op_type, o, newDEFSVOP());
5488 Perl_ck_sassign(pTHX_ OP *o)
5490 OP *kid = cLISTOPo->op_first;
5491 /* has a disposable target? */
5492 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5493 && !(kid->op_flags & OPf_STACKED)
5494 /* Cannot steal the second time! */
5495 && !(kid->op_private & OPpTARGET_MY))
5497 OP *kkid = kid->op_sibling;
5499 /* Can just relocate the target. */
5500 if (kkid && kkid->op_type == OP_PADSV
5501 && !(kkid->op_private & OPpLVAL_INTRO))
5503 kid->op_targ = kkid->op_targ;
5505 /* Now we do not need PADSV and SASSIGN. */
5506 kid->op_sibling = o->op_sibling; /* NULL */
5507 cLISTOPo->op_first = NULL;
5510 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
5518 Perl_ck_match(pTHX_ OP *o)
5520 o->op_private |= OPpRUNTIME;
5525 Perl_ck_method(pTHX_ OP *o)
5527 OP *kid = cUNOPo->op_first;
5528 if (kid->op_type == OP_CONST) {
5529 SV* sv = kSVOP->op_sv;
5530 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
5532 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5533 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
5536 kSVOP->op_sv = Nullsv;
5538 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5547 Perl_ck_null(pTHX_ OP *o)
5553 Perl_ck_open(pTHX_ OP *o)
5555 HV *table = GvHV(PL_hintgv);
5559 svp = hv_fetch(table, "open_IN", 7, FALSE);
5561 mode = mode_from_discipline(*svp);
5562 if (mode & O_BINARY)
5563 o->op_private |= OPpOPEN_IN_RAW;
5564 else if (mode & O_TEXT)
5565 o->op_private |= OPpOPEN_IN_CRLF;
5568 svp = hv_fetch(table, "open_OUT", 8, FALSE);
5570 mode = mode_from_discipline(*svp);
5571 if (mode & O_BINARY)
5572 o->op_private |= OPpOPEN_OUT_RAW;
5573 else if (mode & O_TEXT)
5574 o->op_private |= OPpOPEN_OUT_CRLF;
5577 if (o->op_type == OP_BACKTICK)
5580 /* In case of three-arg dup open remove strictness
5581 * from the last arg if it is a bareword. */
5582 OP *first = cLISTOPx(o)->op_first; /* The pushmark. */
5583 OP *last = cLISTOPx(o)->op_last; /* The bareword. */
5587 if ((last->op_type == OP_CONST) && /* The bareword. */
5588 (last->op_private & OPpCONST_BARE) &&
5589 (last->op_private & OPpCONST_STRICT) &&
5590 (oa = first->op_sibling) && /* The fh. */
5591 (oa = oa->op_sibling) && /* The mode. */
5592 SvPOK(((SVOP*)oa)->op_sv) &&
5593 (mode = SvPVX(((SVOP*)oa)->op_sv)) &&
5594 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
5595 (last == oa->op_sibling)) /* The bareword. */
5596 last->op_private &= ~OPpCONST_STRICT;
5602 Perl_ck_repeat(pTHX_ OP *o)
5604 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5605 o->op_private |= OPpREPEAT_DOLIST;
5606 cBINOPo->op_first = force_list(cBINOPo->op_first);
5614 Perl_ck_require(pTHX_ OP *o)
5618 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
5619 SVOP *kid = (SVOP*)cUNOPo->op_first;
5621 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5623 for (s = SvPVX(kid->op_sv); *s; s++) {
5624 if (*s == ':' && s[1] == ':') {
5626 Move(s+2, s+1, strlen(s+2)+1, char);
5627 --SvCUR(kid->op_sv);
5630 if (SvREADONLY(kid->op_sv)) {
5631 SvREADONLY_off(kid->op_sv);
5632 sv_catpvn(kid->op_sv, ".pm", 3);
5633 SvREADONLY_on(kid->op_sv);
5636 sv_catpvn(kid->op_sv, ".pm", 3);
5640 /* handle override, if any */
5641 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
5642 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
5643 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
5645 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5646 OP *kid = cUNOPo->op_first;
5647 cUNOPo->op_first = 0;
5649 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5650 append_elem(OP_LIST, kid,
5651 scalar(newUNOP(OP_RV2CV, 0,
5660 Perl_ck_return(pTHX_ OP *o)
5663 if (CvLVALUE(PL_compcv)) {
5664 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5665 mod(kid, OP_LEAVESUBLV);
5672 Perl_ck_retarget(pTHX_ OP *o)
5674 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5681 Perl_ck_select(pTHX_ OP *o)
5684 if (o->op_flags & OPf_KIDS) {
5685 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5686 if (kid && kid->op_sibling) {
5687 o->op_type = OP_SSELECT;
5688 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
5690 return fold_constants(o);
5694 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5695 if (kid && kid->op_type == OP_RV2GV)
5696 kid->op_private &= ~HINT_STRICT_REFS;
5701 Perl_ck_shift(pTHX_ OP *o)
5703 I32 type = o->op_type;
5705 if (!(o->op_flags & OPf_KIDS)) {
5709 argop = newUNOP(OP_RV2AV, 0,
5710 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
5711 return newUNOP(type, 0, scalar(argop));
5713 return scalar(modkids(ck_fun(o), type));
5717 Perl_ck_sort(pTHX_ OP *o)
5721 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
5723 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5724 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
5726 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
5728 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
5730 if (kid->op_type == OP_SCOPE) {
5734 else if (kid->op_type == OP_LEAVE) {
5735 if (o->op_type == OP_SORT) {
5736 op_null(kid); /* wipe out leave */
5739 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
5740 if (k->op_next == kid)
5742 /* don't descend into loops */
5743 else if (k->op_type == OP_ENTERLOOP
5744 || k->op_type == OP_ENTERITER)
5746 k = cLOOPx(k)->op_lastop;
5751 kid->op_next = 0; /* just disconnect the leave */
5752 k = kLISTOP->op_first;
5757 if (o->op_type == OP_SORT) {
5758 /* provide scalar context for comparison function/block */
5764 o->op_flags |= OPf_SPECIAL;
5766 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
5769 firstkid = firstkid->op_sibling;
5772 /* provide list context for arguments */
5773 if (o->op_type == OP_SORT)
5780 S_simplify_sort(pTHX_ OP *o)
5782 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5786 if (!(o->op_flags & OPf_STACKED))
5788 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
5789 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
5790 kid = kUNOP->op_first; /* get past null */
5791 if (kid->op_type != OP_SCOPE)
5793 kid = kLISTOP->op_last; /* get past scope */
5794 switch(kid->op_type) {
5802 k = kid; /* remember this node*/
5803 if (kBINOP->op_first->op_type != OP_RV2SV)
5805 kid = kBINOP->op_first; /* get past cmp */
5806 if (kUNOP->op_first->op_type != OP_GV)
5808 kid = kUNOP->op_first; /* get past rv2sv */
5810 if (GvSTASH(gv) != PL_curstash)
5812 if (strEQ(GvNAME(gv), "a"))
5814 else if (strEQ(GvNAME(gv), "b"))
5818 kid = k; /* back to cmp */
5819 if (kBINOP->op_last->op_type != OP_RV2SV)
5821 kid = kBINOP->op_last; /* down to 2nd arg */
5822 if (kUNOP->op_first->op_type != OP_GV)
5824 kid = kUNOP->op_first; /* get past rv2sv */
5826 if (GvSTASH(gv) != PL_curstash
5828 ? strNE(GvNAME(gv), "a")
5829 : strNE(GvNAME(gv), "b")))
5831 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
5833 o->op_private |= OPpSORT_REVERSE;
5834 if (k->op_type == OP_NCMP)
5835 o->op_private |= OPpSORT_NUMERIC;
5836 if (k->op_type == OP_I_NCMP)
5837 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
5838 kid = cLISTOPo->op_first->op_sibling;
5839 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
5840 op_free(kid); /* then delete it */
5844 Perl_ck_split(pTHX_ OP *o)
5848 if (o->op_flags & OPf_STACKED)
5849 return no_fh_allowed(o);
5851 kid = cLISTOPo->op_first;
5852 if (kid->op_type != OP_NULL)
5853 Perl_croak(aTHX_ "panic: ck_split");
5854 kid = kid->op_sibling;
5855 op_free(cLISTOPo->op_first);
5856 cLISTOPo->op_first = kid;
5858 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
5859 cLISTOPo->op_last = kid; /* There was only one element previously */
5862 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
5863 OP *sibl = kid->op_sibling;
5864 kid->op_sibling = 0;
5865 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
5866 if (cLISTOPo->op_first == cLISTOPo->op_last)
5867 cLISTOPo->op_last = kid;
5868 cLISTOPo->op_first = kid;
5869 kid->op_sibling = sibl;
5872 kid->op_type = OP_PUSHRE;
5873 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
5875 if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
5876 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
5877 "Use of /g modifier is meaningless in split");
5880 if (!kid->op_sibling)
5881 append_elem(OP_SPLIT, o, newDEFSVOP());
5883 kid = kid->op_sibling;
5886 if (!kid->op_sibling)
5887 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
5889 kid = kid->op_sibling;
5892 if (kid->op_sibling)
5893 return too_many_arguments(o,OP_DESC(o));
5899 Perl_ck_join(pTHX_ OP *o)
5901 if (ckWARN(WARN_SYNTAX)) {
5902 OP *kid = cLISTOPo->op_first->op_sibling;
5903 if (kid && kid->op_type == OP_MATCH) {
5904 char *pmstr = "STRING";
5905 if (PM_GETRE(kPMOP))
5906 pmstr = PM_GETRE(kPMOP)->precomp;
5907 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5908 "/%s/ should probably be written as \"%s\"",
5916 Perl_ck_subr(pTHX_ OP *o)
5918 OP *prev = ((cUNOPo->op_first->op_sibling)
5919 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
5920 OP *o2 = prev->op_sibling;
5927 I32 contextclass = 0;
5932 o->op_private |= OPpENTERSUB_HASTARG;
5933 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
5934 if (cvop->op_type == OP_RV2CV) {
5936 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
5937 op_null(cvop); /* disable rv2cv */
5938 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
5939 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
5940 GV *gv = cGVOPx_gv(tmpop);
5943 tmpop->op_private |= OPpEARLY_CV;
5946 namegv = CvANON(cv) ? gv : CvGV(cv);
5947 proto = SvPV((SV*)cv, n_a);
5949 if (CvASSERTION(cv)) {
5950 if (PL_hints & HINT_ASSERTING) {
5951 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
5952 o->op_private |= OPpENTERSUB_DB;
5956 if (ckWARN(WARN_ASSERTIONS) && !(PL_hints & HINT_ASSERTIONSSEEN)) {
5957 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
5958 "Impossible to activate assertion call");
5965 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
5966 if (o2->op_type == OP_CONST)
5967 o2->op_private &= ~OPpCONST_STRICT;
5968 else if (o2->op_type == OP_LIST) {
5969 OP *o = ((UNOP*)o2)->op_first->op_sibling;
5970 if (o && o->op_type == OP_CONST)
5971 o->op_private &= ~OPpCONST_STRICT;
5974 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5975 if (PERLDB_SUB && PL_curstash != PL_debstash)
5976 o->op_private |= OPpENTERSUB_DB;
5977 while (o2 != cvop) {
5981 return too_many_arguments(o, gv_ename(namegv));
5999 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6001 arg == 1 ? "block or sub {}" : "sub {}",
6002 gv_ename(namegv), o2);
6005 /* '*' allows any scalar type, including bareword */
6008 if (o2->op_type == OP_RV2GV)
6009 goto wrapref; /* autoconvert GLOB -> GLOBref */
6010 else if (o2->op_type == OP_CONST)
6011 o2->op_private &= ~OPpCONST_STRICT;
6012 else if (o2->op_type == OP_ENTERSUB) {
6013 /* accidental subroutine, revert to bareword */
6014 OP *gvop = ((UNOP*)o2)->op_first;
6015 if (gvop && gvop->op_type == OP_NULL) {
6016 gvop = ((UNOP*)gvop)->op_first;
6018 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6021 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6022 (gvop = ((UNOP*)gvop)->op_first) &&
6023 gvop->op_type == OP_GV)
6025 GV *gv = cGVOPx_gv(gvop);
6026 OP *sibling = o2->op_sibling;
6027 SV *n = newSVpvn("",0);
6029 gv_fullname3(n, gv, "");
6030 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6031 sv_chop(n, SvPVX(n)+6);
6032 o2 = newSVOP(OP_CONST, 0, n);
6033 prev->op_sibling = o2;
6034 o2->op_sibling = sibling;
6050 if (contextclass++ == 0) {
6051 e = strchr(proto, ']');
6052 if (!e || e == proto)
6065 while (*--p != '[');
6066 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6067 gv_ename(namegv), o2);
6073 if (o2->op_type == OP_RV2GV)
6076 bad_type(arg, "symbol", gv_ename(namegv), o2);
6079 if (o2->op_type == OP_ENTERSUB)
6082 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6085 if (o2->op_type == OP_RV2SV ||
6086 o2->op_type == OP_PADSV ||
6087 o2->op_type == OP_HELEM ||
6088 o2->op_type == OP_AELEM ||
6089 o2->op_type == OP_THREADSV)
6092 bad_type(arg, "scalar", gv_ename(namegv), o2);
6095 if (o2->op_type == OP_RV2AV ||
6096 o2->op_type == OP_PADAV)
6099 bad_type(arg, "array", gv_ename(namegv), o2);
6102 if (o2->op_type == OP_RV2HV ||
6103 o2->op_type == OP_PADHV)
6106 bad_type(arg, "hash", gv_ename(namegv), o2);
6111 OP* sib = kid->op_sibling;
6112 kid->op_sibling = 0;
6113 o2 = newUNOP(OP_REFGEN, 0, kid);
6114 o2->op_sibling = sib;
6115 prev->op_sibling = o2;
6117 if (contextclass && e) {
6132 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6133 gv_ename(namegv), cv);
6138 mod(o2, OP_ENTERSUB);
6140 o2 = o2->op_sibling;
6142 if (proto && !optional &&
6143 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6144 return too_few_arguments(o, gv_ename(namegv));
6147 o=newSVOP(OP_CONST, 0, newSViv(0));
6153 Perl_ck_svconst(pTHX_ OP *o)
6155 SvREADONLY_on(cSVOPo->op_sv);
6160 Perl_ck_trunc(pTHX_ OP *o)
6162 if (o->op_flags & OPf_KIDS) {
6163 SVOP *kid = (SVOP*)cUNOPo->op_first;
6165 if (kid->op_type == OP_NULL)
6166 kid = (SVOP*)kid->op_sibling;
6167 if (kid && kid->op_type == OP_CONST &&
6168 (kid->op_private & OPpCONST_BARE))
6170 o->op_flags |= OPf_SPECIAL;
6171 kid->op_private &= ~OPpCONST_STRICT;
6178 Perl_ck_substr(pTHX_ OP *o)
6181 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6182 OP *kid = cLISTOPo->op_first;
6184 if (kid->op_type == OP_NULL)
6185 kid = kid->op_sibling;
6187 kid->op_flags |= OPf_MOD;
6193 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6196 Perl_peep(pTHX_ register OP *o)
6198 register OP* oldop = 0;
6200 if (!o || o->op_seq)
6204 SAVEVPTR(PL_curcop);
6205 for (; o; o = o->op_next) {
6208 /* The special value -1 is used by the B::C compiler backend to indicate
6209 * that an op is statically defined and should not be freed */
6210 if (!PL_op_seqmax || PL_op_seqmax == (U16)-1)
6213 switch (o->op_type) {
6217 PL_curcop = ((COP*)o); /* for warnings */
6218 o->op_seq = PL_op_seqmax++;
6222 if (cSVOPo->op_private & OPpCONST_STRICT)
6223 no_bareword_allowed(o);
6225 case OP_METHOD_NAMED:
6226 /* Relocate sv to the pad for thread safety.
6227 * Despite being a "constant", the SV is written to,
6228 * for reference counts, sv_upgrade() etc. */
6230 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6231 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6232 /* If op_sv is already a PADTMP then it is being used by
6233 * some pad, so make a copy. */
6234 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6235 SvREADONLY_on(PAD_SVl(ix));
6236 SvREFCNT_dec(cSVOPo->op_sv);
6239 SvREFCNT_dec(PAD_SVl(ix));
6240 SvPADTMP_on(cSVOPo->op_sv);
6241 PAD_SETSV(ix, cSVOPo->op_sv);
6242 /* XXX I don't know how this isn't readonly already. */
6243 SvREADONLY_on(PAD_SVl(ix));
6245 cSVOPo->op_sv = Nullsv;
6249 o->op_seq = PL_op_seqmax++;
6253 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6254 if (o->op_next->op_private & OPpTARGET_MY) {
6255 if (o->op_flags & OPf_STACKED) /* chained concats */
6256 goto ignore_optimization;
6258 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6259 o->op_targ = o->op_next->op_targ;
6260 o->op_next->op_targ = 0;
6261 o->op_private |= OPpTARGET_MY;
6264 op_null(o->op_next);
6266 ignore_optimization:
6267 o->op_seq = PL_op_seqmax++;
6270 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6271 o->op_seq = PL_op_seqmax++;
6272 break; /* Scalar stub must produce undef. List stub is noop */
6276 if (o->op_targ == OP_NEXTSTATE
6277 || o->op_targ == OP_DBSTATE
6278 || o->op_targ == OP_SETSTATE)
6280 PL_curcop = ((COP*)o);
6282 /* XXX: We avoid setting op_seq here to prevent later calls
6283 to peep() from mistakenly concluding that optimisation
6284 has already occurred. This doesn't fix the real problem,
6285 though (See 20010220.007). AMS 20010719 */
6286 if (oldop && o->op_next) {
6287 oldop->op_next = o->op_next;
6295 if (oldop && o->op_next) {
6296 oldop->op_next = o->op_next;
6299 o->op_seq = PL_op_seqmax++;
6303 if (o->op_next->op_type == OP_RV2SV) {
6304 if (!(o->op_next->op_private & OPpDEREF)) {
6305 op_null(o->op_next);
6306 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6308 o->op_next = o->op_next->op_next;
6309 o->op_type = OP_GVSV;
6310 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6313 else if (o->op_next->op_type == OP_RV2AV) {
6314 OP* pop = o->op_next->op_next;
6316 if (pop && pop->op_type == OP_CONST &&
6317 (PL_op = pop->op_next) &&
6318 pop->op_next->op_type == OP_AELEM &&
6319 !(pop->op_next->op_private &
6320 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6321 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6326 op_null(o->op_next);
6327 op_null(pop->op_next);
6329 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6330 o->op_next = pop->op_next->op_next;
6331 o->op_type = OP_AELEMFAST;
6332 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6333 o->op_private = (U8)i;
6338 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6340 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6341 /* XXX could check prototype here instead of just carping */
6342 SV *sv = sv_newmortal();
6343 gv_efullname3(sv, gv, Nullch);
6344 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6345 "%"SVf"() called too early to check prototype",
6349 else if (o->op_next->op_type == OP_READLINE
6350 && o->op_next->op_next->op_type == OP_CONCAT
6351 && (o->op_next->op_next->op_flags & OPf_STACKED))
6353 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6354 o->op_type = OP_RCATLINE;
6355 o->op_flags |= OPf_STACKED;
6356 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6357 op_null(o->op_next->op_next);
6358 op_null(o->op_next);
6361 o->op_seq = PL_op_seqmax++;
6374 o->op_seq = PL_op_seqmax++;
6375 while (cLOGOP->op_other->op_type == OP_NULL)
6376 cLOGOP->op_other = cLOGOP->op_other->op_next;
6377 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6382 o->op_seq = PL_op_seqmax++;
6383 while (cLOOP->op_redoop->op_type == OP_NULL)
6384 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6385 peep(cLOOP->op_redoop);
6386 while (cLOOP->op_nextop->op_type == OP_NULL)
6387 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6388 peep(cLOOP->op_nextop);
6389 while (cLOOP->op_lastop->op_type == OP_NULL)
6390 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6391 peep(cLOOP->op_lastop);
6397 o->op_seq = PL_op_seqmax++;
6398 while (cPMOP->op_pmreplstart &&
6399 cPMOP->op_pmreplstart->op_type == OP_NULL)
6400 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6401 peep(cPMOP->op_pmreplstart);
6405 o->op_seq = PL_op_seqmax++;
6406 if (ckWARN(WARN_SYNTAX) && o->op_next
6407 && o->op_next->op_type == OP_NEXTSTATE) {
6408 if (o->op_next->op_sibling &&
6409 o->op_next->op_sibling->op_type != OP_EXIT &&
6410 o->op_next->op_sibling->op_type != OP_WARN &&
6411 o->op_next->op_sibling->op_type != OP_DIE) {
6412 line_t oldline = CopLINE(PL_curcop);
6414 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6415 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6416 "Statement unlikely to be reached");
6417 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6418 "\t(Maybe you meant system() when you said exec()?)\n");
6419 CopLINE_set(PL_curcop, oldline);
6430 o->op_seq = PL_op_seqmax++;
6432 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6435 /* Make the CONST have a shared SV */
6436 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6437 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6438 key = SvPV(sv, keylen);
6439 lexname = newSVpvn_share(key,
6440 SvUTF8(sv) ? -(I32)keylen : keylen,
6449 o->op_seq = PL_op_seqmax++;
6459 char* Perl_custom_op_name(pTHX_ OP* o)
6461 IV index = PTR2IV(o->op_ppaddr);
6465 if (!PL_custom_op_names) /* This probably shouldn't happen */
6466 return PL_op_name[OP_CUSTOM];
6468 keysv = sv_2mortal(newSViv(index));
6470 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
6472 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
6474 return SvPV_nolen(HeVAL(he));
6477 char* Perl_custom_op_desc(pTHX_ OP* o)
6479 IV index = PTR2IV(o->op_ppaddr);
6483 if (!PL_custom_op_descs)
6484 return PL_op_desc[OP_CUSTOM];
6486 keysv = sv_2mortal(newSViv(index));
6488 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
6490 return PL_op_desc[OP_CUSTOM];
6492 return SvPV_nolen(HeVAL(he));
6498 /* Efficient sub that returns a constant scalar value. */
6500 const_sv_xsub(pTHX_ CV* cv)
6505 Perl_croak(aTHX_ "usage: %s::%s()",
6506 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
6510 ST(0) = (SV*)XSANY.any_ptr;
6514 /* XXX this belongs in doio.c, not here */
6523 f = PerlIO_fdopen(fd, "w+b");
6525 # ifdef PERL_EXTERNAL_GLOB
6526 /* File::Temp pulls in Fcntl, which may not be available with
6527 * e.g. miniperl, use mkstemp() or stdio tmpfile() instead. */
6528 # if defined(WIN32) || !defined(HAS_MKSTEMP)
6529 FILE *stdio = PerlSIO_tmpfile();
6532 if ((f = PerlIO_push(aTHX_(PerlIO_allocate(aTHX)),
6533 &PerlIO_stdio, "w+", Nullsv))) {
6534 PerlIOStdio *s = PerlIOSelf(f, PerlIOStdio);
6540 # else /* !WIN32 && HAS_MKSTEMP */
6541 SV *sv = newSVpv("/tmp/PerlIO_XXXXXX", 0);
6544 fd = mkstemp(SvPVX(sv));
6546 f = PerlIO_fdopen(fd, "w+");
6548 PerlLIO_unlink(SvPVX(sv));
6553 # endif /* !HAS_MKSTEMP */
6555 /* We have internal glob, which probably also means that we
6556 * can also use File::Temp (which uses Fcntl) with impunity. */
6557 GV *gv = gv_fetchpv("File::Temp::tempfile", FALSE, SVt_PVCV);
6561 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6562 newSVpvn("File::Temp", 10), Nullsv, Nullsv, Nullsv);
6563 gv = gv_fetchpv("File::Temp::tempfile", FALSE, SVt_PVCV);
6564 GvIMPORTED_CV_on(gv);
6567 if (gv && GvCV(gv)) {
6573 if (call_sv((SV*)GvCV(gv), G_SCALAR)) {
6574 GV *gv = (GV*)SvRV(newSVsv(*PL_stack_sp--));
6580 fd = PerlIO_fileno(IoIFP(io));
6582 f = PerlIO_fdopen(fd, "w+");