3 * Copyright (c) 1991-2003, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
12 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
13 * youngest of the Old Took's daughters); and Mr. Drogo was his second
14 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
15 * either way, as the saying is, if you follow me." --the Gaffer
24 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
26 #if defined(PL_OP_SLAB_ALLOC)
28 #ifndef PERL_SLAB_SIZE
29 #define PERL_SLAB_SIZE 2048
32 #define NewOp(m,var,c,type) \
33 STMT_START { var = (type *) Slab_Alloc(m,c*sizeof(type)); } STMT_END
35 #define FreeOp(p) Slab_Free(p)
38 S_Slab_Alloc(pTHX_ int m, size_t sz)
41 * To make incrementing use count easy PL_OpSlab is an I32 *
42 * To make inserting the link to slab PL_OpPtr is I32 **
43 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
44 * Add an overhead for pointer to slab and round up as a number of pointers
46 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
47 if ((PL_OpSpace -= sz) < 0) {
48 PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*));
52 Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **);
53 /* We reserve the 0'th I32 sized chunk as a use count */
54 PL_OpSlab = (I32 *) PL_OpPtr;
55 /* Reduce size by the use count word, and by the size we need.
56 * Latter is to mimic the '-=' in the if() above
58 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
59 /* Allocation pointer starts at the top.
60 Theory: because we build leaves before trunk allocating at end
61 means that at run time access is cache friendly upward
63 PL_OpPtr += PERL_SLAB_SIZE;
65 assert( PL_OpSpace >= 0 );
66 /* Move the allocation pointer down */
68 assert( PL_OpPtr > (I32 **) PL_OpSlab );
69 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
70 (*PL_OpSlab)++; /* Increment use count of slab */
71 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
72 assert( *PL_OpSlab > 0 );
73 return (void *)(PL_OpPtr + 1);
77 S_Slab_Free(pTHX_ void *op)
79 I32 **ptr = (I32 **) op;
81 assert( ptr-1 > (I32 **) slab );
82 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
86 #define PerlMemShared PerlMem
89 PerlMemShared_free(slab);
90 if (slab == PL_OpSlab) {
97 #define NewOp(m, var, c, type) Newz(m, var, c, type)
98 #define FreeOp(p) Safefree(p)
101 * In the following definition, the ", Nullop" is just to make the compiler
102 * think the expression is of the right type: croak actually does a Siglongjmp.
104 #define CHECKOP(type,o) \
105 ((PL_op_mask && PL_op_mask[type]) \
106 ? ( op_free((OP*)o), \
107 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
109 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
111 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
114 S_gv_ename(pTHX_ GV *gv)
117 SV* tmpsv = sv_newmortal();
118 gv_efullname3(tmpsv, gv, Nullch);
119 return SvPV(tmpsv,n_a);
123 S_no_fh_allowed(pTHX_ OP *o)
125 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
131 S_too_few_arguments(pTHX_ OP *o, char *name)
133 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
138 S_too_many_arguments(pTHX_ OP *o, char *name)
140 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
145 S_bad_type(pTHX_ I32 n, char *t, char *name, OP *kid)
147 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
148 (int)n, name, t, OP_DESC(kid)));
152 S_no_bareword_allowed(pTHX_ OP *o)
154 qerror(Perl_mess(aTHX_
155 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
159 /* "register" allocation */
162 Perl_allocmy(pTHX_ char *name)
166 /* complain about "my $_" etc etc */
167 if (!(PL_in_my == KEY_our ||
169 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
170 (name[1] == '_' && (int)strlen(name) > 2)))
172 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
173 /* 1999-02-27 mjd@plover.com */
175 p = strchr(name, '\0');
176 /* The next block assumes the buffer is at least 205 chars
177 long. At present, it's always at least 256 chars. */
179 strcpy(name+200, "...");
185 /* Move everything else down one character */
186 for (; p-name > 2; p--)
188 name[2] = toCTRL(name[1]);
191 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
194 /* check for duplicate declaration */
197 (PL_curstash ? PL_curstash : PL_defstash)
200 if (PL_in_my_stash && *name != '$') {
201 yyerror(Perl_form(aTHX_
202 "Can't declare class for non-scalar %s in \"%s\"",
203 name, PL_in_my == KEY_our ? "our" : "my"));
206 /* allocate a spare slot and store the name in that slot */
208 off = pad_add_name(name,
211 ? (PL_curstash ? PL_curstash : PL_defstash)
222 Perl_op_free(pTHX_ OP *o)
224 register OP *kid, *nextkid;
227 if (!o || o->op_seq == (U16)-1)
230 if (o->op_private & OPpREFCOUNTED) {
231 switch (o->op_type) {
239 if (OpREFCNT_dec(o)) {
250 if (o->op_flags & OPf_KIDS) {
251 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
252 nextkid = kid->op_sibling; /* Get before next freeing kid */
258 type = (OPCODE)o->op_targ;
260 /* COP* is not cleared by op_clear() so that we may track line
261 * numbers etc even after null() */
262 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
270 Perl_op_clear(pTHX_ OP *o)
273 switch (o->op_type) {
274 case OP_NULL: /* Was holding old type, if any. */
275 case OP_ENTEREVAL: /* Was holding hints. */
279 if (!(o->op_flags & OPf_REF)
280 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
287 if (cPADOPo->op_padix > 0) {
288 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
289 * may still exist on the pad */
290 pad_swipe(cPADOPo->op_padix, TRUE);
291 cPADOPo->op_padix = 0;
294 SvREFCNT_dec(cSVOPo->op_sv);
295 cSVOPo->op_sv = Nullsv;
298 case OP_METHOD_NAMED:
300 SvREFCNT_dec(cSVOPo->op_sv);
301 cSVOPo->op_sv = Nullsv;
304 Even if op_clear does a pad_free for the target of the op,
305 pad_free doesn't actually remove the sv that exists in the bad
306 instead it lives on. This results in that it could be reused as
307 a target later on when the pad was reallocated.
310 pad_swipe(o->op_targ,1);
319 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
323 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
324 SvREFCNT_dec(cSVOPo->op_sv);
325 cSVOPo->op_sv = Nullsv;
328 Safefree(cPVOPo->op_pv);
329 cPVOPo->op_pv = Nullch;
333 op_free(cPMOPo->op_pmreplroot);
337 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
338 /* No GvIN_PAD_off here, because other references may still
339 * exist on the pad */
340 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
343 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
350 HV *pmstash = PmopSTASH(cPMOPo);
351 if (pmstash && SvREFCNT(pmstash)) {
352 PMOP *pmop = HvPMROOT(pmstash);
353 PMOP *lastpmop = NULL;
355 if (cPMOPo == pmop) {
357 lastpmop->op_pmnext = pmop->op_pmnext;
359 HvPMROOT(pmstash) = pmop->op_pmnext;
363 pmop = pmop->op_pmnext;
366 PmopSTASH_free(cPMOPo);
368 cPMOPo->op_pmreplroot = Nullop;
369 /* we use the "SAFE" version of the PM_ macros here
370 * since sv_clean_all might release some PMOPs
371 * after PL_regex_padav has been cleared
372 * and the clearing of PL_regex_padav needs to
373 * happen before sv_clean_all
375 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
376 PM_SETRE_SAFE(cPMOPo, (REGEXP*)NULL);
378 if(PL_regex_pad) { /* We could be in destruction */
379 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
380 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
381 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
388 if (o->op_targ > 0) {
389 pad_free(o->op_targ);
395 S_cop_free(pTHX_ COP* cop)
397 Safefree(cop->cop_label); /* FIXME: treaddead ??? */
400 if (! specialWARN(cop->cop_warnings))
401 SvREFCNT_dec(cop->cop_warnings);
402 if (! specialCopIO(cop->cop_io)) {
406 char *s = SvPV(cop->cop_io,len);
407 Perl_warn(aTHX_ "io='%.*s'",(int) len,s); /* ??? --jhi */
410 SvREFCNT_dec(cop->cop_io);
416 Perl_op_null(pTHX_ OP *o)
418 if (o->op_type == OP_NULL)
421 o->op_targ = o->op_type;
422 o->op_type = OP_NULL;
423 o->op_ppaddr = PL_ppaddr[OP_NULL];
426 /* Contextualizers */
428 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
431 Perl_linklist(pTHX_ OP *o)
438 /* establish postfix order */
439 if (cUNOPo->op_first) {
440 o->op_next = LINKLIST(cUNOPo->op_first);
441 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
443 kid->op_next = LINKLIST(kid->op_sibling);
455 Perl_scalarkids(pTHX_ OP *o)
458 if (o && o->op_flags & OPf_KIDS) {
459 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
466 S_scalarboolean(pTHX_ OP *o)
468 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
469 if (ckWARN(WARN_SYNTAX)) {
470 line_t oldline = CopLINE(PL_curcop);
472 if (PL_copline != NOLINE)
473 CopLINE_set(PL_curcop, PL_copline);
474 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
475 CopLINE_set(PL_curcop, oldline);
482 Perl_scalar(pTHX_ OP *o)
486 /* assumes no premature commitment */
487 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
488 || o->op_type == OP_RETURN)
493 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
495 switch (o->op_type) {
497 scalar(cBINOPo->op_first);
502 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
506 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
507 if (!kPMOP->op_pmreplroot)
508 deprecate_old("implicit split to @_");
516 if (o->op_flags & OPf_KIDS) {
517 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
523 kid = cLISTOPo->op_first;
525 while ((kid = kid->op_sibling)) {
531 WITH_THR(PL_curcop = &PL_compiling);
536 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
542 WITH_THR(PL_curcop = &PL_compiling);
545 if (ckWARN(WARN_VOID))
546 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
552 Perl_scalarvoid(pTHX_ OP *o)
559 if (o->op_type == OP_NEXTSTATE
560 || o->op_type == OP_SETSTATE
561 || o->op_type == OP_DBSTATE
562 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
563 || o->op_targ == OP_SETSTATE
564 || o->op_targ == OP_DBSTATE)))
565 PL_curcop = (COP*)o; /* for warning below */
567 /* assumes no premature commitment */
568 want = o->op_flags & OPf_WANT;
569 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
570 || o->op_type == OP_RETURN)
575 if ((o->op_private & OPpTARGET_MY)
576 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
578 return scalar(o); /* As if inside SASSIGN */
581 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
583 switch (o->op_type) {
585 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
589 if (o->op_flags & OPf_STACKED)
593 if (o->op_private == 4)
665 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
666 useless = OP_DESC(o);
673 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
674 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
675 useless = "a variable";
680 if (cSVOPo->op_private & OPpCONST_STRICT)
681 no_bareword_allowed(o);
683 if (ckWARN(WARN_VOID)) {
684 useless = "a constant";
685 /* the constants 0 and 1 are permitted as they are
686 conventionally used as dummies in constructs like
687 1 while some_condition_with_side_effects; */
688 if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
690 else if (SvPOK(sv)) {
691 /* perl4's way of mixing documentation and code
692 (before the invention of POD) was based on a
693 trick to mix nroff and perl code. The trick was
694 built upon these three nroff macros being used in
695 void context. The pink camel has the details in
696 the script wrapman near page 319. */
697 if (strnEQ(SvPVX(sv), "di", 2) ||
698 strnEQ(SvPVX(sv), "ds", 2) ||
699 strnEQ(SvPVX(sv), "ig", 2))
704 op_null(o); /* don't execute or even remember it */
708 o->op_type = OP_PREINC; /* pre-increment is faster */
709 o->op_ppaddr = PL_ppaddr[OP_PREINC];
713 o->op_type = OP_PREDEC; /* pre-decrement is faster */
714 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
721 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
726 if (o->op_flags & OPf_STACKED)
733 if (!(o->op_flags & OPf_KIDS))
742 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
749 /* all requires must return a boolean value */
750 o->op_flags &= ~OPf_WANT;
755 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
756 if (!kPMOP->op_pmreplroot)
757 deprecate_old("implicit split to @_");
761 if (useless && ckWARN(WARN_VOID))
762 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
767 Perl_listkids(pTHX_ OP *o)
770 if (o && o->op_flags & OPf_KIDS) {
771 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
778 Perl_list(pTHX_ OP *o)
782 /* assumes no premature commitment */
783 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
784 || o->op_type == OP_RETURN)
789 if ((o->op_private & OPpTARGET_MY)
790 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
792 return o; /* As if inside SASSIGN */
795 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
797 switch (o->op_type) {
800 list(cBINOPo->op_first);
805 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
813 if (!(o->op_flags & OPf_KIDS))
815 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
816 list(cBINOPo->op_first);
817 return gen_constant_list(o);
824 kid = cLISTOPo->op_first;
826 while ((kid = kid->op_sibling)) {
832 WITH_THR(PL_curcop = &PL_compiling);
836 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
842 WITH_THR(PL_curcop = &PL_compiling);
845 /* all requires must return a boolean value */
846 o->op_flags &= ~OPf_WANT;
853 Perl_scalarseq(pTHX_ OP *o)
858 if (o->op_type == OP_LINESEQ ||
859 o->op_type == OP_SCOPE ||
860 o->op_type == OP_LEAVE ||
861 o->op_type == OP_LEAVETRY)
863 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
864 if (kid->op_sibling) {
868 PL_curcop = &PL_compiling;
870 o->op_flags &= ~OPf_PARENS;
871 if (PL_hints & HINT_BLOCK_SCOPE)
872 o->op_flags |= OPf_PARENS;
875 o = newOP(OP_STUB, 0);
880 S_modkids(pTHX_ OP *o, I32 type)
883 if (o && o->op_flags & OPf_KIDS) {
884 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
891 Perl_mod(pTHX_ OP *o, I32 type)
895 if (!o || PL_error_count)
898 if ((o->op_private & OPpTARGET_MY)
899 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
904 switch (o->op_type) {
909 if (!(o->op_private & (OPpCONST_ARYBASE)))
911 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
912 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
916 SAVEI32(PL_compiling.cop_arybase);
917 PL_compiling.cop_arybase = 0;
919 else if (type == OP_REFGEN)
922 Perl_croak(aTHX_ "That use of $[ is unsupported");
925 if (o->op_flags & OPf_PARENS)
929 if ((type == OP_UNDEF || type == OP_REFGEN) &&
930 !(o->op_flags & OPf_STACKED)) {
931 o->op_type = OP_RV2CV; /* entersub => rv2cv */
932 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
933 assert(cUNOPo->op_first->op_type == OP_NULL);
934 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
937 else if (o->op_private & OPpENTERSUB_NOMOD)
939 else { /* lvalue subroutine call */
940 o->op_private |= OPpLVAL_INTRO;
941 PL_modcount = RETURN_UNLIMITED_NUMBER;
942 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
943 /* Backward compatibility mode: */
944 o->op_private |= OPpENTERSUB_INARGS;
947 else { /* Compile-time error message: */
948 OP *kid = cUNOPo->op_first;
952 if (kid->op_type == OP_PUSHMARK)
954 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
956 "panic: unexpected lvalue entersub "
957 "args: type/targ %ld:%"UVuf,
958 (long)kid->op_type, (UV)kid->op_targ);
959 kid = kLISTOP->op_first;
961 while (kid->op_sibling)
962 kid = kid->op_sibling;
963 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
965 if (kid->op_type == OP_METHOD_NAMED
966 || kid->op_type == OP_METHOD)
970 NewOp(1101, newop, 1, UNOP);
971 newop->op_type = OP_RV2CV;
972 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
973 newop->op_first = Nullop;
974 newop->op_next = (OP*)newop;
975 kid->op_sibling = (OP*)newop;
976 newop->op_private |= OPpLVAL_INTRO;
980 if (kid->op_type != OP_RV2CV)
982 "panic: unexpected lvalue entersub "
983 "entry via type/targ %ld:%"UVuf,
984 (long)kid->op_type, (UV)kid->op_targ);
985 kid->op_private |= OPpLVAL_INTRO;
986 break; /* Postpone until runtime */
990 kid = kUNOP->op_first;
991 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
992 kid = kUNOP->op_first;
993 if (kid->op_type == OP_NULL)
995 "Unexpected constant lvalue entersub "
996 "entry via type/targ %ld:%"UVuf,
997 (long)kid->op_type, (UV)kid->op_targ);
998 if (kid->op_type != OP_GV) {
999 /* Restore RV2CV to check lvalueness */
1001 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1002 okid->op_next = kid->op_next;
1003 kid->op_next = okid;
1006 okid->op_next = Nullop;
1007 okid->op_type = OP_RV2CV;
1009 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1010 okid->op_private |= OPpLVAL_INTRO;
1014 cv = GvCV(kGVOP_gv);
1024 /* grep, foreach, subcalls, refgen */
1025 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1027 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1028 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1030 : (o->op_type == OP_ENTERSUB
1031 ? "non-lvalue subroutine call"
1033 type ? PL_op_desc[type] : "local"));
1047 case OP_RIGHT_SHIFT:
1056 if (!(o->op_flags & OPf_STACKED))
1062 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1068 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1069 PL_modcount = RETURN_UNLIMITED_NUMBER;
1070 return o; /* Treat \(@foo) like ordinary list. */
1074 if (scalar_mod_type(o, type))
1076 ref(cUNOPo->op_first, o->op_type);
1080 if (type == OP_LEAVESUBLV)
1081 o->op_private |= OPpMAYBE_LVSUB;
1086 PL_modcount = RETURN_UNLIMITED_NUMBER;
1089 ref(cUNOPo->op_first, o->op_type);
1093 PL_hints |= HINT_BLOCK_SCOPE;
1104 PL_modcount = RETURN_UNLIMITED_NUMBER;
1105 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1106 return o; /* Treat \(@foo) like ordinary list. */
1107 if (scalar_mod_type(o, type))
1109 if (type == OP_LEAVESUBLV)
1110 o->op_private |= OPpMAYBE_LVSUB;
1115 { /* XXX DAPM 2002.08.25 tmp assert test */
1116 /* XXX */ assert(av_fetch(PL_comppad_name, (o->op_targ), FALSE));
1117 /* XXX */ assert(*av_fetch(PL_comppad_name, (o->op_targ), FALSE));
1119 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1120 PAD_COMPNAME_PV(o->op_targ));
1128 if (type != OP_SASSIGN)
1132 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1137 if (type == OP_LEAVESUBLV)
1138 o->op_private |= OPpMAYBE_LVSUB;
1140 pad_free(o->op_targ);
1141 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1142 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1143 if (o->op_flags & OPf_KIDS)
1144 mod(cBINOPo->op_first->op_sibling, type);
1149 ref(cBINOPo->op_first, o->op_type);
1150 if (type == OP_ENTERSUB &&
1151 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1152 o->op_private |= OPpLVAL_DEFER;
1153 if (type == OP_LEAVESUBLV)
1154 o->op_private |= OPpMAYBE_LVSUB;
1162 if (o->op_flags & OPf_KIDS)
1163 mod(cLISTOPo->op_last, type);
1167 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1169 else if (!(o->op_flags & OPf_KIDS))
1171 if (o->op_targ != OP_LIST) {
1172 mod(cBINOPo->op_first, type);
1177 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1182 if (type != OP_LEAVESUBLV)
1184 break; /* mod()ing was handled by ck_return() */
1187 /* [20011101.069] File test operators interpret OPf_REF to mean that
1188 their argument is a filehandle; thus \stat(".") should not set
1190 if (type == OP_REFGEN &&
1191 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1194 if (type != OP_LEAVESUBLV)
1195 o->op_flags |= OPf_MOD;
1197 if (type == OP_AASSIGN || type == OP_SASSIGN)
1198 o->op_flags |= OPf_SPECIAL|OPf_REF;
1200 o->op_private |= OPpLVAL_INTRO;
1201 o->op_flags &= ~OPf_SPECIAL;
1202 PL_hints |= HINT_BLOCK_SCOPE;
1204 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1205 && type != OP_LEAVESUBLV)
1206 o->op_flags |= OPf_REF;
1211 S_scalar_mod_type(pTHX_ OP *o, I32 type)
1215 if (o->op_type == OP_RV2GV)
1239 case OP_RIGHT_SHIFT:
1258 S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
1260 switch (o->op_type) {
1268 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1281 Perl_refkids(pTHX_ OP *o, I32 type)
1284 if (o && o->op_flags & OPf_KIDS) {
1285 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1292 Perl_ref(pTHX_ OP *o, I32 type)
1296 if (!o || PL_error_count)
1299 switch (o->op_type) {
1301 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1302 !(o->op_flags & OPf_STACKED)) {
1303 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1304 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1305 assert(cUNOPo->op_first->op_type == OP_NULL);
1306 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1307 o->op_flags |= OPf_SPECIAL;
1312 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1316 if (type == OP_DEFINED)
1317 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1318 ref(cUNOPo->op_first, o->op_type);
1321 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1322 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1323 : type == OP_RV2HV ? OPpDEREF_HV
1325 o->op_flags |= OPf_MOD;
1330 o->op_flags |= OPf_MOD; /* XXX ??? */
1335 o->op_flags |= OPf_REF;
1338 if (type == OP_DEFINED)
1339 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1340 ref(cUNOPo->op_first, o->op_type);
1345 o->op_flags |= OPf_REF;
1350 if (!(o->op_flags & OPf_KIDS))
1352 ref(cBINOPo->op_first, type);
1356 ref(cBINOPo->op_first, o->op_type);
1357 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1358 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1359 : type == OP_RV2HV ? OPpDEREF_HV
1361 o->op_flags |= OPf_MOD;
1369 if (!(o->op_flags & OPf_KIDS))
1371 ref(cLISTOPo->op_last, type);
1381 S_dup_attrlist(pTHX_ OP *o)
1385 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1386 * where the first kid is OP_PUSHMARK and the remaining ones
1387 * are OP_CONST. We need to push the OP_CONST values.
1389 if (o->op_type == OP_CONST)
1390 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1392 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1393 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1394 if (o->op_type == OP_CONST)
1395 rop = append_elem(OP_LIST, rop,
1396 newSVOP(OP_CONST, o->op_flags,
1397 SvREFCNT_inc(cSVOPo->op_sv)));
1404 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1408 /* fake up C<use attributes $pkg,$rv,@attrs> */
1409 ENTER; /* need to protect against side-effects of 'use' */
1412 stashsv = newSVpv(HvNAME(stash), 0);
1414 stashsv = &PL_sv_no;
1416 #define ATTRSMODULE "attributes"
1417 #define ATTRSMODULE_PM "attributes.pm"
1421 /* Don't force the C<use> if we don't need it. */
1422 svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
1423 sizeof(ATTRSMODULE_PM)-1, 0);
1424 if (svp && *svp != &PL_sv_undef)
1425 ; /* already in %INC */
1427 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1428 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1432 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1433 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1435 prepend_elem(OP_LIST,
1436 newSVOP(OP_CONST, 0, stashsv),
1437 prepend_elem(OP_LIST,
1438 newSVOP(OP_CONST, 0,
1440 dup_attrlist(attrs))));
1446 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1448 OP *pack, *imop, *arg;
1454 assert(target->op_type == OP_PADSV ||
1455 target->op_type == OP_PADHV ||
1456 target->op_type == OP_PADAV);
1458 /* Ensure that attributes.pm is loaded. */
1459 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1461 /* Need package name for method call. */
1462 pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
1464 /* Build up the real arg-list. */
1466 stashsv = newSVpv(HvNAME(stash), 0);
1468 stashsv = &PL_sv_no;
1469 arg = newOP(OP_PADSV, 0);
1470 arg->op_targ = target->op_targ;
1471 arg = prepend_elem(OP_LIST,
1472 newSVOP(OP_CONST, 0, stashsv),
1473 prepend_elem(OP_LIST,
1474 newUNOP(OP_REFGEN, 0,
1475 mod(arg, OP_REFGEN)),
1476 dup_attrlist(attrs)));
1478 /* Fake up a method call to import */
1479 meth = newSVpvn("import", 6);
1480 (void)SvUPGRADE(meth, SVt_PVIV);
1481 (void)SvIOK_on(meth);
1482 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
1483 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1484 append_elem(OP_LIST,
1485 prepend_elem(OP_LIST, pack, list(arg)),
1486 newSVOP(OP_METHOD_NAMED, 0, meth)));
1487 imop->op_private |= OPpENTERSUB_NOMOD;
1489 /* Combine the ops. */
1490 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1494 =notfor apidoc apply_attrs_string
1496 Attempts to apply a list of attributes specified by the C<attrstr> and
1497 C<len> arguments to the subroutine identified by the C<cv> argument which
1498 is expected to be associated with the package identified by the C<stashpv>
1499 argument (see L<attributes>). It gets this wrong, though, in that it
1500 does not correctly identify the boundaries of the individual attribute
1501 specifications within C<attrstr>. This is not really intended for the
1502 public API, but has to be listed here for systems such as AIX which
1503 need an explicit export list for symbols. (It's called from XS code
1504 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1505 to respect attribute syntax properly would be welcome.
1511 Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
1512 char *attrstr, STRLEN len)
1517 len = strlen(attrstr);
1521 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1523 char *sstr = attrstr;
1524 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1525 attrs = append_elem(OP_LIST, attrs,
1526 newSVOP(OP_CONST, 0,
1527 newSVpvn(sstr, attrstr-sstr)));
1531 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1532 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1533 Nullsv, prepend_elem(OP_LIST,
1534 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1535 prepend_elem(OP_LIST,
1536 newSVOP(OP_CONST, 0,
1542 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1547 if (!o || PL_error_count)
1551 if (type == OP_LIST) {
1552 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1553 my_kid(kid, attrs, imopsp);
1554 } else if (type == OP_UNDEF) {
1556 } else if (type == OP_RV2SV || /* "our" declaration */
1558 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1559 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1560 yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
1561 OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
1563 GV *gv = cGVOPx_gv(cUNOPo->op_first);
1565 PL_in_my_stash = Nullhv;
1566 apply_attrs(GvSTASH(gv),
1567 (type == OP_RV2SV ? GvSV(gv) :
1568 type == OP_RV2AV ? (SV*)GvAV(gv) :
1569 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1572 o->op_private |= OPpOUR_INTRO;
1575 else if (type != OP_PADSV &&
1578 type != OP_PUSHMARK)
1580 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1582 PL_in_my == KEY_our ? "our" : "my"));
1585 else if (attrs && type != OP_PUSHMARK) {
1589 PL_in_my_stash = Nullhv;
1591 /* check for C<my Dog $spot> when deciding package */
1592 stash = PAD_COMPNAME_TYPE(o->op_targ);
1594 stash = PL_curstash;
1595 apply_attrs_my(stash, o, attrs, imopsp);
1597 o->op_flags |= OPf_MOD;
1598 o->op_private |= OPpLVAL_INTRO;
1603 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1606 int maybe_scalar = 0;
1608 /* [perl #17376]: this appears to be premature, and results in code such as
1609 C< our(%x); > executing in list mode rather than void mode */
1611 if (o->op_flags & OPf_PARENS)
1620 o = my_kid(o, attrs, &rops);
1622 if (maybe_scalar && o->op_type == OP_PADSV) {
1623 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1624 o->op_private |= OPpLVAL_INTRO;
1627 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1630 PL_in_my_stash = Nullhv;
1635 Perl_my(pTHX_ OP *o)
1637 return my_attrs(o, Nullop);
1641 Perl_sawparens(pTHX_ OP *o)
1644 o->op_flags |= OPf_PARENS;
1649 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1653 if (ckWARN(WARN_MISC) &&
1654 (left->op_type == OP_RV2AV ||
1655 left->op_type == OP_RV2HV ||
1656 left->op_type == OP_PADAV ||
1657 left->op_type == OP_PADHV)) {
1658 char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
1659 right->op_type == OP_TRANS)
1660 ? right->op_type : OP_MATCH];
1661 const char *sample = ((left->op_type == OP_RV2AV ||
1662 left->op_type == OP_PADAV)
1663 ? "@array" : "%hash");
1664 Perl_warner(aTHX_ packWARN(WARN_MISC),
1665 "Applying %s to %s will act on scalar(%s)",
1666 desc, sample, sample);
1669 if (right->op_type == OP_CONST &&
1670 cSVOPx(right)->op_private & OPpCONST_BARE &&
1671 cSVOPx(right)->op_private & OPpCONST_STRICT)
1673 no_bareword_allowed(right);
1676 if (!(right->op_flags & OPf_STACKED) &&
1677 (right->op_type == OP_MATCH ||
1678 right->op_type == OP_SUBST ||
1679 right->op_type == OP_TRANS)) {
1680 right->op_flags |= OPf_STACKED;
1681 if (right->op_type != OP_MATCH &&
1682 ! (right->op_type == OP_TRANS &&
1683 right->op_private & OPpTRANS_IDENTICAL))
1684 left = mod(left, right->op_type);
1685 if (right->op_type == OP_TRANS)
1686 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
1688 o = prepend_elem(right->op_type, scalar(left), right);
1690 return newUNOP(OP_NOT, 0, scalar(o));
1694 return bind_match(type, left,
1695 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
1699 Perl_invert(pTHX_ OP *o)
1703 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
1704 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1708 Perl_scope(pTHX_ OP *o)
1711 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1712 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1713 o->op_type = OP_LEAVE;
1714 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1716 else if (o->op_type == OP_LINESEQ) {
1718 o->op_type = OP_SCOPE;
1719 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1720 kid = ((LISTOP*)o)->op_first;
1721 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
1725 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
1731 Perl_save_hints(pTHX)
1734 SAVESPTR(GvHV(PL_hintgv));
1735 GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
1736 SAVEFREESV(GvHV(PL_hintgv));
1740 Perl_block_start(pTHX_ int full)
1742 int retval = PL_savestack_ix;
1743 /* If there were syntax errors, don't try to start a block */
1744 if (PL_yynerrs) return retval;
1746 pad_block_start(full);
1748 PL_hints &= ~HINT_BLOCK_SCOPE;
1749 SAVESPTR(PL_compiling.cop_warnings);
1750 if (! specialWARN(PL_compiling.cop_warnings)) {
1751 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1752 SAVEFREESV(PL_compiling.cop_warnings) ;
1754 SAVESPTR(PL_compiling.cop_io);
1755 if (! specialCopIO(PL_compiling.cop_io)) {
1756 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1757 SAVEFREESV(PL_compiling.cop_io) ;
1763 Perl_block_end(pTHX_ I32 floor, OP *seq)
1765 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1766 OP* retval = scalarseq(seq);
1767 /* If there were syntax errors, don't try to close a block */
1768 if (PL_yynerrs) return retval;
1770 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
1772 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
1780 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1784 Perl_newPROG(pTHX_ OP *o)
1789 PL_eval_root = newUNOP(OP_LEAVEEVAL,
1790 ((PL_in_eval & EVAL_KEEPERR)
1791 ? OPf_SPECIAL : 0), o);
1792 PL_eval_start = linklist(PL_eval_root);
1793 PL_eval_root->op_private |= OPpREFCOUNTED;
1794 OpREFCNT_set(PL_eval_root, 1);
1795 PL_eval_root->op_next = 0;
1796 CALL_PEEP(PL_eval_start);
1801 PL_main_root = scope(sawparens(scalarvoid(o)));
1802 PL_curcop = &PL_compiling;
1803 PL_main_start = LINKLIST(PL_main_root);
1804 PL_main_root->op_private |= OPpREFCOUNTED;
1805 OpREFCNT_set(PL_main_root, 1);
1806 PL_main_root->op_next = 0;
1807 CALL_PEEP(PL_main_start);
1810 /* Register with debugger */
1812 CV *cv = get_cv("DB::postponed", FALSE);
1816 XPUSHs((SV*)CopFILEGV(&PL_compiling));
1818 call_sv((SV*)cv, G_DISCARD);
1825 Perl_localize(pTHX_ OP *o, I32 lex)
1827 if (o->op_flags & OPf_PARENS)
1828 /* [perl #17376]: this appears to be premature, and results in code such as
1829 C< our(%x); > executing in list mode rather than void mode */
1836 if (ckWARN(WARN_PARENTHESIS)
1837 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
1839 char *s = PL_bufptr;
1841 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ", *s)))
1844 if (*s == ';' || *s == '=')
1845 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
1846 "Parentheses missing around \"%s\" list",
1847 lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
1853 o = mod(o, OP_NULL); /* a bit kludgey */
1855 PL_in_my_stash = Nullhv;
1860 Perl_jmaybe(pTHX_ OP *o)
1862 if (o->op_type == OP_LIST) {
1864 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
1865 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
1871 Perl_fold_constants(pTHX_ register OP *o)
1874 I32 type = o->op_type;
1877 if (PL_opargs[type] & OA_RETSCALAR)
1879 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
1880 o->op_targ = pad_alloc(type, SVs_PADTMP);
1882 /* integerize op, unless it happens to be C<-foo>.
1883 * XXX should pp_i_negate() do magic string negation instead? */
1884 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
1885 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
1886 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
1888 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
1891 if (!(PL_opargs[type] & OA_FOLDCONST))
1896 /* XXX might want a ck_negate() for this */
1897 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
1909 /* XXX what about the numeric ops? */
1910 if (PL_hints & HINT_LOCALE)
1915 goto nope; /* Don't try to run w/ errors */
1917 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
1918 if ((curop->op_type != OP_CONST ||
1919 (curop->op_private & OPpCONST_BARE)) &&
1920 curop->op_type != OP_LIST &&
1921 curop->op_type != OP_SCALAR &&
1922 curop->op_type != OP_NULL &&
1923 curop->op_type != OP_PUSHMARK)
1929 curop = LINKLIST(o);
1933 sv = *(PL_stack_sp--);
1934 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
1935 pad_swipe(o->op_targ, FALSE);
1936 else if (SvTEMP(sv)) { /* grab mortal temp? */
1937 (void)SvREFCNT_inc(sv);
1941 if (type == OP_RV2GV)
1942 return newGVOP(OP_GV, 0, (GV*)sv);
1943 return newSVOP(OP_CONST, 0, sv);
1950 Perl_gen_constant_list(pTHX_ register OP *o)
1953 I32 oldtmps_floor = PL_tmps_floor;
1957 return o; /* Don't attempt to run with errors */
1959 PL_op = curop = LINKLIST(o);
1966 PL_tmps_floor = oldtmps_floor;
1968 o->op_type = OP_RV2AV;
1969 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
1970 o->op_seq = 0; /* needs to be revisited in peep() */
1971 curop = ((UNOP*)o)->op_first;
1972 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
1979 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
1981 if (!o || o->op_type != OP_LIST)
1982 o = newLISTOP(OP_LIST, 0, o, Nullop);
1984 o->op_flags &= ~OPf_WANT;
1986 if (!(PL_opargs[type] & OA_MARK))
1987 op_null(cLISTOPo->op_first);
1989 o->op_type = (OPCODE)type;
1990 o->op_ppaddr = PL_ppaddr[type];
1991 o->op_flags |= flags;
1993 o = CHECKOP(type, o);
1994 if (o->op_type != type)
1997 return fold_constants(o);
2000 /* List constructors */
2003 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2011 if (first->op_type != type
2012 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2014 return newLISTOP(type, 0, first, last);
2017 if (first->op_flags & OPf_KIDS)
2018 ((LISTOP*)first)->op_last->op_sibling = last;
2020 first->op_flags |= OPf_KIDS;
2021 ((LISTOP*)first)->op_first = last;
2023 ((LISTOP*)first)->op_last = last;
2028 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2036 if (first->op_type != type)
2037 return prepend_elem(type, (OP*)first, (OP*)last);
2039 if (last->op_type != type)
2040 return append_elem(type, (OP*)first, (OP*)last);
2042 first->op_last->op_sibling = last->op_first;
2043 first->op_last = last->op_last;
2044 first->op_flags |= (last->op_flags & OPf_KIDS);
2052 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2060 if (last->op_type == type) {
2061 if (type == OP_LIST) { /* already a PUSHMARK there */
2062 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2063 ((LISTOP*)last)->op_first->op_sibling = first;
2064 if (!(first->op_flags & OPf_PARENS))
2065 last->op_flags &= ~OPf_PARENS;
2068 if (!(last->op_flags & OPf_KIDS)) {
2069 ((LISTOP*)last)->op_last = first;
2070 last->op_flags |= OPf_KIDS;
2072 first->op_sibling = ((LISTOP*)last)->op_first;
2073 ((LISTOP*)last)->op_first = first;
2075 last->op_flags |= OPf_KIDS;
2079 return newLISTOP(type, 0, first, last);
2085 Perl_newNULLLIST(pTHX)
2087 return newOP(OP_STUB, 0);
2091 Perl_force_list(pTHX_ OP *o)
2093 if (!o || o->op_type != OP_LIST)
2094 o = newLISTOP(OP_LIST, 0, o, Nullop);
2100 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2104 NewOp(1101, listop, 1, LISTOP);
2106 listop->op_type = (OPCODE)type;
2107 listop->op_ppaddr = PL_ppaddr[type];
2110 listop->op_flags = (U8)flags;
2114 else if (!first && last)
2117 first->op_sibling = last;
2118 listop->op_first = first;
2119 listop->op_last = last;
2120 if (type == OP_LIST) {
2122 pushop = newOP(OP_PUSHMARK, 0);
2123 pushop->op_sibling = first;
2124 listop->op_first = pushop;
2125 listop->op_flags |= OPf_KIDS;
2127 listop->op_last = pushop;
2134 Perl_newOP(pTHX_ I32 type, I32 flags)
2137 NewOp(1101, o, 1, OP);
2138 o->op_type = (OPCODE)type;
2139 o->op_ppaddr = PL_ppaddr[type];
2140 o->op_flags = (U8)flags;
2143 o->op_private = (U8)(0 | (flags >> 8));
2144 if (PL_opargs[type] & OA_RETSCALAR)
2146 if (PL_opargs[type] & OA_TARGET)
2147 o->op_targ = pad_alloc(type, SVs_PADTMP);
2148 return CHECKOP(type, o);
2152 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2157 first = newOP(OP_STUB, 0);
2158 if (PL_opargs[type] & OA_MARK)
2159 first = force_list(first);
2161 NewOp(1101, unop, 1, UNOP);
2162 unop->op_type = (OPCODE)type;
2163 unop->op_ppaddr = PL_ppaddr[type];
2164 unop->op_first = first;
2165 unop->op_flags = flags | OPf_KIDS;
2166 unop->op_private = (U8)(1 | (flags >> 8));
2167 unop = (UNOP*) CHECKOP(type, unop);
2171 return fold_constants((OP *) unop);
2175 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2178 NewOp(1101, binop, 1, BINOP);
2181 first = newOP(OP_NULL, 0);
2183 binop->op_type = (OPCODE)type;
2184 binop->op_ppaddr = PL_ppaddr[type];
2185 binop->op_first = first;
2186 binop->op_flags = flags | OPf_KIDS;
2189 binop->op_private = (U8)(1 | (flags >> 8));
2192 binop->op_private = (U8)(2 | (flags >> 8));
2193 first->op_sibling = last;
2196 binop = (BINOP*)CHECKOP(type, binop);
2197 if (binop->op_next || binop->op_type != (OPCODE)type)
2200 binop->op_last = binop->op_first->op_sibling;
2202 return fold_constants((OP *)binop);
2206 uvcompare(const void *a, const void *b)
2208 if (*((UV *)a) < (*(UV *)b))
2210 if (*((UV *)a) > (*(UV *)b))
2212 if (*((UV *)a+1) < (*(UV *)b+1))
2214 if (*((UV *)a+1) > (*(UV *)b+1))
2220 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2222 SV *tstr = ((SVOP*)expr)->op_sv;
2223 SV *rstr = ((SVOP*)repl)->op_sv;
2226 U8 *t = (U8*)SvPV(tstr, tlen);
2227 U8 *r = (U8*)SvPV(rstr, rlen);
2234 register short *tbl;
2236 PL_hints |= HINT_BLOCK_SCOPE;
2237 complement = o->op_private & OPpTRANS_COMPLEMENT;
2238 del = o->op_private & OPpTRANS_DELETE;
2239 squash = o->op_private & OPpTRANS_SQUASH;
2242 o->op_private |= OPpTRANS_FROM_UTF;
2245 o->op_private |= OPpTRANS_TO_UTF;
2247 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2248 SV* listsv = newSVpvn("# comment\n",10);
2250 U8* tend = t + tlen;
2251 U8* rend = r + rlen;
2265 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2266 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2272 tsave = t = bytes_to_utf8(t, &len);
2275 if (!to_utf && rlen) {
2277 rsave = r = bytes_to_utf8(r, &len);
2281 /* There are several snags with this code on EBCDIC:
2282 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2283 2. scan_const() in toke.c has encoded chars in native encoding which makes
2284 ranges at least in EBCDIC 0..255 range the bottom odd.
2288 U8 tmpbuf[UTF8_MAXLEN+1];
2291 New(1109, cp, 2*tlen, UV);
2293 transv = newSVpvn("",0);
2295 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2297 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2299 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2303 cp[2*i+1] = cp[2*i];
2307 qsort(cp, i, 2*sizeof(UV), uvcompare);
2308 for (j = 0; j < i; j++) {
2310 diff = val - nextmin;
2312 t = uvuni_to_utf8(tmpbuf,nextmin);
2313 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2315 U8 range_mark = UTF_TO_NATIVE(0xff);
2316 t = uvuni_to_utf8(tmpbuf, val - 1);
2317 sv_catpvn(transv, (char *)&range_mark, 1);
2318 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2325 t = uvuni_to_utf8(tmpbuf,nextmin);
2326 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2328 U8 range_mark = UTF_TO_NATIVE(0xff);
2329 sv_catpvn(transv, (char *)&range_mark, 1);
2331 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2332 UNICODE_ALLOW_SUPER);
2333 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2334 t = (U8*)SvPVX(transv);
2335 tlen = SvCUR(transv);
2339 else if (!rlen && !del) {
2340 r = t; rlen = tlen; rend = tend;
2343 if ((!rlen && !del) || t == r ||
2344 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2346 o->op_private |= OPpTRANS_IDENTICAL;
2350 while (t < tend || tfirst <= tlast) {
2351 /* see if we need more "t" chars */
2352 if (tfirst > tlast) {
2353 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2355 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2357 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2364 /* now see if we need more "r" chars */
2365 if (rfirst > rlast) {
2367 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2369 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2371 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2380 rfirst = rlast = 0xffffffff;
2384 /* now see which range will peter our first, if either. */
2385 tdiff = tlast - tfirst;
2386 rdiff = rlast - rfirst;
2393 if (rfirst == 0xffffffff) {
2394 diff = tdiff; /* oops, pretend rdiff is infinite */
2396 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2397 (long)tfirst, (long)tlast);
2399 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2403 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2404 (long)tfirst, (long)(tfirst + diff),
2407 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2408 (long)tfirst, (long)rfirst);
2410 if (rfirst + diff > max)
2411 max = rfirst + diff;
2413 grows = (tfirst < rfirst &&
2414 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2426 else if (max > 0xff)
2431 Safefree(cPVOPo->op_pv);
2432 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2433 SvREFCNT_dec(listsv);
2435 SvREFCNT_dec(transv);
2437 if (!del && havefinal && rlen)
2438 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2439 newSVuv((UV)final), 0);
2442 o->op_private |= OPpTRANS_GROWS;
2454 tbl = (short*)cPVOPo->op_pv;
2456 Zero(tbl, 256, short);
2457 for (i = 0; i < (I32)tlen; i++)
2459 for (i = 0, j = 0; i < 256; i++) {
2461 if (j >= (I32)rlen) {
2470 if (i < 128 && r[j] >= 128)
2480 o->op_private |= OPpTRANS_IDENTICAL;
2482 else if (j >= (I32)rlen)
2485 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2486 tbl[0x100] = rlen - j;
2487 for (i=0; i < (I32)rlen - j; i++)
2488 tbl[0x101+i] = r[j+i];
2492 if (!rlen && !del) {
2495 o->op_private |= OPpTRANS_IDENTICAL;
2497 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2498 o->op_private |= OPpTRANS_IDENTICAL;
2500 for (i = 0; i < 256; i++)
2502 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
2503 if (j >= (I32)rlen) {
2505 if (tbl[t[i]] == -1)
2511 if (tbl[t[i]] == -1) {
2512 if (t[i] < 128 && r[j] >= 128)
2519 o->op_private |= OPpTRANS_GROWS;
2527 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2531 NewOp(1101, pmop, 1, PMOP);
2532 pmop->op_type = (OPCODE)type;
2533 pmop->op_ppaddr = PL_ppaddr[type];
2534 pmop->op_flags = (U8)flags;
2535 pmop->op_private = (U8)(0 | (flags >> 8));
2537 if (PL_hints & HINT_RE_TAINT)
2538 pmop->op_pmpermflags |= PMf_RETAINT;
2539 if (PL_hints & HINT_LOCALE)
2540 pmop->op_pmpermflags |= PMf_LOCALE;
2541 pmop->op_pmflags = pmop->op_pmpermflags;
2546 if(av_len((AV*) PL_regex_pad[0]) > -1) {
2547 repointer = av_pop((AV*)PL_regex_pad[0]);
2548 pmop->op_pmoffset = SvIV(repointer);
2549 SvREPADTMP_off(repointer);
2550 sv_setiv(repointer,0);
2552 repointer = newSViv(0);
2553 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2554 pmop->op_pmoffset = av_len(PL_regex_padav);
2555 PL_regex_pad = AvARRAY(PL_regex_padav);
2560 /* link into pm list */
2561 if (type != OP_TRANS && PL_curstash) {
2562 pmop->op_pmnext = HvPMROOT(PL_curstash);
2563 HvPMROOT(PL_curstash) = pmop;
2564 PmopSTASH_set(pmop,PL_curstash);
2571 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
2575 I32 repl_has_vars = 0;
2577 if (o->op_type == OP_TRANS)
2578 return pmtrans(o, expr, repl);
2580 PL_hints |= HINT_BLOCK_SCOPE;
2583 if (expr->op_type == OP_CONST) {
2585 SV *pat = ((SVOP*)expr)->op_sv;
2586 char *p = SvPV(pat, plen);
2587 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
2588 sv_setpvn(pat, "\\s+", 3);
2589 p = SvPV(pat, plen);
2590 pm->op_pmflags |= PMf_SKIPWHITE;
2593 pm->op_pmdynflags |= PMdf_UTF8;
2594 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
2595 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
2596 pm->op_pmflags |= PMf_WHITE;
2600 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2601 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2603 : OP_REGCMAYBE),0,expr);
2605 NewOp(1101, rcop, 1, LOGOP);
2606 rcop->op_type = OP_REGCOMP;
2607 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2608 rcop->op_first = scalar(expr);
2609 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
2610 ? (OPf_SPECIAL | OPf_KIDS)
2612 rcop->op_private = 1;
2615 /* establish postfix order */
2616 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2618 rcop->op_next = expr;
2619 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2622 rcop->op_next = LINKLIST(expr);
2623 expr->op_next = (OP*)rcop;
2626 prepend_elem(o->op_type, scalar((OP*)rcop), o);
2631 if (pm->op_pmflags & PMf_EVAL) {
2633 if (CopLINE(PL_curcop) < PL_multi_end)
2634 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
2636 else if (repl->op_type == OP_CONST)
2640 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
2641 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
2642 if (curop->op_type == OP_GV) {
2643 GV *gv = cGVOPx_gv(curop);
2645 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
2648 else if (curop->op_type == OP_RV2CV)
2650 else if (curop->op_type == OP_RV2SV ||
2651 curop->op_type == OP_RV2AV ||
2652 curop->op_type == OP_RV2HV ||
2653 curop->op_type == OP_RV2GV) {
2654 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2657 else if (curop->op_type == OP_PADSV ||
2658 curop->op_type == OP_PADAV ||
2659 curop->op_type == OP_PADHV ||
2660 curop->op_type == OP_PADANY) {
2663 else if (curop->op_type == OP_PUSHRE)
2664 ; /* Okay here, dangerous in newASSIGNOP */
2674 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
2675 pm->op_pmflags |= PMf_CONST; /* const for long enough */
2676 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
2677 prepend_elem(o->op_type, scalar(repl), o);
2680 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
2681 pm->op_pmflags |= PMf_MAYBE_CONST;
2682 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2684 NewOp(1101, rcop, 1, LOGOP);
2685 rcop->op_type = OP_SUBSTCONT;
2686 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
2687 rcop->op_first = scalar(repl);
2688 rcop->op_flags |= OPf_KIDS;
2689 rcop->op_private = 1;
2692 /* establish postfix order */
2693 rcop->op_next = LINKLIST(repl);
2694 repl->op_next = (OP*)rcop;
2696 pm->op_pmreplroot = scalar((OP*)rcop);
2697 pm->op_pmreplstart = LINKLIST(rcop);
2706 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
2709 NewOp(1101, svop, 1, SVOP);
2710 svop->op_type = (OPCODE)type;
2711 svop->op_ppaddr = PL_ppaddr[type];
2713 svop->op_next = (OP*)svop;
2714 svop->op_flags = (U8)flags;
2715 if (PL_opargs[type] & OA_RETSCALAR)
2717 if (PL_opargs[type] & OA_TARGET)
2718 svop->op_targ = pad_alloc(type, SVs_PADTMP);
2719 return CHECKOP(type, svop);
2723 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2726 NewOp(1101, padop, 1, PADOP);
2727 padop->op_type = (OPCODE)type;
2728 padop->op_ppaddr = PL_ppaddr[type];
2729 padop->op_padix = pad_alloc(type, SVs_PADTMP);
2730 SvREFCNT_dec(PAD_SVl(padop->op_padix));
2731 PAD_SETSV(padop->op_padix, sv);
2734 padop->op_next = (OP*)padop;
2735 padop->op_flags = (U8)flags;
2736 if (PL_opargs[type] & OA_RETSCALAR)
2738 if (PL_opargs[type] & OA_TARGET)
2739 padop->op_targ = pad_alloc(type, SVs_PADTMP);
2740 return CHECKOP(type, padop);
2744 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
2749 return newPADOP(type, flags, SvREFCNT_inc(gv));
2751 return newSVOP(type, flags, SvREFCNT_inc(gv));
2756 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
2759 NewOp(1101, pvop, 1, PVOP);
2760 pvop->op_type = (OPCODE)type;
2761 pvop->op_ppaddr = PL_ppaddr[type];
2763 pvop->op_next = (OP*)pvop;
2764 pvop->op_flags = (U8)flags;
2765 if (PL_opargs[type] & OA_RETSCALAR)
2767 if (PL_opargs[type] & OA_TARGET)
2768 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
2769 return CHECKOP(type, pvop);
2773 Perl_package(pTHX_ OP *o)
2778 save_hptr(&PL_curstash);
2779 save_item(PL_curstname);
2781 name = SvPV(cSVOPo->op_sv, len);
2782 PL_curstash = gv_stashpvn(name, len, TRUE);
2783 sv_setpvn(PL_curstname, name, len);
2786 PL_hints |= HINT_BLOCK_SCOPE;
2787 PL_copline = NOLINE;
2792 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
2798 if (id->op_type != OP_CONST)
2799 Perl_croak(aTHX_ "Module name must be constant");
2803 if (version != Nullop) {
2804 SV *vesv = ((SVOP*)version)->op_sv;
2806 if (arg == Nullop && !SvNIOKp(vesv)) {
2813 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
2814 Perl_croak(aTHX_ "Version number must be constant number");
2816 /* Make copy of id so we don't free it twice */
2817 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
2819 /* Fake up a method call to VERSION */
2820 meth = newSVpvn("VERSION",7);
2821 sv_upgrade(meth, SVt_PVIV);
2822 (void)SvIOK_on(meth);
2823 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
2824 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2825 append_elem(OP_LIST,
2826 prepend_elem(OP_LIST, pack, list(version)),
2827 newSVOP(OP_METHOD_NAMED, 0, meth)));
2831 /* Fake up an import/unimport */
2832 if (arg && arg->op_type == OP_STUB)
2833 imop = arg; /* no import on explicit () */
2834 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
2835 imop = Nullop; /* use 5.0; */
2840 /* Make copy of id so we don't free it twice */
2841 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
2843 /* Fake up a method call to import/unimport */
2844 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);
2845 (void)SvUPGRADE(meth, SVt_PVIV);
2846 (void)SvIOK_on(meth);
2847 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
2848 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2849 append_elem(OP_LIST,
2850 prepend_elem(OP_LIST, pack, list(arg)),
2851 newSVOP(OP_METHOD_NAMED, 0, meth)));
2854 /* Fake up the BEGIN {}, which does its thing immediately. */
2856 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
2859 append_elem(OP_LINESEQ,
2860 append_elem(OP_LINESEQ,
2861 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, id)),
2862 newSTATEOP(0, Nullch, veop)),
2863 newSTATEOP(0, Nullch, imop) ));
2865 /* The "did you use incorrect case?" warning used to be here.
2866 * The problem is that on case-insensitive filesystems one
2867 * might get false positives for "use" (and "require"):
2868 * "use Strict" or "require CARP" will work. This causes
2869 * portability problems for the script: in case-strict
2870 * filesystems the script will stop working.
2872 * The "incorrect case" warning checked whether "use Foo"
2873 * imported "Foo" to your namespace, but that is wrong, too:
2874 * there is no requirement nor promise in the language that
2875 * a Foo.pm should or would contain anything in package "Foo".
2877 * There is very little Configure-wise that can be done, either:
2878 * the case-sensitivity of the build filesystem of Perl does not
2879 * help in guessing the case-sensitivity of the runtime environment.
2882 PL_hints |= HINT_BLOCK_SCOPE;
2883 PL_copline = NOLINE;
2888 =head1 Embedding Functions
2890 =for apidoc load_module
2892 Loads the module whose name is pointed to by the string part of name.
2893 Note that the actual module name, not its filename, should be given.
2894 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
2895 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
2896 (or 0 for no flags). ver, if specified, provides version semantics
2897 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
2898 arguments can be used to specify arguments to the module's import()
2899 method, similar to C<use Foo::Bar VERSION LIST>.
2904 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
2907 va_start(args, ver);
2908 vload_module(flags, name, ver, &args);
2912 #ifdef PERL_IMPLICIT_CONTEXT
2914 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
2918 va_start(args, ver);
2919 vload_module(flags, name, ver, &args);
2925 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
2927 OP *modname, *veop, *imop;
2929 modname = newSVOP(OP_CONST, 0, name);
2930 modname->op_private |= OPpCONST_BARE;
2932 veop = newSVOP(OP_CONST, 0, ver);
2936 if (flags & PERL_LOADMOD_NOIMPORT) {
2937 imop = sawparens(newNULLLIST());
2939 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
2940 imop = va_arg(*args, OP*);
2945 sv = va_arg(*args, SV*);
2947 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
2948 sv = va_arg(*args, SV*);
2952 line_t ocopline = PL_copline;
2953 COP *ocurcop = PL_curcop;
2954 int oexpect = PL_expect;
2956 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
2957 veop, modname, imop);
2958 PL_expect = oexpect;
2959 PL_copline = ocopline;
2960 PL_curcop = ocurcop;
2965 Perl_dofile(pTHX_ OP *term)
2970 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
2971 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
2972 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
2974 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
2975 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
2976 append_elem(OP_LIST, term,
2977 scalar(newUNOP(OP_RV2CV, 0,
2982 doop = newUNOP(OP_DOFILE, 0, scalar(term));
2988 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
2990 return newBINOP(OP_LSLICE, flags,
2991 list(force_list(subscript)),
2992 list(force_list(listval)) );
2996 S_list_assignment(pTHX_ register OP *o)
3001 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3002 o = cUNOPo->op_first;
3004 if (o->op_type == OP_COND_EXPR) {
3005 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3006 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3011 yyerror("Assignment to both a list and a scalar");
3015 if (o->op_type == OP_LIST &&
3016 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3017 o->op_private & OPpLVAL_INTRO)
3020 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3021 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3022 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3025 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3028 if (o->op_type == OP_RV2SV)
3035 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3040 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3041 return newLOGOP(optype, 0,
3042 mod(scalar(left), optype),
3043 newUNOP(OP_SASSIGN, 0, scalar(right)));
3046 return newBINOP(optype, OPf_STACKED,
3047 mod(scalar(left), optype), scalar(right));
3051 if (list_assignment(left)) {
3055 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3056 left = mod(left, OP_AASSIGN);
3064 curop = list(force_list(left));
3065 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3066 o->op_private = (U8)(0 | (flags >> 8));
3068 /* PL_generation sorcery:
3069 * an assignment like ($a,$b) = ($c,$d) is easier than
3070 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3071 * To detect whether there are common vars, the global var
3072 * PL_generation is incremented for each assign op we compile.
3073 * Then, while compiling the assign op, we run through all the
3074 * variables on both sides of the assignment, setting a spare slot
3075 * in each of them to PL_generation. If any of them already have
3076 * that value, we know we've got commonality. We could use a
3077 * single bit marker, but then we'd have to make 2 passes, first
3078 * to clear the flag, then to test and set it. To find somewhere
3079 * to store these values, evil chicanery is done with SvCUR().
3082 if (!(left->op_private & OPpLVAL_INTRO)) {
3085 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3086 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3087 if (curop->op_type == OP_GV) {
3088 GV *gv = cGVOPx_gv(curop);
3089 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3091 SvCUR(gv) = PL_generation;
3093 else if (curop->op_type == OP_PADSV ||
3094 curop->op_type == OP_PADAV ||
3095 curop->op_type == OP_PADHV ||
3096 curop->op_type == OP_PADANY)
3098 if (PAD_COMPNAME_GEN(curop->op_targ)
3099 == (STRLEN)PL_generation)
3101 PAD_COMPNAME_GEN(curop->op_targ)
3105 else if (curop->op_type == OP_RV2CV)
3107 else if (curop->op_type == OP_RV2SV ||
3108 curop->op_type == OP_RV2AV ||
3109 curop->op_type == OP_RV2HV ||
3110 curop->op_type == OP_RV2GV) {
3111 if (lastop->op_type != OP_GV) /* funny deref? */
3114 else if (curop->op_type == OP_PUSHRE) {
3115 if (((PMOP*)curop)->op_pmreplroot) {
3117 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3118 ((PMOP*)curop)->op_pmreplroot));
3120 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3122 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3124 SvCUR(gv) = PL_generation;
3133 o->op_private |= OPpASSIGN_COMMON;
3135 if (right && right->op_type == OP_SPLIT) {
3137 if ((tmpop = ((LISTOP*)right)->op_first) &&
3138 tmpop->op_type == OP_PUSHRE)
3140 PMOP *pm = (PMOP*)tmpop;
3141 if (left->op_type == OP_RV2AV &&
3142 !(left->op_private & OPpLVAL_INTRO) &&
3143 !(o->op_private & OPpASSIGN_COMMON) )
3145 tmpop = ((UNOP*)left)->op_first;
3146 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3148 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3149 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3151 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3152 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3154 pm->op_pmflags |= PMf_ONCE;
3155 tmpop = cUNOPo->op_first; /* to list (nulled) */
3156 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3157 tmpop->op_sibling = Nullop; /* don't free split */
3158 right->op_next = tmpop->op_next; /* fix starting loc */
3159 op_free(o); /* blow off assign */
3160 right->op_flags &= ~OPf_WANT;
3161 /* "I don't know and I don't care." */
3166 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3167 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3169 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3171 sv_setiv(sv, PL_modcount+1);
3179 right = newOP(OP_UNDEF, 0);
3180 if (right->op_type == OP_READLINE) {
3181 right->op_flags |= OPf_STACKED;
3182 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3185 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3186 o = newBINOP(OP_SASSIGN, flags,
3187 scalar(right), mod(scalar(left), OP_SASSIGN) );
3199 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3201 U32 seq = intro_my();
3204 NewOp(1101, cop, 1, COP);
3205 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3206 cop->op_type = OP_DBSTATE;
3207 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3210 cop->op_type = OP_NEXTSTATE;
3211 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3213 cop->op_flags = (U8)flags;
3214 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3216 cop->op_private |= NATIVE_HINTS;
3218 PL_compiling.op_private = cop->op_private;
3219 cop->op_next = (OP*)cop;
3222 cop->cop_label = label;
3223 PL_hints |= HINT_BLOCK_SCOPE;
3226 cop->cop_arybase = PL_curcop->cop_arybase;
3227 if (specialWARN(PL_curcop->cop_warnings))
3228 cop->cop_warnings = PL_curcop->cop_warnings ;
3230 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3231 if (specialCopIO(PL_curcop->cop_io))
3232 cop->cop_io = PL_curcop->cop_io;
3234 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3237 if (PL_copline == NOLINE)
3238 CopLINE_set(cop, CopLINE(PL_curcop));
3240 CopLINE_set(cop, PL_copline);
3241 PL_copline = NOLINE;
3244 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3246 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3248 CopSTASH_set(cop, PL_curstash);
3250 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3251 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3252 if (svp && *svp != &PL_sv_undef ) {
3253 (void)SvIOK_on(*svp);
3254 SvIVX(*svp) = PTR2IV(cop);
3258 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3263 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3265 return new_logop(type, flags, &first, &other);
3269 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3273 OP *first = *firstp;
3274 OP *other = *otherp;
3276 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3277 return newBINOP(type, flags, scalar(first), scalar(other));
3279 scalarboolean(first);
3280 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3281 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3282 if (type == OP_AND || type == OP_OR) {
3288 first = *firstp = cUNOPo->op_first;
3290 first->op_next = o->op_next;
3291 cUNOPo->op_first = Nullop;
3295 if (first->op_type == OP_CONST) {
3296 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE)) {
3297 if (first->op_private & OPpCONST_STRICT)
3298 no_bareword_allowed(first);
3300 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3302 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3313 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3314 OP *k1 = ((UNOP*)first)->op_first;
3315 OP *k2 = k1->op_sibling;
3317 switch (first->op_type)
3320 if (k2 && k2->op_type == OP_READLINE
3321 && (k2->op_flags & OPf_STACKED)
3322 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3324 warnop = k2->op_type;
3329 if (k1->op_type == OP_READDIR
3330 || k1->op_type == OP_GLOB
3331 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3332 || k1->op_type == OP_EACH)
3334 warnop = ((k1->op_type == OP_NULL)
3335 ? (OPCODE)k1->op_targ : k1->op_type);
3340 line_t oldline = CopLINE(PL_curcop);
3341 CopLINE_set(PL_curcop, PL_copline);
3342 Perl_warner(aTHX_ packWARN(WARN_MISC),
3343 "Value of %s%s can be \"0\"; test with defined()",
3345 ((warnop == OP_READLINE || warnop == OP_GLOB)
3346 ? " construct" : "() operator"));
3347 CopLINE_set(PL_curcop, oldline);
3354 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3355 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3357 NewOp(1101, logop, 1, LOGOP);
3359 logop->op_type = (OPCODE)type;
3360 logop->op_ppaddr = PL_ppaddr[type];
3361 logop->op_first = first;
3362 logop->op_flags = flags | OPf_KIDS;
3363 logop->op_other = LINKLIST(other);
3364 logop->op_private = (U8)(1 | (flags >> 8));
3366 /* establish postfix order */
3367 logop->op_next = LINKLIST(first);
3368 first->op_next = (OP*)logop;
3369 first->op_sibling = other;
3371 o = newUNOP(OP_NULL, 0, (OP*)logop);
3378 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3385 return newLOGOP(OP_AND, 0, first, trueop);
3387 return newLOGOP(OP_OR, 0, first, falseop);
3389 scalarboolean(first);
3390 if (first->op_type == OP_CONST) {
3391 if (first->op_private & OPpCONST_BARE &&
3392 first->op_private & OPpCONST_STRICT) {
3393 no_bareword_allowed(first);
3395 if (SvTRUE(((SVOP*)first)->op_sv)) {
3406 NewOp(1101, logop, 1, LOGOP);
3407 logop->op_type = OP_COND_EXPR;
3408 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3409 logop->op_first = first;
3410 logop->op_flags = flags | OPf_KIDS;
3411 logop->op_private = (U8)(1 | (flags >> 8));
3412 logop->op_other = LINKLIST(trueop);
3413 logop->op_next = LINKLIST(falseop);
3416 /* establish postfix order */
3417 start = LINKLIST(first);
3418 first->op_next = (OP*)logop;
3420 first->op_sibling = trueop;
3421 trueop->op_sibling = falseop;
3422 o = newUNOP(OP_NULL, 0, (OP*)logop);
3424 trueop->op_next = falseop->op_next = o;
3431 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3439 NewOp(1101, range, 1, LOGOP);
3441 range->op_type = OP_RANGE;
3442 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3443 range->op_first = left;
3444 range->op_flags = OPf_KIDS;
3445 leftstart = LINKLIST(left);
3446 range->op_other = LINKLIST(right);
3447 range->op_private = (U8)(1 | (flags >> 8));
3449 left->op_sibling = right;
3451 range->op_next = (OP*)range;
3452 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3453 flop = newUNOP(OP_FLOP, 0, flip);
3454 o = newUNOP(OP_NULL, 0, flop);
3456 range->op_next = leftstart;
3458 left->op_next = flip;
3459 right->op_next = flop;
3461 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3462 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3463 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3464 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3466 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3467 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3470 if (!flip->op_private || !flop->op_private)
3471 linklist(o); /* blow off optimizer unless constant */
3477 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3481 int once = block && block->op_flags & OPf_SPECIAL &&
3482 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3485 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3486 return block; /* do {} while 0 does once */
3487 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3488 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3489 expr = newUNOP(OP_DEFINED, 0,
3490 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3491 } else if (expr->op_flags & OPf_KIDS) {
3492 OP *k1 = ((UNOP*)expr)->op_first;
3493 OP *k2 = (k1) ? k1->op_sibling : NULL;
3494 switch (expr->op_type) {
3496 if (k2 && k2->op_type == OP_READLINE
3497 && (k2->op_flags & OPf_STACKED)
3498 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3499 expr = newUNOP(OP_DEFINED, 0, expr);
3503 if (k1->op_type == OP_READDIR
3504 || k1->op_type == OP_GLOB
3505 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3506 || k1->op_type == OP_EACH)
3507 expr = newUNOP(OP_DEFINED, 0, expr);
3513 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3514 o = new_logop(OP_AND, 0, &expr, &listop);
3517 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3519 if (once && o != listop)
3520 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3523 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3525 o->op_flags |= flags;
3527 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3532 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3540 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3541 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3542 expr = newUNOP(OP_DEFINED, 0,
3543 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3544 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3545 OP *k1 = ((UNOP*)expr)->op_first;
3546 OP *k2 = (k1) ? k1->op_sibling : NULL;
3547 switch (expr->op_type) {
3549 if (k2 && k2->op_type == OP_READLINE
3550 && (k2->op_flags & OPf_STACKED)
3551 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3552 expr = newUNOP(OP_DEFINED, 0, expr);
3556 if (k1->op_type == OP_READDIR
3557 || k1->op_type == OP_GLOB
3558 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3559 || k1->op_type == OP_EACH)
3560 expr = newUNOP(OP_DEFINED, 0, expr);
3566 block = newOP(OP_NULL, 0);
3568 block = scope(block);
3572 next = LINKLIST(cont);
3575 OP *unstack = newOP(OP_UNSTACK, 0);
3578 cont = append_elem(OP_LINESEQ, cont, unstack);
3579 if ((line_t)whileline != NOLINE) {
3580 PL_copline = (line_t)whileline;
3581 cont = append_elem(OP_LINESEQ, cont,
3582 newSTATEOP(0, Nullch, Nullop));
3586 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3587 redo = LINKLIST(listop);
3590 PL_copline = (line_t)whileline;
3592 o = new_logop(OP_AND, 0, &expr, &listop);
3593 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3594 op_free(expr); /* oops, it's a while (0) */
3596 return Nullop; /* listop already freed by new_logop */
3599 ((LISTOP*)listop)->op_last->op_next =
3600 (o == listop ? redo : LINKLIST(o));
3606 NewOp(1101,loop,1,LOOP);
3607 loop->op_type = OP_ENTERLOOP;
3608 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3609 loop->op_private = 0;
3610 loop->op_next = (OP*)loop;
3613 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3615 loop->op_redoop = redo;
3616 loop->op_lastop = o;
3617 o->op_private |= loopflags;
3620 loop->op_nextop = next;
3622 loop->op_nextop = o;
3624 o->op_flags |= flags;
3625 o->op_private |= (flags >> 8);
3630 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
3634 PADOFFSET padoff = 0;
3638 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
3639 sv->op_type = OP_RV2GV;
3640 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3642 else if (sv->op_type == OP_PADSV) { /* private variable */
3643 padoff = sv->op_targ;
3648 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3649 padoff = sv->op_targ;
3651 iterflags |= OPf_SPECIAL;
3656 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3659 sv = newGVOP(OP_GV, 0, PL_defgv);
3661 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3662 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3663 iterflags |= OPf_STACKED;
3665 else if (expr->op_type == OP_NULL &&
3666 (expr->op_flags & OPf_KIDS) &&
3667 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3669 /* Basically turn for($x..$y) into the same as for($x,$y), but we
3670 * set the STACKED flag to indicate that these values are to be
3671 * treated as min/max values by 'pp_iterinit'.
3673 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
3674 LOGOP* range = (LOGOP*) flip->op_first;
3675 OP* left = range->op_first;
3676 OP* right = left->op_sibling;
3679 range->op_flags &= ~OPf_KIDS;
3680 range->op_first = Nullop;
3682 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
3683 listop->op_first->op_next = range->op_next;
3684 left->op_next = range->op_other;
3685 right->op_next = (OP*)listop;
3686 listop->op_next = listop->op_first;
3689 expr = (OP*)(listop);
3691 iterflags |= OPf_STACKED;
3694 expr = mod(force_list(expr), OP_GREPSTART);
3698 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
3699 append_elem(OP_LIST, expr, scalar(sv))));
3700 assert(!loop->op_next);
3701 #ifdef PL_OP_SLAB_ALLOC
3704 NewOp(1234,tmp,1,LOOP);
3705 Copy(loop,tmp,1,LOOP);
3710 Renew(loop, 1, LOOP);
3712 loop->op_targ = padoff;
3713 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
3714 PL_copline = forline;
3715 return newSTATEOP(0, label, wop);
3719 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
3724 if (type != OP_GOTO || label->op_type == OP_CONST) {
3725 /* "last()" means "last" */
3726 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
3727 o = newOP(type, OPf_SPECIAL);
3729 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
3730 ? SvPVx(((SVOP*)label)->op_sv, n_a)
3736 if (label->op_type == OP_ENTERSUB)
3737 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
3738 o = newUNOP(type, OPf_STACKED, label);
3740 PL_hints |= HINT_BLOCK_SCOPE;
3745 =for apidoc cv_undef
3747 Clear out all the active components of a CV. This can happen either
3748 by an explicit C<undef &foo>, or by the reference count going to zero.
3749 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
3750 children can still follow the full lexical scope chain.
3756 Perl_cv_undef(pTHX_ CV *cv)
3759 if (CvFILE(cv) && !CvXSUB(cv)) {
3760 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
3761 Safefree(CvFILE(cv));
3766 if (!CvXSUB(cv) && CvROOT(cv)) {
3768 Perl_croak(aTHX_ "Can't undef active subroutine");
3771 PAD_SAVE_SETNULLPAD();
3773 op_free(CvROOT(cv));
3774 CvROOT(cv) = Nullop;
3777 SvPOK_off((SV*)cv); /* forget prototype */
3782 /* remove CvOUTSIDE unless this is an undef rather than a free */
3783 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
3784 if (!CvWEAKOUTSIDE(cv))
3785 SvREFCNT_dec(CvOUTSIDE(cv));
3786 CvOUTSIDE(cv) = Nullcv;
3789 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
3795 /* delete all flags except WEAKOUTSIDE */
3796 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
3800 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
3802 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
3803 SV* msg = sv_newmortal();
3807 gv_efullname3(name = sv_newmortal(), gv, Nullch);
3808 sv_setpv(msg, "Prototype mismatch:");
3810 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
3812 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (SV *)cv);
3813 sv_catpv(msg, " vs ");
3815 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
3817 sv_catpv(msg, "none");
3818 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
3822 static void const_sv_xsub(pTHX_ CV* cv);
3826 =head1 Optree Manipulation Functions
3828 =for apidoc cv_const_sv
3830 If C<cv> is a constant sub eligible for inlining. returns the constant
3831 value returned by the sub. Otherwise, returns NULL.
3833 Constant subs can be created with C<newCONSTSUB> or as described in
3834 L<perlsub/"Constant Functions">.
3839 Perl_cv_const_sv(pTHX_ CV *cv)
3841 if (!cv || !CvCONST(cv))
3843 return (SV*)CvXSUBANY(cv).any_ptr;
3847 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
3854 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
3855 o = cLISTOPo->op_first->op_sibling;
3857 for (; o; o = o->op_next) {
3858 OPCODE type = o->op_type;
3860 if (sv && o->op_next == o)
3862 if (o->op_next != o) {
3863 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
3865 if (type == OP_DBSTATE)
3868 if (type == OP_LEAVESUB || type == OP_RETURN)
3872 if (type == OP_CONST && cSVOPo->op_sv)
3874 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
3875 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
3879 /* We get here only from cv_clone2() while creating a closure.
3880 Copy the const value here instead of in cv_clone2 so that
3881 SvREADONLY_on doesn't lead to problems when leaving
3886 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
3898 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
3908 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
3912 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
3914 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
3918 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
3924 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
3928 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
3929 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
3930 SV *sv = sv_newmortal();
3931 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
3932 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
3933 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3938 gv = gv_fetchpv(name ? name : (aname ? aname :
3939 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__")),
3940 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
3950 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
3951 maximum a prototype before. */
3952 if (SvTYPE(gv) > SVt_NULL) {
3953 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
3954 && ckWARN_d(WARN_PROTOTYPE))
3956 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
3958 cv_ckproto((CV*)gv, NULL, ps);
3961 sv_setpv((SV*)gv, ps);
3963 sv_setiv((SV*)gv, -1);
3964 SvREFCNT_dec(PL_compcv);
3965 cv = PL_compcv = NULL;
3966 PL_sub_generation++;
3970 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
3972 #ifdef GV_UNIQUE_CHECK
3973 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
3974 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
3978 if (!block || !ps || *ps || attrs)
3981 const_sv = op_const_sv(block, Nullcv);
3984 bool exists = CvROOT(cv) || CvXSUB(cv);
3986 #ifdef GV_UNIQUE_CHECK
3987 if (exists && GvUNIQUE(gv)) {
3988 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
3992 /* if the subroutine doesn't exist and wasn't pre-declared
3993 * with a prototype, assume it will be AUTOLOADed,
3994 * skipping the prototype check
3996 if (exists || SvPOK(cv))
3997 cv_ckproto(cv, gv, ps);
3998 /* already defined (or promised)? */
3999 if (exists || GvASSUMECV(gv)) {
4000 if (!block && !attrs) {
4001 if (CvFLAGS(PL_compcv)) {
4002 /* might have had built-in attrs applied */
4003 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4005 /* just a "sub foo;" when &foo is already defined */
4006 SAVEFREESV(PL_compcv);
4009 /* ahem, death to those who redefine active sort subs */
4010 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4011 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4013 if (ckWARN(WARN_REDEFINE)
4015 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4017 line_t oldline = CopLINE(PL_curcop);
4018 if (PL_copline != NOLINE)
4019 CopLINE_set(PL_curcop, PL_copline);
4020 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4021 CvCONST(cv) ? "Constant subroutine %s redefined"
4022 : "Subroutine %s redefined", name);
4023 CopLINE_set(PL_curcop, oldline);
4031 SvREFCNT_inc(const_sv);
4033 assert(!CvROOT(cv) && !CvCONST(cv));
4034 sv_setpv((SV*)cv, ""); /* prototype is "" */
4035 CvXSUBANY(cv).any_ptr = const_sv;
4036 CvXSUB(cv) = const_sv_xsub;
4041 cv = newCONSTSUB(NULL, name, const_sv);
4044 SvREFCNT_dec(PL_compcv);
4046 PL_sub_generation++;
4053 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4054 * before we clobber PL_compcv.
4058 /* Might have had built-in attributes applied -- propagate them. */
4059 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4060 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4061 stash = GvSTASH(CvGV(cv));
4062 else if (CvSTASH(cv))
4063 stash = CvSTASH(cv);
4065 stash = PL_curstash;
4068 /* possibly about to re-define existing subr -- ignore old cv */
4069 rcv = (SV*)PL_compcv;
4070 if (name && GvSTASH(gv))
4071 stash = GvSTASH(gv);
4073 stash = PL_curstash;
4075 apply_attrs(stash, rcv, attrs, FALSE);
4077 if (cv) { /* must reuse cv if autoloaded */
4079 /* got here with just attrs -- work done, so bug out */
4080 SAVEFREESV(PL_compcv);
4083 /* transfer PL_compcv to cv */
4085 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4086 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4087 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4088 CvOUTSIDE(PL_compcv) = 0;
4089 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4090 CvPADLIST(PL_compcv) = 0;
4091 /* inner references to PL_compcv must be fixed up ... */
4092 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4093 /* ... before we throw it away */
4094 SvREFCNT_dec(PL_compcv);
4095 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4096 ++PL_sub_generation;
4103 PL_sub_generation++;
4107 CvFILE_set_from_cop(cv, PL_curcop);
4108 CvSTASH(cv) = PL_curstash;
4111 sv_setpv((SV*)cv, ps);
4113 if (PL_error_count) {
4117 char *s = strrchr(name, ':');
4119 if (strEQ(s, "BEGIN")) {
4121 "BEGIN not safe after errors--compilation aborted";
4122 if (PL_in_eval & EVAL_KEEPERR)
4123 Perl_croak(aTHX_ not_safe);
4125 /* force display of errors found but not reported */
4126 sv_catpv(ERRSV, not_safe);
4127 Perl_croak(aTHX_ "%"SVf, ERRSV);
4136 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4137 mod(scalarseq(block), OP_LEAVESUBLV));
4140 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4142 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4143 OpREFCNT_set(CvROOT(cv), 1);
4144 CvSTART(cv) = LINKLIST(CvROOT(cv));
4145 CvROOT(cv)->op_next = 0;
4146 CALL_PEEP(CvSTART(cv));
4148 /* now that optimizer has done its work, adjust pad values */
4150 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4153 assert(!CvCONST(cv));
4154 if (ps && !*ps && op_const_sv(block, cv))
4158 if (name || aname) {
4160 char *tname = (name ? name : aname);
4162 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4163 SV *sv = NEWSV(0,0);
4164 SV *tmpstr = sv_newmortal();
4165 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4169 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4171 (long)PL_subline, (long)CopLINE(PL_curcop));
4172 gv_efullname3(tmpstr, gv, Nullch);
4173 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4174 hv = GvHVn(db_postponed);
4175 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4176 && (pcv = GvCV(db_postponed)))
4182 call_sv((SV*)pcv, G_DISCARD);
4186 if ((s = strrchr(tname,':')))
4191 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4194 if (strEQ(s, "BEGIN")) {
4195 I32 oldscope = PL_scopestack_ix;
4197 SAVECOPFILE(&PL_compiling);
4198 SAVECOPLINE(&PL_compiling);
4201 PL_beginav = newAV();
4202 DEBUG_x( dump_sub(gv) );
4203 av_push(PL_beginav, (SV*)cv);
4204 GvCV(gv) = 0; /* cv has been hijacked */
4205 call_list(oldscope, PL_beginav);
4207 PL_curcop = &PL_compiling;
4208 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4211 else if (strEQ(s, "END") && !PL_error_count) {
4214 DEBUG_x( dump_sub(gv) );
4215 av_unshift(PL_endav, 1);
4216 av_store(PL_endav, 0, (SV*)cv);
4217 GvCV(gv) = 0; /* cv has been hijacked */
4219 else if (strEQ(s, "CHECK") && !PL_error_count) {
4221 PL_checkav = newAV();
4222 DEBUG_x( dump_sub(gv) );
4223 if (PL_main_start && ckWARN(WARN_VOID))
4224 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4225 av_unshift(PL_checkav, 1);
4226 av_store(PL_checkav, 0, (SV*)cv);
4227 GvCV(gv) = 0; /* cv has been hijacked */
4229 else if (strEQ(s, "INIT") && !PL_error_count) {
4231 PL_initav = newAV();
4232 DEBUG_x( dump_sub(gv) );
4233 if (PL_main_start && ckWARN(WARN_VOID))
4234 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4235 av_push(PL_initav, (SV*)cv);
4236 GvCV(gv) = 0; /* cv has been hijacked */
4241 PL_copline = NOLINE;
4246 /* XXX unsafe for threads if eval_owner isn't held */
4248 =for apidoc newCONSTSUB
4250 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4251 eligible for inlining at compile-time.
4257 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4263 SAVECOPLINE(PL_curcop);
4264 CopLINE_set(PL_curcop, PL_copline);
4267 PL_hints &= ~HINT_BLOCK_SCOPE;
4270 SAVESPTR(PL_curstash);
4271 SAVECOPSTASH(PL_curcop);
4272 PL_curstash = stash;
4273 CopSTASH_set(PL_curcop,stash);
4276 cv = newXS(name, const_sv_xsub, __FILE__);
4277 CvXSUBANY(cv).any_ptr = sv;
4279 sv_setpv((SV*)cv, ""); /* prototype is "" */
4287 =for apidoc U||newXS
4289 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4295 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
4297 GV *gv = gv_fetchpv(name ? name :
4298 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4299 GV_ADDMULTI, SVt_PVCV);
4303 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4305 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4307 /* just a cached method */
4311 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4312 /* already defined (or promised) */
4313 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4314 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4315 line_t oldline = CopLINE(PL_curcop);
4316 if (PL_copline != NOLINE)
4317 CopLINE_set(PL_curcop, PL_copline);
4318 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4319 CvCONST(cv) ? "Constant subroutine %s redefined"
4320 : "Subroutine %s redefined"
4322 CopLINE_set(PL_curcop, oldline);
4329 if (cv) /* must reuse cv if autoloaded */
4332 cv = (CV*)NEWSV(1105,0);
4333 sv_upgrade((SV *)cv, SVt_PVCV);
4337 PL_sub_generation++;
4341 (void)gv_fetchfile(filename);
4342 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
4343 an external constant string */
4344 CvXSUB(cv) = subaddr;
4347 char *s = strrchr(name,':');
4353 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4356 if (strEQ(s, "BEGIN")) {
4358 PL_beginav = newAV();
4359 av_push(PL_beginav, (SV*)cv);
4360 GvCV(gv) = 0; /* cv has been hijacked */
4362 else if (strEQ(s, "END")) {
4365 av_unshift(PL_endav, 1);
4366 av_store(PL_endav, 0, (SV*)cv);
4367 GvCV(gv) = 0; /* cv has been hijacked */
4369 else if (strEQ(s, "CHECK")) {
4371 PL_checkav = newAV();
4372 if (PL_main_start && ckWARN(WARN_VOID))
4373 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4374 av_unshift(PL_checkav, 1);
4375 av_store(PL_checkav, 0, (SV*)cv);
4376 GvCV(gv) = 0; /* cv has been hijacked */
4378 else if (strEQ(s, "INIT")) {
4380 PL_initav = newAV();
4381 if (PL_main_start && ckWARN(WARN_VOID))
4382 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4383 av_push(PL_initav, (SV*)cv);
4384 GvCV(gv) = 0; /* cv has been hijacked */
4395 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4403 name = SvPVx(cSVOPo->op_sv, n_a);
4406 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
4407 #ifdef GV_UNIQUE_CHECK
4409 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4413 if ((cv = GvFORM(gv))) {
4414 if (ckWARN(WARN_REDEFINE)) {
4415 line_t oldline = CopLINE(PL_curcop);
4416 if (PL_copline != NOLINE)
4417 CopLINE_set(PL_curcop, PL_copline);
4418 Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Format %s redefined",name);
4419 CopLINE_set(PL_curcop, oldline);
4426 CvFILE_set_from_cop(cv, PL_curcop);
4429 pad_tidy(padtidy_FORMAT);
4430 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4431 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4432 OpREFCNT_set(CvROOT(cv), 1);
4433 CvSTART(cv) = LINKLIST(CvROOT(cv));
4434 CvROOT(cv)->op_next = 0;
4435 CALL_PEEP(CvSTART(cv));
4437 PL_copline = NOLINE;
4442 Perl_newANONLIST(pTHX_ OP *o)
4444 return newUNOP(OP_REFGEN, 0,
4445 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4449 Perl_newANONHASH(pTHX_ OP *o)
4451 return newUNOP(OP_REFGEN, 0,
4452 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4456 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4458 return newANONATTRSUB(floor, proto, Nullop, block);
4462 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4464 return newUNOP(OP_REFGEN, 0,
4465 newSVOP(OP_ANONCODE, 0,
4466 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
4470 Perl_oopsAV(pTHX_ OP *o)
4472 switch (o->op_type) {
4474 o->op_type = OP_PADAV;
4475 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4476 return ref(o, OP_RV2AV);
4479 o->op_type = OP_RV2AV;
4480 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4485 if (ckWARN_d(WARN_INTERNAL))
4486 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
4493 Perl_oopsHV(pTHX_ OP *o)
4495 switch (o->op_type) {
4498 o->op_type = OP_PADHV;
4499 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4500 return ref(o, OP_RV2HV);
4504 o->op_type = OP_RV2HV;
4505 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
4510 if (ckWARN_d(WARN_INTERNAL))
4511 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
4518 Perl_newAVREF(pTHX_ OP *o)
4520 if (o->op_type == OP_PADANY) {
4521 o->op_type = OP_PADAV;
4522 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4525 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
4526 && ckWARN(WARN_DEPRECATED)) {
4527 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4528 "Using an array as a reference is deprecated");
4530 return newUNOP(OP_RV2AV, 0, scalar(o));
4534 Perl_newGVREF(pTHX_ I32 type, OP *o)
4536 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
4537 return newUNOP(OP_NULL, 0, o);
4538 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
4542 Perl_newHVREF(pTHX_ OP *o)
4544 if (o->op_type == OP_PADANY) {
4545 o->op_type = OP_PADHV;
4546 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4549 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
4550 && ckWARN(WARN_DEPRECATED)) {
4551 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4552 "Using a hash as a reference is deprecated");
4554 return newUNOP(OP_RV2HV, 0, scalar(o));
4558 Perl_oopsCV(pTHX_ OP *o)
4560 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
4566 Perl_newCVREF(pTHX_ I32 flags, OP *o)
4568 return newUNOP(OP_RV2CV, flags, scalar(o));
4572 Perl_newSVREF(pTHX_ OP *o)
4574 if (o->op_type == OP_PADANY) {
4575 o->op_type = OP_PADSV;
4576 o->op_ppaddr = PL_ppaddr[OP_PADSV];
4579 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4580 o->op_flags |= OPpDONE_SVREF;
4583 return newUNOP(OP_RV2SV, 0, scalar(o));
4586 /* Check routines. */
4589 Perl_ck_anoncode(pTHX_ OP *o)
4591 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
4592 cSVOPo->op_sv = Nullsv;
4597 Perl_ck_bitop(pTHX_ OP *o)
4599 #define OP_IS_NUMCOMPARE(op) \
4600 ((op) == OP_LT || (op) == OP_I_LT || \
4601 (op) == OP_GT || (op) == OP_I_GT || \
4602 (op) == OP_LE || (op) == OP_I_LE || \
4603 (op) == OP_GE || (op) == OP_I_GE || \
4604 (op) == OP_EQ || (op) == OP_I_EQ || \
4605 (op) == OP_NE || (op) == OP_I_NE || \
4606 (op) == OP_NCMP || (op) == OP_I_NCMP)
4607 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4608 if (o->op_type == OP_BIT_OR
4609 || o->op_type == OP_BIT_AND
4610 || o->op_type == OP_BIT_XOR)
4612 OPCODE typfirst = cBINOPo->op_first->op_type;
4613 OPCODE typlast = cBINOPo->op_first->op_sibling->op_type;
4614 if (OP_IS_NUMCOMPARE(typfirst) || OP_IS_NUMCOMPARE(typlast))
4615 if (ckWARN(WARN_PRECEDENCE))
4616 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4617 "Possible precedence problem on bitwise %c operator",
4618 o->op_type == OP_BIT_OR ? '|'
4619 : o->op_type == OP_BIT_AND ? '&' : '^'
4626 Perl_ck_concat(pTHX_ OP *o)
4628 if (cUNOPo->op_first->op_type == OP_CONCAT)
4629 o->op_flags |= OPf_STACKED;
4634 Perl_ck_spair(pTHX_ OP *o)
4636 if (o->op_flags & OPf_KIDS) {
4639 OPCODE type = o->op_type;
4640 o = modkids(ck_fun(o), type);
4641 kid = cUNOPo->op_first;
4642 newop = kUNOP->op_first->op_sibling;
4644 (newop->op_sibling ||
4645 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
4646 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
4647 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
4651 op_free(kUNOP->op_first);
4652 kUNOP->op_first = newop;
4654 o->op_ppaddr = PL_ppaddr[++o->op_type];
4659 Perl_ck_delete(pTHX_ OP *o)
4663 if (o->op_flags & OPf_KIDS) {
4664 OP *kid = cUNOPo->op_first;
4665 switch (kid->op_type) {
4667 o->op_flags |= OPf_SPECIAL;
4670 o->op_private |= OPpSLICE;
4673 o->op_flags |= OPf_SPECIAL;
4678 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
4687 Perl_ck_die(pTHX_ OP *o)
4690 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4696 Perl_ck_eof(pTHX_ OP *o)
4698 I32 type = o->op_type;
4700 if (o->op_flags & OPf_KIDS) {
4701 if (cLISTOPo->op_first->op_type == OP_STUB) {
4703 o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
4711 Perl_ck_eval(pTHX_ OP *o)
4713 PL_hints |= HINT_BLOCK_SCOPE;
4714 if (o->op_flags & OPf_KIDS) {
4715 SVOP *kid = (SVOP*)cUNOPo->op_first;
4718 o->op_flags &= ~OPf_KIDS;
4721 else if (kid->op_type == OP_LINESEQ) {
4724 kid->op_next = o->op_next;
4725 cUNOPo->op_first = 0;
4728 NewOp(1101, enter, 1, LOGOP);
4729 enter->op_type = OP_ENTERTRY;
4730 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
4731 enter->op_private = 0;
4733 /* establish postfix order */
4734 enter->op_next = (OP*)enter;
4736 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
4737 o->op_type = OP_LEAVETRY;
4738 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
4739 enter->op_other = o;
4747 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
4749 o->op_targ = (PADOFFSET)PL_hints;
4754 Perl_ck_exit(pTHX_ OP *o)
4757 HV *table = GvHV(PL_hintgv);
4759 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
4760 if (svp && *svp && SvTRUE(*svp))
4761 o->op_private |= OPpEXIT_VMSISH;
4763 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4769 Perl_ck_exec(pTHX_ OP *o)
4772 if (o->op_flags & OPf_STACKED) {
4774 kid = cUNOPo->op_first->op_sibling;
4775 if (kid->op_type == OP_RV2GV)
4784 Perl_ck_exists(pTHX_ OP *o)
4787 if (o->op_flags & OPf_KIDS) {
4788 OP *kid = cUNOPo->op_first;
4789 if (kid->op_type == OP_ENTERSUB) {
4790 (void) ref(kid, o->op_type);
4791 if (kid->op_type != OP_RV2CV && !PL_error_count)
4792 Perl_croak(aTHX_ "%s argument is not a subroutine name",
4794 o->op_private |= OPpEXISTS_SUB;
4796 else if (kid->op_type == OP_AELEM)
4797 o->op_flags |= OPf_SPECIAL;
4798 else if (kid->op_type != OP_HELEM)
4799 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
4808 Perl_ck_gvconst(pTHX_ register OP *o)
4810 o = fold_constants(o);
4811 if (o->op_type == OP_CONST)
4818 Perl_ck_rvconst(pTHX_ register OP *o)
4820 SVOP *kid = (SVOP*)cUNOPo->op_first;
4822 o->op_private |= (PL_hints & HINT_STRICT_REFS);
4823 if (kid->op_type == OP_CONST) {
4827 SV *kidsv = kid->op_sv;
4830 /* Is it a constant from cv_const_sv()? */
4831 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
4832 SV *rsv = SvRV(kidsv);
4833 int svtype = SvTYPE(rsv);
4834 char *badtype = Nullch;
4836 switch (o->op_type) {
4838 if (svtype > SVt_PVMG)
4839 badtype = "a SCALAR";
4842 if (svtype != SVt_PVAV)
4843 badtype = "an ARRAY";
4846 if (svtype != SVt_PVHV)
4850 if (svtype != SVt_PVCV)
4855 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
4858 name = SvPV(kidsv, n_a);
4859 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
4860 char *badthing = Nullch;
4861 switch (o->op_type) {
4863 badthing = "a SCALAR";
4866 badthing = "an ARRAY";
4869 badthing = "a HASH";
4874 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
4878 * This is a little tricky. We only want to add the symbol if we
4879 * didn't add it in the lexer. Otherwise we get duplicate strict
4880 * warnings. But if we didn't add it in the lexer, we must at
4881 * least pretend like we wanted to add it even if it existed before,
4882 * or we get possible typo warnings. OPpCONST_ENTERED says
4883 * whether the lexer already added THIS instance of this symbol.
4885 iscv = (o->op_type == OP_RV2CV) * 2;
4887 gv = gv_fetchpv(name,
4888 iscv | !(kid->op_private & OPpCONST_ENTERED),
4891 : o->op_type == OP_RV2SV
4893 : o->op_type == OP_RV2AV
4895 : o->op_type == OP_RV2HV
4898 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
4900 kid->op_type = OP_GV;
4901 SvREFCNT_dec(kid->op_sv);
4903 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
4904 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
4905 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
4907 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
4909 kid->op_sv = SvREFCNT_inc(gv);
4911 kid->op_private = 0;
4912 kid->op_ppaddr = PL_ppaddr[OP_GV];
4919 Perl_ck_ftst(pTHX_ OP *o)
4921 I32 type = o->op_type;
4923 if (o->op_flags & OPf_REF) {
4926 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
4927 SVOP *kid = (SVOP*)cUNOPo->op_first;
4929 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
4931 OP *newop = newGVOP(type, OPf_REF,
4932 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
4939 if (type == OP_FTTTY)
4940 o = newGVOP(type, OPf_REF, PL_stdingv);
4942 o = newUNOP(type, 0, newDEFSVOP());
4948 Perl_ck_fun(pTHX_ OP *o)
4954 int type = o->op_type;
4955 register I32 oa = PL_opargs[type] >> OASHIFT;
4957 if (o->op_flags & OPf_STACKED) {
4958 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
4961 return no_fh_allowed(o);
4964 if (o->op_flags & OPf_KIDS) {
4966 tokid = &cLISTOPo->op_first;
4967 kid = cLISTOPo->op_first;
4968 if (kid->op_type == OP_PUSHMARK ||
4969 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
4971 tokid = &kid->op_sibling;
4972 kid = kid->op_sibling;
4974 if (!kid && PL_opargs[type] & OA_DEFGV)
4975 *tokid = kid = newDEFSVOP();
4979 sibl = kid->op_sibling;
4982 /* list seen where single (scalar) arg expected? */
4983 if (numargs == 1 && !(oa >> 4)
4984 && kid->op_type == OP_LIST && type != OP_SCALAR)
4986 return too_many_arguments(o,PL_op_desc[type]);
4999 if ((type == OP_PUSH || type == OP_UNSHIFT)
5000 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5001 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5002 "Useless use of %s with no values",
5005 if (kid->op_type == OP_CONST &&
5006 (kid->op_private & OPpCONST_BARE))
5008 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5009 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5010 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5011 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5012 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5013 "Array @%s missing the @ in argument %"IVdf" of %s()",
5014 name, (IV)numargs, PL_op_desc[type]);
5017 kid->op_sibling = sibl;
5020 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5021 bad_type(numargs, "array", PL_op_desc[type], kid);
5025 if (kid->op_type == OP_CONST &&
5026 (kid->op_private & OPpCONST_BARE))
5028 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5029 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5030 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5031 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5032 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5033 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5034 name, (IV)numargs, PL_op_desc[type]);
5037 kid->op_sibling = sibl;
5040 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5041 bad_type(numargs, "hash", PL_op_desc[type], kid);
5046 OP *newop = newUNOP(OP_NULL, 0, kid);
5047 kid->op_sibling = 0;
5049 newop->op_next = newop;
5051 kid->op_sibling = sibl;
5056 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5057 if (kid->op_type == OP_CONST &&
5058 (kid->op_private & OPpCONST_BARE))
5060 OP *newop = newGVOP(OP_GV, 0,
5061 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5063 if (!(o->op_private & 1) && /* if not unop */
5064 kid == cLISTOPo->op_last)
5065 cLISTOPo->op_last = newop;
5069 else if (kid->op_type == OP_READLINE) {
5070 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5071 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5074 I32 flags = OPf_SPECIAL;
5078 /* is this op a FH constructor? */
5079 if (is_handle_constructor(o,numargs)) {
5080 char *name = Nullch;
5084 /* Set a flag to tell rv2gv to vivify
5085 * need to "prove" flag does not mean something
5086 * else already - NI-S 1999/05/07
5089 if (kid->op_type == OP_PADSV) {
5090 /*XXX DAPM 2002.08.25 tmp assert test */
5091 /*XXX*/ assert(av_fetch(PL_comppad_name, (kid->op_targ), FALSE));
5092 /*XXX*/ assert(*av_fetch(PL_comppad_name, (kid->op_targ), FALSE));
5094 name = PAD_COMPNAME_PV(kid->op_targ);
5095 /* SvCUR of a pad namesv can't be trusted
5096 * (see PL_generation), so calc its length
5102 else if (kid->op_type == OP_RV2SV
5103 && kUNOP->op_first->op_type == OP_GV)
5105 GV *gv = cGVOPx_gv(kUNOP->op_first);
5107 len = GvNAMELEN(gv);
5109 else if (kid->op_type == OP_AELEM
5110 || kid->op_type == OP_HELEM)
5112 name = "__ANONIO__";
5118 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5119 namesv = PAD_SVl(targ);
5120 (void)SvUPGRADE(namesv, SVt_PV);
5122 sv_setpvn(namesv, "$", 1);
5123 sv_catpvn(namesv, name, len);
5126 kid->op_sibling = 0;
5127 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5128 kid->op_targ = targ;
5129 kid->op_private |= priv;
5131 kid->op_sibling = sibl;
5137 mod(scalar(kid), type);
5141 tokid = &kid->op_sibling;
5142 kid = kid->op_sibling;
5144 o->op_private |= numargs;
5146 return too_many_arguments(o,OP_DESC(o));
5149 else if (PL_opargs[type] & OA_DEFGV) {
5151 return newUNOP(type, 0, newDEFSVOP());
5155 while (oa & OA_OPTIONAL)
5157 if (oa && oa != OA_LIST)
5158 return too_few_arguments(o,OP_DESC(o));
5164 Perl_ck_glob(pTHX_ OP *o)
5169 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5170 append_elem(OP_GLOB, o, newDEFSVOP());
5172 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5173 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5175 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5178 #if !defined(PERL_EXTERNAL_GLOB)
5179 /* XXX this can be tightened up and made more failsafe. */
5183 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5184 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5185 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5186 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5187 GvCV(gv) = GvCV(glob_gv);
5188 SvREFCNT_inc((SV*)GvCV(gv));
5189 GvIMPORTED_CV_on(gv);
5192 #endif /* PERL_EXTERNAL_GLOB */
5194 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5195 append_elem(OP_GLOB, o,
5196 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5197 o->op_type = OP_LIST;
5198 o->op_ppaddr = PL_ppaddr[OP_LIST];
5199 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5200 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5201 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5202 append_elem(OP_LIST, o,
5203 scalar(newUNOP(OP_RV2CV, 0,
5204 newGVOP(OP_GV, 0, gv)))));
5205 o = newUNOP(OP_NULL, 0, ck_subr(o));
5206 o->op_targ = OP_GLOB; /* hint at what it used to be */
5209 gv = newGVgen("main");
5211 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5217 Perl_ck_grep(pTHX_ OP *o)
5221 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5223 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5224 NewOp(1101, gwop, 1, LOGOP);
5226 if (o->op_flags & OPf_STACKED) {
5229 kid = cLISTOPo->op_first->op_sibling;
5230 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5233 kid->op_next = (OP*)gwop;
5234 o->op_flags &= ~OPf_STACKED;
5236 kid = cLISTOPo->op_first->op_sibling;
5237 if (type == OP_MAPWHILE)
5244 kid = cLISTOPo->op_first->op_sibling;
5245 if (kid->op_type != OP_NULL)
5246 Perl_croak(aTHX_ "panic: ck_grep");
5247 kid = kUNOP->op_first;
5249 gwop->op_type = type;
5250 gwop->op_ppaddr = PL_ppaddr[type];
5251 gwop->op_first = listkids(o);
5252 gwop->op_flags |= OPf_KIDS;
5253 gwop->op_private = 1;
5254 gwop->op_other = LINKLIST(kid);
5255 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5256 kid->op_next = (OP*)gwop;
5258 kid = cLISTOPo->op_first->op_sibling;
5259 if (!kid || !kid->op_sibling)
5260 return too_few_arguments(o,OP_DESC(o));
5261 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5262 mod(kid, OP_GREPSTART);
5268 Perl_ck_index(pTHX_ OP *o)
5270 if (o->op_flags & OPf_KIDS) {
5271 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5273 kid = kid->op_sibling; /* get past "big" */
5274 if (kid && kid->op_type == OP_CONST)
5275 fbm_compile(((SVOP*)kid)->op_sv, 0);
5281 Perl_ck_lengthconst(pTHX_ OP *o)
5283 /* XXX length optimization goes here */
5288 Perl_ck_lfun(pTHX_ OP *o)
5290 OPCODE type = o->op_type;
5291 return modkids(ck_fun(o), type);
5295 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5297 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5298 switch (cUNOPo->op_first->op_type) {
5300 /* This is needed for
5301 if (defined %stash::)
5302 to work. Do not break Tk.
5304 break; /* Globals via GV can be undef */
5306 case OP_AASSIGN: /* Is this a good idea? */
5307 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5308 "defined(@array) is deprecated");
5309 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5310 "\t(Maybe you should just omit the defined()?)\n");
5313 /* This is needed for
5314 if (defined %stash::)
5315 to work. Do not break Tk.
5317 break; /* Globals via GV can be undef */
5319 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5320 "defined(%%hash) is deprecated");
5321 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5322 "\t(Maybe you should just omit the defined()?)\n");
5333 Perl_ck_rfun(pTHX_ OP *o)
5335 OPCODE type = o->op_type;
5336 return refkids(ck_fun(o), type);
5340 Perl_ck_listiob(pTHX_ OP *o)
5344 kid = cLISTOPo->op_first;
5347 kid = cLISTOPo->op_first;
5349 if (kid->op_type == OP_PUSHMARK)
5350 kid = kid->op_sibling;
5351 if (kid && o->op_flags & OPf_STACKED)
5352 kid = kid->op_sibling;
5353 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5354 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5355 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5356 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5357 cLISTOPo->op_first->op_sibling = kid;
5358 cLISTOPo->op_last = kid;
5359 kid = kid->op_sibling;
5364 append_elem(o->op_type, o, newDEFSVOP());
5370 Perl_ck_sassign(pTHX_ OP *o)
5372 OP *kid = cLISTOPo->op_first;
5373 /* has a disposable target? */
5374 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5375 && !(kid->op_flags & OPf_STACKED)
5376 /* Cannot steal the second time! */
5377 && !(kid->op_private & OPpTARGET_MY))
5379 OP *kkid = kid->op_sibling;
5381 /* Can just relocate the target. */
5382 if (kkid && kkid->op_type == OP_PADSV
5383 && !(kkid->op_private & OPpLVAL_INTRO))
5385 kid->op_targ = kkid->op_targ;
5387 /* Now we do not need PADSV and SASSIGN. */
5388 kid->op_sibling = o->op_sibling; /* NULL */
5389 cLISTOPo->op_first = NULL;
5392 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
5400 Perl_ck_match(pTHX_ OP *o)
5402 o->op_private |= OPpRUNTIME;
5407 Perl_ck_method(pTHX_ OP *o)
5409 OP *kid = cUNOPo->op_first;
5410 if (kid->op_type == OP_CONST) {
5411 SV* sv = kSVOP->op_sv;
5412 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
5414 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5415 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
5418 kSVOP->op_sv = Nullsv;
5420 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5429 Perl_ck_null(pTHX_ OP *o)
5435 Perl_ck_open(pTHX_ OP *o)
5437 HV *table = GvHV(PL_hintgv);
5441 svp = hv_fetch(table, "open_IN", 7, FALSE);
5443 mode = mode_from_discipline(*svp);
5444 if (mode & O_BINARY)
5445 o->op_private |= OPpOPEN_IN_RAW;
5446 else if (mode & O_TEXT)
5447 o->op_private |= OPpOPEN_IN_CRLF;
5450 svp = hv_fetch(table, "open_OUT", 8, FALSE);
5452 mode = mode_from_discipline(*svp);
5453 if (mode & O_BINARY)
5454 o->op_private |= OPpOPEN_OUT_RAW;
5455 else if (mode & O_TEXT)
5456 o->op_private |= OPpOPEN_OUT_CRLF;
5459 if (o->op_type == OP_BACKTICK)
5465 Perl_ck_repeat(pTHX_ OP *o)
5467 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5468 o->op_private |= OPpREPEAT_DOLIST;
5469 cBINOPo->op_first = force_list(cBINOPo->op_first);
5477 Perl_ck_require(pTHX_ OP *o)
5481 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
5482 SVOP *kid = (SVOP*)cUNOPo->op_first;
5484 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5486 for (s = SvPVX(kid->op_sv); *s; s++) {
5487 if (*s == ':' && s[1] == ':') {
5489 Move(s+2, s+1, strlen(s+2)+1, char);
5490 --SvCUR(kid->op_sv);
5493 if (SvREADONLY(kid->op_sv)) {
5494 SvREADONLY_off(kid->op_sv);
5495 sv_catpvn(kid->op_sv, ".pm", 3);
5496 SvREADONLY_on(kid->op_sv);
5499 sv_catpvn(kid->op_sv, ".pm", 3);
5503 /* handle override, if any */
5504 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
5505 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
5506 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
5508 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5509 OP *kid = cUNOPo->op_first;
5510 cUNOPo->op_first = 0;
5512 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5513 append_elem(OP_LIST, kid,
5514 scalar(newUNOP(OP_RV2CV, 0,
5523 Perl_ck_return(pTHX_ OP *o)
5526 if (CvLVALUE(PL_compcv)) {
5527 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5528 mod(kid, OP_LEAVESUBLV);
5535 Perl_ck_retarget(pTHX_ OP *o)
5537 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5544 Perl_ck_select(pTHX_ OP *o)
5547 if (o->op_flags & OPf_KIDS) {
5548 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5549 if (kid && kid->op_sibling) {
5550 o->op_type = OP_SSELECT;
5551 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
5553 return fold_constants(o);
5557 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5558 if (kid && kid->op_type == OP_RV2GV)
5559 kid->op_private &= ~HINT_STRICT_REFS;
5564 Perl_ck_shift(pTHX_ OP *o)
5566 I32 type = o->op_type;
5568 if (!(o->op_flags & OPf_KIDS)) {
5572 argop = newUNOP(OP_RV2AV, 0,
5573 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
5574 return newUNOP(type, 0, scalar(argop));
5576 return scalar(modkids(ck_fun(o), type));
5580 Perl_ck_sort(pTHX_ OP *o)
5584 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
5586 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5587 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
5589 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
5591 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
5593 if (kid->op_type == OP_SCOPE) {
5597 else if (kid->op_type == OP_LEAVE) {
5598 if (o->op_type == OP_SORT) {
5599 op_null(kid); /* wipe out leave */
5602 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
5603 if (k->op_next == kid)
5605 /* don't descend into loops */
5606 else if (k->op_type == OP_ENTERLOOP
5607 || k->op_type == OP_ENTERITER)
5609 k = cLOOPx(k)->op_lastop;
5614 kid->op_next = 0; /* just disconnect the leave */
5615 k = kLISTOP->op_first;
5620 if (o->op_type == OP_SORT) {
5621 /* provide scalar context for comparison function/block */
5627 o->op_flags |= OPf_SPECIAL;
5629 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
5632 firstkid = firstkid->op_sibling;
5635 /* provide list context for arguments */
5636 if (o->op_type == OP_SORT)
5643 S_simplify_sort(pTHX_ OP *o)
5645 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5649 if (!(o->op_flags & OPf_STACKED))
5651 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
5652 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
5653 kid = kUNOP->op_first; /* get past null */
5654 if (kid->op_type != OP_SCOPE)
5656 kid = kLISTOP->op_last; /* get past scope */
5657 switch(kid->op_type) {
5665 k = kid; /* remember this node*/
5666 if (kBINOP->op_first->op_type != OP_RV2SV)
5668 kid = kBINOP->op_first; /* get past cmp */
5669 if (kUNOP->op_first->op_type != OP_GV)
5671 kid = kUNOP->op_first; /* get past rv2sv */
5673 if (GvSTASH(gv) != PL_curstash)
5675 if (strEQ(GvNAME(gv), "a"))
5677 else if (strEQ(GvNAME(gv), "b"))
5681 kid = k; /* back to cmp */
5682 if (kBINOP->op_last->op_type != OP_RV2SV)
5684 kid = kBINOP->op_last; /* down to 2nd arg */
5685 if (kUNOP->op_first->op_type != OP_GV)
5687 kid = kUNOP->op_first; /* get past rv2sv */
5689 if (GvSTASH(gv) != PL_curstash
5691 ? strNE(GvNAME(gv), "a")
5692 : strNE(GvNAME(gv), "b")))
5694 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
5696 o->op_private |= OPpSORT_REVERSE;
5697 if (k->op_type == OP_NCMP)
5698 o->op_private |= OPpSORT_NUMERIC;
5699 if (k->op_type == OP_I_NCMP)
5700 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
5701 kid = cLISTOPo->op_first->op_sibling;
5702 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
5703 op_free(kid); /* then delete it */
5707 Perl_ck_split(pTHX_ OP *o)
5711 if (o->op_flags & OPf_STACKED)
5712 return no_fh_allowed(o);
5714 kid = cLISTOPo->op_first;
5715 if (kid->op_type != OP_NULL)
5716 Perl_croak(aTHX_ "panic: ck_split");
5717 kid = kid->op_sibling;
5718 op_free(cLISTOPo->op_first);
5719 cLISTOPo->op_first = kid;
5721 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
5722 cLISTOPo->op_last = kid; /* There was only one element previously */
5725 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
5726 OP *sibl = kid->op_sibling;
5727 kid->op_sibling = 0;
5728 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
5729 if (cLISTOPo->op_first == cLISTOPo->op_last)
5730 cLISTOPo->op_last = kid;
5731 cLISTOPo->op_first = kid;
5732 kid->op_sibling = sibl;
5735 kid->op_type = OP_PUSHRE;
5736 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
5738 if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
5739 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
5740 "Use of /g modifier is meaningless in split");
5743 if (!kid->op_sibling)
5744 append_elem(OP_SPLIT, o, newDEFSVOP());
5746 kid = kid->op_sibling;
5749 if (!kid->op_sibling)
5750 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
5752 kid = kid->op_sibling;
5755 if (kid->op_sibling)
5756 return too_many_arguments(o,OP_DESC(o));
5762 Perl_ck_join(pTHX_ OP *o)
5764 if (ckWARN(WARN_SYNTAX)) {
5765 OP *kid = cLISTOPo->op_first->op_sibling;
5766 if (kid && kid->op_type == OP_MATCH) {
5767 char *pmstr = "STRING";
5768 if (PM_GETRE(kPMOP))
5769 pmstr = PM_GETRE(kPMOP)->precomp;
5770 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5771 "/%s/ should probably be written as \"%s\"",
5779 Perl_ck_subr(pTHX_ OP *o)
5781 OP *prev = ((cUNOPo->op_first->op_sibling)
5782 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
5783 OP *o2 = prev->op_sibling;
5790 I32 contextclass = 0;
5795 o->op_private |= OPpENTERSUB_HASTARG;
5796 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
5797 if (cvop->op_type == OP_RV2CV) {
5799 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
5800 op_null(cvop); /* disable rv2cv */
5801 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
5802 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
5803 GV *gv = cGVOPx_gv(tmpop);
5806 tmpop->op_private |= OPpEARLY_CV;
5809 namegv = CvANON(cv) ? gv : CvGV(cv);
5810 proto = SvPV((SV*)cv, n_a);
5812 if (CvASSERTION(cv)) {
5813 if (PL_hints & HINT_ASSERTING) {
5814 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
5815 o->op_private |= OPpENTERSUB_DB;
5822 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
5823 if (o2->op_type == OP_CONST)
5824 o2->op_private &= ~OPpCONST_STRICT;
5825 else if (o2->op_type == OP_LIST) {
5826 OP *o = ((UNOP*)o2)->op_first->op_sibling;
5827 if (o && o->op_type == OP_CONST)
5828 o->op_private &= ~OPpCONST_STRICT;
5831 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5832 if (PERLDB_SUB && PL_curstash != PL_debstash)
5833 o->op_private |= OPpENTERSUB_DB;
5834 while (o2 != cvop) {
5838 return too_many_arguments(o, gv_ename(namegv));
5856 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
5858 arg == 1 ? "block or sub {}" : "sub {}",
5859 gv_ename(namegv), o2);
5862 /* '*' allows any scalar type, including bareword */
5865 if (o2->op_type == OP_RV2GV)
5866 goto wrapref; /* autoconvert GLOB -> GLOBref */
5867 else if (o2->op_type == OP_CONST)
5868 o2->op_private &= ~OPpCONST_STRICT;
5869 else if (o2->op_type == OP_ENTERSUB) {
5870 /* accidental subroutine, revert to bareword */
5871 OP *gvop = ((UNOP*)o2)->op_first;
5872 if (gvop && gvop->op_type == OP_NULL) {
5873 gvop = ((UNOP*)gvop)->op_first;
5875 for (; gvop->op_sibling; gvop = gvop->op_sibling)
5878 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
5879 (gvop = ((UNOP*)gvop)->op_first) &&
5880 gvop->op_type == OP_GV)
5882 GV *gv = cGVOPx_gv(gvop);
5883 OP *sibling = o2->op_sibling;
5884 SV *n = newSVpvn("",0);
5886 gv_fullname3(n, gv, "");
5887 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
5888 sv_chop(n, SvPVX(n)+6);
5889 o2 = newSVOP(OP_CONST, 0, n);
5890 prev->op_sibling = o2;
5891 o2->op_sibling = sibling;
5907 if (contextclass++ == 0) {
5908 e = strchr(proto, ']');
5909 if (!e || e == proto)
5922 while (*--p != '[');
5923 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
5924 gv_ename(namegv), o2);
5930 if (o2->op_type == OP_RV2GV)
5933 bad_type(arg, "symbol", gv_ename(namegv), o2);
5936 if (o2->op_type == OP_ENTERSUB)
5939 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
5942 if (o2->op_type == OP_RV2SV ||
5943 o2->op_type == OP_PADSV ||
5944 o2->op_type == OP_HELEM ||
5945 o2->op_type == OP_AELEM ||
5946 o2->op_type == OP_THREADSV)
5949 bad_type(arg, "scalar", gv_ename(namegv), o2);
5952 if (o2->op_type == OP_RV2AV ||
5953 o2->op_type == OP_PADAV)
5956 bad_type(arg, "array", gv_ename(namegv), o2);
5959 if (o2->op_type == OP_RV2HV ||
5960 o2->op_type == OP_PADHV)
5963 bad_type(arg, "hash", gv_ename(namegv), o2);
5968 OP* sib = kid->op_sibling;
5969 kid->op_sibling = 0;
5970 o2 = newUNOP(OP_REFGEN, 0, kid);
5971 o2->op_sibling = sib;
5972 prev->op_sibling = o2;
5974 if (contextclass && e) {
5989 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
5990 gv_ename(namegv), cv);
5995 mod(o2, OP_ENTERSUB);
5997 o2 = o2->op_sibling;
5999 if (proto && !optional &&
6000 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6001 return too_few_arguments(o, gv_ename(namegv));
6004 o=newSVOP(OP_CONST, 0, newSViv(0));
6010 Perl_ck_svconst(pTHX_ OP *o)
6012 SvREADONLY_on(cSVOPo->op_sv);
6017 Perl_ck_trunc(pTHX_ OP *o)
6019 if (o->op_flags & OPf_KIDS) {
6020 SVOP *kid = (SVOP*)cUNOPo->op_first;
6022 if (kid->op_type == OP_NULL)
6023 kid = (SVOP*)kid->op_sibling;
6024 if (kid && kid->op_type == OP_CONST &&
6025 (kid->op_private & OPpCONST_BARE))
6027 o->op_flags |= OPf_SPECIAL;
6028 kid->op_private &= ~OPpCONST_STRICT;
6035 Perl_ck_substr(pTHX_ OP *o)
6038 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6039 OP *kid = cLISTOPo->op_first;
6041 if (kid->op_type == OP_NULL)
6042 kid = kid->op_sibling;
6044 kid->op_flags |= OPf_MOD;
6050 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6053 Perl_peep(pTHX_ register OP *o)
6055 register OP* oldop = 0;
6057 if (!o || o->op_seq)
6061 SAVEVPTR(PL_curcop);
6062 for (; o; o = o->op_next) {
6065 /* The special value -1 is used by the B::C compiler backend to indicate
6066 * that an op is statically defined and should not be freed */
6067 if (!PL_op_seqmax || PL_op_seqmax == (U16)-1)
6070 switch (o->op_type) {
6074 PL_curcop = ((COP*)o); /* for warnings */
6075 o->op_seq = PL_op_seqmax++;
6079 if (cSVOPo->op_private & OPpCONST_STRICT)
6080 no_bareword_allowed(o);
6082 case OP_METHOD_NAMED:
6083 /* Relocate sv to the pad for thread safety.
6084 * Despite being a "constant", the SV is written to,
6085 * for reference counts, sv_upgrade() etc. */
6087 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6088 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6089 /* If op_sv is already a PADTMP then it is being used by
6090 * some pad, so make a copy. */
6091 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6092 SvREADONLY_on(PAD_SVl(ix));
6093 SvREFCNT_dec(cSVOPo->op_sv);
6096 SvREFCNT_dec(PAD_SVl(ix));
6097 SvPADTMP_on(cSVOPo->op_sv);
6098 PAD_SETSV(ix, cSVOPo->op_sv);
6099 /* XXX I don't know how this isn't readonly already. */
6100 SvREADONLY_on(PAD_SVl(ix));
6102 cSVOPo->op_sv = Nullsv;
6106 o->op_seq = PL_op_seqmax++;
6110 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6111 if (o->op_next->op_private & OPpTARGET_MY) {
6112 if (o->op_flags & OPf_STACKED) /* chained concats */
6113 goto ignore_optimization;
6115 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6116 o->op_targ = o->op_next->op_targ;
6117 o->op_next->op_targ = 0;
6118 o->op_private |= OPpTARGET_MY;
6121 op_null(o->op_next);
6123 ignore_optimization:
6124 o->op_seq = PL_op_seqmax++;
6127 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6128 o->op_seq = PL_op_seqmax++;
6129 break; /* Scalar stub must produce undef. List stub is noop */
6133 if (o->op_targ == OP_NEXTSTATE
6134 || o->op_targ == OP_DBSTATE
6135 || o->op_targ == OP_SETSTATE)
6137 PL_curcop = ((COP*)o);
6139 /* XXX: We avoid setting op_seq here to prevent later calls
6140 to peep() from mistakenly concluding that optimisation
6141 has already occurred. This doesn't fix the real problem,
6142 though (See 20010220.007). AMS 20010719 */
6143 if (oldop && o->op_next) {
6144 oldop->op_next = o->op_next;
6152 if (oldop && o->op_next) {
6153 oldop->op_next = o->op_next;
6156 o->op_seq = PL_op_seqmax++;
6160 if (o->op_next->op_type == OP_RV2SV) {
6161 if (!(o->op_next->op_private & OPpDEREF)) {
6162 op_null(o->op_next);
6163 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6165 o->op_next = o->op_next->op_next;
6166 o->op_type = OP_GVSV;
6167 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6170 else if (o->op_next->op_type == OP_RV2AV) {
6171 OP* pop = o->op_next->op_next;
6173 if (pop && pop->op_type == OP_CONST &&
6174 (PL_op = pop->op_next) &&
6175 pop->op_next->op_type == OP_AELEM &&
6176 !(pop->op_next->op_private &
6177 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6178 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6183 op_null(o->op_next);
6184 op_null(pop->op_next);
6186 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6187 o->op_next = pop->op_next->op_next;
6188 o->op_type = OP_AELEMFAST;
6189 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6190 o->op_private = (U8)i;
6195 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6197 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6198 /* XXX could check prototype here instead of just carping */
6199 SV *sv = sv_newmortal();
6200 gv_efullname3(sv, gv, Nullch);
6201 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6202 "%"SVf"() called too early to check prototype",
6206 else if (o->op_next->op_type == OP_READLINE
6207 && o->op_next->op_next->op_type == OP_CONCAT
6208 && (o->op_next->op_next->op_flags & OPf_STACKED))
6210 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6211 o->op_type = OP_RCATLINE;
6212 o->op_flags |= OPf_STACKED;
6213 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6214 op_null(o->op_next->op_next);
6215 op_null(o->op_next);
6218 o->op_seq = PL_op_seqmax++;
6231 o->op_seq = PL_op_seqmax++;
6232 while (cLOGOP->op_other->op_type == OP_NULL)
6233 cLOGOP->op_other = cLOGOP->op_other->op_next;
6234 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6239 o->op_seq = PL_op_seqmax++;
6240 while (cLOOP->op_redoop->op_type == OP_NULL)
6241 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6242 peep(cLOOP->op_redoop);
6243 while (cLOOP->op_nextop->op_type == OP_NULL)
6244 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6245 peep(cLOOP->op_nextop);
6246 while (cLOOP->op_lastop->op_type == OP_NULL)
6247 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6248 peep(cLOOP->op_lastop);
6254 o->op_seq = PL_op_seqmax++;
6255 while (cPMOP->op_pmreplstart &&
6256 cPMOP->op_pmreplstart->op_type == OP_NULL)
6257 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6258 peep(cPMOP->op_pmreplstart);
6262 o->op_seq = PL_op_seqmax++;
6263 if (ckWARN(WARN_SYNTAX) && o->op_next
6264 && o->op_next->op_type == OP_NEXTSTATE) {
6265 if (o->op_next->op_sibling &&
6266 o->op_next->op_sibling->op_type != OP_EXIT &&
6267 o->op_next->op_sibling->op_type != OP_WARN &&
6268 o->op_next->op_sibling->op_type != OP_DIE) {
6269 line_t oldline = CopLINE(PL_curcop);
6271 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6272 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6273 "Statement unlikely to be reached");
6274 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6275 "\t(Maybe you meant system() when you said exec()?)\n");
6276 CopLINE_set(PL_curcop, oldline);
6287 o->op_seq = PL_op_seqmax++;
6289 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6292 /* Make the CONST have a shared SV */
6293 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6294 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6295 key = SvPV(sv, keylen);
6296 lexname = newSVpvn_share(key,
6297 SvUTF8(sv) ? -(I32)keylen : keylen,
6306 o->op_seq = PL_op_seqmax++;
6316 char* Perl_custom_op_name(pTHX_ OP* o)
6318 IV index = PTR2IV(o->op_ppaddr);
6322 if (!PL_custom_op_names) /* This probably shouldn't happen */
6323 return PL_op_name[OP_CUSTOM];
6325 keysv = sv_2mortal(newSViv(index));
6327 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
6329 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
6331 return SvPV_nolen(HeVAL(he));
6334 char* Perl_custom_op_desc(pTHX_ OP* o)
6336 IV index = PTR2IV(o->op_ppaddr);
6340 if (!PL_custom_op_descs)
6341 return PL_op_desc[OP_CUSTOM];
6343 keysv = sv_2mortal(newSViv(index));
6345 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
6347 return PL_op_desc[OP_CUSTOM];
6349 return SvPV_nolen(HeVAL(he));
6355 /* Efficient sub that returns a constant scalar value. */
6357 const_sv_xsub(pTHX_ CV* cv)
6362 Perl_croak(aTHX_ "usage: %s::%s()",
6363 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
6367 ST(0) = (SV*)XSANY.any_ptr;