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);
1766 /* XXX kept for BINCOMPAT only */
1768 Perl_save_hints(pTHX)
1770 Perl_croak(aTHX_ "internal error: obsolete function save_hints() called");
1774 Perl_block_start(pTHX_ int full)
1776 int retval = PL_savestack_ix;
1777 pad_block_start(full);
1779 PL_hints &= ~HINT_BLOCK_SCOPE;
1780 SAVESPTR(PL_compiling.cop_warnings);
1781 if (! specialWARN(PL_compiling.cop_warnings)) {
1782 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1783 SAVEFREESV(PL_compiling.cop_warnings) ;
1785 SAVESPTR(PL_compiling.cop_io);
1786 if (! specialCopIO(PL_compiling.cop_io)) {
1787 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1788 SAVEFREESV(PL_compiling.cop_io) ;
1794 Perl_block_end(pTHX_ I32 floor, OP *seq)
1796 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1797 OP* retval = scalarseq(seq);
1799 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
1801 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
1809 I32 offset = pad_findmy("$_");
1810 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
1811 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1814 OP *o = newOP(OP_PADSV, 0);
1815 o->op_targ = offset;
1821 Perl_newPROG(pTHX_ OP *o)
1826 PL_eval_root = newUNOP(OP_LEAVEEVAL,
1827 ((PL_in_eval & EVAL_KEEPERR)
1828 ? OPf_SPECIAL : 0), o);
1829 PL_eval_start = linklist(PL_eval_root);
1830 PL_eval_root->op_private |= OPpREFCOUNTED;
1831 OpREFCNT_set(PL_eval_root, 1);
1832 PL_eval_root->op_next = 0;
1833 CALL_PEEP(PL_eval_start);
1836 if (o->op_type == OP_STUB) {
1837 PL_comppad_name = 0;
1842 PL_main_root = scope(sawparens(scalarvoid(o)));
1843 PL_curcop = &PL_compiling;
1844 PL_main_start = LINKLIST(PL_main_root);
1845 PL_main_root->op_private |= OPpREFCOUNTED;
1846 OpREFCNT_set(PL_main_root, 1);
1847 PL_main_root->op_next = 0;
1848 CALL_PEEP(PL_main_start);
1851 /* Register with debugger */
1853 CV *cv = get_cv("DB::postponed", FALSE);
1857 XPUSHs((SV*)CopFILEGV(&PL_compiling));
1859 call_sv((SV*)cv, G_DISCARD);
1866 Perl_localize(pTHX_ OP *o, I32 lex)
1868 if (o->op_flags & OPf_PARENS)
1869 /* [perl #17376]: this appears to be premature, and results in code such as
1870 C< our(%x); > executing in list mode rather than void mode */
1877 if (ckWARN(WARN_PARENTHESIS)
1878 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
1880 char *s = PL_bufptr;
1883 /* some heuristics to detect a potential error */
1884 while (*s && (strchr(", \t\n", *s)))
1888 if (*s && strchr("@$%*", *s) && *++s
1889 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
1892 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
1894 while (*s && (strchr(", \t\n", *s)))
1900 if (sigil && (*s == ';' || *s == '=')) {
1901 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
1902 "Parentheses missing around \"%s\" list",
1903 lex ? (PL_in_my == KEY_our ? "our" : "my")
1911 o = mod(o, OP_NULL); /* a bit kludgey */
1913 PL_in_my_stash = Nullhv;
1918 Perl_jmaybe(pTHX_ OP *o)
1920 if (o->op_type == OP_LIST) {
1922 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
1923 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
1929 Perl_fold_constants(pTHX_ register OP *o)
1932 I32 type = o->op_type;
1935 if (PL_opargs[type] & OA_RETSCALAR)
1937 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
1938 o->op_targ = pad_alloc(type, SVs_PADTMP);
1940 /* integerize op, unless it happens to be C<-foo>.
1941 * XXX should pp_i_negate() do magic string negation instead? */
1942 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
1943 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
1944 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
1946 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
1949 if (!(PL_opargs[type] & OA_FOLDCONST))
1954 /* XXX might want a ck_negate() for this */
1955 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
1967 /* XXX what about the numeric ops? */
1968 if (PL_hints & HINT_LOCALE)
1973 goto nope; /* Don't try to run w/ errors */
1975 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
1976 if ((curop->op_type != OP_CONST ||
1977 (curop->op_private & OPpCONST_BARE)) &&
1978 curop->op_type != OP_LIST &&
1979 curop->op_type != OP_SCALAR &&
1980 curop->op_type != OP_NULL &&
1981 curop->op_type != OP_PUSHMARK)
1987 curop = LINKLIST(o);
1991 sv = *(PL_stack_sp--);
1992 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
1993 pad_swipe(o->op_targ, FALSE);
1994 else if (SvTEMP(sv)) { /* grab mortal temp? */
1995 (void)SvREFCNT_inc(sv);
1999 if (type == OP_RV2GV)
2000 return newGVOP(OP_GV, 0, (GV*)sv);
2001 return newSVOP(OP_CONST, 0, sv);
2008 Perl_gen_constant_list(pTHX_ register OP *o)
2011 I32 oldtmps_floor = PL_tmps_floor;
2015 return o; /* Don't attempt to run with errors */
2017 PL_op = curop = LINKLIST(o);
2024 PL_tmps_floor = oldtmps_floor;
2026 o->op_type = OP_RV2AV;
2027 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2028 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2029 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2030 o->op_opt = 0; /* needs to be revisited in peep() */
2031 curop = ((UNOP*)o)->op_first;
2032 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2039 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2041 if (!o || o->op_type != OP_LIST)
2042 o = newLISTOP(OP_LIST, 0, o, Nullop);
2044 o->op_flags &= ~OPf_WANT;
2046 if (!(PL_opargs[type] & OA_MARK))
2047 op_null(cLISTOPo->op_first);
2049 o->op_type = (OPCODE)type;
2050 o->op_ppaddr = PL_ppaddr[type];
2051 o->op_flags |= flags;
2053 o = CHECKOP(type, o);
2054 if (o->op_type != type)
2057 return fold_constants(o);
2060 /* List constructors */
2063 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2071 if (first->op_type != type
2072 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2074 return newLISTOP(type, 0, first, last);
2077 if (first->op_flags & OPf_KIDS)
2078 ((LISTOP*)first)->op_last->op_sibling = last;
2080 first->op_flags |= OPf_KIDS;
2081 ((LISTOP*)first)->op_first = last;
2083 ((LISTOP*)first)->op_last = last;
2088 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2096 if (first->op_type != type)
2097 return prepend_elem(type, (OP*)first, (OP*)last);
2099 if (last->op_type != type)
2100 return append_elem(type, (OP*)first, (OP*)last);
2102 first->op_last->op_sibling = last->op_first;
2103 first->op_last = last->op_last;
2104 first->op_flags |= (last->op_flags & OPf_KIDS);
2112 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2120 if (last->op_type == type) {
2121 if (type == OP_LIST) { /* already a PUSHMARK there */
2122 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2123 ((LISTOP*)last)->op_first->op_sibling = first;
2124 if (!(first->op_flags & OPf_PARENS))
2125 last->op_flags &= ~OPf_PARENS;
2128 if (!(last->op_flags & OPf_KIDS)) {
2129 ((LISTOP*)last)->op_last = first;
2130 last->op_flags |= OPf_KIDS;
2132 first->op_sibling = ((LISTOP*)last)->op_first;
2133 ((LISTOP*)last)->op_first = first;
2135 last->op_flags |= OPf_KIDS;
2139 return newLISTOP(type, 0, first, last);
2145 Perl_newNULLLIST(pTHX)
2147 return newOP(OP_STUB, 0);
2151 Perl_force_list(pTHX_ OP *o)
2153 if (!o || o->op_type != OP_LIST)
2154 o = newLISTOP(OP_LIST, 0, o, Nullop);
2160 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2164 NewOp(1101, listop, 1, LISTOP);
2166 listop->op_type = (OPCODE)type;
2167 listop->op_ppaddr = PL_ppaddr[type];
2170 listop->op_flags = (U8)flags;
2174 else if (!first && last)
2177 first->op_sibling = last;
2178 listop->op_first = first;
2179 listop->op_last = last;
2180 if (type == OP_LIST) {
2182 pushop = newOP(OP_PUSHMARK, 0);
2183 pushop->op_sibling = first;
2184 listop->op_first = pushop;
2185 listop->op_flags |= OPf_KIDS;
2187 listop->op_last = pushop;
2190 return CHECKOP(type, listop);
2194 Perl_newOP(pTHX_ I32 type, I32 flags)
2197 NewOp(1101, o, 1, OP);
2198 o->op_type = (OPCODE)type;
2199 o->op_ppaddr = PL_ppaddr[type];
2200 o->op_flags = (U8)flags;
2203 o->op_private = (U8)(0 | (flags >> 8));
2204 if (PL_opargs[type] & OA_RETSCALAR)
2206 if (PL_opargs[type] & OA_TARGET)
2207 o->op_targ = pad_alloc(type, SVs_PADTMP);
2208 return CHECKOP(type, o);
2212 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2217 first = newOP(OP_STUB, 0);
2218 if (PL_opargs[type] & OA_MARK)
2219 first = force_list(first);
2221 NewOp(1101, unop, 1, UNOP);
2222 unop->op_type = (OPCODE)type;
2223 unop->op_ppaddr = PL_ppaddr[type];
2224 unop->op_first = first;
2225 unop->op_flags = flags | OPf_KIDS;
2226 unop->op_private = (U8)(1 | (flags >> 8));
2227 unop = (UNOP*) CHECKOP(type, unop);
2231 return fold_constants((OP *) unop);
2235 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2238 NewOp(1101, binop, 1, BINOP);
2241 first = newOP(OP_NULL, 0);
2243 binop->op_type = (OPCODE)type;
2244 binop->op_ppaddr = PL_ppaddr[type];
2245 binop->op_first = first;
2246 binop->op_flags = flags | OPf_KIDS;
2249 binop->op_private = (U8)(1 | (flags >> 8));
2252 binop->op_private = (U8)(2 | (flags >> 8));
2253 first->op_sibling = last;
2256 binop = (BINOP*)CHECKOP(type, binop);
2257 if (binop->op_next || binop->op_type != (OPCODE)type)
2260 binop->op_last = binop->op_first->op_sibling;
2262 return fold_constants((OP *)binop);
2266 uvcompare(const void *a, const void *b)
2268 if (*((UV *)a) < (*(UV *)b))
2270 if (*((UV *)a) > (*(UV *)b))
2272 if (*((UV *)a+1) < (*(UV *)b+1))
2274 if (*((UV *)a+1) > (*(UV *)b+1))
2280 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2282 SV *tstr = ((SVOP*)expr)->op_sv;
2283 SV *rstr = ((SVOP*)repl)->op_sv;
2286 U8 *t = (U8*)SvPV(tstr, tlen);
2287 U8 *r = (U8*)SvPV(rstr, rlen);
2294 register short *tbl;
2296 PL_hints |= HINT_BLOCK_SCOPE;
2297 complement = o->op_private & OPpTRANS_COMPLEMENT;
2298 del = o->op_private & OPpTRANS_DELETE;
2299 squash = o->op_private & OPpTRANS_SQUASH;
2302 o->op_private |= OPpTRANS_FROM_UTF;
2305 o->op_private |= OPpTRANS_TO_UTF;
2307 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2308 SV* listsv = newSVpvn("# comment\n",10);
2310 U8* tend = t + tlen;
2311 U8* rend = r + rlen;
2325 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2326 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2332 tsave = t = bytes_to_utf8(t, &len);
2335 if (!to_utf && rlen) {
2337 rsave = r = bytes_to_utf8(r, &len);
2341 /* There are several snags with this code on EBCDIC:
2342 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2343 2. scan_const() in toke.c has encoded chars in native encoding which makes
2344 ranges at least in EBCDIC 0..255 range the bottom odd.
2348 U8 tmpbuf[UTF8_MAXLEN+1];
2351 New(1109, cp, 2*tlen, UV);
2353 transv = newSVpvn("",0);
2355 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2357 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2359 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2363 cp[2*i+1] = cp[2*i];
2367 qsort(cp, i, 2*sizeof(UV), uvcompare);
2368 for (j = 0; j < i; j++) {
2370 diff = val - nextmin;
2372 t = uvuni_to_utf8(tmpbuf,nextmin);
2373 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2375 U8 range_mark = UTF_TO_NATIVE(0xff);
2376 t = uvuni_to_utf8(tmpbuf, val - 1);
2377 sv_catpvn(transv, (char *)&range_mark, 1);
2378 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2385 t = uvuni_to_utf8(tmpbuf,nextmin);
2386 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2388 U8 range_mark = UTF_TO_NATIVE(0xff);
2389 sv_catpvn(transv, (char *)&range_mark, 1);
2391 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2392 UNICODE_ALLOW_SUPER);
2393 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2394 t = (U8*)SvPVX(transv);
2395 tlen = SvCUR(transv);
2399 else if (!rlen && !del) {
2400 r = t; rlen = tlen; rend = tend;
2403 if ((!rlen && !del) || t == r ||
2404 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2406 o->op_private |= OPpTRANS_IDENTICAL;
2410 while (t < tend || tfirst <= tlast) {
2411 /* see if we need more "t" chars */
2412 if (tfirst > tlast) {
2413 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2415 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2417 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2424 /* now see if we need more "r" chars */
2425 if (rfirst > rlast) {
2427 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2429 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2431 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2440 rfirst = rlast = 0xffffffff;
2444 /* now see which range will peter our first, if either. */
2445 tdiff = tlast - tfirst;
2446 rdiff = rlast - rfirst;
2453 if (rfirst == 0xffffffff) {
2454 diff = tdiff; /* oops, pretend rdiff is infinite */
2456 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2457 (long)tfirst, (long)tlast);
2459 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2463 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2464 (long)tfirst, (long)(tfirst + diff),
2467 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2468 (long)tfirst, (long)rfirst);
2470 if (rfirst + diff > max)
2471 max = rfirst + diff;
2473 grows = (tfirst < rfirst &&
2474 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2486 else if (max > 0xff)
2491 Safefree(cPVOPo->op_pv);
2492 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2493 SvREFCNT_dec(listsv);
2495 SvREFCNT_dec(transv);
2497 if (!del && havefinal && rlen)
2498 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2499 newSVuv((UV)final), 0);
2502 o->op_private |= OPpTRANS_GROWS;
2514 tbl = (short*)cPVOPo->op_pv;
2516 Zero(tbl, 256, short);
2517 for (i = 0; i < (I32)tlen; i++)
2519 for (i = 0, j = 0; i < 256; i++) {
2521 if (j >= (I32)rlen) {
2530 if (i < 128 && r[j] >= 128)
2540 o->op_private |= OPpTRANS_IDENTICAL;
2542 else if (j >= (I32)rlen)
2545 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2546 tbl[0x100] = rlen - j;
2547 for (i=0; i < (I32)rlen - j; i++)
2548 tbl[0x101+i] = r[j+i];
2552 if (!rlen && !del) {
2555 o->op_private |= OPpTRANS_IDENTICAL;
2557 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2558 o->op_private |= OPpTRANS_IDENTICAL;
2560 for (i = 0; i < 256; i++)
2562 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
2563 if (j >= (I32)rlen) {
2565 if (tbl[t[i]] == -1)
2571 if (tbl[t[i]] == -1) {
2572 if (t[i] < 128 && r[j] >= 128)
2579 o->op_private |= OPpTRANS_GROWS;
2587 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2591 NewOp(1101, pmop, 1, PMOP);
2592 pmop->op_type = (OPCODE)type;
2593 pmop->op_ppaddr = PL_ppaddr[type];
2594 pmop->op_flags = (U8)flags;
2595 pmop->op_private = (U8)(0 | (flags >> 8));
2597 if (PL_hints & HINT_RE_TAINT)
2598 pmop->op_pmpermflags |= PMf_RETAINT;
2599 if (PL_hints & HINT_LOCALE)
2600 pmop->op_pmpermflags |= PMf_LOCALE;
2601 pmop->op_pmflags = pmop->op_pmpermflags;
2606 if(av_len((AV*) PL_regex_pad[0]) > -1) {
2607 repointer = av_pop((AV*)PL_regex_pad[0]);
2608 pmop->op_pmoffset = SvIV(repointer);
2609 SvREPADTMP_off(repointer);
2610 sv_setiv(repointer,0);
2612 repointer = newSViv(0);
2613 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2614 pmop->op_pmoffset = av_len(PL_regex_padav);
2615 PL_regex_pad = AvARRAY(PL_regex_padav);
2620 /* link into pm list */
2621 if (type != OP_TRANS && PL_curstash) {
2622 pmop->op_pmnext = HvPMROOT(PL_curstash);
2623 HvPMROOT(PL_curstash) = pmop;
2624 PmopSTASH_set(pmop,PL_curstash);
2627 return CHECKOP(type, pmop);
2631 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
2635 I32 repl_has_vars = 0;
2637 if (o->op_type == OP_TRANS)
2638 return pmtrans(o, expr, repl);
2640 PL_hints |= HINT_BLOCK_SCOPE;
2643 if (expr->op_type == OP_CONST) {
2645 SV *pat = ((SVOP*)expr)->op_sv;
2646 char *p = SvPV(pat, plen);
2647 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
2648 sv_setpvn(pat, "\\s+", 3);
2649 p = SvPV(pat, plen);
2650 pm->op_pmflags |= PMf_SKIPWHITE;
2653 pm->op_pmdynflags |= PMdf_UTF8;
2654 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
2655 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
2656 pm->op_pmflags |= PMf_WHITE;
2660 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2661 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2663 : OP_REGCMAYBE),0,expr);
2665 NewOp(1101, rcop, 1, LOGOP);
2666 rcop->op_type = OP_REGCOMP;
2667 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2668 rcop->op_first = scalar(expr);
2669 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
2670 ? (OPf_SPECIAL | OPf_KIDS)
2672 rcop->op_private = 1;
2674 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
2677 /* establish postfix order */
2678 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2680 rcop->op_next = expr;
2681 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2684 rcop->op_next = LINKLIST(expr);
2685 expr->op_next = (OP*)rcop;
2688 prepend_elem(o->op_type, scalar((OP*)rcop), o);
2693 if (pm->op_pmflags & PMf_EVAL) {
2695 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
2696 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
2698 else if (repl->op_type == OP_CONST)
2702 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
2703 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
2704 if (curop->op_type == OP_GV) {
2705 GV *gv = cGVOPx_gv(curop);
2707 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
2710 else if (curop->op_type == OP_RV2CV)
2712 else if (curop->op_type == OP_RV2SV ||
2713 curop->op_type == OP_RV2AV ||
2714 curop->op_type == OP_RV2HV ||
2715 curop->op_type == OP_RV2GV) {
2716 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2719 else if (curop->op_type == OP_PADSV ||
2720 curop->op_type == OP_PADAV ||
2721 curop->op_type == OP_PADHV ||
2722 curop->op_type == OP_PADANY) {
2725 else if (curop->op_type == OP_PUSHRE)
2726 ; /* Okay here, dangerous in newASSIGNOP */
2736 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
2737 pm->op_pmflags |= PMf_CONST; /* const for long enough */
2738 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
2739 prepend_elem(o->op_type, scalar(repl), o);
2742 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
2743 pm->op_pmflags |= PMf_MAYBE_CONST;
2744 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2746 NewOp(1101, rcop, 1, LOGOP);
2747 rcop->op_type = OP_SUBSTCONT;
2748 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
2749 rcop->op_first = scalar(repl);
2750 rcop->op_flags |= OPf_KIDS;
2751 rcop->op_private = 1;
2754 /* establish postfix order */
2755 rcop->op_next = LINKLIST(repl);
2756 repl->op_next = (OP*)rcop;
2758 pm->op_pmreplroot = scalar((OP*)rcop);
2759 pm->op_pmreplstart = LINKLIST(rcop);
2768 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
2771 NewOp(1101, svop, 1, SVOP);
2772 svop->op_type = (OPCODE)type;
2773 svop->op_ppaddr = PL_ppaddr[type];
2775 svop->op_next = (OP*)svop;
2776 svop->op_flags = (U8)flags;
2777 if (PL_opargs[type] & OA_RETSCALAR)
2779 if (PL_opargs[type] & OA_TARGET)
2780 svop->op_targ = pad_alloc(type, SVs_PADTMP);
2781 return CHECKOP(type, svop);
2785 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2788 NewOp(1101, padop, 1, PADOP);
2789 padop->op_type = (OPCODE)type;
2790 padop->op_ppaddr = PL_ppaddr[type];
2791 padop->op_padix = pad_alloc(type, SVs_PADTMP);
2792 SvREFCNT_dec(PAD_SVl(padop->op_padix));
2793 PAD_SETSV(padop->op_padix, sv);
2796 padop->op_next = (OP*)padop;
2797 padop->op_flags = (U8)flags;
2798 if (PL_opargs[type] & OA_RETSCALAR)
2800 if (PL_opargs[type] & OA_TARGET)
2801 padop->op_targ = pad_alloc(type, SVs_PADTMP);
2802 return CHECKOP(type, padop);
2806 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
2811 return newPADOP(type, flags, SvREFCNT_inc(gv));
2813 return newSVOP(type, flags, SvREFCNT_inc(gv));
2818 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
2821 NewOp(1101, pvop, 1, PVOP);
2822 pvop->op_type = (OPCODE)type;
2823 pvop->op_ppaddr = PL_ppaddr[type];
2825 pvop->op_next = (OP*)pvop;
2826 pvop->op_flags = (U8)flags;
2827 if (PL_opargs[type] & OA_RETSCALAR)
2829 if (PL_opargs[type] & OA_TARGET)
2830 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
2831 return CHECKOP(type, pvop);
2835 Perl_package(pTHX_ OP *o)
2840 save_hptr(&PL_curstash);
2841 save_item(PL_curstname);
2843 name = SvPV(cSVOPo->op_sv, len);
2844 PL_curstash = gv_stashpvn(name, len, TRUE);
2845 sv_setpvn(PL_curstname, name, len);
2848 PL_hints |= HINT_BLOCK_SCOPE;
2849 PL_copline = NOLINE;
2854 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
2860 if (idop->op_type != OP_CONST)
2861 Perl_croak(aTHX_ "Module name must be constant");
2865 if (version != Nullop) {
2866 SV *vesv = ((SVOP*)version)->op_sv;
2868 if (arg == Nullop && !SvNIOKp(vesv)) {
2875 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
2876 Perl_croak(aTHX_ "Version number must be constant number");
2878 /* Make copy of idop so we don't free it twice */
2879 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
2881 /* Fake up a method call to VERSION */
2882 meth = newSVpvn("VERSION",7);
2883 sv_upgrade(meth, SVt_PVIV);
2884 (void)SvIOK_on(meth);
2885 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
2886 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2887 append_elem(OP_LIST,
2888 prepend_elem(OP_LIST, pack, list(version)),
2889 newSVOP(OP_METHOD_NAMED, 0, meth)));
2893 /* Fake up an import/unimport */
2894 if (arg && arg->op_type == OP_STUB)
2895 imop = arg; /* no import on explicit () */
2896 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
2897 imop = Nullop; /* use 5.0; */
2902 /* Make copy of idop so we don't free it twice */
2903 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
2905 /* Fake up a method call to import/unimport */
2906 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);
2907 (void)SvUPGRADE(meth, SVt_PVIV);
2908 (void)SvIOK_on(meth);
2909 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
2910 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2911 append_elem(OP_LIST,
2912 prepend_elem(OP_LIST, pack, list(arg)),
2913 newSVOP(OP_METHOD_NAMED, 0, meth)));
2916 /* Fake up the BEGIN {}, which does its thing immediately. */
2918 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
2921 append_elem(OP_LINESEQ,
2922 append_elem(OP_LINESEQ,
2923 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, idop)),
2924 newSTATEOP(0, Nullch, veop)),
2925 newSTATEOP(0, Nullch, imop) ));
2927 /* The "did you use incorrect case?" warning used to be here.
2928 * The problem is that on case-insensitive filesystems one
2929 * might get false positives for "use" (and "require"):
2930 * "use Strict" or "require CARP" will work. This causes
2931 * portability problems for the script: in case-strict
2932 * filesystems the script will stop working.
2934 * The "incorrect case" warning checked whether "use Foo"
2935 * imported "Foo" to your namespace, but that is wrong, too:
2936 * there is no requirement nor promise in the language that
2937 * a Foo.pm should or would contain anything in package "Foo".
2939 * There is very little Configure-wise that can be done, either:
2940 * the case-sensitivity of the build filesystem of Perl does not
2941 * help in guessing the case-sensitivity of the runtime environment.
2944 PL_hints |= HINT_BLOCK_SCOPE;
2945 PL_copline = NOLINE;
2947 PL_cop_seqmax++; /* Purely for B::*'s benefit */
2951 =head1 Embedding Functions
2953 =for apidoc load_module
2955 Loads the module whose name is pointed to by the string part of name.
2956 Note that the actual module name, not its filename, should be given.
2957 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
2958 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
2959 (or 0 for no flags). ver, if specified, provides version semantics
2960 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
2961 arguments can be used to specify arguments to the module's import()
2962 method, similar to C<use Foo::Bar VERSION LIST>.
2967 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
2970 va_start(args, ver);
2971 vload_module(flags, name, ver, &args);
2975 #ifdef PERL_IMPLICIT_CONTEXT
2977 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
2981 va_start(args, ver);
2982 vload_module(flags, name, ver, &args);
2988 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
2990 OP *modname, *veop, *imop;
2992 modname = newSVOP(OP_CONST, 0, name);
2993 modname->op_private |= OPpCONST_BARE;
2995 veop = newSVOP(OP_CONST, 0, ver);
2999 if (flags & PERL_LOADMOD_NOIMPORT) {
3000 imop = sawparens(newNULLLIST());
3002 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3003 imop = va_arg(*args, OP*);
3008 sv = va_arg(*args, SV*);
3010 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3011 sv = va_arg(*args, SV*);
3015 line_t ocopline = PL_copline;
3016 COP *ocurcop = PL_curcop;
3017 int oexpect = PL_expect;
3019 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3020 veop, modname, imop);
3021 PL_expect = oexpect;
3022 PL_copline = ocopline;
3023 PL_curcop = ocurcop;
3028 Perl_dofile(pTHX_ OP *term)
3033 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3034 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
3035 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3037 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3038 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3039 append_elem(OP_LIST, term,
3040 scalar(newUNOP(OP_RV2CV, 0,
3045 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3051 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3053 return newBINOP(OP_LSLICE, flags,
3054 list(force_list(subscript)),
3055 list(force_list(listval)) );
3059 S_list_assignment(pTHX_ register OP *o)
3064 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3065 o = cUNOPo->op_first;
3067 if (o->op_type == OP_COND_EXPR) {
3068 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3069 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3074 yyerror("Assignment to both a list and a scalar");
3078 if (o->op_type == OP_LIST &&
3079 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3080 o->op_private & OPpLVAL_INTRO)
3083 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3084 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3085 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3088 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3091 if (o->op_type == OP_RV2SV)
3098 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3103 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3104 return newLOGOP(optype, 0,
3105 mod(scalar(left), optype),
3106 newUNOP(OP_SASSIGN, 0, scalar(right)));
3109 return newBINOP(optype, OPf_STACKED,
3110 mod(scalar(left), optype), scalar(right));
3114 if (list_assignment(left)) {
3118 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3119 left = mod(left, OP_AASSIGN);
3127 /* optimise C<my @x = ()> to C<my @x>, and likewise for hashes */
3128 if ((left->op_type == OP_PADAV || left->op_type == OP_PADHV)
3129 && right->op_type == OP_STUB
3130 && (left->op_private & OPpLVAL_INTRO))
3135 curop = list(force_list(left));
3136 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3137 o->op_private = (U8)(0 | (flags >> 8));
3139 /* PL_generation sorcery:
3140 * an assignment like ($a,$b) = ($c,$d) is easier than
3141 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3142 * To detect whether there are common vars, the global var
3143 * PL_generation is incremented for each assign op we compile.
3144 * Then, while compiling the assign op, we run through all the
3145 * variables on both sides of the assignment, setting a spare slot
3146 * in each of them to PL_generation. If any of them already have
3147 * that value, we know we've got commonality. We could use a
3148 * single bit marker, but then we'd have to make 2 passes, first
3149 * to clear the flag, then to test and set it. To find somewhere
3150 * to store these values, evil chicanery is done with SvCUR().
3153 if (!(left->op_private & OPpLVAL_INTRO)) {
3156 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3157 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3158 if (curop->op_type == OP_GV) {
3159 GV *gv = cGVOPx_gv(curop);
3160 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3162 SvCUR(gv) = PL_generation;
3164 else if (curop->op_type == OP_PADSV ||
3165 curop->op_type == OP_PADAV ||
3166 curop->op_type == OP_PADHV ||
3167 curop->op_type == OP_PADANY)
3169 if (PAD_COMPNAME_GEN(curop->op_targ)
3170 == (STRLEN)PL_generation)
3172 PAD_COMPNAME_GEN(curop->op_targ)
3176 else if (curop->op_type == OP_RV2CV)
3178 else if (curop->op_type == OP_RV2SV ||
3179 curop->op_type == OP_RV2AV ||
3180 curop->op_type == OP_RV2HV ||
3181 curop->op_type == OP_RV2GV) {
3182 if (lastop->op_type != OP_GV) /* funny deref? */
3185 else if (curop->op_type == OP_PUSHRE) {
3186 if (((PMOP*)curop)->op_pmreplroot) {
3188 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3189 ((PMOP*)curop)->op_pmreplroot));
3191 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3193 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3195 SvCUR(gv) = PL_generation;
3204 o->op_private |= OPpASSIGN_COMMON;
3206 if (right && right->op_type == OP_SPLIT) {
3208 if ((tmpop = ((LISTOP*)right)->op_first) &&
3209 tmpop->op_type == OP_PUSHRE)
3211 PMOP *pm = (PMOP*)tmpop;
3212 if (left->op_type == OP_RV2AV &&
3213 !(left->op_private & OPpLVAL_INTRO) &&
3214 !(o->op_private & OPpASSIGN_COMMON) )
3216 tmpop = ((UNOP*)left)->op_first;
3217 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3219 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3220 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3222 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3223 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3225 pm->op_pmflags |= PMf_ONCE;
3226 tmpop = cUNOPo->op_first; /* to list (nulled) */
3227 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3228 tmpop->op_sibling = Nullop; /* don't free split */
3229 right->op_next = tmpop->op_next; /* fix starting loc */
3230 op_free(o); /* blow off assign */
3231 right->op_flags &= ~OPf_WANT;
3232 /* "I don't know and I don't care." */
3237 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3238 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3240 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3242 sv_setiv(sv, PL_modcount+1);
3250 right = newOP(OP_UNDEF, 0);
3251 if (right->op_type == OP_READLINE) {
3252 right->op_flags |= OPf_STACKED;
3253 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3256 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3257 o = newBINOP(OP_SASSIGN, flags,
3258 scalar(right), mod(scalar(left), OP_SASSIGN) );
3270 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3272 U32 seq = intro_my();
3275 NewOp(1101, cop, 1, COP);
3276 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3277 cop->op_type = OP_DBSTATE;
3278 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3281 cop->op_type = OP_NEXTSTATE;
3282 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3284 cop->op_flags = (U8)flags;
3285 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3287 cop->op_private |= NATIVE_HINTS;
3289 PL_compiling.op_private = cop->op_private;
3290 cop->op_next = (OP*)cop;
3293 cop->cop_label = label;
3294 PL_hints |= HINT_BLOCK_SCOPE;
3297 cop->cop_arybase = PL_curcop->cop_arybase;
3298 if (specialWARN(PL_curcop->cop_warnings))
3299 cop->cop_warnings = PL_curcop->cop_warnings ;
3301 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3302 if (specialCopIO(PL_curcop->cop_io))
3303 cop->cop_io = PL_curcop->cop_io;
3305 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3308 if (PL_copline == NOLINE)
3309 CopLINE_set(cop, CopLINE(PL_curcop));
3311 CopLINE_set(cop, PL_copline);
3312 PL_copline = NOLINE;
3315 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3317 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3319 CopSTASH_set(cop, PL_curstash);
3321 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3322 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3323 if (svp && *svp != &PL_sv_undef ) {
3324 (void)SvIOK_on(*svp);
3325 SvIVX(*svp) = PTR2IV(cop);
3329 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3334 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3336 return new_logop(type, flags, &first, &other);
3340 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3344 OP *first = *firstp;
3345 OP *other = *otherp;
3347 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3348 return newBINOP(type, flags, scalar(first), scalar(other));
3350 scalarboolean(first);
3351 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3352 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3353 if (type == OP_AND || type == OP_OR) {
3359 first = *firstp = cUNOPo->op_first;
3361 first->op_next = o->op_next;
3362 cUNOPo->op_first = Nullop;
3366 if (first->op_type == OP_CONST) {
3367 if (first->op_private & OPpCONST_STRICT)
3368 no_bareword_allowed(first);
3369 else if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3370 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3371 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
3372 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
3373 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
3376 if (other->op_type == OP_CONST)
3377 other->op_private |= OPpCONST_SHORTCIRCUIT;
3381 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
3383 if ( ! (o2->op_type == OP_LIST
3384 && (( o2 = cUNOPx(o2)->op_first))
3385 && o2->op_type == OP_PUSHMARK
3386 && (( o2 = o2->op_sibling)) )
3389 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
3390 || o2->op_type == OP_PADHV)
3391 && o2->op_private & OPpLVAL_INTRO
3392 && ckWARN(WARN_DEPRECATED))
3394 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
3395 "Deprecated use of my() in false conditional");
3400 if (first->op_type == OP_CONST)
3401 first->op_private |= OPpCONST_SHORTCIRCUIT;
3405 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS) &&
3406 type != OP_DOR) /* [#24076] Don't warn for <FH> err FOO. */
3408 OP *k1 = ((UNOP*)first)->op_first;
3409 OP *k2 = k1->op_sibling;
3411 switch (first->op_type)
3414 if (k2 && k2->op_type == OP_READLINE
3415 && (k2->op_flags & OPf_STACKED)
3416 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3418 warnop = k2->op_type;
3423 if (k1->op_type == OP_READDIR
3424 || k1->op_type == OP_GLOB
3425 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3426 || k1->op_type == OP_EACH)
3428 warnop = ((k1->op_type == OP_NULL)
3429 ? (OPCODE)k1->op_targ : k1->op_type);
3434 line_t oldline = CopLINE(PL_curcop);
3435 CopLINE_set(PL_curcop, PL_copline);
3436 Perl_warner(aTHX_ packWARN(WARN_MISC),
3437 "Value of %s%s can be \"0\"; test with defined()",
3439 ((warnop == OP_READLINE || warnop == OP_GLOB)
3440 ? " construct" : "() operator"));
3441 CopLINE_set(PL_curcop, oldline);
3448 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3449 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3451 NewOp(1101, logop, 1, LOGOP);
3453 logop->op_type = (OPCODE)type;
3454 logop->op_ppaddr = PL_ppaddr[type];
3455 logop->op_first = first;
3456 logop->op_flags = flags | OPf_KIDS;
3457 logop->op_other = LINKLIST(other);
3458 logop->op_private = (U8)(1 | (flags >> 8));
3460 /* establish postfix order */
3461 logop->op_next = LINKLIST(first);
3462 first->op_next = (OP*)logop;
3463 first->op_sibling = other;
3465 CHECKOP(type,logop);
3467 o = newUNOP(OP_NULL, 0, (OP*)logop);
3474 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3481 return newLOGOP(OP_AND, 0, first, trueop);
3483 return newLOGOP(OP_OR, 0, first, falseop);
3485 scalarboolean(first);
3486 if (first->op_type == OP_CONST) {
3487 if (first->op_private & OPpCONST_BARE &&
3488 first->op_private & OPpCONST_STRICT) {
3489 no_bareword_allowed(first);
3491 if (SvTRUE(((SVOP*)first)->op_sv)) {
3502 NewOp(1101, logop, 1, LOGOP);
3503 logop->op_type = OP_COND_EXPR;
3504 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3505 logop->op_first = first;
3506 logop->op_flags = flags | OPf_KIDS;
3507 logop->op_private = (U8)(1 | (flags >> 8));
3508 logop->op_other = LINKLIST(trueop);
3509 logop->op_next = LINKLIST(falseop);
3511 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
3514 /* establish postfix order */
3515 start = LINKLIST(first);
3516 first->op_next = (OP*)logop;
3518 first->op_sibling = trueop;
3519 trueop->op_sibling = falseop;
3520 o = newUNOP(OP_NULL, 0, (OP*)logop);
3522 trueop->op_next = falseop->op_next = o;
3529 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3537 NewOp(1101, range, 1, LOGOP);
3539 range->op_type = OP_RANGE;
3540 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3541 range->op_first = left;
3542 range->op_flags = OPf_KIDS;
3543 leftstart = LINKLIST(left);
3544 range->op_other = LINKLIST(right);
3545 range->op_private = (U8)(1 | (flags >> 8));
3547 left->op_sibling = right;
3549 range->op_next = (OP*)range;
3550 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3551 flop = newUNOP(OP_FLOP, 0, flip);
3552 o = newUNOP(OP_NULL, 0, flop);
3554 range->op_next = leftstart;
3556 left->op_next = flip;
3557 right->op_next = flop;
3559 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3560 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3561 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3562 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3564 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3565 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3568 if (!flip->op_private || !flop->op_private)
3569 linklist(o); /* blow off optimizer unless constant */
3575 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3579 int once = block && block->op_flags & OPf_SPECIAL &&
3580 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3583 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3584 return block; /* do {} while 0 does once */
3585 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3586 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3587 expr = newUNOP(OP_DEFINED, 0,
3588 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3589 } else if (expr->op_flags & OPf_KIDS) {
3590 OP *k1 = ((UNOP*)expr)->op_first;
3591 OP *k2 = (k1) ? k1->op_sibling : NULL;
3592 switch (expr->op_type) {
3594 if (k2 && k2->op_type == OP_READLINE
3595 && (k2->op_flags & OPf_STACKED)
3596 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3597 expr = newUNOP(OP_DEFINED, 0, expr);
3601 if (k1->op_type == OP_READDIR
3602 || k1->op_type == OP_GLOB
3603 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3604 || k1->op_type == OP_EACH)
3605 expr = newUNOP(OP_DEFINED, 0, expr);
3611 /* if block is null, the next append_elem() would put UNSTACK, a scalar
3612 * op, in listop. This is wrong. [perl #27024] */
3614 block = newOP(OP_NULL, 0);
3615 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3616 o = new_logop(OP_AND, 0, &expr, &listop);
3619 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3621 if (once && o != listop)
3622 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3625 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3627 o->op_flags |= flags;
3629 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3634 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3642 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3643 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3644 expr = newUNOP(OP_DEFINED, 0,
3645 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3646 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3647 OP *k1 = ((UNOP*)expr)->op_first;
3648 OP *k2 = (k1) ? k1->op_sibling : NULL;
3649 switch (expr->op_type) {
3651 if (k2 && k2->op_type == OP_READLINE
3652 && (k2->op_flags & OPf_STACKED)
3653 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3654 expr = newUNOP(OP_DEFINED, 0, expr);
3658 if (k1->op_type == OP_READDIR
3659 || k1->op_type == OP_GLOB
3660 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3661 || k1->op_type == OP_EACH)
3662 expr = newUNOP(OP_DEFINED, 0, expr);
3668 block = newOP(OP_NULL, 0);
3670 block = scope(block);
3674 next = LINKLIST(cont);
3677 OP *unstack = newOP(OP_UNSTACK, 0);
3680 cont = append_elem(OP_LINESEQ, cont, unstack);
3683 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3684 redo = LINKLIST(listop);
3687 PL_copline = (line_t)whileline;
3689 o = new_logop(OP_AND, 0, &expr, &listop);
3690 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3691 op_free(expr); /* oops, it's a while (0) */
3693 return Nullop; /* listop already freed by new_logop */
3696 ((LISTOP*)listop)->op_last->op_next =
3697 (o == listop ? redo : LINKLIST(o));
3703 NewOp(1101,loop,1,LOOP);
3704 loop->op_type = OP_ENTERLOOP;
3705 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3706 loop->op_private = 0;
3707 loop->op_next = (OP*)loop;
3710 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3712 loop->op_redoop = redo;
3713 loop->op_lastop = o;
3714 o->op_private |= loopflags;
3717 loop->op_nextop = next;
3719 loop->op_nextop = o;
3721 o->op_flags |= flags;
3722 o->op_private |= (flags >> 8);
3727 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
3731 PADOFFSET padoff = 0;
3736 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
3737 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
3738 sv->op_type = OP_RV2GV;
3739 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3741 else if (sv->op_type == OP_PADSV) { /* private variable */
3742 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
3743 padoff = sv->op_targ;
3748 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3749 padoff = sv->op_targ;
3751 iterflags |= OPf_SPECIAL;
3756 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3759 I32 offset = pad_findmy("$_");
3760 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
3761 sv = newGVOP(OP_GV, 0, PL_defgv);
3767 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3768 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3769 iterflags |= OPf_STACKED;
3771 else if (expr->op_type == OP_NULL &&
3772 (expr->op_flags & OPf_KIDS) &&
3773 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3775 /* Basically turn for($x..$y) into the same as for($x,$y), but we
3776 * set the STACKED flag to indicate that these values are to be
3777 * treated as min/max values by 'pp_iterinit'.
3779 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
3780 LOGOP* range = (LOGOP*) flip->op_first;
3781 OP* left = range->op_first;
3782 OP* right = left->op_sibling;
3785 range->op_flags &= ~OPf_KIDS;
3786 range->op_first = Nullop;
3788 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
3789 listop->op_first->op_next = range->op_next;
3790 left->op_next = range->op_other;
3791 right->op_next = (OP*)listop;
3792 listop->op_next = listop->op_first;
3795 expr = (OP*)(listop);
3797 iterflags |= OPf_STACKED;
3800 expr = mod(force_list(expr), OP_GREPSTART);
3804 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
3805 append_elem(OP_LIST, expr, scalar(sv))));
3806 assert(!loop->op_next);
3807 /* for my $x () sets OPpLVAL_INTRO;
3808 * for our $x () sets OPpOUR_INTRO */
3809 loop->op_private = (U8)iterpflags;
3810 #ifdef PL_OP_SLAB_ALLOC
3813 NewOp(1234,tmp,1,LOOP);
3814 Copy(loop,tmp,1,LOOP);
3819 Renew(loop, 1, LOOP);
3821 loop->op_targ = padoff;
3822 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
3823 PL_copline = forline;
3824 return newSTATEOP(0, label, wop);
3828 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
3833 if (type != OP_GOTO || label->op_type == OP_CONST) {
3834 /* "last()" means "last" */
3835 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
3836 o = newOP(type, OPf_SPECIAL);
3838 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
3839 ? SvPVx(((SVOP*)label)->op_sv, n_a)
3845 /* Check whether it's going to be a goto &function */
3846 if (label->op_type == OP_ENTERSUB
3847 && !(label->op_flags & OPf_STACKED))
3848 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
3849 o = newUNOP(type, OPf_STACKED, label);
3851 PL_hints |= HINT_BLOCK_SCOPE;
3856 =for apidoc cv_undef
3858 Clear out all the active components of a CV. This can happen either
3859 by an explicit C<undef &foo>, or by the reference count going to zero.
3860 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
3861 children can still follow the full lexical scope chain.
3867 Perl_cv_undef(pTHX_ CV *cv)
3870 if (CvFILE(cv) && !CvXSUB(cv)) {
3871 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
3872 Safefree(CvFILE(cv));
3877 if (!CvXSUB(cv) && CvROOT(cv)) {
3879 Perl_croak(aTHX_ "Can't undef active subroutine");
3882 PAD_SAVE_SETNULLPAD();
3884 op_free(CvROOT(cv));
3885 CvROOT(cv) = Nullop;
3888 SvPOK_off((SV*)cv); /* forget prototype */
3893 /* remove CvOUTSIDE unless this is an undef rather than a free */
3894 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
3895 if (!CvWEAKOUTSIDE(cv))
3896 SvREFCNT_dec(CvOUTSIDE(cv));
3897 CvOUTSIDE(cv) = Nullcv;
3900 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
3906 /* delete all flags except WEAKOUTSIDE */
3907 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
3911 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
3913 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
3914 SV* msg = sv_newmortal();
3918 gv_efullname3(name = sv_newmortal(), gv, Nullch);
3919 sv_setpv(msg, "Prototype mismatch:");
3921 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
3923 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (SV *)cv);
3925 Perl_sv_catpvf(aTHX_ msg, ": none");
3926 sv_catpv(msg, " vs ");
3928 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
3930 sv_catpv(msg, "none");
3931 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
3935 static void const_sv_xsub(pTHX_ CV* cv);
3939 =head1 Optree Manipulation Functions
3941 =for apidoc cv_const_sv
3943 If C<cv> is a constant sub eligible for inlining. returns the constant
3944 value returned by the sub. Otherwise, returns NULL.
3946 Constant subs can be created with C<newCONSTSUB> or as described in
3947 L<perlsub/"Constant Functions">.
3952 Perl_cv_const_sv(pTHX_ CV *cv)
3954 if (!cv || !CvCONST(cv))
3956 return (SV*)CvXSUBANY(cv).any_ptr;
3959 /* op_const_sv: examine an optree to determine whether it's in-lineable.
3960 * Can be called in 3 ways:
3963 * look for a single OP_CONST with attached value: return the value
3965 * cv && CvCLONE(cv) && !CvCONST(cv)
3967 * examine the clone prototype, and if contains only a single
3968 * OP_CONST referencing a pad const, or a single PADSV referencing
3969 * an outer lexical, return a non-zero value to indicate the CV is
3970 * a candidate for "constizing" at clone time
3974 * We have just cloned an anon prototype that was marked as a const
3975 * candidiate. Try to grab the current value, and in the case of
3976 * PADSV, ignore it if it has multiple references. Return the value.
3980 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
3987 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
3988 o = cLISTOPo->op_first->op_sibling;
3990 for (; o; o = o->op_next) {
3991 OPCODE type = o->op_type;
3993 if (sv && o->op_next == o)
3995 if (o->op_next != o) {
3996 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
3998 if (type == OP_DBSTATE)
4001 if (type == OP_LEAVESUB || type == OP_RETURN)
4005 if (type == OP_CONST && cSVOPo->op_sv)
4007 else if (cv && type == OP_CONST) {
4008 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4012 else if (cv && type == OP_PADSV) {
4013 if (CvCONST(cv)) { /* newly cloned anon */
4014 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4015 /* the candidate should have 1 ref from this pad and 1 ref
4016 * from the parent */
4017 if (!sv || SvREFCNT(sv) != 2)
4024 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4025 sv = &PL_sv_undef; /* an arbitrary non-null value */
4036 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4046 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4050 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4052 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4056 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4062 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4066 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4067 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4068 SV *sv = sv_newmortal();
4069 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4070 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4071 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4076 gv = gv_fetchpv(name ? name : (aname ? aname :
4077 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__")),
4078 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4088 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4089 maximum a prototype before. */
4090 if (SvTYPE(gv) > SVt_NULL) {
4091 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4092 && ckWARN_d(WARN_PROTOTYPE))
4094 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4096 cv_ckproto((CV*)gv, NULL, ps);
4099 sv_setpv((SV*)gv, ps);
4101 sv_setiv((SV*)gv, -1);
4102 SvREFCNT_dec(PL_compcv);
4103 cv = PL_compcv = NULL;
4104 PL_sub_generation++;
4108 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4110 #ifdef GV_UNIQUE_CHECK
4111 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4112 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4116 if (!block || !ps || *ps || attrs)
4119 const_sv = op_const_sv(block, Nullcv);
4122 bool exists = CvROOT(cv) || CvXSUB(cv);
4124 #ifdef GV_UNIQUE_CHECK
4125 if (exists && GvUNIQUE(gv)) {
4126 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4130 /* if the subroutine doesn't exist and wasn't pre-declared
4131 * with a prototype, assume it will be AUTOLOADed,
4132 * skipping the prototype check
4134 if (exists || SvPOK(cv))
4135 cv_ckproto(cv, gv, ps);
4136 /* already defined (or promised)? */
4137 if (exists || GvASSUMECV(gv)) {
4138 if (!block && !attrs) {
4139 if (CvFLAGS(PL_compcv)) {
4140 /* might have had built-in attrs applied */
4141 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4143 /* just a "sub foo;" when &foo is already defined */
4144 SAVEFREESV(PL_compcv);
4147 /* ahem, death to those who redefine active sort subs */
4148 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4149 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4151 if (ckWARN(WARN_REDEFINE)
4153 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4155 line_t oldline = CopLINE(PL_curcop);
4156 if (PL_copline != NOLINE)
4157 CopLINE_set(PL_curcop, PL_copline);
4158 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4159 CvCONST(cv) ? "Constant subroutine %s redefined"
4160 : "Subroutine %s redefined", name);
4161 CopLINE_set(PL_curcop, oldline);
4169 SvREFCNT_inc(const_sv);
4171 assert(!CvROOT(cv) && !CvCONST(cv));
4172 sv_setpv((SV*)cv, ""); /* prototype is "" */
4173 CvXSUBANY(cv).any_ptr = const_sv;
4174 CvXSUB(cv) = const_sv_xsub;
4179 cv = newCONSTSUB(NULL, name, const_sv);
4182 SvREFCNT_dec(PL_compcv);
4184 PL_sub_generation++;
4191 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4192 * before we clobber PL_compcv.
4196 /* Might have had built-in attributes applied -- propagate them. */
4197 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4198 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4199 stash = GvSTASH(CvGV(cv));
4200 else if (CvSTASH(cv))
4201 stash = CvSTASH(cv);
4203 stash = PL_curstash;
4206 /* possibly about to re-define existing subr -- ignore old cv */
4207 rcv = (SV*)PL_compcv;
4208 if (name && GvSTASH(gv))
4209 stash = GvSTASH(gv);
4211 stash = PL_curstash;
4213 apply_attrs(stash, rcv, attrs, FALSE);
4215 if (cv) { /* must reuse cv if autoloaded */
4217 /* got here with just attrs -- work done, so bug out */
4218 SAVEFREESV(PL_compcv);
4221 /* transfer PL_compcv to cv */
4223 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4224 if (!CvWEAKOUTSIDE(cv))
4225 SvREFCNT_dec(CvOUTSIDE(cv));
4226 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4227 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4228 CvOUTSIDE(PL_compcv) = 0;
4229 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4230 CvPADLIST(PL_compcv) = 0;
4231 /* inner references to PL_compcv must be fixed up ... */
4232 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4233 /* ... before we throw it away */
4234 SvREFCNT_dec(PL_compcv);
4236 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4237 ++PL_sub_generation;
4244 PL_sub_generation++;
4248 CvFILE_set_from_cop(cv, PL_curcop);
4249 CvSTASH(cv) = PL_curstash;
4252 sv_setpv((SV*)cv, ps);
4254 if (PL_error_count) {
4258 char *s = strrchr(name, ':');
4260 if (strEQ(s, "BEGIN")) {
4262 "BEGIN not safe after errors--compilation aborted";
4263 if (PL_in_eval & EVAL_KEEPERR)
4264 Perl_croak(aTHX_ not_safe);
4266 /* force display of errors found but not reported */
4267 sv_catpv(ERRSV, not_safe);
4268 Perl_croak(aTHX_ "%"SVf, ERRSV);
4277 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4278 mod(scalarseq(block), OP_LEAVESUBLV));
4281 /* This makes sub {}; work as expected. */
4282 if (block->op_type == OP_STUB) {
4284 block = newSTATEOP(0, Nullch, 0);
4286 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4288 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4289 OpREFCNT_set(CvROOT(cv), 1);
4290 CvSTART(cv) = LINKLIST(CvROOT(cv));
4291 CvROOT(cv)->op_next = 0;
4292 CALL_PEEP(CvSTART(cv));
4294 /* now that optimizer has done its work, adjust pad values */
4296 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4299 assert(!CvCONST(cv));
4300 if (ps && !*ps && op_const_sv(block, cv))
4304 if (name || aname) {
4306 char *tname = (name ? name : aname);
4308 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4309 SV *sv = NEWSV(0,0);
4310 SV *tmpstr = sv_newmortal();
4311 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4315 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4317 (long)PL_subline, (long)CopLINE(PL_curcop));
4318 gv_efullname3(tmpstr, gv, Nullch);
4319 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4320 hv = GvHVn(db_postponed);
4321 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4322 && (pcv = GvCV(db_postponed)))
4328 call_sv((SV*)pcv, G_DISCARD);
4332 if ((s = strrchr(tname,':')))
4337 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4340 if (strEQ(s, "BEGIN") && !PL_error_count) {
4341 I32 oldscope = PL_scopestack_ix;
4343 SAVECOPFILE(&PL_compiling);
4344 SAVECOPLINE(&PL_compiling);
4347 PL_beginav = newAV();
4348 DEBUG_x( dump_sub(gv) );
4349 av_push(PL_beginav, (SV*)cv);
4350 GvCV(gv) = 0; /* cv has been hijacked */
4351 call_list(oldscope, PL_beginav);
4353 PL_curcop = &PL_compiling;
4354 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4357 else if (strEQ(s, "END") && !PL_error_count) {
4360 DEBUG_x( dump_sub(gv) );
4361 av_unshift(PL_endav, 1);
4362 av_store(PL_endav, 0, (SV*)cv);
4363 GvCV(gv) = 0; /* cv has been hijacked */
4365 else if (strEQ(s, "CHECK") && !PL_error_count) {
4367 PL_checkav = newAV();
4368 DEBUG_x( dump_sub(gv) );
4369 if (PL_main_start && ckWARN(WARN_VOID))
4370 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4371 av_unshift(PL_checkav, 1);
4372 av_store(PL_checkav, 0, (SV*)cv);
4373 GvCV(gv) = 0; /* cv has been hijacked */
4375 else if (strEQ(s, "INIT") && !PL_error_count) {
4377 PL_initav = newAV();
4378 DEBUG_x( dump_sub(gv) );
4379 if (PL_main_start && ckWARN(WARN_VOID))
4380 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4381 av_push(PL_initav, (SV*)cv);
4382 GvCV(gv) = 0; /* cv has been hijacked */
4387 PL_copline = NOLINE;
4392 /* XXX unsafe for threads if eval_owner isn't held */
4394 =for apidoc newCONSTSUB
4396 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4397 eligible for inlining at compile-time.
4403 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4409 SAVECOPLINE(PL_curcop);
4410 CopLINE_set(PL_curcop, PL_copline);
4413 PL_hints &= ~HINT_BLOCK_SCOPE;
4416 SAVESPTR(PL_curstash);
4417 SAVECOPSTASH(PL_curcop);
4418 PL_curstash = stash;
4419 CopSTASH_set(PL_curcop,stash);
4422 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4423 CvXSUBANY(cv).any_ptr = sv;
4425 sv_setpv((SV*)cv, ""); /* prototype is "" */
4428 CopSTASH_free(PL_curcop);
4436 =for apidoc U||newXS
4438 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4444 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
4446 GV *gv = gv_fetchpv(name ? name :
4447 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4448 GV_ADDMULTI, SVt_PVCV);
4452 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4454 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4456 /* just a cached method */
4460 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4461 /* already defined (or promised) */
4462 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4463 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4464 line_t oldline = CopLINE(PL_curcop);
4465 if (PL_copline != NOLINE)
4466 CopLINE_set(PL_curcop, PL_copline);
4467 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4468 CvCONST(cv) ? "Constant subroutine %s redefined"
4469 : "Subroutine %s redefined"
4471 CopLINE_set(PL_curcop, oldline);
4478 if (cv) /* must reuse cv if autoloaded */
4481 cv = (CV*)NEWSV(1105,0);
4482 sv_upgrade((SV *)cv, SVt_PVCV);
4486 PL_sub_generation++;
4490 (void)gv_fetchfile(filename);
4491 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
4492 an external constant string */
4493 CvXSUB(cv) = subaddr;
4496 char *s = strrchr(name,':');
4502 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4505 if (strEQ(s, "BEGIN")) {
4507 PL_beginav = newAV();
4508 av_push(PL_beginav, (SV*)cv);
4509 GvCV(gv) = 0; /* cv has been hijacked */
4511 else if (strEQ(s, "END")) {
4514 av_unshift(PL_endav, 1);
4515 av_store(PL_endav, 0, (SV*)cv);
4516 GvCV(gv) = 0; /* cv has been hijacked */
4518 else if (strEQ(s, "CHECK")) {
4520 PL_checkav = newAV();
4521 if (PL_main_start && ckWARN(WARN_VOID))
4522 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4523 av_unshift(PL_checkav, 1);
4524 av_store(PL_checkav, 0, (SV*)cv);
4525 GvCV(gv) = 0; /* cv has been hijacked */
4527 else if (strEQ(s, "INIT")) {
4529 PL_initav = newAV();
4530 if (PL_main_start && ckWARN(WARN_VOID))
4531 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4532 av_push(PL_initav, (SV*)cv);
4533 GvCV(gv) = 0; /* cv has been hijacked */
4544 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4552 name = SvPVx(cSVOPo->op_sv, n_a);
4555 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
4556 #ifdef GV_UNIQUE_CHECK
4558 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4562 if ((cv = GvFORM(gv))) {
4563 if (ckWARN(WARN_REDEFINE)) {
4564 line_t oldline = CopLINE(PL_curcop);
4565 if (PL_copline != NOLINE)
4566 CopLINE_set(PL_curcop, PL_copline);
4567 Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Format %s redefined",name);
4568 CopLINE_set(PL_curcop, oldline);
4575 CvFILE_set_from_cop(cv, PL_curcop);
4578 pad_tidy(padtidy_FORMAT);
4579 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4580 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4581 OpREFCNT_set(CvROOT(cv), 1);
4582 CvSTART(cv) = LINKLIST(CvROOT(cv));
4583 CvROOT(cv)->op_next = 0;
4584 CALL_PEEP(CvSTART(cv));
4586 PL_copline = NOLINE;
4591 Perl_newANONLIST(pTHX_ OP *o)
4593 return newUNOP(OP_REFGEN, 0,
4594 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4598 Perl_newANONHASH(pTHX_ OP *o)
4600 return newUNOP(OP_REFGEN, 0,
4601 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4605 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4607 return newANONATTRSUB(floor, proto, Nullop, block);
4611 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4613 return newUNOP(OP_REFGEN, 0,
4614 newSVOP(OP_ANONCODE, 0,
4615 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
4619 Perl_oopsAV(pTHX_ OP *o)
4621 switch (o->op_type) {
4623 o->op_type = OP_PADAV;
4624 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4625 return ref(o, OP_RV2AV);
4628 o->op_type = OP_RV2AV;
4629 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4634 if (ckWARN_d(WARN_INTERNAL))
4635 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
4642 Perl_oopsHV(pTHX_ OP *o)
4644 switch (o->op_type) {
4647 o->op_type = OP_PADHV;
4648 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4649 return ref(o, OP_RV2HV);
4653 o->op_type = OP_RV2HV;
4654 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
4659 if (ckWARN_d(WARN_INTERNAL))
4660 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
4667 Perl_newAVREF(pTHX_ OP *o)
4669 if (o->op_type == OP_PADANY) {
4670 o->op_type = OP_PADAV;
4671 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4674 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
4675 && ckWARN(WARN_DEPRECATED)) {
4676 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4677 "Using an array as a reference is deprecated");
4679 return newUNOP(OP_RV2AV, 0, scalar(o));
4683 Perl_newGVREF(pTHX_ I32 type, OP *o)
4685 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
4686 return newUNOP(OP_NULL, 0, o);
4687 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
4691 Perl_newHVREF(pTHX_ OP *o)
4693 if (o->op_type == OP_PADANY) {
4694 o->op_type = OP_PADHV;
4695 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4698 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
4699 && ckWARN(WARN_DEPRECATED)) {
4700 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4701 "Using a hash as a reference is deprecated");
4703 return newUNOP(OP_RV2HV, 0, scalar(o));
4707 Perl_oopsCV(pTHX_ OP *o)
4709 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
4715 Perl_newCVREF(pTHX_ I32 flags, OP *o)
4717 return newUNOP(OP_RV2CV, flags, scalar(o));
4721 Perl_newSVREF(pTHX_ OP *o)
4723 if (o->op_type == OP_PADANY) {
4724 o->op_type = OP_PADSV;
4725 o->op_ppaddr = PL_ppaddr[OP_PADSV];
4728 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4729 o->op_flags |= OPpDONE_SVREF;
4732 return newUNOP(OP_RV2SV, 0, scalar(o));
4735 /* Check routines. */
4738 Perl_ck_anoncode(pTHX_ OP *o)
4740 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
4741 cSVOPo->op_sv = Nullsv;
4746 Perl_ck_bitop(pTHX_ OP *o)
4748 #define OP_IS_NUMCOMPARE(op) \
4749 ((op) == OP_LT || (op) == OP_I_LT || \
4750 (op) == OP_GT || (op) == OP_I_GT || \
4751 (op) == OP_LE || (op) == OP_I_LE || \
4752 (op) == OP_GE || (op) == OP_I_GE || \
4753 (op) == OP_EQ || (op) == OP_I_EQ || \
4754 (op) == OP_NE || (op) == OP_I_NE || \
4755 (op) == OP_NCMP || (op) == OP_I_NCMP)
4756 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4757 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
4758 && (o->op_type == OP_BIT_OR
4759 || o->op_type == OP_BIT_AND
4760 || o->op_type == OP_BIT_XOR))
4762 OP * left = cBINOPo->op_first;
4763 OP * right = left->op_sibling;
4764 if ((OP_IS_NUMCOMPARE(left->op_type) &&
4765 (left->op_flags & OPf_PARENS) == 0) ||
4766 (OP_IS_NUMCOMPARE(right->op_type) &&
4767 (right->op_flags & OPf_PARENS) == 0))
4768 if (ckWARN(WARN_PRECEDENCE))
4769 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4770 "Possible precedence problem on bitwise %c operator",
4771 o->op_type == OP_BIT_OR ? '|'
4772 : o->op_type == OP_BIT_AND ? '&' : '^'
4779 Perl_ck_concat(pTHX_ OP *o)
4781 OP *kid = cUNOPo->op_first;
4782 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
4783 !(kUNOP->op_first->op_flags & OPf_MOD))
4784 o->op_flags |= OPf_STACKED;
4789 Perl_ck_spair(pTHX_ OP *o)
4791 if (o->op_flags & OPf_KIDS) {
4794 OPCODE type = o->op_type;
4795 o = modkids(ck_fun(o), type);
4796 kid = cUNOPo->op_first;
4797 newop = kUNOP->op_first->op_sibling;
4799 (newop->op_sibling ||
4800 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
4801 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
4802 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
4806 op_free(kUNOP->op_first);
4807 kUNOP->op_first = newop;
4809 o->op_ppaddr = PL_ppaddr[++o->op_type];
4814 Perl_ck_delete(pTHX_ OP *o)
4818 if (o->op_flags & OPf_KIDS) {
4819 OP *kid = cUNOPo->op_first;
4820 switch (kid->op_type) {
4822 o->op_flags |= OPf_SPECIAL;
4825 o->op_private |= OPpSLICE;
4828 o->op_flags |= OPf_SPECIAL;
4833 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
4842 Perl_ck_die(pTHX_ OP *o)
4845 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4851 Perl_ck_eof(pTHX_ OP *o)
4853 I32 type = o->op_type;
4855 if (o->op_flags & OPf_KIDS) {
4856 if (cLISTOPo->op_first->op_type == OP_STUB) {
4858 o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
4866 Perl_ck_eval(pTHX_ OP *o)
4868 PL_hints |= HINT_BLOCK_SCOPE;
4869 if (o->op_flags & OPf_KIDS) {
4870 SVOP *kid = (SVOP*)cUNOPo->op_first;
4873 o->op_flags &= ~OPf_KIDS;
4876 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
4879 cUNOPo->op_first = 0;
4882 NewOp(1101, enter, 1, LOGOP);
4883 enter->op_type = OP_ENTERTRY;
4884 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
4885 enter->op_private = 0;
4887 /* establish postfix order */
4888 enter->op_next = (OP*)enter;
4890 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
4891 o->op_type = OP_LEAVETRY;
4892 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
4893 enter->op_other = o;
4903 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
4905 o->op_targ = (PADOFFSET)PL_hints;
4910 Perl_ck_exit(pTHX_ OP *o)
4913 HV *table = GvHV(PL_hintgv);
4915 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
4916 if (svp && *svp && SvTRUE(*svp))
4917 o->op_private |= OPpEXIT_VMSISH;
4919 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4925 Perl_ck_exec(pTHX_ OP *o)
4928 if (o->op_flags & OPf_STACKED) {
4930 kid = cUNOPo->op_first->op_sibling;
4931 if (kid->op_type == OP_RV2GV)
4940 Perl_ck_exists(pTHX_ OP *o)
4943 if (o->op_flags & OPf_KIDS) {
4944 OP *kid = cUNOPo->op_first;
4945 if (kid->op_type == OP_ENTERSUB) {
4946 (void) ref(kid, o->op_type);
4947 if (kid->op_type != OP_RV2CV && !PL_error_count)
4948 Perl_croak(aTHX_ "%s argument is not a subroutine name",
4950 o->op_private |= OPpEXISTS_SUB;
4952 else if (kid->op_type == OP_AELEM)
4953 o->op_flags |= OPf_SPECIAL;
4954 else if (kid->op_type != OP_HELEM)
4955 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
4964 Perl_ck_gvconst(pTHX_ register OP *o)
4966 o = fold_constants(o);
4967 if (o->op_type == OP_CONST)
4974 Perl_ck_rvconst(pTHX_ register OP *o)
4976 SVOP *kid = (SVOP*)cUNOPo->op_first;
4978 o->op_private |= (PL_hints & HINT_STRICT_REFS);
4979 if (kid->op_type == OP_CONST) {
4983 SV *kidsv = kid->op_sv;
4986 /* Is it a constant from cv_const_sv()? */
4987 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
4988 SV *rsv = SvRV(kidsv);
4989 int svtype = SvTYPE(rsv);
4990 char *badtype = Nullch;
4992 switch (o->op_type) {
4994 if (svtype > SVt_PVMG)
4995 badtype = "a SCALAR";
4998 if (svtype != SVt_PVAV)
4999 badtype = "an ARRAY";
5002 if (svtype != SVt_PVHV)
5006 if (svtype != SVt_PVCV)
5011 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5014 name = SvPV(kidsv, n_a);
5015 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5016 char *badthing = Nullch;
5017 switch (o->op_type) {
5019 badthing = "a SCALAR";
5022 badthing = "an ARRAY";
5025 badthing = "a HASH";
5030 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5034 * This is a little tricky. We only want to add the symbol if we
5035 * didn't add it in the lexer. Otherwise we get duplicate strict
5036 * warnings. But if we didn't add it in the lexer, we must at
5037 * least pretend like we wanted to add it even if it existed before,
5038 * or we get possible typo warnings. OPpCONST_ENTERED says
5039 * whether the lexer already added THIS instance of this symbol.
5041 iscv = (o->op_type == OP_RV2CV) * 2;
5043 gv = gv_fetchpv(name,
5044 iscv | !(kid->op_private & OPpCONST_ENTERED),
5047 : o->op_type == OP_RV2SV
5049 : o->op_type == OP_RV2AV
5051 : o->op_type == OP_RV2HV
5054 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5056 kid->op_type = OP_GV;
5057 SvREFCNT_dec(kid->op_sv);
5059 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5060 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5061 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
5063 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
5065 kid->op_sv = SvREFCNT_inc(gv);
5067 kid->op_private = 0;
5068 kid->op_ppaddr = PL_ppaddr[OP_GV];
5075 Perl_ck_ftst(pTHX_ OP *o)
5077 I32 type = o->op_type;
5079 if (o->op_flags & OPf_REF) {
5082 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5083 SVOP *kid = (SVOP*)cUNOPo->op_first;
5085 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5087 OP *newop = newGVOP(type, OPf_REF,
5088 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5093 if ((PL_hints & HINT_FILETEST_ACCESS) &&
5094 OP_IS_FILETEST_ACCESS(o))
5095 o->op_private |= OPpFT_ACCESS;
5097 if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
5098 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
5099 o->op_private |= OPpFT_STACKED;
5103 if (type == OP_FTTTY)
5104 o = newGVOP(type, OPf_REF, PL_stdingv);
5106 o = newUNOP(type, 0, newDEFSVOP());
5112 Perl_ck_fun(pTHX_ OP *o)
5118 int type = o->op_type;
5119 register I32 oa = PL_opargs[type] >> OASHIFT;
5121 if (o->op_flags & OPf_STACKED) {
5122 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5125 return no_fh_allowed(o);
5128 if (o->op_flags & OPf_KIDS) {
5130 tokid = &cLISTOPo->op_first;
5131 kid = cLISTOPo->op_first;
5132 if (kid->op_type == OP_PUSHMARK ||
5133 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5135 tokid = &kid->op_sibling;
5136 kid = kid->op_sibling;
5138 if (!kid && PL_opargs[type] & OA_DEFGV)
5139 *tokid = kid = newDEFSVOP();
5143 sibl = kid->op_sibling;
5146 /* list seen where single (scalar) arg expected? */
5147 if (numargs == 1 && !(oa >> 4)
5148 && kid->op_type == OP_LIST && type != OP_SCALAR)
5150 return too_many_arguments(o,PL_op_desc[type]);
5163 if ((type == OP_PUSH || type == OP_UNSHIFT)
5164 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5165 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5166 "Useless use of %s with no values",
5169 if (kid->op_type == OP_CONST &&
5170 (kid->op_private & OPpCONST_BARE))
5172 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5173 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5174 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5175 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5176 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5177 "Array @%s missing the @ in argument %"IVdf" of %s()",
5178 name, (IV)numargs, PL_op_desc[type]);
5181 kid->op_sibling = sibl;
5184 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5185 bad_type(numargs, "array", PL_op_desc[type], kid);
5189 if (kid->op_type == OP_CONST &&
5190 (kid->op_private & OPpCONST_BARE))
5192 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5193 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5194 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5195 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5196 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5197 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5198 name, (IV)numargs, PL_op_desc[type]);
5201 kid->op_sibling = sibl;
5204 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5205 bad_type(numargs, "hash", PL_op_desc[type], kid);
5210 OP *newop = newUNOP(OP_NULL, 0, kid);
5211 kid->op_sibling = 0;
5213 newop->op_next = newop;
5215 kid->op_sibling = sibl;
5220 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5221 if (kid->op_type == OP_CONST &&
5222 (kid->op_private & OPpCONST_BARE))
5224 OP *newop = newGVOP(OP_GV, 0,
5225 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5227 if (!(o->op_private & 1) && /* if not unop */
5228 kid == cLISTOPo->op_last)
5229 cLISTOPo->op_last = newop;
5233 else if (kid->op_type == OP_READLINE) {
5234 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5235 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5238 I32 flags = OPf_SPECIAL;
5242 /* is this op a FH constructor? */
5243 if (is_handle_constructor(o,numargs)) {
5244 char *name = Nullch;
5248 /* Set a flag to tell rv2gv to vivify
5249 * need to "prove" flag does not mean something
5250 * else already - NI-S 1999/05/07
5253 if (kid->op_type == OP_PADSV) {
5254 name = PAD_COMPNAME_PV(kid->op_targ);
5255 /* SvCUR of a pad namesv can't be trusted
5256 * (see PL_generation), so calc its length
5262 else if (kid->op_type == OP_RV2SV
5263 && kUNOP->op_first->op_type == OP_GV)
5265 GV *gv = cGVOPx_gv(kUNOP->op_first);
5267 len = GvNAMELEN(gv);
5269 else if (kid->op_type == OP_AELEM
5270 || kid->op_type == OP_HELEM)
5275 if ((op = ((BINOP*)kid)->op_first)) {
5276 SV *tmpstr = Nullsv;
5278 kid->op_type == OP_AELEM ?
5280 if (((op->op_type == OP_RV2AV) ||
5281 (op->op_type == OP_RV2HV)) &&
5282 (op = ((UNOP*)op)->op_first) &&
5283 (op->op_type == OP_GV)) {
5284 /* packagevar $a[] or $h{} */
5285 GV *gv = cGVOPx_gv(op);
5293 else if (op->op_type == OP_PADAV
5294 || op->op_type == OP_PADHV) {
5295 /* lexicalvar $a[] or $h{} */
5297 PAD_COMPNAME_PV(op->op_targ);
5307 name = SvPV(tmpstr, len);
5312 name = "__ANONIO__";
5319 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5320 namesv = PAD_SVl(targ);
5321 (void)SvUPGRADE(namesv, SVt_PV);
5323 sv_setpvn(namesv, "$", 1);
5324 sv_catpvn(namesv, name, len);
5327 kid->op_sibling = 0;
5328 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5329 kid->op_targ = targ;
5330 kid->op_private |= priv;
5332 kid->op_sibling = sibl;
5338 mod(scalar(kid), type);
5342 tokid = &kid->op_sibling;
5343 kid = kid->op_sibling;
5345 o->op_private |= numargs;
5347 return too_many_arguments(o,OP_DESC(o));
5350 else if (PL_opargs[type] & OA_DEFGV) {
5352 return newUNOP(type, 0, newDEFSVOP());
5356 while (oa & OA_OPTIONAL)
5358 if (oa && oa != OA_LIST)
5359 return too_few_arguments(o,OP_DESC(o));
5365 Perl_ck_glob(pTHX_ OP *o)
5370 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5371 append_elem(OP_GLOB, o, newDEFSVOP());
5373 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5374 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5376 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5379 #if !defined(PERL_EXTERNAL_GLOB)
5380 /* XXX this can be tightened up and made more failsafe. */
5381 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5384 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5385 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5386 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5387 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5388 GvCV(gv) = GvCV(glob_gv);
5389 SvREFCNT_inc((SV*)GvCV(gv));
5390 GvIMPORTED_CV_on(gv);
5393 #endif /* PERL_EXTERNAL_GLOB */
5395 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5396 append_elem(OP_GLOB, o,
5397 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5398 o->op_type = OP_LIST;
5399 o->op_ppaddr = PL_ppaddr[OP_LIST];
5400 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5401 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5402 cLISTOPo->op_first->op_targ = 0;
5403 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5404 append_elem(OP_LIST, o,
5405 scalar(newUNOP(OP_RV2CV, 0,
5406 newGVOP(OP_GV, 0, gv)))));
5407 o = newUNOP(OP_NULL, 0, ck_subr(o));
5408 o->op_targ = OP_GLOB; /* hint at what it used to be */
5411 gv = newGVgen("main");
5413 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5419 Perl_ck_grep(pTHX_ OP *o)
5423 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5426 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5427 NewOp(1101, gwop, 1, LOGOP);
5429 if (o->op_flags & OPf_STACKED) {
5432 kid = cLISTOPo->op_first->op_sibling;
5433 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
5436 kid->op_next = (OP*)gwop;
5437 o->op_flags &= ~OPf_STACKED;
5439 kid = cLISTOPo->op_first->op_sibling;
5440 if (type == OP_MAPWHILE)
5447 kid = cLISTOPo->op_first->op_sibling;
5448 if (kid->op_type != OP_NULL)
5449 Perl_croak(aTHX_ "panic: ck_grep");
5450 kid = kUNOP->op_first;
5452 gwop->op_type = type;
5453 gwop->op_ppaddr = PL_ppaddr[type];
5454 gwop->op_first = listkids(o);
5455 gwop->op_flags |= OPf_KIDS;
5456 gwop->op_other = LINKLIST(kid);
5457 kid->op_next = (OP*)gwop;
5458 offset = pad_findmy("$_");
5459 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
5460 o->op_private = gwop->op_private = 0;
5461 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5464 o->op_private = gwop->op_private = OPpGREP_LEX;
5465 gwop->op_targ = o->op_targ = offset;
5468 kid = cLISTOPo->op_first->op_sibling;
5469 if (!kid || !kid->op_sibling)
5470 return too_few_arguments(o,OP_DESC(o));
5471 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5472 mod(kid, OP_GREPSTART);
5478 Perl_ck_index(pTHX_ OP *o)
5480 if (o->op_flags & OPf_KIDS) {
5481 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5483 kid = kid->op_sibling; /* get past "big" */
5484 if (kid && kid->op_type == OP_CONST)
5485 fbm_compile(((SVOP*)kid)->op_sv, 0);
5491 Perl_ck_lengthconst(pTHX_ OP *o)
5493 /* XXX length optimization goes here */
5498 Perl_ck_lfun(pTHX_ OP *o)
5500 OPCODE type = o->op_type;
5501 return modkids(ck_fun(o), type);
5505 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5507 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5508 switch (cUNOPo->op_first->op_type) {
5510 /* This is needed for
5511 if (defined %stash::)
5512 to work. Do not break Tk.
5514 break; /* Globals via GV can be undef */
5516 case OP_AASSIGN: /* Is this a good idea? */
5517 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5518 "defined(@array) is deprecated");
5519 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5520 "\t(Maybe you should just omit the defined()?)\n");
5523 /* This is needed for
5524 if (defined %stash::)
5525 to work. Do not break Tk.
5527 break; /* Globals via GV can be undef */
5529 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5530 "defined(%%hash) is deprecated");
5531 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5532 "\t(Maybe you should just omit the defined()?)\n");
5543 Perl_ck_rfun(pTHX_ OP *o)
5545 OPCODE type = o->op_type;
5546 return refkids(ck_fun(o), type);
5550 Perl_ck_listiob(pTHX_ OP *o)
5554 kid = cLISTOPo->op_first;
5557 kid = cLISTOPo->op_first;
5559 if (kid->op_type == OP_PUSHMARK)
5560 kid = kid->op_sibling;
5561 if (kid && o->op_flags & OPf_STACKED)
5562 kid = kid->op_sibling;
5563 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5564 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5565 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5566 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5567 cLISTOPo->op_first->op_sibling = kid;
5568 cLISTOPo->op_last = kid;
5569 kid = kid->op_sibling;
5574 append_elem(o->op_type, o, newDEFSVOP());
5580 Perl_ck_sassign(pTHX_ OP *o)
5582 OP *kid = cLISTOPo->op_first;
5583 /* has a disposable target? */
5584 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5585 && !(kid->op_flags & OPf_STACKED)
5586 /* Cannot steal the second time! */
5587 && !(kid->op_private & OPpTARGET_MY))
5589 OP *kkid = kid->op_sibling;
5591 /* Can just relocate the target. */
5592 if (kkid && kkid->op_type == OP_PADSV
5593 && !(kkid->op_private & OPpLVAL_INTRO))
5595 kid->op_targ = kkid->op_targ;
5597 /* Now we do not need PADSV and SASSIGN. */
5598 kid->op_sibling = o->op_sibling; /* NULL */
5599 cLISTOPo->op_first = NULL;
5602 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
5606 /* optimise C<my $x = undef> to C<my $x> */
5607 if (kid->op_type == OP_UNDEF) {
5608 OP *kkid = kid->op_sibling;
5609 if (kkid && kkid->op_type == OP_PADSV
5610 && (kkid->op_private & OPpLVAL_INTRO))
5612 cLISTOPo->op_first = NULL;
5613 kid->op_sibling = NULL;
5623 Perl_ck_match(pTHX_ OP *o)
5625 if (o->op_type != OP_QR) {
5626 I32 offset = pad_findmy("$_");
5627 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS(offset) & SVpad_OUR)) {
5628 o->op_targ = offset;
5629 o->op_private |= OPpTARGET_MY;
5632 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
5633 o->op_private |= OPpRUNTIME;
5638 Perl_ck_method(pTHX_ OP *o)
5640 OP *kid = cUNOPo->op_first;
5641 if (kid->op_type == OP_CONST) {
5642 SV* sv = kSVOP->op_sv;
5643 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
5645 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5646 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
5649 kSVOP->op_sv = Nullsv;
5651 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5660 Perl_ck_null(pTHX_ OP *o)
5666 Perl_ck_open(pTHX_ OP *o)
5668 HV *table = GvHV(PL_hintgv);
5672 svp = hv_fetch(table, "open_IN", 7, FALSE);
5674 mode = mode_from_discipline(*svp);
5675 if (mode & O_BINARY)
5676 o->op_private |= OPpOPEN_IN_RAW;
5677 else if (mode & O_TEXT)
5678 o->op_private |= OPpOPEN_IN_CRLF;
5681 svp = hv_fetch(table, "open_OUT", 8, FALSE);
5683 mode = mode_from_discipline(*svp);
5684 if (mode & O_BINARY)
5685 o->op_private |= OPpOPEN_OUT_RAW;
5686 else if (mode & O_TEXT)
5687 o->op_private |= OPpOPEN_OUT_CRLF;
5690 if (o->op_type == OP_BACKTICK)
5693 /* In case of three-arg dup open remove strictness
5694 * from the last arg if it is a bareword. */
5695 OP *first = cLISTOPx(o)->op_first; /* The pushmark. */
5696 OP *last = cLISTOPx(o)->op_last; /* The bareword. */
5700 if ((last->op_type == OP_CONST) && /* The bareword. */
5701 (last->op_private & OPpCONST_BARE) &&
5702 (last->op_private & OPpCONST_STRICT) &&
5703 (oa = first->op_sibling) && /* The fh. */
5704 (oa = oa->op_sibling) && /* The mode. */
5705 SvPOK(((SVOP*)oa)->op_sv) &&
5706 (mode = SvPVX(((SVOP*)oa)->op_sv)) &&
5707 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
5708 (last == oa->op_sibling)) /* The bareword. */
5709 last->op_private &= ~OPpCONST_STRICT;
5715 Perl_ck_repeat(pTHX_ OP *o)
5717 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5718 o->op_private |= OPpREPEAT_DOLIST;
5719 cBINOPo->op_first = force_list(cBINOPo->op_first);
5727 Perl_ck_require(pTHX_ OP *o)
5731 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
5732 SVOP *kid = (SVOP*)cUNOPo->op_first;
5734 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5736 for (s = SvPVX(kid->op_sv); *s; s++) {
5737 if (*s == ':' && s[1] == ':') {
5739 Move(s+2, s+1, strlen(s+2)+1, char);
5740 --SvCUR(kid->op_sv);
5743 if (SvREADONLY(kid->op_sv)) {
5744 SvREADONLY_off(kid->op_sv);
5745 sv_catpvn(kid->op_sv, ".pm", 3);
5746 SvREADONLY_on(kid->op_sv);
5749 sv_catpvn(kid->op_sv, ".pm", 3);
5753 /* handle override, if any */
5754 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
5755 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
5756 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
5758 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5759 OP *kid = cUNOPo->op_first;
5760 cUNOPo->op_first = 0;
5762 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5763 append_elem(OP_LIST, kid,
5764 scalar(newUNOP(OP_RV2CV, 0,
5773 Perl_ck_return(pTHX_ OP *o)
5776 if (CvLVALUE(PL_compcv)) {
5777 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5778 mod(kid, OP_LEAVESUBLV);
5785 Perl_ck_retarget(pTHX_ OP *o)
5787 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5794 Perl_ck_select(pTHX_ OP *o)
5797 if (o->op_flags & OPf_KIDS) {
5798 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5799 if (kid && kid->op_sibling) {
5800 o->op_type = OP_SSELECT;
5801 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
5803 return fold_constants(o);
5807 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5808 if (kid && kid->op_type == OP_RV2GV)
5809 kid->op_private &= ~HINT_STRICT_REFS;
5814 Perl_ck_shift(pTHX_ OP *o)
5816 I32 type = o->op_type;
5818 if (!(o->op_flags & OPf_KIDS)) {
5822 argop = newUNOP(OP_RV2AV, 0,
5823 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
5824 return newUNOP(type, 0, scalar(argop));
5826 return scalar(modkids(ck_fun(o), type));
5830 Perl_ck_sort(pTHX_ OP *o)
5834 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
5836 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5837 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
5839 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
5841 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
5843 if (kid->op_type == OP_SCOPE) {
5847 else if (kid->op_type == OP_LEAVE) {
5848 if (o->op_type == OP_SORT) {
5849 op_null(kid); /* wipe out leave */
5852 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
5853 if (k->op_next == kid)
5855 /* don't descend into loops */
5856 else if (k->op_type == OP_ENTERLOOP
5857 || k->op_type == OP_ENTERITER)
5859 k = cLOOPx(k)->op_lastop;
5864 kid->op_next = 0; /* just disconnect the leave */
5865 k = kLISTOP->op_first;
5870 if (o->op_type == OP_SORT) {
5871 /* provide scalar context for comparison function/block */
5877 o->op_flags |= OPf_SPECIAL;
5879 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
5882 firstkid = firstkid->op_sibling;
5885 /* provide list context for arguments */
5886 if (o->op_type == OP_SORT)
5893 S_simplify_sort(pTHX_ OP *o)
5895 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5899 if (!(o->op_flags & OPf_STACKED))
5901 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
5902 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
5903 kid = kUNOP->op_first; /* get past null */
5904 if (kid->op_type != OP_SCOPE)
5906 kid = kLISTOP->op_last; /* get past scope */
5907 switch(kid->op_type) {
5915 k = kid; /* remember this node*/
5916 if (kBINOP->op_first->op_type != OP_RV2SV)
5918 kid = kBINOP->op_first; /* get past cmp */
5919 if (kUNOP->op_first->op_type != OP_GV)
5921 kid = kUNOP->op_first; /* get past rv2sv */
5923 if (GvSTASH(gv) != PL_curstash)
5925 if (strEQ(GvNAME(gv), "a"))
5927 else if (strEQ(GvNAME(gv), "b"))
5931 kid = k; /* back to cmp */
5932 if (kBINOP->op_last->op_type != OP_RV2SV)
5934 kid = kBINOP->op_last; /* down to 2nd arg */
5935 if (kUNOP->op_first->op_type != OP_GV)
5937 kid = kUNOP->op_first; /* get past rv2sv */
5939 if (GvSTASH(gv) != PL_curstash
5941 ? strNE(GvNAME(gv), "a")
5942 : strNE(GvNAME(gv), "b")))
5944 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
5946 o->op_private |= OPpSORT_REVERSE;
5947 if (k->op_type == OP_NCMP)
5948 o->op_private |= OPpSORT_NUMERIC;
5949 if (k->op_type == OP_I_NCMP)
5950 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
5951 kid = cLISTOPo->op_first->op_sibling;
5952 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
5953 op_free(kid); /* then delete it */
5957 Perl_ck_split(pTHX_ OP *o)
5961 if (o->op_flags & OPf_STACKED)
5962 return no_fh_allowed(o);
5964 kid = cLISTOPo->op_first;
5965 if (kid->op_type != OP_NULL)
5966 Perl_croak(aTHX_ "panic: ck_split");
5967 kid = kid->op_sibling;
5968 op_free(cLISTOPo->op_first);
5969 cLISTOPo->op_first = kid;
5971 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
5972 cLISTOPo->op_last = kid; /* There was only one element previously */
5975 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
5976 OP *sibl = kid->op_sibling;
5977 kid->op_sibling = 0;
5978 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
5979 if (cLISTOPo->op_first == cLISTOPo->op_last)
5980 cLISTOPo->op_last = kid;
5981 cLISTOPo->op_first = kid;
5982 kid->op_sibling = sibl;
5985 kid->op_type = OP_PUSHRE;
5986 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
5988 if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
5989 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
5990 "Use of /g modifier is meaningless in split");
5993 if (!kid->op_sibling)
5994 append_elem(OP_SPLIT, o, newDEFSVOP());
5996 kid = kid->op_sibling;
5999 if (!kid->op_sibling)
6000 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6002 kid = kid->op_sibling;
6005 if (kid->op_sibling)
6006 return too_many_arguments(o,OP_DESC(o));
6012 Perl_ck_join(pTHX_ OP *o)
6014 if (ckWARN(WARN_SYNTAX)) {
6015 OP *kid = cLISTOPo->op_first->op_sibling;
6016 if (kid && kid->op_type == OP_MATCH) {
6017 char *pmstr = "STRING";
6018 if (PM_GETRE(kPMOP))
6019 pmstr = PM_GETRE(kPMOP)->precomp;
6020 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6021 "/%s/ should probably be written as \"%s\"",
6029 Perl_ck_subr(pTHX_ OP *o)
6031 OP *prev = ((cUNOPo->op_first->op_sibling)
6032 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6033 OP *o2 = prev->op_sibling;
6040 I32 contextclass = 0;
6045 o->op_private |= OPpENTERSUB_HASTARG;
6046 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6047 if (cvop->op_type == OP_RV2CV) {
6049 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6050 op_null(cvop); /* disable rv2cv */
6051 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6052 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6053 GV *gv = cGVOPx_gv(tmpop);
6056 tmpop->op_private |= OPpEARLY_CV;
6059 namegv = CvANON(cv) ? gv : CvGV(cv);
6060 proto = SvPV((SV*)cv, n_a);
6062 if (CvASSERTION(cv)) {
6063 if (PL_hints & HINT_ASSERTING) {
6064 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
6065 o->op_private |= OPpENTERSUB_DB;
6069 if (ckWARN(WARN_ASSERTIONS) && !(PL_hints & HINT_ASSERTIONSSEEN)) {
6070 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
6071 "Impossible to activate assertion call");
6078 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6079 if (o2->op_type == OP_CONST)
6080 o2->op_private &= ~OPpCONST_STRICT;
6081 else if (o2->op_type == OP_LIST) {
6082 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6083 if (o && o->op_type == OP_CONST)
6084 o->op_private &= ~OPpCONST_STRICT;
6087 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6088 if (PERLDB_SUB && PL_curstash != PL_debstash)
6089 o->op_private |= OPpENTERSUB_DB;
6090 while (o2 != cvop) {
6094 return too_many_arguments(o, gv_ename(namegv));
6112 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6114 arg == 1 ? "block or sub {}" : "sub {}",
6115 gv_ename(namegv), o2);
6118 /* '*' allows any scalar type, including bareword */
6121 if (o2->op_type == OP_RV2GV)
6122 goto wrapref; /* autoconvert GLOB -> GLOBref */
6123 else if (o2->op_type == OP_CONST)
6124 o2->op_private &= ~OPpCONST_STRICT;
6125 else if (o2->op_type == OP_ENTERSUB) {
6126 /* accidental subroutine, revert to bareword */
6127 OP *gvop = ((UNOP*)o2)->op_first;
6128 if (gvop && gvop->op_type == OP_NULL) {
6129 gvop = ((UNOP*)gvop)->op_first;
6131 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6134 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6135 (gvop = ((UNOP*)gvop)->op_first) &&
6136 gvop->op_type == OP_GV)
6138 GV *gv = cGVOPx_gv(gvop);
6139 OP *sibling = o2->op_sibling;
6140 SV *n = newSVpvn("",0);
6142 gv_fullname3(n, gv, "");
6143 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6144 sv_chop(n, SvPVX(n)+6);
6145 o2 = newSVOP(OP_CONST, 0, n);
6146 prev->op_sibling = o2;
6147 o2->op_sibling = sibling;
6163 if (contextclass++ == 0) {
6164 e = strchr(proto, ']');
6165 if (!e || e == proto)
6178 while (*--p != '[');
6179 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6180 gv_ename(namegv), o2);
6186 if (o2->op_type == OP_RV2GV)
6189 bad_type(arg, "symbol", gv_ename(namegv), o2);
6192 if (o2->op_type == OP_ENTERSUB)
6195 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6198 if (o2->op_type == OP_RV2SV ||
6199 o2->op_type == OP_PADSV ||
6200 o2->op_type == OP_HELEM ||
6201 o2->op_type == OP_AELEM ||
6202 o2->op_type == OP_THREADSV)
6205 bad_type(arg, "scalar", gv_ename(namegv), o2);
6208 if (o2->op_type == OP_RV2AV ||
6209 o2->op_type == OP_PADAV)
6212 bad_type(arg, "array", gv_ename(namegv), o2);
6215 if (o2->op_type == OP_RV2HV ||
6216 o2->op_type == OP_PADHV)
6219 bad_type(arg, "hash", gv_ename(namegv), o2);
6224 OP* sib = kid->op_sibling;
6225 kid->op_sibling = 0;
6226 o2 = newUNOP(OP_REFGEN, 0, kid);
6227 o2->op_sibling = sib;
6228 prev->op_sibling = o2;
6230 if (contextclass && e) {
6245 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6246 gv_ename(namegv), cv);
6251 mod(o2, OP_ENTERSUB);
6253 o2 = o2->op_sibling;
6255 if (proto && !optional &&
6256 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6257 return too_few_arguments(o, gv_ename(namegv));
6260 o=newSVOP(OP_CONST, 0, newSViv(0));
6266 Perl_ck_svconst(pTHX_ OP *o)
6268 SvREADONLY_on(cSVOPo->op_sv);
6273 Perl_ck_trunc(pTHX_ OP *o)
6275 if (o->op_flags & OPf_KIDS) {
6276 SVOP *kid = (SVOP*)cUNOPo->op_first;
6278 if (kid->op_type == OP_NULL)
6279 kid = (SVOP*)kid->op_sibling;
6280 if (kid && kid->op_type == OP_CONST &&
6281 (kid->op_private & OPpCONST_BARE))
6283 o->op_flags |= OPf_SPECIAL;
6284 kid->op_private &= ~OPpCONST_STRICT;
6291 Perl_ck_unpack(pTHX_ OP *o)
6293 OP *kid = cLISTOPo->op_first;
6294 if (kid->op_sibling) {
6295 kid = kid->op_sibling;
6296 if (!kid->op_sibling)
6297 kid->op_sibling = newDEFSVOP();
6303 Perl_ck_substr(pTHX_ OP *o)
6306 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6307 OP *kid = cLISTOPo->op_first;
6309 if (kid->op_type == OP_NULL)
6310 kid = kid->op_sibling;
6312 kid->op_flags |= OPf_MOD;
6318 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6321 Perl_peep(pTHX_ register OP *o)
6323 register OP* oldop = 0;
6325 if (!o || o->op_opt)
6329 SAVEVPTR(PL_curcop);
6330 for (; o; o = o->op_next) {
6334 switch (o->op_type) {
6338 PL_curcop = ((COP*)o); /* for warnings */
6343 if (cSVOPo->op_private & OPpCONST_STRICT)
6344 no_bareword_allowed(o);
6346 case OP_METHOD_NAMED:
6347 /* Relocate sv to the pad for thread safety.
6348 * Despite being a "constant", the SV is written to,
6349 * for reference counts, sv_upgrade() etc. */
6351 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6352 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6353 /* If op_sv is already a PADTMP then it is being used by
6354 * some pad, so make a copy. */
6355 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6356 SvREADONLY_on(PAD_SVl(ix));
6357 SvREFCNT_dec(cSVOPo->op_sv);
6360 SvREFCNT_dec(PAD_SVl(ix));
6361 SvPADTMP_on(cSVOPo->op_sv);
6362 PAD_SETSV(ix, cSVOPo->op_sv);
6363 /* XXX I don't know how this isn't readonly already. */
6364 SvREADONLY_on(PAD_SVl(ix));
6366 cSVOPo->op_sv = Nullsv;
6374 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6375 if (o->op_next->op_private & OPpTARGET_MY) {
6376 if (o->op_flags & OPf_STACKED) /* chained concats */
6377 goto ignore_optimization;
6379 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6380 o->op_targ = o->op_next->op_targ;
6381 o->op_next->op_targ = 0;
6382 o->op_private |= OPpTARGET_MY;
6385 op_null(o->op_next);
6387 ignore_optimization:
6391 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6393 break; /* Scalar stub must produce undef. List stub is noop */
6397 if (o->op_targ == OP_NEXTSTATE
6398 || o->op_targ == OP_DBSTATE
6399 || o->op_targ == OP_SETSTATE)
6401 PL_curcop = ((COP*)o);
6403 /* XXX: We avoid setting op_seq here to prevent later calls
6404 to peep() from mistakenly concluding that optimisation
6405 has already occurred. This doesn't fix the real problem,
6406 though (See 20010220.007). AMS 20010719 */
6407 /* op_seq functionality is now replaced by op_opt */
6408 if (oldop && o->op_next) {
6409 oldop->op_next = o->op_next;
6417 if (oldop && o->op_next) {
6418 oldop->op_next = o->op_next;
6426 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
6427 OP* pop = (o->op_type == OP_PADAV) ?
6428 o->op_next : o->op_next->op_next;
6430 if (pop && pop->op_type == OP_CONST &&
6431 ((PL_op = pop->op_next)) &&
6432 pop->op_next->op_type == OP_AELEM &&
6433 !(pop->op_next->op_private &
6434 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6435 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6440 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
6441 no_bareword_allowed(pop);
6442 if (o->op_type == OP_GV)
6443 op_null(o->op_next);
6444 op_null(pop->op_next);
6446 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6447 o->op_next = pop->op_next->op_next;
6448 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6449 o->op_private = (U8)i;
6450 if (o->op_type == OP_GV) {
6455 o->op_flags |= OPf_SPECIAL;
6456 o->op_type = OP_AELEMFAST;
6462 if (o->op_next->op_type == OP_RV2SV) {
6463 if (!(o->op_next->op_private & OPpDEREF)) {
6464 op_null(o->op_next);
6465 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6467 o->op_next = o->op_next->op_next;
6468 o->op_type = OP_GVSV;
6469 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6472 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6474 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6475 /* XXX could check prototype here instead of just carping */
6476 SV *sv = sv_newmortal();
6477 gv_efullname3(sv, gv, Nullch);
6478 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6479 "%"SVf"() called too early to check prototype",
6483 else if (o->op_next->op_type == OP_READLINE
6484 && o->op_next->op_next->op_type == OP_CONCAT
6485 && (o->op_next->op_next->op_flags & OPf_STACKED))
6487 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6488 o->op_type = OP_RCATLINE;
6489 o->op_flags |= OPf_STACKED;
6490 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6491 op_null(o->op_next->op_next);
6492 op_null(o->op_next);
6509 while (cLOGOP->op_other->op_type == OP_NULL)
6510 cLOGOP->op_other = cLOGOP->op_other->op_next;
6511 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6517 while (cLOOP->op_redoop->op_type == OP_NULL)
6518 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6519 peep(cLOOP->op_redoop);
6520 while (cLOOP->op_nextop->op_type == OP_NULL)
6521 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6522 peep(cLOOP->op_nextop);
6523 while (cLOOP->op_lastop->op_type == OP_NULL)
6524 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6525 peep(cLOOP->op_lastop);
6532 while (cPMOP->op_pmreplstart &&
6533 cPMOP->op_pmreplstart->op_type == OP_NULL)
6534 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6535 peep(cPMOP->op_pmreplstart);
6540 if (ckWARN(WARN_SYNTAX) && o->op_next
6541 && o->op_next->op_type == OP_NEXTSTATE) {
6542 if (o->op_next->op_sibling &&
6543 o->op_next->op_sibling->op_type != OP_EXIT &&
6544 o->op_next->op_sibling->op_type != OP_WARN &&
6545 o->op_next->op_sibling->op_type != OP_DIE) {
6546 line_t oldline = CopLINE(PL_curcop);
6548 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6549 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6550 "Statement unlikely to be reached");
6551 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6552 "\t(Maybe you meant system() when you said exec()?)\n");
6553 CopLINE_set(PL_curcop, oldline);
6566 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6569 /* Make the CONST have a shared SV */
6570 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6571 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6572 key = SvPV(sv, keylen);
6573 lexname = newSVpvn_share(key,
6574 SvUTF8(sv) ? -(I32)keylen : keylen,
6583 /* make @a = sort @a act in-place */
6585 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
6591 /* check that RHS of sort is a single plain array */
6592 oright = cUNOPo->op_first;
6593 if (!oright || oright->op_type != OP_PUSHMARK)
6595 oright = cUNOPx(oright)->op_sibling;
6598 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
6599 oright = cUNOPx(oright)->op_sibling;
6603 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
6604 || oright->op_next != o
6605 || (oright->op_private & OPpLVAL_INTRO)
6609 /* o2 follows the chain of op_nexts through the LHS of the
6610 * assign (if any) to the aassign op itself */
6612 if (!o2 || o2->op_type != OP_NULL)
6615 if (!o2 || o2->op_type != OP_PUSHMARK)
6618 if (o2 && o2->op_type == OP_GV)
6621 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
6622 || (o2->op_private & OPpLVAL_INTRO)
6627 if (!o2 || o2->op_type != OP_NULL)
6630 if (!o2 || o2->op_type != OP_AASSIGN
6631 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
6634 /* check the array is the same on both sides */
6635 if (oleft->op_type == OP_RV2AV) {
6636 if (oright->op_type != OP_RV2AV
6637 || !cUNOPx(oright)->op_first
6638 || cUNOPx(oright)->op_first->op_type != OP_GV
6639 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
6640 cGVOPx_gv(cUNOPx(oright)->op_first)
6644 else if (oright->op_type != OP_PADAV
6645 || oright->op_targ != oleft->op_targ
6649 /* transfer MODishness etc from LHS arg to RHS arg */
6650 oright->op_flags = oleft->op_flags;
6651 o->op_private |= OPpSORT_INPLACE;
6653 /* excise push->gv->rv2av->null->aassign */
6654 o2 = o->op_next->op_next;
6655 op_null(o2); /* PUSHMARK */
6657 if (o2->op_type == OP_GV) {
6658 op_null(o2); /* GV */
6661 op_null(o2); /* RV2AV or PADAV */
6662 o2 = o2->op_next->op_next;
6663 op_null(o2); /* AASSIGN */
6665 o->op_next = o2->op_next;
6683 char* Perl_custom_op_name(pTHX_ OP* o)
6685 IV index = PTR2IV(o->op_ppaddr);
6689 if (!PL_custom_op_names) /* This probably shouldn't happen */
6690 return PL_op_name[OP_CUSTOM];
6692 keysv = sv_2mortal(newSViv(index));
6694 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
6696 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
6698 return SvPV_nolen(HeVAL(he));
6701 char* Perl_custom_op_desc(pTHX_ OP* o)
6703 IV index = PTR2IV(o->op_ppaddr);
6707 if (!PL_custom_op_descs)
6708 return PL_op_desc[OP_CUSTOM];
6710 keysv = sv_2mortal(newSViv(index));
6712 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
6714 return PL_op_desc[OP_CUSTOM];
6716 return SvPV_nolen(HeVAL(he));
6722 /* Efficient sub that returns a constant scalar value. */
6724 const_sv_xsub(pTHX_ CV* cv)
6729 Perl_croak(aTHX_ "usage: %s::%s()",
6730 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
6734 ST(0) = (SV*)XSANY.any_ptr;