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 /* This makes sub {}; work as expected. */
4217 if (block->op_type == OP_STUB) {
4219 block = newSTATEOP(0, Nullch, 0);
4221 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4223 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4224 OpREFCNT_set(CvROOT(cv), 1);
4225 CvSTART(cv) = LINKLIST(CvROOT(cv));
4226 CvROOT(cv)->op_next = 0;
4227 CALL_PEEP(CvSTART(cv));
4229 /* now that optimizer has done its work, adjust pad values */
4231 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4234 assert(!CvCONST(cv));
4235 if (ps && !*ps && op_const_sv(block, cv))
4239 if (name || aname) {
4241 char *tname = (name ? name : aname);
4243 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4244 SV *sv = NEWSV(0,0);
4245 SV *tmpstr = sv_newmortal();
4246 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4250 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4252 (long)PL_subline, (long)CopLINE(PL_curcop));
4253 gv_efullname3(tmpstr, gv, Nullch);
4254 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4255 hv = GvHVn(db_postponed);
4256 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4257 && (pcv = GvCV(db_postponed)))
4263 call_sv((SV*)pcv, G_DISCARD);
4267 if ((s = strrchr(tname,':')))
4272 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4275 if (strEQ(s, "BEGIN") && !PL_error_count) {
4276 I32 oldscope = PL_scopestack_ix;
4278 SAVECOPFILE(&PL_compiling);
4279 SAVECOPLINE(&PL_compiling);
4282 PL_beginav = newAV();
4283 DEBUG_x( dump_sub(gv) );
4284 av_push(PL_beginav, (SV*)cv);
4285 GvCV(gv) = 0; /* cv has been hijacked */
4286 call_list(oldscope, PL_beginav);
4288 PL_curcop = &PL_compiling;
4289 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4292 else if (strEQ(s, "END") && !PL_error_count) {
4295 DEBUG_x( dump_sub(gv) );
4296 av_unshift(PL_endav, 1);
4297 av_store(PL_endav, 0, (SV*)cv);
4298 GvCV(gv) = 0; /* cv has been hijacked */
4300 else if (strEQ(s, "CHECK") && !PL_error_count) {
4302 PL_checkav = newAV();
4303 DEBUG_x( dump_sub(gv) );
4304 if (PL_main_start && ckWARN(WARN_VOID))
4305 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4306 av_unshift(PL_checkav, 1);
4307 av_store(PL_checkav, 0, (SV*)cv);
4308 GvCV(gv) = 0; /* cv has been hijacked */
4310 else if (strEQ(s, "INIT") && !PL_error_count) {
4312 PL_initav = newAV();
4313 DEBUG_x( dump_sub(gv) );
4314 if (PL_main_start && ckWARN(WARN_VOID))
4315 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4316 av_push(PL_initav, (SV*)cv);
4317 GvCV(gv) = 0; /* cv has been hijacked */
4322 PL_copline = NOLINE;
4327 /* XXX unsafe for threads if eval_owner isn't held */
4329 =for apidoc newCONSTSUB
4331 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4332 eligible for inlining at compile-time.
4338 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4344 SAVECOPLINE(PL_curcop);
4345 CopLINE_set(PL_curcop, PL_copline);
4348 PL_hints &= ~HINT_BLOCK_SCOPE;
4351 SAVESPTR(PL_curstash);
4352 SAVECOPSTASH(PL_curcop);
4353 PL_curstash = stash;
4354 CopSTASH_set(PL_curcop,stash);
4357 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4358 CvXSUBANY(cv).any_ptr = sv;
4360 sv_setpv((SV*)cv, ""); /* prototype is "" */
4363 CopSTASH_free(PL_curcop);
4371 =for apidoc U||newXS
4373 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4379 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
4381 GV *gv = gv_fetchpv(name ? name :
4382 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4383 GV_ADDMULTI, SVt_PVCV);
4387 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4389 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4391 /* just a cached method */
4395 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4396 /* already defined (or promised) */
4397 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4398 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4399 line_t oldline = CopLINE(PL_curcop);
4400 if (PL_copline != NOLINE)
4401 CopLINE_set(PL_curcop, PL_copline);
4402 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4403 CvCONST(cv) ? "Constant subroutine %s redefined"
4404 : "Subroutine %s redefined"
4406 CopLINE_set(PL_curcop, oldline);
4413 if (cv) /* must reuse cv if autoloaded */
4416 cv = (CV*)NEWSV(1105,0);
4417 sv_upgrade((SV *)cv, SVt_PVCV);
4421 PL_sub_generation++;
4425 (void)gv_fetchfile(filename);
4426 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
4427 an external constant string */
4428 CvXSUB(cv) = subaddr;
4431 char *s = strrchr(name,':');
4437 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4440 if (strEQ(s, "BEGIN")) {
4442 PL_beginav = newAV();
4443 av_push(PL_beginav, (SV*)cv);
4444 GvCV(gv) = 0; /* cv has been hijacked */
4446 else if (strEQ(s, "END")) {
4449 av_unshift(PL_endav, 1);
4450 av_store(PL_endav, 0, (SV*)cv);
4451 GvCV(gv) = 0; /* cv has been hijacked */
4453 else if (strEQ(s, "CHECK")) {
4455 PL_checkav = newAV();
4456 if (PL_main_start && ckWARN(WARN_VOID))
4457 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4458 av_unshift(PL_checkav, 1);
4459 av_store(PL_checkav, 0, (SV*)cv);
4460 GvCV(gv) = 0; /* cv has been hijacked */
4462 else if (strEQ(s, "INIT")) {
4464 PL_initav = newAV();
4465 if (PL_main_start && ckWARN(WARN_VOID))
4466 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4467 av_push(PL_initav, (SV*)cv);
4468 GvCV(gv) = 0; /* cv has been hijacked */
4479 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4487 name = SvPVx(cSVOPo->op_sv, n_a);
4490 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
4491 #ifdef GV_UNIQUE_CHECK
4493 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4497 if ((cv = GvFORM(gv))) {
4498 if (ckWARN(WARN_REDEFINE)) {
4499 line_t oldline = CopLINE(PL_curcop);
4500 if (PL_copline != NOLINE)
4501 CopLINE_set(PL_curcop, PL_copline);
4502 Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Format %s redefined",name);
4503 CopLINE_set(PL_curcop, oldline);
4510 CvFILE_set_from_cop(cv, PL_curcop);
4513 pad_tidy(padtidy_FORMAT);
4514 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4515 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4516 OpREFCNT_set(CvROOT(cv), 1);
4517 CvSTART(cv) = LINKLIST(CvROOT(cv));
4518 CvROOT(cv)->op_next = 0;
4519 CALL_PEEP(CvSTART(cv));
4521 PL_copline = NOLINE;
4526 Perl_newANONLIST(pTHX_ OP *o)
4528 return newUNOP(OP_REFGEN, 0,
4529 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4533 Perl_newANONHASH(pTHX_ OP *o)
4535 return newUNOP(OP_REFGEN, 0,
4536 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4540 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4542 return newANONATTRSUB(floor, proto, Nullop, block);
4546 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4548 return newUNOP(OP_REFGEN, 0,
4549 newSVOP(OP_ANONCODE, 0,
4550 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
4554 Perl_oopsAV(pTHX_ OP *o)
4556 switch (o->op_type) {
4558 o->op_type = OP_PADAV;
4559 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4560 return ref(o, OP_RV2AV);
4563 o->op_type = OP_RV2AV;
4564 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4569 if (ckWARN_d(WARN_INTERNAL))
4570 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
4577 Perl_oopsHV(pTHX_ OP *o)
4579 switch (o->op_type) {
4582 o->op_type = OP_PADHV;
4583 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4584 return ref(o, OP_RV2HV);
4588 o->op_type = OP_RV2HV;
4589 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
4594 if (ckWARN_d(WARN_INTERNAL))
4595 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
4602 Perl_newAVREF(pTHX_ OP *o)
4604 if (o->op_type == OP_PADANY) {
4605 o->op_type = OP_PADAV;
4606 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4609 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
4610 && ckWARN(WARN_DEPRECATED)) {
4611 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4612 "Using an array as a reference is deprecated");
4614 return newUNOP(OP_RV2AV, 0, scalar(o));
4618 Perl_newGVREF(pTHX_ I32 type, OP *o)
4620 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
4621 return newUNOP(OP_NULL, 0, o);
4622 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
4626 Perl_newHVREF(pTHX_ OP *o)
4628 if (o->op_type == OP_PADANY) {
4629 o->op_type = OP_PADHV;
4630 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4633 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
4634 && ckWARN(WARN_DEPRECATED)) {
4635 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4636 "Using a hash as a reference is deprecated");
4638 return newUNOP(OP_RV2HV, 0, scalar(o));
4642 Perl_oopsCV(pTHX_ OP *o)
4644 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
4650 Perl_newCVREF(pTHX_ I32 flags, OP *o)
4652 return newUNOP(OP_RV2CV, flags, scalar(o));
4656 Perl_newSVREF(pTHX_ OP *o)
4658 if (o->op_type == OP_PADANY) {
4659 o->op_type = OP_PADSV;
4660 o->op_ppaddr = PL_ppaddr[OP_PADSV];
4663 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4664 o->op_flags |= OPpDONE_SVREF;
4667 return newUNOP(OP_RV2SV, 0, scalar(o));
4670 /* Check routines. */
4673 Perl_ck_anoncode(pTHX_ OP *o)
4675 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
4676 cSVOPo->op_sv = Nullsv;
4681 Perl_ck_bitop(pTHX_ OP *o)
4683 #define OP_IS_NUMCOMPARE(op) \
4684 ((op) == OP_LT || (op) == OP_I_LT || \
4685 (op) == OP_GT || (op) == OP_I_GT || \
4686 (op) == OP_LE || (op) == OP_I_LE || \
4687 (op) == OP_GE || (op) == OP_I_GE || \
4688 (op) == OP_EQ || (op) == OP_I_EQ || \
4689 (op) == OP_NE || (op) == OP_I_NE || \
4690 (op) == OP_NCMP || (op) == OP_I_NCMP)
4691 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4692 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
4693 && (o->op_type == OP_BIT_OR
4694 || o->op_type == OP_BIT_AND
4695 || o->op_type == OP_BIT_XOR))
4697 OP * left = cBINOPo->op_first;
4698 OP * right = left->op_sibling;
4699 if ((OP_IS_NUMCOMPARE(left->op_type) &&
4700 (left->op_flags & OPf_PARENS) == 0) ||
4701 (OP_IS_NUMCOMPARE(right->op_type) &&
4702 (right->op_flags & OPf_PARENS) == 0))
4703 if (ckWARN(WARN_PRECEDENCE))
4704 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4705 "Possible precedence problem on bitwise %c operator",
4706 o->op_type == OP_BIT_OR ? '|'
4707 : o->op_type == OP_BIT_AND ? '&' : '^'
4714 Perl_ck_concat(pTHX_ OP *o)
4716 OP *kid = cUNOPo->op_first;
4717 if (kid->op_type == OP_CONCAT && !(kUNOP->op_first->op_flags & OPf_MOD))
4718 o->op_flags |= OPf_STACKED;
4723 Perl_ck_spair(pTHX_ OP *o)
4725 if (o->op_flags & OPf_KIDS) {
4728 OPCODE type = o->op_type;
4729 o = modkids(ck_fun(o), type);
4730 kid = cUNOPo->op_first;
4731 newop = kUNOP->op_first->op_sibling;
4733 (newop->op_sibling ||
4734 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
4735 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
4736 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
4740 op_free(kUNOP->op_first);
4741 kUNOP->op_first = newop;
4743 o->op_ppaddr = PL_ppaddr[++o->op_type];
4748 Perl_ck_delete(pTHX_ OP *o)
4752 if (o->op_flags & OPf_KIDS) {
4753 OP *kid = cUNOPo->op_first;
4754 switch (kid->op_type) {
4756 o->op_flags |= OPf_SPECIAL;
4759 o->op_private |= OPpSLICE;
4762 o->op_flags |= OPf_SPECIAL;
4767 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
4776 Perl_ck_die(pTHX_ OP *o)
4779 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4785 Perl_ck_eof(pTHX_ OP *o)
4787 I32 type = o->op_type;
4789 if (o->op_flags & OPf_KIDS) {
4790 if (cLISTOPo->op_first->op_type == OP_STUB) {
4792 o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
4800 Perl_ck_eval(pTHX_ OP *o)
4802 PL_hints |= HINT_BLOCK_SCOPE;
4803 if (o->op_flags & OPf_KIDS) {
4804 SVOP *kid = (SVOP*)cUNOPo->op_first;
4807 o->op_flags &= ~OPf_KIDS;
4810 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
4813 cUNOPo->op_first = 0;
4816 NewOp(1101, enter, 1, LOGOP);
4817 enter->op_type = OP_ENTERTRY;
4818 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
4819 enter->op_private = 0;
4821 /* establish postfix order */
4822 enter->op_next = (OP*)enter;
4824 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
4825 o->op_type = OP_LEAVETRY;
4826 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
4827 enter->op_other = o;
4837 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
4839 o->op_targ = (PADOFFSET)PL_hints;
4844 Perl_ck_exit(pTHX_ OP *o)
4847 HV *table = GvHV(PL_hintgv);
4849 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
4850 if (svp && *svp && SvTRUE(*svp))
4851 o->op_private |= OPpEXIT_VMSISH;
4853 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4859 Perl_ck_exec(pTHX_ OP *o)
4862 if (o->op_flags & OPf_STACKED) {
4864 kid = cUNOPo->op_first->op_sibling;
4865 if (kid->op_type == OP_RV2GV)
4874 Perl_ck_exists(pTHX_ OP *o)
4877 if (o->op_flags & OPf_KIDS) {
4878 OP *kid = cUNOPo->op_first;
4879 if (kid->op_type == OP_ENTERSUB) {
4880 (void) ref(kid, o->op_type);
4881 if (kid->op_type != OP_RV2CV && !PL_error_count)
4882 Perl_croak(aTHX_ "%s argument is not a subroutine name",
4884 o->op_private |= OPpEXISTS_SUB;
4886 else if (kid->op_type == OP_AELEM)
4887 o->op_flags |= OPf_SPECIAL;
4888 else if (kid->op_type != OP_HELEM)
4889 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
4898 Perl_ck_gvconst(pTHX_ register OP *o)
4900 o = fold_constants(o);
4901 if (o->op_type == OP_CONST)
4908 Perl_ck_rvconst(pTHX_ register OP *o)
4910 SVOP *kid = (SVOP*)cUNOPo->op_first;
4912 o->op_private |= (PL_hints & HINT_STRICT_REFS);
4913 if (kid->op_type == OP_CONST) {
4917 SV *kidsv = kid->op_sv;
4920 /* Is it a constant from cv_const_sv()? */
4921 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
4922 SV *rsv = SvRV(kidsv);
4923 int svtype = SvTYPE(rsv);
4924 char *badtype = Nullch;
4926 switch (o->op_type) {
4928 if (svtype > SVt_PVMG)
4929 badtype = "a SCALAR";
4932 if (svtype != SVt_PVAV)
4933 badtype = "an ARRAY";
4936 if (svtype != SVt_PVHV)
4940 if (svtype != SVt_PVCV)
4945 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
4948 name = SvPV(kidsv, n_a);
4949 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
4950 char *badthing = Nullch;
4951 switch (o->op_type) {
4953 badthing = "a SCALAR";
4956 badthing = "an ARRAY";
4959 badthing = "a HASH";
4964 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
4968 * This is a little tricky. We only want to add the symbol if we
4969 * didn't add it in the lexer. Otherwise we get duplicate strict
4970 * warnings. But if we didn't add it in the lexer, we must at
4971 * least pretend like we wanted to add it even if it existed before,
4972 * or we get possible typo warnings. OPpCONST_ENTERED says
4973 * whether the lexer already added THIS instance of this symbol.
4975 iscv = (o->op_type == OP_RV2CV) * 2;
4977 gv = gv_fetchpv(name,
4978 iscv | !(kid->op_private & OPpCONST_ENTERED),
4981 : o->op_type == OP_RV2SV
4983 : o->op_type == OP_RV2AV
4985 : o->op_type == OP_RV2HV
4988 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
4990 kid->op_type = OP_GV;
4991 SvREFCNT_dec(kid->op_sv);
4993 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
4994 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
4995 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
4997 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
4999 kid->op_sv = SvREFCNT_inc(gv);
5001 kid->op_private = 0;
5002 kid->op_ppaddr = PL_ppaddr[OP_GV];
5009 Perl_ck_ftst(pTHX_ OP *o)
5011 I32 type = o->op_type;
5013 if (o->op_flags & OPf_REF) {
5016 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5017 SVOP *kid = (SVOP*)cUNOPo->op_first;
5019 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5021 OP *newop = newGVOP(type, OPf_REF,
5022 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5027 if ((PL_hints & HINT_FILETEST_ACCESS) &&
5028 OP_IS_FILETEST_ACCESS(o))
5029 o->op_private |= OPpFT_ACCESS;
5034 if (type == OP_FTTTY)
5035 o = newGVOP(type, OPf_REF, PL_stdingv);
5037 o = newUNOP(type, 0, newDEFSVOP());
5043 Perl_ck_fun(pTHX_ OP *o)
5049 int type = o->op_type;
5050 register I32 oa = PL_opargs[type] >> OASHIFT;
5052 if (o->op_flags & OPf_STACKED) {
5053 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5056 return no_fh_allowed(o);
5059 if (o->op_flags & OPf_KIDS) {
5061 tokid = &cLISTOPo->op_first;
5062 kid = cLISTOPo->op_first;
5063 if (kid->op_type == OP_PUSHMARK ||
5064 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5066 tokid = &kid->op_sibling;
5067 kid = kid->op_sibling;
5069 if (!kid && PL_opargs[type] & OA_DEFGV)
5070 *tokid = kid = newDEFSVOP();
5074 sibl = kid->op_sibling;
5077 /* list seen where single (scalar) arg expected? */
5078 if (numargs == 1 && !(oa >> 4)
5079 && kid->op_type == OP_LIST && type != OP_SCALAR)
5081 return too_many_arguments(o,PL_op_desc[type]);
5094 if ((type == OP_PUSH || type == OP_UNSHIFT)
5095 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5096 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5097 "Useless use of %s with no values",
5100 if (kid->op_type == OP_CONST &&
5101 (kid->op_private & OPpCONST_BARE))
5103 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5104 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5105 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5106 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5107 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5108 "Array @%s missing the @ in argument %"IVdf" of %s()",
5109 name, (IV)numargs, PL_op_desc[type]);
5112 kid->op_sibling = sibl;
5115 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5116 bad_type(numargs, "array", PL_op_desc[type], kid);
5120 if (kid->op_type == OP_CONST &&
5121 (kid->op_private & OPpCONST_BARE))
5123 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5124 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5125 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5126 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5127 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5128 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5129 name, (IV)numargs, PL_op_desc[type]);
5132 kid->op_sibling = sibl;
5135 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5136 bad_type(numargs, "hash", PL_op_desc[type], kid);
5141 OP *newop = newUNOP(OP_NULL, 0, kid);
5142 kid->op_sibling = 0;
5144 newop->op_next = newop;
5146 kid->op_sibling = sibl;
5151 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5152 if (kid->op_type == OP_CONST &&
5153 (kid->op_private & OPpCONST_BARE))
5155 OP *newop = newGVOP(OP_GV, 0,
5156 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5158 if (!(o->op_private & 1) && /* if not unop */
5159 kid == cLISTOPo->op_last)
5160 cLISTOPo->op_last = newop;
5164 else if (kid->op_type == OP_READLINE) {
5165 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5166 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5169 I32 flags = OPf_SPECIAL;
5173 /* is this op a FH constructor? */
5174 if (is_handle_constructor(o,numargs)) {
5175 char *name = Nullch;
5179 /* Set a flag to tell rv2gv to vivify
5180 * need to "prove" flag does not mean something
5181 * else already - NI-S 1999/05/07
5184 if (kid->op_type == OP_PADSV) {
5185 name = PAD_COMPNAME_PV(kid->op_targ);
5186 /* SvCUR of a pad namesv can't be trusted
5187 * (see PL_generation), so calc its length
5193 else if (kid->op_type == OP_RV2SV
5194 && kUNOP->op_first->op_type == OP_GV)
5196 GV *gv = cGVOPx_gv(kUNOP->op_first);
5198 len = GvNAMELEN(gv);
5200 else if (kid->op_type == OP_AELEM
5201 || kid->op_type == OP_HELEM)
5206 if ((op = ((BINOP*)kid)->op_first)) {
5207 SV *tmpstr = Nullsv;
5209 kid->op_type == OP_AELEM ?
5211 if (((op->op_type == OP_RV2AV) ||
5212 (op->op_type == OP_RV2HV)) &&
5213 (op = ((UNOP*)op)->op_first) &&
5214 (op->op_type == OP_GV)) {
5215 /* packagevar $a[] or $h{} */
5216 GV *gv = cGVOPx_gv(op);
5224 else if (op->op_type == OP_PADAV
5225 || op->op_type == OP_PADHV) {
5226 /* lexicalvar $a[] or $h{} */
5228 PAD_COMPNAME_PV(op->op_targ);
5238 name = savepv(SvPVX(tmpstr));
5244 name = "__ANONIO__";
5251 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5252 namesv = PAD_SVl(targ);
5253 (void)SvUPGRADE(namesv, SVt_PV);
5255 sv_setpvn(namesv, "$", 1);
5256 sv_catpvn(namesv, name, len);
5259 kid->op_sibling = 0;
5260 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5261 kid->op_targ = targ;
5262 kid->op_private |= priv;
5264 kid->op_sibling = sibl;
5270 mod(scalar(kid), type);
5274 tokid = &kid->op_sibling;
5275 kid = kid->op_sibling;
5277 o->op_private |= numargs;
5279 return too_many_arguments(o,OP_DESC(o));
5282 else if (PL_opargs[type] & OA_DEFGV) {
5284 return newUNOP(type, 0, newDEFSVOP());
5288 while (oa & OA_OPTIONAL)
5290 if (oa && oa != OA_LIST)
5291 return too_few_arguments(o,OP_DESC(o));
5297 Perl_ck_glob(pTHX_ OP *o)
5302 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5303 append_elem(OP_GLOB, o, newDEFSVOP());
5305 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5306 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5308 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5311 #if !defined(PERL_EXTERNAL_GLOB)
5312 /* XXX this can be tightened up and made more failsafe. */
5313 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5316 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5317 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5318 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5319 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5320 GvCV(gv) = GvCV(glob_gv);
5321 SvREFCNT_inc((SV*)GvCV(gv));
5322 GvIMPORTED_CV_on(gv);
5325 #endif /* PERL_EXTERNAL_GLOB */
5327 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5328 append_elem(OP_GLOB, o,
5329 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5330 o->op_type = OP_LIST;
5331 o->op_ppaddr = PL_ppaddr[OP_LIST];
5332 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5333 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5334 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5335 append_elem(OP_LIST, o,
5336 scalar(newUNOP(OP_RV2CV, 0,
5337 newGVOP(OP_GV, 0, gv)))));
5338 o = newUNOP(OP_NULL, 0, ck_subr(o));
5339 o->op_targ = OP_GLOB; /* hint at what it used to be */
5342 gv = newGVgen("main");
5344 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5350 Perl_ck_grep(pTHX_ OP *o)
5354 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5356 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5357 NewOp(1101, gwop, 1, LOGOP);
5359 if (o->op_flags & OPf_STACKED) {
5362 kid = cLISTOPo->op_first->op_sibling;
5363 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5366 kid->op_next = (OP*)gwop;
5367 o->op_flags &= ~OPf_STACKED;
5369 kid = cLISTOPo->op_first->op_sibling;
5370 if (type == OP_MAPWHILE)
5377 kid = cLISTOPo->op_first->op_sibling;
5378 if (kid->op_type != OP_NULL)
5379 Perl_croak(aTHX_ "panic: ck_grep");
5380 kid = kUNOP->op_first;
5382 gwop->op_type = type;
5383 gwop->op_ppaddr = PL_ppaddr[type];
5384 gwop->op_first = listkids(o);
5385 gwop->op_flags |= OPf_KIDS;
5386 gwop->op_private = 1;
5387 gwop->op_other = LINKLIST(kid);
5388 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5389 kid->op_next = (OP*)gwop;
5391 kid = cLISTOPo->op_first->op_sibling;
5392 if (!kid || !kid->op_sibling)
5393 return too_few_arguments(o,OP_DESC(o));
5394 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5395 mod(kid, OP_GREPSTART);
5401 Perl_ck_index(pTHX_ OP *o)
5403 if (o->op_flags & OPf_KIDS) {
5404 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5406 kid = kid->op_sibling; /* get past "big" */
5407 if (kid && kid->op_type == OP_CONST)
5408 fbm_compile(((SVOP*)kid)->op_sv, 0);
5414 Perl_ck_lengthconst(pTHX_ OP *o)
5416 /* XXX length optimization goes here */
5421 Perl_ck_lfun(pTHX_ OP *o)
5423 OPCODE type = o->op_type;
5424 return modkids(ck_fun(o), type);
5428 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5430 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5431 switch (cUNOPo->op_first->op_type) {
5433 /* This is needed for
5434 if (defined %stash::)
5435 to work. Do not break Tk.
5437 break; /* Globals via GV can be undef */
5439 case OP_AASSIGN: /* Is this a good idea? */
5440 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5441 "defined(@array) is deprecated");
5442 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5443 "\t(Maybe you should just omit the defined()?)\n");
5446 /* This is needed for
5447 if (defined %stash::)
5448 to work. Do not break Tk.
5450 break; /* Globals via GV can be undef */
5452 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5453 "defined(%%hash) is deprecated");
5454 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5455 "\t(Maybe you should just omit the defined()?)\n");
5466 Perl_ck_rfun(pTHX_ OP *o)
5468 OPCODE type = o->op_type;
5469 return refkids(ck_fun(o), type);
5473 Perl_ck_listiob(pTHX_ OP *o)
5477 kid = cLISTOPo->op_first;
5480 kid = cLISTOPo->op_first;
5482 if (kid->op_type == OP_PUSHMARK)
5483 kid = kid->op_sibling;
5484 if (kid && o->op_flags & OPf_STACKED)
5485 kid = kid->op_sibling;
5486 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5487 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5488 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5489 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5490 cLISTOPo->op_first->op_sibling = kid;
5491 cLISTOPo->op_last = kid;
5492 kid = kid->op_sibling;
5497 append_elem(o->op_type, o, newDEFSVOP());
5503 Perl_ck_sassign(pTHX_ OP *o)
5505 OP *kid = cLISTOPo->op_first;
5506 /* has a disposable target? */
5507 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5508 && !(kid->op_flags & OPf_STACKED)
5509 /* Cannot steal the second time! */
5510 && !(kid->op_private & OPpTARGET_MY))
5512 OP *kkid = kid->op_sibling;
5514 /* Can just relocate the target. */
5515 if (kkid && kkid->op_type == OP_PADSV
5516 && !(kkid->op_private & OPpLVAL_INTRO))
5518 kid->op_targ = kkid->op_targ;
5520 /* Now we do not need PADSV and SASSIGN. */
5521 kid->op_sibling = o->op_sibling; /* NULL */
5522 cLISTOPo->op_first = NULL;
5525 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
5533 Perl_ck_match(pTHX_ OP *o)
5535 o->op_private |= OPpRUNTIME;
5540 Perl_ck_method(pTHX_ OP *o)
5542 OP *kid = cUNOPo->op_first;
5543 if (kid->op_type == OP_CONST) {
5544 SV* sv = kSVOP->op_sv;
5545 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
5547 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5548 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
5551 kSVOP->op_sv = Nullsv;
5553 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5562 Perl_ck_null(pTHX_ OP *o)
5568 Perl_ck_open(pTHX_ OP *o)
5570 HV *table = GvHV(PL_hintgv);
5574 svp = hv_fetch(table, "open_IN", 7, FALSE);
5576 mode = mode_from_discipline(*svp);
5577 if (mode & O_BINARY)
5578 o->op_private |= OPpOPEN_IN_RAW;
5579 else if (mode & O_TEXT)
5580 o->op_private |= OPpOPEN_IN_CRLF;
5583 svp = hv_fetch(table, "open_OUT", 8, FALSE);
5585 mode = mode_from_discipline(*svp);
5586 if (mode & O_BINARY)
5587 o->op_private |= OPpOPEN_OUT_RAW;
5588 else if (mode & O_TEXT)
5589 o->op_private |= OPpOPEN_OUT_CRLF;
5592 if (o->op_type == OP_BACKTICK)
5595 /* In case of three-arg dup open remove strictness
5596 * from the last arg if it is a bareword. */
5597 OP *first = cLISTOPx(o)->op_first; /* The pushmark. */
5598 OP *last = cLISTOPx(o)->op_last; /* The bareword. */
5602 if ((last->op_type == OP_CONST) && /* The bareword. */
5603 (last->op_private & OPpCONST_BARE) &&
5604 (last->op_private & OPpCONST_STRICT) &&
5605 (oa = first->op_sibling) && /* The fh. */
5606 (oa = oa->op_sibling) && /* The mode. */
5607 SvPOK(((SVOP*)oa)->op_sv) &&
5608 (mode = SvPVX(((SVOP*)oa)->op_sv)) &&
5609 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
5610 (last == oa->op_sibling)) /* The bareword. */
5611 last->op_private &= ~OPpCONST_STRICT;
5617 Perl_ck_repeat(pTHX_ OP *o)
5619 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5620 o->op_private |= OPpREPEAT_DOLIST;
5621 cBINOPo->op_first = force_list(cBINOPo->op_first);
5629 Perl_ck_require(pTHX_ OP *o)
5633 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
5634 SVOP *kid = (SVOP*)cUNOPo->op_first;
5636 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5638 for (s = SvPVX(kid->op_sv); *s; s++) {
5639 if (*s == ':' && s[1] == ':') {
5641 Move(s+2, s+1, strlen(s+2)+1, char);
5642 --SvCUR(kid->op_sv);
5645 if (SvREADONLY(kid->op_sv)) {
5646 SvREADONLY_off(kid->op_sv);
5647 sv_catpvn(kid->op_sv, ".pm", 3);
5648 SvREADONLY_on(kid->op_sv);
5651 sv_catpvn(kid->op_sv, ".pm", 3);
5655 /* handle override, if any */
5656 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
5657 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
5658 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
5660 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5661 OP *kid = cUNOPo->op_first;
5662 cUNOPo->op_first = 0;
5664 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5665 append_elem(OP_LIST, kid,
5666 scalar(newUNOP(OP_RV2CV, 0,
5675 Perl_ck_return(pTHX_ OP *o)
5678 if (CvLVALUE(PL_compcv)) {
5679 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5680 mod(kid, OP_LEAVESUBLV);
5687 Perl_ck_retarget(pTHX_ OP *o)
5689 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5696 Perl_ck_select(pTHX_ OP *o)
5699 if (o->op_flags & OPf_KIDS) {
5700 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5701 if (kid && kid->op_sibling) {
5702 o->op_type = OP_SSELECT;
5703 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
5705 return fold_constants(o);
5709 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5710 if (kid && kid->op_type == OP_RV2GV)
5711 kid->op_private &= ~HINT_STRICT_REFS;
5716 Perl_ck_shift(pTHX_ OP *o)
5718 I32 type = o->op_type;
5720 if (!(o->op_flags & OPf_KIDS)) {
5724 argop = newUNOP(OP_RV2AV, 0,
5725 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
5726 return newUNOP(type, 0, scalar(argop));
5728 return scalar(modkids(ck_fun(o), type));
5732 Perl_ck_sort(pTHX_ OP *o)
5736 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
5738 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5739 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
5741 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
5743 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
5745 if (kid->op_type == OP_SCOPE) {
5749 else if (kid->op_type == OP_LEAVE) {
5750 if (o->op_type == OP_SORT) {
5751 op_null(kid); /* wipe out leave */
5754 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
5755 if (k->op_next == kid)
5757 /* don't descend into loops */
5758 else if (k->op_type == OP_ENTERLOOP
5759 || k->op_type == OP_ENTERITER)
5761 k = cLOOPx(k)->op_lastop;
5766 kid->op_next = 0; /* just disconnect the leave */
5767 k = kLISTOP->op_first;
5772 if (o->op_type == OP_SORT) {
5773 /* provide scalar context for comparison function/block */
5779 o->op_flags |= OPf_SPECIAL;
5781 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
5784 firstkid = firstkid->op_sibling;
5787 /* provide list context for arguments */
5788 if (o->op_type == OP_SORT)
5795 S_simplify_sort(pTHX_ OP *o)
5797 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5801 if (!(o->op_flags & OPf_STACKED))
5803 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
5804 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
5805 kid = kUNOP->op_first; /* get past null */
5806 if (kid->op_type != OP_SCOPE)
5808 kid = kLISTOP->op_last; /* get past scope */
5809 switch(kid->op_type) {
5817 k = kid; /* remember this node*/
5818 if (kBINOP->op_first->op_type != OP_RV2SV)
5820 kid = kBINOP->op_first; /* get past cmp */
5821 if (kUNOP->op_first->op_type != OP_GV)
5823 kid = kUNOP->op_first; /* get past rv2sv */
5825 if (GvSTASH(gv) != PL_curstash)
5827 if (strEQ(GvNAME(gv), "a"))
5829 else if (strEQ(GvNAME(gv), "b"))
5833 kid = k; /* back to cmp */
5834 if (kBINOP->op_last->op_type != OP_RV2SV)
5836 kid = kBINOP->op_last; /* down to 2nd arg */
5837 if (kUNOP->op_first->op_type != OP_GV)
5839 kid = kUNOP->op_first; /* get past rv2sv */
5841 if (GvSTASH(gv) != PL_curstash
5843 ? strNE(GvNAME(gv), "a")
5844 : strNE(GvNAME(gv), "b")))
5846 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
5848 o->op_private |= OPpSORT_REVERSE;
5849 if (k->op_type == OP_NCMP)
5850 o->op_private |= OPpSORT_NUMERIC;
5851 if (k->op_type == OP_I_NCMP)
5852 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
5853 kid = cLISTOPo->op_first->op_sibling;
5854 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
5855 op_free(kid); /* then delete it */
5859 Perl_ck_split(pTHX_ OP *o)
5863 if (o->op_flags & OPf_STACKED)
5864 return no_fh_allowed(o);
5866 kid = cLISTOPo->op_first;
5867 if (kid->op_type != OP_NULL)
5868 Perl_croak(aTHX_ "panic: ck_split");
5869 kid = kid->op_sibling;
5870 op_free(cLISTOPo->op_first);
5871 cLISTOPo->op_first = kid;
5873 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
5874 cLISTOPo->op_last = kid; /* There was only one element previously */
5877 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
5878 OP *sibl = kid->op_sibling;
5879 kid->op_sibling = 0;
5880 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
5881 if (cLISTOPo->op_first == cLISTOPo->op_last)
5882 cLISTOPo->op_last = kid;
5883 cLISTOPo->op_first = kid;
5884 kid->op_sibling = sibl;
5887 kid->op_type = OP_PUSHRE;
5888 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
5890 if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
5891 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
5892 "Use of /g modifier is meaningless in split");
5895 if (!kid->op_sibling)
5896 append_elem(OP_SPLIT, o, newDEFSVOP());
5898 kid = kid->op_sibling;
5901 if (!kid->op_sibling)
5902 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
5904 kid = kid->op_sibling;
5907 if (kid->op_sibling)
5908 return too_many_arguments(o,OP_DESC(o));
5914 Perl_ck_join(pTHX_ OP *o)
5916 if (ckWARN(WARN_SYNTAX)) {
5917 OP *kid = cLISTOPo->op_first->op_sibling;
5918 if (kid && kid->op_type == OP_MATCH) {
5919 char *pmstr = "STRING";
5920 if (PM_GETRE(kPMOP))
5921 pmstr = PM_GETRE(kPMOP)->precomp;
5922 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5923 "/%s/ should probably be written as \"%s\"",
5931 Perl_ck_subr(pTHX_ OP *o)
5933 OP *prev = ((cUNOPo->op_first->op_sibling)
5934 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
5935 OP *o2 = prev->op_sibling;
5942 I32 contextclass = 0;
5947 o->op_private |= OPpENTERSUB_HASTARG;
5948 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
5949 if (cvop->op_type == OP_RV2CV) {
5951 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
5952 op_null(cvop); /* disable rv2cv */
5953 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
5954 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
5955 GV *gv = cGVOPx_gv(tmpop);
5958 tmpop->op_private |= OPpEARLY_CV;
5961 namegv = CvANON(cv) ? gv : CvGV(cv);
5962 proto = SvPV((SV*)cv, n_a);
5964 if (CvASSERTION(cv)) {
5965 if (PL_hints & HINT_ASSERTING) {
5966 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
5967 o->op_private |= OPpENTERSUB_DB;
5971 if (ckWARN(WARN_ASSERTIONS) && !(PL_hints & HINT_ASSERTIONSSEEN)) {
5972 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
5973 "Impossible to activate assertion call");
5980 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
5981 if (o2->op_type == OP_CONST)
5982 o2->op_private &= ~OPpCONST_STRICT;
5983 else if (o2->op_type == OP_LIST) {
5984 OP *o = ((UNOP*)o2)->op_first->op_sibling;
5985 if (o && o->op_type == OP_CONST)
5986 o->op_private &= ~OPpCONST_STRICT;
5989 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5990 if (PERLDB_SUB && PL_curstash != PL_debstash)
5991 o->op_private |= OPpENTERSUB_DB;
5992 while (o2 != cvop) {
5996 return too_many_arguments(o, gv_ename(namegv));
6014 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6016 arg == 1 ? "block or sub {}" : "sub {}",
6017 gv_ename(namegv), o2);
6020 /* '*' allows any scalar type, including bareword */
6023 if (o2->op_type == OP_RV2GV)
6024 goto wrapref; /* autoconvert GLOB -> GLOBref */
6025 else if (o2->op_type == OP_CONST)
6026 o2->op_private &= ~OPpCONST_STRICT;
6027 else if (o2->op_type == OP_ENTERSUB) {
6028 /* accidental subroutine, revert to bareword */
6029 OP *gvop = ((UNOP*)o2)->op_first;
6030 if (gvop && gvop->op_type == OP_NULL) {
6031 gvop = ((UNOP*)gvop)->op_first;
6033 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6036 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6037 (gvop = ((UNOP*)gvop)->op_first) &&
6038 gvop->op_type == OP_GV)
6040 GV *gv = cGVOPx_gv(gvop);
6041 OP *sibling = o2->op_sibling;
6042 SV *n = newSVpvn("",0);
6044 gv_fullname3(n, gv, "");
6045 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6046 sv_chop(n, SvPVX(n)+6);
6047 o2 = newSVOP(OP_CONST, 0, n);
6048 prev->op_sibling = o2;
6049 o2->op_sibling = sibling;
6065 if (contextclass++ == 0) {
6066 e = strchr(proto, ']');
6067 if (!e || e == proto)
6080 while (*--p != '[');
6081 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6082 gv_ename(namegv), o2);
6088 if (o2->op_type == OP_RV2GV)
6091 bad_type(arg, "symbol", gv_ename(namegv), o2);
6094 if (o2->op_type == OP_ENTERSUB)
6097 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6100 if (o2->op_type == OP_RV2SV ||
6101 o2->op_type == OP_PADSV ||
6102 o2->op_type == OP_HELEM ||
6103 o2->op_type == OP_AELEM ||
6104 o2->op_type == OP_THREADSV)
6107 bad_type(arg, "scalar", gv_ename(namegv), o2);
6110 if (o2->op_type == OP_RV2AV ||
6111 o2->op_type == OP_PADAV)
6114 bad_type(arg, "array", gv_ename(namegv), o2);
6117 if (o2->op_type == OP_RV2HV ||
6118 o2->op_type == OP_PADHV)
6121 bad_type(arg, "hash", gv_ename(namegv), o2);
6126 OP* sib = kid->op_sibling;
6127 kid->op_sibling = 0;
6128 o2 = newUNOP(OP_REFGEN, 0, kid);
6129 o2->op_sibling = sib;
6130 prev->op_sibling = o2;
6132 if (contextclass && e) {
6147 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6148 gv_ename(namegv), cv);
6153 mod(o2, OP_ENTERSUB);
6155 o2 = o2->op_sibling;
6157 if (proto && !optional &&
6158 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6159 return too_few_arguments(o, gv_ename(namegv));
6162 o=newSVOP(OP_CONST, 0, newSViv(0));
6168 Perl_ck_svconst(pTHX_ OP *o)
6170 SvREADONLY_on(cSVOPo->op_sv);
6175 Perl_ck_trunc(pTHX_ OP *o)
6177 if (o->op_flags & OPf_KIDS) {
6178 SVOP *kid = (SVOP*)cUNOPo->op_first;
6180 if (kid->op_type == OP_NULL)
6181 kid = (SVOP*)kid->op_sibling;
6182 if (kid && kid->op_type == OP_CONST &&
6183 (kid->op_private & OPpCONST_BARE))
6185 o->op_flags |= OPf_SPECIAL;
6186 kid->op_private &= ~OPpCONST_STRICT;
6193 Perl_ck_substr(pTHX_ OP *o)
6196 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6197 OP *kid = cLISTOPo->op_first;
6199 if (kid->op_type == OP_NULL)
6200 kid = kid->op_sibling;
6202 kid->op_flags |= OPf_MOD;
6208 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6211 Perl_peep(pTHX_ register OP *o)
6213 register OP* oldop = 0;
6215 if (!o || o->op_seq)
6219 SAVEVPTR(PL_curcop);
6220 for (; o; o = o->op_next) {
6223 /* The special value -1 is used by the B::C compiler backend to indicate
6224 * that an op is statically defined and should not be freed */
6225 if (!PL_op_seqmax || PL_op_seqmax == (U16)-1)
6228 switch (o->op_type) {
6232 PL_curcop = ((COP*)o); /* for warnings */
6233 o->op_seq = PL_op_seqmax++;
6237 if (cSVOPo->op_private & OPpCONST_STRICT)
6238 no_bareword_allowed(o);
6240 case OP_METHOD_NAMED:
6241 /* Relocate sv to the pad for thread safety.
6242 * Despite being a "constant", the SV is written to,
6243 * for reference counts, sv_upgrade() etc. */
6245 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6246 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6247 /* If op_sv is already a PADTMP then it is being used by
6248 * some pad, so make a copy. */
6249 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6250 SvREADONLY_on(PAD_SVl(ix));
6251 SvREFCNT_dec(cSVOPo->op_sv);
6254 SvREFCNT_dec(PAD_SVl(ix));
6255 SvPADTMP_on(cSVOPo->op_sv);
6256 PAD_SETSV(ix, cSVOPo->op_sv);
6257 /* XXX I don't know how this isn't readonly already. */
6258 SvREADONLY_on(PAD_SVl(ix));
6260 cSVOPo->op_sv = Nullsv;
6264 o->op_seq = PL_op_seqmax++;
6268 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6269 o->op_seq = PL_op_seqmax++;
6270 break; /* Scalar stub must produce undef. List stub is noop */
6274 if (o->op_targ == OP_NEXTSTATE
6275 || o->op_targ == OP_DBSTATE
6276 || o->op_targ == OP_SETSTATE)
6278 PL_curcop = ((COP*)o);
6280 /* XXX: We avoid setting op_seq here to prevent later calls
6281 to peep() from mistakenly concluding that optimisation
6282 has already occurred. This doesn't fix the real problem,
6283 though (See 20010220.007). AMS 20010719 */
6284 if (oldop && o->op_next) {
6285 oldop->op_next = o->op_next;
6293 if (oldop && o->op_next) {
6294 oldop->op_next = o->op_next;
6297 o->op_seq = PL_op_seqmax++;
6301 if (o->op_next->op_type == OP_RV2SV) {
6302 if (!(o->op_next->op_private & OPpDEREF)) {
6303 op_null(o->op_next);
6304 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6306 o->op_next = o->op_next->op_next;
6307 o->op_type = OP_GVSV;
6308 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6311 else if (o->op_next->op_type == OP_RV2AV) {
6312 OP* pop = o->op_next->op_next;
6314 if (pop && pop->op_type == OP_CONST &&
6315 (PL_op = pop->op_next) &&
6316 pop->op_next->op_type == OP_AELEM &&
6317 !(pop->op_next->op_private &
6318 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6319 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6324 op_null(o->op_next);
6325 op_null(pop->op_next);
6327 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6328 o->op_next = pop->op_next->op_next;
6329 o->op_type = OP_AELEMFAST;
6330 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6331 o->op_private = (U8)i;
6336 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6338 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6339 /* XXX could check prototype here instead of just carping */
6340 SV *sv = sv_newmortal();
6341 gv_efullname3(sv, gv, Nullch);
6342 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6343 "%"SVf"() called too early to check prototype",
6347 else if (o->op_next->op_type == OP_READLINE
6348 && o->op_next->op_next->op_type == OP_CONCAT
6349 && (o->op_next->op_next->op_flags & OPf_STACKED))
6351 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6352 o->op_type = OP_RCATLINE;
6353 o->op_flags |= OPf_STACKED;
6354 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6355 op_null(o->op_next->op_next);
6356 op_null(o->op_next);
6359 o->op_seq = PL_op_seqmax++;
6372 o->op_seq = PL_op_seqmax++;
6373 while (cLOGOP->op_other->op_type == OP_NULL)
6374 cLOGOP->op_other = cLOGOP->op_other->op_next;
6375 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6380 o->op_seq = PL_op_seqmax++;
6381 while (cLOOP->op_redoop->op_type == OP_NULL)
6382 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6383 peep(cLOOP->op_redoop);
6384 while (cLOOP->op_nextop->op_type == OP_NULL)
6385 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6386 peep(cLOOP->op_nextop);
6387 while (cLOOP->op_lastop->op_type == OP_NULL)
6388 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6389 peep(cLOOP->op_lastop);
6395 o->op_seq = PL_op_seqmax++;
6396 while (cPMOP->op_pmreplstart &&
6397 cPMOP->op_pmreplstart->op_type == OP_NULL)
6398 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6399 peep(cPMOP->op_pmreplstart);
6403 o->op_seq = PL_op_seqmax++;
6404 if (ckWARN(WARN_SYNTAX) && o->op_next
6405 && o->op_next->op_type == OP_NEXTSTATE) {
6406 if (o->op_next->op_sibling &&
6407 o->op_next->op_sibling->op_type != OP_EXIT &&
6408 o->op_next->op_sibling->op_type != OP_WARN &&
6409 o->op_next->op_sibling->op_type != OP_DIE) {
6410 line_t oldline = CopLINE(PL_curcop);
6412 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6413 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6414 "Statement unlikely to be reached");
6415 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6416 "\t(Maybe you meant system() when you said exec()?)\n");
6417 CopLINE_set(PL_curcop, oldline);
6428 o->op_seq = PL_op_seqmax++;
6430 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6433 /* Make the CONST have a shared SV */
6434 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6435 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6436 key = SvPV(sv, keylen);
6437 lexname = newSVpvn_share(key,
6438 SvUTF8(sv) ? -(I32)keylen : keylen,
6447 o->op_seq = PL_op_seqmax++;
6457 char* Perl_custom_op_name(pTHX_ OP* o)
6459 IV index = PTR2IV(o->op_ppaddr);
6463 if (!PL_custom_op_names) /* This probably shouldn't happen */
6464 return PL_op_name[OP_CUSTOM];
6466 keysv = sv_2mortal(newSViv(index));
6468 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
6470 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
6472 return SvPV_nolen(HeVAL(he));
6475 char* Perl_custom_op_desc(pTHX_ OP* o)
6477 IV index = PTR2IV(o->op_ppaddr);
6481 if (!PL_custom_op_descs)
6482 return PL_op_desc[OP_CUSTOM];
6484 keysv = sv_2mortal(newSViv(index));
6486 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
6488 return PL_op_desc[OP_CUSTOM];
6490 return SvPV_nolen(HeVAL(he));
6496 /* Efficient sub that returns a constant scalar value. */
6498 const_sv_xsub(pTHX_ CV* cv)
6503 Perl_croak(aTHX_ "usage: %s::%s()",
6504 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
6508 ST(0) = (SV*)XSANY.any_ptr;