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