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