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