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)
729 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
730 useless = OP_DESC(o);
737 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
738 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
739 useless = "a variable";
744 if (cSVOPo->op_private & OPpCONST_STRICT)
745 no_bareword_allowed(o);
747 if (ckWARN(WARN_VOID)) {
748 useless = "a constant";
749 /* the constants 0 and 1 are permitted as they are
750 conventionally used as dummies in constructs like
751 1 while some_condition_with_side_effects; */
752 if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
754 else if (SvPOK(sv)) {
755 /* perl4's way of mixing documentation and code
756 (before the invention of POD) was based on a
757 trick to mix nroff and perl code. The trick was
758 built upon these three nroff macros being used in
759 void context. The pink camel has the details in
760 the script wrapman near page 319. */
761 if (strnEQ(SvPVX(sv), "di", 2) ||
762 strnEQ(SvPVX(sv), "ds", 2) ||
763 strnEQ(SvPVX(sv), "ig", 2))
768 op_null(o); /* don't execute or even remember it */
772 o->op_type = OP_PREINC; /* pre-increment is faster */
773 o->op_ppaddr = PL_ppaddr[OP_PREINC];
777 o->op_type = OP_PREDEC; /* pre-decrement is faster */
778 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
785 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
790 if (o->op_flags & OPf_STACKED)
797 if (!(o->op_flags & OPf_KIDS))
806 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
813 /* all requires must return a boolean value */
814 o->op_flags &= ~OPf_WANT;
819 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
820 if (!kPMOP->op_pmreplroot)
821 deprecate_old("implicit split to @_");
825 if (useless && ckWARN(WARN_VOID))
826 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
831 Perl_listkids(pTHX_ OP *o)
834 if (o && o->op_flags & OPf_KIDS) {
835 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
842 Perl_list(pTHX_ OP *o)
846 /* assumes no premature commitment */
847 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
848 || o->op_type == OP_RETURN)
853 if ((o->op_private & OPpTARGET_MY)
854 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
856 return o; /* As if inside SASSIGN */
859 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
861 switch (o->op_type) {
864 list(cBINOPo->op_first);
869 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
877 if (!(o->op_flags & OPf_KIDS))
879 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
880 list(cBINOPo->op_first);
881 return gen_constant_list(o);
888 kid = cLISTOPo->op_first;
890 while ((kid = kid->op_sibling)) {
896 WITH_THR(PL_curcop = &PL_compiling);
900 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
906 WITH_THR(PL_curcop = &PL_compiling);
909 /* all requires must return a boolean value */
910 o->op_flags &= ~OPf_WANT;
917 Perl_scalarseq(pTHX_ OP *o)
922 if (o->op_type == OP_LINESEQ ||
923 o->op_type == OP_SCOPE ||
924 o->op_type == OP_LEAVE ||
925 o->op_type == OP_LEAVETRY)
927 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
928 if (kid->op_sibling) {
932 PL_curcop = &PL_compiling;
934 o->op_flags &= ~OPf_PARENS;
935 if (PL_hints & HINT_BLOCK_SCOPE)
936 o->op_flags |= OPf_PARENS;
939 o = newOP(OP_STUB, 0);
944 S_modkids(pTHX_ OP *o, I32 type)
947 if (o && o->op_flags & OPf_KIDS) {
948 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
955 Perl_mod(pTHX_ OP *o, I32 type)
959 if (!o || PL_error_count)
962 if ((o->op_private & OPpTARGET_MY)
963 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
968 switch (o->op_type) {
973 if (!(o->op_private & (OPpCONST_ARYBASE)))
975 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
976 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
980 SAVEI32(PL_compiling.cop_arybase);
981 PL_compiling.cop_arybase = 0;
983 else if (type == OP_REFGEN)
986 Perl_croak(aTHX_ "That use of $[ is unsupported");
989 if (o->op_flags & OPf_PARENS)
993 if ((type == OP_UNDEF || type == OP_REFGEN) &&
994 !(o->op_flags & OPf_STACKED)) {
995 o->op_type = OP_RV2CV; /* entersub => rv2cv */
996 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
997 assert(cUNOPo->op_first->op_type == OP_NULL);
998 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1001 else if (o->op_private & OPpENTERSUB_NOMOD)
1003 else { /* lvalue subroutine call */
1004 o->op_private |= OPpLVAL_INTRO;
1005 PL_modcount = RETURN_UNLIMITED_NUMBER;
1006 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1007 /* Backward compatibility mode: */
1008 o->op_private |= OPpENTERSUB_INARGS;
1011 else { /* Compile-time error message: */
1012 OP *kid = cUNOPo->op_first;
1016 if (kid->op_type == OP_PUSHMARK)
1018 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1020 "panic: unexpected lvalue entersub "
1021 "args: type/targ %ld:%"UVuf,
1022 (long)kid->op_type, (UV)kid->op_targ);
1023 kid = kLISTOP->op_first;
1025 while (kid->op_sibling)
1026 kid = kid->op_sibling;
1027 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1029 if (kid->op_type == OP_METHOD_NAMED
1030 || kid->op_type == OP_METHOD)
1034 NewOp(1101, newop, 1, UNOP);
1035 newop->op_type = OP_RV2CV;
1036 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1037 newop->op_first = Nullop;
1038 newop->op_next = (OP*)newop;
1039 kid->op_sibling = (OP*)newop;
1040 newop->op_private |= OPpLVAL_INTRO;
1044 if (kid->op_type != OP_RV2CV)
1046 "panic: unexpected lvalue entersub "
1047 "entry via type/targ %ld:%"UVuf,
1048 (long)kid->op_type, (UV)kid->op_targ);
1049 kid->op_private |= OPpLVAL_INTRO;
1050 break; /* Postpone until runtime */
1054 kid = kUNOP->op_first;
1055 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1056 kid = kUNOP->op_first;
1057 if (kid->op_type == OP_NULL)
1059 "Unexpected constant lvalue entersub "
1060 "entry via type/targ %ld:%"UVuf,
1061 (long)kid->op_type, (UV)kid->op_targ);
1062 if (kid->op_type != OP_GV) {
1063 /* Restore RV2CV to check lvalueness */
1065 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1066 okid->op_next = kid->op_next;
1067 kid->op_next = okid;
1070 okid->op_next = Nullop;
1071 okid->op_type = OP_RV2CV;
1073 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1074 okid->op_private |= OPpLVAL_INTRO;
1078 cv = GvCV(kGVOP_gv);
1088 /* grep, foreach, subcalls, refgen */
1089 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1091 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1092 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1094 : (o->op_type == OP_ENTERSUB
1095 ? "non-lvalue subroutine call"
1097 type ? PL_op_desc[type] : "local"));
1111 case OP_RIGHT_SHIFT:
1120 if (!(o->op_flags & OPf_STACKED))
1126 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1132 if (!type && cUNOPo->op_first->op_type != OP_GV)
1133 Perl_croak(aTHX_ "Can't localize through a reference");
1134 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1135 PL_modcount = RETURN_UNLIMITED_NUMBER;
1136 return o; /* Treat \(@foo) like ordinary list. */
1140 if (scalar_mod_type(o, type))
1142 ref(cUNOPo->op_first, o->op_type);
1146 if (type == OP_LEAVESUBLV)
1147 o->op_private |= OPpMAYBE_LVSUB;
1152 PL_modcount = RETURN_UNLIMITED_NUMBER;
1155 if (!type && cUNOPo->op_first->op_type != OP_GV)
1156 Perl_croak(aTHX_ "Can't localize through a reference");
1157 ref(cUNOPo->op_first, o->op_type);
1161 PL_hints |= HINT_BLOCK_SCOPE;
1172 PL_modcount = RETURN_UNLIMITED_NUMBER;
1173 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1174 return o; /* Treat \(@foo) like ordinary list. */
1175 if (scalar_mod_type(o, type))
1177 if (type == OP_LEAVESUBLV)
1178 o->op_private |= OPpMAYBE_LVSUB;
1183 { /* XXX DAPM 2002.08.25 tmp assert test */
1184 /* XXX */ assert(av_fetch(PL_comppad_name, (o->op_targ), FALSE));
1185 /* XXX */ assert(*av_fetch(PL_comppad_name, (o->op_targ), FALSE));
1187 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1188 PAD_COMPNAME_PV(o->op_targ));
1192 #ifdef USE_5005THREADS
1194 PL_modcount++; /* XXX ??? */
1196 #endif /* USE_5005THREADS */
1202 if (type != OP_SASSIGN)
1206 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1211 if (type == OP_LEAVESUBLV)
1212 o->op_private |= OPpMAYBE_LVSUB;
1214 pad_free(o->op_targ);
1215 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1216 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1217 if (o->op_flags & OPf_KIDS)
1218 mod(cBINOPo->op_first->op_sibling, type);
1223 ref(cBINOPo->op_first, o->op_type);
1224 if (type == OP_ENTERSUB &&
1225 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1226 o->op_private |= OPpLVAL_DEFER;
1227 if (type == OP_LEAVESUBLV)
1228 o->op_private |= OPpMAYBE_LVSUB;
1236 if (o->op_flags & OPf_KIDS)
1237 mod(cLISTOPo->op_last, type);
1241 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1243 else if (!(o->op_flags & OPf_KIDS))
1245 if (o->op_targ != OP_LIST) {
1246 mod(cBINOPo->op_first, type);
1251 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1256 if (type != OP_LEAVESUBLV)
1258 break; /* mod()ing was handled by ck_return() */
1261 /* [20011101.069] File test operators interpret OPf_REF to mean that
1262 their argument is a filehandle; thus \stat(".") should not set
1264 if (type == OP_REFGEN &&
1265 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1268 if (type != OP_LEAVESUBLV)
1269 o->op_flags |= OPf_MOD;
1271 if (type == OP_AASSIGN || type == OP_SASSIGN)
1272 o->op_flags |= OPf_SPECIAL|OPf_REF;
1274 o->op_private |= OPpLVAL_INTRO;
1275 o->op_flags &= ~OPf_SPECIAL;
1276 PL_hints |= HINT_BLOCK_SCOPE;
1278 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1279 && type != OP_LEAVESUBLV)
1280 o->op_flags |= OPf_REF;
1285 S_scalar_mod_type(pTHX_ OP *o, I32 type)
1289 if (o->op_type == OP_RV2GV)
1313 case OP_RIGHT_SHIFT:
1332 S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
1334 switch (o->op_type) {
1342 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1355 Perl_refkids(pTHX_ OP *o, I32 type)
1358 if (o && o->op_flags & OPf_KIDS) {
1359 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1366 Perl_ref(pTHX_ OP *o, I32 type)
1370 if (!o || PL_error_count)
1373 switch (o->op_type) {
1375 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1376 !(o->op_flags & OPf_STACKED)) {
1377 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1378 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1379 assert(cUNOPo->op_first->op_type == OP_NULL);
1380 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1381 o->op_flags |= OPf_SPECIAL;
1386 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1390 if (type == OP_DEFINED)
1391 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1392 ref(cUNOPo->op_first, o->op_type);
1395 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1396 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1397 : type == OP_RV2HV ? OPpDEREF_HV
1399 o->op_flags |= OPf_MOD;
1404 o->op_flags |= OPf_MOD; /* XXX ??? */
1409 o->op_flags |= OPf_REF;
1412 if (type == OP_DEFINED)
1413 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1414 ref(cUNOPo->op_first, o->op_type);
1419 o->op_flags |= OPf_REF;
1424 if (!(o->op_flags & OPf_KIDS))
1426 ref(cBINOPo->op_first, type);
1430 ref(cBINOPo->op_first, o->op_type);
1431 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1432 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1433 : type == OP_RV2HV ? OPpDEREF_HV
1435 o->op_flags |= OPf_MOD;
1443 if (!(o->op_flags & OPf_KIDS))
1445 ref(cLISTOPo->op_last, type);
1455 S_dup_attrlist(pTHX_ OP *o)
1459 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1460 * where the first kid is OP_PUSHMARK and the remaining ones
1461 * are OP_CONST. We need to push the OP_CONST values.
1463 if (o->op_type == OP_CONST)
1464 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1466 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1467 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1468 if (o->op_type == OP_CONST)
1469 rop = append_elem(OP_LIST, rop,
1470 newSVOP(OP_CONST, o->op_flags,
1471 SvREFCNT_inc(cSVOPo->op_sv)));
1478 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1482 /* fake up C<use attributes $pkg,$rv,@attrs> */
1483 ENTER; /* need to protect against side-effects of 'use' */
1486 stashsv = newSVpv(HvNAME(stash), 0);
1488 stashsv = &PL_sv_no;
1490 #define ATTRSMODULE "attributes"
1491 #define ATTRSMODULE_PM "attributes.pm"
1495 /* Don't force the C<use> if we don't need it. */
1496 svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
1497 sizeof(ATTRSMODULE_PM)-1, 0);
1498 if (svp && *svp != &PL_sv_undef)
1499 ; /* already in %INC */
1501 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1502 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1506 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1507 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1509 prepend_elem(OP_LIST,
1510 newSVOP(OP_CONST, 0, stashsv),
1511 prepend_elem(OP_LIST,
1512 newSVOP(OP_CONST, 0,
1514 dup_attrlist(attrs))));
1520 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1522 OP *pack, *imop, *arg;
1528 assert(target->op_type == OP_PADSV ||
1529 target->op_type == OP_PADHV ||
1530 target->op_type == OP_PADAV);
1532 /* Ensure that attributes.pm is loaded. */
1533 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1535 /* Need package name for method call. */
1536 pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
1538 /* Build up the real arg-list. */
1540 stashsv = newSVpv(HvNAME(stash), 0);
1542 stashsv = &PL_sv_no;
1543 arg = newOP(OP_PADSV, 0);
1544 arg->op_targ = target->op_targ;
1545 arg = prepend_elem(OP_LIST,
1546 newSVOP(OP_CONST, 0, stashsv),
1547 prepend_elem(OP_LIST,
1548 newUNOP(OP_REFGEN, 0,
1549 mod(arg, OP_REFGEN)),
1550 dup_attrlist(attrs)));
1552 /* Fake up a method call to import */
1553 meth = newSVpvn("import", 6);
1554 (void)SvUPGRADE(meth, SVt_PVIV);
1555 (void)SvIOK_on(meth);
1556 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
1557 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1558 append_elem(OP_LIST,
1559 prepend_elem(OP_LIST, pack, list(arg)),
1560 newSVOP(OP_METHOD_NAMED, 0, meth)));
1561 imop->op_private |= OPpENTERSUB_NOMOD;
1563 /* Combine the ops. */
1564 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1568 =notfor apidoc apply_attrs_string
1570 Attempts to apply a list of attributes specified by the C<attrstr> and
1571 C<len> arguments to the subroutine identified by the C<cv> argument which
1572 is expected to be associated with the package identified by the C<stashpv>
1573 argument (see L<attributes>). It gets this wrong, though, in that it
1574 does not correctly identify the boundaries of the individual attribute
1575 specifications within C<attrstr>. This is not really intended for the
1576 public API, but has to be listed here for systems such as AIX which
1577 need an explicit export list for symbols. (It's called from XS code
1578 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1579 to respect attribute syntax properly would be welcome.
1585 Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
1586 char *attrstr, STRLEN len)
1591 len = strlen(attrstr);
1595 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1597 char *sstr = attrstr;
1598 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1599 attrs = append_elem(OP_LIST, attrs,
1600 newSVOP(OP_CONST, 0,
1601 newSVpvn(sstr, attrstr-sstr)));
1605 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1606 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1607 Nullsv, prepend_elem(OP_LIST,
1608 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1609 prepend_elem(OP_LIST,
1610 newSVOP(OP_CONST, 0,
1616 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1621 if (!o || PL_error_count)
1625 if (type == OP_LIST) {
1626 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1627 my_kid(kid, attrs, imopsp);
1628 } else if (type == OP_UNDEF) {
1630 } else if (type == OP_RV2SV || /* "our" declaration */
1632 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1633 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1634 yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
1635 OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
1637 GV *gv = cGVOPx_gv(cUNOPo->op_first);
1639 PL_in_my_stash = Nullhv;
1640 apply_attrs(GvSTASH(gv),
1641 (type == OP_RV2SV ? GvSV(gv) :
1642 type == OP_RV2AV ? (SV*)GvAV(gv) :
1643 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1646 o->op_private |= OPpOUR_INTRO;
1649 else if (type != OP_PADSV &&
1652 type != OP_PUSHMARK)
1654 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1656 PL_in_my == KEY_our ? "our" : "my"));
1659 else if (attrs && type != OP_PUSHMARK) {
1663 PL_in_my_stash = Nullhv;
1665 /* check for C<my Dog $spot> when deciding package */
1666 stash = PAD_COMPNAME_TYPE(o->op_targ);
1668 stash = PL_curstash;
1669 apply_attrs_my(stash, o, attrs, imopsp);
1671 o->op_flags |= OPf_MOD;
1672 o->op_private |= OPpLVAL_INTRO;
1677 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1680 int maybe_scalar = 0;
1682 /* [perl #17376]: this appears to be premature, and results in code such as
1683 C< our(%x); > executing in list mode rather than void mode */
1685 if (o->op_flags & OPf_PARENS)
1694 o = my_kid(o, attrs, &rops);
1696 if (maybe_scalar && o->op_type == OP_PADSV) {
1697 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1698 o->op_private |= OPpLVAL_INTRO;
1701 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1704 PL_in_my_stash = Nullhv;
1709 Perl_my(pTHX_ OP *o)
1711 return my_attrs(o, Nullop);
1715 Perl_sawparens(pTHX_ OP *o)
1718 o->op_flags |= OPf_PARENS;
1723 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1727 if (ckWARN(WARN_MISC) &&
1728 (left->op_type == OP_RV2AV ||
1729 left->op_type == OP_RV2HV ||
1730 left->op_type == OP_PADAV ||
1731 left->op_type == OP_PADHV)) {
1732 char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
1733 right->op_type == OP_TRANS)
1734 ? right->op_type : OP_MATCH];
1735 const char *sample = ((left->op_type == OP_RV2AV ||
1736 left->op_type == OP_PADAV)
1737 ? "@array" : "%hash");
1738 Perl_warner(aTHX_ packWARN(WARN_MISC),
1739 "Applying %s to %s will act on scalar(%s)",
1740 desc, sample, sample);
1743 if (right->op_type == OP_CONST &&
1744 cSVOPx(right)->op_private & OPpCONST_BARE &&
1745 cSVOPx(right)->op_private & OPpCONST_STRICT)
1747 no_bareword_allowed(right);
1750 if (!(right->op_flags & OPf_STACKED) &&
1751 (right->op_type == OP_MATCH ||
1752 right->op_type == OP_SUBST ||
1753 right->op_type == OP_TRANS)) {
1754 right->op_flags |= OPf_STACKED;
1755 if (right->op_type != OP_MATCH &&
1756 ! (right->op_type == OP_TRANS &&
1757 right->op_private & OPpTRANS_IDENTICAL))
1758 left = mod(left, right->op_type);
1759 if (right->op_type == OP_TRANS)
1760 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
1762 o = prepend_elem(right->op_type, scalar(left), right);
1764 return newUNOP(OP_NOT, 0, scalar(o));
1768 return bind_match(type, left,
1769 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
1773 Perl_invert(pTHX_ OP *o)
1777 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
1778 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1782 Perl_scope(pTHX_ OP *o)
1785 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1786 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1787 o->op_type = OP_LEAVE;
1788 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1791 if (o->op_type == OP_LINESEQ) {
1793 o->op_type = OP_SCOPE;
1794 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1795 kid = ((LISTOP*)o)->op_first;
1796 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
1800 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
1807 Perl_save_hints(pTHX)
1810 SAVESPTR(GvHV(PL_hintgv));
1811 GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
1812 SAVEFREESV(GvHV(PL_hintgv));
1816 Perl_block_start(pTHX_ int full)
1818 int retval = PL_savestack_ix;
1820 pad_block_start(full);
1822 PL_hints &= ~HINT_BLOCK_SCOPE;
1823 SAVESPTR(PL_compiling.cop_warnings);
1824 if (! specialWARN(PL_compiling.cop_warnings)) {
1825 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1826 SAVEFREESV(PL_compiling.cop_warnings) ;
1828 SAVESPTR(PL_compiling.cop_io);
1829 if (! specialCopIO(PL_compiling.cop_io)) {
1830 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1831 SAVEFREESV(PL_compiling.cop_io) ;
1837 Perl_block_end(pTHX_ I32 floor, OP *seq)
1839 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1840 line_t copline = PL_copline;
1841 /* there should be a nextstate in every block */
1842 OP* retval = seq ? scalarseq(seq) : newSTATEOP(0, Nullch, seq);
1843 PL_copline = copline; /* XXX newSTATEOP may reset PL_copline */
1845 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
1847 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
1855 #ifdef USE_5005THREADS
1856 OP *o = newOP(OP_THREADSV, 0);
1857 o->op_targ = find_threadsv("_");
1860 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1861 #endif /* USE_5005THREADS */
1865 Perl_newPROG(pTHX_ OP *o)
1870 PL_eval_root = newUNOP(OP_LEAVEEVAL,
1871 ((PL_in_eval & EVAL_KEEPERR)
1872 ? OPf_SPECIAL : 0), o);
1873 PL_eval_start = linklist(PL_eval_root);
1874 PL_eval_root->op_private |= OPpREFCOUNTED;
1875 OpREFCNT_set(PL_eval_root, 1);
1876 PL_eval_root->op_next = 0;
1877 CALL_PEEP(PL_eval_start);
1882 PL_main_root = scope(sawparens(scalarvoid(o)));
1883 PL_curcop = &PL_compiling;
1884 PL_main_start = LINKLIST(PL_main_root);
1885 PL_main_root->op_private |= OPpREFCOUNTED;
1886 OpREFCNT_set(PL_main_root, 1);
1887 PL_main_root->op_next = 0;
1888 CALL_PEEP(PL_main_start);
1891 /* Register with debugger */
1893 CV *cv = get_cv("DB::postponed", FALSE);
1897 XPUSHs((SV*)CopFILEGV(&PL_compiling));
1899 call_sv((SV*)cv, G_DISCARD);
1906 Perl_localize(pTHX_ OP *o, I32 lex)
1908 if (o->op_flags & OPf_PARENS)
1909 /* [perl #17376]: this appears to be premature, and results in code such as
1910 C< our(%x); > executing in list mode rather than void mode */
1917 if (ckWARN(WARN_PARENTHESIS)
1918 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
1920 char *s = PL_bufptr;
1922 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ", *s)))
1925 if (*s == ';' || *s == '=')
1926 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
1927 "Parentheses missing around \"%s\" list",
1928 lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
1934 o = mod(o, OP_NULL); /* a bit kludgey */
1936 PL_in_my_stash = Nullhv;
1941 Perl_jmaybe(pTHX_ OP *o)
1943 if (o->op_type == OP_LIST) {
1945 #ifdef USE_5005THREADS
1946 o2 = newOP(OP_THREADSV, 0);
1947 o2->op_targ = find_threadsv(";");
1949 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
1950 #endif /* USE_5005THREADS */
1951 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
1957 Perl_fold_constants(pTHX_ register OP *o)
1960 I32 type = o->op_type;
1963 if (PL_opargs[type] & OA_RETSCALAR)
1965 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
1966 o->op_targ = pad_alloc(type, SVs_PADTMP);
1968 /* integerize op, unless it happens to be C<-foo>.
1969 * XXX should pp_i_negate() do magic string negation instead? */
1970 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
1971 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
1972 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
1974 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
1977 if (!(PL_opargs[type] & OA_FOLDCONST))
1982 /* XXX might want a ck_negate() for this */
1983 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
1995 /* XXX what about the numeric ops? */
1996 if (PL_hints & HINT_LOCALE)
2001 goto nope; /* Don't try to run w/ errors */
2003 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2004 if ((curop->op_type != OP_CONST ||
2005 (curop->op_private & OPpCONST_BARE)) &&
2006 curop->op_type != OP_LIST &&
2007 curop->op_type != OP_SCALAR &&
2008 curop->op_type != OP_NULL &&
2009 curop->op_type != OP_PUSHMARK)
2015 curop = LINKLIST(o);
2019 sv = *(PL_stack_sp--);
2020 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2021 pad_swipe(o->op_targ, FALSE);
2022 else if (SvTEMP(sv)) { /* grab mortal temp? */
2023 (void)SvREFCNT_inc(sv);
2027 if (type == OP_RV2GV)
2028 return newGVOP(OP_GV, 0, (GV*)sv);
2030 /* try to smush double to int, but don't smush -2.0 to -2 */
2031 if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
2034 #ifdef PERL_PRESERVE_IVUV
2035 /* Only bother to attempt to fold to IV if
2036 most operators will benefit */
2040 return newSVOP(OP_CONST, 0, sv);
2048 Perl_gen_constant_list(pTHX_ register OP *o)
2051 I32 oldtmps_floor = PL_tmps_floor;
2055 return o; /* Don't attempt to run with errors */
2057 PL_op = curop = LINKLIST(o);
2064 PL_tmps_floor = oldtmps_floor;
2066 o->op_type = OP_RV2AV;
2067 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2068 o->op_seq = 0; /* needs to be revisited in peep() */
2069 curop = ((UNOP*)o)->op_first;
2070 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2077 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2079 if (!o || o->op_type != OP_LIST)
2080 o = newLISTOP(OP_LIST, 0, o, Nullop);
2082 o->op_flags &= ~OPf_WANT;
2084 if (!(PL_opargs[type] & OA_MARK))
2085 op_null(cLISTOPo->op_first);
2087 o->op_type = (OPCODE)type;
2088 o->op_ppaddr = PL_ppaddr[type];
2089 o->op_flags |= flags;
2091 o = CHECKOP(type, o);
2092 if (o->op_type != type)
2095 return fold_constants(o);
2098 /* List constructors */
2101 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2109 if (first->op_type != type
2110 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2112 return newLISTOP(type, 0, first, last);
2115 if (first->op_flags & OPf_KIDS)
2116 ((LISTOP*)first)->op_last->op_sibling = last;
2118 first->op_flags |= OPf_KIDS;
2119 ((LISTOP*)first)->op_first = last;
2121 ((LISTOP*)first)->op_last = last;
2126 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2134 if (first->op_type != type)
2135 return prepend_elem(type, (OP*)first, (OP*)last);
2137 if (last->op_type != type)
2138 return append_elem(type, (OP*)first, (OP*)last);
2140 first->op_last->op_sibling = last->op_first;
2141 first->op_last = last->op_last;
2142 first->op_flags |= (last->op_flags & OPf_KIDS);
2150 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2158 if (last->op_type == type) {
2159 if (type == OP_LIST) { /* already a PUSHMARK there */
2160 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2161 ((LISTOP*)last)->op_first->op_sibling = first;
2162 if (!(first->op_flags & OPf_PARENS))
2163 last->op_flags &= ~OPf_PARENS;
2166 if (!(last->op_flags & OPf_KIDS)) {
2167 ((LISTOP*)last)->op_last = first;
2168 last->op_flags |= OPf_KIDS;
2170 first->op_sibling = ((LISTOP*)last)->op_first;
2171 ((LISTOP*)last)->op_first = first;
2173 last->op_flags |= OPf_KIDS;
2177 return newLISTOP(type, 0, first, last);
2183 Perl_newNULLLIST(pTHX)
2185 return newOP(OP_STUB, 0);
2189 Perl_force_list(pTHX_ OP *o)
2191 if (!o || o->op_type != OP_LIST)
2192 o = newLISTOP(OP_LIST, 0, o, Nullop);
2198 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2202 NewOp(1101, listop, 1, LISTOP);
2204 listop->op_type = (OPCODE)type;
2205 listop->op_ppaddr = PL_ppaddr[type];
2208 listop->op_flags = (U8)flags;
2212 else if (!first && last)
2215 first->op_sibling = last;
2216 listop->op_first = first;
2217 listop->op_last = last;
2218 if (type == OP_LIST) {
2220 pushop = newOP(OP_PUSHMARK, 0);
2221 pushop->op_sibling = first;
2222 listop->op_first = pushop;
2223 listop->op_flags |= OPf_KIDS;
2225 listop->op_last = pushop;
2232 Perl_newOP(pTHX_ I32 type, I32 flags)
2235 NewOp(1101, o, 1, OP);
2236 o->op_type = (OPCODE)type;
2237 o->op_ppaddr = PL_ppaddr[type];
2238 o->op_flags = (U8)flags;
2241 o->op_private = (U8)(0 | (flags >> 8));
2242 if (PL_opargs[type] & OA_RETSCALAR)
2244 if (PL_opargs[type] & OA_TARGET)
2245 o->op_targ = pad_alloc(type, SVs_PADTMP);
2246 return CHECKOP(type, o);
2250 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2255 first = newOP(OP_STUB, 0);
2256 if (PL_opargs[type] & OA_MARK)
2257 first = force_list(first);
2259 NewOp(1101, unop, 1, UNOP);
2260 unop->op_type = (OPCODE)type;
2261 unop->op_ppaddr = PL_ppaddr[type];
2262 unop->op_first = first;
2263 unop->op_flags = flags | OPf_KIDS;
2264 unop->op_private = (U8)(1 | (flags >> 8));
2265 unop = (UNOP*) CHECKOP(type, unop);
2269 return fold_constants((OP *) unop);
2273 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2276 NewOp(1101, binop, 1, BINOP);
2279 first = newOP(OP_NULL, 0);
2281 binop->op_type = (OPCODE)type;
2282 binop->op_ppaddr = PL_ppaddr[type];
2283 binop->op_first = first;
2284 binop->op_flags = flags | OPf_KIDS;
2287 binop->op_private = (U8)(1 | (flags >> 8));
2290 binop->op_private = (U8)(2 | (flags >> 8));
2291 first->op_sibling = last;
2294 binop = (BINOP*)CHECKOP(type, binop);
2295 if (binop->op_next || binop->op_type != (OPCODE)type)
2298 binop->op_last = binop->op_first->op_sibling;
2300 return fold_constants((OP *)binop);
2304 uvcompare(const void *a, const void *b)
2306 if (*((UV *)a) < (*(UV *)b))
2308 if (*((UV *)a) > (*(UV *)b))
2310 if (*((UV *)a+1) < (*(UV *)b+1))
2312 if (*((UV *)a+1) > (*(UV *)b+1))
2318 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2320 SV *tstr = ((SVOP*)expr)->op_sv;
2321 SV *rstr = ((SVOP*)repl)->op_sv;
2324 U8 *t = (U8*)SvPV(tstr, tlen);
2325 U8 *r = (U8*)SvPV(rstr, rlen);
2332 register short *tbl;
2334 PL_hints |= HINT_BLOCK_SCOPE;
2335 complement = o->op_private & OPpTRANS_COMPLEMENT;
2336 del = o->op_private & OPpTRANS_DELETE;
2337 squash = o->op_private & OPpTRANS_SQUASH;
2340 o->op_private |= OPpTRANS_FROM_UTF;
2343 o->op_private |= OPpTRANS_TO_UTF;
2345 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2346 SV* listsv = newSVpvn("# comment\n",10);
2348 U8* tend = t + tlen;
2349 U8* rend = r + rlen;
2363 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2364 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2370 tsave = t = bytes_to_utf8(t, &len);
2373 if (!to_utf && rlen) {
2375 rsave = r = bytes_to_utf8(r, &len);
2379 /* There are several snags with this code on EBCDIC:
2380 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2381 2. scan_const() in toke.c has encoded chars in native encoding which makes
2382 ranges at least in EBCDIC 0..255 range the bottom odd.
2386 U8 tmpbuf[UTF8_MAXLEN+1];
2389 New(1109, cp, 2*tlen, UV);
2391 transv = newSVpvn("",0);
2393 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2395 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2397 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2401 cp[2*i+1] = cp[2*i];
2405 qsort(cp, i, 2*sizeof(UV), uvcompare);
2406 for (j = 0; j < i; j++) {
2408 diff = val - nextmin;
2410 t = uvuni_to_utf8(tmpbuf,nextmin);
2411 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2413 U8 range_mark = UTF_TO_NATIVE(0xff);
2414 t = uvuni_to_utf8(tmpbuf, val - 1);
2415 sv_catpvn(transv, (char *)&range_mark, 1);
2416 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2423 t = uvuni_to_utf8(tmpbuf,nextmin);
2424 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2426 U8 range_mark = UTF_TO_NATIVE(0xff);
2427 sv_catpvn(transv, (char *)&range_mark, 1);
2429 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2430 UNICODE_ALLOW_SUPER);
2431 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2432 t = (U8*)SvPVX(transv);
2433 tlen = SvCUR(transv);
2437 else if (!rlen && !del) {
2438 r = t; rlen = tlen; rend = tend;
2441 if ((!rlen && !del) || t == r ||
2442 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2444 o->op_private |= OPpTRANS_IDENTICAL;
2448 while (t < tend || tfirst <= tlast) {
2449 /* see if we need more "t" chars */
2450 if (tfirst > tlast) {
2451 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2453 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2455 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2462 /* now see if we need more "r" chars */
2463 if (rfirst > rlast) {
2465 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2467 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2469 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2478 rfirst = rlast = 0xffffffff;
2482 /* now see which range will peter our first, if either. */
2483 tdiff = tlast - tfirst;
2484 rdiff = rlast - rfirst;
2491 if (rfirst == 0xffffffff) {
2492 diff = tdiff; /* oops, pretend rdiff is infinite */
2494 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2495 (long)tfirst, (long)tlast);
2497 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2501 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2502 (long)tfirst, (long)(tfirst + diff),
2505 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2506 (long)tfirst, (long)rfirst);
2508 if (rfirst + diff > max)
2509 max = rfirst + diff;
2511 grows = (tfirst < rfirst &&
2512 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2524 else if (max > 0xff)
2529 Safefree(cPVOPo->op_pv);
2530 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2531 SvREFCNT_dec(listsv);
2533 SvREFCNT_dec(transv);
2535 if (!del && havefinal && rlen)
2536 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2537 newSVuv((UV)final), 0);
2540 o->op_private |= OPpTRANS_GROWS;
2552 tbl = (short*)cPVOPo->op_pv;
2554 Zero(tbl, 256, short);
2555 for (i = 0; i < (I32)tlen; i++)
2557 for (i = 0, j = 0; i < 256; i++) {
2559 if (j >= (I32)rlen) {
2568 if (i < 128 && r[j] >= 128)
2578 o->op_private |= OPpTRANS_IDENTICAL;
2580 else if (j >= (I32)rlen)
2583 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2584 tbl[0x100] = rlen - j;
2585 for (i=0; i < (I32)rlen - j; i++)
2586 tbl[0x101+i] = r[j+i];
2590 if (!rlen && !del) {
2593 o->op_private |= OPpTRANS_IDENTICAL;
2595 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2596 o->op_private |= OPpTRANS_IDENTICAL;
2598 for (i = 0; i < 256; i++)
2600 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
2601 if (j >= (I32)rlen) {
2603 if (tbl[t[i]] == -1)
2609 if (tbl[t[i]] == -1) {
2610 if (t[i] < 128 && r[j] >= 128)
2617 o->op_private |= OPpTRANS_GROWS;
2625 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2629 NewOp(1101, pmop, 1, PMOP);
2630 pmop->op_type = (OPCODE)type;
2631 pmop->op_ppaddr = PL_ppaddr[type];
2632 pmop->op_flags = (U8)flags;
2633 pmop->op_private = (U8)(0 | (flags >> 8));
2635 if (PL_hints & HINT_RE_TAINT)
2636 pmop->op_pmpermflags |= PMf_RETAINT;
2637 if (PL_hints & HINT_LOCALE)
2638 pmop->op_pmpermflags |= PMf_LOCALE;
2639 pmop->op_pmflags = pmop->op_pmpermflags;
2644 if(av_len((AV*) PL_regex_pad[0]) > -1) {
2645 repointer = av_pop((AV*)PL_regex_pad[0]);
2646 pmop->op_pmoffset = SvIV(repointer);
2647 SvREPADTMP_off(repointer);
2648 sv_setiv(repointer,0);
2650 repointer = newSViv(0);
2651 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2652 pmop->op_pmoffset = av_len(PL_regex_padav);
2653 PL_regex_pad = AvARRAY(PL_regex_padav);
2658 /* link into pm list */
2659 if (type != OP_TRANS && PL_curstash) {
2660 pmop->op_pmnext = HvPMROOT(PL_curstash);
2661 HvPMROOT(PL_curstash) = pmop;
2662 PmopSTASH_set(pmop,PL_curstash);
2669 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
2673 I32 repl_has_vars = 0;
2675 if (o->op_type == OP_TRANS)
2676 return pmtrans(o, expr, repl);
2678 PL_hints |= HINT_BLOCK_SCOPE;
2681 if (expr->op_type == OP_CONST) {
2683 SV *pat = ((SVOP*)expr)->op_sv;
2684 char *p = SvPV(pat, plen);
2685 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
2686 sv_setpvn(pat, "\\s+", 3);
2687 p = SvPV(pat, plen);
2688 pm->op_pmflags |= PMf_SKIPWHITE;
2691 pm->op_pmdynflags |= PMdf_UTF8;
2692 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
2693 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
2694 pm->op_pmflags |= PMf_WHITE;
2698 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2699 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2701 : OP_REGCMAYBE),0,expr);
2703 NewOp(1101, rcop, 1, LOGOP);
2704 rcop->op_type = OP_REGCOMP;
2705 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2706 rcop->op_first = scalar(expr);
2707 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
2708 ? (OPf_SPECIAL | OPf_KIDS)
2710 rcop->op_private = 1;
2713 /* establish postfix order */
2714 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2716 rcop->op_next = expr;
2717 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2720 rcop->op_next = LINKLIST(expr);
2721 expr->op_next = (OP*)rcop;
2724 prepend_elem(o->op_type, scalar((OP*)rcop), o);
2729 if (pm->op_pmflags & PMf_EVAL) {
2731 if (CopLINE(PL_curcop) < PL_multi_end)
2732 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
2734 #ifdef USE_5005THREADS
2735 else if (repl->op_type == OP_THREADSV
2736 && strchr("&`'123456789+",
2737 PL_threadsv_names[repl->op_targ]))
2741 #endif /* USE_5005THREADS */
2742 else if (repl->op_type == OP_CONST)
2746 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
2747 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
2748 #ifdef USE_5005THREADS
2749 if (curop->op_type == OP_THREADSV) {
2751 if (strchr("&`'123456789+", curop->op_private))
2755 if (curop->op_type == OP_GV) {
2756 GV *gv = cGVOPx_gv(curop);
2758 if (strchr("&`'123456789+", *GvENAME(gv)))
2761 #endif /* USE_5005THREADS */
2762 else if (curop->op_type == OP_RV2CV)
2764 else if (curop->op_type == OP_RV2SV ||
2765 curop->op_type == OP_RV2AV ||
2766 curop->op_type == OP_RV2HV ||
2767 curop->op_type == OP_RV2GV) {
2768 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2771 else if (curop->op_type == OP_PADSV ||
2772 curop->op_type == OP_PADAV ||
2773 curop->op_type == OP_PADHV ||
2774 curop->op_type == OP_PADANY) {
2777 else if (curop->op_type == OP_PUSHRE)
2778 ; /* Okay here, dangerous in newASSIGNOP */
2788 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
2789 pm->op_pmflags |= PMf_CONST; /* const for long enough */
2790 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
2791 prepend_elem(o->op_type, scalar(repl), o);
2794 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
2795 pm->op_pmflags |= PMf_MAYBE_CONST;
2796 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2798 NewOp(1101, rcop, 1, LOGOP);
2799 rcop->op_type = OP_SUBSTCONT;
2800 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
2801 rcop->op_first = scalar(repl);
2802 rcop->op_flags |= OPf_KIDS;
2803 rcop->op_private = 1;
2806 /* establish postfix order */
2807 rcop->op_next = LINKLIST(repl);
2808 repl->op_next = (OP*)rcop;
2810 pm->op_pmreplroot = scalar((OP*)rcop);
2811 pm->op_pmreplstart = LINKLIST(rcop);
2820 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
2823 NewOp(1101, svop, 1, SVOP);
2824 svop->op_type = (OPCODE)type;
2825 svop->op_ppaddr = PL_ppaddr[type];
2827 svop->op_next = (OP*)svop;
2828 svop->op_flags = (U8)flags;
2829 if (PL_opargs[type] & OA_RETSCALAR)
2831 if (PL_opargs[type] & OA_TARGET)
2832 svop->op_targ = pad_alloc(type, SVs_PADTMP);
2833 return CHECKOP(type, svop);
2837 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2840 NewOp(1101, padop, 1, PADOP);
2841 padop->op_type = (OPCODE)type;
2842 padop->op_ppaddr = PL_ppaddr[type];
2843 padop->op_padix = pad_alloc(type, SVs_PADTMP);
2844 SvREFCNT_dec(PAD_SVl(padop->op_padix));
2845 PAD_SETSV(padop->op_padix, sv);
2848 padop->op_next = (OP*)padop;
2849 padop->op_flags = (U8)flags;
2850 if (PL_opargs[type] & OA_RETSCALAR)
2852 if (PL_opargs[type] & OA_TARGET)
2853 padop->op_targ = pad_alloc(type, SVs_PADTMP);
2854 return CHECKOP(type, padop);
2858 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
2863 return newPADOP(type, flags, SvREFCNT_inc(gv));
2865 return newSVOP(type, flags, SvREFCNT_inc(gv));
2870 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
2873 NewOp(1101, pvop, 1, PVOP);
2874 pvop->op_type = (OPCODE)type;
2875 pvop->op_ppaddr = PL_ppaddr[type];
2877 pvop->op_next = (OP*)pvop;
2878 pvop->op_flags = (U8)flags;
2879 if (PL_opargs[type] & OA_RETSCALAR)
2881 if (PL_opargs[type] & OA_TARGET)
2882 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
2883 return CHECKOP(type, pvop);
2887 Perl_package(pTHX_ OP *o)
2892 save_hptr(&PL_curstash);
2893 save_item(PL_curstname);
2895 name = SvPV(cSVOPo->op_sv, len);
2896 PL_curstash = gv_stashpvn(name, len, TRUE);
2897 sv_setpvn(PL_curstname, name, len);
2900 PL_hints |= HINT_BLOCK_SCOPE;
2901 PL_copline = NOLINE;
2906 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
2912 if (id->op_type != OP_CONST)
2913 Perl_croak(aTHX_ "Module name must be constant");
2917 if (version != Nullop) {
2918 SV *vesv = ((SVOP*)version)->op_sv;
2920 if (arg == Nullop && !SvNIOKp(vesv)) {
2927 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
2928 Perl_croak(aTHX_ "Version number must be constant number");
2930 /* Make copy of id so we don't free it twice */
2931 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
2933 /* Fake up a method call to VERSION */
2934 meth = newSVpvn("VERSION",7);
2935 sv_upgrade(meth, SVt_PVIV);
2936 (void)SvIOK_on(meth);
2937 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
2938 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2939 append_elem(OP_LIST,
2940 prepend_elem(OP_LIST, pack, list(version)),
2941 newSVOP(OP_METHOD_NAMED, 0, meth)));
2945 /* Fake up an import/unimport */
2946 if (arg && arg->op_type == OP_STUB)
2947 imop = arg; /* no import on explicit () */
2948 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
2949 imop = Nullop; /* use 5.0; */
2954 /* Make copy of id so we don't free it twice */
2955 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
2957 /* Fake up a method call to import/unimport */
2958 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);
2959 (void)SvUPGRADE(meth, SVt_PVIV);
2960 (void)SvIOK_on(meth);
2961 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
2962 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2963 append_elem(OP_LIST,
2964 prepend_elem(OP_LIST, pack, list(arg)),
2965 newSVOP(OP_METHOD_NAMED, 0, meth)));
2968 /* Fake up the BEGIN {}, which does its thing immediately. */
2970 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
2973 append_elem(OP_LINESEQ,
2974 append_elem(OP_LINESEQ,
2975 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, id)),
2976 newSTATEOP(0, Nullch, veop)),
2977 newSTATEOP(0, Nullch, imop) ));
2979 /* The "did you use incorrect case?" warning used to be here.
2980 * The problem is that on case-insensitive filesystems one
2981 * might get false positives for "use" (and "require"):
2982 * "use Strict" or "require CARP" will work. This causes
2983 * portability problems for the script: in case-strict
2984 * filesystems the script will stop working.
2986 * The "incorrect case" warning checked whether "use Foo"
2987 * imported "Foo" to your namespace, but that is wrong, too:
2988 * there is no requirement nor promise in the language that
2989 * a Foo.pm should or would contain anything in package "Foo".
2991 * There is very little Configure-wise that can be done, either:
2992 * the case-sensitivity of the build filesystem of Perl does not
2993 * help in guessing the case-sensitivity of the runtime environment.
2996 PL_hints |= HINT_BLOCK_SCOPE;
2997 PL_copline = NOLINE;
3002 =head1 Embedding Functions
3004 =for apidoc load_module
3006 Loads the module whose name is pointed to by the string part of name.
3007 Note that the actual module name, not its filename, should be given.
3008 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3009 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3010 (or 0 for no flags). ver, if specified, provides version semantics
3011 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3012 arguments can be used to specify arguments to the module's import()
3013 method, similar to C<use Foo::Bar VERSION LIST>.
3018 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3021 va_start(args, ver);
3022 vload_module(flags, name, ver, &args);
3026 #ifdef PERL_IMPLICIT_CONTEXT
3028 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3032 va_start(args, ver);
3033 vload_module(flags, name, ver, &args);
3039 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3041 OP *modname, *veop, *imop;
3043 modname = newSVOP(OP_CONST, 0, name);
3044 modname->op_private |= OPpCONST_BARE;
3046 veop = newSVOP(OP_CONST, 0, ver);
3050 if (flags & PERL_LOADMOD_NOIMPORT) {
3051 imop = sawparens(newNULLLIST());
3053 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3054 imop = va_arg(*args, OP*);
3059 sv = va_arg(*args, SV*);
3061 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3062 sv = va_arg(*args, SV*);
3066 line_t ocopline = PL_copline;
3067 int oexpect = PL_expect;
3069 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3070 veop, modname, imop);
3071 PL_expect = oexpect;
3072 PL_copline = ocopline;
3077 Perl_dofile(pTHX_ OP *term)
3082 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3083 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
3084 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3086 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3087 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3088 append_elem(OP_LIST, term,
3089 scalar(newUNOP(OP_RV2CV, 0,
3094 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3100 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3102 return newBINOP(OP_LSLICE, flags,
3103 list(force_list(subscript)),
3104 list(force_list(listval)) );
3108 S_list_assignment(pTHX_ register OP *o)
3113 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3114 o = cUNOPo->op_first;
3116 if (o->op_type == OP_COND_EXPR) {
3117 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3118 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3123 yyerror("Assignment to both a list and a scalar");
3127 if (o->op_type == OP_LIST &&
3128 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3129 o->op_private & OPpLVAL_INTRO)
3132 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3133 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3134 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3137 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3140 if (o->op_type == OP_RV2SV)
3147 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3152 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3153 return newLOGOP(optype, 0,
3154 mod(scalar(left), optype),
3155 newUNOP(OP_SASSIGN, 0, scalar(right)));
3158 return newBINOP(optype, OPf_STACKED,
3159 mod(scalar(left), optype), scalar(right));
3163 if (list_assignment(left)) {
3167 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3168 left = mod(left, OP_AASSIGN);
3176 curop = list(force_list(left));
3177 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3178 o->op_private = (U8)(0 | (flags >> 8));
3180 /* PL_generation sorcery:
3181 * an assignment like ($a,$b) = ($c,$d) is easier than
3182 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3183 * To detect whether there are common vars, the global var
3184 * PL_generation is incremented for each assign op we compile.
3185 * Then, while compiling the assign op, we run through all the
3186 * variables on both sides of the assignment, setting a spare slot
3187 * in each of them to PL_generation. If any of them already have
3188 * that value, we know we've got commonality. We could use a
3189 * single bit marker, but then we'd have to make 2 passes, first
3190 * to clear the flag, then to test and set it. To find somewhere
3191 * to store these values, evil chicanery is done with SvCUR().
3194 if (!(left->op_private & OPpLVAL_INTRO)) {
3197 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3198 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3199 if (curop->op_type == OP_GV) {
3200 GV *gv = cGVOPx_gv(curop);
3201 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3203 SvCUR(gv) = PL_generation;
3205 else if (curop->op_type == OP_PADSV ||
3206 curop->op_type == OP_PADAV ||
3207 curop->op_type == OP_PADHV ||
3208 curop->op_type == OP_PADANY)
3210 if (PAD_COMPNAME_GEN(curop->op_targ)
3213 PAD_COMPNAME_GEN(curop->op_targ)
3217 else if (curop->op_type == OP_RV2CV)
3219 else if (curop->op_type == OP_RV2SV ||
3220 curop->op_type == OP_RV2AV ||
3221 curop->op_type == OP_RV2HV ||
3222 curop->op_type == OP_RV2GV) {
3223 if (lastop->op_type != OP_GV) /* funny deref? */
3226 else if (curop->op_type == OP_PUSHRE) {
3227 if (((PMOP*)curop)->op_pmreplroot) {
3229 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3230 ((PMOP*)curop)->op_pmreplroot));
3232 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3234 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3236 SvCUR(gv) = PL_generation;
3245 o->op_private |= OPpASSIGN_COMMON;
3247 if (right && right->op_type == OP_SPLIT) {
3249 if ((tmpop = ((LISTOP*)right)->op_first) &&
3250 tmpop->op_type == OP_PUSHRE)
3252 PMOP *pm = (PMOP*)tmpop;
3253 if (left->op_type == OP_RV2AV &&
3254 !(left->op_private & OPpLVAL_INTRO) &&
3255 !(o->op_private & OPpASSIGN_COMMON) )
3257 tmpop = ((UNOP*)left)->op_first;
3258 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3260 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3261 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3263 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3264 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3266 pm->op_pmflags |= PMf_ONCE;
3267 tmpop = cUNOPo->op_first; /* to list (nulled) */
3268 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3269 tmpop->op_sibling = Nullop; /* don't free split */
3270 right->op_next = tmpop->op_next; /* fix starting loc */
3271 op_free(o); /* blow off assign */
3272 right->op_flags &= ~OPf_WANT;
3273 /* "I don't know and I don't care." */
3278 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3279 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3281 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3283 sv_setiv(sv, PL_modcount+1);
3291 right = newOP(OP_UNDEF, 0);
3292 if (right->op_type == OP_READLINE) {
3293 right->op_flags |= OPf_STACKED;
3294 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3297 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3298 o = newBINOP(OP_SASSIGN, flags,
3299 scalar(right), mod(scalar(left), OP_SASSIGN) );
3311 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3313 U32 seq = intro_my();
3316 NewOp(1101, cop, 1, COP);
3317 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3318 cop->op_type = OP_DBSTATE;
3319 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3322 cop->op_type = OP_NEXTSTATE;
3323 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3325 cop->op_flags = (U8)flags;
3326 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3328 cop->op_private |= NATIVE_HINTS;
3330 PL_compiling.op_private = cop->op_private;
3331 cop->op_next = (OP*)cop;
3334 cop->cop_label = label;
3335 PL_hints |= HINT_BLOCK_SCOPE;
3338 cop->cop_arybase = PL_curcop->cop_arybase;
3339 if (specialWARN(PL_curcop->cop_warnings))
3340 cop->cop_warnings = PL_curcop->cop_warnings ;
3342 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3343 if (specialCopIO(PL_curcop->cop_io))
3344 cop->cop_io = PL_curcop->cop_io;
3346 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3349 if (PL_copline == NOLINE)
3350 CopLINE_set(cop, CopLINE(PL_curcop));
3352 CopLINE_set(cop, PL_copline);
3353 PL_copline = NOLINE;
3356 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3358 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3360 CopSTASH_set(cop, PL_curstash);
3362 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3363 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3364 if (svp && *svp != &PL_sv_undef ) {
3365 (void)SvIOK_on(*svp);
3366 SvIVX(*svp) = PTR2IV(cop);
3370 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3375 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3377 return new_logop(type, flags, &first, &other);
3381 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3385 OP *first = *firstp;
3386 OP *other = *otherp;
3388 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3389 return newBINOP(type, flags, scalar(first), scalar(other));
3391 scalarboolean(first);
3392 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3393 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3394 if (type == OP_AND || type == OP_OR) {
3400 first = *firstp = cUNOPo->op_first;
3402 first->op_next = o->op_next;
3403 cUNOPo->op_first = Nullop;
3407 if (first->op_type == OP_CONST) {
3408 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE)) {
3409 if (first->op_private & OPpCONST_STRICT)
3410 no_bareword_allowed(first);
3412 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3414 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3425 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3426 OP *k1 = ((UNOP*)first)->op_first;
3427 OP *k2 = k1->op_sibling;
3429 switch (first->op_type)
3432 if (k2 && k2->op_type == OP_READLINE
3433 && (k2->op_flags & OPf_STACKED)
3434 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3436 warnop = k2->op_type;
3441 if (k1->op_type == OP_READDIR
3442 || k1->op_type == OP_GLOB
3443 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3444 || k1->op_type == OP_EACH)
3446 warnop = ((k1->op_type == OP_NULL)
3447 ? (OPCODE)k1->op_targ : k1->op_type);
3452 line_t oldline = CopLINE(PL_curcop);
3453 CopLINE_set(PL_curcop, PL_copline);
3454 Perl_warner(aTHX_ packWARN(WARN_MISC),
3455 "Value of %s%s can be \"0\"; test with defined()",
3457 ((warnop == OP_READLINE || warnop == OP_GLOB)
3458 ? " construct" : "() operator"));
3459 CopLINE_set(PL_curcop, oldline);
3466 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3467 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3469 NewOp(1101, logop, 1, LOGOP);
3471 logop->op_type = (OPCODE)type;
3472 logop->op_ppaddr = PL_ppaddr[type];
3473 logop->op_first = first;
3474 logop->op_flags = flags | OPf_KIDS;
3475 logop->op_other = LINKLIST(other);
3476 logop->op_private = (U8)(1 | (flags >> 8));
3478 /* establish postfix order */
3479 logop->op_next = LINKLIST(first);
3480 first->op_next = (OP*)logop;
3481 first->op_sibling = other;
3483 o = newUNOP(OP_NULL, 0, (OP*)logop);
3490 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3497 return newLOGOP(OP_AND, 0, first, trueop);
3499 return newLOGOP(OP_OR, 0, first, falseop);
3501 scalarboolean(first);
3502 if (first->op_type == OP_CONST) {
3503 if (first->op_private & OPpCONST_BARE &&
3504 first->op_private & OPpCONST_STRICT) {
3505 no_bareword_allowed(first);
3507 if (SvTRUE(((SVOP*)first)->op_sv)) {
3518 NewOp(1101, logop, 1, LOGOP);
3519 logop->op_type = OP_COND_EXPR;
3520 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3521 logop->op_first = first;
3522 logop->op_flags = flags | OPf_KIDS;
3523 logop->op_private = (U8)(1 | (flags >> 8));
3524 logop->op_other = LINKLIST(trueop);
3525 logop->op_next = LINKLIST(falseop);
3528 /* establish postfix order */
3529 start = LINKLIST(first);
3530 first->op_next = (OP*)logop;
3532 first->op_sibling = trueop;
3533 trueop->op_sibling = falseop;
3534 o = newUNOP(OP_NULL, 0, (OP*)logop);
3536 trueop->op_next = falseop->op_next = o;
3543 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3551 NewOp(1101, range, 1, LOGOP);
3553 range->op_type = OP_RANGE;
3554 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3555 range->op_first = left;
3556 range->op_flags = OPf_KIDS;
3557 leftstart = LINKLIST(left);
3558 range->op_other = LINKLIST(right);
3559 range->op_private = (U8)(1 | (flags >> 8));
3561 left->op_sibling = right;
3563 range->op_next = (OP*)range;
3564 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3565 flop = newUNOP(OP_FLOP, 0, flip);
3566 o = newUNOP(OP_NULL, 0, flop);
3568 range->op_next = leftstart;
3570 left->op_next = flip;
3571 right->op_next = flop;
3573 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3574 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3575 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3576 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3578 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3579 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3582 if (!flip->op_private || !flop->op_private)
3583 linklist(o); /* blow off optimizer unless constant */
3589 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3593 int once = block && block->op_flags & OPf_SPECIAL &&
3594 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3597 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3598 return block; /* do {} while 0 does once */
3599 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3600 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3601 expr = newUNOP(OP_DEFINED, 0,
3602 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3603 } else if (expr->op_flags & OPf_KIDS) {
3604 OP *k1 = ((UNOP*)expr)->op_first;
3605 OP *k2 = (k1) ? k1->op_sibling : NULL;
3606 switch (expr->op_type) {
3608 if (k2 && k2->op_type == OP_READLINE
3609 && (k2->op_flags & OPf_STACKED)
3610 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3611 expr = newUNOP(OP_DEFINED, 0, expr);
3615 if (k1->op_type == OP_READDIR
3616 || k1->op_type == OP_GLOB
3617 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3618 || k1->op_type == OP_EACH)
3619 expr = newUNOP(OP_DEFINED, 0, expr);
3625 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3626 o = new_logop(OP_AND, 0, &expr, &listop);
3629 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3631 if (once && o != listop)
3632 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3635 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3637 o->op_flags |= flags;
3639 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3644 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3652 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3653 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3654 expr = newUNOP(OP_DEFINED, 0,
3655 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3656 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3657 OP *k1 = ((UNOP*)expr)->op_first;
3658 OP *k2 = (k1) ? k1->op_sibling : NULL;
3659 switch (expr->op_type) {
3661 if (k2 && k2->op_type == OP_READLINE
3662 && (k2->op_flags & OPf_STACKED)
3663 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3664 expr = newUNOP(OP_DEFINED, 0, expr);
3668 if (k1->op_type == OP_READDIR
3669 || k1->op_type == OP_GLOB
3670 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3671 || k1->op_type == OP_EACH)
3672 expr = newUNOP(OP_DEFINED, 0, expr);
3678 block = newOP(OP_NULL, 0);
3680 block = scope(block);
3684 next = LINKLIST(cont);
3687 OP *unstack = newOP(OP_UNSTACK, 0);
3690 cont = append_elem(OP_LINESEQ, cont, unstack);
3691 if ((line_t)whileline != NOLINE) {
3692 PL_copline = (line_t)whileline;
3693 cont = append_elem(OP_LINESEQ, cont,
3694 newSTATEOP(0, Nullch, Nullop));
3698 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3699 redo = LINKLIST(listop);
3702 PL_copline = (line_t)whileline;
3704 o = new_logop(OP_AND, 0, &expr, &listop);
3705 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3706 op_free(expr); /* oops, it's a while (0) */
3708 return Nullop; /* listop already freed by new_logop */
3711 ((LISTOP*)listop)->op_last->op_next =
3712 (o == listop ? redo : LINKLIST(o));
3718 NewOp(1101,loop,1,LOOP);
3719 loop->op_type = OP_ENTERLOOP;
3720 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3721 loop->op_private = 0;
3722 loop->op_next = (OP*)loop;
3725 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3727 loop->op_redoop = redo;
3728 loop->op_lastop = o;
3729 o->op_private |= loopflags;
3732 loop->op_nextop = next;
3734 loop->op_nextop = o;
3736 o->op_flags |= flags;
3737 o->op_private |= (flags >> 8);
3742 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
3746 PADOFFSET padoff = 0;
3750 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
3751 sv->op_type = OP_RV2GV;
3752 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3754 else if (sv->op_type == OP_PADSV) { /* private variable */
3755 padoff = sv->op_targ;
3760 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3761 padoff = sv->op_targ;
3763 iterflags |= OPf_SPECIAL;
3768 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3771 #ifdef USE_5005THREADS
3772 padoff = find_threadsv("_");
3773 iterflags |= OPf_SPECIAL;
3775 sv = newGVOP(OP_GV, 0, PL_defgv);
3778 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3779 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3780 iterflags |= OPf_STACKED;
3782 else if (expr->op_type == OP_NULL &&
3783 (expr->op_flags & OPf_KIDS) &&
3784 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3786 /* Basically turn for($x..$y) into the same as for($x,$y), but we
3787 * set the STACKED flag to indicate that these values are to be
3788 * treated as min/max values by 'pp_iterinit'.
3790 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
3791 LOGOP* range = (LOGOP*) flip->op_first;
3792 OP* left = range->op_first;
3793 OP* right = left->op_sibling;
3796 range->op_flags &= ~OPf_KIDS;
3797 range->op_first = Nullop;
3799 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
3800 listop->op_first->op_next = range->op_next;
3801 left->op_next = range->op_other;
3802 right->op_next = (OP*)listop;
3803 listop->op_next = listop->op_first;
3806 expr = (OP*)(listop);
3808 iterflags |= OPf_STACKED;
3811 expr = mod(force_list(expr), OP_GREPSTART);
3815 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
3816 append_elem(OP_LIST, expr, scalar(sv))));
3817 assert(!loop->op_next);
3818 #ifdef PL_OP_SLAB_ALLOC
3821 NewOp(1234,tmp,1,LOOP);
3822 Copy(loop,tmp,1,LOOP);
3827 Renew(loop, 1, LOOP);
3829 loop->op_targ = padoff;
3830 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
3831 PL_copline = forline;
3832 return newSTATEOP(0, label, wop);
3836 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
3841 if (type != OP_GOTO || label->op_type == OP_CONST) {
3842 /* "last()" means "last" */
3843 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
3844 o = newOP(type, OPf_SPECIAL);
3846 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
3847 ? SvPVx(((SVOP*)label)->op_sv, n_a)
3853 if (label->op_type == OP_ENTERSUB)
3854 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
3855 o = newUNOP(type, OPf_STACKED, label);
3857 PL_hints |= HINT_BLOCK_SCOPE;
3862 Perl_cv_undef(pTHX_ CV *cv)
3865 CV *freecv = Nullcv;
3867 #ifdef USE_5005THREADS
3869 MUTEX_DESTROY(CvMUTEXP(cv));
3870 Safefree(CvMUTEXP(cv));
3873 #endif /* USE_5005THREADS */
3876 if (CvFILE(cv) && !CvXSUB(cv)) {
3877 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
3878 Safefree(CvFILE(cv));
3883 if (!CvXSUB(cv) && CvROOT(cv)) {
3884 #ifdef USE_5005THREADS
3885 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
3886 Perl_croak(aTHX_ "Can't undef active subroutine");
3889 Perl_croak(aTHX_ "Can't undef active subroutine");
3890 #endif /* USE_5005THREADS */
3893 PAD_SAVE_SETNULLPAD;
3895 op_free(CvROOT(cv));
3896 CvROOT(cv) = Nullop;
3899 SvPOK_off((SV*)cv); /* forget prototype */
3901 outsidecv = CvOUTSIDE(cv);
3902 /* Since closure prototypes have the same lifetime as the containing
3903 * CV, they don't hold a refcount on the outside CV. This avoids
3904 * the refcount loop between the outer CV (which keeps a refcount to
3905 * the closure prototype in the pad entry for pp_anoncode()) and the
3906 * closure prototype, and the ensuing memory leak. --GSAR */
3907 if (!CvANON(cv) || CvCLONED(cv))
3909 CvOUTSIDE(cv) = Nullcv;
3911 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
3914 pad_undef(cv, outsidecv);
3916 SvREFCNT_dec(freecv);
3924 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
3926 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
3927 SV* msg = sv_newmortal();
3931 gv_efullname3(name = sv_newmortal(), gv, Nullch);
3932 sv_setpv(msg, "Prototype mismatch:");
3934 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
3936 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
3937 sv_catpv(msg, " vs ");
3939 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
3941 sv_catpv(msg, "none");
3942 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
3946 static void const_sv_xsub(pTHX_ CV* cv);
3950 =head1 Optree Manipulation Functions
3952 =for apidoc cv_const_sv
3954 If C<cv> is a constant sub eligible for inlining. returns the constant
3955 value returned by the sub. Otherwise, returns NULL.
3957 Constant subs can be created with C<newCONSTSUB> or as described in
3958 L<perlsub/"Constant Functions">.
3963 Perl_cv_const_sv(pTHX_ CV *cv)
3965 if (!cv || !CvCONST(cv))
3967 return (SV*)CvXSUBANY(cv).any_ptr;
3971 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
3978 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
3979 o = cLISTOPo->op_first->op_sibling;
3981 for (; o; o = o->op_next) {
3982 OPCODE type = o->op_type;
3984 if (sv && o->op_next == o)
3986 if (o->op_next != o) {
3987 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
3989 if (type == OP_DBSTATE)
3992 if (type == OP_LEAVESUB || type == OP_RETURN)
3996 if (type == OP_CONST && cSVOPo->op_sv)
3998 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
3999 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4003 /* We get here only from cv_clone2() while creating a closure.
4004 Copy the const value here instead of in cv_clone2 so that
4005 SvREADONLY_on doesn't lead to problems when leaving
4010 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4022 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4032 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4036 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4038 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4042 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4048 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4052 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4053 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4054 SV *sv = sv_newmortal();
4055 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4056 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4057 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4062 gv = gv_fetchpv(name ? name : (aname ? aname :
4063 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__")),
4064 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4074 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4075 maximum a prototype before. */
4076 if (SvTYPE(gv) > SVt_NULL) {
4077 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4078 && ckWARN_d(WARN_PROTOTYPE))
4080 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4082 cv_ckproto((CV*)gv, NULL, ps);
4085 sv_setpv((SV*)gv, ps);
4087 sv_setiv((SV*)gv, -1);
4088 SvREFCNT_dec(PL_compcv);
4089 cv = PL_compcv = NULL;
4090 PL_sub_generation++;
4094 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4096 #ifdef GV_UNIQUE_CHECK
4097 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4098 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4102 if (!block || !ps || *ps || attrs)
4105 const_sv = op_const_sv(block, Nullcv);
4108 bool exists = CvROOT(cv) || CvXSUB(cv);
4110 #ifdef GV_UNIQUE_CHECK
4111 if (exists && GvUNIQUE(gv)) {
4112 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4116 /* if the subroutine doesn't exist and wasn't pre-declared
4117 * with a prototype, assume it will be AUTOLOADed,
4118 * skipping the prototype check
4120 if (exists || SvPOK(cv))
4121 cv_ckproto(cv, gv, ps);
4122 /* already defined (or promised)? */
4123 if (exists || GvASSUMECV(gv)) {
4124 if (!block && !attrs) {
4125 if (CvFLAGS(PL_compcv)) {
4126 /* might have had built-in attrs applied */
4127 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4129 /* just a "sub foo;" when &foo is already defined */
4130 SAVEFREESV(PL_compcv);
4133 /* ahem, death to those who redefine active sort subs */
4134 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4135 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4137 if (ckWARN(WARN_REDEFINE)
4139 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4141 line_t oldline = CopLINE(PL_curcop);
4142 if (PL_copline != NOLINE)
4143 CopLINE_set(PL_curcop, PL_copline);
4144 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4145 CvCONST(cv) ? "Constant subroutine %s redefined"
4146 : "Subroutine %s redefined", name);
4147 CopLINE_set(PL_curcop, oldline);
4155 SvREFCNT_inc(const_sv);
4157 assert(!CvROOT(cv) && !CvCONST(cv));
4158 sv_setpv((SV*)cv, ""); /* prototype is "" */
4159 CvXSUBANY(cv).any_ptr = const_sv;
4160 CvXSUB(cv) = const_sv_xsub;
4165 cv = newCONSTSUB(NULL, name, const_sv);
4168 SvREFCNT_dec(PL_compcv);
4170 PL_sub_generation++;
4177 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4178 * before we clobber PL_compcv.
4182 /* Might have had built-in attributes applied -- propagate them. */
4183 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4184 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4185 stash = GvSTASH(CvGV(cv));
4186 else if (CvSTASH(cv))
4187 stash = CvSTASH(cv);
4189 stash = PL_curstash;
4192 /* possibly about to re-define existing subr -- ignore old cv */
4193 rcv = (SV*)PL_compcv;
4194 if (name && GvSTASH(gv))
4195 stash = GvSTASH(gv);
4197 stash = PL_curstash;
4199 apply_attrs(stash, rcv, attrs, FALSE);
4201 if (cv) { /* must reuse cv if autoloaded */
4203 /* got here with just attrs -- work done, so bug out */
4204 SAVEFREESV(PL_compcv);
4208 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4209 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4210 CvOUTSIDE(PL_compcv) = 0;
4211 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4212 CvPADLIST(PL_compcv) = 0;
4213 /* inner references to PL_compcv must be fixed up ... */
4214 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4215 /* ... before we throw it away */
4216 SvREFCNT_dec(PL_compcv);
4217 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4218 ++PL_sub_generation;
4225 PL_sub_generation++;
4229 CvFILE_set_from_cop(cv, PL_curcop);
4230 CvSTASH(cv) = PL_curstash;
4231 #ifdef USE_5005THREADS
4233 if (!CvMUTEXP(cv)) {
4234 New(666, CvMUTEXP(cv), 1, perl_mutex);
4235 MUTEX_INIT(CvMUTEXP(cv));
4237 #endif /* USE_5005THREADS */
4240 sv_setpv((SV*)cv, ps);
4242 if (PL_error_count) {
4246 char *s = strrchr(name, ':');
4248 if (strEQ(s, "BEGIN")) {
4250 "BEGIN not safe after errors--compilation aborted";
4251 if (PL_in_eval & EVAL_KEEPERR)
4252 Perl_croak(aTHX_ not_safe);
4254 /* force display of errors found but not reported */
4255 sv_catpv(ERRSV, not_safe);
4256 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4265 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4266 mod(scalarseq(block), OP_LEAVESUBLV));
4269 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4271 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4272 OpREFCNT_set(CvROOT(cv), 1);
4273 CvSTART(cv) = LINKLIST(CvROOT(cv));
4274 CvROOT(cv)->op_next = 0;
4275 CALL_PEEP(CvSTART(cv));
4277 /* now that optimizer has done its work, adjust pad values */
4279 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4282 assert(!CvCONST(cv));
4283 if (ps && !*ps && op_const_sv(block, cv))
4287 /* If a potential closure prototype, don't keep a refcount on outer CV.
4288 * This is okay as the lifetime of the prototype is tied to the
4289 * lifetime of the outer CV. Avoids memory leak due to reference
4292 SvREFCNT_dec(CvOUTSIDE(cv));
4294 if (name || aname) {
4296 char *tname = (name ? name : aname);
4298 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4299 SV *sv = NEWSV(0,0);
4300 SV *tmpstr = sv_newmortal();
4301 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4305 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4307 (long)PL_subline, (long)CopLINE(PL_curcop));
4308 gv_efullname3(tmpstr, gv, Nullch);
4309 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4310 hv = GvHVn(db_postponed);
4311 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4312 && (pcv = GvCV(db_postponed)))
4318 call_sv((SV*)pcv, G_DISCARD);
4322 if ((s = strrchr(tname,':')))
4327 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4330 if (strEQ(s, "BEGIN")) {
4331 I32 oldscope = PL_scopestack_ix;
4333 SAVECOPFILE(&PL_compiling);
4334 SAVECOPLINE(&PL_compiling);
4337 PL_beginav = newAV();
4338 DEBUG_x( dump_sub(gv) );
4339 av_push(PL_beginav, (SV*)cv);
4340 GvCV(gv) = 0; /* cv has been hijacked */
4341 call_list(oldscope, PL_beginav);
4343 PL_curcop = &PL_compiling;
4344 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4347 else if (strEQ(s, "END") && !PL_error_count) {
4350 DEBUG_x( dump_sub(gv) );
4351 av_unshift(PL_endav, 1);
4352 av_store(PL_endav, 0, (SV*)cv);
4353 GvCV(gv) = 0; /* cv has been hijacked */
4355 else if (strEQ(s, "CHECK") && !PL_error_count) {
4357 PL_checkav = newAV();
4358 DEBUG_x( dump_sub(gv) );
4359 if (PL_main_start && ckWARN(WARN_VOID))
4360 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4361 av_unshift(PL_checkav, 1);
4362 av_store(PL_checkav, 0, (SV*)cv);
4363 GvCV(gv) = 0; /* cv has been hijacked */
4365 else if (strEQ(s, "INIT") && !PL_error_count) {
4367 PL_initav = newAV();
4368 DEBUG_x( dump_sub(gv) );
4369 if (PL_main_start && ckWARN(WARN_VOID))
4370 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4371 av_push(PL_initav, (SV*)cv);
4372 GvCV(gv) = 0; /* cv has been hijacked */
4377 PL_copline = NOLINE;
4382 /* XXX unsafe for threads if eval_owner isn't held */
4384 =for apidoc newCONSTSUB
4386 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4387 eligible for inlining at compile-time.
4393 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4399 SAVECOPLINE(PL_curcop);
4400 CopLINE_set(PL_curcop, PL_copline);
4403 PL_hints &= ~HINT_BLOCK_SCOPE;
4406 SAVESPTR(PL_curstash);
4407 SAVECOPSTASH(PL_curcop);
4408 PL_curstash = stash;
4409 CopSTASH_set(PL_curcop,stash);
4412 cv = newXS(name, const_sv_xsub, __FILE__);
4413 CvXSUBANY(cv).any_ptr = sv;
4415 sv_setpv((SV*)cv, ""); /* prototype is "" */
4423 =for apidoc U||newXS
4425 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4431 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
4433 GV *gv = gv_fetchpv(name ? name :
4434 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4435 GV_ADDMULTI, SVt_PVCV);
4439 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4441 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4443 /* just a cached method */
4447 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4448 /* already defined (or promised) */
4449 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4450 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4451 line_t oldline = CopLINE(PL_curcop);
4452 if (PL_copline != NOLINE)
4453 CopLINE_set(PL_curcop, PL_copline);
4454 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4455 CvCONST(cv) ? "Constant subroutine %s redefined"
4456 : "Subroutine %s redefined"
4458 CopLINE_set(PL_curcop, oldline);
4465 if (cv) /* must reuse cv if autoloaded */
4468 cv = (CV*)NEWSV(1105,0);
4469 sv_upgrade((SV *)cv, SVt_PVCV);
4473 PL_sub_generation++;
4477 #ifdef USE_5005THREADS
4478 New(666, CvMUTEXP(cv), 1, perl_mutex);
4479 MUTEX_INIT(CvMUTEXP(cv));
4481 #endif /* USE_5005THREADS */
4482 (void)gv_fetchfile(filename);
4483 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
4484 an external constant string */
4485 CvXSUB(cv) = subaddr;
4488 char *s = strrchr(name,':');
4494 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4497 if (strEQ(s, "BEGIN")) {
4499 PL_beginav = newAV();
4500 av_push(PL_beginav, (SV*)cv);
4501 GvCV(gv) = 0; /* cv has been hijacked */
4503 else if (strEQ(s, "END")) {
4506 av_unshift(PL_endav, 1);
4507 av_store(PL_endav, 0, (SV*)cv);
4508 GvCV(gv) = 0; /* cv has been hijacked */
4510 else if (strEQ(s, "CHECK")) {
4512 PL_checkav = newAV();
4513 if (PL_main_start && ckWARN(WARN_VOID))
4514 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4515 av_unshift(PL_checkav, 1);
4516 av_store(PL_checkav, 0, (SV*)cv);
4517 GvCV(gv) = 0; /* cv has been hijacked */
4519 else if (strEQ(s, "INIT")) {
4521 PL_initav = newAV();
4522 if (PL_main_start && ckWARN(WARN_VOID))
4523 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4524 av_push(PL_initav, (SV*)cv);
4525 GvCV(gv) = 0; /* cv has been hijacked */
4536 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4544 name = SvPVx(cSVOPo->op_sv, n_a);
4547 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
4548 #ifdef GV_UNIQUE_CHECK
4550 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4554 if ((cv = GvFORM(gv))) {
4555 if (ckWARN(WARN_REDEFINE)) {
4556 line_t oldline = CopLINE(PL_curcop);
4557 if (PL_copline != NOLINE)
4558 CopLINE_set(PL_curcop, PL_copline);
4559 Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Format %s redefined",name);
4560 CopLINE_set(PL_curcop, oldline);
4567 CvFILE_set_from_cop(cv, PL_curcop);
4570 pad_tidy(padtidy_FORMAT);
4571 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4572 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4573 OpREFCNT_set(CvROOT(cv), 1);
4574 CvSTART(cv) = LINKLIST(CvROOT(cv));
4575 CvROOT(cv)->op_next = 0;
4576 CALL_PEEP(CvSTART(cv));
4578 PL_copline = NOLINE;
4583 Perl_newANONLIST(pTHX_ OP *o)
4585 return newUNOP(OP_REFGEN, 0,
4586 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4590 Perl_newANONHASH(pTHX_ OP *o)
4592 return newUNOP(OP_REFGEN, 0,
4593 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4597 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4599 return newANONATTRSUB(floor, proto, Nullop, block);
4603 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4605 return newUNOP(OP_REFGEN, 0,
4606 newSVOP(OP_ANONCODE, 0,
4607 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
4611 Perl_oopsAV(pTHX_ OP *o)
4613 switch (o->op_type) {
4615 o->op_type = OP_PADAV;
4616 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4617 return ref(o, OP_RV2AV);
4620 o->op_type = OP_RV2AV;
4621 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4626 if (ckWARN_d(WARN_INTERNAL))
4627 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
4634 Perl_oopsHV(pTHX_ OP *o)
4636 switch (o->op_type) {
4639 o->op_type = OP_PADHV;
4640 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4641 return ref(o, OP_RV2HV);
4645 o->op_type = OP_RV2HV;
4646 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
4651 if (ckWARN_d(WARN_INTERNAL))
4652 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
4659 Perl_newAVREF(pTHX_ OP *o)
4661 if (o->op_type == OP_PADANY) {
4662 o->op_type = OP_PADAV;
4663 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4666 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
4667 && ckWARN(WARN_DEPRECATED)) {
4668 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4669 "Using an array as a reference is deprecated");
4671 return newUNOP(OP_RV2AV, 0, scalar(o));
4675 Perl_newGVREF(pTHX_ I32 type, OP *o)
4677 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
4678 return newUNOP(OP_NULL, 0, o);
4679 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
4683 Perl_newHVREF(pTHX_ OP *o)
4685 if (o->op_type == OP_PADANY) {
4686 o->op_type = OP_PADHV;
4687 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4690 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
4691 && ckWARN(WARN_DEPRECATED)) {
4692 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4693 "Using a hash as a reference is deprecated");
4695 return newUNOP(OP_RV2HV, 0, scalar(o));
4699 Perl_oopsCV(pTHX_ OP *o)
4701 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
4707 Perl_newCVREF(pTHX_ I32 flags, OP *o)
4709 return newUNOP(OP_RV2CV, flags, scalar(o));
4713 Perl_newSVREF(pTHX_ OP *o)
4715 if (o->op_type == OP_PADANY) {
4716 o->op_type = OP_PADSV;
4717 o->op_ppaddr = PL_ppaddr[OP_PADSV];
4720 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4721 o->op_flags |= OPpDONE_SVREF;
4724 return newUNOP(OP_RV2SV, 0, scalar(o));
4727 /* Check routines. */
4730 Perl_ck_anoncode(pTHX_ OP *o)
4732 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
4733 cSVOPo->op_sv = Nullsv;
4738 Perl_ck_bitop(pTHX_ OP *o)
4740 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4745 Perl_ck_concat(pTHX_ OP *o)
4747 if (cUNOPo->op_first->op_type == OP_CONCAT)
4748 o->op_flags |= OPf_STACKED;
4753 Perl_ck_spair(pTHX_ OP *o)
4755 if (o->op_flags & OPf_KIDS) {
4758 OPCODE type = o->op_type;
4759 o = modkids(ck_fun(o), type);
4760 kid = cUNOPo->op_first;
4761 newop = kUNOP->op_first->op_sibling;
4763 (newop->op_sibling ||
4764 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
4765 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
4766 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
4770 op_free(kUNOP->op_first);
4771 kUNOP->op_first = newop;
4773 o->op_ppaddr = PL_ppaddr[++o->op_type];
4778 Perl_ck_delete(pTHX_ OP *o)
4782 if (o->op_flags & OPf_KIDS) {
4783 OP *kid = cUNOPo->op_first;
4784 switch (kid->op_type) {
4786 o->op_flags |= OPf_SPECIAL;
4789 o->op_private |= OPpSLICE;
4792 o->op_flags |= OPf_SPECIAL;
4797 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
4806 Perl_ck_die(pTHX_ OP *o)
4809 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4815 Perl_ck_eof(pTHX_ OP *o)
4817 I32 type = o->op_type;
4819 if (o->op_flags & OPf_KIDS) {
4820 if (cLISTOPo->op_first->op_type == OP_STUB) {
4822 o = newUNOP(type, OPf_SPECIAL,
4823 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
4831 Perl_ck_eval(pTHX_ OP *o)
4833 PL_hints |= HINT_BLOCK_SCOPE;
4834 if (o->op_flags & OPf_KIDS) {
4835 SVOP *kid = (SVOP*)cUNOPo->op_first;
4838 o->op_flags &= ~OPf_KIDS;
4841 else if (kid->op_type == OP_LINESEQ) {
4844 kid->op_next = o->op_next;
4845 cUNOPo->op_first = 0;
4848 NewOp(1101, enter, 1, LOGOP);
4849 enter->op_type = OP_ENTERTRY;
4850 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
4851 enter->op_private = 0;
4853 /* establish postfix order */
4854 enter->op_next = (OP*)enter;
4856 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
4857 o->op_type = OP_LEAVETRY;
4858 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
4859 enter->op_other = o;
4867 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
4869 o->op_targ = (PADOFFSET)PL_hints;
4874 Perl_ck_exit(pTHX_ OP *o)
4877 HV *table = GvHV(PL_hintgv);
4879 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
4880 if (svp && *svp && SvTRUE(*svp))
4881 o->op_private |= OPpEXIT_VMSISH;
4883 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4889 Perl_ck_exec(pTHX_ OP *o)
4892 if (o->op_flags & OPf_STACKED) {
4894 kid = cUNOPo->op_first->op_sibling;
4895 if (kid->op_type == OP_RV2GV)
4904 Perl_ck_exists(pTHX_ OP *o)
4907 if (o->op_flags & OPf_KIDS) {
4908 OP *kid = cUNOPo->op_first;
4909 if (kid->op_type == OP_ENTERSUB) {
4910 (void) ref(kid, o->op_type);
4911 if (kid->op_type != OP_RV2CV && !PL_error_count)
4912 Perl_croak(aTHX_ "%s argument is not a subroutine name",
4914 o->op_private |= OPpEXISTS_SUB;
4916 else if (kid->op_type == OP_AELEM)
4917 o->op_flags |= OPf_SPECIAL;
4918 else if (kid->op_type != OP_HELEM)
4919 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
4928 Perl_ck_gvconst(pTHX_ register OP *o)
4930 o = fold_constants(o);
4931 if (o->op_type == OP_CONST)
4938 Perl_ck_rvconst(pTHX_ register OP *o)
4940 SVOP *kid = (SVOP*)cUNOPo->op_first;
4942 o->op_private |= (PL_hints & HINT_STRICT_REFS);
4943 if (kid->op_type == OP_CONST) {
4947 SV *kidsv = kid->op_sv;
4950 /* Is it a constant from cv_const_sv()? */
4951 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
4952 SV *rsv = SvRV(kidsv);
4953 int svtype = SvTYPE(rsv);
4954 char *badtype = Nullch;
4956 switch (o->op_type) {
4958 if (svtype > SVt_PVMG)
4959 badtype = "a SCALAR";
4962 if (svtype != SVt_PVAV)
4963 badtype = "an ARRAY";
4966 if (svtype != SVt_PVHV)
4970 if (svtype != SVt_PVCV)
4975 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
4978 name = SvPV(kidsv, n_a);
4979 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
4980 char *badthing = Nullch;
4981 switch (o->op_type) {
4983 badthing = "a SCALAR";
4986 badthing = "an ARRAY";
4989 badthing = "a HASH";
4994 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
4998 * This is a little tricky. We only want to add the symbol if we
4999 * didn't add it in the lexer. Otherwise we get duplicate strict
5000 * warnings. But if we didn't add it in the lexer, we must at
5001 * least pretend like we wanted to add it even if it existed before,
5002 * or we get possible typo warnings. OPpCONST_ENTERED says
5003 * whether the lexer already added THIS instance of this symbol.
5005 iscv = (o->op_type == OP_RV2CV) * 2;
5007 gv = gv_fetchpv(name,
5008 iscv | !(kid->op_private & OPpCONST_ENTERED),
5011 : o->op_type == OP_RV2SV
5013 : o->op_type == OP_RV2AV
5015 : o->op_type == OP_RV2HV
5018 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5020 kid->op_type = OP_GV;
5021 SvREFCNT_dec(kid->op_sv);
5023 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5024 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5025 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
5027 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
5029 kid->op_sv = SvREFCNT_inc(gv);
5031 kid->op_private = 0;
5032 kid->op_ppaddr = PL_ppaddr[OP_GV];
5039 Perl_ck_ftst(pTHX_ OP *o)
5041 I32 type = o->op_type;
5043 if (o->op_flags & OPf_REF) {
5046 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5047 SVOP *kid = (SVOP*)cUNOPo->op_first;
5049 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5051 OP *newop = newGVOP(type, OPf_REF,
5052 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5059 if (type == OP_FTTTY)
5060 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5063 o = newUNOP(type, 0, newDEFSVOP());
5069 Perl_ck_fun(pTHX_ OP *o)
5075 int type = o->op_type;
5076 register I32 oa = PL_opargs[type] >> OASHIFT;
5078 if (o->op_flags & OPf_STACKED) {
5079 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5082 return no_fh_allowed(o);
5085 if (o->op_flags & OPf_KIDS) {
5087 tokid = &cLISTOPo->op_first;
5088 kid = cLISTOPo->op_first;
5089 if (kid->op_type == OP_PUSHMARK ||
5090 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5092 tokid = &kid->op_sibling;
5093 kid = kid->op_sibling;
5095 if (!kid && PL_opargs[type] & OA_DEFGV)
5096 *tokid = kid = newDEFSVOP();
5100 sibl = kid->op_sibling;
5103 /* list seen where single (scalar) arg expected? */
5104 if (numargs == 1 && !(oa >> 4)
5105 && kid->op_type == OP_LIST && type != OP_SCALAR)
5107 return too_many_arguments(o,PL_op_desc[type]);
5120 if ((type == OP_PUSH || type == OP_UNSHIFT)
5121 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5122 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5123 "Useless use of %s with no values",
5126 if (kid->op_type == OP_CONST &&
5127 (kid->op_private & OPpCONST_BARE))
5129 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5130 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5131 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5132 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5133 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5134 "Array @%s missing the @ in argument %"IVdf" of %s()",
5135 name, (IV)numargs, PL_op_desc[type]);
5138 kid->op_sibling = sibl;
5141 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5142 bad_type(numargs, "array", PL_op_desc[type], kid);
5146 if (kid->op_type == OP_CONST &&
5147 (kid->op_private & OPpCONST_BARE))
5149 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5150 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5151 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5152 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5153 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5154 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5155 name, (IV)numargs, PL_op_desc[type]);
5158 kid->op_sibling = sibl;
5161 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5162 bad_type(numargs, "hash", PL_op_desc[type], kid);
5167 OP *newop = newUNOP(OP_NULL, 0, kid);
5168 kid->op_sibling = 0;
5170 newop->op_next = newop;
5172 kid->op_sibling = sibl;
5177 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5178 if (kid->op_type == OP_CONST &&
5179 (kid->op_private & OPpCONST_BARE))
5181 OP *newop = newGVOP(OP_GV, 0,
5182 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5184 if (!(o->op_private & 1) && /* if not unop */
5185 kid == cLISTOPo->op_last)
5186 cLISTOPo->op_last = newop;
5190 else if (kid->op_type == OP_READLINE) {
5191 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5192 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5195 I32 flags = OPf_SPECIAL;
5199 /* is this op a FH constructor? */
5200 if (is_handle_constructor(o,numargs)) {
5201 char *name = Nullch;
5205 /* Set a flag to tell rv2gv to vivify
5206 * need to "prove" flag does not mean something
5207 * else already - NI-S 1999/05/07
5210 if (kid->op_type == OP_PADSV) {
5211 /*XXX DAPM 2002.08.25 tmp assert test */
5212 /*XXX*/ assert(av_fetch(PL_comppad_name, (kid->op_targ), FALSE));
5213 /*XXX*/ assert(*av_fetch(PL_comppad_name, (kid->op_targ), FALSE));
5215 name = PAD_COMPNAME_PV(kid->op_targ);
5216 /* SvCUR of a pad namesv can't be trusted
5217 * (see PL_generation), so calc its length
5223 else if (kid->op_type == OP_RV2SV
5224 && kUNOP->op_first->op_type == OP_GV)
5226 GV *gv = cGVOPx_gv(kUNOP->op_first);
5228 len = GvNAMELEN(gv);
5230 else if (kid->op_type == OP_AELEM
5231 || kid->op_type == OP_HELEM)
5233 name = "__ANONIO__";
5239 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5240 namesv = PAD_SVl(targ);
5241 (void)SvUPGRADE(namesv, SVt_PV);
5243 sv_setpvn(namesv, "$", 1);
5244 sv_catpvn(namesv, name, len);
5247 kid->op_sibling = 0;
5248 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5249 kid->op_targ = targ;
5250 kid->op_private |= priv;
5252 kid->op_sibling = sibl;
5258 mod(scalar(kid), type);
5262 tokid = &kid->op_sibling;
5263 kid = kid->op_sibling;
5265 o->op_private |= numargs;
5267 return too_many_arguments(o,OP_DESC(o));
5270 else if (PL_opargs[type] & OA_DEFGV) {
5272 return newUNOP(type, 0, newDEFSVOP());
5276 while (oa & OA_OPTIONAL)
5278 if (oa && oa != OA_LIST)
5279 return too_few_arguments(o,OP_DESC(o));
5285 Perl_ck_glob(pTHX_ OP *o)
5290 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5291 append_elem(OP_GLOB, o, newDEFSVOP());
5293 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5294 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5296 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5299 #if !defined(PERL_EXTERNAL_GLOB)
5300 /* XXX this can be tightened up and made more failsafe. */
5304 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5305 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5306 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5307 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5308 GvCV(gv) = GvCV(glob_gv);
5309 SvREFCNT_inc((SV*)GvCV(gv));
5310 GvIMPORTED_CV_on(gv);
5313 #endif /* PERL_EXTERNAL_GLOB */
5315 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5316 append_elem(OP_GLOB, o,
5317 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5318 o->op_type = OP_LIST;
5319 o->op_ppaddr = PL_ppaddr[OP_LIST];
5320 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5321 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5322 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5323 append_elem(OP_LIST, o,
5324 scalar(newUNOP(OP_RV2CV, 0,
5325 newGVOP(OP_GV, 0, gv)))));
5326 o = newUNOP(OP_NULL, 0, ck_subr(o));
5327 o->op_targ = OP_GLOB; /* hint at what it used to be */
5330 gv = newGVgen("main");
5332 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5338 Perl_ck_grep(pTHX_ OP *o)
5342 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5344 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5345 NewOp(1101, gwop, 1, LOGOP);
5347 if (o->op_flags & OPf_STACKED) {
5350 kid = cLISTOPo->op_first->op_sibling;
5351 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5354 kid->op_next = (OP*)gwop;
5355 o->op_flags &= ~OPf_STACKED;
5357 kid = cLISTOPo->op_first->op_sibling;
5358 if (type == OP_MAPWHILE)
5365 kid = cLISTOPo->op_first->op_sibling;
5366 if (kid->op_type != OP_NULL)
5367 Perl_croak(aTHX_ "panic: ck_grep");
5368 kid = kUNOP->op_first;
5370 gwop->op_type = type;
5371 gwop->op_ppaddr = PL_ppaddr[type];
5372 gwop->op_first = listkids(o);
5373 gwop->op_flags |= OPf_KIDS;
5374 gwop->op_private = 1;
5375 gwop->op_other = LINKLIST(kid);
5376 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5377 kid->op_next = (OP*)gwop;
5379 kid = cLISTOPo->op_first->op_sibling;
5380 if (!kid || !kid->op_sibling)
5381 return too_few_arguments(o,OP_DESC(o));
5382 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5383 mod(kid, OP_GREPSTART);
5389 Perl_ck_index(pTHX_ OP *o)
5391 if (o->op_flags & OPf_KIDS) {
5392 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5394 kid = kid->op_sibling; /* get past "big" */
5395 if (kid && kid->op_type == OP_CONST)
5396 fbm_compile(((SVOP*)kid)->op_sv, 0);
5402 Perl_ck_lengthconst(pTHX_ OP *o)
5404 /* XXX length optimization goes here */
5409 Perl_ck_lfun(pTHX_ OP *o)
5411 OPCODE type = o->op_type;
5412 return modkids(ck_fun(o), type);
5416 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5418 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5419 switch (cUNOPo->op_first->op_type) {
5421 /* This is needed for
5422 if (defined %stash::)
5423 to work. Do not break Tk.
5425 break; /* Globals via GV can be undef */
5427 case OP_AASSIGN: /* Is this a good idea? */
5428 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5429 "defined(@array) is deprecated");
5430 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5431 "\t(Maybe you should just omit the defined()?)\n");
5434 /* This is needed for
5435 if (defined %stash::)
5436 to work. Do not break Tk.
5438 break; /* Globals via GV can be undef */
5440 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5441 "defined(%%hash) is deprecated");
5442 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5443 "\t(Maybe you should just omit the defined()?)\n");
5454 Perl_ck_rfun(pTHX_ OP *o)
5456 OPCODE type = o->op_type;
5457 return refkids(ck_fun(o), type);
5461 Perl_ck_listiob(pTHX_ OP *o)
5465 kid = cLISTOPo->op_first;
5468 kid = cLISTOPo->op_first;
5470 if (kid->op_type == OP_PUSHMARK)
5471 kid = kid->op_sibling;
5472 if (kid && o->op_flags & OPf_STACKED)
5473 kid = kid->op_sibling;
5474 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5475 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5476 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5477 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5478 cLISTOPo->op_first->op_sibling = kid;
5479 cLISTOPo->op_last = kid;
5480 kid = kid->op_sibling;
5485 append_elem(o->op_type, o, newDEFSVOP());
5491 Perl_ck_sassign(pTHX_ OP *o)
5493 OP *kid = cLISTOPo->op_first;
5494 /* has a disposable target? */
5495 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5496 && !(kid->op_flags & OPf_STACKED)
5497 /* Cannot steal the second time! */
5498 && !(kid->op_private & OPpTARGET_MY))
5500 OP *kkid = kid->op_sibling;
5502 /* Can just relocate the target. */
5503 if (kkid && kkid->op_type == OP_PADSV
5504 && !(kkid->op_private & OPpLVAL_INTRO))
5506 kid->op_targ = kkid->op_targ;
5508 /* Now we do not need PADSV and SASSIGN. */
5509 kid->op_sibling = o->op_sibling; /* NULL */
5510 cLISTOPo->op_first = NULL;
5513 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
5521 Perl_ck_match(pTHX_ OP *o)
5523 o->op_private |= OPpRUNTIME;
5528 Perl_ck_method(pTHX_ OP *o)
5530 OP *kid = cUNOPo->op_first;
5531 if (kid->op_type == OP_CONST) {
5532 SV* sv = kSVOP->op_sv;
5533 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
5535 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5536 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
5539 kSVOP->op_sv = Nullsv;
5541 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5550 Perl_ck_null(pTHX_ OP *o)
5556 Perl_ck_open(pTHX_ OP *o)
5558 HV *table = GvHV(PL_hintgv);
5562 svp = hv_fetch(table, "open_IN", 7, FALSE);
5564 mode = mode_from_discipline(*svp);
5565 if (mode & O_BINARY)
5566 o->op_private |= OPpOPEN_IN_RAW;
5567 else if (mode & O_TEXT)
5568 o->op_private |= OPpOPEN_IN_CRLF;
5571 svp = hv_fetch(table, "open_OUT", 8, FALSE);
5573 mode = mode_from_discipline(*svp);
5574 if (mode & O_BINARY)
5575 o->op_private |= OPpOPEN_OUT_RAW;
5576 else if (mode & O_TEXT)
5577 o->op_private |= OPpOPEN_OUT_CRLF;
5580 if (o->op_type == OP_BACKTICK)
5586 Perl_ck_repeat(pTHX_ OP *o)
5588 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5589 o->op_private |= OPpREPEAT_DOLIST;
5590 cBINOPo->op_first = force_list(cBINOPo->op_first);
5598 Perl_ck_require(pTHX_ OP *o)
5602 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
5603 SVOP *kid = (SVOP*)cUNOPo->op_first;
5605 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5607 for (s = SvPVX(kid->op_sv); *s; s++) {
5608 if (*s == ':' && s[1] == ':') {
5610 Move(s+2, s+1, strlen(s+2)+1, char);
5611 --SvCUR(kid->op_sv);
5614 if (SvREADONLY(kid->op_sv)) {
5615 SvREADONLY_off(kid->op_sv);
5616 sv_catpvn(kid->op_sv, ".pm", 3);
5617 SvREADONLY_on(kid->op_sv);
5620 sv_catpvn(kid->op_sv, ".pm", 3);
5624 /* handle override, if any */
5625 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
5626 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
5627 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
5629 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5630 OP *kid = cUNOPo->op_first;
5631 cUNOPo->op_first = 0;
5633 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5634 append_elem(OP_LIST, kid,
5635 scalar(newUNOP(OP_RV2CV, 0,
5644 Perl_ck_return(pTHX_ OP *o)
5647 if (CvLVALUE(PL_compcv)) {
5648 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5649 mod(kid, OP_LEAVESUBLV);
5656 Perl_ck_retarget(pTHX_ OP *o)
5658 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5665 Perl_ck_select(pTHX_ OP *o)
5668 if (o->op_flags & OPf_KIDS) {
5669 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5670 if (kid && kid->op_sibling) {
5671 o->op_type = OP_SSELECT;
5672 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
5674 return fold_constants(o);
5678 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5679 if (kid && kid->op_type == OP_RV2GV)
5680 kid->op_private &= ~HINT_STRICT_REFS;
5685 Perl_ck_shift(pTHX_ OP *o)
5687 I32 type = o->op_type;
5689 if (!(o->op_flags & OPf_KIDS)) {
5693 #ifdef USE_5005THREADS
5694 if (!CvUNIQUE(PL_compcv)) {
5695 argop = newOP(OP_PADAV, OPf_REF);
5696 argop->op_targ = 0; /* PAD_SV(0) is @_ */
5699 argop = newUNOP(OP_RV2AV, 0,
5700 scalar(newGVOP(OP_GV, 0,
5701 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
5704 argop = newUNOP(OP_RV2AV, 0,
5705 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
5706 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
5707 #endif /* USE_5005THREADS */
5708 return newUNOP(type, 0, scalar(argop));
5710 return scalar(modkids(ck_fun(o), type));
5714 Perl_ck_sort(pTHX_ OP *o)
5718 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
5720 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5721 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
5723 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
5725 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
5727 if (kid->op_type == OP_SCOPE) {
5731 else if (kid->op_type == OP_LEAVE) {
5732 if (o->op_type == OP_SORT) {
5733 op_null(kid); /* wipe out leave */
5736 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
5737 if (k->op_next == kid)
5739 /* don't descend into loops */
5740 else if (k->op_type == OP_ENTERLOOP
5741 || k->op_type == OP_ENTERITER)
5743 k = cLOOPx(k)->op_lastop;
5748 kid->op_next = 0; /* just disconnect the leave */
5749 k = kLISTOP->op_first;
5754 if (o->op_type == OP_SORT) {
5755 /* provide scalar context for comparison function/block */
5761 o->op_flags |= OPf_SPECIAL;
5763 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
5766 firstkid = firstkid->op_sibling;
5769 /* provide list context for arguments */
5770 if (o->op_type == OP_SORT)
5777 S_simplify_sort(pTHX_ OP *o)
5779 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5783 if (!(o->op_flags & OPf_STACKED))
5785 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
5786 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
5787 kid = kUNOP->op_first; /* get past null */
5788 if (kid->op_type != OP_SCOPE)
5790 kid = kLISTOP->op_last; /* get past scope */
5791 switch(kid->op_type) {
5799 k = kid; /* remember this node*/
5800 if (kBINOP->op_first->op_type != OP_RV2SV)
5802 kid = kBINOP->op_first; /* get past cmp */
5803 if (kUNOP->op_first->op_type != OP_GV)
5805 kid = kUNOP->op_first; /* get past rv2sv */
5807 if (GvSTASH(gv) != PL_curstash)
5809 if (strEQ(GvNAME(gv), "a"))
5811 else if (strEQ(GvNAME(gv), "b"))
5815 kid = k; /* back to cmp */
5816 if (kBINOP->op_last->op_type != OP_RV2SV)
5818 kid = kBINOP->op_last; /* down to 2nd arg */
5819 if (kUNOP->op_first->op_type != OP_GV)
5821 kid = kUNOP->op_first; /* get past rv2sv */
5823 if (GvSTASH(gv) != PL_curstash
5825 ? strNE(GvNAME(gv), "a")
5826 : strNE(GvNAME(gv), "b")))
5828 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
5830 o->op_private |= OPpSORT_REVERSE;
5831 if (k->op_type == OP_NCMP)
5832 o->op_private |= OPpSORT_NUMERIC;
5833 if (k->op_type == OP_I_NCMP)
5834 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
5835 kid = cLISTOPo->op_first->op_sibling;
5836 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
5837 op_free(kid); /* then delete it */
5841 Perl_ck_split(pTHX_ OP *o)
5845 if (o->op_flags & OPf_STACKED)
5846 return no_fh_allowed(o);
5848 kid = cLISTOPo->op_first;
5849 if (kid->op_type != OP_NULL)
5850 Perl_croak(aTHX_ "panic: ck_split");
5851 kid = kid->op_sibling;
5852 op_free(cLISTOPo->op_first);
5853 cLISTOPo->op_first = kid;
5855 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
5856 cLISTOPo->op_last = kid; /* There was only one element previously */
5859 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
5860 OP *sibl = kid->op_sibling;
5861 kid->op_sibling = 0;
5862 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
5863 if (cLISTOPo->op_first == cLISTOPo->op_last)
5864 cLISTOPo->op_last = kid;
5865 cLISTOPo->op_first = kid;
5866 kid->op_sibling = sibl;
5869 kid->op_type = OP_PUSHRE;
5870 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
5872 if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
5873 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
5874 "Use of /g modifier is meaningless in split");
5877 if (!kid->op_sibling)
5878 append_elem(OP_SPLIT, o, newDEFSVOP());
5880 kid = kid->op_sibling;
5883 if (!kid->op_sibling)
5884 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
5886 kid = kid->op_sibling;
5889 if (kid->op_sibling)
5890 return too_many_arguments(o,OP_DESC(o));
5896 Perl_ck_join(pTHX_ OP *o)
5898 if (ckWARN(WARN_SYNTAX)) {
5899 OP *kid = cLISTOPo->op_first->op_sibling;
5900 if (kid && kid->op_type == OP_MATCH) {
5901 char *pmstr = "STRING";
5902 if (PM_GETRE(kPMOP))
5903 pmstr = PM_GETRE(kPMOP)->precomp;
5904 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5905 "/%s/ should probably be written as \"%s\"",
5913 Perl_ck_subr(pTHX_ OP *o)
5915 OP *prev = ((cUNOPo->op_first->op_sibling)
5916 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
5917 OP *o2 = prev->op_sibling;
5924 I32 contextclass = 0;
5928 o->op_private |= OPpENTERSUB_HASTARG;
5929 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
5930 if (cvop->op_type == OP_RV2CV) {
5932 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
5933 op_null(cvop); /* disable rv2cv */
5934 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
5935 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
5936 GV *gv = cGVOPx_gv(tmpop);
5939 tmpop->op_private |= OPpEARLY_CV;
5940 else if (SvPOK(cv)) {
5941 namegv = CvANON(cv) ? gv : CvGV(cv);
5942 proto = SvPV((SV*)cv, n_a);
5946 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
5947 if (o2->op_type == OP_CONST)
5948 o2->op_private &= ~OPpCONST_STRICT;
5949 else if (o2->op_type == OP_LIST) {
5950 OP *o = ((UNOP*)o2)->op_first->op_sibling;
5951 if (o && o->op_type == OP_CONST)
5952 o->op_private &= ~OPpCONST_STRICT;
5955 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5956 if (PERLDB_SUB && PL_curstash != PL_debstash)
5957 o->op_private |= OPpENTERSUB_DB;
5958 while (o2 != cvop) {
5962 return too_many_arguments(o, gv_ename(namegv));
5980 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
5982 arg == 1 ? "block or sub {}" : "sub {}",
5983 gv_ename(namegv), o2);
5986 /* '*' allows any scalar type, including bareword */
5989 if (o2->op_type == OP_RV2GV)
5990 goto wrapref; /* autoconvert GLOB -> GLOBref */
5991 else if (o2->op_type == OP_CONST)
5992 o2->op_private &= ~OPpCONST_STRICT;
5993 else if (o2->op_type == OP_ENTERSUB) {
5994 /* accidental subroutine, revert to bareword */
5995 OP *gvop = ((UNOP*)o2)->op_first;
5996 if (gvop && gvop->op_type == OP_NULL) {
5997 gvop = ((UNOP*)gvop)->op_first;
5999 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6002 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6003 (gvop = ((UNOP*)gvop)->op_first) &&
6004 gvop->op_type == OP_GV)
6006 GV *gv = cGVOPx_gv(gvop);
6007 OP *sibling = o2->op_sibling;
6008 SV *n = newSVpvn("",0);
6010 gv_fullname3(n, gv, "");
6011 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6012 sv_chop(n, SvPVX(n)+6);
6013 o2 = newSVOP(OP_CONST, 0, n);
6014 prev->op_sibling = o2;
6015 o2->op_sibling = sibling;
6031 if (contextclass++ == 0) {
6032 e = strchr(proto, ']');
6033 if (!e || e == proto)
6046 while (*--p != '[');
6047 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6048 gv_ename(namegv), o2);
6054 if (o2->op_type == OP_RV2GV)
6057 bad_type(arg, "symbol", gv_ename(namegv), o2);
6060 if (o2->op_type == OP_ENTERSUB)
6063 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6066 if (o2->op_type == OP_RV2SV ||
6067 o2->op_type == OP_PADSV ||
6068 o2->op_type == OP_HELEM ||
6069 o2->op_type == OP_AELEM ||
6070 o2->op_type == OP_THREADSV)
6073 bad_type(arg, "scalar", gv_ename(namegv), o2);
6076 if (o2->op_type == OP_RV2AV ||
6077 o2->op_type == OP_PADAV)
6080 bad_type(arg, "array", gv_ename(namegv), o2);
6083 if (o2->op_type == OP_RV2HV ||
6084 o2->op_type == OP_PADHV)
6087 bad_type(arg, "hash", gv_ename(namegv), o2);
6092 OP* sib = kid->op_sibling;
6093 kid->op_sibling = 0;
6094 o2 = newUNOP(OP_REFGEN, 0, kid);
6095 o2->op_sibling = sib;
6096 prev->op_sibling = o2;
6098 if (contextclass && e) {
6113 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6114 gv_ename(namegv), SvPV((SV*)cv, n_a));
6119 mod(o2, OP_ENTERSUB);
6121 o2 = o2->op_sibling;
6123 if (proto && !optional &&
6124 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6125 return too_few_arguments(o, gv_ename(namegv));
6130 Perl_ck_svconst(pTHX_ OP *o)
6132 SvREADONLY_on(cSVOPo->op_sv);
6137 Perl_ck_trunc(pTHX_ OP *o)
6139 if (o->op_flags & OPf_KIDS) {
6140 SVOP *kid = (SVOP*)cUNOPo->op_first;
6142 if (kid->op_type == OP_NULL)
6143 kid = (SVOP*)kid->op_sibling;
6144 if (kid && kid->op_type == OP_CONST &&
6145 (kid->op_private & OPpCONST_BARE))
6147 o->op_flags |= OPf_SPECIAL;
6148 kid->op_private &= ~OPpCONST_STRICT;
6155 Perl_ck_substr(pTHX_ OP *o)
6158 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6159 OP *kid = cLISTOPo->op_first;
6161 if (kid->op_type == OP_NULL)
6162 kid = kid->op_sibling;
6164 kid->op_flags |= OPf_MOD;
6170 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6173 Perl_peep(pTHX_ register OP *o)
6175 register OP* oldop = 0;
6177 if (!o || o->op_seq)
6181 SAVEVPTR(PL_curcop);
6182 for (; o; o = o->op_next) {
6188 switch (o->op_type) {
6192 PL_curcop = ((COP*)o); /* for warnings */
6193 o->op_seq = PL_op_seqmax++;
6197 if (cSVOPo->op_private & OPpCONST_STRICT)
6198 no_bareword_allowed(o);
6200 /* Relocate sv to the pad for thread safety.
6201 * Despite being a "constant", the SV is written to,
6202 * for reference counts, sv_upgrade() etc. */
6204 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6205 if (SvPADTMP(cSVOPo->op_sv)) {
6206 /* If op_sv is already a PADTMP then it is being used by
6207 * some pad, so make a copy. */
6208 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6209 SvREADONLY_on(PAD_SVl(ix));
6210 SvREFCNT_dec(cSVOPo->op_sv);
6213 SvREFCNT_dec(PAD_SVl(ix));
6214 SvPADTMP_on(cSVOPo->op_sv);
6215 PAD_SETSV(ix, cSVOPo->op_sv);
6216 /* XXX I don't know how this isn't readonly already. */
6217 SvREADONLY_on(PAD_SVl(ix));
6219 cSVOPo->op_sv = Nullsv;
6223 o->op_seq = PL_op_seqmax++;
6227 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6228 if (o->op_next->op_private & OPpTARGET_MY) {
6229 if (o->op_flags & OPf_STACKED) /* chained concats */
6230 goto ignore_optimization;
6232 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6233 o->op_targ = o->op_next->op_targ;
6234 o->op_next->op_targ = 0;
6235 o->op_private |= OPpTARGET_MY;
6238 op_null(o->op_next);
6240 ignore_optimization:
6241 o->op_seq = PL_op_seqmax++;
6244 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6245 o->op_seq = PL_op_seqmax++;
6246 break; /* Scalar stub must produce undef. List stub is noop */
6250 if (o->op_targ == OP_NEXTSTATE
6251 || o->op_targ == OP_DBSTATE
6252 || o->op_targ == OP_SETSTATE)
6254 PL_curcop = ((COP*)o);
6256 /* XXX: We avoid setting op_seq here to prevent later calls
6257 to peep() from mistakenly concluding that optimisation
6258 has already occurred. This doesn't fix the real problem,
6259 though (See 20010220.007). AMS 20010719 */
6260 if (oldop && o->op_next) {
6261 oldop->op_next = o->op_next;
6269 if (oldop && o->op_next) {
6270 oldop->op_next = o->op_next;
6273 o->op_seq = PL_op_seqmax++;
6277 if (o->op_next->op_type == OP_RV2SV) {
6278 if (!(o->op_next->op_private & OPpDEREF)) {
6279 op_null(o->op_next);
6280 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6282 o->op_next = o->op_next->op_next;
6283 o->op_type = OP_GVSV;
6284 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6287 else if (o->op_next->op_type == OP_RV2AV) {
6288 OP* pop = o->op_next->op_next;
6290 if (pop && pop->op_type == OP_CONST &&
6291 (PL_op = pop->op_next) &&
6292 pop->op_next->op_type == OP_AELEM &&
6293 !(pop->op_next->op_private &
6294 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6295 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6300 op_null(o->op_next);
6301 op_null(pop->op_next);
6303 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6304 o->op_next = pop->op_next->op_next;
6305 o->op_type = OP_AELEMFAST;
6306 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6307 o->op_private = (U8)i;
6312 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6314 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6315 /* XXX could check prototype here instead of just carping */
6316 SV *sv = sv_newmortal();
6317 gv_efullname3(sv, gv, Nullch);
6318 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6319 "%s() called too early to check prototype",
6323 else if (o->op_next->op_type == OP_READLINE
6324 && o->op_next->op_next->op_type == OP_CONCAT
6325 && (o->op_next->op_next->op_flags & OPf_STACKED))
6327 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6328 o->op_type = OP_RCATLINE;
6329 o->op_flags |= OPf_STACKED;
6330 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6331 op_null(o->op_next->op_next);
6332 op_null(o->op_next);
6335 o->op_seq = PL_op_seqmax++;
6348 o->op_seq = PL_op_seqmax++;
6349 while (cLOGOP->op_other->op_type == OP_NULL)
6350 cLOGOP->op_other = cLOGOP->op_other->op_next;
6351 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6356 o->op_seq = PL_op_seqmax++;
6357 while (cLOOP->op_redoop->op_type == OP_NULL)
6358 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6359 peep(cLOOP->op_redoop);
6360 while (cLOOP->op_nextop->op_type == OP_NULL)
6361 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6362 peep(cLOOP->op_nextop);
6363 while (cLOOP->op_lastop->op_type == OP_NULL)
6364 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6365 peep(cLOOP->op_lastop);
6371 o->op_seq = PL_op_seqmax++;
6372 while (cPMOP->op_pmreplstart &&
6373 cPMOP->op_pmreplstart->op_type == OP_NULL)
6374 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6375 peep(cPMOP->op_pmreplstart);
6379 o->op_seq = PL_op_seqmax++;
6380 if (ckWARN(WARN_SYNTAX) && o->op_next
6381 && o->op_next->op_type == OP_NEXTSTATE) {
6382 if (o->op_next->op_sibling &&
6383 o->op_next->op_sibling->op_type != OP_EXIT &&
6384 o->op_next->op_sibling->op_type != OP_WARN &&
6385 o->op_next->op_sibling->op_type != OP_DIE) {
6386 line_t oldline = CopLINE(PL_curcop);
6388 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6389 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6390 "Statement unlikely to be reached");
6391 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6392 "\t(Maybe you meant system() when you said exec()?)\n");
6393 CopLINE_set(PL_curcop, oldline);
6404 o->op_seq = PL_op_seqmax++;
6406 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6409 /* Make the CONST have a shared SV */
6410 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6411 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6412 key = SvPV(sv, keylen);
6413 lexname = newSVpvn_share(key,
6414 SvUTF8(sv) ? -(I32)keylen : keylen,
6423 o->op_seq = PL_op_seqmax++;
6433 char* Perl_custom_op_name(pTHX_ OP* o)
6435 IV index = PTR2IV(o->op_ppaddr);
6439 if (!PL_custom_op_names) /* This probably shouldn't happen */
6440 return PL_op_name[OP_CUSTOM];
6442 keysv = sv_2mortal(newSViv(index));
6444 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
6446 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
6448 return SvPV_nolen(HeVAL(he));
6451 char* Perl_custom_op_desc(pTHX_ OP* o)
6453 IV index = PTR2IV(o->op_ppaddr);
6457 if (!PL_custom_op_descs)
6458 return PL_op_desc[OP_CUSTOM];
6460 keysv = sv_2mortal(newSViv(index));
6462 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
6464 return PL_op_desc[OP_CUSTOM];
6466 return SvPV_nolen(HeVAL(he));
6472 /* Efficient sub that returns a constant scalar value. */
6474 const_sv_xsub(pTHX_ CV* cv)
6479 Perl_croak(aTHX_ "usage: %s::%s()",
6480 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
6484 ST(0) = (SV*)XSANY.any_ptr;