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;
1829 PL_main_root = scope(sawparens(scalarvoid(o)));
1830 PL_curcop = &PL_compiling;
1831 PL_main_start = LINKLIST(PL_main_root);
1832 PL_main_root->op_private |= OPpREFCOUNTED;
1833 OpREFCNT_set(PL_main_root, 1);
1834 PL_main_root->op_next = 0;
1835 CALL_PEEP(PL_main_start);
1838 /* Register with debugger */
1840 CV *cv = get_cv("DB::postponed", FALSE);
1844 XPUSHs((SV*)CopFILEGV(&PL_compiling));
1846 call_sv((SV*)cv, G_DISCARD);
1853 Perl_localize(pTHX_ OP *o, I32 lex)
1855 if (o->op_flags & OPf_PARENS)
1856 /* [perl #17376]: this appears to be premature, and results in code such as
1857 C< our(%x); > executing in list mode rather than void mode */
1864 if (ckWARN(WARN_PARENTHESIS)
1865 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
1867 char *s = PL_bufptr;
1870 /* some heuristics to detect a potential error */
1871 while (*s && (strchr(", \t\n", *s)))
1875 if (*s && strchr("@$%*", *s) && *++s
1876 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
1879 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
1881 while (*s && (strchr(", \t\n", *s)))
1887 if (sigil && (*s == ';' || *s == '=')) {
1888 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
1889 "Parentheses missing around \"%s\" list",
1890 lex ? (PL_in_my == KEY_our ? "our" : "my")
1898 o = mod(o, OP_NULL); /* a bit kludgey */
1900 PL_in_my_stash = Nullhv;
1905 Perl_jmaybe(pTHX_ OP *o)
1907 if (o->op_type == OP_LIST) {
1909 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
1910 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
1916 Perl_fold_constants(pTHX_ register OP *o)
1919 I32 type = o->op_type;
1922 if (PL_opargs[type] & OA_RETSCALAR)
1924 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
1925 o->op_targ = pad_alloc(type, SVs_PADTMP);
1927 /* integerize op, unless it happens to be C<-foo>.
1928 * XXX should pp_i_negate() do magic string negation instead? */
1929 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
1930 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
1931 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
1933 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
1936 if (!(PL_opargs[type] & OA_FOLDCONST))
1941 /* XXX might want a ck_negate() for this */
1942 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
1954 /* XXX what about the numeric ops? */
1955 if (PL_hints & HINT_LOCALE)
1960 goto nope; /* Don't try to run w/ errors */
1962 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
1963 if ((curop->op_type != OP_CONST ||
1964 (curop->op_private & OPpCONST_BARE)) &&
1965 curop->op_type != OP_LIST &&
1966 curop->op_type != OP_SCALAR &&
1967 curop->op_type != OP_NULL &&
1968 curop->op_type != OP_PUSHMARK)
1974 curop = LINKLIST(o);
1978 sv = *(PL_stack_sp--);
1979 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
1980 pad_swipe(o->op_targ, FALSE);
1981 else if (SvTEMP(sv)) { /* grab mortal temp? */
1982 (void)SvREFCNT_inc(sv);
1986 if (type == OP_RV2GV)
1987 return newGVOP(OP_GV, 0, (GV*)sv);
1988 return newSVOP(OP_CONST, 0, sv);
1995 Perl_gen_constant_list(pTHX_ register OP *o)
1998 I32 oldtmps_floor = PL_tmps_floor;
2002 return o; /* Don't attempt to run with errors */
2004 PL_op = curop = LINKLIST(o);
2011 PL_tmps_floor = oldtmps_floor;
2013 o->op_type = OP_RV2AV;
2014 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2015 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2016 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2017 o->op_seq = 0; /* needs to be revisited in peep() */
2018 curop = ((UNOP*)o)->op_first;
2019 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2026 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2028 if (!o || o->op_type != OP_LIST)
2029 o = newLISTOP(OP_LIST, 0, o, Nullop);
2031 o->op_flags &= ~OPf_WANT;
2033 if (!(PL_opargs[type] & OA_MARK))
2034 op_null(cLISTOPo->op_first);
2036 o->op_type = (OPCODE)type;
2037 o->op_ppaddr = PL_ppaddr[type];
2038 o->op_flags |= flags;
2040 o = CHECKOP(type, o);
2041 if (o->op_type != type)
2044 return fold_constants(o);
2047 /* List constructors */
2050 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2058 if (first->op_type != type
2059 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2061 return newLISTOP(type, 0, first, last);
2064 if (first->op_flags & OPf_KIDS)
2065 ((LISTOP*)first)->op_last->op_sibling = last;
2067 first->op_flags |= OPf_KIDS;
2068 ((LISTOP*)first)->op_first = last;
2070 ((LISTOP*)first)->op_last = last;
2075 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2083 if (first->op_type != type)
2084 return prepend_elem(type, (OP*)first, (OP*)last);
2086 if (last->op_type != type)
2087 return append_elem(type, (OP*)first, (OP*)last);
2089 first->op_last->op_sibling = last->op_first;
2090 first->op_last = last->op_last;
2091 first->op_flags |= (last->op_flags & OPf_KIDS);
2099 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2107 if (last->op_type == type) {
2108 if (type == OP_LIST) { /* already a PUSHMARK there */
2109 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2110 ((LISTOP*)last)->op_first->op_sibling = first;
2111 if (!(first->op_flags & OPf_PARENS))
2112 last->op_flags &= ~OPf_PARENS;
2115 if (!(last->op_flags & OPf_KIDS)) {
2116 ((LISTOP*)last)->op_last = first;
2117 last->op_flags |= OPf_KIDS;
2119 first->op_sibling = ((LISTOP*)last)->op_first;
2120 ((LISTOP*)last)->op_first = first;
2122 last->op_flags |= OPf_KIDS;
2126 return newLISTOP(type, 0, first, last);
2132 Perl_newNULLLIST(pTHX)
2134 return newOP(OP_STUB, 0);
2138 Perl_force_list(pTHX_ OP *o)
2140 if (!o || o->op_type != OP_LIST)
2141 o = newLISTOP(OP_LIST, 0, o, Nullop);
2147 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2151 NewOp(1101, listop, 1, LISTOP);
2153 listop->op_type = (OPCODE)type;
2154 listop->op_ppaddr = PL_ppaddr[type];
2157 listop->op_flags = (U8)flags;
2161 else if (!first && last)
2164 first->op_sibling = last;
2165 listop->op_first = first;
2166 listop->op_last = last;
2167 if (type == OP_LIST) {
2169 pushop = newOP(OP_PUSHMARK, 0);
2170 pushop->op_sibling = first;
2171 listop->op_first = pushop;
2172 listop->op_flags |= OPf_KIDS;
2174 listop->op_last = pushop;
2177 return CHECKOP(type, listop);
2181 Perl_newOP(pTHX_ I32 type, I32 flags)
2184 NewOp(1101, o, 1, OP);
2185 o->op_type = (OPCODE)type;
2186 o->op_ppaddr = PL_ppaddr[type];
2187 o->op_flags = (U8)flags;
2190 o->op_private = (U8)(0 | (flags >> 8));
2191 if (PL_opargs[type] & OA_RETSCALAR)
2193 if (PL_opargs[type] & OA_TARGET)
2194 o->op_targ = pad_alloc(type, SVs_PADTMP);
2195 return CHECKOP(type, o);
2199 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2204 first = newOP(OP_STUB, 0);
2205 if (PL_opargs[type] & OA_MARK)
2206 first = force_list(first);
2208 NewOp(1101, unop, 1, UNOP);
2209 unop->op_type = (OPCODE)type;
2210 unop->op_ppaddr = PL_ppaddr[type];
2211 unop->op_first = first;
2212 unop->op_flags = flags | OPf_KIDS;
2213 unop->op_private = (U8)(1 | (flags >> 8));
2214 unop = (UNOP*) CHECKOP(type, unop);
2218 return fold_constants((OP *) unop);
2222 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2225 NewOp(1101, binop, 1, BINOP);
2228 first = newOP(OP_NULL, 0);
2230 binop->op_type = (OPCODE)type;
2231 binop->op_ppaddr = PL_ppaddr[type];
2232 binop->op_first = first;
2233 binop->op_flags = flags | OPf_KIDS;
2236 binop->op_private = (U8)(1 | (flags >> 8));
2239 binop->op_private = (U8)(2 | (flags >> 8));
2240 first->op_sibling = last;
2243 binop = (BINOP*)CHECKOP(type, binop);
2244 if (binop->op_next || binop->op_type != (OPCODE)type)
2247 binop->op_last = binop->op_first->op_sibling;
2249 return fold_constants((OP *)binop);
2253 uvcompare(const void *a, const void *b)
2255 if (*((UV *)a) < (*(UV *)b))
2257 if (*((UV *)a) > (*(UV *)b))
2259 if (*((UV *)a+1) < (*(UV *)b+1))
2261 if (*((UV *)a+1) > (*(UV *)b+1))
2267 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2269 SV *tstr = ((SVOP*)expr)->op_sv;
2270 SV *rstr = ((SVOP*)repl)->op_sv;
2273 U8 *t = (U8*)SvPV(tstr, tlen);
2274 U8 *r = (U8*)SvPV(rstr, rlen);
2281 register short *tbl;
2283 PL_hints |= HINT_BLOCK_SCOPE;
2284 complement = o->op_private & OPpTRANS_COMPLEMENT;
2285 del = o->op_private & OPpTRANS_DELETE;
2286 squash = o->op_private & OPpTRANS_SQUASH;
2289 o->op_private |= OPpTRANS_FROM_UTF;
2292 o->op_private |= OPpTRANS_TO_UTF;
2294 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2295 SV* listsv = newSVpvn("# comment\n",10);
2297 U8* tend = t + tlen;
2298 U8* rend = r + rlen;
2312 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2313 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2319 tsave = t = bytes_to_utf8(t, &len);
2322 if (!to_utf && rlen) {
2324 rsave = r = bytes_to_utf8(r, &len);
2328 /* There are several snags with this code on EBCDIC:
2329 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2330 2. scan_const() in toke.c has encoded chars in native encoding which makes
2331 ranges at least in EBCDIC 0..255 range the bottom odd.
2335 U8 tmpbuf[UTF8_MAXLEN+1];
2338 New(1109, cp, 2*tlen, UV);
2340 transv = newSVpvn("",0);
2342 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2344 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2346 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2350 cp[2*i+1] = cp[2*i];
2354 qsort(cp, i, 2*sizeof(UV), uvcompare);
2355 for (j = 0; j < i; j++) {
2357 diff = val - nextmin;
2359 t = uvuni_to_utf8(tmpbuf,nextmin);
2360 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2362 U8 range_mark = UTF_TO_NATIVE(0xff);
2363 t = uvuni_to_utf8(tmpbuf, val - 1);
2364 sv_catpvn(transv, (char *)&range_mark, 1);
2365 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2372 t = uvuni_to_utf8(tmpbuf,nextmin);
2373 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2375 U8 range_mark = UTF_TO_NATIVE(0xff);
2376 sv_catpvn(transv, (char *)&range_mark, 1);
2378 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2379 UNICODE_ALLOW_SUPER);
2380 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2381 t = (U8*)SvPVX(transv);
2382 tlen = SvCUR(transv);
2386 else if (!rlen && !del) {
2387 r = t; rlen = tlen; rend = tend;
2390 if ((!rlen && !del) || t == r ||
2391 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2393 o->op_private |= OPpTRANS_IDENTICAL;
2397 while (t < tend || tfirst <= tlast) {
2398 /* see if we need more "t" chars */
2399 if (tfirst > tlast) {
2400 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2402 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2404 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2411 /* now see if we need more "r" chars */
2412 if (rfirst > rlast) {
2414 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2416 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2418 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2427 rfirst = rlast = 0xffffffff;
2431 /* now see which range will peter our first, if either. */
2432 tdiff = tlast - tfirst;
2433 rdiff = rlast - rfirst;
2440 if (rfirst == 0xffffffff) {
2441 diff = tdiff; /* oops, pretend rdiff is infinite */
2443 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2444 (long)tfirst, (long)tlast);
2446 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2450 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2451 (long)tfirst, (long)(tfirst + diff),
2454 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2455 (long)tfirst, (long)rfirst);
2457 if (rfirst + diff > max)
2458 max = rfirst + diff;
2460 grows = (tfirst < rfirst &&
2461 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2473 else if (max > 0xff)
2478 Safefree(cPVOPo->op_pv);
2479 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2480 SvREFCNT_dec(listsv);
2482 SvREFCNT_dec(transv);
2484 if (!del && havefinal && rlen)
2485 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2486 newSVuv((UV)final), 0);
2489 o->op_private |= OPpTRANS_GROWS;
2501 tbl = (short*)cPVOPo->op_pv;
2503 Zero(tbl, 256, short);
2504 for (i = 0; i < (I32)tlen; i++)
2506 for (i = 0, j = 0; i < 256; i++) {
2508 if (j >= (I32)rlen) {
2517 if (i < 128 && r[j] >= 128)
2527 o->op_private |= OPpTRANS_IDENTICAL;
2529 else if (j >= (I32)rlen)
2532 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2533 tbl[0x100] = rlen - j;
2534 for (i=0; i < (I32)rlen - j; i++)
2535 tbl[0x101+i] = r[j+i];
2539 if (!rlen && !del) {
2542 o->op_private |= OPpTRANS_IDENTICAL;
2544 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2545 o->op_private |= OPpTRANS_IDENTICAL;
2547 for (i = 0; i < 256; i++)
2549 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
2550 if (j >= (I32)rlen) {
2552 if (tbl[t[i]] == -1)
2558 if (tbl[t[i]] == -1) {
2559 if (t[i] < 128 && r[j] >= 128)
2566 o->op_private |= OPpTRANS_GROWS;
2574 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2578 NewOp(1101, pmop, 1, PMOP);
2579 pmop->op_type = (OPCODE)type;
2580 pmop->op_ppaddr = PL_ppaddr[type];
2581 pmop->op_flags = (U8)flags;
2582 pmop->op_private = (U8)(0 | (flags >> 8));
2584 if (PL_hints & HINT_RE_TAINT)
2585 pmop->op_pmpermflags |= PMf_RETAINT;
2586 if (PL_hints & HINT_LOCALE)
2587 pmop->op_pmpermflags |= PMf_LOCALE;
2588 pmop->op_pmflags = pmop->op_pmpermflags;
2593 if(av_len((AV*) PL_regex_pad[0]) > -1) {
2594 repointer = av_pop((AV*)PL_regex_pad[0]);
2595 pmop->op_pmoffset = SvIV(repointer);
2596 SvREPADTMP_off(repointer);
2597 sv_setiv(repointer,0);
2599 repointer = newSViv(0);
2600 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2601 pmop->op_pmoffset = av_len(PL_regex_padav);
2602 PL_regex_pad = AvARRAY(PL_regex_padav);
2607 /* link into pm list */
2608 if (type != OP_TRANS && PL_curstash) {
2609 pmop->op_pmnext = HvPMROOT(PL_curstash);
2610 HvPMROOT(PL_curstash) = pmop;
2611 PmopSTASH_set(pmop,PL_curstash);
2614 return CHECKOP(type, pmop);
2618 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
2622 I32 repl_has_vars = 0;
2624 if (o->op_type == OP_TRANS)
2625 return pmtrans(o, expr, repl);
2627 PL_hints |= HINT_BLOCK_SCOPE;
2630 if (expr->op_type == OP_CONST) {
2632 SV *pat = ((SVOP*)expr)->op_sv;
2633 char *p = SvPV(pat, plen);
2634 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
2635 sv_setpvn(pat, "\\s+", 3);
2636 p = SvPV(pat, plen);
2637 pm->op_pmflags |= PMf_SKIPWHITE;
2640 pm->op_pmdynflags |= PMdf_UTF8;
2641 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
2642 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
2643 pm->op_pmflags |= PMf_WHITE;
2647 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2648 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2650 : OP_REGCMAYBE),0,expr);
2652 NewOp(1101, rcop, 1, LOGOP);
2653 rcop->op_type = OP_REGCOMP;
2654 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2655 rcop->op_first = scalar(expr);
2656 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
2657 ? (OPf_SPECIAL | OPf_KIDS)
2659 rcop->op_private = 1;
2661 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
2664 /* establish postfix order */
2665 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2667 rcop->op_next = expr;
2668 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2671 rcop->op_next = LINKLIST(expr);
2672 expr->op_next = (OP*)rcop;
2675 prepend_elem(o->op_type, scalar((OP*)rcop), o);
2680 if (pm->op_pmflags & PMf_EVAL) {
2682 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
2683 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
2685 else if (repl->op_type == OP_CONST)
2689 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
2690 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
2691 if (curop->op_type == OP_GV) {
2692 GV *gv = cGVOPx_gv(curop);
2694 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
2697 else if (curop->op_type == OP_RV2CV)
2699 else if (curop->op_type == OP_RV2SV ||
2700 curop->op_type == OP_RV2AV ||
2701 curop->op_type == OP_RV2HV ||
2702 curop->op_type == OP_RV2GV) {
2703 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2706 else if (curop->op_type == OP_PADSV ||
2707 curop->op_type == OP_PADAV ||
2708 curop->op_type == OP_PADHV ||
2709 curop->op_type == OP_PADANY) {
2712 else if (curop->op_type == OP_PUSHRE)
2713 ; /* Okay here, dangerous in newASSIGNOP */
2723 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
2724 pm->op_pmflags |= PMf_CONST; /* const for long enough */
2725 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
2726 prepend_elem(o->op_type, scalar(repl), o);
2729 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
2730 pm->op_pmflags |= PMf_MAYBE_CONST;
2731 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2733 NewOp(1101, rcop, 1, LOGOP);
2734 rcop->op_type = OP_SUBSTCONT;
2735 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
2736 rcop->op_first = scalar(repl);
2737 rcop->op_flags |= OPf_KIDS;
2738 rcop->op_private = 1;
2741 /* establish postfix order */
2742 rcop->op_next = LINKLIST(repl);
2743 repl->op_next = (OP*)rcop;
2745 pm->op_pmreplroot = scalar((OP*)rcop);
2746 pm->op_pmreplstart = LINKLIST(rcop);
2755 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
2758 NewOp(1101, svop, 1, SVOP);
2759 svop->op_type = (OPCODE)type;
2760 svop->op_ppaddr = PL_ppaddr[type];
2762 svop->op_next = (OP*)svop;
2763 svop->op_flags = (U8)flags;
2764 if (PL_opargs[type] & OA_RETSCALAR)
2766 if (PL_opargs[type] & OA_TARGET)
2767 svop->op_targ = pad_alloc(type, SVs_PADTMP);
2768 return CHECKOP(type, svop);
2772 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2775 NewOp(1101, padop, 1, PADOP);
2776 padop->op_type = (OPCODE)type;
2777 padop->op_ppaddr = PL_ppaddr[type];
2778 padop->op_padix = pad_alloc(type, SVs_PADTMP);
2779 SvREFCNT_dec(PAD_SVl(padop->op_padix));
2780 PAD_SETSV(padop->op_padix, sv);
2783 padop->op_next = (OP*)padop;
2784 padop->op_flags = (U8)flags;
2785 if (PL_opargs[type] & OA_RETSCALAR)
2787 if (PL_opargs[type] & OA_TARGET)
2788 padop->op_targ = pad_alloc(type, SVs_PADTMP);
2789 return CHECKOP(type, padop);
2793 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
2798 return newPADOP(type, flags, SvREFCNT_inc(gv));
2800 return newSVOP(type, flags, SvREFCNT_inc(gv));
2805 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
2808 NewOp(1101, pvop, 1, PVOP);
2809 pvop->op_type = (OPCODE)type;
2810 pvop->op_ppaddr = PL_ppaddr[type];
2812 pvop->op_next = (OP*)pvop;
2813 pvop->op_flags = (U8)flags;
2814 if (PL_opargs[type] & OA_RETSCALAR)
2816 if (PL_opargs[type] & OA_TARGET)
2817 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
2818 return CHECKOP(type, pvop);
2822 Perl_package(pTHX_ OP *o)
2827 save_hptr(&PL_curstash);
2828 save_item(PL_curstname);
2830 name = SvPV(cSVOPo->op_sv, len);
2831 PL_curstash = gv_stashpvn(name, len, TRUE);
2832 sv_setpvn(PL_curstname, name, len);
2835 PL_hints |= HINT_BLOCK_SCOPE;
2836 PL_copline = NOLINE;
2841 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
2847 if (idop->op_type != OP_CONST)
2848 Perl_croak(aTHX_ "Module name must be constant");
2852 if (version != Nullop) {
2853 SV *vesv = ((SVOP*)version)->op_sv;
2855 if (arg == Nullop && !SvNIOKp(vesv)) {
2862 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
2863 Perl_croak(aTHX_ "Version number must be constant number");
2865 /* Make copy of idop so we don't free it twice */
2866 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
2868 /* Fake up a method call to VERSION */
2869 meth = newSVpvn("VERSION",7);
2870 sv_upgrade(meth, SVt_PVIV);
2871 (void)SvIOK_on(meth);
2872 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
2873 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2874 append_elem(OP_LIST,
2875 prepend_elem(OP_LIST, pack, list(version)),
2876 newSVOP(OP_METHOD_NAMED, 0, meth)));
2880 /* Fake up an import/unimport */
2881 if (arg && arg->op_type == OP_STUB)
2882 imop = arg; /* no import on explicit () */
2883 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
2884 imop = Nullop; /* use 5.0; */
2889 /* Make copy of idop so we don't free it twice */
2890 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
2892 /* Fake up a method call to import/unimport */
2893 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);
2894 (void)SvUPGRADE(meth, SVt_PVIV);
2895 (void)SvIOK_on(meth);
2896 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
2897 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2898 append_elem(OP_LIST,
2899 prepend_elem(OP_LIST, pack, list(arg)),
2900 newSVOP(OP_METHOD_NAMED, 0, meth)));
2903 /* Fake up the BEGIN {}, which does its thing immediately. */
2905 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
2908 append_elem(OP_LINESEQ,
2909 append_elem(OP_LINESEQ,
2910 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, idop)),
2911 newSTATEOP(0, Nullch, veop)),
2912 newSTATEOP(0, Nullch, imop) ));
2914 /* The "did you use incorrect case?" warning used to be here.
2915 * The problem is that on case-insensitive filesystems one
2916 * might get false positives for "use" (and "require"):
2917 * "use Strict" or "require CARP" will work. This causes
2918 * portability problems for the script: in case-strict
2919 * filesystems the script will stop working.
2921 * The "incorrect case" warning checked whether "use Foo"
2922 * imported "Foo" to your namespace, but that is wrong, too:
2923 * there is no requirement nor promise in the language that
2924 * a Foo.pm should or would contain anything in package "Foo".
2926 * There is very little Configure-wise that can be done, either:
2927 * the case-sensitivity of the build filesystem of Perl does not
2928 * help in guessing the case-sensitivity of the runtime environment.
2931 PL_hints |= HINT_BLOCK_SCOPE;
2932 PL_copline = NOLINE;
2934 PL_cop_seqmax++; /* Purely for B::*'s benefit */
2938 =head1 Embedding Functions
2940 =for apidoc load_module
2942 Loads the module whose name is pointed to by the string part of name.
2943 Note that the actual module name, not its filename, should be given.
2944 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
2945 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
2946 (or 0 for no flags). ver, if specified, provides version semantics
2947 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
2948 arguments can be used to specify arguments to the module's import()
2949 method, similar to C<use Foo::Bar VERSION LIST>.
2954 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
2957 va_start(args, ver);
2958 vload_module(flags, name, ver, &args);
2962 #ifdef PERL_IMPLICIT_CONTEXT
2964 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
2968 va_start(args, ver);
2969 vload_module(flags, name, ver, &args);
2975 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
2977 OP *modname, *veop, *imop;
2979 modname = newSVOP(OP_CONST, 0, name);
2980 modname->op_private |= OPpCONST_BARE;
2982 veop = newSVOP(OP_CONST, 0, ver);
2986 if (flags & PERL_LOADMOD_NOIMPORT) {
2987 imop = sawparens(newNULLLIST());
2989 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
2990 imop = va_arg(*args, OP*);
2995 sv = va_arg(*args, SV*);
2997 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
2998 sv = va_arg(*args, SV*);
3002 line_t ocopline = PL_copline;
3003 COP *ocurcop = PL_curcop;
3004 int oexpect = PL_expect;
3006 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3007 veop, modname, imop);
3008 PL_expect = oexpect;
3009 PL_copline = ocopline;
3010 PL_curcop = ocurcop;
3015 Perl_dofile(pTHX_ OP *term)
3020 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3021 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
3022 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3024 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3025 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3026 append_elem(OP_LIST, term,
3027 scalar(newUNOP(OP_RV2CV, 0,
3032 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3038 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3040 return newBINOP(OP_LSLICE, flags,
3041 list(force_list(subscript)),
3042 list(force_list(listval)) );
3046 S_list_assignment(pTHX_ register OP *o)
3051 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3052 o = cUNOPo->op_first;
3054 if (o->op_type == OP_COND_EXPR) {
3055 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3056 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3061 yyerror("Assignment to both a list and a scalar");
3065 if (o->op_type == OP_LIST &&
3066 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3067 o->op_private & OPpLVAL_INTRO)
3070 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3071 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3072 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3075 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3078 if (o->op_type == OP_RV2SV)
3085 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3090 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3091 return newLOGOP(optype, 0,
3092 mod(scalar(left), optype),
3093 newUNOP(OP_SASSIGN, 0, scalar(right)));
3096 return newBINOP(optype, OPf_STACKED,
3097 mod(scalar(left), optype), scalar(right));
3101 if (list_assignment(left)) {
3105 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3106 left = mod(left, OP_AASSIGN);
3114 curop = list(force_list(left));
3115 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3116 o->op_private = (U8)(0 | (flags >> 8));
3118 /* PL_generation sorcery:
3119 * an assignment like ($a,$b) = ($c,$d) is easier than
3120 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3121 * To detect whether there are common vars, the global var
3122 * PL_generation is incremented for each assign op we compile.
3123 * Then, while compiling the assign op, we run through all the
3124 * variables on both sides of the assignment, setting a spare slot
3125 * in each of them to PL_generation. If any of them already have
3126 * that value, we know we've got commonality. We could use a
3127 * single bit marker, but then we'd have to make 2 passes, first
3128 * to clear the flag, then to test and set it. To find somewhere
3129 * to store these values, evil chicanery is done with SvCUR().
3132 if (!(left->op_private & OPpLVAL_INTRO)) {
3135 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3136 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3137 if (curop->op_type == OP_GV) {
3138 GV *gv = cGVOPx_gv(curop);
3139 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3141 SvCUR(gv) = PL_generation;
3143 else if (curop->op_type == OP_PADSV ||
3144 curop->op_type == OP_PADAV ||
3145 curop->op_type == OP_PADHV ||
3146 curop->op_type == OP_PADANY)
3148 if (PAD_COMPNAME_GEN(curop->op_targ)
3149 == (STRLEN)PL_generation)
3151 PAD_COMPNAME_GEN(curop->op_targ)
3155 else if (curop->op_type == OP_RV2CV)
3157 else if (curop->op_type == OP_RV2SV ||
3158 curop->op_type == OP_RV2AV ||
3159 curop->op_type == OP_RV2HV ||
3160 curop->op_type == OP_RV2GV) {
3161 if (lastop->op_type != OP_GV) /* funny deref? */
3164 else if (curop->op_type == OP_PUSHRE) {
3165 if (((PMOP*)curop)->op_pmreplroot) {
3167 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3168 ((PMOP*)curop)->op_pmreplroot));
3170 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3172 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3174 SvCUR(gv) = PL_generation;
3183 o->op_private |= OPpASSIGN_COMMON;
3185 if (right && right->op_type == OP_SPLIT) {
3187 if ((tmpop = ((LISTOP*)right)->op_first) &&
3188 tmpop->op_type == OP_PUSHRE)
3190 PMOP *pm = (PMOP*)tmpop;
3191 if (left->op_type == OP_RV2AV &&
3192 !(left->op_private & OPpLVAL_INTRO) &&
3193 !(o->op_private & OPpASSIGN_COMMON) )
3195 tmpop = ((UNOP*)left)->op_first;
3196 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3198 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3199 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3201 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3202 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3204 pm->op_pmflags |= PMf_ONCE;
3205 tmpop = cUNOPo->op_first; /* to list (nulled) */
3206 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3207 tmpop->op_sibling = Nullop; /* don't free split */
3208 right->op_next = tmpop->op_next; /* fix starting loc */
3209 op_free(o); /* blow off assign */
3210 right->op_flags &= ~OPf_WANT;
3211 /* "I don't know and I don't care." */
3216 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3217 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3219 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3221 sv_setiv(sv, PL_modcount+1);
3229 right = newOP(OP_UNDEF, 0);
3230 if (right->op_type == OP_READLINE) {
3231 right->op_flags |= OPf_STACKED;
3232 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3235 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3236 o = newBINOP(OP_SASSIGN, flags,
3237 scalar(right), mod(scalar(left), OP_SASSIGN) );
3249 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3251 U32 seq = intro_my();
3254 NewOp(1101, cop, 1, COP);
3255 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3256 cop->op_type = OP_DBSTATE;
3257 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3260 cop->op_type = OP_NEXTSTATE;
3261 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3263 cop->op_flags = (U8)flags;
3264 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3266 cop->op_private |= NATIVE_HINTS;
3268 PL_compiling.op_private = cop->op_private;
3269 cop->op_next = (OP*)cop;
3272 cop->cop_label = label;
3273 PL_hints |= HINT_BLOCK_SCOPE;
3276 cop->cop_arybase = PL_curcop->cop_arybase;
3277 if (specialWARN(PL_curcop->cop_warnings))
3278 cop->cop_warnings = PL_curcop->cop_warnings ;
3280 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3281 if (specialCopIO(PL_curcop->cop_io))
3282 cop->cop_io = PL_curcop->cop_io;
3284 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3287 if (PL_copline == NOLINE)
3288 CopLINE_set(cop, CopLINE(PL_curcop));
3290 CopLINE_set(cop, PL_copline);
3291 PL_copline = NOLINE;
3294 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3296 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3298 CopSTASH_set(cop, PL_curstash);
3300 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3301 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3302 if (svp && *svp != &PL_sv_undef ) {
3303 (void)SvIOK_on(*svp);
3304 SvIVX(*svp) = PTR2IV(cop);
3308 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3313 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3315 return new_logop(type, flags, &first, &other);
3319 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3323 OP *first = *firstp;
3324 OP *other = *otherp;
3326 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3327 return newBINOP(type, flags, scalar(first), scalar(other));
3329 scalarboolean(first);
3330 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3331 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3332 if (type == OP_AND || type == OP_OR) {
3338 first = *firstp = cUNOPo->op_first;
3340 first->op_next = o->op_next;
3341 cUNOPo->op_first = Nullop;
3345 if (first->op_type == OP_CONST) {
3346 if (first->op_private & OPpCONST_STRICT)
3347 no_bareword_allowed(first);
3348 else if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3349 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3350 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3361 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS) &&
3362 type != OP_DOR) /* [#24076] Don't warn for <FH> err FOO. */
3364 OP *k1 = ((UNOP*)first)->op_first;
3365 OP *k2 = k1->op_sibling;
3367 switch (first->op_type)
3370 if (k2 && k2->op_type == OP_READLINE
3371 && (k2->op_flags & OPf_STACKED)
3372 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3374 warnop = k2->op_type;
3379 if (k1->op_type == OP_READDIR
3380 || k1->op_type == OP_GLOB
3381 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3382 || k1->op_type == OP_EACH)
3384 warnop = ((k1->op_type == OP_NULL)
3385 ? (OPCODE)k1->op_targ : k1->op_type);
3390 line_t oldline = CopLINE(PL_curcop);
3391 CopLINE_set(PL_curcop, PL_copline);
3392 Perl_warner(aTHX_ packWARN(WARN_MISC),
3393 "Value of %s%s can be \"0\"; test with defined()",
3395 ((warnop == OP_READLINE || warnop == OP_GLOB)
3396 ? " construct" : "() operator"));
3397 CopLINE_set(PL_curcop, oldline);
3404 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3405 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3407 NewOp(1101, logop, 1, LOGOP);
3409 logop->op_type = (OPCODE)type;
3410 logop->op_ppaddr = PL_ppaddr[type];
3411 logop->op_first = first;
3412 logop->op_flags = flags | OPf_KIDS;
3413 logop->op_other = LINKLIST(other);
3414 logop->op_private = (U8)(1 | (flags >> 8));
3416 /* establish postfix order */
3417 logop->op_next = LINKLIST(first);
3418 first->op_next = (OP*)logop;
3419 first->op_sibling = other;
3421 CHECKOP(type,logop);
3423 o = newUNOP(OP_NULL, 0, (OP*)logop);
3430 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3437 return newLOGOP(OP_AND, 0, first, trueop);
3439 return newLOGOP(OP_OR, 0, first, falseop);
3441 scalarboolean(first);
3442 if (first->op_type == OP_CONST) {
3443 if (first->op_private & OPpCONST_BARE &&
3444 first->op_private & OPpCONST_STRICT) {
3445 no_bareword_allowed(first);
3447 if (SvTRUE(((SVOP*)first)->op_sv)) {
3458 NewOp(1101, logop, 1, LOGOP);
3459 logop->op_type = OP_COND_EXPR;
3460 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3461 logop->op_first = first;
3462 logop->op_flags = flags | OPf_KIDS;
3463 logop->op_private = (U8)(1 | (flags >> 8));
3464 logop->op_other = LINKLIST(trueop);
3465 logop->op_next = LINKLIST(falseop);
3467 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
3470 /* establish postfix order */
3471 start = LINKLIST(first);
3472 first->op_next = (OP*)logop;
3474 first->op_sibling = trueop;
3475 trueop->op_sibling = falseop;
3476 o = newUNOP(OP_NULL, 0, (OP*)logop);
3478 trueop->op_next = falseop->op_next = o;
3485 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3493 NewOp(1101, range, 1, LOGOP);
3495 range->op_type = OP_RANGE;
3496 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3497 range->op_first = left;
3498 range->op_flags = OPf_KIDS;
3499 leftstart = LINKLIST(left);
3500 range->op_other = LINKLIST(right);
3501 range->op_private = (U8)(1 | (flags >> 8));
3503 left->op_sibling = right;
3505 range->op_next = (OP*)range;
3506 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3507 flop = newUNOP(OP_FLOP, 0, flip);
3508 o = newUNOP(OP_NULL, 0, flop);
3510 range->op_next = leftstart;
3512 left->op_next = flip;
3513 right->op_next = flop;
3515 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3516 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3517 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3518 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3520 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3521 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3524 if (!flip->op_private || !flop->op_private)
3525 linklist(o); /* blow off optimizer unless constant */
3531 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3535 int once = block && block->op_flags & OPf_SPECIAL &&
3536 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3539 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3540 return block; /* do {} while 0 does once */
3541 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3542 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3543 expr = newUNOP(OP_DEFINED, 0,
3544 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3545 } else if (expr->op_flags & OPf_KIDS) {
3546 OP *k1 = ((UNOP*)expr)->op_first;
3547 OP *k2 = (k1) ? k1->op_sibling : NULL;
3548 switch (expr->op_type) {
3550 if (k2 && k2->op_type == OP_READLINE
3551 && (k2->op_flags & OPf_STACKED)
3552 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3553 expr = newUNOP(OP_DEFINED, 0, expr);
3557 if (k1->op_type == OP_READDIR
3558 || k1->op_type == OP_GLOB
3559 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3560 || k1->op_type == OP_EACH)
3561 expr = newUNOP(OP_DEFINED, 0, expr);
3567 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3568 o = new_logop(OP_AND, 0, &expr, &listop);
3571 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3573 if (once && o != listop)
3574 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3577 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3579 o->op_flags |= flags;
3581 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3586 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3594 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3595 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3596 expr = newUNOP(OP_DEFINED, 0,
3597 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3598 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3599 OP *k1 = ((UNOP*)expr)->op_first;
3600 OP *k2 = (k1) ? k1->op_sibling : NULL;
3601 switch (expr->op_type) {
3603 if (k2 && k2->op_type == OP_READLINE
3604 && (k2->op_flags & OPf_STACKED)
3605 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3606 expr = newUNOP(OP_DEFINED, 0, expr);
3610 if (k1->op_type == OP_READDIR
3611 || k1->op_type == OP_GLOB
3612 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3613 || k1->op_type == OP_EACH)
3614 expr = newUNOP(OP_DEFINED, 0, expr);
3620 block = newOP(OP_NULL, 0);
3622 block = scope(block);
3626 next = LINKLIST(cont);
3629 OP *unstack = newOP(OP_UNSTACK, 0);
3632 cont = append_elem(OP_LINESEQ, cont, unstack);
3635 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3636 redo = LINKLIST(listop);
3639 PL_copline = (line_t)whileline;
3641 o = new_logop(OP_AND, 0, &expr, &listop);
3642 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3643 op_free(expr); /* oops, it's a while (0) */
3645 return Nullop; /* listop already freed by new_logop */
3648 ((LISTOP*)listop)->op_last->op_next =
3649 (o == listop ? redo : LINKLIST(o));
3655 NewOp(1101,loop,1,LOOP);
3656 loop->op_type = OP_ENTERLOOP;
3657 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3658 loop->op_private = 0;
3659 loop->op_next = (OP*)loop;
3662 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3664 loop->op_redoop = redo;
3665 loop->op_lastop = o;
3666 o->op_private |= loopflags;
3669 loop->op_nextop = next;
3671 loop->op_nextop = o;
3673 o->op_flags |= flags;
3674 o->op_private |= (flags >> 8);
3679 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
3683 PADOFFSET padoff = 0;
3688 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
3689 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
3690 sv->op_type = OP_RV2GV;
3691 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3693 else if (sv->op_type == OP_PADSV) { /* private variable */
3694 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
3695 padoff = sv->op_targ;
3700 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3701 padoff = sv->op_targ;
3703 iterflags |= OPf_SPECIAL;
3708 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3711 sv = newGVOP(OP_GV, 0, PL_defgv);
3713 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3714 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3715 iterflags |= OPf_STACKED;
3717 else if (expr->op_type == OP_NULL &&
3718 (expr->op_flags & OPf_KIDS) &&
3719 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3721 /* Basically turn for($x..$y) into the same as for($x,$y), but we
3722 * set the STACKED flag to indicate that these values are to be
3723 * treated as min/max values by 'pp_iterinit'.
3725 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
3726 LOGOP* range = (LOGOP*) flip->op_first;
3727 OP* left = range->op_first;
3728 OP* right = left->op_sibling;
3731 range->op_flags &= ~OPf_KIDS;
3732 range->op_first = Nullop;
3734 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
3735 listop->op_first->op_next = range->op_next;
3736 left->op_next = range->op_other;
3737 right->op_next = (OP*)listop;
3738 listop->op_next = listop->op_first;
3741 expr = (OP*)(listop);
3743 iterflags |= OPf_STACKED;
3746 expr = mod(force_list(expr), OP_GREPSTART);
3750 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
3751 append_elem(OP_LIST, expr, scalar(sv))));
3752 assert(!loop->op_next);
3753 /* for my $x () sets OPpLVAL_INTRO;
3754 * for our $x () sets OPpOUR_INTRO */
3755 loop->op_private = (U8)iterpflags;
3756 #ifdef PL_OP_SLAB_ALLOC
3759 NewOp(1234,tmp,1,LOOP);
3760 Copy(loop,tmp,1,LOOP);
3765 Renew(loop, 1, LOOP);
3767 loop->op_targ = padoff;
3768 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
3769 PL_copline = forline;
3770 return newSTATEOP(0, label, wop);
3774 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
3779 if (type != OP_GOTO || label->op_type == OP_CONST) {
3780 /* "last()" means "last" */
3781 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
3782 o = newOP(type, OPf_SPECIAL);
3784 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
3785 ? SvPVx(((SVOP*)label)->op_sv, n_a)
3791 /* Check whether it's going to be a goto &function */
3792 if (label->op_type == OP_ENTERSUB
3793 && !(label->op_flags & OPf_STACKED))
3794 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
3795 o = newUNOP(type, OPf_STACKED, label);
3797 PL_hints |= HINT_BLOCK_SCOPE;
3802 =for apidoc cv_undef
3804 Clear out all the active components of a CV. This can happen either
3805 by an explicit C<undef &foo>, or by the reference count going to zero.
3806 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
3807 children can still follow the full lexical scope chain.
3813 Perl_cv_undef(pTHX_ CV *cv)
3816 if (CvFILE(cv) && !CvXSUB(cv)) {
3817 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
3818 Safefree(CvFILE(cv));
3823 if (!CvXSUB(cv) && CvROOT(cv)) {
3825 Perl_croak(aTHX_ "Can't undef active subroutine");
3828 PAD_SAVE_SETNULLPAD();
3830 op_free(CvROOT(cv));
3831 CvROOT(cv) = Nullop;
3834 SvPOK_off((SV*)cv); /* forget prototype */
3839 /* remove CvOUTSIDE unless this is an undef rather than a free */
3840 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
3841 if (!CvWEAKOUTSIDE(cv))
3842 SvREFCNT_dec(CvOUTSIDE(cv));
3843 CvOUTSIDE(cv) = Nullcv;
3846 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
3852 /* delete all flags except WEAKOUTSIDE */
3853 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
3857 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
3859 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
3860 SV* msg = sv_newmortal();
3864 gv_efullname3(name = sv_newmortal(), gv, Nullch);
3865 sv_setpv(msg, "Prototype mismatch:");
3867 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
3869 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (SV *)cv);
3870 sv_catpv(msg, " vs ");
3872 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
3874 sv_catpv(msg, "none");
3875 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
3879 static void const_sv_xsub(pTHX_ CV* cv);
3883 =head1 Optree Manipulation Functions
3885 =for apidoc cv_const_sv
3887 If C<cv> is a constant sub eligible for inlining. returns the constant
3888 value returned by the sub. Otherwise, returns NULL.
3890 Constant subs can be created with C<newCONSTSUB> or as described in
3891 L<perlsub/"Constant Functions">.
3896 Perl_cv_const_sv(pTHX_ CV *cv)
3898 if (!cv || !CvCONST(cv))
3900 return (SV*)CvXSUBANY(cv).any_ptr;
3903 /* op_const_sv: examine an optree to determine whether it's in-lineable.
3904 * Can be called in 3 ways:
3907 * look for a single OP_CONST with attached value: return the value
3909 * cv && CvCLONE(cv) && !CvCONST(cv)
3911 * examine the clone prototype, and if contains only a single
3912 * OP_CONST referencing a pad const, or a single PADSV referencing
3913 * an outer lexical, return a non-zero value to indicate the CV is
3914 * a candidate for "constizing" at clone time
3918 * We have just cloned an anon prototype that was marked as a const
3919 * candidiate. Try to grab the current value, and in the case of
3920 * PADSV, ignore it if it has multiple references. Return the value.
3924 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
3931 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
3932 o = cLISTOPo->op_first->op_sibling;
3934 for (; o; o = o->op_next) {
3935 OPCODE type = o->op_type;
3937 if (sv && o->op_next == o)
3939 if (o->op_next != o) {
3940 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
3942 if (type == OP_DBSTATE)
3945 if (type == OP_LEAVESUB || type == OP_RETURN)
3949 if (type == OP_CONST && cSVOPo->op_sv)
3951 else if (cv && type == OP_CONST) {
3952 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
3956 else if (cv && type == OP_PADSV) {
3957 if (CvCONST(cv)) { /* newly cloned anon */
3958 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
3959 /* the candidate should have 1 ref from this pad and 1 ref
3960 * from the parent */
3961 if (!sv || SvREFCNT(sv) != 2)
3968 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
3969 sv = &PL_sv_undef; /* an arbitrary non-null value */
3980 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
3990 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
3994 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
3996 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4000 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4006 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4010 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4011 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4012 SV *sv = sv_newmortal();
4013 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4014 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4015 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4020 gv = gv_fetchpv(name ? name : (aname ? aname :
4021 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__")),
4022 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4032 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4033 maximum a prototype before. */
4034 if (SvTYPE(gv) > SVt_NULL) {
4035 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4036 && ckWARN_d(WARN_PROTOTYPE))
4038 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4040 cv_ckproto((CV*)gv, NULL, ps);
4043 sv_setpv((SV*)gv, ps);
4045 sv_setiv((SV*)gv, -1);
4046 SvREFCNT_dec(PL_compcv);
4047 cv = PL_compcv = NULL;
4048 PL_sub_generation++;
4052 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4054 #ifdef GV_UNIQUE_CHECK
4055 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4056 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4060 if (!block || !ps || *ps || attrs)
4063 const_sv = op_const_sv(block, Nullcv);
4066 bool exists = CvROOT(cv) || CvXSUB(cv);
4068 #ifdef GV_UNIQUE_CHECK
4069 if (exists && GvUNIQUE(gv)) {
4070 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4074 /* if the subroutine doesn't exist and wasn't pre-declared
4075 * with a prototype, assume it will be AUTOLOADed,
4076 * skipping the prototype check
4078 if (exists || SvPOK(cv))
4079 cv_ckproto(cv, gv, ps);
4080 /* already defined (or promised)? */
4081 if (exists || GvASSUMECV(gv)) {
4082 if (!block && !attrs) {
4083 if (CvFLAGS(PL_compcv)) {
4084 /* might have had built-in attrs applied */
4085 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4087 /* just a "sub foo;" when &foo is already defined */
4088 SAVEFREESV(PL_compcv);
4091 /* ahem, death to those who redefine active sort subs */
4092 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4093 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4095 if (ckWARN(WARN_REDEFINE)
4097 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4099 line_t oldline = CopLINE(PL_curcop);
4100 if (PL_copline != NOLINE)
4101 CopLINE_set(PL_curcop, PL_copline);
4102 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4103 CvCONST(cv) ? "Constant subroutine %s redefined"
4104 : "Subroutine %s redefined", name);
4105 CopLINE_set(PL_curcop, oldline);
4113 SvREFCNT_inc(const_sv);
4115 assert(!CvROOT(cv) && !CvCONST(cv));
4116 sv_setpv((SV*)cv, ""); /* prototype is "" */
4117 CvXSUBANY(cv).any_ptr = const_sv;
4118 CvXSUB(cv) = const_sv_xsub;
4123 cv = newCONSTSUB(NULL, name, const_sv);
4126 SvREFCNT_dec(PL_compcv);
4128 PL_sub_generation++;
4135 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4136 * before we clobber PL_compcv.
4140 /* Might have had built-in attributes applied -- propagate them. */
4141 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4142 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4143 stash = GvSTASH(CvGV(cv));
4144 else if (CvSTASH(cv))
4145 stash = CvSTASH(cv);
4147 stash = PL_curstash;
4150 /* possibly about to re-define existing subr -- ignore old cv */
4151 rcv = (SV*)PL_compcv;
4152 if (name && GvSTASH(gv))
4153 stash = GvSTASH(gv);
4155 stash = PL_curstash;
4157 apply_attrs(stash, rcv, attrs, FALSE);
4159 if (cv) { /* must reuse cv if autoloaded */
4161 /* got here with just attrs -- work done, so bug out */
4162 SAVEFREESV(PL_compcv);
4165 /* transfer PL_compcv to cv */
4167 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4168 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4169 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4170 CvOUTSIDE(PL_compcv) = 0;
4171 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4172 CvPADLIST(PL_compcv) = 0;
4173 /* inner references to PL_compcv must be fixed up ... */
4174 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4175 /* ... before we throw it away */
4176 SvREFCNT_dec(PL_compcv);
4178 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4179 ++PL_sub_generation;
4186 PL_sub_generation++;
4190 CvFILE_set_from_cop(cv, PL_curcop);
4191 CvSTASH(cv) = PL_curstash;
4194 sv_setpv((SV*)cv, ps);
4196 if (PL_error_count) {
4200 char *s = strrchr(name, ':');
4202 if (strEQ(s, "BEGIN")) {
4204 "BEGIN not safe after errors--compilation aborted";
4205 if (PL_in_eval & EVAL_KEEPERR)
4206 Perl_croak(aTHX_ not_safe);
4208 /* force display of errors found but not reported */
4209 sv_catpv(ERRSV, not_safe);
4210 Perl_croak(aTHX_ "%"SVf, ERRSV);
4219 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4220 mod(scalarseq(block), OP_LEAVESUBLV));
4223 /* This makes sub {}; work as expected. */
4224 if (block->op_type == OP_STUB) {
4226 block = newSTATEOP(0, Nullch, 0);
4228 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4230 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4231 OpREFCNT_set(CvROOT(cv), 1);
4232 CvSTART(cv) = LINKLIST(CvROOT(cv));
4233 CvROOT(cv)->op_next = 0;
4234 CALL_PEEP(CvSTART(cv));
4236 /* now that optimizer has done its work, adjust pad values */
4238 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4241 assert(!CvCONST(cv));
4242 if (ps && !*ps && op_const_sv(block, cv))
4246 if (name || aname) {
4248 char *tname = (name ? name : aname);
4250 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4251 SV *sv = NEWSV(0,0);
4252 SV *tmpstr = sv_newmortal();
4253 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4257 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4259 (long)PL_subline, (long)CopLINE(PL_curcop));
4260 gv_efullname3(tmpstr, gv, Nullch);
4261 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4262 hv = GvHVn(db_postponed);
4263 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4264 && (pcv = GvCV(db_postponed)))
4270 call_sv((SV*)pcv, G_DISCARD);
4274 if ((s = strrchr(tname,':')))
4279 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4282 if (strEQ(s, "BEGIN") && !PL_error_count) {
4283 I32 oldscope = PL_scopestack_ix;
4285 SAVECOPFILE(&PL_compiling);
4286 SAVECOPLINE(&PL_compiling);
4289 PL_beginav = newAV();
4290 DEBUG_x( dump_sub(gv) );
4291 av_push(PL_beginav, (SV*)cv);
4292 GvCV(gv) = 0; /* cv has been hijacked */
4293 call_list(oldscope, PL_beginav);
4295 PL_curcop = &PL_compiling;
4296 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4299 else if (strEQ(s, "END") && !PL_error_count) {
4302 DEBUG_x( dump_sub(gv) );
4303 av_unshift(PL_endav, 1);
4304 av_store(PL_endav, 0, (SV*)cv);
4305 GvCV(gv) = 0; /* cv has been hijacked */
4307 else if (strEQ(s, "CHECK") && !PL_error_count) {
4309 PL_checkav = newAV();
4310 DEBUG_x( dump_sub(gv) );
4311 if (PL_main_start && ckWARN(WARN_VOID))
4312 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4313 av_unshift(PL_checkav, 1);
4314 av_store(PL_checkav, 0, (SV*)cv);
4315 GvCV(gv) = 0; /* cv has been hijacked */
4317 else if (strEQ(s, "INIT") && !PL_error_count) {
4319 PL_initav = newAV();
4320 DEBUG_x( dump_sub(gv) );
4321 if (PL_main_start && ckWARN(WARN_VOID))
4322 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4323 av_push(PL_initav, (SV*)cv);
4324 GvCV(gv) = 0; /* cv has been hijacked */
4329 PL_copline = NOLINE;
4334 /* XXX unsafe for threads if eval_owner isn't held */
4336 =for apidoc newCONSTSUB
4338 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4339 eligible for inlining at compile-time.
4345 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4351 SAVECOPLINE(PL_curcop);
4352 CopLINE_set(PL_curcop, PL_copline);
4355 PL_hints &= ~HINT_BLOCK_SCOPE;
4358 SAVESPTR(PL_curstash);
4359 SAVECOPSTASH(PL_curcop);
4360 PL_curstash = stash;
4361 CopSTASH_set(PL_curcop,stash);
4364 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4365 CvXSUBANY(cv).any_ptr = sv;
4367 sv_setpv((SV*)cv, ""); /* prototype is "" */
4370 CopSTASH_free(PL_curcop);
4378 =for apidoc U||newXS
4380 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4386 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
4388 GV *gv = gv_fetchpv(name ? name :
4389 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4390 GV_ADDMULTI, SVt_PVCV);
4394 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4396 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4398 /* just a cached method */
4402 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4403 /* already defined (or promised) */
4404 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4405 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4406 line_t oldline = CopLINE(PL_curcop);
4407 if (PL_copline != NOLINE)
4408 CopLINE_set(PL_curcop, PL_copline);
4409 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4410 CvCONST(cv) ? "Constant subroutine %s redefined"
4411 : "Subroutine %s redefined"
4413 CopLINE_set(PL_curcop, oldline);
4420 if (cv) /* must reuse cv if autoloaded */
4423 cv = (CV*)NEWSV(1105,0);
4424 sv_upgrade((SV *)cv, SVt_PVCV);
4428 PL_sub_generation++;
4432 (void)gv_fetchfile(filename);
4433 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
4434 an external constant string */
4435 CvXSUB(cv) = subaddr;
4438 char *s = strrchr(name,':');
4444 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4447 if (strEQ(s, "BEGIN")) {
4449 PL_beginav = newAV();
4450 av_push(PL_beginav, (SV*)cv);
4451 GvCV(gv) = 0; /* cv has been hijacked */
4453 else if (strEQ(s, "END")) {
4456 av_unshift(PL_endav, 1);
4457 av_store(PL_endav, 0, (SV*)cv);
4458 GvCV(gv) = 0; /* cv has been hijacked */
4460 else if (strEQ(s, "CHECK")) {
4462 PL_checkav = newAV();
4463 if (PL_main_start && ckWARN(WARN_VOID))
4464 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4465 av_unshift(PL_checkav, 1);
4466 av_store(PL_checkav, 0, (SV*)cv);
4467 GvCV(gv) = 0; /* cv has been hijacked */
4469 else if (strEQ(s, "INIT")) {
4471 PL_initav = newAV();
4472 if (PL_main_start && ckWARN(WARN_VOID))
4473 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4474 av_push(PL_initav, (SV*)cv);
4475 GvCV(gv) = 0; /* cv has been hijacked */
4486 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4494 name = SvPVx(cSVOPo->op_sv, n_a);
4497 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
4498 #ifdef GV_UNIQUE_CHECK
4500 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4504 if ((cv = GvFORM(gv))) {
4505 if (ckWARN(WARN_REDEFINE)) {
4506 line_t oldline = CopLINE(PL_curcop);
4507 if (PL_copline != NOLINE)
4508 CopLINE_set(PL_curcop, PL_copline);
4509 Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Format %s redefined",name);
4510 CopLINE_set(PL_curcop, oldline);
4517 CvFILE_set_from_cop(cv, PL_curcop);
4520 pad_tidy(padtidy_FORMAT);
4521 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4522 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4523 OpREFCNT_set(CvROOT(cv), 1);
4524 CvSTART(cv) = LINKLIST(CvROOT(cv));
4525 CvROOT(cv)->op_next = 0;
4526 CALL_PEEP(CvSTART(cv));
4528 PL_copline = NOLINE;
4533 Perl_newANONLIST(pTHX_ OP *o)
4535 return newUNOP(OP_REFGEN, 0,
4536 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4540 Perl_newANONHASH(pTHX_ OP *o)
4542 return newUNOP(OP_REFGEN, 0,
4543 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4547 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4549 return newANONATTRSUB(floor, proto, Nullop, block);
4553 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4555 return newUNOP(OP_REFGEN, 0,
4556 newSVOP(OP_ANONCODE, 0,
4557 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
4561 Perl_oopsAV(pTHX_ OP *o)
4563 switch (o->op_type) {
4565 o->op_type = OP_PADAV;
4566 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4567 return ref(o, OP_RV2AV);
4570 o->op_type = OP_RV2AV;
4571 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4576 if (ckWARN_d(WARN_INTERNAL))
4577 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
4584 Perl_oopsHV(pTHX_ OP *o)
4586 switch (o->op_type) {
4589 o->op_type = OP_PADHV;
4590 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4591 return ref(o, OP_RV2HV);
4595 o->op_type = OP_RV2HV;
4596 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
4601 if (ckWARN_d(WARN_INTERNAL))
4602 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
4609 Perl_newAVREF(pTHX_ OP *o)
4611 if (o->op_type == OP_PADANY) {
4612 o->op_type = OP_PADAV;
4613 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4616 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
4617 && ckWARN(WARN_DEPRECATED)) {
4618 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4619 "Using an array as a reference is deprecated");
4621 return newUNOP(OP_RV2AV, 0, scalar(o));
4625 Perl_newGVREF(pTHX_ I32 type, OP *o)
4627 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
4628 return newUNOP(OP_NULL, 0, o);
4629 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
4633 Perl_newHVREF(pTHX_ OP *o)
4635 if (o->op_type == OP_PADANY) {
4636 o->op_type = OP_PADHV;
4637 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4640 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
4641 && ckWARN(WARN_DEPRECATED)) {
4642 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4643 "Using a hash as a reference is deprecated");
4645 return newUNOP(OP_RV2HV, 0, scalar(o));
4649 Perl_oopsCV(pTHX_ OP *o)
4651 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
4657 Perl_newCVREF(pTHX_ I32 flags, OP *o)
4659 return newUNOP(OP_RV2CV, flags, scalar(o));
4663 Perl_newSVREF(pTHX_ OP *o)
4665 if (o->op_type == OP_PADANY) {
4666 o->op_type = OP_PADSV;
4667 o->op_ppaddr = PL_ppaddr[OP_PADSV];
4670 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4671 o->op_flags |= OPpDONE_SVREF;
4674 return newUNOP(OP_RV2SV, 0, scalar(o));
4677 /* Check routines. */
4680 Perl_ck_anoncode(pTHX_ OP *o)
4682 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
4683 cSVOPo->op_sv = Nullsv;
4688 Perl_ck_bitop(pTHX_ OP *o)
4690 #define OP_IS_NUMCOMPARE(op) \
4691 ((op) == OP_LT || (op) == OP_I_LT || \
4692 (op) == OP_GT || (op) == OP_I_GT || \
4693 (op) == OP_LE || (op) == OP_I_LE || \
4694 (op) == OP_GE || (op) == OP_I_GE || \
4695 (op) == OP_EQ || (op) == OP_I_EQ || \
4696 (op) == OP_NE || (op) == OP_I_NE || \
4697 (op) == OP_NCMP || (op) == OP_I_NCMP)
4698 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4699 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
4700 && (o->op_type == OP_BIT_OR
4701 || o->op_type == OP_BIT_AND
4702 || o->op_type == OP_BIT_XOR))
4704 OP * left = cBINOPo->op_first;
4705 OP * right = left->op_sibling;
4706 if ((OP_IS_NUMCOMPARE(left->op_type) &&
4707 (left->op_flags & OPf_PARENS) == 0) ||
4708 (OP_IS_NUMCOMPARE(right->op_type) &&
4709 (right->op_flags & OPf_PARENS) == 0))
4710 if (ckWARN(WARN_PRECEDENCE))
4711 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4712 "Possible precedence problem on bitwise %c operator",
4713 o->op_type == OP_BIT_OR ? '|'
4714 : o->op_type == OP_BIT_AND ? '&' : '^'
4721 Perl_ck_concat(pTHX_ OP *o)
4723 OP *kid = cUNOPo->op_first;
4724 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
4725 !(kUNOP->op_first->op_flags & OPf_MOD))
4726 o->op_flags |= OPf_STACKED;
4731 Perl_ck_spair(pTHX_ OP *o)
4733 if (o->op_flags & OPf_KIDS) {
4736 OPCODE type = o->op_type;
4737 o = modkids(ck_fun(o), type);
4738 kid = cUNOPo->op_first;
4739 newop = kUNOP->op_first->op_sibling;
4741 (newop->op_sibling ||
4742 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
4743 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
4744 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
4748 op_free(kUNOP->op_first);
4749 kUNOP->op_first = newop;
4751 o->op_ppaddr = PL_ppaddr[++o->op_type];
4756 Perl_ck_delete(pTHX_ OP *o)
4760 if (o->op_flags & OPf_KIDS) {
4761 OP *kid = cUNOPo->op_first;
4762 switch (kid->op_type) {
4764 o->op_flags |= OPf_SPECIAL;
4767 o->op_private |= OPpSLICE;
4770 o->op_flags |= OPf_SPECIAL;
4775 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
4784 Perl_ck_die(pTHX_ OP *o)
4787 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4793 Perl_ck_eof(pTHX_ OP *o)
4795 I32 type = o->op_type;
4797 if (o->op_flags & OPf_KIDS) {
4798 if (cLISTOPo->op_first->op_type == OP_STUB) {
4800 o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
4808 Perl_ck_eval(pTHX_ OP *o)
4810 PL_hints |= HINT_BLOCK_SCOPE;
4811 if (o->op_flags & OPf_KIDS) {
4812 SVOP *kid = (SVOP*)cUNOPo->op_first;
4815 o->op_flags &= ~OPf_KIDS;
4818 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
4821 cUNOPo->op_first = 0;
4824 NewOp(1101, enter, 1, LOGOP);
4825 enter->op_type = OP_ENTERTRY;
4826 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
4827 enter->op_private = 0;
4829 /* establish postfix order */
4830 enter->op_next = (OP*)enter;
4832 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
4833 o->op_type = OP_LEAVETRY;
4834 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
4835 enter->op_other = o;
4845 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
4847 o->op_targ = (PADOFFSET)PL_hints;
4852 Perl_ck_exit(pTHX_ OP *o)
4855 HV *table = GvHV(PL_hintgv);
4857 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
4858 if (svp && *svp && SvTRUE(*svp))
4859 o->op_private |= OPpEXIT_VMSISH;
4861 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4867 Perl_ck_exec(pTHX_ OP *o)
4870 if (o->op_flags & OPf_STACKED) {
4872 kid = cUNOPo->op_first->op_sibling;
4873 if (kid->op_type == OP_RV2GV)
4882 Perl_ck_exists(pTHX_ OP *o)
4885 if (o->op_flags & OPf_KIDS) {
4886 OP *kid = cUNOPo->op_first;
4887 if (kid->op_type == OP_ENTERSUB) {
4888 (void) ref(kid, o->op_type);
4889 if (kid->op_type != OP_RV2CV && !PL_error_count)
4890 Perl_croak(aTHX_ "%s argument is not a subroutine name",
4892 o->op_private |= OPpEXISTS_SUB;
4894 else if (kid->op_type == OP_AELEM)
4895 o->op_flags |= OPf_SPECIAL;
4896 else if (kid->op_type != OP_HELEM)
4897 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
4906 Perl_ck_gvconst(pTHX_ register OP *o)
4908 o = fold_constants(o);
4909 if (o->op_type == OP_CONST)
4916 Perl_ck_rvconst(pTHX_ register OP *o)
4918 SVOP *kid = (SVOP*)cUNOPo->op_first;
4920 o->op_private |= (PL_hints & HINT_STRICT_REFS);
4921 if (kid->op_type == OP_CONST) {
4925 SV *kidsv = kid->op_sv;
4928 /* Is it a constant from cv_const_sv()? */
4929 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
4930 SV *rsv = SvRV(kidsv);
4931 int svtype = SvTYPE(rsv);
4932 char *badtype = Nullch;
4934 switch (o->op_type) {
4936 if (svtype > SVt_PVMG)
4937 badtype = "a SCALAR";
4940 if (svtype != SVt_PVAV)
4941 badtype = "an ARRAY";
4944 if (svtype != SVt_PVHV)
4948 if (svtype != SVt_PVCV)
4953 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
4956 name = SvPV(kidsv, n_a);
4957 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
4958 char *badthing = Nullch;
4959 switch (o->op_type) {
4961 badthing = "a SCALAR";
4964 badthing = "an ARRAY";
4967 badthing = "a HASH";
4972 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
4976 * This is a little tricky. We only want to add the symbol if we
4977 * didn't add it in the lexer. Otherwise we get duplicate strict
4978 * warnings. But if we didn't add it in the lexer, we must at
4979 * least pretend like we wanted to add it even if it existed before,
4980 * or we get possible typo warnings. OPpCONST_ENTERED says
4981 * whether the lexer already added THIS instance of this symbol.
4983 iscv = (o->op_type == OP_RV2CV) * 2;
4985 gv = gv_fetchpv(name,
4986 iscv | !(kid->op_private & OPpCONST_ENTERED),
4989 : o->op_type == OP_RV2SV
4991 : o->op_type == OP_RV2AV
4993 : o->op_type == OP_RV2HV
4996 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
4998 kid->op_type = OP_GV;
4999 SvREFCNT_dec(kid->op_sv);
5001 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5002 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5003 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
5005 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
5007 kid->op_sv = SvREFCNT_inc(gv);
5009 kid->op_private = 0;
5010 kid->op_ppaddr = PL_ppaddr[OP_GV];
5017 Perl_ck_ftst(pTHX_ OP *o)
5019 I32 type = o->op_type;
5021 if (o->op_flags & OPf_REF) {
5024 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5025 SVOP *kid = (SVOP*)cUNOPo->op_first;
5027 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5029 OP *newop = newGVOP(type, OPf_REF,
5030 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5035 if ((PL_hints & HINT_FILETEST_ACCESS) &&
5036 OP_IS_FILETEST_ACCESS(o))
5037 o->op_private |= OPpFT_ACCESS;
5042 if (type == OP_FTTTY)
5043 o = newGVOP(type, OPf_REF, PL_stdingv);
5045 o = newUNOP(type, 0, newDEFSVOP());
5051 Perl_ck_fun(pTHX_ OP *o)
5057 int type = o->op_type;
5058 register I32 oa = PL_opargs[type] >> OASHIFT;
5060 if (o->op_flags & OPf_STACKED) {
5061 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5064 return no_fh_allowed(o);
5067 if (o->op_flags & OPf_KIDS) {
5069 tokid = &cLISTOPo->op_first;
5070 kid = cLISTOPo->op_first;
5071 if (kid->op_type == OP_PUSHMARK ||
5072 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5074 tokid = &kid->op_sibling;
5075 kid = kid->op_sibling;
5077 if (!kid && PL_opargs[type] & OA_DEFGV)
5078 *tokid = kid = newDEFSVOP();
5082 sibl = kid->op_sibling;
5085 /* list seen where single (scalar) arg expected? */
5086 if (numargs == 1 && !(oa >> 4)
5087 && kid->op_type == OP_LIST && type != OP_SCALAR)
5089 return too_many_arguments(o,PL_op_desc[type]);
5102 if ((type == OP_PUSH || type == OP_UNSHIFT)
5103 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5104 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5105 "Useless use of %s with no values",
5108 if (kid->op_type == OP_CONST &&
5109 (kid->op_private & OPpCONST_BARE))
5111 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5112 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5113 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5114 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5115 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5116 "Array @%s missing the @ in argument %"IVdf" of %s()",
5117 name, (IV)numargs, PL_op_desc[type]);
5120 kid->op_sibling = sibl;
5123 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5124 bad_type(numargs, "array", PL_op_desc[type], kid);
5128 if (kid->op_type == OP_CONST &&
5129 (kid->op_private & OPpCONST_BARE))
5131 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5132 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5133 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5134 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5135 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5136 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5137 name, (IV)numargs, PL_op_desc[type]);
5140 kid->op_sibling = sibl;
5143 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5144 bad_type(numargs, "hash", PL_op_desc[type], kid);
5149 OP *newop = newUNOP(OP_NULL, 0, kid);
5150 kid->op_sibling = 0;
5152 newop->op_next = newop;
5154 kid->op_sibling = sibl;
5159 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5160 if (kid->op_type == OP_CONST &&
5161 (kid->op_private & OPpCONST_BARE))
5163 OP *newop = newGVOP(OP_GV, 0,
5164 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5166 if (!(o->op_private & 1) && /* if not unop */
5167 kid == cLISTOPo->op_last)
5168 cLISTOPo->op_last = newop;
5172 else if (kid->op_type == OP_READLINE) {
5173 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5174 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5177 I32 flags = OPf_SPECIAL;
5181 /* is this op a FH constructor? */
5182 if (is_handle_constructor(o,numargs)) {
5183 char *name = Nullch;
5187 /* Set a flag to tell rv2gv to vivify
5188 * need to "prove" flag does not mean something
5189 * else already - NI-S 1999/05/07
5192 if (kid->op_type == OP_PADSV) {
5193 name = PAD_COMPNAME_PV(kid->op_targ);
5194 /* SvCUR of a pad namesv can't be trusted
5195 * (see PL_generation), so calc its length
5201 else if (kid->op_type == OP_RV2SV
5202 && kUNOP->op_first->op_type == OP_GV)
5204 GV *gv = cGVOPx_gv(kUNOP->op_first);
5206 len = GvNAMELEN(gv);
5208 else if (kid->op_type == OP_AELEM
5209 || kid->op_type == OP_HELEM)
5214 if ((op = ((BINOP*)kid)->op_first)) {
5215 SV *tmpstr = Nullsv;
5217 kid->op_type == OP_AELEM ?
5219 if (((op->op_type == OP_RV2AV) ||
5220 (op->op_type == OP_RV2HV)) &&
5221 (op = ((UNOP*)op)->op_first) &&
5222 (op->op_type == OP_GV)) {
5223 /* packagevar $a[] or $h{} */
5224 GV *gv = cGVOPx_gv(op);
5232 else if (op->op_type == OP_PADAV
5233 || op->op_type == OP_PADHV) {
5234 /* lexicalvar $a[] or $h{} */
5236 PAD_COMPNAME_PV(op->op_targ);
5246 name = SvPV(tmpstr, len);
5251 name = "__ANONIO__";
5258 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5259 namesv = PAD_SVl(targ);
5260 (void)SvUPGRADE(namesv, SVt_PV);
5262 sv_setpvn(namesv, "$", 1);
5263 sv_catpvn(namesv, name, len);
5266 kid->op_sibling = 0;
5267 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5268 kid->op_targ = targ;
5269 kid->op_private |= priv;
5271 kid->op_sibling = sibl;
5277 mod(scalar(kid), type);
5281 tokid = &kid->op_sibling;
5282 kid = kid->op_sibling;
5284 o->op_private |= numargs;
5286 return too_many_arguments(o,OP_DESC(o));
5289 else if (PL_opargs[type] & OA_DEFGV) {
5291 return newUNOP(type, 0, newDEFSVOP());
5295 while (oa & OA_OPTIONAL)
5297 if (oa && oa != OA_LIST)
5298 return too_few_arguments(o,OP_DESC(o));
5304 Perl_ck_glob(pTHX_ OP *o)
5309 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5310 append_elem(OP_GLOB, o, newDEFSVOP());
5312 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5313 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5315 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5318 #if !defined(PERL_EXTERNAL_GLOB)
5319 /* XXX this can be tightened up and made more failsafe. */
5320 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5323 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5324 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5325 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5326 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5327 GvCV(gv) = GvCV(glob_gv);
5328 SvREFCNT_inc((SV*)GvCV(gv));
5329 GvIMPORTED_CV_on(gv);
5332 #endif /* PERL_EXTERNAL_GLOB */
5334 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5335 append_elem(OP_GLOB, o,
5336 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5337 o->op_type = OP_LIST;
5338 o->op_ppaddr = PL_ppaddr[OP_LIST];
5339 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5340 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5341 cLISTOPo->op_first->op_targ = 0;
5342 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5343 append_elem(OP_LIST, o,
5344 scalar(newUNOP(OP_RV2CV, 0,
5345 newGVOP(OP_GV, 0, gv)))));
5346 o = newUNOP(OP_NULL, 0, ck_subr(o));
5347 o->op_targ = OP_GLOB; /* hint at what it used to be */
5350 gv = newGVgen("main");
5352 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5358 Perl_ck_grep(pTHX_ OP *o)
5362 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5364 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5365 NewOp(1101, gwop, 1, LOGOP);
5367 if (o->op_flags & OPf_STACKED) {
5370 kid = cLISTOPo->op_first->op_sibling;
5371 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5374 kid->op_next = (OP*)gwop;
5375 o->op_flags &= ~OPf_STACKED;
5377 kid = cLISTOPo->op_first->op_sibling;
5378 if (type == OP_MAPWHILE)
5385 kid = cLISTOPo->op_first->op_sibling;
5386 if (kid->op_type != OP_NULL)
5387 Perl_croak(aTHX_ "panic: ck_grep");
5388 kid = kUNOP->op_first;
5390 gwop->op_type = type;
5391 gwop->op_ppaddr = PL_ppaddr[type];
5392 gwop->op_first = listkids(o);
5393 gwop->op_flags |= OPf_KIDS;
5394 gwop->op_private = 1;
5395 gwop->op_other = LINKLIST(kid);
5396 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5397 kid->op_next = (OP*)gwop;
5399 kid = cLISTOPo->op_first->op_sibling;
5400 if (!kid || !kid->op_sibling)
5401 return too_few_arguments(o,OP_DESC(o));
5402 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5403 mod(kid, OP_GREPSTART);
5409 Perl_ck_index(pTHX_ OP *o)
5411 if (o->op_flags & OPf_KIDS) {
5412 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5414 kid = kid->op_sibling; /* get past "big" */
5415 if (kid && kid->op_type == OP_CONST)
5416 fbm_compile(((SVOP*)kid)->op_sv, 0);
5422 Perl_ck_lengthconst(pTHX_ OP *o)
5424 /* XXX length optimization goes here */
5429 Perl_ck_lfun(pTHX_ OP *o)
5431 OPCODE type = o->op_type;
5432 return modkids(ck_fun(o), type);
5436 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5438 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5439 switch (cUNOPo->op_first->op_type) {
5441 /* This is needed for
5442 if (defined %stash::)
5443 to work. Do not break Tk.
5445 break; /* Globals via GV can be undef */
5447 case OP_AASSIGN: /* Is this a good idea? */
5448 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5449 "defined(@array) is deprecated");
5450 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5451 "\t(Maybe you should just omit the defined()?)\n");
5454 /* This is needed for
5455 if (defined %stash::)
5456 to work. Do not break Tk.
5458 break; /* Globals via GV can be undef */
5460 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5461 "defined(%%hash) is deprecated");
5462 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5463 "\t(Maybe you should just omit the defined()?)\n");
5474 Perl_ck_rfun(pTHX_ OP *o)
5476 OPCODE type = o->op_type;
5477 return refkids(ck_fun(o), type);
5481 Perl_ck_listiob(pTHX_ OP *o)
5485 kid = cLISTOPo->op_first;
5488 kid = cLISTOPo->op_first;
5490 if (kid->op_type == OP_PUSHMARK)
5491 kid = kid->op_sibling;
5492 if (kid && o->op_flags & OPf_STACKED)
5493 kid = kid->op_sibling;
5494 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5495 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5496 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5497 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5498 cLISTOPo->op_first->op_sibling = kid;
5499 cLISTOPo->op_last = kid;
5500 kid = kid->op_sibling;
5505 append_elem(o->op_type, o, newDEFSVOP());
5511 Perl_ck_sassign(pTHX_ OP *o)
5513 OP *kid = cLISTOPo->op_first;
5514 /* has a disposable target? */
5515 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5516 && !(kid->op_flags & OPf_STACKED)
5517 /* Cannot steal the second time! */
5518 && !(kid->op_private & OPpTARGET_MY))
5520 OP *kkid = kid->op_sibling;
5522 /* Can just relocate the target. */
5523 if (kkid && kkid->op_type == OP_PADSV
5524 && !(kkid->op_private & OPpLVAL_INTRO))
5526 kid->op_targ = kkid->op_targ;
5528 /* Now we do not need PADSV and SASSIGN. */
5529 kid->op_sibling = o->op_sibling; /* NULL */
5530 cLISTOPo->op_first = NULL;
5533 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
5541 Perl_ck_match(pTHX_ OP *o)
5543 o->op_private |= OPpRUNTIME;
5548 Perl_ck_method(pTHX_ OP *o)
5550 OP *kid = cUNOPo->op_first;
5551 if (kid->op_type == OP_CONST) {
5552 SV* sv = kSVOP->op_sv;
5553 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
5555 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5556 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
5559 kSVOP->op_sv = Nullsv;
5561 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5570 Perl_ck_null(pTHX_ OP *o)
5576 Perl_ck_open(pTHX_ OP *o)
5578 HV *table = GvHV(PL_hintgv);
5582 svp = hv_fetch(table, "open_IN", 7, FALSE);
5584 mode = mode_from_discipline(*svp);
5585 if (mode & O_BINARY)
5586 o->op_private |= OPpOPEN_IN_RAW;
5587 else if (mode & O_TEXT)
5588 o->op_private |= OPpOPEN_IN_CRLF;
5591 svp = hv_fetch(table, "open_OUT", 8, FALSE);
5593 mode = mode_from_discipline(*svp);
5594 if (mode & O_BINARY)
5595 o->op_private |= OPpOPEN_OUT_RAW;
5596 else if (mode & O_TEXT)
5597 o->op_private |= OPpOPEN_OUT_CRLF;
5600 if (o->op_type == OP_BACKTICK)
5603 /* In case of three-arg dup open remove strictness
5604 * from the last arg if it is a bareword. */
5605 OP *first = cLISTOPx(o)->op_first; /* The pushmark. */
5606 OP *last = cLISTOPx(o)->op_last; /* The bareword. */
5610 if ((last->op_type == OP_CONST) && /* The bareword. */
5611 (last->op_private & OPpCONST_BARE) &&
5612 (last->op_private & OPpCONST_STRICT) &&
5613 (oa = first->op_sibling) && /* The fh. */
5614 (oa = oa->op_sibling) && /* The mode. */
5615 SvPOK(((SVOP*)oa)->op_sv) &&
5616 (mode = SvPVX(((SVOP*)oa)->op_sv)) &&
5617 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
5618 (last == oa->op_sibling)) /* The bareword. */
5619 last->op_private &= ~OPpCONST_STRICT;
5625 Perl_ck_repeat(pTHX_ OP *o)
5627 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5628 o->op_private |= OPpREPEAT_DOLIST;
5629 cBINOPo->op_first = force_list(cBINOPo->op_first);
5637 Perl_ck_require(pTHX_ OP *o)
5641 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
5642 SVOP *kid = (SVOP*)cUNOPo->op_first;
5644 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5646 for (s = SvPVX(kid->op_sv); *s; s++) {
5647 if (*s == ':' && s[1] == ':') {
5649 Move(s+2, s+1, strlen(s+2)+1, char);
5650 --SvCUR(kid->op_sv);
5653 if (SvREADONLY(kid->op_sv)) {
5654 SvREADONLY_off(kid->op_sv);
5655 sv_catpvn(kid->op_sv, ".pm", 3);
5656 SvREADONLY_on(kid->op_sv);
5659 sv_catpvn(kid->op_sv, ".pm", 3);
5663 /* handle override, if any */
5664 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
5665 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
5666 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
5668 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5669 OP *kid = cUNOPo->op_first;
5670 cUNOPo->op_first = 0;
5672 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5673 append_elem(OP_LIST, kid,
5674 scalar(newUNOP(OP_RV2CV, 0,
5683 Perl_ck_return(pTHX_ OP *o)
5686 if (CvLVALUE(PL_compcv)) {
5687 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5688 mod(kid, OP_LEAVESUBLV);
5695 Perl_ck_retarget(pTHX_ OP *o)
5697 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5704 Perl_ck_select(pTHX_ OP *o)
5707 if (o->op_flags & OPf_KIDS) {
5708 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5709 if (kid && kid->op_sibling) {
5710 o->op_type = OP_SSELECT;
5711 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
5713 return fold_constants(o);
5717 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5718 if (kid && kid->op_type == OP_RV2GV)
5719 kid->op_private &= ~HINT_STRICT_REFS;
5724 Perl_ck_shift(pTHX_ OP *o)
5726 I32 type = o->op_type;
5728 if (!(o->op_flags & OPf_KIDS)) {
5732 argop = newUNOP(OP_RV2AV, 0,
5733 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
5734 return newUNOP(type, 0, scalar(argop));
5736 return scalar(modkids(ck_fun(o), type));
5740 Perl_ck_sort(pTHX_ OP *o)
5744 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
5746 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5747 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
5749 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
5751 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
5753 if (kid->op_type == OP_SCOPE) {
5757 else if (kid->op_type == OP_LEAVE) {
5758 if (o->op_type == OP_SORT) {
5759 op_null(kid); /* wipe out leave */
5762 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
5763 if (k->op_next == kid)
5765 /* don't descend into loops */
5766 else if (k->op_type == OP_ENTERLOOP
5767 || k->op_type == OP_ENTERITER)
5769 k = cLOOPx(k)->op_lastop;
5774 kid->op_next = 0; /* just disconnect the leave */
5775 k = kLISTOP->op_first;
5780 if (o->op_type == OP_SORT) {
5781 /* provide scalar context for comparison function/block */
5787 o->op_flags |= OPf_SPECIAL;
5789 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
5792 firstkid = firstkid->op_sibling;
5795 /* provide list context for arguments */
5796 if (o->op_type == OP_SORT)
5803 S_simplify_sort(pTHX_ OP *o)
5805 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5809 if (!(o->op_flags & OPf_STACKED))
5811 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
5812 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
5813 kid = kUNOP->op_first; /* get past null */
5814 if (kid->op_type != OP_SCOPE)
5816 kid = kLISTOP->op_last; /* get past scope */
5817 switch(kid->op_type) {
5825 k = kid; /* remember this node*/
5826 if (kBINOP->op_first->op_type != OP_RV2SV)
5828 kid = kBINOP->op_first; /* get past cmp */
5829 if (kUNOP->op_first->op_type != OP_GV)
5831 kid = kUNOP->op_first; /* get past rv2sv */
5833 if (GvSTASH(gv) != PL_curstash)
5835 if (strEQ(GvNAME(gv), "a"))
5837 else if (strEQ(GvNAME(gv), "b"))
5841 kid = k; /* back to cmp */
5842 if (kBINOP->op_last->op_type != OP_RV2SV)
5844 kid = kBINOP->op_last; /* down to 2nd arg */
5845 if (kUNOP->op_first->op_type != OP_GV)
5847 kid = kUNOP->op_first; /* get past rv2sv */
5849 if (GvSTASH(gv) != PL_curstash
5851 ? strNE(GvNAME(gv), "a")
5852 : strNE(GvNAME(gv), "b")))
5854 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
5856 o->op_private |= OPpSORT_REVERSE;
5857 if (k->op_type == OP_NCMP)
5858 o->op_private |= OPpSORT_NUMERIC;
5859 if (k->op_type == OP_I_NCMP)
5860 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
5861 kid = cLISTOPo->op_first->op_sibling;
5862 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
5863 op_free(kid); /* then delete it */
5867 Perl_ck_split(pTHX_ OP *o)
5871 if (o->op_flags & OPf_STACKED)
5872 return no_fh_allowed(o);
5874 kid = cLISTOPo->op_first;
5875 if (kid->op_type != OP_NULL)
5876 Perl_croak(aTHX_ "panic: ck_split");
5877 kid = kid->op_sibling;
5878 op_free(cLISTOPo->op_first);
5879 cLISTOPo->op_first = kid;
5881 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
5882 cLISTOPo->op_last = kid; /* There was only one element previously */
5885 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
5886 OP *sibl = kid->op_sibling;
5887 kid->op_sibling = 0;
5888 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
5889 if (cLISTOPo->op_first == cLISTOPo->op_last)
5890 cLISTOPo->op_last = kid;
5891 cLISTOPo->op_first = kid;
5892 kid->op_sibling = sibl;
5895 kid->op_type = OP_PUSHRE;
5896 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
5898 if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
5899 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
5900 "Use of /g modifier is meaningless in split");
5903 if (!kid->op_sibling)
5904 append_elem(OP_SPLIT, o, newDEFSVOP());
5906 kid = kid->op_sibling;
5909 if (!kid->op_sibling)
5910 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
5912 kid = kid->op_sibling;
5915 if (kid->op_sibling)
5916 return too_many_arguments(o,OP_DESC(o));
5922 Perl_ck_join(pTHX_ OP *o)
5924 if (ckWARN(WARN_SYNTAX)) {
5925 OP *kid = cLISTOPo->op_first->op_sibling;
5926 if (kid && kid->op_type == OP_MATCH) {
5927 char *pmstr = "STRING";
5928 if (PM_GETRE(kPMOP))
5929 pmstr = PM_GETRE(kPMOP)->precomp;
5930 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5931 "/%s/ should probably be written as \"%s\"",
5939 Perl_ck_subr(pTHX_ OP *o)
5941 OP *prev = ((cUNOPo->op_first->op_sibling)
5942 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
5943 OP *o2 = prev->op_sibling;
5950 I32 contextclass = 0;
5955 o->op_private |= OPpENTERSUB_HASTARG;
5956 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
5957 if (cvop->op_type == OP_RV2CV) {
5959 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
5960 op_null(cvop); /* disable rv2cv */
5961 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
5962 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
5963 GV *gv = cGVOPx_gv(tmpop);
5966 tmpop->op_private |= OPpEARLY_CV;
5969 namegv = CvANON(cv) ? gv : CvGV(cv);
5970 proto = SvPV((SV*)cv, n_a);
5972 if (CvASSERTION(cv)) {
5973 if (PL_hints & HINT_ASSERTING) {
5974 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
5975 o->op_private |= OPpENTERSUB_DB;
5979 if (ckWARN(WARN_ASSERTIONS) && !(PL_hints & HINT_ASSERTIONSSEEN)) {
5980 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
5981 "Impossible to activate assertion call");
5988 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
5989 if (o2->op_type == OP_CONST)
5990 o2->op_private &= ~OPpCONST_STRICT;
5991 else if (o2->op_type == OP_LIST) {
5992 OP *o = ((UNOP*)o2)->op_first->op_sibling;
5993 if (o && o->op_type == OP_CONST)
5994 o->op_private &= ~OPpCONST_STRICT;
5997 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5998 if (PERLDB_SUB && PL_curstash != PL_debstash)
5999 o->op_private |= OPpENTERSUB_DB;
6000 while (o2 != cvop) {
6004 return too_many_arguments(o, gv_ename(namegv));
6022 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6024 arg == 1 ? "block or sub {}" : "sub {}",
6025 gv_ename(namegv), o2);
6028 /* '*' allows any scalar type, including bareword */
6031 if (o2->op_type == OP_RV2GV)
6032 goto wrapref; /* autoconvert GLOB -> GLOBref */
6033 else if (o2->op_type == OP_CONST)
6034 o2->op_private &= ~OPpCONST_STRICT;
6035 else if (o2->op_type == OP_ENTERSUB) {
6036 /* accidental subroutine, revert to bareword */
6037 OP *gvop = ((UNOP*)o2)->op_first;
6038 if (gvop && gvop->op_type == OP_NULL) {
6039 gvop = ((UNOP*)gvop)->op_first;
6041 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6044 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6045 (gvop = ((UNOP*)gvop)->op_first) &&
6046 gvop->op_type == OP_GV)
6048 GV *gv = cGVOPx_gv(gvop);
6049 OP *sibling = o2->op_sibling;
6050 SV *n = newSVpvn("",0);
6052 gv_fullname3(n, gv, "");
6053 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6054 sv_chop(n, SvPVX(n)+6);
6055 o2 = newSVOP(OP_CONST, 0, n);
6056 prev->op_sibling = o2;
6057 o2->op_sibling = sibling;
6073 if (contextclass++ == 0) {
6074 e = strchr(proto, ']');
6075 if (!e || e == proto)
6088 while (*--p != '[');
6089 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6090 gv_ename(namegv), o2);
6096 if (o2->op_type == OP_RV2GV)
6099 bad_type(arg, "symbol", gv_ename(namegv), o2);
6102 if (o2->op_type == OP_ENTERSUB)
6105 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6108 if (o2->op_type == OP_RV2SV ||
6109 o2->op_type == OP_PADSV ||
6110 o2->op_type == OP_HELEM ||
6111 o2->op_type == OP_AELEM ||
6112 o2->op_type == OP_THREADSV)
6115 bad_type(arg, "scalar", gv_ename(namegv), o2);
6118 if (o2->op_type == OP_RV2AV ||
6119 o2->op_type == OP_PADAV)
6122 bad_type(arg, "array", gv_ename(namegv), o2);
6125 if (o2->op_type == OP_RV2HV ||
6126 o2->op_type == OP_PADHV)
6129 bad_type(arg, "hash", gv_ename(namegv), o2);
6134 OP* sib = kid->op_sibling;
6135 kid->op_sibling = 0;
6136 o2 = newUNOP(OP_REFGEN, 0, kid);
6137 o2->op_sibling = sib;
6138 prev->op_sibling = o2;
6140 if (contextclass && e) {
6155 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6156 gv_ename(namegv), cv);
6161 mod(o2, OP_ENTERSUB);
6163 o2 = o2->op_sibling;
6165 if (proto && !optional &&
6166 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6167 return too_few_arguments(o, gv_ename(namegv));
6170 o=newSVOP(OP_CONST, 0, newSViv(0));
6176 Perl_ck_svconst(pTHX_ OP *o)
6178 SvREADONLY_on(cSVOPo->op_sv);
6183 Perl_ck_trunc(pTHX_ OP *o)
6185 if (o->op_flags & OPf_KIDS) {
6186 SVOP *kid = (SVOP*)cUNOPo->op_first;
6188 if (kid->op_type == OP_NULL)
6189 kid = (SVOP*)kid->op_sibling;
6190 if (kid && kid->op_type == OP_CONST &&
6191 (kid->op_private & OPpCONST_BARE))
6193 o->op_flags |= OPf_SPECIAL;
6194 kid->op_private &= ~OPpCONST_STRICT;
6201 Perl_ck_unpack(pTHX_ OP *o)
6203 OP *kid = cLISTOPo->op_first;
6204 if (kid->op_sibling) {
6205 kid = kid->op_sibling;
6206 if (!kid->op_sibling)
6207 kid->op_sibling = newDEFSVOP();
6213 Perl_ck_substr(pTHX_ OP *o)
6216 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6217 OP *kid = cLISTOPo->op_first;
6219 if (kid->op_type == OP_NULL)
6220 kid = kid->op_sibling;
6222 kid->op_flags |= OPf_MOD;
6228 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6231 Perl_peep(pTHX_ register OP *o)
6233 register OP* oldop = 0;
6235 if (!o || o->op_seq)
6239 SAVEVPTR(PL_curcop);
6240 for (; o; o = o->op_next) {
6243 /* The special value -1 is used by the B::C compiler backend to indicate
6244 * that an op is statically defined and should not be freed */
6245 if (!PL_op_seqmax || PL_op_seqmax == (U16)-1)
6248 switch (o->op_type) {
6252 PL_curcop = ((COP*)o); /* for warnings */
6253 o->op_seq = PL_op_seqmax++;
6257 if (cSVOPo->op_private & OPpCONST_STRICT)
6258 no_bareword_allowed(o);
6260 case OP_METHOD_NAMED:
6261 /* Relocate sv to the pad for thread safety.
6262 * Despite being a "constant", the SV is written to,
6263 * for reference counts, sv_upgrade() etc. */
6265 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6266 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6267 /* If op_sv is already a PADTMP then it is being used by
6268 * some pad, so make a copy. */
6269 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6270 SvREADONLY_on(PAD_SVl(ix));
6271 SvREFCNT_dec(cSVOPo->op_sv);
6274 SvREFCNT_dec(PAD_SVl(ix));
6275 SvPADTMP_on(cSVOPo->op_sv);
6276 PAD_SETSV(ix, cSVOPo->op_sv);
6277 /* XXX I don't know how this isn't readonly already. */
6278 SvREADONLY_on(PAD_SVl(ix));
6280 cSVOPo->op_sv = Nullsv;
6284 o->op_seq = PL_op_seqmax++;
6288 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6289 if (o->op_next->op_private & OPpTARGET_MY) {
6290 if (o->op_flags & OPf_STACKED) /* chained concats */
6291 goto ignore_optimization;
6293 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6294 o->op_targ = o->op_next->op_targ;
6295 o->op_next->op_targ = 0;
6296 o->op_private |= OPpTARGET_MY;
6299 op_null(o->op_next);
6301 ignore_optimization:
6302 o->op_seq = PL_op_seqmax++;
6305 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6306 o->op_seq = PL_op_seqmax++;
6307 break; /* Scalar stub must produce undef. List stub is noop */
6311 if (o->op_targ == OP_NEXTSTATE
6312 || o->op_targ == OP_DBSTATE
6313 || o->op_targ == OP_SETSTATE)
6315 PL_curcop = ((COP*)o);
6317 /* XXX: We avoid setting op_seq here to prevent later calls
6318 to peep() from mistakenly concluding that optimisation
6319 has already occurred. This doesn't fix the real problem,
6320 though (See 20010220.007). AMS 20010719 */
6321 if (oldop && o->op_next) {
6322 oldop->op_next = o->op_next;
6330 if (oldop && o->op_next) {
6331 oldop->op_next = o->op_next;
6334 o->op_seq = PL_op_seqmax++;
6338 if (o->op_next->op_type == OP_RV2SV) {
6339 if (!(o->op_next->op_private & OPpDEREF)) {
6340 op_null(o->op_next);
6341 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6343 o->op_next = o->op_next->op_next;
6344 o->op_type = OP_GVSV;
6345 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6348 else if (o->op_next->op_type == OP_RV2AV) {
6349 OP* pop = o->op_next->op_next;
6351 if (pop && pop->op_type == OP_CONST &&
6352 (PL_op = pop->op_next) &&
6353 pop->op_next->op_type == OP_AELEM &&
6354 !(pop->op_next->op_private &
6355 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6356 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6361 op_null(o->op_next);
6362 op_null(pop->op_next);
6364 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6365 o->op_next = pop->op_next->op_next;
6366 o->op_type = OP_AELEMFAST;
6367 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6368 o->op_private = (U8)i;
6373 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6375 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6376 /* XXX could check prototype here instead of just carping */
6377 SV *sv = sv_newmortal();
6378 gv_efullname3(sv, gv, Nullch);
6379 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6380 "%"SVf"() called too early to check prototype",
6384 else if (o->op_next->op_type == OP_READLINE
6385 && o->op_next->op_next->op_type == OP_CONCAT
6386 && (o->op_next->op_next->op_flags & OPf_STACKED))
6388 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6389 o->op_type = OP_RCATLINE;
6390 o->op_flags |= OPf_STACKED;
6391 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6392 op_null(o->op_next->op_next);
6393 op_null(o->op_next);
6396 o->op_seq = PL_op_seqmax++;
6409 o->op_seq = PL_op_seqmax++;
6410 while (cLOGOP->op_other->op_type == OP_NULL)
6411 cLOGOP->op_other = cLOGOP->op_other->op_next;
6412 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6417 o->op_seq = PL_op_seqmax++;
6418 while (cLOOP->op_redoop->op_type == OP_NULL)
6419 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6420 peep(cLOOP->op_redoop);
6421 while (cLOOP->op_nextop->op_type == OP_NULL)
6422 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6423 peep(cLOOP->op_nextop);
6424 while (cLOOP->op_lastop->op_type == OP_NULL)
6425 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6426 peep(cLOOP->op_lastop);
6432 o->op_seq = PL_op_seqmax++;
6433 while (cPMOP->op_pmreplstart &&
6434 cPMOP->op_pmreplstart->op_type == OP_NULL)
6435 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6436 peep(cPMOP->op_pmreplstart);
6440 o->op_seq = PL_op_seqmax++;
6441 if (ckWARN(WARN_SYNTAX) && o->op_next
6442 && o->op_next->op_type == OP_NEXTSTATE) {
6443 if (o->op_next->op_sibling &&
6444 o->op_next->op_sibling->op_type != OP_EXIT &&
6445 o->op_next->op_sibling->op_type != OP_WARN &&
6446 o->op_next->op_sibling->op_type != OP_DIE) {
6447 line_t oldline = CopLINE(PL_curcop);
6449 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6450 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6451 "Statement unlikely to be reached");
6452 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6453 "\t(Maybe you meant system() when you said exec()?)\n");
6454 CopLINE_set(PL_curcop, oldline);
6465 o->op_seq = PL_op_seqmax++;
6467 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6470 /* Make the CONST have a shared SV */
6471 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6472 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6473 key = SvPV(sv, keylen);
6474 lexname = newSVpvn_share(key,
6475 SvUTF8(sv) ? -(I32)keylen : keylen,
6484 o->op_seq = PL_op_seqmax++;
6494 char* Perl_custom_op_name(pTHX_ OP* o)
6496 IV index = PTR2IV(o->op_ppaddr);
6500 if (!PL_custom_op_names) /* This probably shouldn't happen */
6501 return PL_op_name[OP_CUSTOM];
6503 keysv = sv_2mortal(newSViv(index));
6505 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
6507 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
6509 return SvPV_nolen(HeVAL(he));
6512 char* Perl_custom_op_desc(pTHX_ OP* o)
6514 IV index = PTR2IV(o->op_ppaddr);
6518 if (!PL_custom_op_descs)
6519 return PL_op_desc[OP_CUSTOM];
6521 keysv = sv_2mortal(newSViv(index));
6523 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
6525 return PL_op_desc[OP_CUSTOM];
6527 return SvPV_nolen(HeVAL(he));
6533 /* Efficient sub that returns a constant scalar value. */
6535 const_sv_xsub(pTHX_ CV* cv)
6540 Perl_croak(aTHX_ "usage: %s::%s()",
6541 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
6545 ST(0) = (SV*)XSANY.any_ptr;