3 * Copyright (c) 1991-2002, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
12 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
13 * youngest of the Old Took's daughters); and Mr. Drogo was his second
14 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
15 * either way, as the saying is, if you follow me." --the Gaffer
24 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
26 #if defined(PL_OP_SLAB_ALLOC)
28 #ifndef PERL_SLAB_SIZE
29 #define PERL_SLAB_SIZE 2048
32 #define NewOp(m,var,c,type) \
33 STMT_START { var = (type *) Slab_Alloc(m,c*sizeof(type)); } STMT_END
35 #define FreeOp(p) Slab_Free(p)
38 S_Slab_Alloc(pTHX_ int m, size_t sz)
41 * To make incrementing use count easy PL_OpSlab is an I32 *
42 * To make inserting the link to slab PL_OpPtr is I32 **
43 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
44 * Add an overhead for pointer to slab and round up as a number of pointers
46 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
47 if ((PL_OpSpace -= sz) < 0) {
48 PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*));
52 Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **);
53 /* We reserve the 0'th I32 sized chunk as a use count */
54 PL_OpSlab = (I32 *) PL_OpPtr;
55 /* Reduce size by the use count word, and by the size we need.
56 * Latter is to mimic the '-=' in the if() above
58 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
59 /* Allocation pointer starts at the top.
60 Theory: because we build leaves before trunk allocating at end
61 means that at run time access is cache friendly upward
63 PL_OpPtr += PERL_SLAB_SIZE;
65 assert( PL_OpSpace >= 0 );
66 /* Move the allocation pointer down */
68 assert( PL_OpPtr > (I32 **) PL_OpSlab );
69 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
70 (*PL_OpSlab)++; /* Increment use count of slab */
71 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
72 assert( *PL_OpSlab > 0 );
73 return (void *)(PL_OpPtr + 1);
77 S_Slab_Free(pTHX_ void *op)
79 I32 **ptr = (I32 **) op;
81 assert( ptr-1 > (I32 **) slab );
82 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
86 #define PerlMemShared PerlMem
89 PerlMemShared_free(slab);
90 if (slab == PL_OpSlab) {
97 #define NewOp(m, var, c, type) Newz(m, var, c, type)
98 #define FreeOp(p) Safefree(p)
101 * In the following definition, the ", Nullop" is just to make the compiler
102 * think the expression is of the right type: croak actually does a Siglongjmp.
104 #define CHECKOP(type,o) \
105 ((PL_op_mask && PL_op_mask[type]) \
106 ? ( op_free((OP*)o), \
107 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
109 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
111 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
114 S_gv_ename(pTHX_ GV *gv)
117 SV* tmpsv = sv_newmortal();
118 gv_efullname3(tmpsv, gv, Nullch);
119 return SvPV(tmpsv,n_a);
123 S_no_fh_allowed(pTHX_ OP *o)
125 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
131 S_too_few_arguments(pTHX_ OP *o, char *name)
133 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
138 S_too_many_arguments(pTHX_ OP *o, char *name)
140 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
145 S_bad_type(pTHX_ I32 n, char *t, char *name, OP *kid)
147 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
148 (int)n, name, t, OP_DESC(kid)));
152 S_no_bareword_allowed(pTHX_ OP *o)
154 qerror(Perl_mess(aTHX_
155 "Bareword \"%s\" not allowed while \"strict subs\" in use",
156 SvPV_nolen(cSVOPo_sv)));
159 /* "register" allocation */
162 Perl_allocmy(pTHX_ char *name)
166 /* complain about "my $_" etc etc */
167 if (!(PL_in_my == KEY_our ||
169 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
170 (name[1] == '_' && (int)strlen(name) > 2)))
172 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
173 /* 1999-02-27 mjd@plover.com */
175 p = strchr(name, '\0');
176 /* The next block assumes the buffer is at least 205 chars
177 long. At present, it's always at least 256 chars. */
179 strcpy(name+200, "...");
185 /* Move everything else down one character */
186 for (; p-name > 2; p--)
188 name[2] = toCTRL(name[1]);
191 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
194 /* check for duplicate declaration */
197 (PL_curstash ? PL_curstash : PL_defstash)
200 if (PL_in_my_stash && *name != '$') {
201 yyerror(Perl_form(aTHX_
202 "Can't declare class for non-scalar %s in \"%s\"",
203 name, PL_in_my == KEY_our ? "our" : "my"));
206 /* allocate a spare slot and store the name in that slot */
208 off = pad_add_name(name,
211 ? (PL_curstash ? PL_curstash : PL_defstash)
222 Perl_op_free(pTHX_ OP *o)
224 register OP *kid, *nextkid;
227 if (!o || o->op_seq == (U16)-1)
230 if (o->op_private & OPpREFCOUNTED) {
231 switch (o->op_type) {
239 if (OpREFCNT_dec(o)) {
250 if (o->op_flags & OPf_KIDS) {
251 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
252 nextkid = kid->op_sibling; /* Get before next freeing kid */
258 type = (OPCODE)o->op_targ;
260 /* COP* is not cleared by op_clear() so that we may track line
261 * numbers etc even after null() */
262 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
270 Perl_op_clear(pTHX_ OP *o)
273 switch (o->op_type) {
274 case OP_NULL: /* Was holding old type, if any. */
275 case OP_ENTEREVAL: /* Was holding hints. */
279 if (!(o->op_flags & OPf_REF)
280 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
287 if (cPADOPo->op_padix > 0) {
288 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
289 * may still exist on the pad */
290 pad_swipe(cPADOPo->op_padix, TRUE);
291 cPADOPo->op_padix = 0;
294 SvREFCNT_dec(cSVOPo->op_sv);
295 cSVOPo->op_sv = Nullsv;
298 case OP_METHOD_NAMED:
300 SvREFCNT_dec(cSVOPo->op_sv);
301 cSVOPo->op_sv = Nullsv;
307 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
311 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
312 SvREFCNT_dec(cSVOPo->op_sv);
313 cSVOPo->op_sv = Nullsv;
316 Safefree(cPVOPo->op_pv);
317 cPVOPo->op_pv = Nullch;
321 op_free(cPMOPo->op_pmreplroot);
325 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
326 /* No GvIN_PAD_off here, because other references may still
327 * exist on the pad */
328 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
331 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
338 HV *pmstash = PmopSTASH(cPMOPo);
339 if (pmstash && SvREFCNT(pmstash)) {
340 PMOP *pmop = HvPMROOT(pmstash);
341 PMOP *lastpmop = NULL;
343 if (cPMOPo == pmop) {
345 lastpmop->op_pmnext = pmop->op_pmnext;
347 HvPMROOT(pmstash) = pmop->op_pmnext;
351 pmop = pmop->op_pmnext;
354 PmopSTASH_free(cPMOPo);
356 cPMOPo->op_pmreplroot = Nullop;
357 /* we use the "SAFE" version of the PM_ macros here
358 * since sv_clean_all might release some PMOPs
359 * after PL_regex_padav has been cleared
360 * and the clearing of PL_regex_padav needs to
361 * happen before sv_clean_all
363 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
364 PM_SETRE_SAFE(cPMOPo, (REGEXP*)NULL);
366 if(PL_regex_pad) { /* We could be in destruction */
367 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
368 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
369 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
376 if (o->op_targ > 0) {
377 pad_free(o->op_targ);
383 S_cop_free(pTHX_ COP* cop)
385 Safefree(cop->cop_label); /* FIXME: treaddead ??? */
388 if (! specialWARN(cop->cop_warnings))
389 SvREFCNT_dec(cop->cop_warnings);
390 if (! specialCopIO(cop->cop_io)) {
394 char *s = SvPV(cop->cop_io,len);
395 Perl_warn(aTHX_ "io='%.*s'",(int) len,s); /* ??? --jhi */
398 SvREFCNT_dec(cop->cop_io);
404 Perl_op_null(pTHX_ OP *o)
406 if (o->op_type == OP_NULL)
409 o->op_targ = o->op_type;
410 o->op_type = OP_NULL;
411 o->op_ppaddr = PL_ppaddr[OP_NULL];
414 /* Contextualizers */
416 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
419 Perl_linklist(pTHX_ OP *o)
426 /* establish postfix order */
427 if (cUNOPo->op_first) {
428 o->op_next = LINKLIST(cUNOPo->op_first);
429 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
431 kid->op_next = LINKLIST(kid->op_sibling);
443 Perl_scalarkids(pTHX_ OP *o)
446 if (o && o->op_flags & OPf_KIDS) {
447 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
454 S_scalarboolean(pTHX_ OP *o)
456 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
457 if (ckWARN(WARN_SYNTAX)) {
458 line_t oldline = CopLINE(PL_curcop);
460 if (PL_copline != NOLINE)
461 CopLINE_set(PL_curcop, PL_copline);
462 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
463 CopLINE_set(PL_curcop, oldline);
470 Perl_scalar(pTHX_ OP *o)
474 /* assumes no premature commitment */
475 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
476 || o->op_type == OP_RETURN)
481 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
483 switch (o->op_type) {
485 scalar(cBINOPo->op_first);
490 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
494 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
495 if (!kPMOP->op_pmreplroot)
496 deprecate_old("implicit split to @_");
504 if (o->op_flags & OPf_KIDS) {
505 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
511 kid = cLISTOPo->op_first;
513 while ((kid = kid->op_sibling)) {
519 WITH_THR(PL_curcop = &PL_compiling);
524 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
530 WITH_THR(PL_curcop = &PL_compiling);
533 if (ckWARN(WARN_VOID))
534 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
540 Perl_scalarvoid(pTHX_ OP *o)
547 if (o->op_type == OP_NEXTSTATE
548 || o->op_type == OP_SETSTATE
549 || o->op_type == OP_DBSTATE
550 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
551 || o->op_targ == OP_SETSTATE
552 || o->op_targ == OP_DBSTATE)))
553 PL_curcop = (COP*)o; /* for warning below */
555 /* assumes no premature commitment */
556 want = o->op_flags & OPf_WANT;
557 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
558 || o->op_type == OP_RETURN)
563 if ((o->op_private & OPpTARGET_MY)
564 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
566 return scalar(o); /* As if inside SASSIGN */
569 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
571 switch (o->op_type) {
573 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
577 if (o->op_flags & OPf_STACKED)
581 if (o->op_private == 4)
653 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
654 useless = OP_DESC(o);
661 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
662 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
663 useless = "a variable";
668 if (cSVOPo->op_private & OPpCONST_STRICT)
669 no_bareword_allowed(o);
671 if (ckWARN(WARN_VOID)) {
672 useless = "a constant";
673 /* the constants 0 and 1 are permitted as they are
674 conventionally used as dummies in constructs like
675 1 while some_condition_with_side_effects; */
676 if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
678 else if (SvPOK(sv)) {
679 /* perl4's way of mixing documentation and code
680 (before the invention of POD) was based on a
681 trick to mix nroff and perl code. The trick was
682 built upon these three nroff macros being used in
683 void context. The pink camel has the details in
684 the script wrapman near page 319. */
685 if (strnEQ(SvPVX(sv), "di", 2) ||
686 strnEQ(SvPVX(sv), "ds", 2) ||
687 strnEQ(SvPVX(sv), "ig", 2))
692 op_null(o); /* don't execute or even remember it */
696 o->op_type = OP_PREINC; /* pre-increment is faster */
697 o->op_ppaddr = PL_ppaddr[OP_PREINC];
701 o->op_type = OP_PREDEC; /* pre-decrement is faster */
702 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
709 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
714 if (o->op_flags & OPf_STACKED)
721 if (!(o->op_flags & OPf_KIDS))
730 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
737 /* all requires must return a boolean value */
738 o->op_flags &= ~OPf_WANT;
743 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
744 if (!kPMOP->op_pmreplroot)
745 deprecate_old("implicit split to @_");
749 if (useless && ckWARN(WARN_VOID))
750 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
755 Perl_listkids(pTHX_ OP *o)
758 if (o && o->op_flags & OPf_KIDS) {
759 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
766 Perl_list(pTHX_ OP *o)
770 /* assumes no premature commitment */
771 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
772 || o->op_type == OP_RETURN)
777 if ((o->op_private & OPpTARGET_MY)
778 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
780 return o; /* As if inside SASSIGN */
783 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
785 switch (o->op_type) {
788 list(cBINOPo->op_first);
793 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
801 if (!(o->op_flags & OPf_KIDS))
803 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
804 list(cBINOPo->op_first);
805 return gen_constant_list(o);
812 kid = cLISTOPo->op_first;
814 while ((kid = kid->op_sibling)) {
820 WITH_THR(PL_curcop = &PL_compiling);
824 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
830 WITH_THR(PL_curcop = &PL_compiling);
833 /* all requires must return a boolean value */
834 o->op_flags &= ~OPf_WANT;
841 Perl_scalarseq(pTHX_ OP *o)
846 if (o->op_type == OP_LINESEQ ||
847 o->op_type == OP_SCOPE ||
848 o->op_type == OP_LEAVE ||
849 o->op_type == OP_LEAVETRY)
851 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
852 if (kid->op_sibling) {
856 PL_curcop = &PL_compiling;
858 o->op_flags &= ~OPf_PARENS;
859 if (PL_hints & HINT_BLOCK_SCOPE)
860 o->op_flags |= OPf_PARENS;
863 o = newOP(OP_STUB, 0);
868 S_modkids(pTHX_ OP *o, I32 type)
871 if (o && o->op_flags & OPf_KIDS) {
872 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
879 Perl_mod(pTHX_ OP *o, I32 type)
883 if (!o || PL_error_count)
886 if ((o->op_private & OPpTARGET_MY)
887 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
892 switch (o->op_type) {
897 if (!(o->op_private & (OPpCONST_ARYBASE)))
899 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
900 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
904 SAVEI32(PL_compiling.cop_arybase);
905 PL_compiling.cop_arybase = 0;
907 else if (type == OP_REFGEN)
910 Perl_croak(aTHX_ "That use of $[ is unsupported");
913 if (o->op_flags & OPf_PARENS)
917 if ((type == OP_UNDEF || type == OP_REFGEN) &&
918 !(o->op_flags & OPf_STACKED)) {
919 o->op_type = OP_RV2CV; /* entersub => rv2cv */
920 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
921 assert(cUNOPo->op_first->op_type == OP_NULL);
922 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
925 else if (o->op_private & OPpENTERSUB_NOMOD)
927 else { /* lvalue subroutine call */
928 o->op_private |= OPpLVAL_INTRO;
929 PL_modcount = RETURN_UNLIMITED_NUMBER;
930 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
931 /* Backward compatibility mode: */
932 o->op_private |= OPpENTERSUB_INARGS;
935 else { /* Compile-time error message: */
936 OP *kid = cUNOPo->op_first;
940 if (kid->op_type == OP_PUSHMARK)
942 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
944 "panic: unexpected lvalue entersub "
945 "args: type/targ %ld:%"UVuf,
946 (long)kid->op_type, (UV)kid->op_targ);
947 kid = kLISTOP->op_first;
949 while (kid->op_sibling)
950 kid = kid->op_sibling;
951 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
953 if (kid->op_type == OP_METHOD_NAMED
954 || kid->op_type == OP_METHOD)
958 NewOp(1101, newop, 1, UNOP);
959 newop->op_type = OP_RV2CV;
960 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
961 newop->op_first = Nullop;
962 newop->op_next = (OP*)newop;
963 kid->op_sibling = (OP*)newop;
964 newop->op_private |= OPpLVAL_INTRO;
968 if (kid->op_type != OP_RV2CV)
970 "panic: unexpected lvalue entersub "
971 "entry via type/targ %ld:%"UVuf,
972 (long)kid->op_type, (UV)kid->op_targ);
973 kid->op_private |= OPpLVAL_INTRO;
974 break; /* Postpone until runtime */
978 kid = kUNOP->op_first;
979 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
980 kid = kUNOP->op_first;
981 if (kid->op_type == OP_NULL)
983 "Unexpected constant lvalue entersub "
984 "entry via type/targ %ld:%"UVuf,
985 (long)kid->op_type, (UV)kid->op_targ);
986 if (kid->op_type != OP_GV) {
987 /* Restore RV2CV to check lvalueness */
989 if (kid->op_next && kid->op_next != kid) { /* Happens? */
990 okid->op_next = kid->op_next;
994 okid->op_next = Nullop;
995 okid->op_type = OP_RV2CV;
997 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
998 okid->op_private |= OPpLVAL_INTRO;
1002 cv = GvCV(kGVOP_gv);
1012 /* grep, foreach, subcalls, refgen */
1013 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1015 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1016 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1018 : (o->op_type == OP_ENTERSUB
1019 ? "non-lvalue subroutine call"
1021 type ? PL_op_desc[type] : "local"));
1035 case OP_RIGHT_SHIFT:
1044 if (!(o->op_flags & OPf_STACKED))
1050 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1056 if (!type && cUNOPo->op_first->op_type != OP_GV)
1057 Perl_croak(aTHX_ "Can't localize through a reference");
1058 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1059 PL_modcount = RETURN_UNLIMITED_NUMBER;
1060 return o; /* Treat \(@foo) like ordinary list. */
1064 if (scalar_mod_type(o, type))
1066 ref(cUNOPo->op_first, o->op_type);
1070 if (type == OP_LEAVESUBLV)
1071 o->op_private |= OPpMAYBE_LVSUB;
1076 PL_modcount = RETURN_UNLIMITED_NUMBER;
1079 if (!type && cUNOPo->op_first->op_type != OP_GV)
1080 Perl_croak(aTHX_ "Can't localize through a reference");
1081 ref(cUNOPo->op_first, o->op_type);
1085 PL_hints |= HINT_BLOCK_SCOPE;
1096 PL_modcount = RETURN_UNLIMITED_NUMBER;
1097 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1098 return o; /* Treat \(@foo) like ordinary list. */
1099 if (scalar_mod_type(o, type))
1101 if (type == OP_LEAVESUBLV)
1102 o->op_private |= OPpMAYBE_LVSUB;
1107 { /* XXX DAPM 2002.08.25 tmp assert test */
1108 /* XXX */ assert(av_fetch(PL_comppad_name, (o->op_targ), FALSE));
1109 /* XXX */ assert(*av_fetch(PL_comppad_name, (o->op_targ), FALSE));
1111 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1112 PAD_COMPNAME_PV(o->op_targ));
1120 if (type != OP_SASSIGN)
1124 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1129 if (type == OP_LEAVESUBLV)
1130 o->op_private |= OPpMAYBE_LVSUB;
1132 pad_free(o->op_targ);
1133 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1134 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1135 if (o->op_flags & OPf_KIDS)
1136 mod(cBINOPo->op_first->op_sibling, type);
1141 ref(cBINOPo->op_first, o->op_type);
1142 if (type == OP_ENTERSUB &&
1143 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1144 o->op_private |= OPpLVAL_DEFER;
1145 if (type == OP_LEAVESUBLV)
1146 o->op_private |= OPpMAYBE_LVSUB;
1154 if (o->op_flags & OPf_KIDS)
1155 mod(cLISTOPo->op_last, type);
1159 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1161 else if (!(o->op_flags & OPf_KIDS))
1163 if (o->op_targ != OP_LIST) {
1164 mod(cBINOPo->op_first, type);
1169 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1174 if (type != OP_LEAVESUBLV)
1176 break; /* mod()ing was handled by ck_return() */
1179 /* [20011101.069] File test operators interpret OPf_REF to mean that
1180 their argument is a filehandle; thus \stat(".") should not set
1182 if (type == OP_REFGEN &&
1183 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1186 if (type != OP_LEAVESUBLV)
1187 o->op_flags |= OPf_MOD;
1189 if (type == OP_AASSIGN || type == OP_SASSIGN)
1190 o->op_flags |= OPf_SPECIAL|OPf_REF;
1192 o->op_private |= OPpLVAL_INTRO;
1193 o->op_flags &= ~OPf_SPECIAL;
1194 PL_hints |= HINT_BLOCK_SCOPE;
1196 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1197 && type != OP_LEAVESUBLV)
1198 o->op_flags |= OPf_REF;
1203 S_scalar_mod_type(pTHX_ OP *o, I32 type)
1207 if (o->op_type == OP_RV2GV)
1231 case OP_RIGHT_SHIFT:
1250 S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
1252 switch (o->op_type) {
1260 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1273 Perl_refkids(pTHX_ OP *o, I32 type)
1276 if (o && o->op_flags & OPf_KIDS) {
1277 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1284 Perl_ref(pTHX_ OP *o, I32 type)
1288 if (!o || PL_error_count)
1291 switch (o->op_type) {
1293 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1294 !(o->op_flags & OPf_STACKED)) {
1295 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1296 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1297 assert(cUNOPo->op_first->op_type == OP_NULL);
1298 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1299 o->op_flags |= OPf_SPECIAL;
1304 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1308 if (type == OP_DEFINED)
1309 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1310 ref(cUNOPo->op_first, o->op_type);
1313 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1314 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1315 : type == OP_RV2HV ? OPpDEREF_HV
1317 o->op_flags |= OPf_MOD;
1322 o->op_flags |= OPf_MOD; /* XXX ??? */
1327 o->op_flags |= OPf_REF;
1330 if (type == OP_DEFINED)
1331 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1332 ref(cUNOPo->op_first, o->op_type);
1337 o->op_flags |= OPf_REF;
1342 if (!(o->op_flags & OPf_KIDS))
1344 ref(cBINOPo->op_first, type);
1348 ref(cBINOPo->op_first, o->op_type);
1349 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1350 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1351 : type == OP_RV2HV ? OPpDEREF_HV
1353 o->op_flags |= OPf_MOD;
1361 if (!(o->op_flags & OPf_KIDS))
1363 ref(cLISTOPo->op_last, type);
1373 S_dup_attrlist(pTHX_ OP *o)
1377 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1378 * where the first kid is OP_PUSHMARK and the remaining ones
1379 * are OP_CONST. We need to push the OP_CONST values.
1381 if (o->op_type == OP_CONST)
1382 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1384 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1385 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1386 if (o->op_type == OP_CONST)
1387 rop = append_elem(OP_LIST, rop,
1388 newSVOP(OP_CONST, o->op_flags,
1389 SvREFCNT_inc(cSVOPo->op_sv)));
1396 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1400 /* fake up C<use attributes $pkg,$rv,@attrs> */
1401 ENTER; /* need to protect against side-effects of 'use' */
1404 stashsv = newSVpv(HvNAME(stash), 0);
1406 stashsv = &PL_sv_no;
1408 #define ATTRSMODULE "attributes"
1409 #define ATTRSMODULE_PM "attributes.pm"
1413 /* Don't force the C<use> if we don't need it. */
1414 svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
1415 sizeof(ATTRSMODULE_PM)-1, 0);
1416 if (svp && *svp != &PL_sv_undef)
1417 ; /* already in %INC */
1419 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1420 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1424 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1425 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1427 prepend_elem(OP_LIST,
1428 newSVOP(OP_CONST, 0, stashsv),
1429 prepend_elem(OP_LIST,
1430 newSVOP(OP_CONST, 0,
1432 dup_attrlist(attrs))));
1438 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1440 OP *pack, *imop, *arg;
1446 assert(target->op_type == OP_PADSV ||
1447 target->op_type == OP_PADHV ||
1448 target->op_type == OP_PADAV);
1450 /* Ensure that attributes.pm is loaded. */
1451 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1453 /* Need package name for method call. */
1454 pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
1456 /* Build up the real arg-list. */
1458 stashsv = newSVpv(HvNAME(stash), 0);
1460 stashsv = &PL_sv_no;
1461 arg = newOP(OP_PADSV, 0);
1462 arg->op_targ = target->op_targ;
1463 arg = prepend_elem(OP_LIST,
1464 newSVOP(OP_CONST, 0, stashsv),
1465 prepend_elem(OP_LIST,
1466 newUNOP(OP_REFGEN, 0,
1467 mod(arg, OP_REFGEN)),
1468 dup_attrlist(attrs)));
1470 /* Fake up a method call to import */
1471 meth = newSVpvn("import", 6);
1472 (void)SvUPGRADE(meth, SVt_PVIV);
1473 (void)SvIOK_on(meth);
1474 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
1475 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1476 append_elem(OP_LIST,
1477 prepend_elem(OP_LIST, pack, list(arg)),
1478 newSVOP(OP_METHOD_NAMED, 0, meth)));
1479 imop->op_private |= OPpENTERSUB_NOMOD;
1481 /* Combine the ops. */
1482 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1486 =notfor apidoc apply_attrs_string
1488 Attempts to apply a list of attributes specified by the C<attrstr> and
1489 C<len> arguments to the subroutine identified by the C<cv> argument which
1490 is expected to be associated with the package identified by the C<stashpv>
1491 argument (see L<attributes>). It gets this wrong, though, in that it
1492 does not correctly identify the boundaries of the individual attribute
1493 specifications within C<attrstr>. This is not really intended for the
1494 public API, but has to be listed here for systems such as AIX which
1495 need an explicit export list for symbols. (It's called from XS code
1496 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1497 to respect attribute syntax properly would be welcome.
1503 Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
1504 char *attrstr, STRLEN len)
1509 len = strlen(attrstr);
1513 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1515 char *sstr = attrstr;
1516 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1517 attrs = append_elem(OP_LIST, attrs,
1518 newSVOP(OP_CONST, 0,
1519 newSVpvn(sstr, attrstr-sstr)));
1523 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1524 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1525 Nullsv, prepend_elem(OP_LIST,
1526 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1527 prepend_elem(OP_LIST,
1528 newSVOP(OP_CONST, 0,
1534 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1539 if (!o || PL_error_count)
1543 if (type == OP_LIST) {
1544 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1545 my_kid(kid, attrs, imopsp);
1546 } else if (type == OP_UNDEF) {
1548 } else if (type == OP_RV2SV || /* "our" declaration */
1550 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1551 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1552 yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
1553 OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
1555 GV *gv = cGVOPx_gv(cUNOPo->op_first);
1557 PL_in_my_stash = Nullhv;
1558 apply_attrs(GvSTASH(gv),
1559 (type == OP_RV2SV ? GvSV(gv) :
1560 type == OP_RV2AV ? (SV*)GvAV(gv) :
1561 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1564 o->op_private |= OPpOUR_INTRO;
1567 else if (type != OP_PADSV &&
1570 type != OP_PUSHMARK)
1572 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1574 PL_in_my == KEY_our ? "our" : "my"));
1577 else if (attrs && type != OP_PUSHMARK) {
1581 PL_in_my_stash = Nullhv;
1583 /* check for C<my Dog $spot> when deciding package */
1584 stash = PAD_COMPNAME_TYPE(o->op_targ);
1586 stash = PL_curstash;
1587 apply_attrs_my(stash, o, attrs, imopsp);
1589 o->op_flags |= OPf_MOD;
1590 o->op_private |= OPpLVAL_INTRO;
1595 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1598 int maybe_scalar = 0;
1600 /* [perl #17376]: this appears to be premature, and results in code such as
1601 C< our(%x); > executing in list mode rather than void mode */
1603 if (o->op_flags & OPf_PARENS)
1612 o = my_kid(o, attrs, &rops);
1614 if (maybe_scalar && o->op_type == OP_PADSV) {
1615 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1616 o->op_private |= OPpLVAL_INTRO;
1619 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1622 PL_in_my_stash = Nullhv;
1627 Perl_my(pTHX_ OP *o)
1629 return my_attrs(o, Nullop);
1633 Perl_sawparens(pTHX_ OP *o)
1636 o->op_flags |= OPf_PARENS;
1641 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1645 if (ckWARN(WARN_MISC) &&
1646 (left->op_type == OP_RV2AV ||
1647 left->op_type == OP_RV2HV ||
1648 left->op_type == OP_PADAV ||
1649 left->op_type == OP_PADHV)) {
1650 char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
1651 right->op_type == OP_TRANS)
1652 ? right->op_type : OP_MATCH];
1653 const char *sample = ((left->op_type == OP_RV2AV ||
1654 left->op_type == OP_PADAV)
1655 ? "@array" : "%hash");
1656 Perl_warner(aTHX_ packWARN(WARN_MISC),
1657 "Applying %s to %s will act on scalar(%s)",
1658 desc, sample, sample);
1661 if (right->op_type == OP_CONST &&
1662 cSVOPx(right)->op_private & OPpCONST_BARE &&
1663 cSVOPx(right)->op_private & OPpCONST_STRICT)
1665 no_bareword_allowed(right);
1668 if (!(right->op_flags & OPf_STACKED) &&
1669 (right->op_type == OP_MATCH ||
1670 right->op_type == OP_SUBST ||
1671 right->op_type == OP_TRANS)) {
1672 right->op_flags |= OPf_STACKED;
1673 if (right->op_type != OP_MATCH &&
1674 ! (right->op_type == OP_TRANS &&
1675 right->op_private & OPpTRANS_IDENTICAL))
1676 left = mod(left, right->op_type);
1677 if (right->op_type == OP_TRANS)
1678 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
1680 o = prepend_elem(right->op_type, scalar(left), right);
1682 return newUNOP(OP_NOT, 0, scalar(o));
1686 return bind_match(type, left,
1687 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
1691 Perl_invert(pTHX_ OP *o)
1695 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
1696 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1700 Perl_scope(pTHX_ OP *o)
1703 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1704 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1705 o->op_type = OP_LEAVE;
1706 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1709 if (o->op_type == OP_LINESEQ) {
1711 o->op_type = OP_SCOPE;
1712 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1713 kid = ((LISTOP*)o)->op_first;
1714 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
1718 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
1725 Perl_save_hints(pTHX)
1728 SAVESPTR(GvHV(PL_hintgv));
1729 GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
1730 SAVEFREESV(GvHV(PL_hintgv));
1734 Perl_block_start(pTHX_ int full)
1736 int retval = PL_savestack_ix;
1738 pad_block_start(full);
1740 PL_hints &= ~HINT_BLOCK_SCOPE;
1741 SAVESPTR(PL_compiling.cop_warnings);
1742 if (! specialWARN(PL_compiling.cop_warnings)) {
1743 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1744 SAVEFREESV(PL_compiling.cop_warnings) ;
1746 SAVESPTR(PL_compiling.cop_io);
1747 if (! specialCopIO(PL_compiling.cop_io)) {
1748 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1749 SAVEFREESV(PL_compiling.cop_io) ;
1755 Perl_block_end(pTHX_ I32 floor, OP *seq)
1757 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1758 line_t copline = PL_copline;
1759 OP* retval = scalarseq(seq);
1761 /* scalarseq() gave us an OP_STUB */
1762 retval->op_flags |= OPf_PARENS;
1763 /* there should be a nextstate in every block */
1764 retval = newSTATEOP(0, Nullch, retval);
1765 PL_copline = copline; /* XXX newSTATEOP may reset PL_copline */
1768 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
1770 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
1778 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1782 Perl_newPROG(pTHX_ OP *o)
1787 PL_eval_root = newUNOP(OP_LEAVEEVAL,
1788 ((PL_in_eval & EVAL_KEEPERR)
1789 ? OPf_SPECIAL : 0), o);
1790 PL_eval_start = linklist(PL_eval_root);
1791 PL_eval_root->op_private |= OPpREFCOUNTED;
1792 OpREFCNT_set(PL_eval_root, 1);
1793 PL_eval_root->op_next = 0;
1794 CALL_PEEP(PL_eval_start);
1799 PL_main_root = scope(sawparens(scalarvoid(o)));
1800 PL_curcop = &PL_compiling;
1801 PL_main_start = LINKLIST(PL_main_root);
1802 PL_main_root->op_private |= OPpREFCOUNTED;
1803 OpREFCNT_set(PL_main_root, 1);
1804 PL_main_root->op_next = 0;
1805 CALL_PEEP(PL_main_start);
1808 /* Register with debugger */
1810 CV *cv = get_cv("DB::postponed", FALSE);
1814 XPUSHs((SV*)CopFILEGV(&PL_compiling));
1816 call_sv((SV*)cv, G_DISCARD);
1823 Perl_localize(pTHX_ OP *o, I32 lex)
1825 if (o->op_flags & OPf_PARENS)
1826 /* [perl #17376]: this appears to be premature, and results in code such as
1827 C< our(%x); > executing in list mode rather than void mode */
1834 if (ckWARN(WARN_PARENTHESIS)
1835 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
1837 char *s = PL_bufptr;
1839 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ", *s)))
1842 if (*s == ';' || *s == '=')
1843 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
1844 "Parentheses missing around \"%s\" list",
1845 lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
1851 o = mod(o, OP_NULL); /* a bit kludgey */
1853 PL_in_my_stash = Nullhv;
1858 Perl_jmaybe(pTHX_ OP *o)
1860 if (o->op_type == OP_LIST) {
1862 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
1863 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
1869 Perl_fold_constants(pTHX_ register OP *o)
1872 I32 type = o->op_type;
1875 if (PL_opargs[type] & OA_RETSCALAR)
1877 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
1878 o->op_targ = pad_alloc(type, SVs_PADTMP);
1880 /* integerize op, unless it happens to be C<-foo>.
1881 * XXX should pp_i_negate() do magic string negation instead? */
1882 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
1883 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
1884 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
1886 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
1889 if (!(PL_opargs[type] & OA_FOLDCONST))
1894 /* XXX might want a ck_negate() for this */
1895 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
1907 /* XXX what about the numeric ops? */
1908 if (PL_hints & HINT_LOCALE)
1913 goto nope; /* Don't try to run w/ errors */
1915 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
1916 if ((curop->op_type != OP_CONST ||
1917 (curop->op_private & OPpCONST_BARE)) &&
1918 curop->op_type != OP_LIST &&
1919 curop->op_type != OP_SCALAR &&
1920 curop->op_type != OP_NULL &&
1921 curop->op_type != OP_PUSHMARK)
1927 curop = LINKLIST(o);
1931 sv = *(PL_stack_sp--);
1932 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
1933 pad_swipe(o->op_targ, FALSE);
1934 else if (SvTEMP(sv)) { /* grab mortal temp? */
1935 (void)SvREFCNT_inc(sv);
1939 if (type == OP_RV2GV)
1940 return newGVOP(OP_GV, 0, (GV*)sv);
1942 /* try to smush double to int, but don't smush -2.0 to -2 */
1943 if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
1946 #ifdef PERL_PRESERVE_IVUV
1947 /* Only bother to attempt to fold to IV if
1948 most operators will benefit */
1952 return newSVOP(OP_CONST, 0, sv);
1960 Perl_gen_constant_list(pTHX_ register OP *o)
1963 I32 oldtmps_floor = PL_tmps_floor;
1967 return o; /* Don't attempt to run with errors */
1969 PL_op = curop = LINKLIST(o);
1976 PL_tmps_floor = oldtmps_floor;
1978 o->op_type = OP_RV2AV;
1979 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
1980 o->op_seq = 0; /* needs to be revisited in peep() */
1981 curop = ((UNOP*)o)->op_first;
1982 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
1989 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
1991 if (!o || o->op_type != OP_LIST)
1992 o = newLISTOP(OP_LIST, 0, o, Nullop);
1994 o->op_flags &= ~OPf_WANT;
1996 if (!(PL_opargs[type] & OA_MARK))
1997 op_null(cLISTOPo->op_first);
1999 o->op_type = (OPCODE)type;
2000 o->op_ppaddr = PL_ppaddr[type];
2001 o->op_flags |= flags;
2003 o = CHECKOP(type, o);
2004 if (o->op_type != type)
2007 return fold_constants(o);
2010 /* List constructors */
2013 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2021 if (first->op_type != type
2022 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2024 return newLISTOP(type, 0, first, last);
2027 if (first->op_flags & OPf_KIDS)
2028 ((LISTOP*)first)->op_last->op_sibling = last;
2030 first->op_flags |= OPf_KIDS;
2031 ((LISTOP*)first)->op_first = last;
2033 ((LISTOP*)first)->op_last = last;
2038 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2046 if (first->op_type != type)
2047 return prepend_elem(type, (OP*)first, (OP*)last);
2049 if (last->op_type != type)
2050 return append_elem(type, (OP*)first, (OP*)last);
2052 first->op_last->op_sibling = last->op_first;
2053 first->op_last = last->op_last;
2054 first->op_flags |= (last->op_flags & OPf_KIDS);
2062 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2070 if (last->op_type == type) {
2071 if (type == OP_LIST) { /* already a PUSHMARK there */
2072 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2073 ((LISTOP*)last)->op_first->op_sibling = first;
2074 if (!(first->op_flags & OPf_PARENS))
2075 last->op_flags &= ~OPf_PARENS;
2078 if (!(last->op_flags & OPf_KIDS)) {
2079 ((LISTOP*)last)->op_last = first;
2080 last->op_flags |= OPf_KIDS;
2082 first->op_sibling = ((LISTOP*)last)->op_first;
2083 ((LISTOP*)last)->op_first = first;
2085 last->op_flags |= OPf_KIDS;
2089 return newLISTOP(type, 0, first, last);
2095 Perl_newNULLLIST(pTHX)
2097 return newOP(OP_STUB, 0);
2101 Perl_force_list(pTHX_ OP *o)
2103 if (!o || o->op_type != OP_LIST)
2104 o = newLISTOP(OP_LIST, 0, o, Nullop);
2110 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2114 NewOp(1101, listop, 1, LISTOP);
2116 listop->op_type = (OPCODE)type;
2117 listop->op_ppaddr = PL_ppaddr[type];
2120 listop->op_flags = (U8)flags;
2124 else if (!first && last)
2127 first->op_sibling = last;
2128 listop->op_first = first;
2129 listop->op_last = last;
2130 if (type == OP_LIST) {
2132 pushop = newOP(OP_PUSHMARK, 0);
2133 pushop->op_sibling = first;
2134 listop->op_first = pushop;
2135 listop->op_flags |= OPf_KIDS;
2137 listop->op_last = pushop;
2144 Perl_newOP(pTHX_ I32 type, I32 flags)
2147 NewOp(1101, o, 1, OP);
2148 o->op_type = (OPCODE)type;
2149 o->op_ppaddr = PL_ppaddr[type];
2150 o->op_flags = (U8)flags;
2153 o->op_private = (U8)(0 | (flags >> 8));
2154 if (PL_opargs[type] & OA_RETSCALAR)
2156 if (PL_opargs[type] & OA_TARGET)
2157 o->op_targ = pad_alloc(type, SVs_PADTMP);
2158 return CHECKOP(type, o);
2162 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2167 first = newOP(OP_STUB, 0);
2168 if (PL_opargs[type] & OA_MARK)
2169 first = force_list(first);
2171 NewOp(1101, unop, 1, UNOP);
2172 unop->op_type = (OPCODE)type;
2173 unop->op_ppaddr = PL_ppaddr[type];
2174 unop->op_first = first;
2175 unop->op_flags = flags | OPf_KIDS;
2176 unop->op_private = (U8)(1 | (flags >> 8));
2177 unop = (UNOP*) CHECKOP(type, unop);
2181 return fold_constants((OP *) unop);
2185 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2188 NewOp(1101, binop, 1, BINOP);
2191 first = newOP(OP_NULL, 0);
2193 binop->op_type = (OPCODE)type;
2194 binop->op_ppaddr = PL_ppaddr[type];
2195 binop->op_first = first;
2196 binop->op_flags = flags | OPf_KIDS;
2199 binop->op_private = (U8)(1 | (flags >> 8));
2202 binop->op_private = (U8)(2 | (flags >> 8));
2203 first->op_sibling = last;
2206 binop = (BINOP*)CHECKOP(type, binop);
2207 if (binop->op_next || binop->op_type != (OPCODE)type)
2210 binop->op_last = binop->op_first->op_sibling;
2212 return fold_constants((OP *)binop);
2216 uvcompare(const void *a, const void *b)
2218 if (*((UV *)a) < (*(UV *)b))
2220 if (*((UV *)a) > (*(UV *)b))
2222 if (*((UV *)a+1) < (*(UV *)b+1))
2224 if (*((UV *)a+1) > (*(UV *)b+1))
2230 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2232 SV *tstr = ((SVOP*)expr)->op_sv;
2233 SV *rstr = ((SVOP*)repl)->op_sv;
2236 U8 *t = (U8*)SvPV(tstr, tlen);
2237 U8 *r = (U8*)SvPV(rstr, rlen);
2244 register short *tbl;
2246 PL_hints |= HINT_BLOCK_SCOPE;
2247 complement = o->op_private & OPpTRANS_COMPLEMENT;
2248 del = o->op_private & OPpTRANS_DELETE;
2249 squash = o->op_private & OPpTRANS_SQUASH;
2252 o->op_private |= OPpTRANS_FROM_UTF;
2255 o->op_private |= OPpTRANS_TO_UTF;
2257 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2258 SV* listsv = newSVpvn("# comment\n",10);
2260 U8* tend = t + tlen;
2261 U8* rend = r + rlen;
2275 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2276 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2282 tsave = t = bytes_to_utf8(t, &len);
2285 if (!to_utf && rlen) {
2287 rsave = r = bytes_to_utf8(r, &len);
2291 /* There are several snags with this code on EBCDIC:
2292 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2293 2. scan_const() in toke.c has encoded chars in native encoding which makes
2294 ranges at least in EBCDIC 0..255 range the bottom odd.
2298 U8 tmpbuf[UTF8_MAXLEN+1];
2301 New(1109, cp, 2*tlen, UV);
2303 transv = newSVpvn("",0);
2305 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2307 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2309 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2313 cp[2*i+1] = cp[2*i];
2317 qsort(cp, i, 2*sizeof(UV), uvcompare);
2318 for (j = 0; j < i; j++) {
2320 diff = val - nextmin;
2322 t = uvuni_to_utf8(tmpbuf,nextmin);
2323 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2325 U8 range_mark = UTF_TO_NATIVE(0xff);
2326 t = uvuni_to_utf8(tmpbuf, val - 1);
2327 sv_catpvn(transv, (char *)&range_mark, 1);
2328 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2335 t = uvuni_to_utf8(tmpbuf,nextmin);
2336 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2338 U8 range_mark = UTF_TO_NATIVE(0xff);
2339 sv_catpvn(transv, (char *)&range_mark, 1);
2341 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2342 UNICODE_ALLOW_SUPER);
2343 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2344 t = (U8*)SvPVX(transv);
2345 tlen = SvCUR(transv);
2349 else if (!rlen && !del) {
2350 r = t; rlen = tlen; rend = tend;
2353 if ((!rlen && !del) || t == r ||
2354 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2356 o->op_private |= OPpTRANS_IDENTICAL;
2360 while (t < tend || tfirst <= tlast) {
2361 /* see if we need more "t" chars */
2362 if (tfirst > tlast) {
2363 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2365 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2367 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2374 /* now see if we need more "r" chars */
2375 if (rfirst > rlast) {
2377 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2379 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2381 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2390 rfirst = rlast = 0xffffffff;
2394 /* now see which range will peter our first, if either. */
2395 tdiff = tlast - tfirst;
2396 rdiff = rlast - rfirst;
2403 if (rfirst == 0xffffffff) {
2404 diff = tdiff; /* oops, pretend rdiff is infinite */
2406 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2407 (long)tfirst, (long)tlast);
2409 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2413 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2414 (long)tfirst, (long)(tfirst + diff),
2417 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2418 (long)tfirst, (long)rfirst);
2420 if (rfirst + diff > max)
2421 max = rfirst + diff;
2423 grows = (tfirst < rfirst &&
2424 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2436 else if (max > 0xff)
2441 Safefree(cPVOPo->op_pv);
2442 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2443 SvREFCNT_dec(listsv);
2445 SvREFCNT_dec(transv);
2447 if (!del && havefinal && rlen)
2448 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2449 newSVuv((UV)final), 0);
2452 o->op_private |= OPpTRANS_GROWS;
2464 tbl = (short*)cPVOPo->op_pv;
2466 Zero(tbl, 256, short);
2467 for (i = 0; i < (I32)tlen; i++)
2469 for (i = 0, j = 0; i < 256; i++) {
2471 if (j >= (I32)rlen) {
2480 if (i < 128 && r[j] >= 128)
2490 o->op_private |= OPpTRANS_IDENTICAL;
2492 else if (j >= (I32)rlen)
2495 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2496 tbl[0x100] = rlen - j;
2497 for (i=0; i < (I32)rlen - j; i++)
2498 tbl[0x101+i] = r[j+i];
2502 if (!rlen && !del) {
2505 o->op_private |= OPpTRANS_IDENTICAL;
2507 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2508 o->op_private |= OPpTRANS_IDENTICAL;
2510 for (i = 0; i < 256; i++)
2512 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
2513 if (j >= (I32)rlen) {
2515 if (tbl[t[i]] == -1)
2521 if (tbl[t[i]] == -1) {
2522 if (t[i] < 128 && r[j] >= 128)
2529 o->op_private |= OPpTRANS_GROWS;
2537 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2541 NewOp(1101, pmop, 1, PMOP);
2542 pmop->op_type = (OPCODE)type;
2543 pmop->op_ppaddr = PL_ppaddr[type];
2544 pmop->op_flags = (U8)flags;
2545 pmop->op_private = (U8)(0 | (flags >> 8));
2547 if (PL_hints & HINT_RE_TAINT)
2548 pmop->op_pmpermflags |= PMf_RETAINT;
2549 if (PL_hints & HINT_LOCALE)
2550 pmop->op_pmpermflags |= PMf_LOCALE;
2551 pmop->op_pmflags = pmop->op_pmpermflags;
2556 if(av_len((AV*) PL_regex_pad[0]) > -1) {
2557 repointer = av_pop((AV*)PL_regex_pad[0]);
2558 pmop->op_pmoffset = SvIV(repointer);
2559 SvREPADTMP_off(repointer);
2560 sv_setiv(repointer,0);
2562 repointer = newSViv(0);
2563 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2564 pmop->op_pmoffset = av_len(PL_regex_padav);
2565 PL_regex_pad = AvARRAY(PL_regex_padav);
2570 /* link into pm list */
2571 if (type != OP_TRANS && PL_curstash) {
2572 pmop->op_pmnext = HvPMROOT(PL_curstash);
2573 HvPMROOT(PL_curstash) = pmop;
2574 PmopSTASH_set(pmop,PL_curstash);
2581 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
2585 I32 repl_has_vars = 0;
2587 if (o->op_type == OP_TRANS)
2588 return pmtrans(o, expr, repl);
2590 PL_hints |= HINT_BLOCK_SCOPE;
2593 if (expr->op_type == OP_CONST) {
2595 SV *pat = ((SVOP*)expr)->op_sv;
2596 char *p = SvPV(pat, plen);
2597 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
2598 sv_setpvn(pat, "\\s+", 3);
2599 p = SvPV(pat, plen);
2600 pm->op_pmflags |= PMf_SKIPWHITE;
2603 pm->op_pmdynflags |= PMdf_UTF8;
2604 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
2605 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
2606 pm->op_pmflags |= PMf_WHITE;
2610 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2611 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2613 : OP_REGCMAYBE),0,expr);
2615 NewOp(1101, rcop, 1, LOGOP);
2616 rcop->op_type = OP_REGCOMP;
2617 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2618 rcop->op_first = scalar(expr);
2619 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
2620 ? (OPf_SPECIAL | OPf_KIDS)
2622 rcop->op_private = 1;
2625 /* establish postfix order */
2626 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2628 rcop->op_next = expr;
2629 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2632 rcop->op_next = LINKLIST(expr);
2633 expr->op_next = (OP*)rcop;
2636 prepend_elem(o->op_type, scalar((OP*)rcop), o);
2641 if (pm->op_pmflags & PMf_EVAL) {
2643 if (CopLINE(PL_curcop) < PL_multi_end)
2644 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
2646 else if (repl->op_type == OP_CONST)
2650 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
2651 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
2652 if (curop->op_type == OP_GV) {
2653 GV *gv = cGVOPx_gv(curop);
2655 if (strchr("&`'123456789+", *GvENAME(gv)))
2658 else if (curop->op_type == OP_RV2CV)
2660 else if (curop->op_type == OP_RV2SV ||
2661 curop->op_type == OP_RV2AV ||
2662 curop->op_type == OP_RV2HV ||
2663 curop->op_type == OP_RV2GV) {
2664 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2667 else if (curop->op_type == OP_PADSV ||
2668 curop->op_type == OP_PADAV ||
2669 curop->op_type == OP_PADHV ||
2670 curop->op_type == OP_PADANY) {
2673 else if (curop->op_type == OP_PUSHRE)
2674 ; /* Okay here, dangerous in newASSIGNOP */
2684 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
2685 pm->op_pmflags |= PMf_CONST; /* const for long enough */
2686 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
2687 prepend_elem(o->op_type, scalar(repl), o);
2690 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
2691 pm->op_pmflags |= PMf_MAYBE_CONST;
2692 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2694 NewOp(1101, rcop, 1, LOGOP);
2695 rcop->op_type = OP_SUBSTCONT;
2696 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
2697 rcop->op_first = scalar(repl);
2698 rcop->op_flags |= OPf_KIDS;
2699 rcop->op_private = 1;
2702 /* establish postfix order */
2703 rcop->op_next = LINKLIST(repl);
2704 repl->op_next = (OP*)rcop;
2706 pm->op_pmreplroot = scalar((OP*)rcop);
2707 pm->op_pmreplstart = LINKLIST(rcop);
2716 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
2719 NewOp(1101, svop, 1, SVOP);
2720 svop->op_type = (OPCODE)type;
2721 svop->op_ppaddr = PL_ppaddr[type];
2723 svop->op_next = (OP*)svop;
2724 svop->op_flags = (U8)flags;
2725 if (PL_opargs[type] & OA_RETSCALAR)
2727 if (PL_opargs[type] & OA_TARGET)
2728 svop->op_targ = pad_alloc(type, SVs_PADTMP);
2729 return CHECKOP(type, svop);
2733 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2736 NewOp(1101, padop, 1, PADOP);
2737 padop->op_type = (OPCODE)type;
2738 padop->op_ppaddr = PL_ppaddr[type];
2739 padop->op_padix = pad_alloc(type, SVs_PADTMP);
2740 SvREFCNT_dec(PAD_SVl(padop->op_padix));
2741 PAD_SETSV(padop->op_padix, sv);
2744 padop->op_next = (OP*)padop;
2745 padop->op_flags = (U8)flags;
2746 if (PL_opargs[type] & OA_RETSCALAR)
2748 if (PL_opargs[type] & OA_TARGET)
2749 padop->op_targ = pad_alloc(type, SVs_PADTMP);
2750 return CHECKOP(type, padop);
2754 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
2759 return newPADOP(type, flags, SvREFCNT_inc(gv));
2761 return newSVOP(type, flags, SvREFCNT_inc(gv));
2766 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
2769 NewOp(1101, pvop, 1, PVOP);
2770 pvop->op_type = (OPCODE)type;
2771 pvop->op_ppaddr = PL_ppaddr[type];
2773 pvop->op_next = (OP*)pvop;
2774 pvop->op_flags = (U8)flags;
2775 if (PL_opargs[type] & OA_RETSCALAR)
2777 if (PL_opargs[type] & OA_TARGET)
2778 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
2779 return CHECKOP(type, pvop);
2783 Perl_package(pTHX_ OP *o)
2788 save_hptr(&PL_curstash);
2789 save_item(PL_curstname);
2791 name = SvPV(cSVOPo->op_sv, len);
2792 PL_curstash = gv_stashpvn(name, len, TRUE);
2793 sv_setpvn(PL_curstname, name, len);
2796 PL_hints |= HINT_BLOCK_SCOPE;
2797 PL_copline = NOLINE;
2802 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
2808 if (id->op_type != OP_CONST)
2809 Perl_croak(aTHX_ "Module name must be constant");
2813 if (version != Nullop) {
2814 SV *vesv = ((SVOP*)version)->op_sv;
2816 if (arg == Nullop && !SvNIOKp(vesv)) {
2823 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
2824 Perl_croak(aTHX_ "Version number must be constant number");
2826 /* Make copy of id so we don't free it twice */
2827 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
2829 /* Fake up a method call to VERSION */
2830 meth = newSVpvn("VERSION",7);
2831 sv_upgrade(meth, SVt_PVIV);
2832 (void)SvIOK_on(meth);
2833 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
2834 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2835 append_elem(OP_LIST,
2836 prepend_elem(OP_LIST, pack, list(version)),
2837 newSVOP(OP_METHOD_NAMED, 0, meth)));
2841 /* Fake up an import/unimport */
2842 if (arg && arg->op_type == OP_STUB)
2843 imop = arg; /* no import on explicit () */
2844 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
2845 imop = Nullop; /* use 5.0; */
2850 /* Make copy of id so we don't free it twice */
2851 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
2853 /* Fake up a method call to import/unimport */
2854 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);
2855 (void)SvUPGRADE(meth, SVt_PVIV);
2856 (void)SvIOK_on(meth);
2857 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
2858 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2859 append_elem(OP_LIST,
2860 prepend_elem(OP_LIST, pack, list(arg)),
2861 newSVOP(OP_METHOD_NAMED, 0, meth)));
2864 /* Fake up the BEGIN {}, which does its thing immediately. */
2866 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
2869 append_elem(OP_LINESEQ,
2870 append_elem(OP_LINESEQ,
2871 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, id)),
2872 newSTATEOP(0, Nullch, veop)),
2873 newSTATEOP(0, Nullch, imop) ));
2875 /* The "did you use incorrect case?" warning used to be here.
2876 * The problem is that on case-insensitive filesystems one
2877 * might get false positives for "use" (and "require"):
2878 * "use Strict" or "require CARP" will work. This causes
2879 * portability problems for the script: in case-strict
2880 * filesystems the script will stop working.
2882 * The "incorrect case" warning checked whether "use Foo"
2883 * imported "Foo" to your namespace, but that is wrong, too:
2884 * there is no requirement nor promise in the language that
2885 * a Foo.pm should or would contain anything in package "Foo".
2887 * There is very little Configure-wise that can be done, either:
2888 * the case-sensitivity of the build filesystem of Perl does not
2889 * help in guessing the case-sensitivity of the runtime environment.
2892 PL_hints |= HINT_BLOCK_SCOPE;
2893 PL_copline = NOLINE;
2898 =head1 Embedding Functions
2900 =for apidoc load_module
2902 Loads the module whose name is pointed to by the string part of name.
2903 Note that the actual module name, not its filename, should be given.
2904 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
2905 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
2906 (or 0 for no flags). ver, if specified, provides version semantics
2907 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
2908 arguments can be used to specify arguments to the module's import()
2909 method, similar to C<use Foo::Bar VERSION LIST>.
2914 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
2917 va_start(args, ver);
2918 vload_module(flags, name, ver, &args);
2922 #ifdef PERL_IMPLICIT_CONTEXT
2924 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
2928 va_start(args, ver);
2929 vload_module(flags, name, ver, &args);
2935 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
2937 OP *modname, *veop, *imop;
2939 modname = newSVOP(OP_CONST, 0, name);
2940 modname->op_private |= OPpCONST_BARE;
2942 veop = newSVOP(OP_CONST, 0, ver);
2946 if (flags & PERL_LOADMOD_NOIMPORT) {
2947 imop = sawparens(newNULLLIST());
2949 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
2950 imop = va_arg(*args, OP*);
2955 sv = va_arg(*args, SV*);
2957 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
2958 sv = va_arg(*args, SV*);
2962 line_t ocopline = PL_copline;
2963 int oexpect = PL_expect;
2965 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
2966 veop, modname, imop);
2967 PL_expect = oexpect;
2968 PL_copline = ocopline;
2973 Perl_dofile(pTHX_ OP *term)
2978 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
2979 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
2980 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
2982 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
2983 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
2984 append_elem(OP_LIST, term,
2985 scalar(newUNOP(OP_RV2CV, 0,
2990 doop = newUNOP(OP_DOFILE, 0, scalar(term));
2996 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
2998 return newBINOP(OP_LSLICE, flags,
2999 list(force_list(subscript)),
3000 list(force_list(listval)) );
3004 S_list_assignment(pTHX_ register OP *o)
3009 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3010 o = cUNOPo->op_first;
3012 if (o->op_type == OP_COND_EXPR) {
3013 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3014 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3019 yyerror("Assignment to both a list and a scalar");
3023 if (o->op_type == OP_LIST &&
3024 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3025 o->op_private & OPpLVAL_INTRO)
3028 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3029 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3030 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3033 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3036 if (o->op_type == OP_RV2SV)
3043 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3048 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3049 return newLOGOP(optype, 0,
3050 mod(scalar(left), optype),
3051 newUNOP(OP_SASSIGN, 0, scalar(right)));
3054 return newBINOP(optype, OPf_STACKED,
3055 mod(scalar(left), optype), scalar(right));
3059 if (list_assignment(left)) {
3063 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3064 left = mod(left, OP_AASSIGN);
3072 curop = list(force_list(left));
3073 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3074 o->op_private = (U8)(0 | (flags >> 8));
3076 /* PL_generation sorcery:
3077 * an assignment like ($a,$b) = ($c,$d) is easier than
3078 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3079 * To detect whether there are common vars, the global var
3080 * PL_generation is incremented for each assign op we compile.
3081 * Then, while compiling the assign op, we run through all the
3082 * variables on both sides of the assignment, setting a spare slot
3083 * in each of them to PL_generation. If any of them already have
3084 * that value, we know we've got commonality. We could use a
3085 * single bit marker, but then we'd have to make 2 passes, first
3086 * to clear the flag, then to test and set it. To find somewhere
3087 * to store these values, evil chicanery is done with SvCUR().
3090 if (!(left->op_private & OPpLVAL_INTRO)) {
3093 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3094 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3095 if (curop->op_type == OP_GV) {
3096 GV *gv = cGVOPx_gv(curop);
3097 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3099 SvCUR(gv) = PL_generation;
3101 else if (curop->op_type == OP_PADSV ||
3102 curop->op_type == OP_PADAV ||
3103 curop->op_type == OP_PADHV ||
3104 curop->op_type == OP_PADANY)
3106 if (PAD_COMPNAME_GEN(curop->op_targ)
3109 PAD_COMPNAME_GEN(curop->op_targ)
3113 else if (curop->op_type == OP_RV2CV)
3115 else if (curop->op_type == OP_RV2SV ||
3116 curop->op_type == OP_RV2AV ||
3117 curop->op_type == OP_RV2HV ||
3118 curop->op_type == OP_RV2GV) {
3119 if (lastop->op_type != OP_GV) /* funny deref? */
3122 else if (curop->op_type == OP_PUSHRE) {
3123 if (((PMOP*)curop)->op_pmreplroot) {
3125 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3126 ((PMOP*)curop)->op_pmreplroot));
3128 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3130 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3132 SvCUR(gv) = PL_generation;
3141 o->op_private |= OPpASSIGN_COMMON;
3143 if (right && right->op_type == OP_SPLIT) {
3145 if ((tmpop = ((LISTOP*)right)->op_first) &&
3146 tmpop->op_type == OP_PUSHRE)
3148 PMOP *pm = (PMOP*)tmpop;
3149 if (left->op_type == OP_RV2AV &&
3150 !(left->op_private & OPpLVAL_INTRO) &&
3151 !(o->op_private & OPpASSIGN_COMMON) )
3153 tmpop = ((UNOP*)left)->op_first;
3154 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3156 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3157 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3159 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3160 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3162 pm->op_pmflags |= PMf_ONCE;
3163 tmpop = cUNOPo->op_first; /* to list (nulled) */
3164 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3165 tmpop->op_sibling = Nullop; /* don't free split */
3166 right->op_next = tmpop->op_next; /* fix starting loc */
3167 op_free(o); /* blow off assign */
3168 right->op_flags &= ~OPf_WANT;
3169 /* "I don't know and I don't care." */
3174 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3175 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3177 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3179 sv_setiv(sv, PL_modcount+1);
3187 right = newOP(OP_UNDEF, 0);
3188 if (right->op_type == OP_READLINE) {
3189 right->op_flags |= OPf_STACKED;
3190 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3193 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3194 o = newBINOP(OP_SASSIGN, flags,
3195 scalar(right), mod(scalar(left), OP_SASSIGN) );
3207 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3209 U32 seq = intro_my();
3212 NewOp(1101, cop, 1, COP);
3213 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3214 cop->op_type = OP_DBSTATE;
3215 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3218 cop->op_type = OP_NEXTSTATE;
3219 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3221 cop->op_flags = (U8)flags;
3222 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3224 cop->op_private |= NATIVE_HINTS;
3226 PL_compiling.op_private = cop->op_private;
3227 cop->op_next = (OP*)cop;
3230 cop->cop_label = label;
3231 PL_hints |= HINT_BLOCK_SCOPE;
3234 cop->cop_arybase = PL_curcop->cop_arybase;
3235 if (specialWARN(PL_curcop->cop_warnings))
3236 cop->cop_warnings = PL_curcop->cop_warnings ;
3238 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3239 if (specialCopIO(PL_curcop->cop_io))
3240 cop->cop_io = PL_curcop->cop_io;
3242 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3245 if (PL_copline == NOLINE)
3246 CopLINE_set(cop, CopLINE(PL_curcop));
3248 CopLINE_set(cop, PL_copline);
3249 PL_copline = NOLINE;
3252 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3254 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3256 CopSTASH_set(cop, PL_curstash);
3258 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3259 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3260 if (svp && *svp != &PL_sv_undef ) {
3261 (void)SvIOK_on(*svp);
3262 SvIVX(*svp) = PTR2IV(cop);
3266 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3271 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3273 return new_logop(type, flags, &first, &other);
3277 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3281 OP *first = *firstp;
3282 OP *other = *otherp;
3284 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3285 return newBINOP(type, flags, scalar(first), scalar(other));
3287 scalarboolean(first);
3288 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3289 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3290 if (type == OP_AND || type == OP_OR) {
3296 first = *firstp = cUNOPo->op_first;
3298 first->op_next = o->op_next;
3299 cUNOPo->op_first = Nullop;
3303 if (first->op_type == OP_CONST) {
3304 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE)) {
3305 if (first->op_private & OPpCONST_STRICT)
3306 no_bareword_allowed(first);
3308 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3310 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3321 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3322 OP *k1 = ((UNOP*)first)->op_first;
3323 OP *k2 = k1->op_sibling;
3325 switch (first->op_type)
3328 if (k2 && k2->op_type == OP_READLINE
3329 && (k2->op_flags & OPf_STACKED)
3330 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3332 warnop = k2->op_type;
3337 if (k1->op_type == OP_READDIR
3338 || k1->op_type == OP_GLOB
3339 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3340 || k1->op_type == OP_EACH)
3342 warnop = ((k1->op_type == OP_NULL)
3343 ? (OPCODE)k1->op_targ : k1->op_type);
3348 line_t oldline = CopLINE(PL_curcop);
3349 CopLINE_set(PL_curcop, PL_copline);
3350 Perl_warner(aTHX_ packWARN(WARN_MISC),
3351 "Value of %s%s can be \"0\"; test with defined()",
3353 ((warnop == OP_READLINE || warnop == OP_GLOB)
3354 ? " construct" : "() operator"));
3355 CopLINE_set(PL_curcop, oldline);
3362 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3363 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3365 NewOp(1101, logop, 1, LOGOP);
3367 logop->op_type = (OPCODE)type;
3368 logop->op_ppaddr = PL_ppaddr[type];
3369 logop->op_first = first;
3370 logop->op_flags = flags | OPf_KIDS;
3371 logop->op_other = LINKLIST(other);
3372 logop->op_private = (U8)(1 | (flags >> 8));
3374 /* establish postfix order */
3375 logop->op_next = LINKLIST(first);
3376 first->op_next = (OP*)logop;
3377 first->op_sibling = other;
3379 o = newUNOP(OP_NULL, 0, (OP*)logop);
3386 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3393 return newLOGOP(OP_AND, 0, first, trueop);
3395 return newLOGOP(OP_OR, 0, first, falseop);
3397 scalarboolean(first);
3398 if (first->op_type == OP_CONST) {
3399 if (first->op_private & OPpCONST_BARE &&
3400 first->op_private & OPpCONST_STRICT) {
3401 no_bareword_allowed(first);
3403 if (SvTRUE(((SVOP*)first)->op_sv)) {
3414 NewOp(1101, logop, 1, LOGOP);
3415 logop->op_type = OP_COND_EXPR;
3416 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3417 logop->op_first = first;
3418 logop->op_flags = flags | OPf_KIDS;
3419 logop->op_private = (U8)(1 | (flags >> 8));
3420 logop->op_other = LINKLIST(trueop);
3421 logop->op_next = LINKLIST(falseop);
3424 /* establish postfix order */
3425 start = LINKLIST(first);
3426 first->op_next = (OP*)logop;
3428 first->op_sibling = trueop;
3429 trueop->op_sibling = falseop;
3430 o = newUNOP(OP_NULL, 0, (OP*)logop);
3432 trueop->op_next = falseop->op_next = o;
3439 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3447 NewOp(1101, range, 1, LOGOP);
3449 range->op_type = OP_RANGE;
3450 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3451 range->op_first = left;
3452 range->op_flags = OPf_KIDS;
3453 leftstart = LINKLIST(left);
3454 range->op_other = LINKLIST(right);
3455 range->op_private = (U8)(1 | (flags >> 8));
3457 left->op_sibling = right;
3459 range->op_next = (OP*)range;
3460 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3461 flop = newUNOP(OP_FLOP, 0, flip);
3462 o = newUNOP(OP_NULL, 0, flop);
3464 range->op_next = leftstart;
3466 left->op_next = flip;
3467 right->op_next = flop;
3469 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3470 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3471 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3472 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3474 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3475 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3478 if (!flip->op_private || !flop->op_private)
3479 linklist(o); /* blow off optimizer unless constant */
3485 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3489 int once = block && block->op_flags & OPf_SPECIAL &&
3490 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3493 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3494 return block; /* do {} while 0 does once */
3495 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3496 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3497 expr = newUNOP(OP_DEFINED, 0,
3498 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3499 } else if (expr->op_flags & OPf_KIDS) {
3500 OP *k1 = ((UNOP*)expr)->op_first;
3501 OP *k2 = (k1) ? k1->op_sibling : NULL;
3502 switch (expr->op_type) {
3504 if (k2 && k2->op_type == OP_READLINE
3505 && (k2->op_flags & OPf_STACKED)
3506 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3507 expr = newUNOP(OP_DEFINED, 0, expr);
3511 if (k1->op_type == OP_READDIR
3512 || k1->op_type == OP_GLOB
3513 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3514 || k1->op_type == OP_EACH)
3515 expr = newUNOP(OP_DEFINED, 0, expr);
3521 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3522 o = new_logop(OP_AND, 0, &expr, &listop);
3525 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3527 if (once && o != listop)
3528 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3531 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3533 o->op_flags |= flags;
3535 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3540 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3548 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3549 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3550 expr = newUNOP(OP_DEFINED, 0,
3551 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3552 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3553 OP *k1 = ((UNOP*)expr)->op_first;
3554 OP *k2 = (k1) ? k1->op_sibling : NULL;
3555 switch (expr->op_type) {
3557 if (k2 && k2->op_type == OP_READLINE
3558 && (k2->op_flags & OPf_STACKED)
3559 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3560 expr = newUNOP(OP_DEFINED, 0, expr);
3564 if (k1->op_type == OP_READDIR
3565 || k1->op_type == OP_GLOB
3566 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3567 || k1->op_type == OP_EACH)
3568 expr = newUNOP(OP_DEFINED, 0, expr);
3574 block = newOP(OP_NULL, 0);
3576 block = scope(block);
3580 next = LINKLIST(cont);
3583 OP *unstack = newOP(OP_UNSTACK, 0);
3586 cont = append_elem(OP_LINESEQ, cont, unstack);
3587 if ((line_t)whileline != NOLINE) {
3588 PL_copline = (line_t)whileline;
3589 cont = append_elem(OP_LINESEQ, cont,
3590 newSTATEOP(0, Nullch, Nullop));
3594 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3595 redo = LINKLIST(listop);
3598 PL_copline = (line_t)whileline;
3600 o = new_logop(OP_AND, 0, &expr, &listop);
3601 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3602 op_free(expr); /* oops, it's a while (0) */
3604 return Nullop; /* listop already freed by new_logop */
3607 ((LISTOP*)listop)->op_last->op_next =
3608 (o == listop ? redo : LINKLIST(o));
3614 NewOp(1101,loop,1,LOOP);
3615 loop->op_type = OP_ENTERLOOP;
3616 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3617 loop->op_private = 0;
3618 loop->op_next = (OP*)loop;
3621 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3623 loop->op_redoop = redo;
3624 loop->op_lastop = o;
3625 o->op_private |= loopflags;
3628 loop->op_nextop = next;
3630 loop->op_nextop = o;
3632 o->op_flags |= flags;
3633 o->op_private |= (flags >> 8);
3638 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
3642 PADOFFSET padoff = 0;
3646 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
3647 sv->op_type = OP_RV2GV;
3648 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3650 else if (sv->op_type == OP_PADSV) { /* private variable */
3651 padoff = sv->op_targ;
3656 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3657 padoff = sv->op_targ;
3659 iterflags |= OPf_SPECIAL;
3664 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3667 sv = newGVOP(OP_GV, 0, PL_defgv);
3669 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3670 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3671 iterflags |= OPf_STACKED;
3673 else if (expr->op_type == OP_NULL &&
3674 (expr->op_flags & OPf_KIDS) &&
3675 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3677 /* Basically turn for($x..$y) into the same as for($x,$y), but we
3678 * set the STACKED flag to indicate that these values are to be
3679 * treated as min/max values by 'pp_iterinit'.
3681 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
3682 LOGOP* range = (LOGOP*) flip->op_first;
3683 OP* left = range->op_first;
3684 OP* right = left->op_sibling;
3687 range->op_flags &= ~OPf_KIDS;
3688 range->op_first = Nullop;
3690 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
3691 listop->op_first->op_next = range->op_next;
3692 left->op_next = range->op_other;
3693 right->op_next = (OP*)listop;
3694 listop->op_next = listop->op_first;
3697 expr = (OP*)(listop);
3699 iterflags |= OPf_STACKED;
3702 expr = mod(force_list(expr), OP_GREPSTART);
3706 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
3707 append_elem(OP_LIST, expr, scalar(sv))));
3708 assert(!loop->op_next);
3709 #ifdef PL_OP_SLAB_ALLOC
3712 NewOp(1234,tmp,1,LOOP);
3713 Copy(loop,tmp,1,LOOP);
3718 Renew(loop, 1, LOOP);
3720 loop->op_targ = padoff;
3721 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
3722 PL_copline = forline;
3723 return newSTATEOP(0, label, wop);
3727 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
3732 if (type != OP_GOTO || label->op_type == OP_CONST) {
3733 /* "last()" means "last" */
3734 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
3735 o = newOP(type, OPf_SPECIAL);
3737 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
3738 ? SvPVx(((SVOP*)label)->op_sv, n_a)
3744 if (label->op_type == OP_ENTERSUB)
3745 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
3746 o = newUNOP(type, OPf_STACKED, label);
3748 PL_hints |= HINT_BLOCK_SCOPE;
3753 Perl_cv_undef(pTHX_ CV *cv)
3756 CV *freecv = Nullcv;
3759 if (CvFILE(cv) && !CvXSUB(cv)) {
3760 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
3761 Safefree(CvFILE(cv));
3766 if (!CvXSUB(cv) && CvROOT(cv)) {
3768 Perl_croak(aTHX_ "Can't undef active subroutine");
3771 PAD_SAVE_SETNULLPAD();
3773 op_free(CvROOT(cv));
3774 CvROOT(cv) = Nullop;
3777 SvPOK_off((SV*)cv); /* forget prototype */
3779 outsidecv = CvOUTSIDE(cv);
3780 /* Since closure prototypes have the same lifetime as the containing
3781 * CV, they don't hold a refcount on the outside CV. This avoids
3782 * the refcount loop between the outer CV (which keeps a refcount to
3783 * the closure prototype in the pad entry for pp_anoncode()) and the
3784 * closure prototype, and the ensuing memory leak. --GSAR */
3785 if (!CvANON(cv) || CvCLONED(cv))
3787 CvOUTSIDE(cv) = Nullcv;
3789 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
3792 pad_undef(cv, outsidecv);
3794 SvREFCNT_dec(freecv);
3802 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
3804 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
3805 SV* msg = sv_newmortal();
3809 gv_efullname3(name = sv_newmortal(), gv, Nullch);
3810 sv_setpv(msg, "Prototype mismatch:");
3812 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
3814 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
3815 sv_catpv(msg, " vs ");
3817 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
3819 sv_catpv(msg, "none");
3820 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
3824 static void const_sv_xsub(pTHX_ CV* cv);
3828 =head1 Optree Manipulation Functions
3830 =for apidoc cv_const_sv
3832 If C<cv> is a constant sub eligible for inlining. returns the constant
3833 value returned by the sub. Otherwise, returns NULL.
3835 Constant subs can be created with C<newCONSTSUB> or as described in
3836 L<perlsub/"Constant Functions">.
3841 Perl_cv_const_sv(pTHX_ CV *cv)
3843 if (!cv || !CvCONST(cv))
3845 return (SV*)CvXSUBANY(cv).any_ptr;
3849 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
3856 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
3857 o = cLISTOPo->op_first->op_sibling;
3859 for (; o; o = o->op_next) {
3860 OPCODE type = o->op_type;
3862 if (sv && o->op_next == o)
3864 if (o->op_next != o) {
3865 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
3867 if (type == OP_DBSTATE)
3870 if (type == OP_LEAVESUB || type == OP_RETURN)
3874 if (type == OP_CONST && cSVOPo->op_sv)
3876 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
3877 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
3881 /* We get here only from cv_clone2() while creating a closure.
3882 Copy the const value here instead of in cv_clone2 so that
3883 SvREADONLY_on doesn't lead to problems when leaving
3888 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
3900 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
3910 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
3914 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
3916 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
3920 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
3926 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
3930 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
3931 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
3932 SV *sv = sv_newmortal();
3933 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
3934 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
3935 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3940 gv = gv_fetchpv(name ? name : (aname ? aname :
3941 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__")),
3942 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
3952 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
3953 maximum a prototype before. */
3954 if (SvTYPE(gv) > SVt_NULL) {
3955 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
3956 && ckWARN_d(WARN_PROTOTYPE))
3958 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
3960 cv_ckproto((CV*)gv, NULL, ps);
3963 sv_setpv((SV*)gv, ps);
3965 sv_setiv((SV*)gv, -1);
3966 SvREFCNT_dec(PL_compcv);
3967 cv = PL_compcv = NULL;
3968 PL_sub_generation++;
3972 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
3974 #ifdef GV_UNIQUE_CHECK
3975 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
3976 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
3980 if (!block || !ps || *ps || attrs)
3983 const_sv = op_const_sv(block, Nullcv);
3986 bool exists = CvROOT(cv) || CvXSUB(cv);
3988 #ifdef GV_UNIQUE_CHECK
3989 if (exists && GvUNIQUE(gv)) {
3990 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
3994 /* if the subroutine doesn't exist and wasn't pre-declared
3995 * with a prototype, assume it will be AUTOLOADed,
3996 * skipping the prototype check
3998 if (exists || SvPOK(cv))
3999 cv_ckproto(cv, gv, ps);
4000 /* already defined (or promised)? */
4001 if (exists || GvASSUMECV(gv)) {
4002 if (!block && !attrs) {
4003 if (CvFLAGS(PL_compcv)) {
4004 /* might have had built-in attrs applied */
4005 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4007 /* just a "sub foo;" when &foo is already defined */
4008 SAVEFREESV(PL_compcv);
4011 /* ahem, death to those who redefine active sort subs */
4012 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4013 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4015 if (ckWARN(WARN_REDEFINE)
4017 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4019 line_t oldline = CopLINE(PL_curcop);
4020 if (PL_copline != NOLINE)
4021 CopLINE_set(PL_curcop, PL_copline);
4022 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4023 CvCONST(cv) ? "Constant subroutine %s redefined"
4024 : "Subroutine %s redefined", name);
4025 CopLINE_set(PL_curcop, oldline);
4033 SvREFCNT_inc(const_sv);
4035 assert(!CvROOT(cv) && !CvCONST(cv));
4036 sv_setpv((SV*)cv, ""); /* prototype is "" */
4037 CvXSUBANY(cv).any_ptr = const_sv;
4038 CvXSUB(cv) = const_sv_xsub;
4043 cv = newCONSTSUB(NULL, name, const_sv);
4046 SvREFCNT_dec(PL_compcv);
4048 PL_sub_generation++;
4055 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4056 * before we clobber PL_compcv.
4060 /* Might have had built-in attributes applied -- propagate them. */
4061 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4062 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4063 stash = GvSTASH(CvGV(cv));
4064 else if (CvSTASH(cv))
4065 stash = CvSTASH(cv);
4067 stash = PL_curstash;
4070 /* possibly about to re-define existing subr -- ignore old cv */
4071 rcv = (SV*)PL_compcv;
4072 if (name && GvSTASH(gv))
4073 stash = GvSTASH(gv);
4075 stash = PL_curstash;
4077 apply_attrs(stash, rcv, attrs, FALSE);
4079 if (cv) { /* must reuse cv if autoloaded */
4081 /* got here with just attrs -- work done, so bug out */
4082 SAVEFREESV(PL_compcv);
4086 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4087 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4088 CvOUTSIDE(PL_compcv) = 0;
4089 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4090 CvPADLIST(PL_compcv) = 0;
4091 /* inner references to PL_compcv must be fixed up ... */
4092 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4093 /* ... before we throw it away */
4094 SvREFCNT_dec(PL_compcv);
4095 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4096 ++PL_sub_generation;
4103 PL_sub_generation++;
4107 CvFILE_set_from_cop(cv, PL_curcop);
4108 CvSTASH(cv) = PL_curstash;
4111 sv_setpv((SV*)cv, ps);
4113 if (PL_error_count) {
4117 char *s = strrchr(name, ':');
4119 if (strEQ(s, "BEGIN")) {
4121 "BEGIN not safe after errors--compilation aborted";
4122 if (PL_in_eval & EVAL_KEEPERR)
4123 Perl_croak(aTHX_ not_safe);
4125 /* force display of errors found but not reported */
4126 sv_catpv(ERRSV, not_safe);
4127 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4136 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4137 mod(scalarseq(block), OP_LEAVESUBLV));
4140 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4142 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4143 OpREFCNT_set(CvROOT(cv), 1);
4144 CvSTART(cv) = LINKLIST(CvROOT(cv));
4145 CvROOT(cv)->op_next = 0;
4146 CALL_PEEP(CvSTART(cv));
4148 /* now that optimizer has done its work, adjust pad values */
4150 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4153 assert(!CvCONST(cv));
4154 if (ps && !*ps && op_const_sv(block, cv))
4158 /* If a potential closure prototype, don't keep a refcount on outer CV.
4159 * This is okay as the lifetime of the prototype is tied to the
4160 * lifetime of the outer CV. Avoids memory leak due to reference
4163 SvREFCNT_dec(CvOUTSIDE(cv));
4165 if (name || aname) {
4167 char *tname = (name ? name : aname);
4169 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4170 SV *sv = NEWSV(0,0);
4171 SV *tmpstr = sv_newmortal();
4172 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4176 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4178 (long)PL_subline, (long)CopLINE(PL_curcop));
4179 gv_efullname3(tmpstr, gv, Nullch);
4180 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4181 hv = GvHVn(db_postponed);
4182 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4183 && (pcv = GvCV(db_postponed)))
4189 call_sv((SV*)pcv, G_DISCARD);
4193 if ((s = strrchr(tname,':')))
4198 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4201 if (strEQ(s, "BEGIN")) {
4202 I32 oldscope = PL_scopestack_ix;
4204 SAVECOPFILE(&PL_compiling);
4205 SAVECOPLINE(&PL_compiling);
4208 PL_beginav = newAV();
4209 DEBUG_x( dump_sub(gv) );
4210 av_push(PL_beginav, (SV*)cv);
4211 GvCV(gv) = 0; /* cv has been hijacked */
4212 call_list(oldscope, PL_beginav);
4214 PL_curcop = &PL_compiling;
4215 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4218 else if (strEQ(s, "END") && !PL_error_count) {
4221 DEBUG_x( dump_sub(gv) );
4222 av_unshift(PL_endav, 1);
4223 av_store(PL_endav, 0, (SV*)cv);
4224 GvCV(gv) = 0; /* cv has been hijacked */
4226 else if (strEQ(s, "CHECK") && !PL_error_count) {
4228 PL_checkav = newAV();
4229 DEBUG_x( dump_sub(gv) );
4230 if (PL_main_start && ckWARN(WARN_VOID))
4231 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4232 av_unshift(PL_checkav, 1);
4233 av_store(PL_checkav, 0, (SV*)cv);
4234 GvCV(gv) = 0; /* cv has been hijacked */
4236 else if (strEQ(s, "INIT") && !PL_error_count) {
4238 PL_initav = newAV();
4239 DEBUG_x( dump_sub(gv) );
4240 if (PL_main_start && ckWARN(WARN_VOID))
4241 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4242 av_push(PL_initav, (SV*)cv);
4243 GvCV(gv) = 0; /* cv has been hijacked */
4248 PL_copline = NOLINE;
4253 /* XXX unsafe for threads if eval_owner isn't held */
4255 =for apidoc newCONSTSUB
4257 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4258 eligible for inlining at compile-time.
4264 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4270 SAVECOPLINE(PL_curcop);
4271 CopLINE_set(PL_curcop, PL_copline);
4274 PL_hints &= ~HINT_BLOCK_SCOPE;
4277 SAVESPTR(PL_curstash);
4278 SAVECOPSTASH(PL_curcop);
4279 PL_curstash = stash;
4280 CopSTASH_set(PL_curcop,stash);
4283 cv = newXS(name, const_sv_xsub, __FILE__);
4284 CvXSUBANY(cv).any_ptr = sv;
4286 sv_setpv((SV*)cv, ""); /* prototype is "" */
4294 =for apidoc U||newXS
4296 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4302 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
4304 GV *gv = gv_fetchpv(name ? name :
4305 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4306 GV_ADDMULTI, SVt_PVCV);
4310 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4312 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4314 /* just a cached method */
4318 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4319 /* already defined (or promised) */
4320 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4321 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4322 line_t oldline = CopLINE(PL_curcop);
4323 if (PL_copline != NOLINE)
4324 CopLINE_set(PL_curcop, PL_copline);
4325 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4326 CvCONST(cv) ? "Constant subroutine %s redefined"
4327 : "Subroutine %s redefined"
4329 CopLINE_set(PL_curcop, oldline);
4336 if (cv) /* must reuse cv if autoloaded */
4339 cv = (CV*)NEWSV(1105,0);
4340 sv_upgrade((SV *)cv, SVt_PVCV);
4344 PL_sub_generation++;
4348 (void)gv_fetchfile(filename);
4349 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
4350 an external constant string */
4351 CvXSUB(cv) = subaddr;
4354 char *s = strrchr(name,':');
4360 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4363 if (strEQ(s, "BEGIN")) {
4365 PL_beginav = newAV();
4366 av_push(PL_beginav, (SV*)cv);
4367 GvCV(gv) = 0; /* cv has been hijacked */
4369 else if (strEQ(s, "END")) {
4372 av_unshift(PL_endav, 1);
4373 av_store(PL_endav, 0, (SV*)cv);
4374 GvCV(gv) = 0; /* cv has been hijacked */
4376 else if (strEQ(s, "CHECK")) {
4378 PL_checkav = newAV();
4379 if (PL_main_start && ckWARN(WARN_VOID))
4380 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4381 av_unshift(PL_checkav, 1);
4382 av_store(PL_checkav, 0, (SV*)cv);
4383 GvCV(gv) = 0; /* cv has been hijacked */
4385 else if (strEQ(s, "INIT")) {
4387 PL_initav = newAV();
4388 if (PL_main_start && ckWARN(WARN_VOID))
4389 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4390 av_push(PL_initav, (SV*)cv);
4391 GvCV(gv) = 0; /* cv has been hijacked */
4402 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4410 name = SvPVx(cSVOPo->op_sv, n_a);
4413 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
4414 #ifdef GV_UNIQUE_CHECK
4416 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4420 if ((cv = GvFORM(gv))) {
4421 if (ckWARN(WARN_REDEFINE)) {
4422 line_t oldline = CopLINE(PL_curcop);
4423 if (PL_copline != NOLINE)
4424 CopLINE_set(PL_curcop, PL_copline);
4425 Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Format %s redefined",name);
4426 CopLINE_set(PL_curcop, oldline);
4433 CvFILE_set_from_cop(cv, PL_curcop);
4436 pad_tidy(padtidy_FORMAT);
4437 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4438 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4439 OpREFCNT_set(CvROOT(cv), 1);
4440 CvSTART(cv) = LINKLIST(CvROOT(cv));
4441 CvROOT(cv)->op_next = 0;
4442 CALL_PEEP(CvSTART(cv));
4444 PL_copline = NOLINE;
4449 Perl_newANONLIST(pTHX_ OP *o)
4451 return newUNOP(OP_REFGEN, 0,
4452 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4456 Perl_newANONHASH(pTHX_ OP *o)
4458 return newUNOP(OP_REFGEN, 0,
4459 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4463 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4465 return newANONATTRSUB(floor, proto, Nullop, block);
4469 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4471 return newUNOP(OP_REFGEN, 0,
4472 newSVOP(OP_ANONCODE, 0,
4473 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
4477 Perl_oopsAV(pTHX_ OP *o)
4479 switch (o->op_type) {
4481 o->op_type = OP_PADAV;
4482 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4483 return ref(o, OP_RV2AV);
4486 o->op_type = OP_RV2AV;
4487 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4492 if (ckWARN_d(WARN_INTERNAL))
4493 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
4500 Perl_oopsHV(pTHX_ OP *o)
4502 switch (o->op_type) {
4505 o->op_type = OP_PADHV;
4506 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4507 return ref(o, OP_RV2HV);
4511 o->op_type = OP_RV2HV;
4512 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
4517 if (ckWARN_d(WARN_INTERNAL))
4518 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
4525 Perl_newAVREF(pTHX_ OP *o)
4527 if (o->op_type == OP_PADANY) {
4528 o->op_type = OP_PADAV;
4529 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4532 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
4533 && ckWARN(WARN_DEPRECATED)) {
4534 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4535 "Using an array as a reference is deprecated");
4537 return newUNOP(OP_RV2AV, 0, scalar(o));
4541 Perl_newGVREF(pTHX_ I32 type, OP *o)
4543 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
4544 return newUNOP(OP_NULL, 0, o);
4545 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
4549 Perl_newHVREF(pTHX_ OP *o)
4551 if (o->op_type == OP_PADANY) {
4552 o->op_type = OP_PADHV;
4553 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4556 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
4557 && ckWARN(WARN_DEPRECATED)) {
4558 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4559 "Using a hash as a reference is deprecated");
4561 return newUNOP(OP_RV2HV, 0, scalar(o));
4565 Perl_oopsCV(pTHX_ OP *o)
4567 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
4573 Perl_newCVREF(pTHX_ I32 flags, OP *o)
4575 return newUNOP(OP_RV2CV, flags, scalar(o));
4579 Perl_newSVREF(pTHX_ OP *o)
4581 if (o->op_type == OP_PADANY) {
4582 o->op_type = OP_PADSV;
4583 o->op_ppaddr = PL_ppaddr[OP_PADSV];
4586 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4587 o->op_flags |= OPpDONE_SVREF;
4590 return newUNOP(OP_RV2SV, 0, scalar(o));
4593 /* Check routines. */
4596 Perl_ck_anoncode(pTHX_ OP *o)
4598 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
4599 cSVOPo->op_sv = Nullsv;
4604 Perl_ck_bitop(pTHX_ OP *o)
4606 #define OP_IS_NUMCOMPARE(op) \
4607 ((op) == OP_LT || (op) == OP_I_LT || \
4608 (op) == OP_GT || (op) == OP_I_GT || \
4609 (op) == OP_LE || (op) == OP_I_LE || \
4610 (op) == OP_GE || (op) == OP_I_GE || \
4611 (op) == OP_EQ || (op) == OP_I_EQ || \
4612 (op) == OP_NE || (op) == OP_I_NE || \
4613 (op) == OP_NCMP || (op) == OP_I_NCMP)
4614 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4615 if (o->op_type == OP_BIT_OR
4616 || o->op_type == OP_BIT_AND
4617 || o->op_type == OP_BIT_XOR)
4619 OPCODE typfirst = cBINOPo->op_first->op_type;
4620 OPCODE typlast = cBINOPo->op_first->op_sibling->op_type;
4621 if (OP_IS_NUMCOMPARE(typfirst) || OP_IS_NUMCOMPARE(typlast))
4622 if (ckWARN(WARN_PRECEDENCE))
4623 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4624 "Possible precedence problem on bitwise %c operator",
4625 o->op_type == OP_BIT_OR ? '|'
4626 : o->op_type == OP_BIT_AND ? '&' : '^'
4633 Perl_ck_concat(pTHX_ OP *o)
4635 if (cUNOPo->op_first->op_type == OP_CONCAT)
4636 o->op_flags |= OPf_STACKED;
4641 Perl_ck_spair(pTHX_ OP *o)
4643 if (o->op_flags & OPf_KIDS) {
4646 OPCODE type = o->op_type;
4647 o = modkids(ck_fun(o), type);
4648 kid = cUNOPo->op_first;
4649 newop = kUNOP->op_first->op_sibling;
4651 (newop->op_sibling ||
4652 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
4653 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
4654 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
4658 op_free(kUNOP->op_first);
4659 kUNOP->op_first = newop;
4661 o->op_ppaddr = PL_ppaddr[++o->op_type];
4666 Perl_ck_delete(pTHX_ OP *o)
4670 if (o->op_flags & OPf_KIDS) {
4671 OP *kid = cUNOPo->op_first;
4672 switch (kid->op_type) {
4674 o->op_flags |= OPf_SPECIAL;
4677 o->op_private |= OPpSLICE;
4680 o->op_flags |= OPf_SPECIAL;
4685 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
4694 Perl_ck_die(pTHX_ OP *o)
4697 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4703 Perl_ck_eof(pTHX_ OP *o)
4705 I32 type = o->op_type;
4707 if (o->op_flags & OPf_KIDS) {
4708 if (cLISTOPo->op_first->op_type == OP_STUB) {
4710 o = newUNOP(type, OPf_SPECIAL,
4711 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
4719 Perl_ck_eval(pTHX_ OP *o)
4721 PL_hints |= HINT_BLOCK_SCOPE;
4722 if (o->op_flags & OPf_KIDS) {
4723 SVOP *kid = (SVOP*)cUNOPo->op_first;
4726 o->op_flags &= ~OPf_KIDS;
4729 else if (kid->op_type == OP_LINESEQ) {
4732 kid->op_next = o->op_next;
4733 cUNOPo->op_first = 0;
4736 NewOp(1101, enter, 1, LOGOP);
4737 enter->op_type = OP_ENTERTRY;
4738 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
4739 enter->op_private = 0;
4741 /* establish postfix order */
4742 enter->op_next = (OP*)enter;
4744 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
4745 o->op_type = OP_LEAVETRY;
4746 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
4747 enter->op_other = o;
4755 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
4757 o->op_targ = (PADOFFSET)PL_hints;
4762 Perl_ck_exit(pTHX_ OP *o)
4765 HV *table = GvHV(PL_hintgv);
4767 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
4768 if (svp && *svp && SvTRUE(*svp))
4769 o->op_private |= OPpEXIT_VMSISH;
4771 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4777 Perl_ck_exec(pTHX_ OP *o)
4780 if (o->op_flags & OPf_STACKED) {
4782 kid = cUNOPo->op_first->op_sibling;
4783 if (kid->op_type == OP_RV2GV)
4792 Perl_ck_exists(pTHX_ OP *o)
4795 if (o->op_flags & OPf_KIDS) {
4796 OP *kid = cUNOPo->op_first;
4797 if (kid->op_type == OP_ENTERSUB) {
4798 (void) ref(kid, o->op_type);
4799 if (kid->op_type != OP_RV2CV && !PL_error_count)
4800 Perl_croak(aTHX_ "%s argument is not a subroutine name",
4802 o->op_private |= OPpEXISTS_SUB;
4804 else if (kid->op_type == OP_AELEM)
4805 o->op_flags |= OPf_SPECIAL;
4806 else if (kid->op_type != OP_HELEM)
4807 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
4816 Perl_ck_gvconst(pTHX_ register OP *o)
4818 o = fold_constants(o);
4819 if (o->op_type == OP_CONST)
4826 Perl_ck_rvconst(pTHX_ register OP *o)
4828 SVOP *kid = (SVOP*)cUNOPo->op_first;
4830 o->op_private |= (PL_hints & HINT_STRICT_REFS);
4831 if (kid->op_type == OP_CONST) {
4835 SV *kidsv = kid->op_sv;
4838 /* Is it a constant from cv_const_sv()? */
4839 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
4840 SV *rsv = SvRV(kidsv);
4841 int svtype = SvTYPE(rsv);
4842 char *badtype = Nullch;
4844 switch (o->op_type) {
4846 if (svtype > SVt_PVMG)
4847 badtype = "a SCALAR";
4850 if (svtype != SVt_PVAV)
4851 badtype = "an ARRAY";
4854 if (svtype != SVt_PVHV)
4858 if (svtype != SVt_PVCV)
4863 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
4866 name = SvPV(kidsv, n_a);
4867 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
4868 char *badthing = Nullch;
4869 switch (o->op_type) {
4871 badthing = "a SCALAR";
4874 badthing = "an ARRAY";
4877 badthing = "a HASH";
4882 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
4886 * This is a little tricky. We only want to add the symbol if we
4887 * didn't add it in the lexer. Otherwise we get duplicate strict
4888 * warnings. But if we didn't add it in the lexer, we must at
4889 * least pretend like we wanted to add it even if it existed before,
4890 * or we get possible typo warnings. OPpCONST_ENTERED says
4891 * whether the lexer already added THIS instance of this symbol.
4893 iscv = (o->op_type == OP_RV2CV) * 2;
4895 gv = gv_fetchpv(name,
4896 iscv | !(kid->op_private & OPpCONST_ENTERED),
4899 : o->op_type == OP_RV2SV
4901 : o->op_type == OP_RV2AV
4903 : o->op_type == OP_RV2HV
4906 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
4908 kid->op_type = OP_GV;
4909 SvREFCNT_dec(kid->op_sv);
4911 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
4912 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
4913 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
4915 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
4917 kid->op_sv = SvREFCNT_inc(gv);
4919 kid->op_private = 0;
4920 kid->op_ppaddr = PL_ppaddr[OP_GV];
4927 Perl_ck_ftst(pTHX_ OP *o)
4929 I32 type = o->op_type;
4931 if (o->op_flags & OPf_REF) {
4934 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
4935 SVOP *kid = (SVOP*)cUNOPo->op_first;
4937 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
4939 OP *newop = newGVOP(type, OPf_REF,
4940 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
4947 if (type == OP_FTTTY)
4948 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
4951 o = newUNOP(type, 0, newDEFSVOP());
4957 Perl_ck_fun(pTHX_ OP *o)
4963 int type = o->op_type;
4964 register I32 oa = PL_opargs[type] >> OASHIFT;
4966 if (o->op_flags & OPf_STACKED) {
4967 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
4970 return no_fh_allowed(o);
4973 if (o->op_flags & OPf_KIDS) {
4975 tokid = &cLISTOPo->op_first;
4976 kid = cLISTOPo->op_first;
4977 if (kid->op_type == OP_PUSHMARK ||
4978 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
4980 tokid = &kid->op_sibling;
4981 kid = kid->op_sibling;
4983 if (!kid && PL_opargs[type] & OA_DEFGV)
4984 *tokid = kid = newDEFSVOP();
4988 sibl = kid->op_sibling;
4991 /* list seen where single (scalar) arg expected? */
4992 if (numargs == 1 && !(oa >> 4)
4993 && kid->op_type == OP_LIST && type != OP_SCALAR)
4995 return too_many_arguments(o,PL_op_desc[type]);
5008 if ((type == OP_PUSH || type == OP_UNSHIFT)
5009 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5010 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5011 "Useless use of %s with no values",
5014 if (kid->op_type == OP_CONST &&
5015 (kid->op_private & OPpCONST_BARE))
5017 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5018 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5019 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5020 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5021 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5022 "Array @%s missing the @ in argument %"IVdf" of %s()",
5023 name, (IV)numargs, PL_op_desc[type]);
5026 kid->op_sibling = sibl;
5029 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5030 bad_type(numargs, "array", PL_op_desc[type], kid);
5034 if (kid->op_type == OP_CONST &&
5035 (kid->op_private & OPpCONST_BARE))
5037 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5038 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5039 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5040 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5041 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5042 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5043 name, (IV)numargs, PL_op_desc[type]);
5046 kid->op_sibling = sibl;
5049 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5050 bad_type(numargs, "hash", PL_op_desc[type], kid);
5055 OP *newop = newUNOP(OP_NULL, 0, kid);
5056 kid->op_sibling = 0;
5058 newop->op_next = newop;
5060 kid->op_sibling = sibl;
5065 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5066 if (kid->op_type == OP_CONST &&
5067 (kid->op_private & OPpCONST_BARE))
5069 OP *newop = newGVOP(OP_GV, 0,
5070 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5072 if (!(o->op_private & 1) && /* if not unop */
5073 kid == cLISTOPo->op_last)
5074 cLISTOPo->op_last = newop;
5078 else if (kid->op_type == OP_READLINE) {
5079 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5080 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5083 I32 flags = OPf_SPECIAL;
5087 /* is this op a FH constructor? */
5088 if (is_handle_constructor(o,numargs)) {
5089 char *name = Nullch;
5093 /* Set a flag to tell rv2gv to vivify
5094 * need to "prove" flag does not mean something
5095 * else already - NI-S 1999/05/07
5098 if (kid->op_type == OP_PADSV) {
5099 /*XXX DAPM 2002.08.25 tmp assert test */
5100 /*XXX*/ assert(av_fetch(PL_comppad_name, (kid->op_targ), FALSE));
5101 /*XXX*/ assert(*av_fetch(PL_comppad_name, (kid->op_targ), FALSE));
5103 name = PAD_COMPNAME_PV(kid->op_targ);
5104 /* SvCUR of a pad namesv can't be trusted
5105 * (see PL_generation), so calc its length
5111 else if (kid->op_type == OP_RV2SV
5112 && kUNOP->op_first->op_type == OP_GV)
5114 GV *gv = cGVOPx_gv(kUNOP->op_first);
5116 len = GvNAMELEN(gv);
5118 else if (kid->op_type == OP_AELEM
5119 || kid->op_type == OP_HELEM)
5121 name = "__ANONIO__";
5127 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5128 namesv = PAD_SVl(targ);
5129 (void)SvUPGRADE(namesv, SVt_PV);
5131 sv_setpvn(namesv, "$", 1);
5132 sv_catpvn(namesv, name, len);
5135 kid->op_sibling = 0;
5136 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5137 kid->op_targ = targ;
5138 kid->op_private |= priv;
5140 kid->op_sibling = sibl;
5146 mod(scalar(kid), type);
5150 tokid = &kid->op_sibling;
5151 kid = kid->op_sibling;
5153 o->op_private |= numargs;
5155 return too_many_arguments(o,OP_DESC(o));
5158 else if (PL_opargs[type] & OA_DEFGV) {
5160 return newUNOP(type, 0, newDEFSVOP());
5164 while (oa & OA_OPTIONAL)
5166 if (oa && oa != OA_LIST)
5167 return too_few_arguments(o,OP_DESC(o));
5173 Perl_ck_glob(pTHX_ OP *o)
5178 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5179 append_elem(OP_GLOB, o, newDEFSVOP());
5181 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5182 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5184 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5187 #if !defined(PERL_EXTERNAL_GLOB)
5188 /* XXX this can be tightened up and made more failsafe. */
5192 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5193 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5194 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5195 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5196 GvCV(gv) = GvCV(glob_gv);
5197 SvREFCNT_inc((SV*)GvCV(gv));
5198 GvIMPORTED_CV_on(gv);
5201 #endif /* PERL_EXTERNAL_GLOB */
5203 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5204 append_elem(OP_GLOB, o,
5205 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5206 o->op_type = OP_LIST;
5207 o->op_ppaddr = PL_ppaddr[OP_LIST];
5208 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5209 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5210 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5211 append_elem(OP_LIST, o,
5212 scalar(newUNOP(OP_RV2CV, 0,
5213 newGVOP(OP_GV, 0, gv)))));
5214 o = newUNOP(OP_NULL, 0, ck_subr(o));
5215 o->op_targ = OP_GLOB; /* hint at what it used to be */
5218 gv = newGVgen("main");
5220 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5226 Perl_ck_grep(pTHX_ OP *o)
5230 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5232 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5233 NewOp(1101, gwop, 1, LOGOP);
5235 if (o->op_flags & OPf_STACKED) {
5238 kid = cLISTOPo->op_first->op_sibling;
5239 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5242 kid->op_next = (OP*)gwop;
5243 o->op_flags &= ~OPf_STACKED;
5245 kid = cLISTOPo->op_first->op_sibling;
5246 if (type == OP_MAPWHILE)
5253 kid = cLISTOPo->op_first->op_sibling;
5254 if (kid->op_type != OP_NULL)
5255 Perl_croak(aTHX_ "panic: ck_grep");
5256 kid = kUNOP->op_first;
5258 gwop->op_type = type;
5259 gwop->op_ppaddr = PL_ppaddr[type];
5260 gwop->op_first = listkids(o);
5261 gwop->op_flags |= OPf_KIDS;
5262 gwop->op_private = 1;
5263 gwop->op_other = LINKLIST(kid);
5264 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5265 kid->op_next = (OP*)gwop;
5267 kid = cLISTOPo->op_first->op_sibling;
5268 if (!kid || !kid->op_sibling)
5269 return too_few_arguments(o,OP_DESC(o));
5270 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5271 mod(kid, OP_GREPSTART);
5277 Perl_ck_index(pTHX_ OP *o)
5279 if (o->op_flags & OPf_KIDS) {
5280 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5282 kid = kid->op_sibling; /* get past "big" */
5283 if (kid && kid->op_type == OP_CONST)
5284 fbm_compile(((SVOP*)kid)->op_sv, 0);
5290 Perl_ck_lengthconst(pTHX_ OP *o)
5292 /* XXX length optimization goes here */
5297 Perl_ck_lfun(pTHX_ OP *o)
5299 OPCODE type = o->op_type;
5300 return modkids(ck_fun(o), type);
5304 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5306 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5307 switch (cUNOPo->op_first->op_type) {
5309 /* This is needed for
5310 if (defined %stash::)
5311 to work. Do not break Tk.
5313 break; /* Globals via GV can be undef */
5315 case OP_AASSIGN: /* Is this a good idea? */
5316 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5317 "defined(@array) is deprecated");
5318 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5319 "\t(Maybe you should just omit the defined()?)\n");
5322 /* This is needed for
5323 if (defined %stash::)
5324 to work. Do not break Tk.
5326 break; /* Globals via GV can be undef */
5328 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5329 "defined(%%hash) is deprecated");
5330 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5331 "\t(Maybe you should just omit the defined()?)\n");
5342 Perl_ck_rfun(pTHX_ OP *o)
5344 OPCODE type = o->op_type;
5345 return refkids(ck_fun(o), type);
5349 Perl_ck_listiob(pTHX_ OP *o)
5353 kid = cLISTOPo->op_first;
5356 kid = cLISTOPo->op_first;
5358 if (kid->op_type == OP_PUSHMARK)
5359 kid = kid->op_sibling;
5360 if (kid && o->op_flags & OPf_STACKED)
5361 kid = kid->op_sibling;
5362 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5363 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5364 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5365 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5366 cLISTOPo->op_first->op_sibling = kid;
5367 cLISTOPo->op_last = kid;
5368 kid = kid->op_sibling;
5373 append_elem(o->op_type, o, newDEFSVOP());
5379 Perl_ck_sassign(pTHX_ OP *o)
5381 OP *kid = cLISTOPo->op_first;
5382 /* has a disposable target? */
5383 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5384 && !(kid->op_flags & OPf_STACKED)
5385 /* Cannot steal the second time! */
5386 && !(kid->op_private & OPpTARGET_MY))
5388 OP *kkid = kid->op_sibling;
5390 /* Can just relocate the target. */
5391 if (kkid && kkid->op_type == OP_PADSV
5392 && !(kkid->op_private & OPpLVAL_INTRO))
5394 kid->op_targ = kkid->op_targ;
5396 /* Now we do not need PADSV and SASSIGN. */
5397 kid->op_sibling = o->op_sibling; /* NULL */
5398 cLISTOPo->op_first = NULL;
5401 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
5409 Perl_ck_match(pTHX_ OP *o)
5411 o->op_private |= OPpRUNTIME;
5416 Perl_ck_method(pTHX_ OP *o)
5418 OP *kid = cUNOPo->op_first;
5419 if (kid->op_type == OP_CONST) {
5420 SV* sv = kSVOP->op_sv;
5421 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
5423 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5424 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
5427 kSVOP->op_sv = Nullsv;
5429 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5438 Perl_ck_null(pTHX_ OP *o)
5444 Perl_ck_open(pTHX_ OP *o)
5446 HV *table = GvHV(PL_hintgv);
5450 svp = hv_fetch(table, "open_IN", 7, FALSE);
5452 mode = mode_from_discipline(*svp);
5453 if (mode & O_BINARY)
5454 o->op_private |= OPpOPEN_IN_RAW;
5455 else if (mode & O_TEXT)
5456 o->op_private |= OPpOPEN_IN_CRLF;
5459 svp = hv_fetch(table, "open_OUT", 8, FALSE);
5461 mode = mode_from_discipline(*svp);
5462 if (mode & O_BINARY)
5463 o->op_private |= OPpOPEN_OUT_RAW;
5464 else if (mode & O_TEXT)
5465 o->op_private |= OPpOPEN_OUT_CRLF;
5468 if (o->op_type == OP_BACKTICK)
5474 Perl_ck_repeat(pTHX_ OP *o)
5476 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5477 o->op_private |= OPpREPEAT_DOLIST;
5478 cBINOPo->op_first = force_list(cBINOPo->op_first);
5486 Perl_ck_require(pTHX_ OP *o)
5490 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
5491 SVOP *kid = (SVOP*)cUNOPo->op_first;
5493 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5495 for (s = SvPVX(kid->op_sv); *s; s++) {
5496 if (*s == ':' && s[1] == ':') {
5498 Move(s+2, s+1, strlen(s+2)+1, char);
5499 --SvCUR(kid->op_sv);
5502 if (SvREADONLY(kid->op_sv)) {
5503 SvREADONLY_off(kid->op_sv);
5504 sv_catpvn(kid->op_sv, ".pm", 3);
5505 SvREADONLY_on(kid->op_sv);
5508 sv_catpvn(kid->op_sv, ".pm", 3);
5512 /* handle override, if any */
5513 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
5514 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
5515 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
5517 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5518 OP *kid = cUNOPo->op_first;
5519 cUNOPo->op_first = 0;
5521 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5522 append_elem(OP_LIST, kid,
5523 scalar(newUNOP(OP_RV2CV, 0,
5532 Perl_ck_return(pTHX_ OP *o)
5535 if (CvLVALUE(PL_compcv)) {
5536 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5537 mod(kid, OP_LEAVESUBLV);
5544 Perl_ck_retarget(pTHX_ OP *o)
5546 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5553 Perl_ck_select(pTHX_ OP *o)
5556 if (o->op_flags & OPf_KIDS) {
5557 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5558 if (kid && kid->op_sibling) {
5559 o->op_type = OP_SSELECT;
5560 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
5562 return fold_constants(o);
5566 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5567 if (kid && kid->op_type == OP_RV2GV)
5568 kid->op_private &= ~HINT_STRICT_REFS;
5573 Perl_ck_shift(pTHX_ OP *o)
5575 I32 type = o->op_type;
5577 if (!(o->op_flags & OPf_KIDS)) {
5581 argop = newUNOP(OP_RV2AV, 0,
5582 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
5583 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
5584 return newUNOP(type, 0, scalar(argop));
5586 return scalar(modkids(ck_fun(o), type));
5590 Perl_ck_sort(pTHX_ OP *o)
5594 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
5596 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5597 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
5599 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
5601 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
5603 if (kid->op_type == OP_SCOPE) {
5607 else if (kid->op_type == OP_LEAVE) {
5608 if (o->op_type == OP_SORT) {
5609 op_null(kid); /* wipe out leave */
5612 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
5613 if (k->op_next == kid)
5615 /* don't descend into loops */
5616 else if (k->op_type == OP_ENTERLOOP
5617 || k->op_type == OP_ENTERITER)
5619 k = cLOOPx(k)->op_lastop;
5624 kid->op_next = 0; /* just disconnect the leave */
5625 k = kLISTOP->op_first;
5630 if (o->op_type == OP_SORT) {
5631 /* provide scalar context for comparison function/block */
5637 o->op_flags |= OPf_SPECIAL;
5639 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
5642 firstkid = firstkid->op_sibling;
5645 /* provide list context for arguments */
5646 if (o->op_type == OP_SORT)
5653 S_simplify_sort(pTHX_ OP *o)
5655 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5659 if (!(o->op_flags & OPf_STACKED))
5661 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
5662 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
5663 kid = kUNOP->op_first; /* get past null */
5664 if (kid->op_type != OP_SCOPE)
5666 kid = kLISTOP->op_last; /* get past scope */
5667 switch(kid->op_type) {
5675 k = kid; /* remember this node*/
5676 if (kBINOP->op_first->op_type != OP_RV2SV)
5678 kid = kBINOP->op_first; /* get past cmp */
5679 if (kUNOP->op_first->op_type != OP_GV)
5681 kid = kUNOP->op_first; /* get past rv2sv */
5683 if (GvSTASH(gv) != PL_curstash)
5685 if (strEQ(GvNAME(gv), "a"))
5687 else if (strEQ(GvNAME(gv), "b"))
5691 kid = k; /* back to cmp */
5692 if (kBINOP->op_last->op_type != OP_RV2SV)
5694 kid = kBINOP->op_last; /* down to 2nd arg */
5695 if (kUNOP->op_first->op_type != OP_GV)
5697 kid = kUNOP->op_first; /* get past rv2sv */
5699 if (GvSTASH(gv) != PL_curstash
5701 ? strNE(GvNAME(gv), "a")
5702 : strNE(GvNAME(gv), "b")))
5704 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
5706 o->op_private |= OPpSORT_REVERSE;
5707 if (k->op_type == OP_NCMP)
5708 o->op_private |= OPpSORT_NUMERIC;
5709 if (k->op_type == OP_I_NCMP)
5710 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
5711 kid = cLISTOPo->op_first->op_sibling;
5712 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
5713 op_free(kid); /* then delete it */
5717 Perl_ck_split(pTHX_ OP *o)
5721 if (o->op_flags & OPf_STACKED)
5722 return no_fh_allowed(o);
5724 kid = cLISTOPo->op_first;
5725 if (kid->op_type != OP_NULL)
5726 Perl_croak(aTHX_ "panic: ck_split");
5727 kid = kid->op_sibling;
5728 op_free(cLISTOPo->op_first);
5729 cLISTOPo->op_first = kid;
5731 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
5732 cLISTOPo->op_last = kid; /* There was only one element previously */
5735 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
5736 OP *sibl = kid->op_sibling;
5737 kid->op_sibling = 0;
5738 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
5739 if (cLISTOPo->op_first == cLISTOPo->op_last)
5740 cLISTOPo->op_last = kid;
5741 cLISTOPo->op_first = kid;
5742 kid->op_sibling = sibl;
5745 kid->op_type = OP_PUSHRE;
5746 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
5748 if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
5749 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
5750 "Use of /g modifier is meaningless in split");
5753 if (!kid->op_sibling)
5754 append_elem(OP_SPLIT, o, newDEFSVOP());
5756 kid = kid->op_sibling;
5759 if (!kid->op_sibling)
5760 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
5762 kid = kid->op_sibling;
5765 if (kid->op_sibling)
5766 return too_many_arguments(o,OP_DESC(o));
5772 Perl_ck_join(pTHX_ OP *o)
5774 if (ckWARN(WARN_SYNTAX)) {
5775 OP *kid = cLISTOPo->op_first->op_sibling;
5776 if (kid && kid->op_type == OP_MATCH) {
5777 char *pmstr = "STRING";
5778 if (PM_GETRE(kPMOP))
5779 pmstr = PM_GETRE(kPMOP)->precomp;
5780 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5781 "/%s/ should probably be written as \"%s\"",
5789 Perl_ck_subr(pTHX_ OP *o)
5791 OP *prev = ((cUNOPo->op_first->op_sibling)
5792 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
5793 OP *o2 = prev->op_sibling;
5800 I32 contextclass = 0;
5804 o->op_private |= OPpENTERSUB_HASTARG;
5805 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
5806 if (cvop->op_type == OP_RV2CV) {
5808 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
5809 op_null(cvop); /* disable rv2cv */
5810 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
5811 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
5812 GV *gv = cGVOPx_gv(tmpop);
5815 tmpop->op_private |= OPpEARLY_CV;
5816 else if (SvPOK(cv)) {
5817 namegv = CvANON(cv) ? gv : CvGV(cv);
5818 proto = SvPV((SV*)cv, n_a);
5822 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
5823 if (o2->op_type == OP_CONST)
5824 o2->op_private &= ~OPpCONST_STRICT;
5825 else if (o2->op_type == OP_LIST) {
5826 OP *o = ((UNOP*)o2)->op_first->op_sibling;
5827 if (o && o->op_type == OP_CONST)
5828 o->op_private &= ~OPpCONST_STRICT;
5831 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5832 if (PERLDB_SUB && PL_curstash != PL_debstash)
5833 o->op_private |= OPpENTERSUB_DB;
5834 while (o2 != cvop) {
5838 return too_many_arguments(o, gv_ename(namegv));
5856 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
5858 arg == 1 ? "block or sub {}" : "sub {}",
5859 gv_ename(namegv), o2);
5862 /* '*' allows any scalar type, including bareword */
5865 if (o2->op_type == OP_RV2GV)
5866 goto wrapref; /* autoconvert GLOB -> GLOBref */
5867 else if (o2->op_type == OP_CONST)
5868 o2->op_private &= ~OPpCONST_STRICT;
5869 else if (o2->op_type == OP_ENTERSUB) {
5870 /* accidental subroutine, revert to bareword */
5871 OP *gvop = ((UNOP*)o2)->op_first;
5872 if (gvop && gvop->op_type == OP_NULL) {
5873 gvop = ((UNOP*)gvop)->op_first;
5875 for (; gvop->op_sibling; gvop = gvop->op_sibling)
5878 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
5879 (gvop = ((UNOP*)gvop)->op_first) &&
5880 gvop->op_type == OP_GV)
5882 GV *gv = cGVOPx_gv(gvop);
5883 OP *sibling = o2->op_sibling;
5884 SV *n = newSVpvn("",0);
5886 gv_fullname3(n, gv, "");
5887 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
5888 sv_chop(n, SvPVX(n)+6);
5889 o2 = newSVOP(OP_CONST, 0, n);
5890 prev->op_sibling = o2;
5891 o2->op_sibling = sibling;
5907 if (contextclass++ == 0) {
5908 e = strchr(proto, ']');
5909 if (!e || e == proto)
5922 while (*--p != '[');
5923 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
5924 gv_ename(namegv), o2);
5930 if (o2->op_type == OP_RV2GV)
5933 bad_type(arg, "symbol", gv_ename(namegv), o2);
5936 if (o2->op_type == OP_ENTERSUB)
5939 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
5942 if (o2->op_type == OP_RV2SV ||
5943 o2->op_type == OP_PADSV ||
5944 o2->op_type == OP_HELEM ||
5945 o2->op_type == OP_AELEM ||
5946 o2->op_type == OP_THREADSV)
5949 bad_type(arg, "scalar", gv_ename(namegv), o2);
5952 if (o2->op_type == OP_RV2AV ||
5953 o2->op_type == OP_PADAV)
5956 bad_type(arg, "array", gv_ename(namegv), o2);
5959 if (o2->op_type == OP_RV2HV ||
5960 o2->op_type == OP_PADHV)
5963 bad_type(arg, "hash", gv_ename(namegv), o2);
5968 OP* sib = kid->op_sibling;
5969 kid->op_sibling = 0;
5970 o2 = newUNOP(OP_REFGEN, 0, kid);
5971 o2->op_sibling = sib;
5972 prev->op_sibling = o2;
5974 if (contextclass && e) {
5989 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
5990 gv_ename(namegv), SvPV((SV*)cv, n_a));
5995 mod(o2, OP_ENTERSUB);
5997 o2 = o2->op_sibling;
5999 if (proto && !optional &&
6000 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6001 return too_few_arguments(o, gv_ename(namegv));
6006 Perl_ck_svconst(pTHX_ OP *o)
6008 SvREADONLY_on(cSVOPo->op_sv);
6013 Perl_ck_trunc(pTHX_ OP *o)
6015 if (o->op_flags & OPf_KIDS) {
6016 SVOP *kid = (SVOP*)cUNOPo->op_first;
6018 if (kid->op_type == OP_NULL)
6019 kid = (SVOP*)kid->op_sibling;
6020 if (kid && kid->op_type == OP_CONST &&
6021 (kid->op_private & OPpCONST_BARE))
6023 o->op_flags |= OPf_SPECIAL;
6024 kid->op_private &= ~OPpCONST_STRICT;
6031 Perl_ck_substr(pTHX_ OP *o)
6034 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6035 OP *kid = cLISTOPo->op_first;
6037 if (kid->op_type == OP_NULL)
6038 kid = kid->op_sibling;
6040 kid->op_flags |= OPf_MOD;
6046 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6049 Perl_peep(pTHX_ register OP *o)
6051 register OP* oldop = 0;
6053 if (!o || o->op_seq)
6057 SAVEVPTR(PL_curcop);
6058 for (; o; o = o->op_next) {
6064 switch (o->op_type) {
6068 PL_curcop = ((COP*)o); /* for warnings */
6069 o->op_seq = PL_op_seqmax++;
6073 if (cSVOPo->op_private & OPpCONST_STRICT)
6074 no_bareword_allowed(o);
6076 /* Relocate sv to the pad for thread safety.
6077 * Despite being a "constant", the SV is written to,
6078 * for reference counts, sv_upgrade() etc. */
6080 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6081 if (SvPADTMP(cSVOPo->op_sv)) {
6082 /* If op_sv is already a PADTMP then it is being used by
6083 * some pad, so make a copy. */
6084 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6085 SvREADONLY_on(PAD_SVl(ix));
6086 SvREFCNT_dec(cSVOPo->op_sv);
6089 SvREFCNT_dec(PAD_SVl(ix));
6090 SvPADTMP_on(cSVOPo->op_sv);
6091 PAD_SETSV(ix, cSVOPo->op_sv);
6092 /* XXX I don't know how this isn't readonly already. */
6093 SvREADONLY_on(PAD_SVl(ix));
6095 cSVOPo->op_sv = Nullsv;
6099 o->op_seq = PL_op_seqmax++;
6103 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6104 if (o->op_next->op_private & OPpTARGET_MY) {
6105 if (o->op_flags & OPf_STACKED) /* chained concats */
6106 goto ignore_optimization;
6108 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6109 o->op_targ = o->op_next->op_targ;
6110 o->op_next->op_targ = 0;
6111 o->op_private |= OPpTARGET_MY;
6114 op_null(o->op_next);
6116 ignore_optimization:
6117 o->op_seq = PL_op_seqmax++;
6120 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6121 o->op_seq = PL_op_seqmax++;
6122 break; /* Scalar stub must produce undef. List stub is noop */
6126 if (o->op_targ == OP_NEXTSTATE
6127 || o->op_targ == OP_DBSTATE
6128 || o->op_targ == OP_SETSTATE)
6130 PL_curcop = ((COP*)o);
6132 /* XXX: We avoid setting op_seq here to prevent later calls
6133 to peep() from mistakenly concluding that optimisation
6134 has already occurred. This doesn't fix the real problem,
6135 though (See 20010220.007). AMS 20010719 */
6136 if (oldop && o->op_next) {
6137 oldop->op_next = o->op_next;
6145 if (oldop && o->op_next) {
6146 oldop->op_next = o->op_next;
6149 o->op_seq = PL_op_seqmax++;
6153 if (o->op_next->op_type == OP_RV2SV) {
6154 if (!(o->op_next->op_private & OPpDEREF)) {
6155 op_null(o->op_next);
6156 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6158 o->op_next = o->op_next->op_next;
6159 o->op_type = OP_GVSV;
6160 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6163 else if (o->op_next->op_type == OP_RV2AV) {
6164 OP* pop = o->op_next->op_next;
6166 if (pop && pop->op_type == OP_CONST &&
6167 (PL_op = pop->op_next) &&
6168 pop->op_next->op_type == OP_AELEM &&
6169 !(pop->op_next->op_private &
6170 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6171 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6176 op_null(o->op_next);
6177 op_null(pop->op_next);
6179 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6180 o->op_next = pop->op_next->op_next;
6181 o->op_type = OP_AELEMFAST;
6182 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6183 o->op_private = (U8)i;
6188 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6190 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6191 /* XXX could check prototype here instead of just carping */
6192 SV *sv = sv_newmortal();
6193 gv_efullname3(sv, gv, Nullch);
6194 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6195 "%s() called too early to check prototype",
6199 else if (o->op_next->op_type == OP_READLINE
6200 && o->op_next->op_next->op_type == OP_CONCAT
6201 && (o->op_next->op_next->op_flags & OPf_STACKED))
6203 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6204 o->op_type = OP_RCATLINE;
6205 o->op_flags |= OPf_STACKED;
6206 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6207 op_null(o->op_next->op_next);
6208 op_null(o->op_next);
6211 o->op_seq = PL_op_seqmax++;
6224 o->op_seq = PL_op_seqmax++;
6225 while (cLOGOP->op_other->op_type == OP_NULL)
6226 cLOGOP->op_other = cLOGOP->op_other->op_next;
6227 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6232 o->op_seq = PL_op_seqmax++;
6233 while (cLOOP->op_redoop->op_type == OP_NULL)
6234 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6235 peep(cLOOP->op_redoop);
6236 while (cLOOP->op_nextop->op_type == OP_NULL)
6237 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6238 peep(cLOOP->op_nextop);
6239 while (cLOOP->op_lastop->op_type == OP_NULL)
6240 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6241 peep(cLOOP->op_lastop);
6247 o->op_seq = PL_op_seqmax++;
6248 while (cPMOP->op_pmreplstart &&
6249 cPMOP->op_pmreplstart->op_type == OP_NULL)
6250 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6251 peep(cPMOP->op_pmreplstart);
6255 o->op_seq = PL_op_seqmax++;
6256 if (ckWARN(WARN_SYNTAX) && o->op_next
6257 && o->op_next->op_type == OP_NEXTSTATE) {
6258 if (o->op_next->op_sibling &&
6259 o->op_next->op_sibling->op_type != OP_EXIT &&
6260 o->op_next->op_sibling->op_type != OP_WARN &&
6261 o->op_next->op_sibling->op_type != OP_DIE) {
6262 line_t oldline = CopLINE(PL_curcop);
6264 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6265 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6266 "Statement unlikely to be reached");
6267 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6268 "\t(Maybe you meant system() when you said exec()?)\n");
6269 CopLINE_set(PL_curcop, oldline);
6280 o->op_seq = PL_op_seqmax++;
6282 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6285 /* Make the CONST have a shared SV */
6286 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6287 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6288 key = SvPV(sv, keylen);
6289 lexname = newSVpvn_share(key,
6290 SvUTF8(sv) ? -(I32)keylen : keylen,
6299 o->op_seq = PL_op_seqmax++;
6309 char* Perl_custom_op_name(pTHX_ OP* o)
6311 IV index = PTR2IV(o->op_ppaddr);
6315 if (!PL_custom_op_names) /* This probably shouldn't happen */
6316 return PL_op_name[OP_CUSTOM];
6318 keysv = sv_2mortal(newSViv(index));
6320 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
6322 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
6324 return SvPV_nolen(HeVAL(he));
6327 char* Perl_custom_op_desc(pTHX_ OP* o)
6329 IV index = PTR2IV(o->op_ppaddr);
6333 if (!PL_custom_op_descs)
6334 return PL_op_desc[OP_CUSTOM];
6336 keysv = sv_2mortal(newSViv(index));
6338 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
6340 return PL_op_desc[OP_CUSTOM];
6342 return SvPV_nolen(HeVAL(he));
6348 /* Efficient sub that returns a constant scalar value. */
6350 const_sv_xsub(pTHX_ CV* cv)
6355 Perl_croak(aTHX_ "usage: %s::%s()",
6356 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
6360 ST(0) = (SV*)XSANY.any_ptr;