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 =for apidoc cv_undef
3759 Clear out all the active components of a CV. This can happen either
3760 by an explicit C<undef &foo>, or by the reference count going to zero.
3761 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
3762 children can still follow the full lexical scope chain.
3768 Perl_cv_undef(pTHX_ CV *cv)
3771 if (CvFILE(cv) && !CvXSUB(cv)) {
3772 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
3773 Safefree(CvFILE(cv));
3778 if (!CvXSUB(cv) && CvROOT(cv)) {
3780 Perl_croak(aTHX_ "Can't undef active subroutine");
3783 PAD_SAVE_SETNULLPAD();
3785 op_free(CvROOT(cv));
3786 CvROOT(cv) = Nullop;
3789 SvPOK_off((SV*)cv); /* forget prototype */
3794 /* remove CvOUTSIDE unless this is an undef rather than a free */
3795 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
3796 if (!CvWEAKOUTSIDE(cv))
3797 SvREFCNT_dec(CvOUTSIDE(cv));
3798 CvOUTSIDE(cv) = Nullcv;
3801 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
3807 /* delete all flags except WEAKOUTSIDE */
3808 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
3812 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
3814 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
3815 SV* msg = sv_newmortal();
3819 gv_efullname3(name = sv_newmortal(), gv, Nullch);
3820 sv_setpv(msg, "Prototype mismatch:");
3822 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
3824 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
3825 sv_catpv(msg, " vs ");
3827 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
3829 sv_catpv(msg, "none");
3830 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
3834 static void const_sv_xsub(pTHX_ CV* cv);
3838 =head1 Optree Manipulation Functions
3840 =for apidoc cv_const_sv
3842 If C<cv> is a constant sub eligible for inlining. returns the constant
3843 value returned by the sub. Otherwise, returns NULL.
3845 Constant subs can be created with C<newCONSTSUB> or as described in
3846 L<perlsub/"Constant Functions">.
3851 Perl_cv_const_sv(pTHX_ CV *cv)
3853 if (!cv || !CvCONST(cv))
3855 return (SV*)CvXSUBANY(cv).any_ptr;
3859 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
3866 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
3867 o = cLISTOPo->op_first->op_sibling;
3869 for (; o; o = o->op_next) {
3870 OPCODE type = o->op_type;
3872 if (sv && o->op_next == o)
3874 if (o->op_next != o) {
3875 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
3877 if (type == OP_DBSTATE)
3880 if (type == OP_LEAVESUB || type == OP_RETURN)
3884 if (type == OP_CONST && cSVOPo->op_sv)
3886 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
3887 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
3891 /* We get here only from cv_clone2() while creating a closure.
3892 Copy the const value here instead of in cv_clone2 so that
3893 SvREADONLY_on doesn't lead to problems when leaving
3898 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
3910 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
3920 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
3924 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
3926 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
3930 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
3936 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
3940 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
3941 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
3942 SV *sv = sv_newmortal();
3943 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
3944 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
3945 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3950 gv = gv_fetchpv(name ? name : (aname ? aname :
3951 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__")),
3952 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
3962 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
3963 maximum a prototype before. */
3964 if (SvTYPE(gv) > SVt_NULL) {
3965 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
3966 && ckWARN_d(WARN_PROTOTYPE))
3968 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
3970 cv_ckproto((CV*)gv, NULL, ps);
3973 sv_setpv((SV*)gv, ps);
3975 sv_setiv((SV*)gv, -1);
3976 SvREFCNT_dec(PL_compcv);
3977 cv = PL_compcv = NULL;
3978 PL_sub_generation++;
3982 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
3984 #ifdef GV_UNIQUE_CHECK
3985 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
3986 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
3990 if (!block || !ps || *ps || attrs)
3993 const_sv = op_const_sv(block, Nullcv);
3996 bool exists = CvROOT(cv) || CvXSUB(cv);
3998 #ifdef GV_UNIQUE_CHECK
3999 if (exists && GvUNIQUE(gv)) {
4000 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4004 /* if the subroutine doesn't exist and wasn't pre-declared
4005 * with a prototype, assume it will be AUTOLOADed,
4006 * skipping the prototype check
4008 if (exists || SvPOK(cv))
4009 cv_ckproto(cv, gv, ps);
4010 /* already defined (or promised)? */
4011 if (exists || GvASSUMECV(gv)) {
4012 if (!block && !attrs) {
4013 if (CvFLAGS(PL_compcv)) {
4014 /* might have had built-in attrs applied */
4015 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4017 /* just a "sub foo;" when &foo is already defined */
4018 SAVEFREESV(PL_compcv);
4021 /* ahem, death to those who redefine active sort subs */
4022 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4023 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4025 if (ckWARN(WARN_REDEFINE)
4027 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4029 line_t oldline = CopLINE(PL_curcop);
4030 if (PL_copline != NOLINE)
4031 CopLINE_set(PL_curcop, PL_copline);
4032 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4033 CvCONST(cv) ? "Constant subroutine %s redefined"
4034 : "Subroutine %s redefined", name);
4035 CopLINE_set(PL_curcop, oldline);
4043 SvREFCNT_inc(const_sv);
4045 assert(!CvROOT(cv) && !CvCONST(cv));
4046 sv_setpv((SV*)cv, ""); /* prototype is "" */
4047 CvXSUBANY(cv).any_ptr = const_sv;
4048 CvXSUB(cv) = const_sv_xsub;
4053 cv = newCONSTSUB(NULL, name, const_sv);
4056 SvREFCNT_dec(PL_compcv);
4058 PL_sub_generation++;
4065 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4066 * before we clobber PL_compcv.
4070 /* Might have had built-in attributes applied -- propagate them. */
4071 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4072 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4073 stash = GvSTASH(CvGV(cv));
4074 else if (CvSTASH(cv))
4075 stash = CvSTASH(cv);
4077 stash = PL_curstash;
4080 /* possibly about to re-define existing subr -- ignore old cv */
4081 rcv = (SV*)PL_compcv;
4082 if (name && GvSTASH(gv))
4083 stash = GvSTASH(gv);
4085 stash = PL_curstash;
4087 apply_attrs(stash, rcv, attrs, FALSE);
4089 if (cv) { /* must reuse cv if autoloaded */
4091 /* got here with just attrs -- work done, so bug out */
4092 SAVEFREESV(PL_compcv);
4095 /* transfer PL_compcv to cv */
4097 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4098 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4099 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4100 CvOUTSIDE(PL_compcv) = 0;
4101 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4102 CvPADLIST(PL_compcv) = 0;
4103 /* inner references to PL_compcv must be fixed up ... */
4104 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4105 /* ... before we throw it away */
4106 SvREFCNT_dec(PL_compcv);
4107 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4108 ++PL_sub_generation;
4115 PL_sub_generation++;
4119 CvFILE_set_from_cop(cv, PL_curcop);
4120 CvSTASH(cv) = PL_curstash;
4123 sv_setpv((SV*)cv, ps);
4125 if (PL_error_count) {
4129 char *s = strrchr(name, ':');
4131 if (strEQ(s, "BEGIN")) {
4133 "BEGIN not safe after errors--compilation aborted";
4134 if (PL_in_eval & EVAL_KEEPERR)
4135 Perl_croak(aTHX_ not_safe);
4137 /* force display of errors found but not reported */
4138 sv_catpv(ERRSV, not_safe);
4139 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4148 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4149 mod(scalarseq(block), OP_LEAVESUBLV));
4152 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4154 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4155 OpREFCNT_set(CvROOT(cv), 1);
4156 CvSTART(cv) = LINKLIST(CvROOT(cv));
4157 CvROOT(cv)->op_next = 0;
4158 CALL_PEEP(CvSTART(cv));
4160 /* now that optimizer has done its work, adjust pad values */
4162 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4165 assert(!CvCONST(cv));
4166 if (ps && !*ps && op_const_sv(block, cv))
4170 if (name || aname) {
4172 char *tname = (name ? name : aname);
4174 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4175 SV *sv = NEWSV(0,0);
4176 SV *tmpstr = sv_newmortal();
4177 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4181 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4183 (long)PL_subline, (long)CopLINE(PL_curcop));
4184 gv_efullname3(tmpstr, gv, Nullch);
4185 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4186 hv = GvHVn(db_postponed);
4187 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4188 && (pcv = GvCV(db_postponed)))
4194 call_sv((SV*)pcv, G_DISCARD);
4198 if ((s = strrchr(tname,':')))
4203 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4206 if (strEQ(s, "BEGIN")) {
4207 I32 oldscope = PL_scopestack_ix;
4209 SAVECOPFILE(&PL_compiling);
4210 SAVECOPLINE(&PL_compiling);
4213 PL_beginav = newAV();
4214 DEBUG_x( dump_sub(gv) );
4215 av_push(PL_beginav, (SV*)cv);
4216 GvCV(gv) = 0; /* cv has been hijacked */
4217 call_list(oldscope, PL_beginav);
4219 PL_curcop = &PL_compiling;
4220 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4223 else if (strEQ(s, "END") && !PL_error_count) {
4226 DEBUG_x( dump_sub(gv) );
4227 av_unshift(PL_endav, 1);
4228 av_store(PL_endav, 0, (SV*)cv);
4229 GvCV(gv) = 0; /* cv has been hijacked */
4231 else if (strEQ(s, "CHECK") && !PL_error_count) {
4233 PL_checkav = newAV();
4234 DEBUG_x( dump_sub(gv) );
4235 if (PL_main_start && ckWARN(WARN_VOID))
4236 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4237 av_unshift(PL_checkav, 1);
4238 av_store(PL_checkav, 0, (SV*)cv);
4239 GvCV(gv) = 0; /* cv has been hijacked */
4241 else if (strEQ(s, "INIT") && !PL_error_count) {
4243 PL_initav = newAV();
4244 DEBUG_x( dump_sub(gv) );
4245 if (PL_main_start && ckWARN(WARN_VOID))
4246 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4247 av_push(PL_initav, (SV*)cv);
4248 GvCV(gv) = 0; /* cv has been hijacked */
4253 PL_copline = NOLINE;
4258 /* XXX unsafe for threads if eval_owner isn't held */
4260 =for apidoc newCONSTSUB
4262 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4263 eligible for inlining at compile-time.
4269 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4275 SAVECOPLINE(PL_curcop);
4276 CopLINE_set(PL_curcop, PL_copline);
4279 PL_hints &= ~HINT_BLOCK_SCOPE;
4282 SAVESPTR(PL_curstash);
4283 SAVECOPSTASH(PL_curcop);
4284 PL_curstash = stash;
4285 CopSTASH_set(PL_curcop,stash);
4288 cv = newXS(name, const_sv_xsub, __FILE__);
4289 CvXSUBANY(cv).any_ptr = sv;
4291 sv_setpv((SV*)cv, ""); /* prototype is "" */
4299 =for apidoc U||newXS
4301 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4307 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
4309 GV *gv = gv_fetchpv(name ? name :
4310 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4311 GV_ADDMULTI, SVt_PVCV);
4315 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4317 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4319 /* just a cached method */
4323 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4324 /* already defined (or promised) */
4325 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4326 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4327 line_t oldline = CopLINE(PL_curcop);
4328 if (PL_copline != NOLINE)
4329 CopLINE_set(PL_curcop, PL_copline);
4330 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4331 CvCONST(cv) ? "Constant subroutine %s redefined"
4332 : "Subroutine %s redefined"
4334 CopLINE_set(PL_curcop, oldline);
4341 if (cv) /* must reuse cv if autoloaded */
4344 cv = (CV*)NEWSV(1105,0);
4345 sv_upgrade((SV *)cv, SVt_PVCV);
4349 PL_sub_generation++;
4353 (void)gv_fetchfile(filename);
4354 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
4355 an external constant string */
4356 CvXSUB(cv) = subaddr;
4359 char *s = strrchr(name,':');
4365 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4368 if (strEQ(s, "BEGIN")) {
4370 PL_beginav = newAV();
4371 av_push(PL_beginav, (SV*)cv);
4372 GvCV(gv) = 0; /* cv has been hijacked */
4374 else if (strEQ(s, "END")) {
4377 av_unshift(PL_endav, 1);
4378 av_store(PL_endav, 0, (SV*)cv);
4379 GvCV(gv) = 0; /* cv has been hijacked */
4381 else if (strEQ(s, "CHECK")) {
4383 PL_checkav = newAV();
4384 if (PL_main_start && ckWARN(WARN_VOID))
4385 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4386 av_unshift(PL_checkav, 1);
4387 av_store(PL_checkav, 0, (SV*)cv);
4388 GvCV(gv) = 0; /* cv has been hijacked */
4390 else if (strEQ(s, "INIT")) {
4392 PL_initav = newAV();
4393 if (PL_main_start && ckWARN(WARN_VOID))
4394 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4395 av_push(PL_initav, (SV*)cv);
4396 GvCV(gv) = 0; /* cv has been hijacked */
4407 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4415 name = SvPVx(cSVOPo->op_sv, n_a);
4418 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
4419 #ifdef GV_UNIQUE_CHECK
4421 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4425 if ((cv = GvFORM(gv))) {
4426 if (ckWARN(WARN_REDEFINE)) {
4427 line_t oldline = CopLINE(PL_curcop);
4428 if (PL_copline != NOLINE)
4429 CopLINE_set(PL_curcop, PL_copline);
4430 Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Format %s redefined",name);
4431 CopLINE_set(PL_curcop, oldline);
4438 CvFILE_set_from_cop(cv, PL_curcop);
4441 pad_tidy(padtidy_FORMAT);
4442 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4443 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4444 OpREFCNT_set(CvROOT(cv), 1);
4445 CvSTART(cv) = LINKLIST(CvROOT(cv));
4446 CvROOT(cv)->op_next = 0;
4447 CALL_PEEP(CvSTART(cv));
4449 PL_copline = NOLINE;
4454 Perl_newANONLIST(pTHX_ OP *o)
4456 return newUNOP(OP_REFGEN, 0,
4457 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4461 Perl_newANONHASH(pTHX_ OP *o)
4463 return newUNOP(OP_REFGEN, 0,
4464 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4468 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4470 return newANONATTRSUB(floor, proto, Nullop, block);
4474 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4476 return newUNOP(OP_REFGEN, 0,
4477 newSVOP(OP_ANONCODE, 0,
4478 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
4482 Perl_oopsAV(pTHX_ OP *o)
4484 switch (o->op_type) {
4486 o->op_type = OP_PADAV;
4487 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4488 return ref(o, OP_RV2AV);
4491 o->op_type = OP_RV2AV;
4492 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4497 if (ckWARN_d(WARN_INTERNAL))
4498 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
4505 Perl_oopsHV(pTHX_ OP *o)
4507 switch (o->op_type) {
4510 o->op_type = OP_PADHV;
4511 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4512 return ref(o, OP_RV2HV);
4516 o->op_type = OP_RV2HV;
4517 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
4522 if (ckWARN_d(WARN_INTERNAL))
4523 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
4530 Perl_newAVREF(pTHX_ OP *o)
4532 if (o->op_type == OP_PADANY) {
4533 o->op_type = OP_PADAV;
4534 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4537 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
4538 && ckWARN(WARN_DEPRECATED)) {
4539 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4540 "Using an array as a reference is deprecated");
4542 return newUNOP(OP_RV2AV, 0, scalar(o));
4546 Perl_newGVREF(pTHX_ I32 type, OP *o)
4548 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
4549 return newUNOP(OP_NULL, 0, o);
4550 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
4554 Perl_newHVREF(pTHX_ OP *o)
4556 if (o->op_type == OP_PADANY) {
4557 o->op_type = OP_PADHV;
4558 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4561 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
4562 && ckWARN(WARN_DEPRECATED)) {
4563 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4564 "Using a hash as a reference is deprecated");
4566 return newUNOP(OP_RV2HV, 0, scalar(o));
4570 Perl_oopsCV(pTHX_ OP *o)
4572 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
4578 Perl_newCVREF(pTHX_ I32 flags, OP *o)
4580 return newUNOP(OP_RV2CV, flags, scalar(o));
4584 Perl_newSVREF(pTHX_ OP *o)
4586 if (o->op_type == OP_PADANY) {
4587 o->op_type = OP_PADSV;
4588 o->op_ppaddr = PL_ppaddr[OP_PADSV];
4591 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4592 o->op_flags |= OPpDONE_SVREF;
4595 return newUNOP(OP_RV2SV, 0, scalar(o));
4598 /* Check routines. */
4601 Perl_ck_anoncode(pTHX_ OP *o)
4603 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
4604 cSVOPo->op_sv = Nullsv;
4609 Perl_ck_bitop(pTHX_ OP *o)
4611 #define OP_IS_NUMCOMPARE(op) \
4612 ((op) == OP_LT || (op) == OP_I_LT || \
4613 (op) == OP_GT || (op) == OP_I_GT || \
4614 (op) == OP_LE || (op) == OP_I_LE || \
4615 (op) == OP_GE || (op) == OP_I_GE || \
4616 (op) == OP_EQ || (op) == OP_I_EQ || \
4617 (op) == OP_NE || (op) == OP_I_NE || \
4618 (op) == OP_NCMP || (op) == OP_I_NCMP)
4619 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4620 if (o->op_type == OP_BIT_OR
4621 || o->op_type == OP_BIT_AND
4622 || o->op_type == OP_BIT_XOR)
4624 OPCODE typfirst = cBINOPo->op_first->op_type;
4625 OPCODE typlast = cBINOPo->op_first->op_sibling->op_type;
4626 if (OP_IS_NUMCOMPARE(typfirst) || OP_IS_NUMCOMPARE(typlast))
4627 if (ckWARN(WARN_PRECEDENCE))
4628 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4629 "Possible precedence problem on bitwise %c operator",
4630 o->op_type == OP_BIT_OR ? '|'
4631 : o->op_type == OP_BIT_AND ? '&' : '^'
4638 Perl_ck_concat(pTHX_ OP *o)
4640 if (cUNOPo->op_first->op_type == OP_CONCAT)
4641 o->op_flags |= OPf_STACKED;
4646 Perl_ck_spair(pTHX_ OP *o)
4648 if (o->op_flags & OPf_KIDS) {
4651 OPCODE type = o->op_type;
4652 o = modkids(ck_fun(o), type);
4653 kid = cUNOPo->op_first;
4654 newop = kUNOP->op_first->op_sibling;
4656 (newop->op_sibling ||
4657 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
4658 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
4659 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
4663 op_free(kUNOP->op_first);
4664 kUNOP->op_first = newop;
4666 o->op_ppaddr = PL_ppaddr[++o->op_type];
4671 Perl_ck_delete(pTHX_ OP *o)
4675 if (o->op_flags & OPf_KIDS) {
4676 OP *kid = cUNOPo->op_first;
4677 switch (kid->op_type) {
4679 o->op_flags |= OPf_SPECIAL;
4682 o->op_private |= OPpSLICE;
4685 o->op_flags |= OPf_SPECIAL;
4690 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
4699 Perl_ck_die(pTHX_ OP *o)
4702 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4708 Perl_ck_eof(pTHX_ OP *o)
4710 I32 type = o->op_type;
4712 if (o->op_flags & OPf_KIDS) {
4713 if (cLISTOPo->op_first->op_type == OP_STUB) {
4715 o = newUNOP(type, OPf_SPECIAL,
4716 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
4724 Perl_ck_eval(pTHX_ OP *o)
4726 PL_hints |= HINT_BLOCK_SCOPE;
4727 if (o->op_flags & OPf_KIDS) {
4728 SVOP *kid = (SVOP*)cUNOPo->op_first;
4731 o->op_flags &= ~OPf_KIDS;
4734 else if (kid->op_type == OP_LINESEQ) {
4737 kid->op_next = o->op_next;
4738 cUNOPo->op_first = 0;
4741 NewOp(1101, enter, 1, LOGOP);
4742 enter->op_type = OP_ENTERTRY;
4743 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
4744 enter->op_private = 0;
4746 /* establish postfix order */
4747 enter->op_next = (OP*)enter;
4749 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
4750 o->op_type = OP_LEAVETRY;
4751 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
4752 enter->op_other = o;
4760 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
4762 o->op_targ = (PADOFFSET)PL_hints;
4767 Perl_ck_exit(pTHX_ OP *o)
4770 HV *table = GvHV(PL_hintgv);
4772 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
4773 if (svp && *svp && SvTRUE(*svp))
4774 o->op_private |= OPpEXIT_VMSISH;
4776 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4782 Perl_ck_exec(pTHX_ OP *o)
4785 if (o->op_flags & OPf_STACKED) {
4787 kid = cUNOPo->op_first->op_sibling;
4788 if (kid->op_type == OP_RV2GV)
4797 Perl_ck_exists(pTHX_ OP *o)
4800 if (o->op_flags & OPf_KIDS) {
4801 OP *kid = cUNOPo->op_first;
4802 if (kid->op_type == OP_ENTERSUB) {
4803 (void) ref(kid, o->op_type);
4804 if (kid->op_type != OP_RV2CV && !PL_error_count)
4805 Perl_croak(aTHX_ "%s argument is not a subroutine name",
4807 o->op_private |= OPpEXISTS_SUB;
4809 else if (kid->op_type == OP_AELEM)
4810 o->op_flags |= OPf_SPECIAL;
4811 else if (kid->op_type != OP_HELEM)
4812 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
4821 Perl_ck_gvconst(pTHX_ register OP *o)
4823 o = fold_constants(o);
4824 if (o->op_type == OP_CONST)
4831 Perl_ck_rvconst(pTHX_ register OP *o)
4833 SVOP *kid = (SVOP*)cUNOPo->op_first;
4835 o->op_private |= (PL_hints & HINT_STRICT_REFS);
4836 if (kid->op_type == OP_CONST) {
4840 SV *kidsv = kid->op_sv;
4843 /* Is it a constant from cv_const_sv()? */
4844 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
4845 SV *rsv = SvRV(kidsv);
4846 int svtype = SvTYPE(rsv);
4847 char *badtype = Nullch;
4849 switch (o->op_type) {
4851 if (svtype > SVt_PVMG)
4852 badtype = "a SCALAR";
4855 if (svtype != SVt_PVAV)
4856 badtype = "an ARRAY";
4859 if (svtype != SVt_PVHV)
4863 if (svtype != SVt_PVCV)
4868 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
4871 name = SvPV(kidsv, n_a);
4872 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
4873 char *badthing = Nullch;
4874 switch (o->op_type) {
4876 badthing = "a SCALAR";
4879 badthing = "an ARRAY";
4882 badthing = "a HASH";
4887 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
4891 * This is a little tricky. We only want to add the symbol if we
4892 * didn't add it in the lexer. Otherwise we get duplicate strict
4893 * warnings. But if we didn't add it in the lexer, we must at
4894 * least pretend like we wanted to add it even if it existed before,
4895 * or we get possible typo warnings. OPpCONST_ENTERED says
4896 * whether the lexer already added THIS instance of this symbol.
4898 iscv = (o->op_type == OP_RV2CV) * 2;
4900 gv = gv_fetchpv(name,
4901 iscv | !(kid->op_private & OPpCONST_ENTERED),
4904 : o->op_type == OP_RV2SV
4906 : o->op_type == OP_RV2AV
4908 : o->op_type == OP_RV2HV
4911 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
4913 kid->op_type = OP_GV;
4914 SvREFCNT_dec(kid->op_sv);
4916 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
4917 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
4918 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
4920 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
4922 kid->op_sv = SvREFCNT_inc(gv);
4924 kid->op_private = 0;
4925 kid->op_ppaddr = PL_ppaddr[OP_GV];
4932 Perl_ck_ftst(pTHX_ OP *o)
4934 I32 type = o->op_type;
4936 if (o->op_flags & OPf_REF) {
4939 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
4940 SVOP *kid = (SVOP*)cUNOPo->op_first;
4942 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
4944 OP *newop = newGVOP(type, OPf_REF,
4945 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
4952 if (type == OP_FTTTY)
4953 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
4956 o = newUNOP(type, 0, newDEFSVOP());
4962 Perl_ck_fun(pTHX_ OP *o)
4968 int type = o->op_type;
4969 register I32 oa = PL_opargs[type] >> OASHIFT;
4971 if (o->op_flags & OPf_STACKED) {
4972 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
4975 return no_fh_allowed(o);
4978 if (o->op_flags & OPf_KIDS) {
4980 tokid = &cLISTOPo->op_first;
4981 kid = cLISTOPo->op_first;
4982 if (kid->op_type == OP_PUSHMARK ||
4983 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
4985 tokid = &kid->op_sibling;
4986 kid = kid->op_sibling;
4988 if (!kid && PL_opargs[type] & OA_DEFGV)
4989 *tokid = kid = newDEFSVOP();
4993 sibl = kid->op_sibling;
4996 /* list seen where single (scalar) arg expected? */
4997 if (numargs == 1 && !(oa >> 4)
4998 && kid->op_type == OP_LIST && type != OP_SCALAR)
5000 return too_many_arguments(o,PL_op_desc[type]);
5013 if ((type == OP_PUSH || type == OP_UNSHIFT)
5014 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5015 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5016 "Useless use of %s with no values",
5019 if (kid->op_type == OP_CONST &&
5020 (kid->op_private & OPpCONST_BARE))
5022 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5023 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5024 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5025 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5026 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5027 "Array @%s missing the @ in argument %"IVdf" of %s()",
5028 name, (IV)numargs, PL_op_desc[type]);
5031 kid->op_sibling = sibl;
5034 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5035 bad_type(numargs, "array", PL_op_desc[type], kid);
5039 if (kid->op_type == OP_CONST &&
5040 (kid->op_private & OPpCONST_BARE))
5042 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5043 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5044 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5045 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5046 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5047 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5048 name, (IV)numargs, PL_op_desc[type]);
5051 kid->op_sibling = sibl;
5054 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5055 bad_type(numargs, "hash", PL_op_desc[type], kid);
5060 OP *newop = newUNOP(OP_NULL, 0, kid);
5061 kid->op_sibling = 0;
5063 newop->op_next = newop;
5065 kid->op_sibling = sibl;
5070 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5071 if (kid->op_type == OP_CONST &&
5072 (kid->op_private & OPpCONST_BARE))
5074 OP *newop = newGVOP(OP_GV, 0,
5075 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5077 if (!(o->op_private & 1) && /* if not unop */
5078 kid == cLISTOPo->op_last)
5079 cLISTOPo->op_last = newop;
5083 else if (kid->op_type == OP_READLINE) {
5084 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5085 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5088 I32 flags = OPf_SPECIAL;
5092 /* is this op a FH constructor? */
5093 if (is_handle_constructor(o,numargs)) {
5094 char *name = Nullch;
5098 /* Set a flag to tell rv2gv to vivify
5099 * need to "prove" flag does not mean something
5100 * else already - NI-S 1999/05/07
5103 if (kid->op_type == OP_PADSV) {
5104 /*XXX DAPM 2002.08.25 tmp assert test */
5105 /*XXX*/ assert(av_fetch(PL_comppad_name, (kid->op_targ), FALSE));
5106 /*XXX*/ assert(*av_fetch(PL_comppad_name, (kid->op_targ), FALSE));
5108 name = PAD_COMPNAME_PV(kid->op_targ);
5109 /* SvCUR of a pad namesv can't be trusted
5110 * (see PL_generation), so calc its length
5116 else if (kid->op_type == OP_RV2SV
5117 && kUNOP->op_first->op_type == OP_GV)
5119 GV *gv = cGVOPx_gv(kUNOP->op_first);
5121 len = GvNAMELEN(gv);
5123 else if (kid->op_type == OP_AELEM
5124 || kid->op_type == OP_HELEM)
5126 name = "__ANONIO__";
5132 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5133 namesv = PAD_SVl(targ);
5134 (void)SvUPGRADE(namesv, SVt_PV);
5136 sv_setpvn(namesv, "$", 1);
5137 sv_catpvn(namesv, name, len);
5140 kid->op_sibling = 0;
5141 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5142 kid->op_targ = targ;
5143 kid->op_private |= priv;
5145 kid->op_sibling = sibl;
5151 mod(scalar(kid), type);
5155 tokid = &kid->op_sibling;
5156 kid = kid->op_sibling;
5158 o->op_private |= numargs;
5160 return too_many_arguments(o,OP_DESC(o));
5163 else if (PL_opargs[type] & OA_DEFGV) {
5165 return newUNOP(type, 0, newDEFSVOP());
5169 while (oa & OA_OPTIONAL)
5171 if (oa && oa != OA_LIST)
5172 return too_few_arguments(o,OP_DESC(o));
5178 Perl_ck_glob(pTHX_ OP *o)
5183 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5184 append_elem(OP_GLOB, o, newDEFSVOP());
5186 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5187 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5189 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5192 #if !defined(PERL_EXTERNAL_GLOB)
5193 /* XXX this can be tightened up and made more failsafe. */
5197 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5198 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5199 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5200 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5201 GvCV(gv) = GvCV(glob_gv);
5202 SvREFCNT_inc((SV*)GvCV(gv));
5203 GvIMPORTED_CV_on(gv);
5206 #endif /* PERL_EXTERNAL_GLOB */
5208 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5209 append_elem(OP_GLOB, o,
5210 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5211 o->op_type = OP_LIST;
5212 o->op_ppaddr = PL_ppaddr[OP_LIST];
5213 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5214 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5215 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5216 append_elem(OP_LIST, o,
5217 scalar(newUNOP(OP_RV2CV, 0,
5218 newGVOP(OP_GV, 0, gv)))));
5219 o = newUNOP(OP_NULL, 0, ck_subr(o));
5220 o->op_targ = OP_GLOB; /* hint at what it used to be */
5223 gv = newGVgen("main");
5225 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5231 Perl_ck_grep(pTHX_ OP *o)
5235 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5237 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5238 NewOp(1101, gwop, 1, LOGOP);
5240 if (o->op_flags & OPf_STACKED) {
5243 kid = cLISTOPo->op_first->op_sibling;
5244 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5247 kid->op_next = (OP*)gwop;
5248 o->op_flags &= ~OPf_STACKED;
5250 kid = cLISTOPo->op_first->op_sibling;
5251 if (type == OP_MAPWHILE)
5258 kid = cLISTOPo->op_first->op_sibling;
5259 if (kid->op_type != OP_NULL)
5260 Perl_croak(aTHX_ "panic: ck_grep");
5261 kid = kUNOP->op_first;
5263 gwop->op_type = type;
5264 gwop->op_ppaddr = PL_ppaddr[type];
5265 gwop->op_first = listkids(o);
5266 gwop->op_flags |= OPf_KIDS;
5267 gwop->op_private = 1;
5268 gwop->op_other = LINKLIST(kid);
5269 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5270 kid->op_next = (OP*)gwop;
5272 kid = cLISTOPo->op_first->op_sibling;
5273 if (!kid || !kid->op_sibling)
5274 return too_few_arguments(o,OP_DESC(o));
5275 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5276 mod(kid, OP_GREPSTART);
5282 Perl_ck_index(pTHX_ OP *o)
5284 if (o->op_flags & OPf_KIDS) {
5285 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5287 kid = kid->op_sibling; /* get past "big" */
5288 if (kid && kid->op_type == OP_CONST)
5289 fbm_compile(((SVOP*)kid)->op_sv, 0);
5295 Perl_ck_lengthconst(pTHX_ OP *o)
5297 /* XXX length optimization goes here */
5302 Perl_ck_lfun(pTHX_ OP *o)
5304 OPCODE type = o->op_type;
5305 return modkids(ck_fun(o), type);
5309 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5311 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5312 switch (cUNOPo->op_first->op_type) {
5314 /* This is needed for
5315 if (defined %stash::)
5316 to work. Do not break Tk.
5318 break; /* Globals via GV can be undef */
5320 case OP_AASSIGN: /* Is this a good idea? */
5321 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5322 "defined(@array) is deprecated");
5323 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5324 "\t(Maybe you should just omit the defined()?)\n");
5327 /* This is needed for
5328 if (defined %stash::)
5329 to work. Do not break Tk.
5331 break; /* Globals via GV can be undef */
5333 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5334 "defined(%%hash) is deprecated");
5335 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5336 "\t(Maybe you should just omit the defined()?)\n");
5347 Perl_ck_rfun(pTHX_ OP *o)
5349 OPCODE type = o->op_type;
5350 return refkids(ck_fun(o), type);
5354 Perl_ck_listiob(pTHX_ OP *o)
5358 kid = cLISTOPo->op_first;
5361 kid = cLISTOPo->op_first;
5363 if (kid->op_type == OP_PUSHMARK)
5364 kid = kid->op_sibling;
5365 if (kid && o->op_flags & OPf_STACKED)
5366 kid = kid->op_sibling;
5367 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5368 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5369 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5370 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5371 cLISTOPo->op_first->op_sibling = kid;
5372 cLISTOPo->op_last = kid;
5373 kid = kid->op_sibling;
5378 append_elem(o->op_type, o, newDEFSVOP());
5384 Perl_ck_sassign(pTHX_ OP *o)
5386 OP *kid = cLISTOPo->op_first;
5387 /* has a disposable target? */
5388 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5389 && !(kid->op_flags & OPf_STACKED)
5390 /* Cannot steal the second time! */
5391 && !(kid->op_private & OPpTARGET_MY))
5393 OP *kkid = kid->op_sibling;
5395 /* Can just relocate the target. */
5396 if (kkid && kkid->op_type == OP_PADSV
5397 && !(kkid->op_private & OPpLVAL_INTRO))
5399 kid->op_targ = kkid->op_targ;
5401 /* Now we do not need PADSV and SASSIGN. */
5402 kid->op_sibling = o->op_sibling; /* NULL */
5403 cLISTOPo->op_first = NULL;
5406 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
5414 Perl_ck_match(pTHX_ OP *o)
5416 o->op_private |= OPpRUNTIME;
5421 Perl_ck_method(pTHX_ OP *o)
5423 OP *kid = cUNOPo->op_first;
5424 if (kid->op_type == OP_CONST) {
5425 SV* sv = kSVOP->op_sv;
5426 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
5428 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5429 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
5432 kSVOP->op_sv = Nullsv;
5434 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5443 Perl_ck_null(pTHX_ OP *o)
5449 Perl_ck_open(pTHX_ OP *o)
5451 HV *table = GvHV(PL_hintgv);
5455 svp = hv_fetch(table, "open_IN", 7, FALSE);
5457 mode = mode_from_discipline(*svp);
5458 if (mode & O_BINARY)
5459 o->op_private |= OPpOPEN_IN_RAW;
5460 else if (mode & O_TEXT)
5461 o->op_private |= OPpOPEN_IN_CRLF;
5464 svp = hv_fetch(table, "open_OUT", 8, FALSE);
5466 mode = mode_from_discipline(*svp);
5467 if (mode & O_BINARY)
5468 o->op_private |= OPpOPEN_OUT_RAW;
5469 else if (mode & O_TEXT)
5470 o->op_private |= OPpOPEN_OUT_CRLF;
5473 if (o->op_type == OP_BACKTICK)
5479 Perl_ck_repeat(pTHX_ OP *o)
5481 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5482 o->op_private |= OPpREPEAT_DOLIST;
5483 cBINOPo->op_first = force_list(cBINOPo->op_first);
5491 Perl_ck_require(pTHX_ OP *o)
5495 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
5496 SVOP *kid = (SVOP*)cUNOPo->op_first;
5498 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5500 for (s = SvPVX(kid->op_sv); *s; s++) {
5501 if (*s == ':' && s[1] == ':') {
5503 Move(s+2, s+1, strlen(s+2)+1, char);
5504 --SvCUR(kid->op_sv);
5507 if (SvREADONLY(kid->op_sv)) {
5508 SvREADONLY_off(kid->op_sv);
5509 sv_catpvn(kid->op_sv, ".pm", 3);
5510 SvREADONLY_on(kid->op_sv);
5513 sv_catpvn(kid->op_sv, ".pm", 3);
5517 /* handle override, if any */
5518 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
5519 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
5520 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
5522 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5523 OP *kid = cUNOPo->op_first;
5524 cUNOPo->op_first = 0;
5526 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5527 append_elem(OP_LIST, kid,
5528 scalar(newUNOP(OP_RV2CV, 0,
5537 Perl_ck_return(pTHX_ OP *o)
5540 if (CvLVALUE(PL_compcv)) {
5541 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5542 mod(kid, OP_LEAVESUBLV);
5549 Perl_ck_retarget(pTHX_ OP *o)
5551 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5558 Perl_ck_select(pTHX_ OP *o)
5561 if (o->op_flags & OPf_KIDS) {
5562 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5563 if (kid && kid->op_sibling) {
5564 o->op_type = OP_SSELECT;
5565 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
5567 return fold_constants(o);
5571 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5572 if (kid && kid->op_type == OP_RV2GV)
5573 kid->op_private &= ~HINT_STRICT_REFS;
5578 Perl_ck_shift(pTHX_ OP *o)
5580 I32 type = o->op_type;
5582 if (!(o->op_flags & OPf_KIDS)) {
5586 argop = newUNOP(OP_RV2AV, 0,
5587 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
5588 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
5589 return newUNOP(type, 0, scalar(argop));
5591 return scalar(modkids(ck_fun(o), type));
5595 Perl_ck_sort(pTHX_ OP *o)
5599 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
5601 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5602 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
5604 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
5606 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
5608 if (kid->op_type == OP_SCOPE) {
5612 else if (kid->op_type == OP_LEAVE) {
5613 if (o->op_type == OP_SORT) {
5614 op_null(kid); /* wipe out leave */
5617 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
5618 if (k->op_next == kid)
5620 /* don't descend into loops */
5621 else if (k->op_type == OP_ENTERLOOP
5622 || k->op_type == OP_ENTERITER)
5624 k = cLOOPx(k)->op_lastop;
5629 kid->op_next = 0; /* just disconnect the leave */
5630 k = kLISTOP->op_first;
5635 if (o->op_type == OP_SORT) {
5636 /* provide scalar context for comparison function/block */
5642 o->op_flags |= OPf_SPECIAL;
5644 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
5647 firstkid = firstkid->op_sibling;
5650 /* provide list context for arguments */
5651 if (o->op_type == OP_SORT)
5658 S_simplify_sort(pTHX_ OP *o)
5660 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5664 if (!(o->op_flags & OPf_STACKED))
5666 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
5667 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
5668 kid = kUNOP->op_first; /* get past null */
5669 if (kid->op_type != OP_SCOPE)
5671 kid = kLISTOP->op_last; /* get past scope */
5672 switch(kid->op_type) {
5680 k = kid; /* remember this node*/
5681 if (kBINOP->op_first->op_type != OP_RV2SV)
5683 kid = kBINOP->op_first; /* get past cmp */
5684 if (kUNOP->op_first->op_type != OP_GV)
5686 kid = kUNOP->op_first; /* get past rv2sv */
5688 if (GvSTASH(gv) != PL_curstash)
5690 if (strEQ(GvNAME(gv), "a"))
5692 else if (strEQ(GvNAME(gv), "b"))
5696 kid = k; /* back to cmp */
5697 if (kBINOP->op_last->op_type != OP_RV2SV)
5699 kid = kBINOP->op_last; /* down to 2nd arg */
5700 if (kUNOP->op_first->op_type != OP_GV)
5702 kid = kUNOP->op_first; /* get past rv2sv */
5704 if (GvSTASH(gv) != PL_curstash
5706 ? strNE(GvNAME(gv), "a")
5707 : strNE(GvNAME(gv), "b")))
5709 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
5711 o->op_private |= OPpSORT_REVERSE;
5712 if (k->op_type == OP_NCMP)
5713 o->op_private |= OPpSORT_NUMERIC;
5714 if (k->op_type == OP_I_NCMP)
5715 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
5716 kid = cLISTOPo->op_first->op_sibling;
5717 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
5718 op_free(kid); /* then delete it */
5722 Perl_ck_split(pTHX_ OP *o)
5726 if (o->op_flags & OPf_STACKED)
5727 return no_fh_allowed(o);
5729 kid = cLISTOPo->op_first;
5730 if (kid->op_type != OP_NULL)
5731 Perl_croak(aTHX_ "panic: ck_split");
5732 kid = kid->op_sibling;
5733 op_free(cLISTOPo->op_first);
5734 cLISTOPo->op_first = kid;
5736 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
5737 cLISTOPo->op_last = kid; /* There was only one element previously */
5740 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
5741 OP *sibl = kid->op_sibling;
5742 kid->op_sibling = 0;
5743 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
5744 if (cLISTOPo->op_first == cLISTOPo->op_last)
5745 cLISTOPo->op_last = kid;
5746 cLISTOPo->op_first = kid;
5747 kid->op_sibling = sibl;
5750 kid->op_type = OP_PUSHRE;
5751 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
5753 if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
5754 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
5755 "Use of /g modifier is meaningless in split");
5758 if (!kid->op_sibling)
5759 append_elem(OP_SPLIT, o, newDEFSVOP());
5761 kid = kid->op_sibling;
5764 if (!kid->op_sibling)
5765 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
5767 kid = kid->op_sibling;
5770 if (kid->op_sibling)
5771 return too_many_arguments(o,OP_DESC(o));
5777 Perl_ck_join(pTHX_ OP *o)
5779 if (ckWARN(WARN_SYNTAX)) {
5780 OP *kid = cLISTOPo->op_first->op_sibling;
5781 if (kid && kid->op_type == OP_MATCH) {
5782 char *pmstr = "STRING";
5783 if (PM_GETRE(kPMOP))
5784 pmstr = PM_GETRE(kPMOP)->precomp;
5785 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5786 "/%s/ should probably be written as \"%s\"",
5794 Perl_ck_subr(pTHX_ OP *o)
5796 OP *prev = ((cUNOPo->op_first->op_sibling)
5797 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
5798 OP *o2 = prev->op_sibling;
5805 I32 contextclass = 0;
5809 o->op_private |= OPpENTERSUB_HASTARG;
5810 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
5811 if (cvop->op_type == OP_RV2CV) {
5813 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
5814 op_null(cvop); /* disable rv2cv */
5815 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
5816 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
5817 GV *gv = cGVOPx_gv(tmpop);
5820 tmpop->op_private |= OPpEARLY_CV;
5821 else if (SvPOK(cv)) {
5822 namegv = CvANON(cv) ? gv : CvGV(cv);
5823 proto = SvPV((SV*)cv, n_a);
5827 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
5828 if (o2->op_type == OP_CONST)
5829 o2->op_private &= ~OPpCONST_STRICT;
5830 else if (o2->op_type == OP_LIST) {
5831 OP *o = ((UNOP*)o2)->op_first->op_sibling;
5832 if (o && o->op_type == OP_CONST)
5833 o->op_private &= ~OPpCONST_STRICT;
5836 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5837 if (PERLDB_SUB && PL_curstash != PL_debstash)
5838 o->op_private |= OPpENTERSUB_DB;
5839 while (o2 != cvop) {
5843 return too_many_arguments(o, gv_ename(namegv));
5861 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
5863 arg == 1 ? "block or sub {}" : "sub {}",
5864 gv_ename(namegv), o2);
5867 /* '*' allows any scalar type, including bareword */
5870 if (o2->op_type == OP_RV2GV)
5871 goto wrapref; /* autoconvert GLOB -> GLOBref */
5872 else if (o2->op_type == OP_CONST)
5873 o2->op_private &= ~OPpCONST_STRICT;
5874 else if (o2->op_type == OP_ENTERSUB) {
5875 /* accidental subroutine, revert to bareword */
5876 OP *gvop = ((UNOP*)o2)->op_first;
5877 if (gvop && gvop->op_type == OP_NULL) {
5878 gvop = ((UNOP*)gvop)->op_first;
5880 for (; gvop->op_sibling; gvop = gvop->op_sibling)
5883 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
5884 (gvop = ((UNOP*)gvop)->op_first) &&
5885 gvop->op_type == OP_GV)
5887 GV *gv = cGVOPx_gv(gvop);
5888 OP *sibling = o2->op_sibling;
5889 SV *n = newSVpvn("",0);
5891 gv_fullname3(n, gv, "");
5892 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
5893 sv_chop(n, SvPVX(n)+6);
5894 o2 = newSVOP(OP_CONST, 0, n);
5895 prev->op_sibling = o2;
5896 o2->op_sibling = sibling;
5912 if (contextclass++ == 0) {
5913 e = strchr(proto, ']');
5914 if (!e || e == proto)
5927 while (*--p != '[');
5928 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
5929 gv_ename(namegv), o2);
5935 if (o2->op_type == OP_RV2GV)
5938 bad_type(arg, "symbol", gv_ename(namegv), o2);
5941 if (o2->op_type == OP_ENTERSUB)
5944 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
5947 if (o2->op_type == OP_RV2SV ||
5948 o2->op_type == OP_PADSV ||
5949 o2->op_type == OP_HELEM ||
5950 o2->op_type == OP_AELEM ||
5951 o2->op_type == OP_THREADSV)
5954 bad_type(arg, "scalar", gv_ename(namegv), o2);
5957 if (o2->op_type == OP_RV2AV ||
5958 o2->op_type == OP_PADAV)
5961 bad_type(arg, "array", gv_ename(namegv), o2);
5964 if (o2->op_type == OP_RV2HV ||
5965 o2->op_type == OP_PADHV)
5968 bad_type(arg, "hash", gv_ename(namegv), o2);
5973 OP* sib = kid->op_sibling;
5974 kid->op_sibling = 0;
5975 o2 = newUNOP(OP_REFGEN, 0, kid);
5976 o2->op_sibling = sib;
5977 prev->op_sibling = o2;
5979 if (contextclass && e) {
5994 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
5995 gv_ename(namegv), SvPV((SV*)cv, n_a));
6000 mod(o2, OP_ENTERSUB);
6002 o2 = o2->op_sibling;
6004 if (proto && !optional &&
6005 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6006 return too_few_arguments(o, gv_ename(namegv));
6011 Perl_ck_svconst(pTHX_ OP *o)
6013 SvREADONLY_on(cSVOPo->op_sv);
6018 Perl_ck_trunc(pTHX_ OP *o)
6020 if (o->op_flags & OPf_KIDS) {
6021 SVOP *kid = (SVOP*)cUNOPo->op_first;
6023 if (kid->op_type == OP_NULL)
6024 kid = (SVOP*)kid->op_sibling;
6025 if (kid && kid->op_type == OP_CONST &&
6026 (kid->op_private & OPpCONST_BARE))
6028 o->op_flags |= OPf_SPECIAL;
6029 kid->op_private &= ~OPpCONST_STRICT;
6036 Perl_ck_substr(pTHX_ OP *o)
6039 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6040 OP *kid = cLISTOPo->op_first;
6042 if (kid->op_type == OP_NULL)
6043 kid = kid->op_sibling;
6045 kid->op_flags |= OPf_MOD;
6051 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6054 Perl_peep(pTHX_ register OP *o)
6056 register OP* oldop = 0;
6058 if (!o || o->op_seq)
6062 SAVEVPTR(PL_curcop);
6063 for (; o; o = o->op_next) {
6069 switch (o->op_type) {
6073 PL_curcop = ((COP*)o); /* for warnings */
6074 o->op_seq = PL_op_seqmax++;
6078 if (cSVOPo->op_private & OPpCONST_STRICT)
6079 no_bareword_allowed(o);
6081 /* Relocate sv to the pad for thread safety.
6082 * Despite being a "constant", the SV is written to,
6083 * for reference counts, sv_upgrade() etc. */
6085 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6086 if (SvPADTMP(cSVOPo->op_sv)) {
6087 /* If op_sv is already a PADTMP then it is being used by
6088 * some pad, so make a copy. */
6089 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6090 SvREADONLY_on(PAD_SVl(ix));
6091 SvREFCNT_dec(cSVOPo->op_sv);
6094 SvREFCNT_dec(PAD_SVl(ix));
6095 SvPADTMP_on(cSVOPo->op_sv);
6096 PAD_SETSV(ix, cSVOPo->op_sv);
6097 /* XXX I don't know how this isn't readonly already. */
6098 SvREADONLY_on(PAD_SVl(ix));
6100 cSVOPo->op_sv = Nullsv;
6104 o->op_seq = PL_op_seqmax++;
6108 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6109 if (o->op_next->op_private & OPpTARGET_MY) {
6110 if (o->op_flags & OPf_STACKED) /* chained concats */
6111 goto ignore_optimization;
6113 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6114 o->op_targ = o->op_next->op_targ;
6115 o->op_next->op_targ = 0;
6116 o->op_private |= OPpTARGET_MY;
6119 op_null(o->op_next);
6121 ignore_optimization:
6122 o->op_seq = PL_op_seqmax++;
6125 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6126 o->op_seq = PL_op_seqmax++;
6127 break; /* Scalar stub must produce undef. List stub is noop */
6131 if (o->op_targ == OP_NEXTSTATE
6132 || o->op_targ == OP_DBSTATE
6133 || o->op_targ == OP_SETSTATE)
6135 PL_curcop = ((COP*)o);
6137 /* XXX: We avoid setting op_seq here to prevent later calls
6138 to peep() from mistakenly concluding that optimisation
6139 has already occurred. This doesn't fix the real problem,
6140 though (See 20010220.007). AMS 20010719 */
6141 if (oldop && o->op_next) {
6142 oldop->op_next = o->op_next;
6150 if (oldop && o->op_next) {
6151 oldop->op_next = o->op_next;
6154 o->op_seq = PL_op_seqmax++;
6158 if (o->op_next->op_type == OP_RV2SV) {
6159 if (!(o->op_next->op_private & OPpDEREF)) {
6160 op_null(o->op_next);
6161 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6163 o->op_next = o->op_next->op_next;
6164 o->op_type = OP_GVSV;
6165 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6168 else if (o->op_next->op_type == OP_RV2AV) {
6169 OP* pop = o->op_next->op_next;
6171 if (pop && pop->op_type == OP_CONST &&
6172 (PL_op = pop->op_next) &&
6173 pop->op_next->op_type == OP_AELEM &&
6174 !(pop->op_next->op_private &
6175 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6176 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6181 op_null(o->op_next);
6182 op_null(pop->op_next);
6184 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6185 o->op_next = pop->op_next->op_next;
6186 o->op_type = OP_AELEMFAST;
6187 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6188 o->op_private = (U8)i;
6193 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6195 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6196 /* XXX could check prototype here instead of just carping */
6197 SV *sv = sv_newmortal();
6198 gv_efullname3(sv, gv, Nullch);
6199 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6200 "%s() called too early to check prototype",
6204 else if (o->op_next->op_type == OP_READLINE
6205 && o->op_next->op_next->op_type == OP_CONCAT
6206 && (o->op_next->op_next->op_flags & OPf_STACKED))
6208 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6209 o->op_type = OP_RCATLINE;
6210 o->op_flags |= OPf_STACKED;
6211 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6212 op_null(o->op_next->op_next);
6213 op_null(o->op_next);
6216 o->op_seq = PL_op_seqmax++;
6229 o->op_seq = PL_op_seqmax++;
6230 while (cLOGOP->op_other->op_type == OP_NULL)
6231 cLOGOP->op_other = cLOGOP->op_other->op_next;
6232 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6237 o->op_seq = PL_op_seqmax++;
6238 while (cLOOP->op_redoop->op_type == OP_NULL)
6239 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6240 peep(cLOOP->op_redoop);
6241 while (cLOOP->op_nextop->op_type == OP_NULL)
6242 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6243 peep(cLOOP->op_nextop);
6244 while (cLOOP->op_lastop->op_type == OP_NULL)
6245 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6246 peep(cLOOP->op_lastop);
6252 o->op_seq = PL_op_seqmax++;
6253 while (cPMOP->op_pmreplstart &&
6254 cPMOP->op_pmreplstart->op_type == OP_NULL)
6255 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6256 peep(cPMOP->op_pmreplstart);
6260 o->op_seq = PL_op_seqmax++;
6261 if (ckWARN(WARN_SYNTAX) && o->op_next
6262 && o->op_next->op_type == OP_NEXTSTATE) {
6263 if (o->op_next->op_sibling &&
6264 o->op_next->op_sibling->op_type != OP_EXIT &&
6265 o->op_next->op_sibling->op_type != OP_WARN &&
6266 o->op_next->op_sibling->op_type != OP_DIE) {
6267 line_t oldline = CopLINE(PL_curcop);
6269 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6270 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6271 "Statement unlikely to be reached");
6272 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6273 "\t(Maybe you meant system() when you said exec()?)\n");
6274 CopLINE_set(PL_curcop, oldline);
6285 o->op_seq = PL_op_seqmax++;
6287 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6290 /* Make the CONST have a shared SV */
6291 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6292 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6293 key = SvPV(sv, keylen);
6294 lexname = newSVpvn_share(key,
6295 SvUTF8(sv) ? -(I32)keylen : keylen,
6304 o->op_seq = PL_op_seqmax++;
6314 char* Perl_custom_op_name(pTHX_ OP* o)
6316 IV index = PTR2IV(o->op_ppaddr);
6320 if (!PL_custom_op_names) /* This probably shouldn't happen */
6321 return PL_op_name[OP_CUSTOM];
6323 keysv = sv_2mortal(newSViv(index));
6325 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
6327 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
6329 return SvPV_nolen(HeVAL(he));
6332 char* Perl_custom_op_desc(pTHX_ OP* o)
6334 IV index = PTR2IV(o->op_ppaddr);
6338 if (!PL_custom_op_descs)
6339 return PL_op_desc[OP_CUSTOM];
6341 keysv = sv_2mortal(newSViv(index));
6343 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
6345 return PL_op_desc[OP_CUSTOM];
6347 return SvPV_nolen(HeVAL(he));
6353 /* Efficient sub that returns a constant scalar value. */
6355 const_sv_xsub(pTHX_ CV* cv)
6360 Perl_croak(aTHX_ "usage: %s::%s()",
6361 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
6365 ST(0) = (SV*)XSANY.any_ptr;