3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 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 $<special_var>" etc etc */
159 if (!(PL_in_my == KEY_our ||
161 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
162 (name[1] == '_' && (*name == '$' || (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_static)
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)))
278 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
279 /* not an OP_PADAV replacement */
281 if (cPADOPo->op_padix > 0) {
282 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
283 * may still exist on the pad */
284 pad_swipe(cPADOPo->op_padix, TRUE);
285 cPADOPo->op_padix = 0;
288 SvREFCNT_dec(cSVOPo->op_sv);
289 cSVOPo->op_sv = Nullsv;
293 case OP_METHOD_NAMED:
295 SvREFCNT_dec(cSVOPo->op_sv);
296 cSVOPo->op_sv = Nullsv;
299 Even if op_clear does a pad_free for the target of the op,
300 pad_free doesn't actually remove the sv that exists in the pad;
301 instead it lives on. This results in that it could be reused as
302 a target later on when the pad was reallocated.
305 pad_swipe(o->op_targ,1);
314 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
318 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
319 SvREFCNT_dec(cSVOPo->op_sv);
320 cSVOPo->op_sv = Nullsv;
323 Safefree(cPVOPo->op_pv);
324 cPVOPo->op_pv = Nullch;
328 op_free(cPMOPo->op_pmreplroot);
332 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
333 /* No GvIN_PAD_off here, because other references may still
334 * exist on the pad */
335 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
338 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
345 HV *pmstash = PmopSTASH(cPMOPo);
346 if (pmstash && SvREFCNT(pmstash)) {
347 PMOP *pmop = HvPMROOT(pmstash);
348 PMOP *lastpmop = NULL;
350 if (cPMOPo == pmop) {
352 lastpmop->op_pmnext = pmop->op_pmnext;
354 HvPMROOT(pmstash) = pmop->op_pmnext;
358 pmop = pmop->op_pmnext;
361 PmopSTASH_free(cPMOPo);
363 cPMOPo->op_pmreplroot = Nullop;
364 /* we use the "SAFE" version of the PM_ macros here
365 * since sv_clean_all might release some PMOPs
366 * after PL_regex_padav has been cleared
367 * and the clearing of PL_regex_padav needs to
368 * happen before sv_clean_all
370 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
371 PM_SETRE_SAFE(cPMOPo, (REGEXP*)NULL);
373 if(PL_regex_pad) { /* We could be in destruction */
374 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
375 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
376 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
383 if (o->op_targ > 0) {
384 pad_free(o->op_targ);
390 S_cop_free(pTHX_ COP* cop)
392 Safefree(cop->cop_label); /* FIXME: treaddead ??? */
395 if (! specialWARN(cop->cop_warnings))
396 SvREFCNT_dec(cop->cop_warnings);
397 if (! specialCopIO(cop->cop_io)) {
401 char *s = SvPV(cop->cop_io,len);
402 Perl_warn(aTHX_ "io='%.*s'",(int) len,s); /* ??? --jhi */
405 SvREFCNT_dec(cop->cop_io);
411 Perl_op_null(pTHX_ OP *o)
413 if (o->op_type == OP_NULL)
416 o->op_targ = o->op_type;
417 o->op_type = OP_NULL;
418 o->op_ppaddr = PL_ppaddr[OP_NULL];
421 /* Contextualizers */
423 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
426 Perl_linklist(pTHX_ OP *o)
433 /* establish postfix order */
434 if (cUNOPo->op_first) {
435 o->op_next = LINKLIST(cUNOPo->op_first);
436 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
438 kid->op_next = LINKLIST(kid->op_sibling);
450 Perl_scalarkids(pTHX_ OP *o)
453 if (o && o->op_flags & OPf_KIDS) {
454 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
461 S_scalarboolean(pTHX_ OP *o)
463 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
464 if (ckWARN(WARN_SYNTAX)) {
465 line_t oldline = CopLINE(PL_curcop);
467 if (PL_copline != NOLINE)
468 CopLINE_set(PL_curcop, PL_copline);
469 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
470 CopLINE_set(PL_curcop, oldline);
477 Perl_scalar(pTHX_ OP *o)
481 /* assumes no premature commitment */
482 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
483 || o->op_type == OP_RETURN)
488 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
490 switch (o->op_type) {
492 scalar(cBINOPo->op_first);
497 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
501 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
502 if (!kPMOP->op_pmreplroot)
503 deprecate_old("implicit split to @_");
511 if (o->op_flags & OPf_KIDS) {
512 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
518 kid = cLISTOPo->op_first;
520 while ((kid = kid->op_sibling)) {
526 WITH_THR(PL_curcop = &PL_compiling);
531 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
537 WITH_THR(PL_curcop = &PL_compiling);
540 if (ckWARN(WARN_VOID))
541 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
547 Perl_scalarvoid(pTHX_ OP *o)
554 if (o->op_type == OP_NEXTSTATE
555 || o->op_type == OP_SETSTATE
556 || o->op_type == OP_DBSTATE
557 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
558 || o->op_targ == OP_SETSTATE
559 || o->op_targ == OP_DBSTATE)))
560 PL_curcop = (COP*)o; /* for warning below */
562 /* assumes no premature commitment */
563 want = o->op_flags & OPf_WANT;
564 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
565 || o->op_type == OP_RETURN)
570 if ((o->op_private & OPpTARGET_MY)
571 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
573 return scalar(o); /* As if inside SASSIGN */
576 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
578 switch (o->op_type) {
580 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
584 if (o->op_flags & OPf_STACKED)
588 if (o->op_private == 4)
660 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
661 useless = OP_DESC(o);
668 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
669 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
670 useless = "a variable";
675 if (cSVOPo->op_private & OPpCONST_STRICT)
676 no_bareword_allowed(o);
678 if (ckWARN(WARN_VOID)) {
679 useless = "a constant";
680 /* don't warn on optimised away booleans, eg
681 * use constant Foo, 5; Foo || print; */
682 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
684 /* the constants 0 and 1 are permitted as they are
685 conventionally used as dummies in constructs like
686 1 while some_condition_with_side_effects; */
687 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
689 else if (SvPOK(sv)) {
690 /* perl4's way of mixing documentation and code
691 (before the invention of POD) was based on a
692 trick to mix nroff and perl code. The trick was
693 built upon these three nroff macros being used in
694 void context. The pink camel has the details in
695 the script wrapman near page 319. */
696 if (strnEQ(SvPVX(sv), "di", 2) ||
697 strnEQ(SvPVX(sv), "ds", 2) ||
698 strnEQ(SvPVX(sv), "ig", 2))
703 op_null(o); /* don't execute or even remember it */
707 o->op_type = OP_PREINC; /* pre-increment is faster */
708 o->op_ppaddr = PL_ppaddr[OP_PREINC];
712 o->op_type = OP_PREDEC; /* pre-decrement is faster */
713 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
720 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
725 if (o->op_flags & OPf_STACKED)
732 if (!(o->op_flags & OPf_KIDS))
741 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
748 /* all requires must return a boolean value */
749 o->op_flags &= ~OPf_WANT;
754 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
755 if (!kPMOP->op_pmreplroot)
756 deprecate_old("implicit split to @_");
760 if (useless && ckWARN(WARN_VOID))
761 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
766 Perl_listkids(pTHX_ OP *o)
769 if (o && o->op_flags & OPf_KIDS) {
770 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
777 Perl_list(pTHX_ OP *o)
781 /* assumes no premature commitment */
782 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
783 || o->op_type == OP_RETURN)
788 if ((o->op_private & OPpTARGET_MY)
789 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
791 return o; /* As if inside SASSIGN */
794 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
796 switch (o->op_type) {
799 list(cBINOPo->op_first);
804 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
812 if (!(o->op_flags & OPf_KIDS))
814 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
815 list(cBINOPo->op_first);
816 return gen_constant_list(o);
823 kid = cLISTOPo->op_first;
825 while ((kid = kid->op_sibling)) {
831 WITH_THR(PL_curcop = &PL_compiling);
835 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
841 WITH_THR(PL_curcop = &PL_compiling);
844 /* all requires must return a boolean value */
845 o->op_flags &= ~OPf_WANT;
852 Perl_scalarseq(pTHX_ OP *o)
857 if (o->op_type == OP_LINESEQ ||
858 o->op_type == OP_SCOPE ||
859 o->op_type == OP_LEAVE ||
860 o->op_type == OP_LEAVETRY)
862 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
863 if (kid->op_sibling) {
867 PL_curcop = &PL_compiling;
869 o->op_flags &= ~OPf_PARENS;
870 if (PL_hints & HINT_BLOCK_SCOPE)
871 o->op_flags |= OPf_PARENS;
874 o = newOP(OP_STUB, 0);
879 S_modkids(pTHX_ OP *o, I32 type)
882 if (o && o->op_flags & OPf_KIDS) {
883 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
889 /* Propagate lvalue ("modifiable") context to an op and it's children.
890 * 'type' represents the context type, roughly based on the type of op that
891 * would do the modifying, although local() is represented by OP_NULL.
892 * It's responsible for detecting things that can't be modified, flag
893 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
894 * might have to vivify a reference in $x), and so on.
896 * For example, "$a+1 = 2" would cause mod() to be called with o being
897 * OP_ADD and type being OP_SASSIGN, and would output an error.
901 Perl_mod(pTHX_ OP *o, I32 type)
904 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
907 if (!o || PL_error_count)
910 if ((o->op_private & OPpTARGET_MY)
911 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
916 switch (o->op_type) {
922 if (!(o->op_private & (OPpCONST_ARYBASE)))
924 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
925 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
929 SAVEI32(PL_compiling.cop_arybase);
930 PL_compiling.cop_arybase = 0;
932 else if (type == OP_REFGEN)
935 Perl_croak(aTHX_ "That use of $[ is unsupported");
938 if (o->op_flags & OPf_PARENS)
942 if ((type == OP_UNDEF || type == OP_REFGEN) &&
943 !(o->op_flags & OPf_STACKED)) {
944 o->op_type = OP_RV2CV; /* entersub => rv2cv */
945 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
946 assert(cUNOPo->op_first->op_type == OP_NULL);
947 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
950 else if (o->op_private & OPpENTERSUB_NOMOD)
952 else { /* lvalue subroutine call */
953 o->op_private |= OPpLVAL_INTRO;
954 PL_modcount = RETURN_UNLIMITED_NUMBER;
955 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
956 /* Backward compatibility mode: */
957 o->op_private |= OPpENTERSUB_INARGS;
960 else { /* Compile-time error message: */
961 OP *kid = cUNOPo->op_first;
965 if (kid->op_type == OP_PUSHMARK)
967 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
969 "panic: unexpected lvalue entersub "
970 "args: type/targ %ld:%"UVuf,
971 (long)kid->op_type, (UV)kid->op_targ);
972 kid = kLISTOP->op_first;
974 while (kid->op_sibling)
975 kid = kid->op_sibling;
976 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
978 if (kid->op_type == OP_METHOD_NAMED
979 || kid->op_type == OP_METHOD)
983 NewOp(1101, newop, 1, UNOP);
984 newop->op_type = OP_RV2CV;
985 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
986 newop->op_first = Nullop;
987 newop->op_next = (OP*)newop;
988 kid->op_sibling = (OP*)newop;
989 newop->op_private |= OPpLVAL_INTRO;
993 if (kid->op_type != OP_RV2CV)
995 "panic: unexpected lvalue entersub "
996 "entry via type/targ %ld:%"UVuf,
997 (long)kid->op_type, (UV)kid->op_targ);
998 kid->op_private |= OPpLVAL_INTRO;
999 break; /* Postpone until runtime */
1003 kid = kUNOP->op_first;
1004 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1005 kid = kUNOP->op_first;
1006 if (kid->op_type == OP_NULL)
1008 "Unexpected constant lvalue entersub "
1009 "entry via type/targ %ld:%"UVuf,
1010 (long)kid->op_type, (UV)kid->op_targ);
1011 if (kid->op_type != OP_GV) {
1012 /* Restore RV2CV to check lvalueness */
1014 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1015 okid->op_next = kid->op_next;
1016 kid->op_next = okid;
1019 okid->op_next = Nullop;
1020 okid->op_type = OP_RV2CV;
1022 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1023 okid->op_private |= OPpLVAL_INTRO;
1027 cv = GvCV(kGVOP_gv);
1037 /* grep, foreach, subcalls, refgen */
1038 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1040 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1041 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1043 : (o->op_type == OP_ENTERSUB
1044 ? "non-lvalue subroutine call"
1046 type ? PL_op_desc[type] : "local"));
1060 case OP_RIGHT_SHIFT:
1069 if (!(o->op_flags & OPf_STACKED))
1076 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1082 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1083 PL_modcount = RETURN_UNLIMITED_NUMBER;
1084 return o; /* Treat \(@foo) like ordinary list. */
1088 if (scalar_mod_type(o, type))
1090 ref(cUNOPo->op_first, o->op_type);
1094 if (type == OP_LEAVESUBLV)
1095 o->op_private |= OPpMAYBE_LVSUB;
1101 PL_modcount = RETURN_UNLIMITED_NUMBER;
1104 ref(cUNOPo->op_first, o->op_type);
1109 PL_hints |= HINT_BLOCK_SCOPE;
1124 PL_modcount = RETURN_UNLIMITED_NUMBER;
1125 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1126 return o; /* Treat \(@foo) like ordinary list. */
1127 if (scalar_mod_type(o, type))
1129 if (type == OP_LEAVESUBLV)
1130 o->op_private |= OPpMAYBE_LVSUB;
1134 if (!type) /* local() */
1135 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1136 PAD_COMPNAME_PV(o->op_targ));
1144 if (type != OP_SASSIGN)
1148 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1153 if (type == OP_LEAVESUBLV)
1154 o->op_private |= OPpMAYBE_LVSUB;
1156 pad_free(o->op_targ);
1157 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1158 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1159 if (o->op_flags & OPf_KIDS)
1160 mod(cBINOPo->op_first->op_sibling, type);
1165 ref(cBINOPo->op_first, o->op_type);
1166 if (type == OP_ENTERSUB &&
1167 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1168 o->op_private |= OPpLVAL_DEFER;
1169 if (type == OP_LEAVESUBLV)
1170 o->op_private |= OPpMAYBE_LVSUB;
1180 if (o->op_flags & OPf_KIDS)
1181 mod(cLISTOPo->op_last, type);
1186 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1188 else if (!(o->op_flags & OPf_KIDS))
1190 if (o->op_targ != OP_LIST) {
1191 mod(cBINOPo->op_first, type);
1197 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1202 if (type != OP_LEAVESUBLV)
1204 break; /* mod()ing was handled by ck_return() */
1207 /* [20011101.069] File test operators interpret OPf_REF to mean that
1208 their argument is a filehandle; thus \stat(".") should not set
1210 if (type == OP_REFGEN &&
1211 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1214 if (type != OP_LEAVESUBLV)
1215 o->op_flags |= OPf_MOD;
1217 if (type == OP_AASSIGN || type == OP_SASSIGN)
1218 o->op_flags |= OPf_SPECIAL|OPf_REF;
1219 else if (!type) { /* local() */
1222 o->op_private |= OPpLVAL_INTRO;
1223 o->op_flags &= ~OPf_SPECIAL;
1224 PL_hints |= HINT_BLOCK_SCOPE;
1229 if (ckWARN(WARN_SYNTAX)) {
1230 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1231 "Useless localization of %s", OP_DESC(o));
1235 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1236 && type != OP_LEAVESUBLV)
1237 o->op_flags |= OPf_REF;
1242 S_scalar_mod_type(pTHX_ OP *o, I32 type)
1246 if (o->op_type == OP_RV2GV)
1270 case OP_RIGHT_SHIFT:
1289 S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
1291 switch (o->op_type) {
1299 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1312 Perl_refkids(pTHX_ OP *o, I32 type)
1315 if (o && o->op_flags & OPf_KIDS) {
1316 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1323 Perl_ref(pTHX_ OP *o, I32 type)
1327 if (!o || PL_error_count)
1330 switch (o->op_type) {
1332 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1333 !(o->op_flags & OPf_STACKED)) {
1334 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1335 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1336 assert(cUNOPo->op_first->op_type == OP_NULL);
1337 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1338 o->op_flags |= OPf_SPECIAL;
1343 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1347 if (type == OP_DEFINED)
1348 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1349 ref(cUNOPo->op_first, o->op_type);
1352 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1353 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1354 : type == OP_RV2HV ? OPpDEREF_HV
1356 o->op_flags |= OPf_MOD;
1361 o->op_flags |= OPf_MOD; /* XXX ??? */
1366 o->op_flags |= OPf_REF;
1369 if (type == OP_DEFINED)
1370 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1371 ref(cUNOPo->op_first, o->op_type);
1376 o->op_flags |= OPf_REF;
1381 if (!(o->op_flags & OPf_KIDS))
1383 ref(cBINOPo->op_first, type);
1387 ref(cBINOPo->op_first, o->op_type);
1388 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1389 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1390 : type == OP_RV2HV ? OPpDEREF_HV
1392 o->op_flags |= OPf_MOD;
1400 if (!(o->op_flags & OPf_KIDS))
1402 ref(cLISTOPo->op_last, type);
1412 S_dup_attrlist(pTHX_ OP *o)
1416 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1417 * where the first kid is OP_PUSHMARK and the remaining ones
1418 * are OP_CONST. We need to push the OP_CONST values.
1420 if (o->op_type == OP_CONST)
1421 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1423 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1424 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1425 if (o->op_type == OP_CONST)
1426 rop = append_elem(OP_LIST, rop,
1427 newSVOP(OP_CONST, o->op_flags,
1428 SvREFCNT_inc(cSVOPo->op_sv)));
1435 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1439 /* fake up C<use attributes $pkg,$rv,@attrs> */
1440 ENTER; /* need to protect against side-effects of 'use' */
1443 stashsv = newSVpv(HvNAME(stash), 0);
1445 stashsv = &PL_sv_no;
1447 #define ATTRSMODULE "attributes"
1448 #define ATTRSMODULE_PM "attributes.pm"
1452 /* Don't force the C<use> if we don't need it. */
1453 svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
1454 sizeof(ATTRSMODULE_PM)-1, 0);
1455 if (svp && *svp != &PL_sv_undef)
1456 ; /* already in %INC */
1458 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1459 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1463 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1464 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1466 prepend_elem(OP_LIST,
1467 newSVOP(OP_CONST, 0, stashsv),
1468 prepend_elem(OP_LIST,
1469 newSVOP(OP_CONST, 0,
1471 dup_attrlist(attrs))));
1477 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1479 OP *pack, *imop, *arg;
1485 assert(target->op_type == OP_PADSV ||
1486 target->op_type == OP_PADHV ||
1487 target->op_type == OP_PADAV);
1489 /* Ensure that attributes.pm is loaded. */
1490 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1492 /* Need package name for method call. */
1493 pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
1495 /* Build up the real arg-list. */
1497 stashsv = newSVpv(HvNAME(stash), 0);
1499 stashsv = &PL_sv_no;
1500 arg = newOP(OP_PADSV, 0);
1501 arg->op_targ = target->op_targ;
1502 arg = prepend_elem(OP_LIST,
1503 newSVOP(OP_CONST, 0, stashsv),
1504 prepend_elem(OP_LIST,
1505 newUNOP(OP_REFGEN, 0,
1506 mod(arg, OP_REFGEN)),
1507 dup_attrlist(attrs)));
1509 /* Fake up a method call to import */
1510 meth = newSVpvn("import", 6);
1511 (void)SvUPGRADE(meth, SVt_PVIV);
1512 (void)SvIOK_on(meth);
1513 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
1514 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1515 append_elem(OP_LIST,
1516 prepend_elem(OP_LIST, pack, list(arg)),
1517 newSVOP(OP_METHOD_NAMED, 0, meth)));
1518 imop->op_private |= OPpENTERSUB_NOMOD;
1520 /* Combine the ops. */
1521 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1525 =notfor apidoc apply_attrs_string
1527 Attempts to apply a list of attributes specified by the C<attrstr> and
1528 C<len> arguments to the subroutine identified by the C<cv> argument which
1529 is expected to be associated with the package identified by the C<stashpv>
1530 argument (see L<attributes>). It gets this wrong, though, in that it
1531 does not correctly identify the boundaries of the individual attribute
1532 specifications within C<attrstr>. This is not really intended for the
1533 public API, but has to be listed here for systems such as AIX which
1534 need an explicit export list for symbols. (It's called from XS code
1535 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1536 to respect attribute syntax properly would be welcome.
1542 Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
1543 char *attrstr, STRLEN len)
1548 len = strlen(attrstr);
1552 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1554 char *sstr = attrstr;
1555 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1556 attrs = append_elem(OP_LIST, attrs,
1557 newSVOP(OP_CONST, 0,
1558 newSVpvn(sstr, attrstr-sstr)));
1562 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1563 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1564 Nullsv, prepend_elem(OP_LIST,
1565 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1566 prepend_elem(OP_LIST,
1567 newSVOP(OP_CONST, 0,
1573 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1578 if (!o || PL_error_count)
1582 if (type == OP_LIST) {
1583 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1584 my_kid(kid, attrs, imopsp);
1585 } else if (type == OP_UNDEF) {
1587 } else if (type == OP_RV2SV || /* "our" declaration */
1589 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1590 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1591 yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
1592 OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
1594 GV *gv = cGVOPx_gv(cUNOPo->op_first);
1596 PL_in_my_stash = Nullhv;
1597 apply_attrs(GvSTASH(gv),
1598 (type == OP_RV2SV ? GvSV(gv) :
1599 type == OP_RV2AV ? (SV*)GvAV(gv) :
1600 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1603 o->op_private |= OPpOUR_INTRO;
1606 else if (type != OP_PADSV &&
1609 type != OP_PUSHMARK)
1611 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1613 PL_in_my == KEY_our ? "our" : "my"));
1616 else if (attrs && type != OP_PUSHMARK) {
1620 PL_in_my_stash = Nullhv;
1622 /* check for C<my Dog $spot> when deciding package */
1623 stash = PAD_COMPNAME_TYPE(o->op_targ);
1625 stash = PL_curstash;
1626 apply_attrs_my(stash, o, attrs, imopsp);
1628 o->op_flags |= OPf_MOD;
1629 o->op_private |= OPpLVAL_INTRO;
1634 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1637 int maybe_scalar = 0;
1639 /* [perl #17376]: this appears to be premature, and results in code such as
1640 C< our(%x); > executing in list mode rather than void mode */
1642 if (o->op_flags & OPf_PARENS)
1651 o = my_kid(o, attrs, &rops);
1653 if (maybe_scalar && o->op_type == OP_PADSV) {
1654 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1655 o->op_private |= OPpLVAL_INTRO;
1658 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1661 PL_in_my_stash = Nullhv;
1666 Perl_my(pTHX_ OP *o)
1668 return my_attrs(o, Nullop);
1672 Perl_sawparens(pTHX_ OP *o)
1675 o->op_flags |= OPf_PARENS;
1680 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1685 if (ckWARN(WARN_MISC) &&
1686 (left->op_type == OP_RV2AV ||
1687 left->op_type == OP_RV2HV ||
1688 left->op_type == OP_PADAV ||
1689 left->op_type == OP_PADHV)) {
1690 char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
1691 right->op_type == OP_TRANS)
1692 ? right->op_type : OP_MATCH];
1693 const char *sample = ((left->op_type == OP_RV2AV ||
1694 left->op_type == OP_PADAV)
1695 ? "@array" : "%hash");
1696 Perl_warner(aTHX_ packWARN(WARN_MISC),
1697 "Applying %s to %s will act on scalar(%s)",
1698 desc, sample, sample);
1701 if (right->op_type == OP_CONST &&
1702 cSVOPx(right)->op_private & OPpCONST_BARE &&
1703 cSVOPx(right)->op_private & OPpCONST_STRICT)
1705 no_bareword_allowed(right);
1708 ismatchop = right->op_type == OP_MATCH ||
1709 right->op_type == OP_SUBST ||
1710 right->op_type == OP_TRANS;
1711 if (ismatchop && right->op_private & OPpTARGET_MY) {
1713 right->op_private &= ~OPpTARGET_MY;
1715 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1716 right->op_flags |= OPf_STACKED;
1717 if (right->op_type != OP_MATCH &&
1718 ! (right->op_type == OP_TRANS &&
1719 right->op_private & OPpTRANS_IDENTICAL))
1720 left = mod(left, right->op_type);
1721 if (right->op_type == OP_TRANS)
1722 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
1724 o = prepend_elem(right->op_type, scalar(left), right);
1726 return newUNOP(OP_NOT, 0, scalar(o));
1730 return bind_match(type, left,
1731 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
1735 Perl_invert(pTHX_ OP *o)
1739 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
1740 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1744 Perl_scope(pTHX_ OP *o)
1747 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1748 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1749 o->op_type = OP_LEAVE;
1750 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1752 else if (o->op_type == OP_LINESEQ) {
1754 o->op_type = OP_SCOPE;
1755 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1756 kid = ((LISTOP*)o)->op_first;
1757 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
1761 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
1767 Perl_save_hints(pTHX)
1770 SAVESPTR(GvHV(PL_hintgv));
1771 GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
1772 SAVEFREESV(GvHV(PL_hintgv));
1776 Perl_block_start(pTHX_ int full)
1778 int retval = PL_savestack_ix;
1779 pad_block_start(full);
1781 PL_hints &= ~HINT_BLOCK_SCOPE;
1782 SAVESPTR(PL_compiling.cop_warnings);
1783 if (! specialWARN(PL_compiling.cop_warnings)) {
1784 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1785 SAVEFREESV(PL_compiling.cop_warnings) ;
1787 SAVESPTR(PL_compiling.cop_io);
1788 if (! specialCopIO(PL_compiling.cop_io)) {
1789 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1790 SAVEFREESV(PL_compiling.cop_io) ;
1796 Perl_block_end(pTHX_ I32 floor, OP *seq)
1798 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1799 OP* retval = scalarseq(seq);
1801 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
1803 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
1811 I32 offset = pad_findmy("$_");
1812 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
1813 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1816 OP *o = newOP(OP_PADSV, 0);
1817 o->op_targ = offset;
1823 Perl_newPROG(pTHX_ OP *o)
1828 PL_eval_root = newUNOP(OP_LEAVEEVAL,
1829 ((PL_in_eval & EVAL_KEEPERR)
1830 ? OPf_SPECIAL : 0), o);
1831 PL_eval_start = linklist(PL_eval_root);
1832 PL_eval_root->op_private |= OPpREFCOUNTED;
1833 OpREFCNT_set(PL_eval_root, 1);
1834 PL_eval_root->op_next = 0;
1835 CALL_PEEP(PL_eval_start);
1838 if (o->op_type == OP_STUB) {
1839 PL_comppad_name = 0;
1844 PL_main_root = scope(sawparens(scalarvoid(o)));
1845 PL_curcop = &PL_compiling;
1846 PL_main_start = LINKLIST(PL_main_root);
1847 PL_main_root->op_private |= OPpREFCOUNTED;
1848 OpREFCNT_set(PL_main_root, 1);
1849 PL_main_root->op_next = 0;
1850 CALL_PEEP(PL_main_start);
1853 /* Register with debugger */
1855 CV *cv = get_cv("DB::postponed", FALSE);
1859 XPUSHs((SV*)CopFILEGV(&PL_compiling));
1861 call_sv((SV*)cv, G_DISCARD);
1868 Perl_localize(pTHX_ OP *o, I32 lex)
1870 if (o->op_flags & OPf_PARENS)
1871 /* [perl #17376]: this appears to be premature, and results in code such as
1872 C< our(%x); > executing in list mode rather than void mode */
1879 if (ckWARN(WARN_PARENTHESIS)
1880 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
1882 char *s = PL_bufptr;
1885 /* some heuristics to detect a potential error */
1886 while (*s && (strchr(", \t\n", *s)))
1890 if (*s && strchr("@$%*", *s) && *++s
1891 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
1894 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
1896 while (*s && (strchr(", \t\n", *s)))
1902 if (sigil && (*s == ';' || *s == '=')) {
1903 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
1904 "Parentheses missing around \"%s\" list",
1905 lex ? (PL_in_my == KEY_our ? "our" : "my")
1913 o = mod(o, OP_NULL); /* a bit kludgey */
1915 PL_in_my_stash = Nullhv;
1920 Perl_jmaybe(pTHX_ OP *o)
1922 if (o->op_type == OP_LIST) {
1924 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
1925 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
1931 Perl_fold_constants(pTHX_ register OP *o)
1934 I32 type = o->op_type;
1937 if (PL_opargs[type] & OA_RETSCALAR)
1939 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
1940 o->op_targ = pad_alloc(type, SVs_PADTMP);
1942 /* integerize op, unless it happens to be C<-foo>.
1943 * XXX should pp_i_negate() do magic string negation instead? */
1944 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
1945 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
1946 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
1948 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
1951 if (!(PL_opargs[type] & OA_FOLDCONST))
1956 /* XXX might want a ck_negate() for this */
1957 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
1969 /* XXX what about the numeric ops? */
1970 if (PL_hints & HINT_LOCALE)
1975 goto nope; /* Don't try to run w/ errors */
1977 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
1978 if ((curop->op_type != OP_CONST ||
1979 (curop->op_private & OPpCONST_BARE)) &&
1980 curop->op_type != OP_LIST &&
1981 curop->op_type != OP_SCALAR &&
1982 curop->op_type != OP_NULL &&
1983 curop->op_type != OP_PUSHMARK)
1989 curop = LINKLIST(o);
1993 sv = *(PL_stack_sp--);
1994 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
1995 pad_swipe(o->op_targ, FALSE);
1996 else if (SvTEMP(sv)) { /* grab mortal temp? */
1997 (void)SvREFCNT_inc(sv);
2001 if (type == OP_RV2GV)
2002 return newGVOP(OP_GV, 0, (GV*)sv);
2003 return newSVOP(OP_CONST, 0, sv);
2010 Perl_gen_constant_list(pTHX_ register OP *o)
2013 I32 oldtmps_floor = PL_tmps_floor;
2017 return o; /* Don't attempt to run with errors */
2019 PL_op = curop = LINKLIST(o);
2026 PL_tmps_floor = oldtmps_floor;
2028 o->op_type = OP_RV2AV;
2029 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2030 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2031 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2032 o->op_opt = 0; /* needs to be revisited in peep() */
2033 curop = ((UNOP*)o)->op_first;
2034 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2041 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2043 if (!o || o->op_type != OP_LIST)
2044 o = newLISTOP(OP_LIST, 0, o, Nullop);
2046 o->op_flags &= ~OPf_WANT;
2048 if (!(PL_opargs[type] & OA_MARK))
2049 op_null(cLISTOPo->op_first);
2051 o->op_type = (OPCODE)type;
2052 o->op_ppaddr = PL_ppaddr[type];
2053 o->op_flags |= flags;
2055 o = CHECKOP(type, o);
2056 if (o->op_type != type)
2059 return fold_constants(o);
2062 /* List constructors */
2065 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2073 if (first->op_type != type
2074 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2076 return newLISTOP(type, 0, first, last);
2079 if (first->op_flags & OPf_KIDS)
2080 ((LISTOP*)first)->op_last->op_sibling = last;
2082 first->op_flags |= OPf_KIDS;
2083 ((LISTOP*)first)->op_first = last;
2085 ((LISTOP*)first)->op_last = last;
2090 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2098 if (first->op_type != type)
2099 return prepend_elem(type, (OP*)first, (OP*)last);
2101 if (last->op_type != type)
2102 return append_elem(type, (OP*)first, (OP*)last);
2104 first->op_last->op_sibling = last->op_first;
2105 first->op_last = last->op_last;
2106 first->op_flags |= (last->op_flags & OPf_KIDS);
2114 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2122 if (last->op_type == type) {
2123 if (type == OP_LIST) { /* already a PUSHMARK there */
2124 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2125 ((LISTOP*)last)->op_first->op_sibling = first;
2126 if (!(first->op_flags & OPf_PARENS))
2127 last->op_flags &= ~OPf_PARENS;
2130 if (!(last->op_flags & OPf_KIDS)) {
2131 ((LISTOP*)last)->op_last = first;
2132 last->op_flags |= OPf_KIDS;
2134 first->op_sibling = ((LISTOP*)last)->op_first;
2135 ((LISTOP*)last)->op_first = first;
2137 last->op_flags |= OPf_KIDS;
2141 return newLISTOP(type, 0, first, last);
2147 Perl_newNULLLIST(pTHX)
2149 return newOP(OP_STUB, 0);
2153 Perl_force_list(pTHX_ OP *o)
2155 if (!o || o->op_type != OP_LIST)
2156 o = newLISTOP(OP_LIST, 0, o, Nullop);
2162 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2166 NewOp(1101, listop, 1, LISTOP);
2168 listop->op_type = (OPCODE)type;
2169 listop->op_ppaddr = PL_ppaddr[type];
2172 listop->op_flags = (U8)flags;
2176 else if (!first && last)
2179 first->op_sibling = last;
2180 listop->op_first = first;
2181 listop->op_last = last;
2182 if (type == OP_LIST) {
2184 pushop = newOP(OP_PUSHMARK, 0);
2185 pushop->op_sibling = first;
2186 listop->op_first = pushop;
2187 listop->op_flags |= OPf_KIDS;
2189 listop->op_last = pushop;
2192 return CHECKOP(type, listop);
2196 Perl_newOP(pTHX_ I32 type, I32 flags)
2199 NewOp(1101, o, 1, OP);
2200 o->op_type = (OPCODE)type;
2201 o->op_ppaddr = PL_ppaddr[type];
2202 o->op_flags = (U8)flags;
2205 o->op_private = (U8)(0 | (flags >> 8));
2206 if (PL_opargs[type] & OA_RETSCALAR)
2208 if (PL_opargs[type] & OA_TARGET)
2209 o->op_targ = pad_alloc(type, SVs_PADTMP);
2210 return CHECKOP(type, o);
2214 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2219 first = newOP(OP_STUB, 0);
2220 if (PL_opargs[type] & OA_MARK)
2221 first = force_list(first);
2223 NewOp(1101, unop, 1, UNOP);
2224 unop->op_type = (OPCODE)type;
2225 unop->op_ppaddr = PL_ppaddr[type];
2226 unop->op_first = first;
2227 unop->op_flags = flags | OPf_KIDS;
2228 unop->op_private = (U8)(1 | (flags >> 8));
2229 unop = (UNOP*) CHECKOP(type, unop);
2233 return fold_constants((OP *) unop);
2237 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2240 NewOp(1101, binop, 1, BINOP);
2243 first = newOP(OP_NULL, 0);
2245 binop->op_type = (OPCODE)type;
2246 binop->op_ppaddr = PL_ppaddr[type];
2247 binop->op_first = first;
2248 binop->op_flags = flags | OPf_KIDS;
2251 binop->op_private = (U8)(1 | (flags >> 8));
2254 binop->op_private = (U8)(2 | (flags >> 8));
2255 first->op_sibling = last;
2258 binop = (BINOP*)CHECKOP(type, binop);
2259 if (binop->op_next || binop->op_type != (OPCODE)type)
2262 binop->op_last = binop->op_first->op_sibling;
2264 return fold_constants((OP *)binop);
2268 uvcompare(const void *a, const void *b)
2270 if (*((UV *)a) < (*(UV *)b))
2272 if (*((UV *)a) > (*(UV *)b))
2274 if (*((UV *)a+1) < (*(UV *)b+1))
2276 if (*((UV *)a+1) > (*(UV *)b+1))
2282 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2284 SV *tstr = ((SVOP*)expr)->op_sv;
2285 SV *rstr = ((SVOP*)repl)->op_sv;
2288 U8 *t = (U8*)SvPV(tstr, tlen);
2289 U8 *r = (U8*)SvPV(rstr, rlen);
2296 register short *tbl;
2298 PL_hints |= HINT_BLOCK_SCOPE;
2299 complement = o->op_private & OPpTRANS_COMPLEMENT;
2300 del = o->op_private & OPpTRANS_DELETE;
2301 squash = o->op_private & OPpTRANS_SQUASH;
2304 o->op_private |= OPpTRANS_FROM_UTF;
2307 o->op_private |= OPpTRANS_TO_UTF;
2309 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2310 SV* listsv = newSVpvn("# comment\n",10);
2312 U8* tend = t + tlen;
2313 U8* rend = r + rlen;
2327 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2328 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2334 tsave = t = bytes_to_utf8(t, &len);
2337 if (!to_utf && rlen) {
2339 rsave = r = bytes_to_utf8(r, &len);
2343 /* There are several snags with this code on EBCDIC:
2344 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2345 2. scan_const() in toke.c has encoded chars in native encoding which makes
2346 ranges at least in EBCDIC 0..255 range the bottom odd.
2350 U8 tmpbuf[UTF8_MAXLEN+1];
2353 New(1109, cp, 2*tlen, UV);
2355 transv = newSVpvn("",0);
2357 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2359 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2361 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2365 cp[2*i+1] = cp[2*i];
2369 qsort(cp, i, 2*sizeof(UV), uvcompare);
2370 for (j = 0; j < i; j++) {
2372 diff = val - nextmin;
2374 t = uvuni_to_utf8(tmpbuf,nextmin);
2375 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2377 U8 range_mark = UTF_TO_NATIVE(0xff);
2378 t = uvuni_to_utf8(tmpbuf, val - 1);
2379 sv_catpvn(transv, (char *)&range_mark, 1);
2380 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2387 t = uvuni_to_utf8(tmpbuf,nextmin);
2388 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2390 U8 range_mark = UTF_TO_NATIVE(0xff);
2391 sv_catpvn(transv, (char *)&range_mark, 1);
2393 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2394 UNICODE_ALLOW_SUPER);
2395 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2396 t = (U8*)SvPVX(transv);
2397 tlen = SvCUR(transv);
2401 else if (!rlen && !del) {
2402 r = t; rlen = tlen; rend = tend;
2405 if ((!rlen && !del) || t == r ||
2406 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2408 o->op_private |= OPpTRANS_IDENTICAL;
2412 while (t < tend || tfirst <= tlast) {
2413 /* see if we need more "t" chars */
2414 if (tfirst > tlast) {
2415 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2417 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2419 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2426 /* now see if we need more "r" chars */
2427 if (rfirst > rlast) {
2429 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2431 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2433 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2442 rfirst = rlast = 0xffffffff;
2446 /* now see which range will peter our first, if either. */
2447 tdiff = tlast - tfirst;
2448 rdiff = rlast - rfirst;
2455 if (rfirst == 0xffffffff) {
2456 diff = tdiff; /* oops, pretend rdiff is infinite */
2458 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2459 (long)tfirst, (long)tlast);
2461 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2465 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2466 (long)tfirst, (long)(tfirst + diff),
2469 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2470 (long)tfirst, (long)rfirst);
2472 if (rfirst + diff > max)
2473 max = rfirst + diff;
2475 grows = (tfirst < rfirst &&
2476 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2488 else if (max > 0xff)
2493 Safefree(cPVOPo->op_pv);
2494 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2495 SvREFCNT_dec(listsv);
2497 SvREFCNT_dec(transv);
2499 if (!del && havefinal && rlen)
2500 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2501 newSVuv((UV)final), 0);
2504 o->op_private |= OPpTRANS_GROWS;
2516 tbl = (short*)cPVOPo->op_pv;
2518 Zero(tbl, 256, short);
2519 for (i = 0; i < (I32)tlen; i++)
2521 for (i = 0, j = 0; i < 256; i++) {
2523 if (j >= (I32)rlen) {
2532 if (i < 128 && r[j] >= 128)
2542 o->op_private |= OPpTRANS_IDENTICAL;
2544 else if (j >= (I32)rlen)
2547 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2548 tbl[0x100] = rlen - j;
2549 for (i=0; i < (I32)rlen - j; i++)
2550 tbl[0x101+i] = r[j+i];
2554 if (!rlen && !del) {
2557 o->op_private |= OPpTRANS_IDENTICAL;
2559 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2560 o->op_private |= OPpTRANS_IDENTICAL;
2562 for (i = 0; i < 256; i++)
2564 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
2565 if (j >= (I32)rlen) {
2567 if (tbl[t[i]] == -1)
2573 if (tbl[t[i]] == -1) {
2574 if (t[i] < 128 && r[j] >= 128)
2581 o->op_private |= OPpTRANS_GROWS;
2589 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2593 NewOp(1101, pmop, 1, PMOP);
2594 pmop->op_type = (OPCODE)type;
2595 pmop->op_ppaddr = PL_ppaddr[type];
2596 pmop->op_flags = (U8)flags;
2597 pmop->op_private = (U8)(0 | (flags >> 8));
2599 if (PL_hints & HINT_RE_TAINT)
2600 pmop->op_pmpermflags |= PMf_RETAINT;
2601 if (PL_hints & HINT_LOCALE)
2602 pmop->op_pmpermflags |= PMf_LOCALE;
2603 pmop->op_pmflags = pmop->op_pmpermflags;
2608 if(av_len((AV*) PL_regex_pad[0]) > -1) {
2609 repointer = av_pop((AV*)PL_regex_pad[0]);
2610 pmop->op_pmoffset = SvIV(repointer);
2611 SvREPADTMP_off(repointer);
2612 sv_setiv(repointer,0);
2614 repointer = newSViv(0);
2615 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2616 pmop->op_pmoffset = av_len(PL_regex_padav);
2617 PL_regex_pad = AvARRAY(PL_regex_padav);
2622 /* link into pm list */
2623 if (type != OP_TRANS && PL_curstash) {
2624 pmop->op_pmnext = HvPMROOT(PL_curstash);
2625 HvPMROOT(PL_curstash) = pmop;
2626 PmopSTASH_set(pmop,PL_curstash);
2629 return CHECKOP(type, pmop);
2633 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
2637 I32 repl_has_vars = 0;
2639 if (o->op_type == OP_TRANS)
2640 return pmtrans(o, expr, repl);
2642 PL_hints |= HINT_BLOCK_SCOPE;
2645 if (expr->op_type == OP_CONST) {
2647 SV *pat = ((SVOP*)expr)->op_sv;
2648 char *p = SvPV(pat, plen);
2649 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
2650 sv_setpvn(pat, "\\s+", 3);
2651 p = SvPV(pat, plen);
2652 pm->op_pmflags |= PMf_SKIPWHITE;
2655 pm->op_pmdynflags |= PMdf_UTF8;
2656 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
2657 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
2658 pm->op_pmflags |= PMf_WHITE;
2662 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2663 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2665 : OP_REGCMAYBE),0,expr);
2667 NewOp(1101, rcop, 1, LOGOP);
2668 rcop->op_type = OP_REGCOMP;
2669 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2670 rcop->op_first = scalar(expr);
2671 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
2672 ? (OPf_SPECIAL | OPf_KIDS)
2674 rcop->op_private = 1;
2676 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
2679 /* establish postfix order */
2680 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2682 rcop->op_next = expr;
2683 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2686 rcop->op_next = LINKLIST(expr);
2687 expr->op_next = (OP*)rcop;
2690 prepend_elem(o->op_type, scalar((OP*)rcop), o);
2695 if (pm->op_pmflags & PMf_EVAL) {
2697 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
2698 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
2700 else if (repl->op_type == OP_CONST)
2704 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
2705 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
2706 if (curop->op_type == OP_GV) {
2707 GV *gv = cGVOPx_gv(curop);
2709 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
2712 else if (curop->op_type == OP_RV2CV)
2714 else if (curop->op_type == OP_RV2SV ||
2715 curop->op_type == OP_RV2AV ||
2716 curop->op_type == OP_RV2HV ||
2717 curop->op_type == OP_RV2GV) {
2718 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2721 else if (curop->op_type == OP_PADSV ||
2722 curop->op_type == OP_PADAV ||
2723 curop->op_type == OP_PADHV ||
2724 curop->op_type == OP_PADANY) {
2727 else if (curop->op_type == OP_PUSHRE)
2728 ; /* Okay here, dangerous in newASSIGNOP */
2738 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
2739 pm->op_pmflags |= PMf_CONST; /* const for long enough */
2740 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
2741 prepend_elem(o->op_type, scalar(repl), o);
2744 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
2745 pm->op_pmflags |= PMf_MAYBE_CONST;
2746 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2748 NewOp(1101, rcop, 1, LOGOP);
2749 rcop->op_type = OP_SUBSTCONT;
2750 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
2751 rcop->op_first = scalar(repl);
2752 rcop->op_flags |= OPf_KIDS;
2753 rcop->op_private = 1;
2756 /* establish postfix order */
2757 rcop->op_next = LINKLIST(repl);
2758 repl->op_next = (OP*)rcop;
2760 pm->op_pmreplroot = scalar((OP*)rcop);
2761 pm->op_pmreplstart = LINKLIST(rcop);
2770 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
2773 NewOp(1101, svop, 1, SVOP);
2774 svop->op_type = (OPCODE)type;
2775 svop->op_ppaddr = PL_ppaddr[type];
2777 svop->op_next = (OP*)svop;
2778 svop->op_flags = (U8)flags;
2779 if (PL_opargs[type] & OA_RETSCALAR)
2781 if (PL_opargs[type] & OA_TARGET)
2782 svop->op_targ = pad_alloc(type, SVs_PADTMP);
2783 return CHECKOP(type, svop);
2787 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2790 NewOp(1101, padop, 1, PADOP);
2791 padop->op_type = (OPCODE)type;
2792 padop->op_ppaddr = PL_ppaddr[type];
2793 padop->op_padix = pad_alloc(type, SVs_PADTMP);
2794 SvREFCNT_dec(PAD_SVl(padop->op_padix));
2795 PAD_SETSV(padop->op_padix, sv);
2798 padop->op_next = (OP*)padop;
2799 padop->op_flags = (U8)flags;
2800 if (PL_opargs[type] & OA_RETSCALAR)
2802 if (PL_opargs[type] & OA_TARGET)
2803 padop->op_targ = pad_alloc(type, SVs_PADTMP);
2804 return CHECKOP(type, padop);
2808 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
2813 return newPADOP(type, flags, SvREFCNT_inc(gv));
2815 return newSVOP(type, flags, SvREFCNT_inc(gv));
2820 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
2823 NewOp(1101, pvop, 1, PVOP);
2824 pvop->op_type = (OPCODE)type;
2825 pvop->op_ppaddr = PL_ppaddr[type];
2827 pvop->op_next = (OP*)pvop;
2828 pvop->op_flags = (U8)flags;
2829 if (PL_opargs[type] & OA_RETSCALAR)
2831 if (PL_opargs[type] & OA_TARGET)
2832 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
2833 return CHECKOP(type, pvop);
2837 Perl_package(pTHX_ OP *o)
2842 save_hptr(&PL_curstash);
2843 save_item(PL_curstname);
2845 name = SvPV(cSVOPo->op_sv, len);
2846 PL_curstash = gv_stashpvn(name, len, TRUE);
2847 sv_setpvn(PL_curstname, name, len);
2850 PL_hints |= HINT_BLOCK_SCOPE;
2851 PL_copline = NOLINE;
2856 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
2862 if (idop->op_type != OP_CONST)
2863 Perl_croak(aTHX_ "Module name must be constant");
2867 if (version != Nullop) {
2868 SV *vesv = ((SVOP*)version)->op_sv;
2870 if (arg == Nullop && !SvNIOKp(vesv)) {
2877 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
2878 Perl_croak(aTHX_ "Version number must be constant number");
2880 /* Make copy of idop so we don't free it twice */
2881 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
2883 /* Fake up a method call to VERSION */
2884 meth = newSVpvn("VERSION",7);
2885 sv_upgrade(meth, SVt_PVIV);
2886 (void)SvIOK_on(meth);
2887 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
2888 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2889 append_elem(OP_LIST,
2890 prepend_elem(OP_LIST, pack, list(version)),
2891 newSVOP(OP_METHOD_NAMED, 0, meth)));
2895 /* Fake up an import/unimport */
2896 if (arg && arg->op_type == OP_STUB)
2897 imop = arg; /* no import on explicit () */
2898 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
2899 imop = Nullop; /* use 5.0; */
2904 /* Make copy of idop so we don't free it twice */
2905 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
2907 /* Fake up a method call to import/unimport */
2908 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);
2909 (void)SvUPGRADE(meth, SVt_PVIV);
2910 (void)SvIOK_on(meth);
2911 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
2912 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2913 append_elem(OP_LIST,
2914 prepend_elem(OP_LIST, pack, list(arg)),
2915 newSVOP(OP_METHOD_NAMED, 0, meth)));
2918 /* Fake up the BEGIN {}, which does its thing immediately. */
2920 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
2923 append_elem(OP_LINESEQ,
2924 append_elem(OP_LINESEQ,
2925 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, idop)),
2926 newSTATEOP(0, Nullch, veop)),
2927 newSTATEOP(0, Nullch, imop) ));
2929 /* The "did you use incorrect case?" warning used to be here.
2930 * The problem is that on case-insensitive filesystems one
2931 * might get false positives for "use" (and "require"):
2932 * "use Strict" or "require CARP" will work. This causes
2933 * portability problems for the script: in case-strict
2934 * filesystems the script will stop working.
2936 * The "incorrect case" warning checked whether "use Foo"
2937 * imported "Foo" to your namespace, but that is wrong, too:
2938 * there is no requirement nor promise in the language that
2939 * a Foo.pm should or would contain anything in package "Foo".
2941 * There is very little Configure-wise that can be done, either:
2942 * the case-sensitivity of the build filesystem of Perl does not
2943 * help in guessing the case-sensitivity of the runtime environment.
2946 PL_hints |= HINT_BLOCK_SCOPE;
2947 PL_copline = NOLINE;
2949 PL_cop_seqmax++; /* Purely for B::*'s benefit */
2953 =head1 Embedding Functions
2955 =for apidoc load_module
2957 Loads the module whose name is pointed to by the string part of name.
2958 Note that the actual module name, not its filename, should be given.
2959 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
2960 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
2961 (or 0 for no flags). ver, if specified, provides version semantics
2962 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
2963 arguments can be used to specify arguments to the module's import()
2964 method, similar to C<use Foo::Bar VERSION LIST>.
2969 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
2972 va_start(args, ver);
2973 vload_module(flags, name, ver, &args);
2977 #ifdef PERL_IMPLICIT_CONTEXT
2979 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
2983 va_start(args, ver);
2984 vload_module(flags, name, ver, &args);
2990 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
2992 OP *modname, *veop, *imop;
2994 modname = newSVOP(OP_CONST, 0, name);
2995 modname->op_private |= OPpCONST_BARE;
2997 veop = newSVOP(OP_CONST, 0, ver);
3001 if (flags & PERL_LOADMOD_NOIMPORT) {
3002 imop = sawparens(newNULLLIST());
3004 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3005 imop = va_arg(*args, OP*);
3010 sv = va_arg(*args, SV*);
3012 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3013 sv = va_arg(*args, SV*);
3017 line_t ocopline = PL_copline;
3018 COP *ocurcop = PL_curcop;
3019 int oexpect = PL_expect;
3021 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3022 veop, modname, imop);
3023 PL_expect = oexpect;
3024 PL_copline = ocopline;
3025 PL_curcop = ocurcop;
3030 Perl_dofile(pTHX_ OP *term)
3035 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3036 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
3037 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3039 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3040 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3041 append_elem(OP_LIST, term,
3042 scalar(newUNOP(OP_RV2CV, 0,
3047 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3053 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3055 return newBINOP(OP_LSLICE, flags,
3056 list(force_list(subscript)),
3057 list(force_list(listval)) );
3061 S_list_assignment(pTHX_ register OP *o)
3066 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3067 o = cUNOPo->op_first;
3069 if (o->op_type == OP_COND_EXPR) {
3070 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3071 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3076 yyerror("Assignment to both a list and a scalar");
3080 if (o->op_type == OP_LIST &&
3081 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3082 o->op_private & OPpLVAL_INTRO)
3085 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3086 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3087 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3090 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3093 if (o->op_type == OP_RV2SV)
3100 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3105 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3106 return newLOGOP(optype, 0,
3107 mod(scalar(left), optype),
3108 newUNOP(OP_SASSIGN, 0, scalar(right)));
3111 return newBINOP(optype, OPf_STACKED,
3112 mod(scalar(left), optype), scalar(right));
3116 if (list_assignment(left)) {
3120 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3121 left = mod(left, OP_AASSIGN);
3129 /* optimise C<my @x = ()> to C<my @x>, and likewise for hashes */
3130 if ((left->op_type == OP_PADAV || left->op_type == OP_PADHV)
3131 && right->op_type == OP_STUB
3132 && (left->op_private & OPpLVAL_INTRO))
3137 curop = list(force_list(left));
3138 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3139 o->op_private = (U8)(0 | (flags >> 8));
3141 /* PL_generation sorcery:
3142 * an assignment like ($a,$b) = ($c,$d) is easier than
3143 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3144 * To detect whether there are common vars, the global var
3145 * PL_generation is incremented for each assign op we compile.
3146 * Then, while compiling the assign op, we run through all the
3147 * variables on both sides of the assignment, setting a spare slot
3148 * in each of them to PL_generation. If any of them already have
3149 * that value, we know we've got commonality. We could use a
3150 * single bit marker, but then we'd have to make 2 passes, first
3151 * to clear the flag, then to test and set it. To find somewhere
3152 * to store these values, evil chicanery is done with SvCUR().
3155 if (!(left->op_private & OPpLVAL_INTRO)) {
3158 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3159 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3160 if (curop->op_type == OP_GV) {
3161 GV *gv = cGVOPx_gv(curop);
3162 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3164 SvCUR(gv) = PL_generation;
3166 else if (curop->op_type == OP_PADSV ||
3167 curop->op_type == OP_PADAV ||
3168 curop->op_type == OP_PADHV ||
3169 curop->op_type == OP_PADANY)
3171 if (PAD_COMPNAME_GEN(curop->op_targ)
3172 == (STRLEN)PL_generation)
3174 PAD_COMPNAME_GEN(curop->op_targ)
3178 else if (curop->op_type == OP_RV2CV)
3180 else if (curop->op_type == OP_RV2SV ||
3181 curop->op_type == OP_RV2AV ||
3182 curop->op_type == OP_RV2HV ||
3183 curop->op_type == OP_RV2GV) {
3184 if (lastop->op_type != OP_GV) /* funny deref? */
3187 else if (curop->op_type == OP_PUSHRE) {
3188 if (((PMOP*)curop)->op_pmreplroot) {
3190 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3191 ((PMOP*)curop)->op_pmreplroot));
3193 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3195 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3197 SvCUR(gv) = PL_generation;
3206 o->op_private |= OPpASSIGN_COMMON;
3208 if (right && right->op_type == OP_SPLIT) {
3210 if ((tmpop = ((LISTOP*)right)->op_first) &&
3211 tmpop->op_type == OP_PUSHRE)
3213 PMOP *pm = (PMOP*)tmpop;
3214 if (left->op_type == OP_RV2AV &&
3215 !(left->op_private & OPpLVAL_INTRO) &&
3216 !(o->op_private & OPpASSIGN_COMMON) )
3218 tmpop = ((UNOP*)left)->op_first;
3219 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3221 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3222 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3224 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3225 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3227 pm->op_pmflags |= PMf_ONCE;
3228 tmpop = cUNOPo->op_first; /* to list (nulled) */
3229 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3230 tmpop->op_sibling = Nullop; /* don't free split */
3231 right->op_next = tmpop->op_next; /* fix starting loc */
3232 op_free(o); /* blow off assign */
3233 right->op_flags &= ~OPf_WANT;
3234 /* "I don't know and I don't care." */
3239 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3240 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3242 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3244 sv_setiv(sv, PL_modcount+1);
3252 right = newOP(OP_UNDEF, 0);
3253 if (right->op_type == OP_READLINE) {
3254 right->op_flags |= OPf_STACKED;
3255 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3258 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3259 o = newBINOP(OP_SASSIGN, flags,
3260 scalar(right), mod(scalar(left), OP_SASSIGN) );
3272 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3274 U32 seq = intro_my();
3277 NewOp(1101, cop, 1, COP);
3278 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3279 cop->op_type = OP_DBSTATE;
3280 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3283 cop->op_type = OP_NEXTSTATE;
3284 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3286 cop->op_flags = (U8)flags;
3287 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3289 cop->op_private |= NATIVE_HINTS;
3291 PL_compiling.op_private = cop->op_private;
3292 cop->op_next = (OP*)cop;
3295 cop->cop_label = label;
3296 PL_hints |= HINT_BLOCK_SCOPE;
3299 cop->cop_arybase = PL_curcop->cop_arybase;
3300 if (specialWARN(PL_curcop->cop_warnings))
3301 cop->cop_warnings = PL_curcop->cop_warnings ;
3303 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3304 if (specialCopIO(PL_curcop->cop_io))
3305 cop->cop_io = PL_curcop->cop_io;
3307 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3310 if (PL_copline == NOLINE)
3311 CopLINE_set(cop, CopLINE(PL_curcop));
3313 CopLINE_set(cop, PL_copline);
3314 PL_copline = NOLINE;
3317 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3319 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3321 CopSTASH_set(cop, PL_curstash);
3323 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3324 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3325 if (svp && *svp != &PL_sv_undef ) {
3326 (void)SvIOK_on(*svp);
3327 SvIVX(*svp) = PTR2IV(cop);
3331 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3336 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3338 return new_logop(type, flags, &first, &other);
3342 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3346 OP *first = *firstp;
3347 OP *other = *otherp;
3349 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3350 return newBINOP(type, flags, scalar(first), scalar(other));
3352 scalarboolean(first);
3353 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3354 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3355 if (type == OP_AND || type == OP_OR) {
3361 first = *firstp = cUNOPo->op_first;
3363 first->op_next = o->op_next;
3364 cUNOPo->op_first = Nullop;
3368 if (first->op_type == OP_CONST) {
3369 if (first->op_private & OPpCONST_STRICT)
3370 no_bareword_allowed(first);
3371 else if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3372 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3373 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3376 other->op_private |= OPpCONST_SHORTCIRCUIT;
3380 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
3382 if ( ! (o2->op_type == OP_LIST
3383 && (( o2 = cUNOPx(o2)->op_first))
3384 && o2->op_type == OP_PUSHMARK
3385 && (( o2 = o2->op_sibling)) )
3388 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
3389 || o2->op_type == OP_PADHV)
3390 && o2->op_private & OPpLVAL_INTRO
3391 && ckWARN(WARN_DEPRECATED))
3393 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
3394 "Deprecated use of my() in false conditional");
3399 first->op_private |= OPpCONST_SHORTCIRCUIT;
3403 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS) &&
3404 type != OP_DOR) /* [#24076] Don't warn for <FH> err FOO. */
3406 OP *k1 = ((UNOP*)first)->op_first;
3407 OP *k2 = k1->op_sibling;
3409 switch (first->op_type)
3412 if (k2 && k2->op_type == OP_READLINE
3413 && (k2->op_flags & OPf_STACKED)
3414 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3416 warnop = k2->op_type;
3421 if (k1->op_type == OP_READDIR
3422 || k1->op_type == OP_GLOB
3423 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3424 || k1->op_type == OP_EACH)
3426 warnop = ((k1->op_type == OP_NULL)
3427 ? (OPCODE)k1->op_targ : k1->op_type);
3432 line_t oldline = CopLINE(PL_curcop);
3433 CopLINE_set(PL_curcop, PL_copline);
3434 Perl_warner(aTHX_ packWARN(WARN_MISC),
3435 "Value of %s%s can be \"0\"; test with defined()",
3437 ((warnop == OP_READLINE || warnop == OP_GLOB)
3438 ? " construct" : "() operator"));
3439 CopLINE_set(PL_curcop, oldline);
3446 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3447 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3449 NewOp(1101, logop, 1, LOGOP);
3451 logop->op_type = (OPCODE)type;
3452 logop->op_ppaddr = PL_ppaddr[type];
3453 logop->op_first = first;
3454 logop->op_flags = flags | OPf_KIDS;
3455 logop->op_other = LINKLIST(other);
3456 logop->op_private = (U8)(1 | (flags >> 8));
3458 /* establish postfix order */
3459 logop->op_next = LINKLIST(first);
3460 first->op_next = (OP*)logop;
3461 first->op_sibling = other;
3463 CHECKOP(type,logop);
3465 o = newUNOP(OP_NULL, 0, (OP*)logop);
3472 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3479 return newLOGOP(OP_AND, 0, first, trueop);
3481 return newLOGOP(OP_OR, 0, first, falseop);
3483 scalarboolean(first);
3484 if (first->op_type == OP_CONST) {
3485 if (first->op_private & OPpCONST_BARE &&
3486 first->op_private & OPpCONST_STRICT) {
3487 no_bareword_allowed(first);
3489 if (SvTRUE(((SVOP*)first)->op_sv)) {
3500 NewOp(1101, logop, 1, LOGOP);
3501 logop->op_type = OP_COND_EXPR;
3502 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3503 logop->op_first = first;
3504 logop->op_flags = flags | OPf_KIDS;
3505 logop->op_private = (U8)(1 | (flags >> 8));
3506 logop->op_other = LINKLIST(trueop);
3507 logop->op_next = LINKLIST(falseop);
3509 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
3512 /* establish postfix order */
3513 start = LINKLIST(first);
3514 first->op_next = (OP*)logop;
3516 first->op_sibling = trueop;
3517 trueop->op_sibling = falseop;
3518 o = newUNOP(OP_NULL, 0, (OP*)logop);
3520 trueop->op_next = falseop->op_next = o;
3527 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3535 NewOp(1101, range, 1, LOGOP);
3537 range->op_type = OP_RANGE;
3538 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3539 range->op_first = left;
3540 range->op_flags = OPf_KIDS;
3541 leftstart = LINKLIST(left);
3542 range->op_other = LINKLIST(right);
3543 range->op_private = (U8)(1 | (flags >> 8));
3545 left->op_sibling = right;
3547 range->op_next = (OP*)range;
3548 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3549 flop = newUNOP(OP_FLOP, 0, flip);
3550 o = newUNOP(OP_NULL, 0, flop);
3552 range->op_next = leftstart;
3554 left->op_next = flip;
3555 right->op_next = flop;
3557 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3558 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3559 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3560 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3562 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3563 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3566 if (!flip->op_private || !flop->op_private)
3567 linklist(o); /* blow off optimizer unless constant */
3573 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3577 int once = block && block->op_flags & OPf_SPECIAL &&
3578 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3581 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3582 return block; /* do {} while 0 does once */
3583 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3584 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3585 expr = newUNOP(OP_DEFINED, 0,
3586 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3587 } else if (expr->op_flags & OPf_KIDS) {
3588 OP *k1 = ((UNOP*)expr)->op_first;
3589 OP *k2 = (k1) ? k1->op_sibling : NULL;
3590 switch (expr->op_type) {
3592 if (k2 && k2->op_type == OP_READLINE
3593 && (k2->op_flags & OPf_STACKED)
3594 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3595 expr = newUNOP(OP_DEFINED, 0, expr);
3599 if (k1->op_type == OP_READDIR
3600 || k1->op_type == OP_GLOB
3601 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3602 || k1->op_type == OP_EACH)
3603 expr = newUNOP(OP_DEFINED, 0, expr);
3609 /* if block is null, the next append_elem() would put UNSTACK, a scalar
3610 * op, in listop. This is wrong. [perl #27024] */
3612 block = newOP(OP_NULL, 0);
3613 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3614 o = new_logop(OP_AND, 0, &expr, &listop);
3617 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3619 if (once && o != listop)
3620 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3623 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3625 o->op_flags |= flags;
3627 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3632 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3640 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3641 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3642 expr = newUNOP(OP_DEFINED, 0,
3643 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3644 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3645 OP *k1 = ((UNOP*)expr)->op_first;
3646 OP *k2 = (k1) ? k1->op_sibling : NULL;
3647 switch (expr->op_type) {
3649 if (k2 && k2->op_type == OP_READLINE
3650 && (k2->op_flags & OPf_STACKED)
3651 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3652 expr = newUNOP(OP_DEFINED, 0, expr);
3656 if (k1->op_type == OP_READDIR
3657 || k1->op_type == OP_GLOB
3658 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3659 || k1->op_type == OP_EACH)
3660 expr = newUNOP(OP_DEFINED, 0, expr);
3666 block = newOP(OP_NULL, 0);
3668 block = scope(block);
3672 next = LINKLIST(cont);
3675 OP *unstack = newOP(OP_UNSTACK, 0);
3678 cont = append_elem(OP_LINESEQ, cont, unstack);
3681 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3682 redo = LINKLIST(listop);
3685 PL_copline = (line_t)whileline;
3687 o = new_logop(OP_AND, 0, &expr, &listop);
3688 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3689 op_free(expr); /* oops, it's a while (0) */
3691 return Nullop; /* listop already freed by new_logop */
3694 ((LISTOP*)listop)->op_last->op_next =
3695 (o == listop ? redo : LINKLIST(o));
3701 NewOp(1101,loop,1,LOOP);
3702 loop->op_type = OP_ENTERLOOP;
3703 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3704 loop->op_private = 0;
3705 loop->op_next = (OP*)loop;
3708 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3710 loop->op_redoop = redo;
3711 loop->op_lastop = o;
3712 o->op_private |= loopflags;
3715 loop->op_nextop = next;
3717 loop->op_nextop = o;
3719 o->op_flags |= flags;
3720 o->op_private |= (flags >> 8);
3725 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
3729 PADOFFSET padoff = 0;
3734 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
3735 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
3736 sv->op_type = OP_RV2GV;
3737 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3739 else if (sv->op_type == OP_PADSV) { /* private variable */
3740 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
3741 padoff = sv->op_targ;
3746 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3747 padoff = sv->op_targ;
3749 iterflags |= OPf_SPECIAL;
3754 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3757 I32 offset = pad_findmy("$_");
3758 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
3759 sv = newGVOP(OP_GV, 0, PL_defgv);
3765 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3766 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3767 iterflags |= OPf_STACKED;
3769 else if (expr->op_type == OP_NULL &&
3770 (expr->op_flags & OPf_KIDS) &&
3771 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3773 /* Basically turn for($x..$y) into the same as for($x,$y), but we
3774 * set the STACKED flag to indicate that these values are to be
3775 * treated as min/max values by 'pp_iterinit'.
3777 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
3778 LOGOP* range = (LOGOP*) flip->op_first;
3779 OP* left = range->op_first;
3780 OP* right = left->op_sibling;
3783 range->op_flags &= ~OPf_KIDS;
3784 range->op_first = Nullop;
3786 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
3787 listop->op_first->op_next = range->op_next;
3788 left->op_next = range->op_other;
3789 right->op_next = (OP*)listop;
3790 listop->op_next = listop->op_first;
3793 expr = (OP*)(listop);
3795 iterflags |= OPf_STACKED;
3798 expr = mod(force_list(expr), OP_GREPSTART);
3802 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
3803 append_elem(OP_LIST, expr, scalar(sv))));
3804 assert(!loop->op_next);
3805 /* for my $x () sets OPpLVAL_INTRO;
3806 * for our $x () sets OPpOUR_INTRO */
3807 loop->op_private = (U8)iterpflags;
3808 #ifdef PL_OP_SLAB_ALLOC
3811 NewOp(1234,tmp,1,LOOP);
3812 Copy(loop,tmp,1,LOOP);
3817 Renew(loop, 1, LOOP);
3819 loop->op_targ = padoff;
3820 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
3821 PL_copline = forline;
3822 return newSTATEOP(0, label, wop);
3826 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
3831 if (type != OP_GOTO || label->op_type == OP_CONST) {
3832 /* "last()" means "last" */
3833 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
3834 o = newOP(type, OPf_SPECIAL);
3836 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
3837 ? SvPVx(((SVOP*)label)->op_sv, n_a)
3843 /* Check whether it's going to be a goto &function */
3844 if (label->op_type == OP_ENTERSUB
3845 && !(label->op_flags & OPf_STACKED))
3846 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
3847 o = newUNOP(type, OPf_STACKED, label);
3849 PL_hints |= HINT_BLOCK_SCOPE;
3854 =for apidoc cv_undef
3856 Clear out all the active components of a CV. This can happen either
3857 by an explicit C<undef &foo>, or by the reference count going to zero.
3858 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
3859 children can still follow the full lexical scope chain.
3865 Perl_cv_undef(pTHX_ CV *cv)
3868 if (CvFILE(cv) && !CvXSUB(cv)) {
3869 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
3870 Safefree(CvFILE(cv));
3875 if (!CvXSUB(cv) && CvROOT(cv)) {
3877 Perl_croak(aTHX_ "Can't undef active subroutine");
3880 PAD_SAVE_SETNULLPAD();
3882 op_free(CvROOT(cv));
3883 CvROOT(cv) = Nullop;
3886 SvPOK_off((SV*)cv); /* forget prototype */
3891 /* remove CvOUTSIDE unless this is an undef rather than a free */
3892 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
3893 if (!CvWEAKOUTSIDE(cv))
3894 SvREFCNT_dec(CvOUTSIDE(cv));
3895 CvOUTSIDE(cv) = Nullcv;
3898 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
3904 /* delete all flags except WEAKOUTSIDE */
3905 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
3909 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
3911 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
3912 SV* msg = sv_newmortal();
3916 gv_efullname3(name = sv_newmortal(), gv, Nullch);
3917 sv_setpv(msg, "Prototype mismatch:");
3919 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
3921 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (SV *)cv);
3923 Perl_sv_catpvf(aTHX_ msg, ": none");
3924 sv_catpv(msg, " vs ");
3926 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
3928 sv_catpv(msg, "none");
3929 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
3933 static void const_sv_xsub(pTHX_ CV* cv);
3937 =head1 Optree Manipulation Functions
3939 =for apidoc cv_const_sv
3941 If C<cv> is a constant sub eligible for inlining. returns the constant
3942 value returned by the sub. Otherwise, returns NULL.
3944 Constant subs can be created with C<newCONSTSUB> or as described in
3945 L<perlsub/"Constant Functions">.
3950 Perl_cv_const_sv(pTHX_ CV *cv)
3952 if (!cv || !CvCONST(cv))
3954 return (SV*)CvXSUBANY(cv).any_ptr;
3957 /* op_const_sv: examine an optree to determine whether it's in-lineable.
3958 * Can be called in 3 ways:
3961 * look for a single OP_CONST with attached value: return the value
3963 * cv && CvCLONE(cv) && !CvCONST(cv)
3965 * examine the clone prototype, and if contains only a single
3966 * OP_CONST referencing a pad const, or a single PADSV referencing
3967 * an outer lexical, return a non-zero value to indicate the CV is
3968 * a candidate for "constizing" at clone time
3972 * We have just cloned an anon prototype that was marked as a const
3973 * candidiate. Try to grab the current value, and in the case of
3974 * PADSV, ignore it if it has multiple references. Return the value.
3978 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
3985 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
3986 o = cLISTOPo->op_first->op_sibling;
3988 for (; o; o = o->op_next) {
3989 OPCODE type = o->op_type;
3991 if (sv && o->op_next == o)
3993 if (o->op_next != o) {
3994 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
3996 if (type == OP_DBSTATE)
3999 if (type == OP_LEAVESUB || type == OP_RETURN)
4003 if (type == OP_CONST && cSVOPo->op_sv)
4005 else if (cv && type == OP_CONST) {
4006 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4010 else if (cv && type == OP_PADSV) {
4011 if (CvCONST(cv)) { /* newly cloned anon */
4012 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4013 /* the candidate should have 1 ref from this pad and 1 ref
4014 * from the parent */
4015 if (!sv || SvREFCNT(sv) != 2)
4022 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4023 sv = &PL_sv_undef; /* an arbitrary non-null value */
4034 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4044 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4048 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4050 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4054 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4060 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4064 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4065 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4066 SV *sv = sv_newmortal();
4067 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4068 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4069 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4074 gv = gv_fetchpv(name ? name : (aname ? aname :
4075 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__")),
4076 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4086 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4087 maximum a prototype before. */
4088 if (SvTYPE(gv) > SVt_NULL) {
4089 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4090 && ckWARN_d(WARN_PROTOTYPE))
4092 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4094 cv_ckproto((CV*)gv, NULL, ps);
4097 sv_setpv((SV*)gv, ps);
4099 sv_setiv((SV*)gv, -1);
4100 SvREFCNT_dec(PL_compcv);
4101 cv = PL_compcv = NULL;
4102 PL_sub_generation++;
4106 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4108 #ifdef GV_UNIQUE_CHECK
4109 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4110 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4114 if (!block || !ps || *ps || attrs)
4117 const_sv = op_const_sv(block, Nullcv);
4120 bool exists = CvROOT(cv) || CvXSUB(cv);
4122 #ifdef GV_UNIQUE_CHECK
4123 if (exists && GvUNIQUE(gv)) {
4124 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4128 /* if the subroutine doesn't exist and wasn't pre-declared
4129 * with a prototype, assume it will be AUTOLOADed,
4130 * skipping the prototype check
4132 if (exists || SvPOK(cv))
4133 cv_ckproto(cv, gv, ps);
4134 /* already defined (or promised)? */
4135 if (exists || GvASSUMECV(gv)) {
4136 if (!block && !attrs) {
4137 if (CvFLAGS(PL_compcv)) {
4138 /* might have had built-in attrs applied */
4139 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4141 /* just a "sub foo;" when &foo is already defined */
4142 SAVEFREESV(PL_compcv);
4145 /* ahem, death to those who redefine active sort subs */
4146 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4147 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4149 if (ckWARN(WARN_REDEFINE)
4151 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4153 line_t oldline = CopLINE(PL_curcop);
4154 if (PL_copline != NOLINE)
4155 CopLINE_set(PL_curcop, PL_copline);
4156 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4157 CvCONST(cv) ? "Constant subroutine %s redefined"
4158 : "Subroutine %s redefined", name);
4159 CopLINE_set(PL_curcop, oldline);
4167 SvREFCNT_inc(const_sv);
4169 assert(!CvROOT(cv) && !CvCONST(cv));
4170 sv_setpv((SV*)cv, ""); /* prototype is "" */
4171 CvXSUBANY(cv).any_ptr = const_sv;
4172 CvXSUB(cv) = const_sv_xsub;
4177 cv = newCONSTSUB(NULL, name, const_sv);
4180 SvREFCNT_dec(PL_compcv);
4182 PL_sub_generation++;
4189 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4190 * before we clobber PL_compcv.
4194 /* Might have had built-in attributes applied -- propagate them. */
4195 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4196 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4197 stash = GvSTASH(CvGV(cv));
4198 else if (CvSTASH(cv))
4199 stash = CvSTASH(cv);
4201 stash = PL_curstash;
4204 /* possibly about to re-define existing subr -- ignore old cv */
4205 rcv = (SV*)PL_compcv;
4206 if (name && GvSTASH(gv))
4207 stash = GvSTASH(gv);
4209 stash = PL_curstash;
4211 apply_attrs(stash, rcv, attrs, FALSE);
4213 if (cv) { /* must reuse cv if autoloaded */
4215 /* got here with just attrs -- work done, so bug out */
4216 SAVEFREESV(PL_compcv);
4219 /* transfer PL_compcv to cv */
4221 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4222 if (!CvWEAKOUTSIDE(cv))
4223 SvREFCNT_dec(CvOUTSIDE(cv));
4224 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4225 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4226 CvOUTSIDE(PL_compcv) = 0;
4227 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4228 CvPADLIST(PL_compcv) = 0;
4229 /* inner references to PL_compcv must be fixed up ... */
4230 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4231 /* ... before we throw it away */
4232 SvREFCNT_dec(PL_compcv);
4234 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4235 ++PL_sub_generation;
4242 PL_sub_generation++;
4246 CvFILE_set_from_cop(cv, PL_curcop);
4247 CvSTASH(cv) = PL_curstash;
4250 sv_setpv((SV*)cv, ps);
4252 if (PL_error_count) {
4256 char *s = strrchr(name, ':');
4258 if (strEQ(s, "BEGIN")) {
4260 "BEGIN not safe after errors--compilation aborted";
4261 if (PL_in_eval & EVAL_KEEPERR)
4262 Perl_croak(aTHX_ not_safe);
4264 /* force display of errors found but not reported */
4265 sv_catpv(ERRSV, not_safe);
4266 Perl_croak(aTHX_ "%"SVf, ERRSV);
4275 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4276 mod(scalarseq(block), OP_LEAVESUBLV));
4279 /* This makes sub {}; work as expected. */
4280 if (block->op_type == OP_STUB) {
4282 block = newSTATEOP(0, Nullch, 0);
4284 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4286 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4287 OpREFCNT_set(CvROOT(cv), 1);
4288 CvSTART(cv) = LINKLIST(CvROOT(cv));
4289 CvROOT(cv)->op_next = 0;
4290 CALL_PEEP(CvSTART(cv));
4292 /* now that optimizer has done its work, adjust pad values */
4294 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4297 assert(!CvCONST(cv));
4298 if (ps && !*ps && op_const_sv(block, cv))
4302 if (name || aname) {
4304 char *tname = (name ? name : aname);
4306 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4307 SV *sv = NEWSV(0,0);
4308 SV *tmpstr = sv_newmortal();
4309 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4313 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4315 (long)PL_subline, (long)CopLINE(PL_curcop));
4316 gv_efullname3(tmpstr, gv, Nullch);
4317 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4318 hv = GvHVn(db_postponed);
4319 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4320 && (pcv = GvCV(db_postponed)))
4326 call_sv((SV*)pcv, G_DISCARD);
4330 if ((s = strrchr(tname,':')))
4335 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4338 if (strEQ(s, "BEGIN") && !PL_error_count) {
4339 I32 oldscope = PL_scopestack_ix;
4341 SAVECOPFILE(&PL_compiling);
4342 SAVECOPLINE(&PL_compiling);
4345 PL_beginav = newAV();
4346 DEBUG_x( dump_sub(gv) );
4347 av_push(PL_beginav, (SV*)cv);
4348 GvCV(gv) = 0; /* cv has been hijacked */
4349 call_list(oldscope, PL_beginav);
4351 PL_curcop = &PL_compiling;
4352 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4355 else if (strEQ(s, "END") && !PL_error_count) {
4358 DEBUG_x( dump_sub(gv) );
4359 av_unshift(PL_endav, 1);
4360 av_store(PL_endav, 0, (SV*)cv);
4361 GvCV(gv) = 0; /* cv has been hijacked */
4363 else if (strEQ(s, "CHECK") && !PL_error_count) {
4365 PL_checkav = newAV();
4366 DEBUG_x( dump_sub(gv) );
4367 if (PL_main_start && ckWARN(WARN_VOID))
4368 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4369 av_unshift(PL_checkav, 1);
4370 av_store(PL_checkav, 0, (SV*)cv);
4371 GvCV(gv) = 0; /* cv has been hijacked */
4373 else if (strEQ(s, "INIT") && !PL_error_count) {
4375 PL_initav = newAV();
4376 DEBUG_x( dump_sub(gv) );
4377 if (PL_main_start && ckWARN(WARN_VOID))
4378 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4379 av_push(PL_initav, (SV*)cv);
4380 GvCV(gv) = 0; /* cv has been hijacked */
4385 PL_copline = NOLINE;
4390 /* XXX unsafe for threads if eval_owner isn't held */
4392 =for apidoc newCONSTSUB
4394 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4395 eligible for inlining at compile-time.
4401 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4407 SAVECOPLINE(PL_curcop);
4408 CopLINE_set(PL_curcop, PL_copline);
4411 PL_hints &= ~HINT_BLOCK_SCOPE;
4414 SAVESPTR(PL_curstash);
4415 SAVECOPSTASH(PL_curcop);
4416 PL_curstash = stash;
4417 CopSTASH_set(PL_curcop,stash);
4420 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4421 CvXSUBANY(cv).any_ptr = sv;
4423 sv_setpv((SV*)cv, ""); /* prototype is "" */
4426 CopSTASH_free(PL_curcop);
4434 =for apidoc U||newXS
4436 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4442 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
4444 GV *gv = gv_fetchpv(name ? name :
4445 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4446 GV_ADDMULTI, SVt_PVCV);
4450 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4452 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4454 /* just a cached method */
4458 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4459 /* already defined (or promised) */
4460 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4461 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4462 line_t oldline = CopLINE(PL_curcop);
4463 if (PL_copline != NOLINE)
4464 CopLINE_set(PL_curcop, PL_copline);
4465 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4466 CvCONST(cv) ? "Constant subroutine %s redefined"
4467 : "Subroutine %s redefined"
4469 CopLINE_set(PL_curcop, oldline);
4476 if (cv) /* must reuse cv if autoloaded */
4479 cv = (CV*)NEWSV(1105,0);
4480 sv_upgrade((SV *)cv, SVt_PVCV);
4484 PL_sub_generation++;
4488 (void)gv_fetchfile(filename);
4489 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
4490 an external constant string */
4491 CvXSUB(cv) = subaddr;
4494 char *s = strrchr(name,':');
4500 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4503 if (strEQ(s, "BEGIN")) {
4505 PL_beginav = newAV();
4506 av_push(PL_beginav, (SV*)cv);
4507 GvCV(gv) = 0; /* cv has been hijacked */
4509 else if (strEQ(s, "END")) {
4512 av_unshift(PL_endav, 1);
4513 av_store(PL_endav, 0, (SV*)cv);
4514 GvCV(gv) = 0; /* cv has been hijacked */
4516 else if (strEQ(s, "CHECK")) {
4518 PL_checkav = newAV();
4519 if (PL_main_start && ckWARN(WARN_VOID))
4520 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4521 av_unshift(PL_checkav, 1);
4522 av_store(PL_checkav, 0, (SV*)cv);
4523 GvCV(gv) = 0; /* cv has been hijacked */
4525 else if (strEQ(s, "INIT")) {
4527 PL_initav = newAV();
4528 if (PL_main_start && ckWARN(WARN_VOID))
4529 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4530 av_push(PL_initav, (SV*)cv);
4531 GvCV(gv) = 0; /* cv has been hijacked */
4542 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4550 name = SvPVx(cSVOPo->op_sv, n_a);
4553 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
4554 #ifdef GV_UNIQUE_CHECK
4556 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4560 if ((cv = GvFORM(gv))) {
4561 if (ckWARN(WARN_REDEFINE)) {
4562 line_t oldline = CopLINE(PL_curcop);
4563 if (PL_copline != NOLINE)
4564 CopLINE_set(PL_curcop, PL_copline);
4565 Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Format %s redefined",name);
4566 CopLINE_set(PL_curcop, oldline);
4573 CvFILE_set_from_cop(cv, PL_curcop);
4576 pad_tidy(padtidy_FORMAT);
4577 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4578 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4579 OpREFCNT_set(CvROOT(cv), 1);
4580 CvSTART(cv) = LINKLIST(CvROOT(cv));
4581 CvROOT(cv)->op_next = 0;
4582 CALL_PEEP(CvSTART(cv));
4584 PL_copline = NOLINE;
4589 Perl_newANONLIST(pTHX_ OP *o)
4591 return newUNOP(OP_REFGEN, 0,
4592 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4596 Perl_newANONHASH(pTHX_ OP *o)
4598 return newUNOP(OP_REFGEN, 0,
4599 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4603 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4605 return newANONATTRSUB(floor, proto, Nullop, block);
4609 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4611 return newUNOP(OP_REFGEN, 0,
4612 newSVOP(OP_ANONCODE, 0,
4613 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
4617 Perl_oopsAV(pTHX_ OP *o)
4619 switch (o->op_type) {
4621 o->op_type = OP_PADAV;
4622 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4623 return ref(o, OP_RV2AV);
4626 o->op_type = OP_RV2AV;
4627 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4632 if (ckWARN_d(WARN_INTERNAL))
4633 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
4640 Perl_oopsHV(pTHX_ OP *o)
4642 switch (o->op_type) {
4645 o->op_type = OP_PADHV;
4646 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4647 return ref(o, OP_RV2HV);
4651 o->op_type = OP_RV2HV;
4652 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
4657 if (ckWARN_d(WARN_INTERNAL))
4658 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
4665 Perl_newAVREF(pTHX_ OP *o)
4667 if (o->op_type == OP_PADANY) {
4668 o->op_type = OP_PADAV;
4669 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4672 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
4673 && ckWARN(WARN_DEPRECATED)) {
4674 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4675 "Using an array as a reference is deprecated");
4677 return newUNOP(OP_RV2AV, 0, scalar(o));
4681 Perl_newGVREF(pTHX_ I32 type, OP *o)
4683 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
4684 return newUNOP(OP_NULL, 0, o);
4685 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
4689 Perl_newHVREF(pTHX_ OP *o)
4691 if (o->op_type == OP_PADANY) {
4692 o->op_type = OP_PADHV;
4693 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4696 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
4697 && ckWARN(WARN_DEPRECATED)) {
4698 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4699 "Using a hash as a reference is deprecated");
4701 return newUNOP(OP_RV2HV, 0, scalar(o));
4705 Perl_oopsCV(pTHX_ OP *o)
4707 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
4713 Perl_newCVREF(pTHX_ I32 flags, OP *o)
4715 return newUNOP(OP_RV2CV, flags, scalar(o));
4719 Perl_newSVREF(pTHX_ OP *o)
4721 if (o->op_type == OP_PADANY) {
4722 o->op_type = OP_PADSV;
4723 o->op_ppaddr = PL_ppaddr[OP_PADSV];
4726 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4727 o->op_flags |= OPpDONE_SVREF;
4730 return newUNOP(OP_RV2SV, 0, scalar(o));
4733 /* Check routines. */
4736 Perl_ck_anoncode(pTHX_ OP *o)
4738 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
4739 cSVOPo->op_sv = Nullsv;
4744 Perl_ck_bitop(pTHX_ OP *o)
4746 #define OP_IS_NUMCOMPARE(op) \
4747 ((op) == OP_LT || (op) == OP_I_LT || \
4748 (op) == OP_GT || (op) == OP_I_GT || \
4749 (op) == OP_LE || (op) == OP_I_LE || \
4750 (op) == OP_GE || (op) == OP_I_GE || \
4751 (op) == OP_EQ || (op) == OP_I_EQ || \
4752 (op) == OP_NE || (op) == OP_I_NE || \
4753 (op) == OP_NCMP || (op) == OP_I_NCMP)
4754 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4755 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
4756 && (o->op_type == OP_BIT_OR
4757 || o->op_type == OP_BIT_AND
4758 || o->op_type == OP_BIT_XOR))
4760 OP * left = cBINOPo->op_first;
4761 OP * right = left->op_sibling;
4762 if ((OP_IS_NUMCOMPARE(left->op_type) &&
4763 (left->op_flags & OPf_PARENS) == 0) ||
4764 (OP_IS_NUMCOMPARE(right->op_type) &&
4765 (right->op_flags & OPf_PARENS) == 0))
4766 if (ckWARN(WARN_PRECEDENCE))
4767 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4768 "Possible precedence problem on bitwise %c operator",
4769 o->op_type == OP_BIT_OR ? '|'
4770 : o->op_type == OP_BIT_AND ? '&' : '^'
4777 Perl_ck_concat(pTHX_ OP *o)
4779 OP *kid = cUNOPo->op_first;
4780 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
4781 !(kUNOP->op_first->op_flags & OPf_MOD))
4782 o->op_flags |= OPf_STACKED;
4787 Perl_ck_spair(pTHX_ OP *o)
4789 if (o->op_flags & OPf_KIDS) {
4792 OPCODE type = o->op_type;
4793 o = modkids(ck_fun(o), type);
4794 kid = cUNOPo->op_first;
4795 newop = kUNOP->op_first->op_sibling;
4797 (newop->op_sibling ||
4798 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
4799 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
4800 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
4804 op_free(kUNOP->op_first);
4805 kUNOP->op_first = newop;
4807 o->op_ppaddr = PL_ppaddr[++o->op_type];
4812 Perl_ck_delete(pTHX_ OP *o)
4816 if (o->op_flags & OPf_KIDS) {
4817 OP *kid = cUNOPo->op_first;
4818 switch (kid->op_type) {
4820 o->op_flags |= OPf_SPECIAL;
4823 o->op_private |= OPpSLICE;
4826 o->op_flags |= OPf_SPECIAL;
4831 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
4840 Perl_ck_die(pTHX_ OP *o)
4843 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4849 Perl_ck_eof(pTHX_ OP *o)
4851 I32 type = o->op_type;
4853 if (o->op_flags & OPf_KIDS) {
4854 if (cLISTOPo->op_first->op_type == OP_STUB) {
4856 o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
4864 Perl_ck_eval(pTHX_ OP *o)
4866 PL_hints |= HINT_BLOCK_SCOPE;
4867 if (o->op_flags & OPf_KIDS) {
4868 SVOP *kid = (SVOP*)cUNOPo->op_first;
4871 o->op_flags &= ~OPf_KIDS;
4874 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
4877 cUNOPo->op_first = 0;
4880 NewOp(1101, enter, 1, LOGOP);
4881 enter->op_type = OP_ENTERTRY;
4882 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
4883 enter->op_private = 0;
4885 /* establish postfix order */
4886 enter->op_next = (OP*)enter;
4888 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
4889 o->op_type = OP_LEAVETRY;
4890 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
4891 enter->op_other = o;
4901 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
4903 o->op_targ = (PADOFFSET)PL_hints;
4908 Perl_ck_exit(pTHX_ OP *o)
4911 HV *table = GvHV(PL_hintgv);
4913 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
4914 if (svp && *svp && SvTRUE(*svp))
4915 o->op_private |= OPpEXIT_VMSISH;
4917 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4923 Perl_ck_exec(pTHX_ OP *o)
4926 if (o->op_flags & OPf_STACKED) {
4928 kid = cUNOPo->op_first->op_sibling;
4929 if (kid->op_type == OP_RV2GV)
4938 Perl_ck_exists(pTHX_ OP *o)
4941 if (o->op_flags & OPf_KIDS) {
4942 OP *kid = cUNOPo->op_first;
4943 if (kid->op_type == OP_ENTERSUB) {
4944 (void) ref(kid, o->op_type);
4945 if (kid->op_type != OP_RV2CV && !PL_error_count)
4946 Perl_croak(aTHX_ "%s argument is not a subroutine name",
4948 o->op_private |= OPpEXISTS_SUB;
4950 else if (kid->op_type == OP_AELEM)
4951 o->op_flags |= OPf_SPECIAL;
4952 else if (kid->op_type != OP_HELEM)
4953 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
4962 Perl_ck_gvconst(pTHX_ register OP *o)
4964 o = fold_constants(o);
4965 if (o->op_type == OP_CONST)
4972 Perl_ck_rvconst(pTHX_ register OP *o)
4974 SVOP *kid = (SVOP*)cUNOPo->op_first;
4976 o->op_private |= (PL_hints & HINT_STRICT_REFS);
4977 if (kid->op_type == OP_CONST) {
4981 SV *kidsv = kid->op_sv;
4984 /* Is it a constant from cv_const_sv()? */
4985 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
4986 SV *rsv = SvRV(kidsv);
4987 int svtype = SvTYPE(rsv);
4988 char *badtype = Nullch;
4990 switch (o->op_type) {
4992 if (svtype > SVt_PVMG)
4993 badtype = "a SCALAR";
4996 if (svtype != SVt_PVAV)
4997 badtype = "an ARRAY";
5000 if (svtype != SVt_PVHV)
5004 if (svtype != SVt_PVCV)
5009 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5012 name = SvPV(kidsv, n_a);
5013 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5014 char *badthing = Nullch;
5015 switch (o->op_type) {
5017 badthing = "a SCALAR";
5020 badthing = "an ARRAY";
5023 badthing = "a HASH";
5028 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5032 * This is a little tricky. We only want to add the symbol if we
5033 * didn't add it in the lexer. Otherwise we get duplicate strict
5034 * warnings. But if we didn't add it in the lexer, we must at
5035 * least pretend like we wanted to add it even if it existed before,
5036 * or we get possible typo warnings. OPpCONST_ENTERED says
5037 * whether the lexer already added THIS instance of this symbol.
5039 iscv = (o->op_type == OP_RV2CV) * 2;
5041 gv = gv_fetchpv(name,
5042 iscv | !(kid->op_private & OPpCONST_ENTERED),
5045 : o->op_type == OP_RV2SV
5047 : o->op_type == OP_RV2AV
5049 : o->op_type == OP_RV2HV
5052 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5054 kid->op_type = OP_GV;
5055 SvREFCNT_dec(kid->op_sv);
5057 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5058 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5059 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
5061 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
5063 kid->op_sv = SvREFCNT_inc(gv);
5065 kid->op_private = 0;
5066 kid->op_ppaddr = PL_ppaddr[OP_GV];
5073 Perl_ck_ftst(pTHX_ OP *o)
5075 I32 type = o->op_type;
5077 if (o->op_flags & OPf_REF) {
5080 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5081 SVOP *kid = (SVOP*)cUNOPo->op_first;
5083 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5085 OP *newop = newGVOP(type, OPf_REF,
5086 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5091 if ((PL_hints & HINT_FILETEST_ACCESS) &&
5092 OP_IS_FILETEST_ACCESS(o))
5093 o->op_private |= OPpFT_ACCESS;
5095 if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
5096 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
5097 o->op_private |= OPpFT_STACKED;
5101 if (type == OP_FTTTY)
5102 o = newGVOP(type, OPf_REF, PL_stdingv);
5104 o = newUNOP(type, 0, newDEFSVOP());
5110 Perl_ck_fun(pTHX_ OP *o)
5116 int type = o->op_type;
5117 register I32 oa = PL_opargs[type] >> OASHIFT;
5119 if (o->op_flags & OPf_STACKED) {
5120 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5123 return no_fh_allowed(o);
5126 if (o->op_flags & OPf_KIDS) {
5128 tokid = &cLISTOPo->op_first;
5129 kid = cLISTOPo->op_first;
5130 if (kid->op_type == OP_PUSHMARK ||
5131 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5133 tokid = &kid->op_sibling;
5134 kid = kid->op_sibling;
5136 if (!kid && PL_opargs[type] & OA_DEFGV)
5137 *tokid = kid = newDEFSVOP();
5141 sibl = kid->op_sibling;
5144 /* list seen where single (scalar) arg expected? */
5145 if (numargs == 1 && !(oa >> 4)
5146 && kid->op_type == OP_LIST && type != OP_SCALAR)
5148 return too_many_arguments(o,PL_op_desc[type]);
5161 if ((type == OP_PUSH || type == OP_UNSHIFT)
5162 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5163 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5164 "Useless use of %s with no values",
5167 if (kid->op_type == OP_CONST &&
5168 (kid->op_private & OPpCONST_BARE))
5170 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5171 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5172 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5173 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5174 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5175 "Array @%s missing the @ in argument %"IVdf" of %s()",
5176 name, (IV)numargs, PL_op_desc[type]);
5179 kid->op_sibling = sibl;
5182 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5183 bad_type(numargs, "array", PL_op_desc[type], kid);
5187 if (kid->op_type == OP_CONST &&
5188 (kid->op_private & OPpCONST_BARE))
5190 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5191 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5192 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5193 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5194 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5195 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5196 name, (IV)numargs, PL_op_desc[type]);
5199 kid->op_sibling = sibl;
5202 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5203 bad_type(numargs, "hash", PL_op_desc[type], kid);
5208 OP *newop = newUNOP(OP_NULL, 0, kid);
5209 kid->op_sibling = 0;
5211 newop->op_next = newop;
5213 kid->op_sibling = sibl;
5218 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5219 if (kid->op_type == OP_CONST &&
5220 (kid->op_private & OPpCONST_BARE))
5222 OP *newop = newGVOP(OP_GV, 0,
5223 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5225 if (!(o->op_private & 1) && /* if not unop */
5226 kid == cLISTOPo->op_last)
5227 cLISTOPo->op_last = newop;
5231 else if (kid->op_type == OP_READLINE) {
5232 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5233 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5236 I32 flags = OPf_SPECIAL;
5240 /* is this op a FH constructor? */
5241 if (is_handle_constructor(o,numargs)) {
5242 char *name = Nullch;
5246 /* Set a flag to tell rv2gv to vivify
5247 * need to "prove" flag does not mean something
5248 * else already - NI-S 1999/05/07
5251 if (kid->op_type == OP_PADSV) {
5252 name = PAD_COMPNAME_PV(kid->op_targ);
5253 /* SvCUR of a pad namesv can't be trusted
5254 * (see PL_generation), so calc its length
5260 else if (kid->op_type == OP_RV2SV
5261 && kUNOP->op_first->op_type == OP_GV)
5263 GV *gv = cGVOPx_gv(kUNOP->op_first);
5265 len = GvNAMELEN(gv);
5267 else if (kid->op_type == OP_AELEM
5268 || kid->op_type == OP_HELEM)
5273 if ((op = ((BINOP*)kid)->op_first)) {
5274 SV *tmpstr = Nullsv;
5276 kid->op_type == OP_AELEM ?
5278 if (((op->op_type == OP_RV2AV) ||
5279 (op->op_type == OP_RV2HV)) &&
5280 (op = ((UNOP*)op)->op_first) &&
5281 (op->op_type == OP_GV)) {
5282 /* packagevar $a[] or $h{} */
5283 GV *gv = cGVOPx_gv(op);
5291 else if (op->op_type == OP_PADAV
5292 || op->op_type == OP_PADHV) {
5293 /* lexicalvar $a[] or $h{} */
5295 PAD_COMPNAME_PV(op->op_targ);
5305 name = SvPV(tmpstr, len);
5310 name = "__ANONIO__";
5317 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5318 namesv = PAD_SVl(targ);
5319 (void)SvUPGRADE(namesv, SVt_PV);
5321 sv_setpvn(namesv, "$", 1);
5322 sv_catpvn(namesv, name, len);
5325 kid->op_sibling = 0;
5326 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5327 kid->op_targ = targ;
5328 kid->op_private |= priv;
5330 kid->op_sibling = sibl;
5336 mod(scalar(kid), type);
5340 tokid = &kid->op_sibling;
5341 kid = kid->op_sibling;
5343 o->op_private |= numargs;
5345 return too_many_arguments(o,OP_DESC(o));
5348 else if (PL_opargs[type] & OA_DEFGV) {
5350 return newUNOP(type, 0, newDEFSVOP());
5354 while (oa & OA_OPTIONAL)
5356 if (oa && oa != OA_LIST)
5357 return too_few_arguments(o,OP_DESC(o));
5363 Perl_ck_glob(pTHX_ OP *o)
5368 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5369 append_elem(OP_GLOB, o, newDEFSVOP());
5371 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5372 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5374 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5377 #if !defined(PERL_EXTERNAL_GLOB)
5378 /* XXX this can be tightened up and made more failsafe. */
5379 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5382 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5383 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5384 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5385 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5386 GvCV(gv) = GvCV(glob_gv);
5387 SvREFCNT_inc((SV*)GvCV(gv));
5388 GvIMPORTED_CV_on(gv);
5391 #endif /* PERL_EXTERNAL_GLOB */
5393 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5394 append_elem(OP_GLOB, o,
5395 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5396 o->op_type = OP_LIST;
5397 o->op_ppaddr = PL_ppaddr[OP_LIST];
5398 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5399 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5400 cLISTOPo->op_first->op_targ = 0;
5401 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5402 append_elem(OP_LIST, o,
5403 scalar(newUNOP(OP_RV2CV, 0,
5404 newGVOP(OP_GV, 0, gv)))));
5405 o = newUNOP(OP_NULL, 0, ck_subr(o));
5406 o->op_targ = OP_GLOB; /* hint at what it used to be */
5409 gv = newGVgen("main");
5411 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5417 Perl_ck_grep(pTHX_ OP *o)
5421 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5424 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5425 NewOp(1101, gwop, 1, LOGOP);
5427 if (o->op_flags & OPf_STACKED) {
5430 kid = cLISTOPo->op_first->op_sibling;
5431 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5434 kid->op_next = (OP*)gwop;
5435 o->op_flags &= ~OPf_STACKED;
5437 kid = cLISTOPo->op_first->op_sibling;
5438 if (type == OP_MAPWHILE)
5445 kid = cLISTOPo->op_first->op_sibling;
5446 if (kid->op_type != OP_NULL)
5447 Perl_croak(aTHX_ "panic: ck_grep");
5448 kid = kUNOP->op_first;
5450 gwop->op_type = type;
5451 gwop->op_ppaddr = PL_ppaddr[type];
5452 gwop->op_first = listkids(o);
5453 gwop->op_flags |= OPf_KIDS;
5454 gwop->op_other = LINKLIST(kid);
5455 kid->op_next = (OP*)gwop;
5456 offset = pad_findmy("$_");
5457 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
5458 o->op_private = gwop->op_private = 0;
5459 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5462 o->op_private = gwop->op_private = OPpGREP_LEX;
5463 gwop->op_targ = o->op_targ = offset;
5466 kid = cLISTOPo->op_first->op_sibling;
5467 if (!kid || !kid->op_sibling)
5468 return too_few_arguments(o,OP_DESC(o));
5469 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5470 mod(kid, OP_GREPSTART);
5476 Perl_ck_index(pTHX_ OP *o)
5478 if (o->op_flags & OPf_KIDS) {
5479 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5481 kid = kid->op_sibling; /* get past "big" */
5482 if (kid && kid->op_type == OP_CONST)
5483 fbm_compile(((SVOP*)kid)->op_sv, 0);
5489 Perl_ck_lengthconst(pTHX_ OP *o)
5491 /* XXX length optimization goes here */
5496 Perl_ck_lfun(pTHX_ OP *o)
5498 OPCODE type = o->op_type;
5499 return modkids(ck_fun(o), type);
5503 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5505 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5506 switch (cUNOPo->op_first->op_type) {
5508 /* This is needed for
5509 if (defined %stash::)
5510 to work. Do not break Tk.
5512 break; /* Globals via GV can be undef */
5514 case OP_AASSIGN: /* Is this a good idea? */
5515 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5516 "defined(@array) is deprecated");
5517 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5518 "\t(Maybe you should just omit the defined()?)\n");
5521 /* This is needed for
5522 if (defined %stash::)
5523 to work. Do not break Tk.
5525 break; /* Globals via GV can be undef */
5527 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5528 "defined(%%hash) is deprecated");
5529 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5530 "\t(Maybe you should just omit the defined()?)\n");
5541 Perl_ck_rfun(pTHX_ OP *o)
5543 OPCODE type = o->op_type;
5544 return refkids(ck_fun(o), type);
5548 Perl_ck_listiob(pTHX_ OP *o)
5552 kid = cLISTOPo->op_first;
5555 kid = cLISTOPo->op_first;
5557 if (kid->op_type == OP_PUSHMARK)
5558 kid = kid->op_sibling;
5559 if (kid && o->op_flags & OPf_STACKED)
5560 kid = kid->op_sibling;
5561 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5562 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5563 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5564 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5565 cLISTOPo->op_first->op_sibling = kid;
5566 cLISTOPo->op_last = kid;
5567 kid = kid->op_sibling;
5572 append_elem(o->op_type, o, newDEFSVOP());
5578 Perl_ck_sassign(pTHX_ OP *o)
5580 OP *kid = cLISTOPo->op_first;
5581 /* has a disposable target? */
5582 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5583 && !(kid->op_flags & OPf_STACKED)
5584 /* Cannot steal the second time! */
5585 && !(kid->op_private & OPpTARGET_MY))
5587 OP *kkid = kid->op_sibling;
5589 /* Can just relocate the target. */
5590 if (kkid && kkid->op_type == OP_PADSV
5591 && !(kkid->op_private & OPpLVAL_INTRO))
5593 kid->op_targ = kkid->op_targ;
5595 /* Now we do not need PADSV and SASSIGN. */
5596 kid->op_sibling = o->op_sibling; /* NULL */
5597 cLISTOPo->op_first = NULL;
5600 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
5604 /* optimise C<my $x = undef> to C<my $x> */
5605 if (kid->op_type == OP_UNDEF) {
5606 OP *kkid = kid->op_sibling;
5607 if (kkid && kkid->op_type == OP_PADSV
5608 && (kkid->op_private & OPpLVAL_INTRO))
5610 cLISTOPo->op_first = NULL;
5611 kid->op_sibling = NULL;
5621 Perl_ck_match(pTHX_ OP *o)
5623 if (o->op_type != OP_QR) {
5624 I32 offset = pad_findmy("$_");
5625 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS(offset) & SVpad_OUR)) {
5626 o->op_targ = offset;
5627 o->op_private |= OPpTARGET_MY;
5630 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
5631 o->op_private |= OPpRUNTIME;
5636 Perl_ck_method(pTHX_ OP *o)
5638 OP *kid = cUNOPo->op_first;
5639 if (kid->op_type == OP_CONST) {
5640 SV* sv = kSVOP->op_sv;
5641 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
5643 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5644 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
5647 kSVOP->op_sv = Nullsv;
5649 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5658 Perl_ck_null(pTHX_ OP *o)
5664 Perl_ck_open(pTHX_ OP *o)
5666 HV *table = GvHV(PL_hintgv);
5670 svp = hv_fetch(table, "open_IN", 7, FALSE);
5672 mode = mode_from_discipline(*svp);
5673 if (mode & O_BINARY)
5674 o->op_private |= OPpOPEN_IN_RAW;
5675 else if (mode & O_TEXT)
5676 o->op_private |= OPpOPEN_IN_CRLF;
5679 svp = hv_fetch(table, "open_OUT", 8, FALSE);
5681 mode = mode_from_discipline(*svp);
5682 if (mode & O_BINARY)
5683 o->op_private |= OPpOPEN_OUT_RAW;
5684 else if (mode & O_TEXT)
5685 o->op_private |= OPpOPEN_OUT_CRLF;
5688 if (o->op_type == OP_BACKTICK)
5691 /* In case of three-arg dup open remove strictness
5692 * from the last arg if it is a bareword. */
5693 OP *first = cLISTOPx(o)->op_first; /* The pushmark. */
5694 OP *last = cLISTOPx(o)->op_last; /* The bareword. */
5698 if ((last->op_type == OP_CONST) && /* The bareword. */
5699 (last->op_private & OPpCONST_BARE) &&
5700 (last->op_private & OPpCONST_STRICT) &&
5701 (oa = first->op_sibling) && /* The fh. */
5702 (oa = oa->op_sibling) && /* The mode. */
5703 SvPOK(((SVOP*)oa)->op_sv) &&
5704 (mode = SvPVX(((SVOP*)oa)->op_sv)) &&
5705 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
5706 (last == oa->op_sibling)) /* The bareword. */
5707 last->op_private &= ~OPpCONST_STRICT;
5713 Perl_ck_repeat(pTHX_ OP *o)
5715 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5716 o->op_private |= OPpREPEAT_DOLIST;
5717 cBINOPo->op_first = force_list(cBINOPo->op_first);
5725 Perl_ck_require(pTHX_ OP *o)
5729 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
5730 SVOP *kid = (SVOP*)cUNOPo->op_first;
5732 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5734 for (s = SvPVX(kid->op_sv); *s; s++) {
5735 if (*s == ':' && s[1] == ':') {
5737 Move(s+2, s+1, strlen(s+2)+1, char);
5738 --SvCUR(kid->op_sv);
5741 if (SvREADONLY(kid->op_sv)) {
5742 SvREADONLY_off(kid->op_sv);
5743 sv_catpvn(kid->op_sv, ".pm", 3);
5744 SvREADONLY_on(kid->op_sv);
5747 sv_catpvn(kid->op_sv, ".pm", 3);
5751 /* handle override, if any */
5752 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
5753 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
5754 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
5756 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5757 OP *kid = cUNOPo->op_first;
5758 cUNOPo->op_first = 0;
5760 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5761 append_elem(OP_LIST, kid,
5762 scalar(newUNOP(OP_RV2CV, 0,
5771 Perl_ck_return(pTHX_ OP *o)
5774 if (CvLVALUE(PL_compcv)) {
5775 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5776 mod(kid, OP_LEAVESUBLV);
5783 Perl_ck_retarget(pTHX_ OP *o)
5785 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5792 Perl_ck_select(pTHX_ OP *o)
5795 if (o->op_flags & OPf_KIDS) {
5796 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5797 if (kid && kid->op_sibling) {
5798 o->op_type = OP_SSELECT;
5799 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
5801 return fold_constants(o);
5805 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5806 if (kid && kid->op_type == OP_RV2GV)
5807 kid->op_private &= ~HINT_STRICT_REFS;
5812 Perl_ck_shift(pTHX_ OP *o)
5814 I32 type = o->op_type;
5816 if (!(o->op_flags & OPf_KIDS)) {
5820 argop = newUNOP(OP_RV2AV, 0,
5821 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
5822 return newUNOP(type, 0, scalar(argop));
5824 return scalar(modkids(ck_fun(o), type));
5828 Perl_ck_sort(pTHX_ OP *o)
5832 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
5834 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5835 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
5837 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
5839 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
5841 if (kid->op_type == OP_SCOPE) {
5845 else if (kid->op_type == OP_LEAVE) {
5846 if (o->op_type == OP_SORT) {
5847 op_null(kid); /* wipe out leave */
5850 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
5851 if (k->op_next == kid)
5853 /* don't descend into loops */
5854 else if (k->op_type == OP_ENTERLOOP
5855 || k->op_type == OP_ENTERITER)
5857 k = cLOOPx(k)->op_lastop;
5862 kid->op_next = 0; /* just disconnect the leave */
5863 k = kLISTOP->op_first;
5868 if (o->op_type == OP_SORT) {
5869 /* provide scalar context for comparison function/block */
5875 o->op_flags |= OPf_SPECIAL;
5877 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
5880 firstkid = firstkid->op_sibling;
5883 /* provide list context for arguments */
5884 if (o->op_type == OP_SORT)
5891 S_simplify_sort(pTHX_ OP *o)
5893 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5897 if (!(o->op_flags & OPf_STACKED))
5899 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
5900 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
5901 kid = kUNOP->op_first; /* get past null */
5902 if (kid->op_type != OP_SCOPE)
5904 kid = kLISTOP->op_last; /* get past scope */
5905 switch(kid->op_type) {
5913 k = kid; /* remember this node*/
5914 if (kBINOP->op_first->op_type != OP_RV2SV)
5916 kid = kBINOP->op_first; /* get past cmp */
5917 if (kUNOP->op_first->op_type != OP_GV)
5919 kid = kUNOP->op_first; /* get past rv2sv */
5921 if (GvSTASH(gv) != PL_curstash)
5923 if (strEQ(GvNAME(gv), "a"))
5925 else if (strEQ(GvNAME(gv), "b"))
5929 kid = k; /* back to cmp */
5930 if (kBINOP->op_last->op_type != OP_RV2SV)
5932 kid = kBINOP->op_last; /* down to 2nd arg */
5933 if (kUNOP->op_first->op_type != OP_GV)
5935 kid = kUNOP->op_first; /* get past rv2sv */
5937 if (GvSTASH(gv) != PL_curstash
5939 ? strNE(GvNAME(gv), "a")
5940 : strNE(GvNAME(gv), "b")))
5942 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
5944 o->op_private |= OPpSORT_REVERSE;
5945 if (k->op_type == OP_NCMP)
5946 o->op_private |= OPpSORT_NUMERIC;
5947 if (k->op_type == OP_I_NCMP)
5948 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
5949 kid = cLISTOPo->op_first->op_sibling;
5950 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
5951 op_free(kid); /* then delete it */
5955 Perl_ck_split(pTHX_ OP *o)
5959 if (o->op_flags & OPf_STACKED)
5960 return no_fh_allowed(o);
5962 kid = cLISTOPo->op_first;
5963 if (kid->op_type != OP_NULL)
5964 Perl_croak(aTHX_ "panic: ck_split");
5965 kid = kid->op_sibling;
5966 op_free(cLISTOPo->op_first);
5967 cLISTOPo->op_first = kid;
5969 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
5970 cLISTOPo->op_last = kid; /* There was only one element previously */
5973 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
5974 OP *sibl = kid->op_sibling;
5975 kid->op_sibling = 0;
5976 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
5977 if (cLISTOPo->op_first == cLISTOPo->op_last)
5978 cLISTOPo->op_last = kid;
5979 cLISTOPo->op_first = kid;
5980 kid->op_sibling = sibl;
5983 kid->op_type = OP_PUSHRE;
5984 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
5986 if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
5987 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
5988 "Use of /g modifier is meaningless in split");
5991 if (!kid->op_sibling)
5992 append_elem(OP_SPLIT, o, newDEFSVOP());
5994 kid = kid->op_sibling;
5997 if (!kid->op_sibling)
5998 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6000 kid = kid->op_sibling;
6003 if (kid->op_sibling)
6004 return too_many_arguments(o,OP_DESC(o));
6010 Perl_ck_join(pTHX_ OP *o)
6012 if (ckWARN(WARN_SYNTAX)) {
6013 OP *kid = cLISTOPo->op_first->op_sibling;
6014 if (kid && kid->op_type == OP_MATCH) {
6015 char *pmstr = "STRING";
6016 if (PM_GETRE(kPMOP))
6017 pmstr = PM_GETRE(kPMOP)->precomp;
6018 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6019 "/%s/ should probably be written as \"%s\"",
6027 Perl_ck_subr(pTHX_ OP *o)
6029 OP *prev = ((cUNOPo->op_first->op_sibling)
6030 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6031 OP *o2 = prev->op_sibling;
6038 I32 contextclass = 0;
6043 o->op_private |= OPpENTERSUB_HASTARG;
6044 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6045 if (cvop->op_type == OP_RV2CV) {
6047 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6048 op_null(cvop); /* disable rv2cv */
6049 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6050 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6051 GV *gv = cGVOPx_gv(tmpop);
6054 tmpop->op_private |= OPpEARLY_CV;
6057 namegv = CvANON(cv) ? gv : CvGV(cv);
6058 proto = SvPV((SV*)cv, n_a);
6060 if (CvASSERTION(cv)) {
6061 if (PL_hints & HINT_ASSERTING) {
6062 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
6063 o->op_private |= OPpENTERSUB_DB;
6067 if (ckWARN(WARN_ASSERTIONS) && !(PL_hints & HINT_ASSERTIONSSEEN)) {
6068 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
6069 "Impossible to activate assertion call");
6076 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6077 if (o2->op_type == OP_CONST)
6078 o2->op_private &= ~OPpCONST_STRICT;
6079 else if (o2->op_type == OP_LIST) {
6080 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6081 if (o && o->op_type == OP_CONST)
6082 o->op_private &= ~OPpCONST_STRICT;
6085 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6086 if (PERLDB_SUB && PL_curstash != PL_debstash)
6087 o->op_private |= OPpENTERSUB_DB;
6088 while (o2 != cvop) {
6092 return too_many_arguments(o, gv_ename(namegv));
6110 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6112 arg == 1 ? "block or sub {}" : "sub {}",
6113 gv_ename(namegv), o2);
6116 /* '*' allows any scalar type, including bareword */
6119 if (o2->op_type == OP_RV2GV)
6120 goto wrapref; /* autoconvert GLOB -> GLOBref */
6121 else if (o2->op_type == OP_CONST)
6122 o2->op_private &= ~OPpCONST_STRICT;
6123 else if (o2->op_type == OP_ENTERSUB) {
6124 /* accidental subroutine, revert to bareword */
6125 OP *gvop = ((UNOP*)o2)->op_first;
6126 if (gvop && gvop->op_type == OP_NULL) {
6127 gvop = ((UNOP*)gvop)->op_first;
6129 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6132 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6133 (gvop = ((UNOP*)gvop)->op_first) &&
6134 gvop->op_type == OP_GV)
6136 GV *gv = cGVOPx_gv(gvop);
6137 OP *sibling = o2->op_sibling;
6138 SV *n = newSVpvn("",0);
6140 gv_fullname3(n, gv, "");
6141 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6142 sv_chop(n, SvPVX(n)+6);
6143 o2 = newSVOP(OP_CONST, 0, n);
6144 prev->op_sibling = o2;
6145 o2->op_sibling = sibling;
6161 if (contextclass++ == 0) {
6162 e = strchr(proto, ']');
6163 if (!e || e == proto)
6176 while (*--p != '[');
6177 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6178 gv_ename(namegv), o2);
6184 if (o2->op_type == OP_RV2GV)
6187 bad_type(arg, "symbol", gv_ename(namegv), o2);
6190 if (o2->op_type == OP_ENTERSUB)
6193 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6196 if (o2->op_type == OP_RV2SV ||
6197 o2->op_type == OP_PADSV ||
6198 o2->op_type == OP_HELEM ||
6199 o2->op_type == OP_AELEM ||
6200 o2->op_type == OP_THREADSV)
6203 bad_type(arg, "scalar", gv_ename(namegv), o2);
6206 if (o2->op_type == OP_RV2AV ||
6207 o2->op_type == OP_PADAV)
6210 bad_type(arg, "array", gv_ename(namegv), o2);
6213 if (o2->op_type == OP_RV2HV ||
6214 o2->op_type == OP_PADHV)
6217 bad_type(arg, "hash", gv_ename(namegv), o2);
6222 OP* sib = kid->op_sibling;
6223 kid->op_sibling = 0;
6224 o2 = newUNOP(OP_REFGEN, 0, kid);
6225 o2->op_sibling = sib;
6226 prev->op_sibling = o2;
6228 if (contextclass && e) {
6243 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6244 gv_ename(namegv), cv);
6249 mod(o2, OP_ENTERSUB);
6251 o2 = o2->op_sibling;
6253 if (proto && !optional &&
6254 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6255 return too_few_arguments(o, gv_ename(namegv));
6258 o=newSVOP(OP_CONST, 0, newSViv(0));
6264 Perl_ck_svconst(pTHX_ OP *o)
6266 SvREADONLY_on(cSVOPo->op_sv);
6271 Perl_ck_trunc(pTHX_ OP *o)
6273 if (o->op_flags & OPf_KIDS) {
6274 SVOP *kid = (SVOP*)cUNOPo->op_first;
6276 if (kid->op_type == OP_NULL)
6277 kid = (SVOP*)kid->op_sibling;
6278 if (kid && kid->op_type == OP_CONST &&
6279 (kid->op_private & OPpCONST_BARE))
6281 o->op_flags |= OPf_SPECIAL;
6282 kid->op_private &= ~OPpCONST_STRICT;
6289 Perl_ck_unpack(pTHX_ OP *o)
6291 OP *kid = cLISTOPo->op_first;
6292 if (kid->op_sibling) {
6293 kid = kid->op_sibling;
6294 if (!kid->op_sibling)
6295 kid->op_sibling = newDEFSVOP();
6301 Perl_ck_substr(pTHX_ OP *o)
6304 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6305 OP *kid = cLISTOPo->op_first;
6307 if (kid->op_type == OP_NULL)
6308 kid = kid->op_sibling;
6310 kid->op_flags |= OPf_MOD;
6316 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6319 Perl_peep(pTHX_ register OP *o)
6321 register OP* oldop = 0;
6323 if (!o || o->op_opt)
6327 SAVEVPTR(PL_curcop);
6328 for (; o; o = o->op_next) {
6332 switch (o->op_type) {
6336 PL_curcop = ((COP*)o); /* for warnings */
6341 if (cSVOPo->op_private & OPpCONST_STRICT)
6342 no_bareword_allowed(o);
6344 case OP_METHOD_NAMED:
6345 /* Relocate sv to the pad for thread safety.
6346 * Despite being a "constant", the SV is written to,
6347 * for reference counts, sv_upgrade() etc. */
6349 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6350 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6351 /* If op_sv is already a PADTMP then it is being used by
6352 * some pad, so make a copy. */
6353 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6354 SvREADONLY_on(PAD_SVl(ix));
6355 SvREFCNT_dec(cSVOPo->op_sv);
6358 SvREFCNT_dec(PAD_SVl(ix));
6359 SvPADTMP_on(cSVOPo->op_sv);
6360 PAD_SETSV(ix, cSVOPo->op_sv);
6361 /* XXX I don't know how this isn't readonly already. */
6362 SvREADONLY_on(PAD_SVl(ix));
6364 cSVOPo->op_sv = Nullsv;
6372 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6373 if (o->op_next->op_private & OPpTARGET_MY) {
6374 if (o->op_flags & OPf_STACKED) /* chained concats */
6375 goto ignore_optimization;
6377 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6378 o->op_targ = o->op_next->op_targ;
6379 o->op_next->op_targ = 0;
6380 o->op_private |= OPpTARGET_MY;
6383 op_null(o->op_next);
6385 ignore_optimization:
6389 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6391 break; /* Scalar stub must produce undef. List stub is noop */
6395 if (o->op_targ == OP_NEXTSTATE
6396 || o->op_targ == OP_DBSTATE
6397 || o->op_targ == OP_SETSTATE)
6399 PL_curcop = ((COP*)o);
6401 /* XXX: We avoid setting op_seq here to prevent later calls
6402 to peep() from mistakenly concluding that optimisation
6403 has already occurred. This doesn't fix the real problem,
6404 though (See 20010220.007). AMS 20010719 */
6405 /* op_seq functionality is now replaced by op_opt */
6406 if (oldop && o->op_next) {
6407 oldop->op_next = o->op_next;
6415 if (oldop && o->op_next) {
6416 oldop->op_next = o->op_next;
6424 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
6425 OP* pop = (o->op_type == OP_PADAV) ?
6426 o->op_next : o->op_next->op_next;
6428 if (pop && pop->op_type == OP_CONST &&
6429 ((PL_op = pop->op_next)) &&
6430 pop->op_next->op_type == OP_AELEM &&
6431 !(pop->op_next->op_private &
6432 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6433 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6438 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
6439 no_bareword_allowed(pop);
6440 if (o->op_type == OP_GV)
6441 op_null(o->op_next);
6442 op_null(pop->op_next);
6444 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6445 o->op_next = pop->op_next->op_next;
6446 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6447 o->op_private = (U8)i;
6448 if (o->op_type == OP_GV) {
6453 o->op_flags |= OPf_SPECIAL;
6454 o->op_type = OP_AELEMFAST;
6460 if (o->op_next->op_type == OP_RV2SV) {
6461 if (!(o->op_next->op_private & OPpDEREF)) {
6462 op_null(o->op_next);
6463 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6465 o->op_next = o->op_next->op_next;
6466 o->op_type = OP_GVSV;
6467 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6470 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6472 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6473 /* XXX could check prototype here instead of just carping */
6474 SV *sv = sv_newmortal();
6475 gv_efullname3(sv, gv, Nullch);
6476 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6477 "%"SVf"() called too early to check prototype",
6481 else if (o->op_next->op_type == OP_READLINE
6482 && o->op_next->op_next->op_type == OP_CONCAT
6483 && (o->op_next->op_next->op_flags & OPf_STACKED))
6485 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6486 o->op_type = OP_RCATLINE;
6487 o->op_flags |= OPf_STACKED;
6488 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6489 op_null(o->op_next->op_next);
6490 op_null(o->op_next);
6507 while (cLOGOP->op_other->op_type == OP_NULL)
6508 cLOGOP->op_other = cLOGOP->op_other->op_next;
6509 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6515 while (cLOOP->op_redoop->op_type == OP_NULL)
6516 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6517 peep(cLOOP->op_redoop);
6518 while (cLOOP->op_nextop->op_type == OP_NULL)
6519 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6520 peep(cLOOP->op_nextop);
6521 while (cLOOP->op_lastop->op_type == OP_NULL)
6522 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6523 peep(cLOOP->op_lastop);
6530 while (cPMOP->op_pmreplstart &&
6531 cPMOP->op_pmreplstart->op_type == OP_NULL)
6532 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6533 peep(cPMOP->op_pmreplstart);
6538 if (ckWARN(WARN_SYNTAX) && o->op_next
6539 && o->op_next->op_type == OP_NEXTSTATE) {
6540 if (o->op_next->op_sibling &&
6541 o->op_next->op_sibling->op_type != OP_EXIT &&
6542 o->op_next->op_sibling->op_type != OP_WARN &&
6543 o->op_next->op_sibling->op_type != OP_DIE) {
6544 line_t oldline = CopLINE(PL_curcop);
6546 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6547 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6548 "Statement unlikely to be reached");
6549 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6550 "\t(Maybe you meant system() when you said exec()?)\n");
6551 CopLINE_set(PL_curcop, oldline);
6564 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6567 /* Make the CONST have a shared SV */
6568 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6569 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6570 key = SvPV(sv, keylen);
6571 lexname = newSVpvn_share(key,
6572 SvUTF8(sv) ? -(I32)keylen : keylen,
6581 /* make @a = sort @a act in-place */
6583 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
6589 /* check that RHS of sort is a single plain array */
6590 oright = cUNOPo->op_first;
6591 if (!oright || oright->op_type != OP_PUSHMARK)
6593 oright = cUNOPx(oright)->op_sibling;
6596 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
6597 oright = cUNOPx(oright)->op_sibling;
6601 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
6602 || oright->op_next != o
6603 || (oright->op_private & OPpLVAL_INTRO)
6607 /* o2 follows the chain of op_nexts through the LHS of the
6608 * assign (if any) to the aassign op itself */
6610 if (!o2 || o2->op_type != OP_NULL)
6613 if (!o2 || o2->op_type != OP_PUSHMARK)
6616 if (o2 && o2->op_type == OP_GV)
6619 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
6620 || (o2->op_private & OPpLVAL_INTRO)
6625 if (!o2 || o2->op_type != OP_NULL)
6628 if (!o2 || o2->op_type != OP_AASSIGN
6629 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
6632 /* check the array is the same on both sides */
6633 if (oleft->op_type == OP_RV2AV) {
6634 if (oright->op_type != OP_RV2AV
6635 || !cUNOPx(oright)->op_first
6636 || cUNOPx(oright)->op_first->op_type != OP_GV
6637 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
6638 cGVOPx_gv(cUNOPx(oright)->op_first)
6642 else if (oright->op_type != OP_PADAV
6643 || oright->op_targ != oleft->op_targ
6647 /* transfer MODishness etc from LHS arg to RHS arg */
6648 oright->op_flags = oleft->op_flags;
6649 o->op_private |= OPpSORT_INPLACE;
6651 /* excise push->gv->rv2av->null->aassign */
6652 o2 = o->op_next->op_next;
6653 op_null(o2); /* PUSHMARK */
6655 if (o2->op_type == OP_GV) {
6656 op_null(o2); /* GV */
6659 op_null(o2); /* RV2AV or PADAV */
6660 o2 = o2->op_next->op_next;
6661 op_null(o2); /* AASSIGN */
6663 o->op_next = o2->op_next;
6681 char* Perl_custom_op_name(pTHX_ OP* o)
6683 IV index = PTR2IV(o->op_ppaddr);
6687 if (!PL_custom_op_names) /* This probably shouldn't happen */
6688 return PL_op_name[OP_CUSTOM];
6690 keysv = sv_2mortal(newSViv(index));
6692 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
6694 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
6696 return SvPV_nolen(HeVAL(he));
6699 char* Perl_custom_op_desc(pTHX_ OP* o)
6701 IV index = PTR2IV(o->op_ppaddr);
6705 if (!PL_custom_op_descs)
6706 return PL_op_desc[OP_CUSTOM];
6708 keysv = sv_2mortal(newSViv(index));
6710 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
6712 return PL_op_desc[OP_CUSTOM];
6714 return SvPV_nolen(HeVAL(he));
6720 /* Efficient sub that returns a constant scalar value. */
6722 const_sv_xsub(pTHX_ CV* cv)
6727 Perl_croak(aTHX_ "usage: %s::%s()",
6728 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
6732 ST(0) = (SV*)XSANY.any_ptr;