3 * Copyright (c) 1991-1999, 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 * Then he heard Merry change the note, and up went the Horn-cry of Buckland,
14 * Awake! Awake! Fear, Fire, Foes! Awake!
19 #define PERL_IN_PP_HOT_C
32 #define HOP(pos,off) (IN_UTF8 ? utf8_hop(pos, off) : (pos + off))
37 static void unset_cvowner(pTHXo_ void *cvarg);
38 #endif /* USE_THREADS */
49 PL_curcop = (COP*)PL_op;
50 TAINT_NOT; /* Each statement is presumed innocent */
51 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
60 if (PL_op->op_private & OPpLVAL_INTRO)
61 PUSHs(save_scalar(cGVOP->op_gv));
63 PUSHs(GvSV(cGVOP->op_gv));
74 PL_curcop = (COP*)PL_op;
80 PUSHMARK(PL_stack_sp);
90 sv_setpvn(TARG,s,len);
98 XPUSHs((SV*)cGVOP->op_gv);
109 RETURNOP(cLOGOP->op_other);
118 if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
120 temp = left; left = right; right = temp;
122 if (PL_tainting && PL_tainted && !SvTAINTED(left))
124 SvSetMagicSV(right, left);
133 RETURNOP(cLOGOP->op_other);
135 RETURNOP(cLOGOP->op_next);
141 TAINT_NOT; /* Each statement is presumed innocent */
142 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
144 oldsave = PL_scopestack[PL_scopestack_ix - 1];
145 LEAVE_SCOPE(oldsave);
151 djSP; dATARGET; tryAMAGICbin(concat,opASSIGN);
158 sv_setpvn(TARG,s,len);
160 else if (SvGMAGICAL(TARG))
162 else if (!SvOK(TARG) && SvTYPE(TARG) <= SVt_PVMG) {
163 sv_setpv(TARG, ""); /* Suppress warning. */
164 s = SvPV_force(TARG, len);
168 sv_catpvn(TARG,s,len);
170 sv_setpvn(TARG,s,len); /* suppress warning */
180 if (PL_op->op_flags & OPf_MOD) {
181 if (PL_op->op_private & OPpLVAL_INTRO)
182 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
183 else if (PL_op->op_private & OPpDEREF) {
185 vivify_ref(PL_curpad[PL_op->op_targ], PL_op->op_private & OPpDEREF);
194 tryAMAGICunTARGET(iter, 0);
195 PL_last_in_gv = (GV*)(*PL_stack_sp--);
196 if (SvTYPE(PL_last_in_gv) != SVt_PVGV) {
197 if (SvROK(PL_last_in_gv) && SvTYPE(SvRV(PL_last_in_gv)) == SVt_PVGV)
198 PL_last_in_gv = (GV*)SvRV(PL_last_in_gv);
201 XPUSHs((SV*)PL_last_in_gv);
204 PL_last_in_gv = (GV*)(*PL_stack_sp--);
207 return do_readline();
212 djSP; tryAMAGICbinSET(eq,0);
215 SETs(boolSV(TOPn == value));
223 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
224 Perl_croak(aTHX_ PL_no_modify);
225 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
226 SvIVX(TOPs) != IV_MAX)
229 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
244 RETURNOP(cLOGOP->op_other);
250 djSP; dATARGET; tryAMAGICbin(add,opASSIGN);
253 SETn( left + right );
261 AV *av = GvAV((GV*)cSVOP->op_sv);
262 U32 lval = PL_op->op_flags & OPf_MOD;
263 SV** svp = av_fetch(av, PL_op->op_private, lval);
264 SV *sv = (svp ? *svp : &PL_sv_undef);
266 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
267 sv = sv_mortalcopy(sv);
274 djSP; dMARK; dTARGET;
276 do_join(TARG, *MARK, MARK, SP);
287 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
288 * will be enough to hold an OP*.
290 SV* sv = sv_newmortal();
291 sv_upgrade(sv, SVt_PVLV);
293 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
301 /* Oversized hot code. */
305 djSP; dMARK; dORIGMARK;
312 if (PL_op->op_flags & OPf_STACKED)
316 if (mg = SvTIED_mg((SV*)gv, 'q')) {
317 if (MARK == ORIGMARK) {
318 /* If using default handle then we need to make space to
319 * pass object as 1st arg, so move other args up ...
323 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
327 *MARK = SvTIED_obj((SV*)gv, mg);
330 call_method("PRINT", G_SCALAR);
338 if (!(io = GvIO(gv))) {
339 if (ckWARN(WARN_UNOPENED)) {
340 SV* sv = sv_newmortal();
341 gv_efullname3(sv, gv, Nullch);
342 Perl_warner(aTHX_ WARN_UNOPENED, "Filehandle %s never opened",
345 SETERRNO(EBADF,RMS$_IFI);
348 else if (!(fp = IoOFP(io))) {
349 if (ckWARN2(WARN_CLOSED, WARN_IO)) {
350 SV* sv = sv_newmortal();
351 gv_efullname3(sv, gv, Nullch);
353 Perl_warner(aTHX_ WARN_IO,
354 "Filehandle %s opened only for input",
356 else if (ckWARN(WARN_CLOSED))
357 Perl_warner(aTHX_ WARN_CLOSED,
358 "print on closed filehandle %s", SvPV(sv,n_a));
360 SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
367 if (!do_print(*MARK, fp))
371 if (PerlIO_write(fp, PL_ofs, PL_ofslen) == 0 || PerlIO_error(fp)) {
380 if (!do_print(*MARK, fp))
389 if (PerlIO_write(fp, PL_ors, PL_orslen) == 0 || PerlIO_error(fp))
392 if (IoFLAGS(io) & IOf_FLUSH)
393 if (PerlIO_flush(fp) == EOF)
414 tryAMAGICunDEREF(to_av);
417 if (SvTYPE(av) != SVt_PVAV)
418 DIE(aTHX_ "Not an ARRAY reference");
419 if (PL_op->op_flags & OPf_REF) {
425 if (SvTYPE(sv) == SVt_PVAV) {
427 if (PL_op->op_flags & OPf_REF) {
435 if (SvTYPE(sv) != SVt_PVGV) {
439 if (SvGMAGICAL(sv)) {
445 if (PL_op->op_flags & OPf_REF ||
446 PL_op->op_private & HINT_STRICT_REFS)
447 DIE(aTHX_ PL_no_usym, "an ARRAY");
448 if (ckWARN(WARN_UNINITIALIZED))
449 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
450 if (GIMME == G_ARRAY) {
457 if ((PL_op->op_flags & OPf_SPECIAL) &&
458 !(PL_op->op_flags & OPf_MOD))
460 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVAV);
465 if (PL_op->op_private & HINT_STRICT_REFS)
466 DIE(aTHX_ PL_no_symref, sym, "an ARRAY");
467 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV);
474 if (PL_op->op_private & OPpLVAL_INTRO)
476 if (PL_op->op_flags & OPf_REF) {
483 if (GIMME == G_ARRAY) {
484 I32 maxarg = AvFILL(av) + 1;
485 (void)POPs; /* XXXX May be optimized away? */
487 if (SvRMAGICAL(av)) {
489 for (i=0; i < maxarg; i++) {
490 SV **svp = av_fetch(av, i, FALSE);
491 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
495 Copy(AvARRAY(av), SP+1, maxarg, SV*);
501 I32 maxarg = AvFILL(av) + 1;
514 tryAMAGICunDEREF(to_hv);
517 if (SvTYPE(hv) != SVt_PVHV && SvTYPE(hv) != SVt_PVAV)
518 DIE(aTHX_ "Not a HASH reference");
519 if (PL_op->op_flags & OPf_REF) {
525 if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) {
527 if (PL_op->op_flags & OPf_REF) {
535 if (SvTYPE(sv) != SVt_PVGV) {
539 if (SvGMAGICAL(sv)) {
545 if (PL_op->op_flags & OPf_REF ||
546 PL_op->op_private & HINT_STRICT_REFS)
547 DIE(aTHX_ PL_no_usym, "a HASH");
548 if (ckWARN(WARN_UNINITIALIZED))
549 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
550 if (GIMME == G_ARRAY) {
557 if ((PL_op->op_flags & OPf_SPECIAL) &&
558 !(PL_op->op_flags & OPf_MOD))
560 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVHV);
565 if (PL_op->op_private & HINT_STRICT_REFS)
566 DIE(aTHX_ PL_no_symref, sym, "a HASH");
567 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV);
574 if (PL_op->op_private & OPpLVAL_INTRO)
576 if (PL_op->op_flags & OPf_REF) {
583 if (GIMME == G_ARRAY) { /* array wanted */
584 *PL_stack_sp = (SV*)hv;
589 if (SvTYPE(hv) == SVt_PVAV)
590 hv = avhv_keys((AV*)hv);
592 Perl_sv_setpvf(aTHX_ TARG, "%ld/%ld",
593 (long)HvFILL(hv), (long)HvMAX(hv) + 1);
605 SV **lastlelem = PL_stack_sp;
606 SV **lastrelem = PL_stack_base + POPMARK;
607 SV **firstrelem = PL_stack_base + POPMARK + 1;
608 SV **firstlelem = lastrelem + 1;
621 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
623 /* If there's a common identifier on both sides we have to take
624 * special care that assigning the identifier on the left doesn't
625 * clobber a value on the right that's used later in the list.
627 if (PL_op->op_private & OPpASSIGN_COMMON) {
628 EXTEND_MORTAL(lastrelem - firstrelem + 1);
629 for (relem = firstrelem; relem <= lastrelem; relem++) {
632 TAINT_NOT; /* Each item is independent */
633 *relem = sv_mortalcopy(sv);
642 while (lelem <= lastlelem) {
643 TAINT_NOT; /* Each item stands on its own, taintwise. */
645 switch (SvTYPE(sv)) {
648 magic = SvMAGICAL(ary) != 0;
651 av_extend(ary, lastrelem - relem);
653 while (relem <= lastrelem) { /* gobble up all the rest */
659 didstore = av_store(ary,i++,sv);
673 magic = SvMAGICAL(hash) != 0;
676 while (relem < lastrelem) { /* gobble up all the rest */
681 sv = &PL_sv_no, relem++;
682 tmpstr = NEWSV(29,0);
684 sv_setsv(tmpstr,*relem); /* value */
686 didstore = hv_store_ent(hash,sv,tmpstr,0);
688 if (SvSMAGICAL(tmpstr))
695 if (relem == lastrelem) {
698 if (ckWARN(WARN_UNSAFE)) {
699 if (relem == firstrelem &&
701 ( SvTYPE(SvRV(*relem)) == SVt_PVAV ||
702 SvTYPE(SvRV(*relem)) == SVt_PVHV ) )
703 Perl_warner(aTHX_ WARN_UNSAFE, "Reference found where even-sized list expected");
705 Perl_warner(aTHX_ WARN_UNSAFE, "Odd number of elements in hash assignment");
707 tmpstr = NEWSV(29,0);
708 didstore = hv_store_ent(hash,*relem,tmpstr,0);
710 if (SvSMAGICAL(tmpstr))
722 if (SvIMMORTAL(sv)) {
723 if (relem <= lastrelem)
727 if (relem <= lastrelem) {
728 sv_setsv(sv, *relem);
732 sv_setsv(sv, &PL_sv_undef);
737 if (PL_delaymagic & ~DM_DELAY) {
738 if (PL_delaymagic & DM_UID) {
740 (void)setresuid(PL_uid,PL_euid,(Uid_t)-1);
743 (void)setreuid(PL_uid,PL_euid);
746 if ((PL_delaymagic & DM_UID) == DM_RUID) {
747 (void)setruid(PL_uid);
748 PL_delaymagic &= ~DM_RUID;
750 # endif /* HAS_SETRUID */
752 if ((PL_delaymagic & DM_UID) == DM_EUID) {
753 (void)seteuid(PL_uid);
754 PL_delaymagic &= ~DM_EUID;
756 # endif /* HAS_SETEUID */
757 if (PL_delaymagic & DM_UID) {
758 if (PL_uid != PL_euid)
759 DIE(aTHX_ "No setreuid available");
760 (void)PerlProc_setuid(PL_uid);
762 # endif /* HAS_SETREUID */
763 #endif /* HAS_SETRESUID */
764 PL_uid = (int)PerlProc_getuid();
765 PL_euid = (int)PerlProc_geteuid();
767 if (PL_delaymagic & DM_GID) {
769 (void)setresgid(PL_gid,PL_egid,(Gid_t)-1);
772 (void)setregid(PL_gid,PL_egid);
775 if ((PL_delaymagic & DM_GID) == DM_RGID) {
776 (void)setrgid(PL_gid);
777 PL_delaymagic &= ~DM_RGID;
779 # endif /* HAS_SETRGID */
781 if ((PL_delaymagic & DM_GID) == DM_EGID) {
782 (void)setegid(PL_gid);
783 PL_delaymagic &= ~DM_EGID;
785 # endif /* HAS_SETEGID */
786 if (PL_delaymagic & DM_GID) {
787 if (PL_gid != PL_egid)
788 DIE(aTHX_ "No setregid available");
789 (void)PerlProc_setgid(PL_gid);
791 # endif /* HAS_SETREGID */
792 #endif /* HAS_SETRESGID */
793 PL_gid = (int)PerlProc_getgid();
794 PL_egid = (int)PerlProc_getegid();
796 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
803 else if (gimme == G_SCALAR) {
806 SETi(lastrelem - firstrelem + 1);
812 SP = firstrelem + (lastlelem - firstlelem);
813 lelem = firstlelem + (relem - firstrelem);
815 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
823 register PMOP *pm = cPMOP;
824 SV *rv = sv_newmortal();
825 SV *sv = newSVrv(rv, "Regexp");
826 sv_magic(sv,(SV*)ReREFCNT_inc(pm->op_pmregexp),'r',0,0);
833 register PMOP *pm = cPMOP;
838 I32 r_flags = REXEC_CHECKED;
839 char *truebase; /* Start of string */
840 register REGEXP *rx = pm->op_pmregexp;
845 I32 oldsave = PL_savestack_ix;
846 I32 update_minmatch = 1;
849 if (PL_op->op_flags & OPf_STACKED)
855 PUTBACK; /* EVAL blocks need stack_sp. */
859 DIE(aTHX_ "panic: do_match");
860 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
861 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
864 if (pm->op_pmdynflags & PMdf_USED) {
866 if (gimme == G_ARRAY)
871 if (!rx->prelen && PL_curpm) {
873 rx = pm->op_pmregexp;
875 if (rx->minlen > len) goto failure;
879 /* XXXX What part of this is needed with true \G-support? */
880 if (global = pm->op_pmflags & PMf_GLOBAL) {
882 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
883 MAGIC* mg = mg_find(TARG, 'g');
884 if (mg && mg->mg_len >= 0) {
885 if (!(rx->reganch & ROPT_GPOS_SEEN))
886 rx->endp[0] = rx->startp[0] = mg->mg_len;
887 else if (rx->reganch & ROPT_ANCH_GPOS) {
888 r_flags |= REXEC_IGNOREPOS;
889 rx->endp[0] = rx->startp[0] = mg->mg_len;
891 minmatch = (mg->mg_flags & MGf_MINMATCH);
896 if ((gimme != G_ARRAY && !global && rx->nparens)
897 || SvTEMP(TARG) || PL_sawampersand)
898 r_flags |= REXEC_COPY_STR;
900 r_flags |= REXEC_SCREAM;
902 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
903 SAVEINT(PL_multiline);
904 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
908 if (global && rx->startp[0] != -1) {
909 t = s = rx->endp[0] + truebase;
910 if ((s + rx->minlen) > strend)
912 if (update_minmatch++)
913 minmatch = had_zerolen;
915 if (rx->reganch & RE_USE_INTUIT) {
916 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
920 if ( (rx->reganch & ROPT_CHECK_ALL)
922 && ((rx->reganch & ROPT_NOSCAN)
923 || !((rx->reganch & RE_INTUIT_TAIL)
924 && (r_flags & REXEC_SCREAM))))
927 if (CALLREGEXEC(aTHX_ rx, s, strend, truebase, minmatch, TARG, NULL, r_flags))
930 if (pm->op_pmflags & PMf_ONCE)
931 pm->op_pmdynflags |= PMdf_USED;
940 RX_MATCH_TAINTED_on(rx);
941 TAINT_IF(RX_MATCH_TAINTED(rx));
942 if (gimme == G_ARRAY) {
946 if (global && !iters)
950 SPAGAIN; /* EVAL blocks could move the stack. */
951 EXTEND(SP, iters + i);
952 EXTEND_MORTAL(iters + i);
953 for (i = !i; i <= iters; i++) {
954 PUSHs(sv_newmortal());
956 if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
957 len = rx->endp[i] - rx->startp[i];
958 s = rx->startp[i] + truebase;
959 sv_setpvn(*SP, s, len);
963 had_zerolen = (rx->startp[0] != -1
964 && rx->startp[0] == rx->endp[0]);
965 PUTBACK; /* EVAL blocks may use stack */
966 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
971 LEAVE_SCOPE(oldsave);
977 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
978 mg = mg_find(TARG, 'g');
980 sv_magic(TARG, (SV*)0, 'g', Nullch, 0);
981 mg = mg_find(TARG, 'g');
983 if (rx->startp[0] != -1) {
984 mg->mg_len = rx->endp[0];
985 if (rx->startp[0] == rx->endp[0])
986 mg->mg_flags |= MGf_MINMATCH;
988 mg->mg_flags &= ~MGf_MINMATCH;
991 LEAVE_SCOPE(oldsave);
995 yup: /* Confirmed by INTUIT */
997 RX_MATCH_TAINTED_on(rx);
998 TAINT_IF(RX_MATCH_TAINTED(rx));
1000 if (pm->op_pmflags & PMf_ONCE)
1001 pm->op_pmdynflags |= PMdf_USED;
1002 if (RX_MATCH_COPIED(rx))
1003 Safefree(rx->subbeg);
1004 RX_MATCH_COPIED_off(rx);
1005 rx->subbeg = Nullch;
1007 rx->subbeg = truebase;
1008 rx->startp[0] = s - truebase;
1009 rx->endp[0] = s - truebase + rx->minlen;
1010 rx->sublen = strend - truebase;
1013 if (PL_sawampersand) {
1016 rx->subbeg = savepvn(t, strend - t);
1017 rx->sublen = strend - t;
1018 RX_MATCH_COPIED_on(rx);
1019 off = rx->startp[0] = s - t;
1020 rx->endp[0] = off + rx->minlen;
1022 else { /* startp/endp are used by @- @+. */
1023 rx->startp[0] = s - truebase;
1024 rx->endp[0] = s - truebase + rx->minlen;
1026 LEAVE_SCOPE(oldsave);
1031 if (global && !(pm->op_pmflags & PMf_CONTINUE)) {
1032 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1033 MAGIC* mg = mg_find(TARG, 'g');
1038 LEAVE_SCOPE(oldsave);
1039 if (gimme == G_ARRAY)
1045 Perl_do_readline(pTHX)
1047 dSP; dTARGETSTACKED;
1052 register IO *io = GvIO(PL_last_in_gv);
1053 register I32 type = PL_op->op_type;
1054 I32 gimme = GIMME_V;
1057 if (mg = SvTIED_mg((SV*)PL_last_in_gv, 'q')) {
1059 XPUSHs(SvTIED_obj((SV*)PL_last_in_gv, mg));
1062 call_method("READLINE", gimme);
1065 if (gimme == G_SCALAR)
1066 SvSetMagicSV_nosteal(TARG, TOPs);
1073 if (IoFLAGS(io) & IOf_ARGV) {
1074 if (IoFLAGS(io) & IOf_START) {
1075 IoFLAGS(io) &= ~IOf_START;
1077 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1078 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp);
1079 sv_setpvn(GvSV(PL_last_in_gv), "-", 1);
1080 SvSETMAGIC(GvSV(PL_last_in_gv));
1085 fp = nextargv(PL_last_in_gv);
1086 if (!fp) { /* Note: fp != IoIFP(io) */
1087 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1088 IoFLAGS(io) |= IOf_START;
1091 else if (type == OP_GLOB) {
1092 SV *tmpcmd = NEWSV(55, 0);
1096 #ifdef VMS /* expand the wildcards right here, rather than opening a pipe, */
1097 /* since spawning off a process is a real performance hit */
1099 #include <descrip.h>
1100 #include <lib$routines.h>
1103 char rslt[NAM$C_MAXRSS+1+sizeof(unsigned short int)] = {'\0','\0'};
1104 char vmsspec[NAM$C_MAXRSS+1];
1105 char *rstr = rslt + sizeof(unsigned short int), *begin, *end, *cp;
1106 char tmpfnam[L_tmpnam] = "SYS$SCRATCH:";
1107 $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
1110 struct dsc$descriptor_s wilddsc
1111 = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1112 struct dsc$descriptor_vs rsdsc
1113 = {sizeof rslt, DSC$K_DTYPE_VT, DSC$K_CLASS_VS, rslt};
1114 unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0, hasver = 0, isunix = 0;
1116 /* We could find out if there's an explicit dev/dir or version
1117 by peeking into lib$find_file's internal context at
1118 ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
1119 but that's unsupported, so I don't want to do it now and
1120 have it bite someone in the future. */
1121 strcat(tmpfnam,PerlLIO_tmpnam(NULL));
1122 cp = SvPV(tmpglob,i);
1124 if (cp[i] == ';') hasver = 1;
1126 if (sts) hasver = 1;
1130 hasdir = isunix = 1;
1133 if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
1138 if ((tmpfp = PerlIO_open(tmpfnam,"w+","fop=dlt")) != NULL) {
1140 if (!PerlLIO_stat(SvPVX(tmpglob),&st) && S_ISDIR(st.st_mode))
1141 ok = ((wilddsc.dsc$a_pointer = tovmspath(SvPVX(tmpglob),vmsspec)) != NULL);
1142 else ok = ((wilddsc.dsc$a_pointer = tovmsspec(SvPVX(tmpglob),vmsspec)) != NULL);
1143 if (ok) wilddsc.dsc$w_length = (unsigned short int) strlen(wilddsc.dsc$a_pointer);
1144 while (ok && ((sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
1145 &dfltdsc,NULL,NULL,NULL))&1)) {
1146 end = rstr + (unsigned long int) *rslt;
1147 if (!hasver) while (*end != ';') end--;
1148 *(end++) = '\n'; *end = '\0';
1149 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
1151 if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
1156 while (*(--begin) != ']' && *begin != '>') ;
1159 ok = (PerlIO_puts(tmpfp,begin) != EOF);
1161 if (cxt) (void)lib$find_file_end(&cxt);
1162 if (ok && sts != RMS$_NMF &&
1163 sts != RMS$_DNF && sts != RMS$_FNF) ok = 0;
1166 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
1168 PerlIO_close(tmpfp);
1172 PerlIO_rewind(tmpfp);
1174 IoIFP(io) = fp = tmpfp;
1175 IoFLAGS(io) &= ~IOf_UNTAINT; /* maybe redundant */
1182 sv_setpv(tmpcmd, "for a in ");
1183 sv_catsv(tmpcmd, tmpglob);
1184 sv_catpv(tmpcmd, "; do echo \"$a\\0\\c\"; done |");
1187 sv_setpv(tmpcmd, "/dev/dosglob/"); /* File System Extension */
1188 sv_catsv(tmpcmd, tmpglob);
1190 sv_setpv(tmpcmd, "perlglob ");
1191 sv_catsv(tmpcmd, tmpglob);
1192 sv_catpv(tmpcmd, " |");
1197 sv_setpvn(tmpcmd, PL_cshname, PL_cshlen);
1198 sv_catpv(tmpcmd, " -cf 'set nonomatch; glob ");
1199 sv_catsv(tmpcmd, tmpglob);
1200 sv_catpv(tmpcmd, "' 2>/dev/null |");
1202 sv_setpv(tmpcmd, "echo ");
1203 sv_catsv(tmpcmd, tmpglob);
1205 sv_catpv(tmpcmd, "|tr -s ' \t\f\r' '\\012\\012\\012\\012'|");
1207 sv_catpv(tmpcmd, "|tr -s ' \t\f\r' '\\n\\n\\n\\n'|");
1210 #endif /* !DOSISH */
1211 (void)do_open(PL_last_in_gv, SvPVX(tmpcmd), SvCUR(tmpcmd),
1212 FALSE, O_RDONLY, 0, Nullfp);
1218 else if (type == OP_GLOB)
1220 else if (ckWARN(WARN_IO) /* stdout/stderr or other write fh */
1221 && (IoTYPE(io) == '>' || fp == PerlIO_stdout()
1222 || fp == PerlIO_stderr()))
1224 SV* sv = sv_newmortal();
1225 gv_efullname3(sv, PL_last_in_gv, Nullch);
1226 Perl_warner(aTHX_ WARN_IO, "Filehandle %s opened only for output",
1231 if (ckWARN(WARN_CLOSED) && io && !(IoFLAGS(io) & IOf_START)) {
1232 if (type == OP_GLOB)
1233 Perl_warner(aTHX_ WARN_CLOSED,
1234 "glob failed (can't start child: %s)",
1237 SV* sv = sv_newmortal();
1238 gv_efullname3(sv, PL_last_in_gv, Nullch);
1239 Perl_warner(aTHX_ WARN_CLOSED,
1240 "Read on closed filehandle %s",
1244 if (gimme == G_SCALAR) {
1245 (void)SvOK_off(TARG);
1251 if (gimme == G_SCALAR) {
1255 (void)SvUPGRADE(sv, SVt_PV);
1256 tmplen = SvLEN(sv); /* remember if already alloced */
1258 Sv_Grow(sv, 80); /* try short-buffering it */
1259 if (type == OP_RCATLINE)
1265 sv = sv_2mortal(NEWSV(57, 80));
1269 /* flip-flop EOF state for a snarfed empty file */
1270 #define SNARF_EOF(gimme,rs,io,sv) \
1271 ((gimme != G_SCALAR || SvCUR(sv) \
1272 || (IoFLAGS(io) & IOf_NOLINE) || IoLINES(io) || !RsSNARF(rs)) \
1273 ? ((IoFLAGS(io) &= ~IOf_NOLINE), TRUE) \
1274 : ((IoFLAGS(io) |= IOf_NOLINE), FALSE))
1277 if (!sv_gets(sv, fp, offset)
1278 && (type == OP_GLOB || SNARF_EOF(gimme, PL_rs, io, sv)))
1280 PerlIO_clearerr(fp);
1281 if (IoFLAGS(io) & IOf_ARGV) {
1282 fp = nextargv(PL_last_in_gv);
1285 (void)do_close(PL_last_in_gv, FALSE);
1286 IoFLAGS(io) |= IOf_START;
1288 else if (type == OP_GLOB) {
1289 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_CLOSED)) {
1290 Perl_warner(aTHX_ WARN_CLOSED,
1291 "glob failed (child exited with status %d%s)",
1292 STATUS_CURRENT >> 8,
1293 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1296 if (gimme == G_SCALAR) {
1297 (void)SvOK_off(TARG);
1302 /* This should not be marked tainted if the fp is marked clean */
1303 if (!(IoFLAGS(io) & IOf_UNTAINT)) {
1310 if (type == OP_GLOB) {
1313 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1314 tmps = SvEND(sv) - 1;
1315 if (*tmps == *SvPVX(PL_rs)) {
1320 for (tmps = SvPVX(sv); *tmps; tmps++)
1321 if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
1322 strchr("$&*(){}[]'\";\\|?<>~`", *tmps))
1324 if (*tmps && PerlLIO_lstat(SvPVX(sv), &PL_statbuf) < 0) {
1325 (void)POPs; /* Unmatched wildcard? Chuck it... */
1329 if (gimme == G_ARRAY) {
1330 if (SvLEN(sv) - SvCUR(sv) > 20) {
1331 SvLEN_set(sv, SvCUR(sv)+1);
1332 Renew(SvPVX(sv), SvLEN(sv), char);
1334 sv = sv_2mortal(NEWSV(58, 80));
1337 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1338 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1342 SvLEN_set(sv, SvCUR(sv)+40); /* allow some slop */
1343 Renew(SvPVX(sv), SvLEN(sv), char);
1352 register PERL_CONTEXT *cx;
1353 I32 gimme = OP_GIMME(PL_op, -1);
1356 if (cxstack_ix >= 0)
1357 gimme = cxstack[cxstack_ix].blk_gimme;
1365 PUSHBLOCK(cx, CXt_BLOCK, SP);
1377 U32 lval = PL_op->op_flags & OPf_MOD;
1378 U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1381 if (SvTYPE(hv) == SVt_PVHV) {
1382 he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
1383 svp = he ? &HeVAL(he) : 0;
1385 else if (SvTYPE(hv) == SVt_PVAV) {
1386 if (PL_op->op_private & OPpLVAL_INTRO)
1387 DIE(aTHX_ "Can't localize pseudo-hash element");
1388 svp = avhv_fetch_ent((AV*)hv, keysv, lval && !defer, 0);
1394 if (!svp || *svp == &PL_sv_undef) {
1399 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
1401 lv = sv_newmortal();
1402 sv_upgrade(lv, SVt_PVLV);
1404 sv_magic(lv, key2 = newSVsv(keysv), 'y', Nullch, 0);
1405 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1406 LvTARG(lv) = SvREFCNT_inc(hv);
1411 if (PL_op->op_private & OPpLVAL_INTRO) {
1412 if (HvNAME(hv) && isGV(*svp))
1413 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1415 save_helem(hv, keysv, svp);
1417 else if (PL_op->op_private & OPpDEREF)
1418 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1420 sv = (svp ? *svp : &PL_sv_undef);
1421 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1422 * Pushing the magical RHS on to the stack is useless, since
1423 * that magic is soon destined to be misled by the local(),
1424 * and thus the later pp_sassign() will fail to mg_get() the
1425 * old value. This should also cure problems with delayed
1426 * mg_get()s. GSAR 98-07-03 */
1427 if (!lval && SvGMAGICAL(sv))
1428 sv = sv_mortalcopy(sv);
1436 register PERL_CONTEXT *cx;
1442 if (PL_op->op_flags & OPf_SPECIAL) {
1443 cx = &cxstack[cxstack_ix];
1444 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1449 gimme = OP_GIMME(PL_op, -1);
1451 if (cxstack_ix >= 0)
1452 gimme = cxstack[cxstack_ix].blk_gimme;
1458 if (gimme == G_VOID)
1460 else if (gimme == G_SCALAR) {
1463 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1466 *MARK = sv_mortalcopy(TOPs);
1469 *MARK = &PL_sv_undef;
1473 else if (gimme == G_ARRAY) {
1474 /* in case LEAVE wipes old return values */
1475 for (mark = newsp + 1; mark <= SP; mark++) {
1476 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1477 *mark = sv_mortalcopy(*mark);
1478 TAINT_NOT; /* Each item is independent */
1482 PL_curpm = newpm; /* Don't pop $1 et al till now */
1492 register PERL_CONTEXT *cx;
1497 cx = &cxstack[cxstack_ix];
1498 if (CxTYPE(cx) != CXt_LOOP)
1499 DIE(aTHX_ "panic: pp_iter");
1501 av = cx->blk_loop.iterary;
1502 if (SvTYPE(av) != SVt_PVAV) {
1503 /* iterate ($min .. $max) */
1504 if (cx->blk_loop.iterlval) {
1505 /* string increment */
1506 register SV* cur = cx->blk_loop.iterlval;
1508 char *max = SvPV((SV*)av, maxlen);
1509 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1510 #ifndef USE_THREADS /* don't risk potential race */
1511 if (SvREFCNT(*cx->blk_loop.itervar) == 1
1512 && !SvMAGICAL(*cx->blk_loop.itervar))
1514 /* safe to reuse old SV */
1515 sv_setsv(*cx->blk_loop.itervar, cur);
1520 /* we need a fresh SV every time so that loop body sees a
1521 * completely new SV for closures/references to work as
1523 SvREFCNT_dec(*cx->blk_loop.itervar);
1524 *cx->blk_loop.itervar = newSVsv(cur);
1526 if (strEQ(SvPVX(cur), max))
1527 sv_setiv(cur, 0); /* terminate next time */
1534 /* integer increment */
1535 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1538 #ifndef USE_THREADS /* don't risk potential race */
1539 if (SvREFCNT(*cx->blk_loop.itervar) == 1
1540 && !SvMAGICAL(*cx->blk_loop.itervar))
1542 /* safe to reuse old SV */
1543 sv_setiv(*cx->blk_loop.itervar, cx->blk_loop.iterix++);
1548 /* we need a fresh SV every time so that loop body sees a
1549 * completely new SV for closures/references to work as they
1551 SvREFCNT_dec(*cx->blk_loop.itervar);
1552 *cx->blk_loop.itervar = newSViv(cx->blk_loop.iterix++);
1558 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp : AvFILL(av)))
1561 SvREFCNT_dec(*cx->blk_loop.itervar);
1563 if (sv = (SvMAGICAL(av))
1564 ? *av_fetch(av, ++cx->blk_loop.iterix, FALSE)
1565 : AvARRAY(av)[++cx->blk_loop.iterix])
1569 if (av != PL_curstack && SvIMMORTAL(sv)) {
1570 SV *lv = cx->blk_loop.iterlval;
1571 if (lv && SvREFCNT(lv) > 1) {
1576 SvREFCNT_dec(LvTARG(lv));
1578 lv = cx->blk_loop.iterlval = NEWSV(26, 0);
1579 sv_upgrade(lv, SVt_PVLV);
1581 sv_magic(lv, Nullsv, 'y', Nullch, 0);
1583 LvTARG(lv) = SvREFCNT_inc(av);
1584 LvTARGOFF(lv) = cx->blk_loop.iterix;
1585 LvTARGLEN(lv) = (UV) -1;
1589 *cx->blk_loop.itervar = SvREFCNT_inc(sv);
1596 register PMOP *pm = cPMOP;
1612 register REGEXP *rx = pm->op_pmregexp;
1614 int force_on_match = 0;
1615 I32 oldsave = PL_savestack_ix;
1616 I32 update_minmatch = 1;
1618 /* known replacement string? */
1619 dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
1620 if (PL_op->op_flags & OPf_STACKED)
1626 if (SvREADONLY(TARG)
1627 || (SvTYPE(TARG) > SVt_PVLV
1628 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG))))
1629 Perl_croak(aTHX_ PL_no_modify);
1632 s = SvPV(TARG, len);
1633 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
1635 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1636 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1643 DIE(aTHX_ "panic: do_subst");
1646 maxiters = 2*(strend - s) + 10; /* We can match twice at each
1647 position, once with zero-length,
1648 second time with non-zero. */
1650 if (!rx->prelen && PL_curpm) {
1652 rx = pm->op_pmregexp;
1654 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
1655 ? REXEC_COPY_STR : 0;
1657 r_flags |= REXEC_SCREAM;
1658 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
1659 SAVEINT(PL_multiline);
1660 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
1663 if (rx->reganch & RE_USE_INTUIT) {
1664 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1668 /* How to do it in subst? */
1669 /* if ( (rx->reganch & ROPT_CHECK_ALL)
1671 && ((rx->reganch & ROPT_NOSCAN)
1672 || !((rx->reganch & RE_INTUIT_TAIL)
1673 && (r_flags & REXEC_SCREAM))))
1678 /* only replace once? */
1679 once = !(rpm->op_pmflags & PMf_GLOBAL);
1681 /* known replacement string? */
1682 c = dstr ? SvPV(dstr, clen) : Nullch;
1684 /* can do inplace substitution? */
1685 if (c && clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
1686 && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)) {
1687 if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
1688 r_flags | REXEC_CHECKED))
1692 LEAVE_SCOPE(oldsave);
1695 if (force_on_match) {
1697 s = SvPV_force(TARG, len);
1702 SvSCREAM_off(TARG); /* disable possible screamer */
1704 rxtainted |= RX_MATCH_TAINTED(rx);
1705 m = orig + rx->startp[0];
1706 d = orig + rx->endp[0];
1708 if (m - s > strend - d) { /* faster to shorten from end */
1710 Copy(c, m, clen, char);
1715 Move(d, m, i, char);
1719 SvCUR_set(TARG, m - s);
1722 else if (i = m - s) { /* faster from front */
1730 Copy(c, m, clen, char);
1735 Copy(c, d, clen, char);
1740 TAINT_IF(rxtainted & 1);
1746 if (iters++ > maxiters)
1747 DIE(aTHX_ "Substitution loop");
1748 rxtainted |= RX_MATCH_TAINTED(rx);
1749 m = rx->startp[0] + orig;
1753 Move(s, d, i, char);
1757 Copy(c, d, clen, char);
1760 s = rx->endp[0] + orig;
1761 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
1763 /* don't match same null twice */
1764 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
1767 SvCUR_set(TARG, d - SvPVX(TARG) + i);
1768 Move(s, d, i+1, char); /* include the NUL */
1770 TAINT_IF(rxtainted & 1);
1772 PUSHs(sv_2mortal(newSViv((I32)iters)));
1774 (void)SvPOK_only(TARG);
1775 TAINT_IF(rxtainted);
1776 if (SvSMAGICAL(TARG)) {
1782 LEAVE_SCOPE(oldsave);
1786 if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
1787 r_flags | REXEC_CHECKED))
1789 if (force_on_match) {
1791 s = SvPV_force(TARG, len);
1794 rxtainted |= RX_MATCH_TAINTED(rx);
1795 dstr = NEWSV(25, len);
1796 sv_setpvn(dstr, m, s-m);
1799 register PERL_CONTEXT *cx;
1802 RETURNOP(cPMOP->op_pmreplroot);
1804 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1806 if (iters++ > maxiters)
1807 DIE(aTHX_ "Substitution loop");
1808 rxtainted |= RX_MATCH_TAINTED(rx);
1809 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
1814 strend = s + (strend - m);
1816 m = rx->startp[0] + orig;
1817 sv_catpvn(dstr, s, m-s);
1818 s = rx->endp[0] + orig;
1820 sv_catpvn(dstr, c, clen);
1823 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m, TARG, NULL, r_flags));
1824 sv_catpvn(dstr, s, strend - s);
1826 (void)SvOOK_off(TARG);
1827 Safefree(SvPVX(TARG));
1828 SvPVX(TARG) = SvPVX(dstr);
1829 SvCUR_set(TARG, SvCUR(dstr));
1830 SvLEN_set(TARG, SvLEN(dstr));
1834 TAINT_IF(rxtainted & 1);
1836 PUSHs(sv_2mortal(newSViv((I32)iters)));
1838 (void)SvPOK_only(TARG);
1839 TAINT_IF(rxtainted);
1842 LEAVE_SCOPE(oldsave);
1851 LEAVE_SCOPE(oldsave);
1860 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
1861 ++*PL_markstack_ptr;
1862 LEAVE; /* exit inner scope */
1865 if (PL_stack_base + *PL_markstack_ptr > SP) {
1867 I32 gimme = GIMME_V;
1869 LEAVE; /* exit outer scope */
1870 (void)POPMARK; /* pop src */
1871 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1872 (void)POPMARK; /* pop dst */
1873 SP = PL_stack_base + POPMARK; /* pop original mark */
1874 if (gimme == G_SCALAR) {
1878 else if (gimme == G_ARRAY)
1885 ENTER; /* enter inner scope */
1888 src = PL_stack_base[*PL_markstack_ptr];
1892 RETURNOP(cLOGOP->op_other);
1903 register PERL_CONTEXT *cx;
1904 struct block_sub cxsub;
1907 POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */
1910 if (gimme == G_SCALAR) {
1913 if (cxsub.cv && CvDEPTH(cxsub.cv) > 1) {
1915 *MARK = SvREFCNT_inc(TOPs);
1920 *MARK = sv_mortalcopy(TOPs);
1923 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
1926 *MARK = &PL_sv_undef;
1930 else if (gimme == G_ARRAY) {
1931 for (MARK = newsp + 1; MARK <= SP; MARK++) {
1932 if (!SvTEMP(*MARK)) {
1933 *MARK = sv_mortalcopy(*MARK);
1934 TAINT_NOT; /* Each item is independent */
1940 POPSUB2(); /* Stack values are safe: release CV and @_ ... */
1941 PL_curpm = newpm; /* ... and pop $1 et al */
1944 return pop_return();
1948 S_get_db_sub(pTHX_ SV **svp, CV *cv)
1951 SV *dbsv = GvSV(PL_DBsub);
1953 if (!PERLDB_SUB_NN) {
1957 if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
1958 || strEQ(GvNAME(gv), "END")
1959 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
1960 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
1961 && (gv = (GV*)*svp) ))) {
1962 /* Use GV from the stack as a fallback. */
1963 /* GV is potentially non-unique, or contain different CV. */
1964 sv_setsv(dbsv, newRV((SV*)cv));
1967 gv_efullname3(dbsv, gv, Nullch);
1971 SvUPGRADE(dbsv, SVt_PVIV);
1973 SAVEIV(SvIVX(dbsv));
1974 SvIVX(dbsv) = (IV)cv; /* Do it the quickest way */
1978 PL_curcopdb = PL_curcop;
1979 cv = GvCV(PL_DBsub);
1989 register PERL_CONTEXT *cx;
1991 bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
1994 DIE(aTHX_ "Not a CODE reference");
1995 switch (SvTYPE(sv)) {
2001 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2003 SP = PL_stack_base + POPMARK;
2006 if (SvGMAGICAL(sv)) {
2008 sym = SvPOKp(sv) ? SvPVX(sv) : Nullch;
2011 sym = SvPV(sv, n_a);
2013 DIE(aTHX_ PL_no_usym, "a subroutine");
2014 if (PL_op->op_private & HINT_STRICT_REFS)
2015 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2016 cv = get_cv(sym, TRUE);
2020 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2021 tryAMAGICunDEREF(to_cv);
2024 if (SvTYPE(cv) == SVt_PVCV)
2029 DIE(aTHX_ "Not a CODE reference");
2034 if (!(cv = GvCVu((GV*)sv)))
2035 cv = sv_2cv(sv, &stash, &gv, FALSE);
2048 if (!CvROOT(cv) && !CvXSUB(cv)) {
2052 /* anonymous or undef'd function leaves us no recourse */
2053 if (CvANON(cv) || !(gv = CvGV(cv)))
2054 DIE(aTHX_ "Undefined subroutine called");
2056 /* autoloaded stub? */
2057 if (cv != GvCV(gv)) {
2060 /* should call AUTOLOAD now? */
2063 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2070 sub_name = sv_newmortal();
2071 gv_efullname3(sub_name, gv, Nullch);
2072 DIE(aTHX_ "Undefined subroutine &%s called", SvPVX(sub_name));
2076 DIE(aTHX_ "Not a CODE reference");
2081 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2082 cv = get_db_sub(&sv, cv);
2084 DIE(aTHX_ "No DBsub routine");
2089 * First we need to check if the sub or method requires locking.
2090 * If so, we gain a lock on the CV, the first argument or the
2091 * stash (for static methods), as appropriate. This has to be
2092 * inline because for FAKE_THREADS, COND_WAIT inlines code to
2093 * reschedule by returning a new op.
2095 MUTEX_LOCK(CvMUTEXP(cv));
2096 if (CvFLAGS(cv) & CVf_LOCKED) {
2098 if (CvFLAGS(cv) & CVf_METHOD) {
2099 if (SP > PL_stack_base + TOPMARK)
2100 sv = *(PL_stack_base + TOPMARK + 1);
2102 AV *av = (AV*)PL_curpad[0];
2103 if (hasargs || !av || AvFILLp(av) < 0
2104 || !(sv = AvARRAY(av)[0]))
2106 MUTEX_UNLOCK(CvMUTEXP(cv));
2107 Perl_croak(aTHX_ "no argument for locked method call");
2114 char *stashname = SvPV(sv, len);
2115 sv = (SV*)gv_stashpvn(stashname, len, TRUE);
2121 MUTEX_UNLOCK(CvMUTEXP(cv));
2122 mg = condpair_magic(sv);
2123 MUTEX_LOCK(MgMUTEXP(mg));
2124 if (MgOWNER(mg) == thr)
2125 MUTEX_UNLOCK(MgMUTEXP(mg));
2128 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
2130 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "%p: pp_entersub lock %p\n",
2132 MUTEX_UNLOCK(MgMUTEXP(mg));
2133 SAVEDESTRUCTOR(Perl_unlock_condpair, sv);
2135 MUTEX_LOCK(CvMUTEXP(cv));
2138 * Now we have permission to enter the sub, we must distinguish
2139 * four cases. (0) It's an XSUB (in which case we don't care
2140 * about ownership); (1) it's ours already (and we're recursing);
2141 * (2) it's free (but we may already be using a cached clone);
2142 * (3) another thread owns it. Case (1) is easy: we just use it.
2143 * Case (2) means we look for a clone--if we have one, use it
2144 * otherwise grab ownership of cv. Case (3) means we look for a
2145 * clone (for non-XSUBs) and have to create one if we don't
2147 * Why look for a clone in case (2) when we could just grab
2148 * ownership of cv straight away? Well, we could be recursing,
2149 * i.e. we originally tried to enter cv while another thread
2150 * owned it (hence we used a clone) but it has been freed up
2151 * and we're now recursing into it. It may or may not be "better"
2152 * to use the clone but at least CvDEPTH can be trusted.
2154 if (CvOWNER(cv) == thr || CvXSUB(cv))
2155 MUTEX_UNLOCK(CvMUTEXP(cv));
2157 /* Case (2) or (3) */
2161 * XXX Might it be better to release CvMUTEXP(cv) while we
2162 * do the hv_fetch? We might find someone has pinched it
2163 * when we look again, in which case we would be in case
2164 * (3) instead of (2) so we'd have to clone. Would the fact
2165 * that we released the mutex more quickly make up for this?
2167 if ((svp = hv_fetch(thr->cvcache, (char *)cv, sizeof(cv), FALSE)))
2169 /* We already have a clone to use */
2170 MUTEX_UNLOCK(CvMUTEXP(cv));
2172 DEBUG_S(PerlIO_printf(PerlIO_stderr(),
2173 "entersub: %p already has clone %p:%s\n",
2174 thr, cv, SvPEEK((SV*)cv)));
2177 if (CvDEPTH(cv) == 0)
2178 SAVEDESTRUCTOR(unset_cvowner, (void*) cv);
2181 /* (2) => grab ownership of cv. (3) => make clone */
2185 MUTEX_UNLOCK(CvMUTEXP(cv));
2186 DEBUG_S(PerlIO_printf(PerlIO_stderr(),
2187 "entersub: %p grabbing %p:%s in stash %s\n",
2188 thr, cv, SvPEEK((SV*)cv), CvSTASH(cv) ?
2189 HvNAME(CvSTASH(cv)) : "(none)"));
2191 /* Make a new clone. */
2193 SvREFCNT_inc(cv); /* don't let it vanish from under us */
2194 MUTEX_UNLOCK(CvMUTEXP(cv));
2195 DEBUG_S((PerlIO_printf(PerlIO_stderr(),
2196 "entersub: %p cloning %p:%s\n",
2197 thr, cv, SvPEEK((SV*)cv))));
2199 * We're creating a new clone so there's no race
2200 * between the original MUTEX_UNLOCK and the
2201 * SvREFCNT_inc since no one will be trying to undef
2202 * it out from underneath us. At least, I don't think
2205 clonecv = cv_clone(cv);
2206 SvREFCNT_dec(cv); /* finished with this */
2207 hv_store(thr->cvcache, (char*)cv, sizeof(cv), (SV*)clonecv,0);
2208 CvOWNER(clonecv) = thr;
2212 DEBUG_S(if (CvDEPTH(cv) != 0)
2213 PerlIO_printf(PerlIO_stderr(), "depth %ld != 0\n",
2215 SAVEDESTRUCTOR(unset_cvowner, (void*) cv);
2218 #endif /* USE_THREADS */
2221 #ifdef PERL_XSUB_OLDSTYLE
2222 if (CvOLDSTYLE(cv)) {
2223 I32 (*fp3)(int,int,int);
2225 register I32 items = SP - MARK;
2226 /* We dont worry to copy from @_. */
2231 PL_stack_sp = mark + 1;
2232 fp3 = (I32(*)(int,int,int)))CvXSUB(cv;
2233 items = (*fp3)(CvXSUBANY(cv).any_i32,
2234 MARK - PL_stack_base + 1,
2236 PL_stack_sp = PL_stack_base + items;
2239 #endif /* PERL_XSUB_OLDSTYLE */
2241 I32 markix = TOPMARK;
2246 /* Need to copy @_ to stack. Alternative may be to
2247 * switch stack to @_, and copy return values
2248 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2252 av = (AV*)PL_curpad[0];
2254 av = GvAV(PL_defgv);
2255 #endif /* USE_THREADS */
2256 items = AvFILLp(av) + 1; /* @_ is not tieable */
2259 /* Mark is at the end of the stack. */
2261 Copy(AvARRAY(av), SP + 1, items, SV*);
2266 /* We assume first XSUB in &DB::sub is the called one. */
2268 SAVESPTR(PL_curcop);
2269 PL_curcop = PL_curcopdb;
2272 /* Do we need to open block here? XXXX */
2273 (void)(*CvXSUB(cv))(aTHXo_ cv);
2275 /* Enforce some sanity in scalar context. */
2276 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2277 if (markix > PL_stack_sp - PL_stack_base)
2278 *(PL_stack_base + markix) = &PL_sv_undef;
2280 *(PL_stack_base + markix) = *PL_stack_sp;
2281 PL_stack_sp = PL_stack_base + markix;
2289 register I32 items = SP - MARK;
2290 AV* padlist = CvPADLIST(cv);
2291 SV** svp = AvARRAY(padlist);
2292 push_return(PL_op->op_next);
2293 PUSHBLOCK(cx, CXt_SUB, MARK);
2296 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2297 * that eval'' ops within this sub know the correct lexical space.
2298 * Owing the speed considerations, we choose to search for the cv
2299 * in doeval() instead.
2301 if (CvDEPTH(cv) < 2)
2302 (void)SvREFCNT_inc(cv);
2303 else { /* save temporaries on recursion? */
2304 if (CvDEPTH(cv) > AvFILLp(padlist)) {
2306 AV *newpad = newAV();
2307 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2308 I32 ix = AvFILLp((AV*)svp[1]);
2309 svp = AvARRAY(svp[0]);
2310 for ( ;ix > 0; ix--) {
2311 if (svp[ix] != &PL_sv_undef) {
2312 char *name = SvPVX(svp[ix]);
2313 if ((SvFLAGS(svp[ix]) & SVf_FAKE) /* outer lexical? */
2314 || *name == '&') /* anonymous code? */
2316 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
2318 else { /* our own lexical */
2320 av_store(newpad, ix, sv = (SV*)newAV());
2321 else if (*name == '%')
2322 av_store(newpad, ix, sv = (SV*)newHV());
2324 av_store(newpad, ix, sv = NEWSV(0,0));
2329 av_store(newpad, ix, sv = NEWSV(0,0));
2333 av = newAV(); /* will be @_ */
2335 av_store(newpad, 0, (SV*)av);
2336 AvFLAGS(av) = AVf_REIFY;
2337 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2338 AvFILLp(padlist) = CvDEPTH(cv);
2339 svp = AvARRAY(padlist);
2344 AV* av = (AV*)PL_curpad[0];
2346 items = AvFILLp(av) + 1;
2348 /* Mark is at the end of the stack. */
2350 Copy(AvARRAY(av), SP + 1, items, SV*);
2355 #endif /* USE_THREADS */
2356 SAVESPTR(PL_curpad);
2357 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2360 #endif /* USE_THREADS */
2366 DEBUG_S(PerlIO_printf(PerlIO_stderr(),
2367 "%p entersub preparing @_\n", thr));
2369 av = (AV*)PL_curpad[0];
2375 cx->blk_sub.savearray = GvAV(PL_defgv);
2376 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2377 #endif /* USE_THREADS */
2378 cx->blk_sub.argarray = av;
2381 if (items > AvMAX(av) + 1) {
2383 if (AvARRAY(av) != ary) {
2384 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2385 SvPVX(av) = (char*)ary;
2387 if (items > AvMAX(av) + 1) {
2388 AvMAX(av) = items - 1;
2389 Renew(ary,items,SV*);
2391 SvPVX(av) = (char*)ary;
2394 Copy(MARK,AvARRAY(av),items,SV*);
2395 AvFILLp(av) = items - 1;
2403 /* warning must come *after* we fully set up the context
2404 * stuff so that __WARN__ handlers can safely dounwind()
2407 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2408 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2409 sub_crush_depth(cv);
2411 DEBUG_S(PerlIO_printf(PerlIO_stderr(),
2412 "%p entersub returning %p\n", thr, CvSTART(cv)));
2414 RETURNOP(CvSTART(cv));
2419 Perl_sub_crush_depth(pTHX_ CV *cv)
2422 Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on anonymous subroutine");
2424 SV* tmpstr = sv_newmortal();
2425 gv_efullname3(tmpstr, CvGV(cv), Nullch);
2426 Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on subroutine \"%s\"",
2437 U32 lval = PL_op->op_flags & OPf_MOD;
2438 U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av));
2442 elem -= PL_curcop->cop_arybase;
2443 if (SvTYPE(av) != SVt_PVAV)
2445 svp = av_fetch(av, elem, lval && !defer);
2447 if (!svp || *svp == &PL_sv_undef) {
2450 DIE(aTHX_ PL_no_aelem, elem);
2451 lv = sv_newmortal();
2452 sv_upgrade(lv, SVt_PVLV);
2454 sv_magic(lv, Nullsv, 'y', Nullch, 0);
2455 LvTARG(lv) = SvREFCNT_inc(av);
2456 LvTARGOFF(lv) = elem;
2461 if (PL_op->op_private & OPpLVAL_INTRO)
2462 save_aelem(av, elem, svp);
2463 else if (PL_op->op_private & OPpDEREF)
2464 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2466 sv = (svp ? *svp : &PL_sv_undef);
2467 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2468 sv = sv_mortalcopy(sv);
2474 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2480 Perl_croak(aTHX_ PL_no_modify);
2481 if (SvTYPE(sv) < SVt_RV)
2482 sv_upgrade(sv, SVt_RV);
2483 else if (SvTYPE(sv) >= SVt_PV) {
2484 (void)SvOOK_off(sv);
2485 Safefree(SvPVX(sv));
2486 SvLEN(sv) = SvCUR(sv) = 0;
2490 SvRV(sv) = NEWSV(355,0);
2493 SvRV(sv) = (SV*)newAV();
2496 SvRV(sv) = (SV*)newHV();
2511 if (SvTYPE(rsv) == SVt_PVCV) {
2517 SETs(method_common(sv, Null(U32*)));
2524 SV* sv = cSVOP->op_sv;
2525 U32 hash = SvUVX(sv);
2527 XPUSHs(method_common(sv, &hash));
2532 S_method_common(pTHX_ SV* meth, U32* hashp)
2544 name = SvPV(meth, namelen);
2545 sv = *(PL_stack_base + TOPMARK + 1);
2556 !(packname = SvPV(sv, packlen)) ||
2557 !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
2558 !(ob=(SV*)GvIO(iogv)))
2561 ((*(U8*)packname >= 0xc0 && IN_UTF8)
2562 ? !isIDFIRST_utf8((U8*)packname)
2563 : !isIDFIRST(*packname)
2566 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
2567 SvOK(sv) ? "without a package or object reference"
2568 : "on an undefined value");
2570 stash = gv_stashpvn(packname, packlen, TRUE);
2573 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
2576 if (!ob || !SvOBJECT(ob))
2577 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
2580 stash = SvSTASH(ob);
2583 /* shortcut for simple names */
2585 HE* he = hv_fetch_ent(stash, meth, 0, *hashp);
2587 gv = (GV*)HeVAL(he);
2588 if (isGV(gv) && GvCV(gv) &&
2589 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
2590 return (SV*)GvCV(gv);
2594 gv = gv_fetchmethod(stash, name);
2600 for (p = name; *p; p++) {
2602 sep = p, leaf = p + 1;
2603 else if (*p == ':' && *(p + 1) == ':')
2604 sep = p, leaf = p + 2;
2606 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
2607 packname = HvNAME(sep ? PL_curcop->cop_stash : stash);
2608 packlen = strlen(packname);
2612 packlen = sep - name;
2615 "Can't locate object method \"%s\" via package \"%s\"",
2618 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
2623 unset_cvowner(pTHXo_ void *cvarg)
2625 register CV* cv = (CV *) cvarg;
2628 #endif /* DEBUGGING */
2630 DEBUG_S((PerlIO_printf(PerlIO_stderr(), "%p unsetting CvOWNER of %p:%s\n",
2631 thr, cv, SvPEEK((SV*)cv))));
2632 MUTEX_LOCK(CvMUTEXP(cv));
2633 DEBUG_S(if (CvDEPTH(cv) != 0)
2634 PerlIO_printf(PerlIO_stderr(), "depth %ld != 0\n",
2636 assert(thr == CvOWNER(cv));
2638 MUTEX_UNLOCK(CvMUTEXP(cv));
2641 #endif /* USE_THREADS */