3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
13 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
14 * youngest of the Old Took's daughters); and Mr. Drogo was his second
15 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
16 * either way, as the saying is, if you follow me." --the Gaffer
25 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
27 #if defined(PL_OP_SLAB_ALLOC)
29 #ifndef PERL_SLAB_SIZE
30 #define PERL_SLAB_SIZE 2048
34 Perl_Slab_Alloc(pTHX_ int m, size_t sz)
37 * To make incrementing use count easy PL_OpSlab is an I32 *
38 * To make inserting the link to slab PL_OpPtr is I32 **
39 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
40 * Add an overhead for pointer to slab and round up as a number of pointers
42 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
43 if ((PL_OpSpace -= sz) < 0) {
44 PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*));
48 Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **);
49 /* We reserve the 0'th I32 sized chunk as a use count */
50 PL_OpSlab = (I32 *) PL_OpPtr;
51 /* Reduce size by the use count word, and by the size we need.
52 * Latter is to mimic the '-=' in the if() above
54 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
55 /* Allocation pointer starts at the top.
56 Theory: because we build leaves before trunk allocating at end
57 means that at run time access is cache friendly upward
59 PL_OpPtr += PERL_SLAB_SIZE;
61 assert( PL_OpSpace >= 0 );
62 /* Move the allocation pointer down */
64 assert( PL_OpPtr > (I32 **) PL_OpSlab );
65 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
66 (*PL_OpSlab)++; /* Increment use count of slab */
67 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
68 assert( *PL_OpSlab > 0 );
69 return (void *)(PL_OpPtr + 1);
73 Perl_Slab_Free(pTHX_ void *op)
75 I32 **ptr = (I32 **) op;
77 assert( ptr-1 > (I32 **) slab );
78 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
82 # define PerlMemShared PerlMem
85 PerlMemShared_free(slab);
86 if (slab == PL_OpSlab) {
93 * In the following definition, the ", Nullop" is just to make the compiler
94 * think the expression is of the right type: croak actually does a Siglongjmp.
96 #define CHECKOP(type,o) \
97 ((PL_op_mask && PL_op_mask[type]) \
98 ? ( op_free((OP*)o), \
99 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
101 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
103 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
106 S_gv_ename(pTHX_ GV *gv)
109 SV* tmpsv = sv_newmortal();
110 gv_efullname3(tmpsv, gv, Nullch);
111 return SvPV(tmpsv,n_a);
115 S_no_fh_allowed(pTHX_ OP *o)
117 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
123 S_too_few_arguments(pTHX_ OP *o, char *name)
125 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
130 S_too_many_arguments(pTHX_ OP *o, char *name)
132 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
137 S_bad_type(pTHX_ I32 n, char *t, char *name, OP *kid)
139 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
140 (int)n, name, t, OP_DESC(kid)));
144 S_no_bareword_allowed(pTHX_ OP *o)
146 qerror(Perl_mess(aTHX_
147 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
151 /* "register" allocation */
154 Perl_allocmy(pTHX_ char *name)
158 /* complain about "my $<special_var>" etc etc */
159 if (!(PL_in_my == KEY_our ||
161 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
162 (name[1] == '_' && (*name == '$' || (int)strlen(name) > 2))))
164 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
165 /* 1999-02-27 mjd@plover.com */
167 p = strchr(name, '\0');
168 /* The next block assumes the buffer is at least 205 chars
169 long. At present, it's always at least 256 chars. */
171 strcpy(name+200, "...");
177 /* Move everything else down one character */
178 for (; p-name > 2; p--)
180 name[2] = toCTRL(name[1]);
183 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
186 /* check for duplicate declaration */
188 (bool)(PL_in_my == KEY_our),
189 (PL_curstash ? PL_curstash : PL_defstash)
192 if (PL_in_my_stash && *name != '$') {
193 yyerror(Perl_form(aTHX_
194 "Can't declare class for non-scalar %s in \"%s\"",
195 name, PL_in_my == KEY_our ? "our" : "my"));
198 /* allocate a spare slot and store the name in that slot */
200 off = pad_add_name(name,
203 ? (PL_curstash ? PL_curstash : PL_defstash)
214 Perl_op_free(pTHX_ OP *o)
216 register OP *kid, *nextkid;
219 if (!o || o->op_static)
222 if (o->op_private & OPpREFCOUNTED) {
223 switch (o->op_type) {
231 if (OpREFCNT_dec(o)) {
242 if (o->op_flags & OPf_KIDS) {
243 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
244 nextkid = kid->op_sibling; /* Get before next freeing kid */
250 type = (OPCODE)o->op_targ;
252 /* COP* is not cleared by op_clear() so that we may track line
253 * numbers etc even after null() */
254 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
262 Perl_op_clear(pTHX_ OP *o)
265 switch (o->op_type) {
266 case OP_NULL: /* Was holding old type, if any. */
267 case OP_ENTEREVAL: /* Was holding hints. */
271 if (!(o->op_flags & OPf_REF)
272 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
278 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
279 /* not an OP_PADAV replacement */
281 if (cPADOPo->op_padix > 0) {
282 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
283 * may still exist on the pad */
284 pad_swipe(cPADOPo->op_padix, TRUE);
285 cPADOPo->op_padix = 0;
288 SvREFCNT_dec(cSVOPo->op_sv);
289 cSVOPo->op_sv = Nullsv;
293 case OP_METHOD_NAMED:
295 SvREFCNT_dec(cSVOPo->op_sv);
296 cSVOPo->op_sv = Nullsv;
299 Even if op_clear does a pad_free for the target of the op,
300 pad_free doesn't actually remove the sv that exists in the pad;
301 instead it lives on. This results in that it could be reused as
302 a target later on when the pad was reallocated.
305 pad_swipe(o->op_targ,1);
314 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
318 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
319 SvREFCNT_dec(cSVOPo->op_sv);
320 cSVOPo->op_sv = Nullsv;
323 Safefree(cPVOPo->op_pv);
324 cPVOPo->op_pv = Nullch;
328 op_free(cPMOPo->op_pmreplroot);
332 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
333 /* No GvIN_PAD_off here, because other references may still
334 * exist on the pad */
335 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
338 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
345 HV *pmstash = PmopSTASH(cPMOPo);
346 if (pmstash && SvREFCNT(pmstash)) {
347 PMOP *pmop = HvPMROOT(pmstash);
348 PMOP *lastpmop = NULL;
350 if (cPMOPo == pmop) {
352 lastpmop->op_pmnext = pmop->op_pmnext;
354 HvPMROOT(pmstash) = pmop->op_pmnext;
358 pmop = pmop->op_pmnext;
361 PmopSTASH_free(cPMOPo);
363 cPMOPo->op_pmreplroot = Nullop;
364 /* we use the "SAFE" version of the PM_ macros here
365 * since sv_clean_all might release some PMOPs
366 * after PL_regex_padav has been cleared
367 * and the clearing of PL_regex_padav needs to
368 * happen before sv_clean_all
370 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
371 PM_SETRE_SAFE(cPMOPo, (REGEXP*)NULL);
373 if(PL_regex_pad) { /* We could be in destruction */
374 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
375 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
376 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
383 if (o->op_targ > 0) {
384 pad_free(o->op_targ);
390 S_cop_free(pTHX_ COP* cop)
392 Safefree(cop->cop_label); /* FIXME: treaddead ??? */
395 if (! specialWARN(cop->cop_warnings))
396 SvREFCNT_dec(cop->cop_warnings);
397 if (! specialCopIO(cop->cop_io)) {
401 char *s = SvPV(cop->cop_io,len);
402 Perl_warn(aTHX_ "io='%.*s'",(int) len,s); /* ??? --jhi */
405 SvREFCNT_dec(cop->cop_io);
411 Perl_op_null(pTHX_ OP *o)
413 if (o->op_type == OP_NULL)
416 o->op_targ = o->op_type;
417 o->op_type = OP_NULL;
418 o->op_ppaddr = PL_ppaddr[OP_NULL];
421 /* Contextualizers */
423 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
426 Perl_linklist(pTHX_ OP *o)
433 /* establish postfix order */
434 if (cUNOPo->op_first) {
435 o->op_next = LINKLIST(cUNOPo->op_first);
436 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
438 kid->op_next = LINKLIST(kid->op_sibling);
450 Perl_scalarkids(pTHX_ OP *o)
453 if (o && o->op_flags & OPf_KIDS) {
454 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
461 S_scalarboolean(pTHX_ OP *o)
463 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
464 if (ckWARN(WARN_SYNTAX)) {
465 line_t oldline = CopLINE(PL_curcop);
467 if (PL_copline != NOLINE)
468 CopLINE_set(PL_curcop, PL_copline);
469 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
470 CopLINE_set(PL_curcop, oldline);
477 Perl_scalar(pTHX_ OP *o)
481 /* assumes no premature commitment */
482 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
483 || o->op_type == OP_RETURN)
488 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
490 switch (o->op_type) {
492 scalar(cBINOPo->op_first);
497 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
501 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
502 if (!kPMOP->op_pmreplroot)
503 deprecate_old("implicit split to @_");
511 if (o->op_flags & OPf_KIDS) {
512 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
518 kid = cLISTOPo->op_first;
520 while ((kid = kid->op_sibling)) {
526 WITH_THR(PL_curcop = &PL_compiling);
531 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
537 WITH_THR(PL_curcop = &PL_compiling);
540 if (ckWARN(WARN_VOID))
541 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
547 Perl_scalarvoid(pTHX_ OP *o)
554 if (o->op_type == OP_NEXTSTATE
555 || o->op_type == OP_SETSTATE
556 || o->op_type == OP_DBSTATE
557 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
558 || o->op_targ == OP_SETSTATE
559 || o->op_targ == OP_DBSTATE)))
560 PL_curcop = (COP*)o; /* for warning below */
562 /* assumes no premature commitment */
563 want = o->op_flags & OPf_WANT;
564 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
565 || o->op_type == OP_RETURN)
570 if ((o->op_private & OPpTARGET_MY)
571 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
573 return scalar(o); /* As if inside SASSIGN */
576 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
578 switch (o->op_type) {
580 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
584 if (o->op_flags & OPf_STACKED)
588 if (o->op_private == 4)
660 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
661 useless = OP_DESC(o);
665 kid = cUNOPo->op_first;
666 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
667 kid->op_type != OP_TRANS) {
670 useless = "negative pattern binding (!~)";
677 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
678 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
679 useless = "a variable";
684 if (cSVOPo->op_private & OPpCONST_STRICT)
685 no_bareword_allowed(o);
687 if (ckWARN(WARN_VOID)) {
688 useless = "a constant";
689 /* don't warn on optimised away booleans, eg
690 * use constant Foo, 5; Foo || print; */
691 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
693 /* the constants 0 and 1 are permitted as they are
694 conventionally used as dummies in constructs like
695 1 while some_condition_with_side_effects; */
696 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
698 else if (SvPOK(sv)) {
699 /* perl4's way of mixing documentation and code
700 (before the invention of POD) was based on a
701 trick to mix nroff and perl code. The trick was
702 built upon these three nroff macros being used in
703 void context. The pink camel has the details in
704 the script wrapman near page 319. */
705 if (strnEQ(SvPVX(sv), "di", 2) ||
706 strnEQ(SvPVX(sv), "ds", 2) ||
707 strnEQ(SvPVX(sv), "ig", 2))
712 op_null(o); /* don't execute or even remember it */
716 o->op_type = OP_PREINC; /* pre-increment is faster */
717 o->op_ppaddr = PL_ppaddr[OP_PREINC];
721 o->op_type = OP_PREDEC; /* pre-decrement is faster */
722 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
729 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
734 if (o->op_flags & OPf_STACKED)
741 if (!(o->op_flags & OPf_KIDS))
750 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
757 /* all requires must return a boolean value */
758 o->op_flags &= ~OPf_WANT;
763 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
764 if (!kPMOP->op_pmreplroot)
765 deprecate_old("implicit split to @_");
769 if (useless && ckWARN(WARN_VOID))
770 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
775 Perl_listkids(pTHX_ OP *o)
778 if (o && o->op_flags & OPf_KIDS) {
779 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
786 Perl_list(pTHX_ OP *o)
790 /* assumes no premature commitment */
791 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
792 || o->op_type == OP_RETURN)
797 if ((o->op_private & OPpTARGET_MY)
798 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
800 return o; /* As if inside SASSIGN */
803 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
805 switch (o->op_type) {
808 list(cBINOPo->op_first);
813 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
821 if (!(o->op_flags & OPf_KIDS))
823 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
824 list(cBINOPo->op_first);
825 return gen_constant_list(o);
832 kid = cLISTOPo->op_first;
834 while ((kid = kid->op_sibling)) {
840 WITH_THR(PL_curcop = &PL_compiling);
844 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
850 WITH_THR(PL_curcop = &PL_compiling);
853 /* all requires must return a boolean value */
854 o->op_flags &= ~OPf_WANT;
861 Perl_scalarseq(pTHX_ OP *o)
866 if (o->op_type == OP_LINESEQ ||
867 o->op_type == OP_SCOPE ||
868 o->op_type == OP_LEAVE ||
869 o->op_type == OP_LEAVETRY)
871 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
872 if (kid->op_sibling) {
876 PL_curcop = &PL_compiling;
878 o->op_flags &= ~OPf_PARENS;
879 if (PL_hints & HINT_BLOCK_SCOPE)
880 o->op_flags |= OPf_PARENS;
883 o = newOP(OP_STUB, 0);
888 S_modkids(pTHX_ OP *o, I32 type)
891 if (o && o->op_flags & OPf_KIDS) {
892 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
898 /* Propagate lvalue ("modifiable") context to an op and it's children.
899 * 'type' represents the context type, roughly based on the type of op that
900 * would do the modifying, although local() is represented by OP_NULL.
901 * It's responsible for detecting things that can't be modified, flag
902 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
903 * might have to vivify a reference in $x), and so on.
905 * For example, "$a+1 = 2" would cause mod() to be called with o being
906 * OP_ADD and type being OP_SASSIGN, and would output an error.
910 Perl_mod(pTHX_ OP *o, I32 type)
913 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
916 if (!o || PL_error_count)
919 if ((o->op_private & OPpTARGET_MY)
920 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
925 switch (o->op_type) {
931 if (!(o->op_private & (OPpCONST_ARYBASE)))
933 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
934 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
938 SAVEI32(PL_compiling.cop_arybase);
939 PL_compiling.cop_arybase = 0;
941 else if (type == OP_REFGEN)
944 Perl_croak(aTHX_ "That use of $[ is unsupported");
947 if (o->op_flags & OPf_PARENS)
951 if ((type == OP_UNDEF || type == OP_REFGEN) &&
952 !(o->op_flags & OPf_STACKED)) {
953 o->op_type = OP_RV2CV; /* entersub => rv2cv */
954 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
955 assert(cUNOPo->op_first->op_type == OP_NULL);
956 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
959 else if (o->op_private & OPpENTERSUB_NOMOD)
961 else { /* lvalue subroutine call */
962 o->op_private |= OPpLVAL_INTRO;
963 PL_modcount = RETURN_UNLIMITED_NUMBER;
964 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
965 /* Backward compatibility mode: */
966 o->op_private |= OPpENTERSUB_INARGS;
969 else { /* Compile-time error message: */
970 OP *kid = cUNOPo->op_first;
974 if (kid->op_type == OP_PUSHMARK)
976 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
978 "panic: unexpected lvalue entersub "
979 "args: type/targ %ld:%"UVuf,
980 (long)kid->op_type, (UV)kid->op_targ);
981 kid = kLISTOP->op_first;
983 while (kid->op_sibling)
984 kid = kid->op_sibling;
985 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
987 if (kid->op_type == OP_METHOD_NAMED
988 || kid->op_type == OP_METHOD)
992 NewOp(1101, newop, 1, UNOP);
993 newop->op_type = OP_RV2CV;
994 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
995 newop->op_first = Nullop;
996 newop->op_next = (OP*)newop;
997 kid->op_sibling = (OP*)newop;
998 newop->op_private |= OPpLVAL_INTRO;
1002 if (kid->op_type != OP_RV2CV)
1004 "panic: unexpected lvalue entersub "
1005 "entry via type/targ %ld:%"UVuf,
1006 (long)kid->op_type, (UV)kid->op_targ);
1007 kid->op_private |= OPpLVAL_INTRO;
1008 break; /* Postpone until runtime */
1012 kid = kUNOP->op_first;
1013 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1014 kid = kUNOP->op_first;
1015 if (kid->op_type == OP_NULL)
1017 "Unexpected constant lvalue entersub "
1018 "entry via type/targ %ld:%"UVuf,
1019 (long)kid->op_type, (UV)kid->op_targ);
1020 if (kid->op_type != OP_GV) {
1021 /* Restore RV2CV to check lvalueness */
1023 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1024 okid->op_next = kid->op_next;
1025 kid->op_next = okid;
1028 okid->op_next = Nullop;
1029 okid->op_type = OP_RV2CV;
1031 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1032 okid->op_private |= OPpLVAL_INTRO;
1036 cv = GvCV(kGVOP_gv);
1046 /* grep, foreach, subcalls, refgen */
1047 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1049 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1050 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1052 : (o->op_type == OP_ENTERSUB
1053 ? "non-lvalue subroutine call"
1055 type ? PL_op_desc[type] : "local"));
1069 case OP_RIGHT_SHIFT:
1078 if (!(o->op_flags & OPf_STACKED))
1085 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1091 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1092 PL_modcount = RETURN_UNLIMITED_NUMBER;
1093 return o; /* Treat \(@foo) like ordinary list. */
1097 if (scalar_mod_type(o, type))
1099 ref(cUNOPo->op_first, o->op_type);
1103 if (type == OP_LEAVESUBLV)
1104 o->op_private |= OPpMAYBE_LVSUB;
1110 PL_modcount = RETURN_UNLIMITED_NUMBER;
1113 ref(cUNOPo->op_first, o->op_type);
1118 PL_hints |= HINT_BLOCK_SCOPE;
1133 PL_modcount = RETURN_UNLIMITED_NUMBER;
1134 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1135 return o; /* Treat \(@foo) like ordinary list. */
1136 if (scalar_mod_type(o, type))
1138 if (type == OP_LEAVESUBLV)
1139 o->op_private |= OPpMAYBE_LVSUB;
1143 if (!type) /* local() */
1144 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1145 PAD_COMPNAME_PV(o->op_targ));
1153 if (type != OP_SASSIGN)
1157 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1162 if (type == OP_LEAVESUBLV)
1163 o->op_private |= OPpMAYBE_LVSUB;
1165 pad_free(o->op_targ);
1166 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1167 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1168 if (o->op_flags & OPf_KIDS)
1169 mod(cBINOPo->op_first->op_sibling, type);
1174 ref(cBINOPo->op_first, o->op_type);
1175 if (type == OP_ENTERSUB &&
1176 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1177 o->op_private |= OPpLVAL_DEFER;
1178 if (type == OP_LEAVESUBLV)
1179 o->op_private |= OPpMAYBE_LVSUB;
1189 if (o->op_flags & OPf_KIDS)
1190 mod(cLISTOPo->op_last, type);
1195 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1197 else if (!(o->op_flags & OPf_KIDS))
1199 if (o->op_targ != OP_LIST) {
1200 mod(cBINOPo->op_first, type);
1206 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1211 if (type != OP_LEAVESUBLV)
1213 break; /* mod()ing was handled by ck_return() */
1216 /* [20011101.069] File test operators interpret OPf_REF to mean that
1217 their argument is a filehandle; thus \stat(".") should not set
1219 if (type == OP_REFGEN &&
1220 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1223 if (type != OP_LEAVESUBLV)
1224 o->op_flags |= OPf_MOD;
1226 if (type == OP_AASSIGN || type == OP_SASSIGN)
1227 o->op_flags |= OPf_SPECIAL|OPf_REF;
1228 else if (!type) { /* local() */
1231 o->op_private |= OPpLVAL_INTRO;
1232 o->op_flags &= ~OPf_SPECIAL;
1233 PL_hints |= HINT_BLOCK_SCOPE;
1238 if (ckWARN(WARN_SYNTAX)) {
1239 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1240 "Useless localization of %s", OP_DESC(o));
1244 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1245 && type != OP_LEAVESUBLV)
1246 o->op_flags |= OPf_REF;
1251 S_scalar_mod_type(pTHX_ OP *o, I32 type)
1255 if (o->op_type == OP_RV2GV)
1279 case OP_RIGHT_SHIFT:
1298 S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
1300 switch (o->op_type) {
1308 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1321 Perl_refkids(pTHX_ OP *o, I32 type)
1324 if (o && o->op_flags & OPf_KIDS) {
1325 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1332 Perl_ref(pTHX_ OP *o, I32 type)
1336 if (!o || PL_error_count)
1339 switch (o->op_type) {
1341 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1342 !(o->op_flags & OPf_STACKED)) {
1343 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1344 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1345 assert(cUNOPo->op_first->op_type == OP_NULL);
1346 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1347 o->op_flags |= OPf_SPECIAL;
1352 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1356 if (type == OP_DEFINED)
1357 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1358 ref(cUNOPo->op_first, o->op_type);
1361 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1362 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1363 : type == OP_RV2HV ? OPpDEREF_HV
1365 o->op_flags |= OPf_MOD;
1370 o->op_flags |= OPf_MOD; /* XXX ??? */
1375 o->op_flags |= OPf_REF;
1378 if (type == OP_DEFINED)
1379 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1380 ref(cUNOPo->op_first, o->op_type);
1385 o->op_flags |= OPf_REF;
1390 if (!(o->op_flags & OPf_KIDS))
1392 ref(cBINOPo->op_first, type);
1396 ref(cBINOPo->op_first, o->op_type);
1397 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1398 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1399 : type == OP_RV2HV ? OPpDEREF_HV
1401 o->op_flags |= OPf_MOD;
1409 if (!(o->op_flags & OPf_KIDS))
1411 ref(cLISTOPo->op_last, type);
1421 S_dup_attrlist(pTHX_ OP *o)
1425 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1426 * where the first kid is OP_PUSHMARK and the remaining ones
1427 * are OP_CONST. We need to push the OP_CONST values.
1429 if (o->op_type == OP_CONST)
1430 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1432 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1433 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1434 if (o->op_type == OP_CONST)
1435 rop = append_elem(OP_LIST, rop,
1436 newSVOP(OP_CONST, o->op_flags,
1437 SvREFCNT_inc(cSVOPo->op_sv)));
1444 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1448 /* fake up C<use attributes $pkg,$rv,@attrs> */
1449 ENTER; /* need to protect against side-effects of 'use' */
1452 stashsv = newSVpv(HvNAME(stash), 0);
1454 stashsv = &PL_sv_no;
1456 #define ATTRSMODULE "attributes"
1457 #define ATTRSMODULE_PM "attributes.pm"
1461 /* Don't force the C<use> if we don't need it. */
1462 svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
1463 sizeof(ATTRSMODULE_PM)-1, 0);
1464 if (svp && *svp != &PL_sv_undef)
1465 ; /* already in %INC */
1467 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1468 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1472 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1473 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1475 prepend_elem(OP_LIST,
1476 newSVOP(OP_CONST, 0, stashsv),
1477 prepend_elem(OP_LIST,
1478 newSVOP(OP_CONST, 0,
1480 dup_attrlist(attrs))));
1486 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1488 OP *pack, *imop, *arg;
1494 assert(target->op_type == OP_PADSV ||
1495 target->op_type == OP_PADHV ||
1496 target->op_type == OP_PADAV);
1498 /* Ensure that attributes.pm is loaded. */
1499 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1501 /* Need package name for method call. */
1502 pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
1504 /* Build up the real arg-list. */
1506 stashsv = newSVpv(HvNAME(stash), 0);
1508 stashsv = &PL_sv_no;
1509 arg = newOP(OP_PADSV, 0);
1510 arg->op_targ = target->op_targ;
1511 arg = prepend_elem(OP_LIST,
1512 newSVOP(OP_CONST, 0, stashsv),
1513 prepend_elem(OP_LIST,
1514 newUNOP(OP_REFGEN, 0,
1515 mod(arg, OP_REFGEN)),
1516 dup_attrlist(attrs)));
1518 /* Fake up a method call to import */
1519 meth = newSVpvn("import", 6);
1520 (void)SvUPGRADE(meth, SVt_PVIV);
1521 (void)SvIOK_on(meth);
1522 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
1523 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1524 append_elem(OP_LIST,
1525 prepend_elem(OP_LIST, pack, list(arg)),
1526 newSVOP(OP_METHOD_NAMED, 0, meth)));
1527 imop->op_private |= OPpENTERSUB_NOMOD;
1529 /* Combine the ops. */
1530 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1534 =notfor apidoc apply_attrs_string
1536 Attempts to apply a list of attributes specified by the C<attrstr> and
1537 C<len> arguments to the subroutine identified by the C<cv> argument which
1538 is expected to be associated with the package identified by the C<stashpv>
1539 argument (see L<attributes>). It gets this wrong, though, in that it
1540 does not correctly identify the boundaries of the individual attribute
1541 specifications within C<attrstr>. This is not really intended for the
1542 public API, but has to be listed here for systems such as AIX which
1543 need an explicit export list for symbols. (It's called from XS code
1544 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1545 to respect attribute syntax properly would be welcome.
1551 Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
1552 char *attrstr, STRLEN len)
1557 len = strlen(attrstr);
1561 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1563 char *sstr = attrstr;
1564 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1565 attrs = append_elem(OP_LIST, attrs,
1566 newSVOP(OP_CONST, 0,
1567 newSVpvn(sstr, attrstr-sstr)));
1571 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1572 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1573 Nullsv, prepend_elem(OP_LIST,
1574 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1575 prepend_elem(OP_LIST,
1576 newSVOP(OP_CONST, 0,
1582 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1587 if (!o || PL_error_count)
1591 if (type == OP_LIST) {
1592 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1593 my_kid(kid, attrs, imopsp);
1594 } else if (type == OP_UNDEF) {
1596 } else if (type == OP_RV2SV || /* "our" declaration */
1598 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1599 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1600 yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
1601 OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
1603 GV *gv = cGVOPx_gv(cUNOPo->op_first);
1605 PL_in_my_stash = Nullhv;
1606 apply_attrs(GvSTASH(gv),
1607 (type == OP_RV2SV ? GvSV(gv) :
1608 type == OP_RV2AV ? (SV*)GvAV(gv) :
1609 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1612 o->op_private |= OPpOUR_INTRO;
1615 else if (type != OP_PADSV &&
1618 type != OP_PUSHMARK)
1620 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1622 PL_in_my == KEY_our ? "our" : "my"));
1625 else if (attrs && type != OP_PUSHMARK) {
1629 PL_in_my_stash = Nullhv;
1631 /* check for C<my Dog $spot> when deciding package */
1632 stash = PAD_COMPNAME_TYPE(o->op_targ);
1634 stash = PL_curstash;
1635 apply_attrs_my(stash, o, attrs, imopsp);
1637 o->op_flags |= OPf_MOD;
1638 o->op_private |= OPpLVAL_INTRO;
1643 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1646 int maybe_scalar = 0;
1648 /* [perl #17376]: this appears to be premature, and results in code such as
1649 C< our(%x); > executing in list mode rather than void mode */
1651 if (o->op_flags & OPf_PARENS)
1660 o = my_kid(o, attrs, &rops);
1662 if (maybe_scalar && o->op_type == OP_PADSV) {
1663 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1664 o->op_private |= OPpLVAL_INTRO;
1667 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1670 PL_in_my_stash = Nullhv;
1675 Perl_my(pTHX_ OP *o)
1677 return my_attrs(o, Nullop);
1681 Perl_sawparens(pTHX_ OP *o)
1684 o->op_flags |= OPf_PARENS;
1689 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1694 if (ckWARN(WARN_MISC) &&
1695 (left->op_type == OP_RV2AV ||
1696 left->op_type == OP_RV2HV ||
1697 left->op_type == OP_PADAV ||
1698 left->op_type == OP_PADHV)) {
1699 char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
1700 right->op_type == OP_TRANS)
1701 ? right->op_type : OP_MATCH];
1702 const char *sample = ((left->op_type == OP_RV2AV ||
1703 left->op_type == OP_PADAV)
1704 ? "@array" : "%hash");
1705 Perl_warner(aTHX_ packWARN(WARN_MISC),
1706 "Applying %s to %s will act on scalar(%s)",
1707 desc, sample, sample);
1710 if (right->op_type == OP_CONST &&
1711 cSVOPx(right)->op_private & OPpCONST_BARE &&
1712 cSVOPx(right)->op_private & OPpCONST_STRICT)
1714 no_bareword_allowed(right);
1717 ismatchop = right->op_type == OP_MATCH ||
1718 right->op_type == OP_SUBST ||
1719 right->op_type == OP_TRANS;
1720 if (ismatchop && right->op_private & OPpTARGET_MY) {
1722 right->op_private &= ~OPpTARGET_MY;
1724 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1725 right->op_flags |= OPf_STACKED;
1726 if (right->op_type != OP_MATCH &&
1727 ! (right->op_type == OP_TRANS &&
1728 right->op_private & OPpTRANS_IDENTICAL))
1729 left = mod(left, right->op_type);
1730 if (right->op_type == OP_TRANS)
1731 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
1733 o = prepend_elem(right->op_type, scalar(left), right);
1735 return newUNOP(OP_NOT, 0, scalar(o));
1739 return bind_match(type, left,
1740 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
1744 Perl_invert(pTHX_ OP *o)
1748 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
1749 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1753 Perl_scope(pTHX_ OP *o)
1756 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1757 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1758 o->op_type = OP_LEAVE;
1759 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1761 else if (o->op_type == OP_LINESEQ) {
1763 o->op_type = OP_SCOPE;
1764 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1765 kid = ((LISTOP*)o)->op_first;
1766 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
1770 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
1775 /* XXX kept for BINCOMPAT only */
1777 Perl_save_hints(pTHX)
1779 Perl_croak(aTHX_ "internal error: obsolete function save_hints() called");
1783 Perl_block_start(pTHX_ int full)
1785 int retval = PL_savestack_ix;
1786 pad_block_start(full);
1788 PL_hints &= ~HINT_BLOCK_SCOPE;
1789 SAVESPTR(PL_compiling.cop_warnings);
1790 if (! specialWARN(PL_compiling.cop_warnings)) {
1791 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1792 SAVEFREESV(PL_compiling.cop_warnings) ;
1794 SAVESPTR(PL_compiling.cop_io);
1795 if (! specialCopIO(PL_compiling.cop_io)) {
1796 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1797 SAVEFREESV(PL_compiling.cop_io) ;
1803 Perl_block_end(pTHX_ I32 floor, OP *seq)
1805 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1806 OP* retval = scalarseq(seq);
1808 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
1810 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
1818 I32 offset = pad_findmy("$_");
1819 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
1820 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1823 OP *o = newOP(OP_PADSV, 0);
1824 o->op_targ = offset;
1830 Perl_newPROG(pTHX_ OP *o)
1835 PL_eval_root = newUNOP(OP_LEAVEEVAL,
1836 ((PL_in_eval & EVAL_KEEPERR)
1837 ? OPf_SPECIAL : 0), o);
1838 PL_eval_start = linklist(PL_eval_root);
1839 PL_eval_root->op_private |= OPpREFCOUNTED;
1840 OpREFCNT_set(PL_eval_root, 1);
1841 PL_eval_root->op_next = 0;
1842 CALL_PEEP(PL_eval_start);
1845 if (o->op_type == OP_STUB) {
1846 PL_comppad_name = 0;
1851 PL_main_root = scope(sawparens(scalarvoid(o)));
1852 PL_curcop = &PL_compiling;
1853 PL_main_start = LINKLIST(PL_main_root);
1854 PL_main_root->op_private |= OPpREFCOUNTED;
1855 OpREFCNT_set(PL_main_root, 1);
1856 PL_main_root->op_next = 0;
1857 CALL_PEEP(PL_main_start);
1860 /* Register with debugger */
1862 CV *cv = get_cv("DB::postponed", FALSE);
1866 XPUSHs((SV*)CopFILEGV(&PL_compiling));
1868 call_sv((SV*)cv, G_DISCARD);
1875 Perl_localize(pTHX_ OP *o, I32 lex)
1877 if (o->op_flags & OPf_PARENS)
1878 /* [perl #17376]: this appears to be premature, and results in code such as
1879 C< our(%x); > executing in list mode rather than void mode */
1886 if (ckWARN(WARN_PARENTHESIS)
1887 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
1889 char *s = PL_bufptr;
1892 /* some heuristics to detect a potential error */
1893 while (*s && (strchr(", \t\n", *s)))
1897 if (*s && strchr("@$%*", *s) && *++s
1898 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
1901 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
1903 while (*s && (strchr(", \t\n", *s)))
1909 if (sigil && (*s == ';' || *s == '=')) {
1910 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
1911 "Parentheses missing around \"%s\" list",
1912 lex ? (PL_in_my == KEY_our ? "our" : "my")
1920 o = mod(o, OP_NULL); /* a bit kludgey */
1922 PL_in_my_stash = Nullhv;
1927 Perl_jmaybe(pTHX_ OP *o)
1929 if (o->op_type == OP_LIST) {
1931 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
1932 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
1938 Perl_fold_constants(pTHX_ register OP *o)
1941 I32 type = o->op_type;
1944 if (PL_opargs[type] & OA_RETSCALAR)
1946 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
1947 o->op_targ = pad_alloc(type, SVs_PADTMP);
1949 /* integerize op, unless it happens to be C<-foo>.
1950 * XXX should pp_i_negate() do magic string negation instead? */
1951 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
1952 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
1953 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
1955 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
1958 if (!(PL_opargs[type] & OA_FOLDCONST))
1963 /* XXX might want a ck_negate() for this */
1964 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
1976 /* XXX what about the numeric ops? */
1977 if (PL_hints & HINT_LOCALE)
1982 goto nope; /* Don't try to run w/ errors */
1984 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
1985 if ((curop->op_type != OP_CONST ||
1986 (curop->op_private & OPpCONST_BARE)) &&
1987 curop->op_type != OP_LIST &&
1988 curop->op_type != OP_SCALAR &&
1989 curop->op_type != OP_NULL &&
1990 curop->op_type != OP_PUSHMARK)
1996 curop = LINKLIST(o);
2000 sv = *(PL_stack_sp--);
2001 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2002 pad_swipe(o->op_targ, FALSE);
2003 else if (SvTEMP(sv)) { /* grab mortal temp? */
2004 (void)SvREFCNT_inc(sv);
2008 if (type == OP_RV2GV)
2009 return newGVOP(OP_GV, 0, (GV*)sv);
2010 return newSVOP(OP_CONST, 0, sv);
2017 Perl_gen_constant_list(pTHX_ register OP *o)
2020 I32 oldtmps_floor = PL_tmps_floor;
2024 return o; /* Don't attempt to run with errors */
2026 PL_op = curop = LINKLIST(o);
2033 PL_tmps_floor = oldtmps_floor;
2035 o->op_type = OP_RV2AV;
2036 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2037 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2038 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2039 o->op_opt = 0; /* needs to be revisited in peep() */
2040 curop = ((UNOP*)o)->op_first;
2041 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2048 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2050 if (!o || o->op_type != OP_LIST)
2051 o = newLISTOP(OP_LIST, 0, o, Nullop);
2053 o->op_flags &= ~OPf_WANT;
2055 if (!(PL_opargs[type] & OA_MARK))
2056 op_null(cLISTOPo->op_first);
2058 o->op_type = (OPCODE)type;
2059 o->op_ppaddr = PL_ppaddr[type];
2060 o->op_flags |= flags;
2062 o = CHECKOP(type, o);
2063 if (o->op_type != type)
2066 return fold_constants(o);
2069 /* List constructors */
2072 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2080 if (first->op_type != type
2081 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2083 return newLISTOP(type, 0, first, last);
2086 if (first->op_flags & OPf_KIDS)
2087 ((LISTOP*)first)->op_last->op_sibling = last;
2089 first->op_flags |= OPf_KIDS;
2090 ((LISTOP*)first)->op_first = last;
2092 ((LISTOP*)first)->op_last = last;
2097 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2105 if (first->op_type != type)
2106 return prepend_elem(type, (OP*)first, (OP*)last);
2108 if (last->op_type != type)
2109 return append_elem(type, (OP*)first, (OP*)last);
2111 first->op_last->op_sibling = last->op_first;
2112 first->op_last = last->op_last;
2113 first->op_flags |= (last->op_flags & OPf_KIDS);
2121 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2129 if (last->op_type == type) {
2130 if (type == OP_LIST) { /* already a PUSHMARK there */
2131 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2132 ((LISTOP*)last)->op_first->op_sibling = first;
2133 if (!(first->op_flags & OPf_PARENS))
2134 last->op_flags &= ~OPf_PARENS;
2137 if (!(last->op_flags & OPf_KIDS)) {
2138 ((LISTOP*)last)->op_last = first;
2139 last->op_flags |= OPf_KIDS;
2141 first->op_sibling = ((LISTOP*)last)->op_first;
2142 ((LISTOP*)last)->op_first = first;
2144 last->op_flags |= OPf_KIDS;
2148 return newLISTOP(type, 0, first, last);
2154 Perl_newNULLLIST(pTHX)
2156 return newOP(OP_STUB, 0);
2160 Perl_force_list(pTHX_ OP *o)
2162 if (!o || o->op_type != OP_LIST)
2163 o = newLISTOP(OP_LIST, 0, o, Nullop);
2169 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2173 NewOp(1101, listop, 1, LISTOP);
2175 listop->op_type = (OPCODE)type;
2176 listop->op_ppaddr = PL_ppaddr[type];
2179 listop->op_flags = (U8)flags;
2183 else if (!first && last)
2186 first->op_sibling = last;
2187 listop->op_first = first;
2188 listop->op_last = last;
2189 if (type == OP_LIST) {
2191 pushop = newOP(OP_PUSHMARK, 0);
2192 pushop->op_sibling = first;
2193 listop->op_first = pushop;
2194 listop->op_flags |= OPf_KIDS;
2196 listop->op_last = pushop;
2199 return CHECKOP(type, listop);
2203 Perl_newOP(pTHX_ I32 type, I32 flags)
2206 NewOp(1101, o, 1, OP);
2207 o->op_type = (OPCODE)type;
2208 o->op_ppaddr = PL_ppaddr[type];
2209 o->op_flags = (U8)flags;
2212 o->op_private = (U8)(0 | (flags >> 8));
2213 if (PL_opargs[type] & OA_RETSCALAR)
2215 if (PL_opargs[type] & OA_TARGET)
2216 o->op_targ = pad_alloc(type, SVs_PADTMP);
2217 return CHECKOP(type, o);
2221 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2226 first = newOP(OP_STUB, 0);
2227 if (PL_opargs[type] & OA_MARK)
2228 first = force_list(first);
2230 NewOp(1101, unop, 1, UNOP);
2231 unop->op_type = (OPCODE)type;
2232 unop->op_ppaddr = PL_ppaddr[type];
2233 unop->op_first = first;
2234 unop->op_flags = flags | OPf_KIDS;
2235 unop->op_private = (U8)(1 | (flags >> 8));
2236 unop = (UNOP*) CHECKOP(type, unop);
2240 return fold_constants((OP *) unop);
2244 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2247 NewOp(1101, binop, 1, BINOP);
2250 first = newOP(OP_NULL, 0);
2252 binop->op_type = (OPCODE)type;
2253 binop->op_ppaddr = PL_ppaddr[type];
2254 binop->op_first = first;
2255 binop->op_flags = flags | OPf_KIDS;
2258 binop->op_private = (U8)(1 | (flags >> 8));
2261 binop->op_private = (U8)(2 | (flags >> 8));
2262 first->op_sibling = last;
2265 binop = (BINOP*)CHECKOP(type, binop);
2266 if (binop->op_next || binop->op_type != (OPCODE)type)
2269 binop->op_last = binop->op_first->op_sibling;
2271 return fold_constants((OP *)binop);
2275 uvcompare(const void *a, const void *b)
2277 if (*((UV *)a) < (*(UV *)b))
2279 if (*((UV *)a) > (*(UV *)b))
2281 if (*((UV *)a+1) < (*(UV *)b+1))
2283 if (*((UV *)a+1) > (*(UV *)b+1))
2289 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2291 SV *tstr = ((SVOP*)expr)->op_sv;
2292 SV *rstr = ((SVOP*)repl)->op_sv;
2295 U8 *t = (U8*)SvPV(tstr, tlen);
2296 U8 *r = (U8*)SvPV(rstr, rlen);
2303 register short *tbl;
2305 PL_hints |= HINT_BLOCK_SCOPE;
2306 complement = o->op_private & OPpTRANS_COMPLEMENT;
2307 del = o->op_private & OPpTRANS_DELETE;
2308 squash = o->op_private & OPpTRANS_SQUASH;
2311 o->op_private |= OPpTRANS_FROM_UTF;
2314 o->op_private |= OPpTRANS_TO_UTF;
2316 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2317 SV* listsv = newSVpvn("# comment\n",10);
2319 U8* tend = t + tlen;
2320 U8* rend = r + rlen;
2334 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2335 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2341 tsave = t = bytes_to_utf8(t, &len);
2344 if (!to_utf && rlen) {
2346 rsave = r = bytes_to_utf8(r, &len);
2350 /* There are several snags with this code on EBCDIC:
2351 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2352 2. scan_const() in toke.c has encoded chars in native encoding which makes
2353 ranges at least in EBCDIC 0..255 range the bottom odd.
2357 U8 tmpbuf[UTF8_MAXLEN+1];
2360 New(1109, cp, 2*tlen, UV);
2362 transv = newSVpvn("",0);
2364 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2366 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2368 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2372 cp[2*i+1] = cp[2*i];
2376 qsort(cp, i, 2*sizeof(UV), uvcompare);
2377 for (j = 0; j < i; j++) {
2379 diff = val - nextmin;
2381 t = uvuni_to_utf8(tmpbuf,nextmin);
2382 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2384 U8 range_mark = UTF_TO_NATIVE(0xff);
2385 t = uvuni_to_utf8(tmpbuf, val - 1);
2386 sv_catpvn(transv, (char *)&range_mark, 1);
2387 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2394 t = uvuni_to_utf8(tmpbuf,nextmin);
2395 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2397 U8 range_mark = UTF_TO_NATIVE(0xff);
2398 sv_catpvn(transv, (char *)&range_mark, 1);
2400 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2401 UNICODE_ALLOW_SUPER);
2402 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2403 t = (U8*)SvPVX(transv);
2404 tlen = SvCUR(transv);
2408 else if (!rlen && !del) {
2409 r = t; rlen = tlen; rend = tend;
2412 if ((!rlen && !del) || t == r ||
2413 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2415 o->op_private |= OPpTRANS_IDENTICAL;
2419 while (t < tend || tfirst <= tlast) {
2420 /* see if we need more "t" chars */
2421 if (tfirst > tlast) {
2422 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2424 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2426 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2433 /* now see if we need more "r" chars */
2434 if (rfirst > rlast) {
2436 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2438 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2440 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2449 rfirst = rlast = 0xffffffff;
2453 /* now see which range will peter our first, if either. */
2454 tdiff = tlast - tfirst;
2455 rdiff = rlast - rfirst;
2462 if (rfirst == 0xffffffff) {
2463 diff = tdiff; /* oops, pretend rdiff is infinite */
2465 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2466 (long)tfirst, (long)tlast);
2468 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2472 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2473 (long)tfirst, (long)(tfirst + diff),
2476 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2477 (long)tfirst, (long)rfirst);
2479 if (rfirst + diff > max)
2480 max = rfirst + diff;
2482 grows = (tfirst < rfirst &&
2483 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2495 else if (max > 0xff)
2500 Safefree(cPVOPo->op_pv);
2501 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2502 SvREFCNT_dec(listsv);
2504 SvREFCNT_dec(transv);
2506 if (!del && havefinal && rlen)
2507 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2508 newSVuv((UV)final), 0);
2511 o->op_private |= OPpTRANS_GROWS;
2523 tbl = (short*)cPVOPo->op_pv;
2525 Zero(tbl, 256, short);
2526 for (i = 0; i < (I32)tlen; i++)
2528 for (i = 0, j = 0; i < 256; i++) {
2530 if (j >= (I32)rlen) {
2539 if (i < 128 && r[j] >= 128)
2549 o->op_private |= OPpTRANS_IDENTICAL;
2551 else if (j >= (I32)rlen)
2554 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2555 tbl[0x100] = rlen - j;
2556 for (i=0; i < (I32)rlen - j; i++)
2557 tbl[0x101+i] = r[j+i];
2561 if (!rlen && !del) {
2564 o->op_private |= OPpTRANS_IDENTICAL;
2566 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2567 o->op_private |= OPpTRANS_IDENTICAL;
2569 for (i = 0; i < 256; i++)
2571 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
2572 if (j >= (I32)rlen) {
2574 if (tbl[t[i]] == -1)
2580 if (tbl[t[i]] == -1) {
2581 if (t[i] < 128 && r[j] >= 128)
2588 o->op_private |= OPpTRANS_GROWS;
2596 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2600 NewOp(1101, pmop, 1, PMOP);
2601 pmop->op_type = (OPCODE)type;
2602 pmop->op_ppaddr = PL_ppaddr[type];
2603 pmop->op_flags = (U8)flags;
2604 pmop->op_private = (U8)(0 | (flags >> 8));
2606 if (PL_hints & HINT_RE_TAINT)
2607 pmop->op_pmpermflags |= PMf_RETAINT;
2608 if (PL_hints & HINT_LOCALE)
2609 pmop->op_pmpermflags |= PMf_LOCALE;
2610 pmop->op_pmflags = pmop->op_pmpermflags;
2615 if(av_len((AV*) PL_regex_pad[0]) > -1) {
2616 repointer = av_pop((AV*)PL_regex_pad[0]);
2617 pmop->op_pmoffset = SvIV(repointer);
2618 SvREPADTMP_off(repointer);
2619 sv_setiv(repointer,0);
2621 repointer = newSViv(0);
2622 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2623 pmop->op_pmoffset = av_len(PL_regex_padav);
2624 PL_regex_pad = AvARRAY(PL_regex_padav);
2629 /* link into pm list */
2630 if (type != OP_TRANS && PL_curstash) {
2631 pmop->op_pmnext = HvPMROOT(PL_curstash);
2632 HvPMROOT(PL_curstash) = pmop;
2633 PmopSTASH_set(pmop,PL_curstash);
2636 return CHECKOP(type, pmop);
2640 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
2644 I32 repl_has_vars = 0;
2646 if (o->op_type == OP_TRANS)
2647 return pmtrans(o, expr, repl);
2649 PL_hints |= HINT_BLOCK_SCOPE;
2652 if (expr->op_type == OP_CONST) {
2654 SV *pat = ((SVOP*)expr)->op_sv;
2655 char *p = SvPV(pat, plen);
2656 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
2657 sv_setpvn(pat, "\\s+", 3);
2658 p = SvPV(pat, plen);
2659 pm->op_pmflags |= PMf_SKIPWHITE;
2662 pm->op_pmdynflags |= PMdf_UTF8;
2663 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
2664 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
2665 pm->op_pmflags |= PMf_WHITE;
2669 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2670 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2672 : OP_REGCMAYBE),0,expr);
2674 NewOp(1101, rcop, 1, LOGOP);
2675 rcop->op_type = OP_REGCOMP;
2676 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2677 rcop->op_first = scalar(expr);
2678 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
2679 ? (OPf_SPECIAL | OPf_KIDS)
2681 rcop->op_private = 1;
2683 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
2686 /* establish postfix order */
2687 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2689 rcop->op_next = expr;
2690 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2693 rcop->op_next = LINKLIST(expr);
2694 expr->op_next = (OP*)rcop;
2697 prepend_elem(o->op_type, scalar((OP*)rcop), o);
2702 if (pm->op_pmflags & PMf_EVAL) {
2704 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
2705 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
2707 else if (repl->op_type == OP_CONST)
2711 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
2712 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
2713 if (curop->op_type == OP_GV) {
2714 GV *gv = cGVOPx_gv(curop);
2716 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
2719 else if (curop->op_type == OP_RV2CV)
2721 else if (curop->op_type == OP_RV2SV ||
2722 curop->op_type == OP_RV2AV ||
2723 curop->op_type == OP_RV2HV ||
2724 curop->op_type == OP_RV2GV) {
2725 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2728 else if (curop->op_type == OP_PADSV ||
2729 curop->op_type == OP_PADAV ||
2730 curop->op_type == OP_PADHV ||
2731 curop->op_type == OP_PADANY) {
2734 else if (curop->op_type == OP_PUSHRE)
2735 ; /* Okay here, dangerous in newASSIGNOP */
2745 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
2746 pm->op_pmflags |= PMf_CONST; /* const for long enough */
2747 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
2748 prepend_elem(o->op_type, scalar(repl), o);
2751 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
2752 pm->op_pmflags |= PMf_MAYBE_CONST;
2753 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2755 NewOp(1101, rcop, 1, LOGOP);
2756 rcop->op_type = OP_SUBSTCONT;
2757 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
2758 rcop->op_first = scalar(repl);
2759 rcop->op_flags |= OPf_KIDS;
2760 rcop->op_private = 1;
2763 /* establish postfix order */
2764 rcop->op_next = LINKLIST(repl);
2765 repl->op_next = (OP*)rcop;
2767 pm->op_pmreplroot = scalar((OP*)rcop);
2768 pm->op_pmreplstart = LINKLIST(rcop);
2777 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
2780 NewOp(1101, svop, 1, SVOP);
2781 svop->op_type = (OPCODE)type;
2782 svop->op_ppaddr = PL_ppaddr[type];
2784 svop->op_next = (OP*)svop;
2785 svop->op_flags = (U8)flags;
2786 if (PL_opargs[type] & OA_RETSCALAR)
2788 if (PL_opargs[type] & OA_TARGET)
2789 svop->op_targ = pad_alloc(type, SVs_PADTMP);
2790 return CHECKOP(type, svop);
2794 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2797 NewOp(1101, padop, 1, PADOP);
2798 padop->op_type = (OPCODE)type;
2799 padop->op_ppaddr = PL_ppaddr[type];
2800 padop->op_padix = pad_alloc(type, SVs_PADTMP);
2801 SvREFCNT_dec(PAD_SVl(padop->op_padix));
2802 PAD_SETSV(padop->op_padix, sv);
2805 padop->op_next = (OP*)padop;
2806 padop->op_flags = (U8)flags;
2807 if (PL_opargs[type] & OA_RETSCALAR)
2809 if (PL_opargs[type] & OA_TARGET)
2810 padop->op_targ = pad_alloc(type, SVs_PADTMP);
2811 return CHECKOP(type, padop);
2815 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
2820 return newPADOP(type, flags, SvREFCNT_inc(gv));
2822 return newSVOP(type, flags, SvREFCNT_inc(gv));
2827 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
2830 NewOp(1101, pvop, 1, PVOP);
2831 pvop->op_type = (OPCODE)type;
2832 pvop->op_ppaddr = PL_ppaddr[type];
2834 pvop->op_next = (OP*)pvop;
2835 pvop->op_flags = (U8)flags;
2836 if (PL_opargs[type] & OA_RETSCALAR)
2838 if (PL_opargs[type] & OA_TARGET)
2839 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
2840 return CHECKOP(type, pvop);
2844 Perl_package(pTHX_ OP *o)
2849 save_hptr(&PL_curstash);
2850 save_item(PL_curstname);
2852 name = SvPV(cSVOPo->op_sv, len);
2853 PL_curstash = gv_stashpvn(name, len, TRUE);
2854 sv_setpvn(PL_curstname, name, len);
2857 PL_hints |= HINT_BLOCK_SCOPE;
2858 PL_copline = NOLINE;
2863 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
2869 if (idop->op_type != OP_CONST)
2870 Perl_croak(aTHX_ "Module name must be constant");
2874 if (version != Nullop) {
2875 SV *vesv = ((SVOP*)version)->op_sv;
2877 if (arg == Nullop && !SvNIOKp(vesv)) {
2884 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
2885 Perl_croak(aTHX_ "Version number must be constant number");
2887 /* Make copy of idop so we don't free it twice */
2888 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
2890 /* Fake up a method call to VERSION */
2891 meth = newSVpvn("VERSION",7);
2892 sv_upgrade(meth, SVt_PVIV);
2893 (void)SvIOK_on(meth);
2894 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
2895 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2896 append_elem(OP_LIST,
2897 prepend_elem(OP_LIST, pack, list(version)),
2898 newSVOP(OP_METHOD_NAMED, 0, meth)));
2902 /* Fake up an import/unimport */
2903 if (arg && arg->op_type == OP_STUB)
2904 imop = arg; /* no import on explicit () */
2905 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
2906 imop = Nullop; /* use 5.0; */
2911 /* Make copy of idop so we don't free it twice */
2912 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
2914 /* Fake up a method call to import/unimport */
2915 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);
2916 (void)SvUPGRADE(meth, SVt_PVIV);
2917 (void)SvIOK_on(meth);
2918 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
2919 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2920 append_elem(OP_LIST,
2921 prepend_elem(OP_LIST, pack, list(arg)),
2922 newSVOP(OP_METHOD_NAMED, 0, meth)));
2925 /* Fake up the BEGIN {}, which does its thing immediately. */
2927 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
2930 append_elem(OP_LINESEQ,
2931 append_elem(OP_LINESEQ,
2932 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, idop)),
2933 newSTATEOP(0, Nullch, veop)),
2934 newSTATEOP(0, Nullch, imop) ));
2936 /* The "did you use incorrect case?" warning used to be here.
2937 * The problem is that on case-insensitive filesystems one
2938 * might get false positives for "use" (and "require"):
2939 * "use Strict" or "require CARP" will work. This causes
2940 * portability problems for the script: in case-strict
2941 * filesystems the script will stop working.
2943 * The "incorrect case" warning checked whether "use Foo"
2944 * imported "Foo" to your namespace, but that is wrong, too:
2945 * there is no requirement nor promise in the language that
2946 * a Foo.pm should or would contain anything in package "Foo".
2948 * There is very little Configure-wise that can be done, either:
2949 * the case-sensitivity of the build filesystem of Perl does not
2950 * help in guessing the case-sensitivity of the runtime environment.
2953 PL_hints |= HINT_BLOCK_SCOPE;
2954 PL_copline = NOLINE;
2956 PL_cop_seqmax++; /* Purely for B::*'s benefit */
2960 =head1 Embedding Functions
2962 =for apidoc load_module
2964 Loads the module whose name is pointed to by the string part of name.
2965 Note that the actual module name, not its filename, should be given.
2966 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
2967 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
2968 (or 0 for no flags). ver, if specified, provides version semantics
2969 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
2970 arguments can be used to specify arguments to the module's import()
2971 method, similar to C<use Foo::Bar VERSION LIST>.
2976 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
2979 va_start(args, ver);
2980 vload_module(flags, name, ver, &args);
2984 #ifdef PERL_IMPLICIT_CONTEXT
2986 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
2990 va_start(args, ver);
2991 vload_module(flags, name, ver, &args);
2997 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
2999 OP *modname, *veop, *imop;
3001 modname = newSVOP(OP_CONST, 0, name);
3002 modname->op_private |= OPpCONST_BARE;
3004 veop = newSVOP(OP_CONST, 0, ver);
3008 if (flags & PERL_LOADMOD_NOIMPORT) {
3009 imop = sawparens(newNULLLIST());
3011 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3012 imop = va_arg(*args, OP*);
3017 sv = va_arg(*args, SV*);
3019 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3020 sv = va_arg(*args, SV*);
3024 line_t ocopline = PL_copline;
3025 COP *ocurcop = PL_curcop;
3026 int oexpect = PL_expect;
3028 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3029 veop, modname, imop);
3030 PL_expect = oexpect;
3031 PL_copline = ocopline;
3032 PL_curcop = ocurcop;
3037 Perl_dofile(pTHX_ OP *term)
3042 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3043 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
3044 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3046 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3047 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3048 append_elem(OP_LIST, term,
3049 scalar(newUNOP(OP_RV2CV, 0,
3054 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3060 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3062 return newBINOP(OP_LSLICE, flags,
3063 list(force_list(subscript)),
3064 list(force_list(listval)) );
3068 S_list_assignment(pTHX_ register OP *o)
3073 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3074 o = cUNOPo->op_first;
3076 if (o->op_type == OP_COND_EXPR) {
3077 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3078 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3083 yyerror("Assignment to both a list and a scalar");
3087 if (o->op_type == OP_LIST &&
3088 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3089 o->op_private & OPpLVAL_INTRO)
3092 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3093 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3094 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3097 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3100 if (o->op_type == OP_RV2SV)
3107 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3112 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3113 return newLOGOP(optype, 0,
3114 mod(scalar(left), optype),
3115 newUNOP(OP_SASSIGN, 0, scalar(right)));
3118 return newBINOP(optype, OPf_STACKED,
3119 mod(scalar(left), optype), scalar(right));
3123 if (list_assignment(left)) {
3127 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3128 left = mod(left, OP_AASSIGN);
3136 /* optimise C<my @x = ()> to C<my @x>, and likewise for hashes */
3137 if ((left->op_type == OP_PADAV || left->op_type == OP_PADHV)
3138 && right->op_type == OP_STUB
3139 && (left->op_private & OPpLVAL_INTRO))
3142 left->op_flags &= ~(OPf_REF|OPf_SPECIAL);
3145 curop = list(force_list(left));
3146 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3147 o->op_private = (U8)(0 | (flags >> 8));
3149 /* PL_generation sorcery:
3150 * an assignment like ($a,$b) = ($c,$d) is easier than
3151 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3152 * To detect whether there are common vars, the global var
3153 * PL_generation is incremented for each assign op we compile.
3154 * Then, while compiling the assign op, we run through all the
3155 * variables on both sides of the assignment, setting a spare slot
3156 * in each of them to PL_generation. If any of them already have
3157 * that value, we know we've got commonality. We could use a
3158 * single bit marker, but then we'd have to make 2 passes, first
3159 * to clear the flag, then to test and set it. To find somewhere
3160 * to store these values, evil chicanery is done with SvCUR().
3163 if (!(left->op_private & OPpLVAL_INTRO)) {
3166 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3167 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3168 if (curop->op_type == OP_GV) {
3169 GV *gv = cGVOPx_gv(curop);
3170 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3172 SvCUR(gv) = PL_generation;
3174 else if (curop->op_type == OP_PADSV ||
3175 curop->op_type == OP_PADAV ||
3176 curop->op_type == OP_PADHV ||
3177 curop->op_type == OP_PADANY)
3179 if (PAD_COMPNAME_GEN(curop->op_targ)
3180 == (STRLEN)PL_generation)
3182 PAD_COMPNAME_GEN(curop->op_targ)
3186 else if (curop->op_type == OP_RV2CV)
3188 else if (curop->op_type == OP_RV2SV ||
3189 curop->op_type == OP_RV2AV ||
3190 curop->op_type == OP_RV2HV ||
3191 curop->op_type == OP_RV2GV) {
3192 if (lastop->op_type != OP_GV) /* funny deref? */
3195 else if (curop->op_type == OP_PUSHRE) {
3196 if (((PMOP*)curop)->op_pmreplroot) {
3198 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3199 ((PMOP*)curop)->op_pmreplroot));
3201 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3203 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3205 SvCUR(gv) = PL_generation;
3214 o->op_private |= OPpASSIGN_COMMON;
3216 if (right && right->op_type == OP_SPLIT) {
3218 if ((tmpop = ((LISTOP*)right)->op_first) &&
3219 tmpop->op_type == OP_PUSHRE)
3221 PMOP *pm = (PMOP*)tmpop;
3222 if (left->op_type == OP_RV2AV &&
3223 !(left->op_private & OPpLVAL_INTRO) &&
3224 !(o->op_private & OPpASSIGN_COMMON) )
3226 tmpop = ((UNOP*)left)->op_first;
3227 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3229 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3230 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3232 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3233 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3235 pm->op_pmflags |= PMf_ONCE;
3236 tmpop = cUNOPo->op_first; /* to list (nulled) */
3237 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3238 tmpop->op_sibling = Nullop; /* don't free split */
3239 right->op_next = tmpop->op_next; /* fix starting loc */
3240 op_free(o); /* blow off assign */
3241 right->op_flags &= ~OPf_WANT;
3242 /* "I don't know and I don't care." */
3247 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3248 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3250 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3252 sv_setiv(sv, PL_modcount+1);
3260 right = newOP(OP_UNDEF, 0);
3261 if (right->op_type == OP_READLINE) {
3262 right->op_flags |= OPf_STACKED;
3263 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3266 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3267 o = newBINOP(OP_SASSIGN, flags,
3268 scalar(right), mod(scalar(left), OP_SASSIGN) );
3280 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3282 U32 seq = intro_my();
3285 NewOp(1101, cop, 1, COP);
3286 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3287 cop->op_type = OP_DBSTATE;
3288 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3291 cop->op_type = OP_NEXTSTATE;
3292 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3294 cop->op_flags = (U8)flags;
3295 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3297 cop->op_private |= NATIVE_HINTS;
3299 PL_compiling.op_private = cop->op_private;
3300 cop->op_next = (OP*)cop;
3303 cop->cop_label = label;
3304 PL_hints |= HINT_BLOCK_SCOPE;
3307 cop->cop_arybase = PL_curcop->cop_arybase;
3308 if (specialWARN(PL_curcop->cop_warnings))
3309 cop->cop_warnings = PL_curcop->cop_warnings ;
3311 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3312 if (specialCopIO(PL_curcop->cop_io))
3313 cop->cop_io = PL_curcop->cop_io;
3315 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3318 if (PL_copline == NOLINE)
3319 CopLINE_set(cop, CopLINE(PL_curcop));
3321 CopLINE_set(cop, PL_copline);
3322 PL_copline = NOLINE;
3325 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3327 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3329 CopSTASH_set(cop, PL_curstash);
3331 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3332 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3333 if (svp && *svp != &PL_sv_undef ) {
3334 (void)SvIOK_on(*svp);
3335 SvIVX(*svp) = PTR2IV(cop);
3339 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3344 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3346 return new_logop(type, flags, &first, &other);
3350 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3354 OP *first = *firstp;
3355 OP *other = *otherp;
3357 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3358 return newBINOP(type, flags, scalar(first), scalar(other));
3360 scalarboolean(first);
3361 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3362 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3363 if (type == OP_AND || type == OP_OR) {
3369 first = *firstp = cUNOPo->op_first;
3371 first->op_next = o->op_next;
3372 cUNOPo->op_first = Nullop;
3376 if (first->op_type == OP_CONST) {
3377 if (first->op_private & OPpCONST_STRICT)
3378 no_bareword_allowed(first);
3379 else if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3380 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3381 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
3382 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
3383 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
3386 if (other->op_type == OP_CONST)
3387 other->op_private |= OPpCONST_SHORTCIRCUIT;
3391 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
3393 if ( ! (o2->op_type == OP_LIST
3394 && (( o2 = cUNOPx(o2)->op_first))
3395 && o2->op_type == OP_PUSHMARK
3396 && (( o2 = o2->op_sibling)) )
3399 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
3400 || o2->op_type == OP_PADHV)
3401 && o2->op_private & OPpLVAL_INTRO
3402 && ckWARN(WARN_DEPRECATED))
3404 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
3405 "Deprecated use of my() in false conditional");
3410 if (first->op_type == OP_CONST)
3411 first->op_private |= OPpCONST_SHORTCIRCUIT;
3415 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS) &&
3416 type != OP_DOR) /* [#24076] Don't warn for <FH> err FOO. */
3418 OP *k1 = ((UNOP*)first)->op_first;
3419 OP *k2 = k1->op_sibling;
3421 switch (first->op_type)
3424 if (k2 && k2->op_type == OP_READLINE
3425 && (k2->op_flags & OPf_STACKED)
3426 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3428 warnop = k2->op_type;
3433 if (k1->op_type == OP_READDIR
3434 || k1->op_type == OP_GLOB
3435 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3436 || k1->op_type == OP_EACH)
3438 warnop = ((k1->op_type == OP_NULL)
3439 ? (OPCODE)k1->op_targ : k1->op_type);
3444 line_t oldline = CopLINE(PL_curcop);
3445 CopLINE_set(PL_curcop, PL_copline);
3446 Perl_warner(aTHX_ packWARN(WARN_MISC),
3447 "Value of %s%s can be \"0\"; test with defined()",
3449 ((warnop == OP_READLINE || warnop == OP_GLOB)
3450 ? " construct" : "() operator"));
3451 CopLINE_set(PL_curcop, oldline);
3458 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3459 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3461 NewOp(1101, logop, 1, LOGOP);
3463 logop->op_type = (OPCODE)type;
3464 logop->op_ppaddr = PL_ppaddr[type];
3465 logop->op_first = first;
3466 logop->op_flags = flags | OPf_KIDS;
3467 logop->op_other = LINKLIST(other);
3468 logop->op_private = (U8)(1 | (flags >> 8));
3470 /* establish postfix order */
3471 logop->op_next = LINKLIST(first);
3472 first->op_next = (OP*)logop;
3473 first->op_sibling = other;
3475 CHECKOP(type,logop);
3477 o = newUNOP(OP_NULL, 0, (OP*)logop);
3484 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3491 return newLOGOP(OP_AND, 0, first, trueop);
3493 return newLOGOP(OP_OR, 0, first, falseop);
3495 scalarboolean(first);
3496 if (first->op_type == OP_CONST) {
3497 if (first->op_private & OPpCONST_BARE &&
3498 first->op_private & OPpCONST_STRICT) {
3499 no_bareword_allowed(first);
3501 if (SvTRUE(((SVOP*)first)->op_sv)) {
3512 NewOp(1101, logop, 1, LOGOP);
3513 logop->op_type = OP_COND_EXPR;
3514 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3515 logop->op_first = first;
3516 logop->op_flags = flags | OPf_KIDS;
3517 logop->op_private = (U8)(1 | (flags >> 8));
3518 logop->op_other = LINKLIST(trueop);
3519 logop->op_next = LINKLIST(falseop);
3521 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
3524 /* establish postfix order */
3525 start = LINKLIST(first);
3526 first->op_next = (OP*)logop;
3528 first->op_sibling = trueop;
3529 trueop->op_sibling = falseop;
3530 o = newUNOP(OP_NULL, 0, (OP*)logop);
3532 trueop->op_next = falseop->op_next = o;
3539 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3547 NewOp(1101, range, 1, LOGOP);
3549 range->op_type = OP_RANGE;
3550 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3551 range->op_first = left;
3552 range->op_flags = OPf_KIDS;
3553 leftstart = LINKLIST(left);
3554 range->op_other = LINKLIST(right);
3555 range->op_private = (U8)(1 | (flags >> 8));
3557 left->op_sibling = right;
3559 range->op_next = (OP*)range;
3560 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3561 flop = newUNOP(OP_FLOP, 0, flip);
3562 o = newUNOP(OP_NULL, 0, flop);
3564 range->op_next = leftstart;
3566 left->op_next = flip;
3567 right->op_next = flop;
3569 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3570 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3571 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3572 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3574 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3575 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3578 if (!flip->op_private || !flop->op_private)
3579 linklist(o); /* blow off optimizer unless constant */
3585 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3589 int once = block && block->op_flags & OPf_SPECIAL &&
3590 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3593 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3594 return block; /* do {} while 0 does once */
3595 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3596 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3597 expr = newUNOP(OP_DEFINED, 0,
3598 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3599 } else if (expr->op_flags & OPf_KIDS) {
3600 OP *k1 = ((UNOP*)expr)->op_first;
3601 OP *k2 = (k1) ? k1->op_sibling : NULL;
3602 switch (expr->op_type) {
3604 if (k2 && k2->op_type == OP_READLINE
3605 && (k2->op_flags & OPf_STACKED)
3606 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3607 expr = newUNOP(OP_DEFINED, 0, expr);
3611 if (k1->op_type == OP_READDIR
3612 || k1->op_type == OP_GLOB
3613 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3614 || k1->op_type == OP_EACH)
3615 expr = newUNOP(OP_DEFINED, 0, expr);
3621 /* if block is null, the next append_elem() would put UNSTACK, a scalar
3622 * op, in listop. This is wrong. [perl #27024] */
3624 block = newOP(OP_NULL, 0);
3625 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3626 o = new_logop(OP_AND, 0, &expr, &listop);
3629 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3631 if (once && o != listop)
3632 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3635 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3637 o->op_flags |= flags;
3639 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3644 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3652 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3653 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3654 expr = newUNOP(OP_DEFINED, 0,
3655 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3656 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3657 OP *k1 = ((UNOP*)expr)->op_first;
3658 OP *k2 = (k1) ? k1->op_sibling : NULL;
3659 switch (expr->op_type) {
3661 if (k2 && k2->op_type == OP_READLINE
3662 && (k2->op_flags & OPf_STACKED)
3663 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3664 expr = newUNOP(OP_DEFINED, 0, expr);
3668 if (k1->op_type == OP_READDIR
3669 || k1->op_type == OP_GLOB
3670 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3671 || k1->op_type == OP_EACH)
3672 expr = newUNOP(OP_DEFINED, 0, expr);
3678 block = newOP(OP_NULL, 0);
3680 block = scope(block);
3684 next = LINKLIST(cont);
3687 OP *unstack = newOP(OP_UNSTACK, 0);
3690 cont = append_elem(OP_LINESEQ, cont, unstack);
3693 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3694 redo = LINKLIST(listop);
3697 PL_copline = (line_t)whileline;
3699 o = new_logop(OP_AND, 0, &expr, &listop);
3700 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3701 op_free(expr); /* oops, it's a while (0) */
3703 return Nullop; /* listop already freed by new_logop */
3706 ((LISTOP*)listop)->op_last->op_next =
3707 (o == listop ? redo : LINKLIST(o));
3713 NewOp(1101,loop,1,LOOP);
3714 loop->op_type = OP_ENTERLOOP;
3715 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3716 loop->op_private = 0;
3717 loop->op_next = (OP*)loop;
3720 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3722 loop->op_redoop = redo;
3723 loop->op_lastop = o;
3724 o->op_private |= loopflags;
3727 loop->op_nextop = next;
3729 loop->op_nextop = o;
3731 o->op_flags |= flags;
3732 o->op_private |= (flags >> 8);
3737 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
3741 PADOFFSET padoff = 0;
3746 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
3747 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
3748 sv->op_type = OP_RV2GV;
3749 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3751 else if (sv->op_type == OP_PADSV) { /* private variable */
3752 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
3753 padoff = sv->op_targ;
3758 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3759 padoff = sv->op_targ;
3761 iterflags |= OPf_SPECIAL;
3766 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3769 I32 offset = pad_findmy("$_");
3770 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
3771 sv = newGVOP(OP_GV, 0, PL_defgv);
3777 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3778 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3779 iterflags |= OPf_STACKED;
3781 else if (expr->op_type == OP_NULL &&
3782 (expr->op_flags & OPf_KIDS) &&
3783 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3785 /* Basically turn for($x..$y) into the same as for($x,$y), but we
3786 * set the STACKED flag to indicate that these values are to be
3787 * treated as min/max values by 'pp_iterinit'.
3789 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
3790 LOGOP* range = (LOGOP*) flip->op_first;
3791 OP* left = range->op_first;
3792 OP* right = left->op_sibling;
3795 range->op_flags &= ~OPf_KIDS;
3796 range->op_first = Nullop;
3798 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
3799 listop->op_first->op_next = range->op_next;
3800 left->op_next = range->op_other;
3801 right->op_next = (OP*)listop;
3802 listop->op_next = listop->op_first;
3805 expr = (OP*)(listop);
3807 iterflags |= OPf_STACKED;
3810 expr = mod(force_list(expr), OP_GREPSTART);
3814 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
3815 append_elem(OP_LIST, expr, scalar(sv))));
3816 assert(!loop->op_next);
3817 /* for my $x () sets OPpLVAL_INTRO;
3818 * for our $x () sets OPpOUR_INTRO */
3819 loop->op_private = (U8)iterpflags;
3820 #ifdef PL_OP_SLAB_ALLOC
3823 NewOp(1234,tmp,1,LOOP);
3824 Copy(loop,tmp,1,LOOP);
3829 Renew(loop, 1, LOOP);
3831 loop->op_targ = padoff;
3832 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
3833 PL_copline = forline;
3834 return newSTATEOP(0, label, wop);
3838 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
3843 if (type != OP_GOTO || label->op_type == OP_CONST) {
3844 /* "last()" means "last" */
3845 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
3846 o = newOP(type, OPf_SPECIAL);
3848 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
3849 ? SvPVx(((SVOP*)label)->op_sv, n_a)
3855 /* Check whether it's going to be a goto &function */
3856 if (label->op_type == OP_ENTERSUB
3857 && !(label->op_flags & OPf_STACKED))
3858 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
3859 o = newUNOP(type, OPf_STACKED, label);
3861 PL_hints |= HINT_BLOCK_SCOPE;
3866 =for apidoc cv_undef
3868 Clear out all the active components of a CV. This can happen either
3869 by an explicit C<undef &foo>, or by the reference count going to zero.
3870 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
3871 children can still follow the full lexical scope chain.
3877 Perl_cv_undef(pTHX_ CV *cv)
3880 if (CvFILE(cv) && !CvXSUB(cv)) {
3881 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
3882 Safefree(CvFILE(cv));
3887 if (!CvXSUB(cv) && CvROOT(cv)) {
3889 Perl_croak(aTHX_ "Can't undef active subroutine");
3892 PAD_SAVE_SETNULLPAD();
3894 op_free(CvROOT(cv));
3895 CvROOT(cv) = Nullop;
3898 SvPOK_off((SV*)cv); /* forget prototype */
3903 /* remove CvOUTSIDE unless this is an undef rather than a free */
3904 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
3905 if (!CvWEAKOUTSIDE(cv))
3906 SvREFCNT_dec(CvOUTSIDE(cv));
3907 CvOUTSIDE(cv) = Nullcv;
3910 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
3916 /* delete all flags except WEAKOUTSIDE */
3917 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
3921 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
3923 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
3924 SV* msg = sv_newmortal();
3928 gv_efullname3(name = sv_newmortal(), gv, Nullch);
3929 sv_setpv(msg, "Prototype mismatch:");
3931 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
3933 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (SV *)cv);
3935 Perl_sv_catpvf(aTHX_ msg, ": none");
3936 sv_catpv(msg, " vs ");
3938 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
3940 sv_catpv(msg, "none");
3941 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
3945 static void const_sv_xsub(pTHX_ CV* cv);
3949 =head1 Optree Manipulation Functions
3951 =for apidoc cv_const_sv
3953 If C<cv> is a constant sub eligible for inlining. returns the constant
3954 value returned by the sub. Otherwise, returns NULL.
3956 Constant subs can be created with C<newCONSTSUB> or as described in
3957 L<perlsub/"Constant Functions">.
3962 Perl_cv_const_sv(pTHX_ CV *cv)
3964 if (!cv || !CvCONST(cv))
3966 return (SV*)CvXSUBANY(cv).any_ptr;
3969 /* op_const_sv: examine an optree to determine whether it's in-lineable.
3970 * Can be called in 3 ways:
3973 * look for a single OP_CONST with attached value: return the value
3975 * cv && CvCLONE(cv) && !CvCONST(cv)
3977 * examine the clone prototype, and if contains only a single
3978 * OP_CONST referencing a pad const, or a single PADSV referencing
3979 * an outer lexical, return a non-zero value to indicate the CV is
3980 * a candidate for "constizing" at clone time
3984 * We have just cloned an anon prototype that was marked as a const
3985 * candidiate. Try to grab the current value, and in the case of
3986 * PADSV, ignore it if it has multiple references. Return the value.
3990 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
3997 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
3998 o = cLISTOPo->op_first->op_sibling;
4000 for (; o; o = o->op_next) {
4001 OPCODE type = o->op_type;
4003 if (sv && o->op_next == o)
4005 if (o->op_next != o) {
4006 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4008 if (type == OP_DBSTATE)
4011 if (type == OP_LEAVESUB || type == OP_RETURN)
4015 if (type == OP_CONST && cSVOPo->op_sv)
4017 else if (cv && type == OP_CONST) {
4018 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4022 else if (cv && type == OP_PADSV) {
4023 if (CvCONST(cv)) { /* newly cloned anon */
4024 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4025 /* the candidate should have 1 ref from this pad and 1 ref
4026 * from the parent */
4027 if (!sv || SvREFCNT(sv) != 2)
4034 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4035 sv = &PL_sv_undef; /* an arbitrary non-null value */
4046 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4056 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4060 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4062 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4066 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4072 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4076 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4077 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4078 SV *sv = sv_newmortal();
4079 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4080 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4081 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4086 gv = gv_fetchpv(name ? name : (aname ? aname :
4087 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__")),
4088 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4098 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4099 maximum a prototype before. */
4100 if (SvTYPE(gv) > SVt_NULL) {
4101 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4102 && ckWARN_d(WARN_PROTOTYPE))
4104 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4106 cv_ckproto((CV*)gv, NULL, ps);
4109 sv_setpv((SV*)gv, ps);
4111 sv_setiv((SV*)gv, -1);
4112 SvREFCNT_dec(PL_compcv);
4113 cv = PL_compcv = NULL;
4114 PL_sub_generation++;
4118 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4120 #ifdef GV_UNIQUE_CHECK
4121 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4122 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4126 if (!block || !ps || *ps || attrs)
4129 const_sv = op_const_sv(block, Nullcv);
4132 bool exists = CvROOT(cv) || CvXSUB(cv);
4134 #ifdef GV_UNIQUE_CHECK
4135 if (exists && GvUNIQUE(gv)) {
4136 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4140 /* if the subroutine doesn't exist and wasn't pre-declared
4141 * with a prototype, assume it will be AUTOLOADed,
4142 * skipping the prototype check
4144 if (exists || SvPOK(cv))
4145 cv_ckproto(cv, gv, ps);
4146 /* already defined (or promised)? */
4147 if (exists || GvASSUMECV(gv)) {
4148 if (!block && !attrs) {
4149 if (CvFLAGS(PL_compcv)) {
4150 /* might have had built-in attrs applied */
4151 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4153 /* just a "sub foo;" when &foo is already defined */
4154 SAVEFREESV(PL_compcv);
4157 /* ahem, death to those who redefine active sort subs */
4158 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4159 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4161 if (ckWARN(WARN_REDEFINE)
4163 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4165 line_t oldline = CopLINE(PL_curcop);
4166 if (PL_copline != NOLINE)
4167 CopLINE_set(PL_curcop, PL_copline);
4168 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4169 CvCONST(cv) ? "Constant subroutine %s redefined"
4170 : "Subroutine %s redefined", name);
4171 CopLINE_set(PL_curcop, oldline);
4179 SvREFCNT_inc(const_sv);
4181 assert(!CvROOT(cv) && !CvCONST(cv));
4182 sv_setpv((SV*)cv, ""); /* prototype is "" */
4183 CvXSUBANY(cv).any_ptr = const_sv;
4184 CvXSUB(cv) = const_sv_xsub;
4189 cv = newCONSTSUB(NULL, name, const_sv);
4192 SvREFCNT_dec(PL_compcv);
4194 PL_sub_generation++;
4201 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4202 * before we clobber PL_compcv.
4206 /* Might have had built-in attributes applied -- propagate them. */
4207 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4208 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4209 stash = GvSTASH(CvGV(cv));
4210 else if (CvSTASH(cv))
4211 stash = CvSTASH(cv);
4213 stash = PL_curstash;
4216 /* possibly about to re-define existing subr -- ignore old cv */
4217 rcv = (SV*)PL_compcv;
4218 if (name && GvSTASH(gv))
4219 stash = GvSTASH(gv);
4221 stash = PL_curstash;
4223 apply_attrs(stash, rcv, attrs, FALSE);
4225 if (cv) { /* must reuse cv if autoloaded */
4227 /* got here with just attrs -- work done, so bug out */
4228 SAVEFREESV(PL_compcv);
4231 /* transfer PL_compcv to cv */
4233 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4234 if (!CvWEAKOUTSIDE(cv))
4235 SvREFCNT_dec(CvOUTSIDE(cv));
4236 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4237 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4238 CvOUTSIDE(PL_compcv) = 0;
4239 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4240 CvPADLIST(PL_compcv) = 0;
4241 /* inner references to PL_compcv must be fixed up ... */
4242 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4243 /* ... before we throw it away */
4244 SvREFCNT_dec(PL_compcv);
4246 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4247 ++PL_sub_generation;
4254 PL_sub_generation++;
4258 CvFILE_set_from_cop(cv, PL_curcop);
4259 CvSTASH(cv) = PL_curstash;
4262 sv_setpv((SV*)cv, ps);
4264 if (PL_error_count) {
4268 char *s = strrchr(name, ':');
4270 if (strEQ(s, "BEGIN")) {
4272 "BEGIN not safe after errors--compilation aborted";
4273 if (PL_in_eval & EVAL_KEEPERR)
4274 Perl_croak(aTHX_ not_safe);
4276 /* force display of errors found but not reported */
4277 sv_catpv(ERRSV, not_safe);
4278 Perl_croak(aTHX_ "%"SVf, ERRSV);
4287 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4288 mod(scalarseq(block), OP_LEAVESUBLV));
4291 /* This makes sub {}; work as expected. */
4292 if (block->op_type == OP_STUB) {
4294 block = newSTATEOP(0, Nullch, 0);
4296 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4298 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4299 OpREFCNT_set(CvROOT(cv), 1);
4300 CvSTART(cv) = LINKLIST(CvROOT(cv));
4301 CvROOT(cv)->op_next = 0;
4302 CALL_PEEP(CvSTART(cv));
4304 /* now that optimizer has done its work, adjust pad values */
4306 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4309 assert(!CvCONST(cv));
4310 if (ps && !*ps && op_const_sv(block, cv))
4314 if (name || aname) {
4316 char *tname = (name ? name : aname);
4318 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4319 SV *sv = NEWSV(0,0);
4320 SV *tmpstr = sv_newmortal();
4321 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4325 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4327 (long)PL_subline, (long)CopLINE(PL_curcop));
4328 gv_efullname3(tmpstr, gv, Nullch);
4329 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4330 hv = GvHVn(db_postponed);
4331 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4332 && (pcv = GvCV(db_postponed)))
4338 call_sv((SV*)pcv, G_DISCARD);
4342 if ((s = strrchr(tname,':')))
4347 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4350 if (strEQ(s, "BEGIN") && !PL_error_count) {
4351 I32 oldscope = PL_scopestack_ix;
4353 SAVECOPFILE(&PL_compiling);
4354 SAVECOPLINE(&PL_compiling);
4357 PL_beginav = newAV();
4358 DEBUG_x( dump_sub(gv) );
4359 av_push(PL_beginav, (SV*)cv);
4360 GvCV(gv) = 0; /* cv has been hijacked */
4361 call_list(oldscope, PL_beginav);
4363 PL_curcop = &PL_compiling;
4364 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4367 else if (strEQ(s, "END") && !PL_error_count) {
4370 DEBUG_x( dump_sub(gv) );
4371 av_unshift(PL_endav, 1);
4372 av_store(PL_endav, 0, (SV*)cv);
4373 GvCV(gv) = 0; /* cv has been hijacked */
4375 else if (strEQ(s, "CHECK") && !PL_error_count) {
4377 PL_checkav = newAV();
4378 DEBUG_x( dump_sub(gv) );
4379 if (PL_main_start && ckWARN(WARN_VOID))
4380 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4381 av_unshift(PL_checkav, 1);
4382 av_store(PL_checkav, 0, (SV*)cv);
4383 GvCV(gv) = 0; /* cv has been hijacked */
4385 else if (strEQ(s, "INIT") && !PL_error_count) {
4387 PL_initav = newAV();
4388 DEBUG_x( dump_sub(gv) );
4389 if (PL_main_start && ckWARN(WARN_VOID))
4390 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4391 av_push(PL_initav, (SV*)cv);
4392 GvCV(gv) = 0; /* cv has been hijacked */
4397 PL_copline = NOLINE;
4402 /* XXX unsafe for threads if eval_owner isn't held */
4404 =for apidoc newCONSTSUB
4406 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4407 eligible for inlining at compile-time.
4413 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4419 SAVECOPLINE(PL_curcop);
4420 CopLINE_set(PL_curcop, PL_copline);
4423 PL_hints &= ~HINT_BLOCK_SCOPE;
4426 SAVESPTR(PL_curstash);
4427 SAVECOPSTASH(PL_curcop);
4428 PL_curstash = stash;
4429 CopSTASH_set(PL_curcop,stash);
4432 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4433 CvXSUBANY(cv).any_ptr = sv;
4435 sv_setpv((SV*)cv, ""); /* prototype is "" */
4438 CopSTASH_free(PL_curcop);
4446 =for apidoc U||newXS
4448 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4454 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
4456 GV *gv = gv_fetchpv(name ? name :
4457 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4458 GV_ADDMULTI, SVt_PVCV);
4462 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4464 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4466 /* just a cached method */
4470 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4471 /* already defined (or promised) */
4472 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4473 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4474 line_t oldline = CopLINE(PL_curcop);
4475 if (PL_copline != NOLINE)
4476 CopLINE_set(PL_curcop, PL_copline);
4477 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4478 CvCONST(cv) ? "Constant subroutine %s redefined"
4479 : "Subroutine %s redefined"
4481 CopLINE_set(PL_curcop, oldline);
4488 if (cv) /* must reuse cv if autoloaded */
4491 cv = (CV*)NEWSV(1105,0);
4492 sv_upgrade((SV *)cv, SVt_PVCV);
4496 PL_sub_generation++;
4500 (void)gv_fetchfile(filename);
4501 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
4502 an external constant string */
4503 CvXSUB(cv) = subaddr;
4506 char *s = strrchr(name,':');
4512 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4515 if (strEQ(s, "BEGIN")) {
4517 PL_beginav = newAV();
4518 av_push(PL_beginav, (SV*)cv);
4519 GvCV(gv) = 0; /* cv has been hijacked */
4521 else if (strEQ(s, "END")) {
4524 av_unshift(PL_endav, 1);
4525 av_store(PL_endav, 0, (SV*)cv);
4526 GvCV(gv) = 0; /* cv has been hijacked */
4528 else if (strEQ(s, "CHECK")) {
4530 PL_checkav = newAV();
4531 if (PL_main_start && ckWARN(WARN_VOID))
4532 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4533 av_unshift(PL_checkav, 1);
4534 av_store(PL_checkav, 0, (SV*)cv);
4535 GvCV(gv) = 0; /* cv has been hijacked */
4537 else if (strEQ(s, "INIT")) {
4539 PL_initav = newAV();
4540 if (PL_main_start && ckWARN(WARN_VOID))
4541 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4542 av_push(PL_initav, (SV*)cv);
4543 GvCV(gv) = 0; /* cv has been hijacked */
4554 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4562 name = SvPVx(cSVOPo->op_sv, n_a);
4565 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
4566 #ifdef GV_UNIQUE_CHECK
4568 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4572 if ((cv = GvFORM(gv))) {
4573 if (ckWARN(WARN_REDEFINE)) {
4574 line_t oldline = CopLINE(PL_curcop);
4575 if (PL_copline != NOLINE)
4576 CopLINE_set(PL_curcop, PL_copline);
4577 Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Format %s redefined",name);
4578 CopLINE_set(PL_curcop, oldline);
4585 CvFILE_set_from_cop(cv, PL_curcop);
4588 pad_tidy(padtidy_FORMAT);
4589 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4590 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4591 OpREFCNT_set(CvROOT(cv), 1);
4592 CvSTART(cv) = LINKLIST(CvROOT(cv));
4593 CvROOT(cv)->op_next = 0;
4594 CALL_PEEP(CvSTART(cv));
4596 PL_copline = NOLINE;
4601 Perl_newANONLIST(pTHX_ OP *o)
4603 return newUNOP(OP_REFGEN, 0,
4604 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4608 Perl_newANONHASH(pTHX_ OP *o)
4610 return newUNOP(OP_REFGEN, 0,
4611 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4615 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4617 return newANONATTRSUB(floor, proto, Nullop, block);
4621 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4623 return newUNOP(OP_REFGEN, 0,
4624 newSVOP(OP_ANONCODE, 0,
4625 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
4629 Perl_oopsAV(pTHX_ OP *o)
4631 switch (o->op_type) {
4633 o->op_type = OP_PADAV;
4634 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4635 return ref(o, OP_RV2AV);
4638 o->op_type = OP_RV2AV;
4639 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4644 if (ckWARN_d(WARN_INTERNAL))
4645 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
4652 Perl_oopsHV(pTHX_ OP *o)
4654 switch (o->op_type) {
4657 o->op_type = OP_PADHV;
4658 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4659 return ref(o, OP_RV2HV);
4663 o->op_type = OP_RV2HV;
4664 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
4669 if (ckWARN_d(WARN_INTERNAL))
4670 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
4677 Perl_newAVREF(pTHX_ OP *o)
4679 if (o->op_type == OP_PADANY) {
4680 o->op_type = OP_PADAV;
4681 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4684 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
4685 && ckWARN(WARN_DEPRECATED)) {
4686 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4687 "Using an array as a reference is deprecated");
4689 return newUNOP(OP_RV2AV, 0, scalar(o));
4693 Perl_newGVREF(pTHX_ I32 type, OP *o)
4695 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
4696 return newUNOP(OP_NULL, 0, o);
4697 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
4701 Perl_newHVREF(pTHX_ OP *o)
4703 if (o->op_type == OP_PADANY) {
4704 o->op_type = OP_PADHV;
4705 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4708 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
4709 && ckWARN(WARN_DEPRECATED)) {
4710 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4711 "Using a hash as a reference is deprecated");
4713 return newUNOP(OP_RV2HV, 0, scalar(o));
4717 Perl_oopsCV(pTHX_ OP *o)
4719 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
4725 Perl_newCVREF(pTHX_ I32 flags, OP *o)
4727 return newUNOP(OP_RV2CV, flags, scalar(o));
4731 Perl_newSVREF(pTHX_ OP *o)
4733 if (o->op_type == OP_PADANY) {
4734 o->op_type = OP_PADSV;
4735 o->op_ppaddr = PL_ppaddr[OP_PADSV];
4738 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4739 o->op_flags |= OPpDONE_SVREF;
4742 return newUNOP(OP_RV2SV, 0, scalar(o));
4745 /* Check routines. */
4748 Perl_ck_anoncode(pTHX_ OP *o)
4750 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
4751 cSVOPo->op_sv = Nullsv;
4756 Perl_ck_bitop(pTHX_ OP *o)
4758 #define OP_IS_NUMCOMPARE(op) \
4759 ((op) == OP_LT || (op) == OP_I_LT || \
4760 (op) == OP_GT || (op) == OP_I_GT || \
4761 (op) == OP_LE || (op) == OP_I_LE || \
4762 (op) == OP_GE || (op) == OP_I_GE || \
4763 (op) == OP_EQ || (op) == OP_I_EQ || \
4764 (op) == OP_NE || (op) == OP_I_NE || \
4765 (op) == OP_NCMP || (op) == OP_I_NCMP)
4766 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4767 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
4768 && (o->op_type == OP_BIT_OR
4769 || o->op_type == OP_BIT_AND
4770 || o->op_type == OP_BIT_XOR))
4772 OP * left = cBINOPo->op_first;
4773 OP * right = left->op_sibling;
4774 if ((OP_IS_NUMCOMPARE(left->op_type) &&
4775 (left->op_flags & OPf_PARENS) == 0) ||
4776 (OP_IS_NUMCOMPARE(right->op_type) &&
4777 (right->op_flags & OPf_PARENS) == 0))
4778 if (ckWARN(WARN_PRECEDENCE))
4779 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4780 "Possible precedence problem on bitwise %c operator",
4781 o->op_type == OP_BIT_OR ? '|'
4782 : o->op_type == OP_BIT_AND ? '&' : '^'
4789 Perl_ck_concat(pTHX_ OP *o)
4791 OP *kid = cUNOPo->op_first;
4792 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
4793 !(kUNOP->op_first->op_flags & OPf_MOD))
4794 o->op_flags |= OPf_STACKED;
4799 Perl_ck_spair(pTHX_ OP *o)
4801 if (o->op_flags & OPf_KIDS) {
4804 OPCODE type = o->op_type;
4805 o = modkids(ck_fun(o), type);
4806 kid = cUNOPo->op_first;
4807 newop = kUNOP->op_first->op_sibling;
4809 (newop->op_sibling ||
4810 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
4811 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
4812 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
4816 op_free(kUNOP->op_first);
4817 kUNOP->op_first = newop;
4819 o->op_ppaddr = PL_ppaddr[++o->op_type];
4824 Perl_ck_delete(pTHX_ OP *o)
4828 if (o->op_flags & OPf_KIDS) {
4829 OP *kid = cUNOPo->op_first;
4830 switch (kid->op_type) {
4832 o->op_flags |= OPf_SPECIAL;
4835 o->op_private |= OPpSLICE;
4838 o->op_flags |= OPf_SPECIAL;
4843 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
4852 Perl_ck_die(pTHX_ OP *o)
4855 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4861 Perl_ck_eof(pTHX_ OP *o)
4863 I32 type = o->op_type;
4865 if (o->op_flags & OPf_KIDS) {
4866 if (cLISTOPo->op_first->op_type == OP_STUB) {
4868 o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
4876 Perl_ck_eval(pTHX_ OP *o)
4878 PL_hints |= HINT_BLOCK_SCOPE;
4879 if (o->op_flags & OPf_KIDS) {
4880 SVOP *kid = (SVOP*)cUNOPo->op_first;
4883 o->op_flags &= ~OPf_KIDS;
4886 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
4889 cUNOPo->op_first = 0;
4892 NewOp(1101, enter, 1, LOGOP);
4893 enter->op_type = OP_ENTERTRY;
4894 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
4895 enter->op_private = 0;
4897 /* establish postfix order */
4898 enter->op_next = (OP*)enter;
4900 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
4901 o->op_type = OP_LEAVETRY;
4902 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
4903 enter->op_other = o;
4913 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
4915 o->op_targ = (PADOFFSET)PL_hints;
4920 Perl_ck_exit(pTHX_ OP *o)
4923 HV *table = GvHV(PL_hintgv);
4925 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
4926 if (svp && *svp && SvTRUE(*svp))
4927 o->op_private |= OPpEXIT_VMSISH;
4929 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4935 Perl_ck_exec(pTHX_ OP *o)
4938 if (o->op_flags & OPf_STACKED) {
4940 kid = cUNOPo->op_first->op_sibling;
4941 if (kid->op_type == OP_RV2GV)
4950 Perl_ck_exists(pTHX_ OP *o)
4953 if (o->op_flags & OPf_KIDS) {
4954 OP *kid = cUNOPo->op_first;
4955 if (kid->op_type == OP_ENTERSUB) {
4956 (void) ref(kid, o->op_type);
4957 if (kid->op_type != OP_RV2CV && !PL_error_count)
4958 Perl_croak(aTHX_ "%s argument is not a subroutine name",
4960 o->op_private |= OPpEXISTS_SUB;
4962 else if (kid->op_type == OP_AELEM)
4963 o->op_flags |= OPf_SPECIAL;
4964 else if (kid->op_type != OP_HELEM)
4965 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
4974 Perl_ck_gvconst(pTHX_ register OP *o)
4976 o = fold_constants(o);
4977 if (o->op_type == OP_CONST)
4984 Perl_ck_rvconst(pTHX_ register OP *o)
4986 SVOP *kid = (SVOP*)cUNOPo->op_first;
4988 o->op_private |= (PL_hints & HINT_STRICT_REFS);
4989 if (kid->op_type == OP_CONST) {
4993 SV *kidsv = kid->op_sv;
4996 /* Is it a constant from cv_const_sv()? */
4997 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
4998 SV *rsv = SvRV(kidsv);
4999 int svtype = SvTYPE(rsv);
5000 char *badtype = Nullch;
5002 switch (o->op_type) {
5004 if (svtype > SVt_PVMG)
5005 badtype = "a SCALAR";
5008 if (svtype != SVt_PVAV)
5009 badtype = "an ARRAY";
5012 if (svtype != SVt_PVHV)
5016 if (svtype != SVt_PVCV)
5021 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5024 name = SvPV(kidsv, n_a);
5025 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5026 char *badthing = Nullch;
5027 switch (o->op_type) {
5029 badthing = "a SCALAR";
5032 badthing = "an ARRAY";
5035 badthing = "a HASH";
5040 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5044 * This is a little tricky. We only want to add the symbol if we
5045 * didn't add it in the lexer. Otherwise we get duplicate strict
5046 * warnings. But if we didn't add it in the lexer, we must at
5047 * least pretend like we wanted to add it even if it existed before,
5048 * or we get possible typo warnings. OPpCONST_ENTERED says
5049 * whether the lexer already added THIS instance of this symbol.
5051 iscv = (o->op_type == OP_RV2CV) * 2;
5053 gv = gv_fetchpv(name,
5054 iscv | !(kid->op_private & OPpCONST_ENTERED),
5057 : o->op_type == OP_RV2SV
5059 : o->op_type == OP_RV2AV
5061 : o->op_type == OP_RV2HV
5064 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5066 kid->op_type = OP_GV;
5067 SvREFCNT_dec(kid->op_sv);
5069 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5070 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5071 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
5073 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
5075 kid->op_sv = SvREFCNT_inc(gv);
5077 kid->op_private = 0;
5078 kid->op_ppaddr = PL_ppaddr[OP_GV];
5085 Perl_ck_ftst(pTHX_ OP *o)
5087 I32 type = o->op_type;
5089 if (o->op_flags & OPf_REF) {
5092 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5093 SVOP *kid = (SVOP*)cUNOPo->op_first;
5095 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5097 OP *newop = newGVOP(type, OPf_REF,
5098 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5104 if ((PL_hints & HINT_FILETEST_ACCESS) &&
5105 OP_IS_FILETEST_ACCESS(o))
5106 o->op_private |= OPpFT_ACCESS;
5108 if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
5109 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
5110 o->op_private |= OPpFT_STACKED;
5114 if (type == OP_FTTTY)
5115 o = newGVOP(type, OPf_REF, PL_stdingv);
5117 o = newUNOP(type, 0, newDEFSVOP());
5123 Perl_ck_fun(pTHX_ OP *o)
5129 int type = o->op_type;
5130 register I32 oa = PL_opargs[type] >> OASHIFT;
5132 if (o->op_flags & OPf_STACKED) {
5133 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5136 return no_fh_allowed(o);
5139 if (o->op_flags & OPf_KIDS) {
5141 tokid = &cLISTOPo->op_first;
5142 kid = cLISTOPo->op_first;
5143 if (kid->op_type == OP_PUSHMARK ||
5144 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5146 tokid = &kid->op_sibling;
5147 kid = kid->op_sibling;
5149 if (!kid && PL_opargs[type] & OA_DEFGV)
5150 *tokid = kid = newDEFSVOP();
5154 sibl = kid->op_sibling;
5157 /* list seen where single (scalar) arg expected? */
5158 if (numargs == 1 && !(oa >> 4)
5159 && kid->op_type == OP_LIST && type != OP_SCALAR)
5161 return too_many_arguments(o,PL_op_desc[type]);
5174 if ((type == OP_PUSH || type == OP_UNSHIFT)
5175 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5176 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5177 "Useless use of %s with no values",
5180 if (kid->op_type == OP_CONST &&
5181 (kid->op_private & OPpCONST_BARE))
5183 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5184 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5185 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5186 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5187 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5188 "Array @%s missing the @ in argument %"IVdf" of %s()",
5189 name, (IV)numargs, PL_op_desc[type]);
5192 kid->op_sibling = sibl;
5195 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5196 bad_type(numargs, "array", PL_op_desc[type], kid);
5200 if (kid->op_type == OP_CONST &&
5201 (kid->op_private & OPpCONST_BARE))
5203 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5204 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5205 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5206 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5207 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5208 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5209 name, (IV)numargs, PL_op_desc[type]);
5212 kid->op_sibling = sibl;
5215 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5216 bad_type(numargs, "hash", PL_op_desc[type], kid);
5221 OP *newop = newUNOP(OP_NULL, 0, kid);
5222 kid->op_sibling = 0;
5224 newop->op_next = newop;
5226 kid->op_sibling = sibl;
5231 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5232 if (kid->op_type == OP_CONST &&
5233 (kid->op_private & OPpCONST_BARE))
5235 OP *newop = newGVOP(OP_GV, 0,
5236 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5238 if (!(o->op_private & 1) && /* if not unop */
5239 kid == cLISTOPo->op_last)
5240 cLISTOPo->op_last = newop;
5244 else if (kid->op_type == OP_READLINE) {
5245 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5246 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5249 I32 flags = OPf_SPECIAL;
5253 /* is this op a FH constructor? */
5254 if (is_handle_constructor(o,numargs)) {
5255 char *name = Nullch;
5259 /* Set a flag to tell rv2gv to vivify
5260 * need to "prove" flag does not mean something
5261 * else already - NI-S 1999/05/07
5264 if (kid->op_type == OP_PADSV) {
5265 name = PAD_COMPNAME_PV(kid->op_targ);
5266 /* SvCUR of a pad namesv can't be trusted
5267 * (see PL_generation), so calc its length
5273 else if (kid->op_type == OP_RV2SV
5274 && kUNOP->op_first->op_type == OP_GV)
5276 GV *gv = cGVOPx_gv(kUNOP->op_first);
5278 len = GvNAMELEN(gv);
5280 else if (kid->op_type == OP_AELEM
5281 || kid->op_type == OP_HELEM)
5286 if ((op = ((BINOP*)kid)->op_first)) {
5287 SV *tmpstr = Nullsv;
5289 kid->op_type == OP_AELEM ?
5291 if (((op->op_type == OP_RV2AV) ||
5292 (op->op_type == OP_RV2HV)) &&
5293 (op = ((UNOP*)op)->op_first) &&
5294 (op->op_type == OP_GV)) {
5295 /* packagevar $a[] or $h{} */
5296 GV *gv = cGVOPx_gv(op);
5304 else if (op->op_type == OP_PADAV
5305 || op->op_type == OP_PADHV) {
5306 /* lexicalvar $a[] or $h{} */
5308 PAD_COMPNAME_PV(op->op_targ);
5318 name = SvPV(tmpstr, len);
5323 name = "__ANONIO__";
5330 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5331 namesv = PAD_SVl(targ);
5332 (void)SvUPGRADE(namesv, SVt_PV);
5334 sv_setpvn(namesv, "$", 1);
5335 sv_catpvn(namesv, name, len);
5338 kid->op_sibling = 0;
5339 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5340 kid->op_targ = targ;
5341 kid->op_private |= priv;
5343 kid->op_sibling = sibl;
5349 mod(scalar(kid), type);
5353 tokid = &kid->op_sibling;
5354 kid = kid->op_sibling;
5356 o->op_private |= numargs;
5358 return too_many_arguments(o,OP_DESC(o));
5361 else if (PL_opargs[type] & OA_DEFGV) {
5363 return newUNOP(type, 0, newDEFSVOP());
5367 while (oa & OA_OPTIONAL)
5369 if (oa && oa != OA_LIST)
5370 return too_few_arguments(o,OP_DESC(o));
5376 Perl_ck_glob(pTHX_ OP *o)
5381 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5382 append_elem(OP_GLOB, o, newDEFSVOP());
5384 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5385 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5387 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5390 #if !defined(PERL_EXTERNAL_GLOB)
5391 /* XXX this can be tightened up and made more failsafe. */
5392 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5395 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5396 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5397 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5398 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5399 GvCV(gv) = GvCV(glob_gv);
5400 SvREFCNT_inc((SV*)GvCV(gv));
5401 GvIMPORTED_CV_on(gv);
5404 #endif /* PERL_EXTERNAL_GLOB */
5406 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5407 append_elem(OP_GLOB, o,
5408 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5409 o->op_type = OP_LIST;
5410 o->op_ppaddr = PL_ppaddr[OP_LIST];
5411 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5412 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5413 cLISTOPo->op_first->op_targ = 0;
5414 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5415 append_elem(OP_LIST, o,
5416 scalar(newUNOP(OP_RV2CV, 0,
5417 newGVOP(OP_GV, 0, gv)))));
5418 o = newUNOP(OP_NULL, 0, ck_subr(o));
5419 o->op_targ = OP_GLOB; /* hint at what it used to be */
5422 gv = newGVgen("main");
5424 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5430 Perl_ck_grep(pTHX_ OP *o)
5434 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5437 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5438 NewOp(1101, gwop, 1, LOGOP);
5440 if (o->op_flags & OPf_STACKED) {
5443 kid = cLISTOPo->op_first->op_sibling;
5444 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
5447 kid->op_next = (OP*)gwop;
5448 o->op_flags &= ~OPf_STACKED;
5450 kid = cLISTOPo->op_first->op_sibling;
5451 if (type == OP_MAPWHILE)
5458 kid = cLISTOPo->op_first->op_sibling;
5459 if (kid->op_type != OP_NULL)
5460 Perl_croak(aTHX_ "panic: ck_grep");
5461 kid = kUNOP->op_first;
5463 gwop->op_type = type;
5464 gwop->op_ppaddr = PL_ppaddr[type];
5465 gwop->op_first = listkids(o);
5466 gwop->op_flags |= OPf_KIDS;
5467 gwop->op_other = LINKLIST(kid);
5468 kid->op_next = (OP*)gwop;
5469 offset = pad_findmy("$_");
5470 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
5471 o->op_private = gwop->op_private = 0;
5472 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5475 o->op_private = gwop->op_private = OPpGREP_LEX;
5476 gwop->op_targ = o->op_targ = offset;
5479 kid = cLISTOPo->op_first->op_sibling;
5480 if (!kid || !kid->op_sibling)
5481 return too_few_arguments(o,OP_DESC(o));
5482 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5483 mod(kid, OP_GREPSTART);
5489 Perl_ck_index(pTHX_ OP *o)
5491 if (o->op_flags & OPf_KIDS) {
5492 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5494 kid = kid->op_sibling; /* get past "big" */
5495 if (kid && kid->op_type == OP_CONST)
5496 fbm_compile(((SVOP*)kid)->op_sv, 0);
5502 Perl_ck_lengthconst(pTHX_ OP *o)
5504 /* XXX length optimization goes here */
5509 Perl_ck_lfun(pTHX_ OP *o)
5511 OPCODE type = o->op_type;
5512 return modkids(ck_fun(o), type);
5516 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5518 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5519 switch (cUNOPo->op_first->op_type) {
5521 /* This is needed for
5522 if (defined %stash::)
5523 to work. Do not break Tk.
5525 break; /* Globals via GV can be undef */
5527 case OP_AASSIGN: /* Is this a good idea? */
5528 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5529 "defined(@array) is deprecated");
5530 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5531 "\t(Maybe you should just omit the defined()?)\n");
5534 /* This is needed for
5535 if (defined %stash::)
5536 to work. Do not break Tk.
5538 break; /* Globals via GV can be undef */
5540 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5541 "defined(%%hash) is deprecated");
5542 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5543 "\t(Maybe you should just omit the defined()?)\n");
5554 Perl_ck_rfun(pTHX_ OP *o)
5556 OPCODE type = o->op_type;
5557 return refkids(ck_fun(o), type);
5561 Perl_ck_listiob(pTHX_ OP *o)
5565 kid = cLISTOPo->op_first;
5568 kid = cLISTOPo->op_first;
5570 if (kid->op_type == OP_PUSHMARK)
5571 kid = kid->op_sibling;
5572 if (kid && o->op_flags & OPf_STACKED)
5573 kid = kid->op_sibling;
5574 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5575 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5576 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5577 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5578 cLISTOPo->op_first->op_sibling = kid;
5579 cLISTOPo->op_last = kid;
5580 kid = kid->op_sibling;
5585 append_elem(o->op_type, o, newDEFSVOP());
5591 Perl_ck_sassign(pTHX_ OP *o)
5593 OP *kid = cLISTOPo->op_first;
5594 /* has a disposable target? */
5595 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5596 && !(kid->op_flags & OPf_STACKED)
5597 /* Cannot steal the second time! */
5598 && !(kid->op_private & OPpTARGET_MY))
5600 OP *kkid = kid->op_sibling;
5602 /* Can just relocate the target. */
5603 if (kkid && kkid->op_type == OP_PADSV
5604 && !(kkid->op_private & OPpLVAL_INTRO))
5606 kid->op_targ = kkid->op_targ;
5608 /* Now we do not need PADSV and SASSIGN. */
5609 kid->op_sibling = o->op_sibling; /* NULL */
5610 cLISTOPo->op_first = NULL;
5613 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
5617 /* optimise C<my $x = undef> to C<my $x> */
5618 if (kid->op_type == OP_UNDEF) {
5619 OP *kkid = kid->op_sibling;
5620 if (kkid && kkid->op_type == OP_PADSV
5621 && (kkid->op_private & OPpLVAL_INTRO))
5623 cLISTOPo->op_first = NULL;
5624 kid->op_sibling = NULL;
5634 Perl_ck_match(pTHX_ OP *o)
5636 if (o->op_type != OP_QR) {
5637 I32 offset = pad_findmy("$_");
5638 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS(offset) & SVpad_OUR)) {
5639 o->op_targ = offset;
5640 o->op_private |= OPpTARGET_MY;
5643 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
5644 o->op_private |= OPpRUNTIME;
5649 Perl_ck_method(pTHX_ OP *o)
5651 OP *kid = cUNOPo->op_first;
5652 if (kid->op_type == OP_CONST) {
5653 SV* sv = kSVOP->op_sv;
5654 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
5656 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5657 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
5660 kSVOP->op_sv = Nullsv;
5662 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5671 Perl_ck_null(pTHX_ OP *o)
5677 Perl_ck_open(pTHX_ OP *o)
5679 HV *table = GvHV(PL_hintgv);
5683 svp = hv_fetch(table, "open_IN", 7, FALSE);
5685 mode = mode_from_discipline(*svp);
5686 if (mode & O_BINARY)
5687 o->op_private |= OPpOPEN_IN_RAW;
5688 else if (mode & O_TEXT)
5689 o->op_private |= OPpOPEN_IN_CRLF;
5692 svp = hv_fetch(table, "open_OUT", 8, FALSE);
5694 mode = mode_from_discipline(*svp);
5695 if (mode & O_BINARY)
5696 o->op_private |= OPpOPEN_OUT_RAW;
5697 else if (mode & O_TEXT)
5698 o->op_private |= OPpOPEN_OUT_CRLF;
5701 if (o->op_type == OP_BACKTICK)
5704 /* In case of three-arg dup open remove strictness
5705 * from the last arg if it is a bareword. */
5706 OP *first = cLISTOPx(o)->op_first; /* The pushmark. */
5707 OP *last = cLISTOPx(o)->op_last; /* The bareword. */
5711 if ((last->op_type == OP_CONST) && /* The bareword. */
5712 (last->op_private & OPpCONST_BARE) &&
5713 (last->op_private & OPpCONST_STRICT) &&
5714 (oa = first->op_sibling) && /* The fh. */
5715 (oa = oa->op_sibling) && /* The mode. */
5716 SvPOK(((SVOP*)oa)->op_sv) &&
5717 (mode = SvPVX(((SVOP*)oa)->op_sv)) &&
5718 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
5719 (last == oa->op_sibling)) /* The bareword. */
5720 last->op_private &= ~OPpCONST_STRICT;
5726 Perl_ck_repeat(pTHX_ OP *o)
5728 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5729 o->op_private |= OPpREPEAT_DOLIST;
5730 cBINOPo->op_first = force_list(cBINOPo->op_first);
5738 Perl_ck_require(pTHX_ OP *o)
5742 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
5743 SVOP *kid = (SVOP*)cUNOPo->op_first;
5745 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5747 for (s = SvPVX(kid->op_sv); *s; s++) {
5748 if (*s == ':' && s[1] == ':') {
5750 Move(s+2, s+1, strlen(s+2)+1, char);
5751 --SvCUR(kid->op_sv);
5754 if (SvREADONLY(kid->op_sv)) {
5755 SvREADONLY_off(kid->op_sv);
5756 sv_catpvn(kid->op_sv, ".pm", 3);
5757 SvREADONLY_on(kid->op_sv);
5760 sv_catpvn(kid->op_sv, ".pm", 3);
5764 /* handle override, if any */
5765 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
5766 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
5767 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
5769 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5770 OP *kid = cUNOPo->op_first;
5771 cUNOPo->op_first = 0;
5773 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5774 append_elem(OP_LIST, kid,
5775 scalar(newUNOP(OP_RV2CV, 0,
5784 Perl_ck_return(pTHX_ OP *o)
5787 if (CvLVALUE(PL_compcv)) {
5788 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5789 mod(kid, OP_LEAVESUBLV);
5796 Perl_ck_retarget(pTHX_ OP *o)
5798 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5805 Perl_ck_select(pTHX_ OP *o)
5808 if (o->op_flags & OPf_KIDS) {
5809 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5810 if (kid && kid->op_sibling) {
5811 o->op_type = OP_SSELECT;
5812 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
5814 return fold_constants(o);
5818 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5819 if (kid && kid->op_type == OP_RV2GV)
5820 kid->op_private &= ~HINT_STRICT_REFS;
5825 Perl_ck_shift(pTHX_ OP *o)
5827 I32 type = o->op_type;
5829 if (!(o->op_flags & OPf_KIDS)) {
5833 argop = newUNOP(OP_RV2AV, 0,
5834 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
5835 return newUNOP(type, 0, scalar(argop));
5837 return scalar(modkids(ck_fun(o), type));
5841 Perl_ck_sort(pTHX_ OP *o)
5845 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
5847 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5848 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
5850 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
5852 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
5854 if (kid->op_type == OP_SCOPE) {
5858 else if (kid->op_type == OP_LEAVE) {
5859 if (o->op_type == OP_SORT) {
5860 op_null(kid); /* wipe out leave */
5863 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
5864 if (k->op_next == kid)
5866 /* don't descend into loops */
5867 else if (k->op_type == OP_ENTERLOOP
5868 || k->op_type == OP_ENTERITER)
5870 k = cLOOPx(k)->op_lastop;
5875 kid->op_next = 0; /* just disconnect the leave */
5876 k = kLISTOP->op_first;
5881 if (o->op_type == OP_SORT) {
5882 /* provide scalar context for comparison function/block */
5888 o->op_flags |= OPf_SPECIAL;
5890 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
5893 firstkid = firstkid->op_sibling;
5896 /* provide list context for arguments */
5897 if (o->op_type == OP_SORT)
5904 S_simplify_sort(pTHX_ OP *o)
5906 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5910 if (!(o->op_flags & OPf_STACKED))
5912 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
5913 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
5914 kid = kUNOP->op_first; /* get past null */
5915 if (kid->op_type != OP_SCOPE)
5917 kid = kLISTOP->op_last; /* get past scope */
5918 switch(kid->op_type) {
5926 k = kid; /* remember this node*/
5927 if (kBINOP->op_first->op_type != OP_RV2SV)
5929 kid = kBINOP->op_first; /* get past cmp */
5930 if (kUNOP->op_first->op_type != OP_GV)
5932 kid = kUNOP->op_first; /* get past rv2sv */
5934 if (GvSTASH(gv) != PL_curstash)
5936 if (strEQ(GvNAME(gv), "a"))
5938 else if (strEQ(GvNAME(gv), "b"))
5942 kid = k; /* back to cmp */
5943 if (kBINOP->op_last->op_type != OP_RV2SV)
5945 kid = kBINOP->op_last; /* down to 2nd arg */
5946 if (kUNOP->op_first->op_type != OP_GV)
5948 kid = kUNOP->op_first; /* get past rv2sv */
5950 if (GvSTASH(gv) != PL_curstash
5952 ? strNE(GvNAME(gv), "a")
5953 : strNE(GvNAME(gv), "b")))
5955 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
5957 o->op_private |= OPpSORT_REVERSE;
5958 if (k->op_type == OP_NCMP)
5959 o->op_private |= OPpSORT_NUMERIC;
5960 if (k->op_type == OP_I_NCMP)
5961 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
5962 kid = cLISTOPo->op_first->op_sibling;
5963 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
5964 op_free(kid); /* then delete it */
5968 Perl_ck_split(pTHX_ OP *o)
5972 if (o->op_flags & OPf_STACKED)
5973 return no_fh_allowed(o);
5975 kid = cLISTOPo->op_first;
5976 if (kid->op_type != OP_NULL)
5977 Perl_croak(aTHX_ "panic: ck_split");
5978 kid = kid->op_sibling;
5979 op_free(cLISTOPo->op_first);
5980 cLISTOPo->op_first = kid;
5982 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
5983 cLISTOPo->op_last = kid; /* There was only one element previously */
5986 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
5987 OP *sibl = kid->op_sibling;
5988 kid->op_sibling = 0;
5989 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
5990 if (cLISTOPo->op_first == cLISTOPo->op_last)
5991 cLISTOPo->op_last = kid;
5992 cLISTOPo->op_first = kid;
5993 kid->op_sibling = sibl;
5996 kid->op_type = OP_PUSHRE;
5997 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
5999 if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
6000 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
6001 "Use of /g modifier is meaningless in split");
6004 if (!kid->op_sibling)
6005 append_elem(OP_SPLIT, o, newDEFSVOP());
6007 kid = kid->op_sibling;
6010 if (!kid->op_sibling)
6011 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6013 kid = kid->op_sibling;
6016 if (kid->op_sibling)
6017 return too_many_arguments(o,OP_DESC(o));
6023 Perl_ck_join(pTHX_ OP *o)
6025 if (ckWARN(WARN_SYNTAX)) {
6026 OP *kid = cLISTOPo->op_first->op_sibling;
6027 if (kid && kid->op_type == OP_MATCH) {
6028 char *pmstr = "STRING";
6029 if (PM_GETRE(kPMOP))
6030 pmstr = PM_GETRE(kPMOP)->precomp;
6031 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6032 "/%s/ should probably be written as \"%s\"",
6040 Perl_ck_subr(pTHX_ OP *o)
6042 OP *prev = ((cUNOPo->op_first->op_sibling)
6043 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6044 OP *o2 = prev->op_sibling;
6051 I32 contextclass = 0;
6056 o->op_private |= OPpENTERSUB_HASTARG;
6057 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6058 if (cvop->op_type == OP_RV2CV) {
6060 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6061 op_null(cvop); /* disable rv2cv */
6062 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6063 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6064 GV *gv = cGVOPx_gv(tmpop);
6067 tmpop->op_private |= OPpEARLY_CV;
6070 namegv = CvANON(cv) ? gv : CvGV(cv);
6071 proto = SvPV((SV*)cv, n_a);
6073 if (CvASSERTION(cv)) {
6074 if (PL_hints & HINT_ASSERTING) {
6075 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
6076 o->op_private |= OPpENTERSUB_DB;
6080 if (ckWARN(WARN_ASSERTIONS) && !(PL_hints & HINT_ASSERTIONSSEEN)) {
6081 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
6082 "Impossible to activate assertion call");
6089 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6090 if (o2->op_type == OP_CONST)
6091 o2->op_private &= ~OPpCONST_STRICT;
6092 else if (o2->op_type == OP_LIST) {
6093 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6094 if (o && o->op_type == OP_CONST)
6095 o->op_private &= ~OPpCONST_STRICT;
6098 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6099 if (PERLDB_SUB && PL_curstash != PL_debstash)
6100 o->op_private |= OPpENTERSUB_DB;
6101 while (o2 != cvop) {
6105 return too_many_arguments(o, gv_ename(namegv));
6123 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6125 arg == 1 ? "block or sub {}" : "sub {}",
6126 gv_ename(namegv), o2);
6129 /* '*' allows any scalar type, including bareword */
6132 if (o2->op_type == OP_RV2GV)
6133 goto wrapref; /* autoconvert GLOB -> GLOBref */
6134 else if (o2->op_type == OP_CONST)
6135 o2->op_private &= ~OPpCONST_STRICT;
6136 else if (o2->op_type == OP_ENTERSUB) {
6137 /* accidental subroutine, revert to bareword */
6138 OP *gvop = ((UNOP*)o2)->op_first;
6139 if (gvop && gvop->op_type == OP_NULL) {
6140 gvop = ((UNOP*)gvop)->op_first;
6142 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6145 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6146 (gvop = ((UNOP*)gvop)->op_first) &&
6147 gvop->op_type == OP_GV)
6149 GV *gv = cGVOPx_gv(gvop);
6150 OP *sibling = o2->op_sibling;
6151 SV *n = newSVpvn("",0);
6153 gv_fullname3(n, gv, "");
6154 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6155 sv_chop(n, SvPVX(n)+6);
6156 o2 = newSVOP(OP_CONST, 0, n);
6157 prev->op_sibling = o2;
6158 o2->op_sibling = sibling;
6174 if (contextclass++ == 0) {
6175 e = strchr(proto, ']');
6176 if (!e || e == proto)
6189 while (*--p != '[');
6190 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6191 gv_ename(namegv), o2);
6197 if (o2->op_type == OP_RV2GV)
6200 bad_type(arg, "symbol", gv_ename(namegv), o2);
6203 if (o2->op_type == OP_ENTERSUB)
6206 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6209 if (o2->op_type == OP_RV2SV ||
6210 o2->op_type == OP_PADSV ||
6211 o2->op_type == OP_HELEM ||
6212 o2->op_type == OP_AELEM ||
6213 o2->op_type == OP_THREADSV)
6216 bad_type(arg, "scalar", gv_ename(namegv), o2);
6219 if (o2->op_type == OP_RV2AV ||
6220 o2->op_type == OP_PADAV)
6223 bad_type(arg, "array", gv_ename(namegv), o2);
6226 if (o2->op_type == OP_RV2HV ||
6227 o2->op_type == OP_PADHV)
6230 bad_type(arg, "hash", gv_ename(namegv), o2);
6235 OP* sib = kid->op_sibling;
6236 kid->op_sibling = 0;
6237 o2 = newUNOP(OP_REFGEN, 0, kid);
6238 o2->op_sibling = sib;
6239 prev->op_sibling = o2;
6241 if (contextclass && e) {
6256 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6257 gv_ename(namegv), cv);
6262 mod(o2, OP_ENTERSUB);
6264 o2 = o2->op_sibling;
6266 if (proto && !optional &&
6267 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6268 return too_few_arguments(o, gv_ename(namegv));
6271 o=newSVOP(OP_CONST, 0, newSViv(0));
6277 Perl_ck_svconst(pTHX_ OP *o)
6279 SvREADONLY_on(cSVOPo->op_sv);
6284 Perl_ck_trunc(pTHX_ OP *o)
6286 if (o->op_flags & OPf_KIDS) {
6287 SVOP *kid = (SVOP*)cUNOPo->op_first;
6289 if (kid->op_type == OP_NULL)
6290 kid = (SVOP*)kid->op_sibling;
6291 if (kid && kid->op_type == OP_CONST &&
6292 (kid->op_private & OPpCONST_BARE))
6294 o->op_flags |= OPf_SPECIAL;
6295 kid->op_private &= ~OPpCONST_STRICT;
6302 Perl_ck_unpack(pTHX_ OP *o)
6304 OP *kid = cLISTOPo->op_first;
6305 if (kid->op_sibling) {
6306 kid = kid->op_sibling;
6307 if (!kid->op_sibling)
6308 kid->op_sibling = newDEFSVOP();
6314 Perl_ck_substr(pTHX_ OP *o)
6317 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6318 OP *kid = cLISTOPo->op_first;
6320 if (kid->op_type == OP_NULL)
6321 kid = kid->op_sibling;
6323 kid->op_flags |= OPf_MOD;
6329 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6332 Perl_peep(pTHX_ register OP *o)
6334 register OP* oldop = 0;
6336 if (!o || o->op_opt)
6340 SAVEVPTR(PL_curcop);
6341 for (; o; o = o->op_next) {
6345 switch (o->op_type) {
6349 PL_curcop = ((COP*)o); /* for warnings */
6354 if (cSVOPo->op_private & OPpCONST_STRICT)
6355 no_bareword_allowed(o);
6357 case OP_METHOD_NAMED:
6358 /* Relocate sv to the pad for thread safety.
6359 * Despite being a "constant", the SV is written to,
6360 * for reference counts, sv_upgrade() etc. */
6362 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6363 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6364 /* If op_sv is already a PADTMP then it is being used by
6365 * some pad, so make a copy. */
6366 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6367 SvREADONLY_on(PAD_SVl(ix));
6368 SvREFCNT_dec(cSVOPo->op_sv);
6371 SvREFCNT_dec(PAD_SVl(ix));
6372 SvPADTMP_on(cSVOPo->op_sv);
6373 PAD_SETSV(ix, cSVOPo->op_sv);
6374 /* XXX I don't know how this isn't readonly already. */
6375 SvREADONLY_on(PAD_SVl(ix));
6377 cSVOPo->op_sv = Nullsv;
6385 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6386 if (o->op_next->op_private & OPpTARGET_MY) {
6387 if (o->op_flags & OPf_STACKED) /* chained concats */
6388 goto ignore_optimization;
6390 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6391 o->op_targ = o->op_next->op_targ;
6392 o->op_next->op_targ = 0;
6393 o->op_private |= OPpTARGET_MY;
6396 op_null(o->op_next);
6398 ignore_optimization:
6402 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6404 break; /* Scalar stub must produce undef. List stub is noop */
6408 if (o->op_targ == OP_NEXTSTATE
6409 || o->op_targ == OP_DBSTATE
6410 || o->op_targ == OP_SETSTATE)
6412 PL_curcop = ((COP*)o);
6414 /* XXX: We avoid setting op_seq here to prevent later calls
6415 to peep() from mistakenly concluding that optimisation
6416 has already occurred. This doesn't fix the real problem,
6417 though (See 20010220.007). AMS 20010719 */
6418 /* op_seq functionality is now replaced by op_opt */
6419 if (oldop && o->op_next) {
6420 oldop->op_next = o->op_next;
6428 if (oldop && o->op_next) {
6429 oldop->op_next = o->op_next;
6437 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
6438 OP* pop = (o->op_type == OP_PADAV) ?
6439 o->op_next : o->op_next->op_next;
6441 if (pop && pop->op_type == OP_CONST &&
6442 ((PL_op = pop->op_next)) &&
6443 pop->op_next->op_type == OP_AELEM &&
6444 !(pop->op_next->op_private &
6445 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6446 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6451 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
6452 no_bareword_allowed(pop);
6453 if (o->op_type == OP_GV)
6454 op_null(o->op_next);
6455 op_null(pop->op_next);
6457 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6458 o->op_next = pop->op_next->op_next;
6459 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6460 o->op_private = (U8)i;
6461 if (o->op_type == OP_GV) {
6466 o->op_flags |= OPf_SPECIAL;
6467 o->op_type = OP_AELEMFAST;
6473 if (o->op_next->op_type == OP_RV2SV) {
6474 if (!(o->op_next->op_private & OPpDEREF)) {
6475 op_null(o->op_next);
6476 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6478 o->op_next = o->op_next->op_next;
6479 o->op_type = OP_GVSV;
6480 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6483 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6485 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6486 /* XXX could check prototype here instead of just carping */
6487 SV *sv = sv_newmortal();
6488 gv_efullname3(sv, gv, Nullch);
6489 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6490 "%"SVf"() called too early to check prototype",
6494 else if (o->op_next->op_type == OP_READLINE
6495 && o->op_next->op_next->op_type == OP_CONCAT
6496 && (o->op_next->op_next->op_flags & OPf_STACKED))
6498 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6499 o->op_type = OP_RCATLINE;
6500 o->op_flags |= OPf_STACKED;
6501 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6502 op_null(o->op_next->op_next);
6503 op_null(o->op_next);
6520 while (cLOGOP->op_other->op_type == OP_NULL)
6521 cLOGOP->op_other = cLOGOP->op_other->op_next;
6522 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6528 while (cLOOP->op_redoop->op_type == OP_NULL)
6529 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6530 peep(cLOOP->op_redoop);
6531 while (cLOOP->op_nextop->op_type == OP_NULL)
6532 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6533 peep(cLOOP->op_nextop);
6534 while (cLOOP->op_lastop->op_type == OP_NULL)
6535 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6536 peep(cLOOP->op_lastop);
6543 while (cPMOP->op_pmreplstart &&
6544 cPMOP->op_pmreplstart->op_type == OP_NULL)
6545 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6546 peep(cPMOP->op_pmreplstart);
6551 if (ckWARN(WARN_SYNTAX) && o->op_next
6552 && o->op_next->op_type == OP_NEXTSTATE) {
6553 if (o->op_next->op_sibling &&
6554 o->op_next->op_sibling->op_type != OP_EXIT &&
6555 o->op_next->op_sibling->op_type != OP_WARN &&
6556 o->op_next->op_sibling->op_type != OP_DIE) {
6557 line_t oldline = CopLINE(PL_curcop);
6559 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6560 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6561 "Statement unlikely to be reached");
6562 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6563 "\t(Maybe you meant system() when you said exec()?)\n");
6564 CopLINE_set(PL_curcop, oldline);
6577 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6580 /* Make the CONST have a shared SV */
6581 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6582 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6583 key = SvPV(sv, keylen);
6584 lexname = newSVpvn_share(key,
6585 SvUTF8(sv) ? -(I32)keylen : keylen,
6594 /* make @a = sort @a act in-place */
6596 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
6602 /* check that RHS of sort is a single plain array */
6603 oright = cUNOPo->op_first;
6604 if (!oright || oright->op_type != OP_PUSHMARK)
6606 oright = cUNOPx(oright)->op_sibling;
6609 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
6610 oright = cUNOPx(oright)->op_sibling;
6614 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
6615 || oright->op_next != o
6616 || (oright->op_private & OPpLVAL_INTRO)
6620 /* o2 follows the chain of op_nexts through the LHS of the
6621 * assign (if any) to the aassign op itself */
6623 if (!o2 || o2->op_type != OP_NULL)
6626 if (!o2 || o2->op_type != OP_PUSHMARK)
6629 if (o2 && o2->op_type == OP_GV)
6632 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
6633 || (o2->op_private & OPpLVAL_INTRO)
6638 if (!o2 || o2->op_type != OP_NULL)
6641 if (!o2 || o2->op_type != OP_AASSIGN
6642 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
6645 /* check the array is the same on both sides */
6646 if (oleft->op_type == OP_RV2AV) {
6647 if (oright->op_type != OP_RV2AV
6648 || !cUNOPx(oright)->op_first
6649 || cUNOPx(oright)->op_first->op_type != OP_GV
6650 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
6651 cGVOPx_gv(cUNOPx(oright)->op_first)
6655 else if (oright->op_type != OP_PADAV
6656 || oright->op_targ != oleft->op_targ
6660 /* transfer MODishness etc from LHS arg to RHS arg */
6661 oright->op_flags = oleft->op_flags;
6662 o->op_private |= OPpSORT_INPLACE;
6664 /* excise push->gv->rv2av->null->aassign */
6665 o2 = o->op_next->op_next;
6666 op_null(o2); /* PUSHMARK */
6668 if (o2->op_type == OP_GV) {
6669 op_null(o2); /* GV */
6672 op_null(o2); /* RV2AV or PADAV */
6673 o2 = o2->op_next->op_next;
6674 op_null(o2); /* AASSIGN */
6676 o->op_next = o2->op_next;
6694 char* Perl_custom_op_name(pTHX_ OP* o)
6696 IV index = PTR2IV(o->op_ppaddr);
6700 if (!PL_custom_op_names) /* This probably shouldn't happen */
6701 return PL_op_name[OP_CUSTOM];
6703 keysv = sv_2mortal(newSViv(index));
6705 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
6707 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
6709 return SvPV_nolen(HeVAL(he));
6712 char* Perl_custom_op_desc(pTHX_ OP* o)
6714 IV index = PTR2IV(o->op_ppaddr);
6718 if (!PL_custom_op_descs)
6719 return PL_op_desc[OP_CUSTOM];
6721 keysv = sv_2mortal(newSViv(index));
6723 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
6725 return PL_op_desc[OP_CUSTOM];
6727 return SvPV_nolen(HeVAL(he));
6733 /* Efficient sub that returns a constant scalar value. */
6735 const_sv_xsub(pTHX_ CV* cv)
6740 Perl_croak(aTHX_ "usage: %s::%s()",
6741 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
6745 ST(0) = (SV*)XSANY.any_ptr;