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 o = prepend_elem(OP_LINESEQ, (OP*)cop, o);
3317 CHECKOP(cop->op_type, cop);
3323 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3325 return new_logop(type, flags, &first, &other);
3329 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3333 OP *first = *firstp;
3334 OP *other = *otherp;
3336 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3337 return newBINOP(type, flags, scalar(first), scalar(other));
3339 scalarboolean(first);
3340 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3341 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3342 if (type == OP_AND || type == OP_OR) {
3348 first = *firstp = cUNOPo->op_first;
3350 first->op_next = o->op_next;
3351 cUNOPo->op_first = Nullop;
3355 if (first->op_type == OP_CONST) {
3356 if (first->op_private & OPpCONST_STRICT)
3357 no_bareword_allowed(first);
3358 else if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3359 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3360 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3371 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS) &&
3372 type != OP_DOR) /* [#24076] Don't warn for <FH> err FOO. */
3374 OP *k1 = ((UNOP*)first)->op_first;
3375 OP *k2 = k1->op_sibling;
3377 switch (first->op_type)
3380 if (k2 && k2->op_type == OP_READLINE
3381 && (k2->op_flags & OPf_STACKED)
3382 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3384 warnop = k2->op_type;
3389 if (k1->op_type == OP_READDIR
3390 || k1->op_type == OP_GLOB
3391 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3392 || k1->op_type == OP_EACH)
3394 warnop = ((k1->op_type == OP_NULL)
3395 ? (OPCODE)k1->op_targ : k1->op_type);
3400 line_t oldline = CopLINE(PL_curcop);
3401 CopLINE_set(PL_curcop, PL_copline);
3402 Perl_warner(aTHX_ packWARN(WARN_MISC),
3403 "Value of %s%s can be \"0\"; test with defined()",
3405 ((warnop == OP_READLINE || warnop == OP_GLOB)
3406 ? " construct" : "() operator"));
3407 CopLINE_set(PL_curcop, oldline);
3414 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3415 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3417 NewOp(1101, logop, 1, LOGOP);
3419 logop->op_type = (OPCODE)type;
3420 logop->op_ppaddr = PL_ppaddr[type];
3421 logop->op_first = first;
3422 logop->op_flags = flags | OPf_KIDS;
3423 logop->op_other = LINKLIST(other);
3424 logop->op_private = (U8)(1 | (flags >> 8));
3426 /* establish postfix order */
3427 logop->op_next = LINKLIST(first);
3428 first->op_next = (OP*)logop;
3429 first->op_sibling = other;
3431 CHECKOP(type,logop);
3433 o = newUNOP(OP_NULL, 0, (OP*)logop);
3440 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3447 return newLOGOP(OP_AND, 0, first, trueop);
3449 return newLOGOP(OP_OR, 0, first, falseop);
3451 scalarboolean(first);
3452 if (first->op_type == OP_CONST) {
3453 if (first->op_private & OPpCONST_BARE &&
3454 first->op_private & OPpCONST_STRICT) {
3455 no_bareword_allowed(first);
3457 if (SvTRUE(((SVOP*)first)->op_sv)) {
3468 NewOp(1101, logop, 1, LOGOP);
3469 logop->op_type = OP_COND_EXPR;
3470 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3471 logop->op_first = first;
3472 logop->op_flags = flags | OPf_KIDS;
3473 logop->op_private = (U8)(1 | (flags >> 8));
3474 logop->op_other = LINKLIST(trueop);
3475 logop->op_next = LINKLIST(falseop);
3477 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
3480 /* establish postfix order */
3481 start = LINKLIST(first);
3482 first->op_next = (OP*)logop;
3484 first->op_sibling = trueop;
3485 trueop->op_sibling = falseop;
3486 o = newUNOP(OP_NULL, 0, (OP*)logop);
3488 trueop->op_next = falseop->op_next = o;
3495 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3503 NewOp(1101, range, 1, LOGOP);
3505 range->op_type = OP_RANGE;
3506 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3507 range->op_first = left;
3508 range->op_flags = OPf_KIDS;
3509 leftstart = LINKLIST(left);
3510 range->op_other = LINKLIST(right);
3511 range->op_private = (U8)(1 | (flags >> 8));
3513 left->op_sibling = right;
3515 range->op_next = (OP*)range;
3516 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3517 flop = newUNOP(OP_FLOP, 0, flip);
3518 o = newUNOP(OP_NULL, 0, flop);
3520 range->op_next = leftstart;
3522 left->op_next = flip;
3523 right->op_next = flop;
3525 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3526 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3527 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3528 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3530 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3531 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3534 if (!flip->op_private || !flop->op_private)
3535 linklist(o); /* blow off optimizer unless constant */
3541 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3545 int once = block && block->op_flags & OPf_SPECIAL &&
3546 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3549 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3550 return block; /* do {} while 0 does once */
3551 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3552 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3553 expr = newUNOP(OP_DEFINED, 0,
3554 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3555 } else if (expr->op_flags & OPf_KIDS) {
3556 OP *k1 = ((UNOP*)expr)->op_first;
3557 OP *k2 = (k1) ? k1->op_sibling : NULL;
3558 switch (expr->op_type) {
3560 if (k2 && k2->op_type == OP_READLINE
3561 && (k2->op_flags & OPf_STACKED)
3562 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3563 expr = newUNOP(OP_DEFINED, 0, expr);
3567 if (k1->op_type == OP_READDIR
3568 || k1->op_type == OP_GLOB
3569 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3570 || k1->op_type == OP_EACH)
3571 expr = newUNOP(OP_DEFINED, 0, expr);
3577 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3578 o = new_logop(OP_AND, 0, &expr, &listop);
3581 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3583 if (once && o != listop)
3584 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3587 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3589 o->op_flags |= flags;
3591 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3596 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3604 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3605 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3606 expr = newUNOP(OP_DEFINED, 0,
3607 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3608 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3609 OP *k1 = ((UNOP*)expr)->op_first;
3610 OP *k2 = (k1) ? k1->op_sibling : NULL;
3611 switch (expr->op_type) {
3613 if (k2 && k2->op_type == OP_READLINE
3614 && (k2->op_flags & OPf_STACKED)
3615 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3616 expr = newUNOP(OP_DEFINED, 0, expr);
3620 if (k1->op_type == OP_READDIR
3621 || k1->op_type == OP_GLOB
3622 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3623 || k1->op_type == OP_EACH)
3624 expr = newUNOP(OP_DEFINED, 0, expr);
3630 block = newOP(OP_NULL, 0);
3632 block = scope(block);
3636 next = LINKLIST(cont);
3639 OP *unstack = newOP(OP_UNSTACK, 0);
3642 cont = append_elem(OP_LINESEQ, cont, unstack);
3645 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3646 redo = LINKLIST(listop);
3649 PL_copline = (line_t)whileline;
3651 o = new_logop(OP_AND, 0, &expr, &listop);
3652 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3653 op_free(expr); /* oops, it's a while (0) */
3655 return Nullop; /* listop already freed by new_logop */
3658 ((LISTOP*)listop)->op_last->op_next =
3659 (o == listop ? redo : LINKLIST(o));
3665 NewOp(1101,loop,1,LOOP);
3666 loop->op_type = OP_ENTERLOOP;
3667 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3668 loop->op_private = 0;
3669 loop->op_next = (OP*)loop;
3672 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3674 loop->op_redoop = redo;
3675 loop->op_lastop = o;
3676 o->op_private |= loopflags;
3679 loop->op_nextop = next;
3681 loop->op_nextop = o;
3683 o->op_flags |= flags;
3684 o->op_private |= (flags >> 8);
3689 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
3693 PADOFFSET padoff = 0;
3698 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
3699 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
3700 sv->op_type = OP_RV2GV;
3701 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3703 else if (sv->op_type == OP_PADSV) { /* private variable */
3704 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
3705 padoff = sv->op_targ;
3710 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3711 padoff = sv->op_targ;
3713 iterflags |= OPf_SPECIAL;
3718 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3721 I32 offset = pad_findmy("$_");
3722 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
3723 sv = newGVOP(OP_GV, 0, PL_defgv);
3727 iterpflags = OPpLVAL_INTRO; /* my $_; for () */
3730 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3731 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3732 iterflags |= OPf_STACKED;
3734 else if (expr->op_type == OP_NULL &&
3735 (expr->op_flags & OPf_KIDS) &&
3736 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3738 /* Basically turn for($x..$y) into the same as for($x,$y), but we
3739 * set the STACKED flag to indicate that these values are to be
3740 * treated as min/max values by 'pp_iterinit'.
3742 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
3743 LOGOP* range = (LOGOP*) flip->op_first;
3744 OP* left = range->op_first;
3745 OP* right = left->op_sibling;
3748 range->op_flags &= ~OPf_KIDS;
3749 range->op_first = Nullop;
3751 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
3752 listop->op_first->op_next = range->op_next;
3753 left->op_next = range->op_other;
3754 right->op_next = (OP*)listop;
3755 listop->op_next = listop->op_first;
3758 expr = (OP*)(listop);
3760 iterflags |= OPf_STACKED;
3763 expr = mod(force_list(expr), OP_GREPSTART);
3767 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
3768 append_elem(OP_LIST, expr, scalar(sv))));
3769 assert(!loop->op_next);
3770 /* for my $x () sets OPpLVAL_INTRO;
3771 * for our $x () sets OPpOUR_INTRO */
3772 loop->op_private = (U8)iterpflags;
3773 #ifdef PL_OP_SLAB_ALLOC
3776 NewOp(1234,tmp,1,LOOP);
3777 Copy(loop,tmp,1,LOOP);
3782 Renew(loop, 1, LOOP);
3784 loop->op_targ = padoff;
3785 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
3786 PL_copline = forline;
3787 return newSTATEOP(0, label, wop);
3791 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
3796 if (type != OP_GOTO || label->op_type == OP_CONST) {
3797 /* "last()" means "last" */
3798 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
3799 o = newOP(type, OPf_SPECIAL);
3801 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
3802 ? SvPVx(((SVOP*)label)->op_sv, n_a)
3808 /* Check whether it's going to be a goto &function */
3809 if (label->op_type == OP_ENTERSUB
3810 && !(label->op_flags & OPf_STACKED))
3811 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
3812 o = newUNOP(type, OPf_STACKED, label);
3814 PL_hints |= HINT_BLOCK_SCOPE;
3819 =for apidoc cv_undef
3821 Clear out all the active components of a CV. This can happen either
3822 by an explicit C<undef &foo>, or by the reference count going to zero.
3823 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
3824 children can still follow the full lexical scope chain.
3830 Perl_cv_undef(pTHX_ CV *cv)
3833 if (CvFILE(cv) && !CvXSUB(cv)) {
3834 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
3835 Safefree(CvFILE(cv));
3840 if (!CvXSUB(cv) && CvROOT(cv)) {
3842 Perl_croak(aTHX_ "Can't undef active subroutine");
3845 PAD_SAVE_SETNULLPAD();
3847 op_free(CvROOT(cv));
3848 CvROOT(cv) = Nullop;
3851 SvPOK_off((SV*)cv); /* forget prototype */
3856 /* remove CvOUTSIDE unless this is an undef rather than a free */
3857 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
3858 if (!CvWEAKOUTSIDE(cv))
3859 SvREFCNT_dec(CvOUTSIDE(cv));
3860 CvOUTSIDE(cv) = Nullcv;
3863 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
3869 /* delete all flags except WEAKOUTSIDE */
3870 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
3874 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
3876 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
3877 SV* msg = sv_newmortal();
3881 gv_efullname3(name = sv_newmortal(), gv, Nullch);
3882 sv_setpv(msg, "Prototype mismatch:");
3884 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
3886 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (SV *)cv);
3887 sv_catpv(msg, " vs ");
3889 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
3891 sv_catpv(msg, "none");
3892 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
3896 static void const_sv_xsub(pTHX_ CV* cv);
3900 =head1 Optree Manipulation Functions
3902 =for apidoc cv_const_sv
3904 If C<cv> is a constant sub eligible for inlining. returns the constant
3905 value returned by the sub. Otherwise, returns NULL.
3907 Constant subs can be created with C<newCONSTSUB> or as described in
3908 L<perlsub/"Constant Functions">.
3913 Perl_cv_const_sv(pTHX_ CV *cv)
3915 if (!cv || !CvCONST(cv))
3917 return (SV*)CvXSUBANY(cv).any_ptr;
3920 /* op_const_sv: examine an optree to determine whether it's in-lineable.
3921 * Can be called in 3 ways:
3924 * look for a single OP_CONST with attached value: return the value
3926 * cv && CvCLONE(cv) && !CvCONST(cv)
3928 * examine the clone prototype, and if contains only a single
3929 * OP_CONST referencing a pad const, or a single PADSV referencing
3930 * an outer lexical, return a non-zero value to indicate the CV is
3931 * a candidate for "constizing" at clone time
3935 * We have just cloned an anon prototype that was marked as a const
3936 * candidiate. Try to grab the current value, and in the case of
3937 * PADSV, ignore it if it has multiple references. Return the value.
3941 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
3948 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
3949 o = cLISTOPo->op_first->op_sibling;
3951 for (; o; o = o->op_next) {
3952 OPCODE type = o->op_type;
3954 if (sv && o->op_next == o)
3956 if (o->op_next != o) {
3957 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
3959 if (type == OP_DBSTATE)
3962 if (type == OP_LEAVESUB || type == OP_RETURN)
3966 if (type == OP_CONST && cSVOPo->op_sv)
3968 else if (cv && type == OP_CONST) {
3969 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
3973 else if (cv && type == OP_PADSV) {
3974 if (CvCONST(cv)) { /* newly cloned anon */
3975 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
3976 /* the candidate should have 1 ref from this pad and 1 ref
3977 * from the parent */
3978 if (!sv || SvREFCNT(sv) != 2)
3985 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
3986 sv = &PL_sv_undef; /* an arbitrary non-null value */
3997 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4007 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4011 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4013 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4017 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4023 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4027 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4028 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4029 SV *sv = sv_newmortal();
4030 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4031 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4032 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4037 gv = gv_fetchpv(name ? name : (aname ? aname :
4038 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__")),
4039 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4049 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4050 maximum a prototype before. */
4051 if (SvTYPE(gv) > SVt_NULL) {
4052 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4053 && ckWARN_d(WARN_PROTOTYPE))
4055 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4057 cv_ckproto((CV*)gv, NULL, ps);
4060 sv_setpv((SV*)gv, ps);
4062 sv_setiv((SV*)gv, -1);
4063 SvREFCNT_dec(PL_compcv);
4064 cv = PL_compcv = NULL;
4065 PL_sub_generation++;
4069 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4071 #ifdef GV_UNIQUE_CHECK
4072 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4073 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4077 if (!block || !ps || *ps || attrs)
4080 const_sv = op_const_sv(block, Nullcv);
4083 bool exists = CvROOT(cv) || CvXSUB(cv);
4085 #ifdef GV_UNIQUE_CHECK
4086 if (exists && GvUNIQUE(gv)) {
4087 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4091 /* if the subroutine doesn't exist and wasn't pre-declared
4092 * with a prototype, assume it will be AUTOLOADed,
4093 * skipping the prototype check
4095 if (exists || SvPOK(cv))
4096 cv_ckproto(cv, gv, ps);
4097 /* already defined (or promised)? */
4098 if (exists || GvASSUMECV(gv)) {
4099 if (!block && !attrs) {
4100 if (CvFLAGS(PL_compcv)) {
4101 /* might have had built-in attrs applied */
4102 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4104 /* just a "sub foo;" when &foo is already defined */
4105 SAVEFREESV(PL_compcv);
4108 /* ahem, death to those who redefine active sort subs */
4109 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4110 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4112 if (ckWARN(WARN_REDEFINE)
4114 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4116 line_t oldline = CopLINE(PL_curcop);
4117 if (PL_copline != NOLINE)
4118 CopLINE_set(PL_curcop, PL_copline);
4119 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4120 CvCONST(cv) ? "Constant subroutine %s redefined"
4121 : "Subroutine %s redefined", name);
4122 CopLINE_set(PL_curcop, oldline);
4130 SvREFCNT_inc(const_sv);
4132 assert(!CvROOT(cv) && !CvCONST(cv));
4133 sv_setpv((SV*)cv, ""); /* prototype is "" */
4134 CvXSUBANY(cv).any_ptr = const_sv;
4135 CvXSUB(cv) = const_sv_xsub;
4140 cv = newCONSTSUB(NULL, name, const_sv);
4143 SvREFCNT_dec(PL_compcv);
4145 PL_sub_generation++;
4152 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4153 * before we clobber PL_compcv.
4157 /* Might have had built-in attributes applied -- propagate them. */
4158 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4159 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4160 stash = GvSTASH(CvGV(cv));
4161 else if (CvSTASH(cv))
4162 stash = CvSTASH(cv);
4164 stash = PL_curstash;
4167 /* possibly about to re-define existing subr -- ignore old cv */
4168 rcv = (SV*)PL_compcv;
4169 if (name && GvSTASH(gv))
4170 stash = GvSTASH(gv);
4172 stash = PL_curstash;
4174 apply_attrs(stash, rcv, attrs, FALSE);
4176 if (cv) { /* must reuse cv if autoloaded */
4178 /* got here with just attrs -- work done, so bug out */
4179 SAVEFREESV(PL_compcv);
4182 /* transfer PL_compcv to cv */
4184 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4185 if (!CvWEAKOUTSIDE(cv))
4186 SvREFCNT_dec(CvOUTSIDE(cv));
4187 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4188 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4189 CvOUTSIDE(PL_compcv) = 0;
4190 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4191 CvPADLIST(PL_compcv) = 0;
4192 /* inner references to PL_compcv must be fixed up ... */
4193 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4194 /* ... before we throw it away */
4195 SvREFCNT_dec(PL_compcv);
4197 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4198 ++PL_sub_generation;
4205 PL_sub_generation++;
4209 CvFILE_set_from_cop(cv, PL_curcop);
4210 CvSTASH(cv) = PL_curstash;
4213 sv_setpv((SV*)cv, ps);
4215 if (PL_error_count) {
4219 char *s = strrchr(name, ':');
4221 if (strEQ(s, "BEGIN")) {
4223 "BEGIN not safe after errors--compilation aborted";
4224 if (PL_in_eval & EVAL_KEEPERR)
4225 Perl_croak(aTHX_ not_safe);
4227 /* force display of errors found but not reported */
4228 sv_catpv(ERRSV, not_safe);
4229 Perl_croak(aTHX_ "%"SVf, ERRSV);
4238 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4239 mod(scalarseq(block), OP_LEAVESUBLV));
4242 /* This makes sub {}; work as expected. */
4243 if (block->op_type == OP_STUB) {
4245 block = newSTATEOP(0, Nullch, 0);
4247 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4249 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4250 OpREFCNT_set(CvROOT(cv), 1);
4251 CvSTART(cv) = LINKLIST(CvROOT(cv));
4252 CvROOT(cv)->op_next = 0;
4253 CALL_PEEP(CvSTART(cv));
4255 /* now that optimizer has done its work, adjust pad values */
4257 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4260 assert(!CvCONST(cv));
4261 if (ps && !*ps && op_const_sv(block, cv))
4265 if (name || aname) {
4267 char *tname = (name ? name : aname);
4269 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4270 SV *sv = NEWSV(0,0);
4271 SV *tmpstr = sv_newmortal();
4272 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4276 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4278 (long)PL_subline, (long)CopLINE(PL_curcop));
4279 gv_efullname3(tmpstr, gv, Nullch);
4280 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4281 hv = GvHVn(db_postponed);
4282 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4283 && (pcv = GvCV(db_postponed)))
4289 call_sv((SV*)pcv, G_DISCARD);
4293 if ((s = strrchr(tname,':')))
4298 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4301 if (strEQ(s, "BEGIN") && !PL_error_count) {
4302 I32 oldscope = PL_scopestack_ix;
4304 SAVECOPFILE(&PL_compiling);
4305 SAVECOPLINE(&PL_compiling);
4308 PL_beginav = newAV();
4309 DEBUG_x( dump_sub(gv) );
4310 av_push(PL_beginav, (SV*)cv);
4311 GvCV(gv) = 0; /* cv has been hijacked */
4312 call_list(oldscope, PL_beginav);
4314 PL_curcop = &PL_compiling;
4315 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4318 else if (strEQ(s, "END") && !PL_error_count) {
4321 DEBUG_x( dump_sub(gv) );
4322 av_unshift(PL_endav, 1);
4323 av_store(PL_endav, 0, (SV*)cv);
4324 GvCV(gv) = 0; /* cv has been hijacked */
4326 else if (strEQ(s, "CHECK") && !PL_error_count) {
4328 PL_checkav = newAV();
4329 DEBUG_x( dump_sub(gv) );
4330 if (PL_main_start && ckWARN(WARN_VOID))
4331 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4332 av_unshift(PL_checkav, 1);
4333 av_store(PL_checkav, 0, (SV*)cv);
4334 GvCV(gv) = 0; /* cv has been hijacked */
4336 else if (strEQ(s, "INIT") && !PL_error_count) {
4338 PL_initav = newAV();
4339 DEBUG_x( dump_sub(gv) );
4340 if (PL_main_start && ckWARN(WARN_VOID))
4341 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4342 av_push(PL_initav, (SV*)cv);
4343 GvCV(gv) = 0; /* cv has been hijacked */
4348 PL_copline = NOLINE;
4353 /* XXX unsafe for threads if eval_owner isn't held */
4355 =for apidoc newCONSTSUB
4357 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4358 eligible for inlining at compile-time.
4364 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4370 SAVECOPLINE(PL_curcop);
4371 CopLINE_set(PL_curcop, PL_copline);
4374 PL_hints &= ~HINT_BLOCK_SCOPE;
4377 SAVESPTR(PL_curstash);
4378 SAVECOPSTASH(PL_curcop);
4379 PL_curstash = stash;
4380 CopSTASH_set(PL_curcop,stash);
4383 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4384 CvXSUBANY(cv).any_ptr = sv;
4386 sv_setpv((SV*)cv, ""); /* prototype is "" */
4389 CopSTASH_free(PL_curcop);
4397 =for apidoc U||newXS
4399 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4405 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
4407 GV *gv = gv_fetchpv(name ? name :
4408 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4409 GV_ADDMULTI, SVt_PVCV);
4413 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4415 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4417 /* just a cached method */
4421 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4422 /* already defined (or promised) */
4423 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4424 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4425 line_t oldline = CopLINE(PL_curcop);
4426 if (PL_copline != NOLINE)
4427 CopLINE_set(PL_curcop, PL_copline);
4428 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4429 CvCONST(cv) ? "Constant subroutine %s redefined"
4430 : "Subroutine %s redefined"
4432 CopLINE_set(PL_curcop, oldline);
4439 if (cv) /* must reuse cv if autoloaded */
4442 cv = (CV*)NEWSV(1105,0);
4443 sv_upgrade((SV *)cv, SVt_PVCV);
4447 PL_sub_generation++;
4451 (void)gv_fetchfile(filename);
4452 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
4453 an external constant string */
4454 CvXSUB(cv) = subaddr;
4457 char *s = strrchr(name,':');
4463 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4466 if (strEQ(s, "BEGIN")) {
4468 PL_beginav = newAV();
4469 av_push(PL_beginav, (SV*)cv);
4470 GvCV(gv) = 0; /* cv has been hijacked */
4472 else if (strEQ(s, "END")) {
4475 av_unshift(PL_endav, 1);
4476 av_store(PL_endav, 0, (SV*)cv);
4477 GvCV(gv) = 0; /* cv has been hijacked */
4479 else if (strEQ(s, "CHECK")) {
4481 PL_checkav = newAV();
4482 if (PL_main_start && ckWARN(WARN_VOID))
4483 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4484 av_unshift(PL_checkav, 1);
4485 av_store(PL_checkav, 0, (SV*)cv);
4486 GvCV(gv) = 0; /* cv has been hijacked */
4488 else if (strEQ(s, "INIT")) {
4490 PL_initav = newAV();
4491 if (PL_main_start && ckWARN(WARN_VOID))
4492 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4493 av_push(PL_initav, (SV*)cv);
4494 GvCV(gv) = 0; /* cv has been hijacked */
4505 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4513 name = SvPVx(cSVOPo->op_sv, n_a);
4516 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
4517 #ifdef GV_UNIQUE_CHECK
4519 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4523 if ((cv = GvFORM(gv))) {
4524 if (ckWARN(WARN_REDEFINE)) {
4525 line_t oldline = CopLINE(PL_curcop);
4526 if (PL_copline != NOLINE)
4527 CopLINE_set(PL_curcop, PL_copline);
4528 Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Format %s redefined",name);
4529 CopLINE_set(PL_curcop, oldline);
4536 CvFILE_set_from_cop(cv, PL_curcop);
4539 pad_tidy(padtidy_FORMAT);
4540 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4541 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4542 OpREFCNT_set(CvROOT(cv), 1);
4543 CvSTART(cv) = LINKLIST(CvROOT(cv));
4544 CvROOT(cv)->op_next = 0;
4545 CALL_PEEP(CvSTART(cv));
4547 PL_copline = NOLINE;
4552 Perl_newANONLIST(pTHX_ OP *o)
4554 return newUNOP(OP_REFGEN, 0,
4555 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4559 Perl_newANONHASH(pTHX_ OP *o)
4561 return newUNOP(OP_REFGEN, 0,
4562 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4566 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4568 return newANONATTRSUB(floor, proto, Nullop, block);
4572 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4574 return newUNOP(OP_REFGEN, 0,
4575 newSVOP(OP_ANONCODE, 0,
4576 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
4580 Perl_oopsAV(pTHX_ OP *o)
4582 switch (o->op_type) {
4584 o->op_type = OP_PADAV;
4585 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4586 return ref(o, OP_RV2AV);
4589 o->op_type = OP_RV2AV;
4590 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4595 if (ckWARN_d(WARN_INTERNAL))
4596 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
4603 Perl_oopsHV(pTHX_ OP *o)
4605 switch (o->op_type) {
4608 o->op_type = OP_PADHV;
4609 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4610 return ref(o, OP_RV2HV);
4614 o->op_type = OP_RV2HV;
4615 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
4620 if (ckWARN_d(WARN_INTERNAL))
4621 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
4628 Perl_newAVREF(pTHX_ OP *o)
4630 if (o->op_type == OP_PADANY) {
4631 o->op_type = OP_PADAV;
4632 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4635 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
4636 && ckWARN(WARN_DEPRECATED)) {
4637 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4638 "Using an array as a reference is deprecated");
4640 return newUNOP(OP_RV2AV, 0, scalar(o));
4644 Perl_newGVREF(pTHX_ I32 type, OP *o)
4646 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
4647 return newUNOP(OP_NULL, 0, o);
4648 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
4652 Perl_newHVREF(pTHX_ OP *o)
4654 if (o->op_type == OP_PADANY) {
4655 o->op_type = OP_PADHV;
4656 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4659 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
4660 && ckWARN(WARN_DEPRECATED)) {
4661 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4662 "Using a hash as a reference is deprecated");
4664 return newUNOP(OP_RV2HV, 0, scalar(o));
4668 Perl_oopsCV(pTHX_ OP *o)
4670 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
4676 Perl_newCVREF(pTHX_ I32 flags, OP *o)
4678 return newUNOP(OP_RV2CV, flags, scalar(o));
4682 Perl_newSVREF(pTHX_ OP *o)
4684 if (o->op_type == OP_PADANY) {
4685 o->op_type = OP_PADSV;
4686 o->op_ppaddr = PL_ppaddr[OP_PADSV];
4689 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4690 o->op_flags |= OPpDONE_SVREF;
4693 return newUNOP(OP_RV2SV, 0, scalar(o));
4696 /* Check routines. */
4699 Perl_ck_anoncode(pTHX_ OP *o)
4701 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
4702 cSVOPo->op_sv = Nullsv;
4707 Perl_ck_bitop(pTHX_ OP *o)
4709 #define OP_IS_NUMCOMPARE(op) \
4710 ((op) == OP_LT || (op) == OP_I_LT || \
4711 (op) == OP_GT || (op) == OP_I_GT || \
4712 (op) == OP_LE || (op) == OP_I_LE || \
4713 (op) == OP_GE || (op) == OP_I_GE || \
4714 (op) == OP_EQ || (op) == OP_I_EQ || \
4715 (op) == OP_NE || (op) == OP_I_NE || \
4716 (op) == OP_NCMP || (op) == OP_I_NCMP)
4717 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4718 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
4719 && (o->op_type == OP_BIT_OR
4720 || o->op_type == OP_BIT_AND
4721 || o->op_type == OP_BIT_XOR))
4723 OP * left = cBINOPo->op_first;
4724 OP * right = left->op_sibling;
4725 if ((OP_IS_NUMCOMPARE(left->op_type) &&
4726 (left->op_flags & OPf_PARENS) == 0) ||
4727 (OP_IS_NUMCOMPARE(right->op_type) &&
4728 (right->op_flags & OPf_PARENS) == 0))
4729 if (ckWARN(WARN_PRECEDENCE))
4730 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4731 "Possible precedence problem on bitwise %c operator",
4732 o->op_type == OP_BIT_OR ? '|'
4733 : o->op_type == OP_BIT_AND ? '&' : '^'
4740 Perl_ck_concat(pTHX_ OP *o)
4742 OP *kid = cUNOPo->op_first;
4743 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
4744 !(kUNOP->op_first->op_flags & OPf_MOD))
4745 o->op_flags |= OPf_STACKED;
4750 Perl_ck_spair(pTHX_ OP *o)
4752 if (o->op_flags & OPf_KIDS) {
4755 OPCODE type = o->op_type;
4756 o = modkids(ck_fun(o), type);
4757 kid = cUNOPo->op_first;
4758 newop = kUNOP->op_first->op_sibling;
4760 (newop->op_sibling ||
4761 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
4762 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
4763 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
4767 op_free(kUNOP->op_first);
4768 kUNOP->op_first = newop;
4770 o->op_ppaddr = PL_ppaddr[++o->op_type];
4775 Perl_ck_delete(pTHX_ OP *o)
4779 if (o->op_flags & OPf_KIDS) {
4780 OP *kid = cUNOPo->op_first;
4781 switch (kid->op_type) {
4783 o->op_flags |= OPf_SPECIAL;
4786 o->op_private |= OPpSLICE;
4789 o->op_flags |= OPf_SPECIAL;
4794 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
4803 Perl_ck_die(pTHX_ OP *o)
4806 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4812 Perl_ck_eof(pTHX_ OP *o)
4814 I32 type = o->op_type;
4816 if (o->op_flags & OPf_KIDS) {
4817 if (cLISTOPo->op_first->op_type == OP_STUB) {
4819 o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
4827 Perl_ck_eval(pTHX_ OP *o)
4829 PL_hints |= HINT_BLOCK_SCOPE;
4830 if (o->op_flags & OPf_KIDS) {
4831 SVOP *kid = (SVOP*)cUNOPo->op_first;
4834 o->op_flags &= ~OPf_KIDS;
4837 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
4840 cUNOPo->op_first = 0;
4843 NewOp(1101, enter, 1, LOGOP);
4844 enter->op_type = OP_ENTERTRY;
4845 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
4846 enter->op_private = 0;
4848 /* establish postfix order */
4849 enter->op_next = (OP*)enter;
4851 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
4852 o->op_type = OP_LEAVETRY;
4853 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
4854 enter->op_other = o;
4864 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
4866 o->op_targ = (PADOFFSET)PL_hints;
4871 Perl_ck_exit(pTHX_ OP *o)
4874 HV *table = GvHV(PL_hintgv);
4876 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
4877 if (svp && *svp && SvTRUE(*svp))
4878 o->op_private |= OPpEXIT_VMSISH;
4880 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4886 Perl_ck_exec(pTHX_ OP *o)
4889 if (o->op_flags & OPf_STACKED) {
4891 kid = cUNOPo->op_first->op_sibling;
4892 if (kid->op_type == OP_RV2GV)
4901 Perl_ck_exists(pTHX_ OP *o)
4904 if (o->op_flags & OPf_KIDS) {
4905 OP *kid = cUNOPo->op_first;
4906 if (kid->op_type == OP_ENTERSUB) {
4907 (void) ref(kid, o->op_type);
4908 if (kid->op_type != OP_RV2CV && !PL_error_count)
4909 Perl_croak(aTHX_ "%s argument is not a subroutine name",
4911 o->op_private |= OPpEXISTS_SUB;
4913 else if (kid->op_type == OP_AELEM)
4914 o->op_flags |= OPf_SPECIAL;
4915 else if (kid->op_type != OP_HELEM)
4916 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
4925 Perl_ck_gvconst(pTHX_ register OP *o)
4927 o = fold_constants(o);
4928 if (o->op_type == OP_CONST)
4935 Perl_ck_rvconst(pTHX_ register OP *o)
4937 SVOP *kid = (SVOP*)cUNOPo->op_first;
4939 o->op_private |= (PL_hints & HINT_STRICT_REFS);
4940 if (kid->op_type == OP_CONST) {
4944 SV *kidsv = kid->op_sv;
4947 /* Is it a constant from cv_const_sv()? */
4948 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
4949 SV *rsv = SvRV(kidsv);
4950 int svtype = SvTYPE(rsv);
4951 char *badtype = Nullch;
4953 switch (o->op_type) {
4955 if (svtype > SVt_PVMG)
4956 badtype = "a SCALAR";
4959 if (svtype != SVt_PVAV)
4960 badtype = "an ARRAY";
4963 if (svtype != SVt_PVHV)
4967 if (svtype != SVt_PVCV)
4972 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
4975 name = SvPV(kidsv, n_a);
4976 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
4977 char *badthing = Nullch;
4978 switch (o->op_type) {
4980 badthing = "a SCALAR";
4983 badthing = "an ARRAY";
4986 badthing = "a HASH";
4991 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
4995 * This is a little tricky. We only want to add the symbol if we
4996 * didn't add it in the lexer. Otherwise we get duplicate strict
4997 * warnings. But if we didn't add it in the lexer, we must at
4998 * least pretend like we wanted to add it even if it existed before,
4999 * or we get possible typo warnings. OPpCONST_ENTERED says
5000 * whether the lexer already added THIS instance of this symbol.
5002 iscv = (o->op_type == OP_RV2CV) * 2;
5004 gv = gv_fetchpv(name,
5005 iscv | !(kid->op_private & OPpCONST_ENTERED),
5008 : o->op_type == OP_RV2SV
5010 : o->op_type == OP_RV2AV
5012 : o->op_type == OP_RV2HV
5015 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5017 kid->op_type = OP_GV;
5018 SvREFCNT_dec(kid->op_sv);
5020 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5021 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5022 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
5024 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
5026 kid->op_sv = SvREFCNT_inc(gv);
5028 kid->op_private = 0;
5029 kid->op_ppaddr = PL_ppaddr[OP_GV];
5036 Perl_ck_ftst(pTHX_ OP *o)
5038 I32 type = o->op_type;
5040 if (o->op_flags & OPf_REF) {
5043 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5044 SVOP *kid = (SVOP*)cUNOPo->op_first;
5046 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5048 OP *newop = newGVOP(type, OPf_REF,
5049 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5054 if ((PL_hints & HINT_FILETEST_ACCESS) &&
5055 OP_IS_FILETEST_ACCESS(o))
5056 o->op_private |= OPpFT_ACCESS;
5058 if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
5059 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
5060 o->op_private |= OPpFT_STACKED;
5064 if (type == OP_FTTTY)
5065 o = newGVOP(type, OPf_REF, PL_stdingv);
5067 o = newUNOP(type, 0, newDEFSVOP());
5073 Perl_ck_fun(pTHX_ OP *o)
5079 int type = o->op_type;
5080 register I32 oa = PL_opargs[type] >> OASHIFT;
5082 if (o->op_flags & OPf_STACKED) {
5083 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5086 return no_fh_allowed(o);
5089 if (o->op_flags & OPf_KIDS) {
5091 tokid = &cLISTOPo->op_first;
5092 kid = cLISTOPo->op_first;
5093 if (kid->op_type == OP_PUSHMARK ||
5094 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5096 tokid = &kid->op_sibling;
5097 kid = kid->op_sibling;
5099 if (!kid && PL_opargs[type] & OA_DEFGV)
5100 *tokid = kid = newDEFSVOP();
5104 sibl = kid->op_sibling;
5107 /* list seen where single (scalar) arg expected? */
5108 if (numargs == 1 && !(oa >> 4)
5109 && kid->op_type == OP_LIST && type != OP_SCALAR)
5111 return too_many_arguments(o,PL_op_desc[type]);
5124 if ((type == OP_PUSH || type == OP_UNSHIFT)
5125 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5126 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5127 "Useless use of %s with no values",
5130 if (kid->op_type == OP_CONST &&
5131 (kid->op_private & OPpCONST_BARE))
5133 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5134 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5135 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5136 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5137 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5138 "Array @%s missing the @ in argument %"IVdf" of %s()",
5139 name, (IV)numargs, PL_op_desc[type]);
5142 kid->op_sibling = sibl;
5145 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5146 bad_type(numargs, "array", PL_op_desc[type], kid);
5150 if (kid->op_type == OP_CONST &&
5151 (kid->op_private & OPpCONST_BARE))
5153 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5154 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5155 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5156 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5157 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5158 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5159 name, (IV)numargs, PL_op_desc[type]);
5162 kid->op_sibling = sibl;
5165 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5166 bad_type(numargs, "hash", PL_op_desc[type], kid);
5171 OP *newop = newUNOP(OP_NULL, 0, kid);
5172 kid->op_sibling = 0;
5174 newop->op_next = newop;
5176 kid->op_sibling = sibl;
5181 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5182 if (kid->op_type == OP_CONST &&
5183 (kid->op_private & OPpCONST_BARE))
5185 OP *newop = newGVOP(OP_GV, 0,
5186 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5188 if (!(o->op_private & 1) && /* if not unop */
5189 kid == cLISTOPo->op_last)
5190 cLISTOPo->op_last = newop;
5194 else if (kid->op_type == OP_READLINE) {
5195 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5196 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5199 I32 flags = OPf_SPECIAL;
5203 /* is this op a FH constructor? */
5204 if (is_handle_constructor(o,numargs)) {
5205 char *name = Nullch;
5209 /* Set a flag to tell rv2gv to vivify
5210 * need to "prove" flag does not mean something
5211 * else already - NI-S 1999/05/07
5214 if (kid->op_type == OP_PADSV) {
5215 name = PAD_COMPNAME_PV(kid->op_targ);
5216 /* SvCUR of a pad namesv can't be trusted
5217 * (see PL_generation), so calc its length
5223 else if (kid->op_type == OP_RV2SV
5224 && kUNOP->op_first->op_type == OP_GV)
5226 GV *gv = cGVOPx_gv(kUNOP->op_first);
5228 len = GvNAMELEN(gv);
5230 else if (kid->op_type == OP_AELEM
5231 || kid->op_type == OP_HELEM)
5236 if ((op = ((BINOP*)kid)->op_first)) {
5237 SV *tmpstr = Nullsv;
5239 kid->op_type == OP_AELEM ?
5241 if (((op->op_type == OP_RV2AV) ||
5242 (op->op_type == OP_RV2HV)) &&
5243 (op = ((UNOP*)op)->op_first) &&
5244 (op->op_type == OP_GV)) {
5245 /* packagevar $a[] or $h{} */
5246 GV *gv = cGVOPx_gv(op);
5254 else if (op->op_type == OP_PADAV
5255 || op->op_type == OP_PADHV) {
5256 /* lexicalvar $a[] or $h{} */
5258 PAD_COMPNAME_PV(op->op_targ);
5268 name = SvPV(tmpstr, len);
5273 name = "__ANONIO__";
5280 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5281 namesv = PAD_SVl(targ);
5282 (void)SvUPGRADE(namesv, SVt_PV);
5284 sv_setpvn(namesv, "$", 1);
5285 sv_catpvn(namesv, name, len);
5288 kid->op_sibling = 0;
5289 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5290 kid->op_targ = targ;
5291 kid->op_private |= priv;
5293 kid->op_sibling = sibl;
5299 mod(scalar(kid), type);
5303 tokid = &kid->op_sibling;
5304 kid = kid->op_sibling;
5306 o->op_private |= numargs;
5308 return too_many_arguments(o,OP_DESC(o));
5311 else if (PL_opargs[type] & OA_DEFGV) {
5313 return newUNOP(type, 0, newDEFSVOP());
5317 while (oa & OA_OPTIONAL)
5319 if (oa && oa != OA_LIST)
5320 return too_few_arguments(o,OP_DESC(o));
5326 Perl_ck_glob(pTHX_ OP *o)
5331 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5332 append_elem(OP_GLOB, o, newDEFSVOP());
5334 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5335 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5337 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5340 #if !defined(PERL_EXTERNAL_GLOB)
5341 /* XXX this can be tightened up and made more failsafe. */
5342 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5345 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5346 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5347 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5348 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5349 GvCV(gv) = GvCV(glob_gv);
5350 SvREFCNT_inc((SV*)GvCV(gv));
5351 GvIMPORTED_CV_on(gv);
5354 #endif /* PERL_EXTERNAL_GLOB */
5356 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5357 append_elem(OP_GLOB, o,
5358 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5359 o->op_type = OP_LIST;
5360 o->op_ppaddr = PL_ppaddr[OP_LIST];
5361 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5362 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5363 cLISTOPo->op_first->op_targ = 0;
5364 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5365 append_elem(OP_LIST, o,
5366 scalar(newUNOP(OP_RV2CV, 0,
5367 newGVOP(OP_GV, 0, gv)))));
5368 o = newUNOP(OP_NULL, 0, ck_subr(o));
5369 o->op_targ = OP_GLOB; /* hint at what it used to be */
5372 gv = newGVgen("main");
5374 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5380 Perl_ck_grep(pTHX_ OP *o)
5384 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5387 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5388 NewOp(1101, gwop, 1, LOGOP);
5390 if (o->op_flags & OPf_STACKED) {
5393 kid = cLISTOPo->op_first->op_sibling;
5394 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5397 kid->op_next = (OP*)gwop;
5398 o->op_flags &= ~OPf_STACKED;
5400 kid = cLISTOPo->op_first->op_sibling;
5401 if (type == OP_MAPWHILE)
5408 kid = cLISTOPo->op_first->op_sibling;
5409 if (kid->op_type != OP_NULL)
5410 Perl_croak(aTHX_ "panic: ck_grep");
5411 kid = kUNOP->op_first;
5413 gwop->op_type = type;
5414 gwop->op_ppaddr = PL_ppaddr[type];
5415 gwop->op_first = listkids(o);
5416 gwop->op_flags |= OPf_KIDS;
5417 gwop->op_other = LINKLIST(kid);
5418 kid->op_next = (OP*)gwop;
5419 offset = pad_findmy("$_");
5420 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
5421 o->op_private = gwop->op_private = 0;
5422 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5425 o->op_private = gwop->op_private = OPpGREP_LEX;
5426 gwop->op_targ = o->op_targ = offset;
5429 kid = cLISTOPo->op_first->op_sibling;
5430 if (!kid || !kid->op_sibling)
5431 return too_few_arguments(o,OP_DESC(o));
5432 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5433 mod(kid, OP_GREPSTART);
5439 Perl_ck_index(pTHX_ OP *o)
5441 if (o->op_flags & OPf_KIDS) {
5442 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5444 kid = kid->op_sibling; /* get past "big" */
5445 if (kid && kid->op_type == OP_CONST)
5446 fbm_compile(((SVOP*)kid)->op_sv, 0);
5452 Perl_ck_lengthconst(pTHX_ OP *o)
5454 /* XXX length optimization goes here */
5459 Perl_ck_lfun(pTHX_ OP *o)
5461 OPCODE type = o->op_type;
5462 return modkids(ck_fun(o), type);
5466 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5468 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5469 switch (cUNOPo->op_first->op_type) {
5471 /* This is needed for
5472 if (defined %stash::)
5473 to work. Do not break Tk.
5475 break; /* Globals via GV can be undef */
5477 case OP_AASSIGN: /* Is this a good idea? */
5478 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5479 "defined(@array) is deprecated");
5480 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5481 "\t(Maybe you should just omit the defined()?)\n");
5484 /* This is needed for
5485 if (defined %stash::)
5486 to work. Do not break Tk.
5488 break; /* Globals via GV can be undef */
5490 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5491 "defined(%%hash) is deprecated");
5492 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5493 "\t(Maybe you should just omit the defined()?)\n");
5504 Perl_ck_rfun(pTHX_ OP *o)
5506 OPCODE type = o->op_type;
5507 return refkids(ck_fun(o), type);
5511 Perl_ck_listiob(pTHX_ OP *o)
5515 kid = cLISTOPo->op_first;
5518 kid = cLISTOPo->op_first;
5520 if (kid->op_type == OP_PUSHMARK)
5521 kid = kid->op_sibling;
5522 if (kid && o->op_flags & OPf_STACKED)
5523 kid = kid->op_sibling;
5524 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5525 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5526 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5527 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5528 cLISTOPo->op_first->op_sibling = kid;
5529 cLISTOPo->op_last = kid;
5530 kid = kid->op_sibling;
5535 append_elem(o->op_type, o, newDEFSVOP());
5541 Perl_ck_sassign(pTHX_ OP *o)
5543 OP *kid = cLISTOPo->op_first;
5544 /* has a disposable target? */
5545 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5546 && !(kid->op_flags & OPf_STACKED)
5547 /* Cannot steal the second time! */
5548 && !(kid->op_private & OPpTARGET_MY))
5550 OP *kkid = kid->op_sibling;
5552 /* Can just relocate the target. */
5553 if (kkid && kkid->op_type == OP_PADSV
5554 && !(kkid->op_private & OPpLVAL_INTRO))
5556 kid->op_targ = kkid->op_targ;
5558 /* Now we do not need PADSV and SASSIGN. */
5559 kid->op_sibling = o->op_sibling; /* NULL */
5560 cLISTOPo->op_first = NULL;
5563 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
5571 Perl_ck_match(pTHX_ OP *o)
5573 if (o->op_type != OP_QR) {
5574 I32 offset = pad_findmy("$_");
5575 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS(offset) & SVpad_OUR)) {
5576 o->op_targ = offset;
5577 o->op_private |= OPpTARGET_MY;
5580 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
5581 o->op_private |= OPpRUNTIME;
5586 Perl_ck_method(pTHX_ OP *o)
5588 OP *kid = cUNOPo->op_first;
5589 if (kid->op_type == OP_CONST) {
5590 SV* sv = kSVOP->op_sv;
5591 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
5593 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5594 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
5597 kSVOP->op_sv = Nullsv;
5599 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5608 Perl_ck_null(pTHX_ OP *o)
5614 Perl_ck_open(pTHX_ OP *o)
5616 HV *table = GvHV(PL_hintgv);
5620 svp = hv_fetch(table, "open_IN", 7, FALSE);
5622 mode = mode_from_discipline(*svp);
5623 if (mode & O_BINARY)
5624 o->op_private |= OPpOPEN_IN_RAW;
5625 else if (mode & O_TEXT)
5626 o->op_private |= OPpOPEN_IN_CRLF;
5629 svp = hv_fetch(table, "open_OUT", 8, FALSE);
5631 mode = mode_from_discipline(*svp);
5632 if (mode & O_BINARY)
5633 o->op_private |= OPpOPEN_OUT_RAW;
5634 else if (mode & O_TEXT)
5635 o->op_private |= OPpOPEN_OUT_CRLF;
5638 if (o->op_type == OP_BACKTICK)
5641 /* In case of three-arg dup open remove strictness
5642 * from the last arg if it is a bareword. */
5643 OP *first = cLISTOPx(o)->op_first; /* The pushmark. */
5644 OP *last = cLISTOPx(o)->op_last; /* The bareword. */
5648 if ((last->op_type == OP_CONST) && /* The bareword. */
5649 (last->op_private & OPpCONST_BARE) &&
5650 (last->op_private & OPpCONST_STRICT) &&
5651 (oa = first->op_sibling) && /* The fh. */
5652 (oa = oa->op_sibling) && /* The mode. */
5653 SvPOK(((SVOP*)oa)->op_sv) &&
5654 (mode = SvPVX(((SVOP*)oa)->op_sv)) &&
5655 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
5656 (last == oa->op_sibling)) /* The bareword. */
5657 last->op_private &= ~OPpCONST_STRICT;
5663 Perl_ck_repeat(pTHX_ OP *o)
5665 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5666 o->op_private |= OPpREPEAT_DOLIST;
5667 cBINOPo->op_first = force_list(cBINOPo->op_first);
5675 Perl_ck_require(pTHX_ OP *o)
5679 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
5680 SVOP *kid = (SVOP*)cUNOPo->op_first;
5682 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5684 for (s = SvPVX(kid->op_sv); *s; s++) {
5685 if (*s == ':' && s[1] == ':') {
5687 Move(s+2, s+1, strlen(s+2)+1, char);
5688 --SvCUR(kid->op_sv);
5691 if (SvREADONLY(kid->op_sv)) {
5692 SvREADONLY_off(kid->op_sv);
5693 sv_catpvn(kid->op_sv, ".pm", 3);
5694 SvREADONLY_on(kid->op_sv);
5697 sv_catpvn(kid->op_sv, ".pm", 3);
5701 /* handle override, if any */
5702 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
5703 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
5704 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
5706 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5707 OP *kid = cUNOPo->op_first;
5708 cUNOPo->op_first = 0;
5710 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5711 append_elem(OP_LIST, kid,
5712 scalar(newUNOP(OP_RV2CV, 0,
5721 Perl_ck_return(pTHX_ OP *o)
5724 if (CvLVALUE(PL_compcv)) {
5725 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5726 mod(kid, OP_LEAVESUBLV);
5733 Perl_ck_retarget(pTHX_ OP *o)
5735 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5742 Perl_ck_select(pTHX_ OP *o)
5745 if (o->op_flags & OPf_KIDS) {
5746 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5747 if (kid && kid->op_sibling) {
5748 o->op_type = OP_SSELECT;
5749 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
5751 return fold_constants(o);
5755 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5756 if (kid && kid->op_type == OP_RV2GV)
5757 kid->op_private &= ~HINT_STRICT_REFS;
5762 Perl_ck_shift(pTHX_ OP *o)
5764 I32 type = o->op_type;
5766 if (!(o->op_flags & OPf_KIDS)) {
5770 argop = newUNOP(OP_RV2AV, 0,
5771 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
5772 return newUNOP(type, 0, scalar(argop));
5774 return scalar(modkids(ck_fun(o), type));
5778 Perl_ck_sort(pTHX_ OP *o)
5782 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
5784 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5785 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
5787 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
5789 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
5791 if (kid->op_type == OP_SCOPE) {
5795 else if (kid->op_type == OP_LEAVE) {
5796 if (o->op_type == OP_SORT) {
5797 op_null(kid); /* wipe out leave */
5800 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
5801 if (k->op_next == kid)
5803 /* don't descend into loops */
5804 else if (k->op_type == OP_ENTERLOOP
5805 || k->op_type == OP_ENTERITER)
5807 k = cLOOPx(k)->op_lastop;
5812 kid->op_next = 0; /* just disconnect the leave */
5813 k = kLISTOP->op_first;
5818 if (o->op_type == OP_SORT) {
5819 /* provide scalar context for comparison function/block */
5825 o->op_flags |= OPf_SPECIAL;
5827 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
5830 firstkid = firstkid->op_sibling;
5833 /* provide list context for arguments */
5834 if (o->op_type == OP_SORT)
5841 S_simplify_sort(pTHX_ OP *o)
5843 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5847 if (!(o->op_flags & OPf_STACKED))
5849 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
5850 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
5851 kid = kUNOP->op_first; /* get past null */
5852 if (kid->op_type != OP_SCOPE)
5854 kid = kLISTOP->op_last; /* get past scope */
5855 switch(kid->op_type) {
5863 k = kid; /* remember this node*/
5864 if (kBINOP->op_first->op_type != OP_RV2SV)
5866 kid = kBINOP->op_first; /* get past cmp */
5867 if (kUNOP->op_first->op_type != OP_GV)
5869 kid = kUNOP->op_first; /* get past rv2sv */
5871 if (GvSTASH(gv) != PL_curstash)
5873 if (strEQ(GvNAME(gv), "a"))
5875 else if (strEQ(GvNAME(gv), "b"))
5879 kid = k; /* back to cmp */
5880 if (kBINOP->op_last->op_type != OP_RV2SV)
5882 kid = kBINOP->op_last; /* down to 2nd arg */
5883 if (kUNOP->op_first->op_type != OP_GV)
5885 kid = kUNOP->op_first; /* get past rv2sv */
5887 if (GvSTASH(gv) != PL_curstash
5889 ? strNE(GvNAME(gv), "a")
5890 : strNE(GvNAME(gv), "b")))
5892 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
5894 o->op_private |= OPpSORT_REVERSE;
5895 if (k->op_type == OP_NCMP)
5896 o->op_private |= OPpSORT_NUMERIC;
5897 if (k->op_type == OP_I_NCMP)
5898 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
5899 kid = cLISTOPo->op_first->op_sibling;
5900 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
5901 op_free(kid); /* then delete it */
5905 Perl_ck_split(pTHX_ OP *o)
5909 if (o->op_flags & OPf_STACKED)
5910 return no_fh_allowed(o);
5912 kid = cLISTOPo->op_first;
5913 if (kid->op_type != OP_NULL)
5914 Perl_croak(aTHX_ "panic: ck_split");
5915 kid = kid->op_sibling;
5916 op_free(cLISTOPo->op_first);
5917 cLISTOPo->op_first = kid;
5919 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
5920 cLISTOPo->op_last = kid; /* There was only one element previously */
5923 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
5924 OP *sibl = kid->op_sibling;
5925 kid->op_sibling = 0;
5926 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
5927 if (cLISTOPo->op_first == cLISTOPo->op_last)
5928 cLISTOPo->op_last = kid;
5929 cLISTOPo->op_first = kid;
5930 kid->op_sibling = sibl;
5933 kid->op_type = OP_PUSHRE;
5934 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
5936 if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
5937 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
5938 "Use of /g modifier is meaningless in split");
5941 if (!kid->op_sibling)
5942 append_elem(OP_SPLIT, o, newDEFSVOP());
5944 kid = kid->op_sibling;
5947 if (!kid->op_sibling)
5948 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
5950 kid = kid->op_sibling;
5953 if (kid->op_sibling)
5954 return too_many_arguments(o,OP_DESC(o));
5960 Perl_ck_join(pTHX_ OP *o)
5962 if (ckWARN(WARN_SYNTAX)) {
5963 OP *kid = cLISTOPo->op_first->op_sibling;
5964 if (kid && kid->op_type == OP_MATCH) {
5965 char *pmstr = "STRING";
5966 if (PM_GETRE(kPMOP))
5967 pmstr = PM_GETRE(kPMOP)->precomp;
5968 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5969 "/%s/ should probably be written as \"%s\"",
5977 Perl_ck_state(pTHX_ OP *o)
5979 /* warn on C<my $x=1 if foo;> , C<$a && my $x=1;> style statements */
5982 if (!o || o->op_type != OP_NULL || !(o->op_flags & OPf_KIDS))
5984 kid = cUNOPo->op_first;
5985 if (!(kid->op_type == OP_AND || kid->op_type == OP_OR))
5987 kid = kUNOP->op_first->op_sibling;
5988 if (kid->op_type == OP_SASSIGN)
5989 kid = kBINOP->op_first->op_sibling;
5990 else if (kid->op_type == OP_AASSIGN)
5991 kid = kBINOP->op_first->op_sibling;
5993 if (kid->op_type == OP_LIST
5994 || (kid->op_type == OP_NULL && kid->op_targ == OP_LIST))
5996 kid = kUNOP->op_first;
5997 if (kid->op_type == OP_PUSHMARK)
5998 kid = kid->op_sibling;
6000 if ((kid->op_type == OP_PADSV || kid->op_type == OP_PADAV
6001 || kid->op_type == OP_PADHV)
6002 && (kid->op_private & OPpLVAL_INTRO)
6003 && (ckWARN(WARN_DEPRECATED)))
6005 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
6006 "Use of my in conditional deprecated");
6013 Perl_ck_subr(pTHX_ OP *o)
6015 OP *prev = ((cUNOPo->op_first->op_sibling)
6016 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6017 OP *o2 = prev->op_sibling;
6024 I32 contextclass = 0;
6029 o->op_private |= OPpENTERSUB_HASTARG;
6030 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6031 if (cvop->op_type == OP_RV2CV) {
6033 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6034 op_null(cvop); /* disable rv2cv */
6035 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6036 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6037 GV *gv = cGVOPx_gv(tmpop);
6040 tmpop->op_private |= OPpEARLY_CV;
6043 namegv = CvANON(cv) ? gv : CvGV(cv);
6044 proto = SvPV((SV*)cv, n_a);
6046 if (CvASSERTION(cv)) {
6047 if (PL_hints & HINT_ASSERTING) {
6048 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
6049 o->op_private |= OPpENTERSUB_DB;
6053 if (ckWARN(WARN_ASSERTIONS) && !(PL_hints & HINT_ASSERTIONSSEEN)) {
6054 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
6055 "Impossible to activate assertion call");
6062 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6063 if (o2->op_type == OP_CONST)
6064 o2->op_private &= ~OPpCONST_STRICT;
6065 else if (o2->op_type == OP_LIST) {
6066 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6067 if (o && o->op_type == OP_CONST)
6068 o->op_private &= ~OPpCONST_STRICT;
6071 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6072 if (PERLDB_SUB && PL_curstash != PL_debstash)
6073 o->op_private |= OPpENTERSUB_DB;
6074 while (o2 != cvop) {
6078 return too_many_arguments(o, gv_ename(namegv));
6096 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6098 arg == 1 ? "block or sub {}" : "sub {}",
6099 gv_ename(namegv), o2);
6102 /* '*' allows any scalar type, including bareword */
6105 if (o2->op_type == OP_RV2GV)
6106 goto wrapref; /* autoconvert GLOB -> GLOBref */
6107 else if (o2->op_type == OP_CONST)
6108 o2->op_private &= ~OPpCONST_STRICT;
6109 else if (o2->op_type == OP_ENTERSUB) {
6110 /* accidental subroutine, revert to bareword */
6111 OP *gvop = ((UNOP*)o2)->op_first;
6112 if (gvop && gvop->op_type == OP_NULL) {
6113 gvop = ((UNOP*)gvop)->op_first;
6115 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6118 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6119 (gvop = ((UNOP*)gvop)->op_first) &&
6120 gvop->op_type == OP_GV)
6122 GV *gv = cGVOPx_gv(gvop);
6123 OP *sibling = o2->op_sibling;
6124 SV *n = newSVpvn("",0);
6126 gv_fullname3(n, gv, "");
6127 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6128 sv_chop(n, SvPVX(n)+6);
6129 o2 = newSVOP(OP_CONST, 0, n);
6130 prev->op_sibling = o2;
6131 o2->op_sibling = sibling;
6147 if (contextclass++ == 0) {
6148 e = strchr(proto, ']');
6149 if (!e || e == proto)
6162 while (*--p != '[');
6163 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6164 gv_ename(namegv), o2);
6170 if (o2->op_type == OP_RV2GV)
6173 bad_type(arg, "symbol", gv_ename(namegv), o2);
6176 if (o2->op_type == OP_ENTERSUB)
6179 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6182 if (o2->op_type == OP_RV2SV ||
6183 o2->op_type == OP_PADSV ||
6184 o2->op_type == OP_HELEM ||
6185 o2->op_type == OP_AELEM ||
6186 o2->op_type == OP_THREADSV)
6189 bad_type(arg, "scalar", gv_ename(namegv), o2);
6192 if (o2->op_type == OP_RV2AV ||
6193 o2->op_type == OP_PADAV)
6196 bad_type(arg, "array", gv_ename(namegv), o2);
6199 if (o2->op_type == OP_RV2HV ||
6200 o2->op_type == OP_PADHV)
6203 bad_type(arg, "hash", gv_ename(namegv), o2);
6208 OP* sib = kid->op_sibling;
6209 kid->op_sibling = 0;
6210 o2 = newUNOP(OP_REFGEN, 0, kid);
6211 o2->op_sibling = sib;
6212 prev->op_sibling = o2;
6214 if (contextclass && e) {
6229 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6230 gv_ename(namegv), cv);
6235 mod(o2, OP_ENTERSUB);
6237 o2 = o2->op_sibling;
6239 if (proto && !optional &&
6240 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6241 return too_few_arguments(o, gv_ename(namegv));
6244 o=newSVOP(OP_CONST, 0, newSViv(0));
6250 Perl_ck_svconst(pTHX_ OP *o)
6252 SvREADONLY_on(cSVOPo->op_sv);
6257 Perl_ck_trunc(pTHX_ OP *o)
6259 if (o->op_flags & OPf_KIDS) {
6260 SVOP *kid = (SVOP*)cUNOPo->op_first;
6262 if (kid->op_type == OP_NULL)
6263 kid = (SVOP*)kid->op_sibling;
6264 if (kid && kid->op_type == OP_CONST &&
6265 (kid->op_private & OPpCONST_BARE))
6267 o->op_flags |= OPf_SPECIAL;
6268 kid->op_private &= ~OPpCONST_STRICT;
6275 Perl_ck_unpack(pTHX_ OP *o)
6277 OP *kid = cLISTOPo->op_first;
6278 if (kid->op_sibling) {
6279 kid = kid->op_sibling;
6280 if (!kid->op_sibling)
6281 kid->op_sibling = newDEFSVOP();
6287 Perl_ck_substr(pTHX_ OP *o)
6290 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6291 OP *kid = cLISTOPo->op_first;
6293 if (kid->op_type == OP_NULL)
6294 kid = kid->op_sibling;
6296 kid->op_flags |= OPf_MOD;
6302 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6305 Perl_peep(pTHX_ register OP *o)
6307 register OP* oldop = 0;
6309 if (!o || o->op_seq)
6313 SAVEVPTR(PL_curcop);
6314 for (; o; o = o->op_next) {
6317 /* The special value -1 is used by the B::C compiler backend to indicate
6318 * that an op is statically defined and should not be freed */
6319 if (!PL_op_seqmax || PL_op_seqmax == (U16)-1)
6322 switch (o->op_type) {
6326 PL_curcop = ((COP*)o); /* for warnings */
6327 o->op_seq = PL_op_seqmax++;
6331 if (cSVOPo->op_private & OPpCONST_STRICT)
6332 no_bareword_allowed(o);
6334 case OP_METHOD_NAMED:
6335 /* Relocate sv to the pad for thread safety.
6336 * Despite being a "constant", the SV is written to,
6337 * for reference counts, sv_upgrade() etc. */
6339 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6340 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6341 /* If op_sv is already a PADTMP then it is being used by
6342 * some pad, so make a copy. */
6343 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6344 SvREADONLY_on(PAD_SVl(ix));
6345 SvREFCNT_dec(cSVOPo->op_sv);
6348 SvREFCNT_dec(PAD_SVl(ix));
6349 SvPADTMP_on(cSVOPo->op_sv);
6350 PAD_SETSV(ix, cSVOPo->op_sv);
6351 /* XXX I don't know how this isn't readonly already. */
6352 SvREADONLY_on(PAD_SVl(ix));
6354 cSVOPo->op_sv = Nullsv;
6358 o->op_seq = PL_op_seqmax++;
6362 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6363 if (o->op_next->op_private & OPpTARGET_MY) {
6364 if (o->op_flags & OPf_STACKED) /* chained concats */
6365 goto ignore_optimization;
6367 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6368 o->op_targ = o->op_next->op_targ;
6369 o->op_next->op_targ = 0;
6370 o->op_private |= OPpTARGET_MY;
6373 op_null(o->op_next);
6375 ignore_optimization:
6376 o->op_seq = PL_op_seqmax++;
6379 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6380 o->op_seq = PL_op_seqmax++;
6381 break; /* Scalar stub must produce undef. List stub is noop */
6385 if (o->op_targ == OP_NEXTSTATE
6386 || o->op_targ == OP_DBSTATE
6387 || o->op_targ == OP_SETSTATE)
6389 PL_curcop = ((COP*)o);
6391 /* XXX: We avoid setting op_seq here to prevent later calls
6392 to peep() from mistakenly concluding that optimisation
6393 has already occurred. This doesn't fix the real problem,
6394 though (See 20010220.007). AMS 20010719 */
6395 if (oldop && o->op_next) {
6396 oldop->op_next = o->op_next;
6404 if (oldop && o->op_next) {
6405 oldop->op_next = o->op_next;
6408 o->op_seq = PL_op_seqmax++;
6412 if (o->op_next->op_type == OP_RV2SV) {
6413 if (!(o->op_next->op_private & OPpDEREF)) {
6414 op_null(o->op_next);
6415 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6417 o->op_next = o->op_next->op_next;
6418 o->op_type = OP_GVSV;
6419 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6422 else if (o->op_next->op_type == OP_RV2AV) {
6423 OP* pop = o->op_next->op_next;
6425 if (pop && pop->op_type == OP_CONST &&
6426 (PL_op = pop->op_next) &&
6427 pop->op_next->op_type == OP_AELEM &&
6428 !(pop->op_next->op_private &
6429 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6430 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6435 op_null(o->op_next);
6436 op_null(pop->op_next);
6438 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6439 o->op_next = pop->op_next->op_next;
6440 o->op_type = OP_AELEMFAST;
6441 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6442 o->op_private = (U8)i;
6447 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6449 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6450 /* XXX could check prototype here instead of just carping */
6451 SV *sv = sv_newmortal();
6452 gv_efullname3(sv, gv, Nullch);
6453 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6454 "%"SVf"() called too early to check prototype",
6458 else if (o->op_next->op_type == OP_READLINE
6459 && o->op_next->op_next->op_type == OP_CONCAT
6460 && (o->op_next->op_next->op_flags & OPf_STACKED))
6462 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6463 o->op_type = OP_RCATLINE;
6464 o->op_flags |= OPf_STACKED;
6465 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6466 op_null(o->op_next->op_next);
6467 op_null(o->op_next);
6470 o->op_seq = PL_op_seqmax++;
6483 o->op_seq = PL_op_seqmax++;
6484 while (cLOGOP->op_other->op_type == OP_NULL)
6485 cLOGOP->op_other = cLOGOP->op_other->op_next;
6486 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6491 o->op_seq = PL_op_seqmax++;
6492 while (cLOOP->op_redoop->op_type == OP_NULL)
6493 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6494 peep(cLOOP->op_redoop);
6495 while (cLOOP->op_nextop->op_type == OP_NULL)
6496 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6497 peep(cLOOP->op_nextop);
6498 while (cLOOP->op_lastop->op_type == OP_NULL)
6499 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6500 peep(cLOOP->op_lastop);
6506 o->op_seq = PL_op_seqmax++;
6507 while (cPMOP->op_pmreplstart &&
6508 cPMOP->op_pmreplstart->op_type == OP_NULL)
6509 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6510 peep(cPMOP->op_pmreplstart);
6514 o->op_seq = PL_op_seqmax++;
6515 if (ckWARN(WARN_SYNTAX) && o->op_next
6516 && o->op_next->op_type == OP_NEXTSTATE) {
6517 if (o->op_next->op_sibling &&
6518 o->op_next->op_sibling->op_type != OP_EXIT &&
6519 o->op_next->op_sibling->op_type != OP_WARN &&
6520 o->op_next->op_sibling->op_type != OP_DIE) {
6521 line_t oldline = CopLINE(PL_curcop);
6523 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6524 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6525 "Statement unlikely to be reached");
6526 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6527 "\t(Maybe you meant system() when you said exec()?)\n");
6528 CopLINE_set(PL_curcop, oldline);
6539 o->op_seq = PL_op_seqmax++;
6541 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6544 /* Make the CONST have a shared SV */
6545 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6546 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6547 key = SvPV(sv, keylen);
6548 lexname = newSVpvn_share(key,
6549 SvUTF8(sv) ? -(I32)keylen : keylen,
6558 o->op_seq = PL_op_seqmax++;
6568 char* Perl_custom_op_name(pTHX_ OP* o)
6570 IV index = PTR2IV(o->op_ppaddr);
6574 if (!PL_custom_op_names) /* This probably shouldn't happen */
6575 return PL_op_name[OP_CUSTOM];
6577 keysv = sv_2mortal(newSViv(index));
6579 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
6581 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
6583 return SvPV_nolen(HeVAL(he));
6586 char* Perl_custom_op_desc(pTHX_ OP* o)
6588 IV index = PTR2IV(o->op_ppaddr);
6592 if (!PL_custom_op_descs)
6593 return PL_op_desc[OP_CUSTOM];
6595 keysv = sv_2mortal(newSViv(index));
6597 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
6599 return PL_op_desc[OP_CUSTOM];
6601 return SvPV_nolen(HeVAL(he));
6607 /* Efficient sub that returns a constant scalar value. */
6609 const_sv_xsub(pTHX_ CV* cv)
6614 Perl_croak(aTHX_ "usage: %s::%s()",
6615 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
6619 ST(0) = (SV*)XSANY.any_ptr;