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 */
197 (bool)(PL_in_my == KEY_our),
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) {
1833 PL_comppad_name = 0;
1837 PL_main_root = scope(sawparens(scalarvoid(o)));
1838 PL_curcop = &PL_compiling;
1839 PL_main_start = LINKLIST(PL_main_root);
1840 PL_main_root->op_private |= OPpREFCOUNTED;
1841 OpREFCNT_set(PL_main_root, 1);
1842 PL_main_root->op_next = 0;
1843 CALL_PEEP(PL_main_start);
1846 /* Register with debugger */
1848 CV *cv = get_cv("DB::postponed", FALSE);
1852 XPUSHs((SV*)CopFILEGV(&PL_compiling));
1854 call_sv((SV*)cv, G_DISCARD);
1861 Perl_localize(pTHX_ OP *o, I32 lex)
1863 if (o->op_flags & OPf_PARENS)
1864 /* [perl #17376]: this appears to be premature, and results in code such as
1865 C< our(%x); > executing in list mode rather than void mode */
1872 if (ckWARN(WARN_PARENTHESIS)
1873 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
1875 char *s = PL_bufptr;
1878 /* some heuristics to detect a potential error */
1879 while (*s && (strchr(", \t\n", *s)
1880 || (strchr("@$%*", *s) && ++sigil) ))
1883 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)
1884 || strchr("@$%*, \t\n", *s)))
1887 if (*s == ';' || *s == '=')
1888 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
1889 "Parentheses missing around \"%s\" list",
1890 lex ? (PL_in_my == KEY_our ? "our" : "my")
1898 o = mod(o, OP_NULL); /* a bit kludgey */
1900 PL_in_my_stash = Nullhv;
1905 Perl_jmaybe(pTHX_ OP *o)
1907 if (o->op_type == OP_LIST) {
1909 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
1910 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
1916 Perl_fold_constants(pTHX_ register OP *o)
1919 I32 type = o->op_type;
1922 if (PL_opargs[type] & OA_RETSCALAR)
1924 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
1925 o->op_targ = pad_alloc(type, SVs_PADTMP);
1927 /* integerize op, unless it happens to be C<-foo>.
1928 * XXX should pp_i_negate() do magic string negation instead? */
1929 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
1930 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
1931 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
1933 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
1936 if (!(PL_opargs[type] & OA_FOLDCONST))
1941 /* XXX might want a ck_negate() for this */
1942 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
1954 /* XXX what about the numeric ops? */
1955 if (PL_hints & HINT_LOCALE)
1960 goto nope; /* Don't try to run w/ errors */
1962 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
1963 if ((curop->op_type != OP_CONST ||
1964 (curop->op_private & OPpCONST_BARE)) &&
1965 curop->op_type != OP_LIST &&
1966 curop->op_type != OP_SCALAR &&
1967 curop->op_type != OP_NULL &&
1968 curop->op_type != OP_PUSHMARK)
1974 curop = LINKLIST(o);
1978 sv = *(PL_stack_sp--);
1979 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
1980 pad_swipe(o->op_targ, FALSE);
1981 else if (SvTEMP(sv)) { /* grab mortal temp? */
1982 (void)SvREFCNT_inc(sv);
1986 if (type == OP_RV2GV)
1987 return newGVOP(OP_GV, 0, (GV*)sv);
1988 return newSVOP(OP_CONST, 0, sv);
1995 Perl_gen_constant_list(pTHX_ register OP *o)
1998 I32 oldtmps_floor = PL_tmps_floor;
2002 return o; /* Don't attempt to run with errors */
2004 PL_op = curop = LINKLIST(o);
2011 PL_tmps_floor = oldtmps_floor;
2013 o->op_type = OP_RV2AV;
2014 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2015 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2016 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2017 o->op_seq = 0; /* needs to be revisited in peep() */
2018 curop = ((UNOP*)o)->op_first;
2019 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2026 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2028 if (!o || o->op_type != OP_LIST)
2029 o = newLISTOP(OP_LIST, 0, o, Nullop);
2031 o->op_flags &= ~OPf_WANT;
2033 if (!(PL_opargs[type] & OA_MARK))
2034 op_null(cLISTOPo->op_first);
2036 o->op_type = (OPCODE)type;
2037 o->op_ppaddr = PL_ppaddr[type];
2038 o->op_flags |= flags;
2040 o = CHECKOP(type, o);
2041 if (o->op_type != type)
2044 return fold_constants(o);
2047 /* List constructors */
2050 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2058 if (first->op_type != type
2059 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2061 return newLISTOP(type, 0, first, last);
2064 if (first->op_flags & OPf_KIDS)
2065 ((LISTOP*)first)->op_last->op_sibling = last;
2067 first->op_flags |= OPf_KIDS;
2068 ((LISTOP*)first)->op_first = last;
2070 ((LISTOP*)first)->op_last = last;
2075 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2083 if (first->op_type != type)
2084 return prepend_elem(type, (OP*)first, (OP*)last);
2086 if (last->op_type != type)
2087 return append_elem(type, (OP*)first, (OP*)last);
2089 first->op_last->op_sibling = last->op_first;
2090 first->op_last = last->op_last;
2091 first->op_flags |= (last->op_flags & OPf_KIDS);
2099 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2107 if (last->op_type == type) {
2108 if (type == OP_LIST) { /* already a PUSHMARK there */
2109 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2110 ((LISTOP*)last)->op_first->op_sibling = first;
2111 if (!(first->op_flags & OPf_PARENS))
2112 last->op_flags &= ~OPf_PARENS;
2115 if (!(last->op_flags & OPf_KIDS)) {
2116 ((LISTOP*)last)->op_last = first;
2117 last->op_flags |= OPf_KIDS;
2119 first->op_sibling = ((LISTOP*)last)->op_first;
2120 ((LISTOP*)last)->op_first = first;
2122 last->op_flags |= OPf_KIDS;
2126 return newLISTOP(type, 0, first, last);
2132 Perl_newNULLLIST(pTHX)
2134 return newOP(OP_STUB, 0);
2138 Perl_force_list(pTHX_ OP *o)
2140 if (!o || o->op_type != OP_LIST)
2141 o = newLISTOP(OP_LIST, 0, o, Nullop);
2147 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2151 NewOp(1101, listop, 1, LISTOP);
2153 listop->op_type = (OPCODE)type;
2154 listop->op_ppaddr = PL_ppaddr[type];
2157 listop->op_flags = (U8)flags;
2161 else if (!first && last)
2164 first->op_sibling = last;
2165 listop->op_first = first;
2166 listop->op_last = last;
2167 if (type == OP_LIST) {
2169 pushop = newOP(OP_PUSHMARK, 0);
2170 pushop->op_sibling = first;
2171 listop->op_first = pushop;
2172 listop->op_flags |= OPf_KIDS;
2174 listop->op_last = pushop;
2177 return CHECKOP(type, listop);
2181 Perl_newOP(pTHX_ I32 type, I32 flags)
2184 NewOp(1101, o, 1, OP);
2185 o->op_type = (OPCODE)type;
2186 o->op_ppaddr = PL_ppaddr[type];
2187 o->op_flags = (U8)flags;
2190 o->op_private = (U8)(0 | (flags >> 8));
2191 if (PL_opargs[type] & OA_RETSCALAR)
2193 if (PL_opargs[type] & OA_TARGET)
2194 o->op_targ = pad_alloc(type, SVs_PADTMP);
2195 return CHECKOP(type, o);
2199 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2204 first = newOP(OP_STUB, 0);
2205 if (PL_opargs[type] & OA_MARK)
2206 first = force_list(first);
2208 NewOp(1101, unop, 1, UNOP);
2209 unop->op_type = (OPCODE)type;
2210 unop->op_ppaddr = PL_ppaddr[type];
2211 unop->op_first = first;
2212 unop->op_flags = flags | OPf_KIDS;
2213 unop->op_private = (U8)(1 | (flags >> 8));
2214 unop = (UNOP*) CHECKOP(type, unop);
2218 return fold_constants((OP *) unop);
2222 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2225 NewOp(1101, binop, 1, BINOP);
2228 first = newOP(OP_NULL, 0);
2230 binop->op_type = (OPCODE)type;
2231 binop->op_ppaddr = PL_ppaddr[type];
2232 binop->op_first = first;
2233 binop->op_flags = flags | OPf_KIDS;
2236 binop->op_private = (U8)(1 | (flags >> 8));
2239 binop->op_private = (U8)(2 | (flags >> 8));
2240 first->op_sibling = last;
2243 binop = (BINOP*)CHECKOP(type, binop);
2244 if (binop->op_next || binop->op_type != (OPCODE)type)
2247 binop->op_last = binop->op_first->op_sibling;
2249 return fold_constants((OP *)binop);
2253 uvcompare(const void *a, const void *b)
2255 if (*((UV *)a) < (*(UV *)b))
2257 if (*((UV *)a) > (*(UV *)b))
2259 if (*((UV *)a+1) < (*(UV *)b+1))
2261 if (*((UV *)a+1) > (*(UV *)b+1))
2267 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2269 SV *tstr = ((SVOP*)expr)->op_sv;
2270 SV *rstr = ((SVOP*)repl)->op_sv;
2273 U8 *t = (U8*)SvPV(tstr, tlen);
2274 U8 *r = (U8*)SvPV(rstr, rlen);
2281 register short *tbl;
2283 PL_hints |= HINT_BLOCK_SCOPE;
2284 complement = o->op_private & OPpTRANS_COMPLEMENT;
2285 del = o->op_private & OPpTRANS_DELETE;
2286 squash = o->op_private & OPpTRANS_SQUASH;
2289 o->op_private |= OPpTRANS_FROM_UTF;
2292 o->op_private |= OPpTRANS_TO_UTF;
2294 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2295 SV* listsv = newSVpvn("# comment\n",10);
2297 U8* tend = t + tlen;
2298 U8* rend = r + rlen;
2312 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2313 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2319 tsave = t = bytes_to_utf8(t, &len);
2322 if (!to_utf && rlen) {
2324 rsave = r = bytes_to_utf8(r, &len);
2328 /* There are several snags with this code on EBCDIC:
2329 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2330 2. scan_const() in toke.c has encoded chars in native encoding which makes
2331 ranges at least in EBCDIC 0..255 range the bottom odd.
2335 U8 tmpbuf[UTF8_MAXLEN+1];
2338 New(1109, cp, 2*tlen, UV);
2340 transv = newSVpvn("",0);
2342 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2344 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2346 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2350 cp[2*i+1] = cp[2*i];
2354 qsort(cp, i, 2*sizeof(UV), uvcompare);
2355 for (j = 0; j < i; j++) {
2357 diff = val - nextmin;
2359 t = uvuni_to_utf8(tmpbuf,nextmin);
2360 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2362 U8 range_mark = UTF_TO_NATIVE(0xff);
2363 t = uvuni_to_utf8(tmpbuf, val - 1);
2364 sv_catpvn(transv, (char *)&range_mark, 1);
2365 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2372 t = uvuni_to_utf8(tmpbuf,nextmin);
2373 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2375 U8 range_mark = UTF_TO_NATIVE(0xff);
2376 sv_catpvn(transv, (char *)&range_mark, 1);
2378 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2379 UNICODE_ALLOW_SUPER);
2380 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2381 t = (U8*)SvPVX(transv);
2382 tlen = SvCUR(transv);
2386 else if (!rlen && !del) {
2387 r = t; rlen = tlen; rend = tend;
2390 if ((!rlen && !del) || t == r ||
2391 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2393 o->op_private |= OPpTRANS_IDENTICAL;
2397 while (t < tend || tfirst <= tlast) {
2398 /* see if we need more "t" chars */
2399 if (tfirst > tlast) {
2400 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2402 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2404 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2411 /* now see if we need more "r" chars */
2412 if (rfirst > rlast) {
2414 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2416 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2418 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2427 rfirst = rlast = 0xffffffff;
2431 /* now see which range will peter our first, if either. */
2432 tdiff = tlast - tfirst;
2433 rdiff = rlast - rfirst;
2440 if (rfirst == 0xffffffff) {
2441 diff = tdiff; /* oops, pretend rdiff is infinite */
2443 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2444 (long)tfirst, (long)tlast);
2446 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2450 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2451 (long)tfirst, (long)(tfirst + diff),
2454 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2455 (long)tfirst, (long)rfirst);
2457 if (rfirst + diff > max)
2458 max = rfirst + diff;
2460 grows = (tfirst < rfirst &&
2461 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2473 else if (max > 0xff)
2478 Safefree(cPVOPo->op_pv);
2479 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2480 SvREFCNT_dec(listsv);
2482 SvREFCNT_dec(transv);
2484 if (!del && havefinal && rlen)
2485 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2486 newSVuv((UV)final), 0);
2489 o->op_private |= OPpTRANS_GROWS;
2501 tbl = (short*)cPVOPo->op_pv;
2503 Zero(tbl, 256, short);
2504 for (i = 0; i < (I32)tlen; i++)
2506 for (i = 0, j = 0; i < 256; i++) {
2508 if (j >= (I32)rlen) {
2517 if (i < 128 && r[j] >= 128)
2527 o->op_private |= OPpTRANS_IDENTICAL;
2529 else if (j >= (I32)rlen)
2532 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2533 tbl[0x100] = rlen - j;
2534 for (i=0; i < (I32)rlen - j; i++)
2535 tbl[0x101+i] = r[j+i];
2539 if (!rlen && !del) {
2542 o->op_private |= OPpTRANS_IDENTICAL;
2544 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2545 o->op_private |= OPpTRANS_IDENTICAL;
2547 for (i = 0; i < 256; i++)
2549 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
2550 if (j >= (I32)rlen) {
2552 if (tbl[t[i]] == -1)
2558 if (tbl[t[i]] == -1) {
2559 if (t[i] < 128 && r[j] >= 128)
2566 o->op_private |= OPpTRANS_GROWS;
2574 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2578 NewOp(1101, pmop, 1, PMOP);
2579 pmop->op_type = (OPCODE)type;
2580 pmop->op_ppaddr = PL_ppaddr[type];
2581 pmop->op_flags = (U8)flags;
2582 pmop->op_private = (U8)(0 | (flags >> 8));
2584 if (PL_hints & HINT_RE_TAINT)
2585 pmop->op_pmpermflags |= PMf_RETAINT;
2586 if (PL_hints & HINT_LOCALE)
2587 pmop->op_pmpermflags |= PMf_LOCALE;
2588 pmop->op_pmflags = pmop->op_pmpermflags;
2593 if(av_len((AV*) PL_regex_pad[0]) > -1) {
2594 repointer = av_pop((AV*)PL_regex_pad[0]);
2595 pmop->op_pmoffset = SvIV(repointer);
2596 SvREPADTMP_off(repointer);
2597 sv_setiv(repointer,0);
2599 repointer = newSViv(0);
2600 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2601 pmop->op_pmoffset = av_len(PL_regex_padav);
2602 PL_regex_pad = AvARRAY(PL_regex_padav);
2607 /* link into pm list */
2608 if (type != OP_TRANS && PL_curstash) {
2609 pmop->op_pmnext = HvPMROOT(PL_curstash);
2610 HvPMROOT(PL_curstash) = pmop;
2611 PmopSTASH_set(pmop,PL_curstash);
2614 return CHECKOP(type, pmop);
2618 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
2622 I32 repl_has_vars = 0;
2624 if (o->op_type == OP_TRANS)
2625 return pmtrans(o, expr, repl);
2627 PL_hints |= HINT_BLOCK_SCOPE;
2630 if (expr->op_type == OP_CONST) {
2632 SV *pat = ((SVOP*)expr)->op_sv;
2633 char *p = SvPV(pat, plen);
2634 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
2635 sv_setpvn(pat, "\\s+", 3);
2636 p = SvPV(pat, plen);
2637 pm->op_pmflags |= PMf_SKIPWHITE;
2640 pm->op_pmdynflags |= PMdf_UTF8;
2641 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
2642 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
2643 pm->op_pmflags |= PMf_WHITE;
2647 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2648 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2650 : OP_REGCMAYBE),0,expr);
2652 NewOp(1101, rcop, 1, LOGOP);
2653 rcop->op_type = OP_REGCOMP;
2654 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2655 rcop->op_first = scalar(expr);
2656 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
2657 ? (OPf_SPECIAL | OPf_KIDS)
2659 rcop->op_private = 1;
2661 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
2664 /* establish postfix order */
2665 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2667 rcop->op_next = expr;
2668 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2671 rcop->op_next = LINKLIST(expr);
2672 expr->op_next = (OP*)rcop;
2675 prepend_elem(o->op_type, scalar((OP*)rcop), o);
2680 if (pm->op_pmflags & PMf_EVAL) {
2682 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
2683 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
2685 else if (repl->op_type == OP_CONST)
2689 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
2690 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
2691 if (curop->op_type == OP_GV) {
2692 GV *gv = cGVOPx_gv(curop);
2694 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
2697 else if (curop->op_type == OP_RV2CV)
2699 else if (curop->op_type == OP_RV2SV ||
2700 curop->op_type == OP_RV2AV ||
2701 curop->op_type == OP_RV2HV ||
2702 curop->op_type == OP_RV2GV) {
2703 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2706 else if (curop->op_type == OP_PADSV ||
2707 curop->op_type == OP_PADAV ||
2708 curop->op_type == OP_PADHV ||
2709 curop->op_type == OP_PADANY) {
2712 else if (curop->op_type == OP_PUSHRE)
2713 ; /* Okay here, dangerous in newASSIGNOP */
2723 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
2724 pm->op_pmflags |= PMf_CONST; /* const for long enough */
2725 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
2726 prepend_elem(o->op_type, scalar(repl), o);
2729 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
2730 pm->op_pmflags |= PMf_MAYBE_CONST;
2731 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2733 NewOp(1101, rcop, 1, LOGOP);
2734 rcop->op_type = OP_SUBSTCONT;
2735 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
2736 rcop->op_first = scalar(repl);
2737 rcop->op_flags |= OPf_KIDS;
2738 rcop->op_private = 1;
2741 /* establish postfix order */
2742 rcop->op_next = LINKLIST(repl);
2743 repl->op_next = (OP*)rcop;
2745 pm->op_pmreplroot = scalar((OP*)rcop);
2746 pm->op_pmreplstart = LINKLIST(rcop);
2755 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
2758 NewOp(1101, svop, 1, SVOP);
2759 svop->op_type = (OPCODE)type;
2760 svop->op_ppaddr = PL_ppaddr[type];
2762 svop->op_next = (OP*)svop;
2763 svop->op_flags = (U8)flags;
2764 if (PL_opargs[type] & OA_RETSCALAR)
2766 if (PL_opargs[type] & OA_TARGET)
2767 svop->op_targ = pad_alloc(type, SVs_PADTMP);
2768 return CHECKOP(type, svop);
2772 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2775 NewOp(1101, padop, 1, PADOP);
2776 padop->op_type = (OPCODE)type;
2777 padop->op_ppaddr = PL_ppaddr[type];
2778 padop->op_padix = pad_alloc(type, SVs_PADTMP);
2779 SvREFCNT_dec(PAD_SVl(padop->op_padix));
2780 PAD_SETSV(padop->op_padix, sv);
2783 padop->op_next = (OP*)padop;
2784 padop->op_flags = (U8)flags;
2785 if (PL_opargs[type] & OA_RETSCALAR)
2787 if (PL_opargs[type] & OA_TARGET)
2788 padop->op_targ = pad_alloc(type, SVs_PADTMP);
2789 return CHECKOP(type, padop);
2793 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
2798 return newPADOP(type, flags, SvREFCNT_inc(gv));
2800 return newSVOP(type, flags, SvREFCNT_inc(gv));
2805 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
2808 NewOp(1101, pvop, 1, PVOP);
2809 pvop->op_type = (OPCODE)type;
2810 pvop->op_ppaddr = PL_ppaddr[type];
2812 pvop->op_next = (OP*)pvop;
2813 pvop->op_flags = (U8)flags;
2814 if (PL_opargs[type] & OA_RETSCALAR)
2816 if (PL_opargs[type] & OA_TARGET)
2817 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
2818 return CHECKOP(type, pvop);
2822 Perl_package(pTHX_ OP *o)
2827 save_hptr(&PL_curstash);
2828 save_item(PL_curstname);
2830 name = SvPV(cSVOPo->op_sv, len);
2831 PL_curstash = gv_stashpvn(name, len, TRUE);
2832 sv_setpvn(PL_curstname, name, len);
2835 PL_hints |= HINT_BLOCK_SCOPE;
2836 PL_copline = NOLINE;
2841 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
2847 if (idop->op_type != OP_CONST)
2848 Perl_croak(aTHX_ "Module name must be constant");
2852 if (version != Nullop) {
2853 SV *vesv = ((SVOP*)version)->op_sv;
2855 if (arg == Nullop && !SvNIOKp(vesv)) {
2862 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
2863 Perl_croak(aTHX_ "Version number must be constant number");
2865 /* Make copy of idop so we don't free it twice */
2866 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
2868 /* Fake up a method call to VERSION */
2869 meth = newSVpvn("VERSION",7);
2870 sv_upgrade(meth, SVt_PVIV);
2871 (void)SvIOK_on(meth);
2872 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
2873 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2874 append_elem(OP_LIST,
2875 prepend_elem(OP_LIST, pack, list(version)),
2876 newSVOP(OP_METHOD_NAMED, 0, meth)));
2880 /* Fake up an import/unimport */
2881 if (arg && arg->op_type == OP_STUB)
2882 imop = arg; /* no import on explicit () */
2883 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
2884 imop = Nullop; /* use 5.0; */
2889 /* Make copy of idop so we don't free it twice */
2890 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
2892 /* Fake up a method call to import/unimport */
2893 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);
2894 (void)SvUPGRADE(meth, SVt_PVIV);
2895 (void)SvIOK_on(meth);
2896 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
2897 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2898 append_elem(OP_LIST,
2899 prepend_elem(OP_LIST, pack, list(arg)),
2900 newSVOP(OP_METHOD_NAMED, 0, meth)));
2903 /* Fake up the BEGIN {}, which does its thing immediately. */
2905 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
2908 append_elem(OP_LINESEQ,
2909 append_elem(OP_LINESEQ,
2910 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, idop)),
2911 newSTATEOP(0, Nullch, veop)),
2912 newSTATEOP(0, Nullch, imop) ));
2914 /* The "did you use incorrect case?" warning used to be here.
2915 * The problem is that on case-insensitive filesystems one
2916 * might get false positives for "use" (and "require"):
2917 * "use Strict" or "require CARP" will work. This causes
2918 * portability problems for the script: in case-strict
2919 * filesystems the script will stop working.
2921 * The "incorrect case" warning checked whether "use Foo"
2922 * imported "Foo" to your namespace, but that is wrong, too:
2923 * there is no requirement nor promise in the language that
2924 * a Foo.pm should or would contain anything in package "Foo".
2926 * There is very little Configure-wise that can be done, either:
2927 * the case-sensitivity of the build filesystem of Perl does not
2928 * help in guessing the case-sensitivity of the runtime environment.
2931 PL_hints |= HINT_BLOCK_SCOPE;
2932 PL_copline = NOLINE;
2934 PL_cop_seqmax++; /* Purely for B::*'s benefit */
2938 =head1 Embedding Functions
2940 =for apidoc load_module
2942 Loads the module whose name is pointed to by the string part of name.
2943 Note that the actual module name, not its filename, should be given.
2944 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
2945 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
2946 (or 0 for no flags). ver, if specified, provides version semantics
2947 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
2948 arguments can be used to specify arguments to the module's import()
2949 method, similar to C<use Foo::Bar VERSION LIST>.
2954 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
2957 va_start(args, ver);
2958 vload_module(flags, name, ver, &args);
2962 #ifdef PERL_IMPLICIT_CONTEXT
2964 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
2968 va_start(args, ver);
2969 vload_module(flags, name, ver, &args);
2975 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
2977 OP *modname, *veop, *imop;
2979 modname = newSVOP(OP_CONST, 0, name);
2980 modname->op_private |= OPpCONST_BARE;
2982 veop = newSVOP(OP_CONST, 0, ver);
2986 if (flags & PERL_LOADMOD_NOIMPORT) {
2987 imop = sawparens(newNULLLIST());
2989 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
2990 imop = va_arg(*args, OP*);
2995 sv = va_arg(*args, SV*);
2997 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
2998 sv = va_arg(*args, SV*);
3002 line_t ocopline = PL_copline;
3003 COP *ocurcop = PL_curcop;
3004 int oexpect = PL_expect;
3006 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3007 veop, modname, imop);
3008 PL_expect = oexpect;
3009 PL_copline = ocopline;
3010 PL_curcop = ocurcop;
3015 Perl_dofile(pTHX_ OP *term)
3020 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3021 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
3022 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3024 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3025 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3026 append_elem(OP_LIST, term,
3027 scalar(newUNOP(OP_RV2CV, 0,
3032 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3038 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3040 return newBINOP(OP_LSLICE, flags,
3041 list(force_list(subscript)),
3042 list(force_list(listval)) );
3046 S_list_assignment(pTHX_ register OP *o)
3051 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3052 o = cUNOPo->op_first;
3054 if (o->op_type == OP_COND_EXPR) {
3055 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3056 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3061 yyerror("Assignment to both a list and a scalar");
3065 if (o->op_type == OP_LIST &&
3066 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3067 o->op_private & OPpLVAL_INTRO)
3070 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3071 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3072 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3075 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3078 if (o->op_type == OP_RV2SV)
3085 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3090 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3091 return newLOGOP(optype, 0,
3092 mod(scalar(left), optype),
3093 newUNOP(OP_SASSIGN, 0, scalar(right)));
3096 return newBINOP(optype, OPf_STACKED,
3097 mod(scalar(left), optype), scalar(right));
3101 if (list_assignment(left)) {
3105 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3106 left = mod(left, OP_AASSIGN);
3114 curop = list(force_list(left));
3115 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3116 o->op_private = (U8)(0 | (flags >> 8));
3118 /* PL_generation sorcery:
3119 * an assignment like ($a,$b) = ($c,$d) is easier than
3120 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3121 * To detect whether there are common vars, the global var
3122 * PL_generation is incremented for each assign op we compile.
3123 * Then, while compiling the assign op, we run through all the
3124 * variables on both sides of the assignment, setting a spare slot
3125 * in each of them to PL_generation. If any of them already have
3126 * that value, we know we've got commonality. We could use a
3127 * single bit marker, but then we'd have to make 2 passes, first
3128 * to clear the flag, then to test and set it. To find somewhere
3129 * to store these values, evil chicanery is done with SvCUR().
3132 if (!(left->op_private & OPpLVAL_INTRO)) {
3135 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3136 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3137 if (curop->op_type == OP_GV) {
3138 GV *gv = cGVOPx_gv(curop);
3139 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3141 SvCUR(gv) = PL_generation;
3143 else if (curop->op_type == OP_PADSV ||
3144 curop->op_type == OP_PADAV ||
3145 curop->op_type == OP_PADHV ||
3146 curop->op_type == OP_PADANY)
3148 if (PAD_COMPNAME_GEN(curop->op_targ)
3149 == (STRLEN)PL_generation)
3151 PAD_COMPNAME_GEN(curop->op_targ)
3155 else if (curop->op_type == OP_RV2CV)
3157 else if (curop->op_type == OP_RV2SV ||
3158 curop->op_type == OP_RV2AV ||
3159 curop->op_type == OP_RV2HV ||
3160 curop->op_type == OP_RV2GV) {
3161 if (lastop->op_type != OP_GV) /* funny deref? */
3164 else if (curop->op_type == OP_PUSHRE) {
3165 if (((PMOP*)curop)->op_pmreplroot) {
3167 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3168 ((PMOP*)curop)->op_pmreplroot));
3170 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3172 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3174 SvCUR(gv) = PL_generation;
3183 o->op_private |= OPpASSIGN_COMMON;
3185 if (right && right->op_type == OP_SPLIT) {
3187 if ((tmpop = ((LISTOP*)right)->op_first) &&
3188 tmpop->op_type == OP_PUSHRE)
3190 PMOP *pm = (PMOP*)tmpop;
3191 if (left->op_type == OP_RV2AV &&
3192 !(left->op_private & OPpLVAL_INTRO) &&
3193 !(o->op_private & OPpASSIGN_COMMON) )
3195 tmpop = ((UNOP*)left)->op_first;
3196 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3198 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3199 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3201 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3202 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3204 pm->op_pmflags |= PMf_ONCE;
3205 tmpop = cUNOPo->op_first; /* to list (nulled) */
3206 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3207 tmpop->op_sibling = Nullop; /* don't free split */
3208 right->op_next = tmpop->op_next; /* fix starting loc */
3209 op_free(o); /* blow off assign */
3210 right->op_flags &= ~OPf_WANT;
3211 /* "I don't know and I don't care." */
3216 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3217 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3219 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3221 sv_setiv(sv, PL_modcount+1);
3229 right = newOP(OP_UNDEF, 0);
3230 if (right->op_type == OP_READLINE) {
3231 right->op_flags |= OPf_STACKED;
3232 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3235 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3236 o = newBINOP(OP_SASSIGN, flags,
3237 scalar(right), mod(scalar(left), OP_SASSIGN) );
3249 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3251 U32 seq = intro_my();
3254 NewOp(1101, cop, 1, COP);
3255 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3256 cop->op_type = OP_DBSTATE;
3257 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3260 cop->op_type = OP_NEXTSTATE;
3261 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3263 cop->op_flags = (U8)flags;
3264 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3266 cop->op_private |= NATIVE_HINTS;
3268 PL_compiling.op_private = cop->op_private;
3269 cop->op_next = (OP*)cop;
3272 cop->cop_label = label;
3273 PL_hints |= HINT_BLOCK_SCOPE;
3276 cop->cop_arybase = PL_curcop->cop_arybase;
3277 if (specialWARN(PL_curcop->cop_warnings))
3278 cop->cop_warnings = PL_curcop->cop_warnings ;
3280 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3281 if (specialCopIO(PL_curcop->cop_io))
3282 cop->cop_io = PL_curcop->cop_io;
3284 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3287 if (PL_copline == NOLINE)
3288 CopLINE_set(cop, CopLINE(PL_curcop));
3290 CopLINE_set(cop, PL_copline);
3291 PL_copline = NOLINE;
3294 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3296 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3298 CopSTASH_set(cop, PL_curstash);
3300 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3301 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3302 if (svp && *svp != &PL_sv_undef ) {
3303 (void)SvIOK_on(*svp);
3304 SvIVX(*svp) = PTR2IV(cop);
3308 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3313 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3315 return new_logop(type, flags, &first, &other);
3319 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3323 OP *first = *firstp;
3324 OP *other = *otherp;
3326 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3327 return newBINOP(type, flags, scalar(first), scalar(other));
3329 scalarboolean(first);
3330 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3331 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3332 if (type == OP_AND || type == OP_OR) {
3338 first = *firstp = cUNOPo->op_first;
3340 first->op_next = o->op_next;
3341 cUNOPo->op_first = Nullop;
3345 if (first->op_type == OP_CONST) {
3346 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE)) {
3347 if (first->op_private & OPpCONST_STRICT)
3348 no_bareword_allowed(first);
3350 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3352 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3363 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3364 OP *k1 = ((UNOP*)first)->op_first;
3365 OP *k2 = k1->op_sibling;
3367 switch (first->op_type)
3370 if (k2 && k2->op_type == OP_READLINE
3371 && (k2->op_flags & OPf_STACKED)
3372 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3374 warnop = k2->op_type;
3379 if (k1->op_type == OP_READDIR
3380 || k1->op_type == OP_GLOB
3381 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3382 || k1->op_type == OP_EACH)
3384 warnop = ((k1->op_type == OP_NULL)
3385 ? (OPCODE)k1->op_targ : k1->op_type);
3390 line_t oldline = CopLINE(PL_curcop);
3391 CopLINE_set(PL_curcop, PL_copline);
3392 Perl_warner(aTHX_ packWARN(WARN_MISC),
3393 "Value of %s%s can be \"0\"; test with defined()",
3395 ((warnop == OP_READLINE || warnop == OP_GLOB)
3396 ? " construct" : "() operator"));
3397 CopLINE_set(PL_curcop, oldline);
3404 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3405 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3407 NewOp(1101, logop, 1, LOGOP);
3409 logop->op_type = (OPCODE)type;
3410 logop->op_ppaddr = PL_ppaddr[type];
3411 logop->op_first = first;
3412 logop->op_flags = flags | OPf_KIDS;
3413 logop->op_other = LINKLIST(other);
3414 logop->op_private = (U8)(1 | (flags >> 8));
3416 /* establish postfix order */
3417 logop->op_next = LINKLIST(first);
3418 first->op_next = (OP*)logop;
3419 first->op_sibling = other;
3421 CHECKOP(type,logop);
3423 o = newUNOP(OP_NULL, 0, (OP*)logop);
3430 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3437 return newLOGOP(OP_AND, 0, first, trueop);
3439 return newLOGOP(OP_OR, 0, first, falseop);
3441 scalarboolean(first);
3442 if (first->op_type == OP_CONST) {
3443 if (first->op_private & OPpCONST_BARE &&
3444 first->op_private & OPpCONST_STRICT) {
3445 no_bareword_allowed(first);
3447 if (SvTRUE(((SVOP*)first)->op_sv)) {
3458 NewOp(1101, logop, 1, LOGOP);
3459 logop->op_type = OP_COND_EXPR;
3460 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3461 logop->op_first = first;
3462 logop->op_flags = flags | OPf_KIDS;
3463 logop->op_private = (U8)(1 | (flags >> 8));
3464 logop->op_other = LINKLIST(trueop);
3465 logop->op_next = LINKLIST(falseop);
3467 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
3470 /* establish postfix order */
3471 start = LINKLIST(first);
3472 first->op_next = (OP*)logop;
3474 first->op_sibling = trueop;
3475 trueop->op_sibling = falseop;
3476 o = newUNOP(OP_NULL, 0, (OP*)logop);
3478 trueop->op_next = falseop->op_next = o;
3485 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3493 NewOp(1101, range, 1, LOGOP);
3495 range->op_type = OP_RANGE;
3496 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3497 range->op_first = left;
3498 range->op_flags = OPf_KIDS;
3499 leftstart = LINKLIST(left);
3500 range->op_other = LINKLIST(right);
3501 range->op_private = (U8)(1 | (flags >> 8));
3503 left->op_sibling = right;
3505 range->op_next = (OP*)range;
3506 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3507 flop = newUNOP(OP_FLOP, 0, flip);
3508 o = newUNOP(OP_NULL, 0, flop);
3510 range->op_next = leftstart;
3512 left->op_next = flip;
3513 right->op_next = flop;
3515 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3516 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3517 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3518 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3520 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3521 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3524 if (!flip->op_private || !flop->op_private)
3525 linklist(o); /* blow off optimizer unless constant */
3531 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3535 int once = block && block->op_flags & OPf_SPECIAL &&
3536 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3539 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3540 return block; /* do {} while 0 does once */
3541 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3542 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3543 expr = newUNOP(OP_DEFINED, 0,
3544 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3545 } else if (expr->op_flags & OPf_KIDS) {
3546 OP *k1 = ((UNOP*)expr)->op_first;
3547 OP *k2 = (k1) ? k1->op_sibling : NULL;
3548 switch (expr->op_type) {
3550 if (k2 && k2->op_type == OP_READLINE
3551 && (k2->op_flags & OPf_STACKED)
3552 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3553 expr = newUNOP(OP_DEFINED, 0, expr);
3557 if (k1->op_type == OP_READDIR
3558 || k1->op_type == OP_GLOB
3559 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3560 || k1->op_type == OP_EACH)
3561 expr = newUNOP(OP_DEFINED, 0, expr);
3567 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3568 o = new_logop(OP_AND, 0, &expr, &listop);
3571 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3573 if (once && o != listop)
3574 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3577 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3579 o->op_flags |= flags;
3581 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3586 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3594 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3595 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3596 expr = newUNOP(OP_DEFINED, 0,
3597 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3598 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3599 OP *k1 = ((UNOP*)expr)->op_first;
3600 OP *k2 = (k1) ? k1->op_sibling : NULL;
3601 switch (expr->op_type) {
3603 if (k2 && k2->op_type == OP_READLINE
3604 && (k2->op_flags & OPf_STACKED)
3605 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3606 expr = newUNOP(OP_DEFINED, 0, expr);
3610 if (k1->op_type == OP_READDIR
3611 || k1->op_type == OP_GLOB
3612 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3613 || k1->op_type == OP_EACH)
3614 expr = newUNOP(OP_DEFINED, 0, expr);
3620 block = newOP(OP_NULL, 0);
3622 block = scope(block);
3626 next = LINKLIST(cont);
3629 OP *unstack = newOP(OP_UNSTACK, 0);
3632 cont = append_elem(OP_LINESEQ, cont, unstack);
3635 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3636 redo = LINKLIST(listop);
3639 PL_copline = (line_t)whileline;
3641 o = new_logop(OP_AND, 0, &expr, &listop);
3642 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3643 op_free(expr); /* oops, it's a while (0) */
3645 return Nullop; /* listop already freed by new_logop */
3648 ((LISTOP*)listop)->op_last->op_next =
3649 (o == listop ? redo : LINKLIST(o));
3655 NewOp(1101,loop,1,LOOP);
3656 loop->op_type = OP_ENTERLOOP;
3657 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3658 loop->op_private = 0;
3659 loop->op_next = (OP*)loop;
3662 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3664 loop->op_redoop = redo;
3665 loop->op_lastop = o;
3666 o->op_private |= loopflags;
3669 loop->op_nextop = next;
3671 loop->op_nextop = o;
3673 o->op_flags |= flags;
3674 o->op_private |= (flags >> 8);
3679 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
3683 PADOFFSET padoff = 0;
3688 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
3689 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
3690 sv->op_type = OP_RV2GV;
3691 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3693 else if (sv->op_type == OP_PADSV) { /* private variable */
3694 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
3695 padoff = sv->op_targ;
3700 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3701 padoff = sv->op_targ;
3703 iterflags |= OPf_SPECIAL;
3708 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3711 sv = newGVOP(OP_GV, 0, PL_defgv);
3713 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3714 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3715 iterflags |= OPf_STACKED;
3717 else if (expr->op_type == OP_NULL &&
3718 (expr->op_flags & OPf_KIDS) &&
3719 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3721 /* Basically turn for($x..$y) into the same as for($x,$y), but we
3722 * set the STACKED flag to indicate that these values are to be
3723 * treated as min/max values by 'pp_iterinit'.
3725 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
3726 LOGOP* range = (LOGOP*) flip->op_first;
3727 OP* left = range->op_first;
3728 OP* right = left->op_sibling;
3731 range->op_flags &= ~OPf_KIDS;
3732 range->op_first = Nullop;
3734 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
3735 listop->op_first->op_next = range->op_next;
3736 left->op_next = range->op_other;
3737 right->op_next = (OP*)listop;
3738 listop->op_next = listop->op_first;
3741 expr = (OP*)(listop);
3743 iterflags |= OPf_STACKED;
3746 expr = mod(force_list(expr), OP_GREPSTART);
3750 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
3751 append_elem(OP_LIST, expr, scalar(sv))));
3752 assert(!loop->op_next);
3753 /* for my $x () sets OPpLVAL_INTRO;
3754 * for our $x () sets OPpOUR_INTRO */
3755 loop->op_private = (U8)iterpflags;
3756 #ifdef PL_OP_SLAB_ALLOC
3759 NewOp(1234,tmp,1,LOOP);
3760 Copy(loop,tmp,1,LOOP);
3765 Renew(loop, 1, LOOP);
3767 loop->op_targ = padoff;
3768 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
3769 PL_copline = forline;
3770 return newSTATEOP(0, label, wop);
3774 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
3779 if (type != OP_GOTO || label->op_type == OP_CONST) {
3780 /* "last()" means "last" */
3781 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
3782 o = newOP(type, OPf_SPECIAL);
3784 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
3785 ? SvPVx(((SVOP*)label)->op_sv, n_a)
3791 if (label->op_type == OP_ENTERSUB)
3792 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
3793 o = newUNOP(type, OPf_STACKED, label);
3795 PL_hints |= HINT_BLOCK_SCOPE;
3799 static void const_sv_xsub(pTHX_ CV* cv);
3802 =for apidoc cv_undef
3804 Clear out all the active components of a CV. This can happen either
3805 by an explicit C<undef &foo>, or by the reference count going to zero.
3806 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
3807 children can still follow the full lexical scope chain.
3813 Perl_cv_undef(pTHX_ CV *cv)
3816 if (CvFILE(cv) && (!CvXSUB(cv) || CvXSUB(cv) == const_sv_xsub)) {
3817 /* for XSUBs CvFILE point directly to static memory; __FILE__
3818 * except when XSUB was constructed via newCONSTSUB() */
3819 Safefree(CvFILE(cv));
3824 if (!CvXSUB(cv) && CvROOT(cv)) {
3826 Perl_croak(aTHX_ "Can't undef active subroutine");
3829 PAD_SAVE_SETNULLPAD();
3831 op_free(CvROOT(cv));
3832 CvROOT(cv) = Nullop;
3835 SvPOK_off((SV*)cv); /* forget prototype */
3840 /* remove CvOUTSIDE unless this is an undef rather than a free */
3841 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
3842 if (!CvWEAKOUTSIDE(cv))
3843 SvREFCNT_dec(CvOUTSIDE(cv));
3844 CvOUTSIDE(cv) = Nullcv;
3847 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
3853 /* delete all flags except WEAKOUTSIDE */
3854 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
3858 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
3860 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
3861 SV* msg = sv_newmortal();
3865 gv_efullname3(name = sv_newmortal(), gv, Nullch);
3866 sv_setpv(msg, "Prototype mismatch:");
3868 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
3870 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (SV *)cv);
3871 sv_catpv(msg, " vs ");
3873 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
3875 sv_catpv(msg, "none");
3876 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
3882 =head1 Optree Manipulation Functions
3884 =for apidoc cv_const_sv
3886 If C<cv> is a constant sub eligible for inlining. returns the constant
3887 value returned by the sub. Otherwise, returns NULL.
3889 Constant subs can be created with C<newCONSTSUB> or as described in
3890 L<perlsub/"Constant Functions">.
3895 Perl_cv_const_sv(pTHX_ CV *cv)
3897 if (!cv || !CvCONST(cv))
3899 return (SV*)CvXSUBANY(cv).any_ptr;
3902 /* op_const_sv: examine an optree to determine whether it's in-lineable.
3903 * Can be called in 3 ways:
3906 * look for a single OP_CONST with attached value: return the value
3908 * cv && CvCLONE(cv) && !CvCONST(cv)
3910 * examine the clone prototype, and if contains only a single
3911 * OP_CONST referencing a pad const, or a single PADSV referencing
3912 * an outer lexical, return a non-zero value to indicate the CV is
3913 * a candidate for "constizing" at clone time
3917 * We have just cloned an anon prototype that was marked as a const
3918 * candidiate. Try to grab the current value, and in the case of
3919 * PADSV, ignore it if it has multiple references. Return the value.
3923 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
3930 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
3931 o = cLISTOPo->op_first->op_sibling;
3933 for (; o; o = o->op_next) {
3934 OPCODE type = o->op_type;
3936 if (sv && o->op_next == o)
3938 if (o->op_next != o) {
3939 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
3941 if (type == OP_DBSTATE)
3944 if (type == OP_LEAVESUB || type == OP_RETURN)
3948 if (type == OP_CONST && cSVOPo->op_sv)
3950 else if (cv && type == OP_CONST) {
3951 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
3955 else if (cv && type == OP_PADSV) {
3956 if (CvCONST(cv)) { /* newly cloned anon */
3957 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
3958 /* the candidate should have 1 ref from this pad and 1 ref
3959 * from the parent */
3960 if (!sv || SvREFCNT(sv) != 2)
3967 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
3968 sv = &PL_sv_undef; /* an arbitrary non-null value */
3979 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
3989 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
3993 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
3995 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
3999 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4005 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4009 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4010 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4011 SV *sv = sv_newmortal();
4012 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4013 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4014 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4019 gv = gv_fetchpv(name ? name : (aname ? aname :
4020 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__")),
4021 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4031 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4032 maximum a prototype before. */
4033 if (SvTYPE(gv) > SVt_NULL) {
4034 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4035 && ckWARN_d(WARN_PROTOTYPE))
4037 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4039 cv_ckproto((CV*)gv, NULL, ps);
4042 sv_setpv((SV*)gv, ps);
4044 sv_setiv((SV*)gv, -1);
4045 SvREFCNT_dec(PL_compcv);
4046 cv = PL_compcv = NULL;
4047 PL_sub_generation++;
4051 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4053 #ifdef GV_UNIQUE_CHECK
4054 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4055 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4059 if (!block || !ps || *ps || attrs)
4062 const_sv = op_const_sv(block, Nullcv);
4065 bool exists = CvROOT(cv) || CvXSUB(cv);
4067 #ifdef GV_UNIQUE_CHECK
4068 if (exists && GvUNIQUE(gv)) {
4069 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4073 /* if the subroutine doesn't exist and wasn't pre-declared
4074 * with a prototype, assume it will be AUTOLOADed,
4075 * skipping the prototype check
4077 if (exists || SvPOK(cv))
4078 cv_ckproto(cv, gv, ps);
4079 /* already defined (or promised)? */
4080 if (exists || GvASSUMECV(gv)) {
4081 if (!block && !attrs) {
4082 if (CvFLAGS(PL_compcv)) {
4083 /* might have had built-in attrs applied */
4084 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4086 /* just a "sub foo;" when &foo is already defined */
4087 SAVEFREESV(PL_compcv);
4090 /* ahem, death to those who redefine active sort subs */
4091 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4092 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4094 if (ckWARN(WARN_REDEFINE)
4096 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4098 line_t oldline = CopLINE(PL_curcop);
4099 if (PL_copline != NOLINE)
4100 CopLINE_set(PL_curcop, PL_copline);
4101 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4102 CvCONST(cv) ? "Constant subroutine %s redefined"
4103 : "Subroutine %s redefined", name);
4104 CopLINE_set(PL_curcop, oldline);
4112 SvREFCNT_inc(const_sv);
4114 assert(!CvROOT(cv) && !CvCONST(cv));
4115 sv_setpv((SV*)cv, ""); /* prototype is "" */
4116 CvXSUBANY(cv).any_ptr = const_sv;
4117 CvXSUB(cv) = const_sv_xsub;
4122 cv = newCONSTSUB(NULL, name, const_sv);
4125 SvREFCNT_dec(PL_compcv);
4127 PL_sub_generation++;
4134 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4135 * before we clobber PL_compcv.
4139 /* Might have had built-in attributes applied -- propagate them. */
4140 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4141 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4142 stash = GvSTASH(CvGV(cv));
4143 else if (CvSTASH(cv))
4144 stash = CvSTASH(cv);
4146 stash = PL_curstash;
4149 /* possibly about to re-define existing subr -- ignore old cv */
4150 rcv = (SV*)PL_compcv;
4151 if (name && GvSTASH(gv))
4152 stash = GvSTASH(gv);
4154 stash = PL_curstash;
4156 apply_attrs(stash, rcv, attrs, FALSE);
4158 if (cv) { /* must reuse cv if autoloaded */
4160 /* got here with just attrs -- work done, so bug out */
4161 SAVEFREESV(PL_compcv);
4164 /* transfer PL_compcv to cv */
4166 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4167 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4168 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4169 CvOUTSIDE(PL_compcv) = 0;
4170 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4171 CvPADLIST(PL_compcv) = 0;
4172 /* inner references to PL_compcv must be fixed up ... */
4173 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4174 /* ... before we throw it away */
4175 SvREFCNT_dec(PL_compcv);
4177 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4178 ++PL_sub_generation;
4185 PL_sub_generation++;
4189 CvFILE_set_from_cop(cv, PL_curcop);
4190 CvSTASH(cv) = PL_curstash;
4193 sv_setpv((SV*)cv, ps);
4195 if (PL_error_count) {
4199 char *s = strrchr(name, ':');
4201 if (strEQ(s, "BEGIN")) {
4203 "BEGIN not safe after errors--compilation aborted";
4204 if (PL_in_eval & EVAL_KEEPERR)
4205 Perl_croak(aTHX_ not_safe);
4207 /* force display of errors found but not reported */
4208 sv_catpv(ERRSV, not_safe);
4209 Perl_croak(aTHX_ "%"SVf, ERRSV);
4218 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4219 mod(scalarseq(block), OP_LEAVESUBLV));
4222 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4224 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4225 OpREFCNT_set(CvROOT(cv), 1);
4226 CvSTART(cv) = LINKLIST(CvROOT(cv));
4227 CvROOT(cv)->op_next = 0;
4228 CALL_PEEP(CvSTART(cv));
4230 /* now that optimizer has done its work, adjust pad values */
4232 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4235 assert(!CvCONST(cv));
4236 if (ps && !*ps && op_const_sv(block, cv))
4240 if (name || aname) {
4242 char *tname = (name ? name : aname);
4244 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4245 SV *sv = NEWSV(0,0);
4246 SV *tmpstr = sv_newmortal();
4247 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4251 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4253 (long)PL_subline, (long)CopLINE(PL_curcop));
4254 gv_efullname3(tmpstr, gv, Nullch);
4255 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4256 hv = GvHVn(db_postponed);
4257 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4258 && (pcv = GvCV(db_postponed)))
4264 call_sv((SV*)pcv, G_DISCARD);
4268 if ((s = strrchr(tname,':')))
4273 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4276 if (strEQ(s, "BEGIN") && !PL_error_count) {
4277 I32 oldscope = PL_scopestack_ix;
4279 SAVECOPFILE(&PL_compiling);
4280 SAVECOPLINE(&PL_compiling);
4283 PL_beginav = newAV();
4284 DEBUG_x( dump_sub(gv) );
4285 av_push(PL_beginav, (SV*)cv);
4286 GvCV(gv) = 0; /* cv has been hijacked */
4287 call_list(oldscope, PL_beginav);
4289 PL_curcop = &PL_compiling;
4290 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4293 else if (strEQ(s, "END") && !PL_error_count) {
4296 DEBUG_x( dump_sub(gv) );
4297 av_unshift(PL_endav, 1);
4298 av_store(PL_endav, 0, (SV*)cv);
4299 GvCV(gv) = 0; /* cv has been hijacked */
4301 else if (strEQ(s, "CHECK") && !PL_error_count) {
4303 PL_checkav = newAV();
4304 DEBUG_x( dump_sub(gv) );
4305 if (PL_main_start && ckWARN(WARN_VOID))
4306 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4307 av_unshift(PL_checkav, 1);
4308 av_store(PL_checkav, 0, (SV*)cv);
4309 GvCV(gv) = 0; /* cv has been hijacked */
4311 else if (strEQ(s, "INIT") && !PL_error_count) {
4313 PL_initav = newAV();
4314 DEBUG_x( dump_sub(gv) );
4315 if (PL_main_start && ckWARN(WARN_VOID))
4316 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4317 av_push(PL_initav, (SV*)cv);
4318 GvCV(gv) = 0; /* cv has been hijacked */
4323 PL_copline = NOLINE;
4328 /* XXX unsafe for threads if eval_owner isn't held */
4330 =for apidoc newCONSTSUB
4332 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4333 eligible for inlining at compile-time.
4339 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4345 SAVECOPLINE(PL_curcop);
4346 CopLINE_set(PL_curcop, PL_copline);
4349 PL_hints &= ~HINT_BLOCK_SCOPE;
4352 SAVESPTR(PL_curstash);
4353 SAVECOPSTASH(PL_curcop);
4354 PL_curstash = stash;
4355 CopSTASH_set(PL_curcop,stash);
4358 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4359 CvXSUBANY(cv).any_ptr = sv;
4361 sv_setpv((SV*)cv, ""); /* prototype is "" */
4364 CopSTASH_free(PL_curcop);
4372 =for apidoc U||newXS
4374 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4380 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
4382 GV *gv = gv_fetchpv(name ? name :
4383 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4384 GV_ADDMULTI, SVt_PVCV);
4388 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4390 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4392 /* just a cached method */
4396 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4397 /* already defined (or promised) */
4398 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4399 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4400 line_t oldline = CopLINE(PL_curcop);
4401 if (PL_copline != NOLINE)
4402 CopLINE_set(PL_curcop, PL_copline);
4403 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4404 CvCONST(cv) ? "Constant subroutine %s redefined"
4405 : "Subroutine %s redefined"
4407 CopLINE_set(PL_curcop, oldline);
4414 if (cv) /* must reuse cv if autoloaded */
4417 cv = (CV*)NEWSV(1105,0);
4418 sv_upgrade((SV *)cv, SVt_PVCV);
4422 PL_sub_generation++;
4426 (void)gv_fetchfile(filename);
4427 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
4428 an external constant string */
4429 CvXSUB(cv) = subaddr;
4432 char *s = strrchr(name,':');
4438 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4441 if (strEQ(s, "BEGIN")) {
4443 PL_beginav = newAV();
4444 av_push(PL_beginav, (SV*)cv);
4445 GvCV(gv) = 0; /* cv has been hijacked */
4447 else if (strEQ(s, "END")) {
4450 av_unshift(PL_endav, 1);
4451 av_store(PL_endav, 0, (SV*)cv);
4452 GvCV(gv) = 0; /* cv has been hijacked */
4454 else if (strEQ(s, "CHECK")) {
4456 PL_checkav = newAV();
4457 if (PL_main_start && ckWARN(WARN_VOID))
4458 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4459 av_unshift(PL_checkav, 1);
4460 av_store(PL_checkav, 0, (SV*)cv);
4461 GvCV(gv) = 0; /* cv has been hijacked */
4463 else if (strEQ(s, "INIT")) {
4465 PL_initav = newAV();
4466 if (PL_main_start && ckWARN(WARN_VOID))
4467 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4468 av_push(PL_initav, (SV*)cv);
4469 GvCV(gv) = 0; /* cv has been hijacked */
4480 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4488 name = SvPVx(cSVOPo->op_sv, n_a);
4491 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
4492 #ifdef GV_UNIQUE_CHECK
4494 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4498 if ((cv = GvFORM(gv))) {
4499 if (ckWARN(WARN_REDEFINE)) {
4500 line_t oldline = CopLINE(PL_curcop);
4501 if (PL_copline != NOLINE)
4502 CopLINE_set(PL_curcop, PL_copline);
4503 Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Format %s redefined",name);
4504 CopLINE_set(PL_curcop, oldline);
4511 CvFILE_set_from_cop(cv, PL_curcop);
4514 pad_tidy(padtidy_FORMAT);
4515 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4516 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4517 OpREFCNT_set(CvROOT(cv), 1);
4518 CvSTART(cv) = LINKLIST(CvROOT(cv));
4519 CvROOT(cv)->op_next = 0;
4520 CALL_PEEP(CvSTART(cv));
4522 PL_copline = NOLINE;
4527 Perl_newANONLIST(pTHX_ OP *o)
4529 return newUNOP(OP_REFGEN, 0,
4530 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4534 Perl_newANONHASH(pTHX_ OP *o)
4536 return newUNOP(OP_REFGEN, 0,
4537 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4541 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4543 return newANONATTRSUB(floor, proto, Nullop, block);
4547 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4549 return newUNOP(OP_REFGEN, 0,
4550 newSVOP(OP_ANONCODE, 0,
4551 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
4555 Perl_oopsAV(pTHX_ OP *o)
4557 switch (o->op_type) {
4559 o->op_type = OP_PADAV;
4560 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4561 return ref(o, OP_RV2AV);
4564 o->op_type = OP_RV2AV;
4565 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4570 if (ckWARN_d(WARN_INTERNAL))
4571 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
4578 Perl_oopsHV(pTHX_ OP *o)
4580 switch (o->op_type) {
4583 o->op_type = OP_PADHV;
4584 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4585 return ref(o, OP_RV2HV);
4589 o->op_type = OP_RV2HV;
4590 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
4595 if (ckWARN_d(WARN_INTERNAL))
4596 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
4603 Perl_newAVREF(pTHX_ OP *o)
4605 if (o->op_type == OP_PADANY) {
4606 o->op_type = OP_PADAV;
4607 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4610 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
4611 && ckWARN(WARN_DEPRECATED)) {
4612 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4613 "Using an array as a reference is deprecated");
4615 return newUNOP(OP_RV2AV, 0, scalar(o));
4619 Perl_newGVREF(pTHX_ I32 type, OP *o)
4621 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
4622 return newUNOP(OP_NULL, 0, o);
4623 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
4627 Perl_newHVREF(pTHX_ OP *o)
4629 if (o->op_type == OP_PADANY) {
4630 o->op_type = OP_PADHV;
4631 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4634 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
4635 && ckWARN(WARN_DEPRECATED)) {
4636 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4637 "Using a hash as a reference is deprecated");
4639 return newUNOP(OP_RV2HV, 0, scalar(o));
4643 Perl_oopsCV(pTHX_ OP *o)
4645 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
4651 Perl_newCVREF(pTHX_ I32 flags, OP *o)
4653 return newUNOP(OP_RV2CV, flags, scalar(o));
4657 Perl_newSVREF(pTHX_ OP *o)
4659 if (o->op_type == OP_PADANY) {
4660 o->op_type = OP_PADSV;
4661 o->op_ppaddr = PL_ppaddr[OP_PADSV];
4664 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4665 o->op_flags |= OPpDONE_SVREF;
4668 return newUNOP(OP_RV2SV, 0, scalar(o));
4671 /* Check routines. */
4674 Perl_ck_anoncode(pTHX_ OP *o)
4676 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
4677 cSVOPo->op_sv = Nullsv;
4682 Perl_ck_bitop(pTHX_ OP *o)
4684 #define OP_IS_NUMCOMPARE(op) \
4685 ((op) == OP_LT || (op) == OP_I_LT || \
4686 (op) == OP_GT || (op) == OP_I_GT || \
4687 (op) == OP_LE || (op) == OP_I_LE || \
4688 (op) == OP_GE || (op) == OP_I_GE || \
4689 (op) == OP_EQ || (op) == OP_I_EQ || \
4690 (op) == OP_NE || (op) == OP_I_NE || \
4691 (op) == OP_NCMP || (op) == OP_I_NCMP)
4692 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4693 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
4694 && (o->op_type == OP_BIT_OR
4695 || o->op_type == OP_BIT_AND
4696 || o->op_type == OP_BIT_XOR))
4698 OP * left = cBINOPo->op_first;
4699 OP * right = left->op_sibling;
4700 if ((OP_IS_NUMCOMPARE(left->op_type) &&
4701 (left->op_flags & OPf_PARENS) == 0) ||
4702 (OP_IS_NUMCOMPARE(right->op_type) &&
4703 (right->op_flags & OPf_PARENS) == 0))
4704 if (ckWARN(WARN_PRECEDENCE))
4705 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4706 "Possible precedence problem on bitwise %c operator",
4707 o->op_type == OP_BIT_OR ? '|'
4708 : o->op_type == OP_BIT_AND ? '&' : '^'
4715 Perl_ck_concat(pTHX_ OP *o)
4717 OP *kid = cUNOPo->op_first;
4718 if (kid->op_type == OP_CONCAT && !(kUNOP->op_first->op_flags & OPf_MOD))
4719 o->op_flags |= OPf_STACKED;
4724 Perl_ck_spair(pTHX_ OP *o)
4726 if (o->op_flags & OPf_KIDS) {
4729 OPCODE type = o->op_type;
4730 o = modkids(ck_fun(o), type);
4731 kid = cUNOPo->op_first;
4732 newop = kUNOP->op_first->op_sibling;
4734 (newop->op_sibling ||
4735 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
4736 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
4737 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
4741 op_free(kUNOP->op_first);
4742 kUNOP->op_first = newop;
4744 o->op_ppaddr = PL_ppaddr[++o->op_type];
4749 Perl_ck_delete(pTHX_ OP *o)
4753 if (o->op_flags & OPf_KIDS) {
4754 OP *kid = cUNOPo->op_first;
4755 switch (kid->op_type) {
4757 o->op_flags |= OPf_SPECIAL;
4760 o->op_private |= OPpSLICE;
4763 o->op_flags |= OPf_SPECIAL;
4768 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
4777 Perl_ck_die(pTHX_ OP *o)
4780 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4786 Perl_ck_eof(pTHX_ OP *o)
4788 I32 type = o->op_type;
4790 if (o->op_flags & OPf_KIDS) {
4791 if (cLISTOPo->op_first->op_type == OP_STUB) {
4793 o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
4801 Perl_ck_eval(pTHX_ OP *o)
4803 PL_hints |= HINT_BLOCK_SCOPE;
4804 if (o->op_flags & OPf_KIDS) {
4805 SVOP *kid = (SVOP*)cUNOPo->op_first;
4808 o->op_flags &= ~OPf_KIDS;
4811 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
4814 cUNOPo->op_first = 0;
4817 NewOp(1101, enter, 1, LOGOP);
4818 enter->op_type = OP_ENTERTRY;
4819 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
4820 enter->op_private = 0;
4822 /* establish postfix order */
4823 enter->op_next = (OP*)enter;
4825 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
4826 o->op_type = OP_LEAVETRY;
4827 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
4828 enter->op_other = o;
4838 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
4840 o->op_targ = (PADOFFSET)PL_hints;
4845 Perl_ck_exit(pTHX_ OP *o)
4848 HV *table = GvHV(PL_hintgv);
4850 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
4851 if (svp && *svp && SvTRUE(*svp))
4852 o->op_private |= OPpEXIT_VMSISH;
4854 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4860 Perl_ck_exec(pTHX_ OP *o)
4863 if (o->op_flags & OPf_STACKED) {
4865 kid = cUNOPo->op_first->op_sibling;
4866 if (kid->op_type == OP_RV2GV)
4875 Perl_ck_exists(pTHX_ OP *o)
4878 if (o->op_flags & OPf_KIDS) {
4879 OP *kid = cUNOPo->op_first;
4880 if (kid->op_type == OP_ENTERSUB) {
4881 (void) ref(kid, o->op_type);
4882 if (kid->op_type != OP_RV2CV && !PL_error_count)
4883 Perl_croak(aTHX_ "%s argument is not a subroutine name",
4885 o->op_private |= OPpEXISTS_SUB;
4887 else if (kid->op_type == OP_AELEM)
4888 o->op_flags |= OPf_SPECIAL;
4889 else if (kid->op_type != OP_HELEM)
4890 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
4899 Perl_ck_gvconst(pTHX_ register OP *o)
4901 o = fold_constants(o);
4902 if (o->op_type == OP_CONST)
4909 Perl_ck_rvconst(pTHX_ register OP *o)
4911 SVOP *kid = (SVOP*)cUNOPo->op_first;
4913 o->op_private |= (PL_hints & HINT_STRICT_REFS);
4914 if (kid->op_type == OP_CONST) {
4918 SV *kidsv = kid->op_sv;
4921 /* Is it a constant from cv_const_sv()? */
4922 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
4923 SV *rsv = SvRV(kidsv);
4924 int svtype = SvTYPE(rsv);
4925 char *badtype = Nullch;
4927 switch (o->op_type) {
4929 if (svtype > SVt_PVMG)
4930 badtype = "a SCALAR";
4933 if (svtype != SVt_PVAV)
4934 badtype = "an ARRAY";
4937 if (svtype != SVt_PVHV)
4941 if (svtype != SVt_PVCV)
4946 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
4949 name = SvPV(kidsv, n_a);
4950 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
4951 char *badthing = Nullch;
4952 switch (o->op_type) {
4954 badthing = "a SCALAR";
4957 badthing = "an ARRAY";
4960 badthing = "a HASH";
4965 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
4969 * This is a little tricky. We only want to add the symbol if we
4970 * didn't add it in the lexer. Otherwise we get duplicate strict
4971 * warnings. But if we didn't add it in the lexer, we must at
4972 * least pretend like we wanted to add it even if it existed before,
4973 * or we get possible typo warnings. OPpCONST_ENTERED says
4974 * whether the lexer already added THIS instance of this symbol.
4976 iscv = (o->op_type == OP_RV2CV) * 2;
4978 gv = gv_fetchpv(name,
4979 iscv | !(kid->op_private & OPpCONST_ENTERED),
4982 : o->op_type == OP_RV2SV
4984 : o->op_type == OP_RV2AV
4986 : o->op_type == OP_RV2HV
4989 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
4991 kid->op_type = OP_GV;
4992 SvREFCNT_dec(kid->op_sv);
4994 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
4995 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
4996 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
4998 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
5000 kid->op_sv = SvREFCNT_inc(gv);
5002 kid->op_private = 0;
5003 kid->op_ppaddr = PL_ppaddr[OP_GV];
5010 Perl_ck_ftst(pTHX_ OP *o)
5012 I32 type = o->op_type;
5014 if (o->op_flags & OPf_REF) {
5017 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5018 SVOP *kid = (SVOP*)cUNOPo->op_first;
5020 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5022 OP *newop = newGVOP(type, OPf_REF,
5023 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5028 if ((PL_hints & HINT_FILETEST_ACCESS) &&
5029 OP_IS_FILETEST_ACCESS(o))
5030 o->op_private |= OPpFT_ACCESS;
5035 if (type == OP_FTTTY)
5036 o = newGVOP(type, OPf_REF, PL_stdingv);
5038 o = newUNOP(type, 0, newDEFSVOP());
5044 Perl_ck_fun(pTHX_ OP *o)
5050 int type = o->op_type;
5051 register I32 oa = PL_opargs[type] >> OASHIFT;
5053 if (o->op_flags & OPf_STACKED) {
5054 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5057 return no_fh_allowed(o);
5060 if (o->op_flags & OPf_KIDS) {
5062 tokid = &cLISTOPo->op_first;
5063 kid = cLISTOPo->op_first;
5064 if (kid->op_type == OP_PUSHMARK ||
5065 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5067 tokid = &kid->op_sibling;
5068 kid = kid->op_sibling;
5070 if (!kid && PL_opargs[type] & OA_DEFGV)
5071 *tokid = kid = newDEFSVOP();
5075 sibl = kid->op_sibling;
5078 /* list seen where single (scalar) arg expected? */
5079 if (numargs == 1 && !(oa >> 4)
5080 && kid->op_type == OP_LIST && type != OP_SCALAR)
5082 return too_many_arguments(o,PL_op_desc[type]);
5095 if ((type == OP_PUSH || type == OP_UNSHIFT)
5096 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5097 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5098 "Useless use of %s with no values",
5101 if (kid->op_type == OP_CONST &&
5102 (kid->op_private & OPpCONST_BARE))
5104 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5105 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5106 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5107 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5108 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5109 "Array @%s missing the @ in argument %"IVdf" of %s()",
5110 name, (IV)numargs, PL_op_desc[type]);
5113 kid->op_sibling = sibl;
5116 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5117 bad_type(numargs, "array", PL_op_desc[type], kid);
5121 if (kid->op_type == OP_CONST &&
5122 (kid->op_private & OPpCONST_BARE))
5124 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5125 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5126 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5127 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5128 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5129 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5130 name, (IV)numargs, PL_op_desc[type]);
5133 kid->op_sibling = sibl;
5136 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5137 bad_type(numargs, "hash", PL_op_desc[type], kid);
5142 OP *newop = newUNOP(OP_NULL, 0, kid);
5143 kid->op_sibling = 0;
5145 newop->op_next = newop;
5147 kid->op_sibling = sibl;
5152 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5153 if (kid->op_type == OP_CONST &&
5154 (kid->op_private & OPpCONST_BARE))
5156 OP *newop = newGVOP(OP_GV, 0,
5157 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5159 if (!(o->op_private & 1) && /* if not unop */
5160 kid == cLISTOPo->op_last)
5161 cLISTOPo->op_last = newop;
5165 else if (kid->op_type == OP_READLINE) {
5166 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5167 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5170 I32 flags = OPf_SPECIAL;
5174 /* is this op a FH constructor? */
5175 if (is_handle_constructor(o,numargs)) {
5176 char *name = Nullch;
5180 /* Set a flag to tell rv2gv to vivify
5181 * need to "prove" flag does not mean something
5182 * else already - NI-S 1999/05/07
5185 if (kid->op_type == OP_PADSV) {
5186 name = PAD_COMPNAME_PV(kid->op_targ);
5187 /* SvCUR of a pad namesv can't be trusted
5188 * (see PL_generation), so calc its length
5194 else if (kid->op_type == OP_RV2SV
5195 && kUNOP->op_first->op_type == OP_GV)
5197 GV *gv = cGVOPx_gv(kUNOP->op_first);
5199 len = GvNAMELEN(gv);
5201 else if (kid->op_type == OP_AELEM
5202 || kid->op_type == OP_HELEM)
5207 if ((op = ((BINOP*)kid)->op_first)) {
5208 SV *tmpstr = Nullsv;
5210 kid->op_type == OP_AELEM ?
5212 if (((op->op_type == OP_RV2AV) ||
5213 (op->op_type == OP_RV2HV)) &&
5214 (op = ((UNOP*)op)->op_first) &&
5215 (op->op_type == OP_GV)) {
5216 /* packagevar $a[] or $h{} */
5217 GV *gv = cGVOPx_gv(op);
5225 else if (op->op_type == OP_PADAV
5226 || op->op_type == OP_PADHV) {
5227 /* lexicalvar $a[] or $h{} */
5229 PAD_COMPNAME_PV(op->op_targ);
5239 name = savepv(SvPVX(tmpstr));
5245 name = "__ANONIO__";
5252 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5253 namesv = PAD_SVl(targ);
5254 (void)SvUPGRADE(namesv, SVt_PV);
5256 sv_setpvn(namesv, "$", 1);
5257 sv_catpvn(namesv, name, len);
5260 kid->op_sibling = 0;
5261 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5262 kid->op_targ = targ;
5263 kid->op_private |= priv;
5265 kid->op_sibling = sibl;
5271 mod(scalar(kid), type);
5275 tokid = &kid->op_sibling;
5276 kid = kid->op_sibling;
5278 o->op_private |= numargs;
5280 return too_many_arguments(o,OP_DESC(o));
5283 else if (PL_opargs[type] & OA_DEFGV) {
5285 return newUNOP(type, 0, newDEFSVOP());
5289 while (oa & OA_OPTIONAL)
5291 if (oa && oa != OA_LIST)
5292 return too_few_arguments(o,OP_DESC(o));
5298 Perl_ck_glob(pTHX_ OP *o)
5303 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5304 append_elem(OP_GLOB, o, newDEFSVOP());
5306 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5307 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5309 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5312 #if !defined(PERL_EXTERNAL_GLOB)
5313 /* XXX this can be tightened up and made more failsafe. */
5317 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5318 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5319 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5320 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5321 GvCV(gv) = GvCV(glob_gv);
5322 SvREFCNT_inc((SV*)GvCV(gv));
5323 GvIMPORTED_CV_on(gv);
5326 #endif /* PERL_EXTERNAL_GLOB */
5328 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5329 append_elem(OP_GLOB, o,
5330 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5331 o->op_type = OP_LIST;
5332 o->op_ppaddr = PL_ppaddr[OP_LIST];
5333 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5334 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5335 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5336 append_elem(OP_LIST, o,
5337 scalar(newUNOP(OP_RV2CV, 0,
5338 newGVOP(OP_GV, 0, gv)))));
5339 o = newUNOP(OP_NULL, 0, ck_subr(o));
5340 o->op_targ = OP_GLOB; /* hint at what it used to be */
5343 gv = newGVgen("main");
5345 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5351 Perl_ck_grep(pTHX_ OP *o)
5355 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5357 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5358 NewOp(1101, gwop, 1, LOGOP);
5360 if (o->op_flags & OPf_STACKED) {
5363 kid = cLISTOPo->op_first->op_sibling;
5364 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5367 kid->op_next = (OP*)gwop;
5368 o->op_flags &= ~OPf_STACKED;
5370 kid = cLISTOPo->op_first->op_sibling;
5371 if (type == OP_MAPWHILE)
5378 kid = cLISTOPo->op_first->op_sibling;
5379 if (kid->op_type != OP_NULL)
5380 Perl_croak(aTHX_ "panic: ck_grep");
5381 kid = kUNOP->op_first;
5383 gwop->op_type = type;
5384 gwop->op_ppaddr = PL_ppaddr[type];
5385 gwop->op_first = listkids(o);
5386 gwop->op_flags |= OPf_KIDS;
5387 gwop->op_private = 1;
5388 gwop->op_other = LINKLIST(kid);
5389 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5390 kid->op_next = (OP*)gwop;
5392 kid = cLISTOPo->op_first->op_sibling;
5393 if (!kid || !kid->op_sibling)
5394 return too_few_arguments(o,OP_DESC(o));
5395 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5396 mod(kid, OP_GREPSTART);
5402 Perl_ck_index(pTHX_ OP *o)
5404 if (o->op_flags & OPf_KIDS) {
5405 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5407 kid = kid->op_sibling; /* get past "big" */
5408 if (kid && kid->op_type == OP_CONST)
5409 fbm_compile(((SVOP*)kid)->op_sv, 0);
5415 Perl_ck_lengthconst(pTHX_ OP *o)
5417 /* XXX length optimization goes here */
5422 Perl_ck_lfun(pTHX_ OP *o)
5424 OPCODE type = o->op_type;
5425 return modkids(ck_fun(o), type);
5429 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5431 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5432 switch (cUNOPo->op_first->op_type) {
5434 /* This is needed for
5435 if (defined %stash::)
5436 to work. Do not break Tk.
5438 break; /* Globals via GV can be undef */
5440 case OP_AASSIGN: /* Is this a good idea? */
5441 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5442 "defined(@array) is deprecated");
5443 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5444 "\t(Maybe you should just omit the defined()?)\n");
5447 /* This is needed for
5448 if (defined %stash::)
5449 to work. Do not break Tk.
5451 break; /* Globals via GV can be undef */
5453 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5454 "defined(%%hash) is deprecated");
5455 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5456 "\t(Maybe you should just omit the defined()?)\n");
5467 Perl_ck_rfun(pTHX_ OP *o)
5469 OPCODE type = o->op_type;
5470 return refkids(ck_fun(o), type);
5474 Perl_ck_listiob(pTHX_ OP *o)
5478 kid = cLISTOPo->op_first;
5481 kid = cLISTOPo->op_first;
5483 if (kid->op_type == OP_PUSHMARK)
5484 kid = kid->op_sibling;
5485 if (kid && o->op_flags & OPf_STACKED)
5486 kid = kid->op_sibling;
5487 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5488 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5489 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5490 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5491 cLISTOPo->op_first->op_sibling = kid;
5492 cLISTOPo->op_last = kid;
5493 kid = kid->op_sibling;
5498 append_elem(o->op_type, o, newDEFSVOP());
5504 Perl_ck_sassign(pTHX_ OP *o)
5506 OP *kid = cLISTOPo->op_first;
5507 /* has a disposable target? */
5508 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5509 && !(kid->op_flags & OPf_STACKED)
5510 /* Cannot steal the second time! */
5511 && !(kid->op_private & OPpTARGET_MY))
5513 OP *kkid = kid->op_sibling;
5515 /* Can just relocate the target. */
5516 if (kkid && kkid->op_type == OP_PADSV
5517 && !(kkid->op_private & OPpLVAL_INTRO))
5519 kid->op_targ = kkid->op_targ;
5521 /* Now we do not need PADSV and SASSIGN. */
5522 kid->op_sibling = o->op_sibling; /* NULL */
5523 cLISTOPo->op_first = NULL;
5526 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
5534 Perl_ck_match(pTHX_ OP *o)
5536 o->op_private |= OPpRUNTIME;
5541 Perl_ck_method(pTHX_ OP *o)
5543 OP *kid = cUNOPo->op_first;
5544 if (kid->op_type == OP_CONST) {
5545 SV* sv = kSVOP->op_sv;
5546 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
5548 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5549 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
5552 kSVOP->op_sv = Nullsv;
5554 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5563 Perl_ck_null(pTHX_ OP *o)
5569 Perl_ck_open(pTHX_ OP *o)
5571 HV *table = GvHV(PL_hintgv);
5575 svp = hv_fetch(table, "open_IN", 7, FALSE);
5577 mode = mode_from_discipline(*svp);
5578 if (mode & O_BINARY)
5579 o->op_private |= OPpOPEN_IN_RAW;
5580 else if (mode & O_TEXT)
5581 o->op_private |= OPpOPEN_IN_CRLF;
5584 svp = hv_fetch(table, "open_OUT", 8, FALSE);
5586 mode = mode_from_discipline(*svp);
5587 if (mode & O_BINARY)
5588 o->op_private |= OPpOPEN_OUT_RAW;
5589 else if (mode & O_TEXT)
5590 o->op_private |= OPpOPEN_OUT_CRLF;
5593 if (o->op_type == OP_BACKTICK)
5596 /* In case of three-arg dup open remove strictness
5597 * from the last arg if it is a bareword. */
5598 OP *first = cLISTOPx(o)->op_first; /* The pushmark. */
5599 OP *last = cLISTOPx(o)->op_last; /* The bareword. */
5603 if ((last->op_type == OP_CONST) && /* The bareword. */
5604 (last->op_private & OPpCONST_BARE) &&
5605 (last->op_private & OPpCONST_STRICT) &&
5606 (oa = first->op_sibling) && /* The fh. */
5607 (oa = oa->op_sibling) && /* The mode. */
5608 SvPOK(((SVOP*)oa)->op_sv) &&
5609 (mode = SvPVX(((SVOP*)oa)->op_sv)) &&
5610 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
5611 (last == oa->op_sibling)) /* The bareword. */
5612 last->op_private &= ~OPpCONST_STRICT;
5618 Perl_ck_repeat(pTHX_ OP *o)
5620 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5621 o->op_private |= OPpREPEAT_DOLIST;
5622 cBINOPo->op_first = force_list(cBINOPo->op_first);
5630 Perl_ck_require(pTHX_ OP *o)
5634 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
5635 SVOP *kid = (SVOP*)cUNOPo->op_first;
5637 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5639 for (s = SvPVX(kid->op_sv); *s; s++) {
5640 if (*s == ':' && s[1] == ':') {
5642 Move(s+2, s+1, strlen(s+2)+1, char);
5643 --SvCUR(kid->op_sv);
5646 if (SvREADONLY(kid->op_sv)) {
5647 SvREADONLY_off(kid->op_sv);
5648 sv_catpvn(kid->op_sv, ".pm", 3);
5649 SvREADONLY_on(kid->op_sv);
5652 sv_catpvn(kid->op_sv, ".pm", 3);
5656 /* handle override, if any */
5657 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
5658 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
5659 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
5661 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5662 OP *kid = cUNOPo->op_first;
5663 cUNOPo->op_first = 0;
5665 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5666 append_elem(OP_LIST, kid,
5667 scalar(newUNOP(OP_RV2CV, 0,
5676 Perl_ck_return(pTHX_ OP *o)
5679 if (CvLVALUE(PL_compcv)) {
5680 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5681 mod(kid, OP_LEAVESUBLV);
5688 Perl_ck_retarget(pTHX_ OP *o)
5690 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5697 Perl_ck_select(pTHX_ OP *o)
5700 if (o->op_flags & OPf_KIDS) {
5701 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5702 if (kid && kid->op_sibling) {
5703 o->op_type = OP_SSELECT;
5704 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
5706 return fold_constants(o);
5710 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5711 if (kid && kid->op_type == OP_RV2GV)
5712 kid->op_private &= ~HINT_STRICT_REFS;
5717 Perl_ck_shift(pTHX_ OP *o)
5719 I32 type = o->op_type;
5721 if (!(o->op_flags & OPf_KIDS)) {
5725 argop = newUNOP(OP_RV2AV, 0,
5726 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
5727 return newUNOP(type, 0, scalar(argop));
5729 return scalar(modkids(ck_fun(o), type));
5733 Perl_ck_sort(pTHX_ OP *o)
5737 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
5739 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5740 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
5742 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
5744 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
5746 if (kid->op_type == OP_SCOPE) {
5750 else if (kid->op_type == OP_LEAVE) {
5751 if (o->op_type == OP_SORT) {
5752 op_null(kid); /* wipe out leave */
5755 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
5756 if (k->op_next == kid)
5758 /* don't descend into loops */
5759 else if (k->op_type == OP_ENTERLOOP
5760 || k->op_type == OP_ENTERITER)
5762 k = cLOOPx(k)->op_lastop;
5767 kid->op_next = 0; /* just disconnect the leave */
5768 k = kLISTOP->op_first;
5773 if (o->op_type == OP_SORT) {
5774 /* provide scalar context for comparison function/block */
5780 o->op_flags |= OPf_SPECIAL;
5782 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
5785 firstkid = firstkid->op_sibling;
5788 /* provide list context for arguments */
5789 if (o->op_type == OP_SORT)
5796 S_simplify_sort(pTHX_ OP *o)
5798 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5802 if (!(o->op_flags & OPf_STACKED))
5804 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
5805 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
5806 kid = kUNOP->op_first; /* get past null */
5807 if (kid->op_type != OP_SCOPE)
5809 kid = kLISTOP->op_last; /* get past scope */
5810 switch(kid->op_type) {
5818 k = kid; /* remember this node*/
5819 if (kBINOP->op_first->op_type != OP_RV2SV)
5821 kid = kBINOP->op_first; /* get past cmp */
5822 if (kUNOP->op_first->op_type != OP_GV)
5824 kid = kUNOP->op_first; /* get past rv2sv */
5826 if (GvSTASH(gv) != PL_curstash)
5828 if (strEQ(GvNAME(gv), "a"))
5830 else if (strEQ(GvNAME(gv), "b"))
5834 kid = k; /* back to cmp */
5835 if (kBINOP->op_last->op_type != OP_RV2SV)
5837 kid = kBINOP->op_last; /* down to 2nd arg */
5838 if (kUNOP->op_first->op_type != OP_GV)
5840 kid = kUNOP->op_first; /* get past rv2sv */
5842 if (GvSTASH(gv) != PL_curstash
5844 ? strNE(GvNAME(gv), "a")
5845 : strNE(GvNAME(gv), "b")))
5847 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
5849 o->op_private |= OPpSORT_REVERSE;
5850 if (k->op_type == OP_NCMP)
5851 o->op_private |= OPpSORT_NUMERIC;
5852 if (k->op_type == OP_I_NCMP)
5853 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
5854 kid = cLISTOPo->op_first->op_sibling;
5855 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
5856 op_free(kid); /* then delete it */
5860 Perl_ck_split(pTHX_ OP *o)
5864 if (o->op_flags & OPf_STACKED)
5865 return no_fh_allowed(o);
5867 kid = cLISTOPo->op_first;
5868 if (kid->op_type != OP_NULL)
5869 Perl_croak(aTHX_ "panic: ck_split");
5870 kid = kid->op_sibling;
5871 op_free(cLISTOPo->op_first);
5872 cLISTOPo->op_first = kid;
5874 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
5875 cLISTOPo->op_last = kid; /* There was only one element previously */
5878 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
5879 OP *sibl = kid->op_sibling;
5880 kid->op_sibling = 0;
5881 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
5882 if (cLISTOPo->op_first == cLISTOPo->op_last)
5883 cLISTOPo->op_last = kid;
5884 cLISTOPo->op_first = kid;
5885 kid->op_sibling = sibl;
5888 kid->op_type = OP_PUSHRE;
5889 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
5891 if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
5892 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
5893 "Use of /g modifier is meaningless in split");
5896 if (!kid->op_sibling)
5897 append_elem(OP_SPLIT, o, newDEFSVOP());
5899 kid = kid->op_sibling;
5902 if (!kid->op_sibling)
5903 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
5905 kid = kid->op_sibling;
5908 if (kid->op_sibling)
5909 return too_many_arguments(o,OP_DESC(o));
5915 Perl_ck_join(pTHX_ OP *o)
5917 if (ckWARN(WARN_SYNTAX)) {
5918 OP *kid = cLISTOPo->op_first->op_sibling;
5919 if (kid && kid->op_type == OP_MATCH) {
5920 char *pmstr = "STRING";
5921 if (PM_GETRE(kPMOP))
5922 pmstr = PM_GETRE(kPMOP)->precomp;
5923 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5924 "/%s/ should probably be written as \"%s\"",
5932 Perl_ck_subr(pTHX_ OP *o)
5934 OP *prev = ((cUNOPo->op_first->op_sibling)
5935 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
5936 OP *o2 = prev->op_sibling;
5943 I32 contextclass = 0;
5948 o->op_private |= OPpENTERSUB_HASTARG;
5949 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
5950 if (cvop->op_type == OP_RV2CV) {
5952 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
5953 op_null(cvop); /* disable rv2cv */
5954 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
5955 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
5956 GV *gv = cGVOPx_gv(tmpop);
5959 tmpop->op_private |= OPpEARLY_CV;
5962 namegv = CvANON(cv) ? gv : CvGV(cv);
5963 proto = SvPV((SV*)cv, n_a);
5965 if (CvASSERTION(cv)) {
5966 if (PL_hints & HINT_ASSERTING) {
5967 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
5968 o->op_private |= OPpENTERSUB_DB;
5972 if (ckWARN(WARN_ASSERTIONS) && !(PL_hints & HINT_ASSERTIONSSEEN)) {
5973 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
5974 "Impossible to activate assertion call");
5981 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
5982 if (o2->op_type == OP_CONST)
5983 o2->op_private &= ~OPpCONST_STRICT;
5984 else if (o2->op_type == OP_LIST) {
5985 OP *o = ((UNOP*)o2)->op_first->op_sibling;
5986 if (o && o->op_type == OP_CONST)
5987 o->op_private &= ~OPpCONST_STRICT;
5990 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5991 if (PERLDB_SUB && PL_curstash != PL_debstash)
5992 o->op_private |= OPpENTERSUB_DB;
5993 while (o2 != cvop) {
5997 return too_many_arguments(o, gv_ename(namegv));
6015 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6017 arg == 1 ? "block or sub {}" : "sub {}",
6018 gv_ename(namegv), o2);
6021 /* '*' allows any scalar type, including bareword */
6024 if (o2->op_type == OP_RV2GV)
6025 goto wrapref; /* autoconvert GLOB -> GLOBref */
6026 else if (o2->op_type == OP_CONST)
6027 o2->op_private &= ~OPpCONST_STRICT;
6028 else if (o2->op_type == OP_ENTERSUB) {
6029 /* accidental subroutine, revert to bareword */
6030 OP *gvop = ((UNOP*)o2)->op_first;
6031 if (gvop && gvop->op_type == OP_NULL) {
6032 gvop = ((UNOP*)gvop)->op_first;
6034 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6037 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6038 (gvop = ((UNOP*)gvop)->op_first) &&
6039 gvop->op_type == OP_GV)
6041 GV *gv = cGVOPx_gv(gvop);
6042 OP *sibling = o2->op_sibling;
6043 SV *n = newSVpvn("",0);
6045 gv_fullname3(n, gv, "");
6046 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6047 sv_chop(n, SvPVX(n)+6);
6048 o2 = newSVOP(OP_CONST, 0, n);
6049 prev->op_sibling = o2;
6050 o2->op_sibling = sibling;
6066 if (contextclass++ == 0) {
6067 e = strchr(proto, ']');
6068 if (!e || e == proto)
6081 while (*--p != '[');
6082 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6083 gv_ename(namegv), o2);
6089 if (o2->op_type == OP_RV2GV)
6092 bad_type(arg, "symbol", gv_ename(namegv), o2);
6095 if (o2->op_type == OP_ENTERSUB)
6098 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6101 if (o2->op_type == OP_RV2SV ||
6102 o2->op_type == OP_PADSV ||
6103 o2->op_type == OP_HELEM ||
6104 o2->op_type == OP_AELEM ||
6105 o2->op_type == OP_THREADSV)
6108 bad_type(arg, "scalar", gv_ename(namegv), o2);
6111 if (o2->op_type == OP_RV2AV ||
6112 o2->op_type == OP_PADAV)
6115 bad_type(arg, "array", gv_ename(namegv), o2);
6118 if (o2->op_type == OP_RV2HV ||
6119 o2->op_type == OP_PADHV)
6122 bad_type(arg, "hash", gv_ename(namegv), o2);
6127 OP* sib = kid->op_sibling;
6128 kid->op_sibling = 0;
6129 o2 = newUNOP(OP_REFGEN, 0, kid);
6130 o2->op_sibling = sib;
6131 prev->op_sibling = o2;
6133 if (contextclass && e) {
6148 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6149 gv_ename(namegv), cv);
6154 mod(o2, OP_ENTERSUB);
6156 o2 = o2->op_sibling;
6158 if (proto && !optional &&
6159 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6160 return too_few_arguments(o, gv_ename(namegv));
6163 o=newSVOP(OP_CONST, 0, newSViv(0));
6169 Perl_ck_svconst(pTHX_ OP *o)
6171 SvREADONLY_on(cSVOPo->op_sv);
6176 Perl_ck_trunc(pTHX_ OP *o)
6178 if (o->op_flags & OPf_KIDS) {
6179 SVOP *kid = (SVOP*)cUNOPo->op_first;
6181 if (kid->op_type == OP_NULL)
6182 kid = (SVOP*)kid->op_sibling;
6183 if (kid && kid->op_type == OP_CONST &&
6184 (kid->op_private & OPpCONST_BARE))
6186 o->op_flags |= OPf_SPECIAL;
6187 kid->op_private &= ~OPpCONST_STRICT;
6194 Perl_ck_substr(pTHX_ OP *o)
6197 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6198 OP *kid = cLISTOPo->op_first;
6200 if (kid->op_type == OP_NULL)
6201 kid = kid->op_sibling;
6203 kid->op_flags |= OPf_MOD;
6209 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6212 Perl_peep(pTHX_ register OP *o)
6214 register OP* oldop = 0;
6216 if (!o || o->op_seq)
6220 SAVEVPTR(PL_curcop);
6221 for (; o; o = o->op_next) {
6224 /* The special value -1 is used by the B::C compiler backend to indicate
6225 * that an op is statically defined and should not be freed */
6226 if (!PL_op_seqmax || PL_op_seqmax == (U16)-1)
6229 switch (o->op_type) {
6233 PL_curcop = ((COP*)o); /* for warnings */
6234 o->op_seq = PL_op_seqmax++;
6238 if (cSVOPo->op_private & OPpCONST_STRICT)
6239 no_bareword_allowed(o);
6241 case OP_METHOD_NAMED:
6242 /* Relocate sv to the pad for thread safety.
6243 * Despite being a "constant", the SV is written to,
6244 * for reference counts, sv_upgrade() etc. */
6246 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6247 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6248 /* If op_sv is already a PADTMP then it is being used by
6249 * some pad, so make a copy. */
6250 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6251 SvREADONLY_on(PAD_SVl(ix));
6252 SvREFCNT_dec(cSVOPo->op_sv);
6255 SvREFCNT_dec(PAD_SVl(ix));
6256 SvPADTMP_on(cSVOPo->op_sv);
6257 PAD_SETSV(ix, cSVOPo->op_sv);
6258 /* XXX I don't know how this isn't readonly already. */
6259 SvREADONLY_on(PAD_SVl(ix));
6261 cSVOPo->op_sv = Nullsv;
6265 o->op_seq = PL_op_seqmax++;
6269 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6270 if (o->op_next->op_private & OPpTARGET_MY) {
6271 if (o->op_flags & OPf_STACKED) /* chained concats */
6272 goto ignore_optimization;
6274 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6275 o->op_targ = o->op_next->op_targ;
6276 o->op_next->op_targ = 0;
6277 o->op_private |= OPpTARGET_MY;
6280 op_null(o->op_next);
6282 ignore_optimization:
6283 o->op_seq = PL_op_seqmax++;
6286 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6287 o->op_seq = PL_op_seqmax++;
6288 break; /* Scalar stub must produce undef. List stub is noop */
6292 if (o->op_targ == OP_NEXTSTATE
6293 || o->op_targ == OP_DBSTATE
6294 || o->op_targ == OP_SETSTATE)
6296 PL_curcop = ((COP*)o);
6298 /* XXX: We avoid setting op_seq here to prevent later calls
6299 to peep() from mistakenly concluding that optimisation
6300 has already occurred. This doesn't fix the real problem,
6301 though (See 20010220.007). AMS 20010719 */
6302 if (oldop && o->op_next) {
6303 oldop->op_next = o->op_next;
6311 if (oldop && o->op_next) {
6312 oldop->op_next = o->op_next;
6315 o->op_seq = PL_op_seqmax++;
6319 if (o->op_next->op_type == OP_RV2SV) {
6320 if (!(o->op_next->op_private & OPpDEREF)) {
6321 op_null(o->op_next);
6322 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6324 o->op_next = o->op_next->op_next;
6325 o->op_type = OP_GVSV;
6326 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6329 else if (o->op_next->op_type == OP_RV2AV) {
6330 OP* pop = o->op_next->op_next;
6332 if (pop && pop->op_type == OP_CONST &&
6333 (PL_op = pop->op_next) &&
6334 pop->op_next->op_type == OP_AELEM &&
6335 !(pop->op_next->op_private &
6336 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6337 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6342 op_null(o->op_next);
6343 op_null(pop->op_next);
6345 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6346 o->op_next = pop->op_next->op_next;
6347 o->op_type = OP_AELEMFAST;
6348 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6349 o->op_private = (U8)i;
6354 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6356 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6357 /* XXX could check prototype here instead of just carping */
6358 SV *sv = sv_newmortal();
6359 gv_efullname3(sv, gv, Nullch);
6360 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6361 "%"SVf"() called too early to check prototype",
6365 else if (o->op_next->op_type == OP_READLINE
6366 && o->op_next->op_next->op_type == OP_CONCAT
6367 && (o->op_next->op_next->op_flags & OPf_STACKED))
6369 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6370 o->op_type = OP_RCATLINE;
6371 o->op_flags |= OPf_STACKED;
6372 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6373 op_null(o->op_next->op_next);
6374 op_null(o->op_next);
6377 o->op_seq = PL_op_seqmax++;
6390 o->op_seq = PL_op_seqmax++;
6391 while (cLOGOP->op_other->op_type == OP_NULL)
6392 cLOGOP->op_other = cLOGOP->op_other->op_next;
6393 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6398 o->op_seq = PL_op_seqmax++;
6399 while (cLOOP->op_redoop->op_type == OP_NULL)
6400 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6401 peep(cLOOP->op_redoop);
6402 while (cLOOP->op_nextop->op_type == OP_NULL)
6403 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6404 peep(cLOOP->op_nextop);
6405 while (cLOOP->op_lastop->op_type == OP_NULL)
6406 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6407 peep(cLOOP->op_lastop);
6413 o->op_seq = PL_op_seqmax++;
6414 while (cPMOP->op_pmreplstart &&
6415 cPMOP->op_pmreplstart->op_type == OP_NULL)
6416 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6417 peep(cPMOP->op_pmreplstart);
6421 o->op_seq = PL_op_seqmax++;
6422 if (ckWARN(WARN_SYNTAX) && o->op_next
6423 && o->op_next->op_type == OP_NEXTSTATE) {
6424 if (o->op_next->op_sibling &&
6425 o->op_next->op_sibling->op_type != OP_EXIT &&
6426 o->op_next->op_sibling->op_type != OP_WARN &&
6427 o->op_next->op_sibling->op_type != OP_DIE) {
6428 line_t oldline = CopLINE(PL_curcop);
6430 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6431 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6432 "Statement unlikely to be reached");
6433 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6434 "\t(Maybe you meant system() when you said exec()?)\n");
6435 CopLINE_set(PL_curcop, oldline);
6446 o->op_seq = PL_op_seqmax++;
6448 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6451 /* Make the CONST have a shared SV */
6452 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6453 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6454 key = SvPV(sv, keylen);
6455 lexname = newSVpvn_share(key,
6456 SvUTF8(sv) ? -(I32)keylen : keylen,
6465 o->op_seq = PL_op_seqmax++;
6475 char* Perl_custom_op_name(pTHX_ OP* o)
6477 IV index = PTR2IV(o->op_ppaddr);
6481 if (!PL_custom_op_names) /* This probably shouldn't happen */
6482 return PL_op_name[OP_CUSTOM];
6484 keysv = sv_2mortal(newSViv(index));
6486 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
6488 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
6490 return SvPV_nolen(HeVAL(he));
6493 char* Perl_custom_op_desc(pTHX_ OP* o)
6495 IV index = PTR2IV(o->op_ppaddr);
6499 if (!PL_custom_op_descs)
6500 return PL_op_desc[OP_CUSTOM];
6502 keysv = sv_2mortal(newSViv(index));
6504 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
6506 return PL_op_desc[OP_CUSTOM];
6508 return SvPV_nolen(HeVAL(he));
6514 /* Efficient sub that returns a constant scalar value. */
6516 const_sv_xsub(pTHX_ CV* cv)
6521 Perl_croak(aTHX_ "usage: %s::%s()",
6522 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
6526 ST(0) = (SV*)XSANY.any_ptr;