3 * Copyright (c) 1991-2002, 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 \"%s\" not allowed while \"strict subs\" in use",
156 SvPV_nolen(cSVOPo_sv)));
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;
307 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
311 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
312 SvREFCNT_dec(cSVOPo->op_sv);
313 cSVOPo->op_sv = Nullsv;
316 Safefree(cPVOPo->op_pv);
317 cPVOPo->op_pv = Nullch;
321 op_free(cPMOPo->op_pmreplroot);
325 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
326 /* No GvIN_PAD_off here, because other references may still
327 * exist on the pad */
328 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
331 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
338 HV *pmstash = PmopSTASH(cPMOPo);
339 if (pmstash && SvREFCNT(pmstash)) {
340 PMOP *pmop = HvPMROOT(pmstash);
341 PMOP *lastpmop = NULL;
343 if (cPMOPo == pmop) {
345 lastpmop->op_pmnext = pmop->op_pmnext;
347 HvPMROOT(pmstash) = pmop->op_pmnext;
351 pmop = pmop->op_pmnext;
354 PmopSTASH_free(cPMOPo);
356 cPMOPo->op_pmreplroot = Nullop;
357 /* we use the "SAFE" version of the PM_ macros here
358 * since sv_clean_all might release some PMOPs
359 * after PL_regex_padav has been cleared
360 * and the clearing of PL_regex_padav needs to
361 * happen before sv_clean_all
363 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
364 PM_SETRE_SAFE(cPMOPo, (REGEXP*)NULL);
366 if(PL_regex_pad) { /* We could be in destruction */
367 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
368 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
369 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
376 if (o->op_targ > 0) {
377 pad_free(o->op_targ);
383 S_cop_free(pTHX_ COP* cop)
385 Safefree(cop->cop_label); /* FIXME: treaddead ??? */
388 if (! specialWARN(cop->cop_warnings))
389 SvREFCNT_dec(cop->cop_warnings);
390 if (! specialCopIO(cop->cop_io)) {
394 char *s = SvPV(cop->cop_io,len);
395 Perl_warn(aTHX_ "io='%.*s'",(int) len,s); /* ??? --jhi */
398 SvREFCNT_dec(cop->cop_io);
404 Perl_op_null(pTHX_ OP *o)
406 if (o->op_type == OP_NULL)
409 o->op_targ = o->op_type;
410 o->op_type = OP_NULL;
411 o->op_ppaddr = PL_ppaddr[OP_NULL];
414 /* Contextualizers */
416 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
419 Perl_linklist(pTHX_ OP *o)
426 /* establish postfix order */
427 if (cUNOPo->op_first) {
428 o->op_next = LINKLIST(cUNOPo->op_first);
429 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
431 kid->op_next = LINKLIST(kid->op_sibling);
443 Perl_scalarkids(pTHX_ OP *o)
446 if (o && o->op_flags & OPf_KIDS) {
447 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
454 S_scalarboolean(pTHX_ OP *o)
456 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
457 if (ckWARN(WARN_SYNTAX)) {
458 line_t oldline = CopLINE(PL_curcop);
460 if (PL_copline != NOLINE)
461 CopLINE_set(PL_curcop, PL_copline);
462 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
463 CopLINE_set(PL_curcop, oldline);
470 Perl_scalar(pTHX_ OP *o)
474 /* assumes no premature commitment */
475 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
476 || o->op_type == OP_RETURN)
481 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
483 switch (o->op_type) {
485 scalar(cBINOPo->op_first);
490 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
494 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
495 if (!kPMOP->op_pmreplroot)
496 deprecate_old("implicit split to @_");
504 if (o->op_flags & OPf_KIDS) {
505 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
511 kid = cLISTOPo->op_first;
513 while ((kid = kid->op_sibling)) {
519 WITH_THR(PL_curcop = &PL_compiling);
524 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
530 WITH_THR(PL_curcop = &PL_compiling);
533 if (ckWARN(WARN_VOID))
534 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
540 Perl_scalarvoid(pTHX_ OP *o)
547 if (o->op_type == OP_NEXTSTATE
548 || o->op_type == OP_SETSTATE
549 || o->op_type == OP_DBSTATE
550 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
551 || o->op_targ == OP_SETSTATE
552 || o->op_targ == OP_DBSTATE)))
553 PL_curcop = (COP*)o; /* for warning below */
555 /* assumes no premature commitment */
556 want = o->op_flags & OPf_WANT;
557 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
558 || o->op_type == OP_RETURN)
563 if ((o->op_private & OPpTARGET_MY)
564 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
566 return scalar(o); /* As if inside SASSIGN */
569 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
571 switch (o->op_type) {
573 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
577 if (o->op_flags & OPf_STACKED)
581 if (o->op_private == 4)
653 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
654 useless = OP_DESC(o);
661 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
662 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
663 useless = "a variable";
668 if (cSVOPo->op_private & OPpCONST_STRICT)
669 no_bareword_allowed(o);
671 if (ckWARN(WARN_VOID)) {
672 useless = "a constant";
673 /* the constants 0 and 1 are permitted as they are
674 conventionally used as dummies in constructs like
675 1 while some_condition_with_side_effects; */
676 if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
678 else if (SvPOK(sv)) {
679 /* perl4's way of mixing documentation and code
680 (before the invention of POD) was based on a
681 trick to mix nroff and perl code. The trick was
682 built upon these three nroff macros being used in
683 void context. The pink camel has the details in
684 the script wrapman near page 319. */
685 if (strnEQ(SvPVX(sv), "di", 2) ||
686 strnEQ(SvPVX(sv), "ds", 2) ||
687 strnEQ(SvPVX(sv), "ig", 2))
692 op_null(o); /* don't execute or even remember it */
696 o->op_type = OP_PREINC; /* pre-increment is faster */
697 o->op_ppaddr = PL_ppaddr[OP_PREINC];
701 o->op_type = OP_PREDEC; /* pre-decrement is faster */
702 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
709 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
714 if (o->op_flags & OPf_STACKED)
721 if (!(o->op_flags & OPf_KIDS))
730 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
737 /* all requires must return a boolean value */
738 o->op_flags &= ~OPf_WANT;
743 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
744 if (!kPMOP->op_pmreplroot)
745 deprecate_old("implicit split to @_");
749 if (useless && ckWARN(WARN_VOID))
750 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
755 Perl_listkids(pTHX_ OP *o)
758 if (o && o->op_flags & OPf_KIDS) {
759 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
766 Perl_list(pTHX_ OP *o)
770 /* assumes no premature commitment */
771 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
772 || o->op_type == OP_RETURN)
777 if ((o->op_private & OPpTARGET_MY)
778 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
780 return o; /* As if inside SASSIGN */
783 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
785 switch (o->op_type) {
788 list(cBINOPo->op_first);
793 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
801 if (!(o->op_flags & OPf_KIDS))
803 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
804 list(cBINOPo->op_first);
805 return gen_constant_list(o);
812 kid = cLISTOPo->op_first;
814 while ((kid = kid->op_sibling)) {
820 WITH_THR(PL_curcop = &PL_compiling);
824 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
830 WITH_THR(PL_curcop = &PL_compiling);
833 /* all requires must return a boolean value */
834 o->op_flags &= ~OPf_WANT;
841 Perl_scalarseq(pTHX_ OP *o)
846 if (o->op_type == OP_LINESEQ ||
847 o->op_type == OP_SCOPE ||
848 o->op_type == OP_LEAVE ||
849 o->op_type == OP_LEAVETRY)
851 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
852 if (kid->op_sibling) {
856 PL_curcop = &PL_compiling;
858 o->op_flags &= ~OPf_PARENS;
859 if (PL_hints & HINT_BLOCK_SCOPE)
860 o->op_flags |= OPf_PARENS;
863 o = newOP(OP_STUB, 0);
868 S_modkids(pTHX_ OP *o, I32 type)
871 if (o && o->op_flags & OPf_KIDS) {
872 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
879 Perl_mod(pTHX_ OP *o, I32 type)
883 if (!o || PL_error_count)
886 if ((o->op_private & OPpTARGET_MY)
887 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
892 switch (o->op_type) {
897 if (!(o->op_private & (OPpCONST_ARYBASE)))
899 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
900 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
904 SAVEI32(PL_compiling.cop_arybase);
905 PL_compiling.cop_arybase = 0;
907 else if (type == OP_REFGEN)
910 Perl_croak(aTHX_ "That use of $[ is unsupported");
913 if (o->op_flags & OPf_PARENS)
917 if ((type == OP_UNDEF || type == OP_REFGEN) &&
918 !(o->op_flags & OPf_STACKED)) {
919 o->op_type = OP_RV2CV; /* entersub => rv2cv */
920 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
921 assert(cUNOPo->op_first->op_type == OP_NULL);
922 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
925 else if (o->op_private & OPpENTERSUB_NOMOD)
927 else { /* lvalue subroutine call */
928 o->op_private |= OPpLVAL_INTRO;
929 PL_modcount = RETURN_UNLIMITED_NUMBER;
930 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
931 /* Backward compatibility mode: */
932 o->op_private |= OPpENTERSUB_INARGS;
935 else { /* Compile-time error message: */
936 OP *kid = cUNOPo->op_first;
940 if (kid->op_type == OP_PUSHMARK)
942 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
944 "panic: unexpected lvalue entersub "
945 "args: type/targ %ld:%"UVuf,
946 (long)kid->op_type, (UV)kid->op_targ);
947 kid = kLISTOP->op_first;
949 while (kid->op_sibling)
950 kid = kid->op_sibling;
951 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
953 if (kid->op_type == OP_METHOD_NAMED
954 || kid->op_type == OP_METHOD)
958 NewOp(1101, newop, 1, UNOP);
959 newop->op_type = OP_RV2CV;
960 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
961 newop->op_first = Nullop;
962 newop->op_next = (OP*)newop;
963 kid->op_sibling = (OP*)newop;
964 newop->op_private |= OPpLVAL_INTRO;
968 if (kid->op_type != OP_RV2CV)
970 "panic: unexpected lvalue entersub "
971 "entry via type/targ %ld:%"UVuf,
972 (long)kid->op_type, (UV)kid->op_targ);
973 kid->op_private |= OPpLVAL_INTRO;
974 break; /* Postpone until runtime */
978 kid = kUNOP->op_first;
979 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
980 kid = kUNOP->op_first;
981 if (kid->op_type == OP_NULL)
983 "Unexpected constant lvalue entersub "
984 "entry via type/targ %ld:%"UVuf,
985 (long)kid->op_type, (UV)kid->op_targ);
986 if (kid->op_type != OP_GV) {
987 /* Restore RV2CV to check lvalueness */
989 if (kid->op_next && kid->op_next != kid) { /* Happens? */
990 okid->op_next = kid->op_next;
994 okid->op_next = Nullop;
995 okid->op_type = OP_RV2CV;
997 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
998 okid->op_private |= OPpLVAL_INTRO;
1002 cv = GvCV(kGVOP_gv);
1012 /* grep, foreach, subcalls, refgen */
1013 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1015 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1016 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1018 : (o->op_type == OP_ENTERSUB
1019 ? "non-lvalue subroutine call"
1021 type ? PL_op_desc[type] : "local"));
1035 case OP_RIGHT_SHIFT:
1044 if (!(o->op_flags & OPf_STACKED))
1050 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1056 if (!type && cUNOPo->op_first->op_type != OP_GV)
1057 Perl_croak(aTHX_ "Can't localize through a reference");
1058 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1059 PL_modcount = RETURN_UNLIMITED_NUMBER;
1060 return o; /* Treat \(@foo) like ordinary list. */
1064 if (scalar_mod_type(o, type))
1066 ref(cUNOPo->op_first, o->op_type);
1070 if (type == OP_LEAVESUBLV)
1071 o->op_private |= OPpMAYBE_LVSUB;
1076 PL_modcount = RETURN_UNLIMITED_NUMBER;
1079 if (!type && cUNOPo->op_first->op_type != OP_GV)
1080 Perl_croak(aTHX_ "Can't localize through a reference");
1081 ref(cUNOPo->op_first, o->op_type);
1085 PL_hints |= HINT_BLOCK_SCOPE;
1096 PL_modcount = RETURN_UNLIMITED_NUMBER;
1097 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1098 return o; /* Treat \(@foo) like ordinary list. */
1099 if (scalar_mod_type(o, type))
1101 if (type == OP_LEAVESUBLV)
1102 o->op_private |= OPpMAYBE_LVSUB;
1107 { /* XXX DAPM 2002.08.25 tmp assert test */
1108 /* XXX */ assert(av_fetch(PL_comppad_name, (o->op_targ), FALSE));
1109 /* XXX */ assert(*av_fetch(PL_comppad_name, (o->op_targ), FALSE));
1111 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1112 PAD_COMPNAME_PV(o->op_targ));
1120 if (type != OP_SASSIGN)
1124 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1129 if (type == OP_LEAVESUBLV)
1130 o->op_private |= OPpMAYBE_LVSUB;
1132 pad_free(o->op_targ);
1133 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1134 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1135 if (o->op_flags & OPf_KIDS)
1136 mod(cBINOPo->op_first->op_sibling, type);
1141 ref(cBINOPo->op_first, o->op_type);
1142 if (type == OP_ENTERSUB &&
1143 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1144 o->op_private |= OPpLVAL_DEFER;
1145 if (type == OP_LEAVESUBLV)
1146 o->op_private |= OPpMAYBE_LVSUB;
1154 if (o->op_flags & OPf_KIDS)
1155 mod(cLISTOPo->op_last, type);
1159 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1161 else if (!(o->op_flags & OPf_KIDS))
1163 if (o->op_targ != OP_LIST) {
1164 mod(cBINOPo->op_first, type);
1169 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1174 if (type != OP_LEAVESUBLV)
1176 break; /* mod()ing was handled by ck_return() */
1179 /* [20011101.069] File test operators interpret OPf_REF to mean that
1180 their argument is a filehandle; thus \stat(".") should not set
1182 if (type == OP_REFGEN &&
1183 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1186 if (type != OP_LEAVESUBLV)
1187 o->op_flags |= OPf_MOD;
1189 if (type == OP_AASSIGN || type == OP_SASSIGN)
1190 o->op_flags |= OPf_SPECIAL|OPf_REF;
1192 o->op_private |= OPpLVAL_INTRO;
1193 o->op_flags &= ~OPf_SPECIAL;
1194 PL_hints |= HINT_BLOCK_SCOPE;
1196 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1197 && type != OP_LEAVESUBLV)
1198 o->op_flags |= OPf_REF;
1203 S_scalar_mod_type(pTHX_ OP *o, I32 type)
1207 if (o->op_type == OP_RV2GV)
1231 case OP_RIGHT_SHIFT:
1250 S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
1252 switch (o->op_type) {
1260 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1273 Perl_refkids(pTHX_ OP *o, I32 type)
1276 if (o && o->op_flags & OPf_KIDS) {
1277 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1284 Perl_ref(pTHX_ OP *o, I32 type)
1288 if (!o || PL_error_count)
1291 switch (o->op_type) {
1293 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1294 !(o->op_flags & OPf_STACKED)) {
1295 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1296 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1297 assert(cUNOPo->op_first->op_type == OP_NULL);
1298 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1299 o->op_flags |= OPf_SPECIAL;
1304 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1308 if (type == OP_DEFINED)
1309 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1310 ref(cUNOPo->op_first, o->op_type);
1313 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1314 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1315 : type == OP_RV2HV ? OPpDEREF_HV
1317 o->op_flags |= OPf_MOD;
1322 o->op_flags |= OPf_MOD; /* XXX ??? */
1327 o->op_flags |= OPf_REF;
1330 if (type == OP_DEFINED)
1331 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1332 ref(cUNOPo->op_first, o->op_type);
1337 o->op_flags |= OPf_REF;
1342 if (!(o->op_flags & OPf_KIDS))
1344 ref(cBINOPo->op_first, type);
1348 ref(cBINOPo->op_first, o->op_type);
1349 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1350 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1351 : type == OP_RV2HV ? OPpDEREF_HV
1353 o->op_flags |= OPf_MOD;
1361 if (!(o->op_flags & OPf_KIDS))
1363 ref(cLISTOPo->op_last, type);
1373 S_dup_attrlist(pTHX_ OP *o)
1377 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1378 * where the first kid is OP_PUSHMARK and the remaining ones
1379 * are OP_CONST. We need to push the OP_CONST values.
1381 if (o->op_type == OP_CONST)
1382 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1384 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1385 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1386 if (o->op_type == OP_CONST)
1387 rop = append_elem(OP_LIST, rop,
1388 newSVOP(OP_CONST, o->op_flags,
1389 SvREFCNT_inc(cSVOPo->op_sv)));
1396 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1400 /* fake up C<use attributes $pkg,$rv,@attrs> */
1401 ENTER; /* need to protect against side-effects of 'use' */
1404 stashsv = newSVpv(HvNAME(stash), 0);
1406 stashsv = &PL_sv_no;
1408 #define ATTRSMODULE "attributes"
1409 #define ATTRSMODULE_PM "attributes.pm"
1413 /* Don't force the C<use> if we don't need it. */
1414 svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
1415 sizeof(ATTRSMODULE_PM)-1, 0);
1416 if (svp && *svp != &PL_sv_undef)
1417 ; /* already in %INC */
1419 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1420 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1424 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1425 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1427 prepend_elem(OP_LIST,
1428 newSVOP(OP_CONST, 0, stashsv),
1429 prepend_elem(OP_LIST,
1430 newSVOP(OP_CONST, 0,
1432 dup_attrlist(attrs))));
1438 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1440 OP *pack, *imop, *arg;
1446 assert(target->op_type == OP_PADSV ||
1447 target->op_type == OP_PADHV ||
1448 target->op_type == OP_PADAV);
1450 /* Ensure that attributes.pm is loaded. */
1451 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1453 /* Need package name for method call. */
1454 pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
1456 /* Build up the real arg-list. */
1458 stashsv = newSVpv(HvNAME(stash), 0);
1460 stashsv = &PL_sv_no;
1461 arg = newOP(OP_PADSV, 0);
1462 arg->op_targ = target->op_targ;
1463 arg = prepend_elem(OP_LIST,
1464 newSVOP(OP_CONST, 0, stashsv),
1465 prepend_elem(OP_LIST,
1466 newUNOP(OP_REFGEN, 0,
1467 mod(arg, OP_REFGEN)),
1468 dup_attrlist(attrs)));
1470 /* Fake up a method call to import */
1471 meth = newSVpvn("import", 6);
1472 (void)SvUPGRADE(meth, SVt_PVIV);
1473 (void)SvIOK_on(meth);
1474 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
1475 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1476 append_elem(OP_LIST,
1477 prepend_elem(OP_LIST, pack, list(arg)),
1478 newSVOP(OP_METHOD_NAMED, 0, meth)));
1479 imop->op_private |= OPpENTERSUB_NOMOD;
1481 /* Combine the ops. */
1482 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1486 =notfor apidoc apply_attrs_string
1488 Attempts to apply a list of attributes specified by the C<attrstr> and
1489 C<len> arguments to the subroutine identified by the C<cv> argument which
1490 is expected to be associated with the package identified by the C<stashpv>
1491 argument (see L<attributes>). It gets this wrong, though, in that it
1492 does not correctly identify the boundaries of the individual attribute
1493 specifications within C<attrstr>. This is not really intended for the
1494 public API, but has to be listed here for systems such as AIX which
1495 need an explicit export list for symbols. (It's called from XS code
1496 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1497 to respect attribute syntax properly would be welcome.
1503 Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
1504 char *attrstr, STRLEN len)
1509 len = strlen(attrstr);
1513 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1515 char *sstr = attrstr;
1516 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1517 attrs = append_elem(OP_LIST, attrs,
1518 newSVOP(OP_CONST, 0,
1519 newSVpvn(sstr, attrstr-sstr)));
1523 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1524 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1525 Nullsv, prepend_elem(OP_LIST,
1526 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1527 prepend_elem(OP_LIST,
1528 newSVOP(OP_CONST, 0,
1534 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1539 if (!o || PL_error_count)
1543 if (type == OP_LIST) {
1544 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1545 my_kid(kid, attrs, imopsp);
1546 } else if (type == OP_UNDEF) {
1548 } else if (type == OP_RV2SV || /* "our" declaration */
1550 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1551 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1552 yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
1553 OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
1555 GV *gv = cGVOPx_gv(cUNOPo->op_first);
1557 PL_in_my_stash = Nullhv;
1558 apply_attrs(GvSTASH(gv),
1559 (type == OP_RV2SV ? GvSV(gv) :
1560 type == OP_RV2AV ? (SV*)GvAV(gv) :
1561 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1564 o->op_private |= OPpOUR_INTRO;
1567 else if (type != OP_PADSV &&
1570 type != OP_PUSHMARK)
1572 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1574 PL_in_my == KEY_our ? "our" : "my"));
1577 else if (attrs && type != OP_PUSHMARK) {
1581 PL_in_my_stash = Nullhv;
1583 /* check for C<my Dog $spot> when deciding package */
1584 stash = PAD_COMPNAME_TYPE(o->op_targ);
1586 stash = PL_curstash;
1587 apply_attrs_my(stash, o, attrs, imopsp);
1589 o->op_flags |= OPf_MOD;
1590 o->op_private |= OPpLVAL_INTRO;
1595 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1598 int maybe_scalar = 0;
1600 /* [perl #17376]: this appears to be premature, and results in code such as
1601 C< our(%x); > executing in list mode rather than void mode */
1603 if (o->op_flags & OPf_PARENS)
1612 o = my_kid(o, attrs, &rops);
1614 if (maybe_scalar && o->op_type == OP_PADSV) {
1615 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1616 o->op_private |= OPpLVAL_INTRO;
1619 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1622 PL_in_my_stash = Nullhv;
1627 Perl_my(pTHX_ OP *o)
1629 return my_attrs(o, Nullop);
1633 Perl_sawparens(pTHX_ OP *o)
1636 o->op_flags |= OPf_PARENS;
1641 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1645 if (ckWARN(WARN_MISC) &&
1646 (left->op_type == OP_RV2AV ||
1647 left->op_type == OP_RV2HV ||
1648 left->op_type == OP_PADAV ||
1649 left->op_type == OP_PADHV)) {
1650 char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
1651 right->op_type == OP_TRANS)
1652 ? right->op_type : OP_MATCH];
1653 const char *sample = ((left->op_type == OP_RV2AV ||
1654 left->op_type == OP_PADAV)
1655 ? "@array" : "%hash");
1656 Perl_warner(aTHX_ packWARN(WARN_MISC),
1657 "Applying %s to %s will act on scalar(%s)",
1658 desc, sample, sample);
1661 if (right->op_type == OP_CONST &&
1662 cSVOPx(right)->op_private & OPpCONST_BARE &&
1663 cSVOPx(right)->op_private & OPpCONST_STRICT)
1665 no_bareword_allowed(right);
1668 if (!(right->op_flags & OPf_STACKED) &&
1669 (right->op_type == OP_MATCH ||
1670 right->op_type == OP_SUBST ||
1671 right->op_type == OP_TRANS)) {
1672 right->op_flags |= OPf_STACKED;
1673 if (right->op_type != OP_MATCH &&
1674 ! (right->op_type == OP_TRANS &&
1675 right->op_private & OPpTRANS_IDENTICAL))
1676 left = mod(left, right->op_type);
1677 if (right->op_type == OP_TRANS)
1678 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
1680 o = prepend_elem(right->op_type, scalar(left), right);
1682 return newUNOP(OP_NOT, 0, scalar(o));
1686 return bind_match(type, left,
1687 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
1691 Perl_invert(pTHX_ OP *o)
1695 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
1696 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1700 Perl_scope(pTHX_ OP *o)
1703 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1704 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1705 o->op_type = OP_LEAVE;
1706 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1709 if (o->op_type == OP_LINESEQ) {
1711 o->op_type = OP_SCOPE;
1712 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1713 kid = ((LISTOP*)o)->op_first;
1714 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
1718 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
1725 Perl_save_hints(pTHX)
1728 SAVESPTR(GvHV(PL_hintgv));
1729 GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
1730 SAVEFREESV(GvHV(PL_hintgv));
1734 Perl_block_start(pTHX_ int full)
1736 int retval = PL_savestack_ix;
1738 pad_block_start(full);
1740 PL_hints &= ~HINT_BLOCK_SCOPE;
1741 SAVESPTR(PL_compiling.cop_warnings);
1742 if (! specialWARN(PL_compiling.cop_warnings)) {
1743 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1744 SAVEFREESV(PL_compiling.cop_warnings) ;
1746 SAVESPTR(PL_compiling.cop_io);
1747 if (! specialCopIO(PL_compiling.cop_io)) {
1748 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1749 SAVEFREESV(PL_compiling.cop_io) ;
1755 Perl_block_end(pTHX_ I32 floor, OP *seq)
1757 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1758 line_t copline = PL_copline;
1759 /* there should be a nextstate in every block */
1760 OP* retval = seq ? scalarseq(seq) : newSTATEOP(0, Nullch, seq);
1761 PL_copline = copline; /* XXX newSTATEOP may reset PL_copline */
1763 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
1765 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
1773 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1777 Perl_newPROG(pTHX_ OP *o)
1782 PL_eval_root = newUNOP(OP_LEAVEEVAL,
1783 ((PL_in_eval & EVAL_KEEPERR)
1784 ? OPf_SPECIAL : 0), o);
1785 PL_eval_start = linklist(PL_eval_root);
1786 PL_eval_root->op_private |= OPpREFCOUNTED;
1787 OpREFCNT_set(PL_eval_root, 1);
1788 PL_eval_root->op_next = 0;
1789 CALL_PEEP(PL_eval_start);
1794 PL_main_root = scope(sawparens(scalarvoid(o)));
1795 PL_curcop = &PL_compiling;
1796 PL_main_start = LINKLIST(PL_main_root);
1797 PL_main_root->op_private |= OPpREFCOUNTED;
1798 OpREFCNT_set(PL_main_root, 1);
1799 PL_main_root->op_next = 0;
1800 CALL_PEEP(PL_main_start);
1803 /* Register with debugger */
1805 CV *cv = get_cv("DB::postponed", FALSE);
1809 XPUSHs((SV*)CopFILEGV(&PL_compiling));
1811 call_sv((SV*)cv, G_DISCARD);
1818 Perl_localize(pTHX_ OP *o, I32 lex)
1820 if (o->op_flags & OPf_PARENS)
1821 /* [perl #17376]: this appears to be premature, and results in code such as
1822 C< our(%x); > executing in list mode rather than void mode */
1829 if (ckWARN(WARN_PARENTHESIS)
1830 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
1832 char *s = PL_bufptr;
1834 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ", *s)))
1837 if (*s == ';' || *s == '=')
1838 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
1839 "Parentheses missing around \"%s\" list",
1840 lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
1846 o = mod(o, OP_NULL); /* a bit kludgey */
1848 PL_in_my_stash = Nullhv;
1853 Perl_jmaybe(pTHX_ OP *o)
1855 if (o->op_type == OP_LIST) {
1857 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
1858 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
1864 Perl_fold_constants(pTHX_ register OP *o)
1867 I32 type = o->op_type;
1870 if (PL_opargs[type] & OA_RETSCALAR)
1872 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
1873 o->op_targ = pad_alloc(type, SVs_PADTMP);
1875 /* integerize op, unless it happens to be C<-foo>.
1876 * XXX should pp_i_negate() do magic string negation instead? */
1877 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
1878 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
1879 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
1881 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
1884 if (!(PL_opargs[type] & OA_FOLDCONST))
1889 /* XXX might want a ck_negate() for this */
1890 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
1902 /* XXX what about the numeric ops? */
1903 if (PL_hints & HINT_LOCALE)
1908 goto nope; /* Don't try to run w/ errors */
1910 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
1911 if ((curop->op_type != OP_CONST ||
1912 (curop->op_private & OPpCONST_BARE)) &&
1913 curop->op_type != OP_LIST &&
1914 curop->op_type != OP_SCALAR &&
1915 curop->op_type != OP_NULL &&
1916 curop->op_type != OP_PUSHMARK)
1922 curop = LINKLIST(o);
1926 sv = *(PL_stack_sp--);
1927 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
1928 pad_swipe(o->op_targ, FALSE);
1929 else if (SvTEMP(sv)) { /* grab mortal temp? */
1930 (void)SvREFCNT_inc(sv);
1934 if (type == OP_RV2GV)
1935 return newGVOP(OP_GV, 0, (GV*)sv);
1937 /* try to smush double to int, but don't smush -2.0 to -2 */
1938 if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
1941 #ifdef PERL_PRESERVE_IVUV
1942 /* Only bother to attempt to fold to IV if
1943 most operators will benefit */
1947 return newSVOP(OP_CONST, 0, sv);
1955 Perl_gen_constant_list(pTHX_ register OP *o)
1958 I32 oldtmps_floor = PL_tmps_floor;
1962 return o; /* Don't attempt to run with errors */
1964 PL_op = curop = LINKLIST(o);
1971 PL_tmps_floor = oldtmps_floor;
1973 o->op_type = OP_RV2AV;
1974 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
1975 o->op_seq = 0; /* needs to be revisited in peep() */
1976 curop = ((UNOP*)o)->op_first;
1977 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
1984 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
1986 if (!o || o->op_type != OP_LIST)
1987 o = newLISTOP(OP_LIST, 0, o, Nullop);
1989 o->op_flags &= ~OPf_WANT;
1991 if (!(PL_opargs[type] & OA_MARK))
1992 op_null(cLISTOPo->op_first);
1994 o->op_type = (OPCODE)type;
1995 o->op_ppaddr = PL_ppaddr[type];
1996 o->op_flags |= flags;
1998 o = CHECKOP(type, o);
1999 if (o->op_type != type)
2002 return fold_constants(o);
2005 /* List constructors */
2008 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2016 if (first->op_type != type
2017 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2019 return newLISTOP(type, 0, first, last);
2022 if (first->op_flags & OPf_KIDS)
2023 ((LISTOP*)first)->op_last->op_sibling = last;
2025 first->op_flags |= OPf_KIDS;
2026 ((LISTOP*)first)->op_first = last;
2028 ((LISTOP*)first)->op_last = last;
2033 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2041 if (first->op_type != type)
2042 return prepend_elem(type, (OP*)first, (OP*)last);
2044 if (last->op_type != type)
2045 return append_elem(type, (OP*)first, (OP*)last);
2047 first->op_last->op_sibling = last->op_first;
2048 first->op_last = last->op_last;
2049 first->op_flags |= (last->op_flags & OPf_KIDS);
2057 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2065 if (last->op_type == type) {
2066 if (type == OP_LIST) { /* already a PUSHMARK there */
2067 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2068 ((LISTOP*)last)->op_first->op_sibling = first;
2069 if (!(first->op_flags & OPf_PARENS))
2070 last->op_flags &= ~OPf_PARENS;
2073 if (!(last->op_flags & OPf_KIDS)) {
2074 ((LISTOP*)last)->op_last = first;
2075 last->op_flags |= OPf_KIDS;
2077 first->op_sibling = ((LISTOP*)last)->op_first;
2078 ((LISTOP*)last)->op_first = first;
2080 last->op_flags |= OPf_KIDS;
2084 return newLISTOP(type, 0, first, last);
2090 Perl_newNULLLIST(pTHX)
2092 return newOP(OP_STUB, 0);
2096 Perl_force_list(pTHX_ OP *o)
2098 if (!o || o->op_type != OP_LIST)
2099 o = newLISTOP(OP_LIST, 0, o, Nullop);
2105 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2109 NewOp(1101, listop, 1, LISTOP);
2111 listop->op_type = (OPCODE)type;
2112 listop->op_ppaddr = PL_ppaddr[type];
2115 listop->op_flags = (U8)flags;
2119 else if (!first && last)
2122 first->op_sibling = last;
2123 listop->op_first = first;
2124 listop->op_last = last;
2125 if (type == OP_LIST) {
2127 pushop = newOP(OP_PUSHMARK, 0);
2128 pushop->op_sibling = first;
2129 listop->op_first = pushop;
2130 listop->op_flags |= OPf_KIDS;
2132 listop->op_last = pushop;
2139 Perl_newOP(pTHX_ I32 type, I32 flags)
2142 NewOp(1101, o, 1, OP);
2143 o->op_type = (OPCODE)type;
2144 o->op_ppaddr = PL_ppaddr[type];
2145 o->op_flags = (U8)flags;
2148 o->op_private = (U8)(0 | (flags >> 8));
2149 if (PL_opargs[type] & OA_RETSCALAR)
2151 if (PL_opargs[type] & OA_TARGET)
2152 o->op_targ = pad_alloc(type, SVs_PADTMP);
2153 return CHECKOP(type, o);
2157 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2162 first = newOP(OP_STUB, 0);
2163 if (PL_opargs[type] & OA_MARK)
2164 first = force_list(first);
2166 NewOp(1101, unop, 1, UNOP);
2167 unop->op_type = (OPCODE)type;
2168 unop->op_ppaddr = PL_ppaddr[type];
2169 unop->op_first = first;
2170 unop->op_flags = flags | OPf_KIDS;
2171 unop->op_private = (U8)(1 | (flags >> 8));
2172 unop = (UNOP*) CHECKOP(type, unop);
2176 return fold_constants((OP *) unop);
2180 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2183 NewOp(1101, binop, 1, BINOP);
2186 first = newOP(OP_NULL, 0);
2188 binop->op_type = (OPCODE)type;
2189 binop->op_ppaddr = PL_ppaddr[type];
2190 binop->op_first = first;
2191 binop->op_flags = flags | OPf_KIDS;
2194 binop->op_private = (U8)(1 | (flags >> 8));
2197 binop->op_private = (U8)(2 | (flags >> 8));
2198 first->op_sibling = last;
2201 binop = (BINOP*)CHECKOP(type, binop);
2202 if (binop->op_next || binop->op_type != (OPCODE)type)
2205 binop->op_last = binop->op_first->op_sibling;
2207 return fold_constants((OP *)binop);
2211 uvcompare(const void *a, const void *b)
2213 if (*((UV *)a) < (*(UV *)b))
2215 if (*((UV *)a) > (*(UV *)b))
2217 if (*((UV *)a+1) < (*(UV *)b+1))
2219 if (*((UV *)a+1) > (*(UV *)b+1))
2225 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2227 SV *tstr = ((SVOP*)expr)->op_sv;
2228 SV *rstr = ((SVOP*)repl)->op_sv;
2231 U8 *t = (U8*)SvPV(tstr, tlen);
2232 U8 *r = (U8*)SvPV(rstr, rlen);
2239 register short *tbl;
2241 PL_hints |= HINT_BLOCK_SCOPE;
2242 complement = o->op_private & OPpTRANS_COMPLEMENT;
2243 del = o->op_private & OPpTRANS_DELETE;
2244 squash = o->op_private & OPpTRANS_SQUASH;
2247 o->op_private |= OPpTRANS_FROM_UTF;
2250 o->op_private |= OPpTRANS_TO_UTF;
2252 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2253 SV* listsv = newSVpvn("# comment\n",10);
2255 U8* tend = t + tlen;
2256 U8* rend = r + rlen;
2270 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2271 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2277 tsave = t = bytes_to_utf8(t, &len);
2280 if (!to_utf && rlen) {
2282 rsave = r = bytes_to_utf8(r, &len);
2286 /* There are several snags with this code on EBCDIC:
2287 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2288 2. scan_const() in toke.c has encoded chars in native encoding which makes
2289 ranges at least in EBCDIC 0..255 range the bottom odd.
2293 U8 tmpbuf[UTF8_MAXLEN+1];
2296 New(1109, cp, 2*tlen, UV);
2298 transv = newSVpvn("",0);
2300 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2302 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2304 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2308 cp[2*i+1] = cp[2*i];
2312 qsort(cp, i, 2*sizeof(UV), uvcompare);
2313 for (j = 0; j < i; j++) {
2315 diff = val - nextmin;
2317 t = uvuni_to_utf8(tmpbuf,nextmin);
2318 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2320 U8 range_mark = UTF_TO_NATIVE(0xff);
2321 t = uvuni_to_utf8(tmpbuf, val - 1);
2322 sv_catpvn(transv, (char *)&range_mark, 1);
2323 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2330 t = uvuni_to_utf8(tmpbuf,nextmin);
2331 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2333 U8 range_mark = UTF_TO_NATIVE(0xff);
2334 sv_catpvn(transv, (char *)&range_mark, 1);
2336 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2337 UNICODE_ALLOW_SUPER);
2338 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2339 t = (U8*)SvPVX(transv);
2340 tlen = SvCUR(transv);
2344 else if (!rlen && !del) {
2345 r = t; rlen = tlen; rend = tend;
2348 if ((!rlen && !del) || t == r ||
2349 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2351 o->op_private |= OPpTRANS_IDENTICAL;
2355 while (t < tend || tfirst <= tlast) {
2356 /* see if we need more "t" chars */
2357 if (tfirst > tlast) {
2358 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2360 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2362 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2369 /* now see if we need more "r" chars */
2370 if (rfirst > rlast) {
2372 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2374 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2376 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2385 rfirst = rlast = 0xffffffff;
2389 /* now see which range will peter our first, if either. */
2390 tdiff = tlast - tfirst;
2391 rdiff = rlast - rfirst;
2398 if (rfirst == 0xffffffff) {
2399 diff = tdiff; /* oops, pretend rdiff is infinite */
2401 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2402 (long)tfirst, (long)tlast);
2404 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2408 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2409 (long)tfirst, (long)(tfirst + diff),
2412 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2413 (long)tfirst, (long)rfirst);
2415 if (rfirst + diff > max)
2416 max = rfirst + diff;
2418 grows = (tfirst < rfirst &&
2419 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2431 else if (max > 0xff)
2436 Safefree(cPVOPo->op_pv);
2437 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2438 SvREFCNT_dec(listsv);
2440 SvREFCNT_dec(transv);
2442 if (!del && havefinal && rlen)
2443 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2444 newSVuv((UV)final), 0);
2447 o->op_private |= OPpTRANS_GROWS;
2459 tbl = (short*)cPVOPo->op_pv;
2461 Zero(tbl, 256, short);
2462 for (i = 0; i < (I32)tlen; i++)
2464 for (i = 0, j = 0; i < 256; i++) {
2466 if (j >= (I32)rlen) {
2475 if (i < 128 && r[j] >= 128)
2485 o->op_private |= OPpTRANS_IDENTICAL;
2487 else if (j >= (I32)rlen)
2490 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2491 tbl[0x100] = rlen - j;
2492 for (i=0; i < (I32)rlen - j; i++)
2493 tbl[0x101+i] = r[j+i];
2497 if (!rlen && !del) {
2500 o->op_private |= OPpTRANS_IDENTICAL;
2502 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2503 o->op_private |= OPpTRANS_IDENTICAL;
2505 for (i = 0; i < 256; i++)
2507 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
2508 if (j >= (I32)rlen) {
2510 if (tbl[t[i]] == -1)
2516 if (tbl[t[i]] == -1) {
2517 if (t[i] < 128 && r[j] >= 128)
2524 o->op_private |= OPpTRANS_GROWS;
2532 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2536 NewOp(1101, pmop, 1, PMOP);
2537 pmop->op_type = (OPCODE)type;
2538 pmop->op_ppaddr = PL_ppaddr[type];
2539 pmop->op_flags = (U8)flags;
2540 pmop->op_private = (U8)(0 | (flags >> 8));
2542 if (PL_hints & HINT_RE_TAINT)
2543 pmop->op_pmpermflags |= PMf_RETAINT;
2544 if (PL_hints & HINT_LOCALE)
2545 pmop->op_pmpermflags |= PMf_LOCALE;
2546 pmop->op_pmflags = pmop->op_pmpermflags;
2551 if(av_len((AV*) PL_regex_pad[0]) > -1) {
2552 repointer = av_pop((AV*)PL_regex_pad[0]);
2553 pmop->op_pmoffset = SvIV(repointer);
2554 SvREPADTMP_off(repointer);
2555 sv_setiv(repointer,0);
2557 repointer = newSViv(0);
2558 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2559 pmop->op_pmoffset = av_len(PL_regex_padav);
2560 PL_regex_pad = AvARRAY(PL_regex_padav);
2565 /* link into pm list */
2566 if (type != OP_TRANS && PL_curstash) {
2567 pmop->op_pmnext = HvPMROOT(PL_curstash);
2568 HvPMROOT(PL_curstash) = pmop;
2569 PmopSTASH_set(pmop,PL_curstash);
2576 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
2580 I32 repl_has_vars = 0;
2582 if (o->op_type == OP_TRANS)
2583 return pmtrans(o, expr, repl);
2585 PL_hints |= HINT_BLOCK_SCOPE;
2588 if (expr->op_type == OP_CONST) {
2590 SV *pat = ((SVOP*)expr)->op_sv;
2591 char *p = SvPV(pat, plen);
2592 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
2593 sv_setpvn(pat, "\\s+", 3);
2594 p = SvPV(pat, plen);
2595 pm->op_pmflags |= PMf_SKIPWHITE;
2598 pm->op_pmdynflags |= PMdf_UTF8;
2599 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
2600 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
2601 pm->op_pmflags |= PMf_WHITE;
2605 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2606 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2608 : OP_REGCMAYBE),0,expr);
2610 NewOp(1101, rcop, 1, LOGOP);
2611 rcop->op_type = OP_REGCOMP;
2612 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2613 rcop->op_first = scalar(expr);
2614 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
2615 ? (OPf_SPECIAL | OPf_KIDS)
2617 rcop->op_private = 1;
2620 /* establish postfix order */
2621 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2623 rcop->op_next = expr;
2624 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2627 rcop->op_next = LINKLIST(expr);
2628 expr->op_next = (OP*)rcop;
2631 prepend_elem(o->op_type, scalar((OP*)rcop), o);
2636 if (pm->op_pmflags & PMf_EVAL) {
2638 if (CopLINE(PL_curcop) < PL_multi_end)
2639 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
2641 else if (repl->op_type == OP_CONST)
2645 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
2646 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
2647 if (curop->op_type == OP_GV) {
2648 GV *gv = cGVOPx_gv(curop);
2650 if (strchr("&`'123456789+", *GvENAME(gv)))
2653 else if (curop->op_type == OP_RV2CV)
2655 else if (curop->op_type == OP_RV2SV ||
2656 curop->op_type == OP_RV2AV ||
2657 curop->op_type == OP_RV2HV ||
2658 curop->op_type == OP_RV2GV) {
2659 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2662 else if (curop->op_type == OP_PADSV ||
2663 curop->op_type == OP_PADAV ||
2664 curop->op_type == OP_PADHV ||
2665 curop->op_type == OP_PADANY) {
2668 else if (curop->op_type == OP_PUSHRE)
2669 ; /* Okay here, dangerous in newASSIGNOP */
2679 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
2680 pm->op_pmflags |= PMf_CONST; /* const for long enough */
2681 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
2682 prepend_elem(o->op_type, scalar(repl), o);
2685 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
2686 pm->op_pmflags |= PMf_MAYBE_CONST;
2687 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2689 NewOp(1101, rcop, 1, LOGOP);
2690 rcop->op_type = OP_SUBSTCONT;
2691 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
2692 rcop->op_first = scalar(repl);
2693 rcop->op_flags |= OPf_KIDS;
2694 rcop->op_private = 1;
2697 /* establish postfix order */
2698 rcop->op_next = LINKLIST(repl);
2699 repl->op_next = (OP*)rcop;
2701 pm->op_pmreplroot = scalar((OP*)rcop);
2702 pm->op_pmreplstart = LINKLIST(rcop);
2711 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
2714 NewOp(1101, svop, 1, SVOP);
2715 svop->op_type = (OPCODE)type;
2716 svop->op_ppaddr = PL_ppaddr[type];
2718 svop->op_next = (OP*)svop;
2719 svop->op_flags = (U8)flags;
2720 if (PL_opargs[type] & OA_RETSCALAR)
2722 if (PL_opargs[type] & OA_TARGET)
2723 svop->op_targ = pad_alloc(type, SVs_PADTMP);
2724 return CHECKOP(type, svop);
2728 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2731 NewOp(1101, padop, 1, PADOP);
2732 padop->op_type = (OPCODE)type;
2733 padop->op_ppaddr = PL_ppaddr[type];
2734 padop->op_padix = pad_alloc(type, SVs_PADTMP);
2735 SvREFCNT_dec(PAD_SVl(padop->op_padix));
2736 PAD_SETSV(padop->op_padix, sv);
2739 padop->op_next = (OP*)padop;
2740 padop->op_flags = (U8)flags;
2741 if (PL_opargs[type] & OA_RETSCALAR)
2743 if (PL_opargs[type] & OA_TARGET)
2744 padop->op_targ = pad_alloc(type, SVs_PADTMP);
2745 return CHECKOP(type, padop);
2749 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
2754 return newPADOP(type, flags, SvREFCNT_inc(gv));
2756 return newSVOP(type, flags, SvREFCNT_inc(gv));
2761 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
2764 NewOp(1101, pvop, 1, PVOP);
2765 pvop->op_type = (OPCODE)type;
2766 pvop->op_ppaddr = PL_ppaddr[type];
2768 pvop->op_next = (OP*)pvop;
2769 pvop->op_flags = (U8)flags;
2770 if (PL_opargs[type] & OA_RETSCALAR)
2772 if (PL_opargs[type] & OA_TARGET)
2773 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
2774 return CHECKOP(type, pvop);
2778 Perl_package(pTHX_ OP *o)
2783 save_hptr(&PL_curstash);
2784 save_item(PL_curstname);
2786 name = SvPV(cSVOPo->op_sv, len);
2787 PL_curstash = gv_stashpvn(name, len, TRUE);
2788 sv_setpvn(PL_curstname, name, len);
2791 PL_hints |= HINT_BLOCK_SCOPE;
2792 PL_copline = NOLINE;
2797 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
2803 if (id->op_type != OP_CONST)
2804 Perl_croak(aTHX_ "Module name must be constant");
2808 if (version != Nullop) {
2809 SV *vesv = ((SVOP*)version)->op_sv;
2811 if (arg == Nullop && !SvNIOKp(vesv)) {
2818 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
2819 Perl_croak(aTHX_ "Version number must be constant number");
2821 /* Make copy of id so we don't free it twice */
2822 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
2824 /* Fake up a method call to VERSION */
2825 meth = newSVpvn("VERSION",7);
2826 sv_upgrade(meth, SVt_PVIV);
2827 (void)SvIOK_on(meth);
2828 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
2829 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2830 append_elem(OP_LIST,
2831 prepend_elem(OP_LIST, pack, list(version)),
2832 newSVOP(OP_METHOD_NAMED, 0, meth)));
2836 /* Fake up an import/unimport */
2837 if (arg && arg->op_type == OP_STUB)
2838 imop = arg; /* no import on explicit () */
2839 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
2840 imop = Nullop; /* use 5.0; */
2845 /* Make copy of id so we don't free it twice */
2846 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
2848 /* Fake up a method call to import/unimport */
2849 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);
2850 (void)SvUPGRADE(meth, SVt_PVIV);
2851 (void)SvIOK_on(meth);
2852 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
2853 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2854 append_elem(OP_LIST,
2855 prepend_elem(OP_LIST, pack, list(arg)),
2856 newSVOP(OP_METHOD_NAMED, 0, meth)));
2859 /* Fake up the BEGIN {}, which does its thing immediately. */
2861 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
2864 append_elem(OP_LINESEQ,
2865 append_elem(OP_LINESEQ,
2866 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, id)),
2867 newSTATEOP(0, Nullch, veop)),
2868 newSTATEOP(0, Nullch, imop) ));
2870 /* The "did you use incorrect case?" warning used to be here.
2871 * The problem is that on case-insensitive filesystems one
2872 * might get false positives for "use" (and "require"):
2873 * "use Strict" or "require CARP" will work. This causes
2874 * portability problems for the script: in case-strict
2875 * filesystems the script will stop working.
2877 * The "incorrect case" warning checked whether "use Foo"
2878 * imported "Foo" to your namespace, but that is wrong, too:
2879 * there is no requirement nor promise in the language that
2880 * a Foo.pm should or would contain anything in package "Foo".
2882 * There is very little Configure-wise that can be done, either:
2883 * the case-sensitivity of the build filesystem of Perl does not
2884 * help in guessing the case-sensitivity of the runtime environment.
2887 PL_hints |= HINT_BLOCK_SCOPE;
2888 PL_copline = NOLINE;
2893 =head1 Embedding Functions
2895 =for apidoc load_module
2897 Loads the module whose name is pointed to by the string part of name.
2898 Note that the actual module name, not its filename, should be given.
2899 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
2900 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
2901 (or 0 for no flags). ver, if specified, provides version semantics
2902 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
2903 arguments can be used to specify arguments to the module's import()
2904 method, similar to C<use Foo::Bar VERSION LIST>.
2909 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
2912 va_start(args, ver);
2913 vload_module(flags, name, ver, &args);
2917 #ifdef PERL_IMPLICIT_CONTEXT
2919 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
2923 va_start(args, ver);
2924 vload_module(flags, name, ver, &args);
2930 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
2932 OP *modname, *veop, *imop;
2934 modname = newSVOP(OP_CONST, 0, name);
2935 modname->op_private |= OPpCONST_BARE;
2937 veop = newSVOP(OP_CONST, 0, ver);
2941 if (flags & PERL_LOADMOD_NOIMPORT) {
2942 imop = sawparens(newNULLLIST());
2944 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
2945 imop = va_arg(*args, OP*);
2950 sv = va_arg(*args, SV*);
2952 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
2953 sv = va_arg(*args, SV*);
2957 line_t ocopline = PL_copline;
2958 int oexpect = PL_expect;
2960 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
2961 veop, modname, imop);
2962 PL_expect = oexpect;
2963 PL_copline = ocopline;
2968 Perl_dofile(pTHX_ OP *term)
2973 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
2974 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
2975 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
2977 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
2978 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
2979 append_elem(OP_LIST, term,
2980 scalar(newUNOP(OP_RV2CV, 0,
2985 doop = newUNOP(OP_DOFILE, 0, scalar(term));
2991 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
2993 return newBINOP(OP_LSLICE, flags,
2994 list(force_list(subscript)),
2995 list(force_list(listval)) );
2999 S_list_assignment(pTHX_ register OP *o)
3004 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3005 o = cUNOPo->op_first;
3007 if (o->op_type == OP_COND_EXPR) {
3008 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3009 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3014 yyerror("Assignment to both a list and a scalar");
3018 if (o->op_type == OP_LIST &&
3019 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3020 o->op_private & OPpLVAL_INTRO)
3023 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3024 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3025 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3028 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3031 if (o->op_type == OP_RV2SV)
3038 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3043 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3044 return newLOGOP(optype, 0,
3045 mod(scalar(left), optype),
3046 newUNOP(OP_SASSIGN, 0, scalar(right)));
3049 return newBINOP(optype, OPf_STACKED,
3050 mod(scalar(left), optype), scalar(right));
3054 if (list_assignment(left)) {
3058 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3059 left = mod(left, OP_AASSIGN);
3067 curop = list(force_list(left));
3068 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3069 o->op_private = (U8)(0 | (flags >> 8));
3071 /* PL_generation sorcery:
3072 * an assignment like ($a,$b) = ($c,$d) is easier than
3073 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3074 * To detect whether there are common vars, the global var
3075 * PL_generation is incremented for each assign op we compile.
3076 * Then, while compiling the assign op, we run through all the
3077 * variables on both sides of the assignment, setting a spare slot
3078 * in each of them to PL_generation. If any of them already have
3079 * that value, we know we've got commonality. We could use a
3080 * single bit marker, but then we'd have to make 2 passes, first
3081 * to clear the flag, then to test and set it. To find somewhere
3082 * to store these values, evil chicanery is done with SvCUR().
3085 if (!(left->op_private & OPpLVAL_INTRO)) {
3088 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3089 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3090 if (curop->op_type == OP_GV) {
3091 GV *gv = cGVOPx_gv(curop);
3092 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3094 SvCUR(gv) = PL_generation;
3096 else if (curop->op_type == OP_PADSV ||
3097 curop->op_type == OP_PADAV ||
3098 curop->op_type == OP_PADHV ||
3099 curop->op_type == OP_PADANY)
3101 if (PAD_COMPNAME_GEN(curop->op_targ)
3104 PAD_COMPNAME_GEN(curop->op_targ)
3108 else if (curop->op_type == OP_RV2CV)
3110 else if (curop->op_type == OP_RV2SV ||
3111 curop->op_type == OP_RV2AV ||
3112 curop->op_type == OP_RV2HV ||
3113 curop->op_type == OP_RV2GV) {
3114 if (lastop->op_type != OP_GV) /* funny deref? */
3117 else if (curop->op_type == OP_PUSHRE) {
3118 if (((PMOP*)curop)->op_pmreplroot) {
3120 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3121 ((PMOP*)curop)->op_pmreplroot));
3123 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3125 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3127 SvCUR(gv) = PL_generation;
3136 o->op_private |= OPpASSIGN_COMMON;
3138 if (right && right->op_type == OP_SPLIT) {
3140 if ((tmpop = ((LISTOP*)right)->op_first) &&
3141 tmpop->op_type == OP_PUSHRE)
3143 PMOP *pm = (PMOP*)tmpop;
3144 if (left->op_type == OP_RV2AV &&
3145 !(left->op_private & OPpLVAL_INTRO) &&
3146 !(o->op_private & OPpASSIGN_COMMON) )
3148 tmpop = ((UNOP*)left)->op_first;
3149 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3151 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3152 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3154 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3155 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3157 pm->op_pmflags |= PMf_ONCE;
3158 tmpop = cUNOPo->op_first; /* to list (nulled) */
3159 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3160 tmpop->op_sibling = Nullop; /* don't free split */
3161 right->op_next = tmpop->op_next; /* fix starting loc */
3162 op_free(o); /* blow off assign */
3163 right->op_flags &= ~OPf_WANT;
3164 /* "I don't know and I don't care." */
3169 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3170 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3172 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3174 sv_setiv(sv, PL_modcount+1);
3182 right = newOP(OP_UNDEF, 0);
3183 if (right->op_type == OP_READLINE) {
3184 right->op_flags |= OPf_STACKED;
3185 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3188 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3189 o = newBINOP(OP_SASSIGN, flags,
3190 scalar(right), mod(scalar(left), OP_SASSIGN) );
3202 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3204 U32 seq = intro_my();
3207 NewOp(1101, cop, 1, COP);
3208 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3209 cop->op_type = OP_DBSTATE;
3210 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3213 cop->op_type = OP_NEXTSTATE;
3214 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3216 cop->op_flags = (U8)flags;
3217 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3219 cop->op_private |= NATIVE_HINTS;
3221 PL_compiling.op_private = cop->op_private;
3222 cop->op_next = (OP*)cop;
3225 cop->cop_label = label;
3226 PL_hints |= HINT_BLOCK_SCOPE;
3229 cop->cop_arybase = PL_curcop->cop_arybase;
3230 if (specialWARN(PL_curcop->cop_warnings))
3231 cop->cop_warnings = PL_curcop->cop_warnings ;
3233 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3234 if (specialCopIO(PL_curcop->cop_io))
3235 cop->cop_io = PL_curcop->cop_io;
3237 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3240 if (PL_copline == NOLINE)
3241 CopLINE_set(cop, CopLINE(PL_curcop));
3243 CopLINE_set(cop, PL_copline);
3244 PL_copline = NOLINE;
3247 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3249 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3251 CopSTASH_set(cop, PL_curstash);
3253 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3254 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3255 if (svp && *svp != &PL_sv_undef ) {
3256 (void)SvIOK_on(*svp);
3257 SvIVX(*svp) = PTR2IV(cop);
3261 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3266 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3268 return new_logop(type, flags, &first, &other);
3272 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3276 OP *first = *firstp;
3277 OP *other = *otherp;
3279 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3280 return newBINOP(type, flags, scalar(first), scalar(other));
3282 scalarboolean(first);
3283 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3284 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3285 if (type == OP_AND || type == OP_OR) {
3291 first = *firstp = cUNOPo->op_first;
3293 first->op_next = o->op_next;
3294 cUNOPo->op_first = Nullop;
3298 if (first->op_type == OP_CONST) {
3299 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE)) {
3300 if (first->op_private & OPpCONST_STRICT)
3301 no_bareword_allowed(first);
3303 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3305 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3316 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3317 OP *k1 = ((UNOP*)first)->op_first;
3318 OP *k2 = k1->op_sibling;
3320 switch (first->op_type)
3323 if (k2 && k2->op_type == OP_READLINE
3324 && (k2->op_flags & OPf_STACKED)
3325 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3327 warnop = k2->op_type;
3332 if (k1->op_type == OP_READDIR
3333 || k1->op_type == OP_GLOB
3334 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3335 || k1->op_type == OP_EACH)
3337 warnop = ((k1->op_type == OP_NULL)
3338 ? (OPCODE)k1->op_targ : k1->op_type);
3343 line_t oldline = CopLINE(PL_curcop);
3344 CopLINE_set(PL_curcop, PL_copline);
3345 Perl_warner(aTHX_ packWARN(WARN_MISC),
3346 "Value of %s%s can be \"0\"; test with defined()",
3348 ((warnop == OP_READLINE || warnop == OP_GLOB)
3349 ? " construct" : "() operator"));
3350 CopLINE_set(PL_curcop, oldline);
3357 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3358 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3360 NewOp(1101, logop, 1, LOGOP);
3362 logop->op_type = (OPCODE)type;
3363 logop->op_ppaddr = PL_ppaddr[type];
3364 logop->op_first = first;
3365 logop->op_flags = flags | OPf_KIDS;
3366 logop->op_other = LINKLIST(other);
3367 logop->op_private = (U8)(1 | (flags >> 8));
3369 /* establish postfix order */
3370 logop->op_next = LINKLIST(first);
3371 first->op_next = (OP*)logop;
3372 first->op_sibling = other;
3374 o = newUNOP(OP_NULL, 0, (OP*)logop);
3381 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3388 return newLOGOP(OP_AND, 0, first, trueop);
3390 return newLOGOP(OP_OR, 0, first, falseop);
3392 scalarboolean(first);
3393 if (first->op_type == OP_CONST) {
3394 if (first->op_private & OPpCONST_BARE &&
3395 first->op_private & OPpCONST_STRICT) {
3396 no_bareword_allowed(first);
3398 if (SvTRUE(((SVOP*)first)->op_sv)) {
3409 NewOp(1101, logop, 1, LOGOP);
3410 logop->op_type = OP_COND_EXPR;
3411 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3412 logop->op_first = first;
3413 logop->op_flags = flags | OPf_KIDS;
3414 logop->op_private = (U8)(1 | (flags >> 8));
3415 logop->op_other = LINKLIST(trueop);
3416 logop->op_next = LINKLIST(falseop);
3419 /* establish postfix order */
3420 start = LINKLIST(first);
3421 first->op_next = (OP*)logop;
3423 first->op_sibling = trueop;
3424 trueop->op_sibling = falseop;
3425 o = newUNOP(OP_NULL, 0, (OP*)logop);
3427 trueop->op_next = falseop->op_next = o;
3434 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3442 NewOp(1101, range, 1, LOGOP);
3444 range->op_type = OP_RANGE;
3445 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3446 range->op_first = left;
3447 range->op_flags = OPf_KIDS;
3448 leftstart = LINKLIST(left);
3449 range->op_other = LINKLIST(right);
3450 range->op_private = (U8)(1 | (flags >> 8));
3452 left->op_sibling = right;
3454 range->op_next = (OP*)range;
3455 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3456 flop = newUNOP(OP_FLOP, 0, flip);
3457 o = newUNOP(OP_NULL, 0, flop);
3459 range->op_next = leftstart;
3461 left->op_next = flip;
3462 right->op_next = flop;
3464 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3465 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3466 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3467 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3469 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3470 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3473 if (!flip->op_private || !flop->op_private)
3474 linklist(o); /* blow off optimizer unless constant */
3480 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3484 int once = block && block->op_flags & OPf_SPECIAL &&
3485 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3488 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3489 return block; /* do {} while 0 does once */
3490 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3491 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3492 expr = newUNOP(OP_DEFINED, 0,
3493 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3494 } else if (expr->op_flags & OPf_KIDS) {
3495 OP *k1 = ((UNOP*)expr)->op_first;
3496 OP *k2 = (k1) ? k1->op_sibling : NULL;
3497 switch (expr->op_type) {
3499 if (k2 && k2->op_type == OP_READLINE
3500 && (k2->op_flags & OPf_STACKED)
3501 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3502 expr = newUNOP(OP_DEFINED, 0, expr);
3506 if (k1->op_type == OP_READDIR
3507 || k1->op_type == OP_GLOB
3508 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3509 || k1->op_type == OP_EACH)
3510 expr = newUNOP(OP_DEFINED, 0, expr);
3516 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3517 o = new_logop(OP_AND, 0, &expr, &listop);
3520 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3522 if (once && o != listop)
3523 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3526 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3528 o->op_flags |= flags;
3530 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3535 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3543 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3544 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3545 expr = newUNOP(OP_DEFINED, 0,
3546 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3547 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3548 OP *k1 = ((UNOP*)expr)->op_first;
3549 OP *k2 = (k1) ? k1->op_sibling : NULL;
3550 switch (expr->op_type) {
3552 if (k2 && k2->op_type == OP_READLINE
3553 && (k2->op_flags & OPf_STACKED)
3554 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3555 expr = newUNOP(OP_DEFINED, 0, expr);
3559 if (k1->op_type == OP_READDIR
3560 || k1->op_type == OP_GLOB
3561 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3562 || k1->op_type == OP_EACH)
3563 expr = newUNOP(OP_DEFINED, 0, expr);
3569 block = newOP(OP_NULL, 0);
3571 block = scope(block);
3575 next = LINKLIST(cont);
3578 OP *unstack = newOP(OP_UNSTACK, 0);
3581 cont = append_elem(OP_LINESEQ, cont, unstack);
3582 if ((line_t)whileline != NOLINE) {
3583 PL_copline = (line_t)whileline;
3584 cont = append_elem(OP_LINESEQ, cont,
3585 newSTATEOP(0, Nullch, Nullop));
3589 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3590 redo = LINKLIST(listop);
3593 PL_copline = (line_t)whileline;
3595 o = new_logop(OP_AND, 0, &expr, &listop);
3596 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3597 op_free(expr); /* oops, it's a while (0) */
3599 return Nullop; /* listop already freed by new_logop */
3602 ((LISTOP*)listop)->op_last->op_next =
3603 (o == listop ? redo : LINKLIST(o));
3609 NewOp(1101,loop,1,LOOP);
3610 loop->op_type = OP_ENTERLOOP;
3611 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3612 loop->op_private = 0;
3613 loop->op_next = (OP*)loop;
3616 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3618 loop->op_redoop = redo;
3619 loop->op_lastop = o;
3620 o->op_private |= loopflags;
3623 loop->op_nextop = next;
3625 loop->op_nextop = o;
3627 o->op_flags |= flags;
3628 o->op_private |= (flags >> 8);
3633 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
3637 PADOFFSET padoff = 0;
3641 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
3642 sv->op_type = OP_RV2GV;
3643 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3645 else if (sv->op_type == OP_PADSV) { /* private variable */
3646 padoff = sv->op_targ;
3651 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3652 padoff = sv->op_targ;
3654 iterflags |= OPf_SPECIAL;
3659 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3662 sv = newGVOP(OP_GV, 0, PL_defgv);
3664 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3665 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3666 iterflags |= OPf_STACKED;
3668 else if (expr->op_type == OP_NULL &&
3669 (expr->op_flags & OPf_KIDS) &&
3670 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3672 /* Basically turn for($x..$y) into the same as for($x,$y), but we
3673 * set the STACKED flag to indicate that these values are to be
3674 * treated as min/max values by 'pp_iterinit'.
3676 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
3677 LOGOP* range = (LOGOP*) flip->op_first;
3678 OP* left = range->op_first;
3679 OP* right = left->op_sibling;
3682 range->op_flags &= ~OPf_KIDS;
3683 range->op_first = Nullop;
3685 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
3686 listop->op_first->op_next = range->op_next;
3687 left->op_next = range->op_other;
3688 right->op_next = (OP*)listop;
3689 listop->op_next = listop->op_first;
3692 expr = (OP*)(listop);
3694 iterflags |= OPf_STACKED;
3697 expr = mod(force_list(expr), OP_GREPSTART);
3701 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
3702 append_elem(OP_LIST, expr, scalar(sv))));
3703 assert(!loop->op_next);
3704 #ifdef PL_OP_SLAB_ALLOC
3707 NewOp(1234,tmp,1,LOOP);
3708 Copy(loop,tmp,1,LOOP);
3713 Renew(loop, 1, LOOP);
3715 loop->op_targ = padoff;
3716 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
3717 PL_copline = forline;
3718 return newSTATEOP(0, label, wop);
3722 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
3727 if (type != OP_GOTO || label->op_type == OP_CONST) {
3728 /* "last()" means "last" */
3729 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
3730 o = newOP(type, OPf_SPECIAL);
3732 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
3733 ? SvPVx(((SVOP*)label)->op_sv, n_a)
3739 if (label->op_type == OP_ENTERSUB)
3740 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
3741 o = newUNOP(type, OPf_STACKED, label);
3743 PL_hints |= HINT_BLOCK_SCOPE;
3748 Perl_cv_undef(pTHX_ CV *cv)
3751 CV *freecv = Nullcv;
3754 if (CvFILE(cv) && !CvXSUB(cv)) {
3755 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
3756 Safefree(CvFILE(cv));
3761 if (!CvXSUB(cv) && CvROOT(cv)) {
3763 Perl_croak(aTHX_ "Can't undef active subroutine");
3766 PAD_SAVE_SETNULLPAD();
3768 op_free(CvROOT(cv));
3769 CvROOT(cv) = Nullop;
3772 SvPOK_off((SV*)cv); /* forget prototype */
3774 outsidecv = CvOUTSIDE(cv);
3775 /* Since closure prototypes have the same lifetime as the containing
3776 * CV, they don't hold a refcount on the outside CV. This avoids
3777 * the refcount loop between the outer CV (which keeps a refcount to
3778 * the closure prototype in the pad entry for pp_anoncode()) and the
3779 * closure prototype, and the ensuing memory leak. --GSAR */
3780 if (!CvANON(cv) || CvCLONED(cv))
3782 CvOUTSIDE(cv) = Nullcv;
3784 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
3787 pad_undef(cv, outsidecv);
3789 SvREFCNT_dec(freecv);
3797 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
3799 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
3800 SV* msg = sv_newmortal();
3804 gv_efullname3(name = sv_newmortal(), gv, Nullch);
3805 sv_setpv(msg, "Prototype mismatch:");
3807 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
3809 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
3810 sv_catpv(msg, " vs ");
3812 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
3814 sv_catpv(msg, "none");
3815 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
3819 static void const_sv_xsub(pTHX_ CV* cv);
3823 =head1 Optree Manipulation Functions
3825 =for apidoc cv_const_sv
3827 If C<cv> is a constant sub eligible for inlining. returns the constant
3828 value returned by the sub. Otherwise, returns NULL.
3830 Constant subs can be created with C<newCONSTSUB> or as described in
3831 L<perlsub/"Constant Functions">.
3836 Perl_cv_const_sv(pTHX_ CV *cv)
3838 if (!cv || !CvCONST(cv))
3840 return (SV*)CvXSUBANY(cv).any_ptr;
3844 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
3851 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
3852 o = cLISTOPo->op_first->op_sibling;
3854 for (; o; o = o->op_next) {
3855 OPCODE type = o->op_type;
3857 if (sv && o->op_next == o)
3859 if (o->op_next != o) {
3860 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
3862 if (type == OP_DBSTATE)
3865 if (type == OP_LEAVESUB || type == OP_RETURN)
3869 if (type == OP_CONST && cSVOPo->op_sv)
3871 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
3872 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
3876 /* We get here only from cv_clone2() while creating a closure.
3877 Copy the const value here instead of in cv_clone2 so that
3878 SvREADONLY_on doesn't lead to problems when leaving
3883 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
3895 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
3905 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
3909 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
3911 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
3915 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
3921 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
3925 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
3926 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
3927 SV *sv = sv_newmortal();
3928 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
3929 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
3930 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3935 gv = gv_fetchpv(name ? name : (aname ? aname :
3936 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__")),
3937 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
3947 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
3948 maximum a prototype before. */
3949 if (SvTYPE(gv) > SVt_NULL) {
3950 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
3951 && ckWARN_d(WARN_PROTOTYPE))
3953 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
3955 cv_ckproto((CV*)gv, NULL, ps);
3958 sv_setpv((SV*)gv, ps);
3960 sv_setiv((SV*)gv, -1);
3961 SvREFCNT_dec(PL_compcv);
3962 cv = PL_compcv = NULL;
3963 PL_sub_generation++;
3967 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
3969 #ifdef GV_UNIQUE_CHECK
3970 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
3971 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
3975 if (!block || !ps || *ps || attrs)
3978 const_sv = op_const_sv(block, Nullcv);
3981 bool exists = CvROOT(cv) || CvXSUB(cv);
3983 #ifdef GV_UNIQUE_CHECK
3984 if (exists && GvUNIQUE(gv)) {
3985 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
3989 /* if the subroutine doesn't exist and wasn't pre-declared
3990 * with a prototype, assume it will be AUTOLOADed,
3991 * skipping the prototype check
3993 if (exists || SvPOK(cv))
3994 cv_ckproto(cv, gv, ps);
3995 /* already defined (or promised)? */
3996 if (exists || GvASSUMECV(gv)) {
3997 if (!block && !attrs) {
3998 if (CvFLAGS(PL_compcv)) {
3999 /* might have had built-in attrs applied */
4000 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4002 /* just a "sub foo;" when &foo is already defined */
4003 SAVEFREESV(PL_compcv);
4006 /* ahem, death to those who redefine active sort subs */
4007 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4008 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4010 if (ckWARN(WARN_REDEFINE)
4012 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4014 line_t oldline = CopLINE(PL_curcop);
4015 if (PL_copline != NOLINE)
4016 CopLINE_set(PL_curcop, PL_copline);
4017 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4018 CvCONST(cv) ? "Constant subroutine %s redefined"
4019 : "Subroutine %s redefined", name);
4020 CopLINE_set(PL_curcop, oldline);
4028 SvREFCNT_inc(const_sv);
4030 assert(!CvROOT(cv) && !CvCONST(cv));
4031 sv_setpv((SV*)cv, ""); /* prototype is "" */
4032 CvXSUBANY(cv).any_ptr = const_sv;
4033 CvXSUB(cv) = const_sv_xsub;
4038 cv = newCONSTSUB(NULL, name, const_sv);
4041 SvREFCNT_dec(PL_compcv);
4043 PL_sub_generation++;
4050 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4051 * before we clobber PL_compcv.
4055 /* Might have had built-in attributes applied -- propagate them. */
4056 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4057 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4058 stash = GvSTASH(CvGV(cv));
4059 else if (CvSTASH(cv))
4060 stash = CvSTASH(cv);
4062 stash = PL_curstash;
4065 /* possibly about to re-define existing subr -- ignore old cv */
4066 rcv = (SV*)PL_compcv;
4067 if (name && GvSTASH(gv))
4068 stash = GvSTASH(gv);
4070 stash = PL_curstash;
4072 apply_attrs(stash, rcv, attrs, FALSE);
4074 if (cv) { /* must reuse cv if autoloaded */
4076 /* got here with just attrs -- work done, so bug out */
4077 SAVEFREESV(PL_compcv);
4081 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4082 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4083 CvOUTSIDE(PL_compcv) = 0;
4084 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4085 CvPADLIST(PL_compcv) = 0;
4086 /* inner references to PL_compcv must be fixed up ... */
4087 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4088 /* ... before we throw it away */
4089 SvREFCNT_dec(PL_compcv);
4090 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4091 ++PL_sub_generation;
4098 PL_sub_generation++;
4102 CvFILE_set_from_cop(cv, PL_curcop);
4103 CvSTASH(cv) = PL_curstash;
4106 sv_setpv((SV*)cv, ps);
4108 if (PL_error_count) {
4112 char *s = strrchr(name, ':');
4114 if (strEQ(s, "BEGIN")) {
4116 "BEGIN not safe after errors--compilation aborted";
4117 if (PL_in_eval & EVAL_KEEPERR)
4118 Perl_croak(aTHX_ not_safe);
4120 /* force display of errors found but not reported */
4121 sv_catpv(ERRSV, not_safe);
4122 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4131 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4132 mod(scalarseq(block), OP_LEAVESUBLV));
4135 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4137 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4138 OpREFCNT_set(CvROOT(cv), 1);
4139 CvSTART(cv) = LINKLIST(CvROOT(cv));
4140 CvROOT(cv)->op_next = 0;
4141 CALL_PEEP(CvSTART(cv));
4143 /* now that optimizer has done its work, adjust pad values */
4145 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4148 assert(!CvCONST(cv));
4149 if (ps && !*ps && op_const_sv(block, cv))
4153 /* If a potential closure prototype, don't keep a refcount on outer CV.
4154 * This is okay as the lifetime of the prototype is tied to the
4155 * lifetime of the outer CV. Avoids memory leak due to reference
4158 SvREFCNT_dec(CvOUTSIDE(cv));
4160 if (name || aname) {
4162 char *tname = (name ? name : aname);
4164 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4165 SV *sv = NEWSV(0,0);
4166 SV *tmpstr = sv_newmortal();
4167 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4171 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4173 (long)PL_subline, (long)CopLINE(PL_curcop));
4174 gv_efullname3(tmpstr, gv, Nullch);
4175 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4176 hv = GvHVn(db_postponed);
4177 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4178 && (pcv = GvCV(db_postponed)))
4184 call_sv((SV*)pcv, G_DISCARD);
4188 if ((s = strrchr(tname,':')))
4193 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4196 if (strEQ(s, "BEGIN")) {
4197 I32 oldscope = PL_scopestack_ix;
4199 SAVECOPFILE(&PL_compiling);
4200 SAVECOPLINE(&PL_compiling);
4203 PL_beginav = newAV();
4204 DEBUG_x( dump_sub(gv) );
4205 av_push(PL_beginav, (SV*)cv);
4206 GvCV(gv) = 0; /* cv has been hijacked */
4207 call_list(oldscope, PL_beginav);
4209 PL_curcop = &PL_compiling;
4210 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4213 else if (strEQ(s, "END") && !PL_error_count) {
4216 DEBUG_x( dump_sub(gv) );
4217 av_unshift(PL_endav, 1);
4218 av_store(PL_endav, 0, (SV*)cv);
4219 GvCV(gv) = 0; /* cv has been hijacked */
4221 else if (strEQ(s, "CHECK") && !PL_error_count) {
4223 PL_checkav = newAV();
4224 DEBUG_x( dump_sub(gv) );
4225 if (PL_main_start && ckWARN(WARN_VOID))
4226 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4227 av_unshift(PL_checkav, 1);
4228 av_store(PL_checkav, 0, (SV*)cv);
4229 GvCV(gv) = 0; /* cv has been hijacked */
4231 else if (strEQ(s, "INIT") && !PL_error_count) {
4233 PL_initav = newAV();
4234 DEBUG_x( dump_sub(gv) );
4235 if (PL_main_start && ckWARN(WARN_VOID))
4236 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4237 av_push(PL_initav, (SV*)cv);
4238 GvCV(gv) = 0; /* cv has been hijacked */
4243 PL_copline = NOLINE;
4248 /* XXX unsafe for threads if eval_owner isn't held */
4250 =for apidoc newCONSTSUB
4252 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4253 eligible for inlining at compile-time.
4259 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4265 SAVECOPLINE(PL_curcop);
4266 CopLINE_set(PL_curcop, PL_copline);
4269 PL_hints &= ~HINT_BLOCK_SCOPE;
4272 SAVESPTR(PL_curstash);
4273 SAVECOPSTASH(PL_curcop);
4274 PL_curstash = stash;
4275 CopSTASH_set(PL_curcop,stash);
4278 cv = newXS(name, const_sv_xsub, __FILE__);
4279 CvXSUBANY(cv).any_ptr = sv;
4281 sv_setpv((SV*)cv, ""); /* prototype is "" */
4289 =for apidoc U||newXS
4291 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4297 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
4299 GV *gv = gv_fetchpv(name ? name :
4300 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4301 GV_ADDMULTI, SVt_PVCV);
4305 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4307 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4309 /* just a cached method */
4313 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4314 /* already defined (or promised) */
4315 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4316 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4317 line_t oldline = CopLINE(PL_curcop);
4318 if (PL_copline != NOLINE)
4319 CopLINE_set(PL_curcop, PL_copline);
4320 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4321 CvCONST(cv) ? "Constant subroutine %s redefined"
4322 : "Subroutine %s redefined"
4324 CopLINE_set(PL_curcop, oldline);
4331 if (cv) /* must reuse cv if autoloaded */
4334 cv = (CV*)NEWSV(1105,0);
4335 sv_upgrade((SV *)cv, SVt_PVCV);
4339 PL_sub_generation++;
4343 (void)gv_fetchfile(filename);
4344 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
4345 an external constant string */
4346 CvXSUB(cv) = subaddr;
4349 char *s = strrchr(name,':');
4355 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4358 if (strEQ(s, "BEGIN")) {
4360 PL_beginav = newAV();
4361 av_push(PL_beginav, (SV*)cv);
4362 GvCV(gv) = 0; /* cv has been hijacked */
4364 else if (strEQ(s, "END")) {
4367 av_unshift(PL_endav, 1);
4368 av_store(PL_endav, 0, (SV*)cv);
4369 GvCV(gv) = 0; /* cv has been hijacked */
4371 else if (strEQ(s, "CHECK")) {
4373 PL_checkav = newAV();
4374 if (PL_main_start && ckWARN(WARN_VOID))
4375 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4376 av_unshift(PL_checkav, 1);
4377 av_store(PL_checkav, 0, (SV*)cv);
4378 GvCV(gv) = 0; /* cv has been hijacked */
4380 else if (strEQ(s, "INIT")) {
4382 PL_initav = newAV();
4383 if (PL_main_start && ckWARN(WARN_VOID))
4384 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4385 av_push(PL_initav, (SV*)cv);
4386 GvCV(gv) = 0; /* cv has been hijacked */
4397 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4405 name = SvPVx(cSVOPo->op_sv, n_a);
4408 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
4409 #ifdef GV_UNIQUE_CHECK
4411 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4415 if ((cv = GvFORM(gv))) {
4416 if (ckWARN(WARN_REDEFINE)) {
4417 line_t oldline = CopLINE(PL_curcop);
4418 if (PL_copline != NOLINE)
4419 CopLINE_set(PL_curcop, PL_copline);
4420 Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Format %s redefined",name);
4421 CopLINE_set(PL_curcop, oldline);
4428 CvFILE_set_from_cop(cv, PL_curcop);
4431 pad_tidy(padtidy_FORMAT);
4432 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4433 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4434 OpREFCNT_set(CvROOT(cv), 1);
4435 CvSTART(cv) = LINKLIST(CvROOT(cv));
4436 CvROOT(cv)->op_next = 0;
4437 CALL_PEEP(CvSTART(cv));
4439 PL_copline = NOLINE;
4444 Perl_newANONLIST(pTHX_ OP *o)
4446 return newUNOP(OP_REFGEN, 0,
4447 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4451 Perl_newANONHASH(pTHX_ OP *o)
4453 return newUNOP(OP_REFGEN, 0,
4454 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4458 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4460 return newANONATTRSUB(floor, proto, Nullop, block);
4464 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4466 return newUNOP(OP_REFGEN, 0,
4467 newSVOP(OP_ANONCODE, 0,
4468 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
4472 Perl_oopsAV(pTHX_ OP *o)
4474 switch (o->op_type) {
4476 o->op_type = OP_PADAV;
4477 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4478 return ref(o, OP_RV2AV);
4481 o->op_type = OP_RV2AV;
4482 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4487 if (ckWARN_d(WARN_INTERNAL))
4488 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
4495 Perl_oopsHV(pTHX_ OP *o)
4497 switch (o->op_type) {
4500 o->op_type = OP_PADHV;
4501 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4502 return ref(o, OP_RV2HV);
4506 o->op_type = OP_RV2HV;
4507 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
4512 if (ckWARN_d(WARN_INTERNAL))
4513 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
4520 Perl_newAVREF(pTHX_ OP *o)
4522 if (o->op_type == OP_PADANY) {
4523 o->op_type = OP_PADAV;
4524 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4527 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
4528 && ckWARN(WARN_DEPRECATED)) {
4529 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4530 "Using an array as a reference is deprecated");
4532 return newUNOP(OP_RV2AV, 0, scalar(o));
4536 Perl_newGVREF(pTHX_ I32 type, OP *o)
4538 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
4539 return newUNOP(OP_NULL, 0, o);
4540 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
4544 Perl_newHVREF(pTHX_ OP *o)
4546 if (o->op_type == OP_PADANY) {
4547 o->op_type = OP_PADHV;
4548 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4551 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
4552 && ckWARN(WARN_DEPRECATED)) {
4553 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4554 "Using a hash as a reference is deprecated");
4556 return newUNOP(OP_RV2HV, 0, scalar(o));
4560 Perl_oopsCV(pTHX_ OP *o)
4562 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
4568 Perl_newCVREF(pTHX_ I32 flags, OP *o)
4570 return newUNOP(OP_RV2CV, flags, scalar(o));
4574 Perl_newSVREF(pTHX_ OP *o)
4576 if (o->op_type == OP_PADANY) {
4577 o->op_type = OP_PADSV;
4578 o->op_ppaddr = PL_ppaddr[OP_PADSV];
4581 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4582 o->op_flags |= OPpDONE_SVREF;
4585 return newUNOP(OP_RV2SV, 0, scalar(o));
4588 /* Check routines. */
4591 Perl_ck_anoncode(pTHX_ OP *o)
4593 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
4594 cSVOPo->op_sv = Nullsv;
4599 Perl_ck_bitop(pTHX_ OP *o)
4601 #define OP_IS_NUMCOMPARE(op) \
4602 ((op) == OP_LT || (op) == OP_I_LT || \
4603 (op) == OP_GT || (op) == OP_I_GT || \
4604 (op) == OP_LE || (op) == OP_I_LE || \
4605 (op) == OP_GE || (op) == OP_I_GE || \
4606 (op) == OP_EQ || (op) == OP_I_EQ || \
4607 (op) == OP_NE || (op) == OP_I_NE || \
4608 (op) == OP_NCMP || (op) == OP_I_NCMP)
4609 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4610 if (o->op_type == OP_BIT_OR
4611 || o->op_type == OP_BIT_AND
4612 || o->op_type == OP_BIT_XOR)
4614 OPCODE typfirst = cBINOPo->op_first->op_type;
4615 OPCODE typlast = cBINOPo->op_first->op_sibling->op_type;
4616 if (OP_IS_NUMCOMPARE(typfirst) || OP_IS_NUMCOMPARE(typlast))
4617 if (ckWARN(WARN_PRECEDENCE))
4618 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4619 "Possible precedence problem on bitwise %c operator",
4620 o->op_type == OP_BIT_OR ? '|'
4621 : o->op_type == OP_BIT_AND ? '&' : '^'
4628 Perl_ck_concat(pTHX_ OP *o)
4630 if (cUNOPo->op_first->op_type == OP_CONCAT)
4631 o->op_flags |= OPf_STACKED;
4636 Perl_ck_spair(pTHX_ OP *o)
4638 if (o->op_flags & OPf_KIDS) {
4641 OPCODE type = o->op_type;
4642 o = modkids(ck_fun(o), type);
4643 kid = cUNOPo->op_first;
4644 newop = kUNOP->op_first->op_sibling;
4646 (newop->op_sibling ||
4647 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
4648 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
4649 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
4653 op_free(kUNOP->op_first);
4654 kUNOP->op_first = newop;
4656 o->op_ppaddr = PL_ppaddr[++o->op_type];
4661 Perl_ck_delete(pTHX_ OP *o)
4665 if (o->op_flags & OPf_KIDS) {
4666 OP *kid = cUNOPo->op_first;
4667 switch (kid->op_type) {
4669 o->op_flags |= OPf_SPECIAL;
4672 o->op_private |= OPpSLICE;
4675 o->op_flags |= OPf_SPECIAL;
4680 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
4689 Perl_ck_die(pTHX_ OP *o)
4692 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4698 Perl_ck_eof(pTHX_ OP *o)
4700 I32 type = o->op_type;
4702 if (o->op_flags & OPf_KIDS) {
4703 if (cLISTOPo->op_first->op_type == OP_STUB) {
4705 o = newUNOP(type, OPf_SPECIAL,
4706 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
4714 Perl_ck_eval(pTHX_ OP *o)
4716 PL_hints |= HINT_BLOCK_SCOPE;
4717 if (o->op_flags & OPf_KIDS) {
4718 SVOP *kid = (SVOP*)cUNOPo->op_first;
4721 o->op_flags &= ~OPf_KIDS;
4724 else if (kid->op_type == OP_LINESEQ) {
4727 kid->op_next = o->op_next;
4728 cUNOPo->op_first = 0;
4731 NewOp(1101, enter, 1, LOGOP);
4732 enter->op_type = OP_ENTERTRY;
4733 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
4734 enter->op_private = 0;
4736 /* establish postfix order */
4737 enter->op_next = (OP*)enter;
4739 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
4740 o->op_type = OP_LEAVETRY;
4741 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
4742 enter->op_other = o;
4750 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
4752 o->op_targ = (PADOFFSET)PL_hints;
4757 Perl_ck_exit(pTHX_ OP *o)
4760 HV *table = GvHV(PL_hintgv);
4762 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
4763 if (svp && *svp && SvTRUE(*svp))
4764 o->op_private |= OPpEXIT_VMSISH;
4766 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4772 Perl_ck_exec(pTHX_ OP *o)
4775 if (o->op_flags & OPf_STACKED) {
4777 kid = cUNOPo->op_first->op_sibling;
4778 if (kid->op_type == OP_RV2GV)
4787 Perl_ck_exists(pTHX_ OP *o)
4790 if (o->op_flags & OPf_KIDS) {
4791 OP *kid = cUNOPo->op_first;
4792 if (kid->op_type == OP_ENTERSUB) {
4793 (void) ref(kid, o->op_type);
4794 if (kid->op_type != OP_RV2CV && !PL_error_count)
4795 Perl_croak(aTHX_ "%s argument is not a subroutine name",
4797 o->op_private |= OPpEXISTS_SUB;
4799 else if (kid->op_type == OP_AELEM)
4800 o->op_flags |= OPf_SPECIAL;
4801 else if (kid->op_type != OP_HELEM)
4802 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
4811 Perl_ck_gvconst(pTHX_ register OP *o)
4813 o = fold_constants(o);
4814 if (o->op_type == OP_CONST)
4821 Perl_ck_rvconst(pTHX_ register OP *o)
4823 SVOP *kid = (SVOP*)cUNOPo->op_first;
4825 o->op_private |= (PL_hints & HINT_STRICT_REFS);
4826 if (kid->op_type == OP_CONST) {
4830 SV *kidsv = kid->op_sv;
4833 /* Is it a constant from cv_const_sv()? */
4834 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
4835 SV *rsv = SvRV(kidsv);
4836 int svtype = SvTYPE(rsv);
4837 char *badtype = Nullch;
4839 switch (o->op_type) {
4841 if (svtype > SVt_PVMG)
4842 badtype = "a SCALAR";
4845 if (svtype != SVt_PVAV)
4846 badtype = "an ARRAY";
4849 if (svtype != SVt_PVHV)
4853 if (svtype != SVt_PVCV)
4858 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
4861 name = SvPV(kidsv, n_a);
4862 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
4863 char *badthing = Nullch;
4864 switch (o->op_type) {
4866 badthing = "a SCALAR";
4869 badthing = "an ARRAY";
4872 badthing = "a HASH";
4877 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
4881 * This is a little tricky. We only want to add the symbol if we
4882 * didn't add it in the lexer. Otherwise we get duplicate strict
4883 * warnings. But if we didn't add it in the lexer, we must at
4884 * least pretend like we wanted to add it even if it existed before,
4885 * or we get possible typo warnings. OPpCONST_ENTERED says
4886 * whether the lexer already added THIS instance of this symbol.
4888 iscv = (o->op_type == OP_RV2CV) * 2;
4890 gv = gv_fetchpv(name,
4891 iscv | !(kid->op_private & OPpCONST_ENTERED),
4894 : o->op_type == OP_RV2SV
4896 : o->op_type == OP_RV2AV
4898 : o->op_type == OP_RV2HV
4901 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
4903 kid->op_type = OP_GV;
4904 SvREFCNT_dec(kid->op_sv);
4906 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
4907 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
4908 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
4910 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
4912 kid->op_sv = SvREFCNT_inc(gv);
4914 kid->op_private = 0;
4915 kid->op_ppaddr = PL_ppaddr[OP_GV];
4922 Perl_ck_ftst(pTHX_ OP *o)
4924 I32 type = o->op_type;
4926 if (o->op_flags & OPf_REF) {
4929 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
4930 SVOP *kid = (SVOP*)cUNOPo->op_first;
4932 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
4934 OP *newop = newGVOP(type, OPf_REF,
4935 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
4942 if (type == OP_FTTTY)
4943 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
4946 o = newUNOP(type, 0, newDEFSVOP());
4952 Perl_ck_fun(pTHX_ OP *o)
4958 int type = o->op_type;
4959 register I32 oa = PL_opargs[type] >> OASHIFT;
4961 if (o->op_flags & OPf_STACKED) {
4962 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
4965 return no_fh_allowed(o);
4968 if (o->op_flags & OPf_KIDS) {
4970 tokid = &cLISTOPo->op_first;
4971 kid = cLISTOPo->op_first;
4972 if (kid->op_type == OP_PUSHMARK ||
4973 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
4975 tokid = &kid->op_sibling;
4976 kid = kid->op_sibling;
4978 if (!kid && PL_opargs[type] & OA_DEFGV)
4979 *tokid = kid = newDEFSVOP();
4983 sibl = kid->op_sibling;
4986 /* list seen where single (scalar) arg expected? */
4987 if (numargs == 1 && !(oa >> 4)
4988 && kid->op_type == OP_LIST && type != OP_SCALAR)
4990 return too_many_arguments(o,PL_op_desc[type]);
5003 if ((type == OP_PUSH || type == OP_UNSHIFT)
5004 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5005 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5006 "Useless use of %s with no values",
5009 if (kid->op_type == OP_CONST &&
5010 (kid->op_private & OPpCONST_BARE))
5012 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5013 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5014 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5015 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5016 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5017 "Array @%s missing the @ in argument %"IVdf" of %s()",
5018 name, (IV)numargs, PL_op_desc[type]);
5021 kid->op_sibling = sibl;
5024 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5025 bad_type(numargs, "array", PL_op_desc[type], kid);
5029 if (kid->op_type == OP_CONST &&
5030 (kid->op_private & OPpCONST_BARE))
5032 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5033 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5034 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5035 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5036 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5037 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5038 name, (IV)numargs, PL_op_desc[type]);
5041 kid->op_sibling = sibl;
5044 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5045 bad_type(numargs, "hash", PL_op_desc[type], kid);
5050 OP *newop = newUNOP(OP_NULL, 0, kid);
5051 kid->op_sibling = 0;
5053 newop->op_next = newop;
5055 kid->op_sibling = sibl;
5060 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5061 if (kid->op_type == OP_CONST &&
5062 (kid->op_private & OPpCONST_BARE))
5064 OP *newop = newGVOP(OP_GV, 0,
5065 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5067 if (!(o->op_private & 1) && /* if not unop */
5068 kid == cLISTOPo->op_last)
5069 cLISTOPo->op_last = newop;
5073 else if (kid->op_type == OP_READLINE) {
5074 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5075 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5078 I32 flags = OPf_SPECIAL;
5082 /* is this op a FH constructor? */
5083 if (is_handle_constructor(o,numargs)) {
5084 char *name = Nullch;
5088 /* Set a flag to tell rv2gv to vivify
5089 * need to "prove" flag does not mean something
5090 * else already - NI-S 1999/05/07
5093 if (kid->op_type == OP_PADSV) {
5094 /*XXX DAPM 2002.08.25 tmp assert test */
5095 /*XXX*/ assert(av_fetch(PL_comppad_name, (kid->op_targ), FALSE));
5096 /*XXX*/ assert(*av_fetch(PL_comppad_name, (kid->op_targ), FALSE));
5098 name = PAD_COMPNAME_PV(kid->op_targ);
5099 /* SvCUR of a pad namesv can't be trusted
5100 * (see PL_generation), so calc its length
5106 else if (kid->op_type == OP_RV2SV
5107 && kUNOP->op_first->op_type == OP_GV)
5109 GV *gv = cGVOPx_gv(kUNOP->op_first);
5111 len = GvNAMELEN(gv);
5113 else if (kid->op_type == OP_AELEM
5114 || kid->op_type == OP_HELEM)
5116 name = "__ANONIO__";
5122 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5123 namesv = PAD_SVl(targ);
5124 (void)SvUPGRADE(namesv, SVt_PV);
5126 sv_setpvn(namesv, "$", 1);
5127 sv_catpvn(namesv, name, len);
5130 kid->op_sibling = 0;
5131 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5132 kid->op_targ = targ;
5133 kid->op_private |= priv;
5135 kid->op_sibling = sibl;
5141 mod(scalar(kid), type);
5145 tokid = &kid->op_sibling;
5146 kid = kid->op_sibling;
5148 o->op_private |= numargs;
5150 return too_many_arguments(o,OP_DESC(o));
5153 else if (PL_opargs[type] & OA_DEFGV) {
5155 return newUNOP(type, 0, newDEFSVOP());
5159 while (oa & OA_OPTIONAL)
5161 if (oa && oa != OA_LIST)
5162 return too_few_arguments(o,OP_DESC(o));
5168 Perl_ck_glob(pTHX_ OP *o)
5173 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5174 append_elem(OP_GLOB, o, newDEFSVOP());
5176 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5177 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5179 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5182 #if !defined(PERL_EXTERNAL_GLOB)
5183 /* XXX this can be tightened up and made more failsafe. */
5187 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5188 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5189 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5190 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5191 GvCV(gv) = GvCV(glob_gv);
5192 SvREFCNT_inc((SV*)GvCV(gv));
5193 GvIMPORTED_CV_on(gv);
5196 #endif /* PERL_EXTERNAL_GLOB */
5198 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5199 append_elem(OP_GLOB, o,
5200 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5201 o->op_type = OP_LIST;
5202 o->op_ppaddr = PL_ppaddr[OP_LIST];
5203 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5204 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5205 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5206 append_elem(OP_LIST, o,
5207 scalar(newUNOP(OP_RV2CV, 0,
5208 newGVOP(OP_GV, 0, gv)))));
5209 o = newUNOP(OP_NULL, 0, ck_subr(o));
5210 o->op_targ = OP_GLOB; /* hint at what it used to be */
5213 gv = newGVgen("main");
5215 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5221 Perl_ck_grep(pTHX_ OP *o)
5225 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5227 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5228 NewOp(1101, gwop, 1, LOGOP);
5230 if (o->op_flags & OPf_STACKED) {
5233 kid = cLISTOPo->op_first->op_sibling;
5234 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5237 kid->op_next = (OP*)gwop;
5238 o->op_flags &= ~OPf_STACKED;
5240 kid = cLISTOPo->op_first->op_sibling;
5241 if (type == OP_MAPWHILE)
5248 kid = cLISTOPo->op_first->op_sibling;
5249 if (kid->op_type != OP_NULL)
5250 Perl_croak(aTHX_ "panic: ck_grep");
5251 kid = kUNOP->op_first;
5253 gwop->op_type = type;
5254 gwop->op_ppaddr = PL_ppaddr[type];
5255 gwop->op_first = listkids(o);
5256 gwop->op_flags |= OPf_KIDS;
5257 gwop->op_private = 1;
5258 gwop->op_other = LINKLIST(kid);
5259 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5260 kid->op_next = (OP*)gwop;
5262 kid = cLISTOPo->op_first->op_sibling;
5263 if (!kid || !kid->op_sibling)
5264 return too_few_arguments(o,OP_DESC(o));
5265 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5266 mod(kid, OP_GREPSTART);
5272 Perl_ck_index(pTHX_ OP *o)
5274 if (o->op_flags & OPf_KIDS) {
5275 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5277 kid = kid->op_sibling; /* get past "big" */
5278 if (kid && kid->op_type == OP_CONST)
5279 fbm_compile(((SVOP*)kid)->op_sv, 0);
5285 Perl_ck_lengthconst(pTHX_ OP *o)
5287 /* XXX length optimization goes here */
5292 Perl_ck_lfun(pTHX_ OP *o)
5294 OPCODE type = o->op_type;
5295 return modkids(ck_fun(o), type);
5299 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5301 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5302 switch (cUNOPo->op_first->op_type) {
5304 /* This is needed for
5305 if (defined %stash::)
5306 to work. Do not break Tk.
5308 break; /* Globals via GV can be undef */
5310 case OP_AASSIGN: /* Is this a good idea? */
5311 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5312 "defined(@array) is deprecated");
5313 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5314 "\t(Maybe you should just omit the defined()?)\n");
5317 /* This is needed for
5318 if (defined %stash::)
5319 to work. Do not break Tk.
5321 break; /* Globals via GV can be undef */
5323 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5324 "defined(%%hash) is deprecated");
5325 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5326 "\t(Maybe you should just omit the defined()?)\n");
5337 Perl_ck_rfun(pTHX_ OP *o)
5339 OPCODE type = o->op_type;
5340 return refkids(ck_fun(o), type);
5344 Perl_ck_listiob(pTHX_ OP *o)
5348 kid = cLISTOPo->op_first;
5351 kid = cLISTOPo->op_first;
5353 if (kid->op_type == OP_PUSHMARK)
5354 kid = kid->op_sibling;
5355 if (kid && o->op_flags & OPf_STACKED)
5356 kid = kid->op_sibling;
5357 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5358 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5359 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5360 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5361 cLISTOPo->op_first->op_sibling = kid;
5362 cLISTOPo->op_last = kid;
5363 kid = kid->op_sibling;
5368 append_elem(o->op_type, o, newDEFSVOP());
5374 Perl_ck_sassign(pTHX_ OP *o)
5376 OP *kid = cLISTOPo->op_first;
5377 /* has a disposable target? */
5378 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5379 && !(kid->op_flags & OPf_STACKED)
5380 /* Cannot steal the second time! */
5381 && !(kid->op_private & OPpTARGET_MY))
5383 OP *kkid = kid->op_sibling;
5385 /* Can just relocate the target. */
5386 if (kkid && kkid->op_type == OP_PADSV
5387 && !(kkid->op_private & OPpLVAL_INTRO))
5389 kid->op_targ = kkid->op_targ;
5391 /* Now we do not need PADSV and SASSIGN. */
5392 kid->op_sibling = o->op_sibling; /* NULL */
5393 cLISTOPo->op_first = NULL;
5396 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
5404 Perl_ck_match(pTHX_ OP *o)
5406 o->op_private |= OPpRUNTIME;
5411 Perl_ck_method(pTHX_ OP *o)
5413 OP *kid = cUNOPo->op_first;
5414 if (kid->op_type == OP_CONST) {
5415 SV* sv = kSVOP->op_sv;
5416 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
5418 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5419 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
5422 kSVOP->op_sv = Nullsv;
5424 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5433 Perl_ck_null(pTHX_ OP *o)
5439 Perl_ck_open(pTHX_ OP *o)
5441 HV *table = GvHV(PL_hintgv);
5445 svp = hv_fetch(table, "open_IN", 7, FALSE);
5447 mode = mode_from_discipline(*svp);
5448 if (mode & O_BINARY)
5449 o->op_private |= OPpOPEN_IN_RAW;
5450 else if (mode & O_TEXT)
5451 o->op_private |= OPpOPEN_IN_CRLF;
5454 svp = hv_fetch(table, "open_OUT", 8, FALSE);
5456 mode = mode_from_discipline(*svp);
5457 if (mode & O_BINARY)
5458 o->op_private |= OPpOPEN_OUT_RAW;
5459 else if (mode & O_TEXT)
5460 o->op_private |= OPpOPEN_OUT_CRLF;
5463 if (o->op_type == OP_BACKTICK)
5469 Perl_ck_repeat(pTHX_ OP *o)
5471 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5472 o->op_private |= OPpREPEAT_DOLIST;
5473 cBINOPo->op_first = force_list(cBINOPo->op_first);
5481 Perl_ck_require(pTHX_ OP *o)
5485 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
5486 SVOP *kid = (SVOP*)cUNOPo->op_first;
5488 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5490 for (s = SvPVX(kid->op_sv); *s; s++) {
5491 if (*s == ':' && s[1] == ':') {
5493 Move(s+2, s+1, strlen(s+2)+1, char);
5494 --SvCUR(kid->op_sv);
5497 if (SvREADONLY(kid->op_sv)) {
5498 SvREADONLY_off(kid->op_sv);
5499 sv_catpvn(kid->op_sv, ".pm", 3);
5500 SvREADONLY_on(kid->op_sv);
5503 sv_catpvn(kid->op_sv, ".pm", 3);
5507 /* handle override, if any */
5508 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
5509 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
5510 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
5512 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5513 OP *kid = cUNOPo->op_first;
5514 cUNOPo->op_first = 0;
5516 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5517 append_elem(OP_LIST, kid,
5518 scalar(newUNOP(OP_RV2CV, 0,
5527 Perl_ck_return(pTHX_ OP *o)
5530 if (CvLVALUE(PL_compcv)) {
5531 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5532 mod(kid, OP_LEAVESUBLV);
5539 Perl_ck_retarget(pTHX_ OP *o)
5541 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5548 Perl_ck_select(pTHX_ OP *o)
5551 if (o->op_flags & OPf_KIDS) {
5552 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5553 if (kid && kid->op_sibling) {
5554 o->op_type = OP_SSELECT;
5555 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
5557 return fold_constants(o);
5561 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5562 if (kid && kid->op_type == OP_RV2GV)
5563 kid->op_private &= ~HINT_STRICT_REFS;
5568 Perl_ck_shift(pTHX_ OP *o)
5570 I32 type = o->op_type;
5572 if (!(o->op_flags & OPf_KIDS)) {
5576 argop = newUNOP(OP_RV2AV, 0,
5577 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
5578 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
5579 return newUNOP(type, 0, scalar(argop));
5581 return scalar(modkids(ck_fun(o), type));
5585 Perl_ck_sort(pTHX_ OP *o)
5589 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
5591 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5592 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
5594 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
5596 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
5598 if (kid->op_type == OP_SCOPE) {
5602 else if (kid->op_type == OP_LEAVE) {
5603 if (o->op_type == OP_SORT) {
5604 op_null(kid); /* wipe out leave */
5607 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
5608 if (k->op_next == kid)
5610 /* don't descend into loops */
5611 else if (k->op_type == OP_ENTERLOOP
5612 || k->op_type == OP_ENTERITER)
5614 k = cLOOPx(k)->op_lastop;
5619 kid->op_next = 0; /* just disconnect the leave */
5620 k = kLISTOP->op_first;
5625 if (o->op_type == OP_SORT) {
5626 /* provide scalar context for comparison function/block */
5632 o->op_flags |= OPf_SPECIAL;
5634 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
5637 firstkid = firstkid->op_sibling;
5640 /* provide list context for arguments */
5641 if (o->op_type == OP_SORT)
5648 S_simplify_sort(pTHX_ OP *o)
5650 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5654 if (!(o->op_flags & OPf_STACKED))
5656 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
5657 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
5658 kid = kUNOP->op_first; /* get past null */
5659 if (kid->op_type != OP_SCOPE)
5661 kid = kLISTOP->op_last; /* get past scope */
5662 switch(kid->op_type) {
5670 k = kid; /* remember this node*/
5671 if (kBINOP->op_first->op_type != OP_RV2SV)
5673 kid = kBINOP->op_first; /* get past cmp */
5674 if (kUNOP->op_first->op_type != OP_GV)
5676 kid = kUNOP->op_first; /* get past rv2sv */
5678 if (GvSTASH(gv) != PL_curstash)
5680 if (strEQ(GvNAME(gv), "a"))
5682 else if (strEQ(GvNAME(gv), "b"))
5686 kid = k; /* back to cmp */
5687 if (kBINOP->op_last->op_type != OP_RV2SV)
5689 kid = kBINOP->op_last; /* down to 2nd arg */
5690 if (kUNOP->op_first->op_type != OP_GV)
5692 kid = kUNOP->op_first; /* get past rv2sv */
5694 if (GvSTASH(gv) != PL_curstash
5696 ? strNE(GvNAME(gv), "a")
5697 : strNE(GvNAME(gv), "b")))
5699 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
5701 o->op_private |= OPpSORT_REVERSE;
5702 if (k->op_type == OP_NCMP)
5703 o->op_private |= OPpSORT_NUMERIC;
5704 if (k->op_type == OP_I_NCMP)
5705 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
5706 kid = cLISTOPo->op_first->op_sibling;
5707 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
5708 op_free(kid); /* then delete it */
5712 Perl_ck_split(pTHX_ OP *o)
5716 if (o->op_flags & OPf_STACKED)
5717 return no_fh_allowed(o);
5719 kid = cLISTOPo->op_first;
5720 if (kid->op_type != OP_NULL)
5721 Perl_croak(aTHX_ "panic: ck_split");
5722 kid = kid->op_sibling;
5723 op_free(cLISTOPo->op_first);
5724 cLISTOPo->op_first = kid;
5726 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
5727 cLISTOPo->op_last = kid; /* There was only one element previously */
5730 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
5731 OP *sibl = kid->op_sibling;
5732 kid->op_sibling = 0;
5733 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
5734 if (cLISTOPo->op_first == cLISTOPo->op_last)
5735 cLISTOPo->op_last = kid;
5736 cLISTOPo->op_first = kid;
5737 kid->op_sibling = sibl;
5740 kid->op_type = OP_PUSHRE;
5741 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
5743 if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
5744 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
5745 "Use of /g modifier is meaningless in split");
5748 if (!kid->op_sibling)
5749 append_elem(OP_SPLIT, o, newDEFSVOP());
5751 kid = kid->op_sibling;
5754 if (!kid->op_sibling)
5755 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
5757 kid = kid->op_sibling;
5760 if (kid->op_sibling)
5761 return too_many_arguments(o,OP_DESC(o));
5767 Perl_ck_join(pTHX_ OP *o)
5769 if (ckWARN(WARN_SYNTAX)) {
5770 OP *kid = cLISTOPo->op_first->op_sibling;
5771 if (kid && kid->op_type == OP_MATCH) {
5772 char *pmstr = "STRING";
5773 if (PM_GETRE(kPMOP))
5774 pmstr = PM_GETRE(kPMOP)->precomp;
5775 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5776 "/%s/ should probably be written as \"%s\"",
5784 Perl_ck_subr(pTHX_ OP *o)
5786 OP *prev = ((cUNOPo->op_first->op_sibling)
5787 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
5788 OP *o2 = prev->op_sibling;
5795 I32 contextclass = 0;
5799 o->op_private |= OPpENTERSUB_HASTARG;
5800 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
5801 if (cvop->op_type == OP_RV2CV) {
5803 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
5804 op_null(cvop); /* disable rv2cv */
5805 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
5806 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
5807 GV *gv = cGVOPx_gv(tmpop);
5810 tmpop->op_private |= OPpEARLY_CV;
5811 else if (SvPOK(cv)) {
5812 namegv = CvANON(cv) ? gv : CvGV(cv);
5813 proto = SvPV((SV*)cv, n_a);
5817 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
5818 if (o2->op_type == OP_CONST)
5819 o2->op_private &= ~OPpCONST_STRICT;
5820 else if (o2->op_type == OP_LIST) {
5821 OP *o = ((UNOP*)o2)->op_first->op_sibling;
5822 if (o && o->op_type == OP_CONST)
5823 o->op_private &= ~OPpCONST_STRICT;
5826 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5827 if (PERLDB_SUB && PL_curstash != PL_debstash)
5828 o->op_private |= OPpENTERSUB_DB;
5829 while (o2 != cvop) {
5833 return too_many_arguments(o, gv_ename(namegv));
5851 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
5853 arg == 1 ? "block or sub {}" : "sub {}",
5854 gv_ename(namegv), o2);
5857 /* '*' allows any scalar type, including bareword */
5860 if (o2->op_type == OP_RV2GV)
5861 goto wrapref; /* autoconvert GLOB -> GLOBref */
5862 else if (o2->op_type == OP_CONST)
5863 o2->op_private &= ~OPpCONST_STRICT;
5864 else if (o2->op_type == OP_ENTERSUB) {
5865 /* accidental subroutine, revert to bareword */
5866 OP *gvop = ((UNOP*)o2)->op_first;
5867 if (gvop && gvop->op_type == OP_NULL) {
5868 gvop = ((UNOP*)gvop)->op_first;
5870 for (; gvop->op_sibling; gvop = gvop->op_sibling)
5873 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
5874 (gvop = ((UNOP*)gvop)->op_first) &&
5875 gvop->op_type == OP_GV)
5877 GV *gv = cGVOPx_gv(gvop);
5878 OP *sibling = o2->op_sibling;
5879 SV *n = newSVpvn("",0);
5881 gv_fullname3(n, gv, "");
5882 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
5883 sv_chop(n, SvPVX(n)+6);
5884 o2 = newSVOP(OP_CONST, 0, n);
5885 prev->op_sibling = o2;
5886 o2->op_sibling = sibling;
5902 if (contextclass++ == 0) {
5903 e = strchr(proto, ']');
5904 if (!e || e == proto)
5917 while (*--p != '[');
5918 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
5919 gv_ename(namegv), o2);
5925 if (o2->op_type == OP_RV2GV)
5928 bad_type(arg, "symbol", gv_ename(namegv), o2);
5931 if (o2->op_type == OP_ENTERSUB)
5934 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
5937 if (o2->op_type == OP_RV2SV ||
5938 o2->op_type == OP_PADSV ||
5939 o2->op_type == OP_HELEM ||
5940 o2->op_type == OP_AELEM ||
5941 o2->op_type == OP_THREADSV)
5944 bad_type(arg, "scalar", gv_ename(namegv), o2);
5947 if (o2->op_type == OP_RV2AV ||
5948 o2->op_type == OP_PADAV)
5951 bad_type(arg, "array", gv_ename(namegv), o2);
5954 if (o2->op_type == OP_RV2HV ||
5955 o2->op_type == OP_PADHV)
5958 bad_type(arg, "hash", gv_ename(namegv), o2);
5963 OP* sib = kid->op_sibling;
5964 kid->op_sibling = 0;
5965 o2 = newUNOP(OP_REFGEN, 0, kid);
5966 o2->op_sibling = sib;
5967 prev->op_sibling = o2;
5969 if (contextclass && e) {
5984 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
5985 gv_ename(namegv), SvPV((SV*)cv, n_a));
5990 mod(o2, OP_ENTERSUB);
5992 o2 = o2->op_sibling;
5994 if (proto && !optional &&
5995 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
5996 return too_few_arguments(o, gv_ename(namegv));
6001 Perl_ck_svconst(pTHX_ OP *o)
6003 SvREADONLY_on(cSVOPo->op_sv);
6008 Perl_ck_trunc(pTHX_ OP *o)
6010 if (o->op_flags & OPf_KIDS) {
6011 SVOP *kid = (SVOP*)cUNOPo->op_first;
6013 if (kid->op_type == OP_NULL)
6014 kid = (SVOP*)kid->op_sibling;
6015 if (kid && kid->op_type == OP_CONST &&
6016 (kid->op_private & OPpCONST_BARE))
6018 o->op_flags |= OPf_SPECIAL;
6019 kid->op_private &= ~OPpCONST_STRICT;
6026 Perl_ck_substr(pTHX_ OP *o)
6029 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6030 OP *kid = cLISTOPo->op_first;
6032 if (kid->op_type == OP_NULL)
6033 kid = kid->op_sibling;
6035 kid->op_flags |= OPf_MOD;
6041 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6044 Perl_peep(pTHX_ register OP *o)
6046 register OP* oldop = 0;
6048 if (!o || o->op_seq)
6052 SAVEVPTR(PL_curcop);
6053 for (; o; o = o->op_next) {
6059 switch (o->op_type) {
6063 PL_curcop = ((COP*)o); /* for warnings */
6064 o->op_seq = PL_op_seqmax++;
6068 if (cSVOPo->op_private & OPpCONST_STRICT)
6069 no_bareword_allowed(o);
6071 /* Relocate sv to the pad for thread safety.
6072 * Despite being a "constant", the SV is written to,
6073 * for reference counts, sv_upgrade() etc. */
6075 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6076 if (SvPADTMP(cSVOPo->op_sv)) {
6077 /* If op_sv is already a PADTMP then it is being used by
6078 * some pad, so make a copy. */
6079 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6080 SvREADONLY_on(PAD_SVl(ix));
6081 SvREFCNT_dec(cSVOPo->op_sv);
6084 SvREFCNT_dec(PAD_SVl(ix));
6085 SvPADTMP_on(cSVOPo->op_sv);
6086 PAD_SETSV(ix, cSVOPo->op_sv);
6087 /* XXX I don't know how this isn't readonly already. */
6088 SvREADONLY_on(PAD_SVl(ix));
6090 cSVOPo->op_sv = Nullsv;
6094 o->op_seq = PL_op_seqmax++;
6098 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6099 if (o->op_next->op_private & OPpTARGET_MY) {
6100 if (o->op_flags & OPf_STACKED) /* chained concats */
6101 goto ignore_optimization;
6103 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6104 o->op_targ = o->op_next->op_targ;
6105 o->op_next->op_targ = 0;
6106 o->op_private |= OPpTARGET_MY;
6109 op_null(o->op_next);
6111 ignore_optimization:
6112 o->op_seq = PL_op_seqmax++;
6115 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6116 o->op_seq = PL_op_seqmax++;
6117 break; /* Scalar stub must produce undef. List stub is noop */
6121 if (o->op_targ == OP_NEXTSTATE
6122 || o->op_targ == OP_DBSTATE
6123 || o->op_targ == OP_SETSTATE)
6125 PL_curcop = ((COP*)o);
6127 /* XXX: We avoid setting op_seq here to prevent later calls
6128 to peep() from mistakenly concluding that optimisation
6129 has already occurred. This doesn't fix the real problem,
6130 though (See 20010220.007). AMS 20010719 */
6131 if (oldop && o->op_next) {
6132 oldop->op_next = o->op_next;
6140 if (oldop && o->op_next) {
6141 oldop->op_next = o->op_next;
6144 o->op_seq = PL_op_seqmax++;
6148 if (o->op_next->op_type == OP_RV2SV) {
6149 if (!(o->op_next->op_private & OPpDEREF)) {
6150 op_null(o->op_next);
6151 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6153 o->op_next = o->op_next->op_next;
6154 o->op_type = OP_GVSV;
6155 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6158 else if (o->op_next->op_type == OP_RV2AV) {
6159 OP* pop = o->op_next->op_next;
6161 if (pop && pop->op_type == OP_CONST &&
6162 (PL_op = pop->op_next) &&
6163 pop->op_next->op_type == OP_AELEM &&
6164 !(pop->op_next->op_private &
6165 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6166 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6171 op_null(o->op_next);
6172 op_null(pop->op_next);
6174 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6175 o->op_next = pop->op_next->op_next;
6176 o->op_type = OP_AELEMFAST;
6177 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6178 o->op_private = (U8)i;
6183 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6185 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6186 /* XXX could check prototype here instead of just carping */
6187 SV *sv = sv_newmortal();
6188 gv_efullname3(sv, gv, Nullch);
6189 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6190 "%s() called too early to check prototype",
6194 else if (o->op_next->op_type == OP_READLINE
6195 && o->op_next->op_next->op_type == OP_CONCAT
6196 && (o->op_next->op_next->op_flags & OPf_STACKED))
6198 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6199 o->op_type = OP_RCATLINE;
6200 o->op_flags |= OPf_STACKED;
6201 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6202 op_null(o->op_next->op_next);
6203 op_null(o->op_next);
6206 o->op_seq = PL_op_seqmax++;
6219 o->op_seq = PL_op_seqmax++;
6220 while (cLOGOP->op_other->op_type == OP_NULL)
6221 cLOGOP->op_other = cLOGOP->op_other->op_next;
6222 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6227 o->op_seq = PL_op_seqmax++;
6228 while (cLOOP->op_redoop->op_type == OP_NULL)
6229 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6230 peep(cLOOP->op_redoop);
6231 while (cLOOP->op_nextop->op_type == OP_NULL)
6232 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6233 peep(cLOOP->op_nextop);
6234 while (cLOOP->op_lastop->op_type == OP_NULL)
6235 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6236 peep(cLOOP->op_lastop);
6242 o->op_seq = PL_op_seqmax++;
6243 while (cPMOP->op_pmreplstart &&
6244 cPMOP->op_pmreplstart->op_type == OP_NULL)
6245 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6246 peep(cPMOP->op_pmreplstart);
6250 o->op_seq = PL_op_seqmax++;
6251 if (ckWARN(WARN_SYNTAX) && o->op_next
6252 && o->op_next->op_type == OP_NEXTSTATE) {
6253 if (o->op_next->op_sibling &&
6254 o->op_next->op_sibling->op_type != OP_EXIT &&
6255 o->op_next->op_sibling->op_type != OP_WARN &&
6256 o->op_next->op_sibling->op_type != OP_DIE) {
6257 line_t oldline = CopLINE(PL_curcop);
6259 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6260 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6261 "Statement unlikely to be reached");
6262 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6263 "\t(Maybe you meant system() when you said exec()?)\n");
6264 CopLINE_set(PL_curcop, oldline);
6275 o->op_seq = PL_op_seqmax++;
6277 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6280 /* Make the CONST have a shared SV */
6281 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6282 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6283 key = SvPV(sv, keylen);
6284 lexname = newSVpvn_share(key,
6285 SvUTF8(sv) ? -(I32)keylen : keylen,
6294 o->op_seq = PL_op_seqmax++;
6304 char* Perl_custom_op_name(pTHX_ OP* o)
6306 IV index = PTR2IV(o->op_ppaddr);
6310 if (!PL_custom_op_names) /* This probably shouldn't happen */
6311 return PL_op_name[OP_CUSTOM];
6313 keysv = sv_2mortal(newSViv(index));
6315 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
6317 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
6319 return SvPV_nolen(HeVAL(he));
6322 char* Perl_custom_op_desc(pTHX_ OP* o)
6324 IV index = PTR2IV(o->op_ppaddr);
6328 if (!PL_custom_op_descs)
6329 return PL_op_desc[OP_CUSTOM];
6331 keysv = sv_2mortal(newSViv(index));
6333 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
6335 return PL_op_desc[OP_CUSTOM];
6337 return SvPV_nolen(HeVAL(he));
6343 /* Efficient sub that returns a constant scalar value. */
6345 const_sv_xsub(pTHX_ CV* cv)
6350 Perl_croak(aTHX_ "usage: %s::%s()",
6351 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
6355 ST(0) = (SV*)XSANY.any_ptr;