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 \"%"SVf"\" not allowed while \"strict subs\" in use",
159 /* "register" allocation */
162 Perl_allocmy(pTHX_ char *name)
166 /* complain about "my $_" etc etc */
167 if (!(PL_in_my == KEY_our ||
169 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
170 (name[1] == '_' && (int)strlen(name) > 2)))
172 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
173 /* 1999-02-27 mjd@plover.com */
175 p = strchr(name, '\0');
176 /* The next block assumes the buffer is at least 205 chars
177 long. At present, it's always at least 256 chars. */
179 strcpy(name+200, "...");
185 /* Move everything else down one character */
186 for (; p-name > 2; p--)
188 name[2] = toCTRL(name[1]);
191 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
194 /* check for duplicate declaration */
197 (PL_curstash ? PL_curstash : PL_defstash)
200 if (PL_in_my_stash && *name != '$') {
201 yyerror(Perl_form(aTHX_
202 "Can't declare class for non-scalar %s in \"%s\"",
203 name, PL_in_my == KEY_our ? "our" : "my"));
206 /* allocate a spare slot and store the name in that slot */
208 off = pad_add_name(name,
211 ? (PL_curstash ? PL_curstash : PL_defstash)
222 Perl_op_free(pTHX_ OP *o)
224 register OP *kid, *nextkid;
227 if (!o || o->op_seq == (U16)-1)
230 if (o->op_private & OPpREFCOUNTED) {
231 switch (o->op_type) {
239 if (OpREFCNT_dec(o)) {
250 if (o->op_flags & OPf_KIDS) {
251 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
252 nextkid = kid->op_sibling; /* Get before next freeing kid */
258 type = (OPCODE)o->op_targ;
260 /* COP* is not cleared by op_clear() so that we may track line
261 * numbers etc even after null() */
262 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
270 Perl_op_clear(pTHX_ OP *o)
273 switch (o->op_type) {
274 case OP_NULL: /* Was holding old type, if any. */
275 case OP_ENTEREVAL: /* Was holding hints. */
279 if (!(o->op_flags & OPf_REF)
280 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
287 if (cPADOPo->op_padix > 0) {
288 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
289 * may still exist on the pad */
290 pad_swipe(cPADOPo->op_padix, TRUE);
291 cPADOPo->op_padix = 0;
294 SvREFCNT_dec(cSVOPo->op_sv);
295 cSVOPo->op_sv = Nullsv;
298 case OP_METHOD_NAMED:
300 SvREFCNT_dec(cSVOPo->op_sv);
301 cSVOPo->op_sv = Nullsv;
307 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
311 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
312 SvREFCNT_dec(cSVOPo->op_sv);
313 cSVOPo->op_sv = Nullsv;
316 Safefree(cPVOPo->op_pv);
317 cPVOPo->op_pv = Nullch;
321 op_free(cPMOPo->op_pmreplroot);
325 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
326 /* No GvIN_PAD_off here, because other references may still
327 * exist on the pad */
328 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
331 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
338 HV *pmstash = PmopSTASH(cPMOPo);
339 if (pmstash && SvREFCNT(pmstash)) {
340 PMOP *pmop = HvPMROOT(pmstash);
341 PMOP *lastpmop = NULL;
343 if (cPMOPo == pmop) {
345 lastpmop->op_pmnext = pmop->op_pmnext;
347 HvPMROOT(pmstash) = pmop->op_pmnext;
351 pmop = pmop->op_pmnext;
354 PmopSTASH_free(cPMOPo);
356 cPMOPo->op_pmreplroot = Nullop;
357 /* we use the "SAFE" version of the PM_ macros here
358 * since sv_clean_all might release some PMOPs
359 * after PL_regex_padav has been cleared
360 * and the clearing of PL_regex_padav needs to
361 * happen before sv_clean_all
363 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
364 PM_SETRE_SAFE(cPMOPo, (REGEXP*)NULL);
366 if(PL_regex_pad) { /* We could be in destruction */
367 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
368 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
369 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
376 if (o->op_targ > 0) {
377 pad_free(o->op_targ);
383 S_cop_free(pTHX_ COP* cop)
385 Safefree(cop->cop_label); /* FIXME: treaddead ??? */
388 if (! specialWARN(cop->cop_warnings))
389 SvREFCNT_dec(cop->cop_warnings);
390 if (! specialCopIO(cop->cop_io)) {
394 char *s = SvPV(cop->cop_io,len);
395 Perl_warn(aTHX_ "io='%.*s'",(int) len,s); /* ??? --jhi */
398 SvREFCNT_dec(cop->cop_io);
404 Perl_op_null(pTHX_ OP *o)
406 if (o->op_type == OP_NULL)
409 o->op_targ = o->op_type;
410 o->op_type = OP_NULL;
411 o->op_ppaddr = PL_ppaddr[OP_NULL];
414 /* Contextualizers */
416 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
419 Perl_linklist(pTHX_ OP *o)
426 /* establish postfix order */
427 if (cUNOPo->op_first) {
428 o->op_next = LINKLIST(cUNOPo->op_first);
429 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
431 kid->op_next = LINKLIST(kid->op_sibling);
443 Perl_scalarkids(pTHX_ OP *o)
446 if (o && o->op_flags & OPf_KIDS) {
447 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
454 S_scalarboolean(pTHX_ OP *o)
456 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
457 if (ckWARN(WARN_SYNTAX)) {
458 line_t oldline = CopLINE(PL_curcop);
460 if (PL_copline != NOLINE)
461 CopLINE_set(PL_curcop, PL_copline);
462 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
463 CopLINE_set(PL_curcop, oldline);
470 Perl_scalar(pTHX_ OP *o)
474 /* assumes no premature commitment */
475 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
476 || o->op_type == OP_RETURN)
481 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
483 switch (o->op_type) {
485 scalar(cBINOPo->op_first);
490 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
494 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
495 if (!kPMOP->op_pmreplroot)
496 deprecate_old("implicit split to @_");
504 if (o->op_flags & OPf_KIDS) {
505 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
511 kid = cLISTOPo->op_first;
513 while ((kid = kid->op_sibling)) {
519 WITH_THR(PL_curcop = &PL_compiling);
524 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
530 WITH_THR(PL_curcop = &PL_compiling);
533 if (ckWARN(WARN_VOID))
534 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
540 Perl_scalarvoid(pTHX_ OP *o)
547 if (o->op_type == OP_NEXTSTATE
548 || o->op_type == OP_SETSTATE
549 || o->op_type == OP_DBSTATE
550 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
551 || o->op_targ == OP_SETSTATE
552 || o->op_targ == OP_DBSTATE)))
553 PL_curcop = (COP*)o; /* for warning below */
555 /* assumes no premature commitment */
556 want = o->op_flags & OPf_WANT;
557 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
558 || o->op_type == OP_RETURN)
563 if ((o->op_private & OPpTARGET_MY)
564 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
566 return scalar(o); /* As if inside SASSIGN */
569 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
571 switch (o->op_type) {
573 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
577 if (o->op_flags & OPf_STACKED)
581 if (o->op_private == 4)
653 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
654 useless = OP_DESC(o);
661 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
662 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
663 useless = "a variable";
668 if (cSVOPo->op_private & OPpCONST_STRICT)
669 no_bareword_allowed(o);
671 if (ckWARN(WARN_VOID)) {
672 useless = "a constant";
673 /* the constants 0 and 1 are permitted as they are
674 conventionally used as dummies in constructs like
675 1 while some_condition_with_side_effects; */
676 if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
678 else if (SvPOK(sv)) {
679 /* perl4's way of mixing documentation and code
680 (before the invention of POD) was based on a
681 trick to mix nroff and perl code. The trick was
682 built upon these three nroff macros being used in
683 void context. The pink camel has the details in
684 the script wrapman near page 319. */
685 if (strnEQ(SvPVX(sv), "di", 2) ||
686 strnEQ(SvPVX(sv), "ds", 2) ||
687 strnEQ(SvPVX(sv), "ig", 2))
692 op_null(o); /* don't execute or even remember it */
696 o->op_type = OP_PREINC; /* pre-increment is faster */
697 o->op_ppaddr = PL_ppaddr[OP_PREINC];
701 o->op_type = OP_PREDEC; /* pre-decrement is faster */
702 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
709 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
714 if (o->op_flags & OPf_STACKED)
721 if (!(o->op_flags & OPf_KIDS))
730 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
737 /* all requires must return a boolean value */
738 o->op_flags &= ~OPf_WANT;
743 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
744 if (!kPMOP->op_pmreplroot)
745 deprecate_old("implicit split to @_");
749 if (useless && ckWARN(WARN_VOID))
750 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
755 Perl_listkids(pTHX_ OP *o)
758 if (o && o->op_flags & OPf_KIDS) {
759 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
766 Perl_list(pTHX_ OP *o)
770 /* assumes no premature commitment */
771 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
772 || o->op_type == OP_RETURN)
777 if ((o->op_private & OPpTARGET_MY)
778 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
780 return o; /* As if inside SASSIGN */
783 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
785 switch (o->op_type) {
788 list(cBINOPo->op_first);
793 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
801 if (!(o->op_flags & OPf_KIDS))
803 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
804 list(cBINOPo->op_first);
805 return gen_constant_list(o);
812 kid = cLISTOPo->op_first;
814 while ((kid = kid->op_sibling)) {
820 WITH_THR(PL_curcop = &PL_compiling);
824 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
830 WITH_THR(PL_curcop = &PL_compiling);
833 /* all requires must return a boolean value */
834 o->op_flags &= ~OPf_WANT;
841 Perl_scalarseq(pTHX_ OP *o)
846 if (o->op_type == OP_LINESEQ ||
847 o->op_type == OP_SCOPE ||
848 o->op_type == OP_LEAVE ||
849 o->op_type == OP_LEAVETRY)
851 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
852 if (kid->op_sibling) {
856 PL_curcop = &PL_compiling;
858 o->op_flags &= ~OPf_PARENS;
859 if (PL_hints & HINT_BLOCK_SCOPE)
860 o->op_flags |= OPf_PARENS;
863 o = newOP(OP_STUB, 0);
868 S_modkids(pTHX_ OP *o, I32 type)
871 if (o && o->op_flags & OPf_KIDS) {
872 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
879 Perl_mod(pTHX_ OP *o, I32 type)
883 if (!o || PL_error_count)
886 if ((o->op_private & OPpTARGET_MY)
887 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
892 switch (o->op_type) {
897 if (!(o->op_private & (OPpCONST_ARYBASE)))
899 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
900 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
904 SAVEI32(PL_compiling.cop_arybase);
905 PL_compiling.cop_arybase = 0;
907 else if (type == OP_REFGEN)
910 Perl_croak(aTHX_ "That use of $[ is unsupported");
913 if (o->op_flags & OPf_PARENS)
917 if ((type == OP_UNDEF || type == OP_REFGEN) &&
918 !(o->op_flags & OPf_STACKED)) {
919 o->op_type = OP_RV2CV; /* entersub => rv2cv */
920 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
921 assert(cUNOPo->op_first->op_type == OP_NULL);
922 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
925 else if (o->op_private & OPpENTERSUB_NOMOD)
927 else { /* lvalue subroutine call */
928 o->op_private |= OPpLVAL_INTRO;
929 PL_modcount = RETURN_UNLIMITED_NUMBER;
930 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
931 /* Backward compatibility mode: */
932 o->op_private |= OPpENTERSUB_INARGS;
935 else { /* Compile-time error message: */
936 OP *kid = cUNOPo->op_first;
940 if (kid->op_type == OP_PUSHMARK)
942 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
944 "panic: unexpected lvalue entersub "
945 "args: type/targ %ld:%"UVuf,
946 (long)kid->op_type, (UV)kid->op_targ);
947 kid = kLISTOP->op_first;
949 while (kid->op_sibling)
950 kid = kid->op_sibling;
951 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
953 if (kid->op_type == OP_METHOD_NAMED
954 || kid->op_type == OP_METHOD)
958 NewOp(1101, newop, 1, UNOP);
959 newop->op_type = OP_RV2CV;
960 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
961 newop->op_first = Nullop;
962 newop->op_next = (OP*)newop;
963 kid->op_sibling = (OP*)newop;
964 newop->op_private |= OPpLVAL_INTRO;
968 if (kid->op_type != OP_RV2CV)
970 "panic: unexpected lvalue entersub "
971 "entry via type/targ %ld:%"UVuf,
972 (long)kid->op_type, (UV)kid->op_targ);
973 kid->op_private |= OPpLVAL_INTRO;
974 break; /* Postpone until runtime */
978 kid = kUNOP->op_first;
979 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
980 kid = kUNOP->op_first;
981 if (kid->op_type == OP_NULL)
983 "Unexpected constant lvalue entersub "
984 "entry via type/targ %ld:%"UVuf,
985 (long)kid->op_type, (UV)kid->op_targ);
986 if (kid->op_type != OP_GV) {
987 /* Restore RV2CV to check lvalueness */
989 if (kid->op_next && kid->op_next != kid) { /* Happens? */
990 okid->op_next = kid->op_next;
994 okid->op_next = Nullop;
995 okid->op_type = OP_RV2CV;
997 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
998 okid->op_private |= OPpLVAL_INTRO;
1002 cv = GvCV(kGVOP_gv);
1012 /* grep, foreach, subcalls, refgen */
1013 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1015 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1016 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1018 : (o->op_type == OP_ENTERSUB
1019 ? "non-lvalue subroutine call"
1021 type ? PL_op_desc[type] : "local"));
1035 case OP_RIGHT_SHIFT:
1044 if (!(o->op_flags & OPf_STACKED))
1050 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1056 if (!type && cUNOPo->op_first->op_type != OP_GV)
1057 Perl_croak(aTHX_ "Can't localize through a reference");
1058 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1059 PL_modcount = RETURN_UNLIMITED_NUMBER;
1060 return o; /* Treat \(@foo) like ordinary list. */
1064 if (scalar_mod_type(o, type))
1066 ref(cUNOPo->op_first, o->op_type);
1070 if (type == OP_LEAVESUBLV)
1071 o->op_private |= OPpMAYBE_LVSUB;
1076 PL_modcount = RETURN_UNLIMITED_NUMBER;
1079 if (!type && cUNOPo->op_first->op_type != OP_GV)
1080 Perl_croak(aTHX_ "Can't localize through a reference");
1081 ref(cUNOPo->op_first, o->op_type);
1085 PL_hints |= HINT_BLOCK_SCOPE;
1096 PL_modcount = RETURN_UNLIMITED_NUMBER;
1097 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1098 return o; /* Treat \(@foo) like ordinary list. */
1099 if (scalar_mod_type(o, type))
1101 if (type == OP_LEAVESUBLV)
1102 o->op_private |= OPpMAYBE_LVSUB;
1107 { /* XXX DAPM 2002.08.25 tmp assert test */
1108 /* XXX */ assert(av_fetch(PL_comppad_name, (o->op_targ), FALSE));
1109 /* XXX */ assert(*av_fetch(PL_comppad_name, (o->op_targ), FALSE));
1111 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1112 PAD_COMPNAME_PV(o->op_targ));
1120 if (type != OP_SASSIGN)
1124 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1129 if (type == OP_LEAVESUBLV)
1130 o->op_private |= OPpMAYBE_LVSUB;
1132 pad_free(o->op_targ);
1133 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1134 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1135 if (o->op_flags & OPf_KIDS)
1136 mod(cBINOPo->op_first->op_sibling, type);
1141 ref(cBINOPo->op_first, o->op_type);
1142 if (type == OP_ENTERSUB &&
1143 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1144 o->op_private |= OPpLVAL_DEFER;
1145 if (type == OP_LEAVESUBLV)
1146 o->op_private |= OPpMAYBE_LVSUB;
1154 if (o->op_flags & OPf_KIDS)
1155 mod(cLISTOPo->op_last, type);
1159 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1161 else if (!(o->op_flags & OPf_KIDS))
1163 if (o->op_targ != OP_LIST) {
1164 mod(cBINOPo->op_first, type);
1169 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1174 if (type != OP_LEAVESUBLV)
1176 break; /* mod()ing was handled by ck_return() */
1179 /* [20011101.069] File test operators interpret OPf_REF to mean that
1180 their argument is a filehandle; thus \stat(".") should not set
1182 if (type == OP_REFGEN &&
1183 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1186 if (type != OP_LEAVESUBLV)
1187 o->op_flags |= OPf_MOD;
1189 if (type == OP_AASSIGN || type == OP_SASSIGN)
1190 o->op_flags |= OPf_SPECIAL|OPf_REF;
1192 o->op_private |= OPpLVAL_INTRO;
1193 o->op_flags &= ~OPf_SPECIAL;
1194 PL_hints |= HINT_BLOCK_SCOPE;
1196 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1197 && type != OP_LEAVESUBLV)
1198 o->op_flags |= OPf_REF;
1203 S_scalar_mod_type(pTHX_ OP *o, I32 type)
1207 if (o->op_type == OP_RV2GV)
1231 case OP_RIGHT_SHIFT:
1250 S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
1252 switch (o->op_type) {
1260 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1273 Perl_refkids(pTHX_ OP *o, I32 type)
1276 if (o && o->op_flags & OPf_KIDS) {
1277 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1284 Perl_ref(pTHX_ OP *o, I32 type)
1288 if (!o || PL_error_count)
1291 switch (o->op_type) {
1293 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1294 !(o->op_flags & OPf_STACKED)) {
1295 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1296 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1297 assert(cUNOPo->op_first->op_type == OP_NULL);
1298 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1299 o->op_flags |= OPf_SPECIAL;
1304 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1308 if (type == OP_DEFINED)
1309 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1310 ref(cUNOPo->op_first, o->op_type);
1313 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1314 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1315 : type == OP_RV2HV ? OPpDEREF_HV
1317 o->op_flags |= OPf_MOD;
1322 o->op_flags |= OPf_MOD; /* XXX ??? */
1327 o->op_flags |= OPf_REF;
1330 if (type == OP_DEFINED)
1331 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1332 ref(cUNOPo->op_first, o->op_type);
1337 o->op_flags |= OPf_REF;
1342 if (!(o->op_flags & OPf_KIDS))
1344 ref(cBINOPo->op_first, type);
1348 ref(cBINOPo->op_first, o->op_type);
1349 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1350 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1351 : type == OP_RV2HV ? OPpDEREF_HV
1353 o->op_flags |= OPf_MOD;
1361 if (!(o->op_flags & OPf_KIDS))
1363 ref(cLISTOPo->op_last, type);
1373 S_dup_attrlist(pTHX_ OP *o)
1377 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1378 * where the first kid is OP_PUSHMARK and the remaining ones
1379 * are OP_CONST. We need to push the OP_CONST values.
1381 if (o->op_type == OP_CONST)
1382 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1384 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1385 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1386 if (o->op_type == OP_CONST)
1387 rop = append_elem(OP_LIST, rop,
1388 newSVOP(OP_CONST, o->op_flags,
1389 SvREFCNT_inc(cSVOPo->op_sv)));
1396 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1400 /* fake up C<use attributes $pkg,$rv,@attrs> */
1401 ENTER; /* need to protect against side-effects of 'use' */
1404 stashsv = newSVpv(HvNAME(stash), 0);
1406 stashsv = &PL_sv_no;
1408 #define ATTRSMODULE "attributes"
1409 #define ATTRSMODULE_PM "attributes.pm"
1413 /* Don't force the C<use> if we don't need it. */
1414 svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
1415 sizeof(ATTRSMODULE_PM)-1, 0);
1416 if (svp && *svp != &PL_sv_undef)
1417 ; /* already in %INC */
1419 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1420 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1424 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1425 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1427 prepend_elem(OP_LIST,
1428 newSVOP(OP_CONST, 0, stashsv),
1429 prepend_elem(OP_LIST,
1430 newSVOP(OP_CONST, 0,
1432 dup_attrlist(attrs))));
1438 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1440 OP *pack, *imop, *arg;
1446 assert(target->op_type == OP_PADSV ||
1447 target->op_type == OP_PADHV ||
1448 target->op_type == OP_PADAV);
1450 /* Ensure that attributes.pm is loaded. */
1451 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1453 /* Need package name for method call. */
1454 pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
1456 /* Build up the real arg-list. */
1458 stashsv = newSVpv(HvNAME(stash), 0);
1460 stashsv = &PL_sv_no;
1461 arg = newOP(OP_PADSV, 0);
1462 arg->op_targ = target->op_targ;
1463 arg = prepend_elem(OP_LIST,
1464 newSVOP(OP_CONST, 0, stashsv),
1465 prepend_elem(OP_LIST,
1466 newUNOP(OP_REFGEN, 0,
1467 mod(arg, OP_REFGEN)),
1468 dup_attrlist(attrs)));
1470 /* Fake up a method call to import */
1471 meth = newSVpvn("import", 6);
1472 (void)SvUPGRADE(meth, SVt_PVIV);
1473 (void)SvIOK_on(meth);
1474 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
1475 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1476 append_elem(OP_LIST,
1477 prepend_elem(OP_LIST, pack, list(arg)),
1478 newSVOP(OP_METHOD_NAMED, 0, meth)));
1479 imop->op_private |= OPpENTERSUB_NOMOD;
1481 /* Combine the ops. */
1482 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1486 =notfor apidoc apply_attrs_string
1488 Attempts to apply a list of attributes specified by the C<attrstr> and
1489 C<len> arguments to the subroutine identified by the C<cv> argument which
1490 is expected to be associated with the package identified by the C<stashpv>
1491 argument (see L<attributes>). It gets this wrong, though, in that it
1492 does not correctly identify the boundaries of the individual attribute
1493 specifications within C<attrstr>. This is not really intended for the
1494 public API, but has to be listed here for systems such as AIX which
1495 need an explicit export list for symbols. (It's called from XS code
1496 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1497 to respect attribute syntax properly would be welcome.
1503 Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
1504 char *attrstr, STRLEN len)
1509 len = strlen(attrstr);
1513 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1515 char *sstr = attrstr;
1516 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1517 attrs = append_elem(OP_LIST, attrs,
1518 newSVOP(OP_CONST, 0,
1519 newSVpvn(sstr, attrstr-sstr)));
1523 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1524 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1525 Nullsv, prepend_elem(OP_LIST,
1526 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1527 prepend_elem(OP_LIST,
1528 newSVOP(OP_CONST, 0,
1534 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1539 if (!o || PL_error_count)
1543 if (type == OP_LIST) {
1544 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1545 my_kid(kid, attrs, imopsp);
1546 } else if (type == OP_UNDEF) {
1548 } else if (type == OP_RV2SV || /* "our" declaration */
1550 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1551 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1552 yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
1553 OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
1555 GV *gv = cGVOPx_gv(cUNOPo->op_first);
1557 PL_in_my_stash = Nullhv;
1558 apply_attrs(GvSTASH(gv),
1559 (type == OP_RV2SV ? GvSV(gv) :
1560 type == OP_RV2AV ? (SV*)GvAV(gv) :
1561 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1564 o->op_private |= OPpOUR_INTRO;
1567 else if (type != OP_PADSV &&
1570 type != OP_PUSHMARK)
1572 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1574 PL_in_my == KEY_our ? "our" : "my"));
1577 else if (attrs && type != OP_PUSHMARK) {
1581 PL_in_my_stash = Nullhv;
1583 /* check for C<my Dog $spot> when deciding package */
1584 stash = PAD_COMPNAME_TYPE(o->op_targ);
1586 stash = PL_curstash;
1587 apply_attrs_my(stash, o, attrs, imopsp);
1589 o->op_flags |= OPf_MOD;
1590 o->op_private |= OPpLVAL_INTRO;
1595 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1598 int maybe_scalar = 0;
1600 /* [perl #17376]: this appears to be premature, and results in code such as
1601 C< our(%x); > executing in list mode rather than void mode */
1603 if (o->op_flags & OPf_PARENS)
1612 o = my_kid(o, attrs, &rops);
1614 if (maybe_scalar && o->op_type == OP_PADSV) {
1615 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1616 o->op_private |= OPpLVAL_INTRO;
1619 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1622 PL_in_my_stash = Nullhv;
1627 Perl_my(pTHX_ OP *o)
1629 return my_attrs(o, Nullop);
1633 Perl_sawparens(pTHX_ OP *o)
1636 o->op_flags |= OPf_PARENS;
1641 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1645 if (ckWARN(WARN_MISC) &&
1646 (left->op_type == OP_RV2AV ||
1647 left->op_type == OP_RV2HV ||
1648 left->op_type == OP_PADAV ||
1649 left->op_type == OP_PADHV)) {
1650 char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
1651 right->op_type == OP_TRANS)
1652 ? right->op_type : OP_MATCH];
1653 const char *sample = ((left->op_type == OP_RV2AV ||
1654 left->op_type == OP_PADAV)
1655 ? "@array" : "%hash");
1656 Perl_warner(aTHX_ packWARN(WARN_MISC),
1657 "Applying %s to %s will act on scalar(%s)",
1658 desc, sample, sample);
1661 if (right->op_type == OP_CONST &&
1662 cSVOPx(right)->op_private & OPpCONST_BARE &&
1663 cSVOPx(right)->op_private & OPpCONST_STRICT)
1665 no_bareword_allowed(right);
1668 if (!(right->op_flags & OPf_STACKED) &&
1669 (right->op_type == OP_MATCH ||
1670 right->op_type == OP_SUBST ||
1671 right->op_type == OP_TRANS)) {
1672 right->op_flags |= OPf_STACKED;
1673 if (right->op_type != OP_MATCH &&
1674 ! (right->op_type == OP_TRANS &&
1675 right->op_private & OPpTRANS_IDENTICAL))
1676 left = mod(left, right->op_type);
1677 if (right->op_type == OP_TRANS)
1678 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
1680 o = prepend_elem(right->op_type, scalar(left), right);
1682 return newUNOP(OP_NOT, 0, scalar(o));
1686 return bind_match(type, left,
1687 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
1691 Perl_invert(pTHX_ OP *o)
1695 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
1696 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1700 Perl_scope(pTHX_ OP *o)
1703 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1704 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1705 o->op_type = OP_LEAVE;
1706 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1709 if (o->op_type == OP_LINESEQ) {
1711 o->op_type = OP_SCOPE;
1712 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1713 kid = ((LISTOP*)o)->op_first;
1714 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
1718 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
1725 Perl_save_hints(pTHX)
1728 SAVESPTR(GvHV(PL_hintgv));
1729 GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
1730 SAVEFREESV(GvHV(PL_hintgv));
1734 Perl_block_start(pTHX_ int full)
1736 int retval = PL_savestack_ix;
1737 /* If there were syntax errors, don't try to start a block */
1738 if (PL_yynerrs) return retval;
1740 pad_block_start(full);
1742 PL_hints &= ~HINT_BLOCK_SCOPE;
1743 SAVESPTR(PL_compiling.cop_warnings);
1744 if (! specialWARN(PL_compiling.cop_warnings)) {
1745 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1746 SAVEFREESV(PL_compiling.cop_warnings) ;
1748 SAVESPTR(PL_compiling.cop_io);
1749 if (! specialCopIO(PL_compiling.cop_io)) {
1750 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1751 SAVEFREESV(PL_compiling.cop_io) ;
1757 Perl_block_end(pTHX_ I32 floor, OP *seq)
1759 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1760 line_t copline = PL_copline;
1761 OP* retval = scalarseq(seq);
1762 /* If there were syntax errors, don't try to close a block */
1763 if (PL_yynerrs) return retval;
1765 /* scalarseq() gave us an OP_STUB */
1766 retval->op_flags |= OPf_PARENS;
1767 /* there should be a nextstate in every block */
1768 retval = newSTATEOP(0, Nullch, retval);
1769 PL_copline = copline; /* XXX newSTATEOP may reset PL_copline */
1772 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
1774 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
1782 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1786 Perl_newPROG(pTHX_ OP *o)
1791 PL_eval_root = newUNOP(OP_LEAVEEVAL,
1792 ((PL_in_eval & EVAL_KEEPERR)
1793 ? OPf_SPECIAL : 0), o);
1794 PL_eval_start = linklist(PL_eval_root);
1795 PL_eval_root->op_private |= OPpREFCOUNTED;
1796 OpREFCNT_set(PL_eval_root, 1);
1797 PL_eval_root->op_next = 0;
1798 CALL_PEEP(PL_eval_start);
1803 PL_main_root = scope(sawparens(scalarvoid(o)));
1804 PL_curcop = &PL_compiling;
1805 PL_main_start = LINKLIST(PL_main_root);
1806 PL_main_root->op_private |= OPpREFCOUNTED;
1807 OpREFCNT_set(PL_main_root, 1);
1808 PL_main_root->op_next = 0;
1809 CALL_PEEP(PL_main_start);
1812 /* Register with debugger */
1814 CV *cv = get_cv("DB::postponed", FALSE);
1818 XPUSHs((SV*)CopFILEGV(&PL_compiling));
1820 call_sv((SV*)cv, G_DISCARD);
1827 Perl_localize(pTHX_ OP *o, I32 lex)
1829 if (o->op_flags & OPf_PARENS)
1830 /* [perl #17376]: this appears to be premature, and results in code such as
1831 C< our(%x); > executing in list mode rather than void mode */
1838 if (ckWARN(WARN_PARENTHESIS)
1839 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
1841 char *s = PL_bufptr;
1843 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ", *s)))
1846 if (*s == ';' || *s == '=')
1847 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
1848 "Parentheses missing around \"%s\" list",
1849 lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
1855 o = mod(o, OP_NULL); /* a bit kludgey */
1857 PL_in_my_stash = Nullhv;
1862 Perl_jmaybe(pTHX_ OP *o)
1864 if (o->op_type == OP_LIST) {
1866 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
1867 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
1873 Perl_fold_constants(pTHX_ register OP *o)
1876 I32 type = o->op_type;
1879 if (PL_opargs[type] & OA_RETSCALAR)
1881 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
1882 o->op_targ = pad_alloc(type, SVs_PADTMP);
1884 /* integerize op, unless it happens to be C<-foo>.
1885 * XXX should pp_i_negate() do magic string negation instead? */
1886 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
1887 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
1888 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
1890 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
1893 if (!(PL_opargs[type] & OA_FOLDCONST))
1898 /* XXX might want a ck_negate() for this */
1899 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
1911 /* XXX what about the numeric ops? */
1912 if (PL_hints & HINT_LOCALE)
1917 goto nope; /* Don't try to run w/ errors */
1919 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
1920 if ((curop->op_type != OP_CONST ||
1921 (curop->op_private & OPpCONST_BARE)) &&
1922 curop->op_type != OP_LIST &&
1923 curop->op_type != OP_SCALAR &&
1924 curop->op_type != OP_NULL &&
1925 curop->op_type != OP_PUSHMARK)
1931 curop = LINKLIST(o);
1935 sv = *(PL_stack_sp--);
1936 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
1937 pad_swipe(o->op_targ, FALSE);
1938 else if (SvTEMP(sv)) { /* grab mortal temp? */
1939 (void)SvREFCNT_inc(sv);
1943 if (type == OP_RV2GV)
1944 return newGVOP(OP_GV, 0, (GV*)sv);
1946 /* try to smush double to int, but don't smush -2.0 to -2 */
1947 if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
1950 #ifdef PERL_PRESERVE_IVUV
1951 /* Only bother to attempt to fold to IV if
1952 most operators will benefit */
1956 return newSVOP(OP_CONST, 0, sv);
1964 Perl_gen_constant_list(pTHX_ register OP *o)
1967 I32 oldtmps_floor = PL_tmps_floor;
1971 return o; /* Don't attempt to run with errors */
1973 PL_op = curop = LINKLIST(o);
1980 PL_tmps_floor = oldtmps_floor;
1982 o->op_type = OP_RV2AV;
1983 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
1984 o->op_seq = 0; /* needs to be revisited in peep() */
1985 curop = ((UNOP*)o)->op_first;
1986 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
1993 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
1995 if (!o || o->op_type != OP_LIST)
1996 o = newLISTOP(OP_LIST, 0, o, Nullop);
1998 o->op_flags &= ~OPf_WANT;
2000 if (!(PL_opargs[type] & OA_MARK))
2001 op_null(cLISTOPo->op_first);
2003 o->op_type = (OPCODE)type;
2004 o->op_ppaddr = PL_ppaddr[type];
2005 o->op_flags |= flags;
2007 o = CHECKOP(type, o);
2008 if (o->op_type != type)
2011 return fold_constants(o);
2014 /* List constructors */
2017 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2025 if (first->op_type != type
2026 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2028 return newLISTOP(type, 0, first, last);
2031 if (first->op_flags & OPf_KIDS)
2032 ((LISTOP*)first)->op_last->op_sibling = last;
2034 first->op_flags |= OPf_KIDS;
2035 ((LISTOP*)first)->op_first = last;
2037 ((LISTOP*)first)->op_last = last;
2042 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2050 if (first->op_type != type)
2051 return prepend_elem(type, (OP*)first, (OP*)last);
2053 if (last->op_type != type)
2054 return append_elem(type, (OP*)first, (OP*)last);
2056 first->op_last->op_sibling = last->op_first;
2057 first->op_last = last->op_last;
2058 first->op_flags |= (last->op_flags & OPf_KIDS);
2066 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2074 if (last->op_type == type) {
2075 if (type == OP_LIST) { /* already a PUSHMARK there */
2076 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2077 ((LISTOP*)last)->op_first->op_sibling = first;
2078 if (!(first->op_flags & OPf_PARENS))
2079 last->op_flags &= ~OPf_PARENS;
2082 if (!(last->op_flags & OPf_KIDS)) {
2083 ((LISTOP*)last)->op_last = first;
2084 last->op_flags |= OPf_KIDS;
2086 first->op_sibling = ((LISTOP*)last)->op_first;
2087 ((LISTOP*)last)->op_first = first;
2089 last->op_flags |= OPf_KIDS;
2093 return newLISTOP(type, 0, first, last);
2099 Perl_newNULLLIST(pTHX)
2101 return newOP(OP_STUB, 0);
2105 Perl_force_list(pTHX_ OP *o)
2107 if (!o || o->op_type != OP_LIST)
2108 o = newLISTOP(OP_LIST, 0, o, Nullop);
2114 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2118 NewOp(1101, listop, 1, LISTOP);
2120 listop->op_type = (OPCODE)type;
2121 listop->op_ppaddr = PL_ppaddr[type];
2124 listop->op_flags = (U8)flags;
2128 else if (!first && last)
2131 first->op_sibling = last;
2132 listop->op_first = first;
2133 listop->op_last = last;
2134 if (type == OP_LIST) {
2136 pushop = newOP(OP_PUSHMARK, 0);
2137 pushop->op_sibling = first;
2138 listop->op_first = pushop;
2139 listop->op_flags |= OPf_KIDS;
2141 listop->op_last = pushop;
2148 Perl_newOP(pTHX_ I32 type, I32 flags)
2151 NewOp(1101, o, 1, OP);
2152 o->op_type = (OPCODE)type;
2153 o->op_ppaddr = PL_ppaddr[type];
2154 o->op_flags = (U8)flags;
2157 o->op_private = (U8)(0 | (flags >> 8));
2158 if (PL_opargs[type] & OA_RETSCALAR)
2160 if (PL_opargs[type] & OA_TARGET)
2161 o->op_targ = pad_alloc(type, SVs_PADTMP);
2162 return CHECKOP(type, o);
2166 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2171 first = newOP(OP_STUB, 0);
2172 if (PL_opargs[type] & OA_MARK)
2173 first = force_list(first);
2175 NewOp(1101, unop, 1, UNOP);
2176 unop->op_type = (OPCODE)type;
2177 unop->op_ppaddr = PL_ppaddr[type];
2178 unop->op_first = first;
2179 unop->op_flags = flags | OPf_KIDS;
2180 unop->op_private = (U8)(1 | (flags >> 8));
2181 unop = (UNOP*) CHECKOP(type, unop);
2185 return fold_constants((OP *) unop);
2189 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2192 NewOp(1101, binop, 1, BINOP);
2195 first = newOP(OP_NULL, 0);
2197 binop->op_type = (OPCODE)type;
2198 binop->op_ppaddr = PL_ppaddr[type];
2199 binop->op_first = first;
2200 binop->op_flags = flags | OPf_KIDS;
2203 binop->op_private = (U8)(1 | (flags >> 8));
2206 binop->op_private = (U8)(2 | (flags >> 8));
2207 first->op_sibling = last;
2210 binop = (BINOP*)CHECKOP(type, binop);
2211 if (binop->op_next || binop->op_type != (OPCODE)type)
2214 binop->op_last = binop->op_first->op_sibling;
2216 return fold_constants((OP *)binop);
2220 uvcompare(const void *a, const void *b)
2222 if (*((UV *)a) < (*(UV *)b))
2224 if (*((UV *)a) > (*(UV *)b))
2226 if (*((UV *)a+1) < (*(UV *)b+1))
2228 if (*((UV *)a+1) > (*(UV *)b+1))
2234 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2236 SV *tstr = ((SVOP*)expr)->op_sv;
2237 SV *rstr = ((SVOP*)repl)->op_sv;
2240 U8 *t = (U8*)SvPV(tstr, tlen);
2241 U8 *r = (U8*)SvPV(rstr, rlen);
2248 register short *tbl;
2250 PL_hints |= HINT_BLOCK_SCOPE;
2251 complement = o->op_private & OPpTRANS_COMPLEMENT;
2252 del = o->op_private & OPpTRANS_DELETE;
2253 squash = o->op_private & OPpTRANS_SQUASH;
2256 o->op_private |= OPpTRANS_FROM_UTF;
2259 o->op_private |= OPpTRANS_TO_UTF;
2261 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2262 SV* listsv = newSVpvn("# comment\n",10);
2264 U8* tend = t + tlen;
2265 U8* rend = r + rlen;
2279 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2280 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2286 tsave = t = bytes_to_utf8(t, &len);
2289 if (!to_utf && rlen) {
2291 rsave = r = bytes_to_utf8(r, &len);
2295 /* There are several snags with this code on EBCDIC:
2296 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2297 2. scan_const() in toke.c has encoded chars in native encoding which makes
2298 ranges at least in EBCDIC 0..255 range the bottom odd.
2302 U8 tmpbuf[UTF8_MAXLEN+1];
2305 New(1109, cp, 2*tlen, UV);
2307 transv = newSVpvn("",0);
2309 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2311 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2313 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2317 cp[2*i+1] = cp[2*i];
2321 qsort(cp, i, 2*sizeof(UV), uvcompare);
2322 for (j = 0; j < i; j++) {
2324 diff = val - nextmin;
2326 t = uvuni_to_utf8(tmpbuf,nextmin);
2327 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2329 U8 range_mark = UTF_TO_NATIVE(0xff);
2330 t = uvuni_to_utf8(tmpbuf, val - 1);
2331 sv_catpvn(transv, (char *)&range_mark, 1);
2332 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2339 t = uvuni_to_utf8(tmpbuf,nextmin);
2340 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2342 U8 range_mark = UTF_TO_NATIVE(0xff);
2343 sv_catpvn(transv, (char *)&range_mark, 1);
2345 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2346 UNICODE_ALLOW_SUPER);
2347 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2348 t = (U8*)SvPVX(transv);
2349 tlen = SvCUR(transv);
2353 else if (!rlen && !del) {
2354 r = t; rlen = tlen; rend = tend;
2357 if ((!rlen && !del) || t == r ||
2358 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2360 o->op_private |= OPpTRANS_IDENTICAL;
2364 while (t < tend || tfirst <= tlast) {
2365 /* see if we need more "t" chars */
2366 if (tfirst > tlast) {
2367 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2369 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2371 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2378 /* now see if we need more "r" chars */
2379 if (rfirst > rlast) {
2381 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2383 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2385 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2394 rfirst = rlast = 0xffffffff;
2398 /* now see which range will peter our first, if either. */
2399 tdiff = tlast - tfirst;
2400 rdiff = rlast - rfirst;
2407 if (rfirst == 0xffffffff) {
2408 diff = tdiff; /* oops, pretend rdiff is infinite */
2410 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2411 (long)tfirst, (long)tlast);
2413 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2417 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2418 (long)tfirst, (long)(tfirst + diff),
2421 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2422 (long)tfirst, (long)rfirst);
2424 if (rfirst + diff > max)
2425 max = rfirst + diff;
2427 grows = (tfirst < rfirst &&
2428 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2440 else if (max > 0xff)
2445 Safefree(cPVOPo->op_pv);
2446 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2447 SvREFCNT_dec(listsv);
2449 SvREFCNT_dec(transv);
2451 if (!del && havefinal && rlen)
2452 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2453 newSVuv((UV)final), 0);
2456 o->op_private |= OPpTRANS_GROWS;
2468 tbl = (short*)cPVOPo->op_pv;
2470 Zero(tbl, 256, short);
2471 for (i = 0; i < (I32)tlen; i++)
2473 for (i = 0, j = 0; i < 256; i++) {
2475 if (j >= (I32)rlen) {
2484 if (i < 128 && r[j] >= 128)
2494 o->op_private |= OPpTRANS_IDENTICAL;
2496 else if (j >= (I32)rlen)
2499 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2500 tbl[0x100] = rlen - j;
2501 for (i=0; i < (I32)rlen - j; i++)
2502 tbl[0x101+i] = r[j+i];
2506 if (!rlen && !del) {
2509 o->op_private |= OPpTRANS_IDENTICAL;
2511 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2512 o->op_private |= OPpTRANS_IDENTICAL;
2514 for (i = 0; i < 256; i++)
2516 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
2517 if (j >= (I32)rlen) {
2519 if (tbl[t[i]] == -1)
2525 if (tbl[t[i]] == -1) {
2526 if (t[i] < 128 && r[j] >= 128)
2533 o->op_private |= OPpTRANS_GROWS;
2541 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2545 NewOp(1101, pmop, 1, PMOP);
2546 pmop->op_type = (OPCODE)type;
2547 pmop->op_ppaddr = PL_ppaddr[type];
2548 pmop->op_flags = (U8)flags;
2549 pmop->op_private = (U8)(0 | (flags >> 8));
2551 if (PL_hints & HINT_RE_TAINT)
2552 pmop->op_pmpermflags |= PMf_RETAINT;
2553 if (PL_hints & HINT_LOCALE)
2554 pmop->op_pmpermflags |= PMf_LOCALE;
2555 pmop->op_pmflags = pmop->op_pmpermflags;
2560 if(av_len((AV*) PL_regex_pad[0]) > -1) {
2561 repointer = av_pop((AV*)PL_regex_pad[0]);
2562 pmop->op_pmoffset = SvIV(repointer);
2563 SvREPADTMP_off(repointer);
2564 sv_setiv(repointer,0);
2566 repointer = newSViv(0);
2567 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2568 pmop->op_pmoffset = av_len(PL_regex_padav);
2569 PL_regex_pad = AvARRAY(PL_regex_padav);
2574 /* link into pm list */
2575 if (type != OP_TRANS && PL_curstash) {
2576 pmop->op_pmnext = HvPMROOT(PL_curstash);
2577 HvPMROOT(PL_curstash) = pmop;
2578 PmopSTASH_set(pmop,PL_curstash);
2585 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
2589 I32 repl_has_vars = 0;
2591 if (o->op_type == OP_TRANS)
2592 return pmtrans(o, expr, repl);
2594 PL_hints |= HINT_BLOCK_SCOPE;
2597 if (expr->op_type == OP_CONST) {
2599 SV *pat = ((SVOP*)expr)->op_sv;
2600 char *p = SvPV(pat, plen);
2601 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
2602 sv_setpvn(pat, "\\s+", 3);
2603 p = SvPV(pat, plen);
2604 pm->op_pmflags |= PMf_SKIPWHITE;
2607 pm->op_pmdynflags |= PMdf_UTF8;
2608 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
2609 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
2610 pm->op_pmflags |= PMf_WHITE;
2614 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2615 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2617 : OP_REGCMAYBE),0,expr);
2619 NewOp(1101, rcop, 1, LOGOP);
2620 rcop->op_type = OP_REGCOMP;
2621 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2622 rcop->op_first = scalar(expr);
2623 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
2624 ? (OPf_SPECIAL | OPf_KIDS)
2626 rcop->op_private = 1;
2629 /* establish postfix order */
2630 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2632 rcop->op_next = expr;
2633 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2636 rcop->op_next = LINKLIST(expr);
2637 expr->op_next = (OP*)rcop;
2640 prepend_elem(o->op_type, scalar((OP*)rcop), o);
2645 if (pm->op_pmflags & PMf_EVAL) {
2647 if (CopLINE(PL_curcop) < PL_multi_end)
2648 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
2650 else if (repl->op_type == OP_CONST)
2654 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
2655 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
2656 if (curop->op_type == OP_GV) {
2657 GV *gv = cGVOPx_gv(curop);
2659 if (strchr("&`'123456789+", *GvENAME(gv)))
2662 else if (curop->op_type == OP_RV2CV)
2664 else if (curop->op_type == OP_RV2SV ||
2665 curop->op_type == OP_RV2AV ||
2666 curop->op_type == OP_RV2HV ||
2667 curop->op_type == OP_RV2GV) {
2668 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2671 else if (curop->op_type == OP_PADSV ||
2672 curop->op_type == OP_PADAV ||
2673 curop->op_type == OP_PADHV ||
2674 curop->op_type == OP_PADANY) {
2677 else if (curop->op_type == OP_PUSHRE)
2678 ; /* Okay here, dangerous in newASSIGNOP */
2688 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
2689 pm->op_pmflags |= PMf_CONST; /* const for long enough */
2690 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
2691 prepend_elem(o->op_type, scalar(repl), o);
2694 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
2695 pm->op_pmflags |= PMf_MAYBE_CONST;
2696 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2698 NewOp(1101, rcop, 1, LOGOP);
2699 rcop->op_type = OP_SUBSTCONT;
2700 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
2701 rcop->op_first = scalar(repl);
2702 rcop->op_flags |= OPf_KIDS;
2703 rcop->op_private = 1;
2706 /* establish postfix order */
2707 rcop->op_next = LINKLIST(repl);
2708 repl->op_next = (OP*)rcop;
2710 pm->op_pmreplroot = scalar((OP*)rcop);
2711 pm->op_pmreplstart = LINKLIST(rcop);
2720 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
2723 NewOp(1101, svop, 1, SVOP);
2724 svop->op_type = (OPCODE)type;
2725 svop->op_ppaddr = PL_ppaddr[type];
2727 svop->op_next = (OP*)svop;
2728 svop->op_flags = (U8)flags;
2729 if (PL_opargs[type] & OA_RETSCALAR)
2731 if (PL_opargs[type] & OA_TARGET)
2732 svop->op_targ = pad_alloc(type, SVs_PADTMP);
2733 return CHECKOP(type, svop);
2737 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2740 NewOp(1101, padop, 1, PADOP);
2741 padop->op_type = (OPCODE)type;
2742 padop->op_ppaddr = PL_ppaddr[type];
2743 padop->op_padix = pad_alloc(type, SVs_PADTMP);
2744 SvREFCNT_dec(PAD_SVl(padop->op_padix));
2745 PAD_SETSV(padop->op_padix, sv);
2748 padop->op_next = (OP*)padop;
2749 padop->op_flags = (U8)flags;
2750 if (PL_opargs[type] & OA_RETSCALAR)
2752 if (PL_opargs[type] & OA_TARGET)
2753 padop->op_targ = pad_alloc(type, SVs_PADTMP);
2754 return CHECKOP(type, padop);
2758 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
2763 return newPADOP(type, flags, SvREFCNT_inc(gv));
2765 return newSVOP(type, flags, SvREFCNT_inc(gv));
2770 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
2773 NewOp(1101, pvop, 1, PVOP);
2774 pvop->op_type = (OPCODE)type;
2775 pvop->op_ppaddr = PL_ppaddr[type];
2777 pvop->op_next = (OP*)pvop;
2778 pvop->op_flags = (U8)flags;
2779 if (PL_opargs[type] & OA_RETSCALAR)
2781 if (PL_opargs[type] & OA_TARGET)
2782 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
2783 return CHECKOP(type, pvop);
2787 Perl_package(pTHX_ OP *o)
2792 save_hptr(&PL_curstash);
2793 save_item(PL_curstname);
2795 name = SvPV(cSVOPo->op_sv, len);
2796 PL_curstash = gv_stashpvn(name, len, TRUE);
2797 sv_setpvn(PL_curstname, name, len);
2800 PL_hints |= HINT_BLOCK_SCOPE;
2801 PL_copline = NOLINE;
2806 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
2812 if (id->op_type != OP_CONST)
2813 Perl_croak(aTHX_ "Module name must be constant");
2817 if (version != Nullop) {
2818 SV *vesv = ((SVOP*)version)->op_sv;
2820 if (arg == Nullop && !SvNIOKp(vesv)) {
2827 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
2828 Perl_croak(aTHX_ "Version number must be constant number");
2830 /* Make copy of id so we don't free it twice */
2831 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
2833 /* Fake up a method call to VERSION */
2834 meth = newSVpvn("VERSION",7);
2835 sv_upgrade(meth, SVt_PVIV);
2836 (void)SvIOK_on(meth);
2837 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
2838 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2839 append_elem(OP_LIST,
2840 prepend_elem(OP_LIST, pack, list(version)),
2841 newSVOP(OP_METHOD_NAMED, 0, meth)));
2845 /* Fake up an import/unimport */
2846 if (arg && arg->op_type == OP_STUB)
2847 imop = arg; /* no import on explicit () */
2848 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
2849 imop = Nullop; /* use 5.0; */
2854 /* Make copy of id so we don't free it twice */
2855 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
2857 /* Fake up a method call to import/unimport */
2858 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);
2859 (void)SvUPGRADE(meth, SVt_PVIV);
2860 (void)SvIOK_on(meth);
2861 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
2862 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2863 append_elem(OP_LIST,
2864 prepend_elem(OP_LIST, pack, list(arg)),
2865 newSVOP(OP_METHOD_NAMED, 0, meth)));
2868 /* Fake up the BEGIN {}, which does its thing immediately. */
2870 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
2873 append_elem(OP_LINESEQ,
2874 append_elem(OP_LINESEQ,
2875 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, id)),
2876 newSTATEOP(0, Nullch, veop)),
2877 newSTATEOP(0, Nullch, imop) ));
2879 /* The "did you use incorrect case?" warning used to be here.
2880 * The problem is that on case-insensitive filesystems one
2881 * might get false positives for "use" (and "require"):
2882 * "use Strict" or "require CARP" will work. This causes
2883 * portability problems for the script: in case-strict
2884 * filesystems the script will stop working.
2886 * The "incorrect case" warning checked whether "use Foo"
2887 * imported "Foo" to your namespace, but that is wrong, too:
2888 * there is no requirement nor promise in the language that
2889 * a Foo.pm should or would contain anything in package "Foo".
2891 * There is very little Configure-wise that can be done, either:
2892 * the case-sensitivity of the build filesystem of Perl does not
2893 * help in guessing the case-sensitivity of the runtime environment.
2896 PL_hints |= HINT_BLOCK_SCOPE;
2897 PL_copline = NOLINE;
2902 =head1 Embedding Functions
2904 =for apidoc load_module
2906 Loads the module whose name is pointed to by the string part of name.
2907 Note that the actual module name, not its filename, should be given.
2908 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
2909 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
2910 (or 0 for no flags). ver, if specified, provides version semantics
2911 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
2912 arguments can be used to specify arguments to the module's import()
2913 method, similar to C<use Foo::Bar VERSION LIST>.
2918 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
2921 va_start(args, ver);
2922 vload_module(flags, name, ver, &args);
2926 #ifdef PERL_IMPLICIT_CONTEXT
2928 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
2932 va_start(args, ver);
2933 vload_module(flags, name, ver, &args);
2939 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
2941 OP *modname, *veop, *imop;
2943 modname = newSVOP(OP_CONST, 0, name);
2944 modname->op_private |= OPpCONST_BARE;
2946 veop = newSVOP(OP_CONST, 0, ver);
2950 if (flags & PERL_LOADMOD_NOIMPORT) {
2951 imop = sawparens(newNULLLIST());
2953 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
2954 imop = va_arg(*args, OP*);
2959 sv = va_arg(*args, SV*);
2961 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
2962 sv = va_arg(*args, SV*);
2966 line_t ocopline = PL_copline;
2967 COP *ocurcop = PL_curcop;
2968 int oexpect = PL_expect;
2970 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
2971 veop, modname, imop);
2972 PL_expect = oexpect;
2973 PL_copline = ocopline;
2974 PL_curcop = ocurcop;
2979 Perl_dofile(pTHX_ OP *term)
2984 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
2985 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
2986 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
2988 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
2989 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
2990 append_elem(OP_LIST, term,
2991 scalar(newUNOP(OP_RV2CV, 0,
2996 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3002 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3004 return newBINOP(OP_LSLICE, flags,
3005 list(force_list(subscript)),
3006 list(force_list(listval)) );
3010 S_list_assignment(pTHX_ register OP *o)
3015 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3016 o = cUNOPo->op_first;
3018 if (o->op_type == OP_COND_EXPR) {
3019 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3020 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3025 yyerror("Assignment to both a list and a scalar");
3029 if (o->op_type == OP_LIST &&
3030 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3031 o->op_private & OPpLVAL_INTRO)
3034 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3035 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3036 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3039 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3042 if (o->op_type == OP_RV2SV)
3049 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3054 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3055 return newLOGOP(optype, 0,
3056 mod(scalar(left), optype),
3057 newUNOP(OP_SASSIGN, 0, scalar(right)));
3060 return newBINOP(optype, OPf_STACKED,
3061 mod(scalar(left), optype), scalar(right));
3065 if (list_assignment(left)) {
3069 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3070 left = mod(left, OP_AASSIGN);
3078 curop = list(force_list(left));
3079 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3080 o->op_private = (U8)(0 | (flags >> 8));
3082 /* PL_generation sorcery:
3083 * an assignment like ($a,$b) = ($c,$d) is easier than
3084 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3085 * To detect whether there are common vars, the global var
3086 * PL_generation is incremented for each assign op we compile.
3087 * Then, while compiling the assign op, we run through all the
3088 * variables on both sides of the assignment, setting a spare slot
3089 * in each of them to PL_generation. If any of them already have
3090 * that value, we know we've got commonality. We could use a
3091 * single bit marker, but then we'd have to make 2 passes, first
3092 * to clear the flag, then to test and set it. To find somewhere
3093 * to store these values, evil chicanery is done with SvCUR().
3096 if (!(left->op_private & OPpLVAL_INTRO)) {
3099 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3100 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3101 if (curop->op_type == OP_GV) {
3102 GV *gv = cGVOPx_gv(curop);
3103 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3105 SvCUR(gv) = PL_generation;
3107 else if (curop->op_type == OP_PADSV ||
3108 curop->op_type == OP_PADAV ||
3109 curop->op_type == OP_PADHV ||
3110 curop->op_type == OP_PADANY)
3112 if (PAD_COMPNAME_GEN(curop->op_targ)
3113 == (STRLEN)PL_generation)
3115 PAD_COMPNAME_GEN(curop->op_targ)
3119 else if (curop->op_type == OP_RV2CV)
3121 else if (curop->op_type == OP_RV2SV ||
3122 curop->op_type == OP_RV2AV ||
3123 curop->op_type == OP_RV2HV ||
3124 curop->op_type == OP_RV2GV) {
3125 if (lastop->op_type != OP_GV) /* funny deref? */
3128 else if (curop->op_type == OP_PUSHRE) {
3129 if (((PMOP*)curop)->op_pmreplroot) {
3131 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3132 ((PMOP*)curop)->op_pmreplroot));
3134 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3136 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3138 SvCUR(gv) = PL_generation;
3147 o->op_private |= OPpASSIGN_COMMON;
3149 if (right && right->op_type == OP_SPLIT) {
3151 if ((tmpop = ((LISTOP*)right)->op_first) &&
3152 tmpop->op_type == OP_PUSHRE)
3154 PMOP *pm = (PMOP*)tmpop;
3155 if (left->op_type == OP_RV2AV &&
3156 !(left->op_private & OPpLVAL_INTRO) &&
3157 !(o->op_private & OPpASSIGN_COMMON) )
3159 tmpop = ((UNOP*)left)->op_first;
3160 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3162 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3163 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3165 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3166 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3168 pm->op_pmflags |= PMf_ONCE;
3169 tmpop = cUNOPo->op_first; /* to list (nulled) */
3170 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3171 tmpop->op_sibling = Nullop; /* don't free split */
3172 right->op_next = tmpop->op_next; /* fix starting loc */
3173 op_free(o); /* blow off assign */
3174 right->op_flags &= ~OPf_WANT;
3175 /* "I don't know and I don't care." */
3180 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3181 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3183 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3185 sv_setiv(sv, PL_modcount+1);
3193 right = newOP(OP_UNDEF, 0);
3194 if (right->op_type == OP_READLINE) {
3195 right->op_flags |= OPf_STACKED;
3196 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3199 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3200 o = newBINOP(OP_SASSIGN, flags,
3201 scalar(right), mod(scalar(left), OP_SASSIGN) );
3213 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3215 U32 seq = intro_my();
3218 NewOp(1101, cop, 1, COP);
3219 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3220 cop->op_type = OP_DBSTATE;
3221 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3224 cop->op_type = OP_NEXTSTATE;
3225 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3227 cop->op_flags = (U8)flags;
3228 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3230 cop->op_private |= NATIVE_HINTS;
3232 PL_compiling.op_private = cop->op_private;
3233 cop->op_next = (OP*)cop;
3236 cop->cop_label = label;
3237 PL_hints |= HINT_BLOCK_SCOPE;
3240 cop->cop_arybase = PL_curcop->cop_arybase;
3241 if (specialWARN(PL_curcop->cop_warnings))
3242 cop->cop_warnings = PL_curcop->cop_warnings ;
3244 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3245 if (specialCopIO(PL_curcop->cop_io))
3246 cop->cop_io = PL_curcop->cop_io;
3248 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3251 if (PL_copline == NOLINE)
3252 CopLINE_set(cop, CopLINE(PL_curcop));
3254 CopLINE_set(cop, PL_copline);
3255 PL_copline = NOLINE;
3258 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3260 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3262 CopSTASH_set(cop, PL_curstash);
3264 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3265 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3266 if (svp && *svp != &PL_sv_undef ) {
3267 (void)SvIOK_on(*svp);
3268 SvIVX(*svp) = PTR2IV(cop);
3272 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3277 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3279 return new_logop(type, flags, &first, &other);
3283 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3287 OP *first = *firstp;
3288 OP *other = *otherp;
3290 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3291 return newBINOP(type, flags, scalar(first), scalar(other));
3293 scalarboolean(first);
3294 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3295 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3296 if (type == OP_AND || type == OP_OR) {
3302 first = *firstp = cUNOPo->op_first;
3304 first->op_next = o->op_next;
3305 cUNOPo->op_first = Nullop;
3309 if (first->op_type == OP_CONST) {
3310 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE)) {
3311 if (first->op_private & OPpCONST_STRICT)
3312 no_bareword_allowed(first);
3314 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3316 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3327 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3328 OP *k1 = ((UNOP*)first)->op_first;
3329 OP *k2 = k1->op_sibling;
3331 switch (first->op_type)
3334 if (k2 && k2->op_type == OP_READLINE
3335 && (k2->op_flags & OPf_STACKED)
3336 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3338 warnop = k2->op_type;
3343 if (k1->op_type == OP_READDIR
3344 || k1->op_type == OP_GLOB
3345 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3346 || k1->op_type == OP_EACH)
3348 warnop = ((k1->op_type == OP_NULL)
3349 ? (OPCODE)k1->op_targ : k1->op_type);
3354 line_t oldline = CopLINE(PL_curcop);
3355 CopLINE_set(PL_curcop, PL_copline);
3356 Perl_warner(aTHX_ packWARN(WARN_MISC),
3357 "Value of %s%s can be \"0\"; test with defined()",
3359 ((warnop == OP_READLINE || warnop == OP_GLOB)
3360 ? " construct" : "() operator"));
3361 CopLINE_set(PL_curcop, oldline);
3368 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3369 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3371 NewOp(1101, logop, 1, LOGOP);
3373 logop->op_type = (OPCODE)type;
3374 logop->op_ppaddr = PL_ppaddr[type];
3375 logop->op_first = first;
3376 logop->op_flags = flags | OPf_KIDS;
3377 logop->op_other = LINKLIST(other);
3378 logop->op_private = (U8)(1 | (flags >> 8));
3380 /* establish postfix order */
3381 logop->op_next = LINKLIST(first);
3382 first->op_next = (OP*)logop;
3383 first->op_sibling = other;
3385 o = newUNOP(OP_NULL, 0, (OP*)logop);
3392 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3399 return newLOGOP(OP_AND, 0, first, trueop);
3401 return newLOGOP(OP_OR, 0, first, falseop);
3403 scalarboolean(first);
3404 if (first->op_type == OP_CONST) {
3405 if (first->op_private & OPpCONST_BARE &&
3406 first->op_private & OPpCONST_STRICT) {
3407 no_bareword_allowed(first);
3409 if (SvTRUE(((SVOP*)first)->op_sv)) {
3420 NewOp(1101, logop, 1, LOGOP);
3421 logop->op_type = OP_COND_EXPR;
3422 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3423 logop->op_first = first;
3424 logop->op_flags = flags | OPf_KIDS;
3425 logop->op_private = (U8)(1 | (flags >> 8));
3426 logop->op_other = LINKLIST(trueop);
3427 logop->op_next = LINKLIST(falseop);
3430 /* establish postfix order */
3431 start = LINKLIST(first);
3432 first->op_next = (OP*)logop;
3434 first->op_sibling = trueop;
3435 trueop->op_sibling = falseop;
3436 o = newUNOP(OP_NULL, 0, (OP*)logop);
3438 trueop->op_next = falseop->op_next = o;
3445 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3453 NewOp(1101, range, 1, LOGOP);
3455 range->op_type = OP_RANGE;
3456 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3457 range->op_first = left;
3458 range->op_flags = OPf_KIDS;
3459 leftstart = LINKLIST(left);
3460 range->op_other = LINKLIST(right);
3461 range->op_private = (U8)(1 | (flags >> 8));
3463 left->op_sibling = right;
3465 range->op_next = (OP*)range;
3466 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3467 flop = newUNOP(OP_FLOP, 0, flip);
3468 o = newUNOP(OP_NULL, 0, flop);
3470 range->op_next = leftstart;
3472 left->op_next = flip;
3473 right->op_next = flop;
3475 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3476 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3477 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3478 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3480 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3481 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3484 if (!flip->op_private || !flop->op_private)
3485 linklist(o); /* blow off optimizer unless constant */
3491 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3495 int once = block && block->op_flags & OPf_SPECIAL &&
3496 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3499 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3500 return block; /* do {} while 0 does once */
3501 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3502 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3503 expr = newUNOP(OP_DEFINED, 0,
3504 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3505 } else if (expr->op_flags & OPf_KIDS) {
3506 OP *k1 = ((UNOP*)expr)->op_first;
3507 OP *k2 = (k1) ? k1->op_sibling : NULL;
3508 switch (expr->op_type) {
3510 if (k2 && k2->op_type == OP_READLINE
3511 && (k2->op_flags & OPf_STACKED)
3512 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3513 expr = newUNOP(OP_DEFINED, 0, expr);
3517 if (k1->op_type == OP_READDIR
3518 || k1->op_type == OP_GLOB
3519 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3520 || k1->op_type == OP_EACH)
3521 expr = newUNOP(OP_DEFINED, 0, expr);
3527 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3528 o = new_logop(OP_AND, 0, &expr, &listop);
3531 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3533 if (once && o != listop)
3534 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3537 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3539 o->op_flags |= flags;
3541 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3546 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3554 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3555 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3556 expr = newUNOP(OP_DEFINED, 0,
3557 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3558 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3559 OP *k1 = ((UNOP*)expr)->op_first;
3560 OP *k2 = (k1) ? k1->op_sibling : NULL;
3561 switch (expr->op_type) {
3563 if (k2 && k2->op_type == OP_READLINE
3564 && (k2->op_flags & OPf_STACKED)
3565 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3566 expr = newUNOP(OP_DEFINED, 0, expr);
3570 if (k1->op_type == OP_READDIR
3571 || k1->op_type == OP_GLOB
3572 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3573 || k1->op_type == OP_EACH)
3574 expr = newUNOP(OP_DEFINED, 0, expr);
3580 block = newOP(OP_NULL, 0);
3582 block = scope(block);
3586 next = LINKLIST(cont);
3589 OP *unstack = newOP(OP_UNSTACK, 0);
3592 cont = append_elem(OP_LINESEQ, cont, unstack);
3593 if ((line_t)whileline != NOLINE) {
3594 PL_copline = (line_t)whileline;
3595 cont = append_elem(OP_LINESEQ, cont,
3596 newSTATEOP(0, Nullch, Nullop));
3600 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3601 redo = LINKLIST(listop);
3604 PL_copline = (line_t)whileline;
3606 o = new_logop(OP_AND, 0, &expr, &listop);
3607 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3608 op_free(expr); /* oops, it's a while (0) */
3610 return Nullop; /* listop already freed by new_logop */
3613 ((LISTOP*)listop)->op_last->op_next =
3614 (o == listop ? redo : LINKLIST(o));
3620 NewOp(1101,loop,1,LOOP);
3621 loop->op_type = OP_ENTERLOOP;
3622 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3623 loop->op_private = 0;
3624 loop->op_next = (OP*)loop;
3627 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3629 loop->op_redoop = redo;
3630 loop->op_lastop = o;
3631 o->op_private |= loopflags;
3634 loop->op_nextop = next;
3636 loop->op_nextop = o;
3638 o->op_flags |= flags;
3639 o->op_private |= (flags >> 8);
3644 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
3648 PADOFFSET padoff = 0;
3652 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
3653 sv->op_type = OP_RV2GV;
3654 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3656 else if (sv->op_type == OP_PADSV) { /* private variable */
3657 padoff = sv->op_targ;
3662 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3663 padoff = sv->op_targ;
3665 iterflags |= OPf_SPECIAL;
3670 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3673 sv = newGVOP(OP_GV, 0, PL_defgv);
3675 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3676 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3677 iterflags |= OPf_STACKED;
3679 else if (expr->op_type == OP_NULL &&
3680 (expr->op_flags & OPf_KIDS) &&
3681 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3683 /* Basically turn for($x..$y) into the same as for($x,$y), but we
3684 * set the STACKED flag to indicate that these values are to be
3685 * treated as min/max values by 'pp_iterinit'.
3687 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
3688 LOGOP* range = (LOGOP*) flip->op_first;
3689 OP* left = range->op_first;
3690 OP* right = left->op_sibling;
3693 range->op_flags &= ~OPf_KIDS;
3694 range->op_first = Nullop;
3696 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
3697 listop->op_first->op_next = range->op_next;
3698 left->op_next = range->op_other;
3699 right->op_next = (OP*)listop;
3700 listop->op_next = listop->op_first;
3703 expr = (OP*)(listop);
3705 iterflags |= OPf_STACKED;
3708 expr = mod(force_list(expr), OP_GREPSTART);
3712 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
3713 append_elem(OP_LIST, expr, scalar(sv))));
3714 assert(!loop->op_next);
3715 #ifdef PL_OP_SLAB_ALLOC
3718 NewOp(1234,tmp,1,LOOP);
3719 Copy(loop,tmp,1,LOOP);
3724 Renew(loop, 1, LOOP);
3726 loop->op_targ = padoff;
3727 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
3728 PL_copline = forline;
3729 return newSTATEOP(0, label, wop);
3733 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
3738 if (type != OP_GOTO || label->op_type == OP_CONST) {
3739 /* "last()" means "last" */
3740 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
3741 o = newOP(type, OPf_SPECIAL);
3743 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
3744 ? SvPVx(((SVOP*)label)->op_sv, n_a)
3750 if (label->op_type == OP_ENTERSUB)
3751 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
3752 o = newUNOP(type, OPf_STACKED, label);
3754 PL_hints |= HINT_BLOCK_SCOPE;
3759 =for apidoc cv_undef
3761 Clear out all the active components of a CV. This can happen either
3762 by an explicit C<undef &foo>, or by the reference count going to zero.
3763 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
3764 children can still follow the full lexical scope chain.
3770 Perl_cv_undef(pTHX_ CV *cv)
3773 if (CvFILE(cv) && !CvXSUB(cv)) {
3774 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
3775 Safefree(CvFILE(cv));
3780 if (!CvXSUB(cv) && CvROOT(cv)) {
3782 Perl_croak(aTHX_ "Can't undef active subroutine");
3785 PAD_SAVE_SETNULLPAD();
3787 op_free(CvROOT(cv));
3788 CvROOT(cv) = Nullop;
3791 SvPOK_off((SV*)cv); /* forget prototype */
3796 /* remove CvOUTSIDE unless this is an undef rather than a free */
3797 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
3798 if (!CvWEAKOUTSIDE(cv))
3799 SvREFCNT_dec(CvOUTSIDE(cv));
3800 CvOUTSIDE(cv) = Nullcv;
3803 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
3809 /* delete all flags except WEAKOUTSIDE */
3810 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
3814 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
3816 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
3817 SV* msg = sv_newmortal();
3821 gv_efullname3(name = sv_newmortal(), gv, Nullch);
3822 sv_setpv(msg, "Prototype mismatch:");
3824 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
3826 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (SV *)cv);
3827 sv_catpv(msg, " vs ");
3829 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
3831 sv_catpv(msg, "none");
3832 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
3836 static void const_sv_xsub(pTHX_ CV* cv);
3840 =head1 Optree Manipulation Functions
3842 =for apidoc cv_const_sv
3844 If C<cv> is a constant sub eligible for inlining. returns the constant
3845 value returned by the sub. Otherwise, returns NULL.
3847 Constant subs can be created with C<newCONSTSUB> or as described in
3848 L<perlsub/"Constant Functions">.
3853 Perl_cv_const_sv(pTHX_ CV *cv)
3855 if (!cv || !CvCONST(cv))
3857 return (SV*)CvXSUBANY(cv).any_ptr;
3861 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
3868 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
3869 o = cLISTOPo->op_first->op_sibling;
3871 for (; o; o = o->op_next) {
3872 OPCODE type = o->op_type;
3874 if (sv && o->op_next == o)
3876 if (o->op_next != o) {
3877 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
3879 if (type == OP_DBSTATE)
3882 if (type == OP_LEAVESUB || type == OP_RETURN)
3886 if (type == OP_CONST && cSVOPo->op_sv)
3888 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
3889 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
3893 /* We get here only from cv_clone2() while creating a closure.
3894 Copy the const value here instead of in cv_clone2 so that
3895 SvREADONLY_on doesn't lead to problems when leaving
3900 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
3912 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
3922 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
3926 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
3928 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
3932 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
3938 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
3942 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
3943 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
3944 SV *sv = sv_newmortal();
3945 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
3946 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
3947 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3952 gv = gv_fetchpv(name ? name : (aname ? aname :
3953 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__")),
3954 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
3964 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
3965 maximum a prototype before. */
3966 if (SvTYPE(gv) > SVt_NULL) {
3967 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
3968 && ckWARN_d(WARN_PROTOTYPE))
3970 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
3972 cv_ckproto((CV*)gv, NULL, ps);
3975 sv_setpv((SV*)gv, ps);
3977 sv_setiv((SV*)gv, -1);
3978 SvREFCNT_dec(PL_compcv);
3979 cv = PL_compcv = NULL;
3980 PL_sub_generation++;
3984 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
3986 #ifdef GV_UNIQUE_CHECK
3987 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
3988 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
3992 if (!block || !ps || *ps || attrs)
3995 const_sv = op_const_sv(block, Nullcv);
3998 bool exists = CvROOT(cv) || CvXSUB(cv);
4000 #ifdef GV_UNIQUE_CHECK
4001 if (exists && GvUNIQUE(gv)) {
4002 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4006 /* if the subroutine doesn't exist and wasn't pre-declared
4007 * with a prototype, assume it will be AUTOLOADed,
4008 * skipping the prototype check
4010 if (exists || SvPOK(cv))
4011 cv_ckproto(cv, gv, ps);
4012 /* already defined (or promised)? */
4013 if (exists || GvASSUMECV(gv)) {
4014 if (!block && !attrs) {
4015 if (CvFLAGS(PL_compcv)) {
4016 /* might have had built-in attrs applied */
4017 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4019 /* just a "sub foo;" when &foo is already defined */
4020 SAVEFREESV(PL_compcv);
4023 /* ahem, death to those who redefine active sort subs */
4024 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4025 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4027 if (ckWARN(WARN_REDEFINE)
4029 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4031 line_t oldline = CopLINE(PL_curcop);
4032 if (PL_copline != NOLINE)
4033 CopLINE_set(PL_curcop, PL_copline);
4034 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4035 CvCONST(cv) ? "Constant subroutine %s redefined"
4036 : "Subroutine %s redefined", name);
4037 CopLINE_set(PL_curcop, oldline);
4045 SvREFCNT_inc(const_sv);
4047 assert(!CvROOT(cv) && !CvCONST(cv));
4048 sv_setpv((SV*)cv, ""); /* prototype is "" */
4049 CvXSUBANY(cv).any_ptr = const_sv;
4050 CvXSUB(cv) = const_sv_xsub;
4055 cv = newCONSTSUB(NULL, name, const_sv);
4058 SvREFCNT_dec(PL_compcv);
4060 PL_sub_generation++;
4067 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4068 * before we clobber PL_compcv.
4072 /* Might have had built-in attributes applied -- propagate them. */
4073 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4074 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4075 stash = GvSTASH(CvGV(cv));
4076 else if (CvSTASH(cv))
4077 stash = CvSTASH(cv);
4079 stash = PL_curstash;
4082 /* possibly about to re-define existing subr -- ignore old cv */
4083 rcv = (SV*)PL_compcv;
4084 if (name && GvSTASH(gv))
4085 stash = GvSTASH(gv);
4087 stash = PL_curstash;
4089 apply_attrs(stash, rcv, attrs, FALSE);
4091 if (cv) { /* must reuse cv if autoloaded */
4093 /* got here with just attrs -- work done, so bug out */
4094 SAVEFREESV(PL_compcv);
4097 /* transfer PL_compcv to cv */
4099 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4100 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4101 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4102 CvOUTSIDE(PL_compcv) = 0;
4103 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4104 CvPADLIST(PL_compcv) = 0;
4105 /* inner references to PL_compcv must be fixed up ... */
4106 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4107 /* ... before we throw it away */
4108 SvREFCNT_dec(PL_compcv);
4109 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4110 ++PL_sub_generation;
4117 PL_sub_generation++;
4121 CvFILE_set_from_cop(cv, PL_curcop);
4122 CvSTASH(cv) = PL_curstash;
4125 sv_setpv((SV*)cv, ps);
4127 if (PL_error_count) {
4131 char *s = strrchr(name, ':');
4133 if (strEQ(s, "BEGIN")) {
4135 "BEGIN not safe after errors--compilation aborted";
4136 if (PL_in_eval & EVAL_KEEPERR)
4137 Perl_croak(aTHX_ not_safe);
4139 /* force display of errors found but not reported */
4140 sv_catpv(ERRSV, not_safe);
4141 Perl_croak(aTHX_ "%"SVf, ERRSV);
4150 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4151 mod(scalarseq(block), OP_LEAVESUBLV));
4154 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4156 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4157 OpREFCNT_set(CvROOT(cv), 1);
4158 CvSTART(cv) = LINKLIST(CvROOT(cv));
4159 CvROOT(cv)->op_next = 0;
4160 CALL_PEEP(CvSTART(cv));
4162 /* now that optimizer has done its work, adjust pad values */
4164 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4167 assert(!CvCONST(cv));
4168 if (ps && !*ps && op_const_sv(block, cv))
4172 if (name || aname) {
4174 char *tname = (name ? name : aname);
4176 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4177 SV *sv = NEWSV(0,0);
4178 SV *tmpstr = sv_newmortal();
4179 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4183 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4185 (long)PL_subline, (long)CopLINE(PL_curcop));
4186 gv_efullname3(tmpstr, gv, Nullch);
4187 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4188 hv = GvHVn(db_postponed);
4189 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4190 && (pcv = GvCV(db_postponed)))
4196 call_sv((SV*)pcv, G_DISCARD);
4200 if ((s = strrchr(tname,':')))
4205 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4208 if (strEQ(s, "BEGIN")) {
4209 I32 oldscope = PL_scopestack_ix;
4211 SAVECOPFILE(&PL_compiling);
4212 SAVECOPLINE(&PL_compiling);
4215 PL_beginav = newAV();
4216 DEBUG_x( dump_sub(gv) );
4217 av_push(PL_beginav, (SV*)cv);
4218 GvCV(gv) = 0; /* cv has been hijacked */
4219 call_list(oldscope, PL_beginav);
4221 PL_curcop = &PL_compiling;
4222 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4225 else if (strEQ(s, "END") && !PL_error_count) {
4228 DEBUG_x( dump_sub(gv) );
4229 av_unshift(PL_endav, 1);
4230 av_store(PL_endav, 0, (SV*)cv);
4231 GvCV(gv) = 0; /* cv has been hijacked */
4233 else if (strEQ(s, "CHECK") && !PL_error_count) {
4235 PL_checkav = newAV();
4236 DEBUG_x( dump_sub(gv) );
4237 if (PL_main_start && ckWARN(WARN_VOID))
4238 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4239 av_unshift(PL_checkav, 1);
4240 av_store(PL_checkav, 0, (SV*)cv);
4241 GvCV(gv) = 0; /* cv has been hijacked */
4243 else if (strEQ(s, "INIT") && !PL_error_count) {
4245 PL_initav = newAV();
4246 DEBUG_x( dump_sub(gv) );
4247 if (PL_main_start && ckWARN(WARN_VOID))
4248 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4249 av_push(PL_initav, (SV*)cv);
4250 GvCV(gv) = 0; /* cv has been hijacked */
4255 PL_copline = NOLINE;
4260 /* XXX unsafe for threads if eval_owner isn't held */
4262 =for apidoc newCONSTSUB
4264 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4265 eligible for inlining at compile-time.
4271 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4277 SAVECOPLINE(PL_curcop);
4278 CopLINE_set(PL_curcop, PL_copline);
4281 PL_hints &= ~HINT_BLOCK_SCOPE;
4284 SAVESPTR(PL_curstash);
4285 SAVECOPSTASH(PL_curcop);
4286 PL_curstash = stash;
4287 CopSTASH_set(PL_curcop,stash);
4290 cv = newXS(name, const_sv_xsub, __FILE__);
4291 CvXSUBANY(cv).any_ptr = sv;
4293 sv_setpv((SV*)cv, ""); /* prototype is "" */
4301 =for apidoc U||newXS
4303 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4309 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
4311 GV *gv = gv_fetchpv(name ? name :
4312 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4313 GV_ADDMULTI, SVt_PVCV);
4317 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4319 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4321 /* just a cached method */
4325 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4326 /* already defined (or promised) */
4327 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4328 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4329 line_t oldline = CopLINE(PL_curcop);
4330 if (PL_copline != NOLINE)
4331 CopLINE_set(PL_curcop, PL_copline);
4332 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4333 CvCONST(cv) ? "Constant subroutine %s redefined"
4334 : "Subroutine %s redefined"
4336 CopLINE_set(PL_curcop, oldline);
4343 if (cv) /* must reuse cv if autoloaded */
4346 cv = (CV*)NEWSV(1105,0);
4347 sv_upgrade((SV *)cv, SVt_PVCV);
4351 PL_sub_generation++;
4355 (void)gv_fetchfile(filename);
4356 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
4357 an external constant string */
4358 CvXSUB(cv) = subaddr;
4361 char *s = strrchr(name,':');
4367 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4370 if (strEQ(s, "BEGIN")) {
4372 PL_beginav = newAV();
4373 av_push(PL_beginav, (SV*)cv);
4374 GvCV(gv) = 0; /* cv has been hijacked */
4376 else if (strEQ(s, "END")) {
4379 av_unshift(PL_endav, 1);
4380 av_store(PL_endav, 0, (SV*)cv);
4381 GvCV(gv) = 0; /* cv has been hijacked */
4383 else if (strEQ(s, "CHECK")) {
4385 PL_checkav = newAV();
4386 if (PL_main_start && ckWARN(WARN_VOID))
4387 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4388 av_unshift(PL_checkav, 1);
4389 av_store(PL_checkav, 0, (SV*)cv);
4390 GvCV(gv) = 0; /* cv has been hijacked */
4392 else if (strEQ(s, "INIT")) {
4394 PL_initav = newAV();
4395 if (PL_main_start && ckWARN(WARN_VOID))
4396 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4397 av_push(PL_initav, (SV*)cv);
4398 GvCV(gv) = 0; /* cv has been hijacked */
4409 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4417 name = SvPVx(cSVOPo->op_sv, n_a);
4420 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
4421 #ifdef GV_UNIQUE_CHECK
4423 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4427 if ((cv = GvFORM(gv))) {
4428 if (ckWARN(WARN_REDEFINE)) {
4429 line_t oldline = CopLINE(PL_curcop);
4430 if (PL_copline != NOLINE)
4431 CopLINE_set(PL_curcop, PL_copline);
4432 Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Format %s redefined",name);
4433 CopLINE_set(PL_curcop, oldline);
4440 CvFILE_set_from_cop(cv, PL_curcop);
4443 pad_tidy(padtidy_FORMAT);
4444 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4445 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4446 OpREFCNT_set(CvROOT(cv), 1);
4447 CvSTART(cv) = LINKLIST(CvROOT(cv));
4448 CvROOT(cv)->op_next = 0;
4449 CALL_PEEP(CvSTART(cv));
4451 PL_copline = NOLINE;
4456 Perl_newANONLIST(pTHX_ OP *o)
4458 return newUNOP(OP_REFGEN, 0,
4459 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4463 Perl_newANONHASH(pTHX_ OP *o)
4465 return newUNOP(OP_REFGEN, 0,
4466 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4470 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4472 return newANONATTRSUB(floor, proto, Nullop, block);
4476 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4478 return newUNOP(OP_REFGEN, 0,
4479 newSVOP(OP_ANONCODE, 0,
4480 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
4484 Perl_oopsAV(pTHX_ OP *o)
4486 switch (o->op_type) {
4488 o->op_type = OP_PADAV;
4489 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4490 return ref(o, OP_RV2AV);
4493 o->op_type = OP_RV2AV;
4494 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4499 if (ckWARN_d(WARN_INTERNAL))
4500 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
4507 Perl_oopsHV(pTHX_ OP *o)
4509 switch (o->op_type) {
4512 o->op_type = OP_PADHV;
4513 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4514 return ref(o, OP_RV2HV);
4518 o->op_type = OP_RV2HV;
4519 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
4524 if (ckWARN_d(WARN_INTERNAL))
4525 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
4532 Perl_newAVREF(pTHX_ OP *o)
4534 if (o->op_type == OP_PADANY) {
4535 o->op_type = OP_PADAV;
4536 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4539 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
4540 && ckWARN(WARN_DEPRECATED)) {
4541 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4542 "Using an array as a reference is deprecated");
4544 return newUNOP(OP_RV2AV, 0, scalar(o));
4548 Perl_newGVREF(pTHX_ I32 type, OP *o)
4550 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
4551 return newUNOP(OP_NULL, 0, o);
4552 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
4556 Perl_newHVREF(pTHX_ OP *o)
4558 if (o->op_type == OP_PADANY) {
4559 o->op_type = OP_PADHV;
4560 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4563 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
4564 && ckWARN(WARN_DEPRECATED)) {
4565 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4566 "Using a hash as a reference is deprecated");
4568 return newUNOP(OP_RV2HV, 0, scalar(o));
4572 Perl_oopsCV(pTHX_ OP *o)
4574 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
4580 Perl_newCVREF(pTHX_ I32 flags, OP *o)
4582 return newUNOP(OP_RV2CV, flags, scalar(o));
4586 Perl_newSVREF(pTHX_ OP *o)
4588 if (o->op_type == OP_PADANY) {
4589 o->op_type = OP_PADSV;
4590 o->op_ppaddr = PL_ppaddr[OP_PADSV];
4593 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4594 o->op_flags |= OPpDONE_SVREF;
4597 return newUNOP(OP_RV2SV, 0, scalar(o));
4600 /* Check routines. */
4603 Perl_ck_anoncode(pTHX_ OP *o)
4605 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
4606 cSVOPo->op_sv = Nullsv;
4611 Perl_ck_bitop(pTHX_ OP *o)
4613 #define OP_IS_NUMCOMPARE(op) \
4614 ((op) == OP_LT || (op) == OP_I_LT || \
4615 (op) == OP_GT || (op) == OP_I_GT || \
4616 (op) == OP_LE || (op) == OP_I_LE || \
4617 (op) == OP_GE || (op) == OP_I_GE || \
4618 (op) == OP_EQ || (op) == OP_I_EQ || \
4619 (op) == OP_NE || (op) == OP_I_NE || \
4620 (op) == OP_NCMP || (op) == OP_I_NCMP)
4621 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4622 if (o->op_type == OP_BIT_OR
4623 || o->op_type == OP_BIT_AND
4624 || o->op_type == OP_BIT_XOR)
4626 OPCODE typfirst = cBINOPo->op_first->op_type;
4627 OPCODE typlast = cBINOPo->op_first->op_sibling->op_type;
4628 if (OP_IS_NUMCOMPARE(typfirst) || OP_IS_NUMCOMPARE(typlast))
4629 if (ckWARN(WARN_PRECEDENCE))
4630 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4631 "Possible precedence problem on bitwise %c operator",
4632 o->op_type == OP_BIT_OR ? '|'
4633 : o->op_type == OP_BIT_AND ? '&' : '^'
4640 Perl_ck_concat(pTHX_ OP *o)
4642 if (cUNOPo->op_first->op_type == OP_CONCAT)
4643 o->op_flags |= OPf_STACKED;
4648 Perl_ck_spair(pTHX_ OP *o)
4650 if (o->op_flags & OPf_KIDS) {
4653 OPCODE type = o->op_type;
4654 o = modkids(ck_fun(o), type);
4655 kid = cUNOPo->op_first;
4656 newop = kUNOP->op_first->op_sibling;
4658 (newop->op_sibling ||
4659 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
4660 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
4661 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
4665 op_free(kUNOP->op_first);
4666 kUNOP->op_first = newop;
4668 o->op_ppaddr = PL_ppaddr[++o->op_type];
4673 Perl_ck_delete(pTHX_ OP *o)
4677 if (o->op_flags & OPf_KIDS) {
4678 OP *kid = cUNOPo->op_first;
4679 switch (kid->op_type) {
4681 o->op_flags |= OPf_SPECIAL;
4684 o->op_private |= OPpSLICE;
4687 o->op_flags |= OPf_SPECIAL;
4692 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
4701 Perl_ck_die(pTHX_ OP *o)
4704 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4710 Perl_ck_eof(pTHX_ OP *o)
4712 I32 type = o->op_type;
4714 if (o->op_flags & OPf_KIDS) {
4715 if (cLISTOPo->op_first->op_type == OP_STUB) {
4717 o = newUNOP(type, OPf_SPECIAL,
4718 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
4726 Perl_ck_eval(pTHX_ OP *o)
4728 PL_hints |= HINT_BLOCK_SCOPE;
4729 if (o->op_flags & OPf_KIDS) {
4730 SVOP *kid = (SVOP*)cUNOPo->op_first;
4733 o->op_flags &= ~OPf_KIDS;
4736 else if (kid->op_type == OP_LINESEQ) {
4739 kid->op_next = o->op_next;
4740 cUNOPo->op_first = 0;
4743 NewOp(1101, enter, 1, LOGOP);
4744 enter->op_type = OP_ENTERTRY;
4745 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
4746 enter->op_private = 0;
4748 /* establish postfix order */
4749 enter->op_next = (OP*)enter;
4751 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
4752 o->op_type = OP_LEAVETRY;
4753 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
4754 enter->op_other = o;
4762 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
4764 o->op_targ = (PADOFFSET)PL_hints;
4769 Perl_ck_exit(pTHX_ OP *o)
4772 HV *table = GvHV(PL_hintgv);
4774 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
4775 if (svp && *svp && SvTRUE(*svp))
4776 o->op_private |= OPpEXIT_VMSISH;
4778 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4784 Perl_ck_exec(pTHX_ OP *o)
4787 if (o->op_flags & OPf_STACKED) {
4789 kid = cUNOPo->op_first->op_sibling;
4790 if (kid->op_type == OP_RV2GV)
4799 Perl_ck_exists(pTHX_ OP *o)
4802 if (o->op_flags & OPf_KIDS) {
4803 OP *kid = cUNOPo->op_first;
4804 if (kid->op_type == OP_ENTERSUB) {
4805 (void) ref(kid, o->op_type);
4806 if (kid->op_type != OP_RV2CV && !PL_error_count)
4807 Perl_croak(aTHX_ "%s argument is not a subroutine name",
4809 o->op_private |= OPpEXISTS_SUB;
4811 else if (kid->op_type == OP_AELEM)
4812 o->op_flags |= OPf_SPECIAL;
4813 else if (kid->op_type != OP_HELEM)
4814 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
4823 Perl_ck_gvconst(pTHX_ register OP *o)
4825 o = fold_constants(o);
4826 if (o->op_type == OP_CONST)
4833 Perl_ck_rvconst(pTHX_ register OP *o)
4835 SVOP *kid = (SVOP*)cUNOPo->op_first;
4837 o->op_private |= (PL_hints & HINT_STRICT_REFS);
4838 if (kid->op_type == OP_CONST) {
4842 SV *kidsv = kid->op_sv;
4845 /* Is it a constant from cv_const_sv()? */
4846 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
4847 SV *rsv = SvRV(kidsv);
4848 int svtype = SvTYPE(rsv);
4849 char *badtype = Nullch;
4851 switch (o->op_type) {
4853 if (svtype > SVt_PVMG)
4854 badtype = "a SCALAR";
4857 if (svtype != SVt_PVAV)
4858 badtype = "an ARRAY";
4861 if (svtype != SVt_PVHV)
4865 if (svtype != SVt_PVCV)
4870 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
4873 name = SvPV(kidsv, n_a);
4874 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
4875 char *badthing = Nullch;
4876 switch (o->op_type) {
4878 badthing = "a SCALAR";
4881 badthing = "an ARRAY";
4884 badthing = "a HASH";
4889 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
4893 * This is a little tricky. We only want to add the symbol if we
4894 * didn't add it in the lexer. Otherwise we get duplicate strict
4895 * warnings. But if we didn't add it in the lexer, we must at
4896 * least pretend like we wanted to add it even if it existed before,
4897 * or we get possible typo warnings. OPpCONST_ENTERED says
4898 * whether the lexer already added THIS instance of this symbol.
4900 iscv = (o->op_type == OP_RV2CV) * 2;
4902 gv = gv_fetchpv(name,
4903 iscv | !(kid->op_private & OPpCONST_ENTERED),
4906 : o->op_type == OP_RV2SV
4908 : o->op_type == OP_RV2AV
4910 : o->op_type == OP_RV2HV
4913 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
4915 kid->op_type = OP_GV;
4916 SvREFCNT_dec(kid->op_sv);
4918 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
4919 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
4920 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
4922 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
4924 kid->op_sv = SvREFCNT_inc(gv);
4926 kid->op_private = 0;
4927 kid->op_ppaddr = PL_ppaddr[OP_GV];
4934 Perl_ck_ftst(pTHX_ OP *o)
4936 I32 type = o->op_type;
4938 if (o->op_flags & OPf_REF) {
4941 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
4942 SVOP *kid = (SVOP*)cUNOPo->op_first;
4944 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
4946 OP *newop = newGVOP(type, OPf_REF,
4947 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
4954 if (type == OP_FTTTY)
4955 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
4958 o = newUNOP(type, 0, newDEFSVOP());
4964 Perl_ck_fun(pTHX_ OP *o)
4970 int type = o->op_type;
4971 register I32 oa = PL_opargs[type] >> OASHIFT;
4973 if (o->op_flags & OPf_STACKED) {
4974 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
4977 return no_fh_allowed(o);
4980 if (o->op_flags & OPf_KIDS) {
4982 tokid = &cLISTOPo->op_first;
4983 kid = cLISTOPo->op_first;
4984 if (kid->op_type == OP_PUSHMARK ||
4985 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
4987 tokid = &kid->op_sibling;
4988 kid = kid->op_sibling;
4990 if (!kid && PL_opargs[type] & OA_DEFGV)
4991 *tokid = kid = newDEFSVOP();
4995 sibl = kid->op_sibling;
4998 /* list seen where single (scalar) arg expected? */
4999 if (numargs == 1 && !(oa >> 4)
5000 && kid->op_type == OP_LIST && type != OP_SCALAR)
5002 return too_many_arguments(o,PL_op_desc[type]);
5015 if ((type == OP_PUSH || type == OP_UNSHIFT)
5016 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5017 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5018 "Useless use of %s with no values",
5021 if (kid->op_type == OP_CONST &&
5022 (kid->op_private & OPpCONST_BARE))
5024 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5025 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5026 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5027 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5028 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5029 "Array @%s missing the @ in argument %"IVdf" of %s()",
5030 name, (IV)numargs, PL_op_desc[type]);
5033 kid->op_sibling = sibl;
5036 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5037 bad_type(numargs, "array", PL_op_desc[type], kid);
5041 if (kid->op_type == OP_CONST &&
5042 (kid->op_private & OPpCONST_BARE))
5044 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5045 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5046 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5047 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5048 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5049 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5050 name, (IV)numargs, PL_op_desc[type]);
5053 kid->op_sibling = sibl;
5056 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5057 bad_type(numargs, "hash", PL_op_desc[type], kid);
5062 OP *newop = newUNOP(OP_NULL, 0, kid);
5063 kid->op_sibling = 0;
5065 newop->op_next = newop;
5067 kid->op_sibling = sibl;
5072 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5073 if (kid->op_type == OP_CONST &&
5074 (kid->op_private & OPpCONST_BARE))
5076 OP *newop = newGVOP(OP_GV, 0,
5077 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5079 if (!(o->op_private & 1) && /* if not unop */
5080 kid == cLISTOPo->op_last)
5081 cLISTOPo->op_last = newop;
5085 else if (kid->op_type == OP_READLINE) {
5086 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5087 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5090 I32 flags = OPf_SPECIAL;
5094 /* is this op a FH constructor? */
5095 if (is_handle_constructor(o,numargs)) {
5096 char *name = Nullch;
5100 /* Set a flag to tell rv2gv to vivify
5101 * need to "prove" flag does not mean something
5102 * else already - NI-S 1999/05/07
5105 if (kid->op_type == OP_PADSV) {
5106 /*XXX DAPM 2002.08.25 tmp assert test */
5107 /*XXX*/ assert(av_fetch(PL_comppad_name, (kid->op_targ), FALSE));
5108 /*XXX*/ assert(*av_fetch(PL_comppad_name, (kid->op_targ), FALSE));
5110 name = PAD_COMPNAME_PV(kid->op_targ);
5111 /* SvCUR of a pad namesv can't be trusted
5112 * (see PL_generation), so calc its length
5118 else if (kid->op_type == OP_RV2SV
5119 && kUNOP->op_first->op_type == OP_GV)
5121 GV *gv = cGVOPx_gv(kUNOP->op_first);
5123 len = GvNAMELEN(gv);
5125 else if (kid->op_type == OP_AELEM
5126 || kid->op_type == OP_HELEM)
5128 name = "__ANONIO__";
5134 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5135 namesv = PAD_SVl(targ);
5136 (void)SvUPGRADE(namesv, SVt_PV);
5138 sv_setpvn(namesv, "$", 1);
5139 sv_catpvn(namesv, name, len);
5142 kid->op_sibling = 0;
5143 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5144 kid->op_targ = targ;
5145 kid->op_private |= priv;
5147 kid->op_sibling = sibl;
5153 mod(scalar(kid), type);
5157 tokid = &kid->op_sibling;
5158 kid = kid->op_sibling;
5160 o->op_private |= numargs;
5162 return too_many_arguments(o,OP_DESC(o));
5165 else if (PL_opargs[type] & OA_DEFGV) {
5167 return newUNOP(type, 0, newDEFSVOP());
5171 while (oa & OA_OPTIONAL)
5173 if (oa && oa != OA_LIST)
5174 return too_few_arguments(o,OP_DESC(o));
5180 Perl_ck_glob(pTHX_ OP *o)
5185 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5186 append_elem(OP_GLOB, o, newDEFSVOP());
5188 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5189 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5191 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5194 #if !defined(PERL_EXTERNAL_GLOB)
5195 /* XXX this can be tightened up and made more failsafe. */
5199 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5200 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5201 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5202 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5203 GvCV(gv) = GvCV(glob_gv);
5204 SvREFCNT_inc((SV*)GvCV(gv));
5205 GvIMPORTED_CV_on(gv);
5208 #endif /* PERL_EXTERNAL_GLOB */
5210 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5211 append_elem(OP_GLOB, o,
5212 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5213 o->op_type = OP_LIST;
5214 o->op_ppaddr = PL_ppaddr[OP_LIST];
5215 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5216 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5217 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5218 append_elem(OP_LIST, o,
5219 scalar(newUNOP(OP_RV2CV, 0,
5220 newGVOP(OP_GV, 0, gv)))));
5221 o = newUNOP(OP_NULL, 0, ck_subr(o));
5222 o->op_targ = OP_GLOB; /* hint at what it used to be */
5225 gv = newGVgen("main");
5227 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5233 Perl_ck_grep(pTHX_ OP *o)
5237 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5239 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5240 NewOp(1101, gwop, 1, LOGOP);
5242 if (o->op_flags & OPf_STACKED) {
5245 kid = cLISTOPo->op_first->op_sibling;
5246 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5249 kid->op_next = (OP*)gwop;
5250 o->op_flags &= ~OPf_STACKED;
5252 kid = cLISTOPo->op_first->op_sibling;
5253 if (type == OP_MAPWHILE)
5260 kid = cLISTOPo->op_first->op_sibling;
5261 if (kid->op_type != OP_NULL)
5262 Perl_croak(aTHX_ "panic: ck_grep");
5263 kid = kUNOP->op_first;
5265 gwop->op_type = type;
5266 gwop->op_ppaddr = PL_ppaddr[type];
5267 gwop->op_first = listkids(o);
5268 gwop->op_flags |= OPf_KIDS;
5269 gwop->op_private = 1;
5270 gwop->op_other = LINKLIST(kid);
5271 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5272 kid->op_next = (OP*)gwop;
5274 kid = cLISTOPo->op_first->op_sibling;
5275 if (!kid || !kid->op_sibling)
5276 return too_few_arguments(o,OP_DESC(o));
5277 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5278 mod(kid, OP_GREPSTART);
5284 Perl_ck_index(pTHX_ OP *o)
5286 if (o->op_flags & OPf_KIDS) {
5287 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5289 kid = kid->op_sibling; /* get past "big" */
5290 if (kid && kid->op_type == OP_CONST)
5291 fbm_compile(((SVOP*)kid)->op_sv, 0);
5297 Perl_ck_lengthconst(pTHX_ OP *o)
5299 /* XXX length optimization goes here */
5304 Perl_ck_lfun(pTHX_ OP *o)
5306 OPCODE type = o->op_type;
5307 return modkids(ck_fun(o), type);
5311 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5313 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5314 switch (cUNOPo->op_first->op_type) {
5316 /* This is needed for
5317 if (defined %stash::)
5318 to work. Do not break Tk.
5320 break; /* Globals via GV can be undef */
5322 case OP_AASSIGN: /* Is this a good idea? */
5323 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5324 "defined(@array) is deprecated");
5325 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5326 "\t(Maybe you should just omit the defined()?)\n");
5329 /* This is needed for
5330 if (defined %stash::)
5331 to work. Do not break Tk.
5333 break; /* Globals via GV can be undef */
5335 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5336 "defined(%%hash) is deprecated");
5337 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5338 "\t(Maybe you should just omit the defined()?)\n");
5349 Perl_ck_rfun(pTHX_ OP *o)
5351 OPCODE type = o->op_type;
5352 return refkids(ck_fun(o), type);
5356 Perl_ck_listiob(pTHX_ OP *o)
5360 kid = cLISTOPo->op_first;
5363 kid = cLISTOPo->op_first;
5365 if (kid->op_type == OP_PUSHMARK)
5366 kid = kid->op_sibling;
5367 if (kid && o->op_flags & OPf_STACKED)
5368 kid = kid->op_sibling;
5369 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5370 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5371 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5372 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5373 cLISTOPo->op_first->op_sibling = kid;
5374 cLISTOPo->op_last = kid;
5375 kid = kid->op_sibling;
5380 append_elem(o->op_type, o, newDEFSVOP());
5386 Perl_ck_sassign(pTHX_ OP *o)
5388 OP *kid = cLISTOPo->op_first;
5389 /* has a disposable target? */
5390 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5391 && !(kid->op_flags & OPf_STACKED)
5392 /* Cannot steal the second time! */
5393 && !(kid->op_private & OPpTARGET_MY))
5395 OP *kkid = kid->op_sibling;
5397 /* Can just relocate the target. */
5398 if (kkid && kkid->op_type == OP_PADSV
5399 && !(kkid->op_private & OPpLVAL_INTRO))
5401 kid->op_targ = kkid->op_targ;
5403 /* Now we do not need PADSV and SASSIGN. */
5404 kid->op_sibling = o->op_sibling; /* NULL */
5405 cLISTOPo->op_first = NULL;
5408 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
5416 Perl_ck_match(pTHX_ OP *o)
5418 o->op_private |= OPpRUNTIME;
5423 Perl_ck_method(pTHX_ OP *o)
5425 OP *kid = cUNOPo->op_first;
5426 if (kid->op_type == OP_CONST) {
5427 SV* sv = kSVOP->op_sv;
5428 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
5430 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5431 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
5434 kSVOP->op_sv = Nullsv;
5436 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5445 Perl_ck_null(pTHX_ OP *o)
5451 Perl_ck_open(pTHX_ OP *o)
5453 HV *table = GvHV(PL_hintgv);
5457 svp = hv_fetch(table, "open_IN", 7, FALSE);
5459 mode = mode_from_discipline(*svp);
5460 if (mode & O_BINARY)
5461 o->op_private |= OPpOPEN_IN_RAW;
5462 else if (mode & O_TEXT)
5463 o->op_private |= OPpOPEN_IN_CRLF;
5466 svp = hv_fetch(table, "open_OUT", 8, FALSE);
5468 mode = mode_from_discipline(*svp);
5469 if (mode & O_BINARY)
5470 o->op_private |= OPpOPEN_OUT_RAW;
5471 else if (mode & O_TEXT)
5472 o->op_private |= OPpOPEN_OUT_CRLF;
5475 if (o->op_type == OP_BACKTICK)
5481 Perl_ck_repeat(pTHX_ OP *o)
5483 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5484 o->op_private |= OPpREPEAT_DOLIST;
5485 cBINOPo->op_first = force_list(cBINOPo->op_first);
5493 Perl_ck_require(pTHX_ OP *o)
5497 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
5498 SVOP *kid = (SVOP*)cUNOPo->op_first;
5500 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5502 for (s = SvPVX(kid->op_sv); *s; s++) {
5503 if (*s == ':' && s[1] == ':') {
5505 Move(s+2, s+1, strlen(s+2)+1, char);
5506 --SvCUR(kid->op_sv);
5509 if (SvREADONLY(kid->op_sv)) {
5510 SvREADONLY_off(kid->op_sv);
5511 sv_catpvn(kid->op_sv, ".pm", 3);
5512 SvREADONLY_on(kid->op_sv);
5515 sv_catpvn(kid->op_sv, ".pm", 3);
5519 /* handle override, if any */
5520 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
5521 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
5522 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
5524 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5525 OP *kid = cUNOPo->op_first;
5526 cUNOPo->op_first = 0;
5528 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5529 append_elem(OP_LIST, kid,
5530 scalar(newUNOP(OP_RV2CV, 0,
5539 Perl_ck_return(pTHX_ OP *o)
5542 if (CvLVALUE(PL_compcv)) {
5543 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5544 mod(kid, OP_LEAVESUBLV);
5551 Perl_ck_retarget(pTHX_ OP *o)
5553 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5560 Perl_ck_select(pTHX_ OP *o)
5563 if (o->op_flags & OPf_KIDS) {
5564 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5565 if (kid && kid->op_sibling) {
5566 o->op_type = OP_SSELECT;
5567 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
5569 return fold_constants(o);
5573 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5574 if (kid && kid->op_type == OP_RV2GV)
5575 kid->op_private &= ~HINT_STRICT_REFS;
5580 Perl_ck_shift(pTHX_ OP *o)
5582 I32 type = o->op_type;
5584 if (!(o->op_flags & OPf_KIDS)) {
5588 argop = newUNOP(OP_RV2AV, 0,
5589 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
5590 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
5591 return newUNOP(type, 0, scalar(argop));
5593 return scalar(modkids(ck_fun(o), type));
5597 Perl_ck_sort(pTHX_ OP *o)
5601 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
5603 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5604 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
5606 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
5608 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
5610 if (kid->op_type == OP_SCOPE) {
5614 else if (kid->op_type == OP_LEAVE) {
5615 if (o->op_type == OP_SORT) {
5616 op_null(kid); /* wipe out leave */
5619 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
5620 if (k->op_next == kid)
5622 /* don't descend into loops */
5623 else if (k->op_type == OP_ENTERLOOP
5624 || k->op_type == OP_ENTERITER)
5626 k = cLOOPx(k)->op_lastop;
5631 kid->op_next = 0; /* just disconnect the leave */
5632 k = kLISTOP->op_first;
5637 if (o->op_type == OP_SORT) {
5638 /* provide scalar context for comparison function/block */
5644 o->op_flags |= OPf_SPECIAL;
5646 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
5649 firstkid = firstkid->op_sibling;
5652 /* provide list context for arguments */
5653 if (o->op_type == OP_SORT)
5660 S_simplify_sort(pTHX_ OP *o)
5662 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5666 if (!(o->op_flags & OPf_STACKED))
5668 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
5669 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
5670 kid = kUNOP->op_first; /* get past null */
5671 if (kid->op_type != OP_SCOPE)
5673 kid = kLISTOP->op_last; /* get past scope */
5674 switch(kid->op_type) {
5682 k = kid; /* remember this node*/
5683 if (kBINOP->op_first->op_type != OP_RV2SV)
5685 kid = kBINOP->op_first; /* get past cmp */
5686 if (kUNOP->op_first->op_type != OP_GV)
5688 kid = kUNOP->op_first; /* get past rv2sv */
5690 if (GvSTASH(gv) != PL_curstash)
5692 if (strEQ(GvNAME(gv), "a"))
5694 else if (strEQ(GvNAME(gv), "b"))
5698 kid = k; /* back to cmp */
5699 if (kBINOP->op_last->op_type != OP_RV2SV)
5701 kid = kBINOP->op_last; /* down to 2nd arg */
5702 if (kUNOP->op_first->op_type != OP_GV)
5704 kid = kUNOP->op_first; /* get past rv2sv */
5706 if (GvSTASH(gv) != PL_curstash
5708 ? strNE(GvNAME(gv), "a")
5709 : strNE(GvNAME(gv), "b")))
5711 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
5713 o->op_private |= OPpSORT_REVERSE;
5714 if (k->op_type == OP_NCMP)
5715 o->op_private |= OPpSORT_NUMERIC;
5716 if (k->op_type == OP_I_NCMP)
5717 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
5718 kid = cLISTOPo->op_first->op_sibling;
5719 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
5720 op_free(kid); /* then delete it */
5724 Perl_ck_split(pTHX_ OP *o)
5728 if (o->op_flags & OPf_STACKED)
5729 return no_fh_allowed(o);
5731 kid = cLISTOPo->op_first;
5732 if (kid->op_type != OP_NULL)
5733 Perl_croak(aTHX_ "panic: ck_split");
5734 kid = kid->op_sibling;
5735 op_free(cLISTOPo->op_first);
5736 cLISTOPo->op_first = kid;
5738 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
5739 cLISTOPo->op_last = kid; /* There was only one element previously */
5742 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
5743 OP *sibl = kid->op_sibling;
5744 kid->op_sibling = 0;
5745 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
5746 if (cLISTOPo->op_first == cLISTOPo->op_last)
5747 cLISTOPo->op_last = kid;
5748 cLISTOPo->op_first = kid;
5749 kid->op_sibling = sibl;
5752 kid->op_type = OP_PUSHRE;
5753 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
5755 if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
5756 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
5757 "Use of /g modifier is meaningless in split");
5760 if (!kid->op_sibling)
5761 append_elem(OP_SPLIT, o, newDEFSVOP());
5763 kid = kid->op_sibling;
5766 if (!kid->op_sibling)
5767 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
5769 kid = kid->op_sibling;
5772 if (kid->op_sibling)
5773 return too_many_arguments(o,OP_DESC(o));
5779 Perl_ck_join(pTHX_ OP *o)
5781 if (ckWARN(WARN_SYNTAX)) {
5782 OP *kid = cLISTOPo->op_first->op_sibling;
5783 if (kid && kid->op_type == OP_MATCH) {
5784 char *pmstr = "STRING";
5785 if (PM_GETRE(kPMOP))
5786 pmstr = PM_GETRE(kPMOP)->precomp;
5787 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5788 "/%s/ should probably be written as \"%s\"",
5796 Perl_ck_subr(pTHX_ OP *o)
5798 OP *prev = ((cUNOPo->op_first->op_sibling)
5799 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
5800 OP *o2 = prev->op_sibling;
5807 I32 contextclass = 0;
5811 o->op_private |= OPpENTERSUB_HASTARG;
5812 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
5813 if (cvop->op_type == OP_RV2CV) {
5815 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
5816 op_null(cvop); /* disable rv2cv */
5817 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
5818 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
5819 GV *gv = cGVOPx_gv(tmpop);
5822 tmpop->op_private |= OPpEARLY_CV;
5823 else if (SvPOK(cv)) {
5824 namegv = CvANON(cv) ? gv : CvGV(cv);
5825 proto = SvPV((SV*)cv, n_a);
5829 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
5830 if (o2->op_type == OP_CONST)
5831 o2->op_private &= ~OPpCONST_STRICT;
5832 else if (o2->op_type == OP_LIST) {
5833 OP *o = ((UNOP*)o2)->op_first->op_sibling;
5834 if (o && o->op_type == OP_CONST)
5835 o->op_private &= ~OPpCONST_STRICT;
5838 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5839 if (PERLDB_SUB && PL_curstash != PL_debstash)
5840 o->op_private |= OPpENTERSUB_DB;
5841 while (o2 != cvop) {
5845 return too_many_arguments(o, gv_ename(namegv));
5863 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
5865 arg == 1 ? "block or sub {}" : "sub {}",
5866 gv_ename(namegv), o2);
5869 /* '*' allows any scalar type, including bareword */
5872 if (o2->op_type == OP_RV2GV)
5873 goto wrapref; /* autoconvert GLOB -> GLOBref */
5874 else if (o2->op_type == OP_CONST)
5875 o2->op_private &= ~OPpCONST_STRICT;
5876 else if (o2->op_type == OP_ENTERSUB) {
5877 /* accidental subroutine, revert to bareword */
5878 OP *gvop = ((UNOP*)o2)->op_first;
5879 if (gvop && gvop->op_type == OP_NULL) {
5880 gvop = ((UNOP*)gvop)->op_first;
5882 for (; gvop->op_sibling; gvop = gvop->op_sibling)
5885 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
5886 (gvop = ((UNOP*)gvop)->op_first) &&
5887 gvop->op_type == OP_GV)
5889 GV *gv = cGVOPx_gv(gvop);
5890 OP *sibling = o2->op_sibling;
5891 SV *n = newSVpvn("",0);
5893 gv_fullname3(n, gv, "");
5894 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
5895 sv_chop(n, SvPVX(n)+6);
5896 o2 = newSVOP(OP_CONST, 0, n);
5897 prev->op_sibling = o2;
5898 o2->op_sibling = sibling;
5914 if (contextclass++ == 0) {
5915 e = strchr(proto, ']');
5916 if (!e || e == proto)
5929 while (*--p != '[');
5930 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
5931 gv_ename(namegv), o2);
5937 if (o2->op_type == OP_RV2GV)
5940 bad_type(arg, "symbol", gv_ename(namegv), o2);
5943 if (o2->op_type == OP_ENTERSUB)
5946 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
5949 if (o2->op_type == OP_RV2SV ||
5950 o2->op_type == OP_PADSV ||
5951 o2->op_type == OP_HELEM ||
5952 o2->op_type == OP_AELEM ||
5953 o2->op_type == OP_THREADSV)
5956 bad_type(arg, "scalar", gv_ename(namegv), o2);
5959 if (o2->op_type == OP_RV2AV ||
5960 o2->op_type == OP_PADAV)
5963 bad_type(arg, "array", gv_ename(namegv), o2);
5966 if (o2->op_type == OP_RV2HV ||
5967 o2->op_type == OP_PADHV)
5970 bad_type(arg, "hash", gv_ename(namegv), o2);
5975 OP* sib = kid->op_sibling;
5976 kid->op_sibling = 0;
5977 o2 = newUNOP(OP_REFGEN, 0, kid);
5978 o2->op_sibling = sib;
5979 prev->op_sibling = o2;
5981 if (contextclass && e) {
5996 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
5997 gv_ename(namegv), cv);
6002 mod(o2, OP_ENTERSUB);
6004 o2 = o2->op_sibling;
6006 if (proto && !optional &&
6007 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6008 return too_few_arguments(o, gv_ename(namegv));
6013 Perl_ck_svconst(pTHX_ OP *o)
6015 SvREADONLY_on(cSVOPo->op_sv);
6020 Perl_ck_trunc(pTHX_ OP *o)
6022 if (o->op_flags & OPf_KIDS) {
6023 SVOP *kid = (SVOP*)cUNOPo->op_first;
6025 if (kid->op_type == OP_NULL)
6026 kid = (SVOP*)kid->op_sibling;
6027 if (kid && kid->op_type == OP_CONST &&
6028 (kid->op_private & OPpCONST_BARE))
6030 o->op_flags |= OPf_SPECIAL;
6031 kid->op_private &= ~OPpCONST_STRICT;
6038 Perl_ck_substr(pTHX_ OP *o)
6041 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6042 OP *kid = cLISTOPo->op_first;
6044 if (kid->op_type == OP_NULL)
6045 kid = kid->op_sibling;
6047 kid->op_flags |= OPf_MOD;
6053 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6056 Perl_peep(pTHX_ register OP *o)
6058 register OP* oldop = 0;
6060 if (!o || o->op_seq)
6064 SAVEVPTR(PL_curcop);
6065 for (; o; o = o->op_next) {
6068 /* The special value -1 is used by the B::C compiler backend to indicate
6069 * that an op is statically defined and should not be freed */
6070 if (!PL_op_seqmax || PL_op_seqmax == (U16)-1)
6073 switch (o->op_type) {
6077 PL_curcop = ((COP*)o); /* for warnings */
6078 o->op_seq = PL_op_seqmax++;
6082 if (cSVOPo->op_private & OPpCONST_STRICT)
6083 no_bareword_allowed(o);
6085 case OP_METHOD_NAMED:
6086 /* Relocate sv to the pad for thread safety.
6087 * Despite being a "constant", the SV is written to,
6088 * for reference counts, sv_upgrade() etc. */
6090 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6091 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6092 /* If op_sv is already a PADTMP then it is being used by
6093 * some pad, so make a copy. */
6094 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6095 SvREADONLY_on(PAD_SVl(ix));
6096 SvREFCNT_dec(cSVOPo->op_sv);
6099 SvREFCNT_dec(PAD_SVl(ix));
6100 SvPADTMP_on(cSVOPo->op_sv);
6101 PAD_SETSV(ix, cSVOPo->op_sv);
6102 /* XXX I don't know how this isn't readonly already. */
6103 SvREADONLY_on(PAD_SVl(ix));
6105 cSVOPo->op_sv = Nullsv;
6109 o->op_seq = PL_op_seqmax++;
6113 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6114 if (o->op_next->op_private & OPpTARGET_MY) {
6115 if (o->op_flags & OPf_STACKED) /* chained concats */
6116 goto ignore_optimization;
6118 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6119 o->op_targ = o->op_next->op_targ;
6120 o->op_next->op_targ = 0;
6121 o->op_private |= OPpTARGET_MY;
6124 op_null(o->op_next);
6126 ignore_optimization:
6127 o->op_seq = PL_op_seqmax++;
6130 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6131 o->op_seq = PL_op_seqmax++;
6132 break; /* Scalar stub must produce undef. List stub is noop */
6136 if (o->op_targ == OP_NEXTSTATE
6137 || o->op_targ == OP_DBSTATE
6138 || o->op_targ == OP_SETSTATE)
6140 PL_curcop = ((COP*)o);
6142 /* XXX: We avoid setting op_seq here to prevent later calls
6143 to peep() from mistakenly concluding that optimisation
6144 has already occurred. This doesn't fix the real problem,
6145 though (See 20010220.007). AMS 20010719 */
6146 if (oldop && o->op_next) {
6147 oldop->op_next = o->op_next;
6155 if (oldop && o->op_next) {
6156 oldop->op_next = o->op_next;
6159 o->op_seq = PL_op_seqmax++;
6163 if (o->op_next->op_type == OP_RV2SV) {
6164 if (!(o->op_next->op_private & OPpDEREF)) {
6165 op_null(o->op_next);
6166 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6168 o->op_next = o->op_next->op_next;
6169 o->op_type = OP_GVSV;
6170 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6173 else if (o->op_next->op_type == OP_RV2AV) {
6174 OP* pop = o->op_next->op_next;
6176 if (pop && pop->op_type == OP_CONST &&
6177 (PL_op = pop->op_next) &&
6178 pop->op_next->op_type == OP_AELEM &&
6179 !(pop->op_next->op_private &
6180 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6181 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6186 op_null(o->op_next);
6187 op_null(pop->op_next);
6189 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6190 o->op_next = pop->op_next->op_next;
6191 o->op_type = OP_AELEMFAST;
6192 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6193 o->op_private = (U8)i;
6198 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6200 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6201 /* XXX could check prototype here instead of just carping */
6202 SV *sv = sv_newmortal();
6203 gv_efullname3(sv, gv, Nullch);
6204 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6205 "%"SVf"() called too early to check prototype",
6209 else if (o->op_next->op_type == OP_READLINE
6210 && o->op_next->op_next->op_type == OP_CONCAT
6211 && (o->op_next->op_next->op_flags & OPf_STACKED))
6213 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6214 o->op_type = OP_RCATLINE;
6215 o->op_flags |= OPf_STACKED;
6216 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6217 op_null(o->op_next->op_next);
6218 op_null(o->op_next);
6221 o->op_seq = PL_op_seqmax++;
6234 o->op_seq = PL_op_seqmax++;
6235 while (cLOGOP->op_other->op_type == OP_NULL)
6236 cLOGOP->op_other = cLOGOP->op_other->op_next;
6237 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6242 o->op_seq = PL_op_seqmax++;
6243 while (cLOOP->op_redoop->op_type == OP_NULL)
6244 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6245 peep(cLOOP->op_redoop);
6246 while (cLOOP->op_nextop->op_type == OP_NULL)
6247 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6248 peep(cLOOP->op_nextop);
6249 while (cLOOP->op_lastop->op_type == OP_NULL)
6250 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6251 peep(cLOOP->op_lastop);
6257 o->op_seq = PL_op_seqmax++;
6258 while (cPMOP->op_pmreplstart &&
6259 cPMOP->op_pmreplstart->op_type == OP_NULL)
6260 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6261 peep(cPMOP->op_pmreplstart);
6265 o->op_seq = PL_op_seqmax++;
6266 if (ckWARN(WARN_SYNTAX) && o->op_next
6267 && o->op_next->op_type == OP_NEXTSTATE) {
6268 if (o->op_next->op_sibling &&
6269 o->op_next->op_sibling->op_type != OP_EXIT &&
6270 o->op_next->op_sibling->op_type != OP_WARN &&
6271 o->op_next->op_sibling->op_type != OP_DIE) {
6272 line_t oldline = CopLINE(PL_curcop);
6274 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6275 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6276 "Statement unlikely to be reached");
6277 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6278 "\t(Maybe you meant system() when you said exec()?)\n");
6279 CopLINE_set(PL_curcop, oldline);
6290 o->op_seq = PL_op_seqmax++;
6292 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6295 /* Make the CONST have a shared SV */
6296 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6297 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6298 key = SvPV(sv, keylen);
6299 lexname = newSVpvn_share(key,
6300 SvUTF8(sv) ? -(I32)keylen : keylen,
6309 o->op_seq = PL_op_seqmax++;
6319 char* Perl_custom_op_name(pTHX_ OP* o)
6321 IV index = PTR2IV(o->op_ppaddr);
6325 if (!PL_custom_op_names) /* This probably shouldn't happen */
6326 return PL_op_name[OP_CUSTOM];
6328 keysv = sv_2mortal(newSViv(index));
6330 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
6332 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
6334 return SvPV_nolen(HeVAL(he));
6337 char* Perl_custom_op_desc(pTHX_ OP* o)
6339 IV index = PTR2IV(o->op_ppaddr);
6343 if (!PL_custom_op_descs)
6344 return PL_op_desc[OP_CUSTOM];
6346 keysv = sv_2mortal(newSViv(index));
6348 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
6350 return PL_op_desc[OP_CUSTOM];
6352 return SvPV_nolen(HeVAL(he));
6358 /* Efficient sub that returns a constant scalar value. */
6360 const_sv_xsub(pTHX_ CV* cv)
6365 Perl_croak(aTHX_ "usage: %s::%s()",
6366 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
6370 ST(0) = (SV*)XSANY.any_ptr;