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;
1737 /* If there were syntax errors, don't try to start a block */
1738 if (PL_yynerrs) return retval;
1740 pad_block_start(full);
1742 PL_hints &= ~HINT_BLOCK_SCOPE;
1743 SAVESPTR(PL_compiling.cop_warnings);
1744 if (! specialWARN(PL_compiling.cop_warnings)) {
1745 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1746 SAVEFREESV(PL_compiling.cop_warnings) ;
1748 SAVESPTR(PL_compiling.cop_io);
1749 if (! specialCopIO(PL_compiling.cop_io)) {
1750 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1751 SAVEFREESV(PL_compiling.cop_io) ;
1757 Perl_block_end(pTHX_ I32 floor, OP *seq)
1759 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1760 line_t copline = PL_copline;
1761 OP* retval = scalarseq(seq);
1762 /* If there were syntax errors, don't try to close a block */
1763 if (PL_yynerrs) return retval;
1765 /* scalarseq() gave us an OP_STUB */
1766 retval->op_flags |= OPf_PARENS;
1767 /* there should be a nextstate in every block */
1768 retval = newSTATEOP(0, Nullch, retval);
1769 PL_copline = copline; /* XXX newSTATEOP may reset PL_copline */
1772 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
1774 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
1782 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1786 Perl_newPROG(pTHX_ OP *o)
1791 PL_eval_root = newUNOP(OP_LEAVEEVAL,
1792 ((PL_in_eval & EVAL_KEEPERR)
1793 ? OPf_SPECIAL : 0), o);
1794 PL_eval_start = linklist(PL_eval_root);
1795 PL_eval_root->op_private |= OPpREFCOUNTED;
1796 OpREFCNT_set(PL_eval_root, 1);
1797 PL_eval_root->op_next = 0;
1798 CALL_PEEP(PL_eval_start);
1803 PL_main_root = scope(sawparens(scalarvoid(o)));
1804 PL_curcop = &PL_compiling;
1805 PL_main_start = LINKLIST(PL_main_root);
1806 PL_main_root->op_private |= OPpREFCOUNTED;
1807 OpREFCNT_set(PL_main_root, 1);
1808 PL_main_root->op_next = 0;
1809 CALL_PEEP(PL_main_start);
1812 /* Register with debugger */
1814 CV *cv = get_cv("DB::postponed", FALSE);
1818 XPUSHs((SV*)CopFILEGV(&PL_compiling));
1820 call_sv((SV*)cv, G_DISCARD);
1827 Perl_localize(pTHX_ OP *o, I32 lex)
1829 if (o->op_flags & OPf_PARENS)
1830 /* [perl #17376]: this appears to be premature, and results in code such as
1831 C< our(%x); > executing in list mode rather than void mode */
1838 if (ckWARN(WARN_PARENTHESIS)
1839 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
1841 char *s = PL_bufptr;
1843 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ", *s)))
1846 if (*s == ';' || *s == '=')
1847 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
1848 "Parentheses missing around \"%s\" list",
1849 lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
1855 o = mod(o, OP_NULL); /* a bit kludgey */
1857 PL_in_my_stash = Nullhv;
1862 Perl_jmaybe(pTHX_ OP *o)
1864 if (o->op_type == OP_LIST) {
1866 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
1867 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
1873 Perl_fold_constants(pTHX_ register OP *o)
1876 I32 type = o->op_type;
1879 if (PL_opargs[type] & OA_RETSCALAR)
1881 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
1882 o->op_targ = pad_alloc(type, SVs_PADTMP);
1884 /* integerize op, unless it happens to be C<-foo>.
1885 * XXX should pp_i_negate() do magic string negation instead? */
1886 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
1887 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
1888 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
1890 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
1893 if (!(PL_opargs[type] & OA_FOLDCONST))
1898 /* XXX might want a ck_negate() for this */
1899 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
1911 /* XXX what about the numeric ops? */
1912 if (PL_hints & HINT_LOCALE)
1917 goto nope; /* Don't try to run w/ errors */
1919 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
1920 if ((curop->op_type != OP_CONST ||
1921 (curop->op_private & OPpCONST_BARE)) &&
1922 curop->op_type != OP_LIST &&
1923 curop->op_type != OP_SCALAR &&
1924 curop->op_type != OP_NULL &&
1925 curop->op_type != OP_PUSHMARK)
1931 curop = LINKLIST(o);
1935 sv = *(PL_stack_sp--);
1936 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
1937 pad_swipe(o->op_targ, FALSE);
1938 else if (SvTEMP(sv)) { /* grab mortal temp? */
1939 (void)SvREFCNT_inc(sv);
1943 if (type == OP_RV2GV)
1944 return newGVOP(OP_GV, 0, (GV*)sv);
1946 /* try to smush double to int, but don't smush -2.0 to -2 */
1947 if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
1950 #ifdef PERL_PRESERVE_IVUV
1951 /* Only bother to attempt to fold to IV if
1952 most operators will benefit */
1956 return newSVOP(OP_CONST, 0, sv);
1964 Perl_gen_constant_list(pTHX_ register OP *o)
1967 I32 oldtmps_floor = PL_tmps_floor;
1971 return o; /* Don't attempt to run with errors */
1973 PL_op = curop = LINKLIST(o);
1980 PL_tmps_floor = oldtmps_floor;
1982 o->op_type = OP_RV2AV;
1983 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
1984 o->op_seq = 0; /* needs to be revisited in peep() */
1985 curop = ((UNOP*)o)->op_first;
1986 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
1993 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
1995 if (!o || o->op_type != OP_LIST)
1996 o = newLISTOP(OP_LIST, 0, o, Nullop);
1998 o->op_flags &= ~OPf_WANT;
2000 if (!(PL_opargs[type] & OA_MARK))
2001 op_null(cLISTOPo->op_first);
2003 o->op_type = (OPCODE)type;
2004 o->op_ppaddr = PL_ppaddr[type];
2005 o->op_flags |= flags;
2007 o = CHECKOP(type, o);
2008 if (o->op_type != type)
2011 return fold_constants(o);
2014 /* List constructors */
2017 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2025 if (first->op_type != type
2026 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2028 return newLISTOP(type, 0, first, last);
2031 if (first->op_flags & OPf_KIDS)
2032 ((LISTOP*)first)->op_last->op_sibling = last;
2034 first->op_flags |= OPf_KIDS;
2035 ((LISTOP*)first)->op_first = last;
2037 ((LISTOP*)first)->op_last = last;
2042 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2050 if (first->op_type != type)
2051 return prepend_elem(type, (OP*)first, (OP*)last);
2053 if (last->op_type != type)
2054 return append_elem(type, (OP*)first, (OP*)last);
2056 first->op_last->op_sibling = last->op_first;
2057 first->op_last = last->op_last;
2058 first->op_flags |= (last->op_flags & OPf_KIDS);
2066 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2074 if (last->op_type == type) {
2075 if (type == OP_LIST) { /* already a PUSHMARK there */
2076 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2077 ((LISTOP*)last)->op_first->op_sibling = first;
2078 if (!(first->op_flags & OPf_PARENS))
2079 last->op_flags &= ~OPf_PARENS;
2082 if (!(last->op_flags & OPf_KIDS)) {
2083 ((LISTOP*)last)->op_last = first;
2084 last->op_flags |= OPf_KIDS;
2086 first->op_sibling = ((LISTOP*)last)->op_first;
2087 ((LISTOP*)last)->op_first = first;
2089 last->op_flags |= OPf_KIDS;
2093 return newLISTOP(type, 0, first, last);
2099 Perl_newNULLLIST(pTHX)
2101 return newOP(OP_STUB, 0);
2105 Perl_force_list(pTHX_ OP *o)
2107 if (!o || o->op_type != OP_LIST)
2108 o = newLISTOP(OP_LIST, 0, o, Nullop);
2114 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2118 NewOp(1101, listop, 1, LISTOP);
2120 listop->op_type = (OPCODE)type;
2121 listop->op_ppaddr = PL_ppaddr[type];
2124 listop->op_flags = (U8)flags;
2128 else if (!first && last)
2131 first->op_sibling = last;
2132 listop->op_first = first;
2133 listop->op_last = last;
2134 if (type == OP_LIST) {
2136 pushop = newOP(OP_PUSHMARK, 0);
2137 pushop->op_sibling = first;
2138 listop->op_first = pushop;
2139 listop->op_flags |= OPf_KIDS;
2141 listop->op_last = pushop;
2148 Perl_newOP(pTHX_ I32 type, I32 flags)
2151 NewOp(1101, o, 1, OP);
2152 o->op_type = (OPCODE)type;
2153 o->op_ppaddr = PL_ppaddr[type];
2154 o->op_flags = (U8)flags;
2157 o->op_private = (U8)(0 | (flags >> 8));
2158 if (PL_opargs[type] & OA_RETSCALAR)
2160 if (PL_opargs[type] & OA_TARGET)
2161 o->op_targ = pad_alloc(type, SVs_PADTMP);
2162 return CHECKOP(type, o);
2166 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2171 first = newOP(OP_STUB, 0);
2172 if (PL_opargs[type] & OA_MARK)
2173 first = force_list(first);
2175 NewOp(1101, unop, 1, UNOP);
2176 unop->op_type = (OPCODE)type;
2177 unop->op_ppaddr = PL_ppaddr[type];
2178 unop->op_first = first;
2179 unop->op_flags = flags | OPf_KIDS;
2180 unop->op_private = (U8)(1 | (flags >> 8));
2181 unop = (UNOP*) CHECKOP(type, unop);
2185 return fold_constants((OP *) unop);
2189 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2192 NewOp(1101, binop, 1, BINOP);
2195 first = newOP(OP_NULL, 0);
2197 binop->op_type = (OPCODE)type;
2198 binop->op_ppaddr = PL_ppaddr[type];
2199 binop->op_first = first;
2200 binop->op_flags = flags | OPf_KIDS;
2203 binop->op_private = (U8)(1 | (flags >> 8));
2206 binop->op_private = (U8)(2 | (flags >> 8));
2207 first->op_sibling = last;
2210 binop = (BINOP*)CHECKOP(type, binop);
2211 if (binop->op_next || binop->op_type != (OPCODE)type)
2214 binop->op_last = binop->op_first->op_sibling;
2216 return fold_constants((OP *)binop);
2220 uvcompare(const void *a, const void *b)
2222 if (*((UV *)a) < (*(UV *)b))
2224 if (*((UV *)a) > (*(UV *)b))
2226 if (*((UV *)a+1) < (*(UV *)b+1))
2228 if (*((UV *)a+1) > (*(UV *)b+1))
2234 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2236 SV *tstr = ((SVOP*)expr)->op_sv;
2237 SV *rstr = ((SVOP*)repl)->op_sv;
2240 U8 *t = (U8*)SvPV(tstr, tlen);
2241 U8 *r = (U8*)SvPV(rstr, rlen);
2248 register short *tbl;
2250 PL_hints |= HINT_BLOCK_SCOPE;
2251 complement = o->op_private & OPpTRANS_COMPLEMENT;
2252 del = o->op_private & OPpTRANS_DELETE;
2253 squash = o->op_private & OPpTRANS_SQUASH;
2256 o->op_private |= OPpTRANS_FROM_UTF;
2259 o->op_private |= OPpTRANS_TO_UTF;
2261 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2262 SV* listsv = newSVpvn("# comment\n",10);
2264 U8* tend = t + tlen;
2265 U8* rend = r + rlen;
2279 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2280 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2286 tsave = t = bytes_to_utf8(t, &len);
2289 if (!to_utf && rlen) {
2291 rsave = r = bytes_to_utf8(r, &len);
2295 /* There are several snags with this code on EBCDIC:
2296 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2297 2. scan_const() in toke.c has encoded chars in native encoding which makes
2298 ranges at least in EBCDIC 0..255 range the bottom odd.
2302 U8 tmpbuf[UTF8_MAXLEN+1];
2305 New(1109, cp, 2*tlen, UV);
2307 transv = newSVpvn("",0);
2309 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2311 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2313 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2317 cp[2*i+1] = cp[2*i];
2321 qsort(cp, i, 2*sizeof(UV), uvcompare);
2322 for (j = 0; j < i; j++) {
2324 diff = val - nextmin;
2326 t = uvuni_to_utf8(tmpbuf,nextmin);
2327 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2329 U8 range_mark = UTF_TO_NATIVE(0xff);
2330 t = uvuni_to_utf8(tmpbuf, val - 1);
2331 sv_catpvn(transv, (char *)&range_mark, 1);
2332 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2339 t = uvuni_to_utf8(tmpbuf,nextmin);
2340 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2342 U8 range_mark = UTF_TO_NATIVE(0xff);
2343 sv_catpvn(transv, (char *)&range_mark, 1);
2345 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2346 UNICODE_ALLOW_SUPER);
2347 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2348 t = (U8*)SvPVX(transv);
2349 tlen = SvCUR(transv);
2353 else if (!rlen && !del) {
2354 r = t; rlen = tlen; rend = tend;
2357 if ((!rlen && !del) || t == r ||
2358 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2360 o->op_private |= OPpTRANS_IDENTICAL;
2364 while (t < tend || tfirst <= tlast) {
2365 /* see if we need more "t" chars */
2366 if (tfirst > tlast) {
2367 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2369 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2371 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2378 /* now see if we need more "r" chars */
2379 if (rfirst > rlast) {
2381 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2383 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2385 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2394 rfirst = rlast = 0xffffffff;
2398 /* now see which range will peter our first, if either. */
2399 tdiff = tlast - tfirst;
2400 rdiff = rlast - rfirst;
2407 if (rfirst == 0xffffffff) {
2408 diff = tdiff; /* oops, pretend rdiff is infinite */
2410 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2411 (long)tfirst, (long)tlast);
2413 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2417 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2418 (long)tfirst, (long)(tfirst + diff),
2421 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2422 (long)tfirst, (long)rfirst);
2424 if (rfirst + diff > max)
2425 max = rfirst + diff;
2427 grows = (tfirst < rfirst &&
2428 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2440 else if (max > 0xff)
2445 Safefree(cPVOPo->op_pv);
2446 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2447 SvREFCNT_dec(listsv);
2449 SvREFCNT_dec(transv);
2451 if (!del && havefinal && rlen)
2452 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2453 newSVuv((UV)final), 0);
2456 o->op_private |= OPpTRANS_GROWS;
2468 tbl = (short*)cPVOPo->op_pv;
2470 Zero(tbl, 256, short);
2471 for (i = 0; i < (I32)tlen; i++)
2473 for (i = 0, j = 0; i < 256; i++) {
2475 if (j >= (I32)rlen) {
2484 if (i < 128 && r[j] >= 128)
2494 o->op_private |= OPpTRANS_IDENTICAL;
2496 else if (j >= (I32)rlen)
2499 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2500 tbl[0x100] = rlen - j;
2501 for (i=0; i < (I32)rlen - j; i++)
2502 tbl[0x101+i] = r[j+i];
2506 if (!rlen && !del) {
2509 o->op_private |= OPpTRANS_IDENTICAL;
2511 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2512 o->op_private |= OPpTRANS_IDENTICAL;
2514 for (i = 0; i < 256; i++)
2516 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
2517 if (j >= (I32)rlen) {
2519 if (tbl[t[i]] == -1)
2525 if (tbl[t[i]] == -1) {
2526 if (t[i] < 128 && r[j] >= 128)
2533 o->op_private |= OPpTRANS_GROWS;
2541 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2545 NewOp(1101, pmop, 1, PMOP);
2546 pmop->op_type = (OPCODE)type;
2547 pmop->op_ppaddr = PL_ppaddr[type];
2548 pmop->op_flags = (U8)flags;
2549 pmop->op_private = (U8)(0 | (flags >> 8));
2551 if (PL_hints & HINT_RE_TAINT)
2552 pmop->op_pmpermflags |= PMf_RETAINT;
2553 if (PL_hints & HINT_LOCALE)
2554 pmop->op_pmpermflags |= PMf_LOCALE;
2555 pmop->op_pmflags = pmop->op_pmpermflags;
2560 if(av_len((AV*) PL_regex_pad[0]) > -1) {
2561 repointer = av_pop((AV*)PL_regex_pad[0]);
2562 pmop->op_pmoffset = SvIV(repointer);
2563 SvREPADTMP_off(repointer);
2564 sv_setiv(repointer,0);
2566 repointer = newSViv(0);
2567 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2568 pmop->op_pmoffset = av_len(PL_regex_padav);
2569 PL_regex_pad = AvARRAY(PL_regex_padav);
2574 /* link into pm list */
2575 if (type != OP_TRANS && PL_curstash) {
2576 pmop->op_pmnext = HvPMROOT(PL_curstash);
2577 HvPMROOT(PL_curstash) = pmop;
2578 PmopSTASH_set(pmop,PL_curstash);
2585 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
2589 I32 repl_has_vars = 0;
2591 if (o->op_type == OP_TRANS)
2592 return pmtrans(o, expr, repl);
2594 PL_hints |= HINT_BLOCK_SCOPE;
2597 if (expr->op_type == OP_CONST) {
2599 SV *pat = ((SVOP*)expr)->op_sv;
2600 char *p = SvPV(pat, plen);
2601 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
2602 sv_setpvn(pat, "\\s+", 3);
2603 p = SvPV(pat, plen);
2604 pm->op_pmflags |= PMf_SKIPWHITE;
2607 pm->op_pmdynflags |= PMdf_UTF8;
2608 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
2609 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
2610 pm->op_pmflags |= PMf_WHITE;
2614 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2615 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2617 : OP_REGCMAYBE),0,expr);
2619 NewOp(1101, rcop, 1, LOGOP);
2620 rcop->op_type = OP_REGCOMP;
2621 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2622 rcop->op_first = scalar(expr);
2623 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
2624 ? (OPf_SPECIAL | OPf_KIDS)
2626 rcop->op_private = 1;
2629 /* establish postfix order */
2630 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2632 rcop->op_next = expr;
2633 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2636 rcop->op_next = LINKLIST(expr);
2637 expr->op_next = (OP*)rcop;
2640 prepend_elem(o->op_type, scalar((OP*)rcop), o);
2645 if (pm->op_pmflags & PMf_EVAL) {
2647 if (CopLINE(PL_curcop) < PL_multi_end)
2648 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
2650 else if (repl->op_type == OP_CONST)
2654 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
2655 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
2656 if (curop->op_type == OP_GV) {
2657 GV *gv = cGVOPx_gv(curop);
2659 if (strchr("&`'123456789+", *GvENAME(gv)))
2662 else if (curop->op_type == OP_RV2CV)
2664 else if (curop->op_type == OP_RV2SV ||
2665 curop->op_type == OP_RV2AV ||
2666 curop->op_type == OP_RV2HV ||
2667 curop->op_type == OP_RV2GV) {
2668 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2671 else if (curop->op_type == OP_PADSV ||
2672 curop->op_type == OP_PADAV ||
2673 curop->op_type == OP_PADHV ||
2674 curop->op_type == OP_PADANY) {
2677 else if (curop->op_type == OP_PUSHRE)
2678 ; /* Okay here, dangerous in newASSIGNOP */
2688 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
2689 pm->op_pmflags |= PMf_CONST; /* const for long enough */
2690 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
2691 prepend_elem(o->op_type, scalar(repl), o);
2694 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
2695 pm->op_pmflags |= PMf_MAYBE_CONST;
2696 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2698 NewOp(1101, rcop, 1, LOGOP);
2699 rcop->op_type = OP_SUBSTCONT;
2700 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
2701 rcop->op_first = scalar(repl);
2702 rcop->op_flags |= OPf_KIDS;
2703 rcop->op_private = 1;
2706 /* establish postfix order */
2707 rcop->op_next = LINKLIST(repl);
2708 repl->op_next = (OP*)rcop;
2710 pm->op_pmreplroot = scalar((OP*)rcop);
2711 pm->op_pmreplstart = LINKLIST(rcop);
2720 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
2723 NewOp(1101, svop, 1, SVOP);
2724 svop->op_type = (OPCODE)type;
2725 svop->op_ppaddr = PL_ppaddr[type];
2727 svop->op_next = (OP*)svop;
2728 svop->op_flags = (U8)flags;
2729 if (PL_opargs[type] & OA_RETSCALAR)
2731 if (PL_opargs[type] & OA_TARGET)
2732 svop->op_targ = pad_alloc(type, SVs_PADTMP);
2733 return CHECKOP(type, svop);
2737 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2740 NewOp(1101, padop, 1, PADOP);
2741 padop->op_type = (OPCODE)type;
2742 padop->op_ppaddr = PL_ppaddr[type];
2743 padop->op_padix = pad_alloc(type, SVs_PADTMP);
2744 SvREFCNT_dec(PAD_SVl(padop->op_padix));
2745 PAD_SETSV(padop->op_padix, sv);
2748 padop->op_next = (OP*)padop;
2749 padop->op_flags = (U8)flags;
2750 if (PL_opargs[type] & OA_RETSCALAR)
2752 if (PL_opargs[type] & OA_TARGET)
2753 padop->op_targ = pad_alloc(type, SVs_PADTMP);
2754 return CHECKOP(type, padop);
2758 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
2763 return newPADOP(type, flags, SvREFCNT_inc(gv));
2765 return newSVOP(type, flags, SvREFCNT_inc(gv));
2770 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
2773 NewOp(1101, pvop, 1, PVOP);
2774 pvop->op_type = (OPCODE)type;
2775 pvop->op_ppaddr = PL_ppaddr[type];
2777 pvop->op_next = (OP*)pvop;
2778 pvop->op_flags = (U8)flags;
2779 if (PL_opargs[type] & OA_RETSCALAR)
2781 if (PL_opargs[type] & OA_TARGET)
2782 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
2783 return CHECKOP(type, pvop);
2787 Perl_package(pTHX_ OP *o)
2792 save_hptr(&PL_curstash);
2793 save_item(PL_curstname);
2795 name = SvPV(cSVOPo->op_sv, len);
2796 PL_curstash = gv_stashpvn(name, len, TRUE);
2797 sv_setpvn(PL_curstname, name, len);
2800 PL_hints |= HINT_BLOCK_SCOPE;
2801 PL_copline = NOLINE;
2806 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
2812 if (id->op_type != OP_CONST)
2813 Perl_croak(aTHX_ "Module name must be constant");
2817 if (version != Nullop) {
2818 SV *vesv = ((SVOP*)version)->op_sv;
2820 if (arg == Nullop && !SvNIOKp(vesv)) {
2827 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
2828 Perl_croak(aTHX_ "Version number must be constant number");
2830 /* Make copy of id so we don't free it twice */
2831 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
2833 /* Fake up a method call to VERSION */
2834 meth = newSVpvn("VERSION",7);
2835 sv_upgrade(meth, SVt_PVIV);
2836 (void)SvIOK_on(meth);
2837 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
2838 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2839 append_elem(OP_LIST,
2840 prepend_elem(OP_LIST, pack, list(version)),
2841 newSVOP(OP_METHOD_NAMED, 0, meth)));
2845 /* Fake up an import/unimport */
2846 if (arg && arg->op_type == OP_STUB)
2847 imop = arg; /* no import on explicit () */
2848 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
2849 imop = Nullop; /* use 5.0; */
2854 /* Make copy of id so we don't free it twice */
2855 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
2857 /* Fake up a method call to import/unimport */
2858 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);
2859 (void)SvUPGRADE(meth, SVt_PVIV);
2860 (void)SvIOK_on(meth);
2861 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
2862 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2863 append_elem(OP_LIST,
2864 prepend_elem(OP_LIST, pack, list(arg)),
2865 newSVOP(OP_METHOD_NAMED, 0, meth)));
2868 /* Fake up the BEGIN {}, which does its thing immediately. */
2870 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
2873 append_elem(OP_LINESEQ,
2874 append_elem(OP_LINESEQ,
2875 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, id)),
2876 newSTATEOP(0, Nullch, veop)),
2877 newSTATEOP(0, Nullch, imop) ));
2879 /* The "did you use incorrect case?" warning used to be here.
2880 * The problem is that on case-insensitive filesystems one
2881 * might get false positives for "use" (and "require"):
2882 * "use Strict" or "require CARP" will work. This causes
2883 * portability problems for the script: in case-strict
2884 * filesystems the script will stop working.
2886 * The "incorrect case" warning checked whether "use Foo"
2887 * imported "Foo" to your namespace, but that is wrong, too:
2888 * there is no requirement nor promise in the language that
2889 * a Foo.pm should or would contain anything in package "Foo".
2891 * There is very little Configure-wise that can be done, either:
2892 * the case-sensitivity of the build filesystem of Perl does not
2893 * help in guessing the case-sensitivity of the runtime environment.
2896 PL_hints |= HINT_BLOCK_SCOPE;
2897 PL_copline = NOLINE;
2902 =head1 Embedding Functions
2904 =for apidoc load_module
2906 Loads the module whose name is pointed to by the string part of name.
2907 Note that the actual module name, not its filename, should be given.
2908 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
2909 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
2910 (or 0 for no flags). ver, if specified, provides version semantics
2911 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
2912 arguments can be used to specify arguments to the module's import()
2913 method, similar to C<use Foo::Bar VERSION LIST>.
2918 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
2921 va_start(args, ver);
2922 vload_module(flags, name, ver, &args);
2926 #ifdef PERL_IMPLICIT_CONTEXT
2928 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
2932 va_start(args, ver);
2933 vload_module(flags, name, ver, &args);
2939 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
2941 OP *modname, *veop, *imop;
2943 modname = newSVOP(OP_CONST, 0, name);
2944 modname->op_private |= OPpCONST_BARE;
2946 veop = newSVOP(OP_CONST, 0, ver);
2950 if (flags & PERL_LOADMOD_NOIMPORT) {
2951 imop = sawparens(newNULLLIST());
2953 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
2954 imop = va_arg(*args, OP*);
2959 sv = va_arg(*args, SV*);
2961 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
2962 sv = va_arg(*args, SV*);
2966 line_t ocopline = PL_copline;
2967 int oexpect = PL_expect;
2969 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
2970 veop, modname, imop);
2971 PL_expect = oexpect;
2972 PL_copline = ocopline;
2977 Perl_dofile(pTHX_ OP *term)
2982 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
2983 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
2984 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
2986 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
2987 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
2988 append_elem(OP_LIST, term,
2989 scalar(newUNOP(OP_RV2CV, 0,
2994 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3000 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3002 return newBINOP(OP_LSLICE, flags,
3003 list(force_list(subscript)),
3004 list(force_list(listval)) );
3008 S_list_assignment(pTHX_ register OP *o)
3013 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3014 o = cUNOPo->op_first;
3016 if (o->op_type == OP_COND_EXPR) {
3017 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3018 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3023 yyerror("Assignment to both a list and a scalar");
3027 if (o->op_type == OP_LIST &&
3028 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3029 o->op_private & OPpLVAL_INTRO)
3032 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3033 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3034 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3037 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3040 if (o->op_type == OP_RV2SV)
3047 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3052 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3053 return newLOGOP(optype, 0,
3054 mod(scalar(left), optype),
3055 newUNOP(OP_SASSIGN, 0, scalar(right)));
3058 return newBINOP(optype, OPf_STACKED,
3059 mod(scalar(left), optype), scalar(right));
3063 if (list_assignment(left)) {
3067 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3068 left = mod(left, OP_AASSIGN);
3076 curop = list(force_list(left));
3077 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3078 o->op_private = (U8)(0 | (flags >> 8));
3080 /* PL_generation sorcery:
3081 * an assignment like ($a,$b) = ($c,$d) is easier than
3082 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3083 * To detect whether there are common vars, the global var
3084 * PL_generation is incremented for each assign op we compile.
3085 * Then, while compiling the assign op, we run through all the
3086 * variables on both sides of the assignment, setting a spare slot
3087 * in each of them to PL_generation. If any of them already have
3088 * that value, we know we've got commonality. We could use a
3089 * single bit marker, but then we'd have to make 2 passes, first
3090 * to clear the flag, then to test and set it. To find somewhere
3091 * to store these values, evil chicanery is done with SvCUR().
3094 if (!(left->op_private & OPpLVAL_INTRO)) {
3097 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3098 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3099 if (curop->op_type == OP_GV) {
3100 GV *gv = cGVOPx_gv(curop);
3101 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3103 SvCUR(gv) = PL_generation;
3105 else if (curop->op_type == OP_PADSV ||
3106 curop->op_type == OP_PADAV ||
3107 curop->op_type == OP_PADHV ||
3108 curop->op_type == OP_PADANY)
3110 if (PAD_COMPNAME_GEN(curop->op_targ)
3113 PAD_COMPNAME_GEN(curop->op_targ)
3117 else if (curop->op_type == OP_RV2CV)
3119 else if (curop->op_type == OP_RV2SV ||
3120 curop->op_type == OP_RV2AV ||
3121 curop->op_type == OP_RV2HV ||
3122 curop->op_type == OP_RV2GV) {
3123 if (lastop->op_type != OP_GV) /* funny deref? */
3126 else if (curop->op_type == OP_PUSHRE) {
3127 if (((PMOP*)curop)->op_pmreplroot) {
3129 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3130 ((PMOP*)curop)->op_pmreplroot));
3132 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3134 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3136 SvCUR(gv) = PL_generation;
3145 o->op_private |= OPpASSIGN_COMMON;
3147 if (right && right->op_type == OP_SPLIT) {
3149 if ((tmpop = ((LISTOP*)right)->op_first) &&
3150 tmpop->op_type == OP_PUSHRE)
3152 PMOP *pm = (PMOP*)tmpop;
3153 if (left->op_type == OP_RV2AV &&
3154 !(left->op_private & OPpLVAL_INTRO) &&
3155 !(o->op_private & OPpASSIGN_COMMON) )
3157 tmpop = ((UNOP*)left)->op_first;
3158 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3160 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3161 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3163 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3164 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3166 pm->op_pmflags |= PMf_ONCE;
3167 tmpop = cUNOPo->op_first; /* to list (nulled) */
3168 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3169 tmpop->op_sibling = Nullop; /* don't free split */
3170 right->op_next = tmpop->op_next; /* fix starting loc */
3171 op_free(o); /* blow off assign */
3172 right->op_flags &= ~OPf_WANT;
3173 /* "I don't know and I don't care." */
3178 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3179 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3181 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3183 sv_setiv(sv, PL_modcount+1);
3191 right = newOP(OP_UNDEF, 0);
3192 if (right->op_type == OP_READLINE) {
3193 right->op_flags |= OPf_STACKED;
3194 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3197 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3198 o = newBINOP(OP_SASSIGN, flags,
3199 scalar(right), mod(scalar(left), OP_SASSIGN) );
3211 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3213 U32 seq = intro_my();
3216 NewOp(1101, cop, 1, COP);
3217 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3218 cop->op_type = OP_DBSTATE;
3219 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3222 cop->op_type = OP_NEXTSTATE;
3223 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3225 cop->op_flags = (U8)flags;
3226 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3228 cop->op_private |= NATIVE_HINTS;
3230 PL_compiling.op_private = cop->op_private;
3231 cop->op_next = (OP*)cop;
3234 cop->cop_label = label;
3235 PL_hints |= HINT_BLOCK_SCOPE;
3238 cop->cop_arybase = PL_curcop->cop_arybase;
3239 if (specialWARN(PL_curcop->cop_warnings))
3240 cop->cop_warnings = PL_curcop->cop_warnings ;
3242 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3243 if (specialCopIO(PL_curcop->cop_io))
3244 cop->cop_io = PL_curcop->cop_io;
3246 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3249 if (PL_copline == NOLINE)
3250 CopLINE_set(cop, CopLINE(PL_curcop));
3252 CopLINE_set(cop, PL_copline);
3253 PL_copline = NOLINE;
3256 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3258 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3260 CopSTASH_set(cop, PL_curstash);
3262 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3263 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3264 if (svp && *svp != &PL_sv_undef ) {
3265 (void)SvIOK_on(*svp);
3266 SvIVX(*svp) = PTR2IV(cop);
3270 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3275 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3277 return new_logop(type, flags, &first, &other);
3281 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3285 OP *first = *firstp;
3286 OP *other = *otherp;
3288 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3289 return newBINOP(type, flags, scalar(first), scalar(other));
3291 scalarboolean(first);
3292 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3293 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3294 if (type == OP_AND || type == OP_OR) {
3300 first = *firstp = cUNOPo->op_first;
3302 first->op_next = o->op_next;
3303 cUNOPo->op_first = Nullop;
3307 if (first->op_type == OP_CONST) {
3308 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE)) {
3309 if (first->op_private & OPpCONST_STRICT)
3310 no_bareword_allowed(first);
3312 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3314 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3325 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3326 OP *k1 = ((UNOP*)first)->op_first;
3327 OP *k2 = k1->op_sibling;
3329 switch (first->op_type)
3332 if (k2 && k2->op_type == OP_READLINE
3333 && (k2->op_flags & OPf_STACKED)
3334 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3336 warnop = k2->op_type;
3341 if (k1->op_type == OP_READDIR
3342 || k1->op_type == OP_GLOB
3343 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3344 || k1->op_type == OP_EACH)
3346 warnop = ((k1->op_type == OP_NULL)
3347 ? (OPCODE)k1->op_targ : k1->op_type);
3352 line_t oldline = CopLINE(PL_curcop);
3353 CopLINE_set(PL_curcop, PL_copline);
3354 Perl_warner(aTHX_ packWARN(WARN_MISC),
3355 "Value of %s%s can be \"0\"; test with defined()",
3357 ((warnop == OP_READLINE || warnop == OP_GLOB)
3358 ? " construct" : "() operator"));
3359 CopLINE_set(PL_curcop, oldline);
3366 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3367 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3369 NewOp(1101, logop, 1, LOGOP);
3371 logop->op_type = (OPCODE)type;
3372 logop->op_ppaddr = PL_ppaddr[type];
3373 logop->op_first = first;
3374 logop->op_flags = flags | OPf_KIDS;
3375 logop->op_other = LINKLIST(other);
3376 logop->op_private = (U8)(1 | (flags >> 8));
3378 /* establish postfix order */
3379 logop->op_next = LINKLIST(first);
3380 first->op_next = (OP*)logop;
3381 first->op_sibling = other;
3383 o = newUNOP(OP_NULL, 0, (OP*)logop);
3390 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3397 return newLOGOP(OP_AND, 0, first, trueop);
3399 return newLOGOP(OP_OR, 0, first, falseop);
3401 scalarboolean(first);
3402 if (first->op_type == OP_CONST) {
3403 if (first->op_private & OPpCONST_BARE &&
3404 first->op_private & OPpCONST_STRICT) {
3405 no_bareword_allowed(first);
3407 if (SvTRUE(((SVOP*)first)->op_sv)) {
3418 NewOp(1101, logop, 1, LOGOP);
3419 logop->op_type = OP_COND_EXPR;
3420 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3421 logop->op_first = first;
3422 logop->op_flags = flags | OPf_KIDS;
3423 logop->op_private = (U8)(1 | (flags >> 8));
3424 logop->op_other = LINKLIST(trueop);
3425 logop->op_next = LINKLIST(falseop);
3428 /* establish postfix order */
3429 start = LINKLIST(first);
3430 first->op_next = (OP*)logop;
3432 first->op_sibling = trueop;
3433 trueop->op_sibling = falseop;
3434 o = newUNOP(OP_NULL, 0, (OP*)logop);
3436 trueop->op_next = falseop->op_next = o;
3443 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3451 NewOp(1101, range, 1, LOGOP);
3453 range->op_type = OP_RANGE;
3454 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3455 range->op_first = left;
3456 range->op_flags = OPf_KIDS;
3457 leftstart = LINKLIST(left);
3458 range->op_other = LINKLIST(right);
3459 range->op_private = (U8)(1 | (flags >> 8));
3461 left->op_sibling = right;
3463 range->op_next = (OP*)range;
3464 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3465 flop = newUNOP(OP_FLOP, 0, flip);
3466 o = newUNOP(OP_NULL, 0, flop);
3468 range->op_next = leftstart;
3470 left->op_next = flip;
3471 right->op_next = flop;
3473 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3474 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3475 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3476 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3478 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3479 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3482 if (!flip->op_private || !flop->op_private)
3483 linklist(o); /* blow off optimizer unless constant */
3489 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3493 int once = block && block->op_flags & OPf_SPECIAL &&
3494 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3497 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3498 return block; /* do {} while 0 does once */
3499 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3500 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3501 expr = newUNOP(OP_DEFINED, 0,
3502 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3503 } else if (expr->op_flags & OPf_KIDS) {
3504 OP *k1 = ((UNOP*)expr)->op_first;
3505 OP *k2 = (k1) ? k1->op_sibling : NULL;
3506 switch (expr->op_type) {
3508 if (k2 && k2->op_type == OP_READLINE
3509 && (k2->op_flags & OPf_STACKED)
3510 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3511 expr = newUNOP(OP_DEFINED, 0, expr);
3515 if (k1->op_type == OP_READDIR
3516 || k1->op_type == OP_GLOB
3517 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3518 || k1->op_type == OP_EACH)
3519 expr = newUNOP(OP_DEFINED, 0, expr);
3525 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3526 o = new_logop(OP_AND, 0, &expr, &listop);
3529 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3531 if (once && o != listop)
3532 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3535 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3537 o->op_flags |= flags;
3539 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3544 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3552 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3553 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3554 expr = newUNOP(OP_DEFINED, 0,
3555 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3556 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3557 OP *k1 = ((UNOP*)expr)->op_first;
3558 OP *k2 = (k1) ? k1->op_sibling : NULL;
3559 switch (expr->op_type) {
3561 if (k2 && k2->op_type == OP_READLINE
3562 && (k2->op_flags & OPf_STACKED)
3563 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3564 expr = newUNOP(OP_DEFINED, 0, expr);
3568 if (k1->op_type == OP_READDIR
3569 || k1->op_type == OP_GLOB
3570 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3571 || k1->op_type == OP_EACH)
3572 expr = newUNOP(OP_DEFINED, 0, expr);
3578 block = newOP(OP_NULL, 0);
3580 block = scope(block);
3584 next = LINKLIST(cont);
3587 OP *unstack = newOP(OP_UNSTACK, 0);
3590 cont = append_elem(OP_LINESEQ, cont, unstack);
3591 if ((line_t)whileline != NOLINE) {
3592 PL_copline = (line_t)whileline;
3593 cont = append_elem(OP_LINESEQ, cont,
3594 newSTATEOP(0, Nullch, Nullop));
3598 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3599 redo = LINKLIST(listop);
3602 PL_copline = (line_t)whileline;
3604 o = new_logop(OP_AND, 0, &expr, &listop);
3605 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3606 op_free(expr); /* oops, it's a while (0) */
3608 return Nullop; /* listop already freed by new_logop */
3611 ((LISTOP*)listop)->op_last->op_next =
3612 (o == listop ? redo : LINKLIST(o));
3618 NewOp(1101,loop,1,LOOP);
3619 loop->op_type = OP_ENTERLOOP;
3620 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3621 loop->op_private = 0;
3622 loop->op_next = (OP*)loop;
3625 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3627 loop->op_redoop = redo;
3628 loop->op_lastop = o;
3629 o->op_private |= loopflags;
3632 loop->op_nextop = next;
3634 loop->op_nextop = o;
3636 o->op_flags |= flags;
3637 o->op_private |= (flags >> 8);
3642 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
3646 PADOFFSET padoff = 0;
3650 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
3651 sv->op_type = OP_RV2GV;
3652 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3654 else if (sv->op_type == OP_PADSV) { /* private variable */
3655 padoff = sv->op_targ;
3660 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3661 padoff = sv->op_targ;
3663 iterflags |= OPf_SPECIAL;
3668 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3671 sv = newGVOP(OP_GV, 0, PL_defgv);
3673 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3674 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3675 iterflags |= OPf_STACKED;
3677 else if (expr->op_type == OP_NULL &&
3678 (expr->op_flags & OPf_KIDS) &&
3679 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3681 /* Basically turn for($x..$y) into the same as for($x,$y), but we
3682 * set the STACKED flag to indicate that these values are to be
3683 * treated as min/max values by 'pp_iterinit'.
3685 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
3686 LOGOP* range = (LOGOP*) flip->op_first;
3687 OP* left = range->op_first;
3688 OP* right = left->op_sibling;
3691 range->op_flags &= ~OPf_KIDS;
3692 range->op_first = Nullop;
3694 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
3695 listop->op_first->op_next = range->op_next;
3696 left->op_next = range->op_other;
3697 right->op_next = (OP*)listop;
3698 listop->op_next = listop->op_first;
3701 expr = (OP*)(listop);
3703 iterflags |= OPf_STACKED;
3706 expr = mod(force_list(expr), OP_GREPSTART);
3710 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
3711 append_elem(OP_LIST, expr, scalar(sv))));
3712 assert(!loop->op_next);
3713 #ifdef PL_OP_SLAB_ALLOC
3716 NewOp(1234,tmp,1,LOOP);
3717 Copy(loop,tmp,1,LOOP);
3722 Renew(loop, 1, LOOP);
3724 loop->op_targ = padoff;
3725 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
3726 PL_copline = forline;
3727 return newSTATEOP(0, label, wop);
3731 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
3736 if (type != OP_GOTO || label->op_type == OP_CONST) {
3737 /* "last()" means "last" */
3738 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
3739 o = newOP(type, OPf_SPECIAL);
3741 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
3742 ? SvPVx(((SVOP*)label)->op_sv, n_a)
3748 if (label->op_type == OP_ENTERSUB)
3749 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
3750 o = newUNOP(type, OPf_STACKED, label);
3752 PL_hints |= HINT_BLOCK_SCOPE;
3757 Perl_cv_undef(pTHX_ CV *cv)
3759 CV *freecv = Nullcv;
3762 if (CvFILE(cv) && !CvXSUB(cv)) {
3763 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
3764 Safefree(CvFILE(cv));
3769 if (!CvXSUB(cv) && CvROOT(cv)) {
3771 Perl_croak(aTHX_ "Can't undef active subroutine");
3774 PAD_SAVE_SETNULLPAD();
3776 op_free(CvROOT(cv));
3777 CvROOT(cv) = Nullop;
3780 SvPOK_off((SV*)cv); /* forget prototype */
3785 /* Since closure prototypes have the same lifetime as the containing
3786 * CV, they don't hold a refcount on the outside CV. This avoids
3787 * the refcount loop between the outer CV (which keeps a refcount to
3788 * the closure prototype in the pad entry for pp_anoncode()) and the
3789 * closure prototype, and the ensuing memory leak. --GSAR */
3790 if (!CvANON(cv) || CvCLONED(cv))
3791 freecv = CvOUTSIDE(cv);
3792 CvOUTSIDE(cv) = Nullcv;
3794 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
3798 SvREFCNT_dec(freecv);
3806 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
3808 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
3809 SV* msg = sv_newmortal();
3813 gv_efullname3(name = sv_newmortal(), gv, Nullch);
3814 sv_setpv(msg, "Prototype mismatch:");
3816 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
3818 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
3819 sv_catpv(msg, " vs ");
3821 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
3823 sv_catpv(msg, "none");
3824 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
3828 static void const_sv_xsub(pTHX_ CV* cv);
3832 =head1 Optree Manipulation Functions
3834 =for apidoc cv_const_sv
3836 If C<cv> is a constant sub eligible for inlining. returns the constant
3837 value returned by the sub. Otherwise, returns NULL.
3839 Constant subs can be created with C<newCONSTSUB> or as described in
3840 L<perlsub/"Constant Functions">.
3845 Perl_cv_const_sv(pTHX_ CV *cv)
3847 if (!cv || !CvCONST(cv))
3849 return (SV*)CvXSUBANY(cv).any_ptr;
3853 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
3860 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
3861 o = cLISTOPo->op_first->op_sibling;
3863 for (; o; o = o->op_next) {
3864 OPCODE type = o->op_type;
3866 if (sv && o->op_next == o)
3868 if (o->op_next != o) {
3869 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
3871 if (type == OP_DBSTATE)
3874 if (type == OP_LEAVESUB || type == OP_RETURN)
3878 if (type == OP_CONST && cSVOPo->op_sv)
3880 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
3881 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
3885 /* We get here only from cv_clone2() while creating a closure.
3886 Copy the const value here instead of in cv_clone2 so that
3887 SvREADONLY_on doesn't lead to problems when leaving
3892 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
3904 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
3914 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
3918 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
3920 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
3924 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
3930 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
3934 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
3935 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
3936 SV *sv = sv_newmortal();
3937 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
3938 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
3939 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3944 gv = gv_fetchpv(name ? name : (aname ? aname :
3945 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__")),
3946 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
3956 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
3957 maximum a prototype before. */
3958 if (SvTYPE(gv) > SVt_NULL) {
3959 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
3960 && ckWARN_d(WARN_PROTOTYPE))
3962 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
3964 cv_ckproto((CV*)gv, NULL, ps);
3967 sv_setpv((SV*)gv, ps);
3969 sv_setiv((SV*)gv, -1);
3970 SvREFCNT_dec(PL_compcv);
3971 cv = PL_compcv = NULL;
3972 PL_sub_generation++;
3976 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
3978 #ifdef GV_UNIQUE_CHECK
3979 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
3980 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
3984 if (!block || !ps || *ps || attrs)
3987 const_sv = op_const_sv(block, Nullcv);
3990 bool exists = CvROOT(cv) || CvXSUB(cv);
3992 #ifdef GV_UNIQUE_CHECK
3993 if (exists && GvUNIQUE(gv)) {
3994 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
3998 /* if the subroutine doesn't exist and wasn't pre-declared
3999 * with a prototype, assume it will be AUTOLOADed,
4000 * skipping the prototype check
4002 if (exists || SvPOK(cv))
4003 cv_ckproto(cv, gv, ps);
4004 /* already defined (or promised)? */
4005 if (exists || GvASSUMECV(gv)) {
4006 if (!block && !attrs) {
4007 if (CvFLAGS(PL_compcv)) {
4008 /* might have had built-in attrs applied */
4009 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4011 /* just a "sub foo;" when &foo is already defined */
4012 SAVEFREESV(PL_compcv);
4015 /* ahem, death to those who redefine active sort subs */
4016 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4017 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4019 if (ckWARN(WARN_REDEFINE)
4021 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4023 line_t oldline = CopLINE(PL_curcop);
4024 if (PL_copline != NOLINE)
4025 CopLINE_set(PL_curcop, PL_copline);
4026 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4027 CvCONST(cv) ? "Constant subroutine %s redefined"
4028 : "Subroutine %s redefined", name);
4029 CopLINE_set(PL_curcop, oldline);
4037 SvREFCNT_inc(const_sv);
4039 assert(!CvROOT(cv) && !CvCONST(cv));
4040 sv_setpv((SV*)cv, ""); /* prototype is "" */
4041 CvXSUBANY(cv).any_ptr = const_sv;
4042 CvXSUB(cv) = const_sv_xsub;
4047 cv = newCONSTSUB(NULL, name, const_sv);
4050 SvREFCNT_dec(PL_compcv);
4052 PL_sub_generation++;
4059 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4060 * before we clobber PL_compcv.
4064 /* Might have had built-in attributes applied -- propagate them. */
4065 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4066 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4067 stash = GvSTASH(CvGV(cv));
4068 else if (CvSTASH(cv))
4069 stash = CvSTASH(cv);
4071 stash = PL_curstash;
4074 /* possibly about to re-define existing subr -- ignore old cv */
4075 rcv = (SV*)PL_compcv;
4076 if (name && GvSTASH(gv))
4077 stash = GvSTASH(gv);
4079 stash = PL_curstash;
4081 apply_attrs(stash, rcv, attrs, FALSE);
4083 if (cv) { /* must reuse cv if autoloaded */
4085 /* got here with just attrs -- work done, so bug out */
4086 SAVEFREESV(PL_compcv);
4089 /* transfer PL_compcv to cv */
4091 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4092 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4093 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4094 CvOUTSIDE(PL_compcv) = 0;
4095 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4096 CvPADLIST(PL_compcv) = 0;
4097 /* inner references to PL_compcv must be fixed up ... */
4098 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4099 /* ... before we throw it away */
4100 SvREFCNT_dec(PL_compcv);
4101 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4102 ++PL_sub_generation;
4109 PL_sub_generation++;
4113 CvFILE_set_from_cop(cv, PL_curcop);
4114 CvSTASH(cv) = PL_curstash;
4117 sv_setpv((SV*)cv, ps);
4119 if (PL_error_count) {
4123 char *s = strrchr(name, ':');
4125 if (strEQ(s, "BEGIN")) {
4127 "BEGIN not safe after errors--compilation aborted";
4128 if (PL_in_eval & EVAL_KEEPERR)
4129 Perl_croak(aTHX_ not_safe);
4131 /* force display of errors found but not reported */
4132 sv_catpv(ERRSV, not_safe);
4133 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4142 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4143 mod(scalarseq(block), OP_LEAVESUBLV));
4146 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4148 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4149 OpREFCNT_set(CvROOT(cv), 1);
4150 CvSTART(cv) = LINKLIST(CvROOT(cv));
4151 CvROOT(cv)->op_next = 0;
4152 CALL_PEEP(CvSTART(cv));
4154 /* now that optimizer has done its work, adjust pad values */
4156 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4159 assert(!CvCONST(cv));
4160 if (ps && !*ps && op_const_sv(block, cv))
4164 /* If a potential closure prototype, don't keep a refcount on outer CV.
4165 * This is okay as the lifetime of the prototype is tied to the
4166 * lifetime of the outer CV. Avoids memory leak due to reference
4169 SvREFCNT_dec(CvOUTSIDE(cv));
4171 if (name || aname) {
4173 char *tname = (name ? name : aname);
4175 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4176 SV *sv = NEWSV(0,0);
4177 SV *tmpstr = sv_newmortal();
4178 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4182 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4184 (long)PL_subline, (long)CopLINE(PL_curcop));
4185 gv_efullname3(tmpstr, gv, Nullch);
4186 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4187 hv = GvHVn(db_postponed);
4188 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4189 && (pcv = GvCV(db_postponed)))
4195 call_sv((SV*)pcv, G_DISCARD);
4199 if ((s = strrchr(tname,':')))
4204 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4207 if (strEQ(s, "BEGIN")) {
4208 I32 oldscope = PL_scopestack_ix;
4210 SAVECOPFILE(&PL_compiling);
4211 SAVECOPLINE(&PL_compiling);
4214 PL_beginav = newAV();
4215 DEBUG_x( dump_sub(gv) );
4216 av_push(PL_beginav, (SV*)cv);
4217 GvCV(gv) = 0; /* cv has been hijacked */
4218 call_list(oldscope, PL_beginav);
4220 PL_curcop = &PL_compiling;
4221 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4224 else if (strEQ(s, "END") && !PL_error_count) {
4227 DEBUG_x( dump_sub(gv) );
4228 av_unshift(PL_endav, 1);
4229 av_store(PL_endav, 0, (SV*)cv);
4230 GvCV(gv) = 0; /* cv has been hijacked */
4232 else if (strEQ(s, "CHECK") && !PL_error_count) {
4234 PL_checkav = newAV();
4235 DEBUG_x( dump_sub(gv) );
4236 if (PL_main_start && ckWARN(WARN_VOID))
4237 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4238 av_unshift(PL_checkav, 1);
4239 av_store(PL_checkav, 0, (SV*)cv);
4240 GvCV(gv) = 0; /* cv has been hijacked */
4242 else if (strEQ(s, "INIT") && !PL_error_count) {
4244 PL_initav = newAV();
4245 DEBUG_x( dump_sub(gv) );
4246 if (PL_main_start && ckWARN(WARN_VOID))
4247 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4248 av_push(PL_initav, (SV*)cv);
4249 GvCV(gv) = 0; /* cv has been hijacked */
4254 PL_copline = NOLINE;
4259 /* XXX unsafe for threads if eval_owner isn't held */
4261 =for apidoc newCONSTSUB
4263 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4264 eligible for inlining at compile-time.
4270 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4276 SAVECOPLINE(PL_curcop);
4277 CopLINE_set(PL_curcop, PL_copline);
4280 PL_hints &= ~HINT_BLOCK_SCOPE;
4283 SAVESPTR(PL_curstash);
4284 SAVECOPSTASH(PL_curcop);
4285 PL_curstash = stash;
4286 CopSTASH_set(PL_curcop,stash);
4289 cv = newXS(name, const_sv_xsub, __FILE__);
4290 CvXSUBANY(cv).any_ptr = sv;
4292 sv_setpv((SV*)cv, ""); /* prototype is "" */
4300 =for apidoc U||newXS
4302 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4308 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
4310 GV *gv = gv_fetchpv(name ? name :
4311 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4312 GV_ADDMULTI, SVt_PVCV);
4316 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4318 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4320 /* just a cached method */
4324 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4325 /* already defined (or promised) */
4326 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4327 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4328 line_t oldline = CopLINE(PL_curcop);
4329 if (PL_copline != NOLINE)
4330 CopLINE_set(PL_curcop, PL_copline);
4331 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4332 CvCONST(cv) ? "Constant subroutine %s redefined"
4333 : "Subroutine %s redefined"
4335 CopLINE_set(PL_curcop, oldline);
4342 if (cv) /* must reuse cv if autoloaded */
4345 cv = (CV*)NEWSV(1105,0);
4346 sv_upgrade((SV *)cv, SVt_PVCV);
4350 PL_sub_generation++;
4354 (void)gv_fetchfile(filename);
4355 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
4356 an external constant string */
4357 CvXSUB(cv) = subaddr;
4360 char *s = strrchr(name,':');
4366 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4369 if (strEQ(s, "BEGIN")) {
4371 PL_beginav = newAV();
4372 av_push(PL_beginav, (SV*)cv);
4373 GvCV(gv) = 0; /* cv has been hijacked */
4375 else if (strEQ(s, "END")) {
4378 av_unshift(PL_endav, 1);
4379 av_store(PL_endav, 0, (SV*)cv);
4380 GvCV(gv) = 0; /* cv has been hijacked */
4382 else if (strEQ(s, "CHECK")) {
4384 PL_checkav = newAV();
4385 if (PL_main_start && ckWARN(WARN_VOID))
4386 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4387 av_unshift(PL_checkav, 1);
4388 av_store(PL_checkav, 0, (SV*)cv);
4389 GvCV(gv) = 0; /* cv has been hijacked */
4391 else if (strEQ(s, "INIT")) {
4393 PL_initav = newAV();
4394 if (PL_main_start && ckWARN(WARN_VOID))
4395 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4396 av_push(PL_initav, (SV*)cv);
4397 GvCV(gv) = 0; /* cv has been hijacked */
4408 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4416 name = SvPVx(cSVOPo->op_sv, n_a);
4419 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
4420 #ifdef GV_UNIQUE_CHECK
4422 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4426 if ((cv = GvFORM(gv))) {
4427 if (ckWARN(WARN_REDEFINE)) {
4428 line_t oldline = CopLINE(PL_curcop);
4429 if (PL_copline != NOLINE)
4430 CopLINE_set(PL_curcop, PL_copline);
4431 Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Format %s redefined",name);
4432 CopLINE_set(PL_curcop, oldline);
4439 CvFILE_set_from_cop(cv, PL_curcop);
4442 pad_tidy(padtidy_FORMAT);
4443 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4444 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4445 OpREFCNT_set(CvROOT(cv), 1);
4446 CvSTART(cv) = LINKLIST(CvROOT(cv));
4447 CvROOT(cv)->op_next = 0;
4448 CALL_PEEP(CvSTART(cv));
4450 PL_copline = NOLINE;
4455 Perl_newANONLIST(pTHX_ OP *o)
4457 return newUNOP(OP_REFGEN, 0,
4458 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4462 Perl_newANONHASH(pTHX_ OP *o)
4464 return newUNOP(OP_REFGEN, 0,
4465 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4469 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4471 return newANONATTRSUB(floor, proto, Nullop, block);
4475 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4477 return newUNOP(OP_REFGEN, 0,
4478 newSVOP(OP_ANONCODE, 0,
4479 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
4483 Perl_oopsAV(pTHX_ OP *o)
4485 switch (o->op_type) {
4487 o->op_type = OP_PADAV;
4488 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4489 return ref(o, OP_RV2AV);
4492 o->op_type = OP_RV2AV;
4493 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4498 if (ckWARN_d(WARN_INTERNAL))
4499 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
4506 Perl_oopsHV(pTHX_ OP *o)
4508 switch (o->op_type) {
4511 o->op_type = OP_PADHV;
4512 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4513 return ref(o, OP_RV2HV);
4517 o->op_type = OP_RV2HV;
4518 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
4523 if (ckWARN_d(WARN_INTERNAL))
4524 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
4531 Perl_newAVREF(pTHX_ OP *o)
4533 if (o->op_type == OP_PADANY) {
4534 o->op_type = OP_PADAV;
4535 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4538 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
4539 && ckWARN(WARN_DEPRECATED)) {
4540 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4541 "Using an array as a reference is deprecated");
4543 return newUNOP(OP_RV2AV, 0, scalar(o));
4547 Perl_newGVREF(pTHX_ I32 type, OP *o)
4549 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
4550 return newUNOP(OP_NULL, 0, o);
4551 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
4555 Perl_newHVREF(pTHX_ OP *o)
4557 if (o->op_type == OP_PADANY) {
4558 o->op_type = OP_PADHV;
4559 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4562 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
4563 && ckWARN(WARN_DEPRECATED)) {
4564 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4565 "Using a hash as a reference is deprecated");
4567 return newUNOP(OP_RV2HV, 0, scalar(o));
4571 Perl_oopsCV(pTHX_ OP *o)
4573 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
4579 Perl_newCVREF(pTHX_ I32 flags, OP *o)
4581 return newUNOP(OP_RV2CV, flags, scalar(o));
4585 Perl_newSVREF(pTHX_ OP *o)
4587 if (o->op_type == OP_PADANY) {
4588 o->op_type = OP_PADSV;
4589 o->op_ppaddr = PL_ppaddr[OP_PADSV];
4592 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4593 o->op_flags |= OPpDONE_SVREF;
4596 return newUNOP(OP_RV2SV, 0, scalar(o));
4599 /* Check routines. */
4602 Perl_ck_anoncode(pTHX_ OP *o)
4604 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
4605 cSVOPo->op_sv = Nullsv;
4610 Perl_ck_bitop(pTHX_ OP *o)
4612 #define OP_IS_NUMCOMPARE(op) \
4613 ((op) == OP_LT || (op) == OP_I_LT || \
4614 (op) == OP_GT || (op) == OP_I_GT || \
4615 (op) == OP_LE || (op) == OP_I_LE || \
4616 (op) == OP_GE || (op) == OP_I_GE || \
4617 (op) == OP_EQ || (op) == OP_I_EQ || \
4618 (op) == OP_NE || (op) == OP_I_NE || \
4619 (op) == OP_NCMP || (op) == OP_I_NCMP)
4620 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4621 if (o->op_type == OP_BIT_OR
4622 || o->op_type == OP_BIT_AND
4623 || o->op_type == OP_BIT_XOR)
4625 OPCODE typfirst = cBINOPo->op_first->op_type;
4626 OPCODE typlast = cBINOPo->op_first->op_sibling->op_type;
4627 if (OP_IS_NUMCOMPARE(typfirst) || OP_IS_NUMCOMPARE(typlast))
4628 if (ckWARN(WARN_PRECEDENCE))
4629 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4630 "Possible precedence problem on bitwise %c operator",
4631 o->op_type == OP_BIT_OR ? '|'
4632 : o->op_type == OP_BIT_AND ? '&' : '^'
4639 Perl_ck_concat(pTHX_ OP *o)
4641 if (cUNOPo->op_first->op_type == OP_CONCAT)
4642 o->op_flags |= OPf_STACKED;
4647 Perl_ck_spair(pTHX_ OP *o)
4649 if (o->op_flags & OPf_KIDS) {
4652 OPCODE type = o->op_type;
4653 o = modkids(ck_fun(o), type);
4654 kid = cUNOPo->op_first;
4655 newop = kUNOP->op_first->op_sibling;
4657 (newop->op_sibling ||
4658 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
4659 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
4660 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
4664 op_free(kUNOP->op_first);
4665 kUNOP->op_first = newop;
4667 o->op_ppaddr = PL_ppaddr[++o->op_type];
4672 Perl_ck_delete(pTHX_ OP *o)
4676 if (o->op_flags & OPf_KIDS) {
4677 OP *kid = cUNOPo->op_first;
4678 switch (kid->op_type) {
4680 o->op_flags |= OPf_SPECIAL;
4683 o->op_private |= OPpSLICE;
4686 o->op_flags |= OPf_SPECIAL;
4691 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
4700 Perl_ck_die(pTHX_ OP *o)
4703 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4709 Perl_ck_eof(pTHX_ OP *o)
4711 I32 type = o->op_type;
4713 if (o->op_flags & OPf_KIDS) {
4714 if (cLISTOPo->op_first->op_type == OP_STUB) {
4716 o = newUNOP(type, OPf_SPECIAL,
4717 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
4725 Perl_ck_eval(pTHX_ OP *o)
4727 PL_hints |= HINT_BLOCK_SCOPE;
4728 if (o->op_flags & OPf_KIDS) {
4729 SVOP *kid = (SVOP*)cUNOPo->op_first;
4732 o->op_flags &= ~OPf_KIDS;
4735 else if (kid->op_type == OP_LINESEQ) {
4738 kid->op_next = o->op_next;
4739 cUNOPo->op_first = 0;
4742 NewOp(1101, enter, 1, LOGOP);
4743 enter->op_type = OP_ENTERTRY;
4744 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
4745 enter->op_private = 0;
4747 /* establish postfix order */
4748 enter->op_next = (OP*)enter;
4750 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
4751 o->op_type = OP_LEAVETRY;
4752 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
4753 enter->op_other = o;
4761 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
4763 o->op_targ = (PADOFFSET)PL_hints;
4768 Perl_ck_exit(pTHX_ OP *o)
4771 HV *table = GvHV(PL_hintgv);
4773 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
4774 if (svp && *svp && SvTRUE(*svp))
4775 o->op_private |= OPpEXIT_VMSISH;
4777 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4783 Perl_ck_exec(pTHX_ OP *o)
4786 if (o->op_flags & OPf_STACKED) {
4788 kid = cUNOPo->op_first->op_sibling;
4789 if (kid->op_type == OP_RV2GV)
4798 Perl_ck_exists(pTHX_ OP *o)
4801 if (o->op_flags & OPf_KIDS) {
4802 OP *kid = cUNOPo->op_first;
4803 if (kid->op_type == OP_ENTERSUB) {
4804 (void) ref(kid, o->op_type);
4805 if (kid->op_type != OP_RV2CV && !PL_error_count)
4806 Perl_croak(aTHX_ "%s argument is not a subroutine name",
4808 o->op_private |= OPpEXISTS_SUB;
4810 else if (kid->op_type == OP_AELEM)
4811 o->op_flags |= OPf_SPECIAL;
4812 else if (kid->op_type != OP_HELEM)
4813 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
4822 Perl_ck_gvconst(pTHX_ register OP *o)
4824 o = fold_constants(o);
4825 if (o->op_type == OP_CONST)
4832 Perl_ck_rvconst(pTHX_ register OP *o)
4834 SVOP *kid = (SVOP*)cUNOPo->op_first;
4836 o->op_private |= (PL_hints & HINT_STRICT_REFS);
4837 if (kid->op_type == OP_CONST) {
4841 SV *kidsv = kid->op_sv;
4844 /* Is it a constant from cv_const_sv()? */
4845 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
4846 SV *rsv = SvRV(kidsv);
4847 int svtype = SvTYPE(rsv);
4848 char *badtype = Nullch;
4850 switch (o->op_type) {
4852 if (svtype > SVt_PVMG)
4853 badtype = "a SCALAR";
4856 if (svtype != SVt_PVAV)
4857 badtype = "an ARRAY";
4860 if (svtype != SVt_PVHV)
4864 if (svtype != SVt_PVCV)
4869 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
4872 name = SvPV(kidsv, n_a);
4873 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
4874 char *badthing = Nullch;
4875 switch (o->op_type) {
4877 badthing = "a SCALAR";
4880 badthing = "an ARRAY";
4883 badthing = "a HASH";
4888 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
4892 * This is a little tricky. We only want to add the symbol if we
4893 * didn't add it in the lexer. Otherwise we get duplicate strict
4894 * warnings. But if we didn't add it in the lexer, we must at
4895 * least pretend like we wanted to add it even if it existed before,
4896 * or we get possible typo warnings. OPpCONST_ENTERED says
4897 * whether the lexer already added THIS instance of this symbol.
4899 iscv = (o->op_type == OP_RV2CV) * 2;
4901 gv = gv_fetchpv(name,
4902 iscv | !(kid->op_private & OPpCONST_ENTERED),
4905 : o->op_type == OP_RV2SV
4907 : o->op_type == OP_RV2AV
4909 : o->op_type == OP_RV2HV
4912 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
4914 kid->op_type = OP_GV;
4915 SvREFCNT_dec(kid->op_sv);
4917 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
4918 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
4919 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
4921 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
4923 kid->op_sv = SvREFCNT_inc(gv);
4925 kid->op_private = 0;
4926 kid->op_ppaddr = PL_ppaddr[OP_GV];
4933 Perl_ck_ftst(pTHX_ OP *o)
4935 I32 type = o->op_type;
4937 if (o->op_flags & OPf_REF) {
4940 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
4941 SVOP *kid = (SVOP*)cUNOPo->op_first;
4943 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
4945 OP *newop = newGVOP(type, OPf_REF,
4946 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
4953 if (type == OP_FTTTY)
4954 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
4957 o = newUNOP(type, 0, newDEFSVOP());
4963 Perl_ck_fun(pTHX_ OP *o)
4969 int type = o->op_type;
4970 register I32 oa = PL_opargs[type] >> OASHIFT;
4972 if (o->op_flags & OPf_STACKED) {
4973 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
4976 return no_fh_allowed(o);
4979 if (o->op_flags & OPf_KIDS) {
4981 tokid = &cLISTOPo->op_first;
4982 kid = cLISTOPo->op_first;
4983 if (kid->op_type == OP_PUSHMARK ||
4984 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
4986 tokid = &kid->op_sibling;
4987 kid = kid->op_sibling;
4989 if (!kid && PL_opargs[type] & OA_DEFGV)
4990 *tokid = kid = newDEFSVOP();
4994 sibl = kid->op_sibling;
4997 /* list seen where single (scalar) arg expected? */
4998 if (numargs == 1 && !(oa >> 4)
4999 && kid->op_type == OP_LIST && type != OP_SCALAR)
5001 return too_many_arguments(o,PL_op_desc[type]);
5014 if ((type == OP_PUSH || type == OP_UNSHIFT)
5015 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5016 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5017 "Useless use of %s with no values",
5020 if (kid->op_type == OP_CONST &&
5021 (kid->op_private & OPpCONST_BARE))
5023 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5024 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5025 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5026 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5027 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5028 "Array @%s missing the @ in argument %"IVdf" of %s()",
5029 name, (IV)numargs, PL_op_desc[type]);
5032 kid->op_sibling = sibl;
5035 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5036 bad_type(numargs, "array", PL_op_desc[type], kid);
5040 if (kid->op_type == OP_CONST &&
5041 (kid->op_private & OPpCONST_BARE))
5043 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5044 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5045 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5046 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5047 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5048 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5049 name, (IV)numargs, PL_op_desc[type]);
5052 kid->op_sibling = sibl;
5055 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5056 bad_type(numargs, "hash", PL_op_desc[type], kid);
5061 OP *newop = newUNOP(OP_NULL, 0, kid);
5062 kid->op_sibling = 0;
5064 newop->op_next = newop;
5066 kid->op_sibling = sibl;
5071 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5072 if (kid->op_type == OP_CONST &&
5073 (kid->op_private & OPpCONST_BARE))
5075 OP *newop = newGVOP(OP_GV, 0,
5076 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5078 if (!(o->op_private & 1) && /* if not unop */
5079 kid == cLISTOPo->op_last)
5080 cLISTOPo->op_last = newop;
5084 else if (kid->op_type == OP_READLINE) {
5085 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5086 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5089 I32 flags = OPf_SPECIAL;
5093 /* is this op a FH constructor? */
5094 if (is_handle_constructor(o,numargs)) {
5095 char *name = Nullch;
5099 /* Set a flag to tell rv2gv to vivify
5100 * need to "prove" flag does not mean something
5101 * else already - NI-S 1999/05/07
5104 if (kid->op_type == OP_PADSV) {
5105 /*XXX DAPM 2002.08.25 tmp assert test */
5106 /*XXX*/ assert(av_fetch(PL_comppad_name, (kid->op_targ), FALSE));
5107 /*XXX*/ assert(*av_fetch(PL_comppad_name, (kid->op_targ), FALSE));
5109 name = PAD_COMPNAME_PV(kid->op_targ);
5110 /* SvCUR of a pad namesv can't be trusted
5111 * (see PL_generation), so calc its length
5117 else if (kid->op_type == OP_RV2SV
5118 && kUNOP->op_first->op_type == OP_GV)
5120 GV *gv = cGVOPx_gv(kUNOP->op_first);
5122 len = GvNAMELEN(gv);
5124 else if (kid->op_type == OP_AELEM
5125 || kid->op_type == OP_HELEM)
5127 name = "__ANONIO__";
5133 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5134 namesv = PAD_SVl(targ);
5135 (void)SvUPGRADE(namesv, SVt_PV);
5137 sv_setpvn(namesv, "$", 1);
5138 sv_catpvn(namesv, name, len);
5141 kid->op_sibling = 0;
5142 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5143 kid->op_targ = targ;
5144 kid->op_private |= priv;
5146 kid->op_sibling = sibl;
5152 mod(scalar(kid), type);
5156 tokid = &kid->op_sibling;
5157 kid = kid->op_sibling;
5159 o->op_private |= numargs;
5161 return too_many_arguments(o,OP_DESC(o));
5164 else if (PL_opargs[type] & OA_DEFGV) {
5166 return newUNOP(type, 0, newDEFSVOP());
5170 while (oa & OA_OPTIONAL)
5172 if (oa && oa != OA_LIST)
5173 return too_few_arguments(o,OP_DESC(o));
5179 Perl_ck_glob(pTHX_ OP *o)
5184 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5185 append_elem(OP_GLOB, o, newDEFSVOP());
5187 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5188 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5190 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5193 #if !defined(PERL_EXTERNAL_GLOB)
5194 /* XXX this can be tightened up and made more failsafe. */
5198 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5199 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5200 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5201 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5202 GvCV(gv) = GvCV(glob_gv);
5203 SvREFCNT_inc((SV*)GvCV(gv));
5204 GvIMPORTED_CV_on(gv);
5207 #endif /* PERL_EXTERNAL_GLOB */
5209 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5210 append_elem(OP_GLOB, o,
5211 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5212 o->op_type = OP_LIST;
5213 o->op_ppaddr = PL_ppaddr[OP_LIST];
5214 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5215 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5216 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5217 append_elem(OP_LIST, o,
5218 scalar(newUNOP(OP_RV2CV, 0,
5219 newGVOP(OP_GV, 0, gv)))));
5220 o = newUNOP(OP_NULL, 0, ck_subr(o));
5221 o->op_targ = OP_GLOB; /* hint at what it used to be */
5224 gv = newGVgen("main");
5226 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5232 Perl_ck_grep(pTHX_ OP *o)
5236 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5238 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5239 NewOp(1101, gwop, 1, LOGOP);
5241 if (o->op_flags & OPf_STACKED) {
5244 kid = cLISTOPo->op_first->op_sibling;
5245 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5248 kid->op_next = (OP*)gwop;
5249 o->op_flags &= ~OPf_STACKED;
5251 kid = cLISTOPo->op_first->op_sibling;
5252 if (type == OP_MAPWHILE)
5259 kid = cLISTOPo->op_first->op_sibling;
5260 if (kid->op_type != OP_NULL)
5261 Perl_croak(aTHX_ "panic: ck_grep");
5262 kid = kUNOP->op_first;
5264 gwop->op_type = type;
5265 gwop->op_ppaddr = PL_ppaddr[type];
5266 gwop->op_first = listkids(o);
5267 gwop->op_flags |= OPf_KIDS;
5268 gwop->op_private = 1;
5269 gwop->op_other = LINKLIST(kid);
5270 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5271 kid->op_next = (OP*)gwop;
5273 kid = cLISTOPo->op_first->op_sibling;
5274 if (!kid || !kid->op_sibling)
5275 return too_few_arguments(o,OP_DESC(o));
5276 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5277 mod(kid, OP_GREPSTART);
5283 Perl_ck_index(pTHX_ OP *o)
5285 if (o->op_flags & OPf_KIDS) {
5286 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5288 kid = kid->op_sibling; /* get past "big" */
5289 if (kid && kid->op_type == OP_CONST)
5290 fbm_compile(((SVOP*)kid)->op_sv, 0);
5296 Perl_ck_lengthconst(pTHX_ OP *o)
5298 /* XXX length optimization goes here */
5303 Perl_ck_lfun(pTHX_ OP *o)
5305 OPCODE type = o->op_type;
5306 return modkids(ck_fun(o), type);
5310 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5312 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5313 switch (cUNOPo->op_first->op_type) {
5315 /* This is needed for
5316 if (defined %stash::)
5317 to work. Do not break Tk.
5319 break; /* Globals via GV can be undef */
5321 case OP_AASSIGN: /* Is this a good idea? */
5322 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5323 "defined(@array) is deprecated");
5324 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5325 "\t(Maybe you should just omit the defined()?)\n");
5328 /* This is needed for
5329 if (defined %stash::)
5330 to work. Do not break Tk.
5332 break; /* Globals via GV can be undef */
5334 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5335 "defined(%%hash) is deprecated");
5336 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5337 "\t(Maybe you should just omit the defined()?)\n");
5348 Perl_ck_rfun(pTHX_ OP *o)
5350 OPCODE type = o->op_type;
5351 return refkids(ck_fun(o), type);
5355 Perl_ck_listiob(pTHX_ OP *o)
5359 kid = cLISTOPo->op_first;
5362 kid = cLISTOPo->op_first;
5364 if (kid->op_type == OP_PUSHMARK)
5365 kid = kid->op_sibling;
5366 if (kid && o->op_flags & OPf_STACKED)
5367 kid = kid->op_sibling;
5368 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5369 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5370 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5371 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5372 cLISTOPo->op_first->op_sibling = kid;
5373 cLISTOPo->op_last = kid;
5374 kid = kid->op_sibling;
5379 append_elem(o->op_type, o, newDEFSVOP());
5385 Perl_ck_sassign(pTHX_ OP *o)
5387 OP *kid = cLISTOPo->op_first;
5388 /* has a disposable target? */
5389 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5390 && !(kid->op_flags & OPf_STACKED)
5391 /* Cannot steal the second time! */
5392 && !(kid->op_private & OPpTARGET_MY))
5394 OP *kkid = kid->op_sibling;
5396 /* Can just relocate the target. */
5397 if (kkid && kkid->op_type == OP_PADSV
5398 && !(kkid->op_private & OPpLVAL_INTRO))
5400 kid->op_targ = kkid->op_targ;
5402 /* Now we do not need PADSV and SASSIGN. */
5403 kid->op_sibling = o->op_sibling; /* NULL */
5404 cLISTOPo->op_first = NULL;
5407 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
5415 Perl_ck_match(pTHX_ OP *o)
5417 o->op_private |= OPpRUNTIME;
5422 Perl_ck_method(pTHX_ OP *o)
5424 OP *kid = cUNOPo->op_first;
5425 if (kid->op_type == OP_CONST) {
5426 SV* sv = kSVOP->op_sv;
5427 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
5429 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5430 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
5433 kSVOP->op_sv = Nullsv;
5435 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5444 Perl_ck_null(pTHX_ OP *o)
5450 Perl_ck_open(pTHX_ OP *o)
5452 HV *table = GvHV(PL_hintgv);
5456 svp = hv_fetch(table, "open_IN", 7, FALSE);
5458 mode = mode_from_discipline(*svp);
5459 if (mode & O_BINARY)
5460 o->op_private |= OPpOPEN_IN_RAW;
5461 else if (mode & O_TEXT)
5462 o->op_private |= OPpOPEN_IN_CRLF;
5465 svp = hv_fetch(table, "open_OUT", 8, FALSE);
5467 mode = mode_from_discipline(*svp);
5468 if (mode & O_BINARY)
5469 o->op_private |= OPpOPEN_OUT_RAW;
5470 else if (mode & O_TEXT)
5471 o->op_private |= OPpOPEN_OUT_CRLF;
5474 if (o->op_type == OP_BACKTICK)
5480 Perl_ck_repeat(pTHX_ OP *o)
5482 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5483 o->op_private |= OPpREPEAT_DOLIST;
5484 cBINOPo->op_first = force_list(cBINOPo->op_first);
5492 Perl_ck_require(pTHX_ OP *o)
5496 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
5497 SVOP *kid = (SVOP*)cUNOPo->op_first;
5499 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5501 for (s = SvPVX(kid->op_sv); *s; s++) {
5502 if (*s == ':' && s[1] == ':') {
5504 Move(s+2, s+1, strlen(s+2)+1, char);
5505 --SvCUR(kid->op_sv);
5508 if (SvREADONLY(kid->op_sv)) {
5509 SvREADONLY_off(kid->op_sv);
5510 sv_catpvn(kid->op_sv, ".pm", 3);
5511 SvREADONLY_on(kid->op_sv);
5514 sv_catpvn(kid->op_sv, ".pm", 3);
5518 /* handle override, if any */
5519 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
5520 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
5521 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
5523 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5524 OP *kid = cUNOPo->op_first;
5525 cUNOPo->op_first = 0;
5527 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5528 append_elem(OP_LIST, kid,
5529 scalar(newUNOP(OP_RV2CV, 0,
5538 Perl_ck_return(pTHX_ OP *o)
5541 if (CvLVALUE(PL_compcv)) {
5542 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5543 mod(kid, OP_LEAVESUBLV);
5550 Perl_ck_retarget(pTHX_ OP *o)
5552 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5559 Perl_ck_select(pTHX_ OP *o)
5562 if (o->op_flags & OPf_KIDS) {
5563 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5564 if (kid && kid->op_sibling) {
5565 o->op_type = OP_SSELECT;
5566 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
5568 return fold_constants(o);
5572 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5573 if (kid && kid->op_type == OP_RV2GV)
5574 kid->op_private &= ~HINT_STRICT_REFS;
5579 Perl_ck_shift(pTHX_ OP *o)
5581 I32 type = o->op_type;
5583 if (!(o->op_flags & OPf_KIDS)) {
5587 argop = newUNOP(OP_RV2AV, 0,
5588 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
5589 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
5590 return newUNOP(type, 0, scalar(argop));
5592 return scalar(modkids(ck_fun(o), type));
5596 Perl_ck_sort(pTHX_ OP *o)
5600 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
5602 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5603 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
5605 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
5607 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
5609 if (kid->op_type == OP_SCOPE) {
5613 else if (kid->op_type == OP_LEAVE) {
5614 if (o->op_type == OP_SORT) {
5615 op_null(kid); /* wipe out leave */
5618 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
5619 if (k->op_next == kid)
5621 /* don't descend into loops */
5622 else if (k->op_type == OP_ENTERLOOP
5623 || k->op_type == OP_ENTERITER)
5625 k = cLOOPx(k)->op_lastop;
5630 kid->op_next = 0; /* just disconnect the leave */
5631 k = kLISTOP->op_first;
5636 if (o->op_type == OP_SORT) {
5637 /* provide scalar context for comparison function/block */
5643 o->op_flags |= OPf_SPECIAL;
5645 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
5648 firstkid = firstkid->op_sibling;
5651 /* provide list context for arguments */
5652 if (o->op_type == OP_SORT)
5659 S_simplify_sort(pTHX_ OP *o)
5661 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5665 if (!(o->op_flags & OPf_STACKED))
5667 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
5668 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
5669 kid = kUNOP->op_first; /* get past null */
5670 if (kid->op_type != OP_SCOPE)
5672 kid = kLISTOP->op_last; /* get past scope */
5673 switch(kid->op_type) {
5681 k = kid; /* remember this node*/
5682 if (kBINOP->op_first->op_type != OP_RV2SV)
5684 kid = kBINOP->op_first; /* get past cmp */
5685 if (kUNOP->op_first->op_type != OP_GV)
5687 kid = kUNOP->op_first; /* get past rv2sv */
5689 if (GvSTASH(gv) != PL_curstash)
5691 if (strEQ(GvNAME(gv), "a"))
5693 else if (strEQ(GvNAME(gv), "b"))
5697 kid = k; /* back to cmp */
5698 if (kBINOP->op_last->op_type != OP_RV2SV)
5700 kid = kBINOP->op_last; /* down to 2nd arg */
5701 if (kUNOP->op_first->op_type != OP_GV)
5703 kid = kUNOP->op_first; /* get past rv2sv */
5705 if (GvSTASH(gv) != PL_curstash
5707 ? strNE(GvNAME(gv), "a")
5708 : strNE(GvNAME(gv), "b")))
5710 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
5712 o->op_private |= OPpSORT_REVERSE;
5713 if (k->op_type == OP_NCMP)
5714 o->op_private |= OPpSORT_NUMERIC;
5715 if (k->op_type == OP_I_NCMP)
5716 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
5717 kid = cLISTOPo->op_first->op_sibling;
5718 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
5719 op_free(kid); /* then delete it */
5723 Perl_ck_split(pTHX_ OP *o)
5727 if (o->op_flags & OPf_STACKED)
5728 return no_fh_allowed(o);
5730 kid = cLISTOPo->op_first;
5731 if (kid->op_type != OP_NULL)
5732 Perl_croak(aTHX_ "panic: ck_split");
5733 kid = kid->op_sibling;
5734 op_free(cLISTOPo->op_first);
5735 cLISTOPo->op_first = kid;
5737 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
5738 cLISTOPo->op_last = kid; /* There was only one element previously */
5741 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
5742 OP *sibl = kid->op_sibling;
5743 kid->op_sibling = 0;
5744 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
5745 if (cLISTOPo->op_first == cLISTOPo->op_last)
5746 cLISTOPo->op_last = kid;
5747 cLISTOPo->op_first = kid;
5748 kid->op_sibling = sibl;
5751 kid->op_type = OP_PUSHRE;
5752 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
5754 if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
5755 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
5756 "Use of /g modifier is meaningless in split");
5759 if (!kid->op_sibling)
5760 append_elem(OP_SPLIT, o, newDEFSVOP());
5762 kid = kid->op_sibling;
5765 if (!kid->op_sibling)
5766 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
5768 kid = kid->op_sibling;
5771 if (kid->op_sibling)
5772 return too_many_arguments(o,OP_DESC(o));
5778 Perl_ck_join(pTHX_ OP *o)
5780 if (ckWARN(WARN_SYNTAX)) {
5781 OP *kid = cLISTOPo->op_first->op_sibling;
5782 if (kid && kid->op_type == OP_MATCH) {
5783 char *pmstr = "STRING";
5784 if (PM_GETRE(kPMOP))
5785 pmstr = PM_GETRE(kPMOP)->precomp;
5786 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5787 "/%s/ should probably be written as \"%s\"",
5795 Perl_ck_subr(pTHX_ OP *o)
5797 OP *prev = ((cUNOPo->op_first->op_sibling)
5798 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
5799 OP *o2 = prev->op_sibling;
5806 I32 contextclass = 0;
5810 o->op_private |= OPpENTERSUB_HASTARG;
5811 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
5812 if (cvop->op_type == OP_RV2CV) {
5814 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
5815 op_null(cvop); /* disable rv2cv */
5816 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
5817 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
5818 GV *gv = cGVOPx_gv(tmpop);
5821 tmpop->op_private |= OPpEARLY_CV;
5822 else if (SvPOK(cv)) {
5823 namegv = CvANON(cv) ? gv : CvGV(cv);
5824 proto = SvPV((SV*)cv, n_a);
5828 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
5829 if (o2->op_type == OP_CONST)
5830 o2->op_private &= ~OPpCONST_STRICT;
5831 else if (o2->op_type == OP_LIST) {
5832 OP *o = ((UNOP*)o2)->op_first->op_sibling;
5833 if (o && o->op_type == OP_CONST)
5834 o->op_private &= ~OPpCONST_STRICT;
5837 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5838 if (PERLDB_SUB && PL_curstash != PL_debstash)
5839 o->op_private |= OPpENTERSUB_DB;
5840 while (o2 != cvop) {
5844 return too_many_arguments(o, gv_ename(namegv));
5862 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
5864 arg == 1 ? "block or sub {}" : "sub {}",
5865 gv_ename(namegv), o2);
5868 /* '*' allows any scalar type, including bareword */
5871 if (o2->op_type == OP_RV2GV)
5872 goto wrapref; /* autoconvert GLOB -> GLOBref */
5873 else if (o2->op_type == OP_CONST)
5874 o2->op_private &= ~OPpCONST_STRICT;
5875 else if (o2->op_type == OP_ENTERSUB) {
5876 /* accidental subroutine, revert to bareword */
5877 OP *gvop = ((UNOP*)o2)->op_first;
5878 if (gvop && gvop->op_type == OP_NULL) {
5879 gvop = ((UNOP*)gvop)->op_first;
5881 for (; gvop->op_sibling; gvop = gvop->op_sibling)
5884 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
5885 (gvop = ((UNOP*)gvop)->op_first) &&
5886 gvop->op_type == OP_GV)
5888 GV *gv = cGVOPx_gv(gvop);
5889 OP *sibling = o2->op_sibling;
5890 SV *n = newSVpvn("",0);
5892 gv_fullname3(n, gv, "");
5893 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
5894 sv_chop(n, SvPVX(n)+6);
5895 o2 = newSVOP(OP_CONST, 0, n);
5896 prev->op_sibling = o2;
5897 o2->op_sibling = sibling;
5913 if (contextclass++ == 0) {
5914 e = strchr(proto, ']');
5915 if (!e || e == proto)
5928 while (*--p != '[');
5929 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
5930 gv_ename(namegv), o2);
5936 if (o2->op_type == OP_RV2GV)
5939 bad_type(arg, "symbol", gv_ename(namegv), o2);
5942 if (o2->op_type == OP_ENTERSUB)
5945 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
5948 if (o2->op_type == OP_RV2SV ||
5949 o2->op_type == OP_PADSV ||
5950 o2->op_type == OP_HELEM ||
5951 o2->op_type == OP_AELEM ||
5952 o2->op_type == OP_THREADSV)
5955 bad_type(arg, "scalar", gv_ename(namegv), o2);
5958 if (o2->op_type == OP_RV2AV ||
5959 o2->op_type == OP_PADAV)
5962 bad_type(arg, "array", gv_ename(namegv), o2);
5965 if (o2->op_type == OP_RV2HV ||
5966 o2->op_type == OP_PADHV)
5969 bad_type(arg, "hash", gv_ename(namegv), o2);
5974 OP* sib = kid->op_sibling;
5975 kid->op_sibling = 0;
5976 o2 = newUNOP(OP_REFGEN, 0, kid);
5977 o2->op_sibling = sib;
5978 prev->op_sibling = o2;
5980 if (contextclass && e) {
5995 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
5996 gv_ename(namegv), SvPV((SV*)cv, n_a));
6001 mod(o2, OP_ENTERSUB);
6003 o2 = o2->op_sibling;
6005 if (proto && !optional &&
6006 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6007 return too_few_arguments(o, gv_ename(namegv));
6012 Perl_ck_svconst(pTHX_ OP *o)
6014 SvREADONLY_on(cSVOPo->op_sv);
6019 Perl_ck_trunc(pTHX_ OP *o)
6021 if (o->op_flags & OPf_KIDS) {
6022 SVOP *kid = (SVOP*)cUNOPo->op_first;
6024 if (kid->op_type == OP_NULL)
6025 kid = (SVOP*)kid->op_sibling;
6026 if (kid && kid->op_type == OP_CONST &&
6027 (kid->op_private & OPpCONST_BARE))
6029 o->op_flags |= OPf_SPECIAL;
6030 kid->op_private &= ~OPpCONST_STRICT;
6037 Perl_ck_substr(pTHX_ OP *o)
6040 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6041 OP *kid = cLISTOPo->op_first;
6043 if (kid->op_type == OP_NULL)
6044 kid = kid->op_sibling;
6046 kid->op_flags |= OPf_MOD;
6052 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6055 Perl_peep(pTHX_ register OP *o)
6057 register OP* oldop = 0;
6059 if (!o || o->op_seq)
6063 SAVEVPTR(PL_curcop);
6064 for (; o; o = o->op_next) {
6070 switch (o->op_type) {
6074 PL_curcop = ((COP*)o); /* for warnings */
6075 o->op_seq = PL_op_seqmax++;
6079 if (cSVOPo->op_private & OPpCONST_STRICT)
6080 no_bareword_allowed(o);
6082 /* Relocate sv to the pad for thread safety.
6083 * Despite being a "constant", the SV is written to,
6084 * for reference counts, sv_upgrade() etc. */
6086 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6087 if (SvPADTMP(cSVOPo->op_sv)) {
6088 /* If op_sv is already a PADTMP then it is being used by
6089 * some pad, so make a copy. */
6090 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6091 SvREADONLY_on(PAD_SVl(ix));
6092 SvREFCNT_dec(cSVOPo->op_sv);
6095 SvREFCNT_dec(PAD_SVl(ix));
6096 SvPADTMP_on(cSVOPo->op_sv);
6097 PAD_SETSV(ix, cSVOPo->op_sv);
6098 /* XXX I don't know how this isn't readonly already. */
6099 SvREADONLY_on(PAD_SVl(ix));
6101 cSVOPo->op_sv = Nullsv;
6105 o->op_seq = PL_op_seqmax++;
6109 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6110 if (o->op_next->op_private & OPpTARGET_MY) {
6111 if (o->op_flags & OPf_STACKED) /* chained concats */
6112 goto ignore_optimization;
6114 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6115 o->op_targ = o->op_next->op_targ;
6116 o->op_next->op_targ = 0;
6117 o->op_private |= OPpTARGET_MY;
6120 op_null(o->op_next);
6122 ignore_optimization:
6123 o->op_seq = PL_op_seqmax++;
6126 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6127 o->op_seq = PL_op_seqmax++;
6128 break; /* Scalar stub must produce undef. List stub is noop */
6132 if (o->op_targ == OP_NEXTSTATE
6133 || o->op_targ == OP_DBSTATE
6134 || o->op_targ == OP_SETSTATE)
6136 PL_curcop = ((COP*)o);
6138 /* XXX: We avoid setting op_seq here to prevent later calls
6139 to peep() from mistakenly concluding that optimisation
6140 has already occurred. This doesn't fix the real problem,
6141 though (See 20010220.007). AMS 20010719 */
6142 if (oldop && o->op_next) {
6143 oldop->op_next = o->op_next;
6151 if (oldop && o->op_next) {
6152 oldop->op_next = o->op_next;
6155 o->op_seq = PL_op_seqmax++;
6159 if (o->op_next->op_type == OP_RV2SV) {
6160 if (!(o->op_next->op_private & OPpDEREF)) {
6161 op_null(o->op_next);
6162 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6164 o->op_next = o->op_next->op_next;
6165 o->op_type = OP_GVSV;
6166 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6169 else if (o->op_next->op_type == OP_RV2AV) {
6170 OP* pop = o->op_next->op_next;
6172 if (pop && pop->op_type == OP_CONST &&
6173 (PL_op = pop->op_next) &&
6174 pop->op_next->op_type == OP_AELEM &&
6175 !(pop->op_next->op_private &
6176 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6177 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6182 op_null(o->op_next);
6183 op_null(pop->op_next);
6185 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6186 o->op_next = pop->op_next->op_next;
6187 o->op_type = OP_AELEMFAST;
6188 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6189 o->op_private = (U8)i;
6194 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6196 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6197 /* XXX could check prototype here instead of just carping */
6198 SV *sv = sv_newmortal();
6199 gv_efullname3(sv, gv, Nullch);
6200 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6201 "%s() called too early to check prototype",
6205 else if (o->op_next->op_type == OP_READLINE
6206 && o->op_next->op_next->op_type == OP_CONCAT
6207 && (o->op_next->op_next->op_flags & OPf_STACKED))
6209 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6210 o->op_type = OP_RCATLINE;
6211 o->op_flags |= OPf_STACKED;
6212 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6213 op_null(o->op_next->op_next);
6214 op_null(o->op_next);
6217 o->op_seq = PL_op_seqmax++;
6230 o->op_seq = PL_op_seqmax++;
6231 while (cLOGOP->op_other->op_type == OP_NULL)
6232 cLOGOP->op_other = cLOGOP->op_other->op_next;
6233 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6238 o->op_seq = PL_op_seqmax++;
6239 while (cLOOP->op_redoop->op_type == OP_NULL)
6240 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6241 peep(cLOOP->op_redoop);
6242 while (cLOOP->op_nextop->op_type == OP_NULL)
6243 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6244 peep(cLOOP->op_nextop);
6245 while (cLOOP->op_lastop->op_type == OP_NULL)
6246 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6247 peep(cLOOP->op_lastop);
6253 o->op_seq = PL_op_seqmax++;
6254 while (cPMOP->op_pmreplstart &&
6255 cPMOP->op_pmreplstart->op_type == OP_NULL)
6256 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6257 peep(cPMOP->op_pmreplstart);
6261 o->op_seq = PL_op_seqmax++;
6262 if (ckWARN(WARN_SYNTAX) && o->op_next
6263 && o->op_next->op_type == OP_NEXTSTATE) {
6264 if (o->op_next->op_sibling &&
6265 o->op_next->op_sibling->op_type != OP_EXIT &&
6266 o->op_next->op_sibling->op_type != OP_WARN &&
6267 o->op_next->op_sibling->op_type != OP_DIE) {
6268 line_t oldline = CopLINE(PL_curcop);
6270 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6271 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6272 "Statement unlikely to be reached");
6273 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6274 "\t(Maybe you meant system() when you said exec()?)\n");
6275 CopLINE_set(PL_curcop, oldline);
6286 o->op_seq = PL_op_seqmax++;
6288 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6291 /* Make the CONST have a shared SV */
6292 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6293 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6294 key = SvPV(sv, keylen);
6295 lexname = newSVpvn_share(key,
6296 SvUTF8(sv) ? -(I32)keylen : keylen,
6305 o->op_seq = PL_op_seqmax++;
6315 char* Perl_custom_op_name(pTHX_ OP* o)
6317 IV index = PTR2IV(o->op_ppaddr);
6321 if (!PL_custom_op_names) /* This probably shouldn't happen */
6322 return PL_op_name[OP_CUSTOM];
6324 keysv = sv_2mortal(newSViv(index));
6326 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
6328 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
6330 return SvPV_nolen(HeVAL(he));
6333 char* Perl_custom_op_desc(pTHX_ OP* o)
6335 IV index = PTR2IV(o->op_ppaddr);
6339 if (!PL_custom_op_descs)
6340 return PL_op_desc[OP_CUSTOM];
6342 keysv = sv_2mortal(newSViv(index));
6344 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
6346 return PL_op_desc[OP_CUSTOM];
6348 return SvPV_nolen(HeVAL(he));
6354 /* Efficient sub that returns a constant scalar value. */
6356 const_sv_xsub(pTHX_ CV* cv)
6361 Perl_croak(aTHX_ "usage: %s::%s()",
6362 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
6366 ST(0) = (SV*)XSANY.any_ptr;