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 OP *k1 = ((UNOP*)first)->op_first;
3356 OP *k2 = k1->op_sibling;
3358 switch (first->op_type)
3361 if (k2 && k2->op_type == OP_READLINE
3362 && (k2->op_flags & OPf_STACKED)
3363 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3365 warnop = k2->op_type;
3370 if (k1->op_type == OP_READDIR
3371 || k1->op_type == OP_GLOB
3372 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3373 || k1->op_type == OP_EACH)
3375 warnop = ((k1->op_type == OP_NULL)
3376 ? (OPCODE)k1->op_targ : k1->op_type);
3381 line_t oldline = CopLINE(PL_curcop);
3382 CopLINE_set(PL_curcop, PL_copline);
3383 Perl_warner(aTHX_ packWARN(WARN_MISC),
3384 "Value of %s%s can be \"0\"; test with defined()",
3386 ((warnop == OP_READLINE || warnop == OP_GLOB)
3387 ? " construct" : "() operator"));
3388 CopLINE_set(PL_curcop, oldline);
3395 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3396 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3398 NewOp(1101, logop, 1, LOGOP);
3400 logop->op_type = (OPCODE)type;
3401 logop->op_ppaddr = PL_ppaddr[type];
3402 logop->op_first = first;
3403 logop->op_flags = flags | OPf_KIDS;
3404 logop->op_other = LINKLIST(other);
3405 logop->op_private = (U8)(1 | (flags >> 8));
3407 /* establish postfix order */
3408 logop->op_next = LINKLIST(first);
3409 first->op_next = (OP*)logop;
3410 first->op_sibling = other;
3412 CHECKOP(type,logop);
3414 o = newUNOP(OP_NULL, 0, (OP*)logop);
3421 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3428 return newLOGOP(OP_AND, 0, first, trueop);
3430 return newLOGOP(OP_OR, 0, first, falseop);
3432 scalarboolean(first);
3433 if (first->op_type == OP_CONST) {
3434 if (first->op_private & OPpCONST_BARE &&
3435 first->op_private & OPpCONST_STRICT) {
3436 no_bareword_allowed(first);
3438 if (SvTRUE(((SVOP*)first)->op_sv)) {
3449 NewOp(1101, logop, 1, LOGOP);
3450 logop->op_type = OP_COND_EXPR;
3451 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3452 logop->op_first = first;
3453 logop->op_flags = flags | OPf_KIDS;
3454 logop->op_private = (U8)(1 | (flags >> 8));
3455 logop->op_other = LINKLIST(trueop);
3456 logop->op_next = LINKLIST(falseop);
3458 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
3461 /* establish postfix order */
3462 start = LINKLIST(first);
3463 first->op_next = (OP*)logop;
3465 first->op_sibling = trueop;
3466 trueop->op_sibling = falseop;
3467 o = newUNOP(OP_NULL, 0, (OP*)logop);
3469 trueop->op_next = falseop->op_next = o;
3476 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3484 NewOp(1101, range, 1, LOGOP);
3486 range->op_type = OP_RANGE;
3487 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3488 range->op_first = left;
3489 range->op_flags = OPf_KIDS;
3490 leftstart = LINKLIST(left);
3491 range->op_other = LINKLIST(right);
3492 range->op_private = (U8)(1 | (flags >> 8));
3494 left->op_sibling = right;
3496 range->op_next = (OP*)range;
3497 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3498 flop = newUNOP(OP_FLOP, 0, flip);
3499 o = newUNOP(OP_NULL, 0, flop);
3501 range->op_next = leftstart;
3503 left->op_next = flip;
3504 right->op_next = flop;
3506 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3507 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3508 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3509 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3511 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3512 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3515 if (!flip->op_private || !flop->op_private)
3516 linklist(o); /* blow off optimizer unless constant */
3522 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3526 int once = block && block->op_flags & OPf_SPECIAL &&
3527 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3530 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3531 return block; /* do {} while 0 does once */
3532 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3533 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3534 expr = newUNOP(OP_DEFINED, 0,
3535 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3536 } else if (expr->op_flags & OPf_KIDS) {
3537 OP *k1 = ((UNOP*)expr)->op_first;
3538 OP *k2 = (k1) ? k1->op_sibling : NULL;
3539 switch (expr->op_type) {
3541 if (k2 && k2->op_type == OP_READLINE
3542 && (k2->op_flags & OPf_STACKED)
3543 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3544 expr = newUNOP(OP_DEFINED, 0, expr);
3548 if (k1->op_type == OP_READDIR
3549 || k1->op_type == OP_GLOB
3550 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3551 || k1->op_type == OP_EACH)
3552 expr = newUNOP(OP_DEFINED, 0, expr);
3558 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3559 o = new_logop(OP_AND, 0, &expr, &listop);
3562 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3564 if (once && o != listop)
3565 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3568 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3570 o->op_flags |= flags;
3572 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3577 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3585 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3586 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3587 expr = newUNOP(OP_DEFINED, 0,
3588 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3589 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3590 OP *k1 = ((UNOP*)expr)->op_first;
3591 OP *k2 = (k1) ? k1->op_sibling : NULL;
3592 switch (expr->op_type) {
3594 if (k2 && k2->op_type == OP_READLINE
3595 && (k2->op_flags & OPf_STACKED)
3596 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3597 expr = newUNOP(OP_DEFINED, 0, expr);
3601 if (k1->op_type == OP_READDIR
3602 || k1->op_type == OP_GLOB
3603 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3604 || k1->op_type == OP_EACH)
3605 expr = newUNOP(OP_DEFINED, 0, expr);
3611 block = newOP(OP_NULL, 0);
3613 block = scope(block);
3617 next = LINKLIST(cont);
3620 OP *unstack = newOP(OP_UNSTACK, 0);
3623 cont = append_elem(OP_LINESEQ, cont, unstack);
3626 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3627 redo = LINKLIST(listop);
3630 PL_copline = (line_t)whileline;
3632 o = new_logop(OP_AND, 0, &expr, &listop);
3633 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3634 op_free(expr); /* oops, it's a while (0) */
3636 return Nullop; /* listop already freed by new_logop */
3639 ((LISTOP*)listop)->op_last->op_next =
3640 (o == listop ? redo : LINKLIST(o));
3646 NewOp(1101,loop,1,LOOP);
3647 loop->op_type = OP_ENTERLOOP;
3648 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3649 loop->op_private = 0;
3650 loop->op_next = (OP*)loop;
3653 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3655 loop->op_redoop = redo;
3656 loop->op_lastop = o;
3657 o->op_private |= loopflags;
3660 loop->op_nextop = next;
3662 loop->op_nextop = o;
3664 o->op_flags |= flags;
3665 o->op_private |= (flags >> 8);
3670 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
3674 PADOFFSET padoff = 0;
3679 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
3680 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
3681 sv->op_type = OP_RV2GV;
3682 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3684 else if (sv->op_type == OP_PADSV) { /* private variable */
3685 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
3686 padoff = sv->op_targ;
3691 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3692 padoff = sv->op_targ;
3694 iterflags |= OPf_SPECIAL;
3699 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3702 sv = newGVOP(OP_GV, 0, PL_defgv);
3704 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3705 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3706 iterflags |= OPf_STACKED;
3708 else if (expr->op_type == OP_NULL &&
3709 (expr->op_flags & OPf_KIDS) &&
3710 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3712 /* Basically turn for($x..$y) into the same as for($x,$y), but we
3713 * set the STACKED flag to indicate that these values are to be
3714 * treated as min/max values by 'pp_iterinit'.
3716 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
3717 LOGOP* range = (LOGOP*) flip->op_first;
3718 OP* left = range->op_first;
3719 OP* right = left->op_sibling;
3722 range->op_flags &= ~OPf_KIDS;
3723 range->op_first = Nullop;
3725 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
3726 listop->op_first->op_next = range->op_next;
3727 left->op_next = range->op_other;
3728 right->op_next = (OP*)listop;
3729 listop->op_next = listop->op_first;
3732 expr = (OP*)(listop);
3734 iterflags |= OPf_STACKED;
3737 expr = mod(force_list(expr), OP_GREPSTART);
3741 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
3742 append_elem(OP_LIST, expr, scalar(sv))));
3743 assert(!loop->op_next);
3744 /* for my $x () sets OPpLVAL_INTRO;
3745 * for our $x () sets OPpOUR_INTRO */
3746 loop->op_private = (U8)iterpflags;
3747 #ifdef PL_OP_SLAB_ALLOC
3750 NewOp(1234,tmp,1,LOOP);
3751 Copy(loop,tmp,1,LOOP);
3756 Renew(loop, 1, LOOP);
3758 loop->op_targ = padoff;
3759 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
3760 PL_copline = forline;
3761 return newSTATEOP(0, label, wop);
3765 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
3770 if (type != OP_GOTO || label->op_type == OP_CONST) {
3771 /* "last()" means "last" */
3772 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
3773 o = newOP(type, OPf_SPECIAL);
3775 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
3776 ? SvPVx(((SVOP*)label)->op_sv, n_a)
3782 if (label->op_type == OP_ENTERSUB)
3783 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
3784 o = newUNOP(type, OPf_STACKED, label);
3786 PL_hints |= HINT_BLOCK_SCOPE;
3790 static void const_sv_xsub(pTHX_ CV* cv);
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) || CvXSUB(cv) == const_sv_xsub)) {
3808 /* for XSUBs CvFILE point directly to static memory; __FILE__
3809 * except when XSUB was constructed via newCONSTSUB() */
3810 Safefree(CvFILE(cv));
3815 if (!CvXSUB(cv) && CvROOT(cv)) {
3817 Perl_croak(aTHX_ "Can't undef active subroutine");
3820 PAD_SAVE_SETNULLPAD();
3822 op_free(CvROOT(cv));
3823 CvROOT(cv) = Nullop;
3826 SvPOK_off((SV*)cv); /* forget prototype */
3831 /* remove CvOUTSIDE unless this is an undef rather than a free */
3832 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
3833 if (!CvWEAKOUTSIDE(cv))
3834 SvREFCNT_dec(CvOUTSIDE(cv));
3835 CvOUTSIDE(cv) = Nullcv;
3838 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
3844 /* delete all flags except WEAKOUTSIDE */
3845 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
3849 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
3851 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
3852 SV* msg = sv_newmortal();
3856 gv_efullname3(name = sv_newmortal(), gv, Nullch);
3857 sv_setpv(msg, "Prototype mismatch:");
3859 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
3861 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (SV *)cv);
3862 sv_catpv(msg, " vs ");
3864 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
3866 sv_catpv(msg, "none");
3867 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
3873 =head1 Optree Manipulation Functions
3875 =for apidoc cv_const_sv
3877 If C<cv> is a constant sub eligible for inlining. returns the constant
3878 value returned by the sub. Otherwise, returns NULL.
3880 Constant subs can be created with C<newCONSTSUB> or as described in
3881 L<perlsub/"Constant Functions">.
3886 Perl_cv_const_sv(pTHX_ CV *cv)
3888 if (!cv || !CvCONST(cv))
3890 return (SV*)CvXSUBANY(cv).any_ptr;
3893 /* op_const_sv: examine an optree to determine whether it's in-lineable.
3894 * Can be called in 3 ways:
3897 * look for a single OP_CONST with attached value: return the value
3899 * cv && CvCLONE(cv) && !CvCONST(cv)
3901 * examine the clone prototype, and if contains only a single
3902 * OP_CONST referencing a pad const, or a single PADSV referencing
3903 * an outer lexical, return a non-zero value to indicate the CV is
3904 * a candidate for "constizing" at clone time
3908 * We have just cloned an anon prototype that was marked as a const
3909 * candidiate. Try to grab the current value, and in the case of
3910 * PADSV, ignore it if it has multiple references. Return the value.
3914 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
3921 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
3922 o = cLISTOPo->op_first->op_sibling;
3924 for (; o; o = o->op_next) {
3925 OPCODE type = o->op_type;
3927 if (sv && o->op_next == o)
3929 if (o->op_next != o) {
3930 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
3932 if (type == OP_DBSTATE)
3935 if (type == OP_LEAVESUB || type == OP_RETURN)
3939 if (type == OP_CONST && cSVOPo->op_sv)
3941 else if (cv && type == OP_CONST) {
3942 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
3946 else if (cv && type == OP_PADSV) {
3947 if (CvCONST(cv)) { /* newly cloned anon */
3948 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
3949 /* the candidate should have 1 ref from this pad and 1 ref
3950 * from the parent */
3951 if (!sv || SvREFCNT(sv) != 2)
3958 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
3959 sv = &PL_sv_undef; /* an arbitrary non-null value */
3970 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
3980 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
3984 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
3986 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
3990 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
3996 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4000 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4001 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4002 SV *sv = sv_newmortal();
4003 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4004 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4005 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4010 gv = gv_fetchpv(name ? name : (aname ? aname :
4011 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__")),
4012 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4022 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4023 maximum a prototype before. */
4024 if (SvTYPE(gv) > SVt_NULL) {
4025 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4026 && ckWARN_d(WARN_PROTOTYPE))
4028 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4030 cv_ckproto((CV*)gv, NULL, ps);
4033 sv_setpv((SV*)gv, ps);
4035 sv_setiv((SV*)gv, -1);
4036 SvREFCNT_dec(PL_compcv);
4037 cv = PL_compcv = NULL;
4038 PL_sub_generation++;
4042 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4044 #ifdef GV_UNIQUE_CHECK
4045 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4046 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4050 if (!block || !ps || *ps || attrs)
4053 const_sv = op_const_sv(block, Nullcv);
4056 bool exists = CvROOT(cv) || CvXSUB(cv);
4058 #ifdef GV_UNIQUE_CHECK
4059 if (exists && GvUNIQUE(gv)) {
4060 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4064 /* if the subroutine doesn't exist and wasn't pre-declared
4065 * with a prototype, assume it will be AUTOLOADed,
4066 * skipping the prototype check
4068 if (exists || SvPOK(cv))
4069 cv_ckproto(cv, gv, ps);
4070 /* already defined (or promised)? */
4071 if (exists || GvASSUMECV(gv)) {
4072 if (!block && !attrs) {
4073 if (CvFLAGS(PL_compcv)) {
4074 /* might have had built-in attrs applied */
4075 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4077 /* just a "sub foo;" when &foo is already defined */
4078 SAVEFREESV(PL_compcv);
4081 /* ahem, death to those who redefine active sort subs */
4082 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4083 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4085 if (ckWARN(WARN_REDEFINE)
4087 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4089 line_t oldline = CopLINE(PL_curcop);
4090 if (PL_copline != NOLINE)
4091 CopLINE_set(PL_curcop, PL_copline);
4092 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4093 CvCONST(cv) ? "Constant subroutine %s redefined"
4094 : "Subroutine %s redefined", name);
4095 CopLINE_set(PL_curcop, oldline);
4103 SvREFCNT_inc(const_sv);
4105 assert(!CvROOT(cv) && !CvCONST(cv));
4106 sv_setpv((SV*)cv, ""); /* prototype is "" */
4107 CvXSUBANY(cv).any_ptr = const_sv;
4108 CvXSUB(cv) = const_sv_xsub;
4113 cv = newCONSTSUB(NULL, name, const_sv);
4116 SvREFCNT_dec(PL_compcv);
4118 PL_sub_generation++;
4125 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4126 * before we clobber PL_compcv.
4130 /* Might have had built-in attributes applied -- propagate them. */
4131 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4132 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4133 stash = GvSTASH(CvGV(cv));
4134 else if (CvSTASH(cv))
4135 stash = CvSTASH(cv);
4137 stash = PL_curstash;
4140 /* possibly about to re-define existing subr -- ignore old cv */
4141 rcv = (SV*)PL_compcv;
4142 if (name && GvSTASH(gv))
4143 stash = GvSTASH(gv);
4145 stash = PL_curstash;
4147 apply_attrs(stash, rcv, attrs, FALSE);
4149 if (cv) { /* must reuse cv if autoloaded */
4151 /* got here with just attrs -- work done, so bug out */
4152 SAVEFREESV(PL_compcv);
4155 /* transfer PL_compcv to cv */
4157 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4158 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4159 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4160 CvOUTSIDE(PL_compcv) = 0;
4161 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4162 CvPADLIST(PL_compcv) = 0;
4163 /* inner references to PL_compcv must be fixed up ... */
4164 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4165 /* ... before we throw it away */
4166 SvREFCNT_dec(PL_compcv);
4168 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4169 ++PL_sub_generation;
4176 PL_sub_generation++;
4180 CvFILE_set_from_cop(cv, PL_curcop);
4181 CvSTASH(cv) = PL_curstash;
4184 sv_setpv((SV*)cv, ps);
4186 if (PL_error_count) {
4190 char *s = strrchr(name, ':');
4192 if (strEQ(s, "BEGIN")) {
4194 "BEGIN not safe after errors--compilation aborted";
4195 if (PL_in_eval & EVAL_KEEPERR)
4196 Perl_croak(aTHX_ not_safe);
4198 /* force display of errors found but not reported */
4199 sv_catpv(ERRSV, not_safe);
4200 Perl_croak(aTHX_ "%"SVf, ERRSV);
4209 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4210 mod(scalarseq(block), OP_LEAVESUBLV));
4213 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4215 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4216 OpREFCNT_set(CvROOT(cv), 1);
4217 CvSTART(cv) = LINKLIST(CvROOT(cv));
4218 CvROOT(cv)->op_next = 0;
4219 CALL_PEEP(CvSTART(cv));
4221 /* now that optimizer has done its work, adjust pad values */
4223 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4226 assert(!CvCONST(cv));
4227 if (ps && !*ps && op_const_sv(block, cv))
4231 if (name || aname) {
4233 char *tname = (name ? name : aname);
4235 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4236 SV *sv = NEWSV(0,0);
4237 SV *tmpstr = sv_newmortal();
4238 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4242 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4244 (long)PL_subline, (long)CopLINE(PL_curcop));
4245 gv_efullname3(tmpstr, gv, Nullch);
4246 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4247 hv = GvHVn(db_postponed);
4248 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4249 && (pcv = GvCV(db_postponed)))
4255 call_sv((SV*)pcv, G_DISCARD);
4259 if ((s = strrchr(tname,':')))
4264 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4267 if (strEQ(s, "BEGIN") && !PL_error_count) {
4268 I32 oldscope = PL_scopestack_ix;
4270 SAVECOPFILE(&PL_compiling);
4271 SAVECOPLINE(&PL_compiling);
4274 PL_beginav = newAV();
4275 DEBUG_x( dump_sub(gv) );
4276 av_push(PL_beginav, (SV*)cv);
4277 GvCV(gv) = 0; /* cv has been hijacked */
4278 call_list(oldscope, PL_beginav);
4280 PL_curcop = &PL_compiling;
4281 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4284 else if (strEQ(s, "END") && !PL_error_count) {
4287 DEBUG_x( dump_sub(gv) );
4288 av_unshift(PL_endav, 1);
4289 av_store(PL_endav, 0, (SV*)cv);
4290 GvCV(gv) = 0; /* cv has been hijacked */
4292 else if (strEQ(s, "CHECK") && !PL_error_count) {
4294 PL_checkav = newAV();
4295 DEBUG_x( dump_sub(gv) );
4296 if (PL_main_start && ckWARN(WARN_VOID))
4297 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4298 av_unshift(PL_checkav, 1);
4299 av_store(PL_checkav, 0, (SV*)cv);
4300 GvCV(gv) = 0; /* cv has been hijacked */
4302 else if (strEQ(s, "INIT") && !PL_error_count) {
4304 PL_initav = newAV();
4305 DEBUG_x( dump_sub(gv) );
4306 if (PL_main_start && ckWARN(WARN_VOID))
4307 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4308 av_push(PL_initav, (SV*)cv);
4309 GvCV(gv) = 0; /* cv has been hijacked */
4314 PL_copline = NOLINE;
4319 /* XXX unsafe for threads if eval_owner isn't held */
4321 =for apidoc newCONSTSUB
4323 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4324 eligible for inlining at compile-time.
4330 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4336 SAVECOPLINE(PL_curcop);
4337 CopLINE_set(PL_curcop, PL_copline);
4340 PL_hints &= ~HINT_BLOCK_SCOPE;
4343 SAVESPTR(PL_curstash);
4344 SAVECOPSTASH(PL_curcop);
4345 PL_curstash = stash;
4346 CopSTASH_set(PL_curcop,stash);
4349 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4350 CvXSUBANY(cv).any_ptr = sv;
4352 sv_setpv((SV*)cv, ""); /* prototype is "" */
4355 CopSTASH_free(PL_curcop);
4363 =for apidoc U||newXS
4365 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4371 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
4373 GV *gv = gv_fetchpv(name ? name :
4374 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4375 GV_ADDMULTI, SVt_PVCV);
4379 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4381 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4383 /* just a cached method */
4387 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4388 /* already defined (or promised) */
4389 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4390 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4391 line_t oldline = CopLINE(PL_curcop);
4392 if (PL_copline != NOLINE)
4393 CopLINE_set(PL_curcop, PL_copline);
4394 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4395 CvCONST(cv) ? "Constant subroutine %s redefined"
4396 : "Subroutine %s redefined"
4398 CopLINE_set(PL_curcop, oldline);
4405 if (cv) /* must reuse cv if autoloaded */
4408 cv = (CV*)NEWSV(1105,0);
4409 sv_upgrade((SV *)cv, SVt_PVCV);
4413 PL_sub_generation++;
4417 (void)gv_fetchfile(filename);
4418 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
4419 an external constant string */
4420 CvXSUB(cv) = subaddr;
4423 char *s = strrchr(name,':');
4429 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4432 if (strEQ(s, "BEGIN")) {
4434 PL_beginav = newAV();
4435 av_push(PL_beginav, (SV*)cv);
4436 GvCV(gv) = 0; /* cv has been hijacked */
4438 else if (strEQ(s, "END")) {
4441 av_unshift(PL_endav, 1);
4442 av_store(PL_endav, 0, (SV*)cv);
4443 GvCV(gv) = 0; /* cv has been hijacked */
4445 else if (strEQ(s, "CHECK")) {
4447 PL_checkav = newAV();
4448 if (PL_main_start && ckWARN(WARN_VOID))
4449 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4450 av_unshift(PL_checkav, 1);
4451 av_store(PL_checkav, 0, (SV*)cv);
4452 GvCV(gv) = 0; /* cv has been hijacked */
4454 else if (strEQ(s, "INIT")) {
4456 PL_initav = newAV();
4457 if (PL_main_start && ckWARN(WARN_VOID))
4458 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4459 av_push(PL_initav, (SV*)cv);
4460 GvCV(gv) = 0; /* cv has been hijacked */
4471 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4479 name = SvPVx(cSVOPo->op_sv, n_a);
4482 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
4483 #ifdef GV_UNIQUE_CHECK
4485 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4489 if ((cv = GvFORM(gv))) {
4490 if (ckWARN(WARN_REDEFINE)) {
4491 line_t oldline = CopLINE(PL_curcop);
4492 if (PL_copline != NOLINE)
4493 CopLINE_set(PL_curcop, PL_copline);
4494 Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Format %s redefined",name);
4495 CopLINE_set(PL_curcop, oldline);
4502 CvFILE_set_from_cop(cv, PL_curcop);
4505 pad_tidy(padtidy_FORMAT);
4506 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4507 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4508 OpREFCNT_set(CvROOT(cv), 1);
4509 CvSTART(cv) = LINKLIST(CvROOT(cv));
4510 CvROOT(cv)->op_next = 0;
4511 CALL_PEEP(CvSTART(cv));
4513 PL_copline = NOLINE;
4518 Perl_newANONLIST(pTHX_ OP *o)
4520 return newUNOP(OP_REFGEN, 0,
4521 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4525 Perl_newANONHASH(pTHX_ OP *o)
4527 return newUNOP(OP_REFGEN, 0,
4528 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4532 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4534 return newANONATTRSUB(floor, proto, Nullop, block);
4538 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4540 return newUNOP(OP_REFGEN, 0,
4541 newSVOP(OP_ANONCODE, 0,
4542 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
4546 Perl_oopsAV(pTHX_ OP *o)
4548 switch (o->op_type) {
4550 o->op_type = OP_PADAV;
4551 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4552 return ref(o, OP_RV2AV);
4555 o->op_type = OP_RV2AV;
4556 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4561 if (ckWARN_d(WARN_INTERNAL))
4562 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
4569 Perl_oopsHV(pTHX_ OP *o)
4571 switch (o->op_type) {
4574 o->op_type = OP_PADHV;
4575 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4576 return ref(o, OP_RV2HV);
4580 o->op_type = OP_RV2HV;
4581 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
4586 if (ckWARN_d(WARN_INTERNAL))
4587 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
4594 Perl_newAVREF(pTHX_ OP *o)
4596 if (o->op_type == OP_PADANY) {
4597 o->op_type = OP_PADAV;
4598 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4601 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
4602 && ckWARN(WARN_DEPRECATED)) {
4603 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4604 "Using an array as a reference is deprecated");
4606 return newUNOP(OP_RV2AV, 0, scalar(o));
4610 Perl_newGVREF(pTHX_ I32 type, OP *o)
4612 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
4613 return newUNOP(OP_NULL, 0, o);
4614 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
4618 Perl_newHVREF(pTHX_ OP *o)
4620 if (o->op_type == OP_PADANY) {
4621 o->op_type = OP_PADHV;
4622 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4625 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
4626 && ckWARN(WARN_DEPRECATED)) {
4627 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4628 "Using a hash as a reference is deprecated");
4630 return newUNOP(OP_RV2HV, 0, scalar(o));
4634 Perl_oopsCV(pTHX_ OP *o)
4636 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
4642 Perl_newCVREF(pTHX_ I32 flags, OP *o)
4644 return newUNOP(OP_RV2CV, flags, scalar(o));
4648 Perl_newSVREF(pTHX_ OP *o)
4650 if (o->op_type == OP_PADANY) {
4651 o->op_type = OP_PADSV;
4652 o->op_ppaddr = PL_ppaddr[OP_PADSV];
4655 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4656 o->op_flags |= OPpDONE_SVREF;
4659 return newUNOP(OP_RV2SV, 0, scalar(o));
4662 /* Check routines. */
4665 Perl_ck_anoncode(pTHX_ OP *o)
4667 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
4668 cSVOPo->op_sv = Nullsv;
4673 Perl_ck_bitop(pTHX_ OP *o)
4675 #define OP_IS_NUMCOMPARE(op) \
4676 ((op) == OP_LT || (op) == OP_I_LT || \
4677 (op) == OP_GT || (op) == OP_I_GT || \
4678 (op) == OP_LE || (op) == OP_I_LE || \
4679 (op) == OP_GE || (op) == OP_I_GE || \
4680 (op) == OP_EQ || (op) == OP_I_EQ || \
4681 (op) == OP_NE || (op) == OP_I_NE || \
4682 (op) == OP_NCMP || (op) == OP_I_NCMP)
4683 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4684 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
4685 && (o->op_type == OP_BIT_OR
4686 || o->op_type == OP_BIT_AND
4687 || o->op_type == OP_BIT_XOR))
4689 OP * left = cBINOPo->op_first;
4690 OP * right = left->op_sibling;
4691 if ((OP_IS_NUMCOMPARE(left->op_type) &&
4692 (left->op_flags & OPf_PARENS) == 0) ||
4693 (OP_IS_NUMCOMPARE(right->op_type) &&
4694 (right->op_flags & OPf_PARENS) == 0))
4695 if (ckWARN(WARN_PRECEDENCE))
4696 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4697 "Possible precedence problem on bitwise %c operator",
4698 o->op_type == OP_BIT_OR ? '|'
4699 : o->op_type == OP_BIT_AND ? '&' : '^'
4706 Perl_ck_concat(pTHX_ OP *o)
4708 OP *kid = cUNOPo->op_first;
4709 if (kid->op_type == OP_CONCAT && !(kUNOP->op_first->op_flags & OPf_MOD))
4710 o->op_flags |= OPf_STACKED;
4715 Perl_ck_spair(pTHX_ OP *o)
4717 if (o->op_flags & OPf_KIDS) {
4720 OPCODE type = o->op_type;
4721 o = modkids(ck_fun(o), type);
4722 kid = cUNOPo->op_first;
4723 newop = kUNOP->op_first->op_sibling;
4725 (newop->op_sibling ||
4726 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
4727 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
4728 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
4732 op_free(kUNOP->op_first);
4733 kUNOP->op_first = newop;
4735 o->op_ppaddr = PL_ppaddr[++o->op_type];
4740 Perl_ck_delete(pTHX_ OP *o)
4744 if (o->op_flags & OPf_KIDS) {
4745 OP *kid = cUNOPo->op_first;
4746 switch (kid->op_type) {
4748 o->op_flags |= OPf_SPECIAL;
4751 o->op_private |= OPpSLICE;
4754 o->op_flags |= OPf_SPECIAL;
4759 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
4768 Perl_ck_die(pTHX_ OP *o)
4771 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4777 Perl_ck_eof(pTHX_ OP *o)
4779 I32 type = o->op_type;
4781 if (o->op_flags & OPf_KIDS) {
4782 if (cLISTOPo->op_first->op_type == OP_STUB) {
4784 o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
4792 Perl_ck_eval(pTHX_ OP *o)
4794 PL_hints |= HINT_BLOCK_SCOPE;
4795 if (o->op_flags & OPf_KIDS) {
4796 SVOP *kid = (SVOP*)cUNOPo->op_first;
4799 o->op_flags &= ~OPf_KIDS;
4802 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
4805 cUNOPo->op_first = 0;
4808 NewOp(1101, enter, 1, LOGOP);
4809 enter->op_type = OP_ENTERTRY;
4810 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
4811 enter->op_private = 0;
4813 /* establish postfix order */
4814 enter->op_next = (OP*)enter;
4816 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
4817 o->op_type = OP_LEAVETRY;
4818 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
4819 enter->op_other = o;
4829 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
4831 o->op_targ = (PADOFFSET)PL_hints;
4836 Perl_ck_exit(pTHX_ OP *o)
4839 HV *table = GvHV(PL_hintgv);
4841 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
4842 if (svp && *svp && SvTRUE(*svp))
4843 o->op_private |= OPpEXIT_VMSISH;
4845 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4851 Perl_ck_exec(pTHX_ OP *o)
4854 if (o->op_flags & OPf_STACKED) {
4856 kid = cUNOPo->op_first->op_sibling;
4857 if (kid->op_type == OP_RV2GV)
4866 Perl_ck_exists(pTHX_ OP *o)
4869 if (o->op_flags & OPf_KIDS) {
4870 OP *kid = cUNOPo->op_first;
4871 if (kid->op_type == OP_ENTERSUB) {
4872 (void) ref(kid, o->op_type);
4873 if (kid->op_type != OP_RV2CV && !PL_error_count)
4874 Perl_croak(aTHX_ "%s argument is not a subroutine name",
4876 o->op_private |= OPpEXISTS_SUB;
4878 else if (kid->op_type == OP_AELEM)
4879 o->op_flags |= OPf_SPECIAL;
4880 else if (kid->op_type != OP_HELEM)
4881 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
4890 Perl_ck_gvconst(pTHX_ register OP *o)
4892 o = fold_constants(o);
4893 if (o->op_type == OP_CONST)
4900 Perl_ck_rvconst(pTHX_ register OP *o)
4902 SVOP *kid = (SVOP*)cUNOPo->op_first;
4904 o->op_private |= (PL_hints & HINT_STRICT_REFS);
4905 if (kid->op_type == OP_CONST) {
4909 SV *kidsv = kid->op_sv;
4912 /* Is it a constant from cv_const_sv()? */
4913 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
4914 SV *rsv = SvRV(kidsv);
4915 int svtype = SvTYPE(rsv);
4916 char *badtype = Nullch;
4918 switch (o->op_type) {
4920 if (svtype > SVt_PVMG)
4921 badtype = "a SCALAR";
4924 if (svtype != SVt_PVAV)
4925 badtype = "an ARRAY";
4928 if (svtype != SVt_PVHV)
4932 if (svtype != SVt_PVCV)
4937 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
4940 name = SvPV(kidsv, n_a);
4941 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
4942 char *badthing = Nullch;
4943 switch (o->op_type) {
4945 badthing = "a SCALAR";
4948 badthing = "an ARRAY";
4951 badthing = "a HASH";
4956 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
4960 * This is a little tricky. We only want to add the symbol if we
4961 * didn't add it in the lexer. Otherwise we get duplicate strict
4962 * warnings. But if we didn't add it in the lexer, we must at
4963 * least pretend like we wanted to add it even if it existed before,
4964 * or we get possible typo warnings. OPpCONST_ENTERED says
4965 * whether the lexer already added THIS instance of this symbol.
4967 iscv = (o->op_type == OP_RV2CV) * 2;
4969 gv = gv_fetchpv(name,
4970 iscv | !(kid->op_private & OPpCONST_ENTERED),
4973 : o->op_type == OP_RV2SV
4975 : o->op_type == OP_RV2AV
4977 : o->op_type == OP_RV2HV
4980 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
4982 kid->op_type = OP_GV;
4983 SvREFCNT_dec(kid->op_sv);
4985 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
4986 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
4987 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
4989 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
4991 kid->op_sv = SvREFCNT_inc(gv);
4993 kid->op_private = 0;
4994 kid->op_ppaddr = PL_ppaddr[OP_GV];
5001 Perl_ck_ftst(pTHX_ OP *o)
5003 I32 type = o->op_type;
5005 if (o->op_flags & OPf_REF) {
5008 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5009 SVOP *kid = (SVOP*)cUNOPo->op_first;
5011 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5013 OP *newop = newGVOP(type, OPf_REF,
5014 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5019 if ((PL_hints & HINT_FILETEST_ACCESS) &&
5020 OP_IS_FILETEST_ACCESS(o))
5021 o->op_private |= OPpFT_ACCESS;
5026 if (type == OP_FTTTY)
5027 o = newGVOP(type, OPf_REF, PL_stdingv);
5029 o = newUNOP(type, 0, newDEFSVOP());
5035 Perl_ck_fun(pTHX_ OP *o)
5041 int type = o->op_type;
5042 register I32 oa = PL_opargs[type] >> OASHIFT;
5044 if (o->op_flags & OPf_STACKED) {
5045 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5048 return no_fh_allowed(o);
5051 if (o->op_flags & OPf_KIDS) {
5053 tokid = &cLISTOPo->op_first;
5054 kid = cLISTOPo->op_first;
5055 if (kid->op_type == OP_PUSHMARK ||
5056 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5058 tokid = &kid->op_sibling;
5059 kid = kid->op_sibling;
5061 if (!kid && PL_opargs[type] & OA_DEFGV)
5062 *tokid = kid = newDEFSVOP();
5066 sibl = kid->op_sibling;
5069 /* list seen where single (scalar) arg expected? */
5070 if (numargs == 1 && !(oa >> 4)
5071 && kid->op_type == OP_LIST && type != OP_SCALAR)
5073 return too_many_arguments(o,PL_op_desc[type]);
5086 if ((type == OP_PUSH || type == OP_UNSHIFT)
5087 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5088 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5089 "Useless use of %s with no values",
5092 if (kid->op_type == OP_CONST &&
5093 (kid->op_private & OPpCONST_BARE))
5095 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5096 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5097 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5098 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5099 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5100 "Array @%s missing the @ in argument %"IVdf" of %s()",
5101 name, (IV)numargs, PL_op_desc[type]);
5104 kid->op_sibling = sibl;
5107 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5108 bad_type(numargs, "array", PL_op_desc[type], kid);
5112 if (kid->op_type == OP_CONST &&
5113 (kid->op_private & OPpCONST_BARE))
5115 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5116 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5117 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5118 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5119 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5120 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5121 name, (IV)numargs, PL_op_desc[type]);
5124 kid->op_sibling = sibl;
5127 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5128 bad_type(numargs, "hash", PL_op_desc[type], kid);
5133 OP *newop = newUNOP(OP_NULL, 0, kid);
5134 kid->op_sibling = 0;
5136 newop->op_next = newop;
5138 kid->op_sibling = sibl;
5143 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5144 if (kid->op_type == OP_CONST &&
5145 (kid->op_private & OPpCONST_BARE))
5147 OP *newop = newGVOP(OP_GV, 0,
5148 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5150 if (!(o->op_private & 1) && /* if not unop */
5151 kid == cLISTOPo->op_last)
5152 cLISTOPo->op_last = newop;
5156 else if (kid->op_type == OP_READLINE) {
5157 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5158 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5161 I32 flags = OPf_SPECIAL;
5165 /* is this op a FH constructor? */
5166 if (is_handle_constructor(o,numargs)) {
5167 char *name = Nullch;
5171 /* Set a flag to tell rv2gv to vivify
5172 * need to "prove" flag does not mean something
5173 * else already - NI-S 1999/05/07
5176 if (kid->op_type == OP_PADSV) {
5177 name = PAD_COMPNAME_PV(kid->op_targ);
5178 /* SvCUR of a pad namesv can't be trusted
5179 * (see PL_generation), so calc its length
5185 else if (kid->op_type == OP_RV2SV
5186 && kUNOP->op_first->op_type == OP_GV)
5188 GV *gv = cGVOPx_gv(kUNOP->op_first);
5190 len = GvNAMELEN(gv);
5192 else if (kid->op_type == OP_AELEM
5193 || kid->op_type == OP_HELEM)
5198 if ((op = ((BINOP*)kid)->op_first)) {
5199 SV *tmpstr = Nullsv;
5201 kid->op_type == OP_AELEM ?
5203 if (((op->op_type == OP_RV2AV) ||
5204 (op->op_type == OP_RV2HV)) &&
5205 (op = ((UNOP*)op)->op_first) &&
5206 (op->op_type == OP_GV)) {
5207 /* packagevar $a[] or $h{} */
5208 GV *gv = cGVOPx_gv(op);
5216 else if (op->op_type == OP_PADAV
5217 || op->op_type == OP_PADHV) {
5218 /* lexicalvar $a[] or $h{} */
5220 PAD_COMPNAME_PV(op->op_targ);
5230 name = savepv(SvPVX(tmpstr));
5236 name = "__ANONIO__";
5243 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5244 namesv = PAD_SVl(targ);
5245 (void)SvUPGRADE(namesv, SVt_PV);
5247 sv_setpvn(namesv, "$", 1);
5248 sv_catpvn(namesv, name, len);
5251 kid->op_sibling = 0;
5252 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5253 kid->op_targ = targ;
5254 kid->op_private |= priv;
5256 kid->op_sibling = sibl;
5262 mod(scalar(kid), type);
5266 tokid = &kid->op_sibling;
5267 kid = kid->op_sibling;
5269 o->op_private |= numargs;
5271 return too_many_arguments(o,OP_DESC(o));
5274 else if (PL_opargs[type] & OA_DEFGV) {
5276 return newUNOP(type, 0, newDEFSVOP());
5280 while (oa & OA_OPTIONAL)
5282 if (oa && oa != OA_LIST)
5283 return too_few_arguments(o,OP_DESC(o));
5289 Perl_ck_glob(pTHX_ OP *o)
5294 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5295 append_elem(OP_GLOB, o, newDEFSVOP());
5297 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5298 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5300 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5303 #if !defined(PERL_EXTERNAL_GLOB)
5304 /* XXX this can be tightened up and made more failsafe. */
5305 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5308 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5309 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5310 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5311 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5312 GvCV(gv) = GvCV(glob_gv);
5313 SvREFCNT_inc((SV*)GvCV(gv));
5314 GvIMPORTED_CV_on(gv);
5317 #endif /* PERL_EXTERNAL_GLOB */
5319 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5320 append_elem(OP_GLOB, o,
5321 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5322 o->op_type = OP_LIST;
5323 o->op_ppaddr = PL_ppaddr[OP_LIST];
5324 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5325 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5326 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5327 append_elem(OP_LIST, o,
5328 scalar(newUNOP(OP_RV2CV, 0,
5329 newGVOP(OP_GV, 0, gv)))));
5330 o = newUNOP(OP_NULL, 0, ck_subr(o));
5331 o->op_targ = OP_GLOB; /* hint at what it used to be */
5334 gv = newGVgen("main");
5336 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5342 Perl_ck_grep(pTHX_ OP *o)
5346 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5348 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5349 NewOp(1101, gwop, 1, LOGOP);
5351 if (o->op_flags & OPf_STACKED) {
5354 kid = cLISTOPo->op_first->op_sibling;
5355 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5358 kid->op_next = (OP*)gwop;
5359 o->op_flags &= ~OPf_STACKED;
5361 kid = cLISTOPo->op_first->op_sibling;
5362 if (type == OP_MAPWHILE)
5369 kid = cLISTOPo->op_first->op_sibling;
5370 if (kid->op_type != OP_NULL)
5371 Perl_croak(aTHX_ "panic: ck_grep");
5372 kid = kUNOP->op_first;
5374 gwop->op_type = type;
5375 gwop->op_ppaddr = PL_ppaddr[type];
5376 gwop->op_first = listkids(o);
5377 gwop->op_flags |= OPf_KIDS;
5378 gwop->op_private = 1;
5379 gwop->op_other = LINKLIST(kid);
5380 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5381 kid->op_next = (OP*)gwop;
5383 kid = cLISTOPo->op_first->op_sibling;
5384 if (!kid || !kid->op_sibling)
5385 return too_few_arguments(o,OP_DESC(o));
5386 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5387 mod(kid, OP_GREPSTART);
5393 Perl_ck_index(pTHX_ OP *o)
5395 if (o->op_flags & OPf_KIDS) {
5396 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5398 kid = kid->op_sibling; /* get past "big" */
5399 if (kid && kid->op_type == OP_CONST)
5400 fbm_compile(((SVOP*)kid)->op_sv, 0);
5406 Perl_ck_lengthconst(pTHX_ OP *o)
5408 /* XXX length optimization goes here */
5413 Perl_ck_lfun(pTHX_ OP *o)
5415 OPCODE type = o->op_type;
5416 return modkids(ck_fun(o), type);
5420 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5422 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5423 switch (cUNOPo->op_first->op_type) {
5425 /* This is needed for
5426 if (defined %stash::)
5427 to work. Do not break Tk.
5429 break; /* Globals via GV can be undef */
5431 case OP_AASSIGN: /* Is this a good idea? */
5432 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5433 "defined(@array) is deprecated");
5434 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5435 "\t(Maybe you should just omit the defined()?)\n");
5438 /* This is needed for
5439 if (defined %stash::)
5440 to work. Do not break Tk.
5442 break; /* Globals via GV can be undef */
5444 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5445 "defined(%%hash) is deprecated");
5446 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5447 "\t(Maybe you should just omit the defined()?)\n");
5458 Perl_ck_rfun(pTHX_ OP *o)
5460 OPCODE type = o->op_type;
5461 return refkids(ck_fun(o), type);
5465 Perl_ck_listiob(pTHX_ OP *o)
5469 kid = cLISTOPo->op_first;
5472 kid = cLISTOPo->op_first;
5474 if (kid->op_type == OP_PUSHMARK)
5475 kid = kid->op_sibling;
5476 if (kid && o->op_flags & OPf_STACKED)
5477 kid = kid->op_sibling;
5478 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5479 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5480 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5481 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5482 cLISTOPo->op_first->op_sibling = kid;
5483 cLISTOPo->op_last = kid;
5484 kid = kid->op_sibling;
5489 append_elem(o->op_type, o, newDEFSVOP());
5495 Perl_ck_sassign(pTHX_ OP *o)
5497 OP *kid = cLISTOPo->op_first;
5498 /* has a disposable target? */
5499 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5500 && !(kid->op_flags & OPf_STACKED)
5501 /* Cannot steal the second time! */
5502 && !(kid->op_private & OPpTARGET_MY))
5504 OP *kkid = kid->op_sibling;
5506 /* Can just relocate the target. */
5507 if (kkid && kkid->op_type == OP_PADSV
5508 && !(kkid->op_private & OPpLVAL_INTRO))
5510 kid->op_targ = kkid->op_targ;
5512 /* Now we do not need PADSV and SASSIGN. */
5513 kid->op_sibling = o->op_sibling; /* NULL */
5514 cLISTOPo->op_first = NULL;
5517 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
5525 Perl_ck_match(pTHX_ OP *o)
5527 o->op_private |= OPpRUNTIME;
5532 Perl_ck_method(pTHX_ OP *o)
5534 OP *kid = cUNOPo->op_first;
5535 if (kid->op_type == OP_CONST) {
5536 SV* sv = kSVOP->op_sv;
5537 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
5539 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5540 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
5543 kSVOP->op_sv = Nullsv;
5545 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5554 Perl_ck_null(pTHX_ OP *o)
5560 Perl_ck_open(pTHX_ OP *o)
5562 HV *table = GvHV(PL_hintgv);
5566 svp = hv_fetch(table, "open_IN", 7, FALSE);
5568 mode = mode_from_discipline(*svp);
5569 if (mode & O_BINARY)
5570 o->op_private |= OPpOPEN_IN_RAW;
5571 else if (mode & O_TEXT)
5572 o->op_private |= OPpOPEN_IN_CRLF;
5575 svp = hv_fetch(table, "open_OUT", 8, FALSE);
5577 mode = mode_from_discipline(*svp);
5578 if (mode & O_BINARY)
5579 o->op_private |= OPpOPEN_OUT_RAW;
5580 else if (mode & O_TEXT)
5581 o->op_private |= OPpOPEN_OUT_CRLF;
5584 if (o->op_type == OP_BACKTICK)
5587 /* In case of three-arg dup open remove strictness
5588 * from the last arg if it is a bareword. */
5589 OP *first = cLISTOPx(o)->op_first; /* The pushmark. */
5590 OP *last = cLISTOPx(o)->op_last; /* The bareword. */
5594 if ((last->op_type == OP_CONST) && /* The bareword. */
5595 (last->op_private & OPpCONST_BARE) &&
5596 (last->op_private & OPpCONST_STRICT) &&
5597 (oa = first->op_sibling) && /* The fh. */
5598 (oa = oa->op_sibling) && /* The mode. */
5599 SvPOK(((SVOP*)oa)->op_sv) &&
5600 (mode = SvPVX(((SVOP*)oa)->op_sv)) &&
5601 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
5602 (last == oa->op_sibling)) /* The bareword. */
5603 last->op_private &= ~OPpCONST_STRICT;
5609 Perl_ck_repeat(pTHX_ OP *o)
5611 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5612 o->op_private |= OPpREPEAT_DOLIST;
5613 cBINOPo->op_first = force_list(cBINOPo->op_first);
5621 Perl_ck_require(pTHX_ OP *o)
5625 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
5626 SVOP *kid = (SVOP*)cUNOPo->op_first;
5628 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5630 for (s = SvPVX(kid->op_sv); *s; s++) {
5631 if (*s == ':' && s[1] == ':') {
5633 Move(s+2, s+1, strlen(s+2)+1, char);
5634 --SvCUR(kid->op_sv);
5637 if (SvREADONLY(kid->op_sv)) {
5638 SvREADONLY_off(kid->op_sv);
5639 sv_catpvn(kid->op_sv, ".pm", 3);
5640 SvREADONLY_on(kid->op_sv);
5643 sv_catpvn(kid->op_sv, ".pm", 3);
5647 /* handle override, if any */
5648 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
5649 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
5650 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
5652 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5653 OP *kid = cUNOPo->op_first;
5654 cUNOPo->op_first = 0;
5656 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5657 append_elem(OP_LIST, kid,
5658 scalar(newUNOP(OP_RV2CV, 0,
5667 Perl_ck_return(pTHX_ OP *o)
5670 if (CvLVALUE(PL_compcv)) {
5671 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5672 mod(kid, OP_LEAVESUBLV);
5679 Perl_ck_retarget(pTHX_ OP *o)
5681 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5688 Perl_ck_select(pTHX_ OP *o)
5691 if (o->op_flags & OPf_KIDS) {
5692 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5693 if (kid && kid->op_sibling) {
5694 o->op_type = OP_SSELECT;
5695 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
5697 return fold_constants(o);
5701 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5702 if (kid && kid->op_type == OP_RV2GV)
5703 kid->op_private &= ~HINT_STRICT_REFS;
5708 Perl_ck_shift(pTHX_ OP *o)
5710 I32 type = o->op_type;
5712 if (!(o->op_flags & OPf_KIDS)) {
5716 argop = newUNOP(OP_RV2AV, 0,
5717 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
5718 return newUNOP(type, 0, scalar(argop));
5720 return scalar(modkids(ck_fun(o), type));
5724 Perl_ck_sort(pTHX_ OP *o)
5728 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
5730 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5731 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
5733 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
5735 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
5737 if (kid->op_type == OP_SCOPE) {
5741 else if (kid->op_type == OP_LEAVE) {
5742 if (o->op_type == OP_SORT) {
5743 op_null(kid); /* wipe out leave */
5746 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
5747 if (k->op_next == kid)
5749 /* don't descend into loops */
5750 else if (k->op_type == OP_ENTERLOOP
5751 || k->op_type == OP_ENTERITER)
5753 k = cLOOPx(k)->op_lastop;
5758 kid->op_next = 0; /* just disconnect the leave */
5759 k = kLISTOP->op_first;
5764 if (o->op_type == OP_SORT) {
5765 /* provide scalar context for comparison function/block */
5771 o->op_flags |= OPf_SPECIAL;
5773 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
5776 firstkid = firstkid->op_sibling;
5779 /* provide list context for arguments */
5780 if (o->op_type == OP_SORT)
5787 S_simplify_sort(pTHX_ OP *o)
5789 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5793 if (!(o->op_flags & OPf_STACKED))
5795 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
5796 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
5797 kid = kUNOP->op_first; /* get past null */
5798 if (kid->op_type != OP_SCOPE)
5800 kid = kLISTOP->op_last; /* get past scope */
5801 switch(kid->op_type) {
5809 k = kid; /* remember this node*/
5810 if (kBINOP->op_first->op_type != OP_RV2SV)
5812 kid = kBINOP->op_first; /* get past cmp */
5813 if (kUNOP->op_first->op_type != OP_GV)
5815 kid = kUNOP->op_first; /* get past rv2sv */
5817 if (GvSTASH(gv) != PL_curstash)
5819 if (strEQ(GvNAME(gv), "a"))
5821 else if (strEQ(GvNAME(gv), "b"))
5825 kid = k; /* back to cmp */
5826 if (kBINOP->op_last->op_type != OP_RV2SV)
5828 kid = kBINOP->op_last; /* down to 2nd arg */
5829 if (kUNOP->op_first->op_type != OP_GV)
5831 kid = kUNOP->op_first; /* get past rv2sv */
5833 if (GvSTASH(gv) != PL_curstash
5835 ? strNE(GvNAME(gv), "a")
5836 : strNE(GvNAME(gv), "b")))
5838 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
5840 o->op_private |= OPpSORT_REVERSE;
5841 if (k->op_type == OP_NCMP)
5842 o->op_private |= OPpSORT_NUMERIC;
5843 if (k->op_type == OP_I_NCMP)
5844 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
5845 kid = cLISTOPo->op_first->op_sibling;
5846 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
5847 op_free(kid); /* then delete it */
5851 Perl_ck_split(pTHX_ OP *o)
5855 if (o->op_flags & OPf_STACKED)
5856 return no_fh_allowed(o);
5858 kid = cLISTOPo->op_first;
5859 if (kid->op_type != OP_NULL)
5860 Perl_croak(aTHX_ "panic: ck_split");
5861 kid = kid->op_sibling;
5862 op_free(cLISTOPo->op_first);
5863 cLISTOPo->op_first = kid;
5865 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
5866 cLISTOPo->op_last = kid; /* There was only one element previously */
5869 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
5870 OP *sibl = kid->op_sibling;
5871 kid->op_sibling = 0;
5872 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
5873 if (cLISTOPo->op_first == cLISTOPo->op_last)
5874 cLISTOPo->op_last = kid;
5875 cLISTOPo->op_first = kid;
5876 kid->op_sibling = sibl;
5879 kid->op_type = OP_PUSHRE;
5880 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
5882 if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
5883 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
5884 "Use of /g modifier is meaningless in split");
5887 if (!kid->op_sibling)
5888 append_elem(OP_SPLIT, o, newDEFSVOP());
5890 kid = kid->op_sibling;
5893 if (!kid->op_sibling)
5894 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
5896 kid = kid->op_sibling;
5899 if (kid->op_sibling)
5900 return too_many_arguments(o,OP_DESC(o));
5906 Perl_ck_join(pTHX_ OP *o)
5908 if (ckWARN(WARN_SYNTAX)) {
5909 OP *kid = cLISTOPo->op_first->op_sibling;
5910 if (kid && kid->op_type == OP_MATCH) {
5911 char *pmstr = "STRING";
5912 if (PM_GETRE(kPMOP))
5913 pmstr = PM_GETRE(kPMOP)->precomp;
5914 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5915 "/%s/ should probably be written as \"%s\"",
5923 Perl_ck_subr(pTHX_ OP *o)
5925 OP *prev = ((cUNOPo->op_first->op_sibling)
5926 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
5927 OP *o2 = prev->op_sibling;
5934 I32 contextclass = 0;
5939 o->op_private |= OPpENTERSUB_HASTARG;
5940 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
5941 if (cvop->op_type == OP_RV2CV) {
5943 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
5944 op_null(cvop); /* disable rv2cv */
5945 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
5946 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
5947 GV *gv = cGVOPx_gv(tmpop);
5950 tmpop->op_private |= OPpEARLY_CV;
5953 namegv = CvANON(cv) ? gv : CvGV(cv);
5954 proto = SvPV((SV*)cv, n_a);
5956 if (CvASSERTION(cv)) {
5957 if (PL_hints & HINT_ASSERTING) {
5958 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
5959 o->op_private |= OPpENTERSUB_DB;
5963 if (ckWARN(WARN_ASSERTIONS) && !(PL_hints & HINT_ASSERTIONSSEEN)) {
5964 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
5965 "Impossible to activate assertion call");
5972 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
5973 if (o2->op_type == OP_CONST)
5974 o2->op_private &= ~OPpCONST_STRICT;
5975 else if (o2->op_type == OP_LIST) {
5976 OP *o = ((UNOP*)o2)->op_first->op_sibling;
5977 if (o && o->op_type == OP_CONST)
5978 o->op_private &= ~OPpCONST_STRICT;
5981 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5982 if (PERLDB_SUB && PL_curstash != PL_debstash)
5983 o->op_private |= OPpENTERSUB_DB;
5984 while (o2 != cvop) {
5988 return too_many_arguments(o, gv_ename(namegv));
6006 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6008 arg == 1 ? "block or sub {}" : "sub {}",
6009 gv_ename(namegv), o2);
6012 /* '*' allows any scalar type, including bareword */
6015 if (o2->op_type == OP_RV2GV)
6016 goto wrapref; /* autoconvert GLOB -> GLOBref */
6017 else if (o2->op_type == OP_CONST)
6018 o2->op_private &= ~OPpCONST_STRICT;
6019 else if (o2->op_type == OP_ENTERSUB) {
6020 /* accidental subroutine, revert to bareword */
6021 OP *gvop = ((UNOP*)o2)->op_first;
6022 if (gvop && gvop->op_type == OP_NULL) {
6023 gvop = ((UNOP*)gvop)->op_first;
6025 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6028 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6029 (gvop = ((UNOP*)gvop)->op_first) &&
6030 gvop->op_type == OP_GV)
6032 GV *gv = cGVOPx_gv(gvop);
6033 OP *sibling = o2->op_sibling;
6034 SV *n = newSVpvn("",0);
6036 gv_fullname3(n, gv, "");
6037 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6038 sv_chop(n, SvPVX(n)+6);
6039 o2 = newSVOP(OP_CONST, 0, n);
6040 prev->op_sibling = o2;
6041 o2->op_sibling = sibling;
6057 if (contextclass++ == 0) {
6058 e = strchr(proto, ']');
6059 if (!e || e == proto)
6072 while (*--p != '[');
6073 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6074 gv_ename(namegv), o2);
6080 if (o2->op_type == OP_RV2GV)
6083 bad_type(arg, "symbol", gv_ename(namegv), o2);
6086 if (o2->op_type == OP_ENTERSUB)
6089 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6092 if (o2->op_type == OP_RV2SV ||
6093 o2->op_type == OP_PADSV ||
6094 o2->op_type == OP_HELEM ||
6095 o2->op_type == OP_AELEM ||
6096 o2->op_type == OP_THREADSV)
6099 bad_type(arg, "scalar", gv_ename(namegv), o2);
6102 if (o2->op_type == OP_RV2AV ||
6103 o2->op_type == OP_PADAV)
6106 bad_type(arg, "array", gv_ename(namegv), o2);
6109 if (o2->op_type == OP_RV2HV ||
6110 o2->op_type == OP_PADHV)
6113 bad_type(arg, "hash", gv_ename(namegv), o2);
6118 OP* sib = kid->op_sibling;
6119 kid->op_sibling = 0;
6120 o2 = newUNOP(OP_REFGEN, 0, kid);
6121 o2->op_sibling = sib;
6122 prev->op_sibling = o2;
6124 if (contextclass && e) {
6139 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6140 gv_ename(namegv), cv);
6145 mod(o2, OP_ENTERSUB);
6147 o2 = o2->op_sibling;
6149 if (proto && !optional &&
6150 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6151 return too_few_arguments(o, gv_ename(namegv));
6154 o=newSVOP(OP_CONST, 0, newSViv(0));
6160 Perl_ck_svconst(pTHX_ OP *o)
6162 SvREADONLY_on(cSVOPo->op_sv);
6167 Perl_ck_trunc(pTHX_ OP *o)
6169 if (o->op_flags & OPf_KIDS) {
6170 SVOP *kid = (SVOP*)cUNOPo->op_first;
6172 if (kid->op_type == OP_NULL)
6173 kid = (SVOP*)kid->op_sibling;
6174 if (kid && kid->op_type == OP_CONST &&
6175 (kid->op_private & OPpCONST_BARE))
6177 o->op_flags |= OPf_SPECIAL;
6178 kid->op_private &= ~OPpCONST_STRICT;
6185 Perl_ck_substr(pTHX_ OP *o)
6188 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6189 OP *kid = cLISTOPo->op_first;
6191 if (kid->op_type == OP_NULL)
6192 kid = kid->op_sibling;
6194 kid->op_flags |= OPf_MOD;
6200 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6203 Perl_peep(pTHX_ register OP *o)
6205 register OP* oldop = 0;
6207 if (!o || o->op_seq)
6211 SAVEVPTR(PL_curcop);
6212 for (; o; o = o->op_next) {
6215 /* The special value -1 is used by the B::C compiler backend to indicate
6216 * that an op is statically defined and should not be freed */
6217 if (!PL_op_seqmax || PL_op_seqmax == (U16)-1)
6220 switch (o->op_type) {
6224 PL_curcop = ((COP*)o); /* for warnings */
6225 o->op_seq = PL_op_seqmax++;
6229 if (cSVOPo->op_private & OPpCONST_STRICT)
6230 no_bareword_allowed(o);
6232 case OP_METHOD_NAMED:
6233 /* Relocate sv to the pad for thread safety.
6234 * Despite being a "constant", the SV is written to,
6235 * for reference counts, sv_upgrade() etc. */
6237 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6238 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6239 /* If op_sv is already a PADTMP then it is being used by
6240 * some pad, so make a copy. */
6241 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6242 SvREADONLY_on(PAD_SVl(ix));
6243 SvREFCNT_dec(cSVOPo->op_sv);
6246 SvREFCNT_dec(PAD_SVl(ix));
6247 SvPADTMP_on(cSVOPo->op_sv);
6248 PAD_SETSV(ix, cSVOPo->op_sv);
6249 /* XXX I don't know how this isn't readonly already. */
6250 SvREADONLY_on(PAD_SVl(ix));
6252 cSVOPo->op_sv = Nullsv;
6256 o->op_seq = PL_op_seqmax++;
6260 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6261 if (o->op_next->op_private & OPpTARGET_MY) {
6262 if (o->op_flags & OPf_STACKED) /* chained concats */
6263 goto ignore_optimization;
6265 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6266 o->op_targ = o->op_next->op_targ;
6267 o->op_next->op_targ = 0;
6268 o->op_private |= OPpTARGET_MY;
6271 op_null(o->op_next);
6273 ignore_optimization:
6274 o->op_seq = PL_op_seqmax++;
6277 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6278 o->op_seq = PL_op_seqmax++;
6279 break; /* Scalar stub must produce undef. List stub is noop */
6283 if (o->op_targ == OP_NEXTSTATE
6284 || o->op_targ == OP_DBSTATE
6285 || o->op_targ == OP_SETSTATE)
6287 PL_curcop = ((COP*)o);
6289 /* XXX: We avoid setting op_seq here to prevent later calls
6290 to peep() from mistakenly concluding that optimisation
6291 has already occurred. This doesn't fix the real problem,
6292 though (See 20010220.007). AMS 20010719 */
6293 if (oldop && o->op_next) {
6294 oldop->op_next = o->op_next;
6302 if (oldop && o->op_next) {
6303 oldop->op_next = o->op_next;
6306 o->op_seq = PL_op_seqmax++;
6310 if (o->op_next->op_type == OP_RV2SV) {
6311 if (!(o->op_next->op_private & OPpDEREF)) {
6312 op_null(o->op_next);
6313 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6315 o->op_next = o->op_next->op_next;
6316 o->op_type = OP_GVSV;
6317 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6320 else if (o->op_next->op_type == OP_RV2AV) {
6321 OP* pop = o->op_next->op_next;
6323 if (pop && pop->op_type == OP_CONST &&
6324 (PL_op = pop->op_next) &&
6325 pop->op_next->op_type == OP_AELEM &&
6326 !(pop->op_next->op_private &
6327 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6328 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6333 op_null(o->op_next);
6334 op_null(pop->op_next);
6336 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6337 o->op_next = pop->op_next->op_next;
6338 o->op_type = OP_AELEMFAST;
6339 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6340 o->op_private = (U8)i;
6345 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6347 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6348 /* XXX could check prototype here instead of just carping */
6349 SV *sv = sv_newmortal();
6350 gv_efullname3(sv, gv, Nullch);
6351 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6352 "%"SVf"() called too early to check prototype",
6356 else if (o->op_next->op_type == OP_READLINE
6357 && o->op_next->op_next->op_type == OP_CONCAT
6358 && (o->op_next->op_next->op_flags & OPf_STACKED))
6360 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6361 o->op_type = OP_RCATLINE;
6362 o->op_flags |= OPf_STACKED;
6363 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6364 op_null(o->op_next->op_next);
6365 op_null(o->op_next);
6368 o->op_seq = PL_op_seqmax++;
6381 o->op_seq = PL_op_seqmax++;
6382 while (cLOGOP->op_other->op_type == OP_NULL)
6383 cLOGOP->op_other = cLOGOP->op_other->op_next;
6384 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6389 o->op_seq = PL_op_seqmax++;
6390 while (cLOOP->op_redoop->op_type == OP_NULL)
6391 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6392 peep(cLOOP->op_redoop);
6393 while (cLOOP->op_nextop->op_type == OP_NULL)
6394 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6395 peep(cLOOP->op_nextop);
6396 while (cLOOP->op_lastop->op_type == OP_NULL)
6397 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6398 peep(cLOOP->op_lastop);
6404 o->op_seq = PL_op_seqmax++;
6405 while (cPMOP->op_pmreplstart &&
6406 cPMOP->op_pmreplstart->op_type == OP_NULL)
6407 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6408 peep(cPMOP->op_pmreplstart);
6412 o->op_seq = PL_op_seqmax++;
6413 if (ckWARN(WARN_SYNTAX) && o->op_next
6414 && o->op_next->op_type == OP_NEXTSTATE) {
6415 if (o->op_next->op_sibling &&
6416 o->op_next->op_sibling->op_type != OP_EXIT &&
6417 o->op_next->op_sibling->op_type != OP_WARN &&
6418 o->op_next->op_sibling->op_type != OP_DIE) {
6419 line_t oldline = CopLINE(PL_curcop);
6421 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6422 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6423 "Statement unlikely to be reached");
6424 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6425 "\t(Maybe you meant system() when you said exec()?)\n");
6426 CopLINE_set(PL_curcop, oldline);
6437 o->op_seq = PL_op_seqmax++;
6439 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6442 /* Make the CONST have a shared SV */
6443 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6444 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6445 key = SvPV(sv, keylen);
6446 lexname = newSVpvn_share(key,
6447 SvUTF8(sv) ? -(I32)keylen : keylen,
6456 o->op_seq = PL_op_seqmax++;
6466 char* Perl_custom_op_name(pTHX_ OP* o)
6468 IV index = PTR2IV(o->op_ppaddr);
6472 if (!PL_custom_op_names) /* This probably shouldn't happen */
6473 return PL_op_name[OP_CUSTOM];
6475 keysv = sv_2mortal(newSViv(index));
6477 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
6479 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
6481 return SvPV_nolen(HeVAL(he));
6484 char* Perl_custom_op_desc(pTHX_ OP* o)
6486 IV index = PTR2IV(o->op_ppaddr);
6490 if (!PL_custom_op_descs)
6491 return PL_op_desc[OP_CUSTOM];
6493 keysv = sv_2mortal(newSViv(index));
6495 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
6497 return PL_op_desc[OP_CUSTOM];
6499 return SvPV_nolen(HeVAL(he));
6505 /* Efficient sub that returns a constant scalar value. */
6507 const_sv_xsub(pTHX_ CV* cv)
6512 Perl_croak(aTHX_ "usage: %s::%s()",
6513 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
6517 ST(0) = (SV*)XSANY.any_ptr;