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