3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
13 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
14 * youngest of the Old Took's daughters); and Mr. Drogo was his second
15 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
16 * either way, as the saying is, if you follow me." --the Gaffer
25 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
27 #if defined(PL_OP_SLAB_ALLOC)
29 #ifndef PERL_SLAB_SIZE
30 #define PERL_SLAB_SIZE 2048
34 Perl_Slab_Alloc(pTHX_ int m, size_t sz)
37 * To make incrementing use count easy PL_OpSlab is an I32 *
38 * To make inserting the link to slab PL_OpPtr is I32 **
39 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
40 * Add an overhead for pointer to slab and round up as a number of pointers
42 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
43 if ((PL_OpSpace -= sz) < 0) {
44 PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*));
48 Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **);
49 /* We reserve the 0'th I32 sized chunk as a use count */
50 PL_OpSlab = (I32 *) PL_OpPtr;
51 /* Reduce size by the use count word, and by the size we need.
52 * Latter is to mimic the '-=' in the if() above
54 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
55 /* Allocation pointer starts at the top.
56 Theory: because we build leaves before trunk allocating at end
57 means that at run time access is cache friendly upward
59 PL_OpPtr += PERL_SLAB_SIZE;
61 assert( PL_OpSpace >= 0 );
62 /* Move the allocation pointer down */
64 assert( PL_OpPtr > (I32 **) PL_OpSlab );
65 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
66 (*PL_OpSlab)++; /* Increment use count of slab */
67 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
68 assert( *PL_OpSlab > 0 );
69 return (void *)(PL_OpPtr + 1);
73 Perl_Slab_Free(pTHX_ void *op)
75 I32 **ptr = (I32 **) op;
77 assert( ptr-1 > (I32 **) slab );
78 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
82 # define PerlMemShared PerlMem
85 PerlMemShared_free(slab);
86 if (slab == PL_OpSlab) {
93 * In the following definition, the ", Nullop" is just to make the compiler
94 * think the expression is of the right type: croak actually does a Siglongjmp.
96 #define CHECKOP(type,o) \
97 ((PL_op_mask && PL_op_mask[type]) \
98 ? ( op_free((OP*)o), \
99 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
101 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
103 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
106 S_gv_ename(pTHX_ GV *gv)
109 SV* tmpsv = sv_newmortal();
110 gv_efullname3(tmpsv, gv, Nullch);
111 return SvPV(tmpsv,n_a);
115 S_no_fh_allowed(pTHX_ OP *o)
117 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
123 S_too_few_arguments(pTHX_ OP *o, char *name)
125 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
130 S_too_many_arguments(pTHX_ OP *o, char *name)
132 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
137 S_bad_type(pTHX_ I32 n, char *t, char *name, OP *kid)
139 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
140 (int)n, name, t, OP_DESC(kid)));
144 S_no_bareword_allowed(pTHX_ OP *o)
146 qerror(Perl_mess(aTHX_
147 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
151 /* "register" allocation */
154 Perl_allocmy(pTHX_ char *name)
158 /* complain about "my $<special_var>" etc etc */
159 if (!(PL_in_my == KEY_our ||
161 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
162 (name[1] == '_' && (*name == '$' || (int)strlen(name) > 2))))
164 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
165 /* 1999-02-27 mjd@plover.com */
167 p = strchr(name, '\0');
168 /* The next block assumes the buffer is at least 205 chars
169 long. At present, it's always at least 256 chars. */
171 strcpy(name+200, "...");
177 /* Move everything else down one character */
178 for (; p-name > 2; p--)
180 name[2] = toCTRL(name[1]);
183 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
186 /* check for duplicate declaration */
188 (bool)(PL_in_my == KEY_our),
189 (PL_curstash ? PL_curstash : PL_defstash)
192 if (PL_in_my_stash && *name != '$') {
193 yyerror(Perl_form(aTHX_
194 "Can't declare class for non-scalar %s in \"%s\"",
195 name, PL_in_my == KEY_our ? "our" : "my"));
198 /* allocate a spare slot and store the name in that slot */
200 off = pad_add_name(name,
203 ? (PL_curstash ? PL_curstash : PL_defstash)
214 Perl_op_free(pTHX_ OP *o)
216 register OP *kid, *nextkid;
219 if (!o || o->op_seq == (U16)-1)
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)))
279 if (cPADOPo->op_padix > 0) {
280 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
281 * may still exist on the pad */
282 pad_swipe(cPADOPo->op_padix, TRUE);
283 cPADOPo->op_padix = 0;
286 SvREFCNT_dec(cSVOPo->op_sv);
287 cSVOPo->op_sv = Nullsv;
290 case OP_METHOD_NAMED:
292 SvREFCNT_dec(cSVOPo->op_sv);
293 cSVOPo->op_sv = Nullsv;
296 Even if op_clear does a pad_free for the target of the op,
297 pad_free doesn't actually remove the sv that exists in the bad
298 instead it lives on. This results in that it could be reused as
299 a target later on when the pad was reallocated.
302 pad_swipe(o->op_targ,1);
311 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
315 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
316 SvREFCNT_dec(cSVOPo->op_sv);
317 cSVOPo->op_sv = Nullsv;
320 Safefree(cPVOPo->op_pv);
321 cPVOPo->op_pv = Nullch;
325 op_free(cPMOPo->op_pmreplroot);
329 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
330 /* No GvIN_PAD_off here, because other references may still
331 * exist on the pad */
332 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
335 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
342 HV *pmstash = PmopSTASH(cPMOPo);
343 if (pmstash && SvREFCNT(pmstash)) {
344 PMOP *pmop = HvPMROOT(pmstash);
345 PMOP *lastpmop = NULL;
347 if (cPMOPo == pmop) {
349 lastpmop->op_pmnext = pmop->op_pmnext;
351 HvPMROOT(pmstash) = pmop->op_pmnext;
355 pmop = pmop->op_pmnext;
358 PmopSTASH_free(cPMOPo);
360 cPMOPo->op_pmreplroot = Nullop;
361 /* we use the "SAFE" version of the PM_ macros here
362 * since sv_clean_all might release some PMOPs
363 * after PL_regex_padav has been cleared
364 * and the clearing of PL_regex_padav needs to
365 * happen before sv_clean_all
367 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
368 PM_SETRE_SAFE(cPMOPo, (REGEXP*)NULL);
370 if(PL_regex_pad) { /* We could be in destruction */
371 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
372 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
373 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
380 if (o->op_targ > 0) {
381 pad_free(o->op_targ);
387 S_cop_free(pTHX_ COP* cop)
389 Safefree(cop->cop_label); /* FIXME: treaddead ??? */
392 if (! specialWARN(cop->cop_warnings))
393 SvREFCNT_dec(cop->cop_warnings);
394 if (! specialCopIO(cop->cop_io)) {
398 char *s = SvPV(cop->cop_io,len);
399 Perl_warn(aTHX_ "io='%.*s'",(int) len,s); /* ??? --jhi */
402 SvREFCNT_dec(cop->cop_io);
408 Perl_op_null(pTHX_ OP *o)
410 if (o->op_type == OP_NULL)
413 o->op_targ = o->op_type;
414 o->op_type = OP_NULL;
415 o->op_ppaddr = PL_ppaddr[OP_NULL];
418 /* Contextualizers */
420 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
423 Perl_linklist(pTHX_ OP *o)
430 /* establish postfix order */
431 if (cUNOPo->op_first) {
432 o->op_next = LINKLIST(cUNOPo->op_first);
433 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
435 kid->op_next = LINKLIST(kid->op_sibling);
447 Perl_scalarkids(pTHX_ OP *o)
450 if (o && o->op_flags & OPf_KIDS) {
451 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
458 S_scalarboolean(pTHX_ OP *o)
460 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
461 if (ckWARN(WARN_SYNTAX)) {
462 line_t oldline = CopLINE(PL_curcop);
464 if (PL_copline != NOLINE)
465 CopLINE_set(PL_curcop, PL_copline);
466 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
467 CopLINE_set(PL_curcop, oldline);
474 Perl_scalar(pTHX_ OP *o)
478 /* assumes no premature commitment */
479 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
480 || o->op_type == OP_RETURN)
485 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
487 switch (o->op_type) {
489 scalar(cBINOPo->op_first);
494 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
498 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
499 if (!kPMOP->op_pmreplroot)
500 deprecate_old("implicit split to @_");
508 if (o->op_flags & OPf_KIDS) {
509 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
515 kid = cLISTOPo->op_first;
517 while ((kid = kid->op_sibling)) {
523 WITH_THR(PL_curcop = &PL_compiling);
528 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
534 WITH_THR(PL_curcop = &PL_compiling);
537 if (ckWARN(WARN_VOID))
538 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
544 Perl_scalarvoid(pTHX_ OP *o)
551 if (o->op_type == OP_NEXTSTATE
552 || o->op_type == OP_SETSTATE
553 || o->op_type == OP_DBSTATE
554 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
555 || o->op_targ == OP_SETSTATE
556 || o->op_targ == OP_DBSTATE)))
557 PL_curcop = (COP*)o; /* for warning below */
559 /* assumes no premature commitment */
560 want = o->op_flags & OPf_WANT;
561 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
562 || o->op_type == OP_RETURN)
567 if ((o->op_private & OPpTARGET_MY)
568 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
570 return scalar(o); /* As if inside SASSIGN */
573 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
575 switch (o->op_type) {
577 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
581 if (o->op_flags & OPf_STACKED)
585 if (o->op_private == 4)
657 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
658 useless = OP_DESC(o);
665 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
666 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
667 useless = "a variable";
672 if (cSVOPo->op_private & OPpCONST_STRICT)
673 no_bareword_allowed(o);
675 if (ckWARN(WARN_VOID)) {
676 useless = "a constant";
677 /* the constants 0 and 1 are permitted as they are
678 conventionally used as dummies in constructs like
679 1 while some_condition_with_side_effects; */
680 if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
682 else if (SvPOK(sv)) {
683 /* perl4's way of mixing documentation and code
684 (before the invention of POD) was based on a
685 trick to mix nroff and perl code. The trick was
686 built upon these three nroff macros being used in
687 void context. The pink camel has the details in
688 the script wrapman near page 319. */
689 if (strnEQ(SvPVX(sv), "di", 2) ||
690 strnEQ(SvPVX(sv), "ds", 2) ||
691 strnEQ(SvPVX(sv), "ig", 2))
696 op_null(o); /* don't execute or even remember it */
700 o->op_type = OP_PREINC; /* pre-increment is faster */
701 o->op_ppaddr = PL_ppaddr[OP_PREINC];
705 o->op_type = OP_PREDEC; /* pre-decrement is faster */
706 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
713 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
718 if (o->op_flags & OPf_STACKED)
725 if (!(o->op_flags & OPf_KIDS))
734 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
741 /* all requires must return a boolean value */
742 o->op_flags &= ~OPf_WANT;
747 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
748 if (!kPMOP->op_pmreplroot)
749 deprecate_old("implicit split to @_");
753 if (useless && ckWARN(WARN_VOID))
754 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
759 Perl_listkids(pTHX_ OP *o)
762 if (o && o->op_flags & OPf_KIDS) {
763 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
770 Perl_list(pTHX_ OP *o)
774 /* assumes no premature commitment */
775 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
776 || o->op_type == OP_RETURN)
781 if ((o->op_private & OPpTARGET_MY)
782 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
784 return o; /* As if inside SASSIGN */
787 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
789 switch (o->op_type) {
792 list(cBINOPo->op_first);
797 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
805 if (!(o->op_flags & OPf_KIDS))
807 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
808 list(cBINOPo->op_first);
809 return gen_constant_list(o);
816 kid = cLISTOPo->op_first;
818 while ((kid = kid->op_sibling)) {
824 WITH_THR(PL_curcop = &PL_compiling);
828 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
834 WITH_THR(PL_curcop = &PL_compiling);
837 /* all requires must return a boolean value */
838 o->op_flags &= ~OPf_WANT;
845 Perl_scalarseq(pTHX_ OP *o)
850 if (o->op_type == OP_LINESEQ ||
851 o->op_type == OP_SCOPE ||
852 o->op_type == OP_LEAVE ||
853 o->op_type == OP_LEAVETRY)
855 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
856 if (kid->op_sibling) {
860 PL_curcop = &PL_compiling;
862 o->op_flags &= ~OPf_PARENS;
863 if (PL_hints & HINT_BLOCK_SCOPE)
864 o->op_flags |= OPf_PARENS;
867 o = newOP(OP_STUB, 0);
872 S_modkids(pTHX_ OP *o, I32 type)
875 if (o && o->op_flags & OPf_KIDS) {
876 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
882 /* Propagate lvalue ("modifiable") context to an op and it's children.
883 * 'type' represents the context type, roughly based on the type of op that
884 * would do the modifying, although local() is represented by OP_NULL.
885 * It's responsible for detecting things that can't be modified, flag
886 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
887 * might have to vivify a reference in $x), and so on.
889 * For example, "$a+1 = 2" would cause mod() to be called with o being
890 * OP_ADD and type being OP_SASSIGN, and would output an error.
894 Perl_mod(pTHX_ OP *o, I32 type)
897 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
900 if (!o || PL_error_count)
903 if ((o->op_private & OPpTARGET_MY)
904 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
909 switch (o->op_type) {
915 if (!(o->op_private & (OPpCONST_ARYBASE)))
917 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
918 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
922 SAVEI32(PL_compiling.cop_arybase);
923 PL_compiling.cop_arybase = 0;
925 else if (type == OP_REFGEN)
928 Perl_croak(aTHX_ "That use of $[ is unsupported");
931 if (o->op_flags & OPf_PARENS)
935 if ((type == OP_UNDEF || type == OP_REFGEN) &&
936 !(o->op_flags & OPf_STACKED)) {
937 o->op_type = OP_RV2CV; /* entersub => rv2cv */
938 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
939 assert(cUNOPo->op_first->op_type == OP_NULL);
940 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
943 else if (o->op_private & OPpENTERSUB_NOMOD)
945 else { /* lvalue subroutine call */
946 o->op_private |= OPpLVAL_INTRO;
947 PL_modcount = RETURN_UNLIMITED_NUMBER;
948 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
949 /* Backward compatibility mode: */
950 o->op_private |= OPpENTERSUB_INARGS;
953 else { /* Compile-time error message: */
954 OP *kid = cUNOPo->op_first;
958 if (kid->op_type == OP_PUSHMARK)
960 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
962 "panic: unexpected lvalue entersub "
963 "args: type/targ %ld:%"UVuf,
964 (long)kid->op_type, (UV)kid->op_targ);
965 kid = kLISTOP->op_first;
967 while (kid->op_sibling)
968 kid = kid->op_sibling;
969 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
971 if (kid->op_type == OP_METHOD_NAMED
972 || kid->op_type == OP_METHOD)
976 NewOp(1101, newop, 1, UNOP);
977 newop->op_type = OP_RV2CV;
978 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
979 newop->op_first = Nullop;
980 newop->op_next = (OP*)newop;
981 kid->op_sibling = (OP*)newop;
982 newop->op_private |= OPpLVAL_INTRO;
986 if (kid->op_type != OP_RV2CV)
988 "panic: unexpected lvalue entersub "
989 "entry via type/targ %ld:%"UVuf,
990 (long)kid->op_type, (UV)kid->op_targ);
991 kid->op_private |= OPpLVAL_INTRO;
992 break; /* Postpone until runtime */
996 kid = kUNOP->op_first;
997 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
998 kid = kUNOP->op_first;
999 if (kid->op_type == OP_NULL)
1001 "Unexpected constant lvalue entersub "
1002 "entry via type/targ %ld:%"UVuf,
1003 (long)kid->op_type, (UV)kid->op_targ);
1004 if (kid->op_type != OP_GV) {
1005 /* Restore RV2CV to check lvalueness */
1007 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1008 okid->op_next = kid->op_next;
1009 kid->op_next = okid;
1012 okid->op_next = Nullop;
1013 okid->op_type = OP_RV2CV;
1015 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1016 okid->op_private |= OPpLVAL_INTRO;
1020 cv = GvCV(kGVOP_gv);
1030 /* grep, foreach, subcalls, refgen */
1031 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1033 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1034 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1036 : (o->op_type == OP_ENTERSUB
1037 ? "non-lvalue subroutine call"
1039 type ? PL_op_desc[type] : "local"));
1053 case OP_RIGHT_SHIFT:
1062 if (!(o->op_flags & OPf_STACKED))
1069 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1075 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1076 PL_modcount = RETURN_UNLIMITED_NUMBER;
1077 return o; /* Treat \(@foo) like ordinary list. */
1081 if (scalar_mod_type(o, type))
1083 ref(cUNOPo->op_first, o->op_type);
1087 if (type == OP_LEAVESUBLV)
1088 o->op_private |= OPpMAYBE_LVSUB;
1094 PL_modcount = RETURN_UNLIMITED_NUMBER;
1097 ref(cUNOPo->op_first, o->op_type);
1102 PL_hints |= HINT_BLOCK_SCOPE;
1117 PL_modcount = RETURN_UNLIMITED_NUMBER;
1118 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1119 return o; /* Treat \(@foo) like ordinary list. */
1120 if (scalar_mod_type(o, type))
1122 if (type == OP_LEAVESUBLV)
1123 o->op_private |= OPpMAYBE_LVSUB;
1127 if (!type) /* local() */
1128 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1129 PAD_COMPNAME_PV(o->op_targ));
1137 if (type != OP_SASSIGN)
1141 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1146 if (type == OP_LEAVESUBLV)
1147 o->op_private |= OPpMAYBE_LVSUB;
1149 pad_free(o->op_targ);
1150 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1151 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1152 if (o->op_flags & OPf_KIDS)
1153 mod(cBINOPo->op_first->op_sibling, type);
1158 ref(cBINOPo->op_first, o->op_type);
1159 if (type == OP_ENTERSUB &&
1160 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1161 o->op_private |= OPpLVAL_DEFER;
1162 if (type == OP_LEAVESUBLV)
1163 o->op_private |= OPpMAYBE_LVSUB;
1173 if (o->op_flags & OPf_KIDS)
1174 mod(cLISTOPo->op_last, type);
1179 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1181 else if (!(o->op_flags & OPf_KIDS))
1183 if (o->op_targ != OP_LIST) {
1184 mod(cBINOPo->op_first, type);
1190 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1195 if (type != OP_LEAVESUBLV)
1197 break; /* mod()ing was handled by ck_return() */
1200 /* [20011101.069] File test operators interpret OPf_REF to mean that
1201 their argument is a filehandle; thus \stat(".") should not set
1203 if (type == OP_REFGEN &&
1204 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1207 if (type != OP_LEAVESUBLV)
1208 o->op_flags |= OPf_MOD;
1210 if (type == OP_AASSIGN || type == OP_SASSIGN)
1211 o->op_flags |= OPf_SPECIAL|OPf_REF;
1212 else if (!type) { /* local() */
1215 o->op_private |= OPpLVAL_INTRO;
1216 o->op_flags &= ~OPf_SPECIAL;
1217 PL_hints |= HINT_BLOCK_SCOPE;
1222 if (ckWARN(WARN_SYNTAX)) {
1223 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1224 "Useless localization of %s", OP_DESC(o));
1228 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1229 && type != OP_LEAVESUBLV)
1230 o->op_flags |= OPf_REF;
1235 S_scalar_mod_type(pTHX_ OP *o, I32 type)
1239 if (o->op_type == OP_RV2GV)
1263 case OP_RIGHT_SHIFT:
1282 S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
1284 switch (o->op_type) {
1292 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1305 Perl_refkids(pTHX_ OP *o, I32 type)
1308 if (o && o->op_flags & OPf_KIDS) {
1309 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1316 Perl_ref(pTHX_ OP *o, I32 type)
1320 if (!o || PL_error_count)
1323 switch (o->op_type) {
1325 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1326 !(o->op_flags & OPf_STACKED)) {
1327 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1328 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1329 assert(cUNOPo->op_first->op_type == OP_NULL);
1330 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1331 o->op_flags |= OPf_SPECIAL;
1336 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1340 if (type == OP_DEFINED)
1341 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1342 ref(cUNOPo->op_first, o->op_type);
1345 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1346 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1347 : type == OP_RV2HV ? OPpDEREF_HV
1349 o->op_flags |= OPf_MOD;
1354 o->op_flags |= OPf_MOD; /* XXX ??? */
1359 o->op_flags |= OPf_REF;
1362 if (type == OP_DEFINED)
1363 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1364 ref(cUNOPo->op_first, o->op_type);
1369 o->op_flags |= OPf_REF;
1374 if (!(o->op_flags & OPf_KIDS))
1376 ref(cBINOPo->op_first, type);
1380 ref(cBINOPo->op_first, o->op_type);
1381 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1382 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1383 : type == OP_RV2HV ? OPpDEREF_HV
1385 o->op_flags |= OPf_MOD;
1393 if (!(o->op_flags & OPf_KIDS))
1395 ref(cLISTOPo->op_last, type);
1405 S_dup_attrlist(pTHX_ OP *o)
1409 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1410 * where the first kid is OP_PUSHMARK and the remaining ones
1411 * are OP_CONST. We need to push the OP_CONST values.
1413 if (o->op_type == OP_CONST)
1414 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1416 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1417 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1418 if (o->op_type == OP_CONST)
1419 rop = append_elem(OP_LIST, rop,
1420 newSVOP(OP_CONST, o->op_flags,
1421 SvREFCNT_inc(cSVOPo->op_sv)));
1428 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1432 /* fake up C<use attributes $pkg,$rv,@attrs> */
1433 ENTER; /* need to protect against side-effects of 'use' */
1436 stashsv = newSVpv(HvNAME(stash), 0);
1438 stashsv = &PL_sv_no;
1440 #define ATTRSMODULE "attributes"
1441 #define ATTRSMODULE_PM "attributes.pm"
1445 /* Don't force the C<use> if we don't need it. */
1446 svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
1447 sizeof(ATTRSMODULE_PM)-1, 0);
1448 if (svp && *svp != &PL_sv_undef)
1449 ; /* already in %INC */
1451 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1452 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1456 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1457 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1459 prepend_elem(OP_LIST,
1460 newSVOP(OP_CONST, 0, stashsv),
1461 prepend_elem(OP_LIST,
1462 newSVOP(OP_CONST, 0,
1464 dup_attrlist(attrs))));
1470 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1472 OP *pack, *imop, *arg;
1478 assert(target->op_type == OP_PADSV ||
1479 target->op_type == OP_PADHV ||
1480 target->op_type == OP_PADAV);
1482 /* Ensure that attributes.pm is loaded. */
1483 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1485 /* Need package name for method call. */
1486 pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
1488 /* Build up the real arg-list. */
1490 stashsv = newSVpv(HvNAME(stash), 0);
1492 stashsv = &PL_sv_no;
1493 arg = newOP(OP_PADSV, 0);
1494 arg->op_targ = target->op_targ;
1495 arg = prepend_elem(OP_LIST,
1496 newSVOP(OP_CONST, 0, stashsv),
1497 prepend_elem(OP_LIST,
1498 newUNOP(OP_REFGEN, 0,
1499 mod(arg, OP_REFGEN)),
1500 dup_attrlist(attrs)));
1502 /* Fake up a method call to import */
1503 meth = newSVpvn("import", 6);
1504 (void)SvUPGRADE(meth, SVt_PVIV);
1505 (void)SvIOK_on(meth);
1506 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
1507 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1508 append_elem(OP_LIST,
1509 prepend_elem(OP_LIST, pack, list(arg)),
1510 newSVOP(OP_METHOD_NAMED, 0, meth)));
1511 imop->op_private |= OPpENTERSUB_NOMOD;
1513 /* Combine the ops. */
1514 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1518 =notfor apidoc apply_attrs_string
1520 Attempts to apply a list of attributes specified by the C<attrstr> and
1521 C<len> arguments to the subroutine identified by the C<cv> argument which
1522 is expected to be associated with the package identified by the C<stashpv>
1523 argument (see L<attributes>). It gets this wrong, though, in that it
1524 does not correctly identify the boundaries of the individual attribute
1525 specifications within C<attrstr>. This is not really intended for the
1526 public API, but has to be listed here for systems such as AIX which
1527 need an explicit export list for symbols. (It's called from XS code
1528 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1529 to respect attribute syntax properly would be welcome.
1535 Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
1536 char *attrstr, STRLEN len)
1541 len = strlen(attrstr);
1545 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1547 char *sstr = attrstr;
1548 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1549 attrs = append_elem(OP_LIST, attrs,
1550 newSVOP(OP_CONST, 0,
1551 newSVpvn(sstr, attrstr-sstr)));
1555 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1556 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1557 Nullsv, prepend_elem(OP_LIST,
1558 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1559 prepend_elem(OP_LIST,
1560 newSVOP(OP_CONST, 0,
1566 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1571 if (!o || PL_error_count)
1575 if (type == OP_LIST) {
1576 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1577 my_kid(kid, attrs, imopsp);
1578 } else if (type == OP_UNDEF) {
1580 } else if (type == OP_RV2SV || /* "our" declaration */
1582 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1583 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1584 yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
1585 OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
1587 GV *gv = cGVOPx_gv(cUNOPo->op_first);
1589 PL_in_my_stash = Nullhv;
1590 apply_attrs(GvSTASH(gv),
1591 (type == OP_RV2SV ? GvSV(gv) :
1592 type == OP_RV2AV ? (SV*)GvAV(gv) :
1593 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1596 o->op_private |= OPpOUR_INTRO;
1599 else if (type != OP_PADSV &&
1602 type != OP_PUSHMARK)
1604 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1606 PL_in_my == KEY_our ? "our" : "my"));
1609 else if (attrs && type != OP_PUSHMARK) {
1613 PL_in_my_stash = Nullhv;
1615 /* check for C<my Dog $spot> when deciding package */
1616 stash = PAD_COMPNAME_TYPE(o->op_targ);
1618 stash = PL_curstash;
1619 apply_attrs_my(stash, o, attrs, imopsp);
1621 o->op_flags |= OPf_MOD;
1622 o->op_private |= OPpLVAL_INTRO;
1627 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1630 int maybe_scalar = 0;
1632 /* [perl #17376]: this appears to be premature, and results in code such as
1633 C< our(%x); > executing in list mode rather than void mode */
1635 if (o->op_flags & OPf_PARENS)
1644 o = my_kid(o, attrs, &rops);
1646 if (maybe_scalar && o->op_type == OP_PADSV) {
1647 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1648 o->op_private |= OPpLVAL_INTRO;
1651 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1654 PL_in_my_stash = Nullhv;
1659 Perl_my(pTHX_ OP *o)
1661 return my_attrs(o, Nullop);
1665 Perl_sawparens(pTHX_ OP *o)
1668 o->op_flags |= OPf_PARENS;
1673 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1678 if (ckWARN(WARN_MISC) &&
1679 (left->op_type == OP_RV2AV ||
1680 left->op_type == OP_RV2HV ||
1681 left->op_type == OP_PADAV ||
1682 left->op_type == OP_PADHV)) {
1683 char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
1684 right->op_type == OP_TRANS)
1685 ? right->op_type : OP_MATCH];
1686 const char *sample = ((left->op_type == OP_RV2AV ||
1687 left->op_type == OP_PADAV)
1688 ? "@array" : "%hash");
1689 Perl_warner(aTHX_ packWARN(WARN_MISC),
1690 "Applying %s to %s will act on scalar(%s)",
1691 desc, sample, sample);
1694 if (right->op_type == OP_CONST &&
1695 cSVOPx(right)->op_private & OPpCONST_BARE &&
1696 cSVOPx(right)->op_private & OPpCONST_STRICT)
1698 no_bareword_allowed(right);
1701 ismatchop = right->op_type == OP_MATCH ||
1702 right->op_type == OP_SUBST ||
1703 right->op_type == OP_TRANS;
1704 if (ismatchop && right->op_private & OPpTARGET_MY) {
1706 right->op_private &= ~OPpTARGET_MY;
1708 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1709 right->op_flags |= OPf_STACKED;
1710 if (right->op_type != OP_MATCH &&
1711 ! (right->op_type == OP_TRANS &&
1712 right->op_private & OPpTRANS_IDENTICAL))
1713 left = mod(left, right->op_type);
1714 if (right->op_type == OP_TRANS)
1715 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
1717 o = prepend_elem(right->op_type, scalar(left), right);
1719 return newUNOP(OP_NOT, 0, scalar(o));
1723 return bind_match(type, left,
1724 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
1728 Perl_invert(pTHX_ OP *o)
1732 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
1733 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1737 Perl_scope(pTHX_ OP *o)
1740 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1741 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1742 o->op_type = OP_LEAVE;
1743 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1745 else if (o->op_type == OP_LINESEQ) {
1747 o->op_type = OP_SCOPE;
1748 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1749 kid = ((LISTOP*)o)->op_first;
1750 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
1754 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
1760 Perl_save_hints(pTHX)
1763 SAVESPTR(GvHV(PL_hintgv));
1764 GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
1765 SAVEFREESV(GvHV(PL_hintgv));
1769 Perl_block_start(pTHX_ int full)
1771 int retval = PL_savestack_ix;
1772 pad_block_start(full);
1774 PL_hints &= ~HINT_BLOCK_SCOPE;
1775 SAVESPTR(PL_compiling.cop_warnings);
1776 if (! specialWARN(PL_compiling.cop_warnings)) {
1777 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1778 SAVEFREESV(PL_compiling.cop_warnings) ;
1780 SAVESPTR(PL_compiling.cop_io);
1781 if (! specialCopIO(PL_compiling.cop_io)) {
1782 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1783 SAVEFREESV(PL_compiling.cop_io) ;
1789 Perl_block_end(pTHX_ I32 floor, OP *seq)
1791 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1792 OP* retval = scalarseq(seq);
1794 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
1796 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
1804 I32 offset = pad_findmy("$_");
1805 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
1806 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1809 OP *o = newOP(OP_PADSV, 0);
1810 o->op_targ = offset;
1816 Perl_newPROG(pTHX_ OP *o)
1821 PL_eval_root = newUNOP(OP_LEAVEEVAL,
1822 ((PL_in_eval & EVAL_KEEPERR)
1823 ? OPf_SPECIAL : 0), o);
1824 PL_eval_start = linklist(PL_eval_root);
1825 PL_eval_root->op_private |= OPpREFCOUNTED;
1826 OpREFCNT_set(PL_eval_root, 1);
1827 PL_eval_root->op_next = 0;
1828 CALL_PEEP(PL_eval_start);
1831 if (o->op_type == OP_STUB) {
1832 PL_comppad_name = 0;
1837 PL_main_root = scope(sawparens(scalarvoid(o)));
1838 PL_curcop = &PL_compiling;
1839 PL_main_start = LINKLIST(PL_main_root);
1840 PL_main_root->op_private |= OPpREFCOUNTED;
1841 OpREFCNT_set(PL_main_root, 1);
1842 PL_main_root->op_next = 0;
1843 CALL_PEEP(PL_main_start);
1846 /* Register with debugger */
1848 CV *cv = get_cv("DB::postponed", FALSE);
1852 XPUSHs((SV*)CopFILEGV(&PL_compiling));
1854 call_sv((SV*)cv, G_DISCARD);
1861 Perl_localize(pTHX_ OP *o, I32 lex)
1863 if (o->op_flags & OPf_PARENS)
1864 /* [perl #17376]: this appears to be premature, and results in code such as
1865 C< our(%x); > executing in list mode rather than void mode */
1872 if (ckWARN(WARN_PARENTHESIS)
1873 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
1875 char *s = PL_bufptr;
1878 /* some heuristics to detect a potential error */
1879 while (*s && (strchr(", \t\n", *s)))
1883 if (*s && strchr("@$%*", *s) && *++s
1884 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
1887 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
1889 while (*s && (strchr(", \t\n", *s)))
1895 if (sigil && (*s == ';' || *s == '=')) {
1896 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
1897 "Parentheses missing around \"%s\" list",
1898 lex ? (PL_in_my == KEY_our ? "our" : "my")
1906 o = mod(o, OP_NULL); /* a bit kludgey */
1908 PL_in_my_stash = Nullhv;
1913 Perl_jmaybe(pTHX_ OP *o)
1915 if (o->op_type == OP_LIST) {
1917 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
1918 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
1924 Perl_fold_constants(pTHX_ register OP *o)
1927 I32 type = o->op_type;
1930 if (PL_opargs[type] & OA_RETSCALAR)
1932 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
1933 o->op_targ = pad_alloc(type, SVs_PADTMP);
1935 /* integerize op, unless it happens to be C<-foo>.
1936 * XXX should pp_i_negate() do magic string negation instead? */
1937 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
1938 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
1939 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
1941 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
1944 if (!(PL_opargs[type] & OA_FOLDCONST))
1949 /* XXX might want a ck_negate() for this */
1950 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
1962 /* XXX what about the numeric ops? */
1963 if (PL_hints & HINT_LOCALE)
1968 goto nope; /* Don't try to run w/ errors */
1970 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
1971 if ((curop->op_type != OP_CONST ||
1972 (curop->op_private & OPpCONST_BARE)) &&
1973 curop->op_type != OP_LIST &&
1974 curop->op_type != OP_SCALAR &&
1975 curop->op_type != OP_NULL &&
1976 curop->op_type != OP_PUSHMARK)
1982 curop = LINKLIST(o);
1986 sv = *(PL_stack_sp--);
1987 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
1988 pad_swipe(o->op_targ, FALSE);
1989 else if (SvTEMP(sv)) { /* grab mortal temp? */
1990 (void)SvREFCNT_inc(sv);
1994 if (type == OP_RV2GV)
1995 return newGVOP(OP_GV, 0, (GV*)sv);
1996 return newSVOP(OP_CONST, 0, sv);
2003 Perl_gen_constant_list(pTHX_ register OP *o)
2006 I32 oldtmps_floor = PL_tmps_floor;
2010 return o; /* Don't attempt to run with errors */
2012 PL_op = curop = LINKLIST(o);
2019 PL_tmps_floor = oldtmps_floor;
2021 o->op_type = OP_RV2AV;
2022 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2023 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2024 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2025 o->op_seq = 0; /* needs to be revisited in peep() */
2026 curop = ((UNOP*)o)->op_first;
2027 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2034 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2036 if (!o || o->op_type != OP_LIST)
2037 o = newLISTOP(OP_LIST, 0, o, Nullop);
2039 o->op_flags &= ~OPf_WANT;
2041 if (!(PL_opargs[type] & OA_MARK))
2042 op_null(cLISTOPo->op_first);
2044 o->op_type = (OPCODE)type;
2045 o->op_ppaddr = PL_ppaddr[type];
2046 o->op_flags |= flags;
2048 o = CHECKOP(type, o);
2049 if (o->op_type != type)
2052 return fold_constants(o);
2055 /* List constructors */
2058 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2066 if (first->op_type != type
2067 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2069 return newLISTOP(type, 0, first, last);
2072 if (first->op_flags & OPf_KIDS)
2073 ((LISTOP*)first)->op_last->op_sibling = last;
2075 first->op_flags |= OPf_KIDS;
2076 ((LISTOP*)first)->op_first = last;
2078 ((LISTOP*)first)->op_last = last;
2083 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2091 if (first->op_type != type)
2092 return prepend_elem(type, (OP*)first, (OP*)last);
2094 if (last->op_type != type)
2095 return append_elem(type, (OP*)first, (OP*)last);
2097 first->op_last->op_sibling = last->op_first;
2098 first->op_last = last->op_last;
2099 first->op_flags |= (last->op_flags & OPf_KIDS);
2107 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2115 if (last->op_type == type) {
2116 if (type == OP_LIST) { /* already a PUSHMARK there */
2117 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2118 ((LISTOP*)last)->op_first->op_sibling = first;
2119 if (!(first->op_flags & OPf_PARENS))
2120 last->op_flags &= ~OPf_PARENS;
2123 if (!(last->op_flags & OPf_KIDS)) {
2124 ((LISTOP*)last)->op_last = first;
2125 last->op_flags |= OPf_KIDS;
2127 first->op_sibling = ((LISTOP*)last)->op_first;
2128 ((LISTOP*)last)->op_first = first;
2130 last->op_flags |= OPf_KIDS;
2134 return newLISTOP(type, 0, first, last);
2140 Perl_newNULLLIST(pTHX)
2142 return newOP(OP_STUB, 0);
2146 Perl_force_list(pTHX_ OP *o)
2148 if (!o || o->op_type != OP_LIST)
2149 o = newLISTOP(OP_LIST, 0, o, Nullop);
2155 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2159 NewOp(1101, listop, 1, LISTOP);
2161 listop->op_type = (OPCODE)type;
2162 listop->op_ppaddr = PL_ppaddr[type];
2165 listop->op_flags = (U8)flags;
2169 else if (!first && last)
2172 first->op_sibling = last;
2173 listop->op_first = first;
2174 listop->op_last = last;
2175 if (type == OP_LIST) {
2177 pushop = newOP(OP_PUSHMARK, 0);
2178 pushop->op_sibling = first;
2179 listop->op_first = pushop;
2180 listop->op_flags |= OPf_KIDS;
2182 listop->op_last = pushop;
2185 return CHECKOP(type, listop);
2189 Perl_newOP(pTHX_ I32 type, I32 flags)
2192 NewOp(1101, o, 1, OP);
2193 o->op_type = (OPCODE)type;
2194 o->op_ppaddr = PL_ppaddr[type];
2195 o->op_flags = (U8)flags;
2198 o->op_private = (U8)(0 | (flags >> 8));
2199 if (PL_opargs[type] & OA_RETSCALAR)
2201 if (PL_opargs[type] & OA_TARGET)
2202 o->op_targ = pad_alloc(type, SVs_PADTMP);
2203 return CHECKOP(type, o);
2207 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2212 first = newOP(OP_STUB, 0);
2213 if (PL_opargs[type] & OA_MARK)
2214 first = force_list(first);
2216 NewOp(1101, unop, 1, UNOP);
2217 unop->op_type = (OPCODE)type;
2218 unop->op_ppaddr = PL_ppaddr[type];
2219 unop->op_first = first;
2220 unop->op_flags = flags | OPf_KIDS;
2221 unop->op_private = (U8)(1 | (flags >> 8));
2222 unop = (UNOP*) CHECKOP(type, unop);
2226 return fold_constants((OP *) unop);
2230 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2233 NewOp(1101, binop, 1, BINOP);
2236 first = newOP(OP_NULL, 0);
2238 binop->op_type = (OPCODE)type;
2239 binop->op_ppaddr = PL_ppaddr[type];
2240 binop->op_first = first;
2241 binop->op_flags = flags | OPf_KIDS;
2244 binop->op_private = (U8)(1 | (flags >> 8));
2247 binop->op_private = (U8)(2 | (flags >> 8));
2248 first->op_sibling = last;
2251 binop = (BINOP*)CHECKOP(type, binop);
2252 if (binop->op_next || binop->op_type != (OPCODE)type)
2255 binop->op_last = binop->op_first->op_sibling;
2257 return fold_constants((OP *)binop);
2261 uvcompare(const void *a, const void *b)
2263 if (*((UV *)a) < (*(UV *)b))
2265 if (*((UV *)a) > (*(UV *)b))
2267 if (*((UV *)a+1) < (*(UV *)b+1))
2269 if (*((UV *)a+1) > (*(UV *)b+1))
2275 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2277 SV *tstr = ((SVOP*)expr)->op_sv;
2278 SV *rstr = ((SVOP*)repl)->op_sv;
2281 U8 *t = (U8*)SvPV(tstr, tlen);
2282 U8 *r = (U8*)SvPV(rstr, rlen);
2289 register short *tbl;
2291 PL_hints |= HINT_BLOCK_SCOPE;
2292 complement = o->op_private & OPpTRANS_COMPLEMENT;
2293 del = o->op_private & OPpTRANS_DELETE;
2294 squash = o->op_private & OPpTRANS_SQUASH;
2297 o->op_private |= OPpTRANS_FROM_UTF;
2300 o->op_private |= OPpTRANS_TO_UTF;
2302 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2303 SV* listsv = newSVpvn("# comment\n",10);
2305 U8* tend = t + tlen;
2306 U8* rend = r + rlen;
2320 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2321 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2327 tsave = t = bytes_to_utf8(t, &len);
2330 if (!to_utf && rlen) {
2332 rsave = r = bytes_to_utf8(r, &len);
2336 /* There are several snags with this code on EBCDIC:
2337 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2338 2. scan_const() in toke.c has encoded chars in native encoding which makes
2339 ranges at least in EBCDIC 0..255 range the bottom odd.
2343 U8 tmpbuf[UTF8_MAXLEN+1];
2346 New(1109, cp, 2*tlen, UV);
2348 transv = newSVpvn("",0);
2350 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2352 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2354 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2358 cp[2*i+1] = cp[2*i];
2362 qsort(cp, i, 2*sizeof(UV), uvcompare);
2363 for (j = 0; j < i; j++) {
2365 diff = val - nextmin;
2367 t = uvuni_to_utf8(tmpbuf,nextmin);
2368 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2370 U8 range_mark = UTF_TO_NATIVE(0xff);
2371 t = uvuni_to_utf8(tmpbuf, val - 1);
2372 sv_catpvn(transv, (char *)&range_mark, 1);
2373 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2380 t = uvuni_to_utf8(tmpbuf,nextmin);
2381 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2383 U8 range_mark = UTF_TO_NATIVE(0xff);
2384 sv_catpvn(transv, (char *)&range_mark, 1);
2386 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2387 UNICODE_ALLOW_SUPER);
2388 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2389 t = (U8*)SvPVX(transv);
2390 tlen = SvCUR(transv);
2394 else if (!rlen && !del) {
2395 r = t; rlen = tlen; rend = tend;
2398 if ((!rlen && !del) || t == r ||
2399 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2401 o->op_private |= OPpTRANS_IDENTICAL;
2405 while (t < tend || tfirst <= tlast) {
2406 /* see if we need more "t" chars */
2407 if (tfirst > tlast) {
2408 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2410 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2412 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2419 /* now see if we need more "r" chars */
2420 if (rfirst > rlast) {
2422 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2424 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2426 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2435 rfirst = rlast = 0xffffffff;
2439 /* now see which range will peter our first, if either. */
2440 tdiff = tlast - tfirst;
2441 rdiff = rlast - rfirst;
2448 if (rfirst == 0xffffffff) {
2449 diff = tdiff; /* oops, pretend rdiff is infinite */
2451 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2452 (long)tfirst, (long)tlast);
2454 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2458 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2459 (long)tfirst, (long)(tfirst + diff),
2462 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2463 (long)tfirst, (long)rfirst);
2465 if (rfirst + diff > max)
2466 max = rfirst + diff;
2468 grows = (tfirst < rfirst &&
2469 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2481 else if (max > 0xff)
2486 Safefree(cPVOPo->op_pv);
2487 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2488 SvREFCNT_dec(listsv);
2490 SvREFCNT_dec(transv);
2492 if (!del && havefinal && rlen)
2493 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2494 newSVuv((UV)final), 0);
2497 o->op_private |= OPpTRANS_GROWS;
2509 tbl = (short*)cPVOPo->op_pv;
2511 Zero(tbl, 256, short);
2512 for (i = 0; i < (I32)tlen; i++)
2514 for (i = 0, j = 0; i < 256; i++) {
2516 if (j >= (I32)rlen) {
2525 if (i < 128 && r[j] >= 128)
2535 o->op_private |= OPpTRANS_IDENTICAL;
2537 else if (j >= (I32)rlen)
2540 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2541 tbl[0x100] = rlen - j;
2542 for (i=0; i < (I32)rlen - j; i++)
2543 tbl[0x101+i] = r[j+i];
2547 if (!rlen && !del) {
2550 o->op_private |= OPpTRANS_IDENTICAL;
2552 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2553 o->op_private |= OPpTRANS_IDENTICAL;
2555 for (i = 0; i < 256; i++)
2557 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
2558 if (j >= (I32)rlen) {
2560 if (tbl[t[i]] == -1)
2566 if (tbl[t[i]] == -1) {
2567 if (t[i] < 128 && r[j] >= 128)
2574 o->op_private |= OPpTRANS_GROWS;
2582 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2586 NewOp(1101, pmop, 1, PMOP);
2587 pmop->op_type = (OPCODE)type;
2588 pmop->op_ppaddr = PL_ppaddr[type];
2589 pmop->op_flags = (U8)flags;
2590 pmop->op_private = (U8)(0 | (flags >> 8));
2592 if (PL_hints & HINT_RE_TAINT)
2593 pmop->op_pmpermflags |= PMf_RETAINT;
2594 if (PL_hints & HINT_LOCALE)
2595 pmop->op_pmpermflags |= PMf_LOCALE;
2596 pmop->op_pmflags = pmop->op_pmpermflags;
2601 if(av_len((AV*) PL_regex_pad[0]) > -1) {
2602 repointer = av_pop((AV*)PL_regex_pad[0]);
2603 pmop->op_pmoffset = SvIV(repointer);
2604 SvREPADTMP_off(repointer);
2605 sv_setiv(repointer,0);
2607 repointer = newSViv(0);
2608 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2609 pmop->op_pmoffset = av_len(PL_regex_padav);
2610 PL_regex_pad = AvARRAY(PL_regex_padav);
2615 /* link into pm list */
2616 if (type != OP_TRANS && PL_curstash) {
2617 pmop->op_pmnext = HvPMROOT(PL_curstash);
2618 HvPMROOT(PL_curstash) = pmop;
2619 PmopSTASH_set(pmop,PL_curstash);
2622 return CHECKOP(type, pmop);
2626 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
2630 I32 repl_has_vars = 0;
2632 if (o->op_type == OP_TRANS)
2633 return pmtrans(o, expr, repl);
2635 PL_hints |= HINT_BLOCK_SCOPE;
2638 if (expr->op_type == OP_CONST) {
2640 SV *pat = ((SVOP*)expr)->op_sv;
2641 char *p = SvPV(pat, plen);
2642 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
2643 sv_setpvn(pat, "\\s+", 3);
2644 p = SvPV(pat, plen);
2645 pm->op_pmflags |= PMf_SKIPWHITE;
2648 pm->op_pmdynflags |= PMdf_UTF8;
2649 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
2650 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
2651 pm->op_pmflags |= PMf_WHITE;
2655 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2656 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2658 : OP_REGCMAYBE),0,expr);
2660 NewOp(1101, rcop, 1, LOGOP);
2661 rcop->op_type = OP_REGCOMP;
2662 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2663 rcop->op_first = scalar(expr);
2664 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
2665 ? (OPf_SPECIAL | OPf_KIDS)
2667 rcop->op_private = 1;
2669 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
2672 /* establish postfix order */
2673 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2675 rcop->op_next = expr;
2676 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2679 rcop->op_next = LINKLIST(expr);
2680 expr->op_next = (OP*)rcop;
2683 prepend_elem(o->op_type, scalar((OP*)rcop), o);
2688 if (pm->op_pmflags & PMf_EVAL) {
2690 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
2691 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
2693 else if (repl->op_type == OP_CONST)
2697 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
2698 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
2699 if (curop->op_type == OP_GV) {
2700 GV *gv = cGVOPx_gv(curop);
2702 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
2705 else if (curop->op_type == OP_RV2CV)
2707 else if (curop->op_type == OP_RV2SV ||
2708 curop->op_type == OP_RV2AV ||
2709 curop->op_type == OP_RV2HV ||
2710 curop->op_type == OP_RV2GV) {
2711 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2714 else if (curop->op_type == OP_PADSV ||
2715 curop->op_type == OP_PADAV ||
2716 curop->op_type == OP_PADHV ||
2717 curop->op_type == OP_PADANY) {
2720 else if (curop->op_type == OP_PUSHRE)
2721 ; /* Okay here, dangerous in newASSIGNOP */
2731 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
2732 pm->op_pmflags |= PMf_CONST; /* const for long enough */
2733 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
2734 prepend_elem(o->op_type, scalar(repl), o);
2737 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
2738 pm->op_pmflags |= PMf_MAYBE_CONST;
2739 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2741 NewOp(1101, rcop, 1, LOGOP);
2742 rcop->op_type = OP_SUBSTCONT;
2743 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
2744 rcop->op_first = scalar(repl);
2745 rcop->op_flags |= OPf_KIDS;
2746 rcop->op_private = 1;
2749 /* establish postfix order */
2750 rcop->op_next = LINKLIST(repl);
2751 repl->op_next = (OP*)rcop;
2753 pm->op_pmreplroot = scalar((OP*)rcop);
2754 pm->op_pmreplstart = LINKLIST(rcop);
2763 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
2766 NewOp(1101, svop, 1, SVOP);
2767 svop->op_type = (OPCODE)type;
2768 svop->op_ppaddr = PL_ppaddr[type];
2770 svop->op_next = (OP*)svop;
2771 svop->op_flags = (U8)flags;
2772 if (PL_opargs[type] & OA_RETSCALAR)
2774 if (PL_opargs[type] & OA_TARGET)
2775 svop->op_targ = pad_alloc(type, SVs_PADTMP);
2776 return CHECKOP(type, svop);
2780 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2783 NewOp(1101, padop, 1, PADOP);
2784 padop->op_type = (OPCODE)type;
2785 padop->op_ppaddr = PL_ppaddr[type];
2786 padop->op_padix = pad_alloc(type, SVs_PADTMP);
2787 SvREFCNT_dec(PAD_SVl(padop->op_padix));
2788 PAD_SETSV(padop->op_padix, sv);
2791 padop->op_next = (OP*)padop;
2792 padop->op_flags = (U8)flags;
2793 if (PL_opargs[type] & OA_RETSCALAR)
2795 if (PL_opargs[type] & OA_TARGET)
2796 padop->op_targ = pad_alloc(type, SVs_PADTMP);
2797 return CHECKOP(type, padop);
2801 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
2806 return newPADOP(type, flags, SvREFCNT_inc(gv));
2808 return newSVOP(type, flags, SvREFCNT_inc(gv));
2813 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
2816 NewOp(1101, pvop, 1, PVOP);
2817 pvop->op_type = (OPCODE)type;
2818 pvop->op_ppaddr = PL_ppaddr[type];
2820 pvop->op_next = (OP*)pvop;
2821 pvop->op_flags = (U8)flags;
2822 if (PL_opargs[type] & OA_RETSCALAR)
2824 if (PL_opargs[type] & OA_TARGET)
2825 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
2826 return CHECKOP(type, pvop);
2830 Perl_package(pTHX_ OP *o)
2835 save_hptr(&PL_curstash);
2836 save_item(PL_curstname);
2838 name = SvPV(cSVOPo->op_sv, len);
2839 PL_curstash = gv_stashpvn(name, len, TRUE);
2840 sv_setpvn(PL_curstname, name, len);
2843 PL_hints |= HINT_BLOCK_SCOPE;
2844 PL_copline = NOLINE;
2849 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
2855 if (idop->op_type != OP_CONST)
2856 Perl_croak(aTHX_ "Module name must be constant");
2860 if (version != Nullop) {
2861 SV *vesv = ((SVOP*)version)->op_sv;
2863 if (arg == Nullop && !SvNIOKp(vesv)) {
2870 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
2871 Perl_croak(aTHX_ "Version number must be constant number");
2873 /* Make copy of idop so we don't free it twice */
2874 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
2876 /* Fake up a method call to VERSION */
2877 meth = newSVpvn("VERSION",7);
2878 sv_upgrade(meth, SVt_PVIV);
2879 (void)SvIOK_on(meth);
2880 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
2881 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2882 append_elem(OP_LIST,
2883 prepend_elem(OP_LIST, pack, list(version)),
2884 newSVOP(OP_METHOD_NAMED, 0, meth)));
2888 /* Fake up an import/unimport */
2889 if (arg && arg->op_type == OP_STUB)
2890 imop = arg; /* no import on explicit () */
2891 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
2892 imop = Nullop; /* use 5.0; */
2897 /* Make copy of idop so we don't free it twice */
2898 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
2900 /* Fake up a method call to import/unimport */
2901 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);
2902 (void)SvUPGRADE(meth, SVt_PVIV);
2903 (void)SvIOK_on(meth);
2904 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
2905 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2906 append_elem(OP_LIST,
2907 prepend_elem(OP_LIST, pack, list(arg)),
2908 newSVOP(OP_METHOD_NAMED, 0, meth)));
2911 /* Fake up the BEGIN {}, which does its thing immediately. */
2913 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
2916 append_elem(OP_LINESEQ,
2917 append_elem(OP_LINESEQ,
2918 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, idop)),
2919 newSTATEOP(0, Nullch, veop)),
2920 newSTATEOP(0, Nullch, imop) ));
2922 /* The "did you use incorrect case?" warning used to be here.
2923 * The problem is that on case-insensitive filesystems one
2924 * might get false positives for "use" (and "require"):
2925 * "use Strict" or "require CARP" will work. This causes
2926 * portability problems for the script: in case-strict
2927 * filesystems the script will stop working.
2929 * The "incorrect case" warning checked whether "use Foo"
2930 * imported "Foo" to your namespace, but that is wrong, too:
2931 * there is no requirement nor promise in the language that
2932 * a Foo.pm should or would contain anything in package "Foo".
2934 * There is very little Configure-wise that can be done, either:
2935 * the case-sensitivity of the build filesystem of Perl does not
2936 * help in guessing the case-sensitivity of the runtime environment.
2939 PL_hints |= HINT_BLOCK_SCOPE;
2940 PL_copline = NOLINE;
2942 PL_cop_seqmax++; /* Purely for B::*'s benefit */
2946 =head1 Embedding Functions
2948 =for apidoc load_module
2950 Loads the module whose name is pointed to by the string part of name.
2951 Note that the actual module name, not its filename, should be given.
2952 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
2953 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
2954 (or 0 for no flags). ver, if specified, provides version semantics
2955 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
2956 arguments can be used to specify arguments to the module's import()
2957 method, similar to C<use Foo::Bar VERSION LIST>.
2962 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
2965 va_start(args, ver);
2966 vload_module(flags, name, ver, &args);
2970 #ifdef PERL_IMPLICIT_CONTEXT
2972 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
2976 va_start(args, ver);
2977 vload_module(flags, name, ver, &args);
2983 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
2985 OP *modname, *veop, *imop;
2987 modname = newSVOP(OP_CONST, 0, name);
2988 modname->op_private |= OPpCONST_BARE;
2990 veop = newSVOP(OP_CONST, 0, ver);
2994 if (flags & PERL_LOADMOD_NOIMPORT) {
2995 imop = sawparens(newNULLLIST());
2997 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
2998 imop = va_arg(*args, OP*);
3003 sv = va_arg(*args, SV*);
3005 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3006 sv = va_arg(*args, SV*);
3010 line_t ocopline = PL_copline;
3011 COP *ocurcop = PL_curcop;
3012 int oexpect = PL_expect;
3014 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3015 veop, modname, imop);
3016 PL_expect = oexpect;
3017 PL_copline = ocopline;
3018 PL_curcop = ocurcop;
3023 Perl_dofile(pTHX_ OP *term)
3028 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3029 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
3030 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3032 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3033 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3034 append_elem(OP_LIST, term,
3035 scalar(newUNOP(OP_RV2CV, 0,
3040 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3046 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3048 return newBINOP(OP_LSLICE, flags,
3049 list(force_list(subscript)),
3050 list(force_list(listval)) );
3054 S_list_assignment(pTHX_ register OP *o)
3059 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3060 o = cUNOPo->op_first;
3062 if (o->op_type == OP_COND_EXPR) {
3063 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3064 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3069 yyerror("Assignment to both a list and a scalar");
3073 if (o->op_type == OP_LIST &&
3074 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3075 o->op_private & OPpLVAL_INTRO)
3078 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3079 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3080 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3083 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3086 if (o->op_type == OP_RV2SV)
3093 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3098 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3099 return newLOGOP(optype, 0,
3100 mod(scalar(left), optype),
3101 newUNOP(OP_SASSIGN, 0, scalar(right)));
3104 return newBINOP(optype, OPf_STACKED,
3105 mod(scalar(left), optype), scalar(right));
3109 if (list_assignment(left)) {
3113 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3114 left = mod(left, OP_AASSIGN);
3122 curop = list(force_list(left));
3123 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3124 o->op_private = (U8)(0 | (flags >> 8));
3126 /* PL_generation sorcery:
3127 * an assignment like ($a,$b) = ($c,$d) is easier than
3128 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3129 * To detect whether there are common vars, the global var
3130 * PL_generation is incremented for each assign op we compile.
3131 * Then, while compiling the assign op, we run through all the
3132 * variables on both sides of the assignment, setting a spare slot
3133 * in each of them to PL_generation. If any of them already have
3134 * that value, we know we've got commonality. We could use a
3135 * single bit marker, but then we'd have to make 2 passes, first
3136 * to clear the flag, then to test and set it. To find somewhere
3137 * to store these values, evil chicanery is done with SvCUR().
3140 if (!(left->op_private & OPpLVAL_INTRO)) {
3143 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3144 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3145 if (curop->op_type == OP_GV) {
3146 GV *gv = cGVOPx_gv(curop);
3147 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3149 SvCUR(gv) = PL_generation;
3151 else if (curop->op_type == OP_PADSV ||
3152 curop->op_type == OP_PADAV ||
3153 curop->op_type == OP_PADHV ||
3154 curop->op_type == OP_PADANY)
3156 if (PAD_COMPNAME_GEN(curop->op_targ)
3157 == (STRLEN)PL_generation)
3159 PAD_COMPNAME_GEN(curop->op_targ)
3163 else if (curop->op_type == OP_RV2CV)
3165 else if (curop->op_type == OP_RV2SV ||
3166 curop->op_type == OP_RV2AV ||
3167 curop->op_type == OP_RV2HV ||
3168 curop->op_type == OP_RV2GV) {
3169 if (lastop->op_type != OP_GV) /* funny deref? */
3172 else if (curop->op_type == OP_PUSHRE) {
3173 if (((PMOP*)curop)->op_pmreplroot) {
3175 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3176 ((PMOP*)curop)->op_pmreplroot));
3178 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3180 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3182 SvCUR(gv) = PL_generation;
3191 o->op_private |= OPpASSIGN_COMMON;
3193 if (right && right->op_type == OP_SPLIT) {
3195 if ((tmpop = ((LISTOP*)right)->op_first) &&
3196 tmpop->op_type == OP_PUSHRE)
3198 PMOP *pm = (PMOP*)tmpop;
3199 if (left->op_type == OP_RV2AV &&
3200 !(left->op_private & OPpLVAL_INTRO) &&
3201 !(o->op_private & OPpASSIGN_COMMON) )
3203 tmpop = ((UNOP*)left)->op_first;
3204 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3206 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3207 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3209 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3210 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3212 pm->op_pmflags |= PMf_ONCE;
3213 tmpop = cUNOPo->op_first; /* to list (nulled) */
3214 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3215 tmpop->op_sibling = Nullop; /* don't free split */
3216 right->op_next = tmpop->op_next; /* fix starting loc */
3217 op_free(o); /* blow off assign */
3218 right->op_flags &= ~OPf_WANT;
3219 /* "I don't know and I don't care." */
3224 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3225 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3227 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3229 sv_setiv(sv, PL_modcount+1);
3237 right = newOP(OP_UNDEF, 0);
3238 if (right->op_type == OP_READLINE) {
3239 right->op_flags |= OPf_STACKED;
3240 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3243 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3244 o = newBINOP(OP_SASSIGN, flags,
3245 scalar(right), mod(scalar(left), OP_SASSIGN) );
3257 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3259 U32 seq = intro_my();
3262 NewOp(1101, cop, 1, COP);
3263 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3264 cop->op_type = OP_DBSTATE;
3265 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3268 cop->op_type = OP_NEXTSTATE;
3269 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3271 cop->op_flags = (U8)flags;
3272 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3274 cop->op_private |= NATIVE_HINTS;
3276 PL_compiling.op_private = cop->op_private;
3277 cop->op_next = (OP*)cop;
3280 cop->cop_label = label;
3281 PL_hints |= HINT_BLOCK_SCOPE;
3284 cop->cop_arybase = PL_curcop->cop_arybase;
3285 if (specialWARN(PL_curcop->cop_warnings))
3286 cop->cop_warnings = PL_curcop->cop_warnings ;
3288 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3289 if (specialCopIO(PL_curcop->cop_io))
3290 cop->cop_io = PL_curcop->cop_io;
3292 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3295 if (PL_copline == NOLINE)
3296 CopLINE_set(cop, CopLINE(PL_curcop));
3298 CopLINE_set(cop, PL_copline);
3299 PL_copline = NOLINE;
3302 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3304 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3306 CopSTASH_set(cop, PL_curstash);
3308 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3309 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3310 if (svp && *svp != &PL_sv_undef ) {
3311 (void)SvIOK_on(*svp);
3312 SvIVX(*svp) = PTR2IV(cop);
3316 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3321 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3323 return new_logop(type, flags, &first, &other);
3327 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3331 OP *first = *firstp;
3332 OP *other = *otherp;
3334 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3335 return newBINOP(type, flags, scalar(first), scalar(other));
3337 scalarboolean(first);
3338 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3339 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3340 if (type == OP_AND || type == OP_OR) {
3346 first = *firstp = cUNOPo->op_first;
3348 first->op_next = o->op_next;
3349 cUNOPo->op_first = Nullop;
3353 if (first->op_type == OP_CONST) {
3354 if (first->op_private & OPpCONST_STRICT)
3355 no_bareword_allowed(first);
3356 else if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3357 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3358 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3369 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS) &&
3370 type != OP_DOR) /* [#24076] Don't warn for <FH> err FOO. */
3372 OP *k1 = ((UNOP*)first)->op_first;
3373 OP *k2 = k1->op_sibling;
3375 switch (first->op_type)
3378 if (k2 && k2->op_type == OP_READLINE
3379 && (k2->op_flags & OPf_STACKED)
3380 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3382 warnop = k2->op_type;
3387 if (k1->op_type == OP_READDIR
3388 || k1->op_type == OP_GLOB
3389 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3390 || k1->op_type == OP_EACH)
3392 warnop = ((k1->op_type == OP_NULL)
3393 ? (OPCODE)k1->op_targ : k1->op_type);
3398 line_t oldline = CopLINE(PL_curcop);
3399 CopLINE_set(PL_curcop, PL_copline);
3400 Perl_warner(aTHX_ packWARN(WARN_MISC),
3401 "Value of %s%s can be \"0\"; test with defined()",
3403 ((warnop == OP_READLINE || warnop == OP_GLOB)
3404 ? " construct" : "() operator"));
3405 CopLINE_set(PL_curcop, oldline);
3412 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3413 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3415 NewOp(1101, logop, 1, LOGOP);
3417 logop->op_type = (OPCODE)type;
3418 logop->op_ppaddr = PL_ppaddr[type];
3419 logop->op_first = first;
3420 logop->op_flags = flags | OPf_KIDS;
3421 logop->op_other = LINKLIST(other);
3422 logop->op_private = (U8)(1 | (flags >> 8));
3424 /* establish postfix order */
3425 logop->op_next = LINKLIST(first);
3426 first->op_next = (OP*)logop;
3427 first->op_sibling = other;
3429 CHECKOP(type,logop);
3431 o = newUNOP(OP_NULL, 0, (OP*)logop);
3438 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3445 return newLOGOP(OP_AND, 0, first, trueop);
3447 return newLOGOP(OP_OR, 0, first, falseop);
3449 scalarboolean(first);
3450 if (first->op_type == OP_CONST) {
3451 if (first->op_private & OPpCONST_BARE &&
3452 first->op_private & OPpCONST_STRICT) {
3453 no_bareword_allowed(first);
3455 if (SvTRUE(((SVOP*)first)->op_sv)) {
3466 NewOp(1101, logop, 1, LOGOP);
3467 logop->op_type = OP_COND_EXPR;
3468 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3469 logop->op_first = first;
3470 logop->op_flags = flags | OPf_KIDS;
3471 logop->op_private = (U8)(1 | (flags >> 8));
3472 logop->op_other = LINKLIST(trueop);
3473 logop->op_next = LINKLIST(falseop);
3475 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
3478 /* establish postfix order */
3479 start = LINKLIST(first);
3480 first->op_next = (OP*)logop;
3482 first->op_sibling = trueop;
3483 trueop->op_sibling = falseop;
3484 o = newUNOP(OP_NULL, 0, (OP*)logop);
3486 trueop->op_next = falseop->op_next = o;
3493 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3501 NewOp(1101, range, 1, LOGOP);
3503 range->op_type = OP_RANGE;
3504 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3505 range->op_first = left;
3506 range->op_flags = OPf_KIDS;
3507 leftstart = LINKLIST(left);
3508 range->op_other = LINKLIST(right);
3509 range->op_private = (U8)(1 | (flags >> 8));
3511 left->op_sibling = right;
3513 range->op_next = (OP*)range;
3514 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3515 flop = newUNOP(OP_FLOP, 0, flip);
3516 o = newUNOP(OP_NULL, 0, flop);
3518 range->op_next = leftstart;
3520 left->op_next = flip;
3521 right->op_next = flop;
3523 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3524 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3525 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3526 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3528 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3529 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3532 if (!flip->op_private || !flop->op_private)
3533 linklist(o); /* blow off optimizer unless constant */
3539 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3543 int once = block && block->op_flags & OPf_SPECIAL &&
3544 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3547 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3548 return block; /* do {} while 0 does once */
3549 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3550 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3551 expr = newUNOP(OP_DEFINED, 0,
3552 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3553 } else if (expr->op_flags & OPf_KIDS) {
3554 OP *k1 = ((UNOP*)expr)->op_first;
3555 OP *k2 = (k1) ? k1->op_sibling : NULL;
3556 switch (expr->op_type) {
3558 if (k2 && k2->op_type == OP_READLINE
3559 && (k2->op_flags & OPf_STACKED)
3560 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3561 expr = newUNOP(OP_DEFINED, 0, expr);
3565 if (k1->op_type == OP_READDIR
3566 || k1->op_type == OP_GLOB
3567 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3568 || k1->op_type == OP_EACH)
3569 expr = newUNOP(OP_DEFINED, 0, expr);
3575 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3576 o = new_logop(OP_AND, 0, &expr, &listop);
3579 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3581 if (once && o != listop)
3582 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3585 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3587 o->op_flags |= flags;
3589 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3594 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3602 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3603 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3604 expr = newUNOP(OP_DEFINED, 0,
3605 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3606 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3607 OP *k1 = ((UNOP*)expr)->op_first;
3608 OP *k2 = (k1) ? k1->op_sibling : NULL;
3609 switch (expr->op_type) {
3611 if (k2 && k2->op_type == OP_READLINE
3612 && (k2->op_flags & OPf_STACKED)
3613 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3614 expr = newUNOP(OP_DEFINED, 0, expr);
3618 if (k1->op_type == OP_READDIR
3619 || k1->op_type == OP_GLOB
3620 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3621 || k1->op_type == OP_EACH)
3622 expr = newUNOP(OP_DEFINED, 0, expr);
3628 block = newOP(OP_NULL, 0);
3630 block = scope(block);
3634 next = LINKLIST(cont);
3637 OP *unstack = newOP(OP_UNSTACK, 0);
3640 cont = append_elem(OP_LINESEQ, cont, unstack);
3643 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3644 redo = LINKLIST(listop);
3647 PL_copline = (line_t)whileline;
3649 o = new_logop(OP_AND, 0, &expr, &listop);
3650 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3651 op_free(expr); /* oops, it's a while (0) */
3653 return Nullop; /* listop already freed by new_logop */
3656 ((LISTOP*)listop)->op_last->op_next =
3657 (o == listop ? redo : LINKLIST(o));
3663 NewOp(1101,loop,1,LOOP);
3664 loop->op_type = OP_ENTERLOOP;
3665 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3666 loop->op_private = 0;
3667 loop->op_next = (OP*)loop;
3670 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3672 loop->op_redoop = redo;
3673 loop->op_lastop = o;
3674 o->op_private |= loopflags;
3677 loop->op_nextop = next;
3679 loop->op_nextop = o;
3681 o->op_flags |= flags;
3682 o->op_private |= (flags >> 8);
3687 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
3691 PADOFFSET padoff = 0;
3696 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
3697 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
3698 sv->op_type = OP_RV2GV;
3699 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3701 else if (sv->op_type == OP_PADSV) { /* private variable */
3702 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
3703 padoff = sv->op_targ;
3708 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3709 padoff = sv->op_targ;
3711 iterflags |= OPf_SPECIAL;
3716 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3719 I32 offset = pad_findmy("$_");
3720 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
3721 sv = newGVOP(OP_GV, 0, PL_defgv);
3725 iterpflags = OPpLVAL_INTRO; /* my $_; for () */
3728 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3729 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3730 iterflags |= OPf_STACKED;
3732 else if (expr->op_type == OP_NULL &&
3733 (expr->op_flags & OPf_KIDS) &&
3734 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3736 /* Basically turn for($x..$y) into the same as for($x,$y), but we
3737 * set the STACKED flag to indicate that these values are to be
3738 * treated as min/max values by 'pp_iterinit'.
3740 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
3741 LOGOP* range = (LOGOP*) flip->op_first;
3742 OP* left = range->op_first;
3743 OP* right = left->op_sibling;
3746 range->op_flags &= ~OPf_KIDS;
3747 range->op_first = Nullop;
3749 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
3750 listop->op_first->op_next = range->op_next;
3751 left->op_next = range->op_other;
3752 right->op_next = (OP*)listop;
3753 listop->op_next = listop->op_first;
3756 expr = (OP*)(listop);
3758 iterflags |= OPf_STACKED;
3761 expr = mod(force_list(expr), OP_GREPSTART);
3765 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
3766 append_elem(OP_LIST, expr, scalar(sv))));
3767 assert(!loop->op_next);
3768 /* for my $x () sets OPpLVAL_INTRO;
3769 * for our $x () sets OPpOUR_INTRO */
3770 loop->op_private = (U8)iterpflags;
3771 #ifdef PL_OP_SLAB_ALLOC
3774 NewOp(1234,tmp,1,LOOP);
3775 Copy(loop,tmp,1,LOOP);
3780 Renew(loop, 1, LOOP);
3782 loop->op_targ = padoff;
3783 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
3784 PL_copline = forline;
3785 return newSTATEOP(0, label, wop);
3789 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
3794 if (type != OP_GOTO || label->op_type == OP_CONST) {
3795 /* "last()" means "last" */
3796 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
3797 o = newOP(type, OPf_SPECIAL);
3799 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
3800 ? SvPVx(((SVOP*)label)->op_sv, n_a)
3806 /* Check whether it's going to be a goto &function */
3807 if (label->op_type == OP_ENTERSUB
3808 && !(label->op_flags & OPf_STACKED))
3809 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
3810 o = newUNOP(type, OPf_STACKED, label);
3812 PL_hints |= HINT_BLOCK_SCOPE;
3817 =for apidoc cv_undef
3819 Clear out all the active components of a CV. This can happen either
3820 by an explicit C<undef &foo>, or by the reference count going to zero.
3821 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
3822 children can still follow the full lexical scope chain.
3828 Perl_cv_undef(pTHX_ CV *cv)
3831 if (CvFILE(cv) && !CvXSUB(cv)) {
3832 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
3833 Safefree(CvFILE(cv));
3838 if (!CvXSUB(cv) && CvROOT(cv)) {
3840 Perl_croak(aTHX_ "Can't undef active subroutine");
3843 PAD_SAVE_SETNULLPAD();
3845 op_free(CvROOT(cv));
3846 CvROOT(cv) = Nullop;
3849 SvPOK_off((SV*)cv); /* forget prototype */
3854 /* remove CvOUTSIDE unless this is an undef rather than a free */
3855 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
3856 if (!CvWEAKOUTSIDE(cv))
3857 SvREFCNT_dec(CvOUTSIDE(cv));
3858 CvOUTSIDE(cv) = Nullcv;
3861 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
3867 /* delete all flags except WEAKOUTSIDE */
3868 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
3872 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
3874 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
3875 SV* msg = sv_newmortal();
3879 gv_efullname3(name = sv_newmortal(), gv, Nullch);
3880 sv_setpv(msg, "Prototype mismatch:");
3882 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
3884 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (SV *)cv);
3885 sv_catpv(msg, " vs ");
3887 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
3889 sv_catpv(msg, "none");
3890 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
3894 static void const_sv_xsub(pTHX_ CV* cv);
3898 =head1 Optree Manipulation Functions
3900 =for apidoc cv_const_sv
3902 If C<cv> is a constant sub eligible for inlining. returns the constant
3903 value returned by the sub. Otherwise, returns NULL.
3905 Constant subs can be created with C<newCONSTSUB> or as described in
3906 L<perlsub/"Constant Functions">.
3911 Perl_cv_const_sv(pTHX_ CV *cv)
3913 if (!cv || !CvCONST(cv))
3915 return (SV*)CvXSUBANY(cv).any_ptr;
3918 /* op_const_sv: examine an optree to determine whether it's in-lineable.
3919 * Can be called in 3 ways:
3922 * look for a single OP_CONST with attached value: return the value
3924 * cv && CvCLONE(cv) && !CvCONST(cv)
3926 * examine the clone prototype, and if contains only a single
3927 * OP_CONST referencing a pad const, or a single PADSV referencing
3928 * an outer lexical, return a non-zero value to indicate the CV is
3929 * a candidate for "constizing" at clone time
3933 * We have just cloned an anon prototype that was marked as a const
3934 * candidiate. Try to grab the current value, and in the case of
3935 * PADSV, ignore it if it has multiple references. Return the value.
3939 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
3946 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
3947 o = cLISTOPo->op_first->op_sibling;
3949 for (; o; o = o->op_next) {
3950 OPCODE type = o->op_type;
3952 if (sv && o->op_next == o)
3954 if (o->op_next != o) {
3955 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
3957 if (type == OP_DBSTATE)
3960 if (type == OP_LEAVESUB || type == OP_RETURN)
3964 if (type == OP_CONST && cSVOPo->op_sv)
3966 else if (cv && type == OP_CONST) {
3967 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
3971 else if (cv && type == OP_PADSV) {
3972 if (CvCONST(cv)) { /* newly cloned anon */
3973 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
3974 /* the candidate should have 1 ref from this pad and 1 ref
3975 * from the parent */
3976 if (!sv || SvREFCNT(sv) != 2)
3983 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
3984 sv = &PL_sv_undef; /* an arbitrary non-null value */
3995 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4005 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4009 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4011 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4015 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4021 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4025 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4026 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4027 SV *sv = sv_newmortal();
4028 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4029 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4030 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4035 gv = gv_fetchpv(name ? name : (aname ? aname :
4036 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__")),
4037 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4047 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4048 maximum a prototype before. */
4049 if (SvTYPE(gv) > SVt_NULL) {
4050 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4051 && ckWARN_d(WARN_PROTOTYPE))
4053 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4055 cv_ckproto((CV*)gv, NULL, ps);
4058 sv_setpv((SV*)gv, ps);
4060 sv_setiv((SV*)gv, -1);
4061 SvREFCNT_dec(PL_compcv);
4062 cv = PL_compcv = NULL;
4063 PL_sub_generation++;
4067 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4069 #ifdef GV_UNIQUE_CHECK
4070 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4071 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4075 if (!block || !ps || *ps || attrs)
4078 const_sv = op_const_sv(block, Nullcv);
4081 bool exists = CvROOT(cv) || CvXSUB(cv);
4083 #ifdef GV_UNIQUE_CHECK
4084 if (exists && GvUNIQUE(gv)) {
4085 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4089 /* if the subroutine doesn't exist and wasn't pre-declared
4090 * with a prototype, assume it will be AUTOLOADed,
4091 * skipping the prototype check
4093 if (exists || SvPOK(cv))
4094 cv_ckproto(cv, gv, ps);
4095 /* already defined (or promised)? */
4096 if (exists || GvASSUMECV(gv)) {
4097 if (!block && !attrs) {
4098 if (CvFLAGS(PL_compcv)) {
4099 /* might have had built-in attrs applied */
4100 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4102 /* just a "sub foo;" when &foo is already defined */
4103 SAVEFREESV(PL_compcv);
4106 /* ahem, death to those who redefine active sort subs */
4107 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4108 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4110 if (ckWARN(WARN_REDEFINE)
4112 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4114 line_t oldline = CopLINE(PL_curcop);
4115 if (PL_copline != NOLINE)
4116 CopLINE_set(PL_curcop, PL_copline);
4117 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4118 CvCONST(cv) ? "Constant subroutine %s redefined"
4119 : "Subroutine %s redefined", name);
4120 CopLINE_set(PL_curcop, oldline);
4128 SvREFCNT_inc(const_sv);
4130 assert(!CvROOT(cv) && !CvCONST(cv));
4131 sv_setpv((SV*)cv, ""); /* prototype is "" */
4132 CvXSUBANY(cv).any_ptr = const_sv;
4133 CvXSUB(cv) = const_sv_xsub;
4138 cv = newCONSTSUB(NULL, name, const_sv);
4141 SvREFCNT_dec(PL_compcv);
4143 PL_sub_generation++;
4150 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4151 * before we clobber PL_compcv.
4155 /* Might have had built-in attributes applied -- propagate them. */
4156 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4157 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4158 stash = GvSTASH(CvGV(cv));
4159 else if (CvSTASH(cv))
4160 stash = CvSTASH(cv);
4162 stash = PL_curstash;
4165 /* possibly about to re-define existing subr -- ignore old cv */
4166 rcv = (SV*)PL_compcv;
4167 if (name && GvSTASH(gv))
4168 stash = GvSTASH(gv);
4170 stash = PL_curstash;
4172 apply_attrs(stash, rcv, attrs, FALSE);
4174 if (cv) { /* must reuse cv if autoloaded */
4176 /* got here with just attrs -- work done, so bug out */
4177 SAVEFREESV(PL_compcv);
4180 /* transfer PL_compcv to cv */
4182 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4183 if (!CvWEAKOUTSIDE(cv))
4184 SvREFCNT_dec(CvOUTSIDE(cv));
4185 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4186 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4187 CvOUTSIDE(PL_compcv) = 0;
4188 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4189 CvPADLIST(PL_compcv) = 0;
4190 /* inner references to PL_compcv must be fixed up ... */
4191 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4192 /* ... before we throw it away */
4193 SvREFCNT_dec(PL_compcv);
4195 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4196 ++PL_sub_generation;
4203 PL_sub_generation++;
4207 CvFILE_set_from_cop(cv, PL_curcop);
4208 CvSTASH(cv) = PL_curstash;
4211 sv_setpv((SV*)cv, ps);
4213 if (PL_error_count) {
4217 char *s = strrchr(name, ':');
4219 if (strEQ(s, "BEGIN")) {
4221 "BEGIN not safe after errors--compilation aborted";
4222 if (PL_in_eval & EVAL_KEEPERR)
4223 Perl_croak(aTHX_ not_safe);
4225 /* force display of errors found but not reported */
4226 sv_catpv(ERRSV, not_safe);
4227 Perl_croak(aTHX_ "%"SVf, ERRSV);
4236 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4237 mod(scalarseq(block), OP_LEAVESUBLV));
4240 /* This makes sub {}; work as expected. */
4241 if (block->op_type == OP_STUB) {
4243 block = newSTATEOP(0, Nullch, 0);
4245 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4247 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4248 OpREFCNT_set(CvROOT(cv), 1);
4249 CvSTART(cv) = LINKLIST(CvROOT(cv));
4250 CvROOT(cv)->op_next = 0;
4251 CALL_PEEP(CvSTART(cv));
4253 /* now that optimizer has done its work, adjust pad values */
4255 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4258 assert(!CvCONST(cv));
4259 if (ps && !*ps && op_const_sv(block, cv))
4263 if (name || aname) {
4265 char *tname = (name ? name : aname);
4267 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4268 SV *sv = NEWSV(0,0);
4269 SV *tmpstr = sv_newmortal();
4270 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4274 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4276 (long)PL_subline, (long)CopLINE(PL_curcop));
4277 gv_efullname3(tmpstr, gv, Nullch);
4278 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4279 hv = GvHVn(db_postponed);
4280 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4281 && (pcv = GvCV(db_postponed)))
4287 call_sv((SV*)pcv, G_DISCARD);
4291 if ((s = strrchr(tname,':')))
4296 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4299 if (strEQ(s, "BEGIN") && !PL_error_count) {
4300 I32 oldscope = PL_scopestack_ix;
4302 SAVECOPFILE(&PL_compiling);
4303 SAVECOPLINE(&PL_compiling);
4306 PL_beginav = newAV();
4307 DEBUG_x( dump_sub(gv) );
4308 av_push(PL_beginav, (SV*)cv);
4309 GvCV(gv) = 0; /* cv has been hijacked */
4310 call_list(oldscope, PL_beginav);
4312 PL_curcop = &PL_compiling;
4313 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4316 else if (strEQ(s, "END") && !PL_error_count) {
4319 DEBUG_x( dump_sub(gv) );
4320 av_unshift(PL_endav, 1);
4321 av_store(PL_endav, 0, (SV*)cv);
4322 GvCV(gv) = 0; /* cv has been hijacked */
4324 else if (strEQ(s, "CHECK") && !PL_error_count) {
4326 PL_checkav = newAV();
4327 DEBUG_x( dump_sub(gv) );
4328 if (PL_main_start && ckWARN(WARN_VOID))
4329 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4330 av_unshift(PL_checkav, 1);
4331 av_store(PL_checkav, 0, (SV*)cv);
4332 GvCV(gv) = 0; /* cv has been hijacked */
4334 else if (strEQ(s, "INIT") && !PL_error_count) {
4336 PL_initav = newAV();
4337 DEBUG_x( dump_sub(gv) );
4338 if (PL_main_start && ckWARN(WARN_VOID))
4339 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4340 av_push(PL_initav, (SV*)cv);
4341 GvCV(gv) = 0; /* cv has been hijacked */
4346 PL_copline = NOLINE;
4351 /* XXX unsafe for threads if eval_owner isn't held */
4353 =for apidoc newCONSTSUB
4355 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4356 eligible for inlining at compile-time.
4362 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4368 SAVECOPLINE(PL_curcop);
4369 CopLINE_set(PL_curcop, PL_copline);
4372 PL_hints &= ~HINT_BLOCK_SCOPE;
4375 SAVESPTR(PL_curstash);
4376 SAVECOPSTASH(PL_curcop);
4377 PL_curstash = stash;
4378 CopSTASH_set(PL_curcop,stash);
4381 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4382 CvXSUBANY(cv).any_ptr = sv;
4384 sv_setpv((SV*)cv, ""); /* prototype is "" */
4387 CopSTASH_free(PL_curcop);
4395 =for apidoc U||newXS
4397 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4403 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
4405 GV *gv = gv_fetchpv(name ? name :
4406 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4407 GV_ADDMULTI, SVt_PVCV);
4411 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4413 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4415 /* just a cached method */
4419 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4420 /* already defined (or promised) */
4421 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4422 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4423 line_t oldline = CopLINE(PL_curcop);
4424 if (PL_copline != NOLINE)
4425 CopLINE_set(PL_curcop, PL_copline);
4426 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4427 CvCONST(cv) ? "Constant subroutine %s redefined"
4428 : "Subroutine %s redefined"
4430 CopLINE_set(PL_curcop, oldline);
4437 if (cv) /* must reuse cv if autoloaded */
4440 cv = (CV*)NEWSV(1105,0);
4441 sv_upgrade((SV *)cv, SVt_PVCV);
4445 PL_sub_generation++;
4449 (void)gv_fetchfile(filename);
4450 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
4451 an external constant string */
4452 CvXSUB(cv) = subaddr;
4455 char *s = strrchr(name,':');
4461 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4464 if (strEQ(s, "BEGIN")) {
4466 PL_beginav = newAV();
4467 av_push(PL_beginav, (SV*)cv);
4468 GvCV(gv) = 0; /* cv has been hijacked */
4470 else if (strEQ(s, "END")) {
4473 av_unshift(PL_endav, 1);
4474 av_store(PL_endav, 0, (SV*)cv);
4475 GvCV(gv) = 0; /* cv has been hijacked */
4477 else if (strEQ(s, "CHECK")) {
4479 PL_checkav = newAV();
4480 if (PL_main_start && ckWARN(WARN_VOID))
4481 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4482 av_unshift(PL_checkav, 1);
4483 av_store(PL_checkav, 0, (SV*)cv);
4484 GvCV(gv) = 0; /* cv has been hijacked */
4486 else if (strEQ(s, "INIT")) {
4488 PL_initav = newAV();
4489 if (PL_main_start && ckWARN(WARN_VOID))
4490 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4491 av_push(PL_initav, (SV*)cv);
4492 GvCV(gv) = 0; /* cv has been hijacked */
4503 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4511 name = SvPVx(cSVOPo->op_sv, n_a);
4514 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
4515 #ifdef GV_UNIQUE_CHECK
4517 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4521 if ((cv = GvFORM(gv))) {
4522 if (ckWARN(WARN_REDEFINE)) {
4523 line_t oldline = CopLINE(PL_curcop);
4524 if (PL_copline != NOLINE)
4525 CopLINE_set(PL_curcop, PL_copline);
4526 Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Format %s redefined",name);
4527 CopLINE_set(PL_curcop, oldline);
4534 CvFILE_set_from_cop(cv, PL_curcop);
4537 pad_tidy(padtidy_FORMAT);
4538 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4539 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4540 OpREFCNT_set(CvROOT(cv), 1);
4541 CvSTART(cv) = LINKLIST(CvROOT(cv));
4542 CvROOT(cv)->op_next = 0;
4543 CALL_PEEP(CvSTART(cv));
4545 PL_copline = NOLINE;
4550 Perl_newANONLIST(pTHX_ OP *o)
4552 return newUNOP(OP_REFGEN, 0,
4553 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4557 Perl_newANONHASH(pTHX_ OP *o)
4559 return newUNOP(OP_REFGEN, 0,
4560 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4564 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4566 return newANONATTRSUB(floor, proto, Nullop, block);
4570 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4572 return newUNOP(OP_REFGEN, 0,
4573 newSVOP(OP_ANONCODE, 0,
4574 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
4578 Perl_oopsAV(pTHX_ OP *o)
4580 switch (o->op_type) {
4582 o->op_type = OP_PADAV;
4583 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4584 return ref(o, OP_RV2AV);
4587 o->op_type = OP_RV2AV;
4588 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4593 if (ckWARN_d(WARN_INTERNAL))
4594 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
4601 Perl_oopsHV(pTHX_ OP *o)
4603 switch (o->op_type) {
4606 o->op_type = OP_PADHV;
4607 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4608 return ref(o, OP_RV2HV);
4612 o->op_type = OP_RV2HV;
4613 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
4618 if (ckWARN_d(WARN_INTERNAL))
4619 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
4626 Perl_newAVREF(pTHX_ OP *o)
4628 if (o->op_type == OP_PADANY) {
4629 o->op_type = OP_PADAV;
4630 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4633 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
4634 && ckWARN(WARN_DEPRECATED)) {
4635 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4636 "Using an array as a reference is deprecated");
4638 return newUNOP(OP_RV2AV, 0, scalar(o));
4642 Perl_newGVREF(pTHX_ I32 type, OP *o)
4644 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
4645 return newUNOP(OP_NULL, 0, o);
4646 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
4650 Perl_newHVREF(pTHX_ OP *o)
4652 if (o->op_type == OP_PADANY) {
4653 o->op_type = OP_PADHV;
4654 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4657 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
4658 && ckWARN(WARN_DEPRECATED)) {
4659 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4660 "Using a hash as a reference is deprecated");
4662 return newUNOP(OP_RV2HV, 0, scalar(o));
4666 Perl_oopsCV(pTHX_ OP *o)
4668 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
4674 Perl_newCVREF(pTHX_ I32 flags, OP *o)
4676 return newUNOP(OP_RV2CV, flags, scalar(o));
4680 Perl_newSVREF(pTHX_ OP *o)
4682 if (o->op_type == OP_PADANY) {
4683 o->op_type = OP_PADSV;
4684 o->op_ppaddr = PL_ppaddr[OP_PADSV];
4687 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4688 o->op_flags |= OPpDONE_SVREF;
4691 return newUNOP(OP_RV2SV, 0, scalar(o));
4694 /* Check routines. */
4697 Perl_ck_anoncode(pTHX_ OP *o)
4699 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
4700 cSVOPo->op_sv = Nullsv;
4705 Perl_ck_bitop(pTHX_ OP *o)
4707 #define OP_IS_NUMCOMPARE(op) \
4708 ((op) == OP_LT || (op) == OP_I_LT || \
4709 (op) == OP_GT || (op) == OP_I_GT || \
4710 (op) == OP_LE || (op) == OP_I_LE || \
4711 (op) == OP_GE || (op) == OP_I_GE || \
4712 (op) == OP_EQ || (op) == OP_I_EQ || \
4713 (op) == OP_NE || (op) == OP_I_NE || \
4714 (op) == OP_NCMP || (op) == OP_I_NCMP)
4715 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4716 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
4717 && (o->op_type == OP_BIT_OR
4718 || o->op_type == OP_BIT_AND
4719 || o->op_type == OP_BIT_XOR))
4721 OP * left = cBINOPo->op_first;
4722 OP * right = left->op_sibling;
4723 if ((OP_IS_NUMCOMPARE(left->op_type) &&
4724 (left->op_flags & OPf_PARENS) == 0) ||
4725 (OP_IS_NUMCOMPARE(right->op_type) &&
4726 (right->op_flags & OPf_PARENS) == 0))
4727 if (ckWARN(WARN_PRECEDENCE))
4728 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4729 "Possible precedence problem on bitwise %c operator",
4730 o->op_type == OP_BIT_OR ? '|'
4731 : o->op_type == OP_BIT_AND ? '&' : '^'
4738 Perl_ck_concat(pTHX_ OP *o)
4740 OP *kid = cUNOPo->op_first;
4741 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
4742 !(kUNOP->op_first->op_flags & OPf_MOD))
4743 o->op_flags |= OPf_STACKED;
4748 Perl_ck_spair(pTHX_ OP *o)
4750 if (o->op_flags & OPf_KIDS) {
4753 OPCODE type = o->op_type;
4754 o = modkids(ck_fun(o), type);
4755 kid = cUNOPo->op_first;
4756 newop = kUNOP->op_first->op_sibling;
4758 (newop->op_sibling ||
4759 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
4760 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
4761 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
4765 op_free(kUNOP->op_first);
4766 kUNOP->op_first = newop;
4768 o->op_ppaddr = PL_ppaddr[++o->op_type];
4773 Perl_ck_delete(pTHX_ OP *o)
4777 if (o->op_flags & OPf_KIDS) {
4778 OP *kid = cUNOPo->op_first;
4779 switch (kid->op_type) {
4781 o->op_flags |= OPf_SPECIAL;
4784 o->op_private |= OPpSLICE;
4787 o->op_flags |= OPf_SPECIAL;
4792 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
4801 Perl_ck_die(pTHX_ OP *o)
4804 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4810 Perl_ck_eof(pTHX_ OP *o)
4812 I32 type = o->op_type;
4814 if (o->op_flags & OPf_KIDS) {
4815 if (cLISTOPo->op_first->op_type == OP_STUB) {
4817 o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
4825 Perl_ck_eval(pTHX_ OP *o)
4827 PL_hints |= HINT_BLOCK_SCOPE;
4828 if (o->op_flags & OPf_KIDS) {
4829 SVOP *kid = (SVOP*)cUNOPo->op_first;
4832 o->op_flags &= ~OPf_KIDS;
4835 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
4838 cUNOPo->op_first = 0;
4841 NewOp(1101, enter, 1, LOGOP);
4842 enter->op_type = OP_ENTERTRY;
4843 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
4844 enter->op_private = 0;
4846 /* establish postfix order */
4847 enter->op_next = (OP*)enter;
4849 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
4850 o->op_type = OP_LEAVETRY;
4851 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
4852 enter->op_other = o;
4862 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
4864 o->op_targ = (PADOFFSET)PL_hints;
4869 Perl_ck_exit(pTHX_ OP *o)
4872 HV *table = GvHV(PL_hintgv);
4874 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
4875 if (svp && *svp && SvTRUE(*svp))
4876 o->op_private |= OPpEXIT_VMSISH;
4878 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4884 Perl_ck_exec(pTHX_ OP *o)
4887 if (o->op_flags & OPf_STACKED) {
4889 kid = cUNOPo->op_first->op_sibling;
4890 if (kid->op_type == OP_RV2GV)
4899 Perl_ck_exists(pTHX_ OP *o)
4902 if (o->op_flags & OPf_KIDS) {
4903 OP *kid = cUNOPo->op_first;
4904 if (kid->op_type == OP_ENTERSUB) {
4905 (void) ref(kid, o->op_type);
4906 if (kid->op_type != OP_RV2CV && !PL_error_count)
4907 Perl_croak(aTHX_ "%s argument is not a subroutine name",
4909 o->op_private |= OPpEXISTS_SUB;
4911 else if (kid->op_type == OP_AELEM)
4912 o->op_flags |= OPf_SPECIAL;
4913 else if (kid->op_type != OP_HELEM)
4914 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
4923 Perl_ck_gvconst(pTHX_ register OP *o)
4925 o = fold_constants(o);
4926 if (o->op_type == OP_CONST)
4933 Perl_ck_rvconst(pTHX_ register OP *o)
4935 SVOP *kid = (SVOP*)cUNOPo->op_first;
4937 o->op_private |= (PL_hints & HINT_STRICT_REFS);
4938 if (kid->op_type == OP_CONST) {
4942 SV *kidsv = kid->op_sv;
4945 /* Is it a constant from cv_const_sv()? */
4946 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
4947 SV *rsv = SvRV(kidsv);
4948 int svtype = SvTYPE(rsv);
4949 char *badtype = Nullch;
4951 switch (o->op_type) {
4953 if (svtype > SVt_PVMG)
4954 badtype = "a SCALAR";
4957 if (svtype != SVt_PVAV)
4958 badtype = "an ARRAY";
4961 if (svtype != SVt_PVHV)
4965 if (svtype != SVt_PVCV)
4970 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
4973 name = SvPV(kidsv, n_a);
4974 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
4975 char *badthing = Nullch;
4976 switch (o->op_type) {
4978 badthing = "a SCALAR";
4981 badthing = "an ARRAY";
4984 badthing = "a HASH";
4989 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
4993 * This is a little tricky. We only want to add the symbol if we
4994 * didn't add it in the lexer. Otherwise we get duplicate strict
4995 * warnings. But if we didn't add it in the lexer, we must at
4996 * least pretend like we wanted to add it even if it existed before,
4997 * or we get possible typo warnings. OPpCONST_ENTERED says
4998 * whether the lexer already added THIS instance of this symbol.
5000 iscv = (o->op_type == OP_RV2CV) * 2;
5002 gv = gv_fetchpv(name,
5003 iscv | !(kid->op_private & OPpCONST_ENTERED),
5006 : o->op_type == OP_RV2SV
5008 : o->op_type == OP_RV2AV
5010 : o->op_type == OP_RV2HV
5013 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5015 kid->op_type = OP_GV;
5016 SvREFCNT_dec(kid->op_sv);
5018 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5019 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5020 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
5022 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
5024 kid->op_sv = SvREFCNT_inc(gv);
5026 kid->op_private = 0;
5027 kid->op_ppaddr = PL_ppaddr[OP_GV];
5034 Perl_ck_ftst(pTHX_ OP *o)
5036 I32 type = o->op_type;
5038 if (o->op_flags & OPf_REF) {
5041 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5042 SVOP *kid = (SVOP*)cUNOPo->op_first;
5044 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5046 OP *newop = newGVOP(type, OPf_REF,
5047 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5052 if ((PL_hints & HINT_FILETEST_ACCESS) &&
5053 OP_IS_FILETEST_ACCESS(o))
5054 o->op_private |= OPpFT_ACCESS;
5056 if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
5057 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
5058 o->op_private |= OPpFT_STACKED;
5062 if (type == OP_FTTTY)
5063 o = newGVOP(type, OPf_REF, PL_stdingv);
5065 o = newUNOP(type, 0, newDEFSVOP());
5071 Perl_ck_fun(pTHX_ OP *o)
5077 int type = o->op_type;
5078 register I32 oa = PL_opargs[type] >> OASHIFT;
5080 if (o->op_flags & OPf_STACKED) {
5081 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5084 return no_fh_allowed(o);
5087 if (o->op_flags & OPf_KIDS) {
5089 tokid = &cLISTOPo->op_first;
5090 kid = cLISTOPo->op_first;
5091 if (kid->op_type == OP_PUSHMARK ||
5092 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5094 tokid = &kid->op_sibling;
5095 kid = kid->op_sibling;
5097 if (!kid && PL_opargs[type] & OA_DEFGV)
5098 *tokid = kid = newDEFSVOP();
5102 sibl = kid->op_sibling;
5105 /* list seen where single (scalar) arg expected? */
5106 if (numargs == 1 && !(oa >> 4)
5107 && kid->op_type == OP_LIST && type != OP_SCALAR)
5109 return too_many_arguments(o,PL_op_desc[type]);
5122 if ((type == OP_PUSH || type == OP_UNSHIFT)
5123 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5124 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5125 "Useless use of %s with no values",
5128 if (kid->op_type == OP_CONST &&
5129 (kid->op_private & OPpCONST_BARE))
5131 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5132 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5133 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5134 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5135 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5136 "Array @%s missing the @ in argument %"IVdf" of %s()",
5137 name, (IV)numargs, PL_op_desc[type]);
5140 kid->op_sibling = sibl;
5143 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5144 bad_type(numargs, "array", PL_op_desc[type], kid);
5148 if (kid->op_type == OP_CONST &&
5149 (kid->op_private & OPpCONST_BARE))
5151 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5152 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5153 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5154 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5155 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5156 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5157 name, (IV)numargs, PL_op_desc[type]);
5160 kid->op_sibling = sibl;
5163 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5164 bad_type(numargs, "hash", PL_op_desc[type], kid);
5169 OP *newop = newUNOP(OP_NULL, 0, kid);
5170 kid->op_sibling = 0;
5172 newop->op_next = newop;
5174 kid->op_sibling = sibl;
5179 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5180 if (kid->op_type == OP_CONST &&
5181 (kid->op_private & OPpCONST_BARE))
5183 OP *newop = newGVOP(OP_GV, 0,
5184 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5186 if (!(o->op_private & 1) && /* if not unop */
5187 kid == cLISTOPo->op_last)
5188 cLISTOPo->op_last = newop;
5192 else if (kid->op_type == OP_READLINE) {
5193 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5194 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5197 I32 flags = OPf_SPECIAL;
5201 /* is this op a FH constructor? */
5202 if (is_handle_constructor(o,numargs)) {
5203 char *name = Nullch;
5207 /* Set a flag to tell rv2gv to vivify
5208 * need to "prove" flag does not mean something
5209 * else already - NI-S 1999/05/07
5212 if (kid->op_type == OP_PADSV) {
5213 name = PAD_COMPNAME_PV(kid->op_targ);
5214 /* SvCUR of a pad namesv can't be trusted
5215 * (see PL_generation), so calc its length
5221 else if (kid->op_type == OP_RV2SV
5222 && kUNOP->op_first->op_type == OP_GV)
5224 GV *gv = cGVOPx_gv(kUNOP->op_first);
5226 len = GvNAMELEN(gv);
5228 else if (kid->op_type == OP_AELEM
5229 || kid->op_type == OP_HELEM)
5234 if ((op = ((BINOP*)kid)->op_first)) {
5235 SV *tmpstr = Nullsv;
5237 kid->op_type == OP_AELEM ?
5239 if (((op->op_type == OP_RV2AV) ||
5240 (op->op_type == OP_RV2HV)) &&
5241 (op = ((UNOP*)op)->op_first) &&
5242 (op->op_type == OP_GV)) {
5243 /* packagevar $a[] or $h{} */
5244 GV *gv = cGVOPx_gv(op);
5252 else if (op->op_type == OP_PADAV
5253 || op->op_type == OP_PADHV) {
5254 /* lexicalvar $a[] or $h{} */
5256 PAD_COMPNAME_PV(op->op_targ);
5266 name = SvPV(tmpstr, len);
5271 name = "__ANONIO__";
5278 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5279 namesv = PAD_SVl(targ);
5280 (void)SvUPGRADE(namesv, SVt_PV);
5282 sv_setpvn(namesv, "$", 1);
5283 sv_catpvn(namesv, name, len);
5286 kid->op_sibling = 0;
5287 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5288 kid->op_targ = targ;
5289 kid->op_private |= priv;
5291 kid->op_sibling = sibl;
5297 mod(scalar(kid), type);
5301 tokid = &kid->op_sibling;
5302 kid = kid->op_sibling;
5304 o->op_private |= numargs;
5306 return too_many_arguments(o,OP_DESC(o));
5309 else if (PL_opargs[type] & OA_DEFGV) {
5311 return newUNOP(type, 0, newDEFSVOP());
5315 while (oa & OA_OPTIONAL)
5317 if (oa && oa != OA_LIST)
5318 return too_few_arguments(o,OP_DESC(o));
5324 Perl_ck_glob(pTHX_ OP *o)
5329 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5330 append_elem(OP_GLOB, o, newDEFSVOP());
5332 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5333 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5335 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5338 #if !defined(PERL_EXTERNAL_GLOB)
5339 /* XXX this can be tightened up and made more failsafe. */
5340 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5343 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5344 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5345 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5346 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5347 GvCV(gv) = GvCV(glob_gv);
5348 SvREFCNT_inc((SV*)GvCV(gv));
5349 GvIMPORTED_CV_on(gv);
5352 #endif /* PERL_EXTERNAL_GLOB */
5354 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5355 append_elem(OP_GLOB, o,
5356 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5357 o->op_type = OP_LIST;
5358 o->op_ppaddr = PL_ppaddr[OP_LIST];
5359 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5360 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5361 cLISTOPo->op_first->op_targ = 0;
5362 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5363 append_elem(OP_LIST, o,
5364 scalar(newUNOP(OP_RV2CV, 0,
5365 newGVOP(OP_GV, 0, gv)))));
5366 o = newUNOP(OP_NULL, 0, ck_subr(o));
5367 o->op_targ = OP_GLOB; /* hint at what it used to be */
5370 gv = newGVgen("main");
5372 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5378 Perl_ck_grep(pTHX_ OP *o)
5382 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5385 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5386 NewOp(1101, gwop, 1, LOGOP);
5388 if (o->op_flags & OPf_STACKED) {
5391 kid = cLISTOPo->op_first->op_sibling;
5392 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5395 kid->op_next = (OP*)gwop;
5396 o->op_flags &= ~OPf_STACKED;
5398 kid = cLISTOPo->op_first->op_sibling;
5399 if (type == OP_MAPWHILE)
5406 kid = cLISTOPo->op_first->op_sibling;
5407 if (kid->op_type != OP_NULL)
5408 Perl_croak(aTHX_ "panic: ck_grep");
5409 kid = kUNOP->op_first;
5411 gwop->op_type = type;
5412 gwop->op_ppaddr = PL_ppaddr[type];
5413 gwop->op_first = listkids(o);
5414 gwop->op_flags |= OPf_KIDS;
5415 gwop->op_other = LINKLIST(kid);
5416 kid->op_next = (OP*)gwop;
5417 offset = pad_findmy("$_");
5418 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
5419 o->op_private = gwop->op_private = 0;
5420 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5423 o->op_private = gwop->op_private = OPpGREP_LEX;
5424 gwop->op_targ = o->op_targ = offset;
5427 kid = cLISTOPo->op_first->op_sibling;
5428 if (!kid || !kid->op_sibling)
5429 return too_few_arguments(o,OP_DESC(o));
5430 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5431 mod(kid, OP_GREPSTART);
5437 Perl_ck_index(pTHX_ OP *o)
5439 if (o->op_flags & OPf_KIDS) {
5440 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5442 kid = kid->op_sibling; /* get past "big" */
5443 if (kid && kid->op_type == OP_CONST)
5444 fbm_compile(((SVOP*)kid)->op_sv, 0);
5450 Perl_ck_lengthconst(pTHX_ OP *o)
5452 /* XXX length optimization goes here */
5457 Perl_ck_lfun(pTHX_ OP *o)
5459 OPCODE type = o->op_type;
5460 return modkids(ck_fun(o), type);
5464 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5466 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5467 switch (cUNOPo->op_first->op_type) {
5469 /* This is needed for
5470 if (defined %stash::)
5471 to work. Do not break Tk.
5473 break; /* Globals via GV can be undef */
5475 case OP_AASSIGN: /* Is this a good idea? */
5476 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5477 "defined(@array) is deprecated");
5478 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5479 "\t(Maybe you should just omit the defined()?)\n");
5482 /* This is needed for
5483 if (defined %stash::)
5484 to work. Do not break Tk.
5486 break; /* Globals via GV can be undef */
5488 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5489 "defined(%%hash) is deprecated");
5490 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5491 "\t(Maybe you should just omit the defined()?)\n");
5502 Perl_ck_rfun(pTHX_ OP *o)
5504 OPCODE type = o->op_type;
5505 return refkids(ck_fun(o), type);
5509 Perl_ck_listiob(pTHX_ OP *o)
5513 kid = cLISTOPo->op_first;
5516 kid = cLISTOPo->op_first;
5518 if (kid->op_type == OP_PUSHMARK)
5519 kid = kid->op_sibling;
5520 if (kid && o->op_flags & OPf_STACKED)
5521 kid = kid->op_sibling;
5522 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5523 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5524 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5525 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5526 cLISTOPo->op_first->op_sibling = kid;
5527 cLISTOPo->op_last = kid;
5528 kid = kid->op_sibling;
5533 append_elem(o->op_type, o, newDEFSVOP());
5539 Perl_ck_sassign(pTHX_ OP *o)
5541 OP *kid = cLISTOPo->op_first;
5542 /* has a disposable target? */
5543 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5544 && !(kid->op_flags & OPf_STACKED)
5545 /* Cannot steal the second time! */
5546 && !(kid->op_private & OPpTARGET_MY))
5548 OP *kkid = kid->op_sibling;
5550 /* Can just relocate the target. */
5551 if (kkid && kkid->op_type == OP_PADSV
5552 && !(kkid->op_private & OPpLVAL_INTRO))
5554 kid->op_targ = kkid->op_targ;
5556 /* Now we do not need PADSV and SASSIGN. */
5557 kid->op_sibling = o->op_sibling; /* NULL */
5558 cLISTOPo->op_first = NULL;
5561 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
5569 Perl_ck_match(pTHX_ OP *o)
5571 if (o->op_type != OP_QR) {
5572 I32 offset = pad_findmy("$_");
5573 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS(offset) & SVpad_OUR)) {
5574 o->op_targ = offset;
5575 o->op_private |= OPpTARGET_MY;
5578 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
5579 o->op_private |= OPpRUNTIME;
5584 Perl_ck_method(pTHX_ OP *o)
5586 OP *kid = cUNOPo->op_first;
5587 if (kid->op_type == OP_CONST) {
5588 SV* sv = kSVOP->op_sv;
5589 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
5591 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5592 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
5595 kSVOP->op_sv = Nullsv;
5597 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5606 Perl_ck_null(pTHX_ OP *o)
5612 Perl_ck_open(pTHX_ OP *o)
5614 HV *table = GvHV(PL_hintgv);
5618 svp = hv_fetch(table, "open_IN", 7, FALSE);
5620 mode = mode_from_discipline(*svp);
5621 if (mode & O_BINARY)
5622 o->op_private |= OPpOPEN_IN_RAW;
5623 else if (mode & O_TEXT)
5624 o->op_private |= OPpOPEN_IN_CRLF;
5627 svp = hv_fetch(table, "open_OUT", 8, FALSE);
5629 mode = mode_from_discipline(*svp);
5630 if (mode & O_BINARY)
5631 o->op_private |= OPpOPEN_OUT_RAW;
5632 else if (mode & O_TEXT)
5633 o->op_private |= OPpOPEN_OUT_CRLF;
5636 if (o->op_type == OP_BACKTICK)
5639 /* In case of three-arg dup open remove strictness
5640 * from the last arg if it is a bareword. */
5641 OP *first = cLISTOPx(o)->op_first; /* The pushmark. */
5642 OP *last = cLISTOPx(o)->op_last; /* The bareword. */
5646 if ((last->op_type == OP_CONST) && /* The bareword. */
5647 (last->op_private & OPpCONST_BARE) &&
5648 (last->op_private & OPpCONST_STRICT) &&
5649 (oa = first->op_sibling) && /* The fh. */
5650 (oa = oa->op_sibling) && /* The mode. */
5651 SvPOK(((SVOP*)oa)->op_sv) &&
5652 (mode = SvPVX(((SVOP*)oa)->op_sv)) &&
5653 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
5654 (last == oa->op_sibling)) /* The bareword. */
5655 last->op_private &= ~OPpCONST_STRICT;
5661 Perl_ck_repeat(pTHX_ OP *o)
5663 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5664 o->op_private |= OPpREPEAT_DOLIST;
5665 cBINOPo->op_first = force_list(cBINOPo->op_first);
5673 Perl_ck_require(pTHX_ OP *o)
5677 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
5678 SVOP *kid = (SVOP*)cUNOPo->op_first;
5680 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5682 for (s = SvPVX(kid->op_sv); *s; s++) {
5683 if (*s == ':' && s[1] == ':') {
5685 Move(s+2, s+1, strlen(s+2)+1, char);
5686 --SvCUR(kid->op_sv);
5689 if (SvREADONLY(kid->op_sv)) {
5690 SvREADONLY_off(kid->op_sv);
5691 sv_catpvn(kid->op_sv, ".pm", 3);
5692 SvREADONLY_on(kid->op_sv);
5695 sv_catpvn(kid->op_sv, ".pm", 3);
5699 /* handle override, if any */
5700 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
5701 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
5702 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
5704 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5705 OP *kid = cUNOPo->op_first;
5706 cUNOPo->op_first = 0;
5708 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5709 append_elem(OP_LIST, kid,
5710 scalar(newUNOP(OP_RV2CV, 0,
5719 Perl_ck_return(pTHX_ OP *o)
5722 if (CvLVALUE(PL_compcv)) {
5723 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5724 mod(kid, OP_LEAVESUBLV);
5731 Perl_ck_retarget(pTHX_ OP *o)
5733 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5740 Perl_ck_select(pTHX_ OP *o)
5743 if (o->op_flags & OPf_KIDS) {
5744 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5745 if (kid && kid->op_sibling) {
5746 o->op_type = OP_SSELECT;
5747 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
5749 return fold_constants(o);
5753 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5754 if (kid && kid->op_type == OP_RV2GV)
5755 kid->op_private &= ~HINT_STRICT_REFS;
5760 Perl_ck_shift(pTHX_ OP *o)
5762 I32 type = o->op_type;
5764 if (!(o->op_flags & OPf_KIDS)) {
5768 argop = newUNOP(OP_RV2AV, 0,
5769 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
5770 return newUNOP(type, 0, scalar(argop));
5772 return scalar(modkids(ck_fun(o), type));
5776 Perl_ck_sort(pTHX_ OP *o)
5780 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
5782 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5783 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
5785 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
5787 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
5789 if (kid->op_type == OP_SCOPE) {
5793 else if (kid->op_type == OP_LEAVE) {
5794 if (o->op_type == OP_SORT) {
5795 op_null(kid); /* wipe out leave */
5798 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
5799 if (k->op_next == kid)
5801 /* don't descend into loops */
5802 else if (k->op_type == OP_ENTERLOOP
5803 || k->op_type == OP_ENTERITER)
5805 k = cLOOPx(k)->op_lastop;
5810 kid->op_next = 0; /* just disconnect the leave */
5811 k = kLISTOP->op_first;
5816 if (o->op_type == OP_SORT) {
5817 /* provide scalar context for comparison function/block */
5823 o->op_flags |= OPf_SPECIAL;
5825 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
5828 firstkid = firstkid->op_sibling;
5831 /* provide list context for arguments */
5832 if (o->op_type == OP_SORT)
5839 S_simplify_sort(pTHX_ OP *o)
5841 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5845 if (!(o->op_flags & OPf_STACKED))
5847 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
5848 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
5849 kid = kUNOP->op_first; /* get past null */
5850 if (kid->op_type != OP_SCOPE)
5852 kid = kLISTOP->op_last; /* get past scope */
5853 switch(kid->op_type) {
5861 k = kid; /* remember this node*/
5862 if (kBINOP->op_first->op_type != OP_RV2SV)
5864 kid = kBINOP->op_first; /* get past cmp */
5865 if (kUNOP->op_first->op_type != OP_GV)
5867 kid = kUNOP->op_first; /* get past rv2sv */
5869 if (GvSTASH(gv) != PL_curstash)
5871 if (strEQ(GvNAME(gv), "a"))
5873 else if (strEQ(GvNAME(gv), "b"))
5877 kid = k; /* back to cmp */
5878 if (kBINOP->op_last->op_type != OP_RV2SV)
5880 kid = kBINOP->op_last; /* down to 2nd arg */
5881 if (kUNOP->op_first->op_type != OP_GV)
5883 kid = kUNOP->op_first; /* get past rv2sv */
5885 if (GvSTASH(gv) != PL_curstash
5887 ? strNE(GvNAME(gv), "a")
5888 : strNE(GvNAME(gv), "b")))
5890 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
5892 o->op_private |= OPpSORT_REVERSE;
5893 if (k->op_type == OP_NCMP)
5894 o->op_private |= OPpSORT_NUMERIC;
5895 if (k->op_type == OP_I_NCMP)
5896 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
5897 kid = cLISTOPo->op_first->op_sibling;
5898 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
5899 op_free(kid); /* then delete it */
5903 Perl_ck_split(pTHX_ OP *o)
5907 if (o->op_flags & OPf_STACKED)
5908 return no_fh_allowed(o);
5910 kid = cLISTOPo->op_first;
5911 if (kid->op_type != OP_NULL)
5912 Perl_croak(aTHX_ "panic: ck_split");
5913 kid = kid->op_sibling;
5914 op_free(cLISTOPo->op_first);
5915 cLISTOPo->op_first = kid;
5917 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
5918 cLISTOPo->op_last = kid; /* There was only one element previously */
5921 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
5922 OP *sibl = kid->op_sibling;
5923 kid->op_sibling = 0;
5924 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
5925 if (cLISTOPo->op_first == cLISTOPo->op_last)
5926 cLISTOPo->op_last = kid;
5927 cLISTOPo->op_first = kid;
5928 kid->op_sibling = sibl;
5931 kid->op_type = OP_PUSHRE;
5932 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
5934 if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
5935 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
5936 "Use of /g modifier is meaningless in split");
5939 if (!kid->op_sibling)
5940 append_elem(OP_SPLIT, o, newDEFSVOP());
5942 kid = kid->op_sibling;
5945 if (!kid->op_sibling)
5946 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
5948 kid = kid->op_sibling;
5951 if (kid->op_sibling)
5952 return too_many_arguments(o,OP_DESC(o));
5958 Perl_ck_join(pTHX_ OP *o)
5960 if (ckWARN(WARN_SYNTAX)) {
5961 OP *kid = cLISTOPo->op_first->op_sibling;
5962 if (kid && kid->op_type == OP_MATCH) {
5963 char *pmstr = "STRING";
5964 if (PM_GETRE(kPMOP))
5965 pmstr = PM_GETRE(kPMOP)->precomp;
5966 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5967 "/%s/ should probably be written as \"%s\"",
5975 Perl_ck_subr(pTHX_ OP *o)
5977 OP *prev = ((cUNOPo->op_first->op_sibling)
5978 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
5979 OP *o2 = prev->op_sibling;
5986 I32 contextclass = 0;
5991 o->op_private |= OPpENTERSUB_HASTARG;
5992 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
5993 if (cvop->op_type == OP_RV2CV) {
5995 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
5996 op_null(cvop); /* disable rv2cv */
5997 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
5998 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
5999 GV *gv = cGVOPx_gv(tmpop);
6002 tmpop->op_private |= OPpEARLY_CV;
6005 namegv = CvANON(cv) ? gv : CvGV(cv);
6006 proto = SvPV((SV*)cv, n_a);
6008 if (CvASSERTION(cv)) {
6009 if (PL_hints & HINT_ASSERTING) {
6010 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
6011 o->op_private |= OPpENTERSUB_DB;
6015 if (ckWARN(WARN_ASSERTIONS) && !(PL_hints & HINT_ASSERTIONSSEEN)) {
6016 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
6017 "Impossible to activate assertion call");
6024 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6025 if (o2->op_type == OP_CONST)
6026 o2->op_private &= ~OPpCONST_STRICT;
6027 else if (o2->op_type == OP_LIST) {
6028 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6029 if (o && o->op_type == OP_CONST)
6030 o->op_private &= ~OPpCONST_STRICT;
6033 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6034 if (PERLDB_SUB && PL_curstash != PL_debstash)
6035 o->op_private |= OPpENTERSUB_DB;
6036 while (o2 != cvop) {
6040 return too_many_arguments(o, gv_ename(namegv));
6058 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6060 arg == 1 ? "block or sub {}" : "sub {}",
6061 gv_ename(namegv), o2);
6064 /* '*' allows any scalar type, including bareword */
6067 if (o2->op_type == OP_RV2GV)
6068 goto wrapref; /* autoconvert GLOB -> GLOBref */
6069 else if (o2->op_type == OP_CONST)
6070 o2->op_private &= ~OPpCONST_STRICT;
6071 else if (o2->op_type == OP_ENTERSUB) {
6072 /* accidental subroutine, revert to bareword */
6073 OP *gvop = ((UNOP*)o2)->op_first;
6074 if (gvop && gvop->op_type == OP_NULL) {
6075 gvop = ((UNOP*)gvop)->op_first;
6077 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6080 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6081 (gvop = ((UNOP*)gvop)->op_first) &&
6082 gvop->op_type == OP_GV)
6084 GV *gv = cGVOPx_gv(gvop);
6085 OP *sibling = o2->op_sibling;
6086 SV *n = newSVpvn("",0);
6088 gv_fullname3(n, gv, "");
6089 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6090 sv_chop(n, SvPVX(n)+6);
6091 o2 = newSVOP(OP_CONST, 0, n);
6092 prev->op_sibling = o2;
6093 o2->op_sibling = sibling;
6109 if (contextclass++ == 0) {
6110 e = strchr(proto, ']');
6111 if (!e || e == proto)
6124 while (*--p != '[');
6125 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6126 gv_ename(namegv), o2);
6132 if (o2->op_type == OP_RV2GV)
6135 bad_type(arg, "symbol", gv_ename(namegv), o2);
6138 if (o2->op_type == OP_ENTERSUB)
6141 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6144 if (o2->op_type == OP_RV2SV ||
6145 o2->op_type == OP_PADSV ||
6146 o2->op_type == OP_HELEM ||
6147 o2->op_type == OP_AELEM ||
6148 o2->op_type == OP_THREADSV)
6151 bad_type(arg, "scalar", gv_ename(namegv), o2);
6154 if (o2->op_type == OP_RV2AV ||
6155 o2->op_type == OP_PADAV)
6158 bad_type(arg, "array", gv_ename(namegv), o2);
6161 if (o2->op_type == OP_RV2HV ||
6162 o2->op_type == OP_PADHV)
6165 bad_type(arg, "hash", gv_ename(namegv), o2);
6170 OP* sib = kid->op_sibling;
6171 kid->op_sibling = 0;
6172 o2 = newUNOP(OP_REFGEN, 0, kid);
6173 o2->op_sibling = sib;
6174 prev->op_sibling = o2;
6176 if (contextclass && e) {
6191 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6192 gv_ename(namegv), cv);
6197 mod(o2, OP_ENTERSUB);
6199 o2 = o2->op_sibling;
6201 if (proto && !optional &&
6202 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6203 return too_few_arguments(o, gv_ename(namegv));
6206 o=newSVOP(OP_CONST, 0, newSViv(0));
6212 Perl_ck_svconst(pTHX_ OP *o)
6214 SvREADONLY_on(cSVOPo->op_sv);
6219 Perl_ck_trunc(pTHX_ OP *o)
6221 if (o->op_flags & OPf_KIDS) {
6222 SVOP *kid = (SVOP*)cUNOPo->op_first;
6224 if (kid->op_type == OP_NULL)
6225 kid = (SVOP*)kid->op_sibling;
6226 if (kid && kid->op_type == OP_CONST &&
6227 (kid->op_private & OPpCONST_BARE))
6229 o->op_flags |= OPf_SPECIAL;
6230 kid->op_private &= ~OPpCONST_STRICT;
6237 Perl_ck_unpack(pTHX_ OP *o)
6239 OP *kid = cLISTOPo->op_first;
6240 if (kid->op_sibling) {
6241 kid = kid->op_sibling;
6242 if (!kid->op_sibling)
6243 kid->op_sibling = newDEFSVOP();
6249 Perl_ck_substr(pTHX_ OP *o)
6252 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6253 OP *kid = cLISTOPo->op_first;
6255 if (kid->op_type == OP_NULL)
6256 kid = kid->op_sibling;
6258 kid->op_flags |= OPf_MOD;
6264 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6267 Perl_peep(pTHX_ register OP *o)
6269 register OP* oldop = 0;
6271 if (!o || o->op_seq)
6275 SAVEVPTR(PL_curcop);
6276 for (; o; o = o->op_next) {
6279 /* The special value -1 is used by the B::C compiler backend to indicate
6280 * that an op is statically defined and should not be freed */
6281 if (!PL_op_seqmax || PL_op_seqmax == (U16)-1)
6284 switch (o->op_type) {
6288 PL_curcop = ((COP*)o); /* for warnings */
6289 o->op_seq = PL_op_seqmax++;
6293 if (cSVOPo->op_private & OPpCONST_STRICT)
6294 no_bareword_allowed(o);
6296 case OP_METHOD_NAMED:
6297 /* Relocate sv to the pad for thread safety.
6298 * Despite being a "constant", the SV is written to,
6299 * for reference counts, sv_upgrade() etc. */
6301 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6302 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6303 /* If op_sv is already a PADTMP then it is being used by
6304 * some pad, so make a copy. */
6305 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6306 SvREADONLY_on(PAD_SVl(ix));
6307 SvREFCNT_dec(cSVOPo->op_sv);
6310 SvREFCNT_dec(PAD_SVl(ix));
6311 SvPADTMP_on(cSVOPo->op_sv);
6312 PAD_SETSV(ix, cSVOPo->op_sv);
6313 /* XXX I don't know how this isn't readonly already. */
6314 SvREADONLY_on(PAD_SVl(ix));
6316 cSVOPo->op_sv = Nullsv;
6320 o->op_seq = PL_op_seqmax++;
6324 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6325 if (o->op_next->op_private & OPpTARGET_MY) {
6326 if (o->op_flags & OPf_STACKED) /* chained concats */
6327 goto ignore_optimization;
6329 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6330 o->op_targ = o->op_next->op_targ;
6331 o->op_next->op_targ = 0;
6332 o->op_private |= OPpTARGET_MY;
6335 op_null(o->op_next);
6337 ignore_optimization:
6338 o->op_seq = PL_op_seqmax++;
6341 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6342 o->op_seq = PL_op_seqmax++;
6343 break; /* Scalar stub must produce undef. List stub is noop */
6347 if (o->op_targ == OP_NEXTSTATE
6348 || o->op_targ == OP_DBSTATE
6349 || o->op_targ == OP_SETSTATE)
6351 PL_curcop = ((COP*)o);
6353 /* XXX: We avoid setting op_seq here to prevent later calls
6354 to peep() from mistakenly concluding that optimisation
6355 has already occurred. This doesn't fix the real problem,
6356 though (See 20010220.007). AMS 20010719 */
6357 if (oldop && o->op_next) {
6358 oldop->op_next = o->op_next;
6366 if (oldop && o->op_next) {
6367 oldop->op_next = o->op_next;
6370 o->op_seq = PL_op_seqmax++;
6374 if (o->op_next->op_type == OP_RV2SV) {
6375 if (!(o->op_next->op_private & OPpDEREF)) {
6376 op_null(o->op_next);
6377 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6379 o->op_next = o->op_next->op_next;
6380 o->op_type = OP_GVSV;
6381 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6384 else if (o->op_next->op_type == OP_RV2AV) {
6385 OP* pop = o->op_next->op_next;
6387 if (pop && pop->op_type == OP_CONST &&
6388 (PL_op = pop->op_next) &&
6389 pop->op_next->op_type == OP_AELEM &&
6390 !(pop->op_next->op_private &
6391 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6392 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6397 op_null(o->op_next);
6398 op_null(pop->op_next);
6400 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6401 o->op_next = pop->op_next->op_next;
6402 o->op_type = OP_AELEMFAST;
6403 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6404 o->op_private = (U8)i;
6409 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6411 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6412 /* XXX could check prototype here instead of just carping */
6413 SV *sv = sv_newmortal();
6414 gv_efullname3(sv, gv, Nullch);
6415 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6416 "%"SVf"() called too early to check prototype",
6420 else if (o->op_next->op_type == OP_READLINE
6421 && o->op_next->op_next->op_type == OP_CONCAT
6422 && (o->op_next->op_next->op_flags & OPf_STACKED))
6424 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6425 o->op_type = OP_RCATLINE;
6426 o->op_flags |= OPf_STACKED;
6427 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6428 op_null(o->op_next->op_next);
6429 op_null(o->op_next);
6432 o->op_seq = PL_op_seqmax++;
6445 o->op_seq = PL_op_seqmax++;
6446 while (cLOGOP->op_other->op_type == OP_NULL)
6447 cLOGOP->op_other = cLOGOP->op_other->op_next;
6448 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6453 o->op_seq = PL_op_seqmax++;
6454 while (cLOOP->op_redoop->op_type == OP_NULL)
6455 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6456 peep(cLOOP->op_redoop);
6457 while (cLOOP->op_nextop->op_type == OP_NULL)
6458 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6459 peep(cLOOP->op_nextop);
6460 while (cLOOP->op_lastop->op_type == OP_NULL)
6461 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6462 peep(cLOOP->op_lastop);
6468 o->op_seq = PL_op_seqmax++;
6469 while (cPMOP->op_pmreplstart &&
6470 cPMOP->op_pmreplstart->op_type == OP_NULL)
6471 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6472 peep(cPMOP->op_pmreplstart);
6476 o->op_seq = PL_op_seqmax++;
6477 if (ckWARN(WARN_SYNTAX) && o->op_next
6478 && o->op_next->op_type == OP_NEXTSTATE) {
6479 if (o->op_next->op_sibling &&
6480 o->op_next->op_sibling->op_type != OP_EXIT &&
6481 o->op_next->op_sibling->op_type != OP_WARN &&
6482 o->op_next->op_sibling->op_type != OP_DIE) {
6483 line_t oldline = CopLINE(PL_curcop);
6485 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6486 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6487 "Statement unlikely to be reached");
6488 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6489 "\t(Maybe you meant system() when you said exec()?)\n");
6490 CopLINE_set(PL_curcop, oldline);
6501 o->op_seq = PL_op_seqmax++;
6503 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6506 /* Make the CONST have a shared SV */
6507 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6508 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6509 key = SvPV(sv, keylen);
6510 lexname = newSVpvn_share(key,
6511 SvUTF8(sv) ? -(I32)keylen : keylen,
6520 o->op_seq = PL_op_seqmax++;
6530 char* Perl_custom_op_name(pTHX_ OP* o)
6532 IV index = PTR2IV(o->op_ppaddr);
6536 if (!PL_custom_op_names) /* This probably shouldn't happen */
6537 return PL_op_name[OP_CUSTOM];
6539 keysv = sv_2mortal(newSViv(index));
6541 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
6543 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
6545 return SvPV_nolen(HeVAL(he));
6548 char* Perl_custom_op_desc(pTHX_ OP* o)
6550 IV index = PTR2IV(o->op_ppaddr);
6554 if (!PL_custom_op_descs)
6555 return PL_op_desc[OP_CUSTOM];
6557 keysv = sv_2mortal(newSViv(index));
6559 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
6561 return PL_op_desc[OP_CUSTOM];
6563 return SvPV_nolen(HeVAL(he));
6569 /* Efficient sub that returns a constant scalar value. */
6571 const_sv_xsub(pTHX_ CV* cv)
6576 Perl_croak(aTHX_ "usage: %s::%s()",
6577 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
6581 ST(0) = (SV*)XSANY.any_ptr;