3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
13 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
14 * youngest of the Old Took's daughters); and Mr. Drogo was his second
15 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
16 * either way, as the saying is, if you follow me." --the Gaffer
25 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
27 #if defined(PL_OP_SLAB_ALLOC)
29 #ifndef PERL_SLAB_SIZE
30 #define PERL_SLAB_SIZE 2048
34 Perl_Slab_Alloc(pTHX_ int m, size_t sz)
37 * To make incrementing use count easy PL_OpSlab is an I32 *
38 * To make inserting the link to slab PL_OpPtr is I32 **
39 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
40 * Add an overhead for pointer to slab and round up as a number of pointers
42 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
43 if ((PL_OpSpace -= sz) < 0) {
44 PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*));
48 Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **);
49 /* We reserve the 0'th I32 sized chunk as a use count */
50 PL_OpSlab = (I32 *) PL_OpPtr;
51 /* Reduce size by the use count word, and by the size we need.
52 * Latter is to mimic the '-=' in the if() above
54 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
55 /* Allocation pointer starts at the top.
56 Theory: because we build leaves before trunk allocating at end
57 means that at run time access is cache friendly upward
59 PL_OpPtr += PERL_SLAB_SIZE;
61 assert( PL_OpSpace >= 0 );
62 /* Move the allocation pointer down */
64 assert( PL_OpPtr > (I32 **) PL_OpSlab );
65 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
66 (*PL_OpSlab)++; /* Increment use count of slab */
67 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
68 assert( *PL_OpSlab > 0 );
69 return (void *)(PL_OpPtr + 1);
73 Perl_Slab_Free(pTHX_ void *op)
75 I32 **ptr = (I32 **) op;
77 assert( ptr-1 > (I32 **) slab );
78 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
82 # define PerlMemShared PerlMem
85 PerlMemShared_free(slab);
86 if (slab == PL_OpSlab) {
93 * In the following definition, the ", Nullop" is just to make the compiler
94 * think the expression is of the right type: croak actually does a Siglongjmp.
96 #define CHECKOP(type,o) \
97 ((PL_op_mask && PL_op_mask[type]) \
98 ? ( op_free((OP*)o), \
99 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
101 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
103 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
106 S_gv_ename(pTHX_ GV *gv)
109 SV* tmpsv = sv_newmortal();
110 gv_efullname3(tmpsv, gv, Nullch);
111 return SvPV(tmpsv,n_a);
115 S_no_fh_allowed(pTHX_ OP *o)
117 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
123 S_too_few_arguments(pTHX_ OP *o, char *name)
125 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
130 S_too_many_arguments(pTHX_ OP *o, char *name)
132 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
137 S_bad_type(pTHX_ I32 n, char *t, char *name, OP *kid)
139 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
140 (int)n, name, t, OP_DESC(kid)));
144 S_no_bareword_allowed(pTHX_ OP *o)
146 qerror(Perl_mess(aTHX_
147 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
151 /* "register" allocation */
154 Perl_allocmy(pTHX_ char *name)
158 /* complain about "my $<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 /* the constants 0 and 1 are permitted as they are
681 conventionally used as dummies in constructs like
682 1 while some_condition_with_side_effects; */
683 if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
685 else if (SvPOK(sv)) {
686 /* perl4's way of mixing documentation and code
687 (before the invention of POD) was based on a
688 trick to mix nroff and perl code. The trick was
689 built upon these three nroff macros being used in
690 void context. The pink camel has the details in
691 the script wrapman near page 319. */
692 if (strnEQ(SvPVX(sv), "di", 2) ||
693 strnEQ(SvPVX(sv), "ds", 2) ||
694 strnEQ(SvPVX(sv), "ig", 2))
699 op_null(o); /* don't execute or even remember it */
703 o->op_type = OP_PREINC; /* pre-increment is faster */
704 o->op_ppaddr = PL_ppaddr[OP_PREINC];
708 o->op_type = OP_PREDEC; /* pre-decrement is faster */
709 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
716 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
721 if (o->op_flags & OPf_STACKED)
728 if (!(o->op_flags & OPf_KIDS))
737 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
744 /* all requires must return a boolean value */
745 o->op_flags &= ~OPf_WANT;
750 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
751 if (!kPMOP->op_pmreplroot)
752 deprecate_old("implicit split to @_");
756 if (useless && ckWARN(WARN_VOID))
757 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
762 Perl_listkids(pTHX_ OP *o)
765 if (o && o->op_flags & OPf_KIDS) {
766 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
773 Perl_list(pTHX_ OP *o)
777 /* assumes no premature commitment */
778 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
779 || o->op_type == OP_RETURN)
784 if ((o->op_private & OPpTARGET_MY)
785 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
787 return o; /* As if inside SASSIGN */
790 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
792 switch (o->op_type) {
795 list(cBINOPo->op_first);
800 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
808 if (!(o->op_flags & OPf_KIDS))
810 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
811 list(cBINOPo->op_first);
812 return gen_constant_list(o);
819 kid = cLISTOPo->op_first;
821 while ((kid = kid->op_sibling)) {
827 WITH_THR(PL_curcop = &PL_compiling);
831 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
837 WITH_THR(PL_curcop = &PL_compiling);
840 /* all requires must return a boolean value */
841 o->op_flags &= ~OPf_WANT;
848 Perl_scalarseq(pTHX_ OP *o)
853 if (o->op_type == OP_LINESEQ ||
854 o->op_type == OP_SCOPE ||
855 o->op_type == OP_LEAVE ||
856 o->op_type == OP_LEAVETRY)
858 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
859 if (kid->op_sibling) {
863 PL_curcop = &PL_compiling;
865 o->op_flags &= ~OPf_PARENS;
866 if (PL_hints & HINT_BLOCK_SCOPE)
867 o->op_flags |= OPf_PARENS;
870 o = newOP(OP_STUB, 0);
875 S_modkids(pTHX_ OP *o, I32 type)
878 if (o && o->op_flags & OPf_KIDS) {
879 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
885 /* Propagate lvalue ("modifiable") context to an op and it's children.
886 * 'type' represents the context type, roughly based on the type of op that
887 * would do the modifying, although local() is represented by OP_NULL.
888 * It's responsible for detecting things that can't be modified, flag
889 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
890 * might have to vivify a reference in $x), and so on.
892 * For example, "$a+1 = 2" would cause mod() to be called with o being
893 * OP_ADD and type being OP_SASSIGN, and would output an error.
897 Perl_mod(pTHX_ OP *o, I32 type)
900 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
903 if (!o || PL_error_count)
906 if ((o->op_private & OPpTARGET_MY)
907 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
912 switch (o->op_type) {
918 if (!(o->op_private & (OPpCONST_ARYBASE)))
920 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
921 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
925 SAVEI32(PL_compiling.cop_arybase);
926 PL_compiling.cop_arybase = 0;
928 else if (type == OP_REFGEN)
931 Perl_croak(aTHX_ "That use of $[ is unsupported");
934 if (o->op_flags & OPf_PARENS)
938 if ((type == OP_UNDEF || type == OP_REFGEN) &&
939 !(o->op_flags & OPf_STACKED)) {
940 o->op_type = OP_RV2CV; /* entersub => rv2cv */
941 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
942 assert(cUNOPo->op_first->op_type == OP_NULL);
943 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
946 else if (o->op_private & OPpENTERSUB_NOMOD)
948 else { /* lvalue subroutine call */
949 o->op_private |= OPpLVAL_INTRO;
950 PL_modcount = RETURN_UNLIMITED_NUMBER;
951 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
952 /* Backward compatibility mode: */
953 o->op_private |= OPpENTERSUB_INARGS;
956 else { /* Compile-time error message: */
957 OP *kid = cUNOPo->op_first;
961 if (kid->op_type == OP_PUSHMARK)
963 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
965 "panic: unexpected lvalue entersub "
966 "args: type/targ %ld:%"UVuf,
967 (long)kid->op_type, (UV)kid->op_targ);
968 kid = kLISTOP->op_first;
970 while (kid->op_sibling)
971 kid = kid->op_sibling;
972 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
974 if (kid->op_type == OP_METHOD_NAMED
975 || kid->op_type == OP_METHOD)
979 NewOp(1101, newop, 1, UNOP);
980 newop->op_type = OP_RV2CV;
981 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
982 newop->op_first = Nullop;
983 newop->op_next = (OP*)newop;
984 kid->op_sibling = (OP*)newop;
985 newop->op_private |= OPpLVAL_INTRO;
989 if (kid->op_type != OP_RV2CV)
991 "panic: unexpected lvalue entersub "
992 "entry via type/targ %ld:%"UVuf,
993 (long)kid->op_type, (UV)kid->op_targ);
994 kid->op_private |= OPpLVAL_INTRO;
995 break; /* Postpone until runtime */
999 kid = kUNOP->op_first;
1000 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1001 kid = kUNOP->op_first;
1002 if (kid->op_type == OP_NULL)
1004 "Unexpected constant lvalue entersub "
1005 "entry via type/targ %ld:%"UVuf,
1006 (long)kid->op_type, (UV)kid->op_targ);
1007 if (kid->op_type != OP_GV) {
1008 /* Restore RV2CV to check lvalueness */
1010 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1011 okid->op_next = kid->op_next;
1012 kid->op_next = okid;
1015 okid->op_next = Nullop;
1016 okid->op_type = OP_RV2CV;
1018 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1019 okid->op_private |= OPpLVAL_INTRO;
1023 cv = GvCV(kGVOP_gv);
1033 /* grep, foreach, subcalls, refgen */
1034 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1036 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1037 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1039 : (o->op_type == OP_ENTERSUB
1040 ? "non-lvalue subroutine call"
1042 type ? PL_op_desc[type] : "local"));
1056 case OP_RIGHT_SHIFT:
1065 if (!(o->op_flags & OPf_STACKED))
1072 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1078 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1079 PL_modcount = RETURN_UNLIMITED_NUMBER;
1080 return o; /* Treat \(@foo) like ordinary list. */
1084 if (scalar_mod_type(o, type))
1086 ref(cUNOPo->op_first, o->op_type);
1090 if (type == OP_LEAVESUBLV)
1091 o->op_private |= OPpMAYBE_LVSUB;
1097 PL_modcount = RETURN_UNLIMITED_NUMBER;
1100 ref(cUNOPo->op_first, o->op_type);
1105 PL_hints |= HINT_BLOCK_SCOPE;
1120 PL_modcount = RETURN_UNLIMITED_NUMBER;
1121 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1122 return o; /* Treat \(@foo) like ordinary list. */
1123 if (scalar_mod_type(o, type))
1125 if (type == OP_LEAVESUBLV)
1126 o->op_private |= OPpMAYBE_LVSUB;
1130 if (!type) /* local() */
1131 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1132 PAD_COMPNAME_PV(o->op_targ));
1140 if (type != OP_SASSIGN)
1144 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1149 if (type == OP_LEAVESUBLV)
1150 o->op_private |= OPpMAYBE_LVSUB;
1152 pad_free(o->op_targ);
1153 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1154 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1155 if (o->op_flags & OPf_KIDS)
1156 mod(cBINOPo->op_first->op_sibling, type);
1161 ref(cBINOPo->op_first, o->op_type);
1162 if (type == OP_ENTERSUB &&
1163 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1164 o->op_private |= OPpLVAL_DEFER;
1165 if (type == OP_LEAVESUBLV)
1166 o->op_private |= OPpMAYBE_LVSUB;
1176 if (o->op_flags & OPf_KIDS)
1177 mod(cLISTOPo->op_last, type);
1182 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1184 else if (!(o->op_flags & OPf_KIDS))
1186 if (o->op_targ != OP_LIST) {
1187 mod(cBINOPo->op_first, type);
1193 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1198 if (type != OP_LEAVESUBLV)
1200 break; /* mod()ing was handled by ck_return() */
1203 /* [20011101.069] File test operators interpret OPf_REF to mean that
1204 their argument is a filehandle; thus \stat(".") should not set
1206 if (type == OP_REFGEN &&
1207 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1210 if (type != OP_LEAVESUBLV)
1211 o->op_flags |= OPf_MOD;
1213 if (type == OP_AASSIGN || type == OP_SASSIGN)
1214 o->op_flags |= OPf_SPECIAL|OPf_REF;
1215 else if (!type) { /* local() */
1218 o->op_private |= OPpLVAL_INTRO;
1219 o->op_flags &= ~OPf_SPECIAL;
1220 PL_hints |= HINT_BLOCK_SCOPE;
1225 if (ckWARN(WARN_SYNTAX)) {
1226 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1227 "Useless localization of %s", OP_DESC(o));
1231 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1232 && type != OP_LEAVESUBLV)
1233 o->op_flags |= OPf_REF;
1238 S_scalar_mod_type(pTHX_ OP *o, I32 type)
1242 if (o->op_type == OP_RV2GV)
1266 case OP_RIGHT_SHIFT:
1285 S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
1287 switch (o->op_type) {
1295 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1308 Perl_refkids(pTHX_ OP *o, I32 type)
1311 if (o && o->op_flags & OPf_KIDS) {
1312 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1319 Perl_ref(pTHX_ OP *o, I32 type)
1323 if (!o || PL_error_count)
1326 switch (o->op_type) {
1328 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1329 !(o->op_flags & OPf_STACKED)) {
1330 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1331 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1332 assert(cUNOPo->op_first->op_type == OP_NULL);
1333 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1334 o->op_flags |= OPf_SPECIAL;
1339 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1343 if (type == OP_DEFINED)
1344 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1345 ref(cUNOPo->op_first, o->op_type);
1348 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1349 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1350 : type == OP_RV2HV ? OPpDEREF_HV
1352 o->op_flags |= OPf_MOD;
1357 o->op_flags |= OPf_MOD; /* XXX ??? */
1362 o->op_flags |= OPf_REF;
1365 if (type == OP_DEFINED)
1366 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1367 ref(cUNOPo->op_first, o->op_type);
1372 o->op_flags |= OPf_REF;
1377 if (!(o->op_flags & OPf_KIDS))
1379 ref(cBINOPo->op_first, type);
1383 ref(cBINOPo->op_first, o->op_type);
1384 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1385 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1386 : type == OP_RV2HV ? OPpDEREF_HV
1388 o->op_flags |= OPf_MOD;
1396 if (!(o->op_flags & OPf_KIDS))
1398 ref(cLISTOPo->op_last, type);
1408 S_dup_attrlist(pTHX_ OP *o)
1412 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1413 * where the first kid is OP_PUSHMARK and the remaining ones
1414 * are OP_CONST. We need to push the OP_CONST values.
1416 if (o->op_type == OP_CONST)
1417 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1419 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1420 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1421 if (o->op_type == OP_CONST)
1422 rop = append_elem(OP_LIST, rop,
1423 newSVOP(OP_CONST, o->op_flags,
1424 SvREFCNT_inc(cSVOPo->op_sv)));
1431 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1435 /* fake up C<use attributes $pkg,$rv,@attrs> */
1436 ENTER; /* need to protect against side-effects of 'use' */
1439 stashsv = newSVpv(HvNAME(stash), 0);
1441 stashsv = &PL_sv_no;
1443 #define ATTRSMODULE "attributes"
1444 #define ATTRSMODULE_PM "attributes.pm"
1448 /* Don't force the C<use> if we don't need it. */
1449 svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
1450 sizeof(ATTRSMODULE_PM)-1, 0);
1451 if (svp && *svp != &PL_sv_undef)
1452 ; /* already in %INC */
1454 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1455 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1459 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1460 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1462 prepend_elem(OP_LIST,
1463 newSVOP(OP_CONST, 0, stashsv),
1464 prepend_elem(OP_LIST,
1465 newSVOP(OP_CONST, 0,
1467 dup_attrlist(attrs))));
1473 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1475 OP *pack, *imop, *arg;
1481 assert(target->op_type == OP_PADSV ||
1482 target->op_type == OP_PADHV ||
1483 target->op_type == OP_PADAV);
1485 /* Ensure that attributes.pm is loaded. */
1486 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1488 /* Need package name for method call. */
1489 pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
1491 /* Build up the real arg-list. */
1493 stashsv = newSVpv(HvNAME(stash), 0);
1495 stashsv = &PL_sv_no;
1496 arg = newOP(OP_PADSV, 0);
1497 arg->op_targ = target->op_targ;
1498 arg = prepend_elem(OP_LIST,
1499 newSVOP(OP_CONST, 0, stashsv),
1500 prepend_elem(OP_LIST,
1501 newUNOP(OP_REFGEN, 0,
1502 mod(arg, OP_REFGEN)),
1503 dup_attrlist(attrs)));
1505 /* Fake up a method call to import */
1506 meth = newSVpvn("import", 6);
1507 (void)SvUPGRADE(meth, SVt_PVIV);
1508 (void)SvIOK_on(meth);
1509 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
1510 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1511 append_elem(OP_LIST,
1512 prepend_elem(OP_LIST, pack, list(arg)),
1513 newSVOP(OP_METHOD_NAMED, 0, meth)));
1514 imop->op_private |= OPpENTERSUB_NOMOD;
1516 /* Combine the ops. */
1517 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1521 =notfor apidoc apply_attrs_string
1523 Attempts to apply a list of attributes specified by the C<attrstr> and
1524 C<len> arguments to the subroutine identified by the C<cv> argument which
1525 is expected to be associated with the package identified by the C<stashpv>
1526 argument (see L<attributes>). It gets this wrong, though, in that it
1527 does not correctly identify the boundaries of the individual attribute
1528 specifications within C<attrstr>. This is not really intended for the
1529 public API, but has to be listed here for systems such as AIX which
1530 need an explicit export list for symbols. (It's called from XS code
1531 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1532 to respect attribute syntax properly would be welcome.
1538 Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
1539 char *attrstr, STRLEN len)
1544 len = strlen(attrstr);
1548 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1550 char *sstr = attrstr;
1551 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1552 attrs = append_elem(OP_LIST, attrs,
1553 newSVOP(OP_CONST, 0,
1554 newSVpvn(sstr, attrstr-sstr)));
1558 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1559 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1560 Nullsv, prepend_elem(OP_LIST,
1561 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1562 prepend_elem(OP_LIST,
1563 newSVOP(OP_CONST, 0,
1569 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1574 if (!o || PL_error_count)
1578 if (type == OP_LIST) {
1579 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1580 my_kid(kid, attrs, imopsp);
1581 } else if (type == OP_UNDEF) {
1583 } else if (type == OP_RV2SV || /* "our" declaration */
1585 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1586 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1587 yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
1588 OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
1590 GV *gv = cGVOPx_gv(cUNOPo->op_first);
1592 PL_in_my_stash = Nullhv;
1593 apply_attrs(GvSTASH(gv),
1594 (type == OP_RV2SV ? GvSV(gv) :
1595 type == OP_RV2AV ? (SV*)GvAV(gv) :
1596 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1599 o->op_private |= OPpOUR_INTRO;
1602 else if (type != OP_PADSV &&
1605 type != OP_PUSHMARK)
1607 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1609 PL_in_my == KEY_our ? "our" : "my"));
1612 else if (attrs && type != OP_PUSHMARK) {
1616 PL_in_my_stash = Nullhv;
1618 /* check for C<my Dog $spot> when deciding package */
1619 stash = PAD_COMPNAME_TYPE(o->op_targ);
1621 stash = PL_curstash;
1622 apply_attrs_my(stash, o, attrs, imopsp);
1624 o->op_flags |= OPf_MOD;
1625 o->op_private |= OPpLVAL_INTRO;
1630 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1633 int maybe_scalar = 0;
1635 /* [perl #17376]: this appears to be premature, and results in code such as
1636 C< our(%x); > executing in list mode rather than void mode */
1638 if (o->op_flags & OPf_PARENS)
1647 o = my_kid(o, attrs, &rops);
1649 if (maybe_scalar && o->op_type == OP_PADSV) {
1650 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1651 o->op_private |= OPpLVAL_INTRO;
1654 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1657 PL_in_my_stash = Nullhv;
1662 Perl_my(pTHX_ OP *o)
1664 return my_attrs(o, Nullop);
1668 Perl_sawparens(pTHX_ OP *o)
1671 o->op_flags |= OPf_PARENS;
1676 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1681 if (ckWARN(WARN_MISC) &&
1682 (left->op_type == OP_RV2AV ||
1683 left->op_type == OP_RV2HV ||
1684 left->op_type == OP_PADAV ||
1685 left->op_type == OP_PADHV)) {
1686 char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
1687 right->op_type == OP_TRANS)
1688 ? right->op_type : OP_MATCH];
1689 const char *sample = ((left->op_type == OP_RV2AV ||
1690 left->op_type == OP_PADAV)
1691 ? "@array" : "%hash");
1692 Perl_warner(aTHX_ packWARN(WARN_MISC),
1693 "Applying %s to %s will act on scalar(%s)",
1694 desc, sample, sample);
1697 if (right->op_type == OP_CONST &&
1698 cSVOPx(right)->op_private & OPpCONST_BARE &&
1699 cSVOPx(right)->op_private & OPpCONST_STRICT)
1701 no_bareword_allowed(right);
1704 ismatchop = right->op_type == OP_MATCH ||
1705 right->op_type == OP_SUBST ||
1706 right->op_type == OP_TRANS;
1707 if (ismatchop && right->op_private & OPpTARGET_MY) {
1709 right->op_private &= ~OPpTARGET_MY;
1711 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1712 right->op_flags |= OPf_STACKED;
1713 if (right->op_type != OP_MATCH &&
1714 ! (right->op_type == OP_TRANS &&
1715 right->op_private & OPpTRANS_IDENTICAL))
1716 left = mod(left, right->op_type);
1717 if (right->op_type == OP_TRANS)
1718 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
1720 o = prepend_elem(right->op_type, scalar(left), right);
1722 return newUNOP(OP_NOT, 0, scalar(o));
1726 return bind_match(type, left,
1727 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
1731 Perl_invert(pTHX_ OP *o)
1735 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
1736 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1740 Perl_scope(pTHX_ OP *o)
1743 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1744 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1745 o->op_type = OP_LEAVE;
1746 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1748 else if (o->op_type == OP_LINESEQ) {
1750 o->op_type = OP_SCOPE;
1751 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1752 kid = ((LISTOP*)o)->op_first;
1753 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
1757 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
1763 Perl_save_hints(pTHX)
1766 SAVESPTR(GvHV(PL_hintgv));
1767 GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
1768 SAVEFREESV(GvHV(PL_hintgv));
1772 Perl_block_start(pTHX_ int full)
1774 int retval = PL_savestack_ix;
1775 pad_block_start(full);
1777 PL_hints &= ~HINT_BLOCK_SCOPE;
1778 SAVESPTR(PL_compiling.cop_warnings);
1779 if (! specialWARN(PL_compiling.cop_warnings)) {
1780 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1781 SAVEFREESV(PL_compiling.cop_warnings) ;
1783 SAVESPTR(PL_compiling.cop_io);
1784 if (! specialCopIO(PL_compiling.cop_io)) {
1785 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1786 SAVEFREESV(PL_compiling.cop_io) ;
1792 Perl_block_end(pTHX_ I32 floor, OP *seq)
1794 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1795 OP* retval = scalarseq(seq);
1797 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
1799 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
1807 I32 offset = pad_findmy("$_");
1808 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
1809 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1812 OP *o = newOP(OP_PADSV, 0);
1813 o->op_targ = offset;
1819 Perl_newPROG(pTHX_ OP *o)
1824 PL_eval_root = newUNOP(OP_LEAVEEVAL,
1825 ((PL_in_eval & EVAL_KEEPERR)
1826 ? OPf_SPECIAL : 0), o);
1827 PL_eval_start = linklist(PL_eval_root);
1828 PL_eval_root->op_private |= OPpREFCOUNTED;
1829 OpREFCNT_set(PL_eval_root, 1);
1830 PL_eval_root->op_next = 0;
1831 CALL_PEEP(PL_eval_start);
1834 if (o->op_type == OP_STUB) {
1835 PL_comppad_name = 0;
1840 PL_main_root = scope(sawparens(scalarvoid(o)));
1841 PL_curcop = &PL_compiling;
1842 PL_main_start = LINKLIST(PL_main_root);
1843 PL_main_root->op_private |= OPpREFCOUNTED;
1844 OpREFCNT_set(PL_main_root, 1);
1845 PL_main_root->op_next = 0;
1846 CALL_PEEP(PL_main_start);
1849 /* Register with debugger */
1851 CV *cv = get_cv("DB::postponed", FALSE);
1855 XPUSHs((SV*)CopFILEGV(&PL_compiling));
1857 call_sv((SV*)cv, G_DISCARD);
1864 Perl_localize(pTHX_ OP *o, I32 lex)
1866 if (o->op_flags & OPf_PARENS)
1867 /* [perl #17376]: this appears to be premature, and results in code such as
1868 C< our(%x); > executing in list mode rather than void mode */
1875 if (ckWARN(WARN_PARENTHESIS)
1876 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
1878 char *s = PL_bufptr;
1881 /* some heuristics to detect a potential error */
1882 while (*s && (strchr(", \t\n", *s)))
1886 if (*s && strchr("@$%*", *s) && *++s
1887 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
1890 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
1892 while (*s && (strchr(", \t\n", *s)))
1898 if (sigil && (*s == ';' || *s == '=')) {
1899 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
1900 "Parentheses missing around \"%s\" list",
1901 lex ? (PL_in_my == KEY_our ? "our" : "my")
1909 o = mod(o, OP_NULL); /* a bit kludgey */
1911 PL_in_my_stash = Nullhv;
1916 Perl_jmaybe(pTHX_ OP *o)
1918 if (o->op_type == OP_LIST) {
1920 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
1921 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
1927 Perl_fold_constants(pTHX_ register OP *o)
1930 I32 type = o->op_type;
1933 if (PL_opargs[type] & OA_RETSCALAR)
1935 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
1936 o->op_targ = pad_alloc(type, SVs_PADTMP);
1938 /* integerize op, unless it happens to be C<-foo>.
1939 * XXX should pp_i_negate() do magic string negation instead? */
1940 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
1941 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
1942 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
1944 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
1947 if (!(PL_opargs[type] & OA_FOLDCONST))
1952 /* XXX might want a ck_negate() for this */
1953 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
1965 /* XXX what about the numeric ops? */
1966 if (PL_hints & HINT_LOCALE)
1971 goto nope; /* Don't try to run w/ errors */
1973 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
1974 if ((curop->op_type != OP_CONST ||
1975 (curop->op_private & OPpCONST_BARE)) &&
1976 curop->op_type != OP_LIST &&
1977 curop->op_type != OP_SCALAR &&
1978 curop->op_type != OP_NULL &&
1979 curop->op_type != OP_PUSHMARK)
1985 curop = LINKLIST(o);
1989 sv = *(PL_stack_sp--);
1990 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
1991 pad_swipe(o->op_targ, FALSE);
1992 else if (SvTEMP(sv)) { /* grab mortal temp? */
1993 (void)SvREFCNT_inc(sv);
1997 if (type == OP_RV2GV)
1998 return newGVOP(OP_GV, 0, (GV*)sv);
1999 return newSVOP(OP_CONST, 0, sv);
2006 Perl_gen_constant_list(pTHX_ register OP *o)
2009 I32 oldtmps_floor = PL_tmps_floor;
2013 return o; /* Don't attempt to run with errors */
2015 PL_op = curop = LINKLIST(o);
2022 PL_tmps_floor = oldtmps_floor;
2024 o->op_type = OP_RV2AV;
2025 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2026 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2027 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2028 o->op_opt = 0; /* needs to be revisited in peep() */
2029 curop = ((UNOP*)o)->op_first;
2030 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2037 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2039 if (!o || o->op_type != OP_LIST)
2040 o = newLISTOP(OP_LIST, 0, o, Nullop);
2042 o->op_flags &= ~OPf_WANT;
2044 if (!(PL_opargs[type] & OA_MARK))
2045 op_null(cLISTOPo->op_first);
2047 o->op_type = (OPCODE)type;
2048 o->op_ppaddr = PL_ppaddr[type];
2049 o->op_flags |= flags;
2051 o = CHECKOP(type, o);
2052 if (o->op_type != type)
2055 return fold_constants(o);
2058 /* List constructors */
2061 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2069 if (first->op_type != type
2070 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2072 return newLISTOP(type, 0, first, last);
2075 if (first->op_flags & OPf_KIDS)
2076 ((LISTOP*)first)->op_last->op_sibling = last;
2078 first->op_flags |= OPf_KIDS;
2079 ((LISTOP*)first)->op_first = last;
2081 ((LISTOP*)first)->op_last = last;
2086 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2094 if (first->op_type != type)
2095 return prepend_elem(type, (OP*)first, (OP*)last);
2097 if (last->op_type != type)
2098 return append_elem(type, (OP*)first, (OP*)last);
2100 first->op_last->op_sibling = last->op_first;
2101 first->op_last = last->op_last;
2102 first->op_flags |= (last->op_flags & OPf_KIDS);
2110 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2118 if (last->op_type == type) {
2119 if (type == OP_LIST) { /* already a PUSHMARK there */
2120 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2121 ((LISTOP*)last)->op_first->op_sibling = first;
2122 if (!(first->op_flags & OPf_PARENS))
2123 last->op_flags &= ~OPf_PARENS;
2126 if (!(last->op_flags & OPf_KIDS)) {
2127 ((LISTOP*)last)->op_last = first;
2128 last->op_flags |= OPf_KIDS;
2130 first->op_sibling = ((LISTOP*)last)->op_first;
2131 ((LISTOP*)last)->op_first = first;
2133 last->op_flags |= OPf_KIDS;
2137 return newLISTOP(type, 0, first, last);
2143 Perl_newNULLLIST(pTHX)
2145 return newOP(OP_STUB, 0);
2149 Perl_force_list(pTHX_ OP *o)
2151 if (!o || o->op_type != OP_LIST)
2152 o = newLISTOP(OP_LIST, 0, o, Nullop);
2158 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2162 NewOp(1101, listop, 1, LISTOP);
2164 listop->op_type = (OPCODE)type;
2165 listop->op_ppaddr = PL_ppaddr[type];
2168 listop->op_flags = (U8)flags;
2172 else if (!first && last)
2175 first->op_sibling = last;
2176 listop->op_first = first;
2177 listop->op_last = last;
2178 if (type == OP_LIST) {
2180 pushop = newOP(OP_PUSHMARK, 0);
2181 pushop->op_sibling = first;
2182 listop->op_first = pushop;
2183 listop->op_flags |= OPf_KIDS;
2185 listop->op_last = pushop;
2188 return CHECKOP(type, listop);
2192 Perl_newOP(pTHX_ I32 type, I32 flags)
2195 NewOp(1101, o, 1, OP);
2196 o->op_type = (OPCODE)type;
2197 o->op_ppaddr = PL_ppaddr[type];
2198 o->op_flags = (U8)flags;
2201 o->op_private = (U8)(0 | (flags >> 8));
2202 if (PL_opargs[type] & OA_RETSCALAR)
2204 if (PL_opargs[type] & OA_TARGET)
2205 o->op_targ = pad_alloc(type, SVs_PADTMP);
2206 return CHECKOP(type, o);
2210 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2215 first = newOP(OP_STUB, 0);
2216 if (PL_opargs[type] & OA_MARK)
2217 first = force_list(first);
2219 NewOp(1101, unop, 1, UNOP);
2220 unop->op_type = (OPCODE)type;
2221 unop->op_ppaddr = PL_ppaddr[type];
2222 unop->op_first = first;
2223 unop->op_flags = flags | OPf_KIDS;
2224 unop->op_private = (U8)(1 | (flags >> 8));
2225 unop = (UNOP*) CHECKOP(type, unop);
2229 return fold_constants((OP *) unop);
2233 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2236 NewOp(1101, binop, 1, BINOP);
2239 first = newOP(OP_NULL, 0);
2241 binop->op_type = (OPCODE)type;
2242 binop->op_ppaddr = PL_ppaddr[type];
2243 binop->op_first = first;
2244 binop->op_flags = flags | OPf_KIDS;
2247 binop->op_private = (U8)(1 | (flags >> 8));
2250 binop->op_private = (U8)(2 | (flags >> 8));
2251 first->op_sibling = last;
2254 binop = (BINOP*)CHECKOP(type, binop);
2255 if (binop->op_next || binop->op_type != (OPCODE)type)
2258 binop->op_last = binop->op_first->op_sibling;
2260 return fold_constants((OP *)binop);
2264 uvcompare(const void *a, const void *b)
2266 if (*((UV *)a) < (*(UV *)b))
2268 if (*((UV *)a) > (*(UV *)b))
2270 if (*((UV *)a+1) < (*(UV *)b+1))
2272 if (*((UV *)a+1) > (*(UV *)b+1))
2278 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2280 SV *tstr = ((SVOP*)expr)->op_sv;
2281 SV *rstr = ((SVOP*)repl)->op_sv;
2284 U8 *t = (U8*)SvPV(tstr, tlen);
2285 U8 *r = (U8*)SvPV(rstr, rlen);
2292 register short *tbl;
2294 PL_hints |= HINT_BLOCK_SCOPE;
2295 complement = o->op_private & OPpTRANS_COMPLEMENT;
2296 del = o->op_private & OPpTRANS_DELETE;
2297 squash = o->op_private & OPpTRANS_SQUASH;
2300 o->op_private |= OPpTRANS_FROM_UTF;
2303 o->op_private |= OPpTRANS_TO_UTF;
2305 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2306 SV* listsv = newSVpvn("# comment\n",10);
2308 U8* tend = t + tlen;
2309 U8* rend = r + rlen;
2323 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2324 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2330 tsave = t = bytes_to_utf8(t, &len);
2333 if (!to_utf && rlen) {
2335 rsave = r = bytes_to_utf8(r, &len);
2339 /* There are several snags with this code on EBCDIC:
2340 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2341 2. scan_const() in toke.c has encoded chars in native encoding which makes
2342 ranges at least in EBCDIC 0..255 range the bottom odd.
2346 U8 tmpbuf[UTF8_MAXLEN+1];
2349 New(1109, cp, 2*tlen, UV);
2351 transv = newSVpvn("",0);
2353 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2355 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2357 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2361 cp[2*i+1] = cp[2*i];
2365 qsort(cp, i, 2*sizeof(UV), uvcompare);
2366 for (j = 0; j < i; j++) {
2368 diff = val - nextmin;
2370 t = uvuni_to_utf8(tmpbuf,nextmin);
2371 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2373 U8 range_mark = UTF_TO_NATIVE(0xff);
2374 t = uvuni_to_utf8(tmpbuf, val - 1);
2375 sv_catpvn(transv, (char *)&range_mark, 1);
2376 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2383 t = uvuni_to_utf8(tmpbuf,nextmin);
2384 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2386 U8 range_mark = UTF_TO_NATIVE(0xff);
2387 sv_catpvn(transv, (char *)&range_mark, 1);
2389 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2390 UNICODE_ALLOW_SUPER);
2391 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2392 t = (U8*)SvPVX(transv);
2393 tlen = SvCUR(transv);
2397 else if (!rlen && !del) {
2398 r = t; rlen = tlen; rend = tend;
2401 if ((!rlen && !del) || t == r ||
2402 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2404 o->op_private |= OPpTRANS_IDENTICAL;
2408 while (t < tend || tfirst <= tlast) {
2409 /* see if we need more "t" chars */
2410 if (tfirst > tlast) {
2411 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2413 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2415 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2422 /* now see if we need more "r" chars */
2423 if (rfirst > rlast) {
2425 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2427 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2429 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2438 rfirst = rlast = 0xffffffff;
2442 /* now see which range will peter our first, if either. */
2443 tdiff = tlast - tfirst;
2444 rdiff = rlast - rfirst;
2451 if (rfirst == 0xffffffff) {
2452 diff = tdiff; /* oops, pretend rdiff is infinite */
2454 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2455 (long)tfirst, (long)tlast);
2457 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2461 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2462 (long)tfirst, (long)(tfirst + diff),
2465 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2466 (long)tfirst, (long)rfirst);
2468 if (rfirst + diff > max)
2469 max = rfirst + diff;
2471 grows = (tfirst < rfirst &&
2472 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2484 else if (max > 0xff)
2489 Safefree(cPVOPo->op_pv);
2490 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2491 SvREFCNT_dec(listsv);
2493 SvREFCNT_dec(transv);
2495 if (!del && havefinal && rlen)
2496 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2497 newSVuv((UV)final), 0);
2500 o->op_private |= OPpTRANS_GROWS;
2512 tbl = (short*)cPVOPo->op_pv;
2514 Zero(tbl, 256, short);
2515 for (i = 0; i < (I32)tlen; i++)
2517 for (i = 0, j = 0; i < 256; i++) {
2519 if (j >= (I32)rlen) {
2528 if (i < 128 && r[j] >= 128)
2538 o->op_private |= OPpTRANS_IDENTICAL;
2540 else if (j >= (I32)rlen)
2543 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2544 tbl[0x100] = rlen - j;
2545 for (i=0; i < (I32)rlen - j; i++)
2546 tbl[0x101+i] = r[j+i];
2550 if (!rlen && !del) {
2553 o->op_private |= OPpTRANS_IDENTICAL;
2555 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2556 o->op_private |= OPpTRANS_IDENTICAL;
2558 for (i = 0; i < 256; i++)
2560 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
2561 if (j >= (I32)rlen) {
2563 if (tbl[t[i]] == -1)
2569 if (tbl[t[i]] == -1) {
2570 if (t[i] < 128 && r[j] >= 128)
2577 o->op_private |= OPpTRANS_GROWS;
2585 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2589 NewOp(1101, pmop, 1, PMOP);
2590 pmop->op_type = (OPCODE)type;
2591 pmop->op_ppaddr = PL_ppaddr[type];
2592 pmop->op_flags = (U8)flags;
2593 pmop->op_private = (U8)(0 | (flags >> 8));
2595 if (PL_hints & HINT_RE_TAINT)
2596 pmop->op_pmpermflags |= PMf_RETAINT;
2597 if (PL_hints & HINT_LOCALE)
2598 pmop->op_pmpermflags |= PMf_LOCALE;
2599 pmop->op_pmflags = pmop->op_pmpermflags;
2604 if(av_len((AV*) PL_regex_pad[0]) > -1) {
2605 repointer = av_pop((AV*)PL_regex_pad[0]);
2606 pmop->op_pmoffset = SvIV(repointer);
2607 SvREPADTMP_off(repointer);
2608 sv_setiv(repointer,0);
2610 repointer = newSViv(0);
2611 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2612 pmop->op_pmoffset = av_len(PL_regex_padav);
2613 PL_regex_pad = AvARRAY(PL_regex_padav);
2618 /* link into pm list */
2619 if (type != OP_TRANS && PL_curstash) {
2620 pmop->op_pmnext = HvPMROOT(PL_curstash);
2621 HvPMROOT(PL_curstash) = pmop;
2622 PmopSTASH_set(pmop,PL_curstash);
2625 return CHECKOP(type, pmop);
2629 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
2633 I32 repl_has_vars = 0;
2635 if (o->op_type == OP_TRANS)
2636 return pmtrans(o, expr, repl);
2638 PL_hints |= HINT_BLOCK_SCOPE;
2641 if (expr->op_type == OP_CONST) {
2643 SV *pat = ((SVOP*)expr)->op_sv;
2644 char *p = SvPV(pat, plen);
2645 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
2646 sv_setpvn(pat, "\\s+", 3);
2647 p = SvPV(pat, plen);
2648 pm->op_pmflags |= PMf_SKIPWHITE;
2651 pm->op_pmdynflags |= PMdf_UTF8;
2652 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
2653 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
2654 pm->op_pmflags |= PMf_WHITE;
2658 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2659 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2661 : OP_REGCMAYBE),0,expr);
2663 NewOp(1101, rcop, 1, LOGOP);
2664 rcop->op_type = OP_REGCOMP;
2665 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2666 rcop->op_first = scalar(expr);
2667 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
2668 ? (OPf_SPECIAL | OPf_KIDS)
2670 rcop->op_private = 1;
2672 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
2675 /* establish postfix order */
2676 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2678 rcop->op_next = expr;
2679 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2682 rcop->op_next = LINKLIST(expr);
2683 expr->op_next = (OP*)rcop;
2686 prepend_elem(o->op_type, scalar((OP*)rcop), o);
2691 if (pm->op_pmflags & PMf_EVAL) {
2693 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
2694 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
2696 else if (repl->op_type == OP_CONST)
2700 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
2701 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
2702 if (curop->op_type == OP_GV) {
2703 GV *gv = cGVOPx_gv(curop);
2705 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
2708 else if (curop->op_type == OP_RV2CV)
2710 else if (curop->op_type == OP_RV2SV ||
2711 curop->op_type == OP_RV2AV ||
2712 curop->op_type == OP_RV2HV ||
2713 curop->op_type == OP_RV2GV) {
2714 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2717 else if (curop->op_type == OP_PADSV ||
2718 curop->op_type == OP_PADAV ||
2719 curop->op_type == OP_PADHV ||
2720 curop->op_type == OP_PADANY) {
2723 else if (curop->op_type == OP_PUSHRE)
2724 ; /* Okay here, dangerous in newASSIGNOP */
2734 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
2735 pm->op_pmflags |= PMf_CONST; /* const for long enough */
2736 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
2737 prepend_elem(o->op_type, scalar(repl), o);
2740 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
2741 pm->op_pmflags |= PMf_MAYBE_CONST;
2742 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2744 NewOp(1101, rcop, 1, LOGOP);
2745 rcop->op_type = OP_SUBSTCONT;
2746 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
2747 rcop->op_first = scalar(repl);
2748 rcop->op_flags |= OPf_KIDS;
2749 rcop->op_private = 1;
2752 /* establish postfix order */
2753 rcop->op_next = LINKLIST(repl);
2754 repl->op_next = (OP*)rcop;
2756 pm->op_pmreplroot = scalar((OP*)rcop);
2757 pm->op_pmreplstart = LINKLIST(rcop);
2766 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
2769 NewOp(1101, svop, 1, SVOP);
2770 svop->op_type = (OPCODE)type;
2771 svop->op_ppaddr = PL_ppaddr[type];
2773 svop->op_next = (OP*)svop;
2774 svop->op_flags = (U8)flags;
2775 if (PL_opargs[type] & OA_RETSCALAR)
2777 if (PL_opargs[type] & OA_TARGET)
2778 svop->op_targ = pad_alloc(type, SVs_PADTMP);
2779 return CHECKOP(type, svop);
2783 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2786 NewOp(1101, padop, 1, PADOP);
2787 padop->op_type = (OPCODE)type;
2788 padop->op_ppaddr = PL_ppaddr[type];
2789 padop->op_padix = pad_alloc(type, SVs_PADTMP);
2790 SvREFCNT_dec(PAD_SVl(padop->op_padix));
2791 PAD_SETSV(padop->op_padix, sv);
2794 padop->op_next = (OP*)padop;
2795 padop->op_flags = (U8)flags;
2796 if (PL_opargs[type] & OA_RETSCALAR)
2798 if (PL_opargs[type] & OA_TARGET)
2799 padop->op_targ = pad_alloc(type, SVs_PADTMP);
2800 return CHECKOP(type, padop);
2804 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
2809 return newPADOP(type, flags, SvREFCNT_inc(gv));
2811 return newSVOP(type, flags, SvREFCNT_inc(gv));
2816 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
2819 NewOp(1101, pvop, 1, PVOP);
2820 pvop->op_type = (OPCODE)type;
2821 pvop->op_ppaddr = PL_ppaddr[type];
2823 pvop->op_next = (OP*)pvop;
2824 pvop->op_flags = (U8)flags;
2825 if (PL_opargs[type] & OA_RETSCALAR)
2827 if (PL_opargs[type] & OA_TARGET)
2828 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
2829 return CHECKOP(type, pvop);
2833 Perl_package(pTHX_ OP *o)
2838 save_hptr(&PL_curstash);
2839 save_item(PL_curstname);
2841 name = SvPV(cSVOPo->op_sv, len);
2842 PL_curstash = gv_stashpvn(name, len, TRUE);
2843 sv_setpvn(PL_curstname, name, len);
2846 PL_hints |= HINT_BLOCK_SCOPE;
2847 PL_copline = NOLINE;
2852 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
2858 if (idop->op_type != OP_CONST)
2859 Perl_croak(aTHX_ "Module name must be constant");
2863 if (version != Nullop) {
2864 SV *vesv = ((SVOP*)version)->op_sv;
2866 if (arg == Nullop && !SvNIOKp(vesv)) {
2873 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
2874 Perl_croak(aTHX_ "Version number must be constant number");
2876 /* Make copy of idop so we don't free it twice */
2877 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
2879 /* Fake up a method call to VERSION */
2880 meth = newSVpvn("VERSION",7);
2881 sv_upgrade(meth, SVt_PVIV);
2882 (void)SvIOK_on(meth);
2883 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
2884 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2885 append_elem(OP_LIST,
2886 prepend_elem(OP_LIST, pack, list(version)),
2887 newSVOP(OP_METHOD_NAMED, 0, meth)));
2891 /* Fake up an import/unimport */
2892 if (arg && arg->op_type == OP_STUB)
2893 imop = arg; /* no import on explicit () */
2894 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
2895 imop = Nullop; /* use 5.0; */
2900 /* Make copy of idop so we don't free it twice */
2901 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
2903 /* Fake up a method call to import/unimport */
2904 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);
2905 (void)SvUPGRADE(meth, SVt_PVIV);
2906 (void)SvIOK_on(meth);
2907 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
2908 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2909 append_elem(OP_LIST,
2910 prepend_elem(OP_LIST, pack, list(arg)),
2911 newSVOP(OP_METHOD_NAMED, 0, meth)));
2914 /* Fake up the BEGIN {}, which does its thing immediately. */
2916 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
2919 append_elem(OP_LINESEQ,
2920 append_elem(OP_LINESEQ,
2921 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, idop)),
2922 newSTATEOP(0, Nullch, veop)),
2923 newSTATEOP(0, Nullch, imop) ));
2925 /* The "did you use incorrect case?" warning used to be here.
2926 * The problem is that on case-insensitive filesystems one
2927 * might get false positives for "use" (and "require"):
2928 * "use Strict" or "require CARP" will work. This causes
2929 * portability problems for the script: in case-strict
2930 * filesystems the script will stop working.
2932 * The "incorrect case" warning checked whether "use Foo"
2933 * imported "Foo" to your namespace, but that is wrong, too:
2934 * there is no requirement nor promise in the language that
2935 * a Foo.pm should or would contain anything in package "Foo".
2937 * There is very little Configure-wise that can be done, either:
2938 * the case-sensitivity of the build filesystem of Perl does not
2939 * help in guessing the case-sensitivity of the runtime environment.
2942 PL_hints |= HINT_BLOCK_SCOPE;
2943 PL_copline = NOLINE;
2945 PL_cop_seqmax++; /* Purely for B::*'s benefit */
2949 =head1 Embedding Functions
2951 =for apidoc load_module
2953 Loads the module whose name is pointed to by the string part of name.
2954 Note that the actual module name, not its filename, should be given.
2955 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
2956 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
2957 (or 0 for no flags). ver, if specified, provides version semantics
2958 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
2959 arguments can be used to specify arguments to the module's import()
2960 method, similar to C<use Foo::Bar VERSION LIST>.
2965 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
2968 va_start(args, ver);
2969 vload_module(flags, name, ver, &args);
2973 #ifdef PERL_IMPLICIT_CONTEXT
2975 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
2979 va_start(args, ver);
2980 vload_module(flags, name, ver, &args);
2986 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
2988 OP *modname, *veop, *imop;
2990 modname = newSVOP(OP_CONST, 0, name);
2991 modname->op_private |= OPpCONST_BARE;
2993 veop = newSVOP(OP_CONST, 0, ver);
2997 if (flags & PERL_LOADMOD_NOIMPORT) {
2998 imop = sawparens(newNULLLIST());
3000 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3001 imop = va_arg(*args, OP*);
3006 sv = va_arg(*args, SV*);
3008 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3009 sv = va_arg(*args, SV*);
3013 line_t ocopline = PL_copline;
3014 COP *ocurcop = PL_curcop;
3015 int oexpect = PL_expect;
3017 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3018 veop, modname, imop);
3019 PL_expect = oexpect;
3020 PL_copline = ocopline;
3021 PL_curcop = ocurcop;
3026 Perl_dofile(pTHX_ OP *term)
3031 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3032 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
3033 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3035 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3036 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3037 append_elem(OP_LIST, term,
3038 scalar(newUNOP(OP_RV2CV, 0,
3043 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3049 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3051 return newBINOP(OP_LSLICE, flags,
3052 list(force_list(subscript)),
3053 list(force_list(listval)) );
3057 S_list_assignment(pTHX_ register OP *o)
3062 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3063 o = cUNOPo->op_first;
3065 if (o->op_type == OP_COND_EXPR) {
3066 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3067 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3072 yyerror("Assignment to both a list and a scalar");
3076 if (o->op_type == OP_LIST &&
3077 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3078 o->op_private & OPpLVAL_INTRO)
3081 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3082 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3083 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3086 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3089 if (o->op_type == OP_RV2SV)
3096 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3101 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3102 return newLOGOP(optype, 0,
3103 mod(scalar(left), optype),
3104 newUNOP(OP_SASSIGN, 0, scalar(right)));
3107 return newBINOP(optype, OPf_STACKED,
3108 mod(scalar(left), optype), scalar(right));
3112 if (list_assignment(left)) {
3116 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3117 left = mod(left, OP_AASSIGN);
3125 curop = list(force_list(left));
3126 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3127 o->op_private = (U8)(0 | (flags >> 8));
3129 /* PL_generation sorcery:
3130 * an assignment like ($a,$b) = ($c,$d) is easier than
3131 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3132 * To detect whether there are common vars, the global var
3133 * PL_generation is incremented for each assign op we compile.
3134 * Then, while compiling the assign op, we run through all the
3135 * variables on both sides of the assignment, setting a spare slot
3136 * in each of them to PL_generation. If any of them already have
3137 * that value, we know we've got commonality. We could use a
3138 * single bit marker, but then we'd have to make 2 passes, first
3139 * to clear the flag, then to test and set it. To find somewhere
3140 * to store these values, evil chicanery is done with SvCUR().
3143 if (!(left->op_private & OPpLVAL_INTRO)) {
3146 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3147 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3148 if (curop->op_type == OP_GV) {
3149 GV *gv = cGVOPx_gv(curop);
3150 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3152 SvCUR(gv) = PL_generation;
3154 else if (curop->op_type == OP_PADSV ||
3155 curop->op_type == OP_PADAV ||
3156 curop->op_type == OP_PADHV ||
3157 curop->op_type == OP_PADANY)
3159 if (PAD_COMPNAME_GEN(curop->op_targ)
3160 == (STRLEN)PL_generation)
3162 PAD_COMPNAME_GEN(curop->op_targ)
3166 else if (curop->op_type == OP_RV2CV)
3168 else if (curop->op_type == OP_RV2SV ||
3169 curop->op_type == OP_RV2AV ||
3170 curop->op_type == OP_RV2HV ||
3171 curop->op_type == OP_RV2GV) {
3172 if (lastop->op_type != OP_GV) /* funny deref? */
3175 else if (curop->op_type == OP_PUSHRE) {
3176 if (((PMOP*)curop)->op_pmreplroot) {
3178 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3179 ((PMOP*)curop)->op_pmreplroot));
3181 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3183 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3185 SvCUR(gv) = PL_generation;
3194 o->op_private |= OPpASSIGN_COMMON;
3196 if (right && right->op_type == OP_SPLIT) {
3198 if ((tmpop = ((LISTOP*)right)->op_first) &&
3199 tmpop->op_type == OP_PUSHRE)
3201 PMOP *pm = (PMOP*)tmpop;
3202 if (left->op_type == OP_RV2AV &&
3203 !(left->op_private & OPpLVAL_INTRO) &&
3204 !(o->op_private & OPpASSIGN_COMMON) )
3206 tmpop = ((UNOP*)left)->op_first;
3207 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3209 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3210 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3212 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3213 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3215 pm->op_pmflags |= PMf_ONCE;
3216 tmpop = cUNOPo->op_first; /* to list (nulled) */
3217 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3218 tmpop->op_sibling = Nullop; /* don't free split */
3219 right->op_next = tmpop->op_next; /* fix starting loc */
3220 op_free(o); /* blow off assign */
3221 right->op_flags &= ~OPf_WANT;
3222 /* "I don't know and I don't care." */
3227 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3228 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3230 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3232 sv_setiv(sv, PL_modcount+1);
3240 right = newOP(OP_UNDEF, 0);
3241 if (right->op_type == OP_READLINE) {
3242 right->op_flags |= OPf_STACKED;
3243 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3246 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3247 o = newBINOP(OP_SASSIGN, flags,
3248 scalar(right), mod(scalar(left), OP_SASSIGN) );
3260 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3262 U32 seq = intro_my();
3265 NewOp(1101, cop, 1, COP);
3266 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3267 cop->op_type = OP_DBSTATE;
3268 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3271 cop->op_type = OP_NEXTSTATE;
3272 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3274 cop->op_flags = (U8)flags;
3275 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3277 cop->op_private |= NATIVE_HINTS;
3279 PL_compiling.op_private = cop->op_private;
3280 cop->op_next = (OP*)cop;
3283 cop->cop_label = label;
3284 PL_hints |= HINT_BLOCK_SCOPE;
3287 cop->cop_arybase = PL_curcop->cop_arybase;
3288 if (specialWARN(PL_curcop->cop_warnings))
3289 cop->cop_warnings = PL_curcop->cop_warnings ;
3291 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3292 if (specialCopIO(PL_curcop->cop_io))
3293 cop->cop_io = PL_curcop->cop_io;
3295 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3298 if (PL_copline == NOLINE)
3299 CopLINE_set(cop, CopLINE(PL_curcop));
3301 CopLINE_set(cop, PL_copline);
3302 PL_copline = NOLINE;
3305 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3307 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3309 CopSTASH_set(cop, PL_curstash);
3311 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3312 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3313 if (svp && *svp != &PL_sv_undef ) {
3314 (void)SvIOK_on(*svp);
3315 SvIVX(*svp) = PTR2IV(cop);
3319 o = prepend_elem(OP_LINESEQ, (OP*)cop, o);
3320 CHECKOP(cop->op_type, cop);
3326 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3328 return new_logop(type, flags, &first, &other);
3332 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3336 OP *first = *firstp;
3337 OP *other = *otherp;
3339 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3340 return newBINOP(type, flags, scalar(first), scalar(other));
3342 scalarboolean(first);
3343 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3344 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3345 if (type == OP_AND || type == OP_OR) {
3351 first = *firstp = cUNOPo->op_first;
3353 first->op_next = o->op_next;
3354 cUNOPo->op_first = Nullop;
3358 if (first->op_type == OP_CONST) {
3359 if (first->op_private & OPpCONST_STRICT)
3360 no_bareword_allowed(first);
3361 else if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3362 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3363 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3374 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS) &&
3375 type != OP_DOR) /* [#24076] Don't warn for <FH> err FOO. */
3377 OP *k1 = ((UNOP*)first)->op_first;
3378 OP *k2 = k1->op_sibling;
3380 switch (first->op_type)
3383 if (k2 && k2->op_type == OP_READLINE
3384 && (k2->op_flags & OPf_STACKED)
3385 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3387 warnop = k2->op_type;
3392 if (k1->op_type == OP_READDIR
3393 || k1->op_type == OP_GLOB
3394 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3395 || k1->op_type == OP_EACH)
3397 warnop = ((k1->op_type == OP_NULL)
3398 ? (OPCODE)k1->op_targ : k1->op_type);
3403 line_t oldline = CopLINE(PL_curcop);
3404 CopLINE_set(PL_curcop, PL_copline);
3405 Perl_warner(aTHX_ packWARN(WARN_MISC),
3406 "Value of %s%s can be \"0\"; test with defined()",
3408 ((warnop == OP_READLINE || warnop == OP_GLOB)
3409 ? " construct" : "() operator"));
3410 CopLINE_set(PL_curcop, oldline);
3417 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3418 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3420 NewOp(1101, logop, 1, LOGOP);
3422 logop->op_type = (OPCODE)type;
3423 logop->op_ppaddr = PL_ppaddr[type];
3424 logop->op_first = first;
3425 logop->op_flags = flags | OPf_KIDS;
3426 logop->op_other = LINKLIST(other);
3427 logop->op_private = (U8)(1 | (flags >> 8));
3429 /* establish postfix order */
3430 logop->op_next = LINKLIST(first);
3431 first->op_next = (OP*)logop;
3432 first->op_sibling = other;
3434 CHECKOP(type,logop);
3436 o = newUNOP(OP_NULL, 0, (OP*)logop);
3443 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3450 return newLOGOP(OP_AND, 0, first, trueop);
3452 return newLOGOP(OP_OR, 0, first, falseop);
3454 scalarboolean(first);
3455 if (first->op_type == OP_CONST) {
3456 if (first->op_private & OPpCONST_BARE &&
3457 first->op_private & OPpCONST_STRICT) {
3458 no_bareword_allowed(first);
3460 if (SvTRUE(((SVOP*)first)->op_sv)) {
3471 NewOp(1101, logop, 1, LOGOP);
3472 logop->op_type = OP_COND_EXPR;
3473 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3474 logop->op_first = first;
3475 logop->op_flags = flags | OPf_KIDS;
3476 logop->op_private = (U8)(1 | (flags >> 8));
3477 logop->op_other = LINKLIST(trueop);
3478 logop->op_next = LINKLIST(falseop);
3480 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
3483 /* establish postfix order */
3484 start = LINKLIST(first);
3485 first->op_next = (OP*)logop;
3487 first->op_sibling = trueop;
3488 trueop->op_sibling = falseop;
3489 o = newUNOP(OP_NULL, 0, (OP*)logop);
3491 trueop->op_next = falseop->op_next = o;
3498 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3506 NewOp(1101, range, 1, LOGOP);
3508 range->op_type = OP_RANGE;
3509 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3510 range->op_first = left;
3511 range->op_flags = OPf_KIDS;
3512 leftstart = LINKLIST(left);
3513 range->op_other = LINKLIST(right);
3514 range->op_private = (U8)(1 | (flags >> 8));
3516 left->op_sibling = right;
3518 range->op_next = (OP*)range;
3519 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3520 flop = newUNOP(OP_FLOP, 0, flip);
3521 o = newUNOP(OP_NULL, 0, flop);
3523 range->op_next = leftstart;
3525 left->op_next = flip;
3526 right->op_next = flop;
3528 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3529 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3530 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3531 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3533 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3534 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3537 if (!flip->op_private || !flop->op_private)
3538 linklist(o); /* blow off optimizer unless constant */
3544 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3548 int once = block && block->op_flags & OPf_SPECIAL &&
3549 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3552 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3553 return block; /* do {} while 0 does once */
3554 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3555 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3556 expr = newUNOP(OP_DEFINED, 0,
3557 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3558 } else if (expr->op_flags & OPf_KIDS) {
3559 OP *k1 = ((UNOP*)expr)->op_first;
3560 OP *k2 = (k1) ? k1->op_sibling : NULL;
3561 switch (expr->op_type) {
3563 if (k2 && k2->op_type == OP_READLINE
3564 && (k2->op_flags & OPf_STACKED)
3565 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3566 expr = newUNOP(OP_DEFINED, 0, expr);
3570 if (k1->op_type == OP_READDIR
3571 || k1->op_type == OP_GLOB
3572 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3573 || k1->op_type == OP_EACH)
3574 expr = newUNOP(OP_DEFINED, 0, expr);
3580 /* if block is null, the next append_elem() would put UNSTACK, a scalar
3581 * op, in listop. This is wrong. [perl #27024] */
3583 block = newOP(OP_NULL, 0);
3584 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3585 o = new_logop(OP_AND, 0, &expr, &listop);
3588 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3590 if (once && o != listop)
3591 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3594 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3596 o->op_flags |= flags;
3598 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3603 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3611 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3612 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3613 expr = newUNOP(OP_DEFINED, 0,
3614 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3615 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3616 OP *k1 = ((UNOP*)expr)->op_first;
3617 OP *k2 = (k1) ? k1->op_sibling : NULL;
3618 switch (expr->op_type) {
3620 if (k2 && k2->op_type == OP_READLINE
3621 && (k2->op_flags & OPf_STACKED)
3622 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3623 expr = newUNOP(OP_DEFINED, 0, expr);
3627 if (k1->op_type == OP_READDIR
3628 || k1->op_type == OP_GLOB
3629 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3630 || k1->op_type == OP_EACH)
3631 expr = newUNOP(OP_DEFINED, 0, expr);
3637 block = newOP(OP_NULL, 0);
3639 block = scope(block);
3643 next = LINKLIST(cont);
3646 OP *unstack = newOP(OP_UNSTACK, 0);
3649 cont = append_elem(OP_LINESEQ, cont, unstack);
3652 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3653 redo = LINKLIST(listop);
3656 PL_copline = (line_t)whileline;
3658 o = new_logop(OP_AND, 0, &expr, &listop);
3659 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3660 op_free(expr); /* oops, it's a while (0) */
3662 return Nullop; /* listop already freed by new_logop */
3665 ((LISTOP*)listop)->op_last->op_next =
3666 (o == listop ? redo : LINKLIST(o));
3672 NewOp(1101,loop,1,LOOP);
3673 loop->op_type = OP_ENTERLOOP;
3674 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3675 loop->op_private = 0;
3676 loop->op_next = (OP*)loop;
3679 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3681 loop->op_redoop = redo;
3682 loop->op_lastop = o;
3683 o->op_private |= loopflags;
3686 loop->op_nextop = next;
3688 loop->op_nextop = o;
3690 o->op_flags |= flags;
3691 o->op_private |= (flags >> 8);
3696 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
3700 PADOFFSET padoff = 0;
3705 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
3706 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
3707 sv->op_type = OP_RV2GV;
3708 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3710 else if (sv->op_type == OP_PADSV) { /* private variable */
3711 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
3712 padoff = sv->op_targ;
3717 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3718 padoff = sv->op_targ;
3720 iterflags |= OPf_SPECIAL;
3725 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3728 I32 offset = pad_findmy("$_");
3729 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
3730 sv = newGVOP(OP_GV, 0, PL_defgv);
3736 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3737 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3738 iterflags |= OPf_STACKED;
3740 else if (expr->op_type == OP_NULL &&
3741 (expr->op_flags & OPf_KIDS) &&
3742 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3744 /* Basically turn for($x..$y) into the same as for($x,$y), but we
3745 * set the STACKED flag to indicate that these values are to be
3746 * treated as min/max values by 'pp_iterinit'.
3748 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
3749 LOGOP* range = (LOGOP*) flip->op_first;
3750 OP* left = range->op_first;
3751 OP* right = left->op_sibling;
3754 range->op_flags &= ~OPf_KIDS;
3755 range->op_first = Nullop;
3757 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
3758 listop->op_first->op_next = range->op_next;
3759 left->op_next = range->op_other;
3760 right->op_next = (OP*)listop;
3761 listop->op_next = listop->op_first;
3764 expr = (OP*)(listop);
3766 iterflags |= OPf_STACKED;
3769 expr = mod(force_list(expr), OP_GREPSTART);
3773 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
3774 append_elem(OP_LIST, expr, scalar(sv))));
3775 assert(!loop->op_next);
3776 /* for my $x () sets OPpLVAL_INTRO;
3777 * for our $x () sets OPpOUR_INTRO */
3778 loop->op_private = (U8)iterpflags;
3779 #ifdef PL_OP_SLAB_ALLOC
3782 NewOp(1234,tmp,1,LOOP);
3783 Copy(loop,tmp,1,LOOP);
3788 Renew(loop, 1, LOOP);
3790 loop->op_targ = padoff;
3791 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
3792 PL_copline = forline;
3793 return newSTATEOP(0, label, wop);
3797 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
3802 if (type != OP_GOTO || label->op_type == OP_CONST) {
3803 /* "last()" means "last" */
3804 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
3805 o = newOP(type, OPf_SPECIAL);
3807 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
3808 ? SvPVx(((SVOP*)label)->op_sv, n_a)
3814 /* Check whether it's going to be a goto &function */
3815 if (label->op_type == OP_ENTERSUB
3816 && !(label->op_flags & OPf_STACKED))
3817 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
3818 o = newUNOP(type, OPf_STACKED, label);
3820 PL_hints |= HINT_BLOCK_SCOPE;
3825 =for apidoc cv_undef
3827 Clear out all the active components of a CV. This can happen either
3828 by an explicit C<undef &foo>, or by the reference count going to zero.
3829 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
3830 children can still follow the full lexical scope chain.
3836 Perl_cv_undef(pTHX_ CV *cv)
3839 if (CvFILE(cv) && !CvXSUB(cv)) {
3840 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
3841 Safefree(CvFILE(cv));
3846 if (!CvXSUB(cv) && CvROOT(cv)) {
3848 Perl_croak(aTHX_ "Can't undef active subroutine");
3851 PAD_SAVE_SETNULLPAD();
3853 op_free(CvROOT(cv));
3854 CvROOT(cv) = Nullop;
3857 SvPOK_off((SV*)cv); /* forget prototype */
3862 /* remove CvOUTSIDE unless this is an undef rather than a free */
3863 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
3864 if (!CvWEAKOUTSIDE(cv))
3865 SvREFCNT_dec(CvOUTSIDE(cv));
3866 CvOUTSIDE(cv) = Nullcv;
3869 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
3875 /* delete all flags except WEAKOUTSIDE */
3876 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
3880 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
3882 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
3883 SV* msg = sv_newmortal();
3887 gv_efullname3(name = sv_newmortal(), gv, Nullch);
3888 sv_setpv(msg, "Prototype mismatch:");
3890 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
3892 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (SV *)cv);
3893 sv_catpv(msg, " vs ");
3895 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
3897 sv_catpv(msg, "none");
3898 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
3902 static void const_sv_xsub(pTHX_ CV* cv);
3906 =head1 Optree Manipulation Functions
3908 =for apidoc cv_const_sv
3910 If C<cv> is a constant sub eligible for inlining. returns the constant
3911 value returned by the sub. Otherwise, returns NULL.
3913 Constant subs can be created with C<newCONSTSUB> or as described in
3914 L<perlsub/"Constant Functions">.
3919 Perl_cv_const_sv(pTHX_ CV *cv)
3921 if (!cv || !CvCONST(cv))
3923 return (SV*)CvXSUBANY(cv).any_ptr;
3926 /* op_const_sv: examine an optree to determine whether it's in-lineable.
3927 * Can be called in 3 ways:
3930 * look for a single OP_CONST with attached value: return the value
3932 * cv && CvCLONE(cv) && !CvCONST(cv)
3934 * examine the clone prototype, and if contains only a single
3935 * OP_CONST referencing a pad const, or a single PADSV referencing
3936 * an outer lexical, return a non-zero value to indicate the CV is
3937 * a candidate for "constizing" at clone time
3941 * We have just cloned an anon prototype that was marked as a const
3942 * candidiate. Try to grab the current value, and in the case of
3943 * PADSV, ignore it if it has multiple references. Return the value.
3947 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
3954 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
3955 o = cLISTOPo->op_first->op_sibling;
3957 for (; o; o = o->op_next) {
3958 OPCODE type = o->op_type;
3960 if (sv && o->op_next == o)
3962 if (o->op_next != o) {
3963 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
3965 if (type == OP_DBSTATE)
3968 if (type == OP_LEAVESUB || type == OP_RETURN)
3972 if (type == OP_CONST && cSVOPo->op_sv)
3974 else if (cv && type == OP_CONST) {
3975 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
3979 else if (cv && type == OP_PADSV) {
3980 if (CvCONST(cv)) { /* newly cloned anon */
3981 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
3982 /* the candidate should have 1 ref from this pad and 1 ref
3983 * from the parent */
3984 if (!sv || SvREFCNT(sv) != 2)
3991 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
3992 sv = &PL_sv_undef; /* an arbitrary non-null value */
4003 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4013 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4017 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4019 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4023 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4029 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4033 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4034 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4035 SV *sv = sv_newmortal();
4036 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4037 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4038 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4043 gv = gv_fetchpv(name ? name : (aname ? aname :
4044 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__")),
4045 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4055 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4056 maximum a prototype before. */
4057 if (SvTYPE(gv) > SVt_NULL) {
4058 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4059 && ckWARN_d(WARN_PROTOTYPE))
4061 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4063 cv_ckproto((CV*)gv, NULL, ps);
4066 sv_setpv((SV*)gv, ps);
4068 sv_setiv((SV*)gv, -1);
4069 SvREFCNT_dec(PL_compcv);
4070 cv = PL_compcv = NULL;
4071 PL_sub_generation++;
4075 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4077 #ifdef GV_UNIQUE_CHECK
4078 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4079 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4083 if (!block || !ps || *ps || attrs)
4086 const_sv = op_const_sv(block, Nullcv);
4089 bool exists = CvROOT(cv) || CvXSUB(cv);
4091 #ifdef GV_UNIQUE_CHECK
4092 if (exists && GvUNIQUE(gv)) {
4093 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4097 /* if the subroutine doesn't exist and wasn't pre-declared
4098 * with a prototype, assume it will be AUTOLOADed,
4099 * skipping the prototype check
4101 if (exists || SvPOK(cv))
4102 cv_ckproto(cv, gv, ps);
4103 /* already defined (or promised)? */
4104 if (exists || GvASSUMECV(gv)) {
4105 if (!block && !attrs) {
4106 if (CvFLAGS(PL_compcv)) {
4107 /* might have had built-in attrs applied */
4108 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4110 /* just a "sub foo;" when &foo is already defined */
4111 SAVEFREESV(PL_compcv);
4114 /* ahem, death to those who redefine active sort subs */
4115 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4116 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4118 if (ckWARN(WARN_REDEFINE)
4120 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4122 line_t oldline = CopLINE(PL_curcop);
4123 if (PL_copline != NOLINE)
4124 CopLINE_set(PL_curcop, PL_copline);
4125 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4126 CvCONST(cv) ? "Constant subroutine %s redefined"
4127 : "Subroutine %s redefined", name);
4128 CopLINE_set(PL_curcop, oldline);
4136 SvREFCNT_inc(const_sv);
4138 assert(!CvROOT(cv) && !CvCONST(cv));
4139 sv_setpv((SV*)cv, ""); /* prototype is "" */
4140 CvXSUBANY(cv).any_ptr = const_sv;
4141 CvXSUB(cv) = const_sv_xsub;
4146 cv = newCONSTSUB(NULL, name, const_sv);
4149 SvREFCNT_dec(PL_compcv);
4151 PL_sub_generation++;
4158 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4159 * before we clobber PL_compcv.
4163 /* Might have had built-in attributes applied -- propagate them. */
4164 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4165 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4166 stash = GvSTASH(CvGV(cv));
4167 else if (CvSTASH(cv))
4168 stash = CvSTASH(cv);
4170 stash = PL_curstash;
4173 /* possibly about to re-define existing subr -- ignore old cv */
4174 rcv = (SV*)PL_compcv;
4175 if (name && GvSTASH(gv))
4176 stash = GvSTASH(gv);
4178 stash = PL_curstash;
4180 apply_attrs(stash, rcv, attrs, FALSE);
4182 if (cv) { /* must reuse cv if autoloaded */
4184 /* got here with just attrs -- work done, so bug out */
4185 SAVEFREESV(PL_compcv);
4188 /* transfer PL_compcv to cv */
4190 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4191 if (!CvWEAKOUTSIDE(cv))
4192 SvREFCNT_dec(CvOUTSIDE(cv));
4193 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4194 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4195 CvOUTSIDE(PL_compcv) = 0;
4196 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4197 CvPADLIST(PL_compcv) = 0;
4198 /* inner references to PL_compcv must be fixed up ... */
4199 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4200 /* ... before we throw it away */
4201 SvREFCNT_dec(PL_compcv);
4203 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4204 ++PL_sub_generation;
4211 PL_sub_generation++;
4215 CvFILE_set_from_cop(cv, PL_curcop);
4216 CvSTASH(cv) = PL_curstash;
4219 sv_setpv((SV*)cv, ps);
4221 if (PL_error_count) {
4225 char *s = strrchr(name, ':');
4227 if (strEQ(s, "BEGIN")) {
4229 "BEGIN not safe after errors--compilation aborted";
4230 if (PL_in_eval & EVAL_KEEPERR)
4231 Perl_croak(aTHX_ not_safe);
4233 /* force display of errors found but not reported */
4234 sv_catpv(ERRSV, not_safe);
4235 Perl_croak(aTHX_ "%"SVf, ERRSV);
4244 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4245 mod(scalarseq(block), OP_LEAVESUBLV));
4248 /* This makes sub {}; work as expected. */
4249 if (block->op_type == OP_STUB) {
4251 block = newSTATEOP(0, Nullch, 0);
4253 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4255 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4256 OpREFCNT_set(CvROOT(cv), 1);
4257 CvSTART(cv) = LINKLIST(CvROOT(cv));
4258 CvROOT(cv)->op_next = 0;
4259 CALL_PEEP(CvSTART(cv));
4261 /* now that optimizer has done its work, adjust pad values */
4263 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4266 assert(!CvCONST(cv));
4267 if (ps && !*ps && op_const_sv(block, cv))
4271 if (name || aname) {
4273 char *tname = (name ? name : aname);
4275 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4276 SV *sv = NEWSV(0,0);
4277 SV *tmpstr = sv_newmortal();
4278 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4282 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4284 (long)PL_subline, (long)CopLINE(PL_curcop));
4285 gv_efullname3(tmpstr, gv, Nullch);
4286 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4287 hv = GvHVn(db_postponed);
4288 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4289 && (pcv = GvCV(db_postponed)))
4295 call_sv((SV*)pcv, G_DISCARD);
4299 if ((s = strrchr(tname,':')))
4304 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4307 if (strEQ(s, "BEGIN") && !PL_error_count) {
4308 I32 oldscope = PL_scopestack_ix;
4310 SAVECOPFILE(&PL_compiling);
4311 SAVECOPLINE(&PL_compiling);
4314 PL_beginav = newAV();
4315 DEBUG_x( dump_sub(gv) );
4316 av_push(PL_beginav, (SV*)cv);
4317 GvCV(gv) = 0; /* cv has been hijacked */
4318 call_list(oldscope, PL_beginav);
4320 PL_curcop = &PL_compiling;
4321 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4324 else if (strEQ(s, "END") && !PL_error_count) {
4327 DEBUG_x( dump_sub(gv) );
4328 av_unshift(PL_endav, 1);
4329 av_store(PL_endav, 0, (SV*)cv);
4330 GvCV(gv) = 0; /* cv has been hijacked */
4332 else if (strEQ(s, "CHECK") && !PL_error_count) {
4334 PL_checkav = newAV();
4335 DEBUG_x( dump_sub(gv) );
4336 if (PL_main_start && ckWARN(WARN_VOID))
4337 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4338 av_unshift(PL_checkav, 1);
4339 av_store(PL_checkav, 0, (SV*)cv);
4340 GvCV(gv) = 0; /* cv has been hijacked */
4342 else if (strEQ(s, "INIT") && !PL_error_count) {
4344 PL_initav = newAV();
4345 DEBUG_x( dump_sub(gv) );
4346 if (PL_main_start && ckWARN(WARN_VOID))
4347 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4348 av_push(PL_initav, (SV*)cv);
4349 GvCV(gv) = 0; /* cv has been hijacked */
4354 PL_copline = NOLINE;
4359 /* XXX unsafe for threads if eval_owner isn't held */
4361 =for apidoc newCONSTSUB
4363 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4364 eligible for inlining at compile-time.
4370 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4376 SAVECOPLINE(PL_curcop);
4377 CopLINE_set(PL_curcop, PL_copline);
4380 PL_hints &= ~HINT_BLOCK_SCOPE;
4383 SAVESPTR(PL_curstash);
4384 SAVECOPSTASH(PL_curcop);
4385 PL_curstash = stash;
4386 CopSTASH_set(PL_curcop,stash);
4389 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4390 CvXSUBANY(cv).any_ptr = sv;
4392 sv_setpv((SV*)cv, ""); /* prototype is "" */
4395 CopSTASH_free(PL_curcop);
4403 =for apidoc U||newXS
4405 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4411 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
4413 GV *gv = gv_fetchpv(name ? name :
4414 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4415 GV_ADDMULTI, SVt_PVCV);
4419 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4421 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4423 /* just a cached method */
4427 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4428 /* already defined (or promised) */
4429 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4430 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4431 line_t oldline = CopLINE(PL_curcop);
4432 if (PL_copline != NOLINE)
4433 CopLINE_set(PL_curcop, PL_copline);
4434 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4435 CvCONST(cv) ? "Constant subroutine %s redefined"
4436 : "Subroutine %s redefined"
4438 CopLINE_set(PL_curcop, oldline);
4445 if (cv) /* must reuse cv if autoloaded */
4448 cv = (CV*)NEWSV(1105,0);
4449 sv_upgrade((SV *)cv, SVt_PVCV);
4453 PL_sub_generation++;
4457 (void)gv_fetchfile(filename);
4458 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
4459 an external constant string */
4460 CvXSUB(cv) = subaddr;
4463 char *s = strrchr(name,':');
4469 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4472 if (strEQ(s, "BEGIN")) {
4474 PL_beginav = newAV();
4475 av_push(PL_beginav, (SV*)cv);
4476 GvCV(gv) = 0; /* cv has been hijacked */
4478 else if (strEQ(s, "END")) {
4481 av_unshift(PL_endav, 1);
4482 av_store(PL_endav, 0, (SV*)cv);
4483 GvCV(gv) = 0; /* cv has been hijacked */
4485 else if (strEQ(s, "CHECK")) {
4487 PL_checkav = newAV();
4488 if (PL_main_start && ckWARN(WARN_VOID))
4489 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4490 av_unshift(PL_checkav, 1);
4491 av_store(PL_checkav, 0, (SV*)cv);
4492 GvCV(gv) = 0; /* cv has been hijacked */
4494 else if (strEQ(s, "INIT")) {
4496 PL_initav = newAV();
4497 if (PL_main_start && ckWARN(WARN_VOID))
4498 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4499 av_push(PL_initav, (SV*)cv);
4500 GvCV(gv) = 0; /* cv has been hijacked */
4511 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4519 name = SvPVx(cSVOPo->op_sv, n_a);
4522 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
4523 #ifdef GV_UNIQUE_CHECK
4525 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4529 if ((cv = GvFORM(gv))) {
4530 if (ckWARN(WARN_REDEFINE)) {
4531 line_t oldline = CopLINE(PL_curcop);
4532 if (PL_copline != NOLINE)
4533 CopLINE_set(PL_curcop, PL_copline);
4534 Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Format %s redefined",name);
4535 CopLINE_set(PL_curcop, oldline);
4542 CvFILE_set_from_cop(cv, PL_curcop);
4545 pad_tidy(padtidy_FORMAT);
4546 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4547 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4548 OpREFCNT_set(CvROOT(cv), 1);
4549 CvSTART(cv) = LINKLIST(CvROOT(cv));
4550 CvROOT(cv)->op_next = 0;
4551 CALL_PEEP(CvSTART(cv));
4553 PL_copline = NOLINE;
4558 Perl_newANONLIST(pTHX_ OP *o)
4560 return newUNOP(OP_REFGEN, 0,
4561 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4565 Perl_newANONHASH(pTHX_ OP *o)
4567 return newUNOP(OP_REFGEN, 0,
4568 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4572 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4574 return newANONATTRSUB(floor, proto, Nullop, block);
4578 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4580 return newUNOP(OP_REFGEN, 0,
4581 newSVOP(OP_ANONCODE, 0,
4582 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
4586 Perl_oopsAV(pTHX_ OP *o)
4588 switch (o->op_type) {
4590 o->op_type = OP_PADAV;
4591 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4592 return ref(o, OP_RV2AV);
4595 o->op_type = OP_RV2AV;
4596 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4601 if (ckWARN_d(WARN_INTERNAL))
4602 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
4609 Perl_oopsHV(pTHX_ OP *o)
4611 switch (o->op_type) {
4614 o->op_type = OP_PADHV;
4615 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4616 return ref(o, OP_RV2HV);
4620 o->op_type = OP_RV2HV;
4621 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
4626 if (ckWARN_d(WARN_INTERNAL))
4627 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
4634 Perl_newAVREF(pTHX_ OP *o)
4636 if (o->op_type == OP_PADANY) {
4637 o->op_type = OP_PADAV;
4638 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4641 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
4642 && ckWARN(WARN_DEPRECATED)) {
4643 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4644 "Using an array as a reference is deprecated");
4646 return newUNOP(OP_RV2AV, 0, scalar(o));
4650 Perl_newGVREF(pTHX_ I32 type, OP *o)
4652 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
4653 return newUNOP(OP_NULL, 0, o);
4654 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
4658 Perl_newHVREF(pTHX_ OP *o)
4660 if (o->op_type == OP_PADANY) {
4661 o->op_type = OP_PADHV;
4662 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4665 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
4666 && ckWARN(WARN_DEPRECATED)) {
4667 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4668 "Using a hash as a reference is deprecated");
4670 return newUNOP(OP_RV2HV, 0, scalar(o));
4674 Perl_oopsCV(pTHX_ OP *o)
4676 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
4682 Perl_newCVREF(pTHX_ I32 flags, OP *o)
4684 return newUNOP(OP_RV2CV, flags, scalar(o));
4688 Perl_newSVREF(pTHX_ OP *o)
4690 if (o->op_type == OP_PADANY) {
4691 o->op_type = OP_PADSV;
4692 o->op_ppaddr = PL_ppaddr[OP_PADSV];
4695 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4696 o->op_flags |= OPpDONE_SVREF;
4699 return newUNOP(OP_RV2SV, 0, scalar(o));
4702 /* Check routines. */
4705 Perl_ck_anoncode(pTHX_ OP *o)
4707 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
4708 cSVOPo->op_sv = Nullsv;
4713 Perl_ck_bitop(pTHX_ OP *o)
4715 #define OP_IS_NUMCOMPARE(op) \
4716 ((op) == OP_LT || (op) == OP_I_LT || \
4717 (op) == OP_GT || (op) == OP_I_GT || \
4718 (op) == OP_LE || (op) == OP_I_LE || \
4719 (op) == OP_GE || (op) == OP_I_GE || \
4720 (op) == OP_EQ || (op) == OP_I_EQ || \
4721 (op) == OP_NE || (op) == OP_I_NE || \
4722 (op) == OP_NCMP || (op) == OP_I_NCMP)
4723 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4724 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
4725 && (o->op_type == OP_BIT_OR
4726 || o->op_type == OP_BIT_AND
4727 || o->op_type == OP_BIT_XOR))
4729 OP * left = cBINOPo->op_first;
4730 OP * right = left->op_sibling;
4731 if ((OP_IS_NUMCOMPARE(left->op_type) &&
4732 (left->op_flags & OPf_PARENS) == 0) ||
4733 (OP_IS_NUMCOMPARE(right->op_type) &&
4734 (right->op_flags & OPf_PARENS) == 0))
4735 if (ckWARN(WARN_PRECEDENCE))
4736 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4737 "Possible precedence problem on bitwise %c operator",
4738 o->op_type == OP_BIT_OR ? '|'
4739 : o->op_type == OP_BIT_AND ? '&' : '^'
4746 Perl_ck_concat(pTHX_ OP *o)
4748 OP *kid = cUNOPo->op_first;
4749 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
4750 !(kUNOP->op_first->op_flags & OPf_MOD))
4751 o->op_flags |= OPf_STACKED;
4756 Perl_ck_spair(pTHX_ OP *o)
4758 if (o->op_flags & OPf_KIDS) {
4761 OPCODE type = o->op_type;
4762 o = modkids(ck_fun(o), type);
4763 kid = cUNOPo->op_first;
4764 newop = kUNOP->op_first->op_sibling;
4766 (newop->op_sibling ||
4767 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
4768 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
4769 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
4773 op_free(kUNOP->op_first);
4774 kUNOP->op_first = newop;
4776 o->op_ppaddr = PL_ppaddr[++o->op_type];
4781 Perl_ck_delete(pTHX_ OP *o)
4785 if (o->op_flags & OPf_KIDS) {
4786 OP *kid = cUNOPo->op_first;
4787 switch (kid->op_type) {
4789 o->op_flags |= OPf_SPECIAL;
4792 o->op_private |= OPpSLICE;
4795 o->op_flags |= OPf_SPECIAL;
4800 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
4809 Perl_ck_die(pTHX_ OP *o)
4812 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4818 Perl_ck_eof(pTHX_ OP *o)
4820 I32 type = o->op_type;
4822 if (o->op_flags & OPf_KIDS) {
4823 if (cLISTOPo->op_first->op_type == OP_STUB) {
4825 o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
4833 Perl_ck_eval(pTHX_ OP *o)
4835 PL_hints |= HINT_BLOCK_SCOPE;
4836 if (o->op_flags & OPf_KIDS) {
4837 SVOP *kid = (SVOP*)cUNOPo->op_first;
4840 o->op_flags &= ~OPf_KIDS;
4843 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
4846 cUNOPo->op_first = 0;
4849 NewOp(1101, enter, 1, LOGOP);
4850 enter->op_type = OP_ENTERTRY;
4851 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
4852 enter->op_private = 0;
4854 /* establish postfix order */
4855 enter->op_next = (OP*)enter;
4857 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
4858 o->op_type = OP_LEAVETRY;
4859 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
4860 enter->op_other = o;
4870 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
4872 o->op_targ = (PADOFFSET)PL_hints;
4877 Perl_ck_exit(pTHX_ OP *o)
4880 HV *table = GvHV(PL_hintgv);
4882 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
4883 if (svp && *svp && SvTRUE(*svp))
4884 o->op_private |= OPpEXIT_VMSISH;
4886 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4892 Perl_ck_exec(pTHX_ OP *o)
4895 if (o->op_flags & OPf_STACKED) {
4897 kid = cUNOPo->op_first->op_sibling;
4898 if (kid->op_type == OP_RV2GV)
4907 Perl_ck_exists(pTHX_ OP *o)
4910 if (o->op_flags & OPf_KIDS) {
4911 OP *kid = cUNOPo->op_first;
4912 if (kid->op_type == OP_ENTERSUB) {
4913 (void) ref(kid, o->op_type);
4914 if (kid->op_type != OP_RV2CV && !PL_error_count)
4915 Perl_croak(aTHX_ "%s argument is not a subroutine name",
4917 o->op_private |= OPpEXISTS_SUB;
4919 else if (kid->op_type == OP_AELEM)
4920 o->op_flags |= OPf_SPECIAL;
4921 else if (kid->op_type != OP_HELEM)
4922 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
4931 Perl_ck_gvconst(pTHX_ register OP *o)
4933 o = fold_constants(o);
4934 if (o->op_type == OP_CONST)
4941 Perl_ck_rvconst(pTHX_ register OP *o)
4943 SVOP *kid = (SVOP*)cUNOPo->op_first;
4945 o->op_private |= (PL_hints & HINT_STRICT_REFS);
4946 if (kid->op_type == OP_CONST) {
4950 SV *kidsv = kid->op_sv;
4953 /* Is it a constant from cv_const_sv()? */
4954 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
4955 SV *rsv = SvRV(kidsv);
4956 int svtype = SvTYPE(rsv);
4957 char *badtype = Nullch;
4959 switch (o->op_type) {
4961 if (svtype > SVt_PVMG)
4962 badtype = "a SCALAR";
4965 if (svtype != SVt_PVAV)
4966 badtype = "an ARRAY";
4969 if (svtype != SVt_PVHV)
4973 if (svtype != SVt_PVCV)
4978 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
4981 name = SvPV(kidsv, n_a);
4982 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
4983 char *badthing = Nullch;
4984 switch (o->op_type) {
4986 badthing = "a SCALAR";
4989 badthing = "an ARRAY";
4992 badthing = "a HASH";
4997 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5001 * This is a little tricky. We only want to add the symbol if we
5002 * didn't add it in the lexer. Otherwise we get duplicate strict
5003 * warnings. But if we didn't add it in the lexer, we must at
5004 * least pretend like we wanted to add it even if it existed before,
5005 * or we get possible typo warnings. OPpCONST_ENTERED says
5006 * whether the lexer already added THIS instance of this symbol.
5008 iscv = (o->op_type == OP_RV2CV) * 2;
5010 gv = gv_fetchpv(name,
5011 iscv | !(kid->op_private & OPpCONST_ENTERED),
5014 : o->op_type == OP_RV2SV
5016 : o->op_type == OP_RV2AV
5018 : o->op_type == OP_RV2HV
5021 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5023 kid->op_type = OP_GV;
5024 SvREFCNT_dec(kid->op_sv);
5026 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5027 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5028 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
5030 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
5032 kid->op_sv = SvREFCNT_inc(gv);
5034 kid->op_private = 0;
5035 kid->op_ppaddr = PL_ppaddr[OP_GV];
5042 Perl_ck_ftst(pTHX_ OP *o)
5044 I32 type = o->op_type;
5046 if (o->op_flags & OPf_REF) {
5049 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5050 SVOP *kid = (SVOP*)cUNOPo->op_first;
5052 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5054 OP *newop = newGVOP(type, OPf_REF,
5055 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5060 if ((PL_hints & HINT_FILETEST_ACCESS) &&
5061 OP_IS_FILETEST_ACCESS(o))
5062 o->op_private |= OPpFT_ACCESS;
5064 if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
5065 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
5066 o->op_private |= OPpFT_STACKED;
5070 if (type == OP_FTTTY)
5071 o = newGVOP(type, OPf_REF, PL_stdingv);
5073 o = newUNOP(type, 0, newDEFSVOP());
5079 Perl_ck_fun(pTHX_ OP *o)
5085 int type = o->op_type;
5086 register I32 oa = PL_opargs[type] >> OASHIFT;
5088 if (o->op_flags & OPf_STACKED) {
5089 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5092 return no_fh_allowed(o);
5095 if (o->op_flags & OPf_KIDS) {
5097 tokid = &cLISTOPo->op_first;
5098 kid = cLISTOPo->op_first;
5099 if (kid->op_type == OP_PUSHMARK ||
5100 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5102 tokid = &kid->op_sibling;
5103 kid = kid->op_sibling;
5105 if (!kid && PL_opargs[type] & OA_DEFGV)
5106 *tokid = kid = newDEFSVOP();
5110 sibl = kid->op_sibling;
5113 /* list seen where single (scalar) arg expected? */
5114 if (numargs == 1 && !(oa >> 4)
5115 && kid->op_type == OP_LIST && type != OP_SCALAR)
5117 return too_many_arguments(o,PL_op_desc[type]);
5130 if ((type == OP_PUSH || type == OP_UNSHIFT)
5131 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5132 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5133 "Useless use of %s with no values",
5136 if (kid->op_type == OP_CONST &&
5137 (kid->op_private & OPpCONST_BARE))
5139 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5140 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5141 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5142 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5143 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5144 "Array @%s missing the @ in argument %"IVdf" of %s()",
5145 name, (IV)numargs, PL_op_desc[type]);
5148 kid->op_sibling = sibl;
5151 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5152 bad_type(numargs, "array", PL_op_desc[type], kid);
5156 if (kid->op_type == OP_CONST &&
5157 (kid->op_private & OPpCONST_BARE))
5159 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5160 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5161 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5162 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5163 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5164 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5165 name, (IV)numargs, PL_op_desc[type]);
5168 kid->op_sibling = sibl;
5171 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5172 bad_type(numargs, "hash", PL_op_desc[type], kid);
5177 OP *newop = newUNOP(OP_NULL, 0, kid);
5178 kid->op_sibling = 0;
5180 newop->op_next = newop;
5182 kid->op_sibling = sibl;
5187 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5188 if (kid->op_type == OP_CONST &&
5189 (kid->op_private & OPpCONST_BARE))
5191 OP *newop = newGVOP(OP_GV, 0,
5192 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5194 if (!(o->op_private & 1) && /* if not unop */
5195 kid == cLISTOPo->op_last)
5196 cLISTOPo->op_last = newop;
5200 else if (kid->op_type == OP_READLINE) {
5201 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5202 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5205 I32 flags = OPf_SPECIAL;
5209 /* is this op a FH constructor? */
5210 if (is_handle_constructor(o,numargs)) {
5211 char *name = Nullch;
5215 /* Set a flag to tell rv2gv to vivify
5216 * need to "prove" flag does not mean something
5217 * else already - NI-S 1999/05/07
5220 if (kid->op_type == OP_PADSV) {
5221 name = PAD_COMPNAME_PV(kid->op_targ);
5222 /* SvCUR of a pad namesv can't be trusted
5223 * (see PL_generation), so calc its length
5229 else if (kid->op_type == OP_RV2SV
5230 && kUNOP->op_first->op_type == OP_GV)
5232 GV *gv = cGVOPx_gv(kUNOP->op_first);
5234 len = GvNAMELEN(gv);
5236 else if (kid->op_type == OP_AELEM
5237 || kid->op_type == OP_HELEM)
5242 if ((op = ((BINOP*)kid)->op_first)) {
5243 SV *tmpstr = Nullsv;
5245 kid->op_type == OP_AELEM ?
5247 if (((op->op_type == OP_RV2AV) ||
5248 (op->op_type == OP_RV2HV)) &&
5249 (op = ((UNOP*)op)->op_first) &&
5250 (op->op_type == OP_GV)) {
5251 /* packagevar $a[] or $h{} */
5252 GV *gv = cGVOPx_gv(op);
5260 else if (op->op_type == OP_PADAV
5261 || op->op_type == OP_PADHV) {
5262 /* lexicalvar $a[] or $h{} */
5264 PAD_COMPNAME_PV(op->op_targ);
5274 name = SvPV(tmpstr, len);
5279 name = "__ANONIO__";
5286 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5287 namesv = PAD_SVl(targ);
5288 (void)SvUPGRADE(namesv, SVt_PV);
5290 sv_setpvn(namesv, "$", 1);
5291 sv_catpvn(namesv, name, len);
5294 kid->op_sibling = 0;
5295 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5296 kid->op_targ = targ;
5297 kid->op_private |= priv;
5299 kid->op_sibling = sibl;
5305 mod(scalar(kid), type);
5309 tokid = &kid->op_sibling;
5310 kid = kid->op_sibling;
5312 o->op_private |= numargs;
5314 return too_many_arguments(o,OP_DESC(o));
5317 else if (PL_opargs[type] & OA_DEFGV) {
5319 return newUNOP(type, 0, newDEFSVOP());
5323 while (oa & OA_OPTIONAL)
5325 if (oa && oa != OA_LIST)
5326 return too_few_arguments(o,OP_DESC(o));
5332 Perl_ck_glob(pTHX_ OP *o)
5337 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5338 append_elem(OP_GLOB, o, newDEFSVOP());
5340 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5341 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5343 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5346 #if !defined(PERL_EXTERNAL_GLOB)
5347 /* XXX this can be tightened up and made more failsafe. */
5348 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5351 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5352 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5353 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5354 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5355 GvCV(gv) = GvCV(glob_gv);
5356 SvREFCNT_inc((SV*)GvCV(gv));
5357 GvIMPORTED_CV_on(gv);
5360 #endif /* PERL_EXTERNAL_GLOB */
5362 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5363 append_elem(OP_GLOB, o,
5364 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5365 o->op_type = OP_LIST;
5366 o->op_ppaddr = PL_ppaddr[OP_LIST];
5367 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5368 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5369 cLISTOPo->op_first->op_targ = 0;
5370 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5371 append_elem(OP_LIST, o,
5372 scalar(newUNOP(OP_RV2CV, 0,
5373 newGVOP(OP_GV, 0, gv)))));
5374 o = newUNOP(OP_NULL, 0, ck_subr(o));
5375 o->op_targ = OP_GLOB; /* hint at what it used to be */
5378 gv = newGVgen("main");
5380 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5386 Perl_ck_grep(pTHX_ OP *o)
5390 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5393 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5394 NewOp(1101, gwop, 1, LOGOP);
5396 if (o->op_flags & OPf_STACKED) {
5399 kid = cLISTOPo->op_first->op_sibling;
5400 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5403 kid->op_next = (OP*)gwop;
5404 o->op_flags &= ~OPf_STACKED;
5406 kid = cLISTOPo->op_first->op_sibling;
5407 if (type == OP_MAPWHILE)
5414 kid = cLISTOPo->op_first->op_sibling;
5415 if (kid->op_type != OP_NULL)
5416 Perl_croak(aTHX_ "panic: ck_grep");
5417 kid = kUNOP->op_first;
5419 gwop->op_type = type;
5420 gwop->op_ppaddr = PL_ppaddr[type];
5421 gwop->op_first = listkids(o);
5422 gwop->op_flags |= OPf_KIDS;
5423 gwop->op_other = LINKLIST(kid);
5424 kid->op_next = (OP*)gwop;
5425 offset = pad_findmy("$_");
5426 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
5427 o->op_private = gwop->op_private = 0;
5428 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5431 o->op_private = gwop->op_private = OPpGREP_LEX;
5432 gwop->op_targ = o->op_targ = offset;
5435 kid = cLISTOPo->op_first->op_sibling;
5436 if (!kid || !kid->op_sibling)
5437 return too_few_arguments(o,OP_DESC(o));
5438 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5439 mod(kid, OP_GREPSTART);
5445 Perl_ck_index(pTHX_ OP *o)
5447 if (o->op_flags & OPf_KIDS) {
5448 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5450 kid = kid->op_sibling; /* get past "big" */
5451 if (kid && kid->op_type == OP_CONST)
5452 fbm_compile(((SVOP*)kid)->op_sv, 0);
5458 Perl_ck_lengthconst(pTHX_ OP *o)
5460 /* XXX length optimization goes here */
5465 Perl_ck_lfun(pTHX_ OP *o)
5467 OPCODE type = o->op_type;
5468 return modkids(ck_fun(o), type);
5472 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5474 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5475 switch (cUNOPo->op_first->op_type) {
5477 /* This is needed for
5478 if (defined %stash::)
5479 to work. Do not break Tk.
5481 break; /* Globals via GV can be undef */
5483 case OP_AASSIGN: /* Is this a good idea? */
5484 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5485 "defined(@array) is deprecated");
5486 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5487 "\t(Maybe you should just omit the defined()?)\n");
5490 /* This is needed for
5491 if (defined %stash::)
5492 to work. Do not break Tk.
5494 break; /* Globals via GV can be undef */
5496 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5497 "defined(%%hash) is deprecated");
5498 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5499 "\t(Maybe you should just omit the defined()?)\n");
5510 Perl_ck_rfun(pTHX_ OP *o)
5512 OPCODE type = o->op_type;
5513 return refkids(ck_fun(o), type);
5517 Perl_ck_listiob(pTHX_ OP *o)
5521 kid = cLISTOPo->op_first;
5524 kid = cLISTOPo->op_first;
5526 if (kid->op_type == OP_PUSHMARK)
5527 kid = kid->op_sibling;
5528 if (kid && o->op_flags & OPf_STACKED)
5529 kid = kid->op_sibling;
5530 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5531 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5532 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5533 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5534 cLISTOPo->op_first->op_sibling = kid;
5535 cLISTOPo->op_last = kid;
5536 kid = kid->op_sibling;
5541 append_elem(o->op_type, o, newDEFSVOP());
5547 Perl_ck_sassign(pTHX_ OP *o)
5549 OP *kid = cLISTOPo->op_first;
5550 /* has a disposable target? */
5551 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5552 && !(kid->op_flags & OPf_STACKED)
5553 /* Cannot steal the second time! */
5554 && !(kid->op_private & OPpTARGET_MY))
5556 OP *kkid = kid->op_sibling;
5558 /* Can just relocate the target. */
5559 if (kkid && kkid->op_type == OP_PADSV
5560 && !(kkid->op_private & OPpLVAL_INTRO))
5562 kid->op_targ = kkid->op_targ;
5564 /* Now we do not need PADSV and SASSIGN. */
5565 kid->op_sibling = o->op_sibling; /* NULL */
5566 cLISTOPo->op_first = NULL;
5569 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
5577 Perl_ck_match(pTHX_ OP *o)
5579 if (o->op_type != OP_QR) {
5580 I32 offset = pad_findmy("$_");
5581 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS(offset) & SVpad_OUR)) {
5582 o->op_targ = offset;
5583 o->op_private |= OPpTARGET_MY;
5586 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
5587 o->op_private |= OPpRUNTIME;
5592 Perl_ck_method(pTHX_ OP *o)
5594 OP *kid = cUNOPo->op_first;
5595 if (kid->op_type == OP_CONST) {
5596 SV* sv = kSVOP->op_sv;
5597 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
5599 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5600 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
5603 kSVOP->op_sv = Nullsv;
5605 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5614 Perl_ck_null(pTHX_ OP *o)
5620 Perl_ck_open(pTHX_ OP *o)
5622 HV *table = GvHV(PL_hintgv);
5626 svp = hv_fetch(table, "open_IN", 7, FALSE);
5628 mode = mode_from_discipline(*svp);
5629 if (mode & O_BINARY)
5630 o->op_private |= OPpOPEN_IN_RAW;
5631 else if (mode & O_TEXT)
5632 o->op_private |= OPpOPEN_IN_CRLF;
5635 svp = hv_fetch(table, "open_OUT", 8, FALSE);
5637 mode = mode_from_discipline(*svp);
5638 if (mode & O_BINARY)
5639 o->op_private |= OPpOPEN_OUT_RAW;
5640 else if (mode & O_TEXT)
5641 o->op_private |= OPpOPEN_OUT_CRLF;
5644 if (o->op_type == OP_BACKTICK)
5647 /* In case of three-arg dup open remove strictness
5648 * from the last arg if it is a bareword. */
5649 OP *first = cLISTOPx(o)->op_first; /* The pushmark. */
5650 OP *last = cLISTOPx(o)->op_last; /* The bareword. */
5654 if ((last->op_type == OP_CONST) && /* The bareword. */
5655 (last->op_private & OPpCONST_BARE) &&
5656 (last->op_private & OPpCONST_STRICT) &&
5657 (oa = first->op_sibling) && /* The fh. */
5658 (oa = oa->op_sibling) && /* The mode. */
5659 SvPOK(((SVOP*)oa)->op_sv) &&
5660 (mode = SvPVX(((SVOP*)oa)->op_sv)) &&
5661 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
5662 (last == oa->op_sibling)) /* The bareword. */
5663 last->op_private &= ~OPpCONST_STRICT;
5669 Perl_ck_repeat(pTHX_ OP *o)
5671 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5672 o->op_private |= OPpREPEAT_DOLIST;
5673 cBINOPo->op_first = force_list(cBINOPo->op_first);
5681 Perl_ck_require(pTHX_ OP *o)
5685 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
5686 SVOP *kid = (SVOP*)cUNOPo->op_first;
5688 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5690 for (s = SvPVX(kid->op_sv); *s; s++) {
5691 if (*s == ':' && s[1] == ':') {
5693 Move(s+2, s+1, strlen(s+2)+1, char);
5694 --SvCUR(kid->op_sv);
5697 if (SvREADONLY(kid->op_sv)) {
5698 SvREADONLY_off(kid->op_sv);
5699 sv_catpvn(kid->op_sv, ".pm", 3);
5700 SvREADONLY_on(kid->op_sv);
5703 sv_catpvn(kid->op_sv, ".pm", 3);
5707 /* handle override, if any */
5708 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
5709 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
5710 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
5712 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5713 OP *kid = cUNOPo->op_first;
5714 cUNOPo->op_first = 0;
5716 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5717 append_elem(OP_LIST, kid,
5718 scalar(newUNOP(OP_RV2CV, 0,
5727 Perl_ck_return(pTHX_ OP *o)
5730 if (CvLVALUE(PL_compcv)) {
5731 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5732 mod(kid, OP_LEAVESUBLV);
5739 Perl_ck_retarget(pTHX_ OP *o)
5741 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5748 Perl_ck_select(pTHX_ OP *o)
5751 if (o->op_flags & OPf_KIDS) {
5752 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5753 if (kid && kid->op_sibling) {
5754 o->op_type = OP_SSELECT;
5755 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
5757 return fold_constants(o);
5761 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5762 if (kid && kid->op_type == OP_RV2GV)
5763 kid->op_private &= ~HINT_STRICT_REFS;
5768 Perl_ck_shift(pTHX_ OP *o)
5770 I32 type = o->op_type;
5772 if (!(o->op_flags & OPf_KIDS)) {
5776 argop = newUNOP(OP_RV2AV, 0,
5777 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
5778 return newUNOP(type, 0, scalar(argop));
5780 return scalar(modkids(ck_fun(o), type));
5784 Perl_ck_sort(pTHX_ OP *o)
5788 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
5790 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5791 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
5793 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
5795 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
5797 if (kid->op_type == OP_SCOPE) {
5801 else if (kid->op_type == OP_LEAVE) {
5802 if (o->op_type == OP_SORT) {
5803 op_null(kid); /* wipe out leave */
5806 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
5807 if (k->op_next == kid)
5809 /* don't descend into loops */
5810 else if (k->op_type == OP_ENTERLOOP
5811 || k->op_type == OP_ENTERITER)
5813 k = cLOOPx(k)->op_lastop;
5818 kid->op_next = 0; /* just disconnect the leave */
5819 k = kLISTOP->op_first;
5824 if (o->op_type == OP_SORT) {
5825 /* provide scalar context for comparison function/block */
5831 o->op_flags |= OPf_SPECIAL;
5833 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
5836 firstkid = firstkid->op_sibling;
5839 /* provide list context for arguments */
5840 if (o->op_type == OP_SORT)
5847 S_simplify_sort(pTHX_ OP *o)
5849 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5853 if (!(o->op_flags & OPf_STACKED))
5855 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
5856 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
5857 kid = kUNOP->op_first; /* get past null */
5858 if (kid->op_type != OP_SCOPE)
5860 kid = kLISTOP->op_last; /* get past scope */
5861 switch(kid->op_type) {
5869 k = kid; /* remember this node*/
5870 if (kBINOP->op_first->op_type != OP_RV2SV)
5872 kid = kBINOP->op_first; /* get past cmp */
5873 if (kUNOP->op_first->op_type != OP_GV)
5875 kid = kUNOP->op_first; /* get past rv2sv */
5877 if (GvSTASH(gv) != PL_curstash)
5879 if (strEQ(GvNAME(gv), "a"))
5881 else if (strEQ(GvNAME(gv), "b"))
5885 kid = k; /* back to cmp */
5886 if (kBINOP->op_last->op_type != OP_RV2SV)
5888 kid = kBINOP->op_last; /* down to 2nd arg */
5889 if (kUNOP->op_first->op_type != OP_GV)
5891 kid = kUNOP->op_first; /* get past rv2sv */
5893 if (GvSTASH(gv) != PL_curstash
5895 ? strNE(GvNAME(gv), "a")
5896 : strNE(GvNAME(gv), "b")))
5898 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
5900 o->op_private |= OPpSORT_REVERSE;
5901 if (k->op_type == OP_NCMP)
5902 o->op_private |= OPpSORT_NUMERIC;
5903 if (k->op_type == OP_I_NCMP)
5904 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
5905 kid = cLISTOPo->op_first->op_sibling;
5906 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
5907 op_free(kid); /* then delete it */
5911 Perl_ck_split(pTHX_ OP *o)
5915 if (o->op_flags & OPf_STACKED)
5916 return no_fh_allowed(o);
5918 kid = cLISTOPo->op_first;
5919 if (kid->op_type != OP_NULL)
5920 Perl_croak(aTHX_ "panic: ck_split");
5921 kid = kid->op_sibling;
5922 op_free(cLISTOPo->op_first);
5923 cLISTOPo->op_first = kid;
5925 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
5926 cLISTOPo->op_last = kid; /* There was only one element previously */
5929 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
5930 OP *sibl = kid->op_sibling;
5931 kid->op_sibling = 0;
5932 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
5933 if (cLISTOPo->op_first == cLISTOPo->op_last)
5934 cLISTOPo->op_last = kid;
5935 cLISTOPo->op_first = kid;
5936 kid->op_sibling = sibl;
5939 kid->op_type = OP_PUSHRE;
5940 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
5942 if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
5943 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
5944 "Use of /g modifier is meaningless in split");
5947 if (!kid->op_sibling)
5948 append_elem(OP_SPLIT, o, newDEFSVOP());
5950 kid = kid->op_sibling;
5953 if (!kid->op_sibling)
5954 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
5956 kid = kid->op_sibling;
5959 if (kid->op_sibling)
5960 return too_many_arguments(o,OP_DESC(o));
5966 Perl_ck_join(pTHX_ OP *o)
5968 if (ckWARN(WARN_SYNTAX)) {
5969 OP *kid = cLISTOPo->op_first->op_sibling;
5970 if (kid && kid->op_type == OP_MATCH) {
5971 char *pmstr = "STRING";
5972 if (PM_GETRE(kPMOP))
5973 pmstr = PM_GETRE(kPMOP)->precomp;
5974 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5975 "/%s/ should probably be written as \"%s\"",
5983 Perl_ck_state(pTHX_ OP *o)
5985 /* warn on C<my $x=1 if foo;> , C<$a && my $x=1;> style statements */
5988 if (!o || o->op_type != OP_NULL || !(o->op_flags & OPf_KIDS))
5990 kid = cUNOPo->op_first;
5991 if (!(kid->op_type == OP_AND || kid->op_type == OP_OR))
5993 kid = kUNOP->op_first->op_sibling;
5994 if (kid->op_type == OP_SASSIGN)
5995 kid = kBINOP->op_first->op_sibling;
5996 else if (kid->op_type == OP_AASSIGN)
5997 kid = kBINOP->op_first->op_sibling;
5999 if (kid->op_type == OP_LIST
6000 || (kid->op_type == OP_NULL && kid->op_targ == OP_LIST))
6002 kid = kUNOP->op_first;
6003 if (kid->op_type == OP_PUSHMARK)
6004 kid = kid->op_sibling;
6006 if ((kid->op_type == OP_PADSV || kid->op_type == OP_PADAV
6007 || kid->op_type == OP_PADHV)
6008 && (kid->op_private & OPpLVAL_INTRO)
6009 && (ckWARN(WARN_DEPRECATED)))
6011 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
6012 "Deprecated use of my() in conditional");
6019 Perl_ck_subr(pTHX_ OP *o)
6021 OP *prev = ((cUNOPo->op_first->op_sibling)
6022 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6023 OP *o2 = prev->op_sibling;
6030 I32 contextclass = 0;
6035 o->op_private |= OPpENTERSUB_HASTARG;
6036 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6037 if (cvop->op_type == OP_RV2CV) {
6039 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6040 op_null(cvop); /* disable rv2cv */
6041 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6042 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6043 GV *gv = cGVOPx_gv(tmpop);
6046 tmpop->op_private |= OPpEARLY_CV;
6049 namegv = CvANON(cv) ? gv : CvGV(cv);
6050 proto = SvPV((SV*)cv, n_a);
6052 if (CvASSERTION(cv)) {
6053 if (PL_hints & HINT_ASSERTING) {
6054 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
6055 o->op_private |= OPpENTERSUB_DB;
6059 if (ckWARN(WARN_ASSERTIONS) && !(PL_hints & HINT_ASSERTIONSSEEN)) {
6060 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
6061 "Impossible to activate assertion call");
6068 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6069 if (o2->op_type == OP_CONST)
6070 o2->op_private &= ~OPpCONST_STRICT;
6071 else if (o2->op_type == OP_LIST) {
6072 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6073 if (o && o->op_type == OP_CONST)
6074 o->op_private &= ~OPpCONST_STRICT;
6077 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6078 if (PERLDB_SUB && PL_curstash != PL_debstash)
6079 o->op_private |= OPpENTERSUB_DB;
6080 while (o2 != cvop) {
6084 return too_many_arguments(o, gv_ename(namegv));
6102 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6104 arg == 1 ? "block or sub {}" : "sub {}",
6105 gv_ename(namegv), o2);
6108 /* '*' allows any scalar type, including bareword */
6111 if (o2->op_type == OP_RV2GV)
6112 goto wrapref; /* autoconvert GLOB -> GLOBref */
6113 else if (o2->op_type == OP_CONST)
6114 o2->op_private &= ~OPpCONST_STRICT;
6115 else if (o2->op_type == OP_ENTERSUB) {
6116 /* accidental subroutine, revert to bareword */
6117 OP *gvop = ((UNOP*)o2)->op_first;
6118 if (gvop && gvop->op_type == OP_NULL) {
6119 gvop = ((UNOP*)gvop)->op_first;
6121 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6124 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6125 (gvop = ((UNOP*)gvop)->op_first) &&
6126 gvop->op_type == OP_GV)
6128 GV *gv = cGVOPx_gv(gvop);
6129 OP *sibling = o2->op_sibling;
6130 SV *n = newSVpvn("",0);
6132 gv_fullname3(n, gv, "");
6133 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6134 sv_chop(n, SvPVX(n)+6);
6135 o2 = newSVOP(OP_CONST, 0, n);
6136 prev->op_sibling = o2;
6137 o2->op_sibling = sibling;
6153 if (contextclass++ == 0) {
6154 e = strchr(proto, ']');
6155 if (!e || e == proto)
6168 while (*--p != '[');
6169 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6170 gv_ename(namegv), o2);
6176 if (o2->op_type == OP_RV2GV)
6179 bad_type(arg, "symbol", gv_ename(namegv), o2);
6182 if (o2->op_type == OP_ENTERSUB)
6185 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6188 if (o2->op_type == OP_RV2SV ||
6189 o2->op_type == OP_PADSV ||
6190 o2->op_type == OP_HELEM ||
6191 o2->op_type == OP_AELEM ||
6192 o2->op_type == OP_THREADSV)
6195 bad_type(arg, "scalar", gv_ename(namegv), o2);
6198 if (o2->op_type == OP_RV2AV ||
6199 o2->op_type == OP_PADAV)
6202 bad_type(arg, "array", gv_ename(namegv), o2);
6205 if (o2->op_type == OP_RV2HV ||
6206 o2->op_type == OP_PADHV)
6209 bad_type(arg, "hash", gv_ename(namegv), o2);
6214 OP* sib = kid->op_sibling;
6215 kid->op_sibling = 0;
6216 o2 = newUNOP(OP_REFGEN, 0, kid);
6217 o2->op_sibling = sib;
6218 prev->op_sibling = o2;
6220 if (contextclass && e) {
6235 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6236 gv_ename(namegv), cv);
6241 mod(o2, OP_ENTERSUB);
6243 o2 = o2->op_sibling;
6245 if (proto && !optional &&
6246 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6247 return too_few_arguments(o, gv_ename(namegv));
6250 o=newSVOP(OP_CONST, 0, newSViv(0));
6256 Perl_ck_svconst(pTHX_ OP *o)
6258 SvREADONLY_on(cSVOPo->op_sv);
6263 Perl_ck_trunc(pTHX_ OP *o)
6265 if (o->op_flags & OPf_KIDS) {
6266 SVOP *kid = (SVOP*)cUNOPo->op_first;
6268 if (kid->op_type == OP_NULL)
6269 kid = (SVOP*)kid->op_sibling;
6270 if (kid && kid->op_type == OP_CONST &&
6271 (kid->op_private & OPpCONST_BARE))
6273 o->op_flags |= OPf_SPECIAL;
6274 kid->op_private &= ~OPpCONST_STRICT;
6281 Perl_ck_unpack(pTHX_ OP *o)
6283 OP *kid = cLISTOPo->op_first;
6284 if (kid->op_sibling) {
6285 kid = kid->op_sibling;
6286 if (!kid->op_sibling)
6287 kid->op_sibling = newDEFSVOP();
6293 Perl_ck_substr(pTHX_ OP *o)
6296 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6297 OP *kid = cLISTOPo->op_first;
6299 if (kid->op_type == OP_NULL)
6300 kid = kid->op_sibling;
6302 kid->op_flags |= OPf_MOD;
6308 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6311 Perl_peep(pTHX_ register OP *o)
6313 register OP* oldop = 0;
6315 if (!o || o->op_opt)
6319 SAVEVPTR(PL_curcop);
6320 for (; o; o = o->op_next) {
6324 switch (o->op_type) {
6328 PL_curcop = ((COP*)o); /* for warnings */
6333 if (cSVOPo->op_private & OPpCONST_STRICT)
6334 no_bareword_allowed(o);
6336 case OP_METHOD_NAMED:
6337 /* Relocate sv to the pad for thread safety.
6338 * Despite being a "constant", the SV is written to,
6339 * for reference counts, sv_upgrade() etc. */
6341 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6342 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6343 /* If op_sv is already a PADTMP then it is being used by
6344 * some pad, so make a copy. */
6345 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6346 SvREADONLY_on(PAD_SVl(ix));
6347 SvREFCNT_dec(cSVOPo->op_sv);
6350 SvREFCNT_dec(PAD_SVl(ix));
6351 SvPADTMP_on(cSVOPo->op_sv);
6352 PAD_SETSV(ix, cSVOPo->op_sv);
6353 /* XXX I don't know how this isn't readonly already. */
6354 SvREADONLY_on(PAD_SVl(ix));
6356 cSVOPo->op_sv = Nullsv;
6364 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6365 if (o->op_next->op_private & OPpTARGET_MY) {
6366 if (o->op_flags & OPf_STACKED) /* chained concats */
6367 goto ignore_optimization;
6369 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6370 o->op_targ = o->op_next->op_targ;
6371 o->op_next->op_targ = 0;
6372 o->op_private |= OPpTARGET_MY;
6375 op_null(o->op_next);
6377 ignore_optimization:
6381 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6383 break; /* Scalar stub must produce undef. List stub is noop */
6387 if (o->op_targ == OP_NEXTSTATE
6388 || o->op_targ == OP_DBSTATE
6389 || o->op_targ == OP_SETSTATE)
6391 PL_curcop = ((COP*)o);
6393 /* XXX: We avoid setting op_seq here to prevent later calls
6394 to peep() from mistakenly concluding that optimisation
6395 has already occurred. This doesn't fix the real problem,
6396 though (See 20010220.007). AMS 20010719 */
6397 /* op_seq functionality is now replaced by op_opt */
6398 if (oldop && o->op_next) {
6399 oldop->op_next = o->op_next;
6407 if (oldop && o->op_next) {
6408 oldop->op_next = o->op_next;
6416 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
6417 OP* pop = (o->op_type == OP_PADAV) ?
6418 o->op_next : o->op_next->op_next;
6420 if (pop && pop->op_type == OP_CONST &&
6421 (PL_op = pop->op_next) &&
6422 pop->op_next->op_type == OP_AELEM &&
6423 !(pop->op_next->op_private &
6424 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6425 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6430 if (o->op_type == OP_GV)
6431 op_null(o->op_next);
6432 op_null(pop->op_next);
6434 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6435 o->op_next = pop->op_next->op_next;
6436 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6437 o->op_private = (U8)i;
6438 if (o->op_type == OP_GV) {
6443 o->op_flags |= OPf_SPECIAL;
6444 o->op_type = OP_AELEMFAST;
6450 if (o->op_next->op_type == OP_RV2SV) {
6451 if (!(o->op_next->op_private & OPpDEREF)) {
6452 op_null(o->op_next);
6453 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6455 o->op_next = o->op_next->op_next;
6456 o->op_type = OP_GVSV;
6457 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6460 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6462 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6463 /* XXX could check prototype here instead of just carping */
6464 SV *sv = sv_newmortal();
6465 gv_efullname3(sv, gv, Nullch);
6466 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6467 "%"SVf"() called too early to check prototype",
6471 else if (o->op_next->op_type == OP_READLINE
6472 && o->op_next->op_next->op_type == OP_CONCAT
6473 && (o->op_next->op_next->op_flags & OPf_STACKED))
6475 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6476 o->op_type = OP_RCATLINE;
6477 o->op_flags |= OPf_STACKED;
6478 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6479 op_null(o->op_next->op_next);
6480 op_null(o->op_next);
6497 while (cLOGOP->op_other->op_type == OP_NULL)
6498 cLOGOP->op_other = cLOGOP->op_other->op_next;
6499 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6505 while (cLOOP->op_redoop->op_type == OP_NULL)
6506 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6507 peep(cLOOP->op_redoop);
6508 while (cLOOP->op_nextop->op_type == OP_NULL)
6509 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6510 peep(cLOOP->op_nextop);
6511 while (cLOOP->op_lastop->op_type == OP_NULL)
6512 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6513 peep(cLOOP->op_lastop);
6520 while (cPMOP->op_pmreplstart &&
6521 cPMOP->op_pmreplstart->op_type == OP_NULL)
6522 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6523 peep(cPMOP->op_pmreplstart);
6528 if (ckWARN(WARN_SYNTAX) && o->op_next
6529 && o->op_next->op_type == OP_NEXTSTATE) {
6530 if (o->op_next->op_sibling &&
6531 o->op_next->op_sibling->op_type != OP_EXIT &&
6532 o->op_next->op_sibling->op_type != OP_WARN &&
6533 o->op_next->op_sibling->op_type != OP_DIE) {
6534 line_t oldline = CopLINE(PL_curcop);
6536 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6537 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6538 "Statement unlikely to be reached");
6539 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6540 "\t(Maybe you meant system() when you said exec()?)\n");
6541 CopLINE_set(PL_curcop, oldline);
6554 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6557 /* Make the CONST have a shared SV */
6558 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6559 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6560 key = SvPV(sv, keylen);
6561 lexname = newSVpvn_share(key,
6562 SvUTF8(sv) ? -(I32)keylen : keylen,
6571 /* make @a = sort @a act in-place */
6573 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
6579 /* check that RHS of sort is a single plain array */
6580 oright = cUNOPo->op_first;
6581 if (!oright || oright->op_type != OP_PUSHMARK)
6583 oright = cUNOPx(oright)->op_sibling;
6586 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
6587 oright = cUNOPx(oright)->op_sibling;
6591 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
6592 || oright->op_next != o
6593 || (oright->op_private & OPpLVAL_INTRO)
6597 /* o2 follows the chain of op_nexts through the LHS of the
6598 * assign (if any) to the aassign op itself */
6600 if (!o2 || o2->op_type != OP_NULL)
6603 if (!o2 || o2->op_type != OP_PUSHMARK)
6606 if (o2 && o2->op_type == OP_GV)
6609 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
6610 || (o2->op_private & OPpLVAL_INTRO)
6615 if (!o2 || o2->op_type != OP_NULL)
6618 if (!o2 || o2->op_type != OP_AASSIGN
6619 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
6622 /* check the array is the same on both sides */
6623 if (oleft->op_type == OP_RV2AV) {
6624 if (oright->op_type != OP_RV2AV
6625 || !cUNOPx(oright)->op_first
6626 || cUNOPx(oright)->op_first->op_type != OP_GV
6627 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
6628 cGVOPx_gv(cUNOPx(oright)->op_first)
6632 else if (oright->op_type != OP_PADAV
6633 || oright->op_targ != oleft->op_targ
6637 /* transfer MODishness etc from LHS arg to RHS arg */
6638 oright->op_flags = oleft->op_flags;
6639 o->op_private |= OPpSORT_INPLACE;
6641 /* excise push->gv->rv2av->null->aassign */
6642 o2 = o->op_next->op_next;
6643 op_null(o2); /* PUSHMARK */
6645 if (o2->op_type == OP_GV) {
6646 op_null(o2); /* GV */
6649 op_null(o2); /* RV2AV or PADAV */
6650 o2 = o2->op_next->op_next;
6651 op_null(o2); /* AASSIGN */
6653 o->op_next = o2->op_next;
6671 char* Perl_custom_op_name(pTHX_ OP* o)
6673 IV index = PTR2IV(o->op_ppaddr);
6677 if (!PL_custom_op_names) /* This probably shouldn't happen */
6678 return PL_op_name[OP_CUSTOM];
6680 keysv = sv_2mortal(newSViv(index));
6682 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
6684 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
6686 return SvPV_nolen(HeVAL(he));
6689 char* Perl_custom_op_desc(pTHX_ OP* o)
6691 IV index = PTR2IV(o->op_ppaddr);
6695 if (!PL_custom_op_descs)
6696 return PL_op_desc[OP_CUSTOM];
6698 keysv = sv_2mortal(newSViv(index));
6700 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
6702 return PL_op_desc[OP_CUSTOM];
6704 return SvPV_nolen(HeVAL(he));
6710 /* Efficient sub that returns a constant scalar value. */
6712 const_sv_xsub(pTHX_ CV* cv)
6717 Perl_croak(aTHX_ "usage: %s::%s()",
6718 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
6722 ST(0) = (SV*)XSANY.any_ptr;