3 * Copyright (c) 1991-2002, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
12 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
13 * youngest of the Old Took's daughters); and Mr. Drogo was his second
14 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
15 * either way, as the saying is, if you follow me." --the Gaffer
24 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
26 #if defined(PL_OP_SLAB_ALLOC)
28 #ifndef PERL_SLAB_SIZE
29 #define PERL_SLAB_SIZE 2048
32 #define NewOp(m,var,c,type) \
33 STMT_START { var = (type *) Slab_Alloc(m,c*sizeof(type)); } STMT_END
35 #define FreeOp(p) Slab_Free(p)
38 S_Slab_Alloc(pTHX_ int m, size_t sz)
41 * To make incrementing use count easy PL_OpSlab is an I32 *
42 * To make inserting the link to slab PL_OpPtr is I32 **
43 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
44 * Add an overhead for pointer to slab and round up as a number of pointers
46 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
47 if ((PL_OpSpace -= sz) < 0) {
48 PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*));
52 Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **);
53 /* We reserve the 0'th I32 sized chunk as a use count */
54 PL_OpSlab = (I32 *) PL_OpPtr;
55 /* Reduce size by the use count word, and by the size we need.
56 * Latter is to mimic the '-=' in the if() above
58 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
59 /* Allocation pointer starts at the top.
60 Theory: because we build leaves before trunk allocating at end
61 means that at run time access is cache friendly upward
63 PL_OpPtr += PERL_SLAB_SIZE;
65 assert( PL_OpSpace >= 0 );
66 /* Move the allocation pointer down */
68 assert( PL_OpPtr > (I32 **) PL_OpSlab );
69 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
70 (*PL_OpSlab)++; /* Increment use count of slab */
71 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
72 assert( *PL_OpSlab > 0 );
73 return (void *)(PL_OpPtr + 1);
77 S_Slab_Free(pTHX_ void *op)
79 I32 **ptr = (I32 **) op;
81 assert( ptr-1 > (I32 **) slab );
82 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
86 #define PerlMemShared PerlMem
89 PerlMemShared_free(slab);
90 if (slab == PL_OpSlab) {
97 #define NewOp(m, var, c, type) Newz(m, var, c, type)
98 #define FreeOp(p) Safefree(p)
101 * In the following definition, the ", Nullop" is just to make the compiler
102 * think the expression is of the right type: croak actually does a Siglongjmp.
104 #define CHECKOP(type,o) \
105 ((PL_op_mask && PL_op_mask[type]) \
106 ? ( op_free((OP*)o), \
107 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
109 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
111 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
114 S_gv_ename(pTHX_ GV *gv)
117 SV* tmpsv = sv_newmortal();
118 gv_efullname3(tmpsv, gv, Nullch);
119 return SvPV(tmpsv,n_a);
123 S_no_fh_allowed(pTHX_ OP *o)
125 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
131 S_too_few_arguments(pTHX_ OP *o, char *name)
133 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
138 S_too_many_arguments(pTHX_ OP *o, char *name)
140 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
145 S_bad_type(pTHX_ I32 n, char *t, char *name, OP *kid)
147 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
148 (int)n, name, t, OP_DESC(kid)));
152 S_no_bareword_allowed(pTHX_ OP *o)
154 qerror(Perl_mess(aTHX_
155 "Bareword \"%s\" not allowed while \"strict subs\" in use",
156 SvPV_nolen(cSVOPo_sv)));
159 /* "register" allocation */
162 Perl_allocmy(pTHX_ char *name)
166 /* complain about "my $_" etc etc */
167 if (!(PL_in_my == KEY_our ||
169 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
170 (name[1] == '_' && (int)strlen(name) > 2)))
172 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
173 /* 1999-02-27 mjd@plover.com */
175 p = strchr(name, '\0');
176 /* The next block assumes the buffer is at least 205 chars
177 long. At present, it's always at least 256 chars. */
179 strcpy(name+200, "...");
185 /* Move everything else down one character */
186 for (; p-name > 2; p--)
188 name[2] = toCTRL(name[1]);
191 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
194 /* check for duplicate declaration */
197 (PL_curstash ? PL_curstash : PL_defstash)
200 if (PL_in_my_stash && *name != '$') {
201 yyerror(Perl_form(aTHX_
202 "Can't declare class for non-scalar %s in \"%s\"",
203 name, PL_in_my == KEY_our ? "our" : "my"));
206 /* allocate a spare slot and store the name in that slot */
208 off = pad_add_name(name,
211 ? (PL_curstash ? PL_curstash : PL_defstash)
220 #ifdef USE_5005THREADS
221 /* find_threadsv is not reentrant */
223 Perl_find_threadsv(pTHX_ const char *name)
228 /* We currently only handle names of a single character */
229 p = strchr(PL_threadsv_names, *name);
232 key = p - PL_threadsv_names;
233 MUTEX_LOCK(&thr->mutex);
234 svp = av_fetch(thr->threadsv, key, FALSE);
236 MUTEX_UNLOCK(&thr->mutex);
238 SV *sv = NEWSV(0, 0);
239 av_store(thr->threadsv, key, sv);
240 thr->threadsvp = AvARRAY(thr->threadsv);
241 MUTEX_UNLOCK(&thr->mutex);
243 * Some magic variables used to be automagically initialised
244 * in gv_fetchpv. Those which are now per-thread magicals get
245 * initialised here instead.
251 sv_setpv(sv, "\034");
252 sv_magic(sv, 0, PERL_MAGIC_sv, name, 1);
257 PL_sawampersand = TRUE;
271 /* XXX %! tied to Errno.pm needs to be added here.
272 * See gv_fetchpv(). */
276 sv_magic(sv, 0, PERL_MAGIC_sv, name, 1);
278 DEBUG_S(PerlIO_printf(Perl_error_log,
279 "find_threadsv: new SV %p for $%s%c\n",
280 sv, (*name < 32) ? "^" : "",
281 (*name < 32) ? toCTRL(*name) : *name));
285 #endif /* USE_5005THREADS */
290 Perl_op_free(pTHX_ OP *o)
292 register OP *kid, *nextkid;
295 if (!o || o->op_seq == (U16)-1)
298 if (o->op_private & OPpREFCOUNTED) {
299 switch (o->op_type) {
307 if (OpREFCNT_dec(o)) {
318 if (o->op_flags & OPf_KIDS) {
319 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
320 nextkid = kid->op_sibling; /* Get before next freeing kid */
326 type = (OPCODE)o->op_targ;
328 /* COP* is not cleared by op_clear() so that we may track line
329 * numbers etc even after null() */
330 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
338 Perl_op_clear(pTHX_ OP *o)
341 switch (o->op_type) {
342 case OP_NULL: /* Was holding old type, if any. */
343 case OP_ENTEREVAL: /* Was holding hints. */
344 #ifdef USE_5005THREADS
345 case OP_THREADSV: /* Was holding index into thr->threadsv AV. */
349 #ifdef USE_5005THREADS
351 if (!(o->op_flags & OPf_SPECIAL))
354 #endif /* USE_5005THREADS */
356 if (!(o->op_flags & OPf_REF)
357 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
364 if (cPADOPo->op_padix > 0) {
365 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
366 * may still exist on the pad */
367 pad_swipe(cPADOPo->op_padix, TRUE);
368 cPADOPo->op_padix = 0;
371 SvREFCNT_dec(cSVOPo->op_sv);
372 cSVOPo->op_sv = Nullsv;
375 case OP_METHOD_NAMED:
377 SvREFCNT_dec(cSVOPo->op_sv);
378 cSVOPo->op_sv = Nullsv;
384 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
388 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
389 SvREFCNT_dec(cSVOPo->op_sv);
390 cSVOPo->op_sv = Nullsv;
393 Safefree(cPVOPo->op_pv);
394 cPVOPo->op_pv = Nullch;
398 op_free(cPMOPo->op_pmreplroot);
402 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
403 /* No GvIN_PAD_off here, because other references may still
404 * exist on the pad */
405 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
408 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
415 HV *pmstash = PmopSTASH(cPMOPo);
416 if (pmstash && SvREFCNT(pmstash)) {
417 PMOP *pmop = HvPMROOT(pmstash);
418 PMOP *lastpmop = NULL;
420 if (cPMOPo == pmop) {
422 lastpmop->op_pmnext = pmop->op_pmnext;
424 HvPMROOT(pmstash) = pmop->op_pmnext;
428 pmop = pmop->op_pmnext;
431 PmopSTASH_free(cPMOPo);
433 cPMOPo->op_pmreplroot = Nullop;
434 /* we use the "SAFE" version of the PM_ macros here
435 * since sv_clean_all might release some PMOPs
436 * after PL_regex_padav has been cleared
437 * and the clearing of PL_regex_padav needs to
438 * happen before sv_clean_all
440 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
441 PM_SETRE_SAFE(cPMOPo, (REGEXP*)NULL);
443 if(PL_regex_pad) { /* We could be in destruction */
444 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
445 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
446 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
453 if (o->op_targ > 0) {
454 pad_free(o->op_targ);
460 S_cop_free(pTHX_ COP* cop)
462 Safefree(cop->cop_label); /* FIXME: treaddead ??? */
465 if (! specialWARN(cop->cop_warnings))
466 SvREFCNT_dec(cop->cop_warnings);
467 if (! specialCopIO(cop->cop_io)) {
471 char *s = SvPV(cop->cop_io,len);
472 Perl_warn(aTHX_ "io='%.*s'",(int) len,s); /* ??? --jhi */
475 SvREFCNT_dec(cop->cop_io);
481 Perl_op_null(pTHX_ OP *o)
483 if (o->op_type == OP_NULL)
486 o->op_targ = o->op_type;
487 o->op_type = OP_NULL;
488 o->op_ppaddr = PL_ppaddr[OP_NULL];
491 /* Contextualizers */
493 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
496 Perl_linklist(pTHX_ OP *o)
503 /* establish postfix order */
504 if (cUNOPo->op_first) {
505 o->op_next = LINKLIST(cUNOPo->op_first);
506 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
508 kid->op_next = LINKLIST(kid->op_sibling);
520 Perl_scalarkids(pTHX_ OP *o)
523 if (o && o->op_flags & OPf_KIDS) {
524 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
531 S_scalarboolean(pTHX_ OP *o)
533 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
534 if (ckWARN(WARN_SYNTAX)) {
535 line_t oldline = CopLINE(PL_curcop);
537 if (PL_copline != NOLINE)
538 CopLINE_set(PL_curcop, PL_copline);
539 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
540 CopLINE_set(PL_curcop, oldline);
547 Perl_scalar(pTHX_ OP *o)
551 /* assumes no premature commitment */
552 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
553 || o->op_type == OP_RETURN)
558 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
560 switch (o->op_type) {
562 scalar(cBINOPo->op_first);
567 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
571 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
572 if (!kPMOP->op_pmreplroot)
573 deprecate_old("implicit split to @_");
581 if (o->op_flags & OPf_KIDS) {
582 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
588 kid = cLISTOPo->op_first;
590 while ((kid = kid->op_sibling)) {
596 WITH_THR(PL_curcop = &PL_compiling);
601 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
607 WITH_THR(PL_curcop = &PL_compiling);
610 if (ckWARN(WARN_VOID))
611 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
617 Perl_scalarvoid(pTHX_ OP *o)
624 if (o->op_type == OP_NEXTSTATE
625 || o->op_type == OP_SETSTATE
626 || o->op_type == OP_DBSTATE
627 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
628 || o->op_targ == OP_SETSTATE
629 || o->op_targ == OP_DBSTATE)))
630 PL_curcop = (COP*)o; /* for warning below */
632 /* assumes no premature commitment */
633 want = o->op_flags & OPf_WANT;
634 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
635 || o->op_type == OP_RETURN)
640 if ((o->op_private & OPpTARGET_MY)
641 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
643 return scalar(o); /* As if inside SASSIGN */
646 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
648 switch (o->op_type) {
650 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
654 if (o->op_flags & OPf_STACKED)
658 if (o->op_private == 4)
730 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
731 useless = OP_DESC(o);
738 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
739 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
740 useless = "a variable";
745 if (cSVOPo->op_private & OPpCONST_STRICT)
746 no_bareword_allowed(o);
748 if (ckWARN(WARN_VOID)) {
749 useless = "a constant";
750 /* the constants 0 and 1 are permitted as they are
751 conventionally used as dummies in constructs like
752 1 while some_condition_with_side_effects; */
753 if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
755 else if (SvPOK(sv)) {
756 /* perl4's way of mixing documentation and code
757 (before the invention of POD) was based on a
758 trick to mix nroff and perl code. The trick was
759 built upon these three nroff macros being used in
760 void context. The pink camel has the details in
761 the script wrapman near page 319. */
762 if (strnEQ(SvPVX(sv), "di", 2) ||
763 strnEQ(SvPVX(sv), "ds", 2) ||
764 strnEQ(SvPVX(sv), "ig", 2))
769 op_null(o); /* don't execute or even remember it */
773 o->op_type = OP_PREINC; /* pre-increment is faster */
774 o->op_ppaddr = PL_ppaddr[OP_PREINC];
778 o->op_type = OP_PREDEC; /* pre-decrement is faster */
779 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
786 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
791 if (o->op_flags & OPf_STACKED)
798 if (!(o->op_flags & OPf_KIDS))
807 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
814 /* all requires must return a boolean value */
815 o->op_flags &= ~OPf_WANT;
820 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
821 if (!kPMOP->op_pmreplroot)
822 deprecate_old("implicit split to @_");
826 if (useless && ckWARN(WARN_VOID))
827 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
832 Perl_listkids(pTHX_ OP *o)
835 if (o && o->op_flags & OPf_KIDS) {
836 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
843 Perl_list(pTHX_ OP *o)
847 /* assumes no premature commitment */
848 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
849 || o->op_type == OP_RETURN)
854 if ((o->op_private & OPpTARGET_MY)
855 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
857 return o; /* As if inside SASSIGN */
860 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
862 switch (o->op_type) {
865 list(cBINOPo->op_first);
870 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
878 if (!(o->op_flags & OPf_KIDS))
880 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
881 list(cBINOPo->op_first);
882 return gen_constant_list(o);
889 kid = cLISTOPo->op_first;
891 while ((kid = kid->op_sibling)) {
897 WITH_THR(PL_curcop = &PL_compiling);
901 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
907 WITH_THR(PL_curcop = &PL_compiling);
910 /* all requires must return a boolean value */
911 o->op_flags &= ~OPf_WANT;
918 Perl_scalarseq(pTHX_ OP *o)
923 if (o->op_type == OP_LINESEQ ||
924 o->op_type == OP_SCOPE ||
925 o->op_type == OP_LEAVE ||
926 o->op_type == OP_LEAVETRY)
928 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
929 if (kid->op_sibling) {
933 PL_curcop = &PL_compiling;
935 o->op_flags &= ~OPf_PARENS;
936 if (PL_hints & HINT_BLOCK_SCOPE)
937 o->op_flags |= OPf_PARENS;
940 o = newOP(OP_STUB, 0);
945 S_modkids(pTHX_ OP *o, I32 type)
948 if (o && o->op_flags & OPf_KIDS) {
949 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
956 Perl_mod(pTHX_ OP *o, I32 type)
960 if (!o || PL_error_count)
963 if ((o->op_private & OPpTARGET_MY)
964 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
969 switch (o->op_type) {
974 if (!(o->op_private & (OPpCONST_ARYBASE)))
976 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
977 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
981 SAVEI32(PL_compiling.cop_arybase);
982 PL_compiling.cop_arybase = 0;
984 else if (type == OP_REFGEN)
987 Perl_croak(aTHX_ "That use of $[ is unsupported");
990 if (o->op_flags & OPf_PARENS)
994 if ((type == OP_UNDEF || type == OP_REFGEN) &&
995 !(o->op_flags & OPf_STACKED)) {
996 o->op_type = OP_RV2CV; /* entersub => rv2cv */
997 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
998 assert(cUNOPo->op_first->op_type == OP_NULL);
999 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1002 else if (o->op_private & OPpENTERSUB_NOMOD)
1004 else { /* lvalue subroutine call */
1005 o->op_private |= OPpLVAL_INTRO;
1006 PL_modcount = RETURN_UNLIMITED_NUMBER;
1007 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1008 /* Backward compatibility mode: */
1009 o->op_private |= OPpENTERSUB_INARGS;
1012 else { /* Compile-time error message: */
1013 OP *kid = cUNOPo->op_first;
1017 if (kid->op_type == OP_PUSHMARK)
1019 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1021 "panic: unexpected lvalue entersub "
1022 "args: type/targ %ld:%"UVuf,
1023 (long)kid->op_type, (UV)kid->op_targ);
1024 kid = kLISTOP->op_first;
1026 while (kid->op_sibling)
1027 kid = kid->op_sibling;
1028 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1030 if (kid->op_type == OP_METHOD_NAMED
1031 || kid->op_type == OP_METHOD)
1035 NewOp(1101, newop, 1, UNOP);
1036 newop->op_type = OP_RV2CV;
1037 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1038 newop->op_first = Nullop;
1039 newop->op_next = (OP*)newop;
1040 kid->op_sibling = (OP*)newop;
1041 newop->op_private |= OPpLVAL_INTRO;
1045 if (kid->op_type != OP_RV2CV)
1047 "panic: unexpected lvalue entersub "
1048 "entry via type/targ %ld:%"UVuf,
1049 (long)kid->op_type, (UV)kid->op_targ);
1050 kid->op_private |= OPpLVAL_INTRO;
1051 break; /* Postpone until runtime */
1055 kid = kUNOP->op_first;
1056 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1057 kid = kUNOP->op_first;
1058 if (kid->op_type == OP_NULL)
1060 "Unexpected constant lvalue entersub "
1061 "entry via type/targ %ld:%"UVuf,
1062 (long)kid->op_type, (UV)kid->op_targ);
1063 if (kid->op_type != OP_GV) {
1064 /* Restore RV2CV to check lvalueness */
1066 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1067 okid->op_next = kid->op_next;
1068 kid->op_next = okid;
1071 okid->op_next = Nullop;
1072 okid->op_type = OP_RV2CV;
1074 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1075 okid->op_private |= OPpLVAL_INTRO;
1079 cv = GvCV(kGVOP_gv);
1089 /* grep, foreach, subcalls, refgen */
1090 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1092 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1093 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1095 : (o->op_type == OP_ENTERSUB
1096 ? "non-lvalue subroutine call"
1098 type ? PL_op_desc[type] : "local"));
1112 case OP_RIGHT_SHIFT:
1121 if (!(o->op_flags & OPf_STACKED))
1127 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1133 if (!type && cUNOPo->op_first->op_type != OP_GV)
1134 Perl_croak(aTHX_ "Can't localize through a reference");
1135 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1136 PL_modcount = RETURN_UNLIMITED_NUMBER;
1137 return o; /* Treat \(@foo) like ordinary list. */
1141 if (scalar_mod_type(o, type))
1143 ref(cUNOPo->op_first, o->op_type);
1147 if (type == OP_LEAVESUBLV)
1148 o->op_private |= OPpMAYBE_LVSUB;
1153 PL_modcount = RETURN_UNLIMITED_NUMBER;
1156 if (!type && cUNOPo->op_first->op_type != OP_GV)
1157 Perl_croak(aTHX_ "Can't localize through a reference");
1158 ref(cUNOPo->op_first, o->op_type);
1162 PL_hints |= HINT_BLOCK_SCOPE;
1173 PL_modcount = RETURN_UNLIMITED_NUMBER;
1174 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1175 return o; /* Treat \(@foo) like ordinary list. */
1176 if (scalar_mod_type(o, type))
1178 if (type == OP_LEAVESUBLV)
1179 o->op_private |= OPpMAYBE_LVSUB;
1184 { /* XXX DAPM 2002.08.25 tmp assert test */
1185 /* XXX */ assert(av_fetch(PL_comppad_name, (o->op_targ), FALSE));
1186 /* XXX */ assert(*av_fetch(PL_comppad_name, (o->op_targ), FALSE));
1188 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1189 PAD_COMPNAME_PV(o->op_targ));
1193 #ifdef USE_5005THREADS
1195 PL_modcount++; /* XXX ??? */
1197 #endif /* USE_5005THREADS */
1203 if (type != OP_SASSIGN)
1207 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1212 if (type == OP_LEAVESUBLV)
1213 o->op_private |= OPpMAYBE_LVSUB;
1215 pad_free(o->op_targ);
1216 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1217 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1218 if (o->op_flags & OPf_KIDS)
1219 mod(cBINOPo->op_first->op_sibling, type);
1224 ref(cBINOPo->op_first, o->op_type);
1225 if (type == OP_ENTERSUB &&
1226 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1227 o->op_private |= OPpLVAL_DEFER;
1228 if (type == OP_LEAVESUBLV)
1229 o->op_private |= OPpMAYBE_LVSUB;
1237 if (o->op_flags & OPf_KIDS)
1238 mod(cLISTOPo->op_last, type);
1242 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1244 else if (!(o->op_flags & OPf_KIDS))
1246 if (o->op_targ != OP_LIST) {
1247 mod(cBINOPo->op_first, type);
1252 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1257 if (type != OP_LEAVESUBLV)
1259 break; /* mod()ing was handled by ck_return() */
1262 /* [20011101.069] File test operators interpret OPf_REF to mean that
1263 their argument is a filehandle; thus \stat(".") should not set
1265 if (type == OP_REFGEN &&
1266 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1269 if (type != OP_LEAVESUBLV)
1270 o->op_flags |= OPf_MOD;
1272 if (type == OP_AASSIGN || type == OP_SASSIGN)
1273 o->op_flags |= OPf_SPECIAL|OPf_REF;
1275 o->op_private |= OPpLVAL_INTRO;
1276 o->op_flags &= ~OPf_SPECIAL;
1277 PL_hints |= HINT_BLOCK_SCOPE;
1279 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1280 && type != OP_LEAVESUBLV)
1281 o->op_flags |= OPf_REF;
1286 S_scalar_mod_type(pTHX_ OP *o, I32 type)
1290 if (o->op_type == OP_RV2GV)
1314 case OP_RIGHT_SHIFT:
1333 S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
1335 switch (o->op_type) {
1343 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1356 Perl_refkids(pTHX_ OP *o, I32 type)
1359 if (o && o->op_flags & OPf_KIDS) {
1360 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1367 Perl_ref(pTHX_ OP *o, I32 type)
1371 if (!o || PL_error_count)
1374 switch (o->op_type) {
1376 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1377 !(o->op_flags & OPf_STACKED)) {
1378 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1379 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1380 assert(cUNOPo->op_first->op_type == OP_NULL);
1381 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1382 o->op_flags |= OPf_SPECIAL;
1387 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1391 if (type == OP_DEFINED)
1392 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1393 ref(cUNOPo->op_first, o->op_type);
1396 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1397 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1398 : type == OP_RV2HV ? OPpDEREF_HV
1400 o->op_flags |= OPf_MOD;
1405 o->op_flags |= OPf_MOD; /* XXX ??? */
1410 o->op_flags |= OPf_REF;
1413 if (type == OP_DEFINED)
1414 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1415 ref(cUNOPo->op_first, o->op_type);
1420 o->op_flags |= OPf_REF;
1425 if (!(o->op_flags & OPf_KIDS))
1427 ref(cBINOPo->op_first, type);
1431 ref(cBINOPo->op_first, o->op_type);
1432 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1433 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1434 : type == OP_RV2HV ? OPpDEREF_HV
1436 o->op_flags |= OPf_MOD;
1444 if (!(o->op_flags & OPf_KIDS))
1446 ref(cLISTOPo->op_last, type);
1456 S_dup_attrlist(pTHX_ OP *o)
1460 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1461 * where the first kid is OP_PUSHMARK and the remaining ones
1462 * are OP_CONST. We need to push the OP_CONST values.
1464 if (o->op_type == OP_CONST)
1465 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1467 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1468 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1469 if (o->op_type == OP_CONST)
1470 rop = append_elem(OP_LIST, rop,
1471 newSVOP(OP_CONST, o->op_flags,
1472 SvREFCNT_inc(cSVOPo->op_sv)));
1479 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1483 /* fake up C<use attributes $pkg,$rv,@attrs> */
1484 ENTER; /* need to protect against side-effects of 'use' */
1487 stashsv = newSVpv(HvNAME(stash), 0);
1489 stashsv = &PL_sv_no;
1491 #define ATTRSMODULE "attributes"
1492 #define ATTRSMODULE_PM "attributes.pm"
1496 /* Don't force the C<use> if we don't need it. */
1497 svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
1498 sizeof(ATTRSMODULE_PM)-1, 0);
1499 if (svp && *svp != &PL_sv_undef)
1500 ; /* already in %INC */
1502 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1503 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1507 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1508 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1510 prepend_elem(OP_LIST,
1511 newSVOP(OP_CONST, 0, stashsv),
1512 prepend_elem(OP_LIST,
1513 newSVOP(OP_CONST, 0,
1515 dup_attrlist(attrs))));
1521 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1523 OP *pack, *imop, *arg;
1529 assert(target->op_type == OP_PADSV ||
1530 target->op_type == OP_PADHV ||
1531 target->op_type == OP_PADAV);
1533 /* Ensure that attributes.pm is loaded. */
1534 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1536 /* Need package name for method call. */
1537 pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
1539 /* Build up the real arg-list. */
1541 stashsv = newSVpv(HvNAME(stash), 0);
1543 stashsv = &PL_sv_no;
1544 arg = newOP(OP_PADSV, 0);
1545 arg->op_targ = target->op_targ;
1546 arg = prepend_elem(OP_LIST,
1547 newSVOP(OP_CONST, 0, stashsv),
1548 prepend_elem(OP_LIST,
1549 newUNOP(OP_REFGEN, 0,
1550 mod(arg, OP_REFGEN)),
1551 dup_attrlist(attrs)));
1553 /* Fake up a method call to import */
1554 meth = newSVpvn("import", 6);
1555 (void)SvUPGRADE(meth, SVt_PVIV);
1556 (void)SvIOK_on(meth);
1557 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
1558 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1559 append_elem(OP_LIST,
1560 prepend_elem(OP_LIST, pack, list(arg)),
1561 newSVOP(OP_METHOD_NAMED, 0, meth)));
1562 imop->op_private |= OPpENTERSUB_NOMOD;
1564 /* Combine the ops. */
1565 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1569 =notfor apidoc apply_attrs_string
1571 Attempts to apply a list of attributes specified by the C<attrstr> and
1572 C<len> arguments to the subroutine identified by the C<cv> argument which
1573 is expected to be associated with the package identified by the C<stashpv>
1574 argument (see L<attributes>). It gets this wrong, though, in that it
1575 does not correctly identify the boundaries of the individual attribute
1576 specifications within C<attrstr>. This is not really intended for the
1577 public API, but has to be listed here for systems such as AIX which
1578 need an explicit export list for symbols. (It's called from XS code
1579 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1580 to respect attribute syntax properly would be welcome.
1586 Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
1587 char *attrstr, STRLEN len)
1592 len = strlen(attrstr);
1596 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1598 char *sstr = attrstr;
1599 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1600 attrs = append_elem(OP_LIST, attrs,
1601 newSVOP(OP_CONST, 0,
1602 newSVpvn(sstr, attrstr-sstr)));
1606 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1607 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1608 Nullsv, prepend_elem(OP_LIST,
1609 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1610 prepend_elem(OP_LIST,
1611 newSVOP(OP_CONST, 0,
1617 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1622 if (!o || PL_error_count)
1626 if (type == OP_LIST) {
1627 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1628 my_kid(kid, attrs, imopsp);
1629 } else if (type == OP_UNDEF) {
1631 } else if (type == OP_RV2SV || /* "our" declaration */
1633 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1634 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1635 yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
1636 OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
1638 GV *gv = cGVOPx_gv(cUNOPo->op_first);
1640 PL_in_my_stash = Nullhv;
1641 apply_attrs(GvSTASH(gv),
1642 (type == OP_RV2SV ? GvSV(gv) :
1643 type == OP_RV2AV ? (SV*)GvAV(gv) :
1644 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1647 o->op_private |= OPpOUR_INTRO;
1650 else if (type != OP_PADSV &&
1653 type != OP_PUSHMARK)
1655 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1657 PL_in_my == KEY_our ? "our" : "my"));
1660 else if (attrs && type != OP_PUSHMARK) {
1664 PL_in_my_stash = Nullhv;
1666 /* check for C<my Dog $spot> when deciding package */
1667 stash = PAD_COMPNAME_TYPE(o->op_targ);
1669 stash = PL_curstash;
1670 apply_attrs_my(stash, o, attrs, imopsp);
1672 o->op_flags |= OPf_MOD;
1673 o->op_private |= OPpLVAL_INTRO;
1678 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1681 int maybe_scalar = 0;
1683 /* [perl #17376]: this appears to be premature, and results in code such as
1684 C< our(%x); > executing in list mode rather than void mode */
1686 if (o->op_flags & OPf_PARENS)
1695 o = my_kid(o, attrs, &rops);
1697 if (maybe_scalar && o->op_type == OP_PADSV) {
1698 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1699 o->op_private |= OPpLVAL_INTRO;
1702 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1705 PL_in_my_stash = Nullhv;
1710 Perl_my(pTHX_ OP *o)
1712 return my_attrs(o, Nullop);
1716 Perl_sawparens(pTHX_ OP *o)
1719 o->op_flags |= OPf_PARENS;
1724 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1728 if (ckWARN(WARN_MISC) &&
1729 (left->op_type == OP_RV2AV ||
1730 left->op_type == OP_RV2HV ||
1731 left->op_type == OP_PADAV ||
1732 left->op_type == OP_PADHV)) {
1733 char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
1734 right->op_type == OP_TRANS)
1735 ? right->op_type : OP_MATCH];
1736 const char *sample = ((left->op_type == OP_RV2AV ||
1737 left->op_type == OP_PADAV)
1738 ? "@array" : "%hash");
1739 Perl_warner(aTHX_ packWARN(WARN_MISC),
1740 "Applying %s to %s will act on scalar(%s)",
1741 desc, sample, sample);
1744 if (right->op_type == OP_CONST &&
1745 cSVOPx(right)->op_private & OPpCONST_BARE &&
1746 cSVOPx(right)->op_private & OPpCONST_STRICT)
1748 no_bareword_allowed(right);
1751 if (!(right->op_flags & OPf_STACKED) &&
1752 (right->op_type == OP_MATCH ||
1753 right->op_type == OP_SUBST ||
1754 right->op_type == OP_TRANS)) {
1755 right->op_flags |= OPf_STACKED;
1756 if (right->op_type != OP_MATCH &&
1757 ! (right->op_type == OP_TRANS &&
1758 right->op_private & OPpTRANS_IDENTICAL))
1759 left = mod(left, right->op_type);
1760 if (right->op_type == OP_TRANS)
1761 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
1763 o = prepend_elem(right->op_type, scalar(left), right);
1765 return newUNOP(OP_NOT, 0, scalar(o));
1769 return bind_match(type, left,
1770 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
1774 Perl_invert(pTHX_ OP *o)
1778 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
1779 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1783 Perl_scope(pTHX_ OP *o)
1786 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1787 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1788 o->op_type = OP_LEAVE;
1789 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1792 if (o->op_type == OP_LINESEQ) {
1794 o->op_type = OP_SCOPE;
1795 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1796 kid = ((LISTOP*)o)->op_first;
1797 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
1801 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
1808 Perl_save_hints(pTHX)
1811 SAVESPTR(GvHV(PL_hintgv));
1812 GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
1813 SAVEFREESV(GvHV(PL_hintgv));
1817 Perl_block_start(pTHX_ int full)
1819 int retval = PL_savestack_ix;
1821 pad_block_start(full);
1823 PL_hints &= ~HINT_BLOCK_SCOPE;
1824 SAVESPTR(PL_compiling.cop_warnings);
1825 if (! specialWARN(PL_compiling.cop_warnings)) {
1826 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1827 SAVEFREESV(PL_compiling.cop_warnings) ;
1829 SAVESPTR(PL_compiling.cop_io);
1830 if (! specialCopIO(PL_compiling.cop_io)) {
1831 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1832 SAVEFREESV(PL_compiling.cop_io) ;
1838 Perl_block_end(pTHX_ I32 floor, OP *seq)
1840 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1841 line_t copline = PL_copline;
1842 /* there should be a nextstate in every block */
1843 OP* retval = seq ? scalarseq(seq) : newSTATEOP(0, Nullch, seq);
1844 PL_copline = copline; /* XXX newSTATEOP may reset PL_copline */
1846 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
1848 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
1856 #ifdef USE_5005THREADS
1857 OP *o = newOP(OP_THREADSV, 0);
1858 o->op_targ = find_threadsv("_");
1861 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1862 #endif /* USE_5005THREADS */
1866 Perl_newPROG(pTHX_ OP *o)
1871 PL_eval_root = newUNOP(OP_LEAVEEVAL,
1872 ((PL_in_eval & EVAL_KEEPERR)
1873 ? OPf_SPECIAL : 0), o);
1874 PL_eval_start = linklist(PL_eval_root);
1875 PL_eval_root->op_private |= OPpREFCOUNTED;
1876 OpREFCNT_set(PL_eval_root, 1);
1877 PL_eval_root->op_next = 0;
1878 CALL_PEEP(PL_eval_start);
1883 PL_main_root = scope(sawparens(scalarvoid(o)));
1884 PL_curcop = &PL_compiling;
1885 PL_main_start = LINKLIST(PL_main_root);
1886 PL_main_root->op_private |= OPpREFCOUNTED;
1887 OpREFCNT_set(PL_main_root, 1);
1888 PL_main_root->op_next = 0;
1889 CALL_PEEP(PL_main_start);
1892 /* Register with debugger */
1894 CV *cv = get_cv("DB::postponed", FALSE);
1898 XPUSHs((SV*)CopFILEGV(&PL_compiling));
1900 call_sv((SV*)cv, G_DISCARD);
1907 Perl_localize(pTHX_ OP *o, I32 lex)
1909 if (o->op_flags & OPf_PARENS)
1910 /* [perl #17376]: this appears to be premature, and results in code such as
1911 C< our(%x); > executing in list mode rather than void mode */
1918 if (ckWARN(WARN_PARENTHESIS)
1919 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
1921 char *s = PL_bufptr;
1923 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ", *s)))
1926 if (*s == ';' || *s == '=')
1927 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
1928 "Parentheses missing around \"%s\" list",
1929 lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
1935 o = mod(o, OP_NULL); /* a bit kludgey */
1937 PL_in_my_stash = Nullhv;
1942 Perl_jmaybe(pTHX_ OP *o)
1944 if (o->op_type == OP_LIST) {
1946 #ifdef USE_5005THREADS
1947 o2 = newOP(OP_THREADSV, 0);
1948 o2->op_targ = find_threadsv(";");
1950 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
1951 #endif /* USE_5005THREADS */
1952 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
1958 Perl_fold_constants(pTHX_ register OP *o)
1961 I32 type = o->op_type;
1964 if (PL_opargs[type] & OA_RETSCALAR)
1966 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
1967 o->op_targ = pad_alloc(type, SVs_PADTMP);
1969 /* integerize op, unless it happens to be C<-foo>.
1970 * XXX should pp_i_negate() do magic string negation instead? */
1971 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
1972 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
1973 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
1975 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
1978 if (!(PL_opargs[type] & OA_FOLDCONST))
1983 /* XXX might want a ck_negate() for this */
1984 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
1996 /* XXX what about the numeric ops? */
1997 if (PL_hints & HINT_LOCALE)
2002 goto nope; /* Don't try to run w/ errors */
2004 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2005 if ((curop->op_type != OP_CONST ||
2006 (curop->op_private & OPpCONST_BARE)) &&
2007 curop->op_type != OP_LIST &&
2008 curop->op_type != OP_SCALAR &&
2009 curop->op_type != OP_NULL &&
2010 curop->op_type != OP_PUSHMARK)
2016 curop = LINKLIST(o);
2020 sv = *(PL_stack_sp--);
2021 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2022 pad_swipe(o->op_targ, FALSE);
2023 else if (SvTEMP(sv)) { /* grab mortal temp? */
2024 (void)SvREFCNT_inc(sv);
2028 if (type == OP_RV2GV)
2029 return newGVOP(OP_GV, 0, (GV*)sv);
2031 /* try to smush double to int, but don't smush -2.0 to -2 */
2032 if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
2035 #ifdef PERL_PRESERVE_IVUV
2036 /* Only bother to attempt to fold to IV if
2037 most operators will benefit */
2041 return newSVOP(OP_CONST, 0, sv);
2049 Perl_gen_constant_list(pTHX_ register OP *o)
2052 I32 oldtmps_floor = PL_tmps_floor;
2056 return o; /* Don't attempt to run with errors */
2058 PL_op = curop = LINKLIST(o);
2065 PL_tmps_floor = oldtmps_floor;
2067 o->op_type = OP_RV2AV;
2068 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2069 o->op_seq = 0; /* needs to be revisited in peep() */
2070 curop = ((UNOP*)o)->op_first;
2071 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2078 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2080 if (!o || o->op_type != OP_LIST)
2081 o = newLISTOP(OP_LIST, 0, o, Nullop);
2083 o->op_flags &= ~OPf_WANT;
2085 if (!(PL_opargs[type] & OA_MARK))
2086 op_null(cLISTOPo->op_first);
2088 o->op_type = (OPCODE)type;
2089 o->op_ppaddr = PL_ppaddr[type];
2090 o->op_flags |= flags;
2092 o = CHECKOP(type, o);
2093 if (o->op_type != type)
2096 return fold_constants(o);
2099 /* List constructors */
2102 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2110 if (first->op_type != type
2111 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2113 return newLISTOP(type, 0, first, last);
2116 if (first->op_flags & OPf_KIDS)
2117 ((LISTOP*)first)->op_last->op_sibling = last;
2119 first->op_flags |= OPf_KIDS;
2120 ((LISTOP*)first)->op_first = last;
2122 ((LISTOP*)first)->op_last = last;
2127 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2135 if (first->op_type != type)
2136 return prepend_elem(type, (OP*)first, (OP*)last);
2138 if (last->op_type != type)
2139 return append_elem(type, (OP*)first, (OP*)last);
2141 first->op_last->op_sibling = last->op_first;
2142 first->op_last = last->op_last;
2143 first->op_flags |= (last->op_flags & OPf_KIDS);
2151 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2159 if (last->op_type == type) {
2160 if (type == OP_LIST) { /* already a PUSHMARK there */
2161 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2162 ((LISTOP*)last)->op_first->op_sibling = first;
2163 if (!(first->op_flags & OPf_PARENS))
2164 last->op_flags &= ~OPf_PARENS;
2167 if (!(last->op_flags & OPf_KIDS)) {
2168 ((LISTOP*)last)->op_last = first;
2169 last->op_flags |= OPf_KIDS;
2171 first->op_sibling = ((LISTOP*)last)->op_first;
2172 ((LISTOP*)last)->op_first = first;
2174 last->op_flags |= OPf_KIDS;
2178 return newLISTOP(type, 0, first, last);
2184 Perl_newNULLLIST(pTHX)
2186 return newOP(OP_STUB, 0);
2190 Perl_force_list(pTHX_ OP *o)
2192 if (!o || o->op_type != OP_LIST)
2193 o = newLISTOP(OP_LIST, 0, o, Nullop);
2199 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2203 NewOp(1101, listop, 1, LISTOP);
2205 listop->op_type = (OPCODE)type;
2206 listop->op_ppaddr = PL_ppaddr[type];
2209 listop->op_flags = (U8)flags;
2213 else if (!first && last)
2216 first->op_sibling = last;
2217 listop->op_first = first;
2218 listop->op_last = last;
2219 if (type == OP_LIST) {
2221 pushop = newOP(OP_PUSHMARK, 0);
2222 pushop->op_sibling = first;
2223 listop->op_first = pushop;
2224 listop->op_flags |= OPf_KIDS;
2226 listop->op_last = pushop;
2233 Perl_newOP(pTHX_ I32 type, I32 flags)
2236 NewOp(1101, o, 1, OP);
2237 o->op_type = (OPCODE)type;
2238 o->op_ppaddr = PL_ppaddr[type];
2239 o->op_flags = (U8)flags;
2242 o->op_private = (U8)(0 | (flags >> 8));
2243 if (PL_opargs[type] & OA_RETSCALAR)
2245 if (PL_opargs[type] & OA_TARGET)
2246 o->op_targ = pad_alloc(type, SVs_PADTMP);
2247 return CHECKOP(type, o);
2251 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2256 first = newOP(OP_STUB, 0);
2257 if (PL_opargs[type] & OA_MARK)
2258 first = force_list(first);
2260 NewOp(1101, unop, 1, UNOP);
2261 unop->op_type = (OPCODE)type;
2262 unop->op_ppaddr = PL_ppaddr[type];
2263 unop->op_first = first;
2264 unop->op_flags = flags | OPf_KIDS;
2265 unop->op_private = (U8)(1 | (flags >> 8));
2266 unop = (UNOP*) CHECKOP(type, unop);
2270 return fold_constants((OP *) unop);
2274 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2277 NewOp(1101, binop, 1, BINOP);
2280 first = newOP(OP_NULL, 0);
2282 binop->op_type = (OPCODE)type;
2283 binop->op_ppaddr = PL_ppaddr[type];
2284 binop->op_first = first;
2285 binop->op_flags = flags | OPf_KIDS;
2288 binop->op_private = (U8)(1 | (flags >> 8));
2291 binop->op_private = (U8)(2 | (flags >> 8));
2292 first->op_sibling = last;
2295 binop = (BINOP*)CHECKOP(type, binop);
2296 if (binop->op_next || binop->op_type != (OPCODE)type)
2299 binop->op_last = binop->op_first->op_sibling;
2301 return fold_constants((OP *)binop);
2305 uvcompare(const void *a, const void *b)
2307 if (*((UV *)a) < (*(UV *)b))
2309 if (*((UV *)a) > (*(UV *)b))
2311 if (*((UV *)a+1) < (*(UV *)b+1))
2313 if (*((UV *)a+1) > (*(UV *)b+1))
2319 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2321 SV *tstr = ((SVOP*)expr)->op_sv;
2322 SV *rstr = ((SVOP*)repl)->op_sv;
2325 U8 *t = (U8*)SvPV(tstr, tlen);
2326 U8 *r = (U8*)SvPV(rstr, rlen);
2333 register short *tbl;
2335 PL_hints |= HINT_BLOCK_SCOPE;
2336 complement = o->op_private & OPpTRANS_COMPLEMENT;
2337 del = o->op_private & OPpTRANS_DELETE;
2338 squash = o->op_private & OPpTRANS_SQUASH;
2341 o->op_private |= OPpTRANS_FROM_UTF;
2344 o->op_private |= OPpTRANS_TO_UTF;
2346 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2347 SV* listsv = newSVpvn("# comment\n",10);
2349 U8* tend = t + tlen;
2350 U8* rend = r + rlen;
2364 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2365 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2371 tsave = t = bytes_to_utf8(t, &len);
2374 if (!to_utf && rlen) {
2376 rsave = r = bytes_to_utf8(r, &len);
2380 /* There are several snags with this code on EBCDIC:
2381 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2382 2. scan_const() in toke.c has encoded chars in native encoding which makes
2383 ranges at least in EBCDIC 0..255 range the bottom odd.
2387 U8 tmpbuf[UTF8_MAXLEN+1];
2390 New(1109, cp, 2*tlen, UV);
2392 transv = newSVpvn("",0);
2394 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2396 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2398 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2402 cp[2*i+1] = cp[2*i];
2406 qsort(cp, i, 2*sizeof(UV), uvcompare);
2407 for (j = 0; j < i; j++) {
2409 diff = val - nextmin;
2411 t = uvuni_to_utf8(tmpbuf,nextmin);
2412 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2414 U8 range_mark = UTF_TO_NATIVE(0xff);
2415 t = uvuni_to_utf8(tmpbuf, val - 1);
2416 sv_catpvn(transv, (char *)&range_mark, 1);
2417 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2424 t = uvuni_to_utf8(tmpbuf,nextmin);
2425 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2427 U8 range_mark = UTF_TO_NATIVE(0xff);
2428 sv_catpvn(transv, (char *)&range_mark, 1);
2430 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2431 UNICODE_ALLOW_SUPER);
2432 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2433 t = (U8*)SvPVX(transv);
2434 tlen = SvCUR(transv);
2438 else if (!rlen && !del) {
2439 r = t; rlen = tlen; rend = tend;
2442 if ((!rlen && !del) || t == r ||
2443 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2445 o->op_private |= OPpTRANS_IDENTICAL;
2449 while (t < tend || tfirst <= tlast) {
2450 /* see if we need more "t" chars */
2451 if (tfirst > tlast) {
2452 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2454 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2456 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2463 /* now see if we need more "r" chars */
2464 if (rfirst > rlast) {
2466 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2468 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2470 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2479 rfirst = rlast = 0xffffffff;
2483 /* now see which range will peter our first, if either. */
2484 tdiff = tlast - tfirst;
2485 rdiff = rlast - rfirst;
2492 if (rfirst == 0xffffffff) {
2493 diff = tdiff; /* oops, pretend rdiff is infinite */
2495 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2496 (long)tfirst, (long)tlast);
2498 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2502 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2503 (long)tfirst, (long)(tfirst + diff),
2506 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2507 (long)tfirst, (long)rfirst);
2509 if (rfirst + diff > max)
2510 max = rfirst + diff;
2512 grows = (tfirst < rfirst &&
2513 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2525 else if (max > 0xff)
2530 Safefree(cPVOPo->op_pv);
2531 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2532 SvREFCNT_dec(listsv);
2534 SvREFCNT_dec(transv);
2536 if (!del && havefinal && rlen)
2537 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2538 newSVuv((UV)final), 0);
2541 o->op_private |= OPpTRANS_GROWS;
2553 tbl = (short*)cPVOPo->op_pv;
2555 Zero(tbl, 256, short);
2556 for (i = 0; i < (I32)tlen; i++)
2558 for (i = 0, j = 0; i < 256; i++) {
2560 if (j >= (I32)rlen) {
2569 if (i < 128 && r[j] >= 128)
2579 o->op_private |= OPpTRANS_IDENTICAL;
2581 else if (j >= (I32)rlen)
2584 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2585 tbl[0x100] = rlen - j;
2586 for (i=0; i < (I32)rlen - j; i++)
2587 tbl[0x101+i] = r[j+i];
2591 if (!rlen && !del) {
2594 o->op_private |= OPpTRANS_IDENTICAL;
2596 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2597 o->op_private |= OPpTRANS_IDENTICAL;
2599 for (i = 0; i < 256; i++)
2601 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
2602 if (j >= (I32)rlen) {
2604 if (tbl[t[i]] == -1)
2610 if (tbl[t[i]] == -1) {
2611 if (t[i] < 128 && r[j] >= 128)
2618 o->op_private |= OPpTRANS_GROWS;
2626 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2630 NewOp(1101, pmop, 1, PMOP);
2631 pmop->op_type = (OPCODE)type;
2632 pmop->op_ppaddr = PL_ppaddr[type];
2633 pmop->op_flags = (U8)flags;
2634 pmop->op_private = (U8)(0 | (flags >> 8));
2636 if (PL_hints & HINT_RE_TAINT)
2637 pmop->op_pmpermflags |= PMf_RETAINT;
2638 if (PL_hints & HINT_LOCALE)
2639 pmop->op_pmpermflags |= PMf_LOCALE;
2640 pmop->op_pmflags = pmop->op_pmpermflags;
2645 if(av_len((AV*) PL_regex_pad[0]) > -1) {
2646 repointer = av_pop((AV*)PL_regex_pad[0]);
2647 pmop->op_pmoffset = SvIV(repointer);
2648 SvREPADTMP_off(repointer);
2649 sv_setiv(repointer,0);
2651 repointer = newSViv(0);
2652 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2653 pmop->op_pmoffset = av_len(PL_regex_padav);
2654 PL_regex_pad = AvARRAY(PL_regex_padav);
2659 /* link into pm list */
2660 if (type != OP_TRANS && PL_curstash) {
2661 pmop->op_pmnext = HvPMROOT(PL_curstash);
2662 HvPMROOT(PL_curstash) = pmop;
2663 PmopSTASH_set(pmop,PL_curstash);
2670 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
2674 I32 repl_has_vars = 0;
2676 if (o->op_type == OP_TRANS)
2677 return pmtrans(o, expr, repl);
2679 PL_hints |= HINT_BLOCK_SCOPE;
2682 if (expr->op_type == OP_CONST) {
2684 SV *pat = ((SVOP*)expr)->op_sv;
2685 char *p = SvPV(pat, plen);
2686 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
2687 sv_setpvn(pat, "\\s+", 3);
2688 p = SvPV(pat, plen);
2689 pm->op_pmflags |= PMf_SKIPWHITE;
2692 pm->op_pmdynflags |= PMdf_UTF8;
2693 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
2694 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
2695 pm->op_pmflags |= PMf_WHITE;
2699 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2700 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2702 : OP_REGCMAYBE),0,expr);
2704 NewOp(1101, rcop, 1, LOGOP);
2705 rcop->op_type = OP_REGCOMP;
2706 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2707 rcop->op_first = scalar(expr);
2708 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
2709 ? (OPf_SPECIAL | OPf_KIDS)
2711 rcop->op_private = 1;
2714 /* establish postfix order */
2715 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2717 rcop->op_next = expr;
2718 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2721 rcop->op_next = LINKLIST(expr);
2722 expr->op_next = (OP*)rcop;
2725 prepend_elem(o->op_type, scalar((OP*)rcop), o);
2730 if (pm->op_pmflags & PMf_EVAL) {
2732 if (CopLINE(PL_curcop) < PL_multi_end)
2733 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
2735 #ifdef USE_5005THREADS
2736 else if (repl->op_type == OP_THREADSV
2737 && strchr("&`'123456789+",
2738 PL_threadsv_names[repl->op_targ]))
2742 #endif /* USE_5005THREADS */
2743 else if (repl->op_type == OP_CONST)
2747 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
2748 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
2749 #ifdef USE_5005THREADS
2750 if (curop->op_type == OP_THREADSV) {
2752 if (strchr("&`'123456789+", curop->op_private))
2756 if (curop->op_type == OP_GV) {
2757 GV *gv = cGVOPx_gv(curop);
2759 if (strchr("&`'123456789+", *GvENAME(gv)))
2762 #endif /* USE_5005THREADS */
2763 else if (curop->op_type == OP_RV2CV)
2765 else if (curop->op_type == OP_RV2SV ||
2766 curop->op_type == OP_RV2AV ||
2767 curop->op_type == OP_RV2HV ||
2768 curop->op_type == OP_RV2GV) {
2769 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2772 else if (curop->op_type == OP_PADSV ||
2773 curop->op_type == OP_PADAV ||
2774 curop->op_type == OP_PADHV ||
2775 curop->op_type == OP_PADANY) {
2778 else if (curop->op_type == OP_PUSHRE)
2779 ; /* Okay here, dangerous in newASSIGNOP */
2789 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
2790 pm->op_pmflags |= PMf_CONST; /* const for long enough */
2791 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
2792 prepend_elem(o->op_type, scalar(repl), o);
2795 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
2796 pm->op_pmflags |= PMf_MAYBE_CONST;
2797 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2799 NewOp(1101, rcop, 1, LOGOP);
2800 rcop->op_type = OP_SUBSTCONT;
2801 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
2802 rcop->op_first = scalar(repl);
2803 rcop->op_flags |= OPf_KIDS;
2804 rcop->op_private = 1;
2807 /* establish postfix order */
2808 rcop->op_next = LINKLIST(repl);
2809 repl->op_next = (OP*)rcop;
2811 pm->op_pmreplroot = scalar((OP*)rcop);
2812 pm->op_pmreplstart = LINKLIST(rcop);
2821 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
2824 NewOp(1101, svop, 1, SVOP);
2825 svop->op_type = (OPCODE)type;
2826 svop->op_ppaddr = PL_ppaddr[type];
2828 svop->op_next = (OP*)svop;
2829 svop->op_flags = (U8)flags;
2830 if (PL_opargs[type] & OA_RETSCALAR)
2832 if (PL_opargs[type] & OA_TARGET)
2833 svop->op_targ = pad_alloc(type, SVs_PADTMP);
2834 return CHECKOP(type, svop);
2838 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2841 NewOp(1101, padop, 1, PADOP);
2842 padop->op_type = (OPCODE)type;
2843 padop->op_ppaddr = PL_ppaddr[type];
2844 padop->op_padix = pad_alloc(type, SVs_PADTMP);
2845 SvREFCNT_dec(PAD_SVl(padop->op_padix));
2846 PAD_SETSV(padop->op_padix, sv);
2849 padop->op_next = (OP*)padop;
2850 padop->op_flags = (U8)flags;
2851 if (PL_opargs[type] & OA_RETSCALAR)
2853 if (PL_opargs[type] & OA_TARGET)
2854 padop->op_targ = pad_alloc(type, SVs_PADTMP);
2855 return CHECKOP(type, padop);
2859 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
2864 return newPADOP(type, flags, SvREFCNT_inc(gv));
2866 return newSVOP(type, flags, SvREFCNT_inc(gv));
2871 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
2874 NewOp(1101, pvop, 1, PVOP);
2875 pvop->op_type = (OPCODE)type;
2876 pvop->op_ppaddr = PL_ppaddr[type];
2878 pvop->op_next = (OP*)pvop;
2879 pvop->op_flags = (U8)flags;
2880 if (PL_opargs[type] & OA_RETSCALAR)
2882 if (PL_opargs[type] & OA_TARGET)
2883 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
2884 return CHECKOP(type, pvop);
2888 Perl_package(pTHX_ OP *o)
2893 save_hptr(&PL_curstash);
2894 save_item(PL_curstname);
2896 name = SvPV(cSVOPo->op_sv, len);
2897 PL_curstash = gv_stashpvn(name, len, TRUE);
2898 sv_setpvn(PL_curstname, name, len);
2901 PL_hints |= HINT_BLOCK_SCOPE;
2902 PL_copline = NOLINE;
2907 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
2913 if (id->op_type != OP_CONST)
2914 Perl_croak(aTHX_ "Module name must be constant");
2918 if (version != Nullop) {
2919 SV *vesv = ((SVOP*)version)->op_sv;
2921 if (arg == Nullop && !SvNIOKp(vesv)) {
2928 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
2929 Perl_croak(aTHX_ "Version number must be constant number");
2931 /* Make copy of id so we don't free it twice */
2932 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
2934 /* Fake up a method call to VERSION */
2935 meth = newSVpvn("VERSION",7);
2936 sv_upgrade(meth, SVt_PVIV);
2937 (void)SvIOK_on(meth);
2938 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
2939 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2940 append_elem(OP_LIST,
2941 prepend_elem(OP_LIST, pack, list(version)),
2942 newSVOP(OP_METHOD_NAMED, 0, meth)));
2946 /* Fake up an import/unimport */
2947 if (arg && arg->op_type == OP_STUB)
2948 imop = arg; /* no import on explicit () */
2949 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
2950 imop = Nullop; /* use 5.0; */
2955 /* Make copy of id so we don't free it twice */
2956 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
2958 /* Fake up a method call to import/unimport */
2959 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);
2960 (void)SvUPGRADE(meth, SVt_PVIV);
2961 (void)SvIOK_on(meth);
2962 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
2963 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2964 append_elem(OP_LIST,
2965 prepend_elem(OP_LIST, pack, list(arg)),
2966 newSVOP(OP_METHOD_NAMED, 0, meth)));
2969 /* Fake up the BEGIN {}, which does its thing immediately. */
2971 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
2974 append_elem(OP_LINESEQ,
2975 append_elem(OP_LINESEQ,
2976 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, id)),
2977 newSTATEOP(0, Nullch, veop)),
2978 newSTATEOP(0, Nullch, imop) ));
2980 /* The "did you use incorrect case?" warning used to be here.
2981 * The problem is that on case-insensitive filesystems one
2982 * might get false positives for "use" (and "require"):
2983 * "use Strict" or "require CARP" will work. This causes
2984 * portability problems for the script: in case-strict
2985 * filesystems the script will stop working.
2987 * The "incorrect case" warning checked whether "use Foo"
2988 * imported "Foo" to your namespace, but that is wrong, too:
2989 * there is no requirement nor promise in the language that
2990 * a Foo.pm should or would contain anything in package "Foo".
2992 * There is very little Configure-wise that can be done, either:
2993 * the case-sensitivity of the build filesystem of Perl does not
2994 * help in guessing the case-sensitivity of the runtime environment.
2997 PL_hints |= HINT_BLOCK_SCOPE;
2998 PL_copline = NOLINE;
3003 =head1 Embedding Functions
3005 =for apidoc load_module
3007 Loads the module whose name is pointed to by the string part of name.
3008 Note that the actual module name, not its filename, should be given.
3009 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3010 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3011 (or 0 for no flags). ver, if specified, provides version semantics
3012 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3013 arguments can be used to specify arguments to the module's import()
3014 method, similar to C<use Foo::Bar VERSION LIST>.
3019 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3022 va_start(args, ver);
3023 vload_module(flags, name, ver, &args);
3027 #ifdef PERL_IMPLICIT_CONTEXT
3029 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3033 va_start(args, ver);
3034 vload_module(flags, name, ver, &args);
3040 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3042 OP *modname, *veop, *imop;
3044 modname = newSVOP(OP_CONST, 0, name);
3045 modname->op_private |= OPpCONST_BARE;
3047 veop = newSVOP(OP_CONST, 0, ver);
3051 if (flags & PERL_LOADMOD_NOIMPORT) {
3052 imop = sawparens(newNULLLIST());
3054 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3055 imop = va_arg(*args, OP*);
3060 sv = va_arg(*args, SV*);
3062 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3063 sv = va_arg(*args, SV*);
3067 line_t ocopline = PL_copline;
3068 int oexpect = PL_expect;
3070 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3071 veop, modname, imop);
3072 PL_expect = oexpect;
3073 PL_copline = ocopline;
3078 Perl_dofile(pTHX_ OP *term)
3083 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3084 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
3085 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3087 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3088 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3089 append_elem(OP_LIST, term,
3090 scalar(newUNOP(OP_RV2CV, 0,
3095 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3101 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3103 return newBINOP(OP_LSLICE, flags,
3104 list(force_list(subscript)),
3105 list(force_list(listval)) );
3109 S_list_assignment(pTHX_ register OP *o)
3114 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3115 o = cUNOPo->op_first;
3117 if (o->op_type == OP_COND_EXPR) {
3118 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3119 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3124 yyerror("Assignment to both a list and a scalar");
3128 if (o->op_type == OP_LIST &&
3129 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3130 o->op_private & OPpLVAL_INTRO)
3133 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3134 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3135 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3138 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3141 if (o->op_type == OP_RV2SV)
3148 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3153 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3154 return newLOGOP(optype, 0,
3155 mod(scalar(left), optype),
3156 newUNOP(OP_SASSIGN, 0, scalar(right)));
3159 return newBINOP(optype, OPf_STACKED,
3160 mod(scalar(left), optype), scalar(right));
3164 if (list_assignment(left)) {
3168 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3169 left = mod(left, OP_AASSIGN);
3177 curop = list(force_list(left));
3178 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3179 o->op_private = (U8)(0 | (flags >> 8));
3181 /* PL_generation sorcery:
3182 * an assignment like ($a,$b) = ($c,$d) is easier than
3183 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3184 * To detect whether there are common vars, the global var
3185 * PL_generation is incremented for each assign op we compile.
3186 * Then, while compiling the assign op, we run through all the
3187 * variables on both sides of the assignment, setting a spare slot
3188 * in each of them to PL_generation. If any of them already have
3189 * that value, we know we've got commonality. We could use a
3190 * single bit marker, but then we'd have to make 2 passes, first
3191 * to clear the flag, then to test and set it. To find somewhere
3192 * to store these values, evil chicanery is done with SvCUR().
3195 if (!(left->op_private & OPpLVAL_INTRO)) {
3198 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3199 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3200 if (curop->op_type == OP_GV) {
3201 GV *gv = cGVOPx_gv(curop);
3202 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3204 SvCUR(gv) = PL_generation;
3206 else if (curop->op_type == OP_PADSV ||
3207 curop->op_type == OP_PADAV ||
3208 curop->op_type == OP_PADHV ||
3209 curop->op_type == OP_PADANY)
3211 if (PAD_COMPNAME_GEN(curop->op_targ)
3214 PAD_COMPNAME_GEN(curop->op_targ)
3218 else if (curop->op_type == OP_RV2CV)
3220 else if (curop->op_type == OP_RV2SV ||
3221 curop->op_type == OP_RV2AV ||
3222 curop->op_type == OP_RV2HV ||
3223 curop->op_type == OP_RV2GV) {
3224 if (lastop->op_type != OP_GV) /* funny deref? */
3227 else if (curop->op_type == OP_PUSHRE) {
3228 if (((PMOP*)curop)->op_pmreplroot) {
3230 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3231 ((PMOP*)curop)->op_pmreplroot));
3233 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3235 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3237 SvCUR(gv) = PL_generation;
3246 o->op_private |= OPpASSIGN_COMMON;
3248 if (right && right->op_type == OP_SPLIT) {
3250 if ((tmpop = ((LISTOP*)right)->op_first) &&
3251 tmpop->op_type == OP_PUSHRE)
3253 PMOP *pm = (PMOP*)tmpop;
3254 if (left->op_type == OP_RV2AV &&
3255 !(left->op_private & OPpLVAL_INTRO) &&
3256 !(o->op_private & OPpASSIGN_COMMON) )
3258 tmpop = ((UNOP*)left)->op_first;
3259 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3261 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3262 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3264 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3265 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3267 pm->op_pmflags |= PMf_ONCE;
3268 tmpop = cUNOPo->op_first; /* to list (nulled) */
3269 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3270 tmpop->op_sibling = Nullop; /* don't free split */
3271 right->op_next = tmpop->op_next; /* fix starting loc */
3272 op_free(o); /* blow off assign */
3273 right->op_flags &= ~OPf_WANT;
3274 /* "I don't know and I don't care." */
3279 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3280 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3282 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3284 sv_setiv(sv, PL_modcount+1);
3292 right = newOP(OP_UNDEF, 0);
3293 if (right->op_type == OP_READLINE) {
3294 right->op_flags |= OPf_STACKED;
3295 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3298 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3299 o = newBINOP(OP_SASSIGN, flags,
3300 scalar(right), mod(scalar(left), OP_SASSIGN) );
3312 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3314 U32 seq = intro_my();
3317 NewOp(1101, cop, 1, COP);
3318 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3319 cop->op_type = OP_DBSTATE;
3320 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3323 cop->op_type = OP_NEXTSTATE;
3324 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3326 cop->op_flags = (U8)flags;
3327 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3329 cop->op_private |= NATIVE_HINTS;
3331 PL_compiling.op_private = cop->op_private;
3332 cop->op_next = (OP*)cop;
3335 cop->cop_label = label;
3336 PL_hints |= HINT_BLOCK_SCOPE;
3339 cop->cop_arybase = PL_curcop->cop_arybase;
3340 if (specialWARN(PL_curcop->cop_warnings))
3341 cop->cop_warnings = PL_curcop->cop_warnings ;
3343 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3344 if (specialCopIO(PL_curcop->cop_io))
3345 cop->cop_io = PL_curcop->cop_io;
3347 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3350 if (PL_copline == NOLINE)
3351 CopLINE_set(cop, CopLINE(PL_curcop));
3353 CopLINE_set(cop, PL_copline);
3354 PL_copline = NOLINE;
3357 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3359 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3361 CopSTASH_set(cop, PL_curstash);
3363 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3364 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3365 if (svp && *svp != &PL_sv_undef ) {
3366 (void)SvIOK_on(*svp);
3367 SvIVX(*svp) = PTR2IV(cop);
3371 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3376 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3378 return new_logop(type, flags, &first, &other);
3382 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3386 OP *first = *firstp;
3387 OP *other = *otherp;
3389 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3390 return newBINOP(type, flags, scalar(first), scalar(other));
3392 scalarboolean(first);
3393 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3394 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3395 if (type == OP_AND || type == OP_OR) {
3401 first = *firstp = cUNOPo->op_first;
3403 first->op_next = o->op_next;
3404 cUNOPo->op_first = Nullop;
3408 if (first->op_type == OP_CONST) {
3409 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE)) {
3410 if (first->op_private & OPpCONST_STRICT)
3411 no_bareword_allowed(first);
3413 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3415 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3426 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3427 OP *k1 = ((UNOP*)first)->op_first;
3428 OP *k2 = k1->op_sibling;
3430 switch (first->op_type)
3433 if (k2 && k2->op_type == OP_READLINE
3434 && (k2->op_flags & OPf_STACKED)
3435 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3437 warnop = k2->op_type;
3442 if (k1->op_type == OP_READDIR
3443 || k1->op_type == OP_GLOB
3444 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3445 || k1->op_type == OP_EACH)
3447 warnop = ((k1->op_type == OP_NULL)
3448 ? (OPCODE)k1->op_targ : k1->op_type);
3453 line_t oldline = CopLINE(PL_curcop);
3454 CopLINE_set(PL_curcop, PL_copline);
3455 Perl_warner(aTHX_ packWARN(WARN_MISC),
3456 "Value of %s%s can be \"0\"; test with defined()",
3458 ((warnop == OP_READLINE || warnop == OP_GLOB)
3459 ? " construct" : "() operator"));
3460 CopLINE_set(PL_curcop, oldline);
3467 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3468 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3470 NewOp(1101, logop, 1, LOGOP);
3472 logop->op_type = (OPCODE)type;
3473 logop->op_ppaddr = PL_ppaddr[type];
3474 logop->op_first = first;
3475 logop->op_flags = flags | OPf_KIDS;
3476 logop->op_other = LINKLIST(other);
3477 logop->op_private = (U8)(1 | (flags >> 8));
3479 /* establish postfix order */
3480 logop->op_next = LINKLIST(first);
3481 first->op_next = (OP*)logop;
3482 first->op_sibling = other;
3484 o = newUNOP(OP_NULL, 0, (OP*)logop);
3491 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3498 return newLOGOP(OP_AND, 0, first, trueop);
3500 return newLOGOP(OP_OR, 0, first, falseop);
3502 scalarboolean(first);
3503 if (first->op_type == OP_CONST) {
3504 if (first->op_private & OPpCONST_BARE &&
3505 first->op_private & OPpCONST_STRICT) {
3506 no_bareword_allowed(first);
3508 if (SvTRUE(((SVOP*)first)->op_sv)) {
3519 NewOp(1101, logop, 1, LOGOP);
3520 logop->op_type = OP_COND_EXPR;
3521 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3522 logop->op_first = first;
3523 logop->op_flags = flags | OPf_KIDS;
3524 logop->op_private = (U8)(1 | (flags >> 8));
3525 logop->op_other = LINKLIST(trueop);
3526 logop->op_next = LINKLIST(falseop);
3529 /* establish postfix order */
3530 start = LINKLIST(first);
3531 first->op_next = (OP*)logop;
3533 first->op_sibling = trueop;
3534 trueop->op_sibling = falseop;
3535 o = newUNOP(OP_NULL, 0, (OP*)logop);
3537 trueop->op_next = falseop->op_next = o;
3544 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3552 NewOp(1101, range, 1, LOGOP);
3554 range->op_type = OP_RANGE;
3555 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3556 range->op_first = left;
3557 range->op_flags = OPf_KIDS;
3558 leftstart = LINKLIST(left);
3559 range->op_other = LINKLIST(right);
3560 range->op_private = (U8)(1 | (flags >> 8));
3562 left->op_sibling = right;
3564 range->op_next = (OP*)range;
3565 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3566 flop = newUNOP(OP_FLOP, 0, flip);
3567 o = newUNOP(OP_NULL, 0, flop);
3569 range->op_next = leftstart;
3571 left->op_next = flip;
3572 right->op_next = flop;
3574 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3575 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3576 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3577 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3579 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3580 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3583 if (!flip->op_private || !flop->op_private)
3584 linklist(o); /* blow off optimizer unless constant */
3590 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3594 int once = block && block->op_flags & OPf_SPECIAL &&
3595 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3598 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3599 return block; /* do {} while 0 does once */
3600 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3601 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3602 expr = newUNOP(OP_DEFINED, 0,
3603 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3604 } else if (expr->op_flags & OPf_KIDS) {
3605 OP *k1 = ((UNOP*)expr)->op_first;
3606 OP *k2 = (k1) ? k1->op_sibling : NULL;
3607 switch (expr->op_type) {
3609 if (k2 && k2->op_type == OP_READLINE
3610 && (k2->op_flags & OPf_STACKED)
3611 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3612 expr = newUNOP(OP_DEFINED, 0, expr);
3616 if (k1->op_type == OP_READDIR
3617 || k1->op_type == OP_GLOB
3618 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3619 || k1->op_type == OP_EACH)
3620 expr = newUNOP(OP_DEFINED, 0, expr);
3626 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3627 o = new_logop(OP_AND, 0, &expr, &listop);
3630 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3632 if (once && o != listop)
3633 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3636 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3638 o->op_flags |= flags;
3640 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3645 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3653 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3654 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3655 expr = newUNOP(OP_DEFINED, 0,
3656 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3657 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3658 OP *k1 = ((UNOP*)expr)->op_first;
3659 OP *k2 = (k1) ? k1->op_sibling : NULL;
3660 switch (expr->op_type) {
3662 if (k2 && k2->op_type == OP_READLINE
3663 && (k2->op_flags & OPf_STACKED)
3664 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3665 expr = newUNOP(OP_DEFINED, 0, expr);
3669 if (k1->op_type == OP_READDIR
3670 || k1->op_type == OP_GLOB
3671 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3672 || k1->op_type == OP_EACH)
3673 expr = newUNOP(OP_DEFINED, 0, expr);
3679 block = newOP(OP_NULL, 0);
3681 block = scope(block);
3685 next = LINKLIST(cont);
3688 OP *unstack = newOP(OP_UNSTACK, 0);
3691 cont = append_elem(OP_LINESEQ, cont, unstack);
3692 if ((line_t)whileline != NOLINE) {
3693 PL_copline = (line_t)whileline;
3694 cont = append_elem(OP_LINESEQ, cont,
3695 newSTATEOP(0, Nullch, Nullop));
3699 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3700 redo = LINKLIST(listop);
3703 PL_copline = (line_t)whileline;
3705 o = new_logop(OP_AND, 0, &expr, &listop);
3706 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3707 op_free(expr); /* oops, it's a while (0) */
3709 return Nullop; /* listop already freed by new_logop */
3712 ((LISTOP*)listop)->op_last->op_next =
3713 (o == listop ? redo : LINKLIST(o));
3719 NewOp(1101,loop,1,LOOP);
3720 loop->op_type = OP_ENTERLOOP;
3721 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3722 loop->op_private = 0;
3723 loop->op_next = (OP*)loop;
3726 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3728 loop->op_redoop = redo;
3729 loop->op_lastop = o;
3730 o->op_private |= loopflags;
3733 loop->op_nextop = next;
3735 loop->op_nextop = o;
3737 o->op_flags |= flags;
3738 o->op_private |= (flags >> 8);
3743 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
3747 PADOFFSET padoff = 0;
3751 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
3752 sv->op_type = OP_RV2GV;
3753 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3755 else if (sv->op_type == OP_PADSV) { /* private variable */
3756 padoff = sv->op_targ;
3761 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3762 padoff = sv->op_targ;
3764 iterflags |= OPf_SPECIAL;
3769 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3772 #ifdef USE_5005THREADS
3773 padoff = find_threadsv("_");
3774 iterflags |= OPf_SPECIAL;
3776 sv = newGVOP(OP_GV, 0, PL_defgv);
3779 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3780 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3781 iterflags |= OPf_STACKED;
3783 else if (expr->op_type == OP_NULL &&
3784 (expr->op_flags & OPf_KIDS) &&
3785 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3787 /* Basically turn for($x..$y) into the same as for($x,$y), but we
3788 * set the STACKED flag to indicate that these values are to be
3789 * treated as min/max values by 'pp_iterinit'.
3791 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
3792 LOGOP* range = (LOGOP*) flip->op_first;
3793 OP* left = range->op_first;
3794 OP* right = left->op_sibling;
3797 range->op_flags &= ~OPf_KIDS;
3798 range->op_first = Nullop;
3800 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
3801 listop->op_first->op_next = range->op_next;
3802 left->op_next = range->op_other;
3803 right->op_next = (OP*)listop;
3804 listop->op_next = listop->op_first;
3807 expr = (OP*)(listop);
3809 iterflags |= OPf_STACKED;
3812 expr = mod(force_list(expr), OP_GREPSTART);
3816 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
3817 append_elem(OP_LIST, expr, scalar(sv))));
3818 assert(!loop->op_next);
3819 #ifdef PL_OP_SLAB_ALLOC
3822 NewOp(1234,tmp,1,LOOP);
3823 Copy(loop,tmp,1,LOOP);
3828 Renew(loop, 1, LOOP);
3830 loop->op_targ = padoff;
3831 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
3832 PL_copline = forline;
3833 return newSTATEOP(0, label, wop);
3837 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
3842 if (type != OP_GOTO || label->op_type == OP_CONST) {
3843 /* "last()" means "last" */
3844 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
3845 o = newOP(type, OPf_SPECIAL);
3847 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
3848 ? SvPVx(((SVOP*)label)->op_sv, n_a)
3854 if (label->op_type == OP_ENTERSUB)
3855 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
3856 o = newUNOP(type, OPf_STACKED, label);
3858 PL_hints |= HINT_BLOCK_SCOPE;
3863 Perl_cv_undef(pTHX_ CV *cv)
3866 CV *freecv = Nullcv;
3868 #ifdef USE_5005THREADS
3870 MUTEX_DESTROY(CvMUTEXP(cv));
3871 Safefree(CvMUTEXP(cv));
3874 #endif /* USE_5005THREADS */
3877 if (CvFILE(cv) && !CvXSUB(cv)) {
3878 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
3879 Safefree(CvFILE(cv));
3884 if (!CvXSUB(cv) && CvROOT(cv)) {
3885 #ifdef USE_5005THREADS
3886 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
3887 Perl_croak(aTHX_ "Can't undef active subroutine");
3890 Perl_croak(aTHX_ "Can't undef active subroutine");
3891 #endif /* USE_5005THREADS */
3894 PAD_SAVE_SETNULLPAD;
3896 op_free(CvROOT(cv));
3897 CvROOT(cv) = Nullop;
3900 SvPOK_off((SV*)cv); /* forget prototype */
3902 outsidecv = CvOUTSIDE(cv);
3903 /* Since closure prototypes have the same lifetime as the containing
3904 * CV, they don't hold a refcount on the outside CV. This avoids
3905 * the refcount loop between the outer CV (which keeps a refcount to
3906 * the closure prototype in the pad entry for pp_anoncode()) and the
3907 * closure prototype, and the ensuing memory leak. --GSAR */
3908 if (!CvANON(cv) || CvCLONED(cv))
3910 CvOUTSIDE(cv) = Nullcv;
3912 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
3915 pad_undef(cv, outsidecv);
3917 SvREFCNT_dec(freecv);
3925 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
3927 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
3928 SV* msg = sv_newmortal();
3932 gv_efullname3(name = sv_newmortal(), gv, Nullch);
3933 sv_setpv(msg, "Prototype mismatch:");
3935 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
3937 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
3938 sv_catpv(msg, " vs ");
3940 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
3942 sv_catpv(msg, "none");
3943 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
3947 static void const_sv_xsub(pTHX_ CV* cv);
3951 =head1 Optree Manipulation Functions
3953 =for apidoc cv_const_sv
3955 If C<cv> is a constant sub eligible for inlining. returns the constant
3956 value returned by the sub. Otherwise, returns NULL.
3958 Constant subs can be created with C<newCONSTSUB> or as described in
3959 L<perlsub/"Constant Functions">.
3964 Perl_cv_const_sv(pTHX_ CV *cv)
3966 if (!cv || !CvCONST(cv))
3968 return (SV*)CvXSUBANY(cv).any_ptr;
3972 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
3979 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
3980 o = cLISTOPo->op_first->op_sibling;
3982 for (; o; o = o->op_next) {
3983 OPCODE type = o->op_type;
3985 if (sv && o->op_next == o)
3987 if (o->op_next != o) {
3988 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
3990 if (type == OP_DBSTATE)
3993 if (type == OP_LEAVESUB || type == OP_RETURN)
3997 if (type == OP_CONST && cSVOPo->op_sv)
3999 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4000 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4004 /* We get here only from cv_clone2() while creating a closure.
4005 Copy the const value here instead of in cv_clone2 so that
4006 SvREADONLY_on doesn't lead to problems when leaving
4011 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4023 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4033 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4037 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4039 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4043 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4049 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4053 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4054 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4055 SV *sv = sv_newmortal();
4056 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4057 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4058 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4063 gv = gv_fetchpv(name ? name : (aname ? aname :
4064 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__")),
4065 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4075 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4076 maximum a prototype before. */
4077 if (SvTYPE(gv) > SVt_NULL) {
4078 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4079 && ckWARN_d(WARN_PROTOTYPE))
4081 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4083 cv_ckproto((CV*)gv, NULL, ps);
4086 sv_setpv((SV*)gv, ps);
4088 sv_setiv((SV*)gv, -1);
4089 SvREFCNT_dec(PL_compcv);
4090 cv = PL_compcv = NULL;
4091 PL_sub_generation++;
4095 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4097 #ifdef GV_UNIQUE_CHECK
4098 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4099 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4103 if (!block || !ps || *ps || attrs)
4106 const_sv = op_const_sv(block, Nullcv);
4109 bool exists = CvROOT(cv) || CvXSUB(cv);
4111 #ifdef GV_UNIQUE_CHECK
4112 if (exists && GvUNIQUE(gv)) {
4113 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4117 /* if the subroutine doesn't exist and wasn't pre-declared
4118 * with a prototype, assume it will be AUTOLOADed,
4119 * skipping the prototype check
4121 if (exists || SvPOK(cv))
4122 cv_ckproto(cv, gv, ps);
4123 /* already defined (or promised)? */
4124 if (exists || GvASSUMECV(gv)) {
4125 if (!block && !attrs) {
4126 if (CvFLAGS(PL_compcv)) {
4127 /* might have had built-in attrs applied */
4128 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4130 /* just a "sub foo;" when &foo is already defined */
4131 SAVEFREESV(PL_compcv);
4134 /* ahem, death to those who redefine active sort subs */
4135 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4136 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4138 if (ckWARN(WARN_REDEFINE)
4140 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4142 line_t oldline = CopLINE(PL_curcop);
4143 if (PL_copline != NOLINE)
4144 CopLINE_set(PL_curcop, PL_copline);
4145 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4146 CvCONST(cv) ? "Constant subroutine %s redefined"
4147 : "Subroutine %s redefined", name);
4148 CopLINE_set(PL_curcop, oldline);
4156 SvREFCNT_inc(const_sv);
4158 assert(!CvROOT(cv) && !CvCONST(cv));
4159 sv_setpv((SV*)cv, ""); /* prototype is "" */
4160 CvXSUBANY(cv).any_ptr = const_sv;
4161 CvXSUB(cv) = const_sv_xsub;
4166 cv = newCONSTSUB(NULL, name, const_sv);
4169 SvREFCNT_dec(PL_compcv);
4171 PL_sub_generation++;
4178 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4179 * before we clobber PL_compcv.
4183 /* Might have had built-in attributes applied -- propagate them. */
4184 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4185 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4186 stash = GvSTASH(CvGV(cv));
4187 else if (CvSTASH(cv))
4188 stash = CvSTASH(cv);
4190 stash = PL_curstash;
4193 /* possibly about to re-define existing subr -- ignore old cv */
4194 rcv = (SV*)PL_compcv;
4195 if (name && GvSTASH(gv))
4196 stash = GvSTASH(gv);
4198 stash = PL_curstash;
4200 apply_attrs(stash, rcv, attrs, FALSE);
4202 if (cv) { /* must reuse cv if autoloaded */
4204 /* got here with just attrs -- work done, so bug out */
4205 SAVEFREESV(PL_compcv);
4209 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4210 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4211 CvOUTSIDE(PL_compcv) = 0;
4212 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4213 CvPADLIST(PL_compcv) = 0;
4214 /* inner references to PL_compcv must be fixed up ... */
4215 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4216 /* ... before we throw it away */
4217 SvREFCNT_dec(PL_compcv);
4218 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4219 ++PL_sub_generation;
4226 PL_sub_generation++;
4230 CvFILE_set_from_cop(cv, PL_curcop);
4231 CvSTASH(cv) = PL_curstash;
4232 #ifdef USE_5005THREADS
4234 if (!CvMUTEXP(cv)) {
4235 New(666, CvMUTEXP(cv), 1, perl_mutex);
4236 MUTEX_INIT(CvMUTEXP(cv));
4238 #endif /* USE_5005THREADS */
4241 sv_setpv((SV*)cv, ps);
4243 if (PL_error_count) {
4247 char *s = strrchr(name, ':');
4249 if (strEQ(s, "BEGIN")) {
4251 "BEGIN not safe after errors--compilation aborted";
4252 if (PL_in_eval & EVAL_KEEPERR)
4253 Perl_croak(aTHX_ not_safe);
4255 /* force display of errors found but not reported */
4256 sv_catpv(ERRSV, not_safe);
4257 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4266 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4267 mod(scalarseq(block), OP_LEAVESUBLV));
4270 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4272 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4273 OpREFCNT_set(CvROOT(cv), 1);
4274 CvSTART(cv) = LINKLIST(CvROOT(cv));
4275 CvROOT(cv)->op_next = 0;
4276 CALL_PEEP(CvSTART(cv));
4278 /* now that optimizer has done its work, adjust pad values */
4280 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4283 assert(!CvCONST(cv));
4284 if (ps && !*ps && op_const_sv(block, cv))
4288 /* If a potential closure prototype, don't keep a refcount on outer CV.
4289 * This is okay as the lifetime of the prototype is tied to the
4290 * lifetime of the outer CV. Avoids memory leak due to reference
4293 SvREFCNT_dec(CvOUTSIDE(cv));
4295 if (name || aname) {
4297 char *tname = (name ? name : aname);
4299 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4300 SV *sv = NEWSV(0,0);
4301 SV *tmpstr = sv_newmortal();
4302 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4306 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4308 (long)PL_subline, (long)CopLINE(PL_curcop));
4309 gv_efullname3(tmpstr, gv, Nullch);
4310 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4311 hv = GvHVn(db_postponed);
4312 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4313 && (pcv = GvCV(db_postponed)))
4319 call_sv((SV*)pcv, G_DISCARD);
4323 if ((s = strrchr(tname,':')))
4328 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4331 if (strEQ(s, "BEGIN")) {
4332 I32 oldscope = PL_scopestack_ix;
4334 SAVECOPFILE(&PL_compiling);
4335 SAVECOPLINE(&PL_compiling);
4338 PL_beginav = newAV();
4339 DEBUG_x( dump_sub(gv) );
4340 av_push(PL_beginav, (SV*)cv);
4341 GvCV(gv) = 0; /* cv has been hijacked */
4342 call_list(oldscope, PL_beginav);
4344 PL_curcop = &PL_compiling;
4345 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4348 else if (strEQ(s, "END") && !PL_error_count) {
4351 DEBUG_x( dump_sub(gv) );
4352 av_unshift(PL_endav, 1);
4353 av_store(PL_endav, 0, (SV*)cv);
4354 GvCV(gv) = 0; /* cv has been hijacked */
4356 else if (strEQ(s, "CHECK") && !PL_error_count) {
4358 PL_checkav = newAV();
4359 DEBUG_x( dump_sub(gv) );
4360 if (PL_main_start && ckWARN(WARN_VOID))
4361 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4362 av_unshift(PL_checkav, 1);
4363 av_store(PL_checkav, 0, (SV*)cv);
4364 GvCV(gv) = 0; /* cv has been hijacked */
4366 else if (strEQ(s, "INIT") && !PL_error_count) {
4368 PL_initav = newAV();
4369 DEBUG_x( dump_sub(gv) );
4370 if (PL_main_start && ckWARN(WARN_VOID))
4371 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4372 av_push(PL_initav, (SV*)cv);
4373 GvCV(gv) = 0; /* cv has been hijacked */
4378 PL_copline = NOLINE;
4383 /* XXX unsafe for threads if eval_owner isn't held */
4385 =for apidoc newCONSTSUB
4387 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4388 eligible for inlining at compile-time.
4394 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4400 SAVECOPLINE(PL_curcop);
4401 CopLINE_set(PL_curcop, PL_copline);
4404 PL_hints &= ~HINT_BLOCK_SCOPE;
4407 SAVESPTR(PL_curstash);
4408 SAVECOPSTASH(PL_curcop);
4409 PL_curstash = stash;
4410 CopSTASH_set(PL_curcop,stash);
4413 cv = newXS(name, const_sv_xsub, __FILE__);
4414 CvXSUBANY(cv).any_ptr = sv;
4416 sv_setpv((SV*)cv, ""); /* prototype is "" */
4424 =for apidoc U||newXS
4426 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4432 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
4434 GV *gv = gv_fetchpv(name ? name :
4435 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4436 GV_ADDMULTI, SVt_PVCV);
4440 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4442 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4444 /* just a cached method */
4448 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4449 /* already defined (or promised) */
4450 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4451 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4452 line_t oldline = CopLINE(PL_curcop);
4453 if (PL_copline != NOLINE)
4454 CopLINE_set(PL_curcop, PL_copline);
4455 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4456 CvCONST(cv) ? "Constant subroutine %s redefined"
4457 : "Subroutine %s redefined"
4459 CopLINE_set(PL_curcop, oldline);
4466 if (cv) /* must reuse cv if autoloaded */
4469 cv = (CV*)NEWSV(1105,0);
4470 sv_upgrade((SV *)cv, SVt_PVCV);
4474 PL_sub_generation++;
4478 #ifdef USE_5005THREADS
4479 New(666, CvMUTEXP(cv), 1, perl_mutex);
4480 MUTEX_INIT(CvMUTEXP(cv));
4482 #endif /* USE_5005THREADS */
4483 (void)gv_fetchfile(filename);
4484 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
4485 an external constant string */
4486 CvXSUB(cv) = subaddr;
4489 char *s = strrchr(name,':');
4495 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4498 if (strEQ(s, "BEGIN")) {
4500 PL_beginav = newAV();
4501 av_push(PL_beginav, (SV*)cv);
4502 GvCV(gv) = 0; /* cv has been hijacked */
4504 else if (strEQ(s, "END")) {
4507 av_unshift(PL_endav, 1);
4508 av_store(PL_endav, 0, (SV*)cv);
4509 GvCV(gv) = 0; /* cv has been hijacked */
4511 else if (strEQ(s, "CHECK")) {
4513 PL_checkav = newAV();
4514 if (PL_main_start && ckWARN(WARN_VOID))
4515 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4516 av_unshift(PL_checkav, 1);
4517 av_store(PL_checkav, 0, (SV*)cv);
4518 GvCV(gv) = 0; /* cv has been hijacked */
4520 else if (strEQ(s, "INIT")) {
4522 PL_initav = newAV();
4523 if (PL_main_start && ckWARN(WARN_VOID))
4524 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4525 av_push(PL_initav, (SV*)cv);
4526 GvCV(gv) = 0; /* cv has been hijacked */
4537 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4545 name = SvPVx(cSVOPo->op_sv, n_a);
4548 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
4549 #ifdef GV_UNIQUE_CHECK
4551 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4555 if ((cv = GvFORM(gv))) {
4556 if (ckWARN(WARN_REDEFINE)) {
4557 line_t oldline = CopLINE(PL_curcop);
4558 if (PL_copline != NOLINE)
4559 CopLINE_set(PL_curcop, PL_copline);
4560 Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Format %s redefined",name);
4561 CopLINE_set(PL_curcop, oldline);
4568 CvFILE_set_from_cop(cv, PL_curcop);
4571 pad_tidy(padtidy_FORMAT);
4572 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4573 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4574 OpREFCNT_set(CvROOT(cv), 1);
4575 CvSTART(cv) = LINKLIST(CvROOT(cv));
4576 CvROOT(cv)->op_next = 0;
4577 CALL_PEEP(CvSTART(cv));
4579 PL_copline = NOLINE;
4584 Perl_newANONLIST(pTHX_ OP *o)
4586 return newUNOP(OP_REFGEN, 0,
4587 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4591 Perl_newANONHASH(pTHX_ OP *o)
4593 return newUNOP(OP_REFGEN, 0,
4594 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4598 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4600 return newANONATTRSUB(floor, proto, Nullop, block);
4604 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4606 return newUNOP(OP_REFGEN, 0,
4607 newSVOP(OP_ANONCODE, 0,
4608 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
4612 Perl_oopsAV(pTHX_ OP *o)
4614 switch (o->op_type) {
4616 o->op_type = OP_PADAV;
4617 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4618 return ref(o, OP_RV2AV);
4621 o->op_type = OP_RV2AV;
4622 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4627 if (ckWARN_d(WARN_INTERNAL))
4628 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
4635 Perl_oopsHV(pTHX_ OP *o)
4637 switch (o->op_type) {
4640 o->op_type = OP_PADHV;
4641 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4642 return ref(o, OP_RV2HV);
4646 o->op_type = OP_RV2HV;
4647 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
4652 if (ckWARN_d(WARN_INTERNAL))
4653 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
4660 Perl_newAVREF(pTHX_ OP *o)
4662 if (o->op_type == OP_PADANY) {
4663 o->op_type = OP_PADAV;
4664 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4667 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
4668 && ckWARN(WARN_DEPRECATED)) {
4669 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4670 "Using an array as a reference is deprecated");
4672 return newUNOP(OP_RV2AV, 0, scalar(o));
4676 Perl_newGVREF(pTHX_ I32 type, OP *o)
4678 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
4679 return newUNOP(OP_NULL, 0, o);
4680 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
4684 Perl_newHVREF(pTHX_ OP *o)
4686 if (o->op_type == OP_PADANY) {
4687 o->op_type = OP_PADHV;
4688 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4691 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
4692 && ckWARN(WARN_DEPRECATED)) {
4693 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4694 "Using a hash as a reference is deprecated");
4696 return newUNOP(OP_RV2HV, 0, scalar(o));
4700 Perl_oopsCV(pTHX_ OP *o)
4702 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
4708 Perl_newCVREF(pTHX_ I32 flags, OP *o)
4710 return newUNOP(OP_RV2CV, flags, scalar(o));
4714 Perl_newSVREF(pTHX_ OP *o)
4716 if (o->op_type == OP_PADANY) {
4717 o->op_type = OP_PADSV;
4718 o->op_ppaddr = PL_ppaddr[OP_PADSV];
4721 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4722 o->op_flags |= OPpDONE_SVREF;
4725 return newUNOP(OP_RV2SV, 0, scalar(o));
4728 /* Check routines. */
4731 Perl_ck_anoncode(pTHX_ OP *o)
4733 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
4734 cSVOPo->op_sv = Nullsv;
4739 Perl_ck_bitop(pTHX_ OP *o)
4741 #define OP_IS_NUMCOMPARE(op) \
4742 ((op) == OP_LT || (op) == OP_I_LT || \
4743 (op) == OP_GT || (op) == OP_I_GT || \
4744 (op) == OP_LE || (op) == OP_I_LE || \
4745 (op) == OP_GE || (op) == OP_I_GE || \
4746 (op) == OP_EQ || (op) == OP_I_EQ || \
4747 (op) == OP_NE || (op) == OP_I_NE || \
4748 (op) == OP_NCMP || (op) == OP_I_NCMP)
4749 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4750 if (o->op_type == OP_BIT_OR
4751 || o->op_type == OP_BIT_AND
4752 || o->op_type == OP_BIT_XOR)
4754 OPCODE typfirst = cBINOPo->op_first->op_type;
4755 OPCODE typlast = cBINOPo->op_first->op_sibling->op_type;
4756 if (OP_IS_NUMCOMPARE(typfirst) || OP_IS_NUMCOMPARE(typlast))
4757 if (ckWARN(WARN_PRECEDENCE))
4758 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4759 "Possible precedence problem on bitwise %c operator",
4760 o->op_type == OP_BIT_OR ? '|'
4761 : o->op_type == OP_BIT_AND ? '&' : '^'
4768 Perl_ck_concat(pTHX_ OP *o)
4770 if (cUNOPo->op_first->op_type == OP_CONCAT)
4771 o->op_flags |= OPf_STACKED;
4776 Perl_ck_spair(pTHX_ OP *o)
4778 if (o->op_flags & OPf_KIDS) {
4781 OPCODE type = o->op_type;
4782 o = modkids(ck_fun(o), type);
4783 kid = cUNOPo->op_first;
4784 newop = kUNOP->op_first->op_sibling;
4786 (newop->op_sibling ||
4787 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
4788 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
4789 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
4793 op_free(kUNOP->op_first);
4794 kUNOP->op_first = newop;
4796 o->op_ppaddr = PL_ppaddr[++o->op_type];
4801 Perl_ck_delete(pTHX_ OP *o)
4805 if (o->op_flags & OPf_KIDS) {
4806 OP *kid = cUNOPo->op_first;
4807 switch (kid->op_type) {
4809 o->op_flags |= OPf_SPECIAL;
4812 o->op_private |= OPpSLICE;
4815 o->op_flags |= OPf_SPECIAL;
4820 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
4829 Perl_ck_die(pTHX_ OP *o)
4832 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4838 Perl_ck_eof(pTHX_ OP *o)
4840 I32 type = o->op_type;
4842 if (o->op_flags & OPf_KIDS) {
4843 if (cLISTOPo->op_first->op_type == OP_STUB) {
4845 o = newUNOP(type, OPf_SPECIAL,
4846 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
4854 Perl_ck_eval(pTHX_ OP *o)
4856 PL_hints |= HINT_BLOCK_SCOPE;
4857 if (o->op_flags & OPf_KIDS) {
4858 SVOP *kid = (SVOP*)cUNOPo->op_first;
4861 o->op_flags &= ~OPf_KIDS;
4864 else if (kid->op_type == OP_LINESEQ) {
4867 kid->op_next = o->op_next;
4868 cUNOPo->op_first = 0;
4871 NewOp(1101, enter, 1, LOGOP);
4872 enter->op_type = OP_ENTERTRY;
4873 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
4874 enter->op_private = 0;
4876 /* establish postfix order */
4877 enter->op_next = (OP*)enter;
4879 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
4880 o->op_type = OP_LEAVETRY;
4881 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
4882 enter->op_other = o;
4890 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
4892 o->op_targ = (PADOFFSET)PL_hints;
4897 Perl_ck_exit(pTHX_ OP *o)
4900 HV *table = GvHV(PL_hintgv);
4902 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
4903 if (svp && *svp && SvTRUE(*svp))
4904 o->op_private |= OPpEXIT_VMSISH;
4906 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4912 Perl_ck_exec(pTHX_ OP *o)
4915 if (o->op_flags & OPf_STACKED) {
4917 kid = cUNOPo->op_first->op_sibling;
4918 if (kid->op_type == OP_RV2GV)
4927 Perl_ck_exists(pTHX_ OP *o)
4930 if (o->op_flags & OPf_KIDS) {
4931 OP *kid = cUNOPo->op_first;
4932 if (kid->op_type == OP_ENTERSUB) {
4933 (void) ref(kid, o->op_type);
4934 if (kid->op_type != OP_RV2CV && !PL_error_count)
4935 Perl_croak(aTHX_ "%s argument is not a subroutine name",
4937 o->op_private |= OPpEXISTS_SUB;
4939 else if (kid->op_type == OP_AELEM)
4940 o->op_flags |= OPf_SPECIAL;
4941 else if (kid->op_type != OP_HELEM)
4942 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
4951 Perl_ck_gvconst(pTHX_ register OP *o)
4953 o = fold_constants(o);
4954 if (o->op_type == OP_CONST)
4961 Perl_ck_rvconst(pTHX_ register OP *o)
4963 SVOP *kid = (SVOP*)cUNOPo->op_first;
4965 o->op_private |= (PL_hints & HINT_STRICT_REFS);
4966 if (kid->op_type == OP_CONST) {
4970 SV *kidsv = kid->op_sv;
4973 /* Is it a constant from cv_const_sv()? */
4974 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
4975 SV *rsv = SvRV(kidsv);
4976 int svtype = SvTYPE(rsv);
4977 char *badtype = Nullch;
4979 switch (o->op_type) {
4981 if (svtype > SVt_PVMG)
4982 badtype = "a SCALAR";
4985 if (svtype != SVt_PVAV)
4986 badtype = "an ARRAY";
4989 if (svtype != SVt_PVHV)
4993 if (svtype != SVt_PVCV)
4998 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5001 name = SvPV(kidsv, n_a);
5002 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5003 char *badthing = Nullch;
5004 switch (o->op_type) {
5006 badthing = "a SCALAR";
5009 badthing = "an ARRAY";
5012 badthing = "a HASH";
5017 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5021 * This is a little tricky. We only want to add the symbol if we
5022 * didn't add it in the lexer. Otherwise we get duplicate strict
5023 * warnings. But if we didn't add it in the lexer, we must at
5024 * least pretend like we wanted to add it even if it existed before,
5025 * or we get possible typo warnings. OPpCONST_ENTERED says
5026 * whether the lexer already added THIS instance of this symbol.
5028 iscv = (o->op_type == OP_RV2CV) * 2;
5030 gv = gv_fetchpv(name,
5031 iscv | !(kid->op_private & OPpCONST_ENTERED),
5034 : o->op_type == OP_RV2SV
5036 : o->op_type == OP_RV2AV
5038 : o->op_type == OP_RV2HV
5041 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5043 kid->op_type = OP_GV;
5044 SvREFCNT_dec(kid->op_sv);
5046 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5047 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5048 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
5050 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
5052 kid->op_sv = SvREFCNT_inc(gv);
5054 kid->op_private = 0;
5055 kid->op_ppaddr = PL_ppaddr[OP_GV];
5062 Perl_ck_ftst(pTHX_ OP *o)
5064 I32 type = o->op_type;
5066 if (o->op_flags & OPf_REF) {
5069 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5070 SVOP *kid = (SVOP*)cUNOPo->op_first;
5072 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5074 OP *newop = newGVOP(type, OPf_REF,
5075 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5082 if (type == OP_FTTTY)
5083 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5086 o = newUNOP(type, 0, newDEFSVOP());
5092 Perl_ck_fun(pTHX_ OP *o)
5098 int type = o->op_type;
5099 register I32 oa = PL_opargs[type] >> OASHIFT;
5101 if (o->op_flags & OPf_STACKED) {
5102 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5105 return no_fh_allowed(o);
5108 if (o->op_flags & OPf_KIDS) {
5110 tokid = &cLISTOPo->op_first;
5111 kid = cLISTOPo->op_first;
5112 if (kid->op_type == OP_PUSHMARK ||
5113 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5115 tokid = &kid->op_sibling;
5116 kid = kid->op_sibling;
5118 if (!kid && PL_opargs[type] & OA_DEFGV)
5119 *tokid = kid = newDEFSVOP();
5123 sibl = kid->op_sibling;
5126 /* list seen where single (scalar) arg expected? */
5127 if (numargs == 1 && !(oa >> 4)
5128 && kid->op_type == OP_LIST && type != OP_SCALAR)
5130 return too_many_arguments(o,PL_op_desc[type]);
5143 if ((type == OP_PUSH || type == OP_UNSHIFT)
5144 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5145 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5146 "Useless use of %s with no values",
5149 if (kid->op_type == OP_CONST &&
5150 (kid->op_private & OPpCONST_BARE))
5152 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5153 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5154 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5155 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5156 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5157 "Array @%s missing the @ in argument %"IVdf" of %s()",
5158 name, (IV)numargs, PL_op_desc[type]);
5161 kid->op_sibling = sibl;
5164 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5165 bad_type(numargs, "array", PL_op_desc[type], kid);
5169 if (kid->op_type == OP_CONST &&
5170 (kid->op_private & OPpCONST_BARE))
5172 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5173 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5174 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5175 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5176 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5177 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5178 name, (IV)numargs, PL_op_desc[type]);
5181 kid->op_sibling = sibl;
5184 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5185 bad_type(numargs, "hash", PL_op_desc[type], kid);
5190 OP *newop = newUNOP(OP_NULL, 0, kid);
5191 kid->op_sibling = 0;
5193 newop->op_next = newop;
5195 kid->op_sibling = sibl;
5200 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5201 if (kid->op_type == OP_CONST &&
5202 (kid->op_private & OPpCONST_BARE))
5204 OP *newop = newGVOP(OP_GV, 0,
5205 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5207 if (!(o->op_private & 1) && /* if not unop */
5208 kid == cLISTOPo->op_last)
5209 cLISTOPo->op_last = newop;
5213 else if (kid->op_type == OP_READLINE) {
5214 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5215 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5218 I32 flags = OPf_SPECIAL;
5222 /* is this op a FH constructor? */
5223 if (is_handle_constructor(o,numargs)) {
5224 char *name = Nullch;
5228 /* Set a flag to tell rv2gv to vivify
5229 * need to "prove" flag does not mean something
5230 * else already - NI-S 1999/05/07
5233 if (kid->op_type == OP_PADSV) {
5234 /*XXX DAPM 2002.08.25 tmp assert test */
5235 /*XXX*/ assert(av_fetch(PL_comppad_name, (kid->op_targ), FALSE));
5236 /*XXX*/ assert(*av_fetch(PL_comppad_name, (kid->op_targ), FALSE));
5238 name = PAD_COMPNAME_PV(kid->op_targ);
5239 /* SvCUR of a pad namesv can't be trusted
5240 * (see PL_generation), so calc its length
5246 else if (kid->op_type == OP_RV2SV
5247 && kUNOP->op_first->op_type == OP_GV)
5249 GV *gv = cGVOPx_gv(kUNOP->op_first);
5251 len = GvNAMELEN(gv);
5253 else if (kid->op_type == OP_AELEM
5254 || kid->op_type == OP_HELEM)
5256 name = "__ANONIO__";
5262 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5263 namesv = PAD_SVl(targ);
5264 (void)SvUPGRADE(namesv, SVt_PV);
5266 sv_setpvn(namesv, "$", 1);
5267 sv_catpvn(namesv, name, len);
5270 kid->op_sibling = 0;
5271 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5272 kid->op_targ = targ;
5273 kid->op_private |= priv;
5275 kid->op_sibling = sibl;
5281 mod(scalar(kid), type);
5285 tokid = &kid->op_sibling;
5286 kid = kid->op_sibling;
5288 o->op_private |= numargs;
5290 return too_many_arguments(o,OP_DESC(o));
5293 else if (PL_opargs[type] & OA_DEFGV) {
5295 return newUNOP(type, 0, newDEFSVOP());
5299 while (oa & OA_OPTIONAL)
5301 if (oa && oa != OA_LIST)
5302 return too_few_arguments(o,OP_DESC(o));
5308 Perl_ck_glob(pTHX_ OP *o)
5313 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5314 append_elem(OP_GLOB, o, newDEFSVOP());
5316 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5317 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5319 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5322 #if !defined(PERL_EXTERNAL_GLOB)
5323 /* XXX this can be tightened up and made more failsafe. */
5327 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5328 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5329 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5330 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5331 GvCV(gv) = GvCV(glob_gv);
5332 SvREFCNT_inc((SV*)GvCV(gv));
5333 GvIMPORTED_CV_on(gv);
5336 #endif /* PERL_EXTERNAL_GLOB */
5338 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5339 append_elem(OP_GLOB, o,
5340 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5341 o->op_type = OP_LIST;
5342 o->op_ppaddr = PL_ppaddr[OP_LIST];
5343 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5344 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5345 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5346 append_elem(OP_LIST, o,
5347 scalar(newUNOP(OP_RV2CV, 0,
5348 newGVOP(OP_GV, 0, gv)))));
5349 o = newUNOP(OP_NULL, 0, ck_subr(o));
5350 o->op_targ = OP_GLOB; /* hint at what it used to be */
5353 gv = newGVgen("main");
5355 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5361 Perl_ck_grep(pTHX_ OP *o)
5365 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5367 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5368 NewOp(1101, gwop, 1, LOGOP);
5370 if (o->op_flags & OPf_STACKED) {
5373 kid = cLISTOPo->op_first->op_sibling;
5374 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5377 kid->op_next = (OP*)gwop;
5378 o->op_flags &= ~OPf_STACKED;
5380 kid = cLISTOPo->op_first->op_sibling;
5381 if (type == OP_MAPWHILE)
5388 kid = cLISTOPo->op_first->op_sibling;
5389 if (kid->op_type != OP_NULL)
5390 Perl_croak(aTHX_ "panic: ck_grep");
5391 kid = kUNOP->op_first;
5393 gwop->op_type = type;
5394 gwop->op_ppaddr = PL_ppaddr[type];
5395 gwop->op_first = listkids(o);
5396 gwop->op_flags |= OPf_KIDS;
5397 gwop->op_private = 1;
5398 gwop->op_other = LINKLIST(kid);
5399 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5400 kid->op_next = (OP*)gwop;
5402 kid = cLISTOPo->op_first->op_sibling;
5403 if (!kid || !kid->op_sibling)
5404 return too_few_arguments(o,OP_DESC(o));
5405 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5406 mod(kid, OP_GREPSTART);
5412 Perl_ck_index(pTHX_ OP *o)
5414 if (o->op_flags & OPf_KIDS) {
5415 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5417 kid = kid->op_sibling; /* get past "big" */
5418 if (kid && kid->op_type == OP_CONST)
5419 fbm_compile(((SVOP*)kid)->op_sv, 0);
5425 Perl_ck_lengthconst(pTHX_ OP *o)
5427 /* XXX length optimization goes here */
5432 Perl_ck_lfun(pTHX_ OP *o)
5434 OPCODE type = o->op_type;
5435 return modkids(ck_fun(o), type);
5439 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5441 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5442 switch (cUNOPo->op_first->op_type) {
5444 /* This is needed for
5445 if (defined %stash::)
5446 to work. Do not break Tk.
5448 break; /* Globals via GV can be undef */
5450 case OP_AASSIGN: /* Is this a good idea? */
5451 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5452 "defined(@array) is deprecated");
5453 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5454 "\t(Maybe you should just omit the defined()?)\n");
5457 /* This is needed for
5458 if (defined %stash::)
5459 to work. Do not break Tk.
5461 break; /* Globals via GV can be undef */
5463 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5464 "defined(%%hash) is deprecated");
5465 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5466 "\t(Maybe you should just omit the defined()?)\n");
5477 Perl_ck_rfun(pTHX_ OP *o)
5479 OPCODE type = o->op_type;
5480 return refkids(ck_fun(o), type);
5484 Perl_ck_listiob(pTHX_ OP *o)
5488 kid = cLISTOPo->op_first;
5491 kid = cLISTOPo->op_first;
5493 if (kid->op_type == OP_PUSHMARK)
5494 kid = kid->op_sibling;
5495 if (kid && o->op_flags & OPf_STACKED)
5496 kid = kid->op_sibling;
5497 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5498 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5499 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5500 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5501 cLISTOPo->op_first->op_sibling = kid;
5502 cLISTOPo->op_last = kid;
5503 kid = kid->op_sibling;
5508 append_elem(o->op_type, o, newDEFSVOP());
5514 Perl_ck_sassign(pTHX_ OP *o)
5516 OP *kid = cLISTOPo->op_first;
5517 /* has a disposable target? */
5518 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5519 && !(kid->op_flags & OPf_STACKED)
5520 /* Cannot steal the second time! */
5521 && !(kid->op_private & OPpTARGET_MY))
5523 OP *kkid = kid->op_sibling;
5525 /* Can just relocate the target. */
5526 if (kkid && kkid->op_type == OP_PADSV
5527 && !(kkid->op_private & OPpLVAL_INTRO))
5529 kid->op_targ = kkid->op_targ;
5531 /* Now we do not need PADSV and SASSIGN. */
5532 kid->op_sibling = o->op_sibling; /* NULL */
5533 cLISTOPo->op_first = NULL;
5536 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
5544 Perl_ck_match(pTHX_ OP *o)
5546 o->op_private |= OPpRUNTIME;
5551 Perl_ck_method(pTHX_ OP *o)
5553 OP *kid = cUNOPo->op_first;
5554 if (kid->op_type == OP_CONST) {
5555 SV* sv = kSVOP->op_sv;
5556 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
5558 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5559 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
5562 kSVOP->op_sv = Nullsv;
5564 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5573 Perl_ck_null(pTHX_ OP *o)
5579 Perl_ck_open(pTHX_ OP *o)
5581 HV *table = GvHV(PL_hintgv);
5585 svp = hv_fetch(table, "open_IN", 7, FALSE);
5587 mode = mode_from_discipline(*svp);
5588 if (mode & O_BINARY)
5589 o->op_private |= OPpOPEN_IN_RAW;
5590 else if (mode & O_TEXT)
5591 o->op_private |= OPpOPEN_IN_CRLF;
5594 svp = hv_fetch(table, "open_OUT", 8, FALSE);
5596 mode = mode_from_discipline(*svp);
5597 if (mode & O_BINARY)
5598 o->op_private |= OPpOPEN_OUT_RAW;
5599 else if (mode & O_TEXT)
5600 o->op_private |= OPpOPEN_OUT_CRLF;
5603 if (o->op_type == OP_BACKTICK)
5609 Perl_ck_repeat(pTHX_ OP *o)
5611 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5612 o->op_private |= OPpREPEAT_DOLIST;
5613 cBINOPo->op_first = force_list(cBINOPo->op_first);
5621 Perl_ck_require(pTHX_ OP *o)
5625 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
5626 SVOP *kid = (SVOP*)cUNOPo->op_first;
5628 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5630 for (s = SvPVX(kid->op_sv); *s; s++) {
5631 if (*s == ':' && s[1] == ':') {
5633 Move(s+2, s+1, strlen(s+2)+1, char);
5634 --SvCUR(kid->op_sv);
5637 if (SvREADONLY(kid->op_sv)) {
5638 SvREADONLY_off(kid->op_sv);
5639 sv_catpvn(kid->op_sv, ".pm", 3);
5640 SvREADONLY_on(kid->op_sv);
5643 sv_catpvn(kid->op_sv, ".pm", 3);
5647 /* handle override, if any */
5648 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
5649 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
5650 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
5652 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5653 OP *kid = cUNOPo->op_first;
5654 cUNOPo->op_first = 0;
5656 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5657 append_elem(OP_LIST, kid,
5658 scalar(newUNOP(OP_RV2CV, 0,
5667 Perl_ck_return(pTHX_ OP *o)
5670 if (CvLVALUE(PL_compcv)) {
5671 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5672 mod(kid, OP_LEAVESUBLV);
5679 Perl_ck_retarget(pTHX_ OP *o)
5681 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5688 Perl_ck_select(pTHX_ OP *o)
5691 if (o->op_flags & OPf_KIDS) {
5692 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5693 if (kid && kid->op_sibling) {
5694 o->op_type = OP_SSELECT;
5695 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
5697 return fold_constants(o);
5701 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5702 if (kid && kid->op_type == OP_RV2GV)
5703 kid->op_private &= ~HINT_STRICT_REFS;
5708 Perl_ck_shift(pTHX_ OP *o)
5710 I32 type = o->op_type;
5712 if (!(o->op_flags & OPf_KIDS)) {
5716 #ifdef USE_5005THREADS
5717 if (!CvUNIQUE(PL_compcv)) {
5718 argop = newOP(OP_PADAV, OPf_REF);
5719 argop->op_targ = 0; /* PAD_SV(0) is @_ */
5722 argop = newUNOP(OP_RV2AV, 0,
5723 scalar(newGVOP(OP_GV, 0,
5724 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
5727 argop = newUNOP(OP_RV2AV, 0,
5728 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
5729 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
5730 #endif /* USE_5005THREADS */
5731 return newUNOP(type, 0, scalar(argop));
5733 return scalar(modkids(ck_fun(o), type));
5737 Perl_ck_sort(pTHX_ OP *o)
5741 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
5743 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5744 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
5746 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
5748 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
5750 if (kid->op_type == OP_SCOPE) {
5754 else if (kid->op_type == OP_LEAVE) {
5755 if (o->op_type == OP_SORT) {
5756 op_null(kid); /* wipe out leave */
5759 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
5760 if (k->op_next == kid)
5762 /* don't descend into loops */
5763 else if (k->op_type == OP_ENTERLOOP
5764 || k->op_type == OP_ENTERITER)
5766 k = cLOOPx(k)->op_lastop;
5771 kid->op_next = 0; /* just disconnect the leave */
5772 k = kLISTOP->op_first;
5777 if (o->op_type == OP_SORT) {
5778 /* provide scalar context for comparison function/block */
5784 o->op_flags |= OPf_SPECIAL;
5786 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
5789 firstkid = firstkid->op_sibling;
5792 /* provide list context for arguments */
5793 if (o->op_type == OP_SORT)
5800 S_simplify_sort(pTHX_ OP *o)
5802 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5806 if (!(o->op_flags & OPf_STACKED))
5808 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
5809 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
5810 kid = kUNOP->op_first; /* get past null */
5811 if (kid->op_type != OP_SCOPE)
5813 kid = kLISTOP->op_last; /* get past scope */
5814 switch(kid->op_type) {
5822 k = kid; /* remember this node*/
5823 if (kBINOP->op_first->op_type != OP_RV2SV)
5825 kid = kBINOP->op_first; /* get past cmp */
5826 if (kUNOP->op_first->op_type != OP_GV)
5828 kid = kUNOP->op_first; /* get past rv2sv */
5830 if (GvSTASH(gv) != PL_curstash)
5832 if (strEQ(GvNAME(gv), "a"))
5834 else if (strEQ(GvNAME(gv), "b"))
5838 kid = k; /* back to cmp */
5839 if (kBINOP->op_last->op_type != OP_RV2SV)
5841 kid = kBINOP->op_last; /* down to 2nd arg */
5842 if (kUNOP->op_first->op_type != OP_GV)
5844 kid = kUNOP->op_first; /* get past rv2sv */
5846 if (GvSTASH(gv) != PL_curstash
5848 ? strNE(GvNAME(gv), "a")
5849 : strNE(GvNAME(gv), "b")))
5851 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
5853 o->op_private |= OPpSORT_REVERSE;
5854 if (k->op_type == OP_NCMP)
5855 o->op_private |= OPpSORT_NUMERIC;
5856 if (k->op_type == OP_I_NCMP)
5857 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
5858 kid = cLISTOPo->op_first->op_sibling;
5859 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
5860 op_free(kid); /* then delete it */
5864 Perl_ck_split(pTHX_ OP *o)
5868 if (o->op_flags & OPf_STACKED)
5869 return no_fh_allowed(o);
5871 kid = cLISTOPo->op_first;
5872 if (kid->op_type != OP_NULL)
5873 Perl_croak(aTHX_ "panic: ck_split");
5874 kid = kid->op_sibling;
5875 op_free(cLISTOPo->op_first);
5876 cLISTOPo->op_first = kid;
5878 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
5879 cLISTOPo->op_last = kid; /* There was only one element previously */
5882 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
5883 OP *sibl = kid->op_sibling;
5884 kid->op_sibling = 0;
5885 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
5886 if (cLISTOPo->op_first == cLISTOPo->op_last)
5887 cLISTOPo->op_last = kid;
5888 cLISTOPo->op_first = kid;
5889 kid->op_sibling = sibl;
5892 kid->op_type = OP_PUSHRE;
5893 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
5895 if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
5896 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
5897 "Use of /g modifier is meaningless in split");
5900 if (!kid->op_sibling)
5901 append_elem(OP_SPLIT, o, newDEFSVOP());
5903 kid = kid->op_sibling;
5906 if (!kid->op_sibling)
5907 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
5909 kid = kid->op_sibling;
5912 if (kid->op_sibling)
5913 return too_many_arguments(o,OP_DESC(o));
5919 Perl_ck_join(pTHX_ OP *o)
5921 if (ckWARN(WARN_SYNTAX)) {
5922 OP *kid = cLISTOPo->op_first->op_sibling;
5923 if (kid && kid->op_type == OP_MATCH) {
5924 char *pmstr = "STRING";
5925 if (PM_GETRE(kPMOP))
5926 pmstr = PM_GETRE(kPMOP)->precomp;
5927 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5928 "/%s/ should probably be written as \"%s\"",
5936 Perl_ck_subr(pTHX_ OP *o)
5938 OP *prev = ((cUNOPo->op_first->op_sibling)
5939 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
5940 OP *o2 = prev->op_sibling;
5947 I32 contextclass = 0;
5951 o->op_private |= OPpENTERSUB_HASTARG;
5952 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
5953 if (cvop->op_type == OP_RV2CV) {
5955 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
5956 op_null(cvop); /* disable rv2cv */
5957 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
5958 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
5959 GV *gv = cGVOPx_gv(tmpop);
5962 tmpop->op_private |= OPpEARLY_CV;
5963 else if (SvPOK(cv)) {
5964 namegv = CvANON(cv) ? gv : CvGV(cv);
5965 proto = SvPV((SV*)cv, n_a);
5969 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
5970 if (o2->op_type == OP_CONST)
5971 o2->op_private &= ~OPpCONST_STRICT;
5972 else if (o2->op_type == OP_LIST) {
5973 OP *o = ((UNOP*)o2)->op_first->op_sibling;
5974 if (o && o->op_type == OP_CONST)
5975 o->op_private &= ~OPpCONST_STRICT;
5978 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5979 if (PERLDB_SUB && PL_curstash != PL_debstash)
5980 o->op_private |= OPpENTERSUB_DB;
5981 while (o2 != cvop) {
5985 return too_many_arguments(o, gv_ename(namegv));
6003 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6005 arg == 1 ? "block or sub {}" : "sub {}",
6006 gv_ename(namegv), o2);
6009 /* '*' allows any scalar type, including bareword */
6012 if (o2->op_type == OP_RV2GV)
6013 goto wrapref; /* autoconvert GLOB -> GLOBref */
6014 else if (o2->op_type == OP_CONST)
6015 o2->op_private &= ~OPpCONST_STRICT;
6016 else if (o2->op_type == OP_ENTERSUB) {
6017 /* accidental subroutine, revert to bareword */
6018 OP *gvop = ((UNOP*)o2)->op_first;
6019 if (gvop && gvop->op_type == OP_NULL) {
6020 gvop = ((UNOP*)gvop)->op_first;
6022 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6025 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6026 (gvop = ((UNOP*)gvop)->op_first) &&
6027 gvop->op_type == OP_GV)
6029 GV *gv = cGVOPx_gv(gvop);
6030 OP *sibling = o2->op_sibling;
6031 SV *n = newSVpvn("",0);
6033 gv_fullname3(n, gv, "");
6034 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6035 sv_chop(n, SvPVX(n)+6);
6036 o2 = newSVOP(OP_CONST, 0, n);
6037 prev->op_sibling = o2;
6038 o2->op_sibling = sibling;
6054 if (contextclass++ == 0) {
6055 e = strchr(proto, ']');
6056 if (!e || e == proto)
6069 while (*--p != '[');
6070 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6071 gv_ename(namegv), o2);
6077 if (o2->op_type == OP_RV2GV)
6080 bad_type(arg, "symbol", gv_ename(namegv), o2);
6083 if (o2->op_type == OP_ENTERSUB)
6086 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6089 if (o2->op_type == OP_RV2SV ||
6090 o2->op_type == OP_PADSV ||
6091 o2->op_type == OP_HELEM ||
6092 o2->op_type == OP_AELEM ||
6093 o2->op_type == OP_THREADSV)
6096 bad_type(arg, "scalar", gv_ename(namegv), o2);
6099 if (o2->op_type == OP_RV2AV ||
6100 o2->op_type == OP_PADAV)
6103 bad_type(arg, "array", gv_ename(namegv), o2);
6106 if (o2->op_type == OP_RV2HV ||
6107 o2->op_type == OP_PADHV)
6110 bad_type(arg, "hash", gv_ename(namegv), o2);
6115 OP* sib = kid->op_sibling;
6116 kid->op_sibling = 0;
6117 o2 = newUNOP(OP_REFGEN, 0, kid);
6118 o2->op_sibling = sib;
6119 prev->op_sibling = o2;
6121 if (contextclass && e) {
6136 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6137 gv_ename(namegv), SvPV((SV*)cv, n_a));
6142 mod(o2, OP_ENTERSUB);
6144 o2 = o2->op_sibling;
6146 if (proto && !optional &&
6147 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6148 return too_few_arguments(o, gv_ename(namegv));
6153 Perl_ck_svconst(pTHX_ OP *o)
6155 SvREADONLY_on(cSVOPo->op_sv);
6160 Perl_ck_trunc(pTHX_ OP *o)
6162 if (o->op_flags & OPf_KIDS) {
6163 SVOP *kid = (SVOP*)cUNOPo->op_first;
6165 if (kid->op_type == OP_NULL)
6166 kid = (SVOP*)kid->op_sibling;
6167 if (kid && kid->op_type == OP_CONST &&
6168 (kid->op_private & OPpCONST_BARE))
6170 o->op_flags |= OPf_SPECIAL;
6171 kid->op_private &= ~OPpCONST_STRICT;
6178 Perl_ck_substr(pTHX_ OP *o)
6181 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6182 OP *kid = cLISTOPo->op_first;
6184 if (kid->op_type == OP_NULL)
6185 kid = kid->op_sibling;
6187 kid->op_flags |= OPf_MOD;
6193 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6196 Perl_peep(pTHX_ register OP *o)
6198 register OP* oldop = 0;
6200 if (!o || o->op_seq)
6204 SAVEVPTR(PL_curcop);
6205 for (; o; o = o->op_next) {
6211 switch (o->op_type) {
6215 PL_curcop = ((COP*)o); /* for warnings */
6216 o->op_seq = PL_op_seqmax++;
6220 if (cSVOPo->op_private & OPpCONST_STRICT)
6221 no_bareword_allowed(o);
6223 /* Relocate sv to the pad for thread safety.
6224 * Despite being a "constant", the SV is written to,
6225 * for reference counts, sv_upgrade() etc. */
6227 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6228 if (SvPADTMP(cSVOPo->op_sv)) {
6229 /* If op_sv is already a PADTMP then it is being used by
6230 * some pad, so make a copy. */
6231 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6232 SvREADONLY_on(PAD_SVl(ix));
6233 SvREFCNT_dec(cSVOPo->op_sv);
6236 SvREFCNT_dec(PAD_SVl(ix));
6237 SvPADTMP_on(cSVOPo->op_sv);
6238 PAD_SETSV(ix, cSVOPo->op_sv);
6239 /* XXX I don't know how this isn't readonly already. */
6240 SvREADONLY_on(PAD_SVl(ix));
6242 cSVOPo->op_sv = Nullsv;
6246 o->op_seq = PL_op_seqmax++;
6250 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6251 if (o->op_next->op_private & OPpTARGET_MY) {
6252 if (o->op_flags & OPf_STACKED) /* chained concats */
6253 goto ignore_optimization;
6255 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6256 o->op_targ = o->op_next->op_targ;
6257 o->op_next->op_targ = 0;
6258 o->op_private |= OPpTARGET_MY;
6261 op_null(o->op_next);
6263 ignore_optimization:
6264 o->op_seq = PL_op_seqmax++;
6267 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6268 o->op_seq = PL_op_seqmax++;
6269 break; /* Scalar stub must produce undef. List stub is noop */
6273 if (o->op_targ == OP_NEXTSTATE
6274 || o->op_targ == OP_DBSTATE
6275 || o->op_targ == OP_SETSTATE)
6277 PL_curcop = ((COP*)o);
6279 /* XXX: We avoid setting op_seq here to prevent later calls
6280 to peep() from mistakenly concluding that optimisation
6281 has already occurred. This doesn't fix the real problem,
6282 though (See 20010220.007). AMS 20010719 */
6283 if (oldop && o->op_next) {
6284 oldop->op_next = o->op_next;
6292 if (oldop && o->op_next) {
6293 oldop->op_next = o->op_next;
6296 o->op_seq = PL_op_seqmax++;
6300 if (o->op_next->op_type == OP_RV2SV) {
6301 if (!(o->op_next->op_private & OPpDEREF)) {
6302 op_null(o->op_next);
6303 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6305 o->op_next = o->op_next->op_next;
6306 o->op_type = OP_GVSV;
6307 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6310 else if (o->op_next->op_type == OP_RV2AV) {
6311 OP* pop = o->op_next->op_next;
6313 if (pop && pop->op_type == OP_CONST &&
6314 (PL_op = pop->op_next) &&
6315 pop->op_next->op_type == OP_AELEM &&
6316 !(pop->op_next->op_private &
6317 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6318 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6323 op_null(o->op_next);
6324 op_null(pop->op_next);
6326 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6327 o->op_next = pop->op_next->op_next;
6328 o->op_type = OP_AELEMFAST;
6329 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6330 o->op_private = (U8)i;
6335 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6337 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6338 /* XXX could check prototype here instead of just carping */
6339 SV *sv = sv_newmortal();
6340 gv_efullname3(sv, gv, Nullch);
6341 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6342 "%s() called too early to check prototype",
6346 else if (o->op_next->op_type == OP_READLINE
6347 && o->op_next->op_next->op_type == OP_CONCAT
6348 && (o->op_next->op_next->op_flags & OPf_STACKED))
6350 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6351 o->op_type = OP_RCATLINE;
6352 o->op_flags |= OPf_STACKED;
6353 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6354 op_null(o->op_next->op_next);
6355 op_null(o->op_next);
6358 o->op_seq = PL_op_seqmax++;
6371 o->op_seq = PL_op_seqmax++;
6372 while (cLOGOP->op_other->op_type == OP_NULL)
6373 cLOGOP->op_other = cLOGOP->op_other->op_next;
6374 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6379 o->op_seq = PL_op_seqmax++;
6380 while (cLOOP->op_redoop->op_type == OP_NULL)
6381 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6382 peep(cLOOP->op_redoop);
6383 while (cLOOP->op_nextop->op_type == OP_NULL)
6384 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6385 peep(cLOOP->op_nextop);
6386 while (cLOOP->op_lastop->op_type == OP_NULL)
6387 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6388 peep(cLOOP->op_lastop);
6394 o->op_seq = PL_op_seqmax++;
6395 while (cPMOP->op_pmreplstart &&
6396 cPMOP->op_pmreplstart->op_type == OP_NULL)
6397 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6398 peep(cPMOP->op_pmreplstart);
6402 o->op_seq = PL_op_seqmax++;
6403 if (ckWARN(WARN_SYNTAX) && o->op_next
6404 && o->op_next->op_type == OP_NEXTSTATE) {
6405 if (o->op_next->op_sibling &&
6406 o->op_next->op_sibling->op_type != OP_EXIT &&
6407 o->op_next->op_sibling->op_type != OP_WARN &&
6408 o->op_next->op_sibling->op_type != OP_DIE) {
6409 line_t oldline = CopLINE(PL_curcop);
6411 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6412 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6413 "Statement unlikely to be reached");
6414 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6415 "\t(Maybe you meant system() when you said exec()?)\n");
6416 CopLINE_set(PL_curcop, oldline);
6427 o->op_seq = PL_op_seqmax++;
6429 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6432 /* Make the CONST have a shared SV */
6433 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6434 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6435 key = SvPV(sv, keylen);
6436 lexname = newSVpvn_share(key,
6437 SvUTF8(sv) ? -(I32)keylen : keylen,
6446 o->op_seq = PL_op_seqmax++;
6456 char* Perl_custom_op_name(pTHX_ OP* o)
6458 IV index = PTR2IV(o->op_ppaddr);
6462 if (!PL_custom_op_names) /* This probably shouldn't happen */
6463 return PL_op_name[OP_CUSTOM];
6465 keysv = sv_2mortal(newSViv(index));
6467 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
6469 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
6471 return SvPV_nolen(HeVAL(he));
6474 char* Perl_custom_op_desc(pTHX_ OP* o)
6476 IV index = PTR2IV(o->op_ppaddr);
6480 if (!PL_custom_op_descs)
6481 return PL_op_desc[OP_CUSTOM];
6483 keysv = sv_2mortal(newSViv(index));
6485 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
6487 return PL_op_desc[OP_CUSTOM];
6489 return SvPV_nolen(HeVAL(he));
6495 /* Efficient sub that returns a constant scalar value. */
6497 const_sv_xsub(pTHX_ CV* cv)
6502 Perl_croak(aTHX_ "usage: %s::%s()",
6503 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
6507 ST(0) = (SV*)XSANY.any_ptr;