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
34 Perl_Slab_Alloc(pTHX_ int m, size_t sz)
37 * To make incrementing use count easy PL_OpSlab is an I32 *
38 * To make inserting the link to slab PL_OpPtr is I32 **
39 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
40 * Add an overhead for pointer to slab and round up as a number of pointers
42 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
43 if ((PL_OpSpace -= sz) < 0) {
44 PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*));
48 Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **);
49 /* We reserve the 0'th I32 sized chunk as a use count */
50 PL_OpSlab = (I32 *) PL_OpPtr;
51 /* Reduce size by the use count word, and by the size we need.
52 * Latter is to mimic the '-=' in the if() above
54 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
55 /* Allocation pointer starts at the top.
56 Theory: because we build leaves before trunk allocating at end
57 means that at run time access is cache friendly upward
59 PL_OpPtr += PERL_SLAB_SIZE;
61 assert( PL_OpSpace >= 0 );
62 /* Move the allocation pointer down */
64 assert( PL_OpPtr > (I32 **) PL_OpSlab );
65 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
66 (*PL_OpSlab)++; /* Increment use count of slab */
67 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
68 assert( *PL_OpSlab > 0 );
69 return (void *)(PL_OpPtr + 1);
73 Perl_Slab_Free(pTHX_ void *op)
75 I32 **ptr = (I32 **) op;
77 assert( ptr-1 > (I32 **) slab );
78 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
82 #define PerlMemShared PerlMem
85 PerlMemShared_free(slab);
86 if (slab == PL_OpSlab) {
93 * In the following definition, the ", Nullop" is just to make the compiler
94 * think the expression is of the right type: croak actually does a Siglongjmp.
96 #define CHECKOP(type,o) \
97 ((PL_op_mask && PL_op_mask[type]) \
98 ? ( op_free((OP*)o), \
99 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
101 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
103 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
106 S_gv_ename(pTHX_ GV *gv)
109 SV* tmpsv = sv_newmortal();
110 gv_efullname3(tmpsv, gv, Nullch);
111 return SvPV(tmpsv,n_a);
115 S_no_fh_allowed(pTHX_ OP *o)
117 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
123 S_too_few_arguments(pTHX_ OP *o, char *name)
125 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
130 S_too_many_arguments(pTHX_ OP *o, char *name)
132 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
137 S_bad_type(pTHX_ I32 n, char *t, char *name, OP *kid)
139 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
140 (int)n, name, t, OP_DESC(kid)));
144 S_no_bareword_allowed(pTHX_ OP *o)
146 qerror(Perl_mess(aTHX_
147 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
151 /* "register" allocation */
154 Perl_allocmy(pTHX_ char *name)
158 /* complain about "my $_" etc etc */
159 if (!(PL_in_my == KEY_our ||
161 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
162 (name[1] == '_' && (int)strlen(name) > 2)))
164 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
165 /* 1999-02-27 mjd@plover.com */
167 p = strchr(name, '\0');
168 /* The next block assumes the buffer is at least 205 chars
169 long. At present, it's always at least 256 chars. */
171 strcpy(name+200, "...");
177 /* Move everything else down one character */
178 for (; p-name > 2; p--)
180 name[2] = toCTRL(name[1]);
183 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
186 /* check for duplicate declaration */
188 (bool)(PL_in_my == KEY_our),
189 (PL_curstash ? PL_curstash : PL_defstash)
192 if (PL_in_my_stash && *name != '$') {
193 yyerror(Perl_form(aTHX_
194 "Can't declare class for non-scalar %s in \"%s\"",
195 name, PL_in_my == KEY_our ? "our" : "my"));
198 /* allocate a spare slot and store the name in that slot */
200 off = pad_add_name(name,
203 ? (PL_curstash ? PL_curstash : PL_defstash)
214 Perl_op_free(pTHX_ OP *o)
216 register OP *kid, *nextkid;
219 if (!o || o->op_seq == (U16)-1)
222 if (o->op_private & OPpREFCOUNTED) {
223 switch (o->op_type) {
231 if (OpREFCNT_dec(o)) {
242 if (o->op_flags & OPf_KIDS) {
243 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
244 nextkid = kid->op_sibling; /* Get before next freeing kid */
250 type = (OPCODE)o->op_targ;
252 /* COP* is not cleared by op_clear() so that we may track line
253 * numbers etc even after null() */
254 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
262 Perl_op_clear(pTHX_ OP *o)
265 switch (o->op_type) {
266 case OP_NULL: /* Was holding old type, if any. */
267 case OP_ENTEREVAL: /* Was holding hints. */
271 if (!(o->op_flags & OPf_REF)
272 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
279 if (cPADOPo->op_padix > 0) {
280 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
281 * may still exist on the pad */
282 pad_swipe(cPADOPo->op_padix, TRUE);
283 cPADOPo->op_padix = 0;
286 SvREFCNT_dec(cSVOPo->op_sv);
287 cSVOPo->op_sv = Nullsv;
290 case OP_METHOD_NAMED:
292 SvREFCNT_dec(cSVOPo->op_sv);
293 cSVOPo->op_sv = Nullsv;
296 Even if op_clear does a pad_free for the target of the op,
297 pad_free doesn't actually remove the sv that exists in the bad
298 instead it lives on. This results in that it could be reused as
299 a target later on when the pad was reallocated.
302 pad_swipe(o->op_targ,1);
311 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
315 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
316 SvREFCNT_dec(cSVOPo->op_sv);
317 cSVOPo->op_sv = Nullsv;
320 Safefree(cPVOPo->op_pv);
321 cPVOPo->op_pv = Nullch;
325 op_free(cPMOPo->op_pmreplroot);
329 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
330 /* No GvIN_PAD_off here, because other references may still
331 * exist on the pad */
332 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
335 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
342 HV *pmstash = PmopSTASH(cPMOPo);
343 if (pmstash && SvREFCNT(pmstash)) {
344 PMOP *pmop = HvPMROOT(pmstash);
345 PMOP *lastpmop = NULL;
347 if (cPMOPo == pmop) {
349 lastpmop->op_pmnext = pmop->op_pmnext;
351 HvPMROOT(pmstash) = pmop->op_pmnext;
355 pmop = pmop->op_pmnext;
358 PmopSTASH_free(cPMOPo);
360 cPMOPo->op_pmreplroot = Nullop;
361 /* we use the "SAFE" version of the PM_ macros here
362 * since sv_clean_all might release some PMOPs
363 * after PL_regex_padav has been cleared
364 * and the clearing of PL_regex_padav needs to
365 * happen before sv_clean_all
367 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
368 PM_SETRE_SAFE(cPMOPo, (REGEXP*)NULL);
370 if(PL_regex_pad) { /* We could be in destruction */
371 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
372 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
373 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
380 if (o->op_targ > 0) {
381 pad_free(o->op_targ);
387 S_cop_free(pTHX_ COP* cop)
389 Safefree(cop->cop_label); /* FIXME: treaddead ??? */
392 if (! specialWARN(cop->cop_warnings))
393 SvREFCNT_dec(cop->cop_warnings);
394 if (! specialCopIO(cop->cop_io)) {
398 char *s = SvPV(cop->cop_io,len);
399 Perl_warn(aTHX_ "io='%.*s'",(int) len,s); /* ??? --jhi */
402 SvREFCNT_dec(cop->cop_io);
408 Perl_op_null(pTHX_ OP *o)
410 if (o->op_type == OP_NULL)
413 o->op_targ = o->op_type;
414 o->op_type = OP_NULL;
415 o->op_ppaddr = PL_ppaddr[OP_NULL];
418 /* Contextualizers */
420 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
423 Perl_linklist(pTHX_ OP *o)
430 /* establish postfix order */
431 if (cUNOPo->op_first) {
432 o->op_next = LINKLIST(cUNOPo->op_first);
433 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
435 kid->op_next = LINKLIST(kid->op_sibling);
447 Perl_scalarkids(pTHX_ OP *o)
450 if (o && o->op_flags & OPf_KIDS) {
451 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
458 S_scalarboolean(pTHX_ OP *o)
460 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
461 if (ckWARN(WARN_SYNTAX)) {
462 line_t oldline = CopLINE(PL_curcop);
464 if (PL_copline != NOLINE)
465 CopLINE_set(PL_curcop, PL_copline);
466 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
467 CopLINE_set(PL_curcop, oldline);
474 Perl_scalar(pTHX_ OP *o)
478 /* assumes no premature commitment */
479 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
480 || o->op_type == OP_RETURN)
485 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
487 switch (o->op_type) {
489 scalar(cBINOPo->op_first);
494 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
498 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
499 if (!kPMOP->op_pmreplroot)
500 deprecate_old("implicit split to @_");
508 if (o->op_flags & OPf_KIDS) {
509 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
515 kid = cLISTOPo->op_first;
517 while ((kid = kid->op_sibling)) {
523 WITH_THR(PL_curcop = &PL_compiling);
528 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
534 WITH_THR(PL_curcop = &PL_compiling);
537 if (ckWARN(WARN_VOID))
538 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
544 Perl_scalarvoid(pTHX_ OP *o)
551 if (o->op_type == OP_NEXTSTATE
552 || o->op_type == OP_SETSTATE
553 || o->op_type == OP_DBSTATE
554 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
555 || o->op_targ == OP_SETSTATE
556 || o->op_targ == OP_DBSTATE)))
557 PL_curcop = (COP*)o; /* for warning below */
559 /* assumes no premature commitment */
560 want = o->op_flags & OPf_WANT;
561 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
562 || o->op_type == OP_RETURN)
567 if ((o->op_private & OPpTARGET_MY)
568 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
570 return scalar(o); /* As if inside SASSIGN */
573 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
575 switch (o->op_type) {
577 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
581 if (o->op_flags & OPf_STACKED)
585 if (o->op_private == 4)
657 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
658 useless = OP_DESC(o);
665 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
666 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
667 useless = "a variable";
672 if (cSVOPo->op_private & OPpCONST_STRICT)
673 no_bareword_allowed(o);
675 if (ckWARN(WARN_VOID)) {
676 useless = "a constant";
677 /* the constants 0 and 1 are permitted as they are
678 conventionally used as dummies in constructs like
679 1 while some_condition_with_side_effects; */
680 if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
682 else if (SvPOK(sv)) {
683 /* perl4's way of mixing documentation and code
684 (before the invention of POD) was based on a
685 trick to mix nroff and perl code. The trick was
686 built upon these three nroff macros being used in
687 void context. The pink camel has the details in
688 the script wrapman near page 319. */
689 if (strnEQ(SvPVX(sv), "di", 2) ||
690 strnEQ(SvPVX(sv), "ds", 2) ||
691 strnEQ(SvPVX(sv), "ig", 2))
696 op_null(o); /* don't execute or even remember it */
700 o->op_type = OP_PREINC; /* pre-increment is faster */
701 o->op_ppaddr = PL_ppaddr[OP_PREINC];
705 o->op_type = OP_PREDEC; /* pre-decrement is faster */
706 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
713 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
718 if (o->op_flags & OPf_STACKED)
725 if (!(o->op_flags & OPf_KIDS))
734 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
741 /* all requires must return a boolean value */
742 o->op_flags &= ~OPf_WANT;
747 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
748 if (!kPMOP->op_pmreplroot)
749 deprecate_old("implicit split to @_");
753 if (useless && ckWARN(WARN_VOID))
754 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
759 Perl_listkids(pTHX_ OP *o)
762 if (o && o->op_flags & OPf_KIDS) {
763 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
770 Perl_list(pTHX_ OP *o)
774 /* assumes no premature commitment */
775 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
776 || o->op_type == OP_RETURN)
781 if ((o->op_private & OPpTARGET_MY)
782 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
784 return o; /* As if inside SASSIGN */
787 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
789 switch (o->op_type) {
792 list(cBINOPo->op_first);
797 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
805 if (!(o->op_flags & OPf_KIDS))
807 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
808 list(cBINOPo->op_first);
809 return gen_constant_list(o);
816 kid = cLISTOPo->op_first;
818 while ((kid = kid->op_sibling)) {
824 WITH_THR(PL_curcop = &PL_compiling);
828 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
834 WITH_THR(PL_curcop = &PL_compiling);
837 /* all requires must return a boolean value */
838 o->op_flags &= ~OPf_WANT;
845 Perl_scalarseq(pTHX_ OP *o)
850 if (o->op_type == OP_LINESEQ ||
851 o->op_type == OP_SCOPE ||
852 o->op_type == OP_LEAVE ||
853 o->op_type == OP_LEAVETRY)
855 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
856 if (kid->op_sibling) {
860 PL_curcop = &PL_compiling;
862 o->op_flags &= ~OPf_PARENS;
863 if (PL_hints & HINT_BLOCK_SCOPE)
864 o->op_flags |= OPf_PARENS;
867 o = newOP(OP_STUB, 0);
872 S_modkids(pTHX_ OP *o, I32 type)
875 if (o && o->op_flags & OPf_KIDS) {
876 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
882 /* Propagate lvalue ("modifiable") context to an op and it's children.
883 * 'type' represents the context type, roughly based on the type of op that
884 * would do the modifying, although local() is represented by OP_NULL.
885 * It's responsible for detecting things that can't be modified, flag
886 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
887 * might have to vivify a reference in $x), and so on.
889 * For example, "$a+1 = 2" would cause mod() to be called with o being
890 * OP_ADD and type being OP_SASSIGN, and would output an error.
894 Perl_mod(pTHX_ OP *o, I32 type)
897 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
900 if (!o || PL_error_count)
903 if ((o->op_private & OPpTARGET_MY)
904 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
909 switch (o->op_type) {
915 if (!(o->op_private & (OPpCONST_ARYBASE)))
917 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
918 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
922 SAVEI32(PL_compiling.cop_arybase);
923 PL_compiling.cop_arybase = 0;
925 else if (type == OP_REFGEN)
928 Perl_croak(aTHX_ "That use of $[ is unsupported");
931 if (o->op_flags & OPf_PARENS)
935 if ((type == OP_UNDEF || type == OP_REFGEN) &&
936 !(o->op_flags & OPf_STACKED)) {
937 o->op_type = OP_RV2CV; /* entersub => rv2cv */
938 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
939 assert(cUNOPo->op_first->op_type == OP_NULL);
940 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
943 else if (o->op_private & OPpENTERSUB_NOMOD)
945 else { /* lvalue subroutine call */
946 o->op_private |= OPpLVAL_INTRO;
947 PL_modcount = RETURN_UNLIMITED_NUMBER;
948 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
949 /* Backward compatibility mode: */
950 o->op_private |= OPpENTERSUB_INARGS;
953 else { /* Compile-time error message: */
954 OP *kid = cUNOPo->op_first;
958 if (kid->op_type == OP_PUSHMARK)
960 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
962 "panic: unexpected lvalue entersub "
963 "args: type/targ %ld:%"UVuf,
964 (long)kid->op_type, (UV)kid->op_targ);
965 kid = kLISTOP->op_first;
967 while (kid->op_sibling)
968 kid = kid->op_sibling;
969 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
971 if (kid->op_type == OP_METHOD_NAMED
972 || kid->op_type == OP_METHOD)
976 NewOp(1101, newop, 1, UNOP);
977 newop->op_type = OP_RV2CV;
978 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
979 newop->op_first = Nullop;
980 newop->op_next = (OP*)newop;
981 kid->op_sibling = (OP*)newop;
982 newop->op_private |= OPpLVAL_INTRO;
986 if (kid->op_type != OP_RV2CV)
988 "panic: unexpected lvalue entersub "
989 "entry via type/targ %ld:%"UVuf,
990 (long)kid->op_type, (UV)kid->op_targ);
991 kid->op_private |= OPpLVAL_INTRO;
992 break; /* Postpone until runtime */
996 kid = kUNOP->op_first;
997 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
998 kid = kUNOP->op_first;
999 if (kid->op_type == OP_NULL)
1001 "Unexpected constant lvalue entersub "
1002 "entry via type/targ %ld:%"UVuf,
1003 (long)kid->op_type, (UV)kid->op_targ);
1004 if (kid->op_type != OP_GV) {
1005 /* Restore RV2CV to check lvalueness */
1007 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1008 okid->op_next = kid->op_next;
1009 kid->op_next = okid;
1012 okid->op_next = Nullop;
1013 okid->op_type = OP_RV2CV;
1015 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1016 okid->op_private |= OPpLVAL_INTRO;
1020 cv = GvCV(kGVOP_gv);
1030 /* grep, foreach, subcalls, refgen */
1031 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1033 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1034 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1036 : (o->op_type == OP_ENTERSUB
1037 ? "non-lvalue subroutine call"
1039 type ? PL_op_desc[type] : "local"));
1053 case OP_RIGHT_SHIFT:
1062 if (!(o->op_flags & OPf_STACKED))
1069 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1075 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1076 PL_modcount = RETURN_UNLIMITED_NUMBER;
1077 return o; /* Treat \(@foo) like ordinary list. */
1081 if (scalar_mod_type(o, type))
1083 ref(cUNOPo->op_first, o->op_type);
1087 if (type == OP_LEAVESUBLV)
1088 o->op_private |= OPpMAYBE_LVSUB;
1094 PL_modcount = RETURN_UNLIMITED_NUMBER;
1097 ref(cUNOPo->op_first, o->op_type);
1102 PL_hints |= HINT_BLOCK_SCOPE;
1117 PL_modcount = RETURN_UNLIMITED_NUMBER;
1118 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1119 return o; /* Treat \(@foo) like ordinary list. */
1120 if (scalar_mod_type(o, type))
1122 if (type == OP_LEAVESUBLV)
1123 o->op_private |= OPpMAYBE_LVSUB;
1127 if (!type) /* local() */
1128 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1129 PAD_COMPNAME_PV(o->op_targ));
1137 if (type != OP_SASSIGN)
1141 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1146 if (type == OP_LEAVESUBLV)
1147 o->op_private |= OPpMAYBE_LVSUB;
1149 pad_free(o->op_targ);
1150 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1151 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1152 if (o->op_flags & OPf_KIDS)
1153 mod(cBINOPo->op_first->op_sibling, type);
1158 ref(cBINOPo->op_first, o->op_type);
1159 if (type == OP_ENTERSUB &&
1160 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1161 o->op_private |= OPpLVAL_DEFER;
1162 if (type == OP_LEAVESUBLV)
1163 o->op_private |= OPpMAYBE_LVSUB;
1173 if (o->op_flags & OPf_KIDS)
1174 mod(cLISTOPo->op_last, type);
1179 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1181 else if (!(o->op_flags & OPf_KIDS))
1183 if (o->op_targ != OP_LIST) {
1184 mod(cBINOPo->op_first, type);
1190 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1195 if (type != OP_LEAVESUBLV)
1197 break; /* mod()ing was handled by ck_return() */
1200 /* [20011101.069] File test operators interpret OPf_REF to mean that
1201 their argument is a filehandle; thus \stat(".") should not set
1203 if (type == OP_REFGEN &&
1204 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1207 if (type != OP_LEAVESUBLV)
1208 o->op_flags |= OPf_MOD;
1210 if (type == OP_AASSIGN || type == OP_SASSIGN)
1211 o->op_flags |= OPf_SPECIAL|OPf_REF;
1212 else if (!type) { /* local() */
1215 o->op_private |= OPpLVAL_INTRO;
1216 o->op_flags &= ~OPf_SPECIAL;
1217 PL_hints |= HINT_BLOCK_SCOPE;
1222 if (ckWARN(WARN_SYNTAX)) {
1223 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1224 "Useless localization of %s", OP_DESC(o));
1228 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1229 && type != OP_LEAVESUBLV)
1230 o->op_flags |= OPf_REF;
1235 S_scalar_mod_type(pTHX_ OP *o, I32 type)
1239 if (o->op_type == OP_RV2GV)
1263 case OP_RIGHT_SHIFT:
1282 S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
1284 switch (o->op_type) {
1292 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1305 Perl_refkids(pTHX_ OP *o, I32 type)
1308 if (o && o->op_flags & OPf_KIDS) {
1309 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1316 Perl_ref(pTHX_ OP *o, I32 type)
1320 if (!o || PL_error_count)
1323 switch (o->op_type) {
1325 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1326 !(o->op_flags & OPf_STACKED)) {
1327 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1328 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1329 assert(cUNOPo->op_first->op_type == OP_NULL);
1330 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1331 o->op_flags |= OPf_SPECIAL;
1336 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1340 if (type == OP_DEFINED)
1341 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1342 ref(cUNOPo->op_first, o->op_type);
1345 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1346 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1347 : type == OP_RV2HV ? OPpDEREF_HV
1349 o->op_flags |= OPf_MOD;
1354 o->op_flags |= OPf_MOD; /* XXX ??? */
1359 o->op_flags |= OPf_REF;
1362 if (type == OP_DEFINED)
1363 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1364 ref(cUNOPo->op_first, o->op_type);
1369 o->op_flags |= OPf_REF;
1374 if (!(o->op_flags & OPf_KIDS))
1376 ref(cBINOPo->op_first, type);
1380 ref(cBINOPo->op_first, o->op_type);
1381 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1382 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1383 : type == OP_RV2HV ? OPpDEREF_HV
1385 o->op_flags |= OPf_MOD;
1393 if (!(o->op_flags & OPf_KIDS))
1395 ref(cLISTOPo->op_last, type);
1405 S_dup_attrlist(pTHX_ OP *o)
1409 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1410 * where the first kid is OP_PUSHMARK and the remaining ones
1411 * are OP_CONST. We need to push the OP_CONST values.
1413 if (o->op_type == OP_CONST)
1414 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1416 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1417 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1418 if (o->op_type == OP_CONST)
1419 rop = append_elem(OP_LIST, rop,
1420 newSVOP(OP_CONST, o->op_flags,
1421 SvREFCNT_inc(cSVOPo->op_sv)));
1428 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1432 /* fake up C<use attributes $pkg,$rv,@attrs> */
1433 ENTER; /* need to protect against side-effects of 'use' */
1436 stashsv = newSVpv(HvNAME(stash), 0);
1438 stashsv = &PL_sv_no;
1440 #define ATTRSMODULE "attributes"
1441 #define ATTRSMODULE_PM "attributes.pm"
1445 /* Don't force the C<use> if we don't need it. */
1446 svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
1447 sizeof(ATTRSMODULE_PM)-1, 0);
1448 if (svp && *svp != &PL_sv_undef)
1449 ; /* already in %INC */
1451 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1452 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1456 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1457 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1459 prepend_elem(OP_LIST,
1460 newSVOP(OP_CONST, 0, stashsv),
1461 prepend_elem(OP_LIST,
1462 newSVOP(OP_CONST, 0,
1464 dup_attrlist(attrs))));
1470 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1472 OP *pack, *imop, *arg;
1478 assert(target->op_type == OP_PADSV ||
1479 target->op_type == OP_PADHV ||
1480 target->op_type == OP_PADAV);
1482 /* Ensure that attributes.pm is loaded. */
1483 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1485 /* Need package name for method call. */
1486 pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
1488 /* Build up the real arg-list. */
1490 stashsv = newSVpv(HvNAME(stash), 0);
1492 stashsv = &PL_sv_no;
1493 arg = newOP(OP_PADSV, 0);
1494 arg->op_targ = target->op_targ;
1495 arg = prepend_elem(OP_LIST,
1496 newSVOP(OP_CONST, 0, stashsv),
1497 prepend_elem(OP_LIST,
1498 newUNOP(OP_REFGEN, 0,
1499 mod(arg, OP_REFGEN)),
1500 dup_attrlist(attrs)));
1502 /* Fake up a method call to import */
1503 meth = newSVpvn("import", 6);
1504 (void)SvUPGRADE(meth, SVt_PVIV);
1505 (void)SvIOK_on(meth);
1506 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
1507 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1508 append_elem(OP_LIST,
1509 prepend_elem(OP_LIST, pack, list(arg)),
1510 newSVOP(OP_METHOD_NAMED, 0, meth)));
1511 imop->op_private |= OPpENTERSUB_NOMOD;
1513 /* Combine the ops. */
1514 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1518 =notfor apidoc apply_attrs_string
1520 Attempts to apply a list of attributes specified by the C<attrstr> and
1521 C<len> arguments to the subroutine identified by the C<cv> argument which
1522 is expected to be associated with the package identified by the C<stashpv>
1523 argument (see L<attributes>). It gets this wrong, though, in that it
1524 does not correctly identify the boundaries of the individual attribute
1525 specifications within C<attrstr>. This is not really intended for the
1526 public API, but has to be listed here for systems such as AIX which
1527 need an explicit export list for symbols. (It's called from XS code
1528 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1529 to respect attribute syntax properly would be welcome.
1535 Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
1536 char *attrstr, STRLEN len)
1541 len = strlen(attrstr);
1545 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1547 char *sstr = attrstr;
1548 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1549 attrs = append_elem(OP_LIST, attrs,
1550 newSVOP(OP_CONST, 0,
1551 newSVpvn(sstr, attrstr-sstr)));
1555 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1556 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1557 Nullsv, prepend_elem(OP_LIST,
1558 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1559 prepend_elem(OP_LIST,
1560 newSVOP(OP_CONST, 0,
1566 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1571 if (!o || PL_error_count)
1575 if (type == OP_LIST) {
1576 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1577 my_kid(kid, attrs, imopsp);
1578 } else if (type == OP_UNDEF) {
1580 } else if (type == OP_RV2SV || /* "our" declaration */
1582 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1583 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1584 yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
1585 OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
1587 GV *gv = cGVOPx_gv(cUNOPo->op_first);
1589 PL_in_my_stash = Nullhv;
1590 apply_attrs(GvSTASH(gv),
1591 (type == OP_RV2SV ? GvSV(gv) :
1592 type == OP_RV2AV ? (SV*)GvAV(gv) :
1593 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1596 o->op_private |= OPpOUR_INTRO;
1599 else if (type != OP_PADSV &&
1602 type != OP_PUSHMARK)
1604 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1606 PL_in_my == KEY_our ? "our" : "my"));
1609 else if (attrs && type != OP_PUSHMARK) {
1613 PL_in_my_stash = Nullhv;
1615 /* check for C<my Dog $spot> when deciding package */
1616 stash = PAD_COMPNAME_TYPE(o->op_targ);
1618 stash = PL_curstash;
1619 apply_attrs_my(stash, o, attrs, imopsp);
1621 o->op_flags |= OPf_MOD;
1622 o->op_private |= OPpLVAL_INTRO;
1627 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1630 int maybe_scalar = 0;
1632 /* [perl #17376]: this appears to be premature, and results in code such as
1633 C< our(%x); > executing in list mode rather than void mode */
1635 if (o->op_flags & OPf_PARENS)
1644 o = my_kid(o, attrs, &rops);
1646 if (maybe_scalar && o->op_type == OP_PADSV) {
1647 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1648 o->op_private |= OPpLVAL_INTRO;
1651 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1654 PL_in_my_stash = Nullhv;
1659 Perl_my(pTHX_ OP *o)
1661 return my_attrs(o, Nullop);
1665 Perl_sawparens(pTHX_ OP *o)
1668 o->op_flags |= OPf_PARENS;
1673 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1677 if (ckWARN(WARN_MISC) &&
1678 (left->op_type == OP_RV2AV ||
1679 left->op_type == OP_RV2HV ||
1680 left->op_type == OP_PADAV ||
1681 left->op_type == OP_PADHV)) {
1682 char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
1683 right->op_type == OP_TRANS)
1684 ? right->op_type : OP_MATCH];
1685 const char *sample = ((left->op_type == OP_RV2AV ||
1686 left->op_type == OP_PADAV)
1687 ? "@array" : "%hash");
1688 Perl_warner(aTHX_ packWARN(WARN_MISC),
1689 "Applying %s to %s will act on scalar(%s)",
1690 desc, sample, sample);
1693 if (right->op_type == OP_CONST &&
1694 cSVOPx(right)->op_private & OPpCONST_BARE &&
1695 cSVOPx(right)->op_private & OPpCONST_STRICT)
1697 no_bareword_allowed(right);
1700 if (!(right->op_flags & OPf_STACKED) &&
1701 (right->op_type == OP_MATCH ||
1702 right->op_type == OP_SUBST ||
1703 right->op_type == OP_TRANS)) {
1704 right->op_flags |= OPf_STACKED;
1705 if (right->op_type != OP_MATCH &&
1706 ! (right->op_type == OP_TRANS &&
1707 right->op_private & OPpTRANS_IDENTICAL))
1708 left = mod(left, right->op_type);
1709 if (right->op_type == OP_TRANS)
1710 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
1712 o = prepend_elem(right->op_type, scalar(left), right);
1714 return newUNOP(OP_NOT, 0, scalar(o));
1718 return bind_match(type, left,
1719 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
1723 Perl_invert(pTHX_ OP *o)
1727 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
1728 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1732 Perl_scope(pTHX_ OP *o)
1735 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1736 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1737 o->op_type = OP_LEAVE;
1738 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1740 else if (o->op_type == OP_LINESEQ) {
1742 o->op_type = OP_SCOPE;
1743 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1744 kid = ((LISTOP*)o)->op_first;
1745 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
1749 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
1755 Perl_save_hints(pTHX)
1758 SAVESPTR(GvHV(PL_hintgv));
1759 GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
1760 SAVEFREESV(GvHV(PL_hintgv));
1764 Perl_block_start(pTHX_ int full)
1766 int retval = PL_savestack_ix;
1767 /* If there were syntax errors, don't try to start a block */
1768 if (PL_yynerrs) return retval;
1770 pad_block_start(full);
1772 PL_hints &= ~HINT_BLOCK_SCOPE;
1773 SAVESPTR(PL_compiling.cop_warnings);
1774 if (! specialWARN(PL_compiling.cop_warnings)) {
1775 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1776 SAVEFREESV(PL_compiling.cop_warnings) ;
1778 SAVESPTR(PL_compiling.cop_io);
1779 if (! specialCopIO(PL_compiling.cop_io)) {
1780 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1781 SAVEFREESV(PL_compiling.cop_io) ;
1787 Perl_block_end(pTHX_ I32 floor, OP *seq)
1789 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1790 OP* retval = scalarseq(seq);
1791 /* If there were syntax errors, don't try to close a block */
1792 if (PL_yynerrs) return retval;
1794 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
1796 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
1804 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1808 Perl_newPROG(pTHX_ OP *o)
1813 PL_eval_root = newUNOP(OP_LEAVEEVAL,
1814 ((PL_in_eval & EVAL_KEEPERR)
1815 ? OPf_SPECIAL : 0), o);
1816 PL_eval_start = linklist(PL_eval_root);
1817 PL_eval_root->op_private |= OPpREFCOUNTED;
1818 OpREFCNT_set(PL_eval_root, 1);
1819 PL_eval_root->op_next = 0;
1820 CALL_PEEP(PL_eval_start);
1823 if (o->op_type == OP_STUB) {
1824 PL_comppad_name = 0;
1828 PL_main_root = scope(sawparens(scalarvoid(o)));
1829 PL_curcop = &PL_compiling;
1830 PL_main_start = LINKLIST(PL_main_root);
1831 PL_main_root->op_private |= OPpREFCOUNTED;
1832 OpREFCNT_set(PL_main_root, 1);
1833 PL_main_root->op_next = 0;
1834 CALL_PEEP(PL_main_start);
1837 /* Register with debugger */
1839 CV *cv = get_cv("DB::postponed", FALSE);
1843 XPUSHs((SV*)CopFILEGV(&PL_compiling));
1845 call_sv((SV*)cv, G_DISCARD);
1852 Perl_localize(pTHX_ OP *o, I32 lex)
1854 if (o->op_flags & OPf_PARENS)
1855 /* [perl #17376]: this appears to be premature, and results in code such as
1856 C< our(%x); > executing in list mode rather than void mode */
1863 if (ckWARN(WARN_PARENTHESIS)
1864 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
1866 char *s = PL_bufptr;
1869 /* some heuristics to detect a potential error */
1870 while (*s && (strchr(", \t\n", *s)
1871 || (strchr("@$%*", *s) && ++sigil) ))
1874 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)
1875 || strchr("@$%*, \t\n", *s)))
1878 if (*s == ';' || *s == '=')
1879 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
1880 "Parentheses missing around \"%s\" list",
1881 lex ? (PL_in_my == KEY_our ? "our" : "my")
1889 o = mod(o, OP_NULL); /* a bit kludgey */
1891 PL_in_my_stash = Nullhv;
1896 Perl_jmaybe(pTHX_ OP *o)
1898 if (o->op_type == OP_LIST) {
1900 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
1901 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
1907 Perl_fold_constants(pTHX_ register OP *o)
1910 I32 type = o->op_type;
1913 if (PL_opargs[type] & OA_RETSCALAR)
1915 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
1916 o->op_targ = pad_alloc(type, SVs_PADTMP);
1918 /* integerize op, unless it happens to be C<-foo>.
1919 * XXX should pp_i_negate() do magic string negation instead? */
1920 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
1921 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
1922 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
1924 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
1927 if (!(PL_opargs[type] & OA_FOLDCONST))
1932 /* XXX might want a ck_negate() for this */
1933 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
1945 /* XXX what about the numeric ops? */
1946 if (PL_hints & HINT_LOCALE)
1951 goto nope; /* Don't try to run w/ errors */
1953 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
1954 if ((curop->op_type != OP_CONST ||
1955 (curop->op_private & OPpCONST_BARE)) &&
1956 curop->op_type != OP_LIST &&
1957 curop->op_type != OP_SCALAR &&
1958 curop->op_type != OP_NULL &&
1959 curop->op_type != OP_PUSHMARK)
1965 curop = LINKLIST(o);
1969 sv = *(PL_stack_sp--);
1970 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
1971 pad_swipe(o->op_targ, FALSE);
1972 else if (SvTEMP(sv)) { /* grab mortal temp? */
1973 (void)SvREFCNT_inc(sv);
1977 if (type == OP_RV2GV)
1978 return newGVOP(OP_GV, 0, (GV*)sv);
1979 return newSVOP(OP_CONST, 0, sv);
1986 Perl_gen_constant_list(pTHX_ register OP *o)
1989 I32 oldtmps_floor = PL_tmps_floor;
1993 return o; /* Don't attempt to run with errors */
1995 PL_op = curop = LINKLIST(o);
2002 PL_tmps_floor = oldtmps_floor;
2004 o->op_type = OP_RV2AV;
2005 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2006 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2007 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2008 o->op_seq = 0; /* needs to be revisited in peep() */
2009 curop = ((UNOP*)o)->op_first;
2010 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2017 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2019 if (!o || o->op_type != OP_LIST)
2020 o = newLISTOP(OP_LIST, 0, o, Nullop);
2022 o->op_flags &= ~OPf_WANT;
2024 if (!(PL_opargs[type] & OA_MARK))
2025 op_null(cLISTOPo->op_first);
2027 o->op_type = (OPCODE)type;
2028 o->op_ppaddr = PL_ppaddr[type];
2029 o->op_flags |= flags;
2031 o = CHECKOP(type, o);
2032 if (o->op_type != type)
2035 return fold_constants(o);
2038 /* List constructors */
2041 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2049 if (first->op_type != type
2050 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2052 return newLISTOP(type, 0, first, last);
2055 if (first->op_flags & OPf_KIDS)
2056 ((LISTOP*)first)->op_last->op_sibling = last;
2058 first->op_flags |= OPf_KIDS;
2059 ((LISTOP*)first)->op_first = last;
2061 ((LISTOP*)first)->op_last = last;
2066 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2074 if (first->op_type != type)
2075 return prepend_elem(type, (OP*)first, (OP*)last);
2077 if (last->op_type != type)
2078 return append_elem(type, (OP*)first, (OP*)last);
2080 first->op_last->op_sibling = last->op_first;
2081 first->op_last = last->op_last;
2082 first->op_flags |= (last->op_flags & OPf_KIDS);
2090 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2098 if (last->op_type == type) {
2099 if (type == OP_LIST) { /* already a PUSHMARK there */
2100 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2101 ((LISTOP*)last)->op_first->op_sibling = first;
2102 if (!(first->op_flags & OPf_PARENS))
2103 last->op_flags &= ~OPf_PARENS;
2106 if (!(last->op_flags & OPf_KIDS)) {
2107 ((LISTOP*)last)->op_last = first;
2108 last->op_flags |= OPf_KIDS;
2110 first->op_sibling = ((LISTOP*)last)->op_first;
2111 ((LISTOP*)last)->op_first = first;
2113 last->op_flags |= OPf_KIDS;
2117 return newLISTOP(type, 0, first, last);
2123 Perl_newNULLLIST(pTHX)
2125 return newOP(OP_STUB, 0);
2129 Perl_force_list(pTHX_ OP *o)
2131 if (!o || o->op_type != OP_LIST)
2132 o = newLISTOP(OP_LIST, 0, o, Nullop);
2138 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2142 NewOp(1101, listop, 1, LISTOP);
2144 listop->op_type = (OPCODE)type;
2145 listop->op_ppaddr = PL_ppaddr[type];
2148 listop->op_flags = (U8)flags;
2152 else if (!first && last)
2155 first->op_sibling = last;
2156 listop->op_first = first;
2157 listop->op_last = last;
2158 if (type == OP_LIST) {
2160 pushop = newOP(OP_PUSHMARK, 0);
2161 pushop->op_sibling = first;
2162 listop->op_first = pushop;
2163 listop->op_flags |= OPf_KIDS;
2165 listop->op_last = pushop;
2168 return CHECKOP(type, listop);
2172 Perl_newOP(pTHX_ I32 type, I32 flags)
2175 NewOp(1101, o, 1, OP);
2176 o->op_type = (OPCODE)type;
2177 o->op_ppaddr = PL_ppaddr[type];
2178 o->op_flags = (U8)flags;
2181 o->op_private = (U8)(0 | (flags >> 8));
2182 if (PL_opargs[type] & OA_RETSCALAR)
2184 if (PL_opargs[type] & OA_TARGET)
2185 o->op_targ = pad_alloc(type, SVs_PADTMP);
2186 return CHECKOP(type, o);
2190 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2195 first = newOP(OP_STUB, 0);
2196 if (PL_opargs[type] & OA_MARK)
2197 first = force_list(first);
2199 NewOp(1101, unop, 1, UNOP);
2200 unop->op_type = (OPCODE)type;
2201 unop->op_ppaddr = PL_ppaddr[type];
2202 unop->op_first = first;
2203 unop->op_flags = flags | OPf_KIDS;
2204 unop->op_private = (U8)(1 | (flags >> 8));
2205 unop = (UNOP*) CHECKOP(type, unop);
2209 return fold_constants((OP *) unop);
2213 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2216 NewOp(1101, binop, 1, BINOP);
2219 first = newOP(OP_NULL, 0);
2221 binop->op_type = (OPCODE)type;
2222 binop->op_ppaddr = PL_ppaddr[type];
2223 binop->op_first = first;
2224 binop->op_flags = flags | OPf_KIDS;
2227 binop->op_private = (U8)(1 | (flags >> 8));
2230 binop->op_private = (U8)(2 | (flags >> 8));
2231 first->op_sibling = last;
2234 binop = (BINOP*)CHECKOP(type, binop);
2235 if (binop->op_next || binop->op_type != (OPCODE)type)
2238 binop->op_last = binop->op_first->op_sibling;
2240 return fold_constants((OP *)binop);
2244 uvcompare(const void *a, const void *b)
2246 if (*((UV *)a) < (*(UV *)b))
2248 if (*((UV *)a) > (*(UV *)b))
2250 if (*((UV *)a+1) < (*(UV *)b+1))
2252 if (*((UV *)a+1) > (*(UV *)b+1))
2258 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2260 SV *tstr = ((SVOP*)expr)->op_sv;
2261 SV *rstr = ((SVOP*)repl)->op_sv;
2264 U8 *t = (U8*)SvPV(tstr, tlen);
2265 U8 *r = (U8*)SvPV(rstr, rlen);
2272 register short *tbl;
2274 PL_hints |= HINT_BLOCK_SCOPE;
2275 complement = o->op_private & OPpTRANS_COMPLEMENT;
2276 del = o->op_private & OPpTRANS_DELETE;
2277 squash = o->op_private & OPpTRANS_SQUASH;
2280 o->op_private |= OPpTRANS_FROM_UTF;
2283 o->op_private |= OPpTRANS_TO_UTF;
2285 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2286 SV* listsv = newSVpvn("# comment\n",10);
2288 U8* tend = t + tlen;
2289 U8* rend = r + rlen;
2303 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2304 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2310 tsave = t = bytes_to_utf8(t, &len);
2313 if (!to_utf && rlen) {
2315 rsave = r = bytes_to_utf8(r, &len);
2319 /* There are several snags with this code on EBCDIC:
2320 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2321 2. scan_const() in toke.c has encoded chars in native encoding which makes
2322 ranges at least in EBCDIC 0..255 range the bottom odd.
2326 U8 tmpbuf[UTF8_MAXLEN+1];
2329 New(1109, cp, 2*tlen, UV);
2331 transv = newSVpvn("",0);
2333 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2335 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2337 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2341 cp[2*i+1] = cp[2*i];
2345 qsort(cp, i, 2*sizeof(UV), uvcompare);
2346 for (j = 0; j < i; j++) {
2348 diff = val - nextmin;
2350 t = uvuni_to_utf8(tmpbuf,nextmin);
2351 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2353 U8 range_mark = UTF_TO_NATIVE(0xff);
2354 t = uvuni_to_utf8(tmpbuf, val - 1);
2355 sv_catpvn(transv, (char *)&range_mark, 1);
2356 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2363 t = uvuni_to_utf8(tmpbuf,nextmin);
2364 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2366 U8 range_mark = UTF_TO_NATIVE(0xff);
2367 sv_catpvn(transv, (char *)&range_mark, 1);
2369 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2370 UNICODE_ALLOW_SUPER);
2371 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2372 t = (U8*)SvPVX(transv);
2373 tlen = SvCUR(transv);
2377 else if (!rlen && !del) {
2378 r = t; rlen = tlen; rend = tend;
2381 if ((!rlen && !del) || t == r ||
2382 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2384 o->op_private |= OPpTRANS_IDENTICAL;
2388 while (t < tend || tfirst <= tlast) {
2389 /* see if we need more "t" chars */
2390 if (tfirst > tlast) {
2391 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2393 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2395 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2402 /* now see if we need more "r" chars */
2403 if (rfirst > rlast) {
2405 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2407 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2409 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2418 rfirst = rlast = 0xffffffff;
2422 /* now see which range will peter our first, if either. */
2423 tdiff = tlast - tfirst;
2424 rdiff = rlast - rfirst;
2431 if (rfirst == 0xffffffff) {
2432 diff = tdiff; /* oops, pretend rdiff is infinite */
2434 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2435 (long)tfirst, (long)tlast);
2437 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2441 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2442 (long)tfirst, (long)(tfirst + diff),
2445 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2446 (long)tfirst, (long)rfirst);
2448 if (rfirst + diff > max)
2449 max = rfirst + diff;
2451 grows = (tfirst < rfirst &&
2452 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2464 else if (max > 0xff)
2469 Safefree(cPVOPo->op_pv);
2470 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2471 SvREFCNT_dec(listsv);
2473 SvREFCNT_dec(transv);
2475 if (!del && havefinal && rlen)
2476 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2477 newSVuv((UV)final), 0);
2480 o->op_private |= OPpTRANS_GROWS;
2492 tbl = (short*)cPVOPo->op_pv;
2494 Zero(tbl, 256, short);
2495 for (i = 0; i < (I32)tlen; i++)
2497 for (i = 0, j = 0; i < 256; i++) {
2499 if (j >= (I32)rlen) {
2508 if (i < 128 && r[j] >= 128)
2518 o->op_private |= OPpTRANS_IDENTICAL;
2520 else if (j >= (I32)rlen)
2523 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2524 tbl[0x100] = rlen - j;
2525 for (i=0; i < (I32)rlen - j; i++)
2526 tbl[0x101+i] = r[j+i];
2530 if (!rlen && !del) {
2533 o->op_private |= OPpTRANS_IDENTICAL;
2535 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2536 o->op_private |= OPpTRANS_IDENTICAL;
2538 for (i = 0; i < 256; i++)
2540 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
2541 if (j >= (I32)rlen) {
2543 if (tbl[t[i]] == -1)
2549 if (tbl[t[i]] == -1) {
2550 if (t[i] < 128 && r[j] >= 128)
2557 o->op_private |= OPpTRANS_GROWS;
2565 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2569 NewOp(1101, pmop, 1, PMOP);
2570 pmop->op_type = (OPCODE)type;
2571 pmop->op_ppaddr = PL_ppaddr[type];
2572 pmop->op_flags = (U8)flags;
2573 pmop->op_private = (U8)(0 | (flags >> 8));
2575 if (PL_hints & HINT_RE_TAINT)
2576 pmop->op_pmpermflags |= PMf_RETAINT;
2577 if (PL_hints & HINT_LOCALE)
2578 pmop->op_pmpermflags |= PMf_LOCALE;
2579 pmop->op_pmflags = pmop->op_pmpermflags;
2584 if(av_len((AV*) PL_regex_pad[0]) > -1) {
2585 repointer = av_pop((AV*)PL_regex_pad[0]);
2586 pmop->op_pmoffset = SvIV(repointer);
2587 SvREPADTMP_off(repointer);
2588 sv_setiv(repointer,0);
2590 repointer = newSViv(0);
2591 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2592 pmop->op_pmoffset = av_len(PL_regex_padav);
2593 PL_regex_pad = AvARRAY(PL_regex_padav);
2598 /* link into pm list */
2599 if (type != OP_TRANS && PL_curstash) {
2600 pmop->op_pmnext = HvPMROOT(PL_curstash);
2601 HvPMROOT(PL_curstash) = pmop;
2602 PmopSTASH_set(pmop,PL_curstash);
2605 return CHECKOP(type, pmop);
2609 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
2613 I32 repl_has_vars = 0;
2615 if (o->op_type == OP_TRANS)
2616 return pmtrans(o, expr, repl);
2618 PL_hints |= HINT_BLOCK_SCOPE;
2621 if (expr->op_type == OP_CONST) {
2623 SV *pat = ((SVOP*)expr)->op_sv;
2624 char *p = SvPV(pat, plen);
2625 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
2626 sv_setpvn(pat, "\\s+", 3);
2627 p = SvPV(pat, plen);
2628 pm->op_pmflags |= PMf_SKIPWHITE;
2631 pm->op_pmdynflags |= PMdf_UTF8;
2632 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
2633 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
2634 pm->op_pmflags |= PMf_WHITE;
2638 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2639 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2641 : OP_REGCMAYBE),0,expr);
2643 NewOp(1101, rcop, 1, LOGOP);
2644 rcop->op_type = OP_REGCOMP;
2645 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2646 rcop->op_first = scalar(expr);
2647 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
2648 ? (OPf_SPECIAL | OPf_KIDS)
2650 rcop->op_private = 1;
2652 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
2655 /* establish postfix order */
2656 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2658 rcop->op_next = expr;
2659 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2662 rcop->op_next = LINKLIST(expr);
2663 expr->op_next = (OP*)rcop;
2666 prepend_elem(o->op_type, scalar((OP*)rcop), o);
2671 if (pm->op_pmflags & PMf_EVAL) {
2673 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
2674 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
2676 else if (repl->op_type == OP_CONST)
2680 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
2681 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
2682 if (curop->op_type == OP_GV) {
2683 GV *gv = cGVOPx_gv(curop);
2685 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
2688 else if (curop->op_type == OP_RV2CV)
2690 else if (curop->op_type == OP_RV2SV ||
2691 curop->op_type == OP_RV2AV ||
2692 curop->op_type == OP_RV2HV ||
2693 curop->op_type == OP_RV2GV) {
2694 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2697 else if (curop->op_type == OP_PADSV ||
2698 curop->op_type == OP_PADAV ||
2699 curop->op_type == OP_PADHV ||
2700 curop->op_type == OP_PADANY) {
2703 else if (curop->op_type == OP_PUSHRE)
2704 ; /* Okay here, dangerous in newASSIGNOP */
2714 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
2715 pm->op_pmflags |= PMf_CONST; /* const for long enough */
2716 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
2717 prepend_elem(o->op_type, scalar(repl), o);
2720 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
2721 pm->op_pmflags |= PMf_MAYBE_CONST;
2722 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2724 NewOp(1101, rcop, 1, LOGOP);
2725 rcop->op_type = OP_SUBSTCONT;
2726 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
2727 rcop->op_first = scalar(repl);
2728 rcop->op_flags |= OPf_KIDS;
2729 rcop->op_private = 1;
2732 /* establish postfix order */
2733 rcop->op_next = LINKLIST(repl);
2734 repl->op_next = (OP*)rcop;
2736 pm->op_pmreplroot = scalar((OP*)rcop);
2737 pm->op_pmreplstart = LINKLIST(rcop);
2746 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
2749 NewOp(1101, svop, 1, SVOP);
2750 svop->op_type = (OPCODE)type;
2751 svop->op_ppaddr = PL_ppaddr[type];
2753 svop->op_next = (OP*)svop;
2754 svop->op_flags = (U8)flags;
2755 if (PL_opargs[type] & OA_RETSCALAR)
2757 if (PL_opargs[type] & OA_TARGET)
2758 svop->op_targ = pad_alloc(type, SVs_PADTMP);
2759 return CHECKOP(type, svop);
2763 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2766 NewOp(1101, padop, 1, PADOP);
2767 padop->op_type = (OPCODE)type;
2768 padop->op_ppaddr = PL_ppaddr[type];
2769 padop->op_padix = pad_alloc(type, SVs_PADTMP);
2770 SvREFCNT_dec(PAD_SVl(padop->op_padix));
2771 PAD_SETSV(padop->op_padix, sv);
2774 padop->op_next = (OP*)padop;
2775 padop->op_flags = (U8)flags;
2776 if (PL_opargs[type] & OA_RETSCALAR)
2778 if (PL_opargs[type] & OA_TARGET)
2779 padop->op_targ = pad_alloc(type, SVs_PADTMP);
2780 return CHECKOP(type, padop);
2784 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
2789 return newPADOP(type, flags, SvREFCNT_inc(gv));
2791 return newSVOP(type, flags, SvREFCNT_inc(gv));
2796 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
2799 NewOp(1101, pvop, 1, PVOP);
2800 pvop->op_type = (OPCODE)type;
2801 pvop->op_ppaddr = PL_ppaddr[type];
2803 pvop->op_next = (OP*)pvop;
2804 pvop->op_flags = (U8)flags;
2805 if (PL_opargs[type] & OA_RETSCALAR)
2807 if (PL_opargs[type] & OA_TARGET)
2808 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
2809 return CHECKOP(type, pvop);
2813 Perl_package(pTHX_ OP *o)
2818 save_hptr(&PL_curstash);
2819 save_item(PL_curstname);
2821 name = SvPV(cSVOPo->op_sv, len);
2822 PL_curstash = gv_stashpvn(name, len, TRUE);
2823 sv_setpvn(PL_curstname, name, len);
2826 PL_hints |= HINT_BLOCK_SCOPE;
2827 PL_copline = NOLINE;
2832 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
2838 if (idop->op_type != OP_CONST)
2839 Perl_croak(aTHX_ "Module name must be constant");
2843 if (version != Nullop) {
2844 SV *vesv = ((SVOP*)version)->op_sv;
2846 if (arg == Nullop && !SvNIOKp(vesv)) {
2853 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
2854 Perl_croak(aTHX_ "Version number must be constant number");
2856 /* Make copy of idop so we don't free it twice */
2857 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
2859 /* Fake up a method call to VERSION */
2860 meth = newSVpvn("VERSION",7);
2861 sv_upgrade(meth, SVt_PVIV);
2862 (void)SvIOK_on(meth);
2863 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
2864 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2865 append_elem(OP_LIST,
2866 prepend_elem(OP_LIST, pack, list(version)),
2867 newSVOP(OP_METHOD_NAMED, 0, meth)));
2871 /* Fake up an import/unimport */
2872 if (arg && arg->op_type == OP_STUB)
2873 imop = arg; /* no import on explicit () */
2874 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
2875 imop = Nullop; /* use 5.0; */
2880 /* Make copy of idop so we don't free it twice */
2881 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
2883 /* Fake up a method call to import/unimport */
2884 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);
2885 (void)SvUPGRADE(meth, SVt_PVIV);
2886 (void)SvIOK_on(meth);
2887 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
2888 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2889 append_elem(OP_LIST,
2890 prepend_elem(OP_LIST, pack, list(arg)),
2891 newSVOP(OP_METHOD_NAMED, 0, meth)));
2894 /* Fake up the BEGIN {}, which does its thing immediately. */
2896 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
2899 append_elem(OP_LINESEQ,
2900 append_elem(OP_LINESEQ,
2901 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, idop)),
2902 newSTATEOP(0, Nullch, veop)),
2903 newSTATEOP(0, Nullch, imop) ));
2905 /* The "did you use incorrect case?" warning used to be here.
2906 * The problem is that on case-insensitive filesystems one
2907 * might get false positives for "use" (and "require"):
2908 * "use Strict" or "require CARP" will work. This causes
2909 * portability problems for the script: in case-strict
2910 * filesystems the script will stop working.
2912 * The "incorrect case" warning checked whether "use Foo"
2913 * imported "Foo" to your namespace, but that is wrong, too:
2914 * there is no requirement nor promise in the language that
2915 * a Foo.pm should or would contain anything in package "Foo".
2917 * There is very little Configure-wise that can be done, either:
2918 * the case-sensitivity of the build filesystem of Perl does not
2919 * help in guessing the case-sensitivity of the runtime environment.
2922 PL_hints |= HINT_BLOCK_SCOPE;
2923 PL_copline = NOLINE;
2925 PL_cop_seqmax++; /* Purely for B::*'s benefit */
2929 =head1 Embedding Functions
2931 =for apidoc load_module
2933 Loads the module whose name is pointed to by the string part of name.
2934 Note that the actual module name, not its filename, should be given.
2935 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
2936 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
2937 (or 0 for no flags). ver, if specified, provides version semantics
2938 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
2939 arguments can be used to specify arguments to the module's import()
2940 method, similar to C<use Foo::Bar VERSION LIST>.
2945 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
2948 va_start(args, ver);
2949 vload_module(flags, name, ver, &args);
2953 #ifdef PERL_IMPLICIT_CONTEXT
2955 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
2959 va_start(args, ver);
2960 vload_module(flags, name, ver, &args);
2966 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
2968 OP *modname, *veop, *imop;
2970 modname = newSVOP(OP_CONST, 0, name);
2971 modname->op_private |= OPpCONST_BARE;
2973 veop = newSVOP(OP_CONST, 0, ver);
2977 if (flags & PERL_LOADMOD_NOIMPORT) {
2978 imop = sawparens(newNULLLIST());
2980 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
2981 imop = va_arg(*args, OP*);
2986 sv = va_arg(*args, SV*);
2988 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
2989 sv = va_arg(*args, SV*);
2993 line_t ocopline = PL_copline;
2994 COP *ocurcop = PL_curcop;
2995 int oexpect = PL_expect;
2997 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
2998 veop, modname, imop);
2999 PL_expect = oexpect;
3000 PL_copline = ocopline;
3001 PL_curcop = ocurcop;
3006 Perl_dofile(pTHX_ OP *term)
3011 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3012 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
3013 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3015 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3016 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3017 append_elem(OP_LIST, term,
3018 scalar(newUNOP(OP_RV2CV, 0,
3023 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3029 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3031 return newBINOP(OP_LSLICE, flags,
3032 list(force_list(subscript)),
3033 list(force_list(listval)) );
3037 S_list_assignment(pTHX_ register OP *o)
3042 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3043 o = cUNOPo->op_first;
3045 if (o->op_type == OP_COND_EXPR) {
3046 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3047 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3052 yyerror("Assignment to both a list and a scalar");
3056 if (o->op_type == OP_LIST &&
3057 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3058 o->op_private & OPpLVAL_INTRO)
3061 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3062 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3063 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3066 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3069 if (o->op_type == OP_RV2SV)
3076 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3081 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3082 return newLOGOP(optype, 0,
3083 mod(scalar(left), optype),
3084 newUNOP(OP_SASSIGN, 0, scalar(right)));
3087 return newBINOP(optype, OPf_STACKED,
3088 mod(scalar(left), optype), scalar(right));
3092 if (list_assignment(left)) {
3096 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3097 left = mod(left, OP_AASSIGN);
3105 curop = list(force_list(left));
3106 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3107 o->op_private = (U8)(0 | (flags >> 8));
3109 /* PL_generation sorcery:
3110 * an assignment like ($a,$b) = ($c,$d) is easier than
3111 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3112 * To detect whether there are common vars, the global var
3113 * PL_generation is incremented for each assign op we compile.
3114 * Then, while compiling the assign op, we run through all the
3115 * variables on both sides of the assignment, setting a spare slot
3116 * in each of them to PL_generation. If any of them already have
3117 * that value, we know we've got commonality. We could use a
3118 * single bit marker, but then we'd have to make 2 passes, first
3119 * to clear the flag, then to test and set it. To find somewhere
3120 * to store these values, evil chicanery is done with SvCUR().
3123 if (!(left->op_private & OPpLVAL_INTRO)) {
3126 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3127 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3128 if (curop->op_type == OP_GV) {
3129 GV *gv = cGVOPx_gv(curop);
3130 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3132 SvCUR(gv) = PL_generation;
3134 else if (curop->op_type == OP_PADSV ||
3135 curop->op_type == OP_PADAV ||
3136 curop->op_type == OP_PADHV ||
3137 curop->op_type == OP_PADANY)
3139 if (PAD_COMPNAME_GEN(curop->op_targ)
3140 == (STRLEN)PL_generation)
3142 PAD_COMPNAME_GEN(curop->op_targ)
3146 else if (curop->op_type == OP_RV2CV)
3148 else if (curop->op_type == OP_RV2SV ||
3149 curop->op_type == OP_RV2AV ||
3150 curop->op_type == OP_RV2HV ||
3151 curop->op_type == OP_RV2GV) {
3152 if (lastop->op_type != OP_GV) /* funny deref? */
3155 else if (curop->op_type == OP_PUSHRE) {
3156 if (((PMOP*)curop)->op_pmreplroot) {
3158 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3159 ((PMOP*)curop)->op_pmreplroot));
3161 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3163 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3165 SvCUR(gv) = PL_generation;
3174 o->op_private |= OPpASSIGN_COMMON;
3176 if (right && right->op_type == OP_SPLIT) {
3178 if ((tmpop = ((LISTOP*)right)->op_first) &&
3179 tmpop->op_type == OP_PUSHRE)
3181 PMOP *pm = (PMOP*)tmpop;
3182 if (left->op_type == OP_RV2AV &&
3183 !(left->op_private & OPpLVAL_INTRO) &&
3184 !(o->op_private & OPpASSIGN_COMMON) )
3186 tmpop = ((UNOP*)left)->op_first;
3187 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3189 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3190 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3192 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3193 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3195 pm->op_pmflags |= PMf_ONCE;
3196 tmpop = cUNOPo->op_first; /* to list (nulled) */
3197 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3198 tmpop->op_sibling = Nullop; /* don't free split */
3199 right->op_next = tmpop->op_next; /* fix starting loc */
3200 op_free(o); /* blow off assign */
3201 right->op_flags &= ~OPf_WANT;
3202 /* "I don't know and I don't care." */
3207 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3208 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3210 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3212 sv_setiv(sv, PL_modcount+1);
3220 right = newOP(OP_UNDEF, 0);
3221 if (right->op_type == OP_READLINE) {
3222 right->op_flags |= OPf_STACKED;
3223 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3226 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3227 o = newBINOP(OP_SASSIGN, flags,
3228 scalar(right), mod(scalar(left), OP_SASSIGN) );
3240 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3242 U32 seq = intro_my();
3245 NewOp(1101, cop, 1, COP);
3246 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3247 cop->op_type = OP_DBSTATE;
3248 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3251 cop->op_type = OP_NEXTSTATE;
3252 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3254 cop->op_flags = (U8)flags;
3255 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3257 cop->op_private |= NATIVE_HINTS;
3259 PL_compiling.op_private = cop->op_private;
3260 cop->op_next = (OP*)cop;
3263 cop->cop_label = label;
3264 PL_hints |= HINT_BLOCK_SCOPE;
3267 cop->cop_arybase = PL_curcop->cop_arybase;
3268 if (specialWARN(PL_curcop->cop_warnings))
3269 cop->cop_warnings = PL_curcop->cop_warnings ;
3271 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3272 if (specialCopIO(PL_curcop->cop_io))
3273 cop->cop_io = PL_curcop->cop_io;
3275 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3278 if (PL_copline == NOLINE)
3279 CopLINE_set(cop, CopLINE(PL_curcop));
3281 CopLINE_set(cop, PL_copline);
3282 PL_copline = NOLINE;
3285 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3287 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3289 CopSTASH_set(cop, PL_curstash);
3291 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3292 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3293 if (svp && *svp != &PL_sv_undef ) {
3294 (void)SvIOK_on(*svp);
3295 SvIVX(*svp) = PTR2IV(cop);
3299 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3304 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3306 return new_logop(type, flags, &first, &other);
3310 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3314 OP *first = *firstp;
3315 OP *other = *otherp;
3317 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3318 return newBINOP(type, flags, scalar(first), scalar(other));
3320 scalarboolean(first);
3321 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3322 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3323 if (type == OP_AND || type == OP_OR) {
3329 first = *firstp = cUNOPo->op_first;
3331 first->op_next = o->op_next;
3332 cUNOPo->op_first = Nullop;
3336 if (first->op_type == OP_CONST) {
3337 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE)) {
3338 if (first->op_private & OPpCONST_STRICT)
3339 no_bareword_allowed(first);
3341 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3343 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3354 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS) &&
3355 type != OP_DOR) /* [#24076] Don't warn for <FH> err FOO. */
3357 OP *k1 = ((UNOP*)first)->op_first;
3358 OP *k2 = k1->op_sibling;
3360 switch (first->op_type)
3363 if (k2 && k2->op_type == OP_READLINE
3364 && (k2->op_flags & OPf_STACKED)
3365 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3367 warnop = k2->op_type;
3372 if (k1->op_type == OP_READDIR
3373 || k1->op_type == OP_GLOB
3374 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3375 || k1->op_type == OP_EACH)
3377 warnop = ((k1->op_type == OP_NULL)
3378 ? (OPCODE)k1->op_targ : k1->op_type);
3383 line_t oldline = CopLINE(PL_curcop);
3384 CopLINE_set(PL_curcop, PL_copline);
3385 Perl_warner(aTHX_ packWARN(WARN_MISC),
3386 "Value of %s%s can be \"0\"; test with defined()",
3388 ((warnop == OP_READLINE || warnop == OP_GLOB)
3389 ? " construct" : "() operator"));
3390 CopLINE_set(PL_curcop, oldline);
3397 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3398 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3400 NewOp(1101, logop, 1, LOGOP);
3402 logop->op_type = (OPCODE)type;
3403 logop->op_ppaddr = PL_ppaddr[type];
3404 logop->op_first = first;
3405 logop->op_flags = flags | OPf_KIDS;
3406 logop->op_other = LINKLIST(other);
3407 logop->op_private = (U8)(1 | (flags >> 8));
3409 /* establish postfix order */
3410 logop->op_next = LINKLIST(first);
3411 first->op_next = (OP*)logop;
3412 first->op_sibling = other;
3414 CHECKOP(type,logop);
3416 o = newUNOP(OP_NULL, 0, (OP*)logop);
3423 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3430 return newLOGOP(OP_AND, 0, first, trueop);
3432 return newLOGOP(OP_OR, 0, first, falseop);
3434 scalarboolean(first);
3435 if (first->op_type == OP_CONST) {
3436 if (first->op_private & OPpCONST_BARE &&
3437 first->op_private & OPpCONST_STRICT) {
3438 no_bareword_allowed(first);
3440 if (SvTRUE(((SVOP*)first)->op_sv)) {
3451 NewOp(1101, logop, 1, LOGOP);
3452 logop->op_type = OP_COND_EXPR;
3453 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3454 logop->op_first = first;
3455 logop->op_flags = flags | OPf_KIDS;
3456 logop->op_private = (U8)(1 | (flags >> 8));
3457 logop->op_other = LINKLIST(trueop);
3458 logop->op_next = LINKLIST(falseop);
3460 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
3463 /* establish postfix order */
3464 start = LINKLIST(first);
3465 first->op_next = (OP*)logop;
3467 first->op_sibling = trueop;
3468 trueop->op_sibling = falseop;
3469 o = newUNOP(OP_NULL, 0, (OP*)logop);
3471 trueop->op_next = falseop->op_next = o;
3478 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3486 NewOp(1101, range, 1, LOGOP);
3488 range->op_type = OP_RANGE;
3489 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3490 range->op_first = left;
3491 range->op_flags = OPf_KIDS;
3492 leftstart = LINKLIST(left);
3493 range->op_other = LINKLIST(right);
3494 range->op_private = (U8)(1 | (flags >> 8));
3496 left->op_sibling = right;
3498 range->op_next = (OP*)range;
3499 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3500 flop = newUNOP(OP_FLOP, 0, flip);
3501 o = newUNOP(OP_NULL, 0, flop);
3503 range->op_next = leftstart;
3505 left->op_next = flip;
3506 right->op_next = flop;
3508 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3509 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3510 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3511 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3513 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3514 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3517 if (!flip->op_private || !flop->op_private)
3518 linklist(o); /* blow off optimizer unless constant */
3524 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3528 int once = block && block->op_flags & OPf_SPECIAL &&
3529 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3532 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3533 return block; /* do {} while 0 does once */
3534 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3535 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3536 expr = newUNOP(OP_DEFINED, 0,
3537 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3538 } else if (expr->op_flags & OPf_KIDS) {
3539 OP *k1 = ((UNOP*)expr)->op_first;
3540 OP *k2 = (k1) ? k1->op_sibling : NULL;
3541 switch (expr->op_type) {
3543 if (k2 && k2->op_type == OP_READLINE
3544 && (k2->op_flags & OPf_STACKED)
3545 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3546 expr = newUNOP(OP_DEFINED, 0, expr);
3550 if (k1->op_type == OP_READDIR
3551 || k1->op_type == OP_GLOB
3552 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3553 || k1->op_type == OP_EACH)
3554 expr = newUNOP(OP_DEFINED, 0, expr);
3560 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3561 o = new_logop(OP_AND, 0, &expr, &listop);
3564 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3566 if (once && o != listop)
3567 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3570 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3572 o->op_flags |= flags;
3574 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3579 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3587 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3588 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3589 expr = newUNOP(OP_DEFINED, 0,
3590 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3591 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3592 OP *k1 = ((UNOP*)expr)->op_first;
3593 OP *k2 = (k1) ? k1->op_sibling : NULL;
3594 switch (expr->op_type) {
3596 if (k2 && k2->op_type == OP_READLINE
3597 && (k2->op_flags & OPf_STACKED)
3598 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3599 expr = newUNOP(OP_DEFINED, 0, expr);
3603 if (k1->op_type == OP_READDIR
3604 || k1->op_type == OP_GLOB
3605 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3606 || k1->op_type == OP_EACH)
3607 expr = newUNOP(OP_DEFINED, 0, expr);
3613 block = newOP(OP_NULL, 0);
3615 block = scope(block);
3619 next = LINKLIST(cont);
3622 OP *unstack = newOP(OP_UNSTACK, 0);
3625 cont = append_elem(OP_LINESEQ, cont, unstack);
3628 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3629 redo = LINKLIST(listop);
3632 PL_copline = (line_t)whileline;
3634 o = new_logop(OP_AND, 0, &expr, &listop);
3635 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3636 op_free(expr); /* oops, it's a while (0) */
3638 return Nullop; /* listop already freed by new_logop */
3641 ((LISTOP*)listop)->op_last->op_next =
3642 (o == listop ? redo : LINKLIST(o));
3648 NewOp(1101,loop,1,LOOP);
3649 loop->op_type = OP_ENTERLOOP;
3650 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3651 loop->op_private = 0;
3652 loop->op_next = (OP*)loop;
3655 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3657 loop->op_redoop = redo;
3658 loop->op_lastop = o;
3659 o->op_private |= loopflags;
3662 loop->op_nextop = next;
3664 loop->op_nextop = o;
3666 o->op_flags |= flags;
3667 o->op_private |= (flags >> 8);
3672 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
3676 PADOFFSET padoff = 0;
3681 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
3682 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
3683 sv->op_type = OP_RV2GV;
3684 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3686 else if (sv->op_type == OP_PADSV) { /* private variable */
3687 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
3688 padoff = sv->op_targ;
3693 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3694 padoff = sv->op_targ;
3696 iterflags |= OPf_SPECIAL;
3701 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3704 sv = newGVOP(OP_GV, 0, PL_defgv);
3706 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3707 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3708 iterflags |= OPf_STACKED;
3710 else if (expr->op_type == OP_NULL &&
3711 (expr->op_flags & OPf_KIDS) &&
3712 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3714 /* Basically turn for($x..$y) into the same as for($x,$y), but we
3715 * set the STACKED flag to indicate that these values are to be
3716 * treated as min/max values by 'pp_iterinit'.
3718 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
3719 LOGOP* range = (LOGOP*) flip->op_first;
3720 OP* left = range->op_first;
3721 OP* right = left->op_sibling;
3724 range->op_flags &= ~OPf_KIDS;
3725 range->op_first = Nullop;
3727 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
3728 listop->op_first->op_next = range->op_next;
3729 left->op_next = range->op_other;
3730 right->op_next = (OP*)listop;
3731 listop->op_next = listop->op_first;
3734 expr = (OP*)(listop);
3736 iterflags |= OPf_STACKED;
3739 expr = mod(force_list(expr), OP_GREPSTART);
3743 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
3744 append_elem(OP_LIST, expr, scalar(sv))));
3745 assert(!loop->op_next);
3746 /* for my $x () sets OPpLVAL_INTRO;
3747 * for our $x () sets OPpOUR_INTRO */
3748 loop->op_private = (U8)iterpflags;
3749 #ifdef PL_OP_SLAB_ALLOC
3752 NewOp(1234,tmp,1,LOOP);
3753 Copy(loop,tmp,1,LOOP);
3758 Renew(loop, 1, LOOP);
3760 loop->op_targ = padoff;
3761 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
3762 PL_copline = forline;
3763 return newSTATEOP(0, label, wop);
3767 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
3772 if (type != OP_GOTO || label->op_type == OP_CONST) {
3773 /* "last()" means "last" */
3774 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
3775 o = newOP(type, OPf_SPECIAL);
3777 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
3778 ? SvPVx(((SVOP*)label)->op_sv, n_a)
3784 if (label->op_type == OP_ENTERSUB)
3785 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
3786 o = newUNOP(type, OPf_STACKED, label);
3788 PL_hints |= HINT_BLOCK_SCOPE;
3793 =for apidoc cv_undef
3795 Clear out all the active components of a CV. This can happen either
3796 by an explicit C<undef &foo>, or by the reference count going to zero.
3797 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
3798 children can still follow the full lexical scope chain.
3804 Perl_cv_undef(pTHX_ CV *cv)
3807 if (CvFILE(cv) && !CvXSUB(cv)) {
3808 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
3809 Safefree(CvFILE(cv));
3814 if (!CvXSUB(cv) && CvROOT(cv)) {
3816 Perl_croak(aTHX_ "Can't undef active subroutine");
3819 PAD_SAVE_SETNULLPAD();
3821 op_free(CvROOT(cv));
3822 CvROOT(cv) = Nullop;
3825 SvPOK_off((SV*)cv); /* forget prototype */
3830 /* remove CvOUTSIDE unless this is an undef rather than a free */
3831 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
3832 if (!CvWEAKOUTSIDE(cv))
3833 SvREFCNT_dec(CvOUTSIDE(cv));
3834 CvOUTSIDE(cv) = Nullcv;
3837 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
3843 /* delete all flags except WEAKOUTSIDE */
3844 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
3848 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
3850 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
3851 SV* msg = sv_newmortal();
3855 gv_efullname3(name = sv_newmortal(), gv, Nullch);
3856 sv_setpv(msg, "Prototype mismatch:");
3858 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
3860 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (SV *)cv);
3861 sv_catpv(msg, " vs ");
3863 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
3865 sv_catpv(msg, "none");
3866 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
3870 static void const_sv_xsub(pTHX_ CV* cv);
3874 =head1 Optree Manipulation Functions
3876 =for apidoc cv_const_sv
3878 If C<cv> is a constant sub eligible for inlining. returns the constant
3879 value returned by the sub. Otherwise, returns NULL.
3881 Constant subs can be created with C<newCONSTSUB> or as described in
3882 L<perlsub/"Constant Functions">.
3887 Perl_cv_const_sv(pTHX_ CV *cv)
3889 if (!cv || !CvCONST(cv))
3891 return (SV*)CvXSUBANY(cv).any_ptr;
3894 /* op_const_sv: examine an optree to determine whether it's in-lineable.
3895 * Can be called in 3 ways:
3898 * look for a single OP_CONST with attached value: return the value
3900 * cv && CvCLONE(cv) && !CvCONST(cv)
3902 * examine the clone prototype, and if contains only a single
3903 * OP_CONST referencing a pad const, or a single PADSV referencing
3904 * an outer lexical, return a non-zero value to indicate the CV is
3905 * a candidate for "constizing" at clone time
3909 * We have just cloned an anon prototype that was marked as a const
3910 * candidiate. Try to grab the current value, and in the case of
3911 * PADSV, ignore it if it has multiple references. Return the value.
3915 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
3922 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
3923 o = cLISTOPo->op_first->op_sibling;
3925 for (; o; o = o->op_next) {
3926 OPCODE type = o->op_type;
3928 if (sv && o->op_next == o)
3930 if (o->op_next != o) {
3931 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
3933 if (type == OP_DBSTATE)
3936 if (type == OP_LEAVESUB || type == OP_RETURN)
3940 if (type == OP_CONST && cSVOPo->op_sv)
3942 else if (cv && type == OP_CONST) {
3943 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
3947 else if (cv && type == OP_PADSV) {
3948 if (CvCONST(cv)) { /* newly cloned anon */
3949 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
3950 /* the candidate should have 1 ref from this pad and 1 ref
3951 * from the parent */
3952 if (!sv || SvREFCNT(sv) != 2)
3959 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
3960 sv = &PL_sv_undef; /* an arbitrary non-null value */
3971 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
3981 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
3985 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
3987 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
3991 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
3997 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4001 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4002 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4003 SV *sv = sv_newmortal();
4004 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4005 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4006 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4011 gv = gv_fetchpv(name ? name : (aname ? aname :
4012 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__")),
4013 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4023 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4024 maximum a prototype before. */
4025 if (SvTYPE(gv) > SVt_NULL) {
4026 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4027 && ckWARN_d(WARN_PROTOTYPE))
4029 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4031 cv_ckproto((CV*)gv, NULL, ps);
4034 sv_setpv((SV*)gv, ps);
4036 sv_setiv((SV*)gv, -1);
4037 SvREFCNT_dec(PL_compcv);
4038 cv = PL_compcv = NULL;
4039 PL_sub_generation++;
4043 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4045 #ifdef GV_UNIQUE_CHECK
4046 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4047 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4051 if (!block || !ps || *ps || attrs)
4054 const_sv = op_const_sv(block, Nullcv);
4057 bool exists = CvROOT(cv) || CvXSUB(cv);
4059 #ifdef GV_UNIQUE_CHECK
4060 if (exists && GvUNIQUE(gv)) {
4061 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4065 /* if the subroutine doesn't exist and wasn't pre-declared
4066 * with a prototype, assume it will be AUTOLOADed,
4067 * skipping the prototype check
4069 if (exists || SvPOK(cv))
4070 cv_ckproto(cv, gv, ps);
4071 /* already defined (or promised)? */
4072 if (exists || GvASSUMECV(gv)) {
4073 if (!block && !attrs) {
4074 if (CvFLAGS(PL_compcv)) {
4075 /* might have had built-in attrs applied */
4076 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4078 /* just a "sub foo;" when &foo is already defined */
4079 SAVEFREESV(PL_compcv);
4082 /* ahem, death to those who redefine active sort subs */
4083 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4084 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4086 if (ckWARN(WARN_REDEFINE)
4088 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4090 line_t oldline = CopLINE(PL_curcop);
4091 if (PL_copline != NOLINE)
4092 CopLINE_set(PL_curcop, PL_copline);
4093 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4094 CvCONST(cv) ? "Constant subroutine %s redefined"
4095 : "Subroutine %s redefined", name);
4096 CopLINE_set(PL_curcop, oldline);
4104 SvREFCNT_inc(const_sv);
4106 assert(!CvROOT(cv) && !CvCONST(cv));
4107 sv_setpv((SV*)cv, ""); /* prototype is "" */
4108 CvXSUBANY(cv).any_ptr = const_sv;
4109 CvXSUB(cv) = const_sv_xsub;
4114 cv = newCONSTSUB(NULL, name, const_sv);
4117 SvREFCNT_dec(PL_compcv);
4119 PL_sub_generation++;
4126 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4127 * before we clobber PL_compcv.
4131 /* Might have had built-in attributes applied -- propagate them. */
4132 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4133 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4134 stash = GvSTASH(CvGV(cv));
4135 else if (CvSTASH(cv))
4136 stash = CvSTASH(cv);
4138 stash = PL_curstash;
4141 /* possibly about to re-define existing subr -- ignore old cv */
4142 rcv = (SV*)PL_compcv;
4143 if (name && GvSTASH(gv))
4144 stash = GvSTASH(gv);
4146 stash = PL_curstash;
4148 apply_attrs(stash, rcv, attrs, FALSE);
4150 if (cv) { /* must reuse cv if autoloaded */
4152 /* got here with just attrs -- work done, so bug out */
4153 SAVEFREESV(PL_compcv);
4156 /* transfer PL_compcv to cv */
4158 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4159 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4160 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4161 CvOUTSIDE(PL_compcv) = 0;
4162 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4163 CvPADLIST(PL_compcv) = 0;
4164 /* inner references to PL_compcv must be fixed up ... */
4165 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4166 /* ... before we throw it away */
4167 SvREFCNT_dec(PL_compcv);
4169 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4170 ++PL_sub_generation;
4177 PL_sub_generation++;
4181 CvFILE_set_from_cop(cv, PL_curcop);
4182 CvSTASH(cv) = PL_curstash;
4185 sv_setpv((SV*)cv, ps);
4187 if (PL_error_count) {
4191 char *s = strrchr(name, ':');
4193 if (strEQ(s, "BEGIN")) {
4195 "BEGIN not safe after errors--compilation aborted";
4196 if (PL_in_eval & EVAL_KEEPERR)
4197 Perl_croak(aTHX_ not_safe);
4199 /* force display of errors found but not reported */
4200 sv_catpv(ERRSV, not_safe);
4201 Perl_croak(aTHX_ "%"SVf, ERRSV);
4210 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4211 mod(scalarseq(block), OP_LEAVESUBLV));
4214 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4216 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4217 OpREFCNT_set(CvROOT(cv), 1);
4218 CvSTART(cv) = LINKLIST(CvROOT(cv));
4219 CvROOT(cv)->op_next = 0;
4220 CALL_PEEP(CvSTART(cv));
4222 /* now that optimizer has done its work, adjust pad values */
4224 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4227 assert(!CvCONST(cv));
4228 if (ps && !*ps && op_const_sv(block, cv))
4232 if (name || aname) {
4234 char *tname = (name ? name : aname);
4236 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4237 SV *sv = NEWSV(0,0);
4238 SV *tmpstr = sv_newmortal();
4239 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4243 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4245 (long)PL_subline, (long)CopLINE(PL_curcop));
4246 gv_efullname3(tmpstr, gv, Nullch);
4247 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4248 hv = GvHVn(db_postponed);
4249 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4250 && (pcv = GvCV(db_postponed)))
4256 call_sv((SV*)pcv, G_DISCARD);
4260 if ((s = strrchr(tname,':')))
4265 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4268 if (strEQ(s, "BEGIN") && !PL_error_count) {
4269 I32 oldscope = PL_scopestack_ix;
4271 SAVECOPFILE(&PL_compiling);
4272 SAVECOPLINE(&PL_compiling);
4275 PL_beginav = newAV();
4276 DEBUG_x( dump_sub(gv) );
4277 av_push(PL_beginav, (SV*)cv);
4278 GvCV(gv) = 0; /* cv has been hijacked */
4279 call_list(oldscope, PL_beginav);
4281 PL_curcop = &PL_compiling;
4282 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4285 else if (strEQ(s, "END") && !PL_error_count) {
4288 DEBUG_x( dump_sub(gv) );
4289 av_unshift(PL_endav, 1);
4290 av_store(PL_endav, 0, (SV*)cv);
4291 GvCV(gv) = 0; /* cv has been hijacked */
4293 else if (strEQ(s, "CHECK") && !PL_error_count) {
4295 PL_checkav = newAV();
4296 DEBUG_x( dump_sub(gv) );
4297 if (PL_main_start && ckWARN(WARN_VOID))
4298 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4299 av_unshift(PL_checkav, 1);
4300 av_store(PL_checkav, 0, (SV*)cv);
4301 GvCV(gv) = 0; /* cv has been hijacked */
4303 else if (strEQ(s, "INIT") && !PL_error_count) {
4305 PL_initav = newAV();
4306 DEBUG_x( dump_sub(gv) );
4307 if (PL_main_start && ckWARN(WARN_VOID))
4308 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4309 av_push(PL_initav, (SV*)cv);
4310 GvCV(gv) = 0; /* cv has been hijacked */
4315 PL_copline = NOLINE;
4320 /* XXX unsafe for threads if eval_owner isn't held */
4322 =for apidoc newCONSTSUB
4324 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4325 eligible for inlining at compile-time.
4331 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4337 SAVECOPLINE(PL_curcop);
4338 CopLINE_set(PL_curcop, PL_copline);
4341 PL_hints &= ~HINT_BLOCK_SCOPE;
4344 SAVESPTR(PL_curstash);
4345 SAVECOPSTASH(PL_curcop);
4346 PL_curstash = stash;
4347 CopSTASH_set(PL_curcop,stash);
4350 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4351 CvXSUBANY(cv).any_ptr = sv;
4353 sv_setpv((SV*)cv, ""); /* prototype is "" */
4356 CopSTASH_free(PL_curcop);
4364 =for apidoc U||newXS
4366 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4372 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
4374 GV *gv = gv_fetchpv(name ? name :
4375 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4376 GV_ADDMULTI, SVt_PVCV);
4380 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4382 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4384 /* just a cached method */
4388 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4389 /* already defined (or promised) */
4390 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4391 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4392 line_t oldline = CopLINE(PL_curcop);
4393 if (PL_copline != NOLINE)
4394 CopLINE_set(PL_curcop, PL_copline);
4395 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4396 CvCONST(cv) ? "Constant subroutine %s redefined"
4397 : "Subroutine %s redefined"
4399 CopLINE_set(PL_curcop, oldline);
4406 if (cv) /* must reuse cv if autoloaded */
4409 cv = (CV*)NEWSV(1105,0);
4410 sv_upgrade((SV *)cv, SVt_PVCV);
4414 PL_sub_generation++;
4418 (void)gv_fetchfile(filename);
4419 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
4420 an external constant string */
4421 CvXSUB(cv) = subaddr;
4424 char *s = strrchr(name,':');
4430 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4433 if (strEQ(s, "BEGIN")) {
4435 PL_beginav = newAV();
4436 av_push(PL_beginav, (SV*)cv);
4437 GvCV(gv) = 0; /* cv has been hijacked */
4439 else if (strEQ(s, "END")) {
4442 av_unshift(PL_endav, 1);
4443 av_store(PL_endav, 0, (SV*)cv);
4444 GvCV(gv) = 0; /* cv has been hijacked */
4446 else if (strEQ(s, "CHECK")) {
4448 PL_checkav = newAV();
4449 if (PL_main_start && ckWARN(WARN_VOID))
4450 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4451 av_unshift(PL_checkav, 1);
4452 av_store(PL_checkav, 0, (SV*)cv);
4453 GvCV(gv) = 0; /* cv has been hijacked */
4455 else if (strEQ(s, "INIT")) {
4457 PL_initav = newAV();
4458 if (PL_main_start && ckWARN(WARN_VOID))
4459 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4460 av_push(PL_initav, (SV*)cv);
4461 GvCV(gv) = 0; /* cv has been hijacked */
4472 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4480 name = SvPVx(cSVOPo->op_sv, n_a);
4483 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
4484 #ifdef GV_UNIQUE_CHECK
4486 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4490 if ((cv = GvFORM(gv))) {
4491 if (ckWARN(WARN_REDEFINE)) {
4492 line_t oldline = CopLINE(PL_curcop);
4493 if (PL_copline != NOLINE)
4494 CopLINE_set(PL_curcop, PL_copline);
4495 Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Format %s redefined",name);
4496 CopLINE_set(PL_curcop, oldline);
4503 CvFILE_set_from_cop(cv, PL_curcop);
4506 pad_tidy(padtidy_FORMAT);
4507 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4508 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4509 OpREFCNT_set(CvROOT(cv), 1);
4510 CvSTART(cv) = LINKLIST(CvROOT(cv));
4511 CvROOT(cv)->op_next = 0;
4512 CALL_PEEP(CvSTART(cv));
4514 PL_copline = NOLINE;
4519 Perl_newANONLIST(pTHX_ OP *o)
4521 return newUNOP(OP_REFGEN, 0,
4522 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4526 Perl_newANONHASH(pTHX_ OP *o)
4528 return newUNOP(OP_REFGEN, 0,
4529 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4533 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4535 return newANONATTRSUB(floor, proto, Nullop, block);
4539 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4541 return newUNOP(OP_REFGEN, 0,
4542 newSVOP(OP_ANONCODE, 0,
4543 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
4547 Perl_oopsAV(pTHX_ OP *o)
4549 switch (o->op_type) {
4551 o->op_type = OP_PADAV;
4552 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4553 return ref(o, OP_RV2AV);
4556 o->op_type = OP_RV2AV;
4557 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4562 if (ckWARN_d(WARN_INTERNAL))
4563 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
4570 Perl_oopsHV(pTHX_ OP *o)
4572 switch (o->op_type) {
4575 o->op_type = OP_PADHV;
4576 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4577 return ref(o, OP_RV2HV);
4581 o->op_type = OP_RV2HV;
4582 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
4587 if (ckWARN_d(WARN_INTERNAL))
4588 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
4595 Perl_newAVREF(pTHX_ OP *o)
4597 if (o->op_type == OP_PADANY) {
4598 o->op_type = OP_PADAV;
4599 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4602 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
4603 && ckWARN(WARN_DEPRECATED)) {
4604 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4605 "Using an array as a reference is deprecated");
4607 return newUNOP(OP_RV2AV, 0, scalar(o));
4611 Perl_newGVREF(pTHX_ I32 type, OP *o)
4613 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
4614 return newUNOP(OP_NULL, 0, o);
4615 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
4619 Perl_newHVREF(pTHX_ OP *o)
4621 if (o->op_type == OP_PADANY) {
4622 o->op_type = OP_PADHV;
4623 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4626 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
4627 && ckWARN(WARN_DEPRECATED)) {
4628 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4629 "Using a hash as a reference is deprecated");
4631 return newUNOP(OP_RV2HV, 0, scalar(o));
4635 Perl_oopsCV(pTHX_ OP *o)
4637 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
4643 Perl_newCVREF(pTHX_ I32 flags, OP *o)
4645 return newUNOP(OP_RV2CV, flags, scalar(o));
4649 Perl_newSVREF(pTHX_ OP *o)
4651 if (o->op_type == OP_PADANY) {
4652 o->op_type = OP_PADSV;
4653 o->op_ppaddr = PL_ppaddr[OP_PADSV];
4656 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4657 o->op_flags |= OPpDONE_SVREF;
4660 return newUNOP(OP_RV2SV, 0, scalar(o));
4663 /* Check routines. */
4666 Perl_ck_anoncode(pTHX_ OP *o)
4668 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
4669 cSVOPo->op_sv = Nullsv;
4674 Perl_ck_bitop(pTHX_ OP *o)
4676 #define OP_IS_NUMCOMPARE(op) \
4677 ((op) == OP_LT || (op) == OP_I_LT || \
4678 (op) == OP_GT || (op) == OP_I_GT || \
4679 (op) == OP_LE || (op) == OP_I_LE || \
4680 (op) == OP_GE || (op) == OP_I_GE || \
4681 (op) == OP_EQ || (op) == OP_I_EQ || \
4682 (op) == OP_NE || (op) == OP_I_NE || \
4683 (op) == OP_NCMP || (op) == OP_I_NCMP)
4684 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4685 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
4686 && (o->op_type == OP_BIT_OR
4687 || o->op_type == OP_BIT_AND
4688 || o->op_type == OP_BIT_XOR))
4690 OP * left = cBINOPo->op_first;
4691 OP * right = left->op_sibling;
4692 if ((OP_IS_NUMCOMPARE(left->op_type) &&
4693 (left->op_flags & OPf_PARENS) == 0) ||
4694 (OP_IS_NUMCOMPARE(right->op_type) &&
4695 (right->op_flags & OPf_PARENS) == 0))
4696 if (ckWARN(WARN_PRECEDENCE))
4697 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4698 "Possible precedence problem on bitwise %c operator",
4699 o->op_type == OP_BIT_OR ? '|'
4700 : o->op_type == OP_BIT_AND ? '&' : '^'
4707 Perl_ck_concat(pTHX_ OP *o)
4709 OP *kid = cUNOPo->op_first;
4710 if (kid->op_type == OP_CONCAT && !(kUNOP->op_first->op_flags & OPf_MOD))
4711 o->op_flags |= OPf_STACKED;
4716 Perl_ck_spair(pTHX_ OP *o)
4718 if (o->op_flags & OPf_KIDS) {
4721 OPCODE type = o->op_type;
4722 o = modkids(ck_fun(o), type);
4723 kid = cUNOPo->op_first;
4724 newop = kUNOP->op_first->op_sibling;
4726 (newop->op_sibling ||
4727 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
4728 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
4729 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
4733 op_free(kUNOP->op_first);
4734 kUNOP->op_first = newop;
4736 o->op_ppaddr = PL_ppaddr[++o->op_type];
4741 Perl_ck_delete(pTHX_ OP *o)
4745 if (o->op_flags & OPf_KIDS) {
4746 OP *kid = cUNOPo->op_first;
4747 switch (kid->op_type) {
4749 o->op_flags |= OPf_SPECIAL;
4752 o->op_private |= OPpSLICE;
4755 o->op_flags |= OPf_SPECIAL;
4760 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
4769 Perl_ck_die(pTHX_ OP *o)
4772 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4778 Perl_ck_eof(pTHX_ OP *o)
4780 I32 type = o->op_type;
4782 if (o->op_flags & OPf_KIDS) {
4783 if (cLISTOPo->op_first->op_type == OP_STUB) {
4785 o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
4793 Perl_ck_eval(pTHX_ OP *o)
4795 PL_hints |= HINT_BLOCK_SCOPE;
4796 if (o->op_flags & OPf_KIDS) {
4797 SVOP *kid = (SVOP*)cUNOPo->op_first;
4800 o->op_flags &= ~OPf_KIDS;
4803 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
4806 cUNOPo->op_first = 0;
4809 NewOp(1101, enter, 1, LOGOP);
4810 enter->op_type = OP_ENTERTRY;
4811 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
4812 enter->op_private = 0;
4814 /* establish postfix order */
4815 enter->op_next = (OP*)enter;
4817 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
4818 o->op_type = OP_LEAVETRY;
4819 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
4820 enter->op_other = o;
4830 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
4832 o->op_targ = (PADOFFSET)PL_hints;
4837 Perl_ck_exit(pTHX_ OP *o)
4840 HV *table = GvHV(PL_hintgv);
4842 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
4843 if (svp && *svp && SvTRUE(*svp))
4844 o->op_private |= OPpEXIT_VMSISH;
4846 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4852 Perl_ck_exec(pTHX_ OP *o)
4855 if (o->op_flags & OPf_STACKED) {
4857 kid = cUNOPo->op_first->op_sibling;
4858 if (kid->op_type == OP_RV2GV)
4867 Perl_ck_exists(pTHX_ OP *o)
4870 if (o->op_flags & OPf_KIDS) {
4871 OP *kid = cUNOPo->op_first;
4872 if (kid->op_type == OP_ENTERSUB) {
4873 (void) ref(kid, o->op_type);
4874 if (kid->op_type != OP_RV2CV && !PL_error_count)
4875 Perl_croak(aTHX_ "%s argument is not a subroutine name",
4877 o->op_private |= OPpEXISTS_SUB;
4879 else if (kid->op_type == OP_AELEM)
4880 o->op_flags |= OPf_SPECIAL;
4881 else if (kid->op_type != OP_HELEM)
4882 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
4891 Perl_ck_gvconst(pTHX_ register OP *o)
4893 o = fold_constants(o);
4894 if (o->op_type == OP_CONST)
4901 Perl_ck_rvconst(pTHX_ register OP *o)
4903 SVOP *kid = (SVOP*)cUNOPo->op_first;
4905 o->op_private |= (PL_hints & HINT_STRICT_REFS);
4906 if (kid->op_type == OP_CONST) {
4910 SV *kidsv = kid->op_sv;
4913 /* Is it a constant from cv_const_sv()? */
4914 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
4915 SV *rsv = SvRV(kidsv);
4916 int svtype = SvTYPE(rsv);
4917 char *badtype = Nullch;
4919 switch (o->op_type) {
4921 if (svtype > SVt_PVMG)
4922 badtype = "a SCALAR";
4925 if (svtype != SVt_PVAV)
4926 badtype = "an ARRAY";
4929 if (svtype != SVt_PVHV)
4933 if (svtype != SVt_PVCV)
4938 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
4941 name = SvPV(kidsv, n_a);
4942 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
4943 char *badthing = Nullch;
4944 switch (o->op_type) {
4946 badthing = "a SCALAR";
4949 badthing = "an ARRAY";
4952 badthing = "a HASH";
4957 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
4961 * This is a little tricky. We only want to add the symbol if we
4962 * didn't add it in the lexer. Otherwise we get duplicate strict
4963 * warnings. But if we didn't add it in the lexer, we must at
4964 * least pretend like we wanted to add it even if it existed before,
4965 * or we get possible typo warnings. OPpCONST_ENTERED says
4966 * whether the lexer already added THIS instance of this symbol.
4968 iscv = (o->op_type == OP_RV2CV) * 2;
4970 gv = gv_fetchpv(name,
4971 iscv | !(kid->op_private & OPpCONST_ENTERED),
4974 : o->op_type == OP_RV2SV
4976 : o->op_type == OP_RV2AV
4978 : o->op_type == OP_RV2HV
4981 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
4983 kid->op_type = OP_GV;
4984 SvREFCNT_dec(kid->op_sv);
4986 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
4987 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
4988 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
4990 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
4992 kid->op_sv = SvREFCNT_inc(gv);
4994 kid->op_private = 0;
4995 kid->op_ppaddr = PL_ppaddr[OP_GV];
5002 Perl_ck_ftst(pTHX_ OP *o)
5004 I32 type = o->op_type;
5006 if (o->op_flags & OPf_REF) {
5009 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5010 SVOP *kid = (SVOP*)cUNOPo->op_first;
5012 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5014 OP *newop = newGVOP(type, OPf_REF,
5015 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5020 if ((PL_hints & HINT_FILETEST_ACCESS) &&
5021 OP_IS_FILETEST_ACCESS(o))
5022 o->op_private |= OPpFT_ACCESS;
5027 if (type == OP_FTTTY)
5028 o = newGVOP(type, OPf_REF, PL_stdingv);
5030 o = newUNOP(type, 0, newDEFSVOP());
5036 Perl_ck_fun(pTHX_ OP *o)
5042 int type = o->op_type;
5043 register I32 oa = PL_opargs[type] >> OASHIFT;
5045 if (o->op_flags & OPf_STACKED) {
5046 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5049 return no_fh_allowed(o);
5052 if (o->op_flags & OPf_KIDS) {
5054 tokid = &cLISTOPo->op_first;
5055 kid = cLISTOPo->op_first;
5056 if (kid->op_type == OP_PUSHMARK ||
5057 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5059 tokid = &kid->op_sibling;
5060 kid = kid->op_sibling;
5062 if (!kid && PL_opargs[type] & OA_DEFGV)
5063 *tokid = kid = newDEFSVOP();
5067 sibl = kid->op_sibling;
5070 /* list seen where single (scalar) arg expected? */
5071 if (numargs == 1 && !(oa >> 4)
5072 && kid->op_type == OP_LIST && type != OP_SCALAR)
5074 return too_many_arguments(o,PL_op_desc[type]);
5087 if ((type == OP_PUSH || type == OP_UNSHIFT)
5088 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5089 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5090 "Useless use of %s with no values",
5093 if (kid->op_type == OP_CONST &&
5094 (kid->op_private & OPpCONST_BARE))
5096 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5097 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5098 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5099 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5100 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5101 "Array @%s missing the @ in argument %"IVdf" of %s()",
5102 name, (IV)numargs, PL_op_desc[type]);
5105 kid->op_sibling = sibl;
5108 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5109 bad_type(numargs, "array", PL_op_desc[type], kid);
5113 if (kid->op_type == OP_CONST &&
5114 (kid->op_private & OPpCONST_BARE))
5116 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5117 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5118 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5119 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5120 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5121 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5122 name, (IV)numargs, PL_op_desc[type]);
5125 kid->op_sibling = sibl;
5128 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5129 bad_type(numargs, "hash", PL_op_desc[type], kid);
5134 OP *newop = newUNOP(OP_NULL, 0, kid);
5135 kid->op_sibling = 0;
5137 newop->op_next = newop;
5139 kid->op_sibling = sibl;
5144 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5145 if (kid->op_type == OP_CONST &&
5146 (kid->op_private & OPpCONST_BARE))
5148 OP *newop = newGVOP(OP_GV, 0,
5149 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5151 if (!(o->op_private & 1) && /* if not unop */
5152 kid == cLISTOPo->op_last)
5153 cLISTOPo->op_last = newop;
5157 else if (kid->op_type == OP_READLINE) {
5158 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5159 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5162 I32 flags = OPf_SPECIAL;
5166 /* is this op a FH constructor? */
5167 if (is_handle_constructor(o,numargs)) {
5168 char *name = Nullch;
5172 /* Set a flag to tell rv2gv to vivify
5173 * need to "prove" flag does not mean something
5174 * else already - NI-S 1999/05/07
5177 if (kid->op_type == OP_PADSV) {
5178 name = PAD_COMPNAME_PV(kid->op_targ);
5179 /* SvCUR of a pad namesv can't be trusted
5180 * (see PL_generation), so calc its length
5186 else if (kid->op_type == OP_RV2SV
5187 && kUNOP->op_first->op_type == OP_GV)
5189 GV *gv = cGVOPx_gv(kUNOP->op_first);
5191 len = GvNAMELEN(gv);
5193 else if (kid->op_type == OP_AELEM
5194 || kid->op_type == OP_HELEM)
5199 if ((op = ((BINOP*)kid)->op_first)) {
5200 SV *tmpstr = Nullsv;
5202 kid->op_type == OP_AELEM ?
5204 if (((op->op_type == OP_RV2AV) ||
5205 (op->op_type == OP_RV2HV)) &&
5206 (op = ((UNOP*)op)->op_first) &&
5207 (op->op_type == OP_GV)) {
5208 /* packagevar $a[] or $h{} */
5209 GV *gv = cGVOPx_gv(op);
5217 else if (op->op_type == OP_PADAV
5218 || op->op_type == OP_PADHV) {
5219 /* lexicalvar $a[] or $h{} */
5221 PAD_COMPNAME_PV(op->op_targ);
5231 name = savepv(SvPVX(tmpstr));
5237 name = "__ANONIO__";
5244 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5245 namesv = PAD_SVl(targ);
5246 (void)SvUPGRADE(namesv, SVt_PV);
5248 sv_setpvn(namesv, "$", 1);
5249 sv_catpvn(namesv, name, len);
5252 kid->op_sibling = 0;
5253 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5254 kid->op_targ = targ;
5255 kid->op_private |= priv;
5257 kid->op_sibling = sibl;
5263 mod(scalar(kid), type);
5267 tokid = &kid->op_sibling;
5268 kid = kid->op_sibling;
5270 o->op_private |= numargs;
5272 return too_many_arguments(o,OP_DESC(o));
5275 else if (PL_opargs[type] & OA_DEFGV) {
5277 return newUNOP(type, 0, newDEFSVOP());
5281 while (oa & OA_OPTIONAL)
5283 if (oa && oa != OA_LIST)
5284 return too_few_arguments(o,OP_DESC(o));
5290 Perl_ck_glob(pTHX_ OP *o)
5295 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5296 append_elem(OP_GLOB, o, newDEFSVOP());
5298 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5299 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5301 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5304 #if !defined(PERL_EXTERNAL_GLOB)
5305 /* XXX this can be tightened up and made more failsafe. */
5306 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5309 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5310 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5311 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5312 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5313 GvCV(gv) = GvCV(glob_gv);
5314 SvREFCNT_inc((SV*)GvCV(gv));
5315 GvIMPORTED_CV_on(gv);
5318 #endif /* PERL_EXTERNAL_GLOB */
5320 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5321 append_elem(OP_GLOB, o,
5322 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5323 o->op_type = OP_LIST;
5324 o->op_ppaddr = PL_ppaddr[OP_LIST];
5325 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5326 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5327 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5328 append_elem(OP_LIST, o,
5329 scalar(newUNOP(OP_RV2CV, 0,
5330 newGVOP(OP_GV, 0, gv)))));
5331 o = newUNOP(OP_NULL, 0, ck_subr(o));
5332 o->op_targ = OP_GLOB; /* hint at what it used to be */
5335 gv = newGVgen("main");
5337 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5343 Perl_ck_grep(pTHX_ OP *o)
5347 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5349 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5350 NewOp(1101, gwop, 1, LOGOP);
5352 if (o->op_flags & OPf_STACKED) {
5355 kid = cLISTOPo->op_first->op_sibling;
5356 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5359 kid->op_next = (OP*)gwop;
5360 o->op_flags &= ~OPf_STACKED;
5362 kid = cLISTOPo->op_first->op_sibling;
5363 if (type == OP_MAPWHILE)
5370 kid = cLISTOPo->op_first->op_sibling;
5371 if (kid->op_type != OP_NULL)
5372 Perl_croak(aTHX_ "panic: ck_grep");
5373 kid = kUNOP->op_first;
5375 gwop->op_type = type;
5376 gwop->op_ppaddr = PL_ppaddr[type];
5377 gwop->op_first = listkids(o);
5378 gwop->op_flags |= OPf_KIDS;
5379 gwop->op_private = 1;
5380 gwop->op_other = LINKLIST(kid);
5381 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5382 kid->op_next = (OP*)gwop;
5384 kid = cLISTOPo->op_first->op_sibling;
5385 if (!kid || !kid->op_sibling)
5386 return too_few_arguments(o,OP_DESC(o));
5387 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5388 mod(kid, OP_GREPSTART);
5394 Perl_ck_index(pTHX_ OP *o)
5396 if (o->op_flags & OPf_KIDS) {
5397 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5399 kid = kid->op_sibling; /* get past "big" */
5400 if (kid && kid->op_type == OP_CONST)
5401 fbm_compile(((SVOP*)kid)->op_sv, 0);
5407 Perl_ck_lengthconst(pTHX_ OP *o)
5409 /* XXX length optimization goes here */
5414 Perl_ck_lfun(pTHX_ OP *o)
5416 OPCODE type = o->op_type;
5417 return modkids(ck_fun(o), type);
5421 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5423 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5424 switch (cUNOPo->op_first->op_type) {
5426 /* This is needed for
5427 if (defined %stash::)
5428 to work. Do not break Tk.
5430 break; /* Globals via GV can be undef */
5432 case OP_AASSIGN: /* Is this a good idea? */
5433 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5434 "defined(@array) is deprecated");
5435 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5436 "\t(Maybe you should just omit the defined()?)\n");
5439 /* This is needed for
5440 if (defined %stash::)
5441 to work. Do not break Tk.
5443 break; /* Globals via GV can be undef */
5445 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5446 "defined(%%hash) is deprecated");
5447 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5448 "\t(Maybe you should just omit the defined()?)\n");
5459 Perl_ck_rfun(pTHX_ OP *o)
5461 OPCODE type = o->op_type;
5462 return refkids(ck_fun(o), type);
5466 Perl_ck_listiob(pTHX_ OP *o)
5470 kid = cLISTOPo->op_first;
5473 kid = cLISTOPo->op_first;
5475 if (kid->op_type == OP_PUSHMARK)
5476 kid = kid->op_sibling;
5477 if (kid && o->op_flags & OPf_STACKED)
5478 kid = kid->op_sibling;
5479 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5480 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5481 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5482 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5483 cLISTOPo->op_first->op_sibling = kid;
5484 cLISTOPo->op_last = kid;
5485 kid = kid->op_sibling;
5490 append_elem(o->op_type, o, newDEFSVOP());
5496 Perl_ck_sassign(pTHX_ OP *o)
5498 OP *kid = cLISTOPo->op_first;
5499 /* has a disposable target? */
5500 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5501 && !(kid->op_flags & OPf_STACKED)
5502 /* Cannot steal the second time! */
5503 && !(kid->op_private & OPpTARGET_MY))
5505 OP *kkid = kid->op_sibling;
5507 /* Can just relocate the target. */
5508 if (kkid && kkid->op_type == OP_PADSV
5509 && !(kkid->op_private & OPpLVAL_INTRO))
5511 kid->op_targ = kkid->op_targ;
5513 /* Now we do not need PADSV and SASSIGN. */
5514 kid->op_sibling = o->op_sibling; /* NULL */
5515 cLISTOPo->op_first = NULL;
5518 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
5526 Perl_ck_match(pTHX_ OP *o)
5528 o->op_private |= OPpRUNTIME;
5533 Perl_ck_method(pTHX_ OP *o)
5535 OP *kid = cUNOPo->op_first;
5536 if (kid->op_type == OP_CONST) {
5537 SV* sv = kSVOP->op_sv;
5538 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
5540 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5541 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
5544 kSVOP->op_sv = Nullsv;
5546 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5555 Perl_ck_null(pTHX_ OP *o)
5561 Perl_ck_open(pTHX_ OP *o)
5563 HV *table = GvHV(PL_hintgv);
5567 svp = hv_fetch(table, "open_IN", 7, FALSE);
5569 mode = mode_from_discipline(*svp);
5570 if (mode & O_BINARY)
5571 o->op_private |= OPpOPEN_IN_RAW;
5572 else if (mode & O_TEXT)
5573 o->op_private |= OPpOPEN_IN_CRLF;
5576 svp = hv_fetch(table, "open_OUT", 8, FALSE);
5578 mode = mode_from_discipline(*svp);
5579 if (mode & O_BINARY)
5580 o->op_private |= OPpOPEN_OUT_RAW;
5581 else if (mode & O_TEXT)
5582 o->op_private |= OPpOPEN_OUT_CRLF;
5585 if (o->op_type == OP_BACKTICK)
5588 /* In case of three-arg dup open remove strictness
5589 * from the last arg if it is a bareword. */
5590 OP *first = cLISTOPx(o)->op_first; /* The pushmark. */
5591 OP *last = cLISTOPx(o)->op_last; /* The bareword. */
5595 if ((last->op_type == OP_CONST) && /* The bareword. */
5596 (last->op_private & OPpCONST_BARE) &&
5597 (last->op_private & OPpCONST_STRICT) &&
5598 (oa = first->op_sibling) && /* The fh. */
5599 (oa = oa->op_sibling) && /* The mode. */
5600 SvPOK(((SVOP*)oa)->op_sv) &&
5601 (mode = SvPVX(((SVOP*)oa)->op_sv)) &&
5602 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
5603 (last == oa->op_sibling)) /* The bareword. */
5604 last->op_private &= ~OPpCONST_STRICT;
5610 Perl_ck_repeat(pTHX_ OP *o)
5612 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5613 o->op_private |= OPpREPEAT_DOLIST;
5614 cBINOPo->op_first = force_list(cBINOPo->op_first);
5622 Perl_ck_require(pTHX_ OP *o)
5626 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
5627 SVOP *kid = (SVOP*)cUNOPo->op_first;
5629 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5631 for (s = SvPVX(kid->op_sv); *s; s++) {
5632 if (*s == ':' && s[1] == ':') {
5634 Move(s+2, s+1, strlen(s+2)+1, char);
5635 --SvCUR(kid->op_sv);
5638 if (SvREADONLY(kid->op_sv)) {
5639 SvREADONLY_off(kid->op_sv);
5640 sv_catpvn(kid->op_sv, ".pm", 3);
5641 SvREADONLY_on(kid->op_sv);
5644 sv_catpvn(kid->op_sv, ".pm", 3);
5648 /* handle override, if any */
5649 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
5650 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
5651 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
5653 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5654 OP *kid = cUNOPo->op_first;
5655 cUNOPo->op_first = 0;
5657 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5658 append_elem(OP_LIST, kid,
5659 scalar(newUNOP(OP_RV2CV, 0,
5668 Perl_ck_return(pTHX_ OP *o)
5671 if (CvLVALUE(PL_compcv)) {
5672 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5673 mod(kid, OP_LEAVESUBLV);
5680 Perl_ck_retarget(pTHX_ OP *o)
5682 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5689 Perl_ck_select(pTHX_ OP *o)
5692 if (o->op_flags & OPf_KIDS) {
5693 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5694 if (kid && kid->op_sibling) {
5695 o->op_type = OP_SSELECT;
5696 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
5698 return fold_constants(o);
5702 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5703 if (kid && kid->op_type == OP_RV2GV)
5704 kid->op_private &= ~HINT_STRICT_REFS;
5709 Perl_ck_shift(pTHX_ OP *o)
5711 I32 type = o->op_type;
5713 if (!(o->op_flags & OPf_KIDS)) {
5717 argop = newUNOP(OP_RV2AV, 0,
5718 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
5719 return newUNOP(type, 0, scalar(argop));
5721 return scalar(modkids(ck_fun(o), type));
5725 Perl_ck_sort(pTHX_ OP *o)
5729 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
5731 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5732 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
5734 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
5736 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
5738 if (kid->op_type == OP_SCOPE) {
5742 else if (kid->op_type == OP_LEAVE) {
5743 if (o->op_type == OP_SORT) {
5744 op_null(kid); /* wipe out leave */
5747 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
5748 if (k->op_next == kid)
5750 /* don't descend into loops */
5751 else if (k->op_type == OP_ENTERLOOP
5752 || k->op_type == OP_ENTERITER)
5754 k = cLOOPx(k)->op_lastop;
5759 kid->op_next = 0; /* just disconnect the leave */
5760 k = kLISTOP->op_first;
5765 if (o->op_type == OP_SORT) {
5766 /* provide scalar context for comparison function/block */
5772 o->op_flags |= OPf_SPECIAL;
5774 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
5777 firstkid = firstkid->op_sibling;
5780 /* provide list context for arguments */
5781 if (o->op_type == OP_SORT)
5788 S_simplify_sort(pTHX_ OP *o)
5790 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5794 if (!(o->op_flags & OPf_STACKED))
5796 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
5797 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
5798 kid = kUNOP->op_first; /* get past null */
5799 if (kid->op_type != OP_SCOPE)
5801 kid = kLISTOP->op_last; /* get past scope */
5802 switch(kid->op_type) {
5810 k = kid; /* remember this node*/
5811 if (kBINOP->op_first->op_type != OP_RV2SV)
5813 kid = kBINOP->op_first; /* get past cmp */
5814 if (kUNOP->op_first->op_type != OP_GV)
5816 kid = kUNOP->op_first; /* get past rv2sv */
5818 if (GvSTASH(gv) != PL_curstash)
5820 if (strEQ(GvNAME(gv), "a"))
5822 else if (strEQ(GvNAME(gv), "b"))
5826 kid = k; /* back to cmp */
5827 if (kBINOP->op_last->op_type != OP_RV2SV)
5829 kid = kBINOP->op_last; /* down to 2nd arg */
5830 if (kUNOP->op_first->op_type != OP_GV)
5832 kid = kUNOP->op_first; /* get past rv2sv */
5834 if (GvSTASH(gv) != PL_curstash
5836 ? strNE(GvNAME(gv), "a")
5837 : strNE(GvNAME(gv), "b")))
5839 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
5841 o->op_private |= OPpSORT_REVERSE;
5842 if (k->op_type == OP_NCMP)
5843 o->op_private |= OPpSORT_NUMERIC;
5844 if (k->op_type == OP_I_NCMP)
5845 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
5846 kid = cLISTOPo->op_first->op_sibling;
5847 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
5848 op_free(kid); /* then delete it */
5852 Perl_ck_split(pTHX_ OP *o)
5856 if (o->op_flags & OPf_STACKED)
5857 return no_fh_allowed(o);
5859 kid = cLISTOPo->op_first;
5860 if (kid->op_type != OP_NULL)
5861 Perl_croak(aTHX_ "panic: ck_split");
5862 kid = kid->op_sibling;
5863 op_free(cLISTOPo->op_first);
5864 cLISTOPo->op_first = kid;
5866 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
5867 cLISTOPo->op_last = kid; /* There was only one element previously */
5870 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
5871 OP *sibl = kid->op_sibling;
5872 kid->op_sibling = 0;
5873 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
5874 if (cLISTOPo->op_first == cLISTOPo->op_last)
5875 cLISTOPo->op_last = kid;
5876 cLISTOPo->op_first = kid;
5877 kid->op_sibling = sibl;
5880 kid->op_type = OP_PUSHRE;
5881 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
5883 if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
5884 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
5885 "Use of /g modifier is meaningless in split");
5888 if (!kid->op_sibling)
5889 append_elem(OP_SPLIT, o, newDEFSVOP());
5891 kid = kid->op_sibling;
5894 if (!kid->op_sibling)
5895 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
5897 kid = kid->op_sibling;
5900 if (kid->op_sibling)
5901 return too_many_arguments(o,OP_DESC(o));
5907 Perl_ck_join(pTHX_ OP *o)
5909 if (ckWARN(WARN_SYNTAX)) {
5910 OP *kid = cLISTOPo->op_first->op_sibling;
5911 if (kid && kid->op_type == OP_MATCH) {
5912 char *pmstr = "STRING";
5913 if (PM_GETRE(kPMOP))
5914 pmstr = PM_GETRE(kPMOP)->precomp;
5915 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5916 "/%s/ should probably be written as \"%s\"",
5924 Perl_ck_subr(pTHX_ OP *o)
5926 OP *prev = ((cUNOPo->op_first->op_sibling)
5927 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
5928 OP *o2 = prev->op_sibling;
5935 I32 contextclass = 0;
5940 o->op_private |= OPpENTERSUB_HASTARG;
5941 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
5942 if (cvop->op_type == OP_RV2CV) {
5944 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
5945 op_null(cvop); /* disable rv2cv */
5946 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
5947 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
5948 GV *gv = cGVOPx_gv(tmpop);
5951 tmpop->op_private |= OPpEARLY_CV;
5954 namegv = CvANON(cv) ? gv : CvGV(cv);
5955 proto = SvPV((SV*)cv, n_a);
5957 if (CvASSERTION(cv)) {
5958 if (PL_hints & HINT_ASSERTING) {
5959 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
5960 o->op_private |= OPpENTERSUB_DB;
5964 if (ckWARN(WARN_ASSERTIONS) && !(PL_hints & HINT_ASSERTIONSSEEN)) {
5965 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
5966 "Impossible to activate assertion call");
5973 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
5974 if (o2->op_type == OP_CONST)
5975 o2->op_private &= ~OPpCONST_STRICT;
5976 else if (o2->op_type == OP_LIST) {
5977 OP *o = ((UNOP*)o2)->op_first->op_sibling;
5978 if (o && o->op_type == OP_CONST)
5979 o->op_private &= ~OPpCONST_STRICT;
5982 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5983 if (PERLDB_SUB && PL_curstash != PL_debstash)
5984 o->op_private |= OPpENTERSUB_DB;
5985 while (o2 != cvop) {
5989 return too_many_arguments(o, gv_ename(namegv));
6007 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6009 arg == 1 ? "block or sub {}" : "sub {}",
6010 gv_ename(namegv), o2);
6013 /* '*' allows any scalar type, including bareword */
6016 if (o2->op_type == OP_RV2GV)
6017 goto wrapref; /* autoconvert GLOB -> GLOBref */
6018 else if (o2->op_type == OP_CONST)
6019 o2->op_private &= ~OPpCONST_STRICT;
6020 else if (o2->op_type == OP_ENTERSUB) {
6021 /* accidental subroutine, revert to bareword */
6022 OP *gvop = ((UNOP*)o2)->op_first;
6023 if (gvop && gvop->op_type == OP_NULL) {
6024 gvop = ((UNOP*)gvop)->op_first;
6026 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6029 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6030 (gvop = ((UNOP*)gvop)->op_first) &&
6031 gvop->op_type == OP_GV)
6033 GV *gv = cGVOPx_gv(gvop);
6034 OP *sibling = o2->op_sibling;
6035 SV *n = newSVpvn("",0);
6037 gv_fullname3(n, gv, "");
6038 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6039 sv_chop(n, SvPVX(n)+6);
6040 o2 = newSVOP(OP_CONST, 0, n);
6041 prev->op_sibling = o2;
6042 o2->op_sibling = sibling;
6058 if (contextclass++ == 0) {
6059 e = strchr(proto, ']');
6060 if (!e || e == proto)
6073 while (*--p != '[');
6074 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6075 gv_ename(namegv), o2);
6081 if (o2->op_type == OP_RV2GV)
6084 bad_type(arg, "symbol", gv_ename(namegv), o2);
6087 if (o2->op_type == OP_ENTERSUB)
6090 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6093 if (o2->op_type == OP_RV2SV ||
6094 o2->op_type == OP_PADSV ||
6095 o2->op_type == OP_HELEM ||
6096 o2->op_type == OP_AELEM ||
6097 o2->op_type == OP_THREADSV)
6100 bad_type(arg, "scalar", gv_ename(namegv), o2);
6103 if (o2->op_type == OP_RV2AV ||
6104 o2->op_type == OP_PADAV)
6107 bad_type(arg, "array", gv_ename(namegv), o2);
6110 if (o2->op_type == OP_RV2HV ||
6111 o2->op_type == OP_PADHV)
6114 bad_type(arg, "hash", gv_ename(namegv), o2);
6119 OP* sib = kid->op_sibling;
6120 kid->op_sibling = 0;
6121 o2 = newUNOP(OP_REFGEN, 0, kid);
6122 o2->op_sibling = sib;
6123 prev->op_sibling = o2;
6125 if (contextclass && e) {
6140 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6141 gv_ename(namegv), cv);
6146 mod(o2, OP_ENTERSUB);
6148 o2 = o2->op_sibling;
6150 if (proto && !optional &&
6151 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6152 return too_few_arguments(o, gv_ename(namegv));
6155 o=newSVOP(OP_CONST, 0, newSViv(0));
6161 Perl_ck_svconst(pTHX_ OP *o)
6163 SvREADONLY_on(cSVOPo->op_sv);
6168 Perl_ck_trunc(pTHX_ OP *o)
6170 if (o->op_flags & OPf_KIDS) {
6171 SVOP *kid = (SVOP*)cUNOPo->op_first;
6173 if (kid->op_type == OP_NULL)
6174 kid = (SVOP*)kid->op_sibling;
6175 if (kid && kid->op_type == OP_CONST &&
6176 (kid->op_private & OPpCONST_BARE))
6178 o->op_flags |= OPf_SPECIAL;
6179 kid->op_private &= ~OPpCONST_STRICT;
6186 Perl_ck_substr(pTHX_ OP *o)
6189 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6190 OP *kid = cLISTOPo->op_first;
6192 if (kid->op_type == OP_NULL)
6193 kid = kid->op_sibling;
6195 kid->op_flags |= OPf_MOD;
6201 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6204 Perl_peep(pTHX_ register OP *o)
6206 register OP* oldop = 0;
6208 if (!o || o->op_seq)
6212 SAVEVPTR(PL_curcop);
6213 for (; o; o = o->op_next) {
6216 /* The special value -1 is used by the B::C compiler backend to indicate
6217 * that an op is statically defined and should not be freed */
6218 if (!PL_op_seqmax || PL_op_seqmax == (U16)-1)
6221 switch (o->op_type) {
6225 PL_curcop = ((COP*)o); /* for warnings */
6226 o->op_seq = PL_op_seqmax++;
6230 if (cSVOPo->op_private & OPpCONST_STRICT)
6231 no_bareword_allowed(o);
6233 case OP_METHOD_NAMED:
6234 /* Relocate sv to the pad for thread safety.
6235 * Despite being a "constant", the SV is written to,
6236 * for reference counts, sv_upgrade() etc. */
6238 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6239 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6240 /* If op_sv is already a PADTMP then it is being used by
6241 * some pad, so make a copy. */
6242 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6243 SvREADONLY_on(PAD_SVl(ix));
6244 SvREFCNT_dec(cSVOPo->op_sv);
6247 SvREFCNT_dec(PAD_SVl(ix));
6248 SvPADTMP_on(cSVOPo->op_sv);
6249 PAD_SETSV(ix, cSVOPo->op_sv);
6250 /* XXX I don't know how this isn't readonly already. */
6251 SvREADONLY_on(PAD_SVl(ix));
6253 cSVOPo->op_sv = Nullsv;
6257 o->op_seq = PL_op_seqmax++;
6261 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6262 if (o->op_next->op_private & OPpTARGET_MY) {
6263 if (o->op_flags & OPf_STACKED) /* chained concats */
6264 goto ignore_optimization;
6266 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6267 o->op_targ = o->op_next->op_targ;
6268 o->op_next->op_targ = 0;
6269 o->op_private |= OPpTARGET_MY;
6272 op_null(o->op_next);
6274 ignore_optimization:
6275 o->op_seq = PL_op_seqmax++;
6278 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6279 o->op_seq = PL_op_seqmax++;
6280 break; /* Scalar stub must produce undef. List stub is noop */
6284 if (o->op_targ == OP_NEXTSTATE
6285 || o->op_targ == OP_DBSTATE
6286 || o->op_targ == OP_SETSTATE)
6288 PL_curcop = ((COP*)o);
6290 /* XXX: We avoid setting op_seq here to prevent later calls
6291 to peep() from mistakenly concluding that optimisation
6292 has already occurred. This doesn't fix the real problem,
6293 though (See 20010220.007). AMS 20010719 */
6294 if (oldop && o->op_next) {
6295 oldop->op_next = o->op_next;
6303 if (oldop && o->op_next) {
6304 oldop->op_next = o->op_next;
6307 o->op_seq = PL_op_seqmax++;
6311 if (o->op_next->op_type == OP_RV2SV) {
6312 if (!(o->op_next->op_private & OPpDEREF)) {
6313 op_null(o->op_next);
6314 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6316 o->op_next = o->op_next->op_next;
6317 o->op_type = OP_GVSV;
6318 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6321 else if (o->op_next->op_type == OP_RV2AV) {
6322 OP* pop = o->op_next->op_next;
6324 if (pop && pop->op_type == OP_CONST &&
6325 (PL_op = pop->op_next) &&
6326 pop->op_next->op_type == OP_AELEM &&
6327 !(pop->op_next->op_private &
6328 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6329 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6334 op_null(o->op_next);
6335 op_null(pop->op_next);
6337 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6338 o->op_next = pop->op_next->op_next;
6339 o->op_type = OP_AELEMFAST;
6340 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6341 o->op_private = (U8)i;
6346 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6348 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6349 /* XXX could check prototype here instead of just carping */
6350 SV *sv = sv_newmortal();
6351 gv_efullname3(sv, gv, Nullch);
6352 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6353 "%"SVf"() called too early to check prototype",
6357 else if (o->op_next->op_type == OP_READLINE
6358 && o->op_next->op_next->op_type == OP_CONCAT
6359 && (o->op_next->op_next->op_flags & OPf_STACKED))
6361 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6362 o->op_type = OP_RCATLINE;
6363 o->op_flags |= OPf_STACKED;
6364 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6365 op_null(o->op_next->op_next);
6366 op_null(o->op_next);
6369 o->op_seq = PL_op_seqmax++;
6382 o->op_seq = PL_op_seqmax++;
6383 while (cLOGOP->op_other->op_type == OP_NULL)
6384 cLOGOP->op_other = cLOGOP->op_other->op_next;
6385 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6390 o->op_seq = PL_op_seqmax++;
6391 while (cLOOP->op_redoop->op_type == OP_NULL)
6392 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6393 peep(cLOOP->op_redoop);
6394 while (cLOOP->op_nextop->op_type == OP_NULL)
6395 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6396 peep(cLOOP->op_nextop);
6397 while (cLOOP->op_lastop->op_type == OP_NULL)
6398 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6399 peep(cLOOP->op_lastop);
6405 o->op_seq = PL_op_seqmax++;
6406 while (cPMOP->op_pmreplstart &&
6407 cPMOP->op_pmreplstart->op_type == OP_NULL)
6408 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6409 peep(cPMOP->op_pmreplstart);
6413 o->op_seq = PL_op_seqmax++;
6414 if (ckWARN(WARN_SYNTAX) && o->op_next
6415 && o->op_next->op_type == OP_NEXTSTATE) {
6416 if (o->op_next->op_sibling &&
6417 o->op_next->op_sibling->op_type != OP_EXIT &&
6418 o->op_next->op_sibling->op_type != OP_WARN &&
6419 o->op_next->op_sibling->op_type != OP_DIE) {
6420 line_t oldline = CopLINE(PL_curcop);
6422 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6423 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6424 "Statement unlikely to be reached");
6425 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6426 "\t(Maybe you meant system() when you said exec()?)\n");
6427 CopLINE_set(PL_curcop, oldline);
6438 o->op_seq = PL_op_seqmax++;
6440 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6443 /* Make the CONST have a shared SV */
6444 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6445 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6446 key = SvPV(sv, keylen);
6447 lexname = newSVpvn_share(key,
6448 SvUTF8(sv) ? -(I32)keylen : keylen,
6457 o->op_seq = PL_op_seqmax++;
6467 char* Perl_custom_op_name(pTHX_ OP* o)
6469 IV index = PTR2IV(o->op_ppaddr);
6473 if (!PL_custom_op_names) /* This probably shouldn't happen */
6474 return PL_op_name[OP_CUSTOM];
6476 keysv = sv_2mortal(newSViv(index));
6478 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
6480 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
6482 return SvPV_nolen(HeVAL(he));
6485 char* Perl_custom_op_desc(pTHX_ OP* o)
6487 IV index = PTR2IV(o->op_ppaddr);
6491 if (!PL_custom_op_descs)
6492 return PL_op_desc[OP_CUSTOM];
6494 keysv = sv_2mortal(newSViv(index));
6496 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
6498 return PL_op_desc[OP_CUSTOM];
6500 return SvPV_nolen(HeVAL(he));
6506 /* Efficient sub that returns a constant scalar value. */
6508 const_sv_xsub(pTHX_ CV* cv)
6513 Perl_croak(aTHX_ "usage: %s::%s()",
6514 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
6518 ST(0) = (SV*)XSANY.any_ptr;