Initial 3-way merge from (5.001m, thr1m, 5.003) plus fixups.
[perl.git] / pp_hot.c
1 /*    pp_hot.c
2  *
3  *    Copyright (c) 1991-1994, Larry Wall
4  *
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.
7  *
8  */
9
10 /*
11  * Then he heard Merry change the note, and up went the Horn-cry of Buckland,
12  * shaking the air.
13  *
14  *            Awake!  Awake!  Fear, Fire, Foes!  Awake!
15  *                     Fire, Foes!  Awake!
16  */
17
18 #include "EXTERN.h"
19 #include "perl.h"
20
21 /* Hot code. */
22
23 #ifdef USE_THREADS
24 static void
25 unset_cvowner(cvarg)
26 void *cvarg;
27 {
28     register CV* cv = (CV *) cvarg;
29 #ifdef DEBUGGING
30     dTHR;
31 #endif /* DEBUGGING */
32
33     DEBUG_L((fprintf(stderr, "0x%lx unsetting CvOWNER of 0x%lx:%s\n",
34                      (unsigned long)thr, (unsigned long)cv, SvPEEK((SV*)cv))));
35     MUTEX_LOCK(CvMUTEXP(cv));
36     assert(CvDEPTH(cv) == 0);
37     assert(thr == CvOWNER(cv));
38     CvOWNER(cv) = 0;
39     if (CvCONDP(cv))
40         COND_SIGNAL(CvCONDP(cv)); /* next please */
41     MUTEX_UNLOCK(CvMUTEXP(cv));
42     SvREFCNT_dec(cv);
43 }
44
45 #if 0
46 void
47 mutex_unlock(m)
48 void *m;
49 {
50 #ifdef DEBUGGING
51     dTHR;
52     DEBUG_L((fprintf(stderr, "0x%lx unlocking mutex 0x%lx\n",
53                          (unsigned long) thr, (unsigned long) m)));
54 #endif /* DEBUGGING */
55     MUTEX_UNLOCK((pthread_mutex_t *) m);
56 }
57 #endif
58 #endif /* USE_THREADS */
59
60 PP(pp_const)
61 {
62     dSP;
63     XPUSHs(cSVOP->op_sv);
64     RETURN;
65 }
66
67 PP(pp_nextstate)
68 {
69     curcop = (COP*)op;
70     TAINT_NOT;          /* Each statement is presumed innocent */
71     stack_sp = stack_base + cxstack[cxstack_ix].blk_oldsp;
72     FREETMPS;
73     return NORMAL;
74 }
75
76 PP(pp_gvsv)
77 {
78     dSP;
79     EXTEND(sp,1);
80     if (op->op_private & OPpLVAL_INTRO)
81         PUSHs(save_scalar(cGVOP->op_gv));
82     else
83         PUSHs(GvSV(cGVOP->op_gv));
84     RETURN;
85 }
86
87 PP(pp_null)
88 {
89     return NORMAL;
90 }
91
92 PP(pp_pushmark)
93 {
94     PUSHMARK(stack_sp);
95     return NORMAL;
96 }
97
98 PP(pp_stringify)
99 {
100     dSP; dTARGET;
101     STRLEN len;
102     char *s;
103     s = SvPV(TOPs,len);
104     sv_setpvn(TARG,s,len);
105     SETTARG;
106     RETURN;
107 }
108
109 PP(pp_gv)
110 {
111     dSP;
112     XPUSHs((SV*)cGVOP->op_gv);
113     RETURN;
114 }
115
116 PP(pp_gelem)
117 {
118     GV *gv;
119     SV *sv;
120     SV *ref;
121     char *elem;
122     dSP;
123
124     sv = POPs;
125     elem = SvPV(sv, na);
126     gv = (GV*)POPs;
127     ref = Nullsv;
128     sv = Nullsv;
129     switch (elem ? *elem : '\0')
130     {
131     case 'A':
132         if (strEQ(elem, "ARRAY"))
133             ref = (SV*)GvAV(gv);
134         break;
135     case 'C':
136         if (strEQ(elem, "CODE"))
137             ref = (SV*)GvCV(gv);
138         break;
139     case 'F':
140         if (strEQ(elem, "FILEHANDLE"))
141             ref = (SV*)GvIOp(gv);
142         break;
143     case 'G':
144         if (strEQ(elem, "GLOB"))
145             ref = (SV*)gv;
146         break;
147     case 'H':
148         if (strEQ(elem, "HASH"))
149             ref = (SV*)GvHV(gv);
150         break;
151     case 'N':
152         if (strEQ(elem, "NAME"))
153             sv = newSVpv(GvNAME(gv), GvNAMELEN(gv));
154         break;
155     case 'P':
156         if (strEQ(elem, "PACKAGE"))
157             sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
158         break;
159     case 'S':
160         if (strEQ(elem, "SCALAR"))
161             ref = GvSV(gv);
162         break;
163     }
164     if (ref)
165         sv = newRV(ref);
166     if (sv)
167         sv_2mortal(sv);
168     else
169         sv = &sv_undef;
170     XPUSHs(sv);
171     RETURN;
172 }
173
174 PP(pp_and)
175 {
176     dSP;
177     if (!SvTRUE(TOPs))
178         RETURN;
179     else {
180         --SP;
181         RETURNOP(cLOGOP->op_other);
182     }
183 }
184
185 PP(pp_sassign)
186 {
187     dSP; dPOPTOPssrl;
188     MAGIC *mg;
189
190     if (op->op_private & OPpASSIGN_BACKWARDS) {
191         SV *temp;
192         temp = left; left = right; right = temp;
193     }
194     if (tainting && tainted && (!SvGMAGICAL(left) || !SvSMAGICAL(left) ||
195                                 !((mg = mg_find(left, 't')) && mg->mg_len & 1)))
196     {
197         TAINT_NOT;
198     }
199     SvSetSV(right, left);
200     SvSETMAGIC(right);
201     SETs(right);
202     RETURN;
203 }
204
205 PP(pp_cond_expr)
206 {
207     dSP;
208     if (SvTRUEx(POPs))
209         RETURNOP(cCONDOP->op_true);
210     else
211         RETURNOP(cCONDOP->op_false);
212 }
213
214 PP(pp_unstack)
215 {
216     I32 oldsave;
217     TAINT_NOT;          /* Each statement is presumed innocent */
218     stack_sp = stack_base + cxstack[cxstack_ix].blk_oldsp;
219     FREETMPS;
220     oldsave = scopestack[scopestack_ix - 1];
221     LEAVE_SCOPE(oldsave);
222     return NORMAL;
223 }
224
225 PP(pp_seq)
226 {
227     dSP; tryAMAGICbinSET(seq,0); 
228     {
229       dPOPTOPssrl;
230       SETs( sv_eq(left, right) ? &sv_yes : &sv_no );
231       RETURN;
232     }
233 }
234
235 PP(pp_concat)
236 {
237   dSP; dATARGET; tryAMAGICbin(concat,opASSIGN);
238   {
239     dPOPTOPssrl;
240     STRLEN len;
241     char *s;
242     if (TARG != left) {
243         s = SvPV(left,len);
244         sv_setpvn(TARG,s,len);
245     }
246     else if (SvGMAGICAL(TARG))
247         mg_get(TARG);
248     else if (!SvOK(TARG)) {
249         s = SvPV_force(TARG, len);
250         sv_setpv(TARG, "");     /* Suppress warning. */
251     }
252     s = SvPV(right,len);
253     sv_catpvn(TARG,s,len);
254     SETTARG;
255     RETURN;
256   }
257 }
258
259 PP(pp_padsv)
260 {
261     dSP; dTARGET;
262     XPUSHs(TARG);
263     if (op->op_flags & OPf_MOD) {
264         if (op->op_private & OPpLVAL_INTRO)
265             SAVECLEARSV(curpad[op->op_targ]);
266         else if (op->op_private & (OPpDEREF_HV|OPpDEREF_AV))
267             provide_ref(op, curpad[op->op_targ]);
268     }
269     RETURN;
270 }
271
272 PP(pp_readline)
273 {
274     last_in_gv = (GV*)(*stack_sp--);
275     return do_readline();
276 }
277
278 PP(pp_eq)
279 {
280     dSP; tryAMAGICbinSET(eq,0); 
281     {
282       dPOPnv;
283       SETs((TOPn == value) ? &sv_yes : &sv_no);
284       RETURN;
285     }
286 }
287
288 PP(pp_preinc)
289 {
290     dSP;
291     if (SvIOK(TOPs)) {
292         ++SvIVX(TOPs);
293         SvFLAGS(TOPs) &= ~(SVf_NOK|SVf_POK|SVp_NOK|SVp_POK);
294     }
295     else
296         sv_inc(TOPs);
297     SvSETMAGIC(TOPs);
298     return NORMAL;
299 }
300
301 PP(pp_or)
302 {
303     dSP;
304     if (SvTRUE(TOPs))
305         RETURN;
306     else {
307         --SP;
308         RETURNOP(cLOGOP->op_other);
309     }
310 }
311
312 PP(pp_add)
313 {
314     dSP; dATARGET; tryAMAGICbin(add,opASSIGN); 
315     {
316       dPOPTOPnnrl;
317       SETn( left + right );
318       RETURN;
319     }
320 }
321
322 PP(pp_aelemfast)
323 {
324     dSP;
325     AV *av = GvAV((GV*)cSVOP->op_sv);
326     SV** svp = av_fetch(av, op->op_private, op->op_flags & OPf_MOD);
327     PUSHs(svp ? *svp : &sv_undef);
328     RETURN;
329 }
330
331 PP(pp_join)
332 {
333     dSP; dMARK; dTARGET;
334     MARK++;
335     do_join(TARG, *MARK, MARK, SP);
336     SP = MARK;
337     SETs(TARG);
338     RETURN;
339 }
340
341 PP(pp_pushre)
342 {
343     dSP;
344     XPUSHs((SV*)op);
345     RETURN;
346 }
347
348 /* Oversized hot code. */
349
350 PP(pp_print)
351 {
352     dSP; dMARK; dORIGMARK;
353     GV *gv;
354     IO *io;
355     register FILE *fp;
356
357     if (op->op_flags & OPf_STACKED)
358         gv = (GV*)*++MARK;
359     else
360         gv = defoutgv;
361     if (!(io = GvIO(gv))) {
362         if (dowarn) {
363             SV* sv = sv_newmortal();
364             gv_fullname(sv,gv);
365             warn("Filehandle %s never opened", SvPV(sv,na));
366         }
367
368         SETERRNO(EBADF,RMS$_IFI);
369         goto just_say_no;
370     }
371     else if (!(fp = IoOFP(io))) {
372         if (dowarn)  {
373             SV* sv = sv_newmortal();
374             gv_fullname(sv,gv);
375             if (IoIFP(io))
376                 warn("Filehandle %s opened only for input", SvPV(sv,na));
377             else
378                 warn("print on closed filehandle %s", SvPV(sv,na));
379         }
380         SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
381         goto just_say_no;
382     }
383     else {
384         MARK++;
385         if (ofslen) {
386             while (MARK <= SP) {
387                 if (!do_print(*MARK, fp))
388                     break;
389                 MARK++;
390                 if (MARK <= SP) {
391                     if (fwrite1(ofs, 1, ofslen, fp) == 0 || ferror(fp)) {
392                         MARK--;
393                         break;
394                     }
395                 }
396             }
397         }
398         else {
399             while (MARK <= SP) {
400                 if (!do_print(*MARK, fp))
401                     break;
402                 MARK++;
403             }
404         }
405         if (MARK <= SP)
406             goto just_say_no;
407         else {
408             if (orslen)
409                 if (fwrite1(ors, 1, orslen, fp) == 0 || ferror(fp))
410                     goto just_say_no;
411
412             if (IoFLAGS(io) & IOf_FLUSH)
413                 if (Fflush(fp) == EOF)
414                     goto just_say_no;
415         }
416     }
417     SP = ORIGMARK;
418     PUSHs(&sv_yes);
419     RETURN;
420
421   just_say_no:
422     SP = ORIGMARK;
423     PUSHs(&sv_undef);
424     RETURN;
425 }
426
427 PP(pp_rv2av)
428 {
429     dSP; dPOPss;
430
431     AV *av;
432
433     if (SvROK(sv)) {
434       wasref:
435         av = (AV*)SvRV(sv);
436         if (SvTYPE(av) != SVt_PVAV)
437             DIE("Not an ARRAY reference");
438         if (op->op_private & OPpLVAL_INTRO)
439             av = (AV*)save_svref((SV**)sv);
440         if (op->op_flags & OPf_REF) {
441             PUSHs((SV*)av);
442             RETURN;
443         }
444     }
445     else {
446         if (SvTYPE(sv) == SVt_PVAV) {
447             av = (AV*)sv;
448             if (op->op_flags & OPf_REF) {
449                 PUSHs((SV*)av);
450                 RETURN;
451             }
452         }
453         else {
454             if (SvTYPE(sv) != SVt_PVGV) {
455                 char *sym;
456
457                 if (SvGMAGICAL(sv)) {
458                     mg_get(sv);
459                     if (SvROK(sv))
460                         goto wasref;
461                 }
462                 if (!SvOK(sv)) {
463                     if (op->op_flags & OPf_REF ||
464                       op->op_private & HINT_STRICT_REFS)
465                         DIE(no_usym, "an ARRAY");
466                     if (GIMME == G_ARRAY)
467                         RETURN;
468                     RETPUSHUNDEF;
469                 }
470                 sym = SvPV(sv,na);
471                 if (op->op_private & HINT_STRICT_REFS)
472                     DIE(no_symref, sym, "an ARRAY");
473                 sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVAV);
474             }
475             av = GvAVn(sv);
476             if (op->op_private & OPpLVAL_INTRO)
477                 av = save_ary(sv);
478             if (op->op_flags & OPf_REF) {
479                 PUSHs((SV*)av);
480                 RETURN;
481             }
482         }
483     }
484
485     if (GIMME == G_ARRAY) {
486         I32 maxarg = AvFILL(av) + 1;
487         EXTEND(SP, maxarg);
488         Copy(AvARRAY(av), SP+1, maxarg, SV*);
489         SP += maxarg;
490     }
491     else {
492         dTARGET;
493         I32 maxarg = AvFILL(av) + 1;
494         PUSHi(maxarg);
495     }
496     RETURN;
497 }
498
499 PP(pp_rv2hv)
500 {
501
502     dSP; dTOPss;
503
504     HV *hv;
505
506     if (SvROK(sv)) {
507       wasref:
508         hv = (HV*)SvRV(sv);
509         if (SvTYPE(hv) != SVt_PVHV)
510             DIE("Not a HASH reference");
511         if (op->op_private & OPpLVAL_INTRO)
512             hv = (HV*)save_svref((SV**)sv);
513         if (op->op_flags & OPf_REF) {
514             SETs((SV*)hv);
515             RETURN;
516         }
517     }
518     else {
519         if (SvTYPE(sv) == SVt_PVHV) {
520             hv = (HV*)sv;
521             if (op->op_flags & OPf_REF) {
522                 SETs((SV*)hv);
523                 RETURN;
524             }
525         }
526         else {
527             if (SvTYPE(sv) != SVt_PVGV) {
528                 char *sym;
529
530                 if (SvGMAGICAL(sv)) {
531                     mg_get(sv);
532                     if (SvROK(sv))
533                         goto wasref;
534                 }
535                 if (!SvOK(sv)) {
536                     if (op->op_flags & OPf_REF ||
537                       op->op_private & HINT_STRICT_REFS)
538                         DIE(no_usym, "a HASH");
539                     if (GIMME == G_ARRAY) {
540                         SP--;
541                         RETURN;
542                     }
543                     RETSETUNDEF;
544                 }
545                 sym = SvPV(sv,na);
546                 if (op->op_private & HINT_STRICT_REFS)
547                     DIE(no_symref, sym, "a HASH");
548                 sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVHV);
549             }
550             hv = GvHVn(sv);
551             if (op->op_private & OPpLVAL_INTRO)
552                 hv = save_hash(sv);
553             if (op->op_flags & OPf_REF) {
554                 SETs((SV*)hv);
555                 RETURN;
556             }
557         }
558     }
559
560     if (GIMME == G_ARRAY) { /* array wanted */
561         *stack_sp = (SV*)hv;
562         return do_kv(ARGS);
563     }
564     else {
565         dTARGET;
566         if (HvFILL(hv)) {
567             sprintf(buf, "%d/%d", HvFILL(hv), HvMAX(hv)+1);
568             sv_setpv(TARG, buf);
569         }
570         else
571             sv_setiv(TARG, 0);
572         SETTARG;
573         RETURN;
574     }
575 }
576
577 PP(pp_aassign)
578 {
579     dSP;
580     SV **lastlelem = stack_sp;
581     SV **lastrelem = stack_base + POPMARK;
582     SV **firstrelem = stack_base + POPMARK + 1;
583     SV **firstlelem = lastrelem + 1;
584
585     register SV **relem;
586     register SV **lelem;
587
588     register SV *sv;
589     register AV *ary;
590
591     HV *hash;
592     I32 i;
593     int magic;
594
595     delaymagic = DM_DELAY;              /* catch simultaneous items */
596
597     /* If there's a common identifier on both sides we have to take
598      * special care that assigning the identifier on the left doesn't
599      * clobber a value on the right that's used later in the list.
600      */
601     if (op->op_private & OPpASSIGN_COMMON) {
602         for (relem = firstrelem; relem <= lastrelem; relem++) {
603             /*SUPPRESS 560*/
604             if (sv = *relem)
605                 *relem = sv_mortalcopy(sv);
606         }
607     }
608
609     relem = firstrelem;
610     lelem = firstlelem;
611     ary = Null(AV*);
612     hash = Null(HV*);
613     while (lelem <= lastlelem) {
614         tainted = 0;            /* Each item stands on its own, taintwise. */
615         sv = *lelem++;
616         switch (SvTYPE(sv)) {
617         case SVt_PVAV:
618             ary = (AV*)sv;
619             magic = SvMAGICAL(ary) != 0;
620             
621             av_clear(ary);
622             i = 0;
623             while (relem <= lastrelem) {        /* gobble up all the rest */
624                 sv = NEWSV(28,0);
625                 assert(*relem);
626                 sv_setsv(sv,*relem);
627                 *(relem++) = sv;
628                 (void)av_store(ary,i++,sv);
629                 if (magic)
630                     mg_set(sv);
631                 tainted = 0;
632             }
633             break;
634         case SVt_PVHV: {
635                 char *tmps;
636                 SV *tmpstr;
637
638                 hash = (HV*)sv;
639                 magic = SvMAGICAL(hash) != 0;
640                 hv_clear(hash);
641
642                 while (relem < lastrelem) {     /* gobble up all the rest */
643                     STRLEN len;
644                     if (*relem)
645                         sv = *(relem++);
646                     else
647                         sv = &sv_no, relem++;
648                     tmps = SvPV(sv, len);
649                     tmpstr = NEWSV(29,0);
650                     if (*relem)
651                         sv_setsv(tmpstr,*relem);        /* value */
652                     *(relem++) = tmpstr;
653                     (void)hv_store(hash,tmps,len,tmpstr,0);
654                     if (magic)
655                         mg_set(tmpstr);
656                     tainted = 0;
657                 }
658             }
659             break;
660         default:
661             if (SvTHINKFIRST(sv)) {
662                 if (SvREADONLY(sv) && curcop != &compiling) {
663                     if (sv != &sv_undef && sv != &sv_yes && sv != &sv_no)
664                         DIE(no_modify);
665                     if (relem <= lastrelem)
666                         relem++;
667                     break;
668                 }
669                 if (SvROK(sv))
670                     sv_unref(sv);
671             }
672             if (relem <= lastrelem) {
673                 sv_setsv(sv, *relem);
674                 *(relem++) = sv;
675             }
676             else
677                 sv_setsv(sv, &sv_undef);
678             SvSETMAGIC(sv);
679             break;
680         }
681     }
682     if (delaymagic & ~DM_DELAY) {
683         if (delaymagic & DM_UID) {
684 #ifdef HAS_SETRESUID
685             (void)setresuid(uid,euid,(Uid_t)-1);
686 #else
687 #  ifdef HAS_SETREUID
688             (void)setreuid(uid,euid);
689 #  else
690 #    ifdef HAS_SETRUID
691             if ((delaymagic & DM_UID) == DM_RUID) {
692                 (void)setruid(uid);
693                 delaymagic &= ~DM_RUID;
694             }
695 #    endif /* HAS_SETRUID */
696 #    ifdef HAS_SETEUID
697             if ((delaymagic & DM_UID) == DM_EUID) {
698                 (void)seteuid(uid);
699                 delaymagic &= ~DM_EUID;
700             }
701 #    endif /* HAS_SETEUID */
702             if (delaymagic & DM_UID) {
703                 if (uid != euid)
704                     DIE("No setreuid available");
705                 (void)setuid(uid);
706             }
707 #  endif /* HAS_SETREUID */
708 #endif /* HAS_SETRESUID */
709             uid = (int)getuid();
710             euid = (int)geteuid();
711         }
712         if (delaymagic & DM_GID) {
713 #ifdef HAS_SETRESGID
714             (void)setresgid(gid,egid,(Gid_t)-1);
715 #else
716 #  ifdef HAS_SETREGID
717             (void)setregid(gid,egid);
718 #  else
719 #    ifdef HAS_SETRGID
720             if ((delaymagic & DM_GID) == DM_RGID) {
721                 (void)setrgid(gid);
722                 delaymagic &= ~DM_RGID;
723             }
724 #    endif /* HAS_SETRGID */
725 #    ifdef HAS_SETEGID
726             if ((delaymagic & DM_GID) == DM_EGID) {
727                 (void)setegid(gid);
728                 delaymagic &= ~DM_EGID;
729             }
730 #    endif /* HAS_SETEGID */
731             if (delaymagic & DM_GID) {
732                 if (gid != egid)
733                     DIE("No setregid available");
734                 (void)setgid(gid);
735             }
736 #  endif /* HAS_SETREGID */
737 #endif /* HAS_SETRESGID */
738             gid = (int)getgid();
739             egid = (int)getegid();
740         }
741         tainting |= (uid && (euid != uid || egid != gid));
742     }
743     delaymagic = 0;
744     if (GIMME == G_ARRAY) {
745         if (ary || hash)
746             SP = lastrelem;
747         else
748             SP = firstrelem + (lastlelem - firstlelem);
749         RETURN;
750     }
751     else {
752         dTARGET;
753         SP = firstrelem;
754                 
755         SETi(lastrelem - firstrelem + 1);
756         RETURN;
757     }
758 }
759
760 PP(pp_match)
761 {
762     dSP; dTARG;
763     register PMOP *pm = cPMOP;
764     register char *t;
765     register char *s;
766     char *strend;
767     I32 global;
768     I32 safebase;
769     char *truebase;
770     register REGEXP *rx = pm->op_pmregexp;
771     I32 gimme = GIMME;
772     STRLEN len;
773     I32 minmatch = 0;
774     I32 oldsave = savestack_ix;
775
776     if (op->op_flags & OPf_STACKED)
777         TARG = POPs;
778     else {
779         TARG = GvSV(defgv);
780         EXTEND(SP,1);
781     }
782     s = SvPV(TARG, len);
783     strend = s + len;
784     if (!s)
785         DIE("panic: do_match");
786
787     if (pm->op_pmflags & PMf_USED) {
788         if (gimme == G_ARRAY)
789             RETURN;
790         RETPUSHNO;
791     }
792
793     if (!rx->prelen && curpm) {
794         pm = curpm;
795         rx = pm->op_pmregexp;
796     }
797     truebase = t = s;
798     if (global = pm->op_pmflags & PMf_GLOBAL) {
799         rx->startp[0] = 0;
800         if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
801             MAGIC* mg = mg_find(TARG, 'g');
802             if (mg && mg->mg_len >= 0) {
803                 rx->endp[0] = rx->startp[0] = s + mg->mg_len; 
804                 minmatch = (mg->mg_flags & MGf_MINMATCH);
805             }
806         }
807     }
808     if (!rx->nparens && !global)
809         gimme = G_SCALAR;                       /* accidental array context? */
810     safebase = (gimme == G_ARRAY) || global;
811     if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
812         SAVEINT(multiline);
813         multiline = pm->op_pmflags & PMf_MULTILINE;
814     }
815
816 play_it_again:
817     if (global && rx->startp[0]) {
818         t = s = rx->endp[0];
819         if (s > strend)
820             goto nope;
821         minmatch = (s == rx->startp[0]);
822     }
823     if (pm->op_pmshort) {
824         if (pm->op_pmflags & PMf_SCANFIRST) {
825             if (SvSCREAM(TARG)) {
826                 if (screamfirst[BmRARE(pm->op_pmshort)] < 0)
827                     goto nope;
828                 else if (!(s = screaminstr(TARG, pm->op_pmshort)))
829                     goto nope;
830                 else if (pm->op_pmflags & PMf_ALL)
831                     goto yup;
832             }
833             else if (!(s = fbm_instr((unsigned char*)s,
834               (unsigned char*)strend, pm->op_pmshort)))
835                 goto nope;
836             else if (pm->op_pmflags & PMf_ALL)
837                 goto yup;
838             if (s && rx->regback >= 0) {
839                 ++BmUSEFUL(pm->op_pmshort);
840                 s -= rx->regback;
841                 if (s < t)
842                     s = t;
843             }
844             else
845                 s = t;
846         }
847         else if (!multiline) {
848             if (*SvPVX(pm->op_pmshort) != *s ||
849               bcmp(SvPVX(pm->op_pmshort), s, pm->op_pmslen) ) {
850                 if (pm->op_pmflags & PMf_FOLD) {
851                     if (ibcmp((U8*)SvPVX(pm->op_pmshort), (U8*)s, pm->op_pmslen) )
852                         goto nope;
853                 }
854                 else
855                     goto nope;
856             }
857         }
858         if (!rx->naughty && --BmUSEFUL(pm->op_pmshort) < 0) {
859             SvREFCNT_dec(pm->op_pmshort);
860             pm->op_pmshort = Nullsv;    /* opt is being useless */
861         }
862     }
863     if (pregexec(rx, s, strend, truebase, minmatch,
864       SvSCREAM(TARG) ? TARG : Nullsv,
865       safebase)) {
866         curpm = pm;
867         if (pm->op_pmflags & PMf_ONCE)
868             pm->op_pmflags |= PMf_USED;
869         goto gotcha;
870     }
871     else
872         goto ret_no;
873     /*NOTREACHED*/
874
875   gotcha:
876     if (gimme == G_ARRAY) {
877         I32 iters, i, len;
878
879         iters = rx->nparens;
880         if (global && !iters)
881             i = 1;
882         else
883             i = 0;
884         EXTEND(SP, iters + i);
885         for (i = !i; i <= iters; i++) {
886             PUSHs(sv_newmortal());
887             /*SUPPRESS 560*/
888             if ((s = rx->startp[i]) && rx->endp[i] ) {
889                 len = rx->endp[i] - s;
890                 sv_setpvn(*SP, s, len);
891             }
892         }
893         if (global) {
894             truebase = rx->subbeg;
895             if (rx->startp[0] && rx->startp[0] == rx->endp[0])
896                 ++rx->endp[0];
897             goto play_it_again;
898         }
899         LEAVE_SCOPE(oldsave);
900         RETURN;
901     }
902     else {
903         if (global) {
904             MAGIC* mg = 0;
905             if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
906                 mg = mg_find(TARG, 'g');
907             if (!mg) {
908                 sv_magic(TARG, (SV*)0, 'g', Nullch, 0);
909                 mg = mg_find(TARG, 'g');
910             }
911             if (rx->startp[0]) {
912                 mg->mg_len = rx->endp[0] - truebase;
913                 if (rx->startp[0] == rx->endp[0])
914                     mg->mg_flags |= MGf_MINMATCH;
915                 else
916                     mg->mg_flags &= ~MGf_MINMATCH;
917             }
918             else
919                 mg->mg_len = -1;
920         }
921         LEAVE_SCOPE(oldsave);
922         RETPUSHYES;
923     }
924
925 yup:
926     ++BmUSEFUL(pm->op_pmshort);
927     curpm = pm;
928     if (pm->op_pmflags & PMf_ONCE)
929         pm->op_pmflags |= PMf_USED;
930     if (global) {
931         rx->subbeg = truebase;
932         rx->subend = strend;
933         rx->startp[0] = s;
934         rx->endp[0] = s + SvCUR(pm->op_pmshort);
935         goto gotcha;
936     }
937     if (sawampersand) {
938         char *tmps;
939
940         if (rx->subbase)
941             Safefree(rx->subbase);
942         tmps = rx->subbase = savepvn(t, strend-t);
943         rx->subbeg = tmps;
944         rx->subend = tmps + (strend-t);
945         tmps = rx->startp[0] = tmps + (s - t);
946         rx->endp[0] = tmps + SvCUR(pm->op_pmshort);
947     }
948     LEAVE_SCOPE(oldsave);
949     RETPUSHYES;
950
951 nope:
952     if (pm->op_pmshort)
953         ++BmUSEFUL(pm->op_pmshort);
954
955 ret_no:
956     if (global) {
957         if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
958             MAGIC* mg = mg_find(TARG, 'g');
959             if (mg)
960                 mg->mg_len = -1;
961         }
962     }
963     LEAVE_SCOPE(oldsave);
964     if (gimme == G_ARRAY)
965         RETURN;
966     RETPUSHNO;
967 }
968
969 OP *
970 do_readline()
971 {
972     dTHR;
973     dSP; dTARGETSTACKED;
974     register SV *sv;
975     STRLEN tmplen = 0;
976     STRLEN offset;
977     FILE *fp;
978     register IO *io = GvIO(last_in_gv);
979     register I32 type = op->op_type;
980
981     fp = Nullfp;
982     if (io) {
983         fp = IoIFP(io);
984         if (!fp) {
985             if (IoFLAGS(io) & IOf_ARGV) {
986                 if (IoFLAGS(io) & IOf_START) {
987                     IoFLAGS(io) &= ~IOf_START;
988                     IoLINES(io) = 0;
989                     if (av_len(GvAVn(last_in_gv)) < 0) {
990                         SV *tmpstr = newSVpv("-", 1); /* assume stdin */
991                         av_push(GvAVn(last_in_gv), tmpstr);
992                     }
993                 }
994                 fp = nextargv(last_in_gv);
995                 if (!fp) { /* Note: fp != IoIFP(io) */
996                     (void)do_close(last_in_gv, FALSE); /* now it does*/
997                     IoFLAGS(io) |= IOf_START;
998                 }
999             }
1000             else if (type == OP_GLOB) {
1001                 SV *tmpcmd = NEWSV(55, 0);
1002                 SV *tmpglob = POPs;
1003                 ENTER;
1004                 SAVEFREESV(tmpcmd);
1005 #ifdef VMS /* expand the wildcards right here, rather than opening a pipe, */
1006            /* since spawning off a process is a real performance hit */
1007                 {
1008 #include <descrip.h>
1009 #include <lib$routines.h>
1010 #include <nam.h>
1011 #include <rmsdef.h>
1012                     char rslt[NAM$C_MAXRSS+1+sizeof(unsigned short int)] = {'\0','\0'};
1013                     char vmsspec[NAM$C_MAXRSS+1];
1014                     char *rstr = rslt + sizeof(unsigned short int), *begin, *end, *cp;
1015                     char tmpfnam[L_tmpnam] = "SYS$SCRATCH:";
1016                     $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
1017                     FILE *tmpfp;
1018                     STRLEN i;
1019                     struct dsc$descriptor_s wilddsc
1020                        = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1021                     struct dsc$descriptor_vs rsdsc
1022                        = {sizeof rslt, DSC$K_DTYPE_VT, DSC$K_CLASS_VS, rslt};
1023                     unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0, hasver = 0, isunix = 0;
1024
1025                     /* We could find out if there's an explicit dev/dir or version
1026                        by peeking into lib$find_file's internal context at
1027                        ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
1028                        but that's unsupported, so I don't want to do it now and
1029                        have it bite someone in the future. */
1030                     strcat(tmpfnam,tmpnam(NULL));
1031                     cp = SvPV(tmpglob,i);
1032                     for (; i; i--) {
1033                        if (cp[i] == ';') hasver = 1;
1034                        if (cp[i] == '.') {
1035                            if (sts) hasver = 1;
1036                            else sts = 1;
1037                        }
1038                        if (cp[i] == '/') {
1039                           hasdir = isunix = 1;
1040                           break;
1041                        }
1042                        if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
1043                            hasdir = 1;
1044                            break;
1045                        }
1046                     }
1047                     if ((tmpfp = fopen(tmpfnam,"w+","fop=dlt")) != NULL) {
1048                         ok = ((wilddsc.dsc$a_pointer = tovmsspec(SvPVX(tmpglob),vmsspec)) != NULL);
1049                         if (ok) wilddsc.dsc$w_length = (unsigned short int) strlen(wilddsc.dsc$a_pointer);
1050                         while (ok && ((sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
1051                                                     &dfltdsc,NULL,NULL,NULL))&1)) {
1052                             end = rstr + (unsigned long int) *rslt;
1053                             if (!hasver) while (*end != ';') end--;
1054                             *(end++) = '\n';  *end = '\0';
1055                             for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
1056                             if (hasdir) {
1057                               if (isunix) trim_unixpath(rstr,SvPVX(tmpglob));
1058                               begin = rstr;
1059                             }
1060                             else {
1061                                 begin = end;
1062                                 while (*(--begin) != ']' && *begin != '>') ;
1063                                 ++begin;
1064                             }
1065                             ok = (fputs(begin,tmpfp) != EOF);
1066                         }
1067                         if (cxt) (void)lib$find_file_end(&cxt);
1068                         if (ok && sts != RMS$_NMF &&
1069                             sts != RMS$_DNF && sts != RMS$_FNF) ok = 0;
1070                         if (!ok) {
1071                             if (!(sts & 1)) {
1072                               SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
1073                             }
1074                             fclose(tmpfp);
1075                             fp = NULL;
1076                         }
1077                         else {
1078                            rewind(tmpfp);
1079                            IoTYPE(io) = '<';
1080                            IoIFP(io) = fp = tmpfp;
1081                         }
1082                     }
1083                 }
1084 #else /* !VMS */
1085 #ifdef DOSISH
1086                 sv_setpv(tmpcmd, "perlglob ");
1087                 sv_catsv(tmpcmd, tmpglob);
1088                 sv_catpv(tmpcmd, " |");
1089 #else
1090 #ifdef CSH
1091                 sv_setpvn(tmpcmd, cshname, cshlen);
1092                 sv_catpv(tmpcmd, " -cf 'set nonomatch; glob ");
1093                 sv_catsv(tmpcmd, tmpglob);
1094                 sv_catpv(tmpcmd, "' 2>/dev/null |");
1095 #else
1096                 sv_setpv(tmpcmd, "echo ");
1097                 sv_catsv(tmpcmd, tmpglob);
1098 #if 'z' - 'a' == 25
1099                 sv_catpv(tmpcmd, "|tr -s ' \t\f\r' '\\012\\012\\012\\012'|");
1100 #else
1101                 sv_catpv(tmpcmd, "|tr -s ' \t\f\r' '\\n\\n\\n\\n'|");
1102 #endif
1103 #endif /* !CSH */
1104 #endif /* !MSDOS */
1105                 (void)do_open(last_in_gv, SvPVX(tmpcmd), SvCUR(tmpcmd),
1106                               FALSE, 0, 0, Nullfp);
1107                 fp = IoIFP(io);
1108 #endif /* !VMS */
1109                 LEAVE;
1110             }
1111         }
1112         else if (type == OP_GLOB)
1113             SP--;
1114     }
1115     if (!fp) {
1116         if (dowarn && io && !(IoFLAGS(io) & IOf_START))
1117             warn("Read on closed filehandle <%s>", GvENAME(last_in_gv));
1118         if (GIMME == G_SCALAR) {
1119             (void)SvOK_off(TARG);
1120             PUSHTARG;
1121         }
1122         RETURN;
1123     }
1124     if (GIMME == G_ARRAY) {
1125         sv = sv_2mortal(NEWSV(57, 80));
1126         offset = 0;
1127     }
1128     else {
1129         sv = TARG;
1130         (void)SvUPGRADE(sv, SVt_PV);
1131         tmplen = SvLEN(sv);     /* remember if already alloced */
1132         if (!tmplen)
1133             Sv_Grow(sv, 80);    /* try short-buffering it */
1134         if (type == OP_RCATLINE)
1135             offset = SvCUR(sv);
1136         else
1137             offset = 0;
1138     }
1139     for (;;) {
1140         if (!sv_gets(sv, fp, offset)) {
1141             clearerr(fp);
1142             if (IoFLAGS(io) & IOf_ARGV) {
1143                 fp = nextargv(last_in_gv);
1144                 if (fp)
1145                     continue;
1146                 (void)do_close(last_in_gv, FALSE);
1147                 IoFLAGS(io) |= IOf_START;
1148             }
1149             else if (type == OP_GLOB) {
1150                 (void)do_close(last_in_gv, FALSE);
1151             }
1152             if (GIMME == G_SCALAR) {
1153                 (void)SvOK_off(TARG);
1154                 PUSHTARG;
1155             }
1156             RETURN;
1157         }
1158         IoLINES(io)++;
1159         XPUSHs(sv);
1160         if (tainting) {
1161             tainted = TRUE;
1162             SvTAINT(sv); /* Anything from the outside world...*/
1163         }
1164         if (type == OP_GLOB) {
1165             char *tmps;
1166
1167             if (SvCUR(sv) > 0 && SvCUR(rs) > 0) {
1168                 tmps = SvEND(sv) - 1;
1169                 if (*tmps == *SvPVX(rs)) {
1170                     *tmps = '\0';
1171                     SvCUR(sv)--;
1172                 }
1173             }
1174             for (tmps = SvPVX(sv); *tmps; tmps++)
1175                 if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
1176                     strchr("$&*(){}[]'\";\\|?<>~`", *tmps))
1177                         break;
1178             if (*tmps && Stat(SvPVX(sv), &statbuf) < 0) {
1179                 (void)POPs;             /* Unmatched wildcard?  Chuck it... */
1180                 continue;
1181             }
1182         }
1183         if (GIMME == G_ARRAY) {
1184             if (SvLEN(sv) - SvCUR(sv) > 20) {
1185                 SvLEN_set(sv, SvCUR(sv)+1);
1186                 Renew(SvPVX(sv), SvLEN(sv), char);
1187             }
1188             sv = sv_2mortal(NEWSV(58, 80));
1189             continue;
1190         }
1191         else if (!tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1192             /* try to reclaim a bit of scalar space (only on 1st alloc) */
1193             if (SvCUR(sv) < 60)
1194                 SvLEN_set(sv, 80);
1195             else
1196                 SvLEN_set(sv, SvCUR(sv)+40);    /* allow some slop */
1197             Renew(SvPVX(sv), SvLEN(sv), char);
1198         }
1199         RETURN;
1200     }
1201 }
1202
1203 PP(pp_enter)
1204 {
1205     dSP;
1206     register CONTEXT *cx;
1207     I32 gimme;
1208
1209     /*
1210      * We don't just use the GIMME macro here because it assumes there's
1211      * already a context, which ain't necessarily so at initial startup.
1212      */
1213
1214     if (op->op_flags & OPf_KNOW)
1215         gimme = op->op_flags & OPf_LIST;
1216     else if (cxstack_ix >= 0)
1217         gimme = cxstack[cxstack_ix].blk_gimme;
1218     else
1219         gimme = G_SCALAR;
1220
1221     ENTER;
1222
1223     SAVETMPS;
1224     PUSHBLOCK(cx, CXt_BLOCK, sp);
1225
1226     RETURN;
1227 }
1228
1229 PP(pp_helem)
1230 {
1231     dSP;
1232     SV** svp;
1233     SV *keysv = POPs;
1234     STRLEN keylen;
1235     char *key = SvPV(keysv, keylen);
1236     HV *hv = (HV*)POPs;
1237     I32 lval = op->op_flags & OPf_MOD;
1238
1239     if (SvTYPE(hv) != SVt_PVHV)
1240         RETPUSHUNDEF;
1241     svp = hv_fetch(hv, key, keylen, lval);
1242     if (lval) {
1243         if (!svp || *svp == &sv_undef)
1244             DIE(no_helem, key);
1245         if (op->op_private & OPpLVAL_INTRO)
1246             save_svref(svp);
1247         else if (op->op_private & (OPpDEREF_HV|OPpDEREF_AV))
1248             provide_ref(op, *svp);
1249     }
1250     PUSHs(svp ? *svp : &sv_undef);
1251     RETURN;
1252 }
1253
1254 PP(pp_leave)
1255 {
1256     dSP;
1257     register CONTEXT *cx;
1258     register SV **mark;
1259     SV **newsp;
1260     PMOP *newpm;
1261     I32 gimme;
1262
1263     if (op->op_flags & OPf_SPECIAL) {
1264         cx = &cxstack[cxstack_ix];
1265         cx->blk_oldpm = curpm;  /* fake block should preserve $1 et al */
1266     }
1267
1268     POPBLOCK(cx,newpm);
1269
1270     if (op->op_flags & OPf_KNOW)
1271         gimme = op->op_flags & OPf_LIST;
1272     else if (cxstack_ix >= 0)
1273         gimme = cxstack[cxstack_ix].blk_gimme;
1274     else
1275         gimme = G_SCALAR;
1276
1277     if (gimme == G_SCALAR) {
1278         if (op->op_private & OPpLEAVE_VOID)
1279             SP = newsp;
1280         else {
1281             MARK = newsp + 1;
1282             if (MARK <= SP)
1283                 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1284                     *MARK = TOPs;
1285                 else
1286                     *MARK = sv_mortalcopy(TOPs);
1287             else {
1288                 MEXTEND(mark,0);
1289                 *MARK = &sv_undef;
1290             }
1291             SP = MARK;
1292         }
1293     }
1294     else {
1295         for (mark = newsp + 1; mark <= SP; mark++)
1296             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP)))
1297                 *mark = sv_mortalcopy(*mark);
1298                 /* in case LEAVE wipes old return values */
1299     }
1300     curpm = newpm;      /* Don't pop $1 et al till now */
1301
1302     LEAVE;
1303
1304     RETURN;
1305 }
1306
1307 PP(pp_iter)
1308 {
1309     dSP;
1310     register CONTEXT *cx;
1311     SV *sv;
1312     AV* av;
1313
1314     EXTEND(sp, 1);
1315     cx = &cxstack[cxstack_ix];
1316     if (cx->cx_type != CXt_LOOP)
1317         DIE("panic: pp_iter");
1318     av = cx->blk_loop.iterary;
1319     if (av == stack && cx->blk_loop.iterix >= cx->blk_oldsp)
1320         RETPUSHNO;
1321
1322     if (cx->blk_loop.iterix >= AvFILL(av))
1323         RETPUSHNO;
1324
1325     if (sv = AvARRAY(av)[++cx->blk_loop.iterix]) {
1326         SvTEMP_off(sv);
1327         *cx->blk_loop.itervar = sv;
1328     }
1329     else
1330         *cx->blk_loop.itervar = &sv_undef;
1331
1332     RETPUSHYES;
1333 }
1334
1335 PP(pp_subst)
1336 {
1337     dSP; dTARG;
1338     register PMOP *pm = cPMOP;
1339     PMOP *rpm = pm;
1340     register SV *dstr;
1341     register char *s;
1342     char *strend;
1343     register char *m;
1344     char *c;
1345     register char *d;
1346     STRLEN clen;
1347     I32 iters = 0;
1348     I32 maxiters;
1349     register I32 i;
1350     bool once;
1351     char *orig;
1352     I32 safebase;
1353     register REGEXP *rx = pm->op_pmregexp;
1354     STRLEN len;
1355     int force_on_match = 0;
1356     I32 oldsave = savestack_ix;
1357
1358     if (pm->op_pmflags & PMf_CONST)     /* known replacement string? */
1359         dstr = POPs;
1360     if (op->op_flags & OPf_STACKED)
1361         TARG = POPs;
1362     else {
1363         TARG = GvSV(defgv);
1364         EXTEND(SP,1);
1365     }
1366     s = SvPV(TARG, len);
1367     if (!SvPOKp(TARG) || SvREADONLY(TARG) || (SvTYPE(TARG) == SVt_PVGV))
1368         force_on_match = 1;
1369
1370   force_it:
1371     if (!pm || !s)
1372         DIE("panic: do_subst");
1373
1374     strend = s + len;
1375     maxiters = (strend - s) + 10;
1376
1377     if (!rx->prelen && curpm) {
1378         pm = curpm;
1379         rx = pm->op_pmregexp;
1380     }
1381     safebase = ((!rx || !rx->nparens) && !sawampersand);
1382     if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
1383         SAVEINT(multiline);
1384         multiline = pm->op_pmflags & PMf_MULTILINE;
1385     }
1386     orig = m = s;
1387     if (pm->op_pmshort) {
1388         if (pm->op_pmflags & PMf_SCANFIRST) {
1389             if (SvSCREAM(TARG)) {
1390                 if (screamfirst[BmRARE(pm->op_pmshort)] < 0)
1391                     goto nope;
1392                 else if (!(s = screaminstr(TARG, pm->op_pmshort)))
1393                     goto nope;
1394             }
1395             else if (!(s = fbm_instr((unsigned char*)s, (unsigned char*)strend,
1396               pm->op_pmshort)))
1397                 goto nope;
1398             if (s && rx->regback >= 0) {
1399                 ++BmUSEFUL(pm->op_pmshort);
1400                 s -= rx->regback;
1401                 if (s < m)
1402                     s = m;
1403             }
1404             else
1405                 s = m;
1406         }
1407         else if (!multiline) {
1408             if (*SvPVX(pm->op_pmshort) != *s ||
1409               bcmp(SvPVX(pm->op_pmshort), s, pm->op_pmslen) ) {
1410                 if (pm->op_pmflags & PMf_FOLD) {
1411                     if (ibcmp((U8*)SvPVX(pm->op_pmshort), (U8*)s, pm->op_pmslen) )
1412                         goto nope;
1413                 }
1414                 else
1415                     goto nope;
1416             }
1417         }
1418         if (!rx->naughty && --BmUSEFUL(pm->op_pmshort) < 0) {
1419             SvREFCNT_dec(pm->op_pmshort);
1420             pm->op_pmshort = Nullsv;    /* opt is being useless */
1421         }
1422     }
1423     once = !(rpm->op_pmflags & PMf_GLOBAL);
1424     if (rpm->op_pmflags & PMf_CONST) {  /* known replacement string? */
1425         c = SvPV(dstr, clen);
1426         if (clen <= rx->minlen) {
1427                                         /* can do inplace substitution */
1428             if (pregexec(rx, s, strend, orig, 0,
1429               SvSCREAM(TARG) ? TARG : Nullsv, safebase)) {
1430                 if (force_on_match) {
1431                     force_on_match = 0;
1432                     s = SvPV_force(TARG, len);
1433                     goto force_it;
1434                 }
1435                 if (rx->subbase)        /* oops, no we can't */
1436                     goto long_way;
1437                 d = s;
1438                 curpm = pm;
1439                 SvSCREAM_off(TARG);     /* disable possible screamer */
1440                 if (once) {
1441                     m = rx->startp[0];
1442                     d = rx->endp[0];
1443                     s = orig;
1444                     if (m - s > strend - d) {   /* faster to shorten from end */
1445                         if (clen) {
1446                             Copy(c, m, clen, char);
1447                             m += clen;
1448                         }
1449                         i = strend - d;
1450                         if (i > 0) {
1451                             Move(d, m, i, char);
1452                             m += i;
1453                         }
1454                         *m = '\0';
1455                         SvCUR_set(TARG, m - s);
1456                         (void)SvPOK_only(TARG);
1457                         SvSETMAGIC(TARG);
1458                         PUSHs(&sv_yes);
1459                         LEAVE_SCOPE(oldsave);
1460                         RETURN;
1461                     }
1462                     /*SUPPRESS 560*/
1463                     else if (i = m - s) {       /* faster from front */
1464                         d -= clen;
1465                         m = d;
1466                         sv_chop(TARG, d-i);
1467                         s += i;
1468                         while (i--)
1469                             *--d = *--s;
1470                         if (clen)
1471                             Copy(c, m, clen, char);
1472                         (void)SvPOK_only(TARG);
1473                         SvSETMAGIC(TARG);
1474                         PUSHs(&sv_yes);
1475                         LEAVE_SCOPE(oldsave);
1476                         RETURN;
1477                     }
1478                     else if (clen) {
1479                         d -= clen;
1480                         sv_chop(TARG, d);
1481                         Copy(c, d, clen, char);
1482                         (void)SvPOK_only(TARG);
1483                         SvSETMAGIC(TARG);
1484                         PUSHs(&sv_yes);
1485                         LEAVE_SCOPE(oldsave);
1486                         RETURN;
1487                     }
1488                     else {
1489                         sv_chop(TARG, d);
1490                         (void)SvPOK_only(TARG);
1491                         SvSETMAGIC(TARG);
1492                         PUSHs(&sv_yes);
1493                         LEAVE_SCOPE(oldsave);
1494                         RETURN;
1495                     }
1496                     /* NOTREACHED */
1497                 }
1498                 do {
1499                     if (iters++ > maxiters)
1500                         DIE("Substitution loop");
1501                     m = rx->startp[0];
1502                     /*SUPPRESS 560*/
1503                     if (i = m - s) {
1504                         if (s != d)
1505                             Move(s, d, i, char);
1506                         d += i;
1507                     }
1508                     if (clen) {
1509                         Copy(c, d, clen, char);
1510                         d += clen;
1511                     }
1512                     s = rx->endp[0];
1513                 } while (pregexec(rx, s, strend, orig, s == m,
1514                     Nullsv, TRUE));     /* (don't match same null twice) */
1515                 if (s != d) {
1516                     i = strend - s;
1517                     SvCUR_set(TARG, d - SvPVX(TARG) + i);
1518                     Move(s, d, i+1, char);              /* include the Null */
1519                 }
1520                 (void)SvPOK_only(TARG);
1521                 SvSETMAGIC(TARG);
1522                 PUSHs(sv_2mortal(newSViv((I32)iters)));
1523                 LEAVE_SCOPE(oldsave);
1524                 RETURN;
1525             }
1526             PUSHs(&sv_no);
1527             LEAVE_SCOPE(oldsave);
1528             RETURN;
1529         }
1530     }
1531     else
1532         c = Nullch;
1533     if (pregexec(rx, s, strend, orig, 0,
1534       SvSCREAM(TARG) ? TARG : Nullsv, safebase)) {
1535     long_way:
1536         if (force_on_match) {
1537             force_on_match = 0;
1538             s = SvPV_force(TARG, len);
1539             goto force_it;
1540         }
1541         dstr = NEWSV(25, sv_len(TARG));
1542         sv_setpvn(dstr, m, s-m);
1543         curpm = pm;
1544         if (!c) {
1545             register CONTEXT *cx;
1546             PUSHSUBST(cx);
1547             RETURNOP(cPMOP->op_pmreplroot);
1548         }
1549         do {
1550             if (iters++ > maxiters)
1551                 DIE("Substitution loop");
1552             if (rx->subbase && rx->subbase != orig) {
1553                 m = s;
1554                 s = orig;
1555                 orig = rx->subbase;
1556                 s = orig + (m - s);
1557                 strend = s + (strend - m);
1558             }
1559             m = rx->startp[0];
1560             sv_catpvn(dstr, s, m-s);
1561             s = rx->endp[0];
1562             if (clen)
1563                 sv_catpvn(dstr, c, clen);
1564             if (once)
1565                 break;
1566         } while (pregexec(rx, s, strend, orig, s == m, Nullsv,
1567             safebase));
1568         sv_catpvn(dstr, s, strend - s);
1569
1570         (void)SvOOK_off(TARG);
1571         Safefree(SvPVX(TARG));
1572         SvPVX(TARG) = SvPVX(dstr);
1573         SvCUR_set(TARG, SvCUR(dstr));
1574         SvLEN_set(TARG, SvLEN(dstr));
1575         SvPVX(dstr) = 0;
1576         sv_free(dstr);
1577
1578         (void)SvPOK_only(TARG);
1579         SvSETMAGIC(TARG);
1580         PUSHs(sv_2mortal(newSViv((I32)iters)));
1581         LEAVE_SCOPE(oldsave);
1582         RETURN;
1583     }
1584     PUSHs(&sv_no);
1585     LEAVE_SCOPE(oldsave);
1586     RETURN;
1587
1588 nope:
1589     ++BmUSEFUL(pm->op_pmshort);
1590     PUSHs(&sv_no);
1591     LEAVE_SCOPE(oldsave);
1592     RETURN;
1593 }
1594
1595 PP(pp_grepwhile)
1596 {
1597     dSP;
1598
1599     if (SvTRUEx(POPs))
1600         stack_base[markstack_ptr[-1]++] = stack_base[*markstack_ptr];
1601     ++*markstack_ptr;
1602     LEAVE;                                      /* exit inner scope */
1603
1604     /* All done yet? */
1605     if (stack_base + *markstack_ptr > sp) {
1606         I32 items;
1607
1608         LEAVE;                                  /* exit outer scope */
1609         (void)POPMARK;                          /* pop src */
1610         items = --*markstack_ptr - markstack_ptr[-1];
1611         (void)POPMARK;                          /* pop dst */
1612         SP = stack_base + POPMARK;              /* pop original mark */
1613         if (GIMME != G_ARRAY) {
1614             dTARGET;
1615             XPUSHi(items);
1616             RETURN;
1617         }
1618         SP += items;
1619         RETURN;
1620     }
1621     else {
1622         SV *src;
1623
1624         ENTER;                                  /* enter inner scope */
1625         SAVESPTR(curpm);
1626
1627         src = stack_base[*markstack_ptr];
1628         SvTEMP_off(src);
1629         GvSV(defgv) = src;
1630
1631         RETURNOP(cLOGOP->op_other);
1632     }
1633 }
1634
1635 PP(pp_leavesub)
1636 {
1637     dSP;
1638     SV **mark;
1639     SV **newsp;
1640     PMOP *newpm;
1641     I32 gimme;
1642     register CONTEXT *cx;
1643
1644     POPBLOCK(cx,newpm);
1645     POPSUB(cx);
1646
1647     if (gimme == G_SCALAR) {
1648         MARK = newsp + 1;
1649         if (MARK <= SP)
1650             if (SvFLAGS(TOPs) & SVs_TEMP)
1651                 *MARK = TOPs;
1652             else
1653                 *MARK = sv_mortalcopy(TOPs);
1654         else {
1655             MEXTEND(mark,0);
1656             *MARK = &sv_undef;
1657         }
1658         SP = MARK;
1659     }
1660     else {
1661         for (mark = newsp + 1; mark <= SP; mark++)
1662             if (!(SvFLAGS(*mark) & SVs_TEMP))
1663                 *mark = sv_mortalcopy(*mark);
1664                 /* in case LEAVE wipes old return values */
1665     }
1666
1667     if (cx->blk_sub.hasargs) {          /* You don't exist; go away. */
1668         AV* av = cx->blk_sub.argarray;
1669
1670         av_clear(av);
1671         AvREAL_off(av);
1672     }
1673     curpm = newpm;      /* Don't pop $1 et al till now */
1674
1675     LEAVE;
1676     PUTBACK;
1677     return pop_return();
1678 }
1679
1680 PP(pp_entersub)
1681 {
1682     dSP; dPOPss;
1683     GV *gv;
1684     HV *stash;
1685     register CV *cv;
1686     register CONTEXT *cx;
1687     I32 gimme;
1688
1689     if (!sv)
1690         DIE("Not a CODE reference");
1691     switch (SvTYPE(sv)) {
1692     default:
1693         if (!SvROK(sv)) {
1694             char *sym;
1695
1696             if (sv == &sv_yes)          /* unfound import, ignore */
1697                 RETURN;
1698             if (!SvOK(sv))
1699                 DIE(no_usym, "a subroutine");
1700             sym = SvPV(sv,na);
1701             if (op->op_private & HINT_STRICT_REFS)
1702                 DIE(no_symref, sym, "a subroutine");
1703             cv = perl_get_cv(sym, TRUE);
1704             break;
1705         }
1706         cv = (CV*)SvRV(sv);
1707         if (SvTYPE(cv) == SVt_PVCV)
1708             break;
1709         /* FALL THROUGH */
1710     case SVt_PVHV:
1711     case SVt_PVAV:
1712         DIE("Not a CODE reference");
1713     case SVt_PVCV:
1714         cv = (CV*)sv;
1715         break;
1716     case SVt_PVGV:
1717         if (!(cv = GvCV((GV*)sv)))
1718             cv = sv_2cv(sv, &stash, &gv, TRUE);
1719         break;
1720     }
1721
1722     ENTER;
1723     SAVETMPS;
1724
1725   retry:
1726     if (!cv)
1727         DIE("Not a CODE reference");
1728
1729     if (!CvROOT(cv) && !CvXSUB(cv)) {
1730         if (gv = CvGV(cv)) {
1731             SV *tmpstr;
1732             GV *ngv;
1733             if (SvFAKE(cv) && GvCV(gv) != cv) { /* autoloaded stub? */
1734                 cv = GvCV(gv);
1735                 if (SvTYPE(sv) == SVt_PVGV) {
1736                     SvREFCNT_dec(GvCV((GV*)sv));
1737                     GvCV((GV*)sv) = (CV*)SvREFCNT_inc((SV*)cv);
1738                 }
1739                 goto retry;
1740             }
1741             tmpstr = sv_newmortal();
1742             gv_efullname(tmpstr, gv);
1743             ngv = gv_fetchmethod(GvESTASH(gv), "AUTOLOAD");
1744             if (ngv && ngv != gv && (cv = GvCV(ngv))) { /* One more chance... */
1745                 gv = ngv;
1746                 sv_setsv(GvSV(CvGV(cv)), tmpstr);       /* Set CV's $AUTOLOAD */
1747                 if (tainting)
1748                     sv_unmagic(GvSV(CvGV(cv)), 't');
1749                 goto retry;
1750             }
1751             else
1752                 DIE("Undefined subroutine &%s called",SvPVX(tmpstr));
1753         }
1754         DIE("Undefined subroutine called");
1755     }
1756
1757     gimme = GIMME;
1758     if ((op->op_private & OPpENTERSUB_DB) && !CvXSUB(cv)) {
1759         sv = GvSV(DBsub);
1760         save_item(sv);
1761         if (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED)) {
1762             /* GV is potentially non-unique */
1763             sv_setsv(sv, newRV((SV*)cv));
1764         }
1765         else {
1766             gv = CvGV(cv);
1767             gv_efullname(sv,gv);
1768         }
1769         cv = GvCV(DBsub);
1770         if (!cv)
1771             DIE("No DBsub routine");
1772     }
1773
1774 #ifdef USE_THREADS
1775     MUTEX_LOCK(CvMUTEXP(cv));
1776     if (!CvCONDP(cv)) {
1777 #ifdef DEBUGGING
1778         DEBUG_L((fprintf(stderr, "0x%lx entering fast %s\n",
1779                                  (unsigned long)thr, SvPEEK((SV*)cv))));
1780 #endif /* DEBUGGING */
1781         MUTEX_UNLOCK(CvMUTEXP(cv)); /* fast sub wants neither sync nor clone */
1782     }
1783     else if (SvFLAGS(cv) & SVpcv_SYNC) {
1784         /*
1785          * It's a synchronised CV. Wait until it's free unless
1786          * we own it already (in which case we're recursing).
1787          */
1788         if (CvOWNER(cv) && CvOWNER(cv) != thr) {
1789             do {
1790                 DEBUG_L((fprintf(stderr, "0x%lx wait for 0x%lx to leave %s\n",
1791                                  (unsigned long)thr,(unsigned long)CvOWNER(cv),
1792                                  SvPEEK((SV*)cv))));
1793                 COND_WAIT(CvCONDP(cv), CvMUTEXP(cv)); /* yawn */
1794             } while (CvOWNER(cv));
1795         }
1796         CvOWNER(cv) = thr;      /* Assert ownership */
1797         SvREFCNT_inc(cv);
1798         MUTEX_UNLOCK(CvMUTEXP(cv));
1799         if (CvDEPTH(cv) == 0)
1800             SAVEDESTRUCTOR(unset_cvowner, (void*) cv);
1801     }
1802     else {
1803         /*
1804          * It's an ordinary unsynchronised CV so we must distinguish
1805          * three cases. (1) It's ours already (and we're recursing);
1806          * (2) it's free (but we may already be using a cached clone);
1807          * (3) another thread owns it. Case (1) is easy: we just use it.
1808          * Case (2) means we look for a clone--if we have one, use it
1809          * otherwise grab ownership of cv. Case (3) means look we for a
1810          * clone and have to create one if we don't already have one.
1811          * Why look for a clone in case (2) when we could just grab
1812          * ownership of cv straight away? Well, we could be recursing,
1813          * i.e. we originally tried to enter cv while another thread
1814          * owned it (hence we used a clone) but it has been freed up
1815          * and we're now recursing into it. It may or may not be "better"
1816          * to use the clone but at least CvDEPTH can be trusted.
1817          */
1818         if (CvOWNER(cv) == thr)
1819             MUTEX_UNLOCK(CvMUTEXP(cv));
1820         else {
1821             /* Case (2) or (3) */
1822             SV **svp;
1823             
1824             /*
1825              * XXX Might it be better to release CvMUTEXP(cv) while we
1826              * do the hv_fetch? We might find someone has pinched it
1827              * when we look again, in which case we would be in case
1828              * (3) instead of (2) so we'd have to clone. Would the fact
1829              * that we released the mutex more quickly make up for this?
1830              */
1831             svp = hv_fetch(cvcache, (char *)cv, sizeof(cv), FALSE);
1832             if (svp) {
1833                 /* We already have a clone to use */
1834                 MUTEX_UNLOCK(CvMUTEXP(cv));
1835                 cv = *(CV**)svp;
1836                 DEBUG_L(fprintf(stderr,
1837                                 "entersub: 0x%lx already has clone 0x%lx:%s\n",
1838                                 (unsigned long) thr, (unsigned long) cv,
1839                                 SvPEEK((SV*)cv)));
1840                 CvOWNER(cv) = thr;
1841                 SvREFCNT_inc(cv);
1842                 if (CvDEPTH(cv) == 0)
1843                     SAVEDESTRUCTOR(unset_cvowner, (void*) cv);
1844             }
1845             else {
1846                 /* (2) => grab ownership of cv. (3) => make clone */
1847                 if (!CvOWNER(cv)) {
1848                     CvOWNER(cv) = thr;
1849                     SvREFCNT_inc(cv);
1850                     MUTEX_UNLOCK(CvMUTEXP(cv));
1851                     DEBUG_L(fprintf(stderr,
1852                                     "entersub: 0x%lx grabbing 0x%lx:%s\n",
1853                                     (unsigned long) thr, (unsigned long) cv,
1854                                     SvPEEK((SV*)cv)));
1855                 } else {
1856                     /* Make a new clone. */
1857                     CV *clonecv;
1858                     SvREFCNT_inc(cv); /* don't let it vanish from under us */
1859                     MUTEX_UNLOCK(CvMUTEXP(cv));
1860                     DEBUG_L((fprintf(stderr,
1861                                      "entersub: 0x%lx cloning 0x%lx:%s\n",
1862                                      (unsigned long) thr, (unsigned long) cv,
1863                                      SvPEEK((SV*)cv))));
1864                     /*
1865                      * We're creating a new clone so there's no race
1866                      * between the original MUTEX_UNLOCK and the
1867                      * SvREFCNT_inc since no one will be trying to undef
1868                      * it out from underneath us. At least, I don't think
1869                      * there's a race...
1870                      */
1871                     clonecv = cv_clone(cv);
1872                     SvREFCNT_dec(cv); /* finished with this */
1873                     hv_store(cvcache, (char*)cv, sizeof(cv), (SV*)clonecv,0);
1874                     CvOWNER(clonecv) = thr;
1875                     cv = clonecv;
1876                     SvREFCNT_inc(cv);
1877                 }
1878                 assert(CvDEPTH(cv) == 0);
1879                 SAVEDESTRUCTOR(unset_cvowner, (void*) cv);
1880             }
1881         }
1882     }   
1883 #endif /* USE_THREADS */
1884
1885     gimme = GIMME;
1886
1887     if (CvXSUB(cv)) {
1888         if (CvOLDSTYLE(cv)) {
1889             I32 (*fp3)_((int,int,int));
1890             dMARK;
1891             register I32 items = SP - MARK;
1892             while (sp > mark) {
1893                 sp[1] = sp[0];
1894                 sp--;
1895             }
1896             stack_sp = mark + 1;
1897             fp3 = (I32(*)_((int,int,int)))CvXSUB(cv);
1898             items = (*fp3)(CvXSUBANY(cv).any_i32, 
1899                            MARK - stack_base + 1,
1900                            items);
1901             stack_sp = stack_base + items;
1902         }
1903         else {
1904             I32 markix = TOPMARK;
1905
1906             PUTBACK;
1907             (void)(*CvXSUB(cv))(cv);
1908
1909             /* Enforce some sanity in scalar context. */
1910             if (gimme == G_SCALAR && ++markix != stack_sp - stack_base ) {
1911                 if (markix > stack_sp - stack_base)
1912                     *(stack_base + markix) = &sv_undef;
1913                 else
1914                     *(stack_base + markix) = *stack_sp;
1915                 stack_sp = stack_base + markix;
1916             }
1917         }
1918         LEAVE;
1919         return NORMAL;
1920     }
1921     else {
1922         dMARK;
1923         register I32 items = SP - MARK;
1924         I32 hasargs = (op->op_flags & OPf_STACKED) != 0;
1925         AV* padlist = CvPADLIST(cv);
1926         SV** svp = AvARRAY(padlist);
1927         push_return(op->op_next);
1928         PUSHBLOCK(cx, CXt_SUB, MARK);
1929         PUSHSUB(cx);
1930         CvDEPTH(cv)++;
1931         if (CvDEPTH(cv) < 2)
1932             (void)SvREFCNT_inc(cv);
1933         else {  /* save temporaries on recursion? */
1934             if (CvDEPTH(cv) == 100 && dowarn)
1935                 warn("Deep recursion on subroutine \"%s\"",GvENAME(CvGV(cv)));
1936             if (CvDEPTH(cv) > AvFILL(padlist)) {
1937                 AV *av;
1938                 AV *newpad = newAV();
1939                 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
1940                 I32 ix = AvFILL((AV*)svp[1]);
1941                 svp = AvARRAY(svp[0]);
1942                 for ( ;ix > 0; ix--) {
1943                     if (svp[ix] != &sv_undef) {
1944                         char *name = SvPVX(svp[ix]);
1945                         if (SvFLAGS(svp[ix]) & SVf_FAKE) { /* outer lexical? */
1946                             av_store(newpad, ix,
1947                                 SvREFCNT_inc(oldpad[ix]) );
1948                         }
1949                         else {                          /* our own lexical */
1950                             if (*name == '@')
1951                                 av_store(newpad, ix, sv = (SV*)newAV());
1952                             else if (*name == '%')
1953                                 av_store(newpad, ix, sv = (SV*)newHV());
1954                             else
1955                                 av_store(newpad, ix, sv = NEWSV(0,0));
1956                             SvPADMY_on(sv);
1957                         }
1958                     }
1959                     else {
1960                         av_store(newpad, ix, sv = NEWSV(0,0));
1961                         SvPADTMP_on(sv);
1962                     }
1963                 }
1964                 av = newAV();           /* will be @_ */
1965                 av_extend(av, 0);
1966                 av_store(newpad, 0, (SV*)av);
1967                 AvFLAGS(av) = AVf_REIFY;
1968                 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
1969                 AvFILL(padlist) = CvDEPTH(cv);
1970                 svp = AvARRAY(padlist);
1971             }
1972         }
1973         SAVESPTR(curpad);
1974         curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
1975         if (hasargs) {
1976             AV* av = (AV*)curpad[0];
1977             SV** ary;
1978
1979             if (AvREAL(av)) {
1980                 av_clear(av);
1981                 AvREAL_off(av);
1982             }
1983             cx->blk_sub.savearray = GvAV(defgv);
1984             cx->blk_sub.argarray = av;
1985             GvAV(defgv) = cx->blk_sub.argarray;
1986             ++MARK;
1987
1988             if (items > AvMAX(av) + 1) {
1989                 ary = AvALLOC(av);
1990                 if (AvARRAY(av) != ary) {
1991                     AvMAX(av) += AvARRAY(av) - AvALLOC(av);
1992                     SvPVX(av) = (char*)ary;
1993                 }
1994                 if (items > AvMAX(av) + 1) {
1995                     AvMAX(av) = items - 1;
1996                     Renew(ary,items,SV*);
1997                     AvALLOC(av) = ary;
1998                     SvPVX(av) = (char*)ary;
1999                 }
2000             }
2001             Copy(MARK,AvARRAY(av),items,SV*);
2002             AvFILL(av) = items - 1;
2003             
2004             while (items--) {
2005                 if (*MARK)
2006                     SvTEMP_off(*MARK);
2007                 MARK++;
2008             }
2009         }
2010         RETURNOP(CvSTART(cv));
2011     }
2012 }
2013
2014 PP(pp_aelem)
2015 {
2016     dSP;
2017     SV** svp;
2018     I32 elem = POPi;
2019     AV *av = (AV*)POPs;
2020     I32 lval = op->op_flags & OPf_MOD;
2021
2022     if (elem > 0)
2023         elem -= curcop->cop_arybase;
2024     if (SvTYPE(av) != SVt_PVAV)
2025         RETPUSHUNDEF;
2026     svp = av_fetch(av, elem, lval);
2027     if (lval) {
2028         if (!svp || *svp == &sv_undef)
2029             DIE(no_aelem, elem);
2030         if (op->op_private & OPpLVAL_INTRO)
2031             save_svref(svp);
2032         else if (op->op_private & (OPpDEREF_HV|OPpDEREF_AV))
2033             provide_ref(op, *svp);
2034     }
2035     PUSHs(svp ? *svp : &sv_undef);
2036     RETURN;
2037 }
2038
2039 void
2040 provide_ref(o, sv)
2041 OP* o;
2042 SV* sv;
2043 {
2044     if (SvGMAGICAL(sv))
2045         mg_get(sv);
2046     if (!SvOK(sv)) {
2047         if (SvREADONLY(sv))
2048             croak(no_modify);
2049         (void)SvUPGRADE(sv, SVt_RV);
2050         SvRV(sv) = (o->op_private & OPpDEREF_HV ?
2051                     (SV*)newHV() : (SV*)newAV());
2052         SvROK_on(sv);
2053         SvSETMAGIC(sv);
2054     }
2055 }
2056
2057 PP(pp_method)
2058 {
2059     dSP;
2060     SV* sv;
2061     SV* ob;
2062     GV* gv;
2063     SV* nm;
2064
2065     nm = TOPs;
2066     sv = *(stack_base + TOPMARK + 1);
2067     
2068     gv = 0;
2069     if (SvGMAGICAL(sv))
2070         mg_get(sv);
2071     if (SvROK(sv))
2072         ob = (SV*)SvRV(sv);
2073     else {
2074         GV* iogv;
2075         char* packname = 0;
2076
2077         if (!SvOK(sv) ||
2078             !(packname = SvPV(sv, na)) ||
2079             !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
2080             !(ob=(SV*)GvIO(iogv)))
2081         {
2082             char *name = SvPV(nm, na);
2083             HV *stash;
2084             if (!packname || !isALPHA(*packname))
2085 DIE("Can't call method \"%s\" without a package or object reference", name);
2086             if (!(stash = gv_stashpv(packname, FALSE))) {
2087                 if (gv_stashpv("UNIVERSAL", FALSE))
2088                     stash = gv_stashpv(packname, TRUE);
2089                 else
2090                     DIE("Can't call method \"%s\" in empty package \"%s\"",
2091                         name, packname);
2092             }
2093             gv = gv_fetchmethod(stash,name);
2094             if (!gv)
2095                 DIE("Can't locate object method \"%s\" via package \"%s\"",
2096                     name, packname);
2097             SETs(gv);
2098             RETURN;
2099         }
2100         *(stack_base + TOPMARK + 1) = sv_2mortal(newRV(iogv));
2101     }
2102
2103     if (!ob || !SvOBJECT(ob)) {
2104         char *name = SvPV(nm, na);
2105         DIE("Can't call method \"%s\" on unblessed reference", name);
2106     }
2107
2108     if (!gv) {          /* nothing cached */
2109         char *name = SvPV(nm, na);
2110         gv = gv_fetchmethod(SvSTASH(ob),name);
2111         if (!gv)
2112             DIE("Can't locate object method \"%s\" via package \"%s\"",
2113                 name, HvNAME(SvSTASH(ob)));
2114     }
2115
2116     SETs(gv);
2117     RETURN;
2118 }
2119