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)
3760 CV *freecv = Nullcv;
3763 if (CvFILE(cv) && !CvXSUB(cv)) {
3764 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
3765 Safefree(CvFILE(cv));
3770 if (!CvXSUB(cv) && CvROOT(cv)) {
3772 Perl_croak(aTHX_ "Can't undef active subroutine");
3775 PAD_SAVE_SETNULLPAD();
3777 op_free(CvROOT(cv));
3778 CvROOT(cv) = Nullop;
3781 SvPOK_off((SV*)cv); /* forget prototype */
3783 outsidecv = CvOUTSIDE(cv);
3784 /* Since closure prototypes have the same lifetime as the containing
3785 * CV, they don't hold a refcount on the outside CV. This avoids
3786 * the refcount loop between the outer CV (which keeps a refcount to
3787 * the closure prototype in the pad entry for pp_anoncode()) and the
3788 * closure prototype, and the ensuing memory leak. --GSAR */
3789 if (!CvANON(cv) || CvCLONED(cv))
3791 CvOUTSIDE(cv) = Nullcv;
3793 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
3796 pad_undef(cv, outsidecv);
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);
4090 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4091 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4092 CvOUTSIDE(PL_compcv) = 0;
4093 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4094 CvPADLIST(PL_compcv) = 0;
4095 /* inner references to PL_compcv must be fixed up ... */
4096 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4097 /* ... before we throw it away */
4098 SvREFCNT_dec(PL_compcv);
4099 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4100 ++PL_sub_generation;
4107 PL_sub_generation++;
4111 CvFILE_set_from_cop(cv, PL_curcop);
4112 CvSTASH(cv) = PL_curstash;
4115 sv_setpv((SV*)cv, ps);
4117 if (PL_error_count) {
4121 char *s = strrchr(name, ':');
4123 if (strEQ(s, "BEGIN")) {
4125 "BEGIN not safe after errors--compilation aborted";
4126 if (PL_in_eval & EVAL_KEEPERR)
4127 Perl_croak(aTHX_ not_safe);
4129 /* force display of errors found but not reported */
4130 sv_catpv(ERRSV, not_safe);
4131 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4140 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4141 mod(scalarseq(block), OP_LEAVESUBLV));
4144 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4146 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4147 OpREFCNT_set(CvROOT(cv), 1);
4148 CvSTART(cv) = LINKLIST(CvROOT(cv));
4149 CvROOT(cv)->op_next = 0;
4150 CALL_PEEP(CvSTART(cv));
4152 /* now that optimizer has done its work, adjust pad values */
4154 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4157 assert(!CvCONST(cv));
4158 if (ps && !*ps && op_const_sv(block, cv))
4162 /* If a potential closure prototype, don't keep a refcount on outer CV.
4163 * This is okay as the lifetime of the prototype is tied to the
4164 * lifetime of the outer CV. Avoids memory leak due to reference
4167 SvREFCNT_dec(CvOUTSIDE(cv));
4169 if (name || aname) {
4171 char *tname = (name ? name : aname);
4173 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4174 SV *sv = NEWSV(0,0);
4175 SV *tmpstr = sv_newmortal();
4176 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4180 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4182 (long)PL_subline, (long)CopLINE(PL_curcop));
4183 gv_efullname3(tmpstr, gv, Nullch);
4184 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4185 hv = GvHVn(db_postponed);
4186 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4187 && (pcv = GvCV(db_postponed)))
4193 call_sv((SV*)pcv, G_DISCARD);
4197 if ((s = strrchr(tname,':')))
4202 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4205 if (strEQ(s, "BEGIN")) {
4206 I32 oldscope = PL_scopestack_ix;
4208 SAVECOPFILE(&PL_compiling);
4209 SAVECOPLINE(&PL_compiling);
4212 PL_beginav = newAV();
4213 DEBUG_x( dump_sub(gv) );
4214 av_push(PL_beginav, (SV*)cv);
4215 GvCV(gv) = 0; /* cv has been hijacked */
4216 call_list(oldscope, PL_beginav);
4218 PL_curcop = &PL_compiling;
4219 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4222 else if (strEQ(s, "END") && !PL_error_count) {
4225 DEBUG_x( dump_sub(gv) );
4226 av_unshift(PL_endav, 1);
4227 av_store(PL_endav, 0, (SV*)cv);
4228 GvCV(gv) = 0; /* cv has been hijacked */
4230 else if (strEQ(s, "CHECK") && !PL_error_count) {
4232 PL_checkav = newAV();
4233 DEBUG_x( dump_sub(gv) );
4234 if (PL_main_start && ckWARN(WARN_VOID))
4235 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4236 av_unshift(PL_checkav, 1);
4237 av_store(PL_checkav, 0, (SV*)cv);
4238 GvCV(gv) = 0; /* cv has been hijacked */
4240 else if (strEQ(s, "INIT") && !PL_error_count) {
4242 PL_initav = newAV();
4243 DEBUG_x( dump_sub(gv) );
4244 if (PL_main_start && ckWARN(WARN_VOID))
4245 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4246 av_push(PL_initav, (SV*)cv);
4247 GvCV(gv) = 0; /* cv has been hijacked */
4252 PL_copline = NOLINE;
4257 /* XXX unsafe for threads if eval_owner isn't held */
4259 =for apidoc newCONSTSUB
4261 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4262 eligible for inlining at compile-time.
4268 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4274 SAVECOPLINE(PL_curcop);
4275 CopLINE_set(PL_curcop, PL_copline);
4278 PL_hints &= ~HINT_BLOCK_SCOPE;
4281 SAVESPTR(PL_curstash);
4282 SAVECOPSTASH(PL_curcop);
4283 PL_curstash = stash;
4284 CopSTASH_set(PL_curcop,stash);
4287 cv = newXS(name, const_sv_xsub, __FILE__);
4288 CvXSUBANY(cv).any_ptr = sv;
4290 sv_setpv((SV*)cv, ""); /* prototype is "" */
4298 =for apidoc U||newXS
4300 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4306 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
4308 GV *gv = gv_fetchpv(name ? name :
4309 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4310 GV_ADDMULTI, SVt_PVCV);
4314 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4316 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4318 /* just a cached method */
4322 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4323 /* already defined (or promised) */
4324 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4325 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4326 line_t oldline = CopLINE(PL_curcop);
4327 if (PL_copline != NOLINE)
4328 CopLINE_set(PL_curcop, PL_copline);
4329 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4330 CvCONST(cv) ? "Constant subroutine %s redefined"
4331 : "Subroutine %s redefined"
4333 CopLINE_set(PL_curcop, oldline);
4340 if (cv) /* must reuse cv if autoloaded */
4343 cv = (CV*)NEWSV(1105,0);
4344 sv_upgrade((SV *)cv, SVt_PVCV);
4348 PL_sub_generation++;
4352 (void)gv_fetchfile(filename);
4353 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
4354 an external constant string */
4355 CvXSUB(cv) = subaddr;
4358 char *s = strrchr(name,':');
4364 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4367 if (strEQ(s, "BEGIN")) {
4369 PL_beginav = newAV();
4370 av_push(PL_beginav, (SV*)cv);
4371 GvCV(gv) = 0; /* cv has been hijacked */
4373 else if (strEQ(s, "END")) {
4376 av_unshift(PL_endav, 1);
4377 av_store(PL_endav, 0, (SV*)cv);
4378 GvCV(gv) = 0; /* cv has been hijacked */
4380 else if (strEQ(s, "CHECK")) {
4382 PL_checkav = newAV();
4383 if (PL_main_start && ckWARN(WARN_VOID))
4384 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4385 av_unshift(PL_checkav, 1);
4386 av_store(PL_checkav, 0, (SV*)cv);
4387 GvCV(gv) = 0; /* cv has been hijacked */
4389 else if (strEQ(s, "INIT")) {
4391 PL_initav = newAV();
4392 if (PL_main_start && ckWARN(WARN_VOID))
4393 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4394 av_push(PL_initav, (SV*)cv);
4395 GvCV(gv) = 0; /* cv has been hijacked */
4406 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4414 name = SvPVx(cSVOPo->op_sv, n_a);
4417 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
4418 #ifdef GV_UNIQUE_CHECK
4420 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4424 if ((cv = GvFORM(gv))) {
4425 if (ckWARN(WARN_REDEFINE)) {
4426 line_t oldline = CopLINE(PL_curcop);
4427 if (PL_copline != NOLINE)
4428 CopLINE_set(PL_curcop, PL_copline);
4429 Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Format %s redefined",name);
4430 CopLINE_set(PL_curcop, oldline);
4437 CvFILE_set_from_cop(cv, PL_curcop);
4440 pad_tidy(padtidy_FORMAT);
4441 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4442 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4443 OpREFCNT_set(CvROOT(cv), 1);
4444 CvSTART(cv) = LINKLIST(CvROOT(cv));
4445 CvROOT(cv)->op_next = 0;
4446 CALL_PEEP(CvSTART(cv));
4448 PL_copline = NOLINE;
4453 Perl_newANONLIST(pTHX_ OP *o)
4455 return newUNOP(OP_REFGEN, 0,
4456 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4460 Perl_newANONHASH(pTHX_ OP *o)
4462 return newUNOP(OP_REFGEN, 0,
4463 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4467 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4469 return newANONATTRSUB(floor, proto, Nullop, block);
4473 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4475 return newUNOP(OP_REFGEN, 0,
4476 newSVOP(OP_ANONCODE, 0,
4477 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
4481 Perl_oopsAV(pTHX_ OP *o)
4483 switch (o->op_type) {
4485 o->op_type = OP_PADAV;
4486 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4487 return ref(o, OP_RV2AV);
4490 o->op_type = OP_RV2AV;
4491 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4496 if (ckWARN_d(WARN_INTERNAL))
4497 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
4504 Perl_oopsHV(pTHX_ OP *o)
4506 switch (o->op_type) {
4509 o->op_type = OP_PADHV;
4510 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4511 return ref(o, OP_RV2HV);
4515 o->op_type = OP_RV2HV;
4516 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
4521 if (ckWARN_d(WARN_INTERNAL))
4522 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
4529 Perl_newAVREF(pTHX_ OP *o)
4531 if (o->op_type == OP_PADANY) {
4532 o->op_type = OP_PADAV;
4533 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4536 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
4537 && ckWARN(WARN_DEPRECATED)) {
4538 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4539 "Using an array as a reference is deprecated");
4541 return newUNOP(OP_RV2AV, 0, scalar(o));
4545 Perl_newGVREF(pTHX_ I32 type, OP *o)
4547 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
4548 return newUNOP(OP_NULL, 0, o);
4549 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
4553 Perl_newHVREF(pTHX_ OP *o)
4555 if (o->op_type == OP_PADANY) {
4556 o->op_type = OP_PADHV;
4557 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4560 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
4561 && ckWARN(WARN_DEPRECATED)) {
4562 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4563 "Using a hash as a reference is deprecated");
4565 return newUNOP(OP_RV2HV, 0, scalar(o));
4569 Perl_oopsCV(pTHX_ OP *o)
4571 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
4577 Perl_newCVREF(pTHX_ I32 flags, OP *o)
4579 return newUNOP(OP_RV2CV, flags, scalar(o));
4583 Perl_newSVREF(pTHX_ OP *o)
4585 if (o->op_type == OP_PADANY) {
4586 o->op_type = OP_PADSV;
4587 o->op_ppaddr = PL_ppaddr[OP_PADSV];
4590 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4591 o->op_flags |= OPpDONE_SVREF;
4594 return newUNOP(OP_RV2SV, 0, scalar(o));
4597 /* Check routines. */
4600 Perl_ck_anoncode(pTHX_ OP *o)
4602 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
4603 cSVOPo->op_sv = Nullsv;
4608 Perl_ck_bitop(pTHX_ OP *o)
4610 #define OP_IS_NUMCOMPARE(op) \
4611 ((op) == OP_LT || (op) == OP_I_LT || \
4612 (op) == OP_GT || (op) == OP_I_GT || \
4613 (op) == OP_LE || (op) == OP_I_LE || \
4614 (op) == OP_GE || (op) == OP_I_GE || \
4615 (op) == OP_EQ || (op) == OP_I_EQ || \
4616 (op) == OP_NE || (op) == OP_I_NE || \
4617 (op) == OP_NCMP || (op) == OP_I_NCMP)
4618 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4619 if (o->op_type == OP_BIT_OR
4620 || o->op_type == OP_BIT_AND
4621 || o->op_type == OP_BIT_XOR)
4623 OPCODE typfirst = cBINOPo->op_first->op_type;
4624 OPCODE typlast = cBINOPo->op_first->op_sibling->op_type;
4625 if (OP_IS_NUMCOMPARE(typfirst) || OP_IS_NUMCOMPARE(typlast))
4626 if (ckWARN(WARN_PRECEDENCE))
4627 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4628 "Possible precedence problem on bitwise %c operator",
4629 o->op_type == OP_BIT_OR ? '|'
4630 : o->op_type == OP_BIT_AND ? '&' : '^'
4637 Perl_ck_concat(pTHX_ OP *o)
4639 if (cUNOPo->op_first->op_type == OP_CONCAT)
4640 o->op_flags |= OPf_STACKED;
4645 Perl_ck_spair(pTHX_ OP *o)
4647 if (o->op_flags & OPf_KIDS) {
4650 OPCODE type = o->op_type;
4651 o = modkids(ck_fun(o), type);
4652 kid = cUNOPo->op_first;
4653 newop = kUNOP->op_first->op_sibling;
4655 (newop->op_sibling ||
4656 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
4657 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
4658 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
4662 op_free(kUNOP->op_first);
4663 kUNOP->op_first = newop;
4665 o->op_ppaddr = PL_ppaddr[++o->op_type];
4670 Perl_ck_delete(pTHX_ OP *o)
4674 if (o->op_flags & OPf_KIDS) {
4675 OP *kid = cUNOPo->op_first;
4676 switch (kid->op_type) {
4678 o->op_flags |= OPf_SPECIAL;
4681 o->op_private |= OPpSLICE;
4684 o->op_flags |= OPf_SPECIAL;
4689 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
4698 Perl_ck_die(pTHX_ OP *o)
4701 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4707 Perl_ck_eof(pTHX_ OP *o)
4709 I32 type = o->op_type;
4711 if (o->op_flags & OPf_KIDS) {
4712 if (cLISTOPo->op_first->op_type == OP_STUB) {
4714 o = newUNOP(type, OPf_SPECIAL,
4715 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
4723 Perl_ck_eval(pTHX_ OP *o)
4725 PL_hints |= HINT_BLOCK_SCOPE;
4726 if (o->op_flags & OPf_KIDS) {
4727 SVOP *kid = (SVOP*)cUNOPo->op_first;
4730 o->op_flags &= ~OPf_KIDS;
4733 else if (kid->op_type == OP_LINESEQ) {
4736 kid->op_next = o->op_next;
4737 cUNOPo->op_first = 0;
4740 NewOp(1101, enter, 1, LOGOP);
4741 enter->op_type = OP_ENTERTRY;
4742 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
4743 enter->op_private = 0;
4745 /* establish postfix order */
4746 enter->op_next = (OP*)enter;
4748 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
4749 o->op_type = OP_LEAVETRY;
4750 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
4751 enter->op_other = o;
4759 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
4761 o->op_targ = (PADOFFSET)PL_hints;
4766 Perl_ck_exit(pTHX_ OP *o)
4769 HV *table = GvHV(PL_hintgv);
4771 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
4772 if (svp && *svp && SvTRUE(*svp))
4773 o->op_private |= OPpEXIT_VMSISH;
4775 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4781 Perl_ck_exec(pTHX_ OP *o)
4784 if (o->op_flags & OPf_STACKED) {
4786 kid = cUNOPo->op_first->op_sibling;
4787 if (kid->op_type == OP_RV2GV)
4796 Perl_ck_exists(pTHX_ OP *o)
4799 if (o->op_flags & OPf_KIDS) {
4800 OP *kid = cUNOPo->op_first;
4801 if (kid->op_type == OP_ENTERSUB) {
4802 (void) ref(kid, o->op_type);
4803 if (kid->op_type != OP_RV2CV && !PL_error_count)
4804 Perl_croak(aTHX_ "%s argument is not a subroutine name",
4806 o->op_private |= OPpEXISTS_SUB;
4808 else if (kid->op_type == OP_AELEM)
4809 o->op_flags |= OPf_SPECIAL;
4810 else if (kid->op_type != OP_HELEM)
4811 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
4820 Perl_ck_gvconst(pTHX_ register OP *o)
4822 o = fold_constants(o);
4823 if (o->op_type == OP_CONST)
4830 Perl_ck_rvconst(pTHX_ register OP *o)
4832 SVOP *kid = (SVOP*)cUNOPo->op_first;
4834 o->op_private |= (PL_hints & HINT_STRICT_REFS);
4835 if (kid->op_type == OP_CONST) {
4839 SV *kidsv = kid->op_sv;
4842 /* Is it a constant from cv_const_sv()? */
4843 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
4844 SV *rsv = SvRV(kidsv);
4845 int svtype = SvTYPE(rsv);
4846 char *badtype = Nullch;
4848 switch (o->op_type) {
4850 if (svtype > SVt_PVMG)
4851 badtype = "a SCALAR";
4854 if (svtype != SVt_PVAV)
4855 badtype = "an ARRAY";
4858 if (svtype != SVt_PVHV)
4862 if (svtype != SVt_PVCV)
4867 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
4870 name = SvPV(kidsv, n_a);
4871 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
4872 char *badthing = Nullch;
4873 switch (o->op_type) {
4875 badthing = "a SCALAR";
4878 badthing = "an ARRAY";
4881 badthing = "a HASH";
4886 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
4890 * This is a little tricky. We only want to add the symbol if we
4891 * didn't add it in the lexer. Otherwise we get duplicate strict
4892 * warnings. But if we didn't add it in the lexer, we must at
4893 * least pretend like we wanted to add it even if it existed before,
4894 * or we get possible typo warnings. OPpCONST_ENTERED says
4895 * whether the lexer already added THIS instance of this symbol.
4897 iscv = (o->op_type == OP_RV2CV) * 2;
4899 gv = gv_fetchpv(name,
4900 iscv | !(kid->op_private & OPpCONST_ENTERED),
4903 : o->op_type == OP_RV2SV
4905 : o->op_type == OP_RV2AV
4907 : o->op_type == OP_RV2HV
4910 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
4912 kid->op_type = OP_GV;
4913 SvREFCNT_dec(kid->op_sv);
4915 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
4916 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
4917 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
4919 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
4921 kid->op_sv = SvREFCNT_inc(gv);
4923 kid->op_private = 0;
4924 kid->op_ppaddr = PL_ppaddr[OP_GV];
4931 Perl_ck_ftst(pTHX_ OP *o)
4933 I32 type = o->op_type;
4935 if (o->op_flags & OPf_REF) {
4938 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
4939 SVOP *kid = (SVOP*)cUNOPo->op_first;
4941 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
4943 OP *newop = newGVOP(type, OPf_REF,
4944 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
4951 if (type == OP_FTTTY)
4952 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
4955 o = newUNOP(type, 0, newDEFSVOP());
4961 Perl_ck_fun(pTHX_ OP *o)
4967 int type = o->op_type;
4968 register I32 oa = PL_opargs[type] >> OASHIFT;
4970 if (o->op_flags & OPf_STACKED) {
4971 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
4974 return no_fh_allowed(o);
4977 if (o->op_flags & OPf_KIDS) {
4979 tokid = &cLISTOPo->op_first;
4980 kid = cLISTOPo->op_first;
4981 if (kid->op_type == OP_PUSHMARK ||
4982 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
4984 tokid = &kid->op_sibling;
4985 kid = kid->op_sibling;
4987 if (!kid && PL_opargs[type] & OA_DEFGV)
4988 *tokid = kid = newDEFSVOP();
4992 sibl = kid->op_sibling;
4995 /* list seen where single (scalar) arg expected? */
4996 if (numargs == 1 && !(oa >> 4)
4997 && kid->op_type == OP_LIST && type != OP_SCALAR)
4999 return too_many_arguments(o,PL_op_desc[type]);
5012 if ((type == OP_PUSH || type == OP_UNSHIFT)
5013 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5014 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5015 "Useless use of %s with no values",
5018 if (kid->op_type == OP_CONST &&
5019 (kid->op_private & OPpCONST_BARE))
5021 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5022 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5023 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5024 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5025 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5026 "Array @%s missing the @ in argument %"IVdf" of %s()",
5027 name, (IV)numargs, PL_op_desc[type]);
5030 kid->op_sibling = sibl;
5033 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5034 bad_type(numargs, "array", PL_op_desc[type], kid);
5038 if (kid->op_type == OP_CONST &&
5039 (kid->op_private & OPpCONST_BARE))
5041 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5042 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5043 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5044 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5045 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5046 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5047 name, (IV)numargs, PL_op_desc[type]);
5050 kid->op_sibling = sibl;
5053 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5054 bad_type(numargs, "hash", PL_op_desc[type], kid);
5059 OP *newop = newUNOP(OP_NULL, 0, kid);
5060 kid->op_sibling = 0;
5062 newop->op_next = newop;
5064 kid->op_sibling = sibl;
5069 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5070 if (kid->op_type == OP_CONST &&
5071 (kid->op_private & OPpCONST_BARE))
5073 OP *newop = newGVOP(OP_GV, 0,
5074 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5076 if (!(o->op_private & 1) && /* if not unop */
5077 kid == cLISTOPo->op_last)
5078 cLISTOPo->op_last = newop;
5082 else if (kid->op_type == OP_READLINE) {
5083 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5084 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5087 I32 flags = OPf_SPECIAL;
5091 /* is this op a FH constructor? */
5092 if (is_handle_constructor(o,numargs)) {
5093 char *name = Nullch;
5097 /* Set a flag to tell rv2gv to vivify
5098 * need to "prove" flag does not mean something
5099 * else already - NI-S 1999/05/07
5102 if (kid->op_type == OP_PADSV) {
5103 /*XXX DAPM 2002.08.25 tmp assert test */
5104 /*XXX*/ assert(av_fetch(PL_comppad_name, (kid->op_targ), FALSE));
5105 /*XXX*/ assert(*av_fetch(PL_comppad_name, (kid->op_targ), FALSE));
5107 name = PAD_COMPNAME_PV(kid->op_targ);
5108 /* SvCUR of a pad namesv can't be trusted
5109 * (see PL_generation), so calc its length
5115 else if (kid->op_type == OP_RV2SV
5116 && kUNOP->op_first->op_type == OP_GV)
5118 GV *gv = cGVOPx_gv(kUNOP->op_first);
5120 len = GvNAMELEN(gv);
5122 else if (kid->op_type == OP_AELEM
5123 || kid->op_type == OP_HELEM)
5125 name = "__ANONIO__";
5131 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5132 namesv = PAD_SVl(targ);
5133 (void)SvUPGRADE(namesv, SVt_PV);
5135 sv_setpvn(namesv, "$", 1);
5136 sv_catpvn(namesv, name, len);
5139 kid->op_sibling = 0;
5140 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5141 kid->op_targ = targ;
5142 kid->op_private |= priv;
5144 kid->op_sibling = sibl;
5150 mod(scalar(kid), type);
5154 tokid = &kid->op_sibling;
5155 kid = kid->op_sibling;
5157 o->op_private |= numargs;
5159 return too_many_arguments(o,OP_DESC(o));
5162 else if (PL_opargs[type] & OA_DEFGV) {
5164 return newUNOP(type, 0, newDEFSVOP());
5168 while (oa & OA_OPTIONAL)
5170 if (oa && oa != OA_LIST)
5171 return too_few_arguments(o,OP_DESC(o));
5177 Perl_ck_glob(pTHX_ OP *o)
5182 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5183 append_elem(OP_GLOB, o, newDEFSVOP());
5185 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5186 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5188 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5191 #if !defined(PERL_EXTERNAL_GLOB)
5192 /* XXX this can be tightened up and made more failsafe. */
5196 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5197 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5198 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5199 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5200 GvCV(gv) = GvCV(glob_gv);
5201 SvREFCNT_inc((SV*)GvCV(gv));
5202 GvIMPORTED_CV_on(gv);
5205 #endif /* PERL_EXTERNAL_GLOB */
5207 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5208 append_elem(OP_GLOB, o,
5209 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5210 o->op_type = OP_LIST;
5211 o->op_ppaddr = PL_ppaddr[OP_LIST];
5212 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5213 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5214 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5215 append_elem(OP_LIST, o,
5216 scalar(newUNOP(OP_RV2CV, 0,
5217 newGVOP(OP_GV, 0, gv)))));
5218 o = newUNOP(OP_NULL, 0, ck_subr(o));
5219 o->op_targ = OP_GLOB; /* hint at what it used to be */
5222 gv = newGVgen("main");
5224 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5230 Perl_ck_grep(pTHX_ OP *o)
5234 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5236 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5237 NewOp(1101, gwop, 1, LOGOP);
5239 if (o->op_flags & OPf_STACKED) {
5242 kid = cLISTOPo->op_first->op_sibling;
5243 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5246 kid->op_next = (OP*)gwop;
5247 o->op_flags &= ~OPf_STACKED;
5249 kid = cLISTOPo->op_first->op_sibling;
5250 if (type == OP_MAPWHILE)
5257 kid = cLISTOPo->op_first->op_sibling;
5258 if (kid->op_type != OP_NULL)
5259 Perl_croak(aTHX_ "panic: ck_grep");
5260 kid = kUNOP->op_first;
5262 gwop->op_type = type;
5263 gwop->op_ppaddr = PL_ppaddr[type];
5264 gwop->op_first = listkids(o);
5265 gwop->op_flags |= OPf_KIDS;
5266 gwop->op_private = 1;
5267 gwop->op_other = LINKLIST(kid);
5268 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5269 kid->op_next = (OP*)gwop;
5271 kid = cLISTOPo->op_first->op_sibling;
5272 if (!kid || !kid->op_sibling)
5273 return too_few_arguments(o,OP_DESC(o));
5274 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5275 mod(kid, OP_GREPSTART);
5281 Perl_ck_index(pTHX_ OP *o)
5283 if (o->op_flags & OPf_KIDS) {
5284 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5286 kid = kid->op_sibling; /* get past "big" */
5287 if (kid && kid->op_type == OP_CONST)
5288 fbm_compile(((SVOP*)kid)->op_sv, 0);
5294 Perl_ck_lengthconst(pTHX_ OP *o)
5296 /* XXX length optimization goes here */
5301 Perl_ck_lfun(pTHX_ OP *o)
5303 OPCODE type = o->op_type;
5304 return modkids(ck_fun(o), type);
5308 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5310 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5311 switch (cUNOPo->op_first->op_type) {
5313 /* This is needed for
5314 if (defined %stash::)
5315 to work. Do not break Tk.
5317 break; /* Globals via GV can be undef */
5319 case OP_AASSIGN: /* Is this a good idea? */
5320 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5321 "defined(@array) is deprecated");
5322 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5323 "\t(Maybe you should just omit the defined()?)\n");
5326 /* This is needed for
5327 if (defined %stash::)
5328 to work. Do not break Tk.
5330 break; /* Globals via GV can be undef */
5332 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5333 "defined(%%hash) is deprecated");
5334 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5335 "\t(Maybe you should just omit the defined()?)\n");
5346 Perl_ck_rfun(pTHX_ OP *o)
5348 OPCODE type = o->op_type;
5349 return refkids(ck_fun(o), type);
5353 Perl_ck_listiob(pTHX_ OP *o)
5357 kid = cLISTOPo->op_first;
5360 kid = cLISTOPo->op_first;
5362 if (kid->op_type == OP_PUSHMARK)
5363 kid = kid->op_sibling;
5364 if (kid && o->op_flags & OPf_STACKED)
5365 kid = kid->op_sibling;
5366 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5367 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5368 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5369 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5370 cLISTOPo->op_first->op_sibling = kid;
5371 cLISTOPo->op_last = kid;
5372 kid = kid->op_sibling;
5377 append_elem(o->op_type, o, newDEFSVOP());
5383 Perl_ck_sassign(pTHX_ OP *o)
5385 OP *kid = cLISTOPo->op_first;
5386 /* has a disposable target? */
5387 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5388 && !(kid->op_flags & OPf_STACKED)
5389 /* Cannot steal the second time! */
5390 && !(kid->op_private & OPpTARGET_MY))
5392 OP *kkid = kid->op_sibling;
5394 /* Can just relocate the target. */
5395 if (kkid && kkid->op_type == OP_PADSV
5396 && !(kkid->op_private & OPpLVAL_INTRO))
5398 kid->op_targ = kkid->op_targ;
5400 /* Now we do not need PADSV and SASSIGN. */
5401 kid->op_sibling = o->op_sibling; /* NULL */
5402 cLISTOPo->op_first = NULL;
5405 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
5413 Perl_ck_match(pTHX_ OP *o)
5415 o->op_private |= OPpRUNTIME;
5420 Perl_ck_method(pTHX_ OP *o)
5422 OP *kid = cUNOPo->op_first;
5423 if (kid->op_type == OP_CONST) {
5424 SV* sv = kSVOP->op_sv;
5425 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
5427 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5428 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
5431 kSVOP->op_sv = Nullsv;
5433 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5442 Perl_ck_null(pTHX_ OP *o)
5448 Perl_ck_open(pTHX_ OP *o)
5450 HV *table = GvHV(PL_hintgv);
5454 svp = hv_fetch(table, "open_IN", 7, FALSE);
5456 mode = mode_from_discipline(*svp);
5457 if (mode & O_BINARY)
5458 o->op_private |= OPpOPEN_IN_RAW;
5459 else if (mode & O_TEXT)
5460 o->op_private |= OPpOPEN_IN_CRLF;
5463 svp = hv_fetch(table, "open_OUT", 8, FALSE);
5465 mode = mode_from_discipline(*svp);
5466 if (mode & O_BINARY)
5467 o->op_private |= OPpOPEN_OUT_RAW;
5468 else if (mode & O_TEXT)
5469 o->op_private |= OPpOPEN_OUT_CRLF;
5472 if (o->op_type == OP_BACKTICK)
5478 Perl_ck_repeat(pTHX_ OP *o)
5480 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5481 o->op_private |= OPpREPEAT_DOLIST;
5482 cBINOPo->op_first = force_list(cBINOPo->op_first);
5490 Perl_ck_require(pTHX_ OP *o)
5494 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
5495 SVOP *kid = (SVOP*)cUNOPo->op_first;
5497 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5499 for (s = SvPVX(kid->op_sv); *s; s++) {
5500 if (*s == ':' && s[1] == ':') {
5502 Move(s+2, s+1, strlen(s+2)+1, char);
5503 --SvCUR(kid->op_sv);
5506 if (SvREADONLY(kid->op_sv)) {
5507 SvREADONLY_off(kid->op_sv);
5508 sv_catpvn(kid->op_sv, ".pm", 3);
5509 SvREADONLY_on(kid->op_sv);
5512 sv_catpvn(kid->op_sv, ".pm", 3);
5516 /* handle override, if any */
5517 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
5518 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
5519 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
5521 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5522 OP *kid = cUNOPo->op_first;
5523 cUNOPo->op_first = 0;
5525 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5526 append_elem(OP_LIST, kid,
5527 scalar(newUNOP(OP_RV2CV, 0,
5536 Perl_ck_return(pTHX_ OP *o)
5539 if (CvLVALUE(PL_compcv)) {
5540 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5541 mod(kid, OP_LEAVESUBLV);
5548 Perl_ck_retarget(pTHX_ OP *o)
5550 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5557 Perl_ck_select(pTHX_ OP *o)
5560 if (o->op_flags & OPf_KIDS) {
5561 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5562 if (kid && kid->op_sibling) {
5563 o->op_type = OP_SSELECT;
5564 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
5566 return fold_constants(o);
5570 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5571 if (kid && kid->op_type == OP_RV2GV)
5572 kid->op_private &= ~HINT_STRICT_REFS;
5577 Perl_ck_shift(pTHX_ OP *o)
5579 I32 type = o->op_type;
5581 if (!(o->op_flags & OPf_KIDS)) {
5585 argop = newUNOP(OP_RV2AV, 0,
5586 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
5587 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
5588 return newUNOP(type, 0, scalar(argop));
5590 return scalar(modkids(ck_fun(o), type));
5594 Perl_ck_sort(pTHX_ OP *o)
5598 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
5600 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5601 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
5603 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
5605 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
5607 if (kid->op_type == OP_SCOPE) {
5611 else if (kid->op_type == OP_LEAVE) {
5612 if (o->op_type == OP_SORT) {
5613 op_null(kid); /* wipe out leave */
5616 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
5617 if (k->op_next == kid)
5619 /* don't descend into loops */
5620 else if (k->op_type == OP_ENTERLOOP
5621 || k->op_type == OP_ENTERITER)
5623 k = cLOOPx(k)->op_lastop;
5628 kid->op_next = 0; /* just disconnect the leave */
5629 k = kLISTOP->op_first;
5634 if (o->op_type == OP_SORT) {
5635 /* provide scalar context for comparison function/block */
5641 o->op_flags |= OPf_SPECIAL;
5643 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
5646 firstkid = firstkid->op_sibling;
5649 /* provide list context for arguments */
5650 if (o->op_type == OP_SORT)
5657 S_simplify_sort(pTHX_ OP *o)
5659 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5663 if (!(o->op_flags & OPf_STACKED))
5665 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
5666 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
5667 kid = kUNOP->op_first; /* get past null */
5668 if (kid->op_type != OP_SCOPE)
5670 kid = kLISTOP->op_last; /* get past scope */
5671 switch(kid->op_type) {
5679 k = kid; /* remember this node*/
5680 if (kBINOP->op_first->op_type != OP_RV2SV)
5682 kid = kBINOP->op_first; /* get past cmp */
5683 if (kUNOP->op_first->op_type != OP_GV)
5685 kid = kUNOP->op_first; /* get past rv2sv */
5687 if (GvSTASH(gv) != PL_curstash)
5689 if (strEQ(GvNAME(gv), "a"))
5691 else if (strEQ(GvNAME(gv), "b"))
5695 kid = k; /* back to cmp */
5696 if (kBINOP->op_last->op_type != OP_RV2SV)
5698 kid = kBINOP->op_last; /* down to 2nd arg */
5699 if (kUNOP->op_first->op_type != OP_GV)
5701 kid = kUNOP->op_first; /* get past rv2sv */
5703 if (GvSTASH(gv) != PL_curstash
5705 ? strNE(GvNAME(gv), "a")
5706 : strNE(GvNAME(gv), "b")))
5708 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
5710 o->op_private |= OPpSORT_REVERSE;
5711 if (k->op_type == OP_NCMP)
5712 o->op_private |= OPpSORT_NUMERIC;
5713 if (k->op_type == OP_I_NCMP)
5714 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
5715 kid = cLISTOPo->op_first->op_sibling;
5716 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
5717 op_free(kid); /* then delete it */
5721 Perl_ck_split(pTHX_ OP *o)
5725 if (o->op_flags & OPf_STACKED)
5726 return no_fh_allowed(o);
5728 kid = cLISTOPo->op_first;
5729 if (kid->op_type != OP_NULL)
5730 Perl_croak(aTHX_ "panic: ck_split");
5731 kid = kid->op_sibling;
5732 op_free(cLISTOPo->op_first);
5733 cLISTOPo->op_first = kid;
5735 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
5736 cLISTOPo->op_last = kid; /* There was only one element previously */
5739 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
5740 OP *sibl = kid->op_sibling;
5741 kid->op_sibling = 0;
5742 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
5743 if (cLISTOPo->op_first == cLISTOPo->op_last)
5744 cLISTOPo->op_last = kid;
5745 cLISTOPo->op_first = kid;
5746 kid->op_sibling = sibl;
5749 kid->op_type = OP_PUSHRE;
5750 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
5752 if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
5753 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
5754 "Use of /g modifier is meaningless in split");
5757 if (!kid->op_sibling)
5758 append_elem(OP_SPLIT, o, newDEFSVOP());
5760 kid = kid->op_sibling;
5763 if (!kid->op_sibling)
5764 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
5766 kid = kid->op_sibling;
5769 if (kid->op_sibling)
5770 return too_many_arguments(o,OP_DESC(o));
5776 Perl_ck_join(pTHX_ OP *o)
5778 if (ckWARN(WARN_SYNTAX)) {
5779 OP *kid = cLISTOPo->op_first->op_sibling;
5780 if (kid && kid->op_type == OP_MATCH) {
5781 char *pmstr = "STRING";
5782 if (PM_GETRE(kPMOP))
5783 pmstr = PM_GETRE(kPMOP)->precomp;
5784 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5785 "/%s/ should probably be written as \"%s\"",
5793 Perl_ck_subr(pTHX_ OP *o)
5795 OP *prev = ((cUNOPo->op_first->op_sibling)
5796 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
5797 OP *o2 = prev->op_sibling;
5804 I32 contextclass = 0;
5808 o->op_private |= OPpENTERSUB_HASTARG;
5809 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
5810 if (cvop->op_type == OP_RV2CV) {
5812 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
5813 op_null(cvop); /* disable rv2cv */
5814 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
5815 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
5816 GV *gv = cGVOPx_gv(tmpop);
5819 tmpop->op_private |= OPpEARLY_CV;
5820 else if (SvPOK(cv)) {
5821 namegv = CvANON(cv) ? gv : CvGV(cv);
5822 proto = SvPV((SV*)cv, n_a);
5826 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
5827 if (o2->op_type == OP_CONST)
5828 o2->op_private &= ~OPpCONST_STRICT;
5829 else if (o2->op_type == OP_LIST) {
5830 OP *o = ((UNOP*)o2)->op_first->op_sibling;
5831 if (o && o->op_type == OP_CONST)
5832 o->op_private &= ~OPpCONST_STRICT;
5835 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5836 if (PERLDB_SUB && PL_curstash != PL_debstash)
5837 o->op_private |= OPpENTERSUB_DB;
5838 while (o2 != cvop) {
5842 return too_many_arguments(o, gv_ename(namegv));
5860 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
5862 arg == 1 ? "block or sub {}" : "sub {}",
5863 gv_ename(namegv), o2);
5866 /* '*' allows any scalar type, including bareword */
5869 if (o2->op_type == OP_RV2GV)
5870 goto wrapref; /* autoconvert GLOB -> GLOBref */
5871 else if (o2->op_type == OP_CONST)
5872 o2->op_private &= ~OPpCONST_STRICT;
5873 else if (o2->op_type == OP_ENTERSUB) {
5874 /* accidental subroutine, revert to bareword */
5875 OP *gvop = ((UNOP*)o2)->op_first;
5876 if (gvop && gvop->op_type == OP_NULL) {
5877 gvop = ((UNOP*)gvop)->op_first;
5879 for (; gvop->op_sibling; gvop = gvop->op_sibling)
5882 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
5883 (gvop = ((UNOP*)gvop)->op_first) &&
5884 gvop->op_type == OP_GV)
5886 GV *gv = cGVOPx_gv(gvop);
5887 OP *sibling = o2->op_sibling;
5888 SV *n = newSVpvn("",0);
5890 gv_fullname3(n, gv, "");
5891 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
5892 sv_chop(n, SvPVX(n)+6);
5893 o2 = newSVOP(OP_CONST, 0, n);
5894 prev->op_sibling = o2;
5895 o2->op_sibling = sibling;
5911 if (contextclass++ == 0) {
5912 e = strchr(proto, ']');
5913 if (!e || e == proto)
5926 while (*--p != '[');
5927 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
5928 gv_ename(namegv), o2);
5934 if (o2->op_type == OP_RV2GV)
5937 bad_type(arg, "symbol", gv_ename(namegv), o2);
5940 if (o2->op_type == OP_ENTERSUB)
5943 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
5946 if (o2->op_type == OP_RV2SV ||
5947 o2->op_type == OP_PADSV ||
5948 o2->op_type == OP_HELEM ||
5949 o2->op_type == OP_AELEM ||
5950 o2->op_type == OP_THREADSV)
5953 bad_type(arg, "scalar", gv_ename(namegv), o2);
5956 if (o2->op_type == OP_RV2AV ||
5957 o2->op_type == OP_PADAV)
5960 bad_type(arg, "array", gv_ename(namegv), o2);
5963 if (o2->op_type == OP_RV2HV ||
5964 o2->op_type == OP_PADHV)
5967 bad_type(arg, "hash", gv_ename(namegv), o2);
5972 OP* sib = kid->op_sibling;
5973 kid->op_sibling = 0;
5974 o2 = newUNOP(OP_REFGEN, 0, kid);
5975 o2->op_sibling = sib;
5976 prev->op_sibling = o2;
5978 if (contextclass && e) {
5993 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
5994 gv_ename(namegv), SvPV((SV*)cv, n_a));
5999 mod(o2, OP_ENTERSUB);
6001 o2 = o2->op_sibling;
6003 if (proto && !optional &&
6004 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6005 return too_few_arguments(o, gv_ename(namegv));
6010 Perl_ck_svconst(pTHX_ OP *o)
6012 SvREADONLY_on(cSVOPo->op_sv);
6017 Perl_ck_trunc(pTHX_ OP *o)
6019 if (o->op_flags & OPf_KIDS) {
6020 SVOP *kid = (SVOP*)cUNOPo->op_first;
6022 if (kid->op_type == OP_NULL)
6023 kid = (SVOP*)kid->op_sibling;
6024 if (kid && kid->op_type == OP_CONST &&
6025 (kid->op_private & OPpCONST_BARE))
6027 o->op_flags |= OPf_SPECIAL;
6028 kid->op_private &= ~OPpCONST_STRICT;
6035 Perl_ck_substr(pTHX_ OP *o)
6038 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6039 OP *kid = cLISTOPo->op_first;
6041 if (kid->op_type == OP_NULL)
6042 kid = kid->op_sibling;
6044 kid->op_flags |= OPf_MOD;
6050 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6053 Perl_peep(pTHX_ register OP *o)
6055 register OP* oldop = 0;
6057 if (!o || o->op_seq)
6061 SAVEVPTR(PL_curcop);
6062 for (; o; o = o->op_next) {
6068 switch (o->op_type) {
6072 PL_curcop = ((COP*)o); /* for warnings */
6073 o->op_seq = PL_op_seqmax++;
6077 if (cSVOPo->op_private & OPpCONST_STRICT)
6078 no_bareword_allowed(o);
6080 /* Relocate sv to the pad for thread safety.
6081 * Despite being a "constant", the SV is written to,
6082 * for reference counts, sv_upgrade() etc. */
6084 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6085 if (SvPADTMP(cSVOPo->op_sv)) {
6086 /* If op_sv is already a PADTMP then it is being used by
6087 * some pad, so make a copy. */
6088 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6089 SvREADONLY_on(PAD_SVl(ix));
6090 SvREFCNT_dec(cSVOPo->op_sv);
6093 SvREFCNT_dec(PAD_SVl(ix));
6094 SvPADTMP_on(cSVOPo->op_sv);
6095 PAD_SETSV(ix, cSVOPo->op_sv);
6096 /* XXX I don't know how this isn't readonly already. */
6097 SvREADONLY_on(PAD_SVl(ix));
6099 cSVOPo->op_sv = Nullsv;
6103 o->op_seq = PL_op_seqmax++;
6107 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6108 if (o->op_next->op_private & OPpTARGET_MY) {
6109 if (o->op_flags & OPf_STACKED) /* chained concats */
6110 goto ignore_optimization;
6112 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6113 o->op_targ = o->op_next->op_targ;
6114 o->op_next->op_targ = 0;
6115 o->op_private |= OPpTARGET_MY;
6118 op_null(o->op_next);
6120 ignore_optimization:
6121 o->op_seq = PL_op_seqmax++;
6124 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6125 o->op_seq = PL_op_seqmax++;
6126 break; /* Scalar stub must produce undef. List stub is noop */
6130 if (o->op_targ == OP_NEXTSTATE
6131 || o->op_targ == OP_DBSTATE
6132 || o->op_targ == OP_SETSTATE)
6134 PL_curcop = ((COP*)o);
6136 /* XXX: We avoid setting op_seq here to prevent later calls
6137 to peep() from mistakenly concluding that optimisation
6138 has already occurred. This doesn't fix the real problem,
6139 though (See 20010220.007). AMS 20010719 */
6140 if (oldop && o->op_next) {
6141 oldop->op_next = o->op_next;
6149 if (oldop && o->op_next) {
6150 oldop->op_next = o->op_next;
6153 o->op_seq = PL_op_seqmax++;
6157 if (o->op_next->op_type == OP_RV2SV) {
6158 if (!(o->op_next->op_private & OPpDEREF)) {
6159 op_null(o->op_next);
6160 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6162 o->op_next = o->op_next->op_next;
6163 o->op_type = OP_GVSV;
6164 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6167 else if (o->op_next->op_type == OP_RV2AV) {
6168 OP* pop = o->op_next->op_next;
6170 if (pop && pop->op_type == OP_CONST &&
6171 (PL_op = pop->op_next) &&
6172 pop->op_next->op_type == OP_AELEM &&
6173 !(pop->op_next->op_private &
6174 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6175 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6180 op_null(o->op_next);
6181 op_null(pop->op_next);
6183 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6184 o->op_next = pop->op_next->op_next;
6185 o->op_type = OP_AELEMFAST;
6186 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6187 o->op_private = (U8)i;
6192 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6194 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6195 /* XXX could check prototype here instead of just carping */
6196 SV *sv = sv_newmortal();
6197 gv_efullname3(sv, gv, Nullch);
6198 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6199 "%s() called too early to check prototype",
6203 else if (o->op_next->op_type == OP_READLINE
6204 && o->op_next->op_next->op_type == OP_CONCAT
6205 && (o->op_next->op_next->op_flags & OPf_STACKED))
6207 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6208 o->op_type = OP_RCATLINE;
6209 o->op_flags |= OPf_STACKED;
6210 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6211 op_null(o->op_next->op_next);
6212 op_null(o->op_next);
6215 o->op_seq = PL_op_seqmax++;
6228 o->op_seq = PL_op_seqmax++;
6229 while (cLOGOP->op_other->op_type == OP_NULL)
6230 cLOGOP->op_other = cLOGOP->op_other->op_next;
6231 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6236 o->op_seq = PL_op_seqmax++;
6237 while (cLOOP->op_redoop->op_type == OP_NULL)
6238 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6239 peep(cLOOP->op_redoop);
6240 while (cLOOP->op_nextop->op_type == OP_NULL)
6241 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6242 peep(cLOOP->op_nextop);
6243 while (cLOOP->op_lastop->op_type == OP_NULL)
6244 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6245 peep(cLOOP->op_lastop);
6251 o->op_seq = PL_op_seqmax++;
6252 while (cPMOP->op_pmreplstart &&
6253 cPMOP->op_pmreplstart->op_type == OP_NULL)
6254 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6255 peep(cPMOP->op_pmreplstart);
6259 o->op_seq = PL_op_seqmax++;
6260 if (ckWARN(WARN_SYNTAX) && o->op_next
6261 && o->op_next->op_type == OP_NEXTSTATE) {
6262 if (o->op_next->op_sibling &&
6263 o->op_next->op_sibling->op_type != OP_EXIT &&
6264 o->op_next->op_sibling->op_type != OP_WARN &&
6265 o->op_next->op_sibling->op_type != OP_DIE) {
6266 line_t oldline = CopLINE(PL_curcop);
6268 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6269 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6270 "Statement unlikely to be reached");
6271 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6272 "\t(Maybe you meant system() when you said exec()?)\n");
6273 CopLINE_set(PL_curcop, oldline);
6284 o->op_seq = PL_op_seqmax++;
6286 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6289 /* Make the CONST have a shared SV */
6290 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6291 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6292 key = SvPV(sv, keylen);
6293 lexname = newSVpvn_share(key,
6294 SvUTF8(sv) ? -(I32)keylen : keylen,
6303 o->op_seq = PL_op_seqmax++;
6313 char* Perl_custom_op_name(pTHX_ OP* o)
6315 IV index = PTR2IV(o->op_ppaddr);
6319 if (!PL_custom_op_names) /* This probably shouldn't happen */
6320 return PL_op_name[OP_CUSTOM];
6322 keysv = sv_2mortal(newSViv(index));
6324 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
6326 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
6328 return SvPV_nolen(HeVAL(he));
6331 char* Perl_custom_op_desc(pTHX_ OP* o)
6333 IV index = PTR2IV(o->op_ppaddr);
6337 if (!PL_custom_op_descs)
6338 return PL_op_desc[OP_CUSTOM];
6340 keysv = sv_2mortal(newSViv(index));
6342 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
6344 return PL_op_desc[OP_CUSTOM];
6346 return SvPV_nolen(HeVAL(he));
6352 /* Efficient sub that returns a constant scalar value. */
6354 const_sv_xsub(pTHX_ CV* cv)
6359 Perl_croak(aTHX_ "usage: %s::%s()",
6360 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
6364 ST(0) = (SV*)XSANY.any_ptr;