3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
13 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
14 * youngest of the Old Took's daughters); and Mr. Drogo was his second
15 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
16 * either way, as the saying is, if you follow me." --the Gaffer
25 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
27 #if defined(PL_OP_SLAB_ALLOC)
29 #ifndef PERL_SLAB_SIZE
30 #define PERL_SLAB_SIZE 2048
34 Perl_Slab_Alloc(pTHX_ int m, size_t sz)
37 * To make incrementing use count easy PL_OpSlab is an I32 *
38 * To make inserting the link to slab PL_OpPtr is I32 **
39 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
40 * Add an overhead for pointer to slab and round up as a number of pointers
42 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
43 if ((PL_OpSpace -= sz) < 0) {
44 PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*));
48 Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **);
49 /* We reserve the 0'th I32 sized chunk as a use count */
50 PL_OpSlab = (I32 *) PL_OpPtr;
51 /* Reduce size by the use count word, and by the size we need.
52 * Latter is to mimic the '-=' in the if() above
54 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
55 /* Allocation pointer starts at the top.
56 Theory: because we build leaves before trunk allocating at end
57 means that at run time access is cache friendly upward
59 PL_OpPtr += PERL_SLAB_SIZE;
61 assert( PL_OpSpace >= 0 );
62 /* Move the allocation pointer down */
64 assert( PL_OpPtr > (I32 **) PL_OpSlab );
65 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
66 (*PL_OpSlab)++; /* Increment use count of slab */
67 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
68 assert( *PL_OpSlab > 0 );
69 return (void *)(PL_OpPtr + 1);
73 Perl_Slab_Free(pTHX_ void *op)
75 I32 **ptr = (I32 **) op;
77 assert( ptr-1 > (I32 **) slab );
78 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
82 # define PerlMemShared PerlMem
85 PerlMemShared_free(slab);
86 if (slab == PL_OpSlab) {
93 * In the following definition, the ", Nullop" is just to make the compiler
94 * think the expression is of the right type: croak actually does a Siglongjmp.
96 #define CHECKOP(type,o) \
97 ((PL_op_mask && PL_op_mask[type]) \
98 ? ( op_free((OP*)o), \
99 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
101 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
103 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
106 S_gv_ename(pTHX_ GV *gv)
109 SV* tmpsv = sv_newmortal();
110 gv_efullname3(tmpsv, gv, Nullch);
111 return SvPV(tmpsv,n_a);
115 S_no_fh_allowed(pTHX_ OP *o)
117 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
123 S_too_few_arguments(pTHX_ OP *o, char *name)
125 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
130 S_too_many_arguments(pTHX_ OP *o, char *name)
132 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
137 S_bad_type(pTHX_ I32 n, char *t, char *name, OP *kid)
139 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
140 (int)n, name, t, OP_DESC(kid)));
144 S_no_bareword_allowed(pTHX_ OP *o)
146 qerror(Perl_mess(aTHX_
147 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
151 /* "register" allocation */
154 Perl_allocmy(pTHX_ char *name)
158 /* complain about "my $_" etc etc */
159 if (!(PL_in_my == KEY_our ||
161 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
162 (name[1] == '_' && (int)strlen(name) > 2)))
164 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
165 /* 1999-02-27 mjd@plover.com */
167 p = strchr(name, '\0');
168 /* The next block assumes the buffer is at least 205 chars
169 long. At present, it's always at least 256 chars. */
171 strcpy(name+200, "...");
177 /* Move everything else down one character */
178 for (; p-name > 2; p--)
180 name[2] = toCTRL(name[1]);
183 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
186 /* check for duplicate declaration */
188 (bool)(PL_in_my == KEY_our),
189 (PL_curstash ? PL_curstash : PL_defstash)
192 if (PL_in_my_stash && *name != '$') {
193 yyerror(Perl_form(aTHX_
194 "Can't declare class for non-scalar %s in \"%s\"",
195 name, PL_in_my == KEY_our ? "our" : "my"));
198 /* allocate a spare slot and store the name in that slot */
200 off = pad_add_name(name,
203 ? (PL_curstash ? PL_curstash : PL_defstash)
214 Perl_op_free(pTHX_ OP *o)
216 register OP *kid, *nextkid;
219 if (!o || o->op_seq == (U16)-1)
222 if (o->op_private & OPpREFCOUNTED) {
223 switch (o->op_type) {
231 if (OpREFCNT_dec(o)) {
242 if (o->op_flags & OPf_KIDS) {
243 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
244 nextkid = kid->op_sibling; /* Get before next freeing kid */
250 type = (OPCODE)o->op_targ;
252 /* COP* is not cleared by op_clear() so that we may track line
253 * numbers etc even after null() */
254 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
262 Perl_op_clear(pTHX_ OP *o)
265 switch (o->op_type) {
266 case OP_NULL: /* Was holding old type, if any. */
267 case OP_ENTEREVAL: /* Was holding hints. */
271 if (!(o->op_flags & OPf_REF)
272 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
279 if (cPADOPo->op_padix > 0) {
280 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
281 * may still exist on the pad */
282 pad_swipe(cPADOPo->op_padix, TRUE);
283 cPADOPo->op_padix = 0;
286 SvREFCNT_dec(cSVOPo->op_sv);
287 cSVOPo->op_sv = Nullsv;
290 case OP_METHOD_NAMED:
292 SvREFCNT_dec(cSVOPo->op_sv);
293 cSVOPo->op_sv = Nullsv;
296 Even if op_clear does a pad_free for the target of the op,
297 pad_free doesn't actually remove the sv that exists in the bad
298 instead it lives on. This results in that it could be reused as
299 a target later on when the pad was reallocated.
302 pad_swipe(o->op_targ,1);
311 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
315 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
316 SvREFCNT_dec(cSVOPo->op_sv);
317 cSVOPo->op_sv = Nullsv;
320 Safefree(cPVOPo->op_pv);
321 cPVOPo->op_pv = Nullch;
325 op_free(cPMOPo->op_pmreplroot);
329 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
330 /* No GvIN_PAD_off here, because other references may still
331 * exist on the pad */
332 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
335 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
342 HV *pmstash = PmopSTASH(cPMOPo);
343 if (pmstash && SvREFCNT(pmstash)) {
344 PMOP *pmop = HvPMROOT(pmstash);
345 PMOP *lastpmop = NULL;
347 if (cPMOPo == pmop) {
349 lastpmop->op_pmnext = pmop->op_pmnext;
351 HvPMROOT(pmstash) = pmop->op_pmnext;
355 pmop = pmop->op_pmnext;
358 PmopSTASH_free(cPMOPo);
360 cPMOPo->op_pmreplroot = Nullop;
361 /* we use the "SAFE" version of the PM_ macros here
362 * since sv_clean_all might release some PMOPs
363 * after PL_regex_padav has been cleared
364 * and the clearing of PL_regex_padav needs to
365 * happen before sv_clean_all
367 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
368 PM_SETRE_SAFE(cPMOPo, (REGEXP*)NULL);
370 if(PL_regex_pad) { /* We could be in destruction */
371 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
372 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
373 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
380 if (o->op_targ > 0) {
381 pad_free(o->op_targ);
387 S_cop_free(pTHX_ COP* cop)
389 Safefree(cop->cop_label); /* FIXME: treaddead ??? */
392 if (! specialWARN(cop->cop_warnings))
393 SvREFCNT_dec(cop->cop_warnings);
394 if (! specialCopIO(cop->cop_io)) {
398 char *s = SvPV(cop->cop_io,len);
399 Perl_warn(aTHX_ "io='%.*s'",(int) len,s); /* ??? --jhi */
402 SvREFCNT_dec(cop->cop_io);
408 Perl_op_null(pTHX_ OP *o)
410 if (o->op_type == OP_NULL)
413 o->op_targ = o->op_type;
414 o->op_type = OP_NULL;
415 o->op_ppaddr = PL_ppaddr[OP_NULL];
418 /* Contextualizers */
420 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
423 Perl_linklist(pTHX_ OP *o)
430 /* establish postfix order */
431 if (cUNOPo->op_first) {
432 o->op_next = LINKLIST(cUNOPo->op_first);
433 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
435 kid->op_next = LINKLIST(kid->op_sibling);
447 Perl_scalarkids(pTHX_ OP *o)
450 if (o && o->op_flags & OPf_KIDS) {
451 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
458 S_scalarboolean(pTHX_ OP *o)
460 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
461 if (ckWARN(WARN_SYNTAX)) {
462 line_t oldline = CopLINE(PL_curcop);
464 if (PL_copline != NOLINE)
465 CopLINE_set(PL_curcop, PL_copline);
466 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
467 CopLINE_set(PL_curcop, oldline);
474 Perl_scalar(pTHX_ OP *o)
478 /* assumes no premature commitment */
479 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
480 || o->op_type == OP_RETURN)
485 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
487 switch (o->op_type) {
489 scalar(cBINOPo->op_first);
494 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
498 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
499 if (!kPMOP->op_pmreplroot)
500 deprecate_old("implicit split to @_");
508 if (o->op_flags & OPf_KIDS) {
509 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
515 kid = cLISTOPo->op_first;
517 while ((kid = kid->op_sibling)) {
523 WITH_THR(PL_curcop = &PL_compiling);
528 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
534 WITH_THR(PL_curcop = &PL_compiling);
537 if (ckWARN(WARN_VOID))
538 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
544 Perl_scalarvoid(pTHX_ OP *o)
551 if (o->op_type == OP_NEXTSTATE
552 || o->op_type == OP_SETSTATE
553 || o->op_type == OP_DBSTATE
554 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
555 || o->op_targ == OP_SETSTATE
556 || o->op_targ == OP_DBSTATE)))
557 PL_curcop = (COP*)o; /* for warning below */
559 /* assumes no premature commitment */
560 want = o->op_flags & OPf_WANT;
561 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
562 || o->op_type == OP_RETURN)
567 if ((o->op_private & OPpTARGET_MY)
568 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
570 return scalar(o); /* As if inside SASSIGN */
573 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
575 switch (o->op_type) {
577 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
581 if (o->op_flags & OPf_STACKED)
585 if (o->op_private == 4)
657 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
658 useless = OP_DESC(o);
665 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
666 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
667 useless = "a variable";
672 if (cSVOPo->op_private & OPpCONST_STRICT)
673 no_bareword_allowed(o);
675 if (ckWARN(WARN_VOID)) {
676 useless = "a constant";
677 /* the constants 0 and 1 are permitted as they are
678 conventionally used as dummies in constructs like
679 1 while some_condition_with_side_effects; */
680 if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
682 else if (SvPOK(sv)) {
683 /* perl4's way of mixing documentation and code
684 (before the invention of POD) was based on a
685 trick to mix nroff and perl code. The trick was
686 built upon these three nroff macros being used in
687 void context. The pink camel has the details in
688 the script wrapman near page 319. */
689 if (strnEQ(SvPVX(sv), "di", 2) ||
690 strnEQ(SvPVX(sv), "ds", 2) ||
691 strnEQ(SvPVX(sv), "ig", 2))
696 op_null(o); /* don't execute or even remember it */
700 o->op_type = OP_PREINC; /* pre-increment is faster */
701 o->op_ppaddr = PL_ppaddr[OP_PREINC];
705 o->op_type = OP_PREDEC; /* pre-decrement is faster */
706 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
713 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
718 if (o->op_flags & OPf_STACKED)
725 if (!(o->op_flags & OPf_KIDS))
734 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
741 /* all requires must return a boolean value */
742 o->op_flags &= ~OPf_WANT;
747 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
748 if (!kPMOP->op_pmreplroot)
749 deprecate_old("implicit split to @_");
753 if (useless && ckWARN(WARN_VOID))
754 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
759 Perl_listkids(pTHX_ OP *o)
762 if (o && o->op_flags & OPf_KIDS) {
763 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
770 Perl_list(pTHX_ OP *o)
774 /* assumes no premature commitment */
775 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
776 || o->op_type == OP_RETURN)
781 if ((o->op_private & OPpTARGET_MY)
782 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
784 return o; /* As if inside SASSIGN */
787 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
789 switch (o->op_type) {
792 list(cBINOPo->op_first);
797 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
805 if (!(o->op_flags & OPf_KIDS))
807 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
808 list(cBINOPo->op_first);
809 return gen_constant_list(o);
816 kid = cLISTOPo->op_first;
818 while ((kid = kid->op_sibling)) {
824 WITH_THR(PL_curcop = &PL_compiling);
828 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
834 WITH_THR(PL_curcop = &PL_compiling);
837 /* all requires must return a boolean value */
838 o->op_flags &= ~OPf_WANT;
845 Perl_scalarseq(pTHX_ OP *o)
850 if (o->op_type == OP_LINESEQ ||
851 o->op_type == OP_SCOPE ||
852 o->op_type == OP_LEAVE ||
853 o->op_type == OP_LEAVETRY)
855 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
856 if (kid->op_sibling) {
860 PL_curcop = &PL_compiling;
862 o->op_flags &= ~OPf_PARENS;
863 if (PL_hints & HINT_BLOCK_SCOPE)
864 o->op_flags |= OPf_PARENS;
867 o = newOP(OP_STUB, 0);
872 S_modkids(pTHX_ OP *o, I32 type)
875 if (o && o->op_flags & OPf_KIDS) {
876 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
882 /* Propagate lvalue ("modifiable") context to an op and it's children.
883 * 'type' represents the context type, roughly based on the type of op that
884 * would do the modifying, although local() is represented by OP_NULL.
885 * It's responsible for detecting things that can't be modified, flag
886 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
887 * might have to vivify a reference in $x), and so on.
889 * For example, "$a+1 = 2" would cause mod() to be called with o being
890 * OP_ADD and type being OP_SASSIGN, and would output an error.
894 Perl_mod(pTHX_ OP *o, I32 type)
897 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
900 if (!o || PL_error_count)
903 if ((o->op_private & OPpTARGET_MY)
904 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
909 switch (o->op_type) {
915 if (!(o->op_private & (OPpCONST_ARYBASE)))
917 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
918 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
922 SAVEI32(PL_compiling.cop_arybase);
923 PL_compiling.cop_arybase = 0;
925 else if (type == OP_REFGEN)
928 Perl_croak(aTHX_ "That use of $[ is unsupported");
931 if (o->op_flags & OPf_PARENS)
935 if ((type == OP_UNDEF || type == OP_REFGEN) &&
936 !(o->op_flags & OPf_STACKED)) {
937 o->op_type = OP_RV2CV; /* entersub => rv2cv */
938 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
939 assert(cUNOPo->op_first->op_type == OP_NULL);
940 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
943 else if (o->op_private & OPpENTERSUB_NOMOD)
945 else { /* lvalue subroutine call */
946 o->op_private |= OPpLVAL_INTRO;
947 PL_modcount = RETURN_UNLIMITED_NUMBER;
948 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
949 /* Backward compatibility mode: */
950 o->op_private |= OPpENTERSUB_INARGS;
953 else { /* Compile-time error message: */
954 OP *kid = cUNOPo->op_first;
958 if (kid->op_type == OP_PUSHMARK)
960 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
962 "panic: unexpected lvalue entersub "
963 "args: type/targ %ld:%"UVuf,
964 (long)kid->op_type, (UV)kid->op_targ);
965 kid = kLISTOP->op_first;
967 while (kid->op_sibling)
968 kid = kid->op_sibling;
969 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
971 if (kid->op_type == OP_METHOD_NAMED
972 || kid->op_type == OP_METHOD)
976 NewOp(1101, newop, 1, UNOP);
977 newop->op_type = OP_RV2CV;
978 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
979 newop->op_first = Nullop;
980 newop->op_next = (OP*)newop;
981 kid->op_sibling = (OP*)newop;
982 newop->op_private |= OPpLVAL_INTRO;
986 if (kid->op_type != OP_RV2CV)
988 "panic: unexpected lvalue entersub "
989 "entry via type/targ %ld:%"UVuf,
990 (long)kid->op_type, (UV)kid->op_targ);
991 kid->op_private |= OPpLVAL_INTRO;
992 break; /* Postpone until runtime */
996 kid = kUNOP->op_first;
997 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
998 kid = kUNOP->op_first;
999 if (kid->op_type == OP_NULL)
1001 "Unexpected constant lvalue entersub "
1002 "entry via type/targ %ld:%"UVuf,
1003 (long)kid->op_type, (UV)kid->op_targ);
1004 if (kid->op_type != OP_GV) {
1005 /* Restore RV2CV to check lvalueness */
1007 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1008 okid->op_next = kid->op_next;
1009 kid->op_next = okid;
1012 okid->op_next = Nullop;
1013 okid->op_type = OP_RV2CV;
1015 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1016 okid->op_private |= OPpLVAL_INTRO;
1020 cv = GvCV(kGVOP_gv);
1030 /* grep, foreach, subcalls, refgen */
1031 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1033 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1034 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1036 : (o->op_type == OP_ENTERSUB
1037 ? "non-lvalue subroutine call"
1039 type ? PL_op_desc[type] : "local"));
1053 case OP_RIGHT_SHIFT:
1062 if (!(o->op_flags & OPf_STACKED))
1069 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1075 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1076 PL_modcount = RETURN_UNLIMITED_NUMBER;
1077 return o; /* Treat \(@foo) like ordinary list. */
1081 if (scalar_mod_type(o, type))
1083 ref(cUNOPo->op_first, o->op_type);
1087 if (type == OP_LEAVESUBLV)
1088 o->op_private |= OPpMAYBE_LVSUB;
1094 PL_modcount = RETURN_UNLIMITED_NUMBER;
1097 ref(cUNOPo->op_first, o->op_type);
1102 PL_hints |= HINT_BLOCK_SCOPE;
1117 PL_modcount = RETURN_UNLIMITED_NUMBER;
1118 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1119 return o; /* Treat \(@foo) like ordinary list. */
1120 if (scalar_mod_type(o, type))
1122 if (type == OP_LEAVESUBLV)
1123 o->op_private |= OPpMAYBE_LVSUB;
1127 if (!type) /* local() */
1128 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1129 PAD_COMPNAME_PV(o->op_targ));
1137 if (type != OP_SASSIGN)
1141 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1146 if (type == OP_LEAVESUBLV)
1147 o->op_private |= OPpMAYBE_LVSUB;
1149 pad_free(o->op_targ);
1150 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1151 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1152 if (o->op_flags & OPf_KIDS)
1153 mod(cBINOPo->op_first->op_sibling, type);
1158 ref(cBINOPo->op_first, o->op_type);
1159 if (type == OP_ENTERSUB &&
1160 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1161 o->op_private |= OPpLVAL_DEFER;
1162 if (type == OP_LEAVESUBLV)
1163 o->op_private |= OPpMAYBE_LVSUB;
1173 if (o->op_flags & OPf_KIDS)
1174 mod(cLISTOPo->op_last, type);
1179 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1181 else if (!(o->op_flags & OPf_KIDS))
1183 if (o->op_targ != OP_LIST) {
1184 mod(cBINOPo->op_first, type);
1190 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1195 if (type != OP_LEAVESUBLV)
1197 break; /* mod()ing was handled by ck_return() */
1200 /* [20011101.069] File test operators interpret OPf_REF to mean that
1201 their argument is a filehandle; thus \stat(".") should not set
1203 if (type == OP_REFGEN &&
1204 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1207 if (type != OP_LEAVESUBLV)
1208 o->op_flags |= OPf_MOD;
1210 if (type == OP_AASSIGN || type == OP_SASSIGN)
1211 o->op_flags |= OPf_SPECIAL|OPf_REF;
1212 else if (!type) { /* local() */
1215 o->op_private |= OPpLVAL_INTRO;
1216 o->op_flags &= ~OPf_SPECIAL;
1217 PL_hints |= HINT_BLOCK_SCOPE;
1222 if (ckWARN(WARN_SYNTAX)) {
1223 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1224 "Useless localization of %s", OP_DESC(o));
1228 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1229 && type != OP_LEAVESUBLV)
1230 o->op_flags |= OPf_REF;
1235 S_scalar_mod_type(pTHX_ OP *o, I32 type)
1239 if (o->op_type == OP_RV2GV)
1263 case OP_RIGHT_SHIFT:
1282 S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
1284 switch (o->op_type) {
1292 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1305 Perl_refkids(pTHX_ OP *o, I32 type)
1308 if (o && o->op_flags & OPf_KIDS) {
1309 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1316 Perl_ref(pTHX_ OP *o, I32 type)
1320 if (!o || PL_error_count)
1323 switch (o->op_type) {
1325 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1326 !(o->op_flags & OPf_STACKED)) {
1327 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1328 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1329 assert(cUNOPo->op_first->op_type == OP_NULL);
1330 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1331 o->op_flags |= OPf_SPECIAL;
1336 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1340 if (type == OP_DEFINED)
1341 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1342 ref(cUNOPo->op_first, o->op_type);
1345 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1346 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1347 : type == OP_RV2HV ? OPpDEREF_HV
1349 o->op_flags |= OPf_MOD;
1354 o->op_flags |= OPf_MOD; /* XXX ??? */
1359 o->op_flags |= OPf_REF;
1362 if (type == OP_DEFINED)
1363 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1364 ref(cUNOPo->op_first, o->op_type);
1369 o->op_flags |= OPf_REF;
1374 if (!(o->op_flags & OPf_KIDS))
1376 ref(cBINOPo->op_first, type);
1380 ref(cBINOPo->op_first, o->op_type);
1381 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1382 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1383 : type == OP_RV2HV ? OPpDEREF_HV
1385 o->op_flags |= OPf_MOD;
1393 if (!(o->op_flags & OPf_KIDS))
1395 ref(cLISTOPo->op_last, type);
1405 S_dup_attrlist(pTHX_ OP *o)
1409 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1410 * where the first kid is OP_PUSHMARK and the remaining ones
1411 * are OP_CONST. We need to push the OP_CONST values.
1413 if (o->op_type == OP_CONST)
1414 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1416 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1417 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1418 if (o->op_type == OP_CONST)
1419 rop = append_elem(OP_LIST, rop,
1420 newSVOP(OP_CONST, o->op_flags,
1421 SvREFCNT_inc(cSVOPo->op_sv)));
1428 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1432 /* fake up C<use attributes $pkg,$rv,@attrs> */
1433 ENTER; /* need to protect against side-effects of 'use' */
1436 stashsv = newSVpv(HvNAME(stash), 0);
1438 stashsv = &PL_sv_no;
1440 #define ATTRSMODULE "attributes"
1441 #define ATTRSMODULE_PM "attributes.pm"
1445 /* Don't force the C<use> if we don't need it. */
1446 svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
1447 sizeof(ATTRSMODULE_PM)-1, 0);
1448 if (svp && *svp != &PL_sv_undef)
1449 ; /* already in %INC */
1451 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1452 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1456 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1457 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1459 prepend_elem(OP_LIST,
1460 newSVOP(OP_CONST, 0, stashsv),
1461 prepend_elem(OP_LIST,
1462 newSVOP(OP_CONST, 0,
1464 dup_attrlist(attrs))));
1470 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1472 OP *pack, *imop, *arg;
1478 assert(target->op_type == OP_PADSV ||
1479 target->op_type == OP_PADHV ||
1480 target->op_type == OP_PADAV);
1482 /* Ensure that attributes.pm is loaded. */
1483 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1485 /* Need package name for method call. */
1486 pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
1488 /* Build up the real arg-list. */
1490 stashsv = newSVpv(HvNAME(stash), 0);
1492 stashsv = &PL_sv_no;
1493 arg = newOP(OP_PADSV, 0);
1494 arg->op_targ = target->op_targ;
1495 arg = prepend_elem(OP_LIST,
1496 newSVOP(OP_CONST, 0, stashsv),
1497 prepend_elem(OP_LIST,
1498 newUNOP(OP_REFGEN, 0,
1499 mod(arg, OP_REFGEN)),
1500 dup_attrlist(attrs)));
1502 /* Fake up a method call to import */
1503 meth = newSVpvn("import", 6);
1504 (void)SvUPGRADE(meth, SVt_PVIV);
1505 (void)SvIOK_on(meth);
1506 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
1507 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1508 append_elem(OP_LIST,
1509 prepend_elem(OP_LIST, pack, list(arg)),
1510 newSVOP(OP_METHOD_NAMED, 0, meth)));
1511 imop->op_private |= OPpENTERSUB_NOMOD;
1513 /* Combine the ops. */
1514 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1518 =notfor apidoc apply_attrs_string
1520 Attempts to apply a list of attributes specified by the C<attrstr> and
1521 C<len> arguments to the subroutine identified by the C<cv> argument which
1522 is expected to be associated with the package identified by the C<stashpv>
1523 argument (see L<attributes>). It gets this wrong, though, in that it
1524 does not correctly identify the boundaries of the individual attribute
1525 specifications within C<attrstr>. This is not really intended for the
1526 public API, but has to be listed here for systems such as AIX which
1527 need an explicit export list for symbols. (It's called from XS code
1528 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1529 to respect attribute syntax properly would be welcome.
1535 Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
1536 char *attrstr, STRLEN len)
1541 len = strlen(attrstr);
1545 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1547 char *sstr = attrstr;
1548 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1549 attrs = append_elem(OP_LIST, attrs,
1550 newSVOP(OP_CONST, 0,
1551 newSVpvn(sstr, attrstr-sstr)));
1555 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1556 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1557 Nullsv, prepend_elem(OP_LIST,
1558 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1559 prepend_elem(OP_LIST,
1560 newSVOP(OP_CONST, 0,
1566 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1571 if (!o || PL_error_count)
1575 if (type == OP_LIST) {
1576 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1577 my_kid(kid, attrs, imopsp);
1578 } else if (type == OP_UNDEF) {
1580 } else if (type == OP_RV2SV || /* "our" declaration */
1582 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1583 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1584 yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
1585 OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
1587 GV *gv = cGVOPx_gv(cUNOPo->op_first);
1589 PL_in_my_stash = Nullhv;
1590 apply_attrs(GvSTASH(gv),
1591 (type == OP_RV2SV ? GvSV(gv) :
1592 type == OP_RV2AV ? (SV*)GvAV(gv) :
1593 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1596 o->op_private |= OPpOUR_INTRO;
1599 else if (type != OP_PADSV &&
1602 type != OP_PUSHMARK)
1604 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1606 PL_in_my == KEY_our ? "our" : "my"));
1609 else if (attrs && type != OP_PUSHMARK) {
1613 PL_in_my_stash = Nullhv;
1615 /* check for C<my Dog $spot> when deciding package */
1616 stash = PAD_COMPNAME_TYPE(o->op_targ);
1618 stash = PL_curstash;
1619 apply_attrs_my(stash, o, attrs, imopsp);
1621 o->op_flags |= OPf_MOD;
1622 o->op_private |= OPpLVAL_INTRO;
1627 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1630 int maybe_scalar = 0;
1632 /* [perl #17376]: this appears to be premature, and results in code such as
1633 C< our(%x); > executing in list mode rather than void mode */
1635 if (o->op_flags & OPf_PARENS)
1644 o = my_kid(o, attrs, &rops);
1646 if (maybe_scalar && o->op_type == OP_PADSV) {
1647 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1648 o->op_private |= OPpLVAL_INTRO;
1651 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1654 PL_in_my_stash = Nullhv;
1659 Perl_my(pTHX_ OP *o)
1661 return my_attrs(o, Nullop);
1665 Perl_sawparens(pTHX_ OP *o)
1668 o->op_flags |= OPf_PARENS;
1673 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1677 if (ckWARN(WARN_MISC) &&
1678 (left->op_type == OP_RV2AV ||
1679 left->op_type == OP_RV2HV ||
1680 left->op_type == OP_PADAV ||
1681 left->op_type == OP_PADHV)) {
1682 char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
1683 right->op_type == OP_TRANS)
1684 ? right->op_type : OP_MATCH];
1685 const char *sample = ((left->op_type == OP_RV2AV ||
1686 left->op_type == OP_PADAV)
1687 ? "@array" : "%hash");
1688 Perl_warner(aTHX_ packWARN(WARN_MISC),
1689 "Applying %s to %s will act on scalar(%s)",
1690 desc, sample, sample);
1693 if (right->op_type == OP_CONST &&
1694 cSVOPx(right)->op_private & OPpCONST_BARE &&
1695 cSVOPx(right)->op_private & OPpCONST_STRICT)
1697 no_bareword_allowed(right);
1700 if (!(right->op_flags & OPf_STACKED) &&
1701 (right->op_type == OP_MATCH ||
1702 right->op_type == OP_SUBST ||
1703 right->op_type == OP_TRANS)) {
1704 right->op_flags |= OPf_STACKED;
1705 if (right->op_type != OP_MATCH &&
1706 ! (right->op_type == OP_TRANS &&
1707 right->op_private & OPpTRANS_IDENTICAL))
1708 left = mod(left, right->op_type);
1709 if (right->op_type == OP_TRANS)
1710 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
1712 o = prepend_elem(right->op_type, scalar(left), right);
1714 return newUNOP(OP_NOT, 0, scalar(o));
1718 return bind_match(type, left,
1719 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
1723 Perl_invert(pTHX_ OP *o)
1727 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
1728 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1732 Perl_scope(pTHX_ OP *o)
1735 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1736 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1737 o->op_type = OP_LEAVE;
1738 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1740 else if (o->op_type == OP_LINESEQ) {
1742 o->op_type = OP_SCOPE;
1743 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1744 kid = ((LISTOP*)o)->op_first;
1745 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
1749 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
1755 Perl_save_hints(pTHX)
1758 SAVESPTR(GvHV(PL_hintgv));
1759 GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
1760 SAVEFREESV(GvHV(PL_hintgv));
1764 Perl_block_start(pTHX_ int full)
1766 int retval = PL_savestack_ix;
1767 /* If there were syntax errors, don't try to start a block */
1768 if (PL_yynerrs) return retval;
1770 pad_block_start(full);
1772 PL_hints &= ~HINT_BLOCK_SCOPE;
1773 SAVESPTR(PL_compiling.cop_warnings);
1774 if (! specialWARN(PL_compiling.cop_warnings)) {
1775 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1776 SAVEFREESV(PL_compiling.cop_warnings) ;
1778 SAVESPTR(PL_compiling.cop_io);
1779 if (! specialCopIO(PL_compiling.cop_io)) {
1780 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1781 SAVEFREESV(PL_compiling.cop_io) ;
1787 Perl_block_end(pTHX_ I32 floor, OP *seq)
1789 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1790 OP* retval = scalarseq(seq);
1791 /* If there were syntax errors, don't try to close a block */
1792 if (PL_yynerrs) return retval;
1794 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
1796 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
1804 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1808 Perl_newPROG(pTHX_ OP *o)
1813 PL_eval_root = newUNOP(OP_LEAVEEVAL,
1814 ((PL_in_eval & EVAL_KEEPERR)
1815 ? OPf_SPECIAL : 0), o);
1816 PL_eval_start = linklist(PL_eval_root);
1817 PL_eval_root->op_private |= OPpREFCOUNTED;
1818 OpREFCNT_set(PL_eval_root, 1);
1819 PL_eval_root->op_next = 0;
1820 CALL_PEEP(PL_eval_start);
1823 if (o->op_type == OP_STUB) {
1824 PL_comppad_name = 0;
1828 PL_main_root = scope(sawparens(scalarvoid(o)));
1829 PL_curcop = &PL_compiling;
1830 PL_main_start = LINKLIST(PL_main_root);
1831 PL_main_root->op_private |= OPpREFCOUNTED;
1832 OpREFCNT_set(PL_main_root, 1);
1833 PL_main_root->op_next = 0;
1834 CALL_PEEP(PL_main_start);
1837 /* Register with debugger */
1839 CV *cv = get_cv("DB::postponed", FALSE);
1843 XPUSHs((SV*)CopFILEGV(&PL_compiling));
1845 call_sv((SV*)cv, G_DISCARD);
1852 Perl_localize(pTHX_ OP *o, I32 lex)
1854 if (o->op_flags & OPf_PARENS)
1855 /* [perl #17376]: this appears to be premature, and results in code such as
1856 C< our(%x); > executing in list mode rather than void mode */
1863 if (ckWARN(WARN_PARENTHESIS)
1864 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
1866 char *s = PL_bufptr;
1869 /* some heuristics to detect a potential error */
1870 while (*s && (strchr(", \t\n", *s)
1871 || (strchr("@$%*", *s) && ++sigil) ))
1874 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)
1875 || strchr("@$%*, \t\n", *s)))
1878 if (*s == ';' || *s == '=')
1879 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
1880 "Parentheses missing around \"%s\" list",
1881 lex ? (PL_in_my == KEY_our ? "our" : "my")
1889 o = mod(o, OP_NULL); /* a bit kludgey */
1891 PL_in_my_stash = Nullhv;
1896 Perl_jmaybe(pTHX_ OP *o)
1898 if (o->op_type == OP_LIST) {
1900 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
1901 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
1907 Perl_fold_constants(pTHX_ register OP *o)
1910 I32 type = o->op_type;
1913 if (PL_opargs[type] & OA_RETSCALAR)
1915 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
1916 o->op_targ = pad_alloc(type, SVs_PADTMP);
1918 /* integerize op, unless it happens to be C<-foo>.
1919 * XXX should pp_i_negate() do magic string negation instead? */
1920 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
1921 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
1922 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
1924 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
1927 if (!(PL_opargs[type] & OA_FOLDCONST))
1932 /* XXX might want a ck_negate() for this */
1933 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
1945 /* XXX what about the numeric ops? */
1946 if (PL_hints & HINT_LOCALE)
1951 goto nope; /* Don't try to run w/ errors */
1953 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
1954 if ((curop->op_type != OP_CONST ||
1955 (curop->op_private & OPpCONST_BARE)) &&
1956 curop->op_type != OP_LIST &&
1957 curop->op_type != OP_SCALAR &&
1958 curop->op_type != OP_NULL &&
1959 curop->op_type != OP_PUSHMARK)
1965 curop = LINKLIST(o);
1969 sv = *(PL_stack_sp--);
1970 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
1971 pad_swipe(o->op_targ, FALSE);
1972 else if (SvTEMP(sv)) { /* grab mortal temp? */
1973 (void)SvREFCNT_inc(sv);
1977 if (type == OP_RV2GV)
1978 return newGVOP(OP_GV, 0, (GV*)sv);
1979 return newSVOP(OP_CONST, 0, sv);
1986 Perl_gen_constant_list(pTHX_ register OP *o)
1989 I32 oldtmps_floor = PL_tmps_floor;
1993 return o; /* Don't attempt to run with errors */
1995 PL_op = curop = LINKLIST(o);
2002 PL_tmps_floor = oldtmps_floor;
2004 o->op_type = OP_RV2AV;
2005 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2006 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2007 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2008 o->op_seq = 0; /* needs to be revisited in peep() */
2009 curop = ((UNOP*)o)->op_first;
2010 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2017 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2019 if (!o || o->op_type != OP_LIST)
2020 o = newLISTOP(OP_LIST, 0, o, Nullop);
2022 o->op_flags &= ~OPf_WANT;
2024 if (!(PL_opargs[type] & OA_MARK))
2025 op_null(cLISTOPo->op_first);
2027 o->op_type = (OPCODE)type;
2028 o->op_ppaddr = PL_ppaddr[type];
2029 o->op_flags |= flags;
2031 o = CHECKOP(type, o);
2032 if (o->op_type != type)
2035 return fold_constants(o);
2038 /* List constructors */
2041 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2049 if (first->op_type != type
2050 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2052 return newLISTOP(type, 0, first, last);
2055 if (first->op_flags & OPf_KIDS)
2056 ((LISTOP*)first)->op_last->op_sibling = last;
2058 first->op_flags |= OPf_KIDS;
2059 ((LISTOP*)first)->op_first = last;
2061 ((LISTOP*)first)->op_last = last;
2066 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2074 if (first->op_type != type)
2075 return prepend_elem(type, (OP*)first, (OP*)last);
2077 if (last->op_type != type)
2078 return append_elem(type, (OP*)first, (OP*)last);
2080 first->op_last->op_sibling = last->op_first;
2081 first->op_last = last->op_last;
2082 first->op_flags |= (last->op_flags & OPf_KIDS);
2090 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2098 if (last->op_type == type) {
2099 if (type == OP_LIST) { /* already a PUSHMARK there */
2100 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2101 ((LISTOP*)last)->op_first->op_sibling = first;
2102 if (!(first->op_flags & OPf_PARENS))
2103 last->op_flags &= ~OPf_PARENS;
2106 if (!(last->op_flags & OPf_KIDS)) {
2107 ((LISTOP*)last)->op_last = first;
2108 last->op_flags |= OPf_KIDS;
2110 first->op_sibling = ((LISTOP*)last)->op_first;
2111 ((LISTOP*)last)->op_first = first;
2113 last->op_flags |= OPf_KIDS;
2117 return newLISTOP(type, 0, first, last);
2123 Perl_newNULLLIST(pTHX)
2125 return newOP(OP_STUB, 0);
2129 Perl_force_list(pTHX_ OP *o)
2131 if (!o || o->op_type != OP_LIST)
2132 o = newLISTOP(OP_LIST, 0, o, Nullop);
2138 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2142 NewOp(1101, listop, 1, LISTOP);
2144 listop->op_type = (OPCODE)type;
2145 listop->op_ppaddr = PL_ppaddr[type];
2148 listop->op_flags = (U8)flags;
2152 else if (!first && last)
2155 first->op_sibling = last;
2156 listop->op_first = first;
2157 listop->op_last = last;
2158 if (type == OP_LIST) {
2160 pushop = newOP(OP_PUSHMARK, 0);
2161 pushop->op_sibling = first;
2162 listop->op_first = pushop;
2163 listop->op_flags |= OPf_KIDS;
2165 listop->op_last = pushop;
2168 return CHECKOP(type, listop);
2172 Perl_newOP(pTHX_ I32 type, I32 flags)
2175 NewOp(1101, o, 1, OP);
2176 o->op_type = (OPCODE)type;
2177 o->op_ppaddr = PL_ppaddr[type];
2178 o->op_flags = (U8)flags;
2181 o->op_private = (U8)(0 | (flags >> 8));
2182 if (PL_opargs[type] & OA_RETSCALAR)
2184 if (PL_opargs[type] & OA_TARGET)
2185 o->op_targ = pad_alloc(type, SVs_PADTMP);
2186 return CHECKOP(type, o);
2190 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2195 first = newOP(OP_STUB, 0);
2196 if (PL_opargs[type] & OA_MARK)
2197 first = force_list(first);
2199 NewOp(1101, unop, 1, UNOP);
2200 unop->op_type = (OPCODE)type;
2201 unop->op_ppaddr = PL_ppaddr[type];
2202 unop->op_first = first;
2203 unop->op_flags = flags | OPf_KIDS;
2204 unop->op_private = (U8)(1 | (flags >> 8));
2205 unop = (UNOP*) CHECKOP(type, unop);
2209 return fold_constants((OP *) unop);
2213 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2216 NewOp(1101, binop, 1, BINOP);
2219 first = newOP(OP_NULL, 0);
2221 binop->op_type = (OPCODE)type;
2222 binop->op_ppaddr = PL_ppaddr[type];
2223 binop->op_first = first;
2224 binop->op_flags = flags | OPf_KIDS;
2227 binop->op_private = (U8)(1 | (flags >> 8));
2230 binop->op_private = (U8)(2 | (flags >> 8));
2231 first->op_sibling = last;
2234 binop = (BINOP*)CHECKOP(type, binop);
2235 if (binop->op_next || binop->op_type != (OPCODE)type)
2238 binop->op_last = binop->op_first->op_sibling;
2240 return fold_constants((OP *)binop);
2244 uvcompare(const void *a, const void *b)
2246 if (*((UV *)a) < (*(UV *)b))
2248 if (*((UV *)a) > (*(UV *)b))
2250 if (*((UV *)a+1) < (*(UV *)b+1))
2252 if (*((UV *)a+1) > (*(UV *)b+1))
2258 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2260 SV *tstr = ((SVOP*)expr)->op_sv;
2261 SV *rstr = ((SVOP*)repl)->op_sv;
2264 U8 *t = (U8*)SvPV(tstr, tlen);
2265 U8 *r = (U8*)SvPV(rstr, rlen);
2272 register short *tbl;
2274 PL_hints |= HINT_BLOCK_SCOPE;
2275 complement = o->op_private & OPpTRANS_COMPLEMENT;
2276 del = o->op_private & OPpTRANS_DELETE;
2277 squash = o->op_private & OPpTRANS_SQUASH;
2280 o->op_private |= OPpTRANS_FROM_UTF;
2283 o->op_private |= OPpTRANS_TO_UTF;
2285 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2286 SV* listsv = newSVpvn("# comment\n",10);
2288 U8* tend = t + tlen;
2289 U8* rend = r + rlen;
2303 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2304 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2310 tsave = t = bytes_to_utf8(t, &len);
2313 if (!to_utf && rlen) {
2315 rsave = r = bytes_to_utf8(r, &len);
2319 /* There are several snags with this code on EBCDIC:
2320 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2321 2. scan_const() in toke.c has encoded chars in native encoding which makes
2322 ranges at least in EBCDIC 0..255 range the bottom odd.
2326 U8 tmpbuf[UTF8_MAXLEN+1];
2329 New(1109, cp, 2*tlen, UV);
2331 transv = newSVpvn("",0);
2333 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2335 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2337 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2341 cp[2*i+1] = cp[2*i];
2345 qsort(cp, i, 2*sizeof(UV), uvcompare);
2346 for (j = 0; j < i; j++) {
2348 diff = val - nextmin;
2350 t = uvuni_to_utf8(tmpbuf,nextmin);
2351 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2353 U8 range_mark = UTF_TO_NATIVE(0xff);
2354 t = uvuni_to_utf8(tmpbuf, val - 1);
2355 sv_catpvn(transv, (char *)&range_mark, 1);
2356 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2363 t = uvuni_to_utf8(tmpbuf,nextmin);
2364 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2366 U8 range_mark = UTF_TO_NATIVE(0xff);
2367 sv_catpvn(transv, (char *)&range_mark, 1);
2369 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2370 UNICODE_ALLOW_SUPER);
2371 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2372 t = (U8*)SvPVX(transv);
2373 tlen = SvCUR(transv);
2377 else if (!rlen && !del) {
2378 r = t; rlen = tlen; rend = tend;
2381 if ((!rlen && !del) || t == r ||
2382 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2384 o->op_private |= OPpTRANS_IDENTICAL;
2388 while (t < tend || tfirst <= tlast) {
2389 /* see if we need more "t" chars */
2390 if (tfirst > tlast) {
2391 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2393 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2395 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2402 /* now see if we need more "r" chars */
2403 if (rfirst > rlast) {
2405 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2407 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2409 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2418 rfirst = rlast = 0xffffffff;
2422 /* now see which range will peter our first, if either. */
2423 tdiff = tlast - tfirst;
2424 rdiff = rlast - rfirst;
2431 if (rfirst == 0xffffffff) {
2432 diff = tdiff; /* oops, pretend rdiff is infinite */
2434 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2435 (long)tfirst, (long)tlast);
2437 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2441 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2442 (long)tfirst, (long)(tfirst + diff),
2445 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2446 (long)tfirst, (long)rfirst);
2448 if (rfirst + diff > max)
2449 max = rfirst + diff;
2451 grows = (tfirst < rfirst &&
2452 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2464 else if (max > 0xff)
2469 Safefree(cPVOPo->op_pv);
2470 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2471 SvREFCNT_dec(listsv);
2473 SvREFCNT_dec(transv);
2475 if (!del && havefinal && rlen)
2476 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2477 newSVuv((UV)final), 0);
2480 o->op_private |= OPpTRANS_GROWS;
2492 tbl = (short*)cPVOPo->op_pv;
2494 Zero(tbl, 256, short);
2495 for (i = 0; i < (I32)tlen; i++)
2497 for (i = 0, j = 0; i < 256; i++) {
2499 if (j >= (I32)rlen) {
2508 if (i < 128 && r[j] >= 128)
2518 o->op_private |= OPpTRANS_IDENTICAL;
2520 else if (j >= (I32)rlen)
2523 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2524 tbl[0x100] = rlen - j;
2525 for (i=0; i < (I32)rlen - j; i++)
2526 tbl[0x101+i] = r[j+i];
2530 if (!rlen && !del) {
2533 o->op_private |= OPpTRANS_IDENTICAL;
2535 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2536 o->op_private |= OPpTRANS_IDENTICAL;
2538 for (i = 0; i < 256; i++)
2540 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
2541 if (j >= (I32)rlen) {
2543 if (tbl[t[i]] == -1)
2549 if (tbl[t[i]] == -1) {
2550 if (t[i] < 128 && r[j] >= 128)
2557 o->op_private |= OPpTRANS_GROWS;
2565 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2569 NewOp(1101, pmop, 1, PMOP);
2570 pmop->op_type = (OPCODE)type;
2571 pmop->op_ppaddr = PL_ppaddr[type];
2572 pmop->op_flags = (U8)flags;
2573 pmop->op_private = (U8)(0 | (flags >> 8));
2575 if (PL_hints & HINT_RE_TAINT)
2576 pmop->op_pmpermflags |= PMf_RETAINT;
2577 if (PL_hints & HINT_LOCALE)
2578 pmop->op_pmpermflags |= PMf_LOCALE;
2579 pmop->op_pmflags = pmop->op_pmpermflags;
2584 if(av_len((AV*) PL_regex_pad[0]) > -1) {
2585 repointer = av_pop((AV*)PL_regex_pad[0]);
2586 pmop->op_pmoffset = SvIV(repointer);
2587 SvREPADTMP_off(repointer);
2588 sv_setiv(repointer,0);
2590 repointer = newSViv(0);
2591 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2592 pmop->op_pmoffset = av_len(PL_regex_padav);
2593 PL_regex_pad = AvARRAY(PL_regex_padav);
2598 /* link into pm list */
2599 if (type != OP_TRANS && PL_curstash) {
2600 pmop->op_pmnext = HvPMROOT(PL_curstash);
2601 HvPMROOT(PL_curstash) = pmop;
2602 PmopSTASH_set(pmop,PL_curstash);
2605 return CHECKOP(type, pmop);
2609 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
2613 I32 repl_has_vars = 0;
2615 if (o->op_type == OP_TRANS)
2616 return pmtrans(o, expr, repl);
2618 PL_hints |= HINT_BLOCK_SCOPE;
2621 if (expr->op_type == OP_CONST) {
2623 SV *pat = ((SVOP*)expr)->op_sv;
2624 char *p = SvPV(pat, plen);
2625 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
2626 sv_setpvn(pat, "\\s+", 3);
2627 p = SvPV(pat, plen);
2628 pm->op_pmflags |= PMf_SKIPWHITE;
2631 pm->op_pmdynflags |= PMdf_UTF8;
2632 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
2633 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
2634 pm->op_pmflags |= PMf_WHITE;
2638 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2639 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2641 : OP_REGCMAYBE),0,expr);
2643 NewOp(1101, rcop, 1, LOGOP);
2644 rcop->op_type = OP_REGCOMP;
2645 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2646 rcop->op_first = scalar(expr);
2647 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
2648 ? (OPf_SPECIAL | OPf_KIDS)
2650 rcop->op_private = 1;
2652 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
2655 /* establish postfix order */
2656 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2658 rcop->op_next = expr;
2659 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2662 rcop->op_next = LINKLIST(expr);
2663 expr->op_next = (OP*)rcop;
2666 prepend_elem(o->op_type, scalar((OP*)rcop), o);
2671 if (pm->op_pmflags & PMf_EVAL) {
2673 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
2674 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
2676 else if (repl->op_type == OP_CONST)
2680 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
2681 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
2682 if (curop->op_type == OP_GV) {
2683 GV *gv = cGVOPx_gv(curop);
2685 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
2688 else if (curop->op_type == OP_RV2CV)
2690 else if (curop->op_type == OP_RV2SV ||
2691 curop->op_type == OP_RV2AV ||
2692 curop->op_type == OP_RV2HV ||
2693 curop->op_type == OP_RV2GV) {
2694 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2697 else if (curop->op_type == OP_PADSV ||
2698 curop->op_type == OP_PADAV ||
2699 curop->op_type == OP_PADHV ||
2700 curop->op_type == OP_PADANY) {
2703 else if (curop->op_type == OP_PUSHRE)
2704 ; /* Okay here, dangerous in newASSIGNOP */
2714 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
2715 pm->op_pmflags |= PMf_CONST; /* const for long enough */
2716 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
2717 prepend_elem(o->op_type, scalar(repl), o);
2720 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
2721 pm->op_pmflags |= PMf_MAYBE_CONST;
2722 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2724 NewOp(1101, rcop, 1, LOGOP);
2725 rcop->op_type = OP_SUBSTCONT;
2726 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
2727 rcop->op_first = scalar(repl);
2728 rcop->op_flags |= OPf_KIDS;
2729 rcop->op_private = 1;
2732 /* establish postfix order */
2733 rcop->op_next = LINKLIST(repl);
2734 repl->op_next = (OP*)rcop;
2736 pm->op_pmreplroot = scalar((OP*)rcop);
2737 pm->op_pmreplstart = LINKLIST(rcop);
2746 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
2749 NewOp(1101, svop, 1, SVOP);
2750 svop->op_type = (OPCODE)type;
2751 svop->op_ppaddr = PL_ppaddr[type];
2753 svop->op_next = (OP*)svop;
2754 svop->op_flags = (U8)flags;
2755 if (PL_opargs[type] & OA_RETSCALAR)
2757 if (PL_opargs[type] & OA_TARGET)
2758 svop->op_targ = pad_alloc(type, SVs_PADTMP);
2759 return CHECKOP(type, svop);
2763 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2766 NewOp(1101, padop, 1, PADOP);
2767 padop->op_type = (OPCODE)type;
2768 padop->op_ppaddr = PL_ppaddr[type];
2769 padop->op_padix = pad_alloc(type, SVs_PADTMP);
2770 SvREFCNT_dec(PAD_SVl(padop->op_padix));
2771 PAD_SETSV(padop->op_padix, sv);
2774 padop->op_next = (OP*)padop;
2775 padop->op_flags = (U8)flags;
2776 if (PL_opargs[type] & OA_RETSCALAR)
2778 if (PL_opargs[type] & OA_TARGET)
2779 padop->op_targ = pad_alloc(type, SVs_PADTMP);
2780 return CHECKOP(type, padop);
2784 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
2789 return newPADOP(type, flags, SvREFCNT_inc(gv));
2791 return newSVOP(type, flags, SvREFCNT_inc(gv));
2796 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
2799 NewOp(1101, pvop, 1, PVOP);
2800 pvop->op_type = (OPCODE)type;
2801 pvop->op_ppaddr = PL_ppaddr[type];
2803 pvop->op_next = (OP*)pvop;
2804 pvop->op_flags = (U8)flags;
2805 if (PL_opargs[type] & OA_RETSCALAR)
2807 if (PL_opargs[type] & OA_TARGET)
2808 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
2809 return CHECKOP(type, pvop);
2813 Perl_package(pTHX_ OP *o)
2818 save_hptr(&PL_curstash);
2819 save_item(PL_curstname);
2821 name = SvPV(cSVOPo->op_sv, len);
2822 PL_curstash = gv_stashpvn(name, len, TRUE);
2823 sv_setpvn(PL_curstname, name, len);
2826 PL_hints |= HINT_BLOCK_SCOPE;
2827 PL_copline = NOLINE;
2832 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
2838 if (idop->op_type != OP_CONST)
2839 Perl_croak(aTHX_ "Module name must be constant");
2843 if (version != Nullop) {
2844 SV *vesv = ((SVOP*)version)->op_sv;
2846 if (arg == Nullop && !SvNIOKp(vesv)) {
2853 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
2854 Perl_croak(aTHX_ "Version number must be constant number");
2856 /* Make copy of idop so we don't free it twice */
2857 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
2859 /* Fake up a method call to VERSION */
2860 meth = newSVpvn("VERSION",7);
2861 sv_upgrade(meth, SVt_PVIV);
2862 (void)SvIOK_on(meth);
2863 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
2864 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2865 append_elem(OP_LIST,
2866 prepend_elem(OP_LIST, pack, list(version)),
2867 newSVOP(OP_METHOD_NAMED, 0, meth)));
2871 /* Fake up an import/unimport */
2872 if (arg && arg->op_type == OP_STUB)
2873 imop = arg; /* no import on explicit () */
2874 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
2875 imop = Nullop; /* use 5.0; */
2880 /* Make copy of idop so we don't free it twice */
2881 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
2883 /* Fake up a method call to import/unimport */
2884 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);
2885 (void)SvUPGRADE(meth, SVt_PVIV);
2886 (void)SvIOK_on(meth);
2887 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
2888 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2889 append_elem(OP_LIST,
2890 prepend_elem(OP_LIST, pack, list(arg)),
2891 newSVOP(OP_METHOD_NAMED, 0, meth)));
2894 /* Fake up the BEGIN {}, which does its thing immediately. */
2896 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
2899 append_elem(OP_LINESEQ,
2900 append_elem(OP_LINESEQ,
2901 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, idop)),
2902 newSTATEOP(0, Nullch, veop)),
2903 newSTATEOP(0, Nullch, imop) ));
2905 /* The "did you use incorrect case?" warning used to be here.
2906 * The problem is that on case-insensitive filesystems one
2907 * might get false positives for "use" (and "require"):
2908 * "use Strict" or "require CARP" will work. This causes
2909 * portability problems for the script: in case-strict
2910 * filesystems the script will stop working.
2912 * The "incorrect case" warning checked whether "use Foo"
2913 * imported "Foo" to your namespace, but that is wrong, too:
2914 * there is no requirement nor promise in the language that
2915 * a Foo.pm should or would contain anything in package "Foo".
2917 * There is very little Configure-wise that can be done, either:
2918 * the case-sensitivity of the build filesystem of Perl does not
2919 * help in guessing the case-sensitivity of the runtime environment.
2922 PL_hints |= HINT_BLOCK_SCOPE;
2923 PL_copline = NOLINE;
2925 PL_cop_seqmax++; /* Purely for B::*'s benefit */
2929 =head1 Embedding Functions
2931 =for apidoc load_module
2933 Loads the module whose name is pointed to by the string part of name.
2934 Note that the actual module name, not its filename, should be given.
2935 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
2936 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
2937 (or 0 for no flags). ver, if specified, provides version semantics
2938 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
2939 arguments can be used to specify arguments to the module's import()
2940 method, similar to C<use Foo::Bar VERSION LIST>.
2945 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
2948 va_start(args, ver);
2949 vload_module(flags, name, ver, &args);
2953 #ifdef PERL_IMPLICIT_CONTEXT
2955 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
2959 va_start(args, ver);
2960 vload_module(flags, name, ver, &args);
2966 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
2968 OP *modname, *veop, *imop;
2970 modname = newSVOP(OP_CONST, 0, name);
2971 modname->op_private |= OPpCONST_BARE;
2973 veop = newSVOP(OP_CONST, 0, ver);
2977 if (flags & PERL_LOADMOD_NOIMPORT) {
2978 imop = sawparens(newNULLLIST());
2980 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
2981 imop = va_arg(*args, OP*);
2986 sv = va_arg(*args, SV*);
2988 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
2989 sv = va_arg(*args, SV*);
2993 line_t ocopline = PL_copline;
2994 COP *ocurcop = PL_curcop;
2995 int oexpect = PL_expect;
2997 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
2998 veop, modname, imop);
2999 PL_expect = oexpect;
3000 PL_copline = ocopline;
3001 PL_curcop = ocurcop;
3006 Perl_dofile(pTHX_ OP *term)
3011 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3012 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
3013 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3015 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3016 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3017 append_elem(OP_LIST, term,
3018 scalar(newUNOP(OP_RV2CV, 0,
3023 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3029 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3031 return newBINOP(OP_LSLICE, flags,
3032 list(force_list(subscript)),
3033 list(force_list(listval)) );
3037 S_list_assignment(pTHX_ register OP *o)
3042 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3043 o = cUNOPo->op_first;
3045 if (o->op_type == OP_COND_EXPR) {
3046 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3047 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3052 yyerror("Assignment to both a list and a scalar");
3056 if (o->op_type == OP_LIST &&
3057 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3058 o->op_private & OPpLVAL_INTRO)
3061 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3062 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3063 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3066 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3069 if (o->op_type == OP_RV2SV)
3076 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3081 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3082 return newLOGOP(optype, 0,
3083 mod(scalar(left), optype),
3084 newUNOP(OP_SASSIGN, 0, scalar(right)));
3087 return newBINOP(optype, OPf_STACKED,
3088 mod(scalar(left), optype), scalar(right));
3092 if (list_assignment(left)) {
3096 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3097 left = mod(left, OP_AASSIGN);
3105 curop = list(force_list(left));
3106 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3107 o->op_private = (U8)(0 | (flags >> 8));
3109 /* PL_generation sorcery:
3110 * an assignment like ($a,$b) = ($c,$d) is easier than
3111 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3112 * To detect whether there are common vars, the global var
3113 * PL_generation is incremented for each assign op we compile.
3114 * Then, while compiling the assign op, we run through all the
3115 * variables on both sides of the assignment, setting a spare slot
3116 * in each of them to PL_generation. If any of them already have
3117 * that value, we know we've got commonality. We could use a
3118 * single bit marker, but then we'd have to make 2 passes, first
3119 * to clear the flag, then to test and set it. To find somewhere
3120 * to store these values, evil chicanery is done with SvCUR().
3123 if (!(left->op_private & OPpLVAL_INTRO)) {
3126 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3127 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3128 if (curop->op_type == OP_GV) {
3129 GV *gv = cGVOPx_gv(curop);
3130 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3132 SvCUR(gv) = PL_generation;
3134 else if (curop->op_type == OP_PADSV ||
3135 curop->op_type == OP_PADAV ||
3136 curop->op_type == OP_PADHV ||
3137 curop->op_type == OP_PADANY)
3139 if (PAD_COMPNAME_GEN(curop->op_targ)
3140 == (STRLEN)PL_generation)
3142 PAD_COMPNAME_GEN(curop->op_targ)
3146 else if (curop->op_type == OP_RV2CV)
3148 else if (curop->op_type == OP_RV2SV ||
3149 curop->op_type == OP_RV2AV ||
3150 curop->op_type == OP_RV2HV ||
3151 curop->op_type == OP_RV2GV) {
3152 if (lastop->op_type != OP_GV) /* funny deref? */
3155 else if (curop->op_type == OP_PUSHRE) {
3156 if (((PMOP*)curop)->op_pmreplroot) {
3158 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3159 ((PMOP*)curop)->op_pmreplroot));
3161 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3163 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3165 SvCUR(gv) = PL_generation;
3174 o->op_private |= OPpASSIGN_COMMON;
3176 if (right && right->op_type == OP_SPLIT) {
3178 if ((tmpop = ((LISTOP*)right)->op_first) &&
3179 tmpop->op_type == OP_PUSHRE)
3181 PMOP *pm = (PMOP*)tmpop;
3182 if (left->op_type == OP_RV2AV &&
3183 !(left->op_private & OPpLVAL_INTRO) &&
3184 !(o->op_private & OPpASSIGN_COMMON) )
3186 tmpop = ((UNOP*)left)->op_first;
3187 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3189 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3190 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3192 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3193 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3195 pm->op_pmflags |= PMf_ONCE;
3196 tmpop = cUNOPo->op_first; /* to list (nulled) */
3197 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3198 tmpop->op_sibling = Nullop; /* don't free split */
3199 right->op_next = tmpop->op_next; /* fix starting loc */
3200 op_free(o); /* blow off assign */
3201 right->op_flags &= ~OPf_WANT;
3202 /* "I don't know and I don't care." */
3207 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3208 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3210 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3212 sv_setiv(sv, PL_modcount+1);
3220 right = newOP(OP_UNDEF, 0);
3221 if (right->op_type == OP_READLINE) {
3222 right->op_flags |= OPf_STACKED;
3223 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3226 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3227 o = newBINOP(OP_SASSIGN, flags,
3228 scalar(right), mod(scalar(left), OP_SASSIGN) );
3240 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3242 U32 seq = intro_my();
3245 NewOp(1101, cop, 1, COP);
3246 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3247 cop->op_type = OP_DBSTATE;
3248 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3251 cop->op_type = OP_NEXTSTATE;
3252 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3254 cop->op_flags = (U8)flags;
3255 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3257 cop->op_private |= NATIVE_HINTS;
3259 PL_compiling.op_private = cop->op_private;
3260 cop->op_next = (OP*)cop;
3263 cop->cop_label = label;
3264 PL_hints |= HINT_BLOCK_SCOPE;
3267 cop->cop_arybase = PL_curcop->cop_arybase;
3268 if (specialWARN(PL_curcop->cop_warnings))
3269 cop->cop_warnings = PL_curcop->cop_warnings ;
3271 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3272 if (specialCopIO(PL_curcop->cop_io))
3273 cop->cop_io = PL_curcop->cop_io;
3275 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3278 if (PL_copline == NOLINE)
3279 CopLINE_set(cop, CopLINE(PL_curcop));
3281 CopLINE_set(cop, PL_copline);
3282 PL_copline = NOLINE;
3285 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3287 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3289 CopSTASH_set(cop, PL_curstash);
3291 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3292 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3293 if (svp && *svp != &PL_sv_undef ) {
3294 (void)SvIOK_on(*svp);
3295 SvIVX(*svp) = PTR2IV(cop);
3299 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3304 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3306 return new_logop(type, flags, &first, &other);
3310 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3314 OP *first = *firstp;
3315 OP *other = *otherp;
3317 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3318 return newBINOP(type, flags, scalar(first), scalar(other));
3320 scalarboolean(first);
3321 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3322 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3323 if (type == OP_AND || type == OP_OR) {
3329 first = *firstp = cUNOPo->op_first;
3331 first->op_next = o->op_next;
3332 cUNOPo->op_first = Nullop;
3336 if (first->op_type == OP_CONST) {
3337 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE)) {
3338 if (first->op_private & OPpCONST_STRICT)
3339 no_bareword_allowed(first);
3341 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3343 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3354 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS) &&
3355 type != OP_DOR) /* [#24076] Don't warn for <FH> err FOO. */
3357 OP *k1 = ((UNOP*)first)->op_first;
3358 OP *k2 = k1->op_sibling;
3360 switch (first->op_type)
3363 if (k2 && k2->op_type == OP_READLINE
3364 && (k2->op_flags & OPf_STACKED)
3365 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3367 warnop = k2->op_type;
3372 if (k1->op_type == OP_READDIR
3373 || k1->op_type == OP_GLOB
3374 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3375 || k1->op_type == OP_EACH)
3377 warnop = ((k1->op_type == OP_NULL)
3378 ? (OPCODE)k1->op_targ : k1->op_type);
3383 line_t oldline = CopLINE(PL_curcop);
3384 CopLINE_set(PL_curcop, PL_copline);
3385 Perl_warner(aTHX_ packWARN(WARN_MISC),
3386 "Value of %s%s can be \"0\"; test with defined()",
3388 ((warnop == OP_READLINE || warnop == OP_GLOB)
3389 ? " construct" : "() operator"));
3390 CopLINE_set(PL_curcop, oldline);
3397 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3398 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3400 NewOp(1101, logop, 1, LOGOP);
3402 logop->op_type = (OPCODE)type;
3403 logop->op_ppaddr = PL_ppaddr[type];
3404 logop->op_first = first;
3405 logop->op_flags = flags | OPf_KIDS;
3406 logop->op_other = LINKLIST(other);
3407 logop->op_private = (U8)(1 | (flags >> 8));
3409 /* establish postfix order */
3410 logop->op_next = LINKLIST(first);
3411 first->op_next = (OP*)logop;
3412 first->op_sibling = other;
3414 CHECKOP(type,logop);
3416 o = newUNOP(OP_NULL, 0, (OP*)logop);
3423 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3430 return newLOGOP(OP_AND, 0, first, trueop);
3432 return newLOGOP(OP_OR, 0, first, falseop);
3434 scalarboolean(first);
3435 if (first->op_type == OP_CONST) {
3436 if (first->op_private & OPpCONST_BARE &&
3437 first->op_private & OPpCONST_STRICT) {
3438 no_bareword_allowed(first);
3440 if (SvTRUE(((SVOP*)first)->op_sv)) {
3451 NewOp(1101, logop, 1, LOGOP);
3452 logop->op_type = OP_COND_EXPR;
3453 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3454 logop->op_first = first;
3455 logop->op_flags = flags | OPf_KIDS;
3456 logop->op_private = (U8)(1 | (flags >> 8));
3457 logop->op_other = LINKLIST(trueop);
3458 logop->op_next = LINKLIST(falseop);
3460 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
3463 /* establish postfix order */
3464 start = LINKLIST(first);
3465 first->op_next = (OP*)logop;
3467 first->op_sibling = trueop;
3468 trueop->op_sibling = falseop;
3469 o = newUNOP(OP_NULL, 0, (OP*)logop);
3471 trueop->op_next = falseop->op_next = o;
3478 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3486 NewOp(1101, range, 1, LOGOP);
3488 range->op_type = OP_RANGE;
3489 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3490 range->op_first = left;
3491 range->op_flags = OPf_KIDS;
3492 leftstart = LINKLIST(left);
3493 range->op_other = LINKLIST(right);
3494 range->op_private = (U8)(1 | (flags >> 8));
3496 left->op_sibling = right;
3498 range->op_next = (OP*)range;
3499 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3500 flop = newUNOP(OP_FLOP, 0, flip);
3501 o = newUNOP(OP_NULL, 0, flop);
3503 range->op_next = leftstart;
3505 left->op_next = flip;
3506 right->op_next = flop;
3508 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3509 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3510 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3511 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3513 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3514 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3517 if (!flip->op_private || !flop->op_private)
3518 linklist(o); /* blow off optimizer unless constant */
3524 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3528 int once = block && block->op_flags & OPf_SPECIAL &&
3529 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3532 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3533 return block; /* do {} while 0 does once */
3534 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3535 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3536 expr = newUNOP(OP_DEFINED, 0,
3537 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3538 } else if (expr->op_flags & OPf_KIDS) {
3539 OP *k1 = ((UNOP*)expr)->op_first;
3540 OP *k2 = (k1) ? k1->op_sibling : NULL;
3541 switch (expr->op_type) {
3543 if (k2 && k2->op_type == OP_READLINE
3544 && (k2->op_flags & OPf_STACKED)
3545 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3546 expr = newUNOP(OP_DEFINED, 0, expr);
3550 if (k1->op_type == OP_READDIR
3551 || k1->op_type == OP_GLOB
3552 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3553 || k1->op_type == OP_EACH)
3554 expr = newUNOP(OP_DEFINED, 0, expr);
3560 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3561 o = new_logop(OP_AND, 0, &expr, &listop);
3564 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3566 if (once && o != listop)
3567 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3570 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3572 o->op_flags |= flags;
3574 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3579 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3587 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3588 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3589 expr = newUNOP(OP_DEFINED, 0,
3590 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3591 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3592 OP *k1 = ((UNOP*)expr)->op_first;
3593 OP *k2 = (k1) ? k1->op_sibling : NULL;
3594 switch (expr->op_type) {
3596 if (k2 && k2->op_type == OP_READLINE
3597 && (k2->op_flags & OPf_STACKED)
3598 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3599 expr = newUNOP(OP_DEFINED, 0, expr);
3603 if (k1->op_type == OP_READDIR
3604 || k1->op_type == OP_GLOB
3605 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3606 || k1->op_type == OP_EACH)
3607 expr = newUNOP(OP_DEFINED, 0, expr);
3613 block = newOP(OP_NULL, 0);
3615 block = scope(block);
3619 next = LINKLIST(cont);
3622 OP *unstack = newOP(OP_UNSTACK, 0);
3625 cont = append_elem(OP_LINESEQ, cont, unstack);
3628 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3629 redo = LINKLIST(listop);
3632 PL_copline = (line_t)whileline;
3634 o = new_logop(OP_AND, 0, &expr, &listop);
3635 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3636 op_free(expr); /* oops, it's a while (0) */
3638 return Nullop; /* listop already freed by new_logop */
3641 ((LISTOP*)listop)->op_last->op_next =
3642 (o == listop ? redo : LINKLIST(o));
3648 NewOp(1101,loop,1,LOOP);
3649 loop->op_type = OP_ENTERLOOP;
3650 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3651 loop->op_private = 0;
3652 loop->op_next = (OP*)loop;
3655 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3657 loop->op_redoop = redo;
3658 loop->op_lastop = o;
3659 o->op_private |= loopflags;
3662 loop->op_nextop = next;
3664 loop->op_nextop = o;
3666 o->op_flags |= flags;
3667 o->op_private |= (flags >> 8);
3672 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
3676 PADOFFSET padoff = 0;
3681 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
3682 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
3683 sv->op_type = OP_RV2GV;
3684 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3686 else if (sv->op_type == OP_PADSV) { /* private variable */
3687 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
3688 padoff = sv->op_targ;
3693 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3694 padoff = sv->op_targ;
3696 iterflags |= OPf_SPECIAL;
3701 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3704 sv = newGVOP(OP_GV, 0, PL_defgv);
3706 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3707 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3708 iterflags |= OPf_STACKED;
3710 else if (expr->op_type == OP_NULL &&
3711 (expr->op_flags & OPf_KIDS) &&
3712 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3714 /* Basically turn for($x..$y) into the same as for($x,$y), but we
3715 * set the STACKED flag to indicate that these values are to be
3716 * treated as min/max values by 'pp_iterinit'.
3718 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
3719 LOGOP* range = (LOGOP*) flip->op_first;
3720 OP* left = range->op_first;
3721 OP* right = left->op_sibling;
3724 range->op_flags &= ~OPf_KIDS;
3725 range->op_first = Nullop;
3727 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
3728 listop->op_first->op_next = range->op_next;
3729 left->op_next = range->op_other;
3730 right->op_next = (OP*)listop;
3731 listop->op_next = listop->op_first;
3734 expr = (OP*)(listop);
3736 iterflags |= OPf_STACKED;
3739 expr = mod(force_list(expr), OP_GREPSTART);
3743 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
3744 append_elem(OP_LIST, expr, scalar(sv))));
3745 assert(!loop->op_next);
3746 /* for my $x () sets OPpLVAL_INTRO;
3747 * for our $x () sets OPpOUR_INTRO */
3748 loop->op_private = (U8)iterpflags;
3749 #ifdef PL_OP_SLAB_ALLOC
3752 NewOp(1234,tmp,1,LOOP);
3753 Copy(loop,tmp,1,LOOP);
3758 Renew(loop, 1, LOOP);
3760 loop->op_targ = padoff;
3761 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
3762 PL_copline = forline;
3763 return newSTATEOP(0, label, wop);
3767 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
3772 if (type != OP_GOTO || label->op_type == OP_CONST) {
3773 /* "last()" means "last" */
3774 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
3775 o = newOP(type, OPf_SPECIAL);
3777 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
3778 ? SvPVx(((SVOP*)label)->op_sv, n_a)
3784 /* Check whether it's going to be a goto &function */
3785 if (label->op_type == OP_ENTERSUB
3786 && !(label->op_flags & OPf_STACKED))
3787 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
3788 o = newUNOP(type, OPf_STACKED, label);
3790 PL_hints |= HINT_BLOCK_SCOPE;
3795 =for apidoc cv_undef
3797 Clear out all the active components of a CV. This can happen either
3798 by an explicit C<undef &foo>, or by the reference count going to zero.
3799 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
3800 children can still follow the full lexical scope chain.
3806 Perl_cv_undef(pTHX_ CV *cv)
3809 if (CvFILE(cv) && !CvXSUB(cv)) {
3810 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
3811 Safefree(CvFILE(cv));
3816 if (!CvXSUB(cv) && CvROOT(cv)) {
3818 Perl_croak(aTHX_ "Can't undef active subroutine");
3821 PAD_SAVE_SETNULLPAD();
3823 op_free(CvROOT(cv));
3824 CvROOT(cv) = Nullop;
3827 SvPOK_off((SV*)cv); /* forget prototype */
3832 /* remove CvOUTSIDE unless this is an undef rather than a free */
3833 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
3834 if (!CvWEAKOUTSIDE(cv))
3835 SvREFCNT_dec(CvOUTSIDE(cv));
3836 CvOUTSIDE(cv) = Nullcv;
3839 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
3845 /* delete all flags except WEAKOUTSIDE */
3846 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
3850 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
3852 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
3853 SV* msg = sv_newmortal();
3857 gv_efullname3(name = sv_newmortal(), gv, Nullch);
3858 sv_setpv(msg, "Prototype mismatch:");
3860 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
3862 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (SV *)cv);
3863 sv_catpv(msg, " vs ");
3865 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
3867 sv_catpv(msg, "none");
3868 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
3872 static void const_sv_xsub(pTHX_ CV* cv);
3876 =head1 Optree Manipulation Functions
3878 =for apidoc cv_const_sv
3880 If C<cv> is a constant sub eligible for inlining. returns the constant
3881 value returned by the sub. Otherwise, returns NULL.
3883 Constant subs can be created with C<newCONSTSUB> or as described in
3884 L<perlsub/"Constant Functions">.
3889 Perl_cv_const_sv(pTHX_ CV *cv)
3891 if (!cv || !CvCONST(cv))
3893 return (SV*)CvXSUBANY(cv).any_ptr;
3896 /* op_const_sv: examine an optree to determine whether it's in-lineable.
3897 * Can be called in 3 ways:
3900 * look for a single OP_CONST with attached value: return the value
3902 * cv && CvCLONE(cv) && !CvCONST(cv)
3904 * examine the clone prototype, and if contains only a single
3905 * OP_CONST referencing a pad const, or a single PADSV referencing
3906 * an outer lexical, return a non-zero value to indicate the CV is
3907 * a candidate for "constizing" at clone time
3911 * We have just cloned an anon prototype that was marked as a const
3912 * candidiate. Try to grab the current value, and in the case of
3913 * PADSV, ignore it if it has multiple references. Return the value.
3917 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
3924 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
3925 o = cLISTOPo->op_first->op_sibling;
3927 for (; o; o = o->op_next) {
3928 OPCODE type = o->op_type;
3930 if (sv && o->op_next == o)
3932 if (o->op_next != o) {
3933 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
3935 if (type == OP_DBSTATE)
3938 if (type == OP_LEAVESUB || type == OP_RETURN)
3942 if (type == OP_CONST && cSVOPo->op_sv)
3944 else if (cv && type == OP_CONST) {
3945 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
3949 else if (cv && type == OP_PADSV) {
3950 if (CvCONST(cv)) { /* newly cloned anon */
3951 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
3952 /* the candidate should have 1 ref from this pad and 1 ref
3953 * from the parent */
3954 if (!sv || SvREFCNT(sv) != 2)
3961 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
3962 sv = &PL_sv_undef; /* an arbitrary non-null value */
3973 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
3983 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
3987 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
3989 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
3993 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
3999 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4003 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4004 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4005 SV *sv = sv_newmortal();
4006 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4007 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4008 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4013 gv = gv_fetchpv(name ? name : (aname ? aname :
4014 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__")),
4015 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4025 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4026 maximum a prototype before. */
4027 if (SvTYPE(gv) > SVt_NULL) {
4028 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4029 && ckWARN_d(WARN_PROTOTYPE))
4031 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4033 cv_ckproto((CV*)gv, NULL, ps);
4036 sv_setpv((SV*)gv, ps);
4038 sv_setiv((SV*)gv, -1);
4039 SvREFCNT_dec(PL_compcv);
4040 cv = PL_compcv = NULL;
4041 PL_sub_generation++;
4045 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4047 #ifdef GV_UNIQUE_CHECK
4048 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4049 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4053 if (!block || !ps || *ps || attrs)
4056 const_sv = op_const_sv(block, Nullcv);
4059 bool exists = CvROOT(cv) || CvXSUB(cv);
4061 #ifdef GV_UNIQUE_CHECK
4062 if (exists && GvUNIQUE(gv)) {
4063 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4067 /* if the subroutine doesn't exist and wasn't pre-declared
4068 * with a prototype, assume it will be AUTOLOADed,
4069 * skipping the prototype check
4071 if (exists || SvPOK(cv))
4072 cv_ckproto(cv, gv, ps);
4073 /* already defined (or promised)? */
4074 if (exists || GvASSUMECV(gv)) {
4075 if (!block && !attrs) {
4076 if (CvFLAGS(PL_compcv)) {
4077 /* might have had built-in attrs applied */
4078 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4080 /* just a "sub foo;" when &foo is already defined */
4081 SAVEFREESV(PL_compcv);
4084 /* ahem, death to those who redefine active sort subs */
4085 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4086 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4088 if (ckWARN(WARN_REDEFINE)
4090 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4092 line_t oldline = CopLINE(PL_curcop);
4093 if (PL_copline != NOLINE)
4094 CopLINE_set(PL_curcop, PL_copline);
4095 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4096 CvCONST(cv) ? "Constant subroutine %s redefined"
4097 : "Subroutine %s redefined", name);
4098 CopLINE_set(PL_curcop, oldline);
4106 SvREFCNT_inc(const_sv);
4108 assert(!CvROOT(cv) && !CvCONST(cv));
4109 sv_setpv((SV*)cv, ""); /* prototype is "" */
4110 CvXSUBANY(cv).any_ptr = const_sv;
4111 CvXSUB(cv) = const_sv_xsub;
4116 cv = newCONSTSUB(NULL, name, const_sv);
4119 SvREFCNT_dec(PL_compcv);
4121 PL_sub_generation++;
4128 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4129 * before we clobber PL_compcv.
4133 /* Might have had built-in attributes applied -- propagate them. */
4134 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4135 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4136 stash = GvSTASH(CvGV(cv));
4137 else if (CvSTASH(cv))
4138 stash = CvSTASH(cv);
4140 stash = PL_curstash;
4143 /* possibly about to re-define existing subr -- ignore old cv */
4144 rcv = (SV*)PL_compcv;
4145 if (name && GvSTASH(gv))
4146 stash = GvSTASH(gv);
4148 stash = PL_curstash;
4150 apply_attrs(stash, rcv, attrs, FALSE);
4152 if (cv) { /* must reuse cv if autoloaded */
4154 /* got here with just attrs -- work done, so bug out */
4155 SAVEFREESV(PL_compcv);
4158 /* transfer PL_compcv to cv */
4160 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4161 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4162 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4163 CvOUTSIDE(PL_compcv) = 0;
4164 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4165 CvPADLIST(PL_compcv) = 0;
4166 /* inner references to PL_compcv must be fixed up ... */
4167 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4168 /* ... before we throw it away */
4169 SvREFCNT_dec(PL_compcv);
4171 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4172 ++PL_sub_generation;
4179 PL_sub_generation++;
4183 CvFILE_set_from_cop(cv, PL_curcop);
4184 CvSTASH(cv) = PL_curstash;
4187 sv_setpv((SV*)cv, ps);
4189 if (PL_error_count) {
4193 char *s = strrchr(name, ':');
4195 if (strEQ(s, "BEGIN")) {
4197 "BEGIN not safe after errors--compilation aborted";
4198 if (PL_in_eval & EVAL_KEEPERR)
4199 Perl_croak(aTHX_ not_safe);
4201 /* force display of errors found but not reported */
4202 sv_catpv(ERRSV, not_safe);
4203 Perl_croak(aTHX_ "%"SVf, ERRSV);
4212 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4213 mod(scalarseq(block), OP_LEAVESUBLV));
4216 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4218 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4219 OpREFCNT_set(CvROOT(cv), 1);
4220 CvSTART(cv) = LINKLIST(CvROOT(cv));
4221 CvROOT(cv)->op_next = 0;
4222 CALL_PEEP(CvSTART(cv));
4224 /* now that optimizer has done its work, adjust pad values */
4226 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4229 assert(!CvCONST(cv));
4230 if (ps && !*ps && op_const_sv(block, cv))
4234 if (name || aname) {
4236 char *tname = (name ? name : aname);
4238 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4239 SV *sv = NEWSV(0,0);
4240 SV *tmpstr = sv_newmortal();
4241 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4245 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4247 (long)PL_subline, (long)CopLINE(PL_curcop));
4248 gv_efullname3(tmpstr, gv, Nullch);
4249 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4250 hv = GvHVn(db_postponed);
4251 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4252 && (pcv = GvCV(db_postponed)))
4258 call_sv((SV*)pcv, G_DISCARD);
4262 if ((s = strrchr(tname,':')))
4267 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4270 if (strEQ(s, "BEGIN") && !PL_error_count) {
4271 I32 oldscope = PL_scopestack_ix;
4273 SAVECOPFILE(&PL_compiling);
4274 SAVECOPLINE(&PL_compiling);
4277 PL_beginav = newAV();
4278 DEBUG_x( dump_sub(gv) );
4279 av_push(PL_beginav, (SV*)cv);
4280 GvCV(gv) = 0; /* cv has been hijacked */
4281 call_list(oldscope, PL_beginav);
4283 PL_curcop = &PL_compiling;
4284 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4287 else if (strEQ(s, "END") && !PL_error_count) {
4290 DEBUG_x( dump_sub(gv) );
4291 av_unshift(PL_endav, 1);
4292 av_store(PL_endav, 0, (SV*)cv);
4293 GvCV(gv) = 0; /* cv has been hijacked */
4295 else if (strEQ(s, "CHECK") && !PL_error_count) {
4297 PL_checkav = newAV();
4298 DEBUG_x( dump_sub(gv) );
4299 if (PL_main_start && ckWARN(WARN_VOID))
4300 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4301 av_unshift(PL_checkav, 1);
4302 av_store(PL_checkav, 0, (SV*)cv);
4303 GvCV(gv) = 0; /* cv has been hijacked */
4305 else if (strEQ(s, "INIT") && !PL_error_count) {
4307 PL_initav = newAV();
4308 DEBUG_x( dump_sub(gv) );
4309 if (PL_main_start && ckWARN(WARN_VOID))
4310 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4311 av_push(PL_initav, (SV*)cv);
4312 GvCV(gv) = 0; /* cv has been hijacked */
4317 PL_copline = NOLINE;
4322 /* XXX unsafe for threads if eval_owner isn't held */
4324 =for apidoc newCONSTSUB
4326 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4327 eligible for inlining at compile-time.
4333 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4339 SAVECOPLINE(PL_curcop);
4340 CopLINE_set(PL_curcop, PL_copline);
4343 PL_hints &= ~HINT_BLOCK_SCOPE;
4346 SAVESPTR(PL_curstash);
4347 SAVECOPSTASH(PL_curcop);
4348 PL_curstash = stash;
4349 CopSTASH_set(PL_curcop,stash);
4352 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4353 CvXSUBANY(cv).any_ptr = sv;
4355 sv_setpv((SV*)cv, ""); /* prototype is "" */
4358 CopSTASH_free(PL_curcop);
4366 =for apidoc U||newXS
4368 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4374 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
4376 GV *gv = gv_fetchpv(name ? name :
4377 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4378 GV_ADDMULTI, SVt_PVCV);
4382 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4384 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4386 /* just a cached method */
4390 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4391 /* already defined (or promised) */
4392 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4393 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4394 line_t oldline = CopLINE(PL_curcop);
4395 if (PL_copline != NOLINE)
4396 CopLINE_set(PL_curcop, PL_copline);
4397 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4398 CvCONST(cv) ? "Constant subroutine %s redefined"
4399 : "Subroutine %s redefined"
4401 CopLINE_set(PL_curcop, oldline);
4408 if (cv) /* must reuse cv if autoloaded */
4411 cv = (CV*)NEWSV(1105,0);
4412 sv_upgrade((SV *)cv, SVt_PVCV);
4416 PL_sub_generation++;
4420 (void)gv_fetchfile(filename);
4421 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
4422 an external constant string */
4423 CvXSUB(cv) = subaddr;
4426 char *s = strrchr(name,':');
4432 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4435 if (strEQ(s, "BEGIN")) {
4437 PL_beginav = newAV();
4438 av_push(PL_beginav, (SV*)cv);
4439 GvCV(gv) = 0; /* cv has been hijacked */
4441 else if (strEQ(s, "END")) {
4444 av_unshift(PL_endav, 1);
4445 av_store(PL_endav, 0, (SV*)cv);
4446 GvCV(gv) = 0; /* cv has been hijacked */
4448 else if (strEQ(s, "CHECK")) {
4450 PL_checkav = newAV();
4451 if (PL_main_start && ckWARN(WARN_VOID))
4452 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4453 av_unshift(PL_checkav, 1);
4454 av_store(PL_checkav, 0, (SV*)cv);
4455 GvCV(gv) = 0; /* cv has been hijacked */
4457 else if (strEQ(s, "INIT")) {
4459 PL_initav = newAV();
4460 if (PL_main_start && ckWARN(WARN_VOID))
4461 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4462 av_push(PL_initav, (SV*)cv);
4463 GvCV(gv) = 0; /* cv has been hijacked */
4474 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4482 name = SvPVx(cSVOPo->op_sv, n_a);
4485 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
4486 #ifdef GV_UNIQUE_CHECK
4488 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4492 if ((cv = GvFORM(gv))) {
4493 if (ckWARN(WARN_REDEFINE)) {
4494 line_t oldline = CopLINE(PL_curcop);
4495 if (PL_copline != NOLINE)
4496 CopLINE_set(PL_curcop, PL_copline);
4497 Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Format %s redefined",name);
4498 CopLINE_set(PL_curcop, oldline);
4505 CvFILE_set_from_cop(cv, PL_curcop);
4508 pad_tidy(padtidy_FORMAT);
4509 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4510 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4511 OpREFCNT_set(CvROOT(cv), 1);
4512 CvSTART(cv) = LINKLIST(CvROOT(cv));
4513 CvROOT(cv)->op_next = 0;
4514 CALL_PEEP(CvSTART(cv));
4516 PL_copline = NOLINE;
4521 Perl_newANONLIST(pTHX_ OP *o)
4523 return newUNOP(OP_REFGEN, 0,
4524 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4528 Perl_newANONHASH(pTHX_ OP *o)
4530 return newUNOP(OP_REFGEN, 0,
4531 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4535 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4537 return newANONATTRSUB(floor, proto, Nullop, block);
4541 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4543 return newUNOP(OP_REFGEN, 0,
4544 newSVOP(OP_ANONCODE, 0,
4545 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
4549 Perl_oopsAV(pTHX_ OP *o)
4551 switch (o->op_type) {
4553 o->op_type = OP_PADAV;
4554 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4555 return ref(o, OP_RV2AV);
4558 o->op_type = OP_RV2AV;
4559 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4564 if (ckWARN_d(WARN_INTERNAL))
4565 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
4572 Perl_oopsHV(pTHX_ OP *o)
4574 switch (o->op_type) {
4577 o->op_type = OP_PADHV;
4578 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4579 return ref(o, OP_RV2HV);
4583 o->op_type = OP_RV2HV;
4584 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
4589 if (ckWARN_d(WARN_INTERNAL))
4590 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
4597 Perl_newAVREF(pTHX_ OP *o)
4599 if (o->op_type == OP_PADANY) {
4600 o->op_type = OP_PADAV;
4601 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4604 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
4605 && ckWARN(WARN_DEPRECATED)) {
4606 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4607 "Using an array as a reference is deprecated");
4609 return newUNOP(OP_RV2AV, 0, scalar(o));
4613 Perl_newGVREF(pTHX_ I32 type, OP *o)
4615 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
4616 return newUNOP(OP_NULL, 0, o);
4617 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
4621 Perl_newHVREF(pTHX_ OP *o)
4623 if (o->op_type == OP_PADANY) {
4624 o->op_type = OP_PADHV;
4625 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4628 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
4629 && ckWARN(WARN_DEPRECATED)) {
4630 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4631 "Using a hash as a reference is deprecated");
4633 return newUNOP(OP_RV2HV, 0, scalar(o));
4637 Perl_oopsCV(pTHX_ OP *o)
4639 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
4645 Perl_newCVREF(pTHX_ I32 flags, OP *o)
4647 return newUNOP(OP_RV2CV, flags, scalar(o));
4651 Perl_newSVREF(pTHX_ OP *o)
4653 if (o->op_type == OP_PADANY) {
4654 o->op_type = OP_PADSV;
4655 o->op_ppaddr = PL_ppaddr[OP_PADSV];
4658 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4659 o->op_flags |= OPpDONE_SVREF;
4662 return newUNOP(OP_RV2SV, 0, scalar(o));
4665 /* Check routines. */
4668 Perl_ck_anoncode(pTHX_ OP *o)
4670 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
4671 cSVOPo->op_sv = Nullsv;
4676 Perl_ck_bitop(pTHX_ OP *o)
4678 #define OP_IS_NUMCOMPARE(op) \
4679 ((op) == OP_LT || (op) == OP_I_LT || \
4680 (op) == OP_GT || (op) == OP_I_GT || \
4681 (op) == OP_LE || (op) == OP_I_LE || \
4682 (op) == OP_GE || (op) == OP_I_GE || \
4683 (op) == OP_EQ || (op) == OP_I_EQ || \
4684 (op) == OP_NE || (op) == OP_I_NE || \
4685 (op) == OP_NCMP || (op) == OP_I_NCMP)
4686 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4687 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
4688 && (o->op_type == OP_BIT_OR
4689 || o->op_type == OP_BIT_AND
4690 || o->op_type == OP_BIT_XOR))
4692 OP * left = cBINOPo->op_first;
4693 OP * right = left->op_sibling;
4694 if ((OP_IS_NUMCOMPARE(left->op_type) &&
4695 (left->op_flags & OPf_PARENS) == 0) ||
4696 (OP_IS_NUMCOMPARE(right->op_type) &&
4697 (right->op_flags & OPf_PARENS) == 0))
4698 if (ckWARN(WARN_PRECEDENCE))
4699 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4700 "Possible precedence problem on bitwise %c operator",
4701 o->op_type == OP_BIT_OR ? '|'
4702 : o->op_type == OP_BIT_AND ? '&' : '^'
4709 Perl_ck_concat(pTHX_ OP *o)
4711 OP *kid = cUNOPo->op_first;
4712 if (kid->op_type == OP_CONCAT && !(kUNOP->op_first->op_flags & OPf_MOD))
4713 o->op_flags |= OPf_STACKED;
4718 Perl_ck_spair(pTHX_ OP *o)
4720 if (o->op_flags & OPf_KIDS) {
4723 OPCODE type = o->op_type;
4724 o = modkids(ck_fun(o), type);
4725 kid = cUNOPo->op_first;
4726 newop = kUNOP->op_first->op_sibling;
4728 (newop->op_sibling ||
4729 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
4730 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
4731 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
4735 op_free(kUNOP->op_first);
4736 kUNOP->op_first = newop;
4738 o->op_ppaddr = PL_ppaddr[++o->op_type];
4743 Perl_ck_delete(pTHX_ OP *o)
4747 if (o->op_flags & OPf_KIDS) {
4748 OP *kid = cUNOPo->op_first;
4749 switch (kid->op_type) {
4751 o->op_flags |= OPf_SPECIAL;
4754 o->op_private |= OPpSLICE;
4757 o->op_flags |= OPf_SPECIAL;
4762 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
4771 Perl_ck_die(pTHX_ OP *o)
4774 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4780 Perl_ck_eof(pTHX_ OP *o)
4782 I32 type = o->op_type;
4784 if (o->op_flags & OPf_KIDS) {
4785 if (cLISTOPo->op_first->op_type == OP_STUB) {
4787 o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
4795 Perl_ck_eval(pTHX_ OP *o)
4797 PL_hints |= HINT_BLOCK_SCOPE;
4798 if (o->op_flags & OPf_KIDS) {
4799 SVOP *kid = (SVOP*)cUNOPo->op_first;
4802 o->op_flags &= ~OPf_KIDS;
4805 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
4808 cUNOPo->op_first = 0;
4811 NewOp(1101, enter, 1, LOGOP);
4812 enter->op_type = OP_ENTERTRY;
4813 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
4814 enter->op_private = 0;
4816 /* establish postfix order */
4817 enter->op_next = (OP*)enter;
4819 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
4820 o->op_type = OP_LEAVETRY;
4821 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
4822 enter->op_other = o;
4832 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
4834 o->op_targ = (PADOFFSET)PL_hints;
4839 Perl_ck_exit(pTHX_ OP *o)
4842 HV *table = GvHV(PL_hintgv);
4844 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
4845 if (svp && *svp && SvTRUE(*svp))
4846 o->op_private |= OPpEXIT_VMSISH;
4848 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4854 Perl_ck_exec(pTHX_ OP *o)
4857 if (o->op_flags & OPf_STACKED) {
4859 kid = cUNOPo->op_first->op_sibling;
4860 if (kid->op_type == OP_RV2GV)
4869 Perl_ck_exists(pTHX_ OP *o)
4872 if (o->op_flags & OPf_KIDS) {
4873 OP *kid = cUNOPo->op_first;
4874 if (kid->op_type == OP_ENTERSUB) {
4875 (void) ref(kid, o->op_type);
4876 if (kid->op_type != OP_RV2CV && !PL_error_count)
4877 Perl_croak(aTHX_ "%s argument is not a subroutine name",
4879 o->op_private |= OPpEXISTS_SUB;
4881 else if (kid->op_type == OP_AELEM)
4882 o->op_flags |= OPf_SPECIAL;
4883 else if (kid->op_type != OP_HELEM)
4884 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
4893 Perl_ck_gvconst(pTHX_ register OP *o)
4895 o = fold_constants(o);
4896 if (o->op_type == OP_CONST)
4903 Perl_ck_rvconst(pTHX_ register OP *o)
4905 SVOP *kid = (SVOP*)cUNOPo->op_first;
4907 o->op_private |= (PL_hints & HINT_STRICT_REFS);
4908 if (kid->op_type == OP_CONST) {
4912 SV *kidsv = kid->op_sv;
4915 /* Is it a constant from cv_const_sv()? */
4916 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
4917 SV *rsv = SvRV(kidsv);
4918 int svtype = SvTYPE(rsv);
4919 char *badtype = Nullch;
4921 switch (o->op_type) {
4923 if (svtype > SVt_PVMG)
4924 badtype = "a SCALAR";
4927 if (svtype != SVt_PVAV)
4928 badtype = "an ARRAY";
4931 if (svtype != SVt_PVHV)
4935 if (svtype != SVt_PVCV)
4940 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
4943 name = SvPV(kidsv, n_a);
4944 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
4945 char *badthing = Nullch;
4946 switch (o->op_type) {
4948 badthing = "a SCALAR";
4951 badthing = "an ARRAY";
4954 badthing = "a HASH";
4959 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
4963 * This is a little tricky. We only want to add the symbol if we
4964 * didn't add it in the lexer. Otherwise we get duplicate strict
4965 * warnings. But if we didn't add it in the lexer, we must at
4966 * least pretend like we wanted to add it even if it existed before,
4967 * or we get possible typo warnings. OPpCONST_ENTERED says
4968 * whether the lexer already added THIS instance of this symbol.
4970 iscv = (o->op_type == OP_RV2CV) * 2;
4972 gv = gv_fetchpv(name,
4973 iscv | !(kid->op_private & OPpCONST_ENTERED),
4976 : o->op_type == OP_RV2SV
4978 : o->op_type == OP_RV2AV
4980 : o->op_type == OP_RV2HV
4983 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
4985 kid->op_type = OP_GV;
4986 SvREFCNT_dec(kid->op_sv);
4988 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
4989 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
4990 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
4992 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
4994 kid->op_sv = SvREFCNT_inc(gv);
4996 kid->op_private = 0;
4997 kid->op_ppaddr = PL_ppaddr[OP_GV];
5004 Perl_ck_ftst(pTHX_ OP *o)
5006 I32 type = o->op_type;
5008 if (o->op_flags & OPf_REF) {
5011 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5012 SVOP *kid = (SVOP*)cUNOPo->op_first;
5014 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5016 OP *newop = newGVOP(type, OPf_REF,
5017 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5022 if ((PL_hints & HINT_FILETEST_ACCESS) &&
5023 OP_IS_FILETEST_ACCESS(o))
5024 o->op_private |= OPpFT_ACCESS;
5029 if (type == OP_FTTTY)
5030 o = newGVOP(type, OPf_REF, PL_stdingv);
5032 o = newUNOP(type, 0, newDEFSVOP());
5038 Perl_ck_fun(pTHX_ OP *o)
5044 int type = o->op_type;
5045 register I32 oa = PL_opargs[type] >> OASHIFT;
5047 if (o->op_flags & OPf_STACKED) {
5048 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5051 return no_fh_allowed(o);
5054 if (o->op_flags & OPf_KIDS) {
5056 tokid = &cLISTOPo->op_first;
5057 kid = cLISTOPo->op_first;
5058 if (kid->op_type == OP_PUSHMARK ||
5059 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5061 tokid = &kid->op_sibling;
5062 kid = kid->op_sibling;
5064 if (!kid && PL_opargs[type] & OA_DEFGV)
5065 *tokid = kid = newDEFSVOP();
5069 sibl = kid->op_sibling;
5072 /* list seen where single (scalar) arg expected? */
5073 if (numargs == 1 && !(oa >> 4)
5074 && kid->op_type == OP_LIST && type != OP_SCALAR)
5076 return too_many_arguments(o,PL_op_desc[type]);
5089 if ((type == OP_PUSH || type == OP_UNSHIFT)
5090 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5091 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5092 "Useless use of %s with no values",
5095 if (kid->op_type == OP_CONST &&
5096 (kid->op_private & OPpCONST_BARE))
5098 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5099 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5100 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5101 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5102 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5103 "Array @%s missing the @ in argument %"IVdf" of %s()",
5104 name, (IV)numargs, PL_op_desc[type]);
5107 kid->op_sibling = sibl;
5110 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5111 bad_type(numargs, "array", PL_op_desc[type], kid);
5115 if (kid->op_type == OP_CONST &&
5116 (kid->op_private & OPpCONST_BARE))
5118 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5119 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5120 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5121 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5122 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5123 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5124 name, (IV)numargs, PL_op_desc[type]);
5127 kid->op_sibling = sibl;
5130 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5131 bad_type(numargs, "hash", PL_op_desc[type], kid);
5136 OP *newop = newUNOP(OP_NULL, 0, kid);
5137 kid->op_sibling = 0;
5139 newop->op_next = newop;
5141 kid->op_sibling = sibl;
5146 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5147 if (kid->op_type == OP_CONST &&
5148 (kid->op_private & OPpCONST_BARE))
5150 OP *newop = newGVOP(OP_GV, 0,
5151 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5153 if (!(o->op_private & 1) && /* if not unop */
5154 kid == cLISTOPo->op_last)
5155 cLISTOPo->op_last = newop;
5159 else if (kid->op_type == OP_READLINE) {
5160 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5161 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5164 I32 flags = OPf_SPECIAL;
5168 /* is this op a FH constructor? */
5169 if (is_handle_constructor(o,numargs)) {
5170 char *name = Nullch;
5174 /* Set a flag to tell rv2gv to vivify
5175 * need to "prove" flag does not mean something
5176 * else already - NI-S 1999/05/07
5179 if (kid->op_type == OP_PADSV) {
5180 name = PAD_COMPNAME_PV(kid->op_targ);
5181 /* SvCUR of a pad namesv can't be trusted
5182 * (see PL_generation), so calc its length
5188 else if (kid->op_type == OP_RV2SV
5189 && kUNOP->op_first->op_type == OP_GV)
5191 GV *gv = cGVOPx_gv(kUNOP->op_first);
5193 len = GvNAMELEN(gv);
5195 else if (kid->op_type == OP_AELEM
5196 || kid->op_type == OP_HELEM)
5201 if ((op = ((BINOP*)kid)->op_first)) {
5202 SV *tmpstr = Nullsv;
5204 kid->op_type == OP_AELEM ?
5206 if (((op->op_type == OP_RV2AV) ||
5207 (op->op_type == OP_RV2HV)) &&
5208 (op = ((UNOP*)op)->op_first) &&
5209 (op->op_type == OP_GV)) {
5210 /* packagevar $a[] or $h{} */
5211 GV *gv = cGVOPx_gv(op);
5219 else if (op->op_type == OP_PADAV
5220 || op->op_type == OP_PADHV) {
5221 /* lexicalvar $a[] or $h{} */
5223 PAD_COMPNAME_PV(op->op_targ);
5233 name = savepv(SvPVX(tmpstr));
5239 name = "__ANONIO__";
5246 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5247 namesv = PAD_SVl(targ);
5248 (void)SvUPGRADE(namesv, SVt_PV);
5250 sv_setpvn(namesv, "$", 1);
5251 sv_catpvn(namesv, name, len);
5254 kid->op_sibling = 0;
5255 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5256 kid->op_targ = targ;
5257 kid->op_private |= priv;
5259 kid->op_sibling = sibl;
5265 mod(scalar(kid), type);
5269 tokid = &kid->op_sibling;
5270 kid = kid->op_sibling;
5272 o->op_private |= numargs;
5274 return too_many_arguments(o,OP_DESC(o));
5277 else if (PL_opargs[type] & OA_DEFGV) {
5279 return newUNOP(type, 0, newDEFSVOP());
5283 while (oa & OA_OPTIONAL)
5285 if (oa && oa != OA_LIST)
5286 return too_few_arguments(o,OP_DESC(o));
5292 Perl_ck_glob(pTHX_ OP *o)
5297 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5298 append_elem(OP_GLOB, o, newDEFSVOP());
5300 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5301 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5303 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5306 #if !defined(PERL_EXTERNAL_GLOB)
5307 /* XXX this can be tightened up and made more failsafe. */
5308 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5311 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5312 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5313 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5314 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5315 GvCV(gv) = GvCV(glob_gv);
5316 SvREFCNT_inc((SV*)GvCV(gv));
5317 GvIMPORTED_CV_on(gv);
5320 #endif /* PERL_EXTERNAL_GLOB */
5322 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5323 append_elem(OP_GLOB, o,
5324 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5325 o->op_type = OP_LIST;
5326 o->op_ppaddr = PL_ppaddr[OP_LIST];
5327 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5328 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5329 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5330 append_elem(OP_LIST, o,
5331 scalar(newUNOP(OP_RV2CV, 0,
5332 newGVOP(OP_GV, 0, gv)))));
5333 o = newUNOP(OP_NULL, 0, ck_subr(o));
5334 o->op_targ = OP_GLOB; /* hint at what it used to be */
5337 gv = newGVgen("main");
5339 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5345 Perl_ck_grep(pTHX_ OP *o)
5349 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5351 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5352 NewOp(1101, gwop, 1, LOGOP);
5354 if (o->op_flags & OPf_STACKED) {
5357 kid = cLISTOPo->op_first->op_sibling;
5358 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5361 kid->op_next = (OP*)gwop;
5362 o->op_flags &= ~OPf_STACKED;
5364 kid = cLISTOPo->op_first->op_sibling;
5365 if (type == OP_MAPWHILE)
5372 kid = cLISTOPo->op_first->op_sibling;
5373 if (kid->op_type != OP_NULL)
5374 Perl_croak(aTHX_ "panic: ck_grep");
5375 kid = kUNOP->op_first;
5377 gwop->op_type = type;
5378 gwop->op_ppaddr = PL_ppaddr[type];
5379 gwop->op_first = listkids(o);
5380 gwop->op_flags |= OPf_KIDS;
5381 gwop->op_private = 1;
5382 gwop->op_other = LINKLIST(kid);
5383 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5384 kid->op_next = (OP*)gwop;
5386 kid = cLISTOPo->op_first->op_sibling;
5387 if (!kid || !kid->op_sibling)
5388 return too_few_arguments(o,OP_DESC(o));
5389 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5390 mod(kid, OP_GREPSTART);
5396 Perl_ck_index(pTHX_ OP *o)
5398 if (o->op_flags & OPf_KIDS) {
5399 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5401 kid = kid->op_sibling; /* get past "big" */
5402 if (kid && kid->op_type == OP_CONST)
5403 fbm_compile(((SVOP*)kid)->op_sv, 0);
5409 Perl_ck_lengthconst(pTHX_ OP *o)
5411 /* XXX length optimization goes here */
5416 Perl_ck_lfun(pTHX_ OP *o)
5418 OPCODE type = o->op_type;
5419 return modkids(ck_fun(o), type);
5423 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5425 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5426 switch (cUNOPo->op_first->op_type) {
5428 /* This is needed for
5429 if (defined %stash::)
5430 to work. Do not break Tk.
5432 break; /* Globals via GV can be undef */
5434 case OP_AASSIGN: /* Is this a good idea? */
5435 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5436 "defined(@array) is deprecated");
5437 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5438 "\t(Maybe you should just omit the defined()?)\n");
5441 /* This is needed for
5442 if (defined %stash::)
5443 to work. Do not break Tk.
5445 break; /* Globals via GV can be undef */
5447 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5448 "defined(%%hash) is deprecated");
5449 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5450 "\t(Maybe you should just omit the defined()?)\n");
5461 Perl_ck_rfun(pTHX_ OP *o)
5463 OPCODE type = o->op_type;
5464 return refkids(ck_fun(o), type);
5468 Perl_ck_listiob(pTHX_ OP *o)
5472 kid = cLISTOPo->op_first;
5475 kid = cLISTOPo->op_first;
5477 if (kid->op_type == OP_PUSHMARK)
5478 kid = kid->op_sibling;
5479 if (kid && o->op_flags & OPf_STACKED)
5480 kid = kid->op_sibling;
5481 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5482 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5483 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5484 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5485 cLISTOPo->op_first->op_sibling = kid;
5486 cLISTOPo->op_last = kid;
5487 kid = kid->op_sibling;
5492 append_elem(o->op_type, o, newDEFSVOP());
5498 Perl_ck_sassign(pTHX_ OP *o)
5500 OP *kid = cLISTOPo->op_first;
5501 /* has a disposable target? */
5502 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5503 && !(kid->op_flags & OPf_STACKED)
5504 /* Cannot steal the second time! */
5505 && !(kid->op_private & OPpTARGET_MY))
5507 OP *kkid = kid->op_sibling;
5509 /* Can just relocate the target. */
5510 if (kkid && kkid->op_type == OP_PADSV
5511 && !(kkid->op_private & OPpLVAL_INTRO))
5513 kid->op_targ = kkid->op_targ;
5515 /* Now we do not need PADSV and SASSIGN. */
5516 kid->op_sibling = o->op_sibling; /* NULL */
5517 cLISTOPo->op_first = NULL;
5520 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
5528 Perl_ck_match(pTHX_ OP *o)
5530 o->op_private |= OPpRUNTIME;
5535 Perl_ck_method(pTHX_ OP *o)
5537 OP *kid = cUNOPo->op_first;
5538 if (kid->op_type == OP_CONST) {
5539 SV* sv = kSVOP->op_sv;
5540 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
5542 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5543 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
5546 kSVOP->op_sv = Nullsv;
5548 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5557 Perl_ck_null(pTHX_ OP *o)
5563 Perl_ck_open(pTHX_ OP *o)
5565 HV *table = GvHV(PL_hintgv);
5569 svp = hv_fetch(table, "open_IN", 7, FALSE);
5571 mode = mode_from_discipline(*svp);
5572 if (mode & O_BINARY)
5573 o->op_private |= OPpOPEN_IN_RAW;
5574 else if (mode & O_TEXT)
5575 o->op_private |= OPpOPEN_IN_CRLF;
5578 svp = hv_fetch(table, "open_OUT", 8, FALSE);
5580 mode = mode_from_discipline(*svp);
5581 if (mode & O_BINARY)
5582 o->op_private |= OPpOPEN_OUT_RAW;
5583 else if (mode & O_TEXT)
5584 o->op_private |= OPpOPEN_OUT_CRLF;
5587 if (o->op_type == OP_BACKTICK)
5590 /* In case of three-arg dup open remove strictness
5591 * from the last arg if it is a bareword. */
5592 OP *first = cLISTOPx(o)->op_first; /* The pushmark. */
5593 OP *last = cLISTOPx(o)->op_last; /* The bareword. */
5597 if ((last->op_type == OP_CONST) && /* The bareword. */
5598 (last->op_private & OPpCONST_BARE) &&
5599 (last->op_private & OPpCONST_STRICT) &&
5600 (oa = first->op_sibling) && /* The fh. */
5601 (oa = oa->op_sibling) && /* The mode. */
5602 SvPOK(((SVOP*)oa)->op_sv) &&
5603 (mode = SvPVX(((SVOP*)oa)->op_sv)) &&
5604 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
5605 (last == oa->op_sibling)) /* The bareword. */
5606 last->op_private &= ~OPpCONST_STRICT;
5612 Perl_ck_repeat(pTHX_ OP *o)
5614 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5615 o->op_private |= OPpREPEAT_DOLIST;
5616 cBINOPo->op_first = force_list(cBINOPo->op_first);
5624 Perl_ck_require(pTHX_ OP *o)
5628 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
5629 SVOP *kid = (SVOP*)cUNOPo->op_first;
5631 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5633 for (s = SvPVX(kid->op_sv); *s; s++) {
5634 if (*s == ':' && s[1] == ':') {
5636 Move(s+2, s+1, strlen(s+2)+1, char);
5637 --SvCUR(kid->op_sv);
5640 if (SvREADONLY(kid->op_sv)) {
5641 SvREADONLY_off(kid->op_sv);
5642 sv_catpvn(kid->op_sv, ".pm", 3);
5643 SvREADONLY_on(kid->op_sv);
5646 sv_catpvn(kid->op_sv, ".pm", 3);
5650 /* handle override, if any */
5651 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
5652 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
5653 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
5655 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5656 OP *kid = cUNOPo->op_first;
5657 cUNOPo->op_first = 0;
5659 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5660 append_elem(OP_LIST, kid,
5661 scalar(newUNOP(OP_RV2CV, 0,
5670 Perl_ck_return(pTHX_ OP *o)
5673 if (CvLVALUE(PL_compcv)) {
5674 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5675 mod(kid, OP_LEAVESUBLV);
5682 Perl_ck_retarget(pTHX_ OP *o)
5684 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5691 Perl_ck_select(pTHX_ OP *o)
5694 if (o->op_flags & OPf_KIDS) {
5695 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5696 if (kid && kid->op_sibling) {
5697 o->op_type = OP_SSELECT;
5698 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
5700 return fold_constants(o);
5704 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5705 if (kid && kid->op_type == OP_RV2GV)
5706 kid->op_private &= ~HINT_STRICT_REFS;
5711 Perl_ck_shift(pTHX_ OP *o)
5713 I32 type = o->op_type;
5715 if (!(o->op_flags & OPf_KIDS)) {
5719 argop = newUNOP(OP_RV2AV, 0,
5720 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
5721 return newUNOP(type, 0, scalar(argop));
5723 return scalar(modkids(ck_fun(o), type));
5727 Perl_ck_sort(pTHX_ OP *o)
5731 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
5733 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5734 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
5736 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
5738 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
5740 if (kid->op_type == OP_SCOPE) {
5744 else if (kid->op_type == OP_LEAVE) {
5745 if (o->op_type == OP_SORT) {
5746 op_null(kid); /* wipe out leave */
5749 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
5750 if (k->op_next == kid)
5752 /* don't descend into loops */
5753 else if (k->op_type == OP_ENTERLOOP
5754 || k->op_type == OP_ENTERITER)
5756 k = cLOOPx(k)->op_lastop;
5761 kid->op_next = 0; /* just disconnect the leave */
5762 k = kLISTOP->op_first;
5767 if (o->op_type == OP_SORT) {
5768 /* provide scalar context for comparison function/block */
5774 o->op_flags |= OPf_SPECIAL;
5776 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
5779 firstkid = firstkid->op_sibling;
5782 /* provide list context for arguments */
5783 if (o->op_type == OP_SORT)
5790 S_simplify_sort(pTHX_ OP *o)
5792 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5796 if (!(o->op_flags & OPf_STACKED))
5798 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
5799 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
5800 kid = kUNOP->op_first; /* get past null */
5801 if (kid->op_type != OP_SCOPE)
5803 kid = kLISTOP->op_last; /* get past scope */
5804 switch(kid->op_type) {
5812 k = kid; /* remember this node*/
5813 if (kBINOP->op_first->op_type != OP_RV2SV)
5815 kid = kBINOP->op_first; /* get past cmp */
5816 if (kUNOP->op_first->op_type != OP_GV)
5818 kid = kUNOP->op_first; /* get past rv2sv */
5820 if (GvSTASH(gv) != PL_curstash)
5822 if (strEQ(GvNAME(gv), "a"))
5824 else if (strEQ(GvNAME(gv), "b"))
5828 kid = k; /* back to cmp */
5829 if (kBINOP->op_last->op_type != OP_RV2SV)
5831 kid = kBINOP->op_last; /* down to 2nd arg */
5832 if (kUNOP->op_first->op_type != OP_GV)
5834 kid = kUNOP->op_first; /* get past rv2sv */
5836 if (GvSTASH(gv) != PL_curstash
5838 ? strNE(GvNAME(gv), "a")
5839 : strNE(GvNAME(gv), "b")))
5841 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
5843 o->op_private |= OPpSORT_REVERSE;
5844 if (k->op_type == OP_NCMP)
5845 o->op_private |= OPpSORT_NUMERIC;
5846 if (k->op_type == OP_I_NCMP)
5847 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
5848 kid = cLISTOPo->op_first->op_sibling;
5849 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
5850 op_free(kid); /* then delete it */
5854 Perl_ck_split(pTHX_ OP *o)
5858 if (o->op_flags & OPf_STACKED)
5859 return no_fh_allowed(o);
5861 kid = cLISTOPo->op_first;
5862 if (kid->op_type != OP_NULL)
5863 Perl_croak(aTHX_ "panic: ck_split");
5864 kid = kid->op_sibling;
5865 op_free(cLISTOPo->op_first);
5866 cLISTOPo->op_first = kid;
5868 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
5869 cLISTOPo->op_last = kid; /* There was only one element previously */
5872 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
5873 OP *sibl = kid->op_sibling;
5874 kid->op_sibling = 0;
5875 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
5876 if (cLISTOPo->op_first == cLISTOPo->op_last)
5877 cLISTOPo->op_last = kid;
5878 cLISTOPo->op_first = kid;
5879 kid->op_sibling = sibl;
5882 kid->op_type = OP_PUSHRE;
5883 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
5885 if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
5886 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
5887 "Use of /g modifier is meaningless in split");
5890 if (!kid->op_sibling)
5891 append_elem(OP_SPLIT, o, newDEFSVOP());
5893 kid = kid->op_sibling;
5896 if (!kid->op_sibling)
5897 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
5899 kid = kid->op_sibling;
5902 if (kid->op_sibling)
5903 return too_many_arguments(o,OP_DESC(o));
5909 Perl_ck_join(pTHX_ OP *o)
5911 if (ckWARN(WARN_SYNTAX)) {
5912 OP *kid = cLISTOPo->op_first->op_sibling;
5913 if (kid && kid->op_type == OP_MATCH) {
5914 char *pmstr = "STRING";
5915 if (PM_GETRE(kPMOP))
5916 pmstr = PM_GETRE(kPMOP)->precomp;
5917 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5918 "/%s/ should probably be written as \"%s\"",
5926 Perl_ck_subr(pTHX_ OP *o)
5928 OP *prev = ((cUNOPo->op_first->op_sibling)
5929 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
5930 OP *o2 = prev->op_sibling;
5937 I32 contextclass = 0;
5942 o->op_private |= OPpENTERSUB_HASTARG;
5943 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
5944 if (cvop->op_type == OP_RV2CV) {
5946 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
5947 op_null(cvop); /* disable rv2cv */
5948 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
5949 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
5950 GV *gv = cGVOPx_gv(tmpop);
5953 tmpop->op_private |= OPpEARLY_CV;
5956 namegv = CvANON(cv) ? gv : CvGV(cv);
5957 proto = SvPV((SV*)cv, n_a);
5959 if (CvASSERTION(cv)) {
5960 if (PL_hints & HINT_ASSERTING) {
5961 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
5962 o->op_private |= OPpENTERSUB_DB;
5966 if (ckWARN(WARN_ASSERTIONS) && !(PL_hints & HINT_ASSERTIONSSEEN)) {
5967 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
5968 "Impossible to activate assertion call");
5975 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
5976 if (o2->op_type == OP_CONST)
5977 o2->op_private &= ~OPpCONST_STRICT;
5978 else if (o2->op_type == OP_LIST) {
5979 OP *o = ((UNOP*)o2)->op_first->op_sibling;
5980 if (o && o->op_type == OP_CONST)
5981 o->op_private &= ~OPpCONST_STRICT;
5984 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5985 if (PERLDB_SUB && PL_curstash != PL_debstash)
5986 o->op_private |= OPpENTERSUB_DB;
5987 while (o2 != cvop) {
5991 return too_many_arguments(o, gv_ename(namegv));
6009 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6011 arg == 1 ? "block or sub {}" : "sub {}",
6012 gv_ename(namegv), o2);
6015 /* '*' allows any scalar type, including bareword */
6018 if (o2->op_type == OP_RV2GV)
6019 goto wrapref; /* autoconvert GLOB -> GLOBref */
6020 else if (o2->op_type == OP_CONST)
6021 o2->op_private &= ~OPpCONST_STRICT;
6022 else if (o2->op_type == OP_ENTERSUB) {
6023 /* accidental subroutine, revert to bareword */
6024 OP *gvop = ((UNOP*)o2)->op_first;
6025 if (gvop && gvop->op_type == OP_NULL) {
6026 gvop = ((UNOP*)gvop)->op_first;
6028 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6031 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6032 (gvop = ((UNOP*)gvop)->op_first) &&
6033 gvop->op_type == OP_GV)
6035 GV *gv = cGVOPx_gv(gvop);
6036 OP *sibling = o2->op_sibling;
6037 SV *n = newSVpvn("",0);
6039 gv_fullname3(n, gv, "");
6040 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6041 sv_chop(n, SvPVX(n)+6);
6042 o2 = newSVOP(OP_CONST, 0, n);
6043 prev->op_sibling = o2;
6044 o2->op_sibling = sibling;
6060 if (contextclass++ == 0) {
6061 e = strchr(proto, ']');
6062 if (!e || e == proto)
6075 while (*--p != '[');
6076 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6077 gv_ename(namegv), o2);
6083 if (o2->op_type == OP_RV2GV)
6086 bad_type(arg, "symbol", gv_ename(namegv), o2);
6089 if (o2->op_type == OP_ENTERSUB)
6092 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6095 if (o2->op_type == OP_RV2SV ||
6096 o2->op_type == OP_PADSV ||
6097 o2->op_type == OP_HELEM ||
6098 o2->op_type == OP_AELEM ||
6099 o2->op_type == OP_THREADSV)
6102 bad_type(arg, "scalar", gv_ename(namegv), o2);
6105 if (o2->op_type == OP_RV2AV ||
6106 o2->op_type == OP_PADAV)
6109 bad_type(arg, "array", gv_ename(namegv), o2);
6112 if (o2->op_type == OP_RV2HV ||
6113 o2->op_type == OP_PADHV)
6116 bad_type(arg, "hash", gv_ename(namegv), o2);
6121 OP* sib = kid->op_sibling;
6122 kid->op_sibling = 0;
6123 o2 = newUNOP(OP_REFGEN, 0, kid);
6124 o2->op_sibling = sib;
6125 prev->op_sibling = o2;
6127 if (contextclass && e) {
6142 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6143 gv_ename(namegv), cv);
6148 mod(o2, OP_ENTERSUB);
6150 o2 = o2->op_sibling;
6152 if (proto && !optional &&
6153 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6154 return too_few_arguments(o, gv_ename(namegv));
6157 o=newSVOP(OP_CONST, 0, newSViv(0));
6163 Perl_ck_svconst(pTHX_ OP *o)
6165 SvREADONLY_on(cSVOPo->op_sv);
6170 Perl_ck_trunc(pTHX_ OP *o)
6172 if (o->op_flags & OPf_KIDS) {
6173 SVOP *kid = (SVOP*)cUNOPo->op_first;
6175 if (kid->op_type == OP_NULL)
6176 kid = (SVOP*)kid->op_sibling;
6177 if (kid && kid->op_type == OP_CONST &&
6178 (kid->op_private & OPpCONST_BARE))
6180 o->op_flags |= OPf_SPECIAL;
6181 kid->op_private &= ~OPpCONST_STRICT;
6188 Perl_ck_substr(pTHX_ OP *o)
6191 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6192 OP *kid = cLISTOPo->op_first;
6194 if (kid->op_type == OP_NULL)
6195 kid = kid->op_sibling;
6197 kid->op_flags |= OPf_MOD;
6203 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6206 Perl_peep(pTHX_ register OP *o)
6208 register OP* oldop = 0;
6210 if (!o || o->op_seq)
6214 SAVEVPTR(PL_curcop);
6215 for (; o; o = o->op_next) {
6218 /* The special value -1 is used by the B::C compiler backend to indicate
6219 * that an op is statically defined and should not be freed */
6220 if (!PL_op_seqmax || PL_op_seqmax == (U16)-1)
6223 switch (o->op_type) {
6227 PL_curcop = ((COP*)o); /* for warnings */
6228 o->op_seq = PL_op_seqmax++;
6232 if (cSVOPo->op_private & OPpCONST_STRICT)
6233 no_bareword_allowed(o);
6235 case OP_METHOD_NAMED:
6236 /* Relocate sv to the pad for thread safety.
6237 * Despite being a "constant", the SV is written to,
6238 * for reference counts, sv_upgrade() etc. */
6240 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6241 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6242 /* If op_sv is already a PADTMP then it is being used by
6243 * some pad, so make a copy. */
6244 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6245 SvREADONLY_on(PAD_SVl(ix));
6246 SvREFCNT_dec(cSVOPo->op_sv);
6249 SvREFCNT_dec(PAD_SVl(ix));
6250 SvPADTMP_on(cSVOPo->op_sv);
6251 PAD_SETSV(ix, cSVOPo->op_sv);
6252 /* XXX I don't know how this isn't readonly already. */
6253 SvREADONLY_on(PAD_SVl(ix));
6255 cSVOPo->op_sv = Nullsv;
6259 o->op_seq = PL_op_seqmax++;
6263 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6264 if (o->op_next->op_private & OPpTARGET_MY) {
6265 if (o->op_flags & OPf_STACKED) /* chained concats */
6266 goto ignore_optimization;
6268 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6269 o->op_targ = o->op_next->op_targ;
6270 o->op_next->op_targ = 0;
6271 o->op_private |= OPpTARGET_MY;
6274 op_null(o->op_next);
6276 ignore_optimization:
6277 o->op_seq = PL_op_seqmax++;
6282 o->op_next->op_type == OP_LEAVESUB) {
6283 OP* newop = newSTATEOP(0, Nullch, 0);
6284 newop->op_next = o->op_next;
6288 ((UNOP*)o->op_next)->op_first = newop;
6289 CvSTART(PL_compcv) = newop;
6291 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6292 o->op_seq = PL_op_seqmax++;
6293 break; /* Scalar stub must produce undef. List stub is noop */
6297 if (o->op_targ == OP_NEXTSTATE
6298 || o->op_targ == OP_DBSTATE
6299 || o->op_targ == OP_SETSTATE)
6301 PL_curcop = ((COP*)o);
6303 /* XXX: We avoid setting op_seq here to prevent later calls
6304 to peep() from mistakenly concluding that optimisation
6305 has already occurred. This doesn't fix the real problem,
6306 though (See 20010220.007). AMS 20010719 */
6307 if (oldop && o->op_next) {
6308 oldop->op_next = o->op_next;
6316 if (oldop && o->op_next) {
6317 oldop->op_next = o->op_next;
6320 o->op_seq = PL_op_seqmax++;
6324 if (o->op_next->op_type == OP_RV2SV) {
6325 if (!(o->op_next->op_private & OPpDEREF)) {
6326 op_null(o->op_next);
6327 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6329 o->op_next = o->op_next->op_next;
6330 o->op_type = OP_GVSV;
6331 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6334 else if (o->op_next->op_type == OP_RV2AV) {
6335 OP* pop = o->op_next->op_next;
6337 if (pop && pop->op_type == OP_CONST &&
6338 (PL_op = pop->op_next) &&
6339 pop->op_next->op_type == OP_AELEM &&
6340 !(pop->op_next->op_private &
6341 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6342 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6347 op_null(o->op_next);
6348 op_null(pop->op_next);
6350 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6351 o->op_next = pop->op_next->op_next;
6352 o->op_type = OP_AELEMFAST;
6353 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6354 o->op_private = (U8)i;
6359 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6361 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6362 /* XXX could check prototype here instead of just carping */
6363 SV *sv = sv_newmortal();
6364 gv_efullname3(sv, gv, Nullch);
6365 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6366 "%"SVf"() called too early to check prototype",
6370 else if (o->op_next->op_type == OP_READLINE
6371 && o->op_next->op_next->op_type == OP_CONCAT
6372 && (o->op_next->op_next->op_flags & OPf_STACKED))
6374 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6375 o->op_type = OP_RCATLINE;
6376 o->op_flags |= OPf_STACKED;
6377 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6378 op_null(o->op_next->op_next);
6379 op_null(o->op_next);
6382 o->op_seq = PL_op_seqmax++;
6395 o->op_seq = PL_op_seqmax++;
6396 while (cLOGOP->op_other->op_type == OP_NULL)
6397 cLOGOP->op_other = cLOGOP->op_other->op_next;
6398 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6403 o->op_seq = PL_op_seqmax++;
6404 while (cLOOP->op_redoop->op_type == OP_NULL)
6405 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6406 peep(cLOOP->op_redoop);
6407 while (cLOOP->op_nextop->op_type == OP_NULL)
6408 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6409 peep(cLOOP->op_nextop);
6410 while (cLOOP->op_lastop->op_type == OP_NULL)
6411 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6412 peep(cLOOP->op_lastop);
6418 o->op_seq = PL_op_seqmax++;
6419 while (cPMOP->op_pmreplstart &&
6420 cPMOP->op_pmreplstart->op_type == OP_NULL)
6421 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6422 peep(cPMOP->op_pmreplstart);
6426 o->op_seq = PL_op_seqmax++;
6427 if (ckWARN(WARN_SYNTAX) && o->op_next
6428 && o->op_next->op_type == OP_NEXTSTATE) {
6429 if (o->op_next->op_sibling &&
6430 o->op_next->op_sibling->op_type != OP_EXIT &&
6431 o->op_next->op_sibling->op_type != OP_WARN &&
6432 o->op_next->op_sibling->op_type != OP_DIE) {
6433 line_t oldline = CopLINE(PL_curcop);
6435 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6436 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6437 "Statement unlikely to be reached");
6438 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6439 "\t(Maybe you meant system() when you said exec()?)\n");
6440 CopLINE_set(PL_curcop, oldline);
6451 o->op_seq = PL_op_seqmax++;
6453 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6456 /* Make the CONST have a shared SV */
6457 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6458 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6459 key = SvPV(sv, keylen);
6460 lexname = newSVpvn_share(key,
6461 SvUTF8(sv) ? -(I32)keylen : keylen,
6470 o->op_seq = PL_op_seqmax++;
6480 char* Perl_custom_op_name(pTHX_ OP* o)
6482 IV index = PTR2IV(o->op_ppaddr);
6486 if (!PL_custom_op_names) /* This probably shouldn't happen */
6487 return PL_op_name[OP_CUSTOM];
6489 keysv = sv_2mortal(newSViv(index));
6491 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
6493 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
6495 return SvPV_nolen(HeVAL(he));
6498 char* Perl_custom_op_desc(pTHX_ OP* o)
6500 IV index = PTR2IV(o->op_ppaddr);
6504 if (!PL_custom_op_descs)
6505 return PL_op_desc[OP_CUSTOM];
6507 keysv = sv_2mortal(newSViv(index));
6509 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
6511 return PL_op_desc[OP_CUSTOM];
6513 return SvPV_nolen(HeVAL(he));
6519 /* Efficient sub that returns a constant scalar value. */
6521 const_sv_xsub(pTHX_ CV* cv)
6526 Perl_croak(aTHX_ "usage: %s::%s()",
6527 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
6531 ST(0) = (SV*)XSANY.any_ptr;