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)
4076 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4079 assert(proto->op_type == OP_CONST);
4080 ps = SvPVx(((SVOP*)proto)->op_sv, n_a);
4085 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4086 SV *sv = sv_newmortal();
4087 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4088 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4089 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4094 gv = gv_fetchpv(name ? name : (aname ? aname :
4095 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__")),
4096 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4106 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4107 maximum a prototype before. */
4108 if (SvTYPE(gv) > SVt_NULL) {
4109 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4110 && ckWARN_d(WARN_PROTOTYPE))
4112 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4114 cv_ckproto((CV*)gv, NULL, ps);
4117 sv_setpv((SV*)gv, ps);
4119 sv_setiv((SV*)gv, -1);
4120 SvREFCNT_dec(PL_compcv);
4121 cv = PL_compcv = NULL;
4122 PL_sub_generation++;
4126 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4128 #ifdef GV_UNIQUE_CHECK
4129 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4130 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4134 if (!block || !ps || *ps || attrs)
4137 const_sv = op_const_sv(block, Nullcv);
4140 bool exists = CvROOT(cv) || CvXSUB(cv);
4142 #ifdef GV_UNIQUE_CHECK
4143 if (exists && GvUNIQUE(gv)) {
4144 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4148 /* if the subroutine doesn't exist and wasn't pre-declared
4149 * with a prototype, assume it will be AUTOLOADed,
4150 * skipping the prototype check
4152 if (exists || SvPOK(cv))
4153 cv_ckproto(cv, gv, ps);
4154 /* already defined (or promised)? */
4155 if (exists || GvASSUMECV(gv)) {
4156 if (!block && !attrs) {
4157 if (CvFLAGS(PL_compcv)) {
4158 /* might have had built-in attrs applied */
4159 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4161 /* just a "sub foo;" when &foo is already defined */
4162 SAVEFREESV(PL_compcv);
4165 /* ahem, death to those who redefine active sort subs */
4166 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4167 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4169 if (ckWARN(WARN_REDEFINE)
4171 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4173 line_t oldline = CopLINE(PL_curcop);
4174 if (PL_copline != NOLINE)
4175 CopLINE_set(PL_curcop, PL_copline);
4176 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4177 CvCONST(cv) ? "Constant subroutine %s redefined"
4178 : "Subroutine %s redefined", name);
4179 CopLINE_set(PL_curcop, oldline);
4187 SvREFCNT_inc(const_sv);
4189 assert(!CvROOT(cv) && !CvCONST(cv));
4190 sv_setpv((SV*)cv, ""); /* prototype is "" */
4191 CvXSUBANY(cv).any_ptr = const_sv;
4192 CvXSUB(cv) = const_sv_xsub;
4197 cv = newCONSTSUB(NULL, name, const_sv);
4200 SvREFCNT_dec(PL_compcv);
4202 PL_sub_generation++;
4209 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4210 * before we clobber PL_compcv.
4214 /* Might have had built-in attributes applied -- propagate them. */
4215 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4216 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4217 stash = GvSTASH(CvGV(cv));
4218 else if (CvSTASH(cv))
4219 stash = CvSTASH(cv);
4221 stash = PL_curstash;
4224 /* possibly about to re-define existing subr -- ignore old cv */
4225 rcv = (SV*)PL_compcv;
4226 if (name && GvSTASH(gv))
4227 stash = GvSTASH(gv);
4229 stash = PL_curstash;
4231 apply_attrs(stash, rcv, attrs, FALSE);
4233 if (cv) { /* must reuse cv if autoloaded */
4235 /* got here with just attrs -- work done, so bug out */
4236 SAVEFREESV(PL_compcv);
4239 /* transfer PL_compcv to cv */
4241 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4242 if (!CvWEAKOUTSIDE(cv))
4243 SvREFCNT_dec(CvOUTSIDE(cv));
4244 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4245 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4246 CvOUTSIDE(PL_compcv) = 0;
4247 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4248 CvPADLIST(PL_compcv) = 0;
4249 /* inner references to PL_compcv must be fixed up ... */
4250 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4251 /* ... before we throw it away */
4252 SvREFCNT_dec(PL_compcv);
4254 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4255 ++PL_sub_generation;
4262 PL_sub_generation++;
4266 CvFILE_set_from_cop(cv, PL_curcop);
4267 CvSTASH(cv) = PL_curstash;
4270 sv_setpv((SV*)cv, ps);
4272 if (PL_error_count) {
4276 char *s = strrchr(name, ':');
4278 if (strEQ(s, "BEGIN")) {
4280 "BEGIN not safe after errors--compilation aborted";
4281 if (PL_in_eval & EVAL_KEEPERR)
4282 Perl_croak(aTHX_ not_safe);
4284 /* force display of errors found but not reported */
4285 sv_catpv(ERRSV, not_safe);
4286 Perl_croak(aTHX_ "%"SVf, ERRSV);
4295 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4296 mod(scalarseq(block), OP_LEAVESUBLV));
4299 /* This makes sub {}; work as expected. */
4300 if (block->op_type == OP_STUB) {
4302 block = newSTATEOP(0, Nullch, 0);
4304 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4306 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4307 OpREFCNT_set(CvROOT(cv), 1);
4308 CvSTART(cv) = LINKLIST(CvROOT(cv));
4309 CvROOT(cv)->op_next = 0;
4310 CALL_PEEP(CvSTART(cv));
4312 /* now that optimizer has done its work, adjust pad values */
4314 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4317 assert(!CvCONST(cv));
4318 if (ps && !*ps && op_const_sv(block, cv))
4322 if (name || aname) {
4324 char *tname = (name ? name : aname);
4326 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4327 SV *sv = NEWSV(0,0);
4328 SV *tmpstr = sv_newmortal();
4329 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4333 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4335 (long)PL_subline, (long)CopLINE(PL_curcop));
4336 gv_efullname3(tmpstr, gv, Nullch);
4337 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4338 hv = GvHVn(db_postponed);
4339 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4340 && (pcv = GvCV(db_postponed)))
4346 call_sv((SV*)pcv, G_DISCARD);
4350 if ((s = strrchr(tname,':')))
4355 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4358 if (strEQ(s, "BEGIN") && !PL_error_count) {
4359 I32 oldscope = PL_scopestack_ix;
4361 SAVECOPFILE(&PL_compiling);
4362 SAVECOPLINE(&PL_compiling);
4365 PL_beginav = newAV();
4366 DEBUG_x( dump_sub(gv) );
4367 av_push(PL_beginav, (SV*)cv);
4368 GvCV(gv) = 0; /* cv has been hijacked */
4369 call_list(oldscope, PL_beginav);
4371 PL_curcop = &PL_compiling;
4372 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4375 else if (strEQ(s, "END") && !PL_error_count) {
4378 DEBUG_x( dump_sub(gv) );
4379 av_unshift(PL_endav, 1);
4380 av_store(PL_endav, 0, (SV*)cv);
4381 GvCV(gv) = 0; /* cv has been hijacked */
4383 else if (strEQ(s, "CHECK") && !PL_error_count) {
4385 PL_checkav = newAV();
4386 DEBUG_x( dump_sub(gv) );
4387 if (PL_main_start && ckWARN(WARN_VOID))
4388 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4389 av_unshift(PL_checkav, 1);
4390 av_store(PL_checkav, 0, (SV*)cv);
4391 GvCV(gv) = 0; /* cv has been hijacked */
4393 else if (strEQ(s, "INIT") && !PL_error_count) {
4395 PL_initav = newAV();
4396 DEBUG_x( dump_sub(gv) );
4397 if (PL_main_start && ckWARN(WARN_VOID))
4398 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4399 av_push(PL_initav, (SV*)cv);
4400 GvCV(gv) = 0; /* cv has been hijacked */
4405 PL_copline = NOLINE;
4410 /* XXX unsafe for threads if eval_owner isn't held */
4412 =for apidoc newCONSTSUB
4414 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4415 eligible for inlining at compile-time.
4421 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4427 SAVECOPLINE(PL_curcop);
4428 CopLINE_set(PL_curcop, PL_copline);
4431 PL_hints &= ~HINT_BLOCK_SCOPE;
4434 SAVESPTR(PL_curstash);
4435 SAVECOPSTASH(PL_curcop);
4436 PL_curstash = stash;
4437 CopSTASH_set(PL_curcop,stash);
4440 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4441 CvXSUBANY(cv).any_ptr = sv;
4443 sv_setpv((SV*)cv, ""); /* prototype is "" */
4446 CopSTASH_free(PL_curcop);
4454 =for apidoc U||newXS
4456 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4462 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
4464 GV *gv = gv_fetchpv(name ? name :
4465 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4466 GV_ADDMULTI, SVt_PVCV);
4470 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4472 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4474 /* just a cached method */
4478 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4479 /* already defined (or promised) */
4480 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4481 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4482 line_t oldline = CopLINE(PL_curcop);
4483 if (PL_copline != NOLINE)
4484 CopLINE_set(PL_curcop, PL_copline);
4485 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4486 CvCONST(cv) ? "Constant subroutine %s redefined"
4487 : "Subroutine %s redefined"
4489 CopLINE_set(PL_curcop, oldline);
4496 if (cv) /* must reuse cv if autoloaded */
4499 cv = (CV*)NEWSV(1105,0);
4500 sv_upgrade((SV *)cv, SVt_PVCV);
4504 PL_sub_generation++;
4508 (void)gv_fetchfile(filename);
4509 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
4510 an external constant string */
4511 CvXSUB(cv) = subaddr;
4514 char *s = strrchr(name,':');
4520 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4523 if (strEQ(s, "BEGIN")) {
4525 PL_beginav = newAV();
4526 av_push(PL_beginav, (SV*)cv);
4527 GvCV(gv) = 0; /* cv has been hijacked */
4529 else if (strEQ(s, "END")) {
4532 av_unshift(PL_endav, 1);
4533 av_store(PL_endav, 0, (SV*)cv);
4534 GvCV(gv) = 0; /* cv has been hijacked */
4536 else if (strEQ(s, "CHECK")) {
4538 PL_checkav = newAV();
4539 if (PL_main_start && ckWARN(WARN_VOID))
4540 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4541 av_unshift(PL_checkav, 1);
4542 av_store(PL_checkav, 0, (SV*)cv);
4543 GvCV(gv) = 0; /* cv has been hijacked */
4545 else if (strEQ(s, "INIT")) {
4547 PL_initav = newAV();
4548 if (PL_main_start && ckWARN(WARN_VOID))
4549 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4550 av_push(PL_initav, (SV*)cv);
4551 GvCV(gv) = 0; /* cv has been hijacked */
4562 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4570 name = SvPVx(cSVOPo->op_sv, n_a);
4573 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
4574 #ifdef GV_UNIQUE_CHECK
4576 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4580 if ((cv = GvFORM(gv))) {
4581 if (ckWARN(WARN_REDEFINE)) {
4582 line_t oldline = CopLINE(PL_curcop);
4583 if (PL_copline != NOLINE)
4584 CopLINE_set(PL_curcop, PL_copline);
4585 Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Format %s redefined",name);
4586 CopLINE_set(PL_curcop, oldline);
4593 CvFILE_set_from_cop(cv, PL_curcop);
4596 pad_tidy(padtidy_FORMAT);
4597 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4598 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4599 OpREFCNT_set(CvROOT(cv), 1);
4600 CvSTART(cv) = LINKLIST(CvROOT(cv));
4601 CvROOT(cv)->op_next = 0;
4602 CALL_PEEP(CvSTART(cv));
4604 PL_copline = NOLINE;
4609 Perl_newANONLIST(pTHX_ OP *o)
4611 return newUNOP(OP_REFGEN, 0,
4612 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4616 Perl_newANONHASH(pTHX_ OP *o)
4618 return newUNOP(OP_REFGEN, 0,
4619 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4623 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4625 return newANONATTRSUB(floor, proto, Nullop, block);
4629 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4631 return newUNOP(OP_REFGEN, 0,
4632 newSVOP(OP_ANONCODE, 0,
4633 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
4637 Perl_oopsAV(pTHX_ OP *o)
4639 switch (o->op_type) {
4641 o->op_type = OP_PADAV;
4642 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4643 return ref(o, OP_RV2AV);
4646 o->op_type = OP_RV2AV;
4647 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4652 if (ckWARN_d(WARN_INTERNAL))
4653 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
4660 Perl_oopsHV(pTHX_ OP *o)
4662 switch (o->op_type) {
4665 o->op_type = OP_PADHV;
4666 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4667 return ref(o, OP_RV2HV);
4671 o->op_type = OP_RV2HV;
4672 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
4677 if (ckWARN_d(WARN_INTERNAL))
4678 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
4685 Perl_newAVREF(pTHX_ OP *o)
4687 if (o->op_type == OP_PADANY) {
4688 o->op_type = OP_PADAV;
4689 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4692 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
4693 && ckWARN(WARN_DEPRECATED)) {
4694 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4695 "Using an array as a reference is deprecated");
4697 return newUNOP(OP_RV2AV, 0, scalar(o));
4701 Perl_newGVREF(pTHX_ I32 type, OP *o)
4703 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
4704 return newUNOP(OP_NULL, 0, o);
4705 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
4709 Perl_newHVREF(pTHX_ OP *o)
4711 if (o->op_type == OP_PADANY) {
4712 o->op_type = OP_PADHV;
4713 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4716 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
4717 && ckWARN(WARN_DEPRECATED)) {
4718 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4719 "Using a hash as a reference is deprecated");
4721 return newUNOP(OP_RV2HV, 0, scalar(o));
4725 Perl_oopsCV(pTHX_ OP *o)
4727 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
4733 Perl_newCVREF(pTHX_ I32 flags, OP *o)
4735 return newUNOP(OP_RV2CV, flags, scalar(o));
4739 Perl_newSVREF(pTHX_ OP *o)
4741 if (o->op_type == OP_PADANY) {
4742 o->op_type = OP_PADSV;
4743 o->op_ppaddr = PL_ppaddr[OP_PADSV];
4746 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4747 o->op_flags |= OPpDONE_SVREF;
4750 return newUNOP(OP_RV2SV, 0, scalar(o));
4753 /* Check routines. */
4756 Perl_ck_anoncode(pTHX_ OP *o)
4758 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
4759 cSVOPo->op_sv = Nullsv;
4764 Perl_ck_bitop(pTHX_ OP *o)
4766 #define OP_IS_NUMCOMPARE(op) \
4767 ((op) == OP_LT || (op) == OP_I_LT || \
4768 (op) == OP_GT || (op) == OP_I_GT || \
4769 (op) == OP_LE || (op) == OP_I_LE || \
4770 (op) == OP_GE || (op) == OP_I_GE || \
4771 (op) == OP_EQ || (op) == OP_I_EQ || \
4772 (op) == OP_NE || (op) == OP_I_NE || \
4773 (op) == OP_NCMP || (op) == OP_I_NCMP)
4774 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4775 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
4776 && (o->op_type == OP_BIT_OR
4777 || o->op_type == OP_BIT_AND
4778 || o->op_type == OP_BIT_XOR))
4780 OP * left = cBINOPo->op_first;
4781 OP * right = left->op_sibling;
4782 if ((OP_IS_NUMCOMPARE(left->op_type) &&
4783 (left->op_flags & OPf_PARENS) == 0) ||
4784 (OP_IS_NUMCOMPARE(right->op_type) &&
4785 (right->op_flags & OPf_PARENS) == 0))
4786 if (ckWARN(WARN_PRECEDENCE))
4787 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4788 "Possible precedence problem on bitwise %c operator",
4789 o->op_type == OP_BIT_OR ? '|'
4790 : o->op_type == OP_BIT_AND ? '&' : '^'
4797 Perl_ck_concat(pTHX_ OP *o)
4799 OP *kid = cUNOPo->op_first;
4800 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
4801 !(kUNOP->op_first->op_flags & OPf_MOD))
4802 o->op_flags |= OPf_STACKED;
4807 Perl_ck_spair(pTHX_ OP *o)
4809 if (o->op_flags & OPf_KIDS) {
4812 OPCODE type = o->op_type;
4813 o = modkids(ck_fun(o), type);
4814 kid = cUNOPo->op_first;
4815 newop = kUNOP->op_first->op_sibling;
4817 (newop->op_sibling ||
4818 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
4819 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
4820 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
4824 op_free(kUNOP->op_first);
4825 kUNOP->op_first = newop;
4827 o->op_ppaddr = PL_ppaddr[++o->op_type];
4832 Perl_ck_delete(pTHX_ OP *o)
4836 if (o->op_flags & OPf_KIDS) {
4837 OP *kid = cUNOPo->op_first;
4838 switch (kid->op_type) {
4840 o->op_flags |= OPf_SPECIAL;
4843 o->op_private |= OPpSLICE;
4846 o->op_flags |= OPf_SPECIAL;
4851 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
4860 Perl_ck_die(pTHX_ OP *o)
4863 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4869 Perl_ck_eof(pTHX_ OP *o)
4871 I32 type = o->op_type;
4873 if (o->op_flags & OPf_KIDS) {
4874 if (cLISTOPo->op_first->op_type == OP_STUB) {
4876 o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
4884 Perl_ck_eval(pTHX_ OP *o)
4886 PL_hints |= HINT_BLOCK_SCOPE;
4887 if (o->op_flags & OPf_KIDS) {
4888 SVOP *kid = (SVOP*)cUNOPo->op_first;
4891 o->op_flags &= ~OPf_KIDS;
4894 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
4897 cUNOPo->op_first = 0;
4900 NewOp(1101, enter, 1, LOGOP);
4901 enter->op_type = OP_ENTERTRY;
4902 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
4903 enter->op_private = 0;
4905 /* establish postfix order */
4906 enter->op_next = (OP*)enter;
4908 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
4909 o->op_type = OP_LEAVETRY;
4910 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
4911 enter->op_other = o;
4921 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
4923 o->op_targ = (PADOFFSET)PL_hints;
4928 Perl_ck_exit(pTHX_ OP *o)
4931 HV *table = GvHV(PL_hintgv);
4933 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
4934 if (svp && *svp && SvTRUE(*svp))
4935 o->op_private |= OPpEXIT_VMSISH;
4937 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4943 Perl_ck_exec(pTHX_ OP *o)
4946 if (o->op_flags & OPf_STACKED) {
4948 kid = cUNOPo->op_first->op_sibling;
4949 if (kid->op_type == OP_RV2GV)
4958 Perl_ck_exists(pTHX_ OP *o)
4961 if (o->op_flags & OPf_KIDS) {
4962 OP *kid = cUNOPo->op_first;
4963 if (kid->op_type == OP_ENTERSUB) {
4964 (void) ref(kid, o->op_type);
4965 if (kid->op_type != OP_RV2CV && !PL_error_count)
4966 Perl_croak(aTHX_ "%s argument is not a subroutine name",
4968 o->op_private |= OPpEXISTS_SUB;
4970 else if (kid->op_type == OP_AELEM)
4971 o->op_flags |= OPf_SPECIAL;
4972 else if (kid->op_type != OP_HELEM)
4973 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
4982 Perl_ck_gvconst(pTHX_ register OP *o)
4984 o = fold_constants(o);
4985 if (o->op_type == OP_CONST)
4992 Perl_ck_rvconst(pTHX_ register OP *o)
4994 SVOP *kid = (SVOP*)cUNOPo->op_first;
4996 o->op_private |= (PL_hints & HINT_STRICT_REFS);
4997 if (kid->op_type == OP_CONST) {
5001 SV *kidsv = kid->op_sv;
5004 /* Is it a constant from cv_const_sv()? */
5005 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5006 SV *rsv = SvRV(kidsv);
5007 int svtype = SvTYPE(rsv);
5008 char *badtype = Nullch;
5010 switch (o->op_type) {
5012 if (svtype > SVt_PVMG)
5013 badtype = "a SCALAR";
5016 if (svtype != SVt_PVAV)
5017 badtype = "an ARRAY";
5020 if (svtype != SVt_PVHV)
5024 if (svtype != SVt_PVCV)
5029 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5032 name = SvPV(kidsv, n_a);
5033 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5034 char *badthing = Nullch;
5035 switch (o->op_type) {
5037 badthing = "a SCALAR";
5040 badthing = "an ARRAY";
5043 badthing = "a HASH";
5048 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5052 * This is a little tricky. We only want to add the symbol if we
5053 * didn't add it in the lexer. Otherwise we get duplicate strict
5054 * warnings. But if we didn't add it in the lexer, we must at
5055 * least pretend like we wanted to add it even if it existed before,
5056 * or we get possible typo warnings. OPpCONST_ENTERED says
5057 * whether the lexer already added THIS instance of this symbol.
5059 iscv = (o->op_type == OP_RV2CV) * 2;
5061 gv = gv_fetchpv(name,
5062 iscv | !(kid->op_private & OPpCONST_ENTERED),
5065 : o->op_type == OP_RV2SV
5067 : o->op_type == OP_RV2AV
5069 : o->op_type == OP_RV2HV
5072 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5074 kid->op_type = OP_GV;
5075 SvREFCNT_dec(kid->op_sv);
5077 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5078 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5079 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
5081 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
5083 kid->op_sv = SvREFCNT_inc(gv);
5085 kid->op_private = 0;
5086 kid->op_ppaddr = PL_ppaddr[OP_GV];
5093 Perl_ck_ftst(pTHX_ OP *o)
5095 I32 type = o->op_type;
5097 if (o->op_flags & OPf_REF) {
5100 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5101 SVOP *kid = (SVOP*)cUNOPo->op_first;
5103 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5105 OP *newop = newGVOP(type, OPf_REF,
5106 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5112 if ((PL_hints & HINT_FILETEST_ACCESS) &&
5113 OP_IS_FILETEST_ACCESS(o))
5114 o->op_private |= OPpFT_ACCESS;
5116 if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
5117 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
5118 o->op_private |= OPpFT_STACKED;
5122 if (type == OP_FTTTY)
5123 o = newGVOP(type, OPf_REF, PL_stdingv);
5125 o = newUNOP(type, 0, newDEFSVOP());
5131 Perl_ck_fun(pTHX_ OP *o)
5137 int type = o->op_type;
5138 register I32 oa = PL_opargs[type] >> OASHIFT;
5140 if (o->op_flags & OPf_STACKED) {
5141 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5144 return no_fh_allowed(o);
5147 if (o->op_flags & OPf_KIDS) {
5149 tokid = &cLISTOPo->op_first;
5150 kid = cLISTOPo->op_first;
5151 if (kid->op_type == OP_PUSHMARK ||
5152 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5154 tokid = &kid->op_sibling;
5155 kid = kid->op_sibling;
5157 if (!kid && PL_opargs[type] & OA_DEFGV)
5158 *tokid = kid = newDEFSVOP();
5162 sibl = kid->op_sibling;
5165 /* list seen where single (scalar) arg expected? */
5166 if (numargs == 1 && !(oa >> 4)
5167 && kid->op_type == OP_LIST && type != OP_SCALAR)
5169 return too_many_arguments(o,PL_op_desc[type]);
5182 if ((type == OP_PUSH || type == OP_UNSHIFT)
5183 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5184 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5185 "Useless use of %s with no values",
5188 if (kid->op_type == OP_CONST &&
5189 (kid->op_private & OPpCONST_BARE))
5191 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5192 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5193 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5194 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5195 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5196 "Array @%s missing the @ in argument %"IVdf" of %s()",
5197 name, (IV)numargs, PL_op_desc[type]);
5200 kid->op_sibling = sibl;
5203 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5204 bad_type(numargs, "array", PL_op_desc[type], kid);
5208 if (kid->op_type == OP_CONST &&
5209 (kid->op_private & OPpCONST_BARE))
5211 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5212 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5213 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5214 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5215 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5216 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5217 name, (IV)numargs, PL_op_desc[type]);
5220 kid->op_sibling = sibl;
5223 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5224 bad_type(numargs, "hash", PL_op_desc[type], kid);
5229 OP *newop = newUNOP(OP_NULL, 0, kid);
5230 kid->op_sibling = 0;
5232 newop->op_next = newop;
5234 kid->op_sibling = sibl;
5239 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5240 if (kid->op_type == OP_CONST &&
5241 (kid->op_private & OPpCONST_BARE))
5243 OP *newop = newGVOP(OP_GV, 0,
5244 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5246 if (!(o->op_private & 1) && /* if not unop */
5247 kid == cLISTOPo->op_last)
5248 cLISTOPo->op_last = newop;
5252 else if (kid->op_type == OP_READLINE) {
5253 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5254 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5257 I32 flags = OPf_SPECIAL;
5261 /* is this op a FH constructor? */
5262 if (is_handle_constructor(o,numargs)) {
5263 char *name = Nullch;
5267 /* Set a flag to tell rv2gv to vivify
5268 * need to "prove" flag does not mean something
5269 * else already - NI-S 1999/05/07
5272 if (kid->op_type == OP_PADSV) {
5273 name = PAD_COMPNAME_PV(kid->op_targ);
5274 /* SvCUR of a pad namesv can't be trusted
5275 * (see PL_generation), so calc its length
5281 else if (kid->op_type == OP_RV2SV
5282 && kUNOP->op_first->op_type == OP_GV)
5284 GV *gv = cGVOPx_gv(kUNOP->op_first);
5286 len = GvNAMELEN(gv);
5288 else if (kid->op_type == OP_AELEM
5289 || kid->op_type == OP_HELEM)
5294 if ((op = ((BINOP*)kid)->op_first)) {
5295 SV *tmpstr = Nullsv;
5297 kid->op_type == OP_AELEM ?
5299 if (((op->op_type == OP_RV2AV) ||
5300 (op->op_type == OP_RV2HV)) &&
5301 (op = ((UNOP*)op)->op_first) &&
5302 (op->op_type == OP_GV)) {
5303 /* packagevar $a[] or $h{} */
5304 GV *gv = cGVOPx_gv(op);
5312 else if (op->op_type == OP_PADAV
5313 || op->op_type == OP_PADHV) {
5314 /* lexicalvar $a[] or $h{} */
5316 PAD_COMPNAME_PV(op->op_targ);
5326 name = SvPV(tmpstr, len);
5331 name = "__ANONIO__";
5338 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5339 namesv = PAD_SVl(targ);
5340 (void)SvUPGRADE(namesv, SVt_PV);
5342 sv_setpvn(namesv, "$", 1);
5343 sv_catpvn(namesv, name, len);
5346 kid->op_sibling = 0;
5347 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5348 kid->op_targ = targ;
5349 kid->op_private |= priv;
5351 kid->op_sibling = sibl;
5357 mod(scalar(kid), type);
5361 tokid = &kid->op_sibling;
5362 kid = kid->op_sibling;
5364 o->op_private |= numargs;
5366 return too_many_arguments(o,OP_DESC(o));
5369 else if (PL_opargs[type] & OA_DEFGV) {
5371 return newUNOP(type, 0, newDEFSVOP());
5375 while (oa & OA_OPTIONAL)
5377 if (oa && oa != OA_LIST)
5378 return too_few_arguments(o,OP_DESC(o));
5384 Perl_ck_glob(pTHX_ OP *o)
5389 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5390 append_elem(OP_GLOB, o, newDEFSVOP());
5392 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5393 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5395 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5398 #if !defined(PERL_EXTERNAL_GLOB)
5399 /* XXX this can be tightened up and made more failsafe. */
5400 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5403 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5404 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5405 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5406 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5407 GvCV(gv) = GvCV(glob_gv);
5408 SvREFCNT_inc((SV*)GvCV(gv));
5409 GvIMPORTED_CV_on(gv);
5412 #endif /* PERL_EXTERNAL_GLOB */
5414 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5415 append_elem(OP_GLOB, o,
5416 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5417 o->op_type = OP_LIST;
5418 o->op_ppaddr = PL_ppaddr[OP_LIST];
5419 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5420 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5421 cLISTOPo->op_first->op_targ = 0;
5422 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5423 append_elem(OP_LIST, o,
5424 scalar(newUNOP(OP_RV2CV, 0,
5425 newGVOP(OP_GV, 0, gv)))));
5426 o = newUNOP(OP_NULL, 0, ck_subr(o));
5427 o->op_targ = OP_GLOB; /* hint at what it used to be */
5430 gv = newGVgen("main");
5432 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5438 Perl_ck_grep(pTHX_ OP *o)
5442 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5445 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5446 NewOp(1101, gwop, 1, LOGOP);
5448 if (o->op_flags & OPf_STACKED) {
5451 kid = cLISTOPo->op_first->op_sibling;
5452 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
5455 kid->op_next = (OP*)gwop;
5456 o->op_flags &= ~OPf_STACKED;
5458 kid = cLISTOPo->op_first->op_sibling;
5459 if (type == OP_MAPWHILE)
5466 kid = cLISTOPo->op_first->op_sibling;
5467 if (kid->op_type != OP_NULL)
5468 Perl_croak(aTHX_ "panic: ck_grep");
5469 kid = kUNOP->op_first;
5471 gwop->op_type = type;
5472 gwop->op_ppaddr = PL_ppaddr[type];
5473 gwop->op_first = listkids(o);
5474 gwop->op_flags |= OPf_KIDS;
5475 gwop->op_other = LINKLIST(kid);
5476 kid->op_next = (OP*)gwop;
5477 offset = pad_findmy("$_");
5478 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
5479 o->op_private = gwop->op_private = 0;
5480 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5483 o->op_private = gwop->op_private = OPpGREP_LEX;
5484 gwop->op_targ = o->op_targ = offset;
5487 kid = cLISTOPo->op_first->op_sibling;
5488 if (!kid || !kid->op_sibling)
5489 return too_few_arguments(o,OP_DESC(o));
5490 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5491 mod(kid, OP_GREPSTART);
5497 Perl_ck_index(pTHX_ OP *o)
5499 if (o->op_flags & OPf_KIDS) {
5500 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5502 kid = kid->op_sibling; /* get past "big" */
5503 if (kid && kid->op_type == OP_CONST)
5504 fbm_compile(((SVOP*)kid)->op_sv, 0);
5510 Perl_ck_lengthconst(pTHX_ OP *o)
5512 /* XXX length optimization goes here */
5517 Perl_ck_lfun(pTHX_ OP *o)
5519 OPCODE type = o->op_type;
5520 return modkids(ck_fun(o), type);
5524 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5526 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5527 switch (cUNOPo->op_first->op_type) {
5529 /* This is needed for
5530 if (defined %stash::)
5531 to work. Do not break Tk.
5533 break; /* Globals via GV can be undef */
5535 case OP_AASSIGN: /* Is this a good idea? */
5536 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5537 "defined(@array) is deprecated");
5538 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5539 "\t(Maybe you should just omit the defined()?)\n");
5542 /* This is needed for
5543 if (defined %stash::)
5544 to work. Do not break Tk.
5546 break; /* Globals via GV can be undef */
5548 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5549 "defined(%%hash) is deprecated");
5550 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5551 "\t(Maybe you should just omit the defined()?)\n");
5562 Perl_ck_rfun(pTHX_ OP *o)
5564 OPCODE type = o->op_type;
5565 return refkids(ck_fun(o), type);
5569 Perl_ck_listiob(pTHX_ OP *o)
5573 kid = cLISTOPo->op_first;
5576 kid = cLISTOPo->op_first;
5578 if (kid->op_type == OP_PUSHMARK)
5579 kid = kid->op_sibling;
5580 if (kid && o->op_flags & OPf_STACKED)
5581 kid = kid->op_sibling;
5582 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5583 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5584 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5585 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5586 cLISTOPo->op_first->op_sibling = kid;
5587 cLISTOPo->op_last = kid;
5588 kid = kid->op_sibling;
5593 append_elem(o->op_type, o, newDEFSVOP());
5599 Perl_ck_sassign(pTHX_ OP *o)
5601 OP *kid = cLISTOPo->op_first;
5602 /* has a disposable target? */
5603 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5604 && !(kid->op_flags & OPf_STACKED)
5605 /* Cannot steal the second time! */
5606 && !(kid->op_private & OPpTARGET_MY))
5608 OP *kkid = kid->op_sibling;
5610 /* Can just relocate the target. */
5611 if (kkid && kkid->op_type == OP_PADSV
5612 && !(kkid->op_private & OPpLVAL_INTRO))
5614 kid->op_targ = kkid->op_targ;
5616 /* Now we do not need PADSV and SASSIGN. */
5617 kid->op_sibling = o->op_sibling; /* NULL */
5618 cLISTOPo->op_first = NULL;
5621 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
5625 /* optimise C<my $x = undef> to C<my $x> */
5626 if (kid->op_type == OP_UNDEF) {
5627 OP *kkid = kid->op_sibling;
5628 if (kkid && kkid->op_type == OP_PADSV
5629 && (kkid->op_private & OPpLVAL_INTRO))
5631 cLISTOPo->op_first = NULL;
5632 kid->op_sibling = NULL;
5642 Perl_ck_match(pTHX_ OP *o)
5644 if (o->op_type != OP_QR) {
5645 I32 offset = pad_findmy("$_");
5646 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS(offset) & SVpad_OUR)) {
5647 o->op_targ = offset;
5648 o->op_private |= OPpTARGET_MY;
5651 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
5652 o->op_private |= OPpRUNTIME;
5657 Perl_ck_method(pTHX_ OP *o)
5659 OP *kid = cUNOPo->op_first;
5660 if (kid->op_type == OP_CONST) {
5661 SV* sv = kSVOP->op_sv;
5662 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
5664 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5665 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
5668 kSVOP->op_sv = Nullsv;
5670 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5679 Perl_ck_null(pTHX_ OP *o)
5685 Perl_ck_open(pTHX_ OP *o)
5687 HV *table = GvHV(PL_hintgv);
5691 svp = hv_fetch(table, "open_IN", 7, FALSE);
5693 mode = mode_from_discipline(*svp);
5694 if (mode & O_BINARY)
5695 o->op_private |= OPpOPEN_IN_RAW;
5696 else if (mode & O_TEXT)
5697 o->op_private |= OPpOPEN_IN_CRLF;
5700 svp = hv_fetch(table, "open_OUT", 8, FALSE);
5702 mode = mode_from_discipline(*svp);
5703 if (mode & O_BINARY)
5704 o->op_private |= OPpOPEN_OUT_RAW;
5705 else if (mode & O_TEXT)
5706 o->op_private |= OPpOPEN_OUT_CRLF;
5709 if (o->op_type == OP_BACKTICK)
5712 /* In case of three-arg dup open remove strictness
5713 * from the last arg if it is a bareword. */
5714 OP *first = cLISTOPx(o)->op_first; /* The pushmark. */
5715 OP *last = cLISTOPx(o)->op_last; /* The bareword. */
5719 if ((last->op_type == OP_CONST) && /* The bareword. */
5720 (last->op_private & OPpCONST_BARE) &&
5721 (last->op_private & OPpCONST_STRICT) &&
5722 (oa = first->op_sibling) && /* The fh. */
5723 (oa = oa->op_sibling) && /* The mode. */
5724 SvPOK(((SVOP*)oa)->op_sv) &&
5725 (mode = SvPVX(((SVOP*)oa)->op_sv)) &&
5726 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
5727 (last == oa->op_sibling)) /* The bareword. */
5728 last->op_private &= ~OPpCONST_STRICT;
5734 Perl_ck_repeat(pTHX_ OP *o)
5736 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5737 o->op_private |= OPpREPEAT_DOLIST;
5738 cBINOPo->op_first = force_list(cBINOPo->op_first);
5746 Perl_ck_require(pTHX_ OP *o)
5750 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
5751 SVOP *kid = (SVOP*)cUNOPo->op_first;
5753 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5755 for (s = SvPVX(kid->op_sv); *s; s++) {
5756 if (*s == ':' && s[1] == ':') {
5758 Move(s+2, s+1, strlen(s+2)+1, char);
5759 --SvCUR(kid->op_sv);
5762 if (SvREADONLY(kid->op_sv)) {
5763 SvREADONLY_off(kid->op_sv);
5764 sv_catpvn(kid->op_sv, ".pm", 3);
5765 SvREADONLY_on(kid->op_sv);
5768 sv_catpvn(kid->op_sv, ".pm", 3);
5772 /* handle override, if any */
5773 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
5774 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
5775 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
5777 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5778 OP *kid = cUNOPo->op_first;
5779 cUNOPo->op_first = 0;
5781 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5782 append_elem(OP_LIST, kid,
5783 scalar(newUNOP(OP_RV2CV, 0,
5792 Perl_ck_return(pTHX_ OP *o)
5795 if (CvLVALUE(PL_compcv)) {
5796 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5797 mod(kid, OP_LEAVESUBLV);
5804 Perl_ck_retarget(pTHX_ OP *o)
5806 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5813 Perl_ck_select(pTHX_ OP *o)
5816 if (o->op_flags & OPf_KIDS) {
5817 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5818 if (kid && kid->op_sibling) {
5819 o->op_type = OP_SSELECT;
5820 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
5822 return fold_constants(o);
5826 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5827 if (kid && kid->op_type == OP_RV2GV)
5828 kid->op_private &= ~HINT_STRICT_REFS;
5833 Perl_ck_shift(pTHX_ OP *o)
5835 I32 type = o->op_type;
5837 if (!(o->op_flags & OPf_KIDS)) {
5841 argop = newUNOP(OP_RV2AV, 0,
5842 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
5843 return newUNOP(type, 0, scalar(argop));
5845 return scalar(modkids(ck_fun(o), type));
5849 Perl_ck_sort(pTHX_ OP *o)
5853 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
5855 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5856 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
5858 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
5860 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
5862 if (kid->op_type == OP_SCOPE) {
5866 else if (kid->op_type == OP_LEAVE) {
5867 if (o->op_type == OP_SORT) {
5868 op_null(kid); /* wipe out leave */
5871 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
5872 if (k->op_next == kid)
5874 /* don't descend into loops */
5875 else if (k->op_type == OP_ENTERLOOP
5876 || k->op_type == OP_ENTERITER)
5878 k = cLOOPx(k)->op_lastop;
5883 kid->op_next = 0; /* just disconnect the leave */
5884 k = kLISTOP->op_first;
5889 if (o->op_type == OP_SORT) {
5890 /* provide scalar context for comparison function/block */
5896 o->op_flags |= OPf_SPECIAL;
5898 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
5901 firstkid = firstkid->op_sibling;
5904 /* provide list context for arguments */
5905 if (o->op_type == OP_SORT)
5912 S_simplify_sort(pTHX_ OP *o)
5914 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5918 if (!(o->op_flags & OPf_STACKED))
5920 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
5921 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
5922 kid = kUNOP->op_first; /* get past null */
5923 if (kid->op_type != OP_SCOPE)
5925 kid = kLISTOP->op_last; /* get past scope */
5926 switch(kid->op_type) {
5934 k = kid; /* remember this node*/
5935 if (kBINOP->op_first->op_type != OP_RV2SV)
5937 kid = kBINOP->op_first; /* get past cmp */
5938 if (kUNOP->op_first->op_type != OP_GV)
5940 kid = kUNOP->op_first; /* get past rv2sv */
5942 if (GvSTASH(gv) != PL_curstash)
5944 if (strEQ(GvNAME(gv), "a"))
5946 else if (strEQ(GvNAME(gv), "b"))
5950 kid = k; /* back to cmp */
5951 if (kBINOP->op_last->op_type != OP_RV2SV)
5953 kid = kBINOP->op_last; /* down to 2nd arg */
5954 if (kUNOP->op_first->op_type != OP_GV)
5956 kid = kUNOP->op_first; /* get past rv2sv */
5958 if (GvSTASH(gv) != PL_curstash
5960 ? strNE(GvNAME(gv), "a")
5961 : strNE(GvNAME(gv), "b")))
5963 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
5965 o->op_private |= OPpSORT_REVERSE;
5966 if (k->op_type == OP_NCMP)
5967 o->op_private |= OPpSORT_NUMERIC;
5968 if (k->op_type == OP_I_NCMP)
5969 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
5970 kid = cLISTOPo->op_first->op_sibling;
5971 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
5972 op_free(kid); /* then delete it */
5976 Perl_ck_split(pTHX_ OP *o)
5980 if (o->op_flags & OPf_STACKED)
5981 return no_fh_allowed(o);
5983 kid = cLISTOPo->op_first;
5984 if (kid->op_type != OP_NULL)
5985 Perl_croak(aTHX_ "panic: ck_split");
5986 kid = kid->op_sibling;
5987 op_free(cLISTOPo->op_first);
5988 cLISTOPo->op_first = kid;
5990 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
5991 cLISTOPo->op_last = kid; /* There was only one element previously */
5994 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
5995 OP *sibl = kid->op_sibling;
5996 kid->op_sibling = 0;
5997 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
5998 if (cLISTOPo->op_first == cLISTOPo->op_last)
5999 cLISTOPo->op_last = kid;
6000 cLISTOPo->op_first = kid;
6001 kid->op_sibling = sibl;
6004 kid->op_type = OP_PUSHRE;
6005 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6007 if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
6008 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
6009 "Use of /g modifier is meaningless in split");
6012 if (!kid->op_sibling)
6013 append_elem(OP_SPLIT, o, newDEFSVOP());
6015 kid = kid->op_sibling;
6018 if (!kid->op_sibling)
6019 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6021 kid = kid->op_sibling;
6024 if (kid->op_sibling)
6025 return too_many_arguments(o,OP_DESC(o));
6031 Perl_ck_join(pTHX_ OP *o)
6033 if (ckWARN(WARN_SYNTAX)) {
6034 OP *kid = cLISTOPo->op_first->op_sibling;
6035 if (kid && kid->op_type == OP_MATCH) {
6036 char *pmstr = "STRING";
6037 if (PM_GETRE(kPMOP))
6038 pmstr = PM_GETRE(kPMOP)->precomp;
6039 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6040 "/%s/ should probably be written as \"%s\"",
6048 Perl_ck_subr(pTHX_ OP *o)
6050 OP *prev = ((cUNOPo->op_first->op_sibling)
6051 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6052 OP *o2 = prev->op_sibling;
6059 I32 contextclass = 0;
6064 o->op_private |= OPpENTERSUB_HASTARG;
6065 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6066 if (cvop->op_type == OP_RV2CV) {
6068 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6069 op_null(cvop); /* disable rv2cv */
6070 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6071 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6072 GV *gv = cGVOPx_gv(tmpop);
6075 tmpop->op_private |= OPpEARLY_CV;
6078 namegv = CvANON(cv) ? gv : CvGV(cv);
6079 proto = SvPV((SV*)cv, n_a);
6081 if (CvASSERTION(cv)) {
6082 if (PL_hints & HINT_ASSERTING) {
6083 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
6084 o->op_private |= OPpENTERSUB_DB;
6088 if (ckWARN(WARN_ASSERTIONS) && !(PL_hints & HINT_ASSERTIONSSEEN)) {
6089 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
6090 "Impossible to activate assertion call");
6097 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6098 if (o2->op_type == OP_CONST)
6099 o2->op_private &= ~OPpCONST_STRICT;
6100 else if (o2->op_type == OP_LIST) {
6101 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6102 if (o && o->op_type == OP_CONST)
6103 o->op_private &= ~OPpCONST_STRICT;
6106 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6107 if (PERLDB_SUB && PL_curstash != PL_debstash)
6108 o->op_private |= OPpENTERSUB_DB;
6109 while (o2 != cvop) {
6113 return too_many_arguments(o, gv_ename(namegv));
6131 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6133 arg == 1 ? "block or sub {}" : "sub {}",
6134 gv_ename(namegv), o2);
6137 /* '*' allows any scalar type, including bareword */
6140 if (o2->op_type == OP_RV2GV)
6141 goto wrapref; /* autoconvert GLOB -> GLOBref */
6142 else if (o2->op_type == OP_CONST)
6143 o2->op_private &= ~OPpCONST_STRICT;
6144 else if (o2->op_type == OP_ENTERSUB) {
6145 /* accidental subroutine, revert to bareword */
6146 OP *gvop = ((UNOP*)o2)->op_first;
6147 if (gvop && gvop->op_type == OP_NULL) {
6148 gvop = ((UNOP*)gvop)->op_first;
6150 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6153 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6154 (gvop = ((UNOP*)gvop)->op_first) &&
6155 gvop->op_type == OP_GV)
6157 GV *gv = cGVOPx_gv(gvop);
6158 OP *sibling = o2->op_sibling;
6159 SV *n = newSVpvn("",0);
6161 gv_fullname3(n, gv, "");
6162 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6163 sv_chop(n, SvPVX(n)+6);
6164 o2 = newSVOP(OP_CONST, 0, n);
6165 prev->op_sibling = o2;
6166 o2->op_sibling = sibling;
6182 if (contextclass++ == 0) {
6183 e = strchr(proto, ']');
6184 if (!e || e == proto)
6197 while (*--p != '[');
6198 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6199 gv_ename(namegv), o2);
6205 if (o2->op_type == OP_RV2GV)
6208 bad_type(arg, "symbol", gv_ename(namegv), o2);
6211 if (o2->op_type == OP_ENTERSUB)
6214 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6217 if (o2->op_type == OP_RV2SV ||
6218 o2->op_type == OP_PADSV ||
6219 o2->op_type == OP_HELEM ||
6220 o2->op_type == OP_AELEM ||
6221 o2->op_type == OP_THREADSV)
6224 bad_type(arg, "scalar", gv_ename(namegv), o2);
6227 if (o2->op_type == OP_RV2AV ||
6228 o2->op_type == OP_PADAV)
6231 bad_type(arg, "array", gv_ename(namegv), o2);
6234 if (o2->op_type == OP_RV2HV ||
6235 o2->op_type == OP_PADHV)
6238 bad_type(arg, "hash", gv_ename(namegv), o2);
6243 OP* sib = kid->op_sibling;
6244 kid->op_sibling = 0;
6245 o2 = newUNOP(OP_REFGEN, 0, kid);
6246 o2->op_sibling = sib;
6247 prev->op_sibling = o2;
6249 if (contextclass && e) {
6264 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6265 gv_ename(namegv), cv);
6270 mod(o2, OP_ENTERSUB);
6272 o2 = o2->op_sibling;
6274 if (proto && !optional &&
6275 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6276 return too_few_arguments(o, gv_ename(namegv));
6279 o=newSVOP(OP_CONST, 0, newSViv(0));
6285 Perl_ck_svconst(pTHX_ OP *o)
6287 SvREADONLY_on(cSVOPo->op_sv);
6292 Perl_ck_trunc(pTHX_ OP *o)
6294 if (o->op_flags & OPf_KIDS) {
6295 SVOP *kid = (SVOP*)cUNOPo->op_first;
6297 if (kid->op_type == OP_NULL)
6298 kid = (SVOP*)kid->op_sibling;
6299 if (kid && kid->op_type == OP_CONST &&
6300 (kid->op_private & OPpCONST_BARE))
6302 o->op_flags |= OPf_SPECIAL;
6303 kid->op_private &= ~OPpCONST_STRICT;
6310 Perl_ck_unpack(pTHX_ OP *o)
6312 OP *kid = cLISTOPo->op_first;
6313 if (kid->op_sibling) {
6314 kid = kid->op_sibling;
6315 if (!kid->op_sibling)
6316 kid->op_sibling = newDEFSVOP();
6322 Perl_ck_substr(pTHX_ OP *o)
6325 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6326 OP *kid = cLISTOPo->op_first;
6328 if (kid->op_type == OP_NULL)
6329 kid = kid->op_sibling;
6331 kid->op_flags |= OPf_MOD;
6337 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6340 Perl_peep(pTHX_ register OP *o)
6342 register OP* oldop = 0;
6344 if (!o || o->op_opt)
6348 SAVEVPTR(PL_curcop);
6349 for (; o; o = o->op_next) {
6353 switch (o->op_type) {
6357 PL_curcop = ((COP*)o); /* for warnings */
6362 if (cSVOPo->op_private & OPpCONST_STRICT)
6363 no_bareword_allowed(o);
6365 case OP_METHOD_NAMED:
6366 /* Relocate sv to the pad for thread safety.
6367 * Despite being a "constant", the SV is written to,
6368 * for reference counts, sv_upgrade() etc. */
6370 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6371 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6372 /* If op_sv is already a PADTMP then it is being used by
6373 * some pad, so make a copy. */
6374 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6375 SvREADONLY_on(PAD_SVl(ix));
6376 SvREFCNT_dec(cSVOPo->op_sv);
6379 SvREFCNT_dec(PAD_SVl(ix));
6380 SvPADTMP_on(cSVOPo->op_sv);
6381 PAD_SETSV(ix, cSVOPo->op_sv);
6382 /* XXX I don't know how this isn't readonly already. */
6383 SvREADONLY_on(PAD_SVl(ix));
6385 cSVOPo->op_sv = Nullsv;
6393 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6394 if (o->op_next->op_private & OPpTARGET_MY) {
6395 if (o->op_flags & OPf_STACKED) /* chained concats */
6396 goto ignore_optimization;
6398 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6399 o->op_targ = o->op_next->op_targ;
6400 o->op_next->op_targ = 0;
6401 o->op_private |= OPpTARGET_MY;
6404 op_null(o->op_next);
6406 ignore_optimization:
6410 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6412 break; /* Scalar stub must produce undef. List stub is noop */
6416 if (o->op_targ == OP_NEXTSTATE
6417 || o->op_targ == OP_DBSTATE
6418 || o->op_targ == OP_SETSTATE)
6420 PL_curcop = ((COP*)o);
6422 /* XXX: We avoid setting op_seq here to prevent later calls
6423 to peep() from mistakenly concluding that optimisation
6424 has already occurred. This doesn't fix the real problem,
6425 though (See 20010220.007). AMS 20010719 */
6426 /* op_seq functionality is now replaced by op_opt */
6427 if (oldop && o->op_next) {
6428 oldop->op_next = o->op_next;
6436 if (oldop && o->op_next) {
6437 oldop->op_next = o->op_next;
6445 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
6446 OP* pop = (o->op_type == OP_PADAV) ?
6447 o->op_next : o->op_next->op_next;
6449 if (pop && pop->op_type == OP_CONST &&
6450 ((PL_op = pop->op_next)) &&
6451 pop->op_next->op_type == OP_AELEM &&
6452 !(pop->op_next->op_private &
6453 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6454 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6459 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
6460 no_bareword_allowed(pop);
6461 if (o->op_type == OP_GV)
6462 op_null(o->op_next);
6463 op_null(pop->op_next);
6465 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6466 o->op_next = pop->op_next->op_next;
6467 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6468 o->op_private = (U8)i;
6469 if (o->op_type == OP_GV) {
6474 o->op_flags |= OPf_SPECIAL;
6475 o->op_type = OP_AELEMFAST;
6481 if (o->op_next->op_type == OP_RV2SV) {
6482 if (!(o->op_next->op_private & OPpDEREF)) {
6483 op_null(o->op_next);
6484 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6486 o->op_next = o->op_next->op_next;
6487 o->op_type = OP_GVSV;
6488 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6491 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6493 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6494 /* XXX could check prototype here instead of just carping */
6495 SV *sv = sv_newmortal();
6496 gv_efullname3(sv, gv, Nullch);
6497 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6498 "%"SVf"() called too early to check prototype",
6502 else if (o->op_next->op_type == OP_READLINE
6503 && o->op_next->op_next->op_type == OP_CONCAT
6504 && (o->op_next->op_next->op_flags & OPf_STACKED))
6506 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6507 o->op_type = OP_RCATLINE;
6508 o->op_flags |= OPf_STACKED;
6509 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6510 op_null(o->op_next->op_next);
6511 op_null(o->op_next);
6528 while (cLOGOP->op_other->op_type == OP_NULL)
6529 cLOGOP->op_other = cLOGOP->op_other->op_next;
6530 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6536 while (cLOOP->op_redoop->op_type == OP_NULL)
6537 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6538 peep(cLOOP->op_redoop);
6539 while (cLOOP->op_nextop->op_type == OP_NULL)
6540 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6541 peep(cLOOP->op_nextop);
6542 while (cLOOP->op_lastop->op_type == OP_NULL)
6543 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6544 peep(cLOOP->op_lastop);
6551 while (cPMOP->op_pmreplstart &&
6552 cPMOP->op_pmreplstart->op_type == OP_NULL)
6553 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6554 peep(cPMOP->op_pmreplstart);
6559 if (ckWARN(WARN_SYNTAX) && o->op_next
6560 && o->op_next->op_type == OP_NEXTSTATE) {
6561 if (o->op_next->op_sibling &&
6562 o->op_next->op_sibling->op_type != OP_EXIT &&
6563 o->op_next->op_sibling->op_type != OP_WARN &&
6564 o->op_next->op_sibling->op_type != OP_DIE) {
6565 line_t oldline = CopLINE(PL_curcop);
6567 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6568 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6569 "Statement unlikely to be reached");
6570 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6571 "\t(Maybe you meant system() when you said exec()?)\n");
6572 CopLINE_set(PL_curcop, oldline);
6585 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6588 /* Make the CONST have a shared SV */
6589 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6590 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6591 key = SvPV(sv, keylen);
6592 lexname = newSVpvn_share(key,
6593 SvUTF8(sv) ? -(I32)keylen : keylen,
6602 /* make @a = sort @a act in-place */
6604 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
6610 /* check that RHS of sort is a single plain array */
6611 oright = cUNOPo->op_first;
6612 if (!oright || oright->op_type != OP_PUSHMARK)
6614 oright = cUNOPx(oright)->op_sibling;
6617 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
6618 oright = cUNOPx(oright)->op_sibling;
6622 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
6623 || oright->op_next != o
6624 || (oright->op_private & OPpLVAL_INTRO)
6628 /* o2 follows the chain of op_nexts through the LHS of the
6629 * assign (if any) to the aassign op itself */
6631 if (!o2 || o2->op_type != OP_NULL)
6634 if (!o2 || o2->op_type != OP_PUSHMARK)
6637 if (o2 && o2->op_type == OP_GV)
6640 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
6641 || (o2->op_private & OPpLVAL_INTRO)
6646 if (!o2 || o2->op_type != OP_NULL)
6649 if (!o2 || o2->op_type != OP_AASSIGN
6650 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
6653 /* check that the sort is the first arg on RHS of assign */
6655 o2 = cUNOPx(o2)->op_first;
6656 if (!o2 || o2->op_type != OP_NULL)
6658 o2 = cUNOPx(o2)->op_first;
6659 if (!o2 || o2->op_type != OP_PUSHMARK)
6661 if (o2->op_sibling != o)
6664 /* check the array is the same on both sides */
6665 if (oleft->op_type == OP_RV2AV) {
6666 if (oright->op_type != OP_RV2AV
6667 || !cUNOPx(oright)->op_first
6668 || cUNOPx(oright)->op_first->op_type != OP_GV
6669 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
6670 cGVOPx_gv(cUNOPx(oright)->op_first)
6674 else if (oright->op_type != OP_PADAV
6675 || oright->op_targ != oleft->op_targ
6679 /* transfer MODishness etc from LHS arg to RHS arg */
6680 oright->op_flags = oleft->op_flags;
6681 o->op_private |= OPpSORT_INPLACE;
6683 /* excise push->gv->rv2av->null->aassign */
6684 o2 = o->op_next->op_next;
6685 op_null(o2); /* PUSHMARK */
6687 if (o2->op_type == OP_GV) {
6688 op_null(o2); /* GV */
6691 op_null(o2); /* RV2AV or PADAV */
6692 o2 = o2->op_next->op_next;
6693 op_null(o2); /* AASSIGN */
6695 o->op_next = o2->op_next;
6713 char* Perl_custom_op_name(pTHX_ OP* o)
6715 IV index = PTR2IV(o->op_ppaddr);
6719 if (!PL_custom_op_names) /* This probably shouldn't happen */
6720 return PL_op_name[OP_CUSTOM];
6722 keysv = sv_2mortal(newSViv(index));
6724 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
6726 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
6728 return SvPV_nolen(HeVAL(he));
6731 char* Perl_custom_op_desc(pTHX_ OP* o)
6733 IV index = PTR2IV(o->op_ppaddr);
6737 if (!PL_custom_op_descs)
6738 return PL_op_desc[OP_CUSTOM];
6740 keysv = sv_2mortal(newSViv(index));
6742 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
6744 return PL_op_desc[OP_CUSTOM];
6746 return SvPV_nolen(HeVAL(he));
6752 /* Efficient sub that returns a constant scalar value. */
6754 const_sv_xsub(pTHX_ CV* cv)
6759 Perl_croak(aTHX_ "usage: %s::%s()",
6760 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
6764 ST(0) = (SV*)XSANY.any_ptr;