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))) {
3374 other->op_private |= OPpCONST_SHORTCIRCUIT;
3378 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
3380 if ( ! (o2->op_type == OP_LIST
3381 && (( o2 = cUNOPx(o2)->op_first))
3382 && o2->op_type == OP_PUSHMARK
3383 && (( o2 = o2->op_sibling)) )
3386 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
3387 || o2->op_type == OP_PADHV)
3388 && o2->op_private & OPpLVAL_INTRO
3389 && ckWARN(WARN_DEPRECATED))
3391 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
3392 "Deprecated use of my() in false conditional");
3397 first->op_private |= OPpCONST_SHORTCIRCUIT;
3401 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS) &&
3402 type != OP_DOR) /* [#24076] Don't warn for <FH> err FOO. */
3404 OP *k1 = ((UNOP*)first)->op_first;
3405 OP *k2 = k1->op_sibling;
3407 switch (first->op_type)
3410 if (k2 && k2->op_type == OP_READLINE
3411 && (k2->op_flags & OPf_STACKED)
3412 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3414 warnop = k2->op_type;
3419 if (k1->op_type == OP_READDIR
3420 || k1->op_type == OP_GLOB
3421 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3422 || k1->op_type == OP_EACH)
3424 warnop = ((k1->op_type == OP_NULL)
3425 ? (OPCODE)k1->op_targ : k1->op_type);
3430 line_t oldline = CopLINE(PL_curcop);
3431 CopLINE_set(PL_curcop, PL_copline);
3432 Perl_warner(aTHX_ packWARN(WARN_MISC),
3433 "Value of %s%s can be \"0\"; test with defined()",
3435 ((warnop == OP_READLINE || warnop == OP_GLOB)
3436 ? " construct" : "() operator"));
3437 CopLINE_set(PL_curcop, oldline);
3444 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3445 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3447 NewOp(1101, logop, 1, LOGOP);
3449 logop->op_type = (OPCODE)type;
3450 logop->op_ppaddr = PL_ppaddr[type];
3451 logop->op_first = first;
3452 logop->op_flags = flags | OPf_KIDS;
3453 logop->op_other = LINKLIST(other);
3454 logop->op_private = (U8)(1 | (flags >> 8));
3456 /* establish postfix order */
3457 logop->op_next = LINKLIST(first);
3458 first->op_next = (OP*)logop;
3459 first->op_sibling = other;
3461 CHECKOP(type,logop);
3463 o = newUNOP(OP_NULL, 0, (OP*)logop);
3470 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3477 return newLOGOP(OP_AND, 0, first, trueop);
3479 return newLOGOP(OP_OR, 0, first, falseop);
3481 scalarboolean(first);
3482 if (first->op_type == OP_CONST) {
3483 if (first->op_private & OPpCONST_BARE &&
3484 first->op_private & OPpCONST_STRICT) {
3485 no_bareword_allowed(first);
3487 if (SvTRUE(((SVOP*)first)->op_sv)) {
3498 NewOp(1101, logop, 1, LOGOP);
3499 logop->op_type = OP_COND_EXPR;
3500 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3501 logop->op_first = first;
3502 logop->op_flags = flags | OPf_KIDS;
3503 logop->op_private = (U8)(1 | (flags >> 8));
3504 logop->op_other = LINKLIST(trueop);
3505 logop->op_next = LINKLIST(falseop);
3507 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
3510 /* establish postfix order */
3511 start = LINKLIST(first);
3512 first->op_next = (OP*)logop;
3514 first->op_sibling = trueop;
3515 trueop->op_sibling = falseop;
3516 o = newUNOP(OP_NULL, 0, (OP*)logop);
3518 trueop->op_next = falseop->op_next = o;
3525 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3533 NewOp(1101, range, 1, LOGOP);
3535 range->op_type = OP_RANGE;
3536 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3537 range->op_first = left;
3538 range->op_flags = OPf_KIDS;
3539 leftstart = LINKLIST(left);
3540 range->op_other = LINKLIST(right);
3541 range->op_private = (U8)(1 | (flags >> 8));
3543 left->op_sibling = right;
3545 range->op_next = (OP*)range;
3546 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3547 flop = newUNOP(OP_FLOP, 0, flip);
3548 o = newUNOP(OP_NULL, 0, flop);
3550 range->op_next = leftstart;
3552 left->op_next = flip;
3553 right->op_next = flop;
3555 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3556 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3557 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3558 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3560 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3561 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3564 if (!flip->op_private || !flop->op_private)
3565 linklist(o); /* blow off optimizer unless constant */
3571 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3575 int once = block && block->op_flags & OPf_SPECIAL &&
3576 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3579 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3580 return block; /* do {} while 0 does once */
3581 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3582 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3583 expr = newUNOP(OP_DEFINED, 0,
3584 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3585 } else if (expr->op_flags & OPf_KIDS) {
3586 OP *k1 = ((UNOP*)expr)->op_first;
3587 OP *k2 = (k1) ? k1->op_sibling : NULL;
3588 switch (expr->op_type) {
3590 if (k2 && k2->op_type == OP_READLINE
3591 && (k2->op_flags & OPf_STACKED)
3592 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3593 expr = newUNOP(OP_DEFINED, 0, expr);
3597 if (k1->op_type == OP_READDIR
3598 || k1->op_type == OP_GLOB
3599 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3600 || k1->op_type == OP_EACH)
3601 expr = newUNOP(OP_DEFINED, 0, expr);
3607 /* if block is null, the next append_elem() would put UNSTACK, a scalar
3608 * op, in listop. This is wrong. [perl #27024] */
3610 block = newOP(OP_NULL, 0);
3611 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3612 o = new_logop(OP_AND, 0, &expr, &listop);
3615 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3617 if (once && o != listop)
3618 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3621 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3623 o->op_flags |= flags;
3625 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3630 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3638 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3639 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3640 expr = newUNOP(OP_DEFINED, 0,
3641 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3642 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3643 OP *k1 = ((UNOP*)expr)->op_first;
3644 OP *k2 = (k1) ? k1->op_sibling : NULL;
3645 switch (expr->op_type) {
3647 if (k2 && k2->op_type == OP_READLINE
3648 && (k2->op_flags & OPf_STACKED)
3649 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3650 expr = newUNOP(OP_DEFINED, 0, expr);
3654 if (k1->op_type == OP_READDIR
3655 || k1->op_type == OP_GLOB
3656 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3657 || k1->op_type == OP_EACH)
3658 expr = newUNOP(OP_DEFINED, 0, expr);
3664 block = newOP(OP_NULL, 0);
3666 block = scope(block);
3670 next = LINKLIST(cont);
3673 OP *unstack = newOP(OP_UNSTACK, 0);
3676 cont = append_elem(OP_LINESEQ, cont, unstack);
3679 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3680 redo = LINKLIST(listop);
3683 PL_copline = (line_t)whileline;
3685 o = new_logop(OP_AND, 0, &expr, &listop);
3686 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3687 op_free(expr); /* oops, it's a while (0) */
3689 return Nullop; /* listop already freed by new_logop */
3692 ((LISTOP*)listop)->op_last->op_next =
3693 (o == listop ? redo : LINKLIST(o));
3699 NewOp(1101,loop,1,LOOP);
3700 loop->op_type = OP_ENTERLOOP;
3701 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3702 loop->op_private = 0;
3703 loop->op_next = (OP*)loop;
3706 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3708 loop->op_redoop = redo;
3709 loop->op_lastop = o;
3710 o->op_private |= loopflags;
3713 loop->op_nextop = next;
3715 loop->op_nextop = o;
3717 o->op_flags |= flags;
3718 o->op_private |= (flags >> 8);
3723 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
3727 PADOFFSET padoff = 0;
3732 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
3733 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
3734 sv->op_type = OP_RV2GV;
3735 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3737 else if (sv->op_type == OP_PADSV) { /* private variable */
3738 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
3739 padoff = sv->op_targ;
3744 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3745 padoff = sv->op_targ;
3747 iterflags |= OPf_SPECIAL;
3752 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3755 I32 offset = pad_findmy("$_");
3756 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
3757 sv = newGVOP(OP_GV, 0, PL_defgv);
3763 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3764 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3765 iterflags |= OPf_STACKED;
3767 else if (expr->op_type == OP_NULL &&
3768 (expr->op_flags & OPf_KIDS) &&
3769 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3771 /* Basically turn for($x..$y) into the same as for($x,$y), but we
3772 * set the STACKED flag to indicate that these values are to be
3773 * treated as min/max values by 'pp_iterinit'.
3775 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
3776 LOGOP* range = (LOGOP*) flip->op_first;
3777 OP* left = range->op_first;
3778 OP* right = left->op_sibling;
3781 range->op_flags &= ~OPf_KIDS;
3782 range->op_first = Nullop;
3784 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
3785 listop->op_first->op_next = range->op_next;
3786 left->op_next = range->op_other;
3787 right->op_next = (OP*)listop;
3788 listop->op_next = listop->op_first;
3791 expr = (OP*)(listop);
3793 iterflags |= OPf_STACKED;
3796 expr = mod(force_list(expr), OP_GREPSTART);
3800 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
3801 append_elem(OP_LIST, expr, scalar(sv))));
3802 assert(!loop->op_next);
3803 /* for my $x () sets OPpLVAL_INTRO;
3804 * for our $x () sets OPpOUR_INTRO */
3805 loop->op_private = (U8)iterpflags;
3806 #ifdef PL_OP_SLAB_ALLOC
3809 NewOp(1234,tmp,1,LOOP);
3810 Copy(loop,tmp,1,LOOP);
3815 Renew(loop, 1, LOOP);
3817 loop->op_targ = padoff;
3818 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
3819 PL_copline = forline;
3820 return newSTATEOP(0, label, wop);
3824 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
3829 if (type != OP_GOTO || label->op_type == OP_CONST) {
3830 /* "last()" means "last" */
3831 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
3832 o = newOP(type, OPf_SPECIAL);
3834 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
3835 ? SvPVx(((SVOP*)label)->op_sv, n_a)
3841 /* Check whether it's going to be a goto &function */
3842 if (label->op_type == OP_ENTERSUB
3843 && !(label->op_flags & OPf_STACKED))
3844 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
3845 o = newUNOP(type, OPf_STACKED, label);
3847 PL_hints |= HINT_BLOCK_SCOPE;
3852 =for apidoc cv_undef
3854 Clear out all the active components of a CV. This can happen either
3855 by an explicit C<undef &foo>, or by the reference count going to zero.
3856 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
3857 children can still follow the full lexical scope chain.
3863 Perl_cv_undef(pTHX_ CV *cv)
3866 if (CvFILE(cv) && !CvXSUB(cv)) {
3867 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
3868 Safefree(CvFILE(cv));
3873 if (!CvXSUB(cv) && CvROOT(cv)) {
3875 Perl_croak(aTHX_ "Can't undef active subroutine");
3878 PAD_SAVE_SETNULLPAD();
3880 op_free(CvROOT(cv));
3881 CvROOT(cv) = Nullop;
3884 SvPOK_off((SV*)cv); /* forget prototype */
3889 /* remove CvOUTSIDE unless this is an undef rather than a free */
3890 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
3891 if (!CvWEAKOUTSIDE(cv))
3892 SvREFCNT_dec(CvOUTSIDE(cv));
3893 CvOUTSIDE(cv) = Nullcv;
3896 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
3902 /* delete all flags except WEAKOUTSIDE */
3903 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
3907 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
3909 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
3910 SV* msg = sv_newmortal();
3914 gv_efullname3(name = sv_newmortal(), gv, Nullch);
3915 sv_setpv(msg, "Prototype mismatch:");
3917 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
3919 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (SV *)cv);
3921 Perl_sv_catpvf(aTHX_ msg, ": none");
3922 sv_catpv(msg, " vs ");
3924 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
3926 sv_catpv(msg, "none");
3927 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
3931 static void const_sv_xsub(pTHX_ CV* cv);
3935 =head1 Optree Manipulation Functions
3937 =for apidoc cv_const_sv
3939 If C<cv> is a constant sub eligible for inlining. returns the constant
3940 value returned by the sub. Otherwise, returns NULL.
3942 Constant subs can be created with C<newCONSTSUB> or as described in
3943 L<perlsub/"Constant Functions">.
3948 Perl_cv_const_sv(pTHX_ CV *cv)
3950 if (!cv || !CvCONST(cv))
3952 return (SV*)CvXSUBANY(cv).any_ptr;
3955 /* op_const_sv: examine an optree to determine whether it's in-lineable.
3956 * Can be called in 3 ways:
3959 * look for a single OP_CONST with attached value: return the value
3961 * cv && CvCLONE(cv) && !CvCONST(cv)
3963 * examine the clone prototype, and if contains only a single
3964 * OP_CONST referencing a pad const, or a single PADSV referencing
3965 * an outer lexical, return a non-zero value to indicate the CV is
3966 * a candidate for "constizing" at clone time
3970 * We have just cloned an anon prototype that was marked as a const
3971 * candidiate. Try to grab the current value, and in the case of
3972 * PADSV, ignore it if it has multiple references. Return the value.
3976 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
3983 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
3984 o = cLISTOPo->op_first->op_sibling;
3986 for (; o; o = o->op_next) {
3987 OPCODE type = o->op_type;
3989 if (sv && o->op_next == o)
3991 if (o->op_next != o) {
3992 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
3994 if (type == OP_DBSTATE)
3997 if (type == OP_LEAVESUB || type == OP_RETURN)
4001 if (type == OP_CONST && cSVOPo->op_sv)
4003 else if (cv && type == OP_CONST) {
4004 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4008 else if (cv && type == OP_PADSV) {
4009 if (CvCONST(cv)) { /* newly cloned anon */
4010 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4011 /* the candidate should have 1 ref from this pad and 1 ref
4012 * from the parent */
4013 if (!sv || SvREFCNT(sv) != 2)
4020 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4021 sv = &PL_sv_undef; /* an arbitrary non-null value */
4032 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4042 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4046 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4048 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4052 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4058 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4062 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4063 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4064 SV *sv = sv_newmortal();
4065 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4066 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4067 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4072 gv = gv_fetchpv(name ? name : (aname ? aname :
4073 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__")),
4074 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4084 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4085 maximum a prototype before. */
4086 if (SvTYPE(gv) > SVt_NULL) {
4087 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4088 && ckWARN_d(WARN_PROTOTYPE))
4090 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4092 cv_ckproto((CV*)gv, NULL, ps);
4095 sv_setpv((SV*)gv, ps);
4097 sv_setiv((SV*)gv, -1);
4098 SvREFCNT_dec(PL_compcv);
4099 cv = PL_compcv = NULL;
4100 PL_sub_generation++;
4104 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4106 #ifdef GV_UNIQUE_CHECK
4107 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4108 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4112 if (!block || !ps || *ps || attrs)
4115 const_sv = op_const_sv(block, Nullcv);
4118 bool exists = CvROOT(cv) || CvXSUB(cv);
4120 #ifdef GV_UNIQUE_CHECK
4121 if (exists && GvUNIQUE(gv)) {
4122 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4126 /* if the subroutine doesn't exist and wasn't pre-declared
4127 * with a prototype, assume it will be AUTOLOADed,
4128 * skipping the prototype check
4130 if (exists || SvPOK(cv))
4131 cv_ckproto(cv, gv, ps);
4132 /* already defined (or promised)? */
4133 if (exists || GvASSUMECV(gv)) {
4134 if (!block && !attrs) {
4135 if (CvFLAGS(PL_compcv)) {
4136 /* might have had built-in attrs applied */
4137 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4139 /* just a "sub foo;" when &foo is already defined */
4140 SAVEFREESV(PL_compcv);
4143 /* ahem, death to those who redefine active sort subs */
4144 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4145 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4147 if (ckWARN(WARN_REDEFINE)
4149 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4151 line_t oldline = CopLINE(PL_curcop);
4152 if (PL_copline != NOLINE)
4153 CopLINE_set(PL_curcop, PL_copline);
4154 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4155 CvCONST(cv) ? "Constant subroutine %s redefined"
4156 : "Subroutine %s redefined", name);
4157 CopLINE_set(PL_curcop, oldline);
4165 SvREFCNT_inc(const_sv);
4167 assert(!CvROOT(cv) && !CvCONST(cv));
4168 sv_setpv((SV*)cv, ""); /* prototype is "" */
4169 CvXSUBANY(cv).any_ptr = const_sv;
4170 CvXSUB(cv) = const_sv_xsub;
4175 cv = newCONSTSUB(NULL, name, const_sv);
4178 SvREFCNT_dec(PL_compcv);
4180 PL_sub_generation++;
4187 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4188 * before we clobber PL_compcv.
4192 /* Might have had built-in attributes applied -- propagate them. */
4193 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4194 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4195 stash = GvSTASH(CvGV(cv));
4196 else if (CvSTASH(cv))
4197 stash = CvSTASH(cv);
4199 stash = PL_curstash;
4202 /* possibly about to re-define existing subr -- ignore old cv */
4203 rcv = (SV*)PL_compcv;
4204 if (name && GvSTASH(gv))
4205 stash = GvSTASH(gv);
4207 stash = PL_curstash;
4209 apply_attrs(stash, rcv, attrs, FALSE);
4211 if (cv) { /* must reuse cv if autoloaded */
4213 /* got here with just attrs -- work done, so bug out */
4214 SAVEFREESV(PL_compcv);
4217 /* transfer PL_compcv to cv */
4219 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4220 if (!CvWEAKOUTSIDE(cv))
4221 SvREFCNT_dec(CvOUTSIDE(cv));
4222 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4223 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4224 CvOUTSIDE(PL_compcv) = 0;
4225 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4226 CvPADLIST(PL_compcv) = 0;
4227 /* inner references to PL_compcv must be fixed up ... */
4228 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4229 /* ... before we throw it away */
4230 SvREFCNT_dec(PL_compcv);
4232 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4233 ++PL_sub_generation;
4240 PL_sub_generation++;
4244 CvFILE_set_from_cop(cv, PL_curcop);
4245 CvSTASH(cv) = PL_curstash;
4248 sv_setpv((SV*)cv, ps);
4250 if (PL_error_count) {
4254 char *s = strrchr(name, ':');
4256 if (strEQ(s, "BEGIN")) {
4258 "BEGIN not safe after errors--compilation aborted";
4259 if (PL_in_eval & EVAL_KEEPERR)
4260 Perl_croak(aTHX_ not_safe);
4262 /* force display of errors found but not reported */
4263 sv_catpv(ERRSV, not_safe);
4264 Perl_croak(aTHX_ "%"SVf, ERRSV);
4273 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4274 mod(scalarseq(block), OP_LEAVESUBLV));
4277 /* This makes sub {}; work as expected. */
4278 if (block->op_type == OP_STUB) {
4280 block = newSTATEOP(0, Nullch, 0);
4282 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4284 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4285 OpREFCNT_set(CvROOT(cv), 1);
4286 CvSTART(cv) = LINKLIST(CvROOT(cv));
4287 CvROOT(cv)->op_next = 0;
4288 CALL_PEEP(CvSTART(cv));
4290 /* now that optimizer has done its work, adjust pad values */
4292 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4295 assert(!CvCONST(cv));
4296 if (ps && !*ps && op_const_sv(block, cv))
4300 if (name || aname) {
4302 char *tname = (name ? name : aname);
4304 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4305 SV *sv = NEWSV(0,0);
4306 SV *tmpstr = sv_newmortal();
4307 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4311 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4313 (long)PL_subline, (long)CopLINE(PL_curcop));
4314 gv_efullname3(tmpstr, gv, Nullch);
4315 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4316 hv = GvHVn(db_postponed);
4317 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4318 && (pcv = GvCV(db_postponed)))
4324 call_sv((SV*)pcv, G_DISCARD);
4328 if ((s = strrchr(tname,':')))
4333 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4336 if (strEQ(s, "BEGIN") && !PL_error_count) {
4337 I32 oldscope = PL_scopestack_ix;
4339 SAVECOPFILE(&PL_compiling);
4340 SAVECOPLINE(&PL_compiling);
4343 PL_beginav = newAV();
4344 DEBUG_x( dump_sub(gv) );
4345 av_push(PL_beginav, (SV*)cv);
4346 GvCV(gv) = 0; /* cv has been hijacked */
4347 call_list(oldscope, PL_beginav);
4349 PL_curcop = &PL_compiling;
4350 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4353 else if (strEQ(s, "END") && !PL_error_count) {
4356 DEBUG_x( dump_sub(gv) );
4357 av_unshift(PL_endav, 1);
4358 av_store(PL_endav, 0, (SV*)cv);
4359 GvCV(gv) = 0; /* cv has been hijacked */
4361 else if (strEQ(s, "CHECK") && !PL_error_count) {
4363 PL_checkav = newAV();
4364 DEBUG_x( dump_sub(gv) );
4365 if (PL_main_start && ckWARN(WARN_VOID))
4366 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4367 av_unshift(PL_checkav, 1);
4368 av_store(PL_checkav, 0, (SV*)cv);
4369 GvCV(gv) = 0; /* cv has been hijacked */
4371 else if (strEQ(s, "INIT") && !PL_error_count) {
4373 PL_initav = newAV();
4374 DEBUG_x( dump_sub(gv) );
4375 if (PL_main_start && ckWARN(WARN_VOID))
4376 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4377 av_push(PL_initav, (SV*)cv);
4378 GvCV(gv) = 0; /* cv has been hijacked */
4383 PL_copline = NOLINE;
4388 /* XXX unsafe for threads if eval_owner isn't held */
4390 =for apidoc newCONSTSUB
4392 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4393 eligible for inlining at compile-time.
4399 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4405 SAVECOPLINE(PL_curcop);
4406 CopLINE_set(PL_curcop, PL_copline);
4409 PL_hints &= ~HINT_BLOCK_SCOPE;
4412 SAVESPTR(PL_curstash);
4413 SAVECOPSTASH(PL_curcop);
4414 PL_curstash = stash;
4415 CopSTASH_set(PL_curcop,stash);
4418 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4419 CvXSUBANY(cv).any_ptr = sv;
4421 sv_setpv((SV*)cv, ""); /* prototype is "" */
4424 CopSTASH_free(PL_curcop);
4432 =for apidoc U||newXS
4434 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4440 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
4442 GV *gv = gv_fetchpv(name ? name :
4443 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4444 GV_ADDMULTI, SVt_PVCV);
4448 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4450 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4452 /* just a cached method */
4456 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4457 /* already defined (or promised) */
4458 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4459 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4460 line_t oldline = CopLINE(PL_curcop);
4461 if (PL_copline != NOLINE)
4462 CopLINE_set(PL_curcop, PL_copline);
4463 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4464 CvCONST(cv) ? "Constant subroutine %s redefined"
4465 : "Subroutine %s redefined"
4467 CopLINE_set(PL_curcop, oldline);
4474 if (cv) /* must reuse cv if autoloaded */
4477 cv = (CV*)NEWSV(1105,0);
4478 sv_upgrade((SV *)cv, SVt_PVCV);
4482 PL_sub_generation++;
4486 (void)gv_fetchfile(filename);
4487 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
4488 an external constant string */
4489 CvXSUB(cv) = subaddr;
4492 char *s = strrchr(name,':');
4498 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4501 if (strEQ(s, "BEGIN")) {
4503 PL_beginav = newAV();
4504 av_push(PL_beginav, (SV*)cv);
4505 GvCV(gv) = 0; /* cv has been hijacked */
4507 else if (strEQ(s, "END")) {
4510 av_unshift(PL_endav, 1);
4511 av_store(PL_endav, 0, (SV*)cv);
4512 GvCV(gv) = 0; /* cv has been hijacked */
4514 else if (strEQ(s, "CHECK")) {
4516 PL_checkav = newAV();
4517 if (PL_main_start && ckWARN(WARN_VOID))
4518 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4519 av_unshift(PL_checkav, 1);
4520 av_store(PL_checkav, 0, (SV*)cv);
4521 GvCV(gv) = 0; /* cv has been hijacked */
4523 else if (strEQ(s, "INIT")) {
4525 PL_initav = newAV();
4526 if (PL_main_start && ckWARN(WARN_VOID))
4527 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4528 av_push(PL_initav, (SV*)cv);
4529 GvCV(gv) = 0; /* cv has been hijacked */
4540 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4548 name = SvPVx(cSVOPo->op_sv, n_a);
4551 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
4552 #ifdef GV_UNIQUE_CHECK
4554 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4558 if ((cv = GvFORM(gv))) {
4559 if (ckWARN(WARN_REDEFINE)) {
4560 line_t oldline = CopLINE(PL_curcop);
4561 if (PL_copline != NOLINE)
4562 CopLINE_set(PL_curcop, PL_copline);
4563 Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Format %s redefined",name);
4564 CopLINE_set(PL_curcop, oldline);
4571 CvFILE_set_from_cop(cv, PL_curcop);
4574 pad_tidy(padtidy_FORMAT);
4575 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4576 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4577 OpREFCNT_set(CvROOT(cv), 1);
4578 CvSTART(cv) = LINKLIST(CvROOT(cv));
4579 CvROOT(cv)->op_next = 0;
4580 CALL_PEEP(CvSTART(cv));
4582 PL_copline = NOLINE;
4587 Perl_newANONLIST(pTHX_ OP *o)
4589 return newUNOP(OP_REFGEN, 0,
4590 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4594 Perl_newANONHASH(pTHX_ OP *o)
4596 return newUNOP(OP_REFGEN, 0,
4597 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4601 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4603 return newANONATTRSUB(floor, proto, Nullop, block);
4607 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4609 return newUNOP(OP_REFGEN, 0,
4610 newSVOP(OP_ANONCODE, 0,
4611 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
4615 Perl_oopsAV(pTHX_ OP *o)
4617 switch (o->op_type) {
4619 o->op_type = OP_PADAV;
4620 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4621 return ref(o, OP_RV2AV);
4624 o->op_type = OP_RV2AV;
4625 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4630 if (ckWARN_d(WARN_INTERNAL))
4631 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
4638 Perl_oopsHV(pTHX_ OP *o)
4640 switch (o->op_type) {
4643 o->op_type = OP_PADHV;
4644 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4645 return ref(o, OP_RV2HV);
4649 o->op_type = OP_RV2HV;
4650 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
4655 if (ckWARN_d(WARN_INTERNAL))
4656 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
4663 Perl_newAVREF(pTHX_ OP *o)
4665 if (o->op_type == OP_PADANY) {
4666 o->op_type = OP_PADAV;
4667 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4670 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
4671 && ckWARN(WARN_DEPRECATED)) {
4672 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4673 "Using an array as a reference is deprecated");
4675 return newUNOP(OP_RV2AV, 0, scalar(o));
4679 Perl_newGVREF(pTHX_ I32 type, OP *o)
4681 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
4682 return newUNOP(OP_NULL, 0, o);
4683 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
4687 Perl_newHVREF(pTHX_ OP *o)
4689 if (o->op_type == OP_PADANY) {
4690 o->op_type = OP_PADHV;
4691 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4694 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
4695 && ckWARN(WARN_DEPRECATED)) {
4696 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4697 "Using a hash as a reference is deprecated");
4699 return newUNOP(OP_RV2HV, 0, scalar(o));
4703 Perl_oopsCV(pTHX_ OP *o)
4705 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
4711 Perl_newCVREF(pTHX_ I32 flags, OP *o)
4713 return newUNOP(OP_RV2CV, flags, scalar(o));
4717 Perl_newSVREF(pTHX_ OP *o)
4719 if (o->op_type == OP_PADANY) {
4720 o->op_type = OP_PADSV;
4721 o->op_ppaddr = PL_ppaddr[OP_PADSV];
4724 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4725 o->op_flags |= OPpDONE_SVREF;
4728 return newUNOP(OP_RV2SV, 0, scalar(o));
4731 /* Check routines. */
4734 Perl_ck_anoncode(pTHX_ OP *o)
4736 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
4737 cSVOPo->op_sv = Nullsv;
4742 Perl_ck_bitop(pTHX_ OP *o)
4744 #define OP_IS_NUMCOMPARE(op) \
4745 ((op) == OP_LT || (op) == OP_I_LT || \
4746 (op) == OP_GT || (op) == OP_I_GT || \
4747 (op) == OP_LE || (op) == OP_I_LE || \
4748 (op) == OP_GE || (op) == OP_I_GE || \
4749 (op) == OP_EQ || (op) == OP_I_EQ || \
4750 (op) == OP_NE || (op) == OP_I_NE || \
4751 (op) == OP_NCMP || (op) == OP_I_NCMP)
4752 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4753 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
4754 && (o->op_type == OP_BIT_OR
4755 || o->op_type == OP_BIT_AND
4756 || o->op_type == OP_BIT_XOR))
4758 OP * left = cBINOPo->op_first;
4759 OP * right = left->op_sibling;
4760 if ((OP_IS_NUMCOMPARE(left->op_type) &&
4761 (left->op_flags & OPf_PARENS) == 0) ||
4762 (OP_IS_NUMCOMPARE(right->op_type) &&
4763 (right->op_flags & OPf_PARENS) == 0))
4764 if (ckWARN(WARN_PRECEDENCE))
4765 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4766 "Possible precedence problem on bitwise %c operator",
4767 o->op_type == OP_BIT_OR ? '|'
4768 : o->op_type == OP_BIT_AND ? '&' : '^'
4775 Perl_ck_concat(pTHX_ OP *o)
4777 OP *kid = cUNOPo->op_first;
4778 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
4779 !(kUNOP->op_first->op_flags & OPf_MOD))
4780 o->op_flags |= OPf_STACKED;
4785 Perl_ck_spair(pTHX_ OP *o)
4787 if (o->op_flags & OPf_KIDS) {
4790 OPCODE type = o->op_type;
4791 o = modkids(ck_fun(o), type);
4792 kid = cUNOPo->op_first;
4793 newop = kUNOP->op_first->op_sibling;
4795 (newop->op_sibling ||
4796 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
4797 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
4798 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
4802 op_free(kUNOP->op_first);
4803 kUNOP->op_first = newop;
4805 o->op_ppaddr = PL_ppaddr[++o->op_type];
4810 Perl_ck_delete(pTHX_ OP *o)
4814 if (o->op_flags & OPf_KIDS) {
4815 OP *kid = cUNOPo->op_first;
4816 switch (kid->op_type) {
4818 o->op_flags |= OPf_SPECIAL;
4821 o->op_private |= OPpSLICE;
4824 o->op_flags |= OPf_SPECIAL;
4829 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
4838 Perl_ck_die(pTHX_ OP *o)
4841 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4847 Perl_ck_eof(pTHX_ OP *o)
4849 I32 type = o->op_type;
4851 if (o->op_flags & OPf_KIDS) {
4852 if (cLISTOPo->op_first->op_type == OP_STUB) {
4854 o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
4862 Perl_ck_eval(pTHX_ OP *o)
4864 PL_hints |= HINT_BLOCK_SCOPE;
4865 if (o->op_flags & OPf_KIDS) {
4866 SVOP *kid = (SVOP*)cUNOPo->op_first;
4869 o->op_flags &= ~OPf_KIDS;
4872 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
4875 cUNOPo->op_first = 0;
4878 NewOp(1101, enter, 1, LOGOP);
4879 enter->op_type = OP_ENTERTRY;
4880 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
4881 enter->op_private = 0;
4883 /* establish postfix order */
4884 enter->op_next = (OP*)enter;
4886 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
4887 o->op_type = OP_LEAVETRY;
4888 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
4889 enter->op_other = o;
4899 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
4901 o->op_targ = (PADOFFSET)PL_hints;
4906 Perl_ck_exit(pTHX_ OP *o)
4909 HV *table = GvHV(PL_hintgv);
4911 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
4912 if (svp && *svp && SvTRUE(*svp))
4913 o->op_private |= OPpEXIT_VMSISH;
4915 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4921 Perl_ck_exec(pTHX_ OP *o)
4924 if (o->op_flags & OPf_STACKED) {
4926 kid = cUNOPo->op_first->op_sibling;
4927 if (kid->op_type == OP_RV2GV)
4936 Perl_ck_exists(pTHX_ OP *o)
4939 if (o->op_flags & OPf_KIDS) {
4940 OP *kid = cUNOPo->op_first;
4941 if (kid->op_type == OP_ENTERSUB) {
4942 (void) ref(kid, o->op_type);
4943 if (kid->op_type != OP_RV2CV && !PL_error_count)
4944 Perl_croak(aTHX_ "%s argument is not a subroutine name",
4946 o->op_private |= OPpEXISTS_SUB;
4948 else if (kid->op_type == OP_AELEM)
4949 o->op_flags |= OPf_SPECIAL;
4950 else if (kid->op_type != OP_HELEM)
4951 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
4960 Perl_ck_gvconst(pTHX_ register OP *o)
4962 o = fold_constants(o);
4963 if (o->op_type == OP_CONST)
4970 Perl_ck_rvconst(pTHX_ register OP *o)
4972 SVOP *kid = (SVOP*)cUNOPo->op_first;
4974 o->op_private |= (PL_hints & HINT_STRICT_REFS);
4975 if (kid->op_type == OP_CONST) {
4979 SV *kidsv = kid->op_sv;
4982 /* Is it a constant from cv_const_sv()? */
4983 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
4984 SV *rsv = SvRV(kidsv);
4985 int svtype = SvTYPE(rsv);
4986 char *badtype = Nullch;
4988 switch (o->op_type) {
4990 if (svtype > SVt_PVMG)
4991 badtype = "a SCALAR";
4994 if (svtype != SVt_PVAV)
4995 badtype = "an ARRAY";
4998 if (svtype != SVt_PVHV)
5002 if (svtype != SVt_PVCV)
5007 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5010 name = SvPV(kidsv, n_a);
5011 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5012 char *badthing = Nullch;
5013 switch (o->op_type) {
5015 badthing = "a SCALAR";
5018 badthing = "an ARRAY";
5021 badthing = "a HASH";
5026 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5030 * This is a little tricky. We only want to add the symbol if we
5031 * didn't add it in the lexer. Otherwise we get duplicate strict
5032 * warnings. But if we didn't add it in the lexer, we must at
5033 * least pretend like we wanted to add it even if it existed before,
5034 * or we get possible typo warnings. OPpCONST_ENTERED says
5035 * whether the lexer already added THIS instance of this symbol.
5037 iscv = (o->op_type == OP_RV2CV) * 2;
5039 gv = gv_fetchpv(name,
5040 iscv | !(kid->op_private & OPpCONST_ENTERED),
5043 : o->op_type == OP_RV2SV
5045 : o->op_type == OP_RV2AV
5047 : o->op_type == OP_RV2HV
5050 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5052 kid->op_type = OP_GV;
5053 SvREFCNT_dec(kid->op_sv);
5055 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5056 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5057 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
5059 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
5061 kid->op_sv = SvREFCNT_inc(gv);
5063 kid->op_private = 0;
5064 kid->op_ppaddr = PL_ppaddr[OP_GV];
5071 Perl_ck_ftst(pTHX_ OP *o)
5073 I32 type = o->op_type;
5075 if (o->op_flags & OPf_REF) {
5078 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5079 SVOP *kid = (SVOP*)cUNOPo->op_first;
5081 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5083 OP *newop = newGVOP(type, OPf_REF,
5084 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5089 if ((PL_hints & HINT_FILETEST_ACCESS) &&
5090 OP_IS_FILETEST_ACCESS(o))
5091 o->op_private |= OPpFT_ACCESS;
5093 if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
5094 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
5095 o->op_private |= OPpFT_STACKED;
5099 if (type == OP_FTTTY)
5100 o = newGVOP(type, OPf_REF, PL_stdingv);
5102 o = newUNOP(type, 0, newDEFSVOP());
5108 Perl_ck_fun(pTHX_ OP *o)
5114 int type = o->op_type;
5115 register I32 oa = PL_opargs[type] >> OASHIFT;
5117 if (o->op_flags & OPf_STACKED) {
5118 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5121 return no_fh_allowed(o);
5124 if (o->op_flags & OPf_KIDS) {
5126 tokid = &cLISTOPo->op_first;
5127 kid = cLISTOPo->op_first;
5128 if (kid->op_type == OP_PUSHMARK ||
5129 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5131 tokid = &kid->op_sibling;
5132 kid = kid->op_sibling;
5134 if (!kid && PL_opargs[type] & OA_DEFGV)
5135 *tokid = kid = newDEFSVOP();
5139 sibl = kid->op_sibling;
5142 /* list seen where single (scalar) arg expected? */
5143 if (numargs == 1 && !(oa >> 4)
5144 && kid->op_type == OP_LIST && type != OP_SCALAR)
5146 return too_many_arguments(o,PL_op_desc[type]);
5159 if ((type == OP_PUSH || type == OP_UNSHIFT)
5160 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5161 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5162 "Useless use of %s with no values",
5165 if (kid->op_type == OP_CONST &&
5166 (kid->op_private & OPpCONST_BARE))
5168 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5169 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5170 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5171 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5172 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5173 "Array @%s missing the @ in argument %"IVdf" of %s()",
5174 name, (IV)numargs, PL_op_desc[type]);
5177 kid->op_sibling = sibl;
5180 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5181 bad_type(numargs, "array", PL_op_desc[type], kid);
5185 if (kid->op_type == OP_CONST &&
5186 (kid->op_private & OPpCONST_BARE))
5188 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5189 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5190 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5191 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5192 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5193 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5194 name, (IV)numargs, PL_op_desc[type]);
5197 kid->op_sibling = sibl;
5200 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5201 bad_type(numargs, "hash", PL_op_desc[type], kid);
5206 OP *newop = newUNOP(OP_NULL, 0, kid);
5207 kid->op_sibling = 0;
5209 newop->op_next = newop;
5211 kid->op_sibling = sibl;
5216 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5217 if (kid->op_type == OP_CONST &&
5218 (kid->op_private & OPpCONST_BARE))
5220 OP *newop = newGVOP(OP_GV, 0,
5221 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5223 if (!(o->op_private & 1) && /* if not unop */
5224 kid == cLISTOPo->op_last)
5225 cLISTOPo->op_last = newop;
5229 else if (kid->op_type == OP_READLINE) {
5230 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5231 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5234 I32 flags = OPf_SPECIAL;
5238 /* is this op a FH constructor? */
5239 if (is_handle_constructor(o,numargs)) {
5240 char *name = Nullch;
5244 /* Set a flag to tell rv2gv to vivify
5245 * need to "prove" flag does not mean something
5246 * else already - NI-S 1999/05/07
5249 if (kid->op_type == OP_PADSV) {
5250 name = PAD_COMPNAME_PV(kid->op_targ);
5251 /* SvCUR of a pad namesv can't be trusted
5252 * (see PL_generation), so calc its length
5258 else if (kid->op_type == OP_RV2SV
5259 && kUNOP->op_first->op_type == OP_GV)
5261 GV *gv = cGVOPx_gv(kUNOP->op_first);
5263 len = GvNAMELEN(gv);
5265 else if (kid->op_type == OP_AELEM
5266 || kid->op_type == OP_HELEM)
5271 if ((op = ((BINOP*)kid)->op_first)) {
5272 SV *tmpstr = Nullsv;
5274 kid->op_type == OP_AELEM ?
5276 if (((op->op_type == OP_RV2AV) ||
5277 (op->op_type == OP_RV2HV)) &&
5278 (op = ((UNOP*)op)->op_first) &&
5279 (op->op_type == OP_GV)) {
5280 /* packagevar $a[] or $h{} */
5281 GV *gv = cGVOPx_gv(op);
5289 else if (op->op_type == OP_PADAV
5290 || op->op_type == OP_PADHV) {
5291 /* lexicalvar $a[] or $h{} */
5293 PAD_COMPNAME_PV(op->op_targ);
5303 name = SvPV(tmpstr, len);
5308 name = "__ANONIO__";
5315 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5316 namesv = PAD_SVl(targ);
5317 (void)SvUPGRADE(namesv, SVt_PV);
5319 sv_setpvn(namesv, "$", 1);
5320 sv_catpvn(namesv, name, len);
5323 kid->op_sibling = 0;
5324 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5325 kid->op_targ = targ;
5326 kid->op_private |= priv;
5328 kid->op_sibling = sibl;
5334 mod(scalar(kid), type);
5338 tokid = &kid->op_sibling;
5339 kid = kid->op_sibling;
5341 o->op_private |= numargs;
5343 return too_many_arguments(o,OP_DESC(o));
5346 else if (PL_opargs[type] & OA_DEFGV) {
5348 return newUNOP(type, 0, newDEFSVOP());
5352 while (oa & OA_OPTIONAL)
5354 if (oa && oa != OA_LIST)
5355 return too_few_arguments(o,OP_DESC(o));
5361 Perl_ck_glob(pTHX_ OP *o)
5366 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5367 append_elem(OP_GLOB, o, newDEFSVOP());
5369 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5370 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5372 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5375 #if !defined(PERL_EXTERNAL_GLOB)
5376 /* XXX this can be tightened up and made more failsafe. */
5377 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5380 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5381 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5382 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5383 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5384 GvCV(gv) = GvCV(glob_gv);
5385 SvREFCNT_inc((SV*)GvCV(gv));
5386 GvIMPORTED_CV_on(gv);
5389 #endif /* PERL_EXTERNAL_GLOB */
5391 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5392 append_elem(OP_GLOB, o,
5393 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5394 o->op_type = OP_LIST;
5395 o->op_ppaddr = PL_ppaddr[OP_LIST];
5396 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5397 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5398 cLISTOPo->op_first->op_targ = 0;
5399 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5400 append_elem(OP_LIST, o,
5401 scalar(newUNOP(OP_RV2CV, 0,
5402 newGVOP(OP_GV, 0, gv)))));
5403 o = newUNOP(OP_NULL, 0, ck_subr(o));
5404 o->op_targ = OP_GLOB; /* hint at what it used to be */
5407 gv = newGVgen("main");
5409 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5415 Perl_ck_grep(pTHX_ OP *o)
5419 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5422 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5423 NewOp(1101, gwop, 1, LOGOP);
5425 if (o->op_flags & OPf_STACKED) {
5428 kid = cLISTOPo->op_first->op_sibling;
5429 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5432 kid->op_next = (OP*)gwop;
5433 o->op_flags &= ~OPf_STACKED;
5435 kid = cLISTOPo->op_first->op_sibling;
5436 if (type == OP_MAPWHILE)
5443 kid = cLISTOPo->op_first->op_sibling;
5444 if (kid->op_type != OP_NULL)
5445 Perl_croak(aTHX_ "panic: ck_grep");
5446 kid = kUNOP->op_first;
5448 gwop->op_type = type;
5449 gwop->op_ppaddr = PL_ppaddr[type];
5450 gwop->op_first = listkids(o);
5451 gwop->op_flags |= OPf_KIDS;
5452 gwop->op_other = LINKLIST(kid);
5453 kid->op_next = (OP*)gwop;
5454 offset = pad_findmy("$_");
5455 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
5456 o->op_private = gwop->op_private = 0;
5457 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5460 o->op_private = gwop->op_private = OPpGREP_LEX;
5461 gwop->op_targ = o->op_targ = offset;
5464 kid = cLISTOPo->op_first->op_sibling;
5465 if (!kid || !kid->op_sibling)
5466 return too_few_arguments(o,OP_DESC(o));
5467 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5468 mod(kid, OP_GREPSTART);
5474 Perl_ck_index(pTHX_ OP *o)
5476 if (o->op_flags & OPf_KIDS) {
5477 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5479 kid = kid->op_sibling; /* get past "big" */
5480 if (kid && kid->op_type == OP_CONST)
5481 fbm_compile(((SVOP*)kid)->op_sv, 0);
5487 Perl_ck_lengthconst(pTHX_ OP *o)
5489 /* XXX length optimization goes here */
5494 Perl_ck_lfun(pTHX_ OP *o)
5496 OPCODE type = o->op_type;
5497 return modkids(ck_fun(o), type);
5501 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5503 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5504 switch (cUNOPo->op_first->op_type) {
5506 /* This is needed for
5507 if (defined %stash::)
5508 to work. Do not break Tk.
5510 break; /* Globals via GV can be undef */
5512 case OP_AASSIGN: /* Is this a good idea? */
5513 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5514 "defined(@array) is deprecated");
5515 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5516 "\t(Maybe you should just omit the defined()?)\n");
5519 /* This is needed for
5520 if (defined %stash::)
5521 to work. Do not break Tk.
5523 break; /* Globals via GV can be undef */
5525 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5526 "defined(%%hash) is deprecated");
5527 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5528 "\t(Maybe you should just omit the defined()?)\n");
5539 Perl_ck_rfun(pTHX_ OP *o)
5541 OPCODE type = o->op_type;
5542 return refkids(ck_fun(o), type);
5546 Perl_ck_listiob(pTHX_ OP *o)
5550 kid = cLISTOPo->op_first;
5553 kid = cLISTOPo->op_first;
5555 if (kid->op_type == OP_PUSHMARK)
5556 kid = kid->op_sibling;
5557 if (kid && o->op_flags & OPf_STACKED)
5558 kid = kid->op_sibling;
5559 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5560 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5561 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5562 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5563 cLISTOPo->op_first->op_sibling = kid;
5564 cLISTOPo->op_last = kid;
5565 kid = kid->op_sibling;
5570 append_elem(o->op_type, o, newDEFSVOP());
5576 Perl_ck_sassign(pTHX_ OP *o)
5578 OP *kid = cLISTOPo->op_first;
5579 /* has a disposable target? */
5580 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5581 && !(kid->op_flags & OPf_STACKED)
5582 /* Cannot steal the second time! */
5583 && !(kid->op_private & OPpTARGET_MY))
5585 OP *kkid = kid->op_sibling;
5587 /* Can just relocate the target. */
5588 if (kkid && kkid->op_type == OP_PADSV
5589 && !(kkid->op_private & OPpLVAL_INTRO))
5591 kid->op_targ = kkid->op_targ;
5593 /* Now we do not need PADSV and SASSIGN. */
5594 kid->op_sibling = o->op_sibling; /* NULL */
5595 cLISTOPo->op_first = NULL;
5598 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
5602 /* optimise C<my $x = undef> to C<my $x> */
5603 if (kid->op_type == OP_UNDEF) {
5604 OP *kkid = kid->op_sibling;
5605 if (kkid && kkid->op_type == OP_PADSV
5606 && (kkid->op_private & OPpLVAL_INTRO))
5608 cLISTOPo->op_first = NULL;
5609 kid->op_sibling = NULL;
5619 Perl_ck_match(pTHX_ OP *o)
5621 if (o->op_type != OP_QR) {
5622 I32 offset = pad_findmy("$_");
5623 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS(offset) & SVpad_OUR)) {
5624 o->op_targ = offset;
5625 o->op_private |= OPpTARGET_MY;
5628 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
5629 o->op_private |= OPpRUNTIME;
5634 Perl_ck_method(pTHX_ OP *o)
5636 OP *kid = cUNOPo->op_first;
5637 if (kid->op_type == OP_CONST) {
5638 SV* sv = kSVOP->op_sv;
5639 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
5641 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5642 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
5645 kSVOP->op_sv = Nullsv;
5647 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5656 Perl_ck_null(pTHX_ OP *o)
5662 Perl_ck_open(pTHX_ OP *o)
5664 HV *table = GvHV(PL_hintgv);
5668 svp = hv_fetch(table, "open_IN", 7, FALSE);
5670 mode = mode_from_discipline(*svp);
5671 if (mode & O_BINARY)
5672 o->op_private |= OPpOPEN_IN_RAW;
5673 else if (mode & O_TEXT)
5674 o->op_private |= OPpOPEN_IN_CRLF;
5677 svp = hv_fetch(table, "open_OUT", 8, FALSE);
5679 mode = mode_from_discipline(*svp);
5680 if (mode & O_BINARY)
5681 o->op_private |= OPpOPEN_OUT_RAW;
5682 else if (mode & O_TEXT)
5683 o->op_private |= OPpOPEN_OUT_CRLF;
5686 if (o->op_type == OP_BACKTICK)
5689 /* In case of three-arg dup open remove strictness
5690 * from the last arg if it is a bareword. */
5691 OP *first = cLISTOPx(o)->op_first; /* The pushmark. */
5692 OP *last = cLISTOPx(o)->op_last; /* The bareword. */
5696 if ((last->op_type == OP_CONST) && /* The bareword. */
5697 (last->op_private & OPpCONST_BARE) &&
5698 (last->op_private & OPpCONST_STRICT) &&
5699 (oa = first->op_sibling) && /* The fh. */
5700 (oa = oa->op_sibling) && /* The mode. */
5701 SvPOK(((SVOP*)oa)->op_sv) &&
5702 (mode = SvPVX(((SVOP*)oa)->op_sv)) &&
5703 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
5704 (last == oa->op_sibling)) /* The bareword. */
5705 last->op_private &= ~OPpCONST_STRICT;
5711 Perl_ck_repeat(pTHX_ OP *o)
5713 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5714 o->op_private |= OPpREPEAT_DOLIST;
5715 cBINOPo->op_first = force_list(cBINOPo->op_first);
5723 Perl_ck_require(pTHX_ OP *o)
5727 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
5728 SVOP *kid = (SVOP*)cUNOPo->op_first;
5730 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5732 for (s = SvPVX(kid->op_sv); *s; s++) {
5733 if (*s == ':' && s[1] == ':') {
5735 Move(s+2, s+1, strlen(s+2)+1, char);
5736 --SvCUR(kid->op_sv);
5739 if (SvREADONLY(kid->op_sv)) {
5740 SvREADONLY_off(kid->op_sv);
5741 sv_catpvn(kid->op_sv, ".pm", 3);
5742 SvREADONLY_on(kid->op_sv);
5745 sv_catpvn(kid->op_sv, ".pm", 3);
5749 /* handle override, if any */
5750 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
5751 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
5752 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
5754 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5755 OP *kid = cUNOPo->op_first;
5756 cUNOPo->op_first = 0;
5758 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5759 append_elem(OP_LIST, kid,
5760 scalar(newUNOP(OP_RV2CV, 0,
5769 Perl_ck_return(pTHX_ OP *o)
5772 if (CvLVALUE(PL_compcv)) {
5773 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5774 mod(kid, OP_LEAVESUBLV);
5781 Perl_ck_retarget(pTHX_ OP *o)
5783 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5790 Perl_ck_select(pTHX_ OP *o)
5793 if (o->op_flags & OPf_KIDS) {
5794 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5795 if (kid && kid->op_sibling) {
5796 o->op_type = OP_SSELECT;
5797 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
5799 return fold_constants(o);
5803 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5804 if (kid && kid->op_type == OP_RV2GV)
5805 kid->op_private &= ~HINT_STRICT_REFS;
5810 Perl_ck_shift(pTHX_ OP *o)
5812 I32 type = o->op_type;
5814 if (!(o->op_flags & OPf_KIDS)) {
5818 argop = newUNOP(OP_RV2AV, 0,
5819 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
5820 return newUNOP(type, 0, scalar(argop));
5822 return scalar(modkids(ck_fun(o), type));
5826 Perl_ck_sort(pTHX_ OP *o)
5830 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
5832 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5833 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
5835 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
5837 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
5839 if (kid->op_type == OP_SCOPE) {
5843 else if (kid->op_type == OP_LEAVE) {
5844 if (o->op_type == OP_SORT) {
5845 op_null(kid); /* wipe out leave */
5848 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
5849 if (k->op_next == kid)
5851 /* don't descend into loops */
5852 else if (k->op_type == OP_ENTERLOOP
5853 || k->op_type == OP_ENTERITER)
5855 k = cLOOPx(k)->op_lastop;
5860 kid->op_next = 0; /* just disconnect the leave */
5861 k = kLISTOP->op_first;
5866 if (o->op_type == OP_SORT) {
5867 /* provide scalar context for comparison function/block */
5873 o->op_flags |= OPf_SPECIAL;
5875 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
5878 firstkid = firstkid->op_sibling;
5881 /* provide list context for arguments */
5882 if (o->op_type == OP_SORT)
5889 S_simplify_sort(pTHX_ OP *o)
5891 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5895 if (!(o->op_flags & OPf_STACKED))
5897 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
5898 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
5899 kid = kUNOP->op_first; /* get past null */
5900 if (kid->op_type != OP_SCOPE)
5902 kid = kLISTOP->op_last; /* get past scope */
5903 switch(kid->op_type) {
5911 k = kid; /* remember this node*/
5912 if (kBINOP->op_first->op_type != OP_RV2SV)
5914 kid = kBINOP->op_first; /* get past cmp */
5915 if (kUNOP->op_first->op_type != OP_GV)
5917 kid = kUNOP->op_first; /* get past rv2sv */
5919 if (GvSTASH(gv) != PL_curstash)
5921 if (strEQ(GvNAME(gv), "a"))
5923 else if (strEQ(GvNAME(gv), "b"))
5927 kid = k; /* back to cmp */
5928 if (kBINOP->op_last->op_type != OP_RV2SV)
5930 kid = kBINOP->op_last; /* down to 2nd arg */
5931 if (kUNOP->op_first->op_type != OP_GV)
5933 kid = kUNOP->op_first; /* get past rv2sv */
5935 if (GvSTASH(gv) != PL_curstash
5937 ? strNE(GvNAME(gv), "a")
5938 : strNE(GvNAME(gv), "b")))
5940 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
5942 o->op_private |= OPpSORT_REVERSE;
5943 if (k->op_type == OP_NCMP)
5944 o->op_private |= OPpSORT_NUMERIC;
5945 if (k->op_type == OP_I_NCMP)
5946 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
5947 kid = cLISTOPo->op_first->op_sibling;
5948 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
5949 op_free(kid); /* then delete it */
5953 Perl_ck_split(pTHX_ OP *o)
5957 if (o->op_flags & OPf_STACKED)
5958 return no_fh_allowed(o);
5960 kid = cLISTOPo->op_first;
5961 if (kid->op_type != OP_NULL)
5962 Perl_croak(aTHX_ "panic: ck_split");
5963 kid = kid->op_sibling;
5964 op_free(cLISTOPo->op_first);
5965 cLISTOPo->op_first = kid;
5967 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
5968 cLISTOPo->op_last = kid; /* There was only one element previously */
5971 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
5972 OP *sibl = kid->op_sibling;
5973 kid->op_sibling = 0;
5974 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
5975 if (cLISTOPo->op_first == cLISTOPo->op_last)
5976 cLISTOPo->op_last = kid;
5977 cLISTOPo->op_first = kid;
5978 kid->op_sibling = sibl;
5981 kid->op_type = OP_PUSHRE;
5982 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
5984 if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
5985 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
5986 "Use of /g modifier is meaningless in split");
5989 if (!kid->op_sibling)
5990 append_elem(OP_SPLIT, o, newDEFSVOP());
5992 kid = kid->op_sibling;
5995 if (!kid->op_sibling)
5996 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
5998 kid = kid->op_sibling;
6001 if (kid->op_sibling)
6002 return too_many_arguments(o,OP_DESC(o));
6008 Perl_ck_join(pTHX_ OP *o)
6010 if (ckWARN(WARN_SYNTAX)) {
6011 OP *kid = cLISTOPo->op_first->op_sibling;
6012 if (kid && kid->op_type == OP_MATCH) {
6013 char *pmstr = "STRING";
6014 if (PM_GETRE(kPMOP))
6015 pmstr = PM_GETRE(kPMOP)->precomp;
6016 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6017 "/%s/ should probably be written as \"%s\"",
6025 Perl_ck_subr(pTHX_ OP *o)
6027 OP *prev = ((cUNOPo->op_first->op_sibling)
6028 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6029 OP *o2 = prev->op_sibling;
6036 I32 contextclass = 0;
6041 o->op_private |= OPpENTERSUB_HASTARG;
6042 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6043 if (cvop->op_type == OP_RV2CV) {
6045 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6046 op_null(cvop); /* disable rv2cv */
6047 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6048 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6049 GV *gv = cGVOPx_gv(tmpop);
6052 tmpop->op_private |= OPpEARLY_CV;
6055 namegv = CvANON(cv) ? gv : CvGV(cv);
6056 proto = SvPV((SV*)cv, n_a);
6058 if (CvASSERTION(cv)) {
6059 if (PL_hints & HINT_ASSERTING) {
6060 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
6061 o->op_private |= OPpENTERSUB_DB;
6065 if (ckWARN(WARN_ASSERTIONS) && !(PL_hints & HINT_ASSERTIONSSEEN)) {
6066 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
6067 "Impossible to activate assertion call");
6074 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6075 if (o2->op_type == OP_CONST)
6076 o2->op_private &= ~OPpCONST_STRICT;
6077 else if (o2->op_type == OP_LIST) {
6078 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6079 if (o && o->op_type == OP_CONST)
6080 o->op_private &= ~OPpCONST_STRICT;
6083 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6084 if (PERLDB_SUB && PL_curstash != PL_debstash)
6085 o->op_private |= OPpENTERSUB_DB;
6086 while (o2 != cvop) {
6090 return too_many_arguments(o, gv_ename(namegv));
6108 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6110 arg == 1 ? "block or sub {}" : "sub {}",
6111 gv_ename(namegv), o2);
6114 /* '*' allows any scalar type, including bareword */
6117 if (o2->op_type == OP_RV2GV)
6118 goto wrapref; /* autoconvert GLOB -> GLOBref */
6119 else if (o2->op_type == OP_CONST)
6120 o2->op_private &= ~OPpCONST_STRICT;
6121 else if (o2->op_type == OP_ENTERSUB) {
6122 /* accidental subroutine, revert to bareword */
6123 OP *gvop = ((UNOP*)o2)->op_first;
6124 if (gvop && gvop->op_type == OP_NULL) {
6125 gvop = ((UNOP*)gvop)->op_first;
6127 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6130 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6131 (gvop = ((UNOP*)gvop)->op_first) &&
6132 gvop->op_type == OP_GV)
6134 GV *gv = cGVOPx_gv(gvop);
6135 OP *sibling = o2->op_sibling;
6136 SV *n = newSVpvn("",0);
6138 gv_fullname3(n, gv, "");
6139 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6140 sv_chop(n, SvPVX(n)+6);
6141 o2 = newSVOP(OP_CONST, 0, n);
6142 prev->op_sibling = o2;
6143 o2->op_sibling = sibling;
6159 if (contextclass++ == 0) {
6160 e = strchr(proto, ']');
6161 if (!e || e == proto)
6174 while (*--p != '[');
6175 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6176 gv_ename(namegv), o2);
6182 if (o2->op_type == OP_RV2GV)
6185 bad_type(arg, "symbol", gv_ename(namegv), o2);
6188 if (o2->op_type == OP_ENTERSUB)
6191 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6194 if (o2->op_type == OP_RV2SV ||
6195 o2->op_type == OP_PADSV ||
6196 o2->op_type == OP_HELEM ||
6197 o2->op_type == OP_AELEM ||
6198 o2->op_type == OP_THREADSV)
6201 bad_type(arg, "scalar", gv_ename(namegv), o2);
6204 if (o2->op_type == OP_RV2AV ||
6205 o2->op_type == OP_PADAV)
6208 bad_type(arg, "array", gv_ename(namegv), o2);
6211 if (o2->op_type == OP_RV2HV ||
6212 o2->op_type == OP_PADHV)
6215 bad_type(arg, "hash", gv_ename(namegv), o2);
6220 OP* sib = kid->op_sibling;
6221 kid->op_sibling = 0;
6222 o2 = newUNOP(OP_REFGEN, 0, kid);
6223 o2->op_sibling = sib;
6224 prev->op_sibling = o2;
6226 if (contextclass && e) {
6241 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6242 gv_ename(namegv), cv);
6247 mod(o2, OP_ENTERSUB);
6249 o2 = o2->op_sibling;
6251 if (proto && !optional &&
6252 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6253 return too_few_arguments(o, gv_ename(namegv));
6256 o=newSVOP(OP_CONST, 0, newSViv(0));
6262 Perl_ck_svconst(pTHX_ OP *o)
6264 SvREADONLY_on(cSVOPo->op_sv);
6269 Perl_ck_trunc(pTHX_ OP *o)
6271 if (o->op_flags & OPf_KIDS) {
6272 SVOP *kid = (SVOP*)cUNOPo->op_first;
6274 if (kid->op_type == OP_NULL)
6275 kid = (SVOP*)kid->op_sibling;
6276 if (kid && kid->op_type == OP_CONST &&
6277 (kid->op_private & OPpCONST_BARE))
6279 o->op_flags |= OPf_SPECIAL;
6280 kid->op_private &= ~OPpCONST_STRICT;
6287 Perl_ck_unpack(pTHX_ OP *o)
6289 OP *kid = cLISTOPo->op_first;
6290 if (kid->op_sibling) {
6291 kid = kid->op_sibling;
6292 if (!kid->op_sibling)
6293 kid->op_sibling = newDEFSVOP();
6299 Perl_ck_substr(pTHX_ OP *o)
6302 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6303 OP *kid = cLISTOPo->op_first;
6305 if (kid->op_type == OP_NULL)
6306 kid = kid->op_sibling;
6308 kid->op_flags |= OPf_MOD;
6314 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6317 Perl_peep(pTHX_ register OP *o)
6319 register OP* oldop = 0;
6321 if (!o || o->op_opt)
6325 SAVEVPTR(PL_curcop);
6326 for (; o; o = o->op_next) {
6330 switch (o->op_type) {
6334 PL_curcop = ((COP*)o); /* for warnings */
6339 if (cSVOPo->op_private & OPpCONST_STRICT)
6340 no_bareword_allowed(o);
6342 case OP_METHOD_NAMED:
6343 /* Relocate sv to the pad for thread safety.
6344 * Despite being a "constant", the SV is written to,
6345 * for reference counts, sv_upgrade() etc. */
6347 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6348 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6349 /* If op_sv is already a PADTMP then it is being used by
6350 * some pad, so make a copy. */
6351 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6352 SvREADONLY_on(PAD_SVl(ix));
6353 SvREFCNT_dec(cSVOPo->op_sv);
6356 SvREFCNT_dec(PAD_SVl(ix));
6357 SvPADTMP_on(cSVOPo->op_sv);
6358 PAD_SETSV(ix, cSVOPo->op_sv);
6359 /* XXX I don't know how this isn't readonly already. */
6360 SvREADONLY_on(PAD_SVl(ix));
6362 cSVOPo->op_sv = Nullsv;
6370 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6371 if (o->op_next->op_private & OPpTARGET_MY) {
6372 if (o->op_flags & OPf_STACKED) /* chained concats */
6373 goto ignore_optimization;
6375 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6376 o->op_targ = o->op_next->op_targ;
6377 o->op_next->op_targ = 0;
6378 o->op_private |= OPpTARGET_MY;
6381 op_null(o->op_next);
6383 ignore_optimization:
6387 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6389 break; /* Scalar stub must produce undef. List stub is noop */
6393 if (o->op_targ == OP_NEXTSTATE
6394 || o->op_targ == OP_DBSTATE
6395 || o->op_targ == OP_SETSTATE)
6397 PL_curcop = ((COP*)o);
6399 /* XXX: We avoid setting op_seq here to prevent later calls
6400 to peep() from mistakenly concluding that optimisation
6401 has already occurred. This doesn't fix the real problem,
6402 though (See 20010220.007). AMS 20010719 */
6403 /* op_seq functionality is now replaced by op_opt */
6404 if (oldop && o->op_next) {
6405 oldop->op_next = o->op_next;
6413 if (oldop && o->op_next) {
6414 oldop->op_next = o->op_next;
6422 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
6423 OP* pop = (o->op_type == OP_PADAV) ?
6424 o->op_next : o->op_next->op_next;
6426 if (pop && pop->op_type == OP_CONST &&
6427 ((PL_op = pop->op_next)) &&
6428 pop->op_next->op_type == OP_AELEM &&
6429 !(pop->op_next->op_private &
6430 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6431 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6436 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
6437 no_bareword_allowed(pop);
6438 if (o->op_type == OP_GV)
6439 op_null(o->op_next);
6440 op_null(pop->op_next);
6442 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6443 o->op_next = pop->op_next->op_next;
6444 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6445 o->op_private = (U8)i;
6446 if (o->op_type == OP_GV) {
6451 o->op_flags |= OPf_SPECIAL;
6452 o->op_type = OP_AELEMFAST;
6458 if (o->op_next->op_type == OP_RV2SV) {
6459 if (!(o->op_next->op_private & OPpDEREF)) {
6460 op_null(o->op_next);
6461 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6463 o->op_next = o->op_next->op_next;
6464 o->op_type = OP_GVSV;
6465 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6468 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6470 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6471 /* XXX could check prototype here instead of just carping */
6472 SV *sv = sv_newmortal();
6473 gv_efullname3(sv, gv, Nullch);
6474 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6475 "%"SVf"() called too early to check prototype",
6479 else if (o->op_next->op_type == OP_READLINE
6480 && o->op_next->op_next->op_type == OP_CONCAT
6481 && (o->op_next->op_next->op_flags & OPf_STACKED))
6483 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6484 o->op_type = OP_RCATLINE;
6485 o->op_flags |= OPf_STACKED;
6486 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6487 op_null(o->op_next->op_next);
6488 op_null(o->op_next);
6505 while (cLOGOP->op_other->op_type == OP_NULL)
6506 cLOGOP->op_other = cLOGOP->op_other->op_next;
6507 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6513 while (cLOOP->op_redoop->op_type == OP_NULL)
6514 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6515 peep(cLOOP->op_redoop);
6516 while (cLOOP->op_nextop->op_type == OP_NULL)
6517 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6518 peep(cLOOP->op_nextop);
6519 while (cLOOP->op_lastop->op_type == OP_NULL)
6520 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6521 peep(cLOOP->op_lastop);
6528 while (cPMOP->op_pmreplstart &&
6529 cPMOP->op_pmreplstart->op_type == OP_NULL)
6530 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6531 peep(cPMOP->op_pmreplstart);
6536 if (ckWARN(WARN_SYNTAX) && o->op_next
6537 && o->op_next->op_type == OP_NEXTSTATE) {
6538 if (o->op_next->op_sibling &&
6539 o->op_next->op_sibling->op_type != OP_EXIT &&
6540 o->op_next->op_sibling->op_type != OP_WARN &&
6541 o->op_next->op_sibling->op_type != OP_DIE) {
6542 line_t oldline = CopLINE(PL_curcop);
6544 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6545 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6546 "Statement unlikely to be reached");
6547 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6548 "\t(Maybe you meant system() when you said exec()?)\n");
6549 CopLINE_set(PL_curcop, oldline);
6562 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6565 /* Make the CONST have a shared SV */
6566 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6567 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6568 key = SvPV(sv, keylen);
6569 lexname = newSVpvn_share(key,
6570 SvUTF8(sv) ? -(I32)keylen : keylen,
6579 /* make @a = sort @a act in-place */
6581 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
6587 /* check that RHS of sort is a single plain array */
6588 oright = cUNOPo->op_first;
6589 if (!oright || oright->op_type != OP_PUSHMARK)
6591 oright = cUNOPx(oright)->op_sibling;
6594 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
6595 oright = cUNOPx(oright)->op_sibling;
6599 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
6600 || oright->op_next != o
6601 || (oright->op_private & OPpLVAL_INTRO)
6605 /* o2 follows the chain of op_nexts through the LHS of the
6606 * assign (if any) to the aassign op itself */
6608 if (!o2 || o2->op_type != OP_NULL)
6611 if (!o2 || o2->op_type != OP_PUSHMARK)
6614 if (o2 && o2->op_type == OP_GV)
6617 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
6618 || (o2->op_private & OPpLVAL_INTRO)
6623 if (!o2 || o2->op_type != OP_NULL)
6626 if (!o2 || o2->op_type != OP_AASSIGN
6627 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
6630 /* check the array is the same on both sides */
6631 if (oleft->op_type == OP_RV2AV) {
6632 if (oright->op_type != OP_RV2AV
6633 || !cUNOPx(oright)->op_first
6634 || cUNOPx(oright)->op_first->op_type != OP_GV
6635 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
6636 cGVOPx_gv(cUNOPx(oright)->op_first)
6640 else if (oright->op_type != OP_PADAV
6641 || oright->op_targ != oleft->op_targ
6645 /* transfer MODishness etc from LHS arg to RHS arg */
6646 oright->op_flags = oleft->op_flags;
6647 o->op_private |= OPpSORT_INPLACE;
6649 /* excise push->gv->rv2av->null->aassign */
6650 o2 = o->op_next->op_next;
6651 op_null(o2); /* PUSHMARK */
6653 if (o2->op_type == OP_GV) {
6654 op_null(o2); /* GV */
6657 op_null(o2); /* RV2AV or PADAV */
6658 o2 = o2->op_next->op_next;
6659 op_null(o2); /* AASSIGN */
6661 o->op_next = o2->op_next;
6679 char* Perl_custom_op_name(pTHX_ OP* o)
6681 IV index = PTR2IV(o->op_ppaddr);
6685 if (!PL_custom_op_names) /* This probably shouldn't happen */
6686 return PL_op_name[OP_CUSTOM];
6688 keysv = sv_2mortal(newSViv(index));
6690 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
6692 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
6694 return SvPV_nolen(HeVAL(he));
6697 char* Perl_custom_op_desc(pTHX_ OP* o)
6699 IV index = PTR2IV(o->op_ppaddr);
6703 if (!PL_custom_op_descs)
6704 return PL_op_desc[OP_CUSTOM];
6706 keysv = sv_2mortal(newSViv(index));
6708 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
6710 return PL_op_desc[OP_CUSTOM];
6712 return SvPV_nolen(HeVAL(he));
6718 /* Efficient sub that returns a constant scalar value. */
6720 const_sv_xsub(pTHX_ CV* cv)
6725 Perl_croak(aTHX_ "usage: %s::%s()",
6726 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
6730 ST(0) = (SV*)XSANY.any_ptr;