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;
3791 =for apidoc cv_undef
3793 Clear out all the active components of a CV. This can happen either
3794 by an explicit C<undef &foo>, or by the reference count going to zero.
3795 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
3796 children can still follow the full lexical scope chain.
3802 Perl_cv_undef(pTHX_ CV *cv)
3805 if (CvFILE(cv) && !CvXSUB(cv)) {
3806 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
3807 Safefree(CvFILE(cv));
3812 if (!CvXSUB(cv) && CvROOT(cv)) {
3814 Perl_croak(aTHX_ "Can't undef active subroutine");
3817 PAD_SAVE_SETNULLPAD();
3819 op_free(CvROOT(cv));
3820 CvROOT(cv) = Nullop;
3823 SvPOK_off((SV*)cv); /* forget prototype */
3828 /* remove CvOUTSIDE unless this is an undef rather than a free */
3829 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
3830 if (!CvWEAKOUTSIDE(cv))
3831 SvREFCNT_dec(CvOUTSIDE(cv));
3832 CvOUTSIDE(cv) = Nullcv;
3835 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
3841 /* delete all flags except WEAKOUTSIDE */
3842 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
3846 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
3848 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
3849 SV* msg = sv_newmortal();
3853 gv_efullname3(name = sv_newmortal(), gv, Nullch);
3854 sv_setpv(msg, "Prototype mismatch:");
3856 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
3858 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (SV *)cv);
3859 sv_catpv(msg, " vs ");
3861 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
3863 sv_catpv(msg, "none");
3864 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
3868 static void const_sv_xsub(pTHX_ CV* cv);
3872 =head1 Optree Manipulation Functions
3874 =for apidoc cv_const_sv
3876 If C<cv> is a constant sub eligible for inlining. returns the constant
3877 value returned by the sub. Otherwise, returns NULL.
3879 Constant subs can be created with C<newCONSTSUB> or as described in
3880 L<perlsub/"Constant Functions">.
3885 Perl_cv_const_sv(pTHX_ CV *cv)
3887 if (!cv || !CvCONST(cv))
3889 return (SV*)CvXSUBANY(cv).any_ptr;
3892 /* op_const_sv: examine an optree to determine whether it's in-lineable.
3893 * Can be called in 3 ways:
3896 * look for a single OP_CONST with attached value: return the value
3898 * cv && CvCLONE(cv) && !CvCONST(cv)
3900 * examine the clone prototype, and if contains only a single
3901 * OP_CONST referencing a pad const, or a single PADSV referencing
3902 * an outer lexical, return a non-zero value to indicate the CV is
3903 * a candidate for "constizing" at clone time
3907 * We have just cloned an anon prototype that was marked as a const
3908 * candidiate. Try to grab the current value, and in the case of
3909 * PADSV, ignore it if it has multiple references. Return the value.
3913 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
3920 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
3921 o = cLISTOPo->op_first->op_sibling;
3923 for (; o; o = o->op_next) {
3924 OPCODE type = o->op_type;
3926 if (sv && o->op_next == o)
3928 if (o->op_next != o) {
3929 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
3931 if (type == OP_DBSTATE)
3934 if (type == OP_LEAVESUB || type == OP_RETURN)
3938 if (type == OP_CONST && cSVOPo->op_sv)
3940 else if (cv && type == OP_CONST) {
3941 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
3945 else if (cv && type == OP_PADSV) {
3946 if (CvCONST(cv)) { /* newly cloned anon */
3947 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
3948 /* the candidate should have 1 ref from this pad and 1 ref
3949 * from the parent */
3950 if (!sv || SvREFCNT(sv) != 2)
3957 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
3958 sv = &PL_sv_undef; /* an arbitrary non-null value */
3969 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
3979 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
3983 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
3985 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
3989 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
3995 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
3999 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4000 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4001 SV *sv = sv_newmortal();
4002 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4003 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4004 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4009 gv = gv_fetchpv(name ? name : (aname ? aname :
4010 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__")),
4011 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4021 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4022 maximum a prototype before. */
4023 if (SvTYPE(gv) > SVt_NULL) {
4024 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4025 && ckWARN_d(WARN_PROTOTYPE))
4027 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4029 cv_ckproto((CV*)gv, NULL, ps);
4032 sv_setpv((SV*)gv, ps);
4034 sv_setiv((SV*)gv, -1);
4035 SvREFCNT_dec(PL_compcv);
4036 cv = PL_compcv = NULL;
4037 PL_sub_generation++;
4041 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4043 #ifdef GV_UNIQUE_CHECK
4044 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4045 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4049 if (!block || !ps || *ps || attrs)
4052 const_sv = op_const_sv(block, Nullcv);
4055 bool exists = CvROOT(cv) || CvXSUB(cv);
4057 #ifdef GV_UNIQUE_CHECK
4058 if (exists && GvUNIQUE(gv)) {
4059 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4063 /* if the subroutine doesn't exist and wasn't pre-declared
4064 * with a prototype, assume it will be AUTOLOADed,
4065 * skipping the prototype check
4067 if (exists || SvPOK(cv))
4068 cv_ckproto(cv, gv, ps);
4069 /* already defined (or promised)? */
4070 if (exists || GvASSUMECV(gv)) {
4071 if (!block && !attrs) {
4072 if (CvFLAGS(PL_compcv)) {
4073 /* might have had built-in attrs applied */
4074 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4076 /* just a "sub foo;" when &foo is already defined */
4077 SAVEFREESV(PL_compcv);
4080 /* ahem, death to those who redefine active sort subs */
4081 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4082 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4084 if (ckWARN(WARN_REDEFINE)
4086 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4088 line_t oldline = CopLINE(PL_curcop);
4089 if (PL_copline != NOLINE)
4090 CopLINE_set(PL_curcop, PL_copline);
4091 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4092 CvCONST(cv) ? "Constant subroutine %s redefined"
4093 : "Subroutine %s redefined", name);
4094 CopLINE_set(PL_curcop, oldline);
4102 SvREFCNT_inc(const_sv);
4104 assert(!CvROOT(cv) && !CvCONST(cv));
4105 sv_setpv((SV*)cv, ""); /* prototype is "" */
4106 CvXSUBANY(cv).any_ptr = const_sv;
4107 CvXSUB(cv) = const_sv_xsub;
4112 cv = newCONSTSUB(NULL, name, const_sv);
4115 SvREFCNT_dec(PL_compcv);
4117 PL_sub_generation++;
4124 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4125 * before we clobber PL_compcv.
4129 /* Might have had built-in attributes applied -- propagate them. */
4130 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4131 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4132 stash = GvSTASH(CvGV(cv));
4133 else if (CvSTASH(cv))
4134 stash = CvSTASH(cv);
4136 stash = PL_curstash;
4139 /* possibly about to re-define existing subr -- ignore old cv */
4140 rcv = (SV*)PL_compcv;
4141 if (name && GvSTASH(gv))
4142 stash = GvSTASH(gv);
4144 stash = PL_curstash;
4146 apply_attrs(stash, rcv, attrs, FALSE);
4148 if (cv) { /* must reuse cv if autoloaded */
4150 /* got here with just attrs -- work done, so bug out */
4151 SAVEFREESV(PL_compcv);
4154 /* transfer PL_compcv to cv */
4156 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4157 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4158 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4159 CvOUTSIDE(PL_compcv) = 0;
4160 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4161 CvPADLIST(PL_compcv) = 0;
4162 /* inner references to PL_compcv must be fixed up ... */
4163 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4164 /* ... before we throw it away */
4165 SvREFCNT_dec(PL_compcv);
4167 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4168 ++PL_sub_generation;
4175 PL_sub_generation++;
4179 CvFILE_set_from_cop(cv, PL_curcop);
4180 CvSTASH(cv) = PL_curstash;
4183 sv_setpv((SV*)cv, ps);
4185 if (PL_error_count) {
4189 char *s = strrchr(name, ':');
4191 if (strEQ(s, "BEGIN")) {
4193 "BEGIN not safe after errors--compilation aborted";
4194 if (PL_in_eval & EVAL_KEEPERR)
4195 Perl_croak(aTHX_ not_safe);
4197 /* force display of errors found but not reported */
4198 sv_catpv(ERRSV, not_safe);
4199 Perl_croak(aTHX_ "%"SVf, ERRSV);
4208 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4209 mod(scalarseq(block), OP_LEAVESUBLV));
4212 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4214 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4215 OpREFCNT_set(CvROOT(cv), 1);
4216 CvSTART(cv) = LINKLIST(CvROOT(cv));
4217 CvROOT(cv)->op_next = 0;
4218 CALL_PEEP(CvSTART(cv));
4220 /* now that optimizer has done its work, adjust pad values */
4222 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4225 assert(!CvCONST(cv));
4226 if (ps && !*ps && op_const_sv(block, cv))
4230 if (name || aname) {
4232 char *tname = (name ? name : aname);
4234 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4235 SV *sv = NEWSV(0,0);
4236 SV *tmpstr = sv_newmortal();
4237 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4241 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4243 (long)PL_subline, (long)CopLINE(PL_curcop));
4244 gv_efullname3(tmpstr, gv, Nullch);
4245 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4246 hv = GvHVn(db_postponed);
4247 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4248 && (pcv = GvCV(db_postponed)))
4254 call_sv((SV*)pcv, G_DISCARD);
4258 if ((s = strrchr(tname,':')))
4263 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4266 if (strEQ(s, "BEGIN") && !PL_error_count) {
4267 I32 oldscope = PL_scopestack_ix;
4269 SAVECOPFILE(&PL_compiling);
4270 SAVECOPLINE(&PL_compiling);
4273 PL_beginav = newAV();
4274 DEBUG_x( dump_sub(gv) );
4275 av_push(PL_beginav, (SV*)cv);
4276 GvCV(gv) = 0; /* cv has been hijacked */
4277 call_list(oldscope, PL_beginav);
4279 PL_curcop = &PL_compiling;
4280 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4283 else if (strEQ(s, "END") && !PL_error_count) {
4286 DEBUG_x( dump_sub(gv) );
4287 av_unshift(PL_endav, 1);
4288 av_store(PL_endav, 0, (SV*)cv);
4289 GvCV(gv) = 0; /* cv has been hijacked */
4291 else if (strEQ(s, "CHECK") && !PL_error_count) {
4293 PL_checkav = newAV();
4294 DEBUG_x( dump_sub(gv) );
4295 if (PL_main_start && ckWARN(WARN_VOID))
4296 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4297 av_unshift(PL_checkav, 1);
4298 av_store(PL_checkav, 0, (SV*)cv);
4299 GvCV(gv) = 0; /* cv has been hijacked */
4301 else if (strEQ(s, "INIT") && !PL_error_count) {
4303 PL_initav = newAV();
4304 DEBUG_x( dump_sub(gv) );
4305 if (PL_main_start && ckWARN(WARN_VOID))
4306 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4307 av_push(PL_initav, (SV*)cv);
4308 GvCV(gv) = 0; /* cv has been hijacked */
4313 PL_copline = NOLINE;
4318 /* XXX unsafe for threads if eval_owner isn't held */
4320 =for apidoc newCONSTSUB
4322 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4323 eligible for inlining at compile-time.
4329 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4335 SAVECOPLINE(PL_curcop);
4336 CopLINE_set(PL_curcop, PL_copline);
4339 PL_hints &= ~HINT_BLOCK_SCOPE;
4342 SAVESPTR(PL_curstash);
4343 SAVECOPSTASH(PL_curcop);
4344 PL_curstash = stash;
4345 CopSTASH_set(PL_curcop,stash);
4348 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4349 CvXSUBANY(cv).any_ptr = sv;
4351 sv_setpv((SV*)cv, ""); /* prototype is "" */
4354 CopSTASH_free(PL_curcop);
4362 =for apidoc U||newXS
4364 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4370 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
4372 GV *gv = gv_fetchpv(name ? name :
4373 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4374 GV_ADDMULTI, SVt_PVCV);
4378 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4380 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4382 /* just a cached method */
4386 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4387 /* already defined (or promised) */
4388 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4389 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4390 line_t oldline = CopLINE(PL_curcop);
4391 if (PL_copline != NOLINE)
4392 CopLINE_set(PL_curcop, PL_copline);
4393 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4394 CvCONST(cv) ? "Constant subroutine %s redefined"
4395 : "Subroutine %s redefined"
4397 CopLINE_set(PL_curcop, oldline);
4404 if (cv) /* must reuse cv if autoloaded */
4407 cv = (CV*)NEWSV(1105,0);
4408 sv_upgrade((SV *)cv, SVt_PVCV);
4412 PL_sub_generation++;
4416 (void)gv_fetchfile(filename);
4417 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
4418 an external constant string */
4419 CvXSUB(cv) = subaddr;
4422 char *s = strrchr(name,':');
4428 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4431 if (strEQ(s, "BEGIN")) {
4433 PL_beginav = newAV();
4434 av_push(PL_beginav, (SV*)cv);
4435 GvCV(gv) = 0; /* cv has been hijacked */
4437 else if (strEQ(s, "END")) {
4440 av_unshift(PL_endav, 1);
4441 av_store(PL_endav, 0, (SV*)cv);
4442 GvCV(gv) = 0; /* cv has been hijacked */
4444 else if (strEQ(s, "CHECK")) {
4446 PL_checkav = newAV();
4447 if (PL_main_start && ckWARN(WARN_VOID))
4448 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4449 av_unshift(PL_checkav, 1);
4450 av_store(PL_checkav, 0, (SV*)cv);
4451 GvCV(gv) = 0; /* cv has been hijacked */
4453 else if (strEQ(s, "INIT")) {
4455 PL_initav = newAV();
4456 if (PL_main_start && ckWARN(WARN_VOID))
4457 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4458 av_push(PL_initav, (SV*)cv);
4459 GvCV(gv) = 0; /* cv has been hijacked */
4470 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4478 name = SvPVx(cSVOPo->op_sv, n_a);
4481 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
4482 #ifdef GV_UNIQUE_CHECK
4484 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4488 if ((cv = GvFORM(gv))) {
4489 if (ckWARN(WARN_REDEFINE)) {
4490 line_t oldline = CopLINE(PL_curcop);
4491 if (PL_copline != NOLINE)
4492 CopLINE_set(PL_curcop, PL_copline);
4493 Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Format %s redefined",name);
4494 CopLINE_set(PL_curcop, oldline);
4501 CvFILE_set_from_cop(cv, PL_curcop);
4504 pad_tidy(padtidy_FORMAT);
4505 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4506 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4507 OpREFCNT_set(CvROOT(cv), 1);
4508 CvSTART(cv) = LINKLIST(CvROOT(cv));
4509 CvROOT(cv)->op_next = 0;
4510 CALL_PEEP(CvSTART(cv));
4512 PL_copline = NOLINE;
4517 Perl_newANONLIST(pTHX_ OP *o)
4519 return newUNOP(OP_REFGEN, 0,
4520 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4524 Perl_newANONHASH(pTHX_ OP *o)
4526 return newUNOP(OP_REFGEN, 0,
4527 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4531 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4533 return newANONATTRSUB(floor, proto, Nullop, block);
4537 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4539 return newUNOP(OP_REFGEN, 0,
4540 newSVOP(OP_ANONCODE, 0,
4541 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
4545 Perl_oopsAV(pTHX_ OP *o)
4547 switch (o->op_type) {
4549 o->op_type = OP_PADAV;
4550 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4551 return ref(o, OP_RV2AV);
4554 o->op_type = OP_RV2AV;
4555 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4560 if (ckWARN_d(WARN_INTERNAL))
4561 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
4568 Perl_oopsHV(pTHX_ OP *o)
4570 switch (o->op_type) {
4573 o->op_type = OP_PADHV;
4574 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4575 return ref(o, OP_RV2HV);
4579 o->op_type = OP_RV2HV;
4580 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
4585 if (ckWARN_d(WARN_INTERNAL))
4586 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
4593 Perl_newAVREF(pTHX_ OP *o)
4595 if (o->op_type == OP_PADANY) {
4596 o->op_type = OP_PADAV;
4597 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4600 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
4601 && ckWARN(WARN_DEPRECATED)) {
4602 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4603 "Using an array as a reference is deprecated");
4605 return newUNOP(OP_RV2AV, 0, scalar(o));
4609 Perl_newGVREF(pTHX_ I32 type, OP *o)
4611 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
4612 return newUNOP(OP_NULL, 0, o);
4613 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
4617 Perl_newHVREF(pTHX_ OP *o)
4619 if (o->op_type == OP_PADANY) {
4620 o->op_type = OP_PADHV;
4621 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4624 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
4625 && ckWARN(WARN_DEPRECATED)) {
4626 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4627 "Using a hash as a reference is deprecated");
4629 return newUNOP(OP_RV2HV, 0, scalar(o));
4633 Perl_oopsCV(pTHX_ OP *o)
4635 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
4641 Perl_newCVREF(pTHX_ I32 flags, OP *o)
4643 return newUNOP(OP_RV2CV, flags, scalar(o));
4647 Perl_newSVREF(pTHX_ OP *o)
4649 if (o->op_type == OP_PADANY) {
4650 o->op_type = OP_PADSV;
4651 o->op_ppaddr = PL_ppaddr[OP_PADSV];
4654 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4655 o->op_flags |= OPpDONE_SVREF;
4658 return newUNOP(OP_RV2SV, 0, scalar(o));
4661 /* Check routines. */
4664 Perl_ck_anoncode(pTHX_ OP *o)
4666 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
4667 cSVOPo->op_sv = Nullsv;
4672 Perl_ck_bitop(pTHX_ OP *o)
4674 #define OP_IS_NUMCOMPARE(op) \
4675 ((op) == OP_LT || (op) == OP_I_LT || \
4676 (op) == OP_GT || (op) == OP_I_GT || \
4677 (op) == OP_LE || (op) == OP_I_LE || \
4678 (op) == OP_GE || (op) == OP_I_GE || \
4679 (op) == OP_EQ || (op) == OP_I_EQ || \
4680 (op) == OP_NE || (op) == OP_I_NE || \
4681 (op) == OP_NCMP || (op) == OP_I_NCMP)
4682 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4683 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
4684 && (o->op_type == OP_BIT_OR
4685 || o->op_type == OP_BIT_AND
4686 || o->op_type == OP_BIT_XOR))
4688 OP * left = cBINOPo->op_first;
4689 OP * right = left->op_sibling;
4690 if ((OP_IS_NUMCOMPARE(left->op_type) &&
4691 (left->op_flags & OPf_PARENS) == 0) ||
4692 (OP_IS_NUMCOMPARE(right->op_type) &&
4693 (right->op_flags & OPf_PARENS) == 0))
4694 if (ckWARN(WARN_PRECEDENCE))
4695 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4696 "Possible precedence problem on bitwise %c operator",
4697 o->op_type == OP_BIT_OR ? '|'
4698 : o->op_type == OP_BIT_AND ? '&' : '^'
4705 Perl_ck_concat(pTHX_ OP *o)
4707 OP *kid = cUNOPo->op_first;
4708 if (kid->op_type == OP_CONCAT && !(kUNOP->op_first->op_flags & OPf_MOD))
4709 o->op_flags |= OPf_STACKED;
4714 Perl_ck_spair(pTHX_ OP *o)
4716 if (o->op_flags & OPf_KIDS) {
4719 OPCODE type = o->op_type;
4720 o = modkids(ck_fun(o), type);
4721 kid = cUNOPo->op_first;
4722 newop = kUNOP->op_first->op_sibling;
4724 (newop->op_sibling ||
4725 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
4726 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
4727 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
4731 op_free(kUNOP->op_first);
4732 kUNOP->op_first = newop;
4734 o->op_ppaddr = PL_ppaddr[++o->op_type];
4739 Perl_ck_delete(pTHX_ OP *o)
4743 if (o->op_flags & OPf_KIDS) {
4744 OP *kid = cUNOPo->op_first;
4745 switch (kid->op_type) {
4747 o->op_flags |= OPf_SPECIAL;
4750 o->op_private |= OPpSLICE;
4753 o->op_flags |= OPf_SPECIAL;
4758 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
4767 Perl_ck_die(pTHX_ OP *o)
4770 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4776 Perl_ck_eof(pTHX_ OP *o)
4778 I32 type = o->op_type;
4780 if (o->op_flags & OPf_KIDS) {
4781 if (cLISTOPo->op_first->op_type == OP_STUB) {
4783 o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
4791 Perl_ck_eval(pTHX_ OP *o)
4793 PL_hints |= HINT_BLOCK_SCOPE;
4794 if (o->op_flags & OPf_KIDS) {
4795 SVOP *kid = (SVOP*)cUNOPo->op_first;
4798 o->op_flags &= ~OPf_KIDS;
4801 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
4804 cUNOPo->op_first = 0;
4807 NewOp(1101, enter, 1, LOGOP);
4808 enter->op_type = OP_ENTERTRY;
4809 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
4810 enter->op_private = 0;
4812 /* establish postfix order */
4813 enter->op_next = (OP*)enter;
4815 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
4816 o->op_type = OP_LEAVETRY;
4817 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
4818 enter->op_other = o;
4828 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
4830 o->op_targ = (PADOFFSET)PL_hints;
4835 Perl_ck_exit(pTHX_ OP *o)
4838 HV *table = GvHV(PL_hintgv);
4840 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
4841 if (svp && *svp && SvTRUE(*svp))
4842 o->op_private |= OPpEXIT_VMSISH;
4844 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4850 Perl_ck_exec(pTHX_ OP *o)
4853 if (o->op_flags & OPf_STACKED) {
4855 kid = cUNOPo->op_first->op_sibling;
4856 if (kid->op_type == OP_RV2GV)
4865 Perl_ck_exists(pTHX_ OP *o)
4868 if (o->op_flags & OPf_KIDS) {
4869 OP *kid = cUNOPo->op_first;
4870 if (kid->op_type == OP_ENTERSUB) {
4871 (void) ref(kid, o->op_type);
4872 if (kid->op_type != OP_RV2CV && !PL_error_count)
4873 Perl_croak(aTHX_ "%s argument is not a subroutine name",
4875 o->op_private |= OPpEXISTS_SUB;
4877 else if (kid->op_type == OP_AELEM)
4878 o->op_flags |= OPf_SPECIAL;
4879 else if (kid->op_type != OP_HELEM)
4880 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
4889 Perl_ck_gvconst(pTHX_ register OP *o)
4891 o = fold_constants(o);
4892 if (o->op_type == OP_CONST)
4899 Perl_ck_rvconst(pTHX_ register OP *o)
4901 SVOP *kid = (SVOP*)cUNOPo->op_first;
4903 o->op_private |= (PL_hints & HINT_STRICT_REFS);
4904 if (kid->op_type == OP_CONST) {
4908 SV *kidsv = kid->op_sv;
4911 /* Is it a constant from cv_const_sv()? */
4912 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
4913 SV *rsv = SvRV(kidsv);
4914 int svtype = SvTYPE(rsv);
4915 char *badtype = Nullch;
4917 switch (o->op_type) {
4919 if (svtype > SVt_PVMG)
4920 badtype = "a SCALAR";
4923 if (svtype != SVt_PVAV)
4924 badtype = "an ARRAY";
4927 if (svtype != SVt_PVHV)
4931 if (svtype != SVt_PVCV)
4936 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
4939 name = SvPV(kidsv, n_a);
4940 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
4941 char *badthing = Nullch;
4942 switch (o->op_type) {
4944 badthing = "a SCALAR";
4947 badthing = "an ARRAY";
4950 badthing = "a HASH";
4955 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
4959 * This is a little tricky. We only want to add the symbol if we
4960 * didn't add it in the lexer. Otherwise we get duplicate strict
4961 * warnings. But if we didn't add it in the lexer, we must at
4962 * least pretend like we wanted to add it even if it existed before,
4963 * or we get possible typo warnings. OPpCONST_ENTERED says
4964 * whether the lexer already added THIS instance of this symbol.
4966 iscv = (o->op_type == OP_RV2CV) * 2;
4968 gv = gv_fetchpv(name,
4969 iscv | !(kid->op_private & OPpCONST_ENTERED),
4972 : o->op_type == OP_RV2SV
4974 : o->op_type == OP_RV2AV
4976 : o->op_type == OP_RV2HV
4979 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
4981 kid->op_type = OP_GV;
4982 SvREFCNT_dec(kid->op_sv);
4984 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
4985 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
4986 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
4988 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
4990 kid->op_sv = SvREFCNT_inc(gv);
4992 kid->op_private = 0;
4993 kid->op_ppaddr = PL_ppaddr[OP_GV];
5000 Perl_ck_ftst(pTHX_ OP *o)
5002 I32 type = o->op_type;
5004 if (o->op_flags & OPf_REF) {
5007 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5008 SVOP *kid = (SVOP*)cUNOPo->op_first;
5010 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5012 OP *newop = newGVOP(type, OPf_REF,
5013 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5018 if ((PL_hints & HINT_FILETEST_ACCESS) &&
5019 OP_IS_FILETEST_ACCESS(o))
5020 o->op_private |= OPpFT_ACCESS;
5025 if (type == OP_FTTTY)
5026 o = newGVOP(type, OPf_REF, PL_stdingv);
5028 o = newUNOP(type, 0, newDEFSVOP());
5034 Perl_ck_fun(pTHX_ OP *o)
5040 int type = o->op_type;
5041 register I32 oa = PL_opargs[type] >> OASHIFT;
5043 if (o->op_flags & OPf_STACKED) {
5044 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5047 return no_fh_allowed(o);
5050 if (o->op_flags & OPf_KIDS) {
5052 tokid = &cLISTOPo->op_first;
5053 kid = cLISTOPo->op_first;
5054 if (kid->op_type == OP_PUSHMARK ||
5055 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5057 tokid = &kid->op_sibling;
5058 kid = kid->op_sibling;
5060 if (!kid && PL_opargs[type] & OA_DEFGV)
5061 *tokid = kid = newDEFSVOP();
5065 sibl = kid->op_sibling;
5068 /* list seen where single (scalar) arg expected? */
5069 if (numargs == 1 && !(oa >> 4)
5070 && kid->op_type == OP_LIST && type != OP_SCALAR)
5072 return too_many_arguments(o,PL_op_desc[type]);
5085 if ((type == OP_PUSH || type == OP_UNSHIFT)
5086 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5087 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5088 "Useless use of %s with no values",
5091 if (kid->op_type == OP_CONST &&
5092 (kid->op_private & OPpCONST_BARE))
5094 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5095 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5096 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5097 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5098 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5099 "Array @%s missing the @ in argument %"IVdf" of %s()",
5100 name, (IV)numargs, PL_op_desc[type]);
5103 kid->op_sibling = sibl;
5106 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5107 bad_type(numargs, "array", PL_op_desc[type], kid);
5111 if (kid->op_type == OP_CONST &&
5112 (kid->op_private & OPpCONST_BARE))
5114 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5115 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5116 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5117 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5118 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5119 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5120 name, (IV)numargs, PL_op_desc[type]);
5123 kid->op_sibling = sibl;
5126 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5127 bad_type(numargs, "hash", PL_op_desc[type], kid);
5132 OP *newop = newUNOP(OP_NULL, 0, kid);
5133 kid->op_sibling = 0;
5135 newop->op_next = newop;
5137 kid->op_sibling = sibl;
5142 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5143 if (kid->op_type == OP_CONST &&
5144 (kid->op_private & OPpCONST_BARE))
5146 OP *newop = newGVOP(OP_GV, 0,
5147 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5149 if (!(o->op_private & 1) && /* if not unop */
5150 kid == cLISTOPo->op_last)
5151 cLISTOPo->op_last = newop;
5155 else if (kid->op_type == OP_READLINE) {
5156 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5157 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5160 I32 flags = OPf_SPECIAL;
5164 /* is this op a FH constructor? */
5165 if (is_handle_constructor(o,numargs)) {
5166 char *name = Nullch;
5170 /* Set a flag to tell rv2gv to vivify
5171 * need to "prove" flag does not mean something
5172 * else already - NI-S 1999/05/07
5175 if (kid->op_type == OP_PADSV) {
5176 name = PAD_COMPNAME_PV(kid->op_targ);
5177 /* SvCUR of a pad namesv can't be trusted
5178 * (see PL_generation), so calc its length
5184 else if (kid->op_type == OP_RV2SV
5185 && kUNOP->op_first->op_type == OP_GV)
5187 GV *gv = cGVOPx_gv(kUNOP->op_first);
5189 len = GvNAMELEN(gv);
5191 else if (kid->op_type == OP_AELEM
5192 || kid->op_type == OP_HELEM)
5197 if ((op = ((BINOP*)kid)->op_first)) {
5198 SV *tmpstr = Nullsv;
5200 kid->op_type == OP_AELEM ?
5202 if (((op->op_type == OP_RV2AV) ||
5203 (op->op_type == OP_RV2HV)) &&
5204 (op = ((UNOP*)op)->op_first) &&
5205 (op->op_type == OP_GV)) {
5206 /* packagevar $a[] or $h{} */
5207 GV *gv = cGVOPx_gv(op);
5215 else if (op->op_type == OP_PADAV
5216 || op->op_type == OP_PADHV) {
5217 /* lexicalvar $a[] or $h{} */
5219 PAD_COMPNAME_PV(op->op_targ);
5229 name = savepv(SvPVX(tmpstr));
5235 name = "__ANONIO__";
5242 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5243 namesv = PAD_SVl(targ);
5244 (void)SvUPGRADE(namesv, SVt_PV);
5246 sv_setpvn(namesv, "$", 1);
5247 sv_catpvn(namesv, name, len);
5250 kid->op_sibling = 0;
5251 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5252 kid->op_targ = targ;
5253 kid->op_private |= priv;
5255 kid->op_sibling = sibl;
5261 mod(scalar(kid), type);
5265 tokid = &kid->op_sibling;
5266 kid = kid->op_sibling;
5268 o->op_private |= numargs;
5270 return too_many_arguments(o,OP_DESC(o));
5273 else if (PL_opargs[type] & OA_DEFGV) {
5275 return newUNOP(type, 0, newDEFSVOP());
5279 while (oa & OA_OPTIONAL)
5281 if (oa && oa != OA_LIST)
5282 return too_few_arguments(o,OP_DESC(o));
5288 Perl_ck_glob(pTHX_ OP *o)
5293 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5294 append_elem(OP_GLOB, o, newDEFSVOP());
5296 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5297 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5299 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5302 #if !defined(PERL_EXTERNAL_GLOB)
5303 /* XXX this can be tightened up and made more failsafe. */
5304 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5307 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5308 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5309 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5310 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5311 GvCV(gv) = GvCV(glob_gv);
5312 SvREFCNT_inc((SV*)GvCV(gv));
5313 GvIMPORTED_CV_on(gv);
5316 #endif /* PERL_EXTERNAL_GLOB */
5318 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5319 append_elem(OP_GLOB, o,
5320 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5321 o->op_type = OP_LIST;
5322 o->op_ppaddr = PL_ppaddr[OP_LIST];
5323 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5324 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5325 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5326 append_elem(OP_LIST, o,
5327 scalar(newUNOP(OP_RV2CV, 0,
5328 newGVOP(OP_GV, 0, gv)))));
5329 o = newUNOP(OP_NULL, 0, ck_subr(o));
5330 o->op_targ = OP_GLOB; /* hint at what it used to be */
5333 gv = newGVgen("main");
5335 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5341 Perl_ck_grep(pTHX_ OP *o)
5345 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5347 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5348 NewOp(1101, gwop, 1, LOGOP);
5350 if (o->op_flags & OPf_STACKED) {
5353 kid = cLISTOPo->op_first->op_sibling;
5354 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5357 kid->op_next = (OP*)gwop;
5358 o->op_flags &= ~OPf_STACKED;
5360 kid = cLISTOPo->op_first->op_sibling;
5361 if (type == OP_MAPWHILE)
5368 kid = cLISTOPo->op_first->op_sibling;
5369 if (kid->op_type != OP_NULL)
5370 Perl_croak(aTHX_ "panic: ck_grep");
5371 kid = kUNOP->op_first;
5373 gwop->op_type = type;
5374 gwop->op_ppaddr = PL_ppaddr[type];
5375 gwop->op_first = listkids(o);
5376 gwop->op_flags |= OPf_KIDS;
5377 gwop->op_private = 1;
5378 gwop->op_other = LINKLIST(kid);
5379 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5380 kid->op_next = (OP*)gwop;
5382 kid = cLISTOPo->op_first->op_sibling;
5383 if (!kid || !kid->op_sibling)
5384 return too_few_arguments(o,OP_DESC(o));
5385 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5386 mod(kid, OP_GREPSTART);
5392 Perl_ck_index(pTHX_ OP *o)
5394 if (o->op_flags & OPf_KIDS) {
5395 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5397 kid = kid->op_sibling; /* get past "big" */
5398 if (kid && kid->op_type == OP_CONST)
5399 fbm_compile(((SVOP*)kid)->op_sv, 0);
5405 Perl_ck_lengthconst(pTHX_ OP *o)
5407 /* XXX length optimization goes here */
5412 Perl_ck_lfun(pTHX_ OP *o)
5414 OPCODE type = o->op_type;
5415 return modkids(ck_fun(o), type);
5419 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5421 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5422 switch (cUNOPo->op_first->op_type) {
5424 /* This is needed for
5425 if (defined %stash::)
5426 to work. Do not break Tk.
5428 break; /* Globals via GV can be undef */
5430 case OP_AASSIGN: /* Is this a good idea? */
5431 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5432 "defined(@array) is deprecated");
5433 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5434 "\t(Maybe you should just omit the defined()?)\n");
5437 /* This is needed for
5438 if (defined %stash::)
5439 to work. Do not break Tk.
5441 break; /* Globals via GV can be undef */
5443 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5444 "defined(%%hash) is deprecated");
5445 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5446 "\t(Maybe you should just omit the defined()?)\n");
5457 Perl_ck_rfun(pTHX_ OP *o)
5459 OPCODE type = o->op_type;
5460 return refkids(ck_fun(o), type);
5464 Perl_ck_listiob(pTHX_ OP *o)
5468 kid = cLISTOPo->op_first;
5471 kid = cLISTOPo->op_first;
5473 if (kid->op_type == OP_PUSHMARK)
5474 kid = kid->op_sibling;
5475 if (kid && o->op_flags & OPf_STACKED)
5476 kid = kid->op_sibling;
5477 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5478 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5479 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5480 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5481 cLISTOPo->op_first->op_sibling = kid;
5482 cLISTOPo->op_last = kid;
5483 kid = kid->op_sibling;
5488 append_elem(o->op_type, o, newDEFSVOP());
5494 Perl_ck_sassign(pTHX_ OP *o)
5496 OP *kid = cLISTOPo->op_first;
5497 /* has a disposable target? */
5498 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5499 && !(kid->op_flags & OPf_STACKED)
5500 /* Cannot steal the second time! */
5501 && !(kid->op_private & OPpTARGET_MY))
5503 OP *kkid = kid->op_sibling;
5505 /* Can just relocate the target. */
5506 if (kkid && kkid->op_type == OP_PADSV
5507 && !(kkid->op_private & OPpLVAL_INTRO))
5509 kid->op_targ = kkid->op_targ;
5511 /* Now we do not need PADSV and SASSIGN. */
5512 kid->op_sibling = o->op_sibling; /* NULL */
5513 cLISTOPo->op_first = NULL;
5516 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
5524 Perl_ck_match(pTHX_ OP *o)
5526 o->op_private |= OPpRUNTIME;
5531 Perl_ck_method(pTHX_ OP *o)
5533 OP *kid = cUNOPo->op_first;
5534 if (kid->op_type == OP_CONST) {
5535 SV* sv = kSVOP->op_sv;
5536 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
5538 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5539 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
5542 kSVOP->op_sv = Nullsv;
5544 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5553 Perl_ck_null(pTHX_ OP *o)
5559 Perl_ck_open(pTHX_ OP *o)
5561 HV *table = GvHV(PL_hintgv);
5565 svp = hv_fetch(table, "open_IN", 7, FALSE);
5567 mode = mode_from_discipline(*svp);
5568 if (mode & O_BINARY)
5569 o->op_private |= OPpOPEN_IN_RAW;
5570 else if (mode & O_TEXT)
5571 o->op_private |= OPpOPEN_IN_CRLF;
5574 svp = hv_fetch(table, "open_OUT", 8, FALSE);
5576 mode = mode_from_discipline(*svp);
5577 if (mode & O_BINARY)
5578 o->op_private |= OPpOPEN_OUT_RAW;
5579 else if (mode & O_TEXT)
5580 o->op_private |= OPpOPEN_OUT_CRLF;
5583 if (o->op_type == OP_BACKTICK)
5586 /* In case of three-arg dup open remove strictness
5587 * from the last arg if it is a bareword. */
5588 OP *first = cLISTOPx(o)->op_first; /* The pushmark. */
5589 OP *last = cLISTOPx(o)->op_last; /* The bareword. */
5593 if ((last->op_type == OP_CONST) && /* The bareword. */
5594 (last->op_private & OPpCONST_BARE) &&
5595 (last->op_private & OPpCONST_STRICT) &&
5596 (oa = first->op_sibling) && /* The fh. */
5597 (oa = oa->op_sibling) && /* The mode. */
5598 SvPOK(((SVOP*)oa)->op_sv) &&
5599 (mode = SvPVX(((SVOP*)oa)->op_sv)) &&
5600 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
5601 (last == oa->op_sibling)) /* The bareword. */
5602 last->op_private &= ~OPpCONST_STRICT;
5608 Perl_ck_repeat(pTHX_ OP *o)
5610 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5611 o->op_private |= OPpREPEAT_DOLIST;
5612 cBINOPo->op_first = force_list(cBINOPo->op_first);
5620 Perl_ck_require(pTHX_ OP *o)
5624 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
5625 SVOP *kid = (SVOP*)cUNOPo->op_first;
5627 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5629 for (s = SvPVX(kid->op_sv); *s; s++) {
5630 if (*s == ':' && s[1] == ':') {
5632 Move(s+2, s+1, strlen(s+2)+1, char);
5633 --SvCUR(kid->op_sv);
5636 if (SvREADONLY(kid->op_sv)) {
5637 SvREADONLY_off(kid->op_sv);
5638 sv_catpvn(kid->op_sv, ".pm", 3);
5639 SvREADONLY_on(kid->op_sv);
5642 sv_catpvn(kid->op_sv, ".pm", 3);
5646 /* handle override, if any */
5647 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
5648 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
5649 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
5651 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5652 OP *kid = cUNOPo->op_first;
5653 cUNOPo->op_first = 0;
5655 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5656 append_elem(OP_LIST, kid,
5657 scalar(newUNOP(OP_RV2CV, 0,
5666 Perl_ck_return(pTHX_ OP *o)
5669 if (CvLVALUE(PL_compcv)) {
5670 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5671 mod(kid, OP_LEAVESUBLV);
5678 Perl_ck_retarget(pTHX_ OP *o)
5680 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5687 Perl_ck_select(pTHX_ OP *o)
5690 if (o->op_flags & OPf_KIDS) {
5691 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5692 if (kid && kid->op_sibling) {
5693 o->op_type = OP_SSELECT;
5694 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
5696 return fold_constants(o);
5700 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5701 if (kid && kid->op_type == OP_RV2GV)
5702 kid->op_private &= ~HINT_STRICT_REFS;
5707 Perl_ck_shift(pTHX_ OP *o)
5709 I32 type = o->op_type;
5711 if (!(o->op_flags & OPf_KIDS)) {
5715 argop = newUNOP(OP_RV2AV, 0,
5716 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
5717 return newUNOP(type, 0, scalar(argop));
5719 return scalar(modkids(ck_fun(o), type));
5723 Perl_ck_sort(pTHX_ OP *o)
5727 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
5729 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5730 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
5732 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
5734 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
5736 if (kid->op_type == OP_SCOPE) {
5740 else if (kid->op_type == OP_LEAVE) {
5741 if (o->op_type == OP_SORT) {
5742 op_null(kid); /* wipe out leave */
5745 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
5746 if (k->op_next == kid)
5748 /* don't descend into loops */
5749 else if (k->op_type == OP_ENTERLOOP
5750 || k->op_type == OP_ENTERITER)
5752 k = cLOOPx(k)->op_lastop;
5757 kid->op_next = 0; /* just disconnect the leave */
5758 k = kLISTOP->op_first;
5763 if (o->op_type == OP_SORT) {
5764 /* provide scalar context for comparison function/block */
5770 o->op_flags |= OPf_SPECIAL;
5772 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
5775 firstkid = firstkid->op_sibling;
5778 /* provide list context for arguments */
5779 if (o->op_type == OP_SORT)
5786 S_simplify_sort(pTHX_ OP *o)
5788 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5792 if (!(o->op_flags & OPf_STACKED))
5794 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
5795 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
5796 kid = kUNOP->op_first; /* get past null */
5797 if (kid->op_type != OP_SCOPE)
5799 kid = kLISTOP->op_last; /* get past scope */
5800 switch(kid->op_type) {
5808 k = kid; /* remember this node*/
5809 if (kBINOP->op_first->op_type != OP_RV2SV)
5811 kid = kBINOP->op_first; /* get past cmp */
5812 if (kUNOP->op_first->op_type != OP_GV)
5814 kid = kUNOP->op_first; /* get past rv2sv */
5816 if (GvSTASH(gv) != PL_curstash)
5818 if (strEQ(GvNAME(gv), "a"))
5820 else if (strEQ(GvNAME(gv), "b"))
5824 kid = k; /* back to cmp */
5825 if (kBINOP->op_last->op_type != OP_RV2SV)
5827 kid = kBINOP->op_last; /* down to 2nd arg */
5828 if (kUNOP->op_first->op_type != OP_GV)
5830 kid = kUNOP->op_first; /* get past rv2sv */
5832 if (GvSTASH(gv) != PL_curstash
5834 ? strNE(GvNAME(gv), "a")
5835 : strNE(GvNAME(gv), "b")))
5837 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
5839 o->op_private |= OPpSORT_REVERSE;
5840 if (k->op_type == OP_NCMP)
5841 o->op_private |= OPpSORT_NUMERIC;
5842 if (k->op_type == OP_I_NCMP)
5843 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
5844 kid = cLISTOPo->op_first->op_sibling;
5845 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
5846 op_free(kid); /* then delete it */
5850 Perl_ck_split(pTHX_ OP *o)
5854 if (o->op_flags & OPf_STACKED)
5855 return no_fh_allowed(o);
5857 kid = cLISTOPo->op_first;
5858 if (kid->op_type != OP_NULL)
5859 Perl_croak(aTHX_ "panic: ck_split");
5860 kid = kid->op_sibling;
5861 op_free(cLISTOPo->op_first);
5862 cLISTOPo->op_first = kid;
5864 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
5865 cLISTOPo->op_last = kid; /* There was only one element previously */
5868 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
5869 OP *sibl = kid->op_sibling;
5870 kid->op_sibling = 0;
5871 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
5872 if (cLISTOPo->op_first == cLISTOPo->op_last)
5873 cLISTOPo->op_last = kid;
5874 cLISTOPo->op_first = kid;
5875 kid->op_sibling = sibl;
5878 kid->op_type = OP_PUSHRE;
5879 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
5881 if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
5882 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
5883 "Use of /g modifier is meaningless in split");
5886 if (!kid->op_sibling)
5887 append_elem(OP_SPLIT, o, newDEFSVOP());
5889 kid = kid->op_sibling;
5892 if (!kid->op_sibling)
5893 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
5895 kid = kid->op_sibling;
5898 if (kid->op_sibling)
5899 return too_many_arguments(o,OP_DESC(o));
5905 Perl_ck_join(pTHX_ OP *o)
5907 if (ckWARN(WARN_SYNTAX)) {
5908 OP *kid = cLISTOPo->op_first->op_sibling;
5909 if (kid && kid->op_type == OP_MATCH) {
5910 char *pmstr = "STRING";
5911 if (PM_GETRE(kPMOP))
5912 pmstr = PM_GETRE(kPMOP)->precomp;
5913 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5914 "/%s/ should probably be written as \"%s\"",
5922 Perl_ck_subr(pTHX_ OP *o)
5924 OP *prev = ((cUNOPo->op_first->op_sibling)
5925 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
5926 OP *o2 = prev->op_sibling;
5933 I32 contextclass = 0;
5938 o->op_private |= OPpENTERSUB_HASTARG;
5939 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
5940 if (cvop->op_type == OP_RV2CV) {
5942 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
5943 op_null(cvop); /* disable rv2cv */
5944 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
5945 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
5946 GV *gv = cGVOPx_gv(tmpop);
5949 tmpop->op_private |= OPpEARLY_CV;
5952 namegv = CvANON(cv) ? gv : CvGV(cv);
5953 proto = SvPV((SV*)cv, n_a);
5955 if (CvASSERTION(cv)) {
5956 if (PL_hints & HINT_ASSERTING) {
5957 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
5958 o->op_private |= OPpENTERSUB_DB;
5962 if (ckWARN(WARN_ASSERTIONS) && !(PL_hints & HINT_ASSERTIONSSEEN)) {
5963 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
5964 "Impossible to activate assertion call");
5971 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
5972 if (o2->op_type == OP_CONST)
5973 o2->op_private &= ~OPpCONST_STRICT;
5974 else if (o2->op_type == OP_LIST) {
5975 OP *o = ((UNOP*)o2)->op_first->op_sibling;
5976 if (o && o->op_type == OP_CONST)
5977 o->op_private &= ~OPpCONST_STRICT;
5980 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5981 if (PERLDB_SUB && PL_curstash != PL_debstash)
5982 o->op_private |= OPpENTERSUB_DB;
5983 while (o2 != cvop) {
5987 return too_many_arguments(o, gv_ename(namegv));
6005 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6007 arg == 1 ? "block or sub {}" : "sub {}",
6008 gv_ename(namegv), o2);
6011 /* '*' allows any scalar type, including bareword */
6014 if (o2->op_type == OP_RV2GV)
6015 goto wrapref; /* autoconvert GLOB -> GLOBref */
6016 else if (o2->op_type == OP_CONST)
6017 o2->op_private &= ~OPpCONST_STRICT;
6018 else if (o2->op_type == OP_ENTERSUB) {
6019 /* accidental subroutine, revert to bareword */
6020 OP *gvop = ((UNOP*)o2)->op_first;
6021 if (gvop && gvop->op_type == OP_NULL) {
6022 gvop = ((UNOP*)gvop)->op_first;
6024 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6027 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6028 (gvop = ((UNOP*)gvop)->op_first) &&
6029 gvop->op_type == OP_GV)
6031 GV *gv = cGVOPx_gv(gvop);
6032 OP *sibling = o2->op_sibling;
6033 SV *n = newSVpvn("",0);
6035 gv_fullname3(n, gv, "");
6036 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6037 sv_chop(n, SvPVX(n)+6);
6038 o2 = newSVOP(OP_CONST, 0, n);
6039 prev->op_sibling = o2;
6040 o2->op_sibling = sibling;
6056 if (contextclass++ == 0) {
6057 e = strchr(proto, ']');
6058 if (!e || e == proto)
6071 while (*--p != '[');
6072 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6073 gv_ename(namegv), o2);
6079 if (o2->op_type == OP_RV2GV)
6082 bad_type(arg, "symbol", gv_ename(namegv), o2);
6085 if (o2->op_type == OP_ENTERSUB)
6088 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6091 if (o2->op_type == OP_RV2SV ||
6092 o2->op_type == OP_PADSV ||
6093 o2->op_type == OP_HELEM ||
6094 o2->op_type == OP_AELEM ||
6095 o2->op_type == OP_THREADSV)
6098 bad_type(arg, "scalar", gv_ename(namegv), o2);
6101 if (o2->op_type == OP_RV2AV ||
6102 o2->op_type == OP_PADAV)
6105 bad_type(arg, "array", gv_ename(namegv), o2);
6108 if (o2->op_type == OP_RV2HV ||
6109 o2->op_type == OP_PADHV)
6112 bad_type(arg, "hash", gv_ename(namegv), o2);
6117 OP* sib = kid->op_sibling;
6118 kid->op_sibling = 0;
6119 o2 = newUNOP(OP_REFGEN, 0, kid);
6120 o2->op_sibling = sib;
6121 prev->op_sibling = o2;
6123 if (contextclass && e) {
6138 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6139 gv_ename(namegv), cv);
6144 mod(o2, OP_ENTERSUB);
6146 o2 = o2->op_sibling;
6148 if (proto && !optional &&
6149 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6150 return too_few_arguments(o, gv_ename(namegv));
6153 o=newSVOP(OP_CONST, 0, newSViv(0));
6159 Perl_ck_svconst(pTHX_ OP *o)
6161 SvREADONLY_on(cSVOPo->op_sv);
6166 Perl_ck_trunc(pTHX_ OP *o)
6168 if (o->op_flags & OPf_KIDS) {
6169 SVOP *kid = (SVOP*)cUNOPo->op_first;
6171 if (kid->op_type == OP_NULL)
6172 kid = (SVOP*)kid->op_sibling;
6173 if (kid && kid->op_type == OP_CONST &&
6174 (kid->op_private & OPpCONST_BARE))
6176 o->op_flags |= OPf_SPECIAL;
6177 kid->op_private &= ~OPpCONST_STRICT;
6184 Perl_ck_substr(pTHX_ OP *o)
6187 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6188 OP *kid = cLISTOPo->op_first;
6190 if (kid->op_type == OP_NULL)
6191 kid = kid->op_sibling;
6193 kid->op_flags |= OPf_MOD;
6199 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6202 Perl_peep(pTHX_ register OP *o)
6204 register OP* oldop = 0;
6206 if (!o || o->op_seq)
6210 SAVEVPTR(PL_curcop);
6211 for (; o; o = o->op_next) {
6214 /* The special value -1 is used by the B::C compiler backend to indicate
6215 * that an op is statically defined and should not be freed */
6216 if (!PL_op_seqmax || PL_op_seqmax == (U16)-1)
6219 switch (o->op_type) {
6223 PL_curcop = ((COP*)o); /* for warnings */
6224 o->op_seq = PL_op_seqmax++;
6228 if (cSVOPo->op_private & OPpCONST_STRICT)
6229 no_bareword_allowed(o);
6231 case OP_METHOD_NAMED:
6232 /* Relocate sv to the pad for thread safety.
6233 * Despite being a "constant", the SV is written to,
6234 * for reference counts, sv_upgrade() etc. */
6236 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6237 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6238 /* If op_sv is already a PADTMP then it is being used by
6239 * some pad, so make a copy. */
6240 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6241 SvREADONLY_on(PAD_SVl(ix));
6242 SvREFCNT_dec(cSVOPo->op_sv);
6245 SvREFCNT_dec(PAD_SVl(ix));
6246 SvPADTMP_on(cSVOPo->op_sv);
6247 PAD_SETSV(ix, cSVOPo->op_sv);
6248 /* XXX I don't know how this isn't readonly already. */
6249 SvREADONLY_on(PAD_SVl(ix));
6251 cSVOPo->op_sv = Nullsv;
6255 o->op_seq = PL_op_seqmax++;
6259 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6260 if (o->op_next->op_private & OPpTARGET_MY) {
6261 if (o->op_flags & OPf_STACKED) /* chained concats */
6262 goto ignore_optimization;
6264 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6265 o->op_targ = o->op_next->op_targ;
6266 o->op_next->op_targ = 0;
6267 o->op_private |= OPpTARGET_MY;
6270 op_null(o->op_next);
6272 ignore_optimization:
6273 o->op_seq = PL_op_seqmax++;
6276 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6277 o->op_seq = PL_op_seqmax++;
6278 break; /* Scalar stub must produce undef. List stub is noop */
6282 if (o->op_targ == OP_NEXTSTATE
6283 || o->op_targ == OP_DBSTATE
6284 || o->op_targ == OP_SETSTATE)
6286 PL_curcop = ((COP*)o);
6288 /* XXX: We avoid setting op_seq here to prevent later calls
6289 to peep() from mistakenly concluding that optimisation
6290 has already occurred. This doesn't fix the real problem,
6291 though (See 20010220.007). AMS 20010719 */
6292 if (oldop && o->op_next) {
6293 oldop->op_next = o->op_next;
6301 if (oldop && o->op_next) {
6302 oldop->op_next = o->op_next;
6305 o->op_seq = PL_op_seqmax++;
6309 if (o->op_next->op_type == OP_RV2SV) {
6310 if (!(o->op_next->op_private & OPpDEREF)) {
6311 op_null(o->op_next);
6312 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6314 o->op_next = o->op_next->op_next;
6315 o->op_type = OP_GVSV;
6316 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6319 else if (o->op_next->op_type == OP_RV2AV) {
6320 OP* pop = o->op_next->op_next;
6322 if (pop && pop->op_type == OP_CONST &&
6323 (PL_op = pop->op_next) &&
6324 pop->op_next->op_type == OP_AELEM &&
6325 !(pop->op_next->op_private &
6326 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6327 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6332 op_null(o->op_next);
6333 op_null(pop->op_next);
6335 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6336 o->op_next = pop->op_next->op_next;
6337 o->op_type = OP_AELEMFAST;
6338 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6339 o->op_private = (U8)i;
6344 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6346 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6347 /* XXX could check prototype here instead of just carping */
6348 SV *sv = sv_newmortal();
6349 gv_efullname3(sv, gv, Nullch);
6350 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6351 "%"SVf"() called too early to check prototype",
6355 else if (o->op_next->op_type == OP_READLINE
6356 && o->op_next->op_next->op_type == OP_CONCAT
6357 && (o->op_next->op_next->op_flags & OPf_STACKED))
6359 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6360 o->op_type = OP_RCATLINE;
6361 o->op_flags |= OPf_STACKED;
6362 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6363 op_null(o->op_next->op_next);
6364 op_null(o->op_next);
6367 o->op_seq = PL_op_seqmax++;
6380 o->op_seq = PL_op_seqmax++;
6381 while (cLOGOP->op_other->op_type == OP_NULL)
6382 cLOGOP->op_other = cLOGOP->op_other->op_next;
6383 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6388 o->op_seq = PL_op_seqmax++;
6389 while (cLOOP->op_redoop->op_type == OP_NULL)
6390 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6391 peep(cLOOP->op_redoop);
6392 while (cLOOP->op_nextop->op_type == OP_NULL)
6393 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6394 peep(cLOOP->op_nextop);
6395 while (cLOOP->op_lastop->op_type == OP_NULL)
6396 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6397 peep(cLOOP->op_lastop);
6403 o->op_seq = PL_op_seqmax++;
6404 while (cPMOP->op_pmreplstart &&
6405 cPMOP->op_pmreplstart->op_type == OP_NULL)
6406 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6407 peep(cPMOP->op_pmreplstart);
6411 o->op_seq = PL_op_seqmax++;
6412 if (ckWARN(WARN_SYNTAX) && o->op_next
6413 && o->op_next->op_type == OP_NEXTSTATE) {
6414 if (o->op_next->op_sibling &&
6415 o->op_next->op_sibling->op_type != OP_EXIT &&
6416 o->op_next->op_sibling->op_type != OP_WARN &&
6417 o->op_next->op_sibling->op_type != OP_DIE) {
6418 line_t oldline = CopLINE(PL_curcop);
6420 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6421 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6422 "Statement unlikely to be reached");
6423 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6424 "\t(Maybe you meant system() when you said exec()?)\n");
6425 CopLINE_set(PL_curcop, oldline);
6436 o->op_seq = PL_op_seqmax++;
6438 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6441 /* Make the CONST have a shared SV */
6442 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6443 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6444 key = SvPV(sv, keylen);
6445 lexname = newSVpvn_share(key,
6446 SvUTF8(sv) ? -(I32)keylen : keylen,
6455 o->op_seq = PL_op_seqmax++;
6465 char* Perl_custom_op_name(pTHX_ OP* o)
6467 IV index = PTR2IV(o->op_ppaddr);
6471 if (!PL_custom_op_names) /* This probably shouldn't happen */
6472 return PL_op_name[OP_CUSTOM];
6474 keysv = sv_2mortal(newSViv(index));
6476 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
6478 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
6480 return SvPV_nolen(HeVAL(he));
6483 char* Perl_custom_op_desc(pTHX_ OP* o)
6485 IV index = PTR2IV(o->op_ppaddr);
6489 if (!PL_custom_op_descs)
6490 return PL_op_desc[OP_CUSTOM];
6492 keysv = sv_2mortal(newSViv(index));
6494 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
6496 return PL_op_desc[OP_CUSTOM];
6498 return SvPV_nolen(HeVAL(he));
6504 /* Efficient sub that returns a constant scalar value. */
6506 const_sv_xsub(pTHX_ CV* cv)
6511 Perl_croak(aTHX_ "usage: %s::%s()",
6512 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
6516 ST(0) = (SV*)XSANY.any_ptr;