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
perl 5.0 alpha 2
[perl5.git] / pp.c
CommitLineData
79072805
LW		 1/***********************************************************
2 *
3 * $Header: /usr/src/local/lwall/perl5/RCS/pp.c, v 4.1 92/08/07 18:26:21 lwall Exp Locker: lwall $
4 *
5 * Description:
6 * Push/Pop code.
7 *
8 * Standards:
9 *
10 * Created:
11 * Mon Jun 15 16:45:59 1992
12 *
13 * Author:
14 * Larry Wall <lwall@netlabs.com>
15 *
16 * $Log: pp.c, v $
17 * Revision 4.1 92/08/07 18:26:21 lwall
18 *
19 *
20 **********************************************************/
21
22#include "EXTERN.h"
23#include "perl.h"
24
25#ifdef HAS_SOCKET
26#include <sys/socket.h>
27#include <netdb.h>
28#ifndef ENOTSOCK
29#include <net/errno.h>
30#endif
31#endif
32
33#ifdef HAS_SELECT
34#ifdef I_SYS_SELECT
35#ifndef I_SYS_TIME
36#include <sys/select.h>
37#endif
38#endif
39#endif
40
41#ifdef HOST_NOT_FOUND
42extern int h_errno;
43#endif
44
45#ifdef I_PWD
46#include <pwd.h>
47#endif
48#ifdef I_GRP
49#include <grp.h>
50#endif
51#ifdef I_UTIME
52#include <utime.h>
53#endif
54#ifdef I_FCNTL
55#include <fcntl.h>
56#endif
57#ifdef I_SYS_FILE
58#include <sys/file.h>
59#endif
60
61#ifdef I_VARARGS
62# include <varargs.h>
63#endif
64
65/* Nothing. */
66
67PP(pp_null)
68{
69 return NORMAL;
70}
71
72PP(pp_scalar)
73{
74 return NORMAL;
75}
76
77/* Pushy stuff. */
78
79PP(pp_pushmark)
80{
81 if (++markstack_ptr == markstack_max) {
82 I32 oldmax = markstack_max - markstack;
83 I32 newmax = oldmax * 3 / 2;
84
85 Renew(markstack, newmax, I32);
86 markstack_ptr = markstack + oldmax;
87 markstack_max = markstack + newmax;
88 }
89 *markstack_ptr = stack_sp - stack_base;
90 return NORMAL;
91}
92
93PP(pp_wantarray)
94{
95 dSP;
96 I32 cxix;
97 EXTEND(SP, 1);
98
99 cxix = dopoptosub(cxstack_ix);
100 if (cxix < 0)
101 RETPUSHUNDEF;
102
103 if (cxstack[cxix].blk_gimme == G_ARRAY)
104 RETPUSHYES;
105 else
106 RETPUSHNO;
107}
108
109PP(pp_word)
110{
111 DIE("PP_WORD");
112}
113
114PP(pp_const)
115{
116 dSP;
117 XPUSHs(cSVOP->op_sv);
118 RETURN;
119}
120
121static void
122ucase(s,send)
123register char *s;
124register char *send;
125{
126 while (s < send) {
127 if (isLOWER(*s))
128 *s = toupper(*s);
129 s++;
130 }
131}
132
133static void
134lcase(s,send)
135register char *s;
136register char *send;
137{
138 while (s < send) {
139 if (isUPPER(*s))
140 *s = tolower(*s);
141 s++;
142 }
143}
144
145PP(pp_interp)
146{
147 DIE("panic: pp_interp");
148}
149
150PP(pp_gvsv)
151{
152 dSP;
153 EXTEND(sp,1);
154 if (op->op_flags & OPf_LOCAL)
155 PUSHs(save_scalar(cGVOP->op_gv));
156 else
157 PUSHs(GvSV(cGVOP->op_gv));
158 RETURN;
159}
160
161PP(pp_gv)
162{
163 dSP;
164 XPUSHs((SV*)cGVOP->op_gv);
165 RETURN;
166}
167
168PP(pp_pushre)
169{
170 dSP;
171 XPUSHs((SV*)op);
172 RETURN;
173}
174
175/* Translations. */
176
177PP(pp_rv2gv)
178{
179 dSP; dTOPss;
180 if (SvTYPE(sv) == SVt_REF) {
181 sv = (SV*)SvANY(sv);
182 if (SvTYPE(sv) != SVt_PVGV)
183 DIE("Not a glob reference");
184 }
185 else {
186 if (SvTYPE(sv) != SVt_PVGV)
187 sv = (SV*)gv_fetchpv(SvPVn(sv), TRUE);
188 }
189 if (op->op_flags & OPf_LOCAL) {
190 GP *ogp = GvGP(sv);
191
192 SSCHECK(3);
193 SSPUSHPTR(sv);
194 SSPUSHPTR(ogp);
195 SSPUSHINT(SAVEt_GP);
196
197 if (op->op_flags & OPf_SPECIAL)
198 GvGP(sv)->gp_refcnt++; /* will soon be assigned */
199 else {
200 GP *gp;
201 Newz(602,gp, 1, GP);
202 GvGP(sv) = gp;
203 GvREFCNT(sv) = 1;
204 GvSV(sv) = NEWSV(72,0);
205 GvLINE(sv) = curcop->cop_line;
206 GvEGV(sv) = sv;
207 }
208 }
209 SETs(sv);
210 RETURN;
211}
212
213PP(pp_sv2len)
214{
215 dSP; dTARGET;
216 dPOPss;
217 PUSHi(sv_len(sv));
218 RETURN;
219}
220
221PP(pp_rv2sv)
222{
223 dSP; dTOPss;
224
225 if (SvTYPE(sv) == SVt_REF) {
226 sv = (SV*)SvANY(sv);
227 switch (SvTYPE(sv)) {
228 case SVt_PVAV:
229 case SVt_PVHV:
230 case SVt_PVCV:
231 DIE("Not a scalar reference");
232 }
233 }
234 else {
235 if (SvTYPE(sv) != SVt_PVGV)
236 sv = (SV*)gv_fetchpv(SvPVn(sv), TRUE);
237 sv = GvSV(sv);
238 }
239 if (op->op_flags & OPf_LOCAL)
240 SETs(save_scalar((GV*)TOPs));
241 else
242 SETs(sv);
243 RETURN;
244}
245
246PP(pp_av2arylen)
247{
248 dSP;
249 AV *av = (AV*)TOPs;
250 SV *sv = AvARYLEN(av);
251 if (!sv) {
252 AvARYLEN(av) = sv = NEWSV(0,0);
253 sv_upgrade(sv, SVt_IV);
254 sv_magic(sv, (SV*)av, '#', Nullch, 0);
255 }
256 SETs(sv);
257 RETURN;
258}
259
260PP(pp_rv2cv)
261{
262 dSP;
263 SV *sv;
264 GV *gv;
265 HV *stash;
266 CV *cv = sv_2cv(TOPs, &stash, &gv, 0);
267
268 SETs((SV*)cv);
269 RETURN;
270}
271
272PP(pp_refgen)
273{
274 dSP; dTOPss;
275 SV* rv;
276 if (!sv)
277 RETSETUNDEF;
278 rv = sv_mortalcopy(&sv_undef);
279 sv_upgrade(rv, SVt_REF);
280 SvANY(rv) = (void*)sv_ref(sv);
281 SETs(rv);
282 RETURN;
283}
284
285PP(pp_ref)
286{
287 dSP; dTARGET; dTOPss;
288 char *pv;
289
290 if (SvTYPE(sv) != SVt_REF)
291 RETSETUNDEF;
292
293 sv = (SV*)SvANY(sv);
294 if (SvSTORAGE(sv) == 'O')
295 pv = HvNAME(SvSTASH(sv));
296 else {
297 switch (SvTYPE(sv)) {
298 case SVt_REF: pv = "REF"; break;
299 case SVt_NULL:
300 case SVt_IV:
301 case SVt_NV:
302 case SVt_PV:
303 case SVt_PVIV:
304 case SVt_PVNV:
305 case SVt_PVMG:
306 case SVt_PVBM: pv = "SCALAR"; break;
307 case SVt_PVLV: pv = "LVALUE"; break;
308 case SVt_PVAV: pv = "ARRAY"; break;
309 case SVt_PVHV: pv = "HASH"; break;
310 case SVt_PVCV: pv = "CODE"; break;
311 case SVt_PVGV: pv = "GLOB"; break;
312 case SVt_PVFM: pv = "FORMLINE"; break;
313 default: pv = "UNKNOWN"; break;
314 }
315 }
316 SETp(pv, strlen(pv));
317 RETURN;
318}
319
320PP(pp_bless)
321{
322 dSP; dTOPss;
323 register SV* ref;
324
325 if (SvTYPE(sv) != SVt_REF)
326 RETSETUNDEF;
327
328 ref = (SV*)SvANY(sv);
329 if (SvSTORAGE(ref) && SvSTORAGE(ref) != 'O')
330 DIE("Can't bless temporary scalar");
331 SvSTORAGE(ref) = 'O';
332 SvUPGRADE(ref, SVt_PVMG);
333 SvSTASH(ref) = curcop->cop_stash;
334 RETURN;
335}
336
337/* Pushy I/O. */
338
339PP(pp_backtick)
340{
341 dSP; dTARGET;
342 FILE *fp;
343 char *tmps = POPp;
344#ifdef TAINT
345 TAINT_PROPER("``");
346#endif
347 fp = my_popen(tmps, "r");
348 if (fp) {
349 sv_setpv(TARG, ""); /* note that this preserves previous buffer */
350 if (GIMME == G_SCALAR) {
351 while (sv_gets(TARG, fp, SvCUR(TARG)) != Nullch)
352 /*SUPPRESS 530*/
353 ;
354 XPUSHs(TARG);
355 }
356 else {
357 SV *sv;
358
359 for (;;) {
360 sv = NEWSV(56, 80);
361 if (sv_gets(sv, fp, 0) == Nullch) {
362 sv_free(sv);
363 break;
364 }
365 XPUSHs(sv_2mortal(sv));
366 if (SvLEN(sv) - SvCUR(sv) > 20) {
367 SvLEN_set(sv, SvCUR(sv)+1);
368 Renew(SvPV(sv), SvLEN(sv), char);
369 }
370 }
371 }
372 statusvalue = my_pclose(fp);
373 }
374 else {
375 statusvalue = -1;
376 if (GIMME == G_SCALAR)
377 RETPUSHUNDEF;
378 }
379
380 RETURN;
381}
382
383OP *
384do_readline()
385{
386 dSP; dTARGETSTACKED;
387 register SV *sv;
388 STRLEN tmplen;
389 STRLEN offset;
390 FILE *fp;
391 register IO *io = GvIO(last_in_gv);
392 register I32 type = op->op_type;
393
394 fp = Nullfp;
395 if (io) {
396 fp = io->ifp;
397 if (!fp) {
398 if (io->flags & IOf_ARGV) {
399 if (io->flags & IOf_START) {
400 io->flags &= ~IOf_START;
401 io->lines = 0;
402 if (av_len(GvAVn(last_in_gv)) < 0) {
403 SV *tmpstr = newSVpv("-", 1); /* assume stdin */
404 (void)av_push(GvAVn(last_in_gv), tmpstr);
405 }
406 }
407 fp = nextargv(last_in_gv);
408 if (!fp) { /* Note: fp != io->ifp */
409 (void)do_close(last_in_gv, FALSE); /* now it does*/
410 io->flags |= IOf_START;
411 }
412 }
413 else if (type == OP_GLOB) {
414 SV *tmpcmd = NEWSV(55, 0);
415 SV *tmpglob = POPs;
416#ifdef DOSISH
417 sv_setpv(tmpcmd, "perlglob ");
418 sv_catsv(tmpcmd, tmpglob);
419 sv_catpv(tmpcmd, " |");
420#else
421#ifdef CSH
422 sv_setpvn(tmpcmd, cshname, cshlen);
423 sv_catpv(tmpcmd, " -cf 'set nonomatch; glob ");
424 sv_catsv(tmpcmd, tmpglob);
425 sv_catpv(tmpcmd, "'|");
426#else
427 sv_setpv(tmpcmd, "echo ");
428 sv_catsv(tmpcmd, tmpglob);
429 sv_catpv(tmpcmd, "|tr -s ' \t\f\r' '\\012\\012\\012\\012'|");
430#endif /* !CSH */
431#endif /* !MSDOS */
432 (void)do_open(last_in_gv, SvPV(tmpcmd), SvCUR(tmpcmd));
433 fp = io->ifp;
434 sv_free(tmpcmd);
435 }
436 }
437 else if (type == OP_GLOB)
438 SP--;
439 }
440 if (!fp) {
441 if (dowarn)
442 warn("Read on closed filehandle <%s>", GvENAME(last_in_gv));
443 if (GIMME == G_SCALAR)
444 RETPUSHUNDEF;
445 RETURN;
446 }
447 if (GIMME == G_ARRAY) {
448 sv = sv_2mortal(NEWSV(57, 80));
449 offset = 0;
450 }
451 else {
452 sv = TARG;
453 SvUPGRADE(sv, SVt_PV);
454 tmplen = SvLEN(sv); /* remember if already alloced */
455 if (!tmplen)
456 Sv_Grow(sv, 80); /* try short-buffering it */
457 if (type == OP_RCATLINE)
458 offset = SvCUR(sv);
459 else
460 offset = 0;
461 }
462 for (;;) {
463 if (!sv_gets(sv, fp, offset)) {
464 clearerr(fp);
465 if (io->flags & IOf_ARGV) {
466 fp = nextargv(last_in_gv);
467 if (fp)
468 continue;
469 (void)do_close(last_in_gv, FALSE);
470 io->flags |= IOf_START;
471 }
472 else if (type == OP_GLOB) {
473 (void)do_close(last_in_gv, FALSE);
474 }
475 if (GIMME == G_SCALAR)
476 RETPUSHUNDEF;
477 RETURN;
478 }
479 io->lines++;
480 XPUSHs(sv);
481#ifdef TAINT
482 sv->sv_tainted = 1; /* Anything from the outside world...*/
483#endif
484 if (type == OP_GLOB) {
485 char *tmps;
486
487 if (SvCUR(sv) > 0)
488 SvCUR(sv)--;
489 if (*SvEND(sv) == rschar)
490 *SvEND(sv) = '\0';
491 else
492 SvCUR(sv)++;
493 for (tmps = SvPV(sv); *tmps; tmps++)
494 if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
495 index("$&*(){}[]'\";\\|?<>~`", *tmps))
496 break;
497 if (*tmps && stat(SvPV(sv), &statbuf) < 0) {
498 POPs; /* Unmatched wildcard? Chuck it... */
499 continue;
500 }
501 }
502 if (GIMME == G_ARRAY) {
503 if (SvLEN(sv) - SvCUR(sv) > 20) {
504 SvLEN_set(sv, SvCUR(sv)+1);
505 Renew(SvPV(sv), SvLEN(sv), char);
506 }
507 sv = sv_2mortal(NEWSV(58, 80));
508 continue;
509 }
510 else if (!tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
511 /* try to reclaim a bit of scalar space (only on 1st alloc) */
512 if (SvCUR(sv) < 60)
513 SvLEN_set(sv, 80);
514 else
515 SvLEN_set(sv, SvCUR(sv)+40); /* allow some slop */
516 Renew(SvPV(sv), SvLEN(sv), char);
517 }
518 RETURN;
519 }
520}
521
522PP(pp_glob)
523{
524 OP *result;
525 ENTER;
526 SAVEINT(rschar);
527 SAVEINT(rslen);
528
529 SAVESPTR(last_in_gv); /* We don't want this to be permanent. */
530 last_in_gv = (GV*)*stack_sp--;
531
532 rslen = 1;
533#ifdef DOSISH
534 rschar = 0;
535#else
536#ifdef CSH
537 rschar = 0;
538#else
539 rschar = '\n';
540#endif /* !CSH */
541#endif /* !MSDOS */
542 result = do_readline();
543 LEAVE;
544 return result;
545}
546
547PP(pp_readline)
548{
549 last_in_gv = (GV*)(*stack_sp--);
550 return do_readline();
551}
552
553PP(pp_indread)
554{
555 last_in_gv = gv_fetchpv(SvPVnx(GvSV((GV*)(*stack_sp--))), TRUE);
556 return do_readline();
557}
558
559PP(pp_rcatline)
560{
561 last_in_gv = cGVOP->op_gv;
562 return do_readline();
563}
564
565PP(pp_regcomp) {
566 dSP;
567 register PMOP *pm = (PMOP*)cLOGOP->op_other;
568 register char *t;
569 I32 global;
570 SV *tmpstr;
571 register REGEXP *rx = pm->op_pmregexp;
572
573 global = pm->op_pmflags & PMf_GLOBAL;
574 tmpstr = POPs;
575 t = SvPVn(tmpstr);
576 if (!global && rx)
577 regfree(rx);
578 pm->op_pmregexp = Null(REGEXP*); /* crucial if regcomp aborts */
579 pm->op_pmregexp = regcomp(t, t+SvCUR(tmpstr),
580 pm->op_pmflags & PMf_FOLD);
581 if (!pm->op_pmregexp->prelen && curpm)
582 pm = curpm;
583 if (pm->op_pmflags & PMf_KEEP) {
584 if (!(pm->op_pmflags & PMf_FOLD))
585 scan_prefix(pm, pm->op_pmregexp->precomp,
586 pm->op_pmregexp->prelen);
587 pm->op_pmflags &= ~PMf_RUNTIME; /* no point compiling again */
588 hoistmust(pm);
589 op->op_type = OP_NULL;
590 op->op_ppaddr = ppaddr[OP_NULL];
591 /* XXX delete push code */
592 }
593 RETURN;
594}
595
596PP(pp_match)
597{
598 dSP; dTARG;
599 register PMOP *pm = cPMOP;
600 register char *t;
601 register char *s;
602 char *strend;
603 SV *tmpstr;
604 char *myhint = hint;
605 I32 global;
606 I32 safebase;
607 char *truebase;
608 register REGEXP *rx = pm->op_pmregexp;
609 I32 gimme = GIMME;
610
611 hint = Nullch;
612 global = pm->op_pmflags & PMf_GLOBAL;
613 safebase = (gimme == G_ARRAY) || global;
614
615 if (op->op_flags & OPf_STACKED)
616 TARG = POPs;
617 else {
618 TARG = GvSV(defgv);
619 EXTEND(SP,1);
620 }
621 s = SvPVn(TARG);
622 strend = s + SvCUR(TARG);
623 if (!s)
624 DIE("panic: do_match");
625
626 if (pm->op_pmflags & PMf_USED) {
627 if (gimme == G_ARRAY)
628 RETURN;
629 RETPUSHNO;
630 }
631
632 if (!rx->prelen && curpm) {
633 pm = curpm;
634 rx = pm->op_pmregexp;
635 }
636 truebase = t = s;
637play_it_again:
638 if (global && rx->startp[0]) {
639 t = s = rx->endp[0];
640 if (s == rx->startp[0])
641 s++, t++;
642 if (s > strend)
643 goto nope;
644 }
645 if (myhint) {
646 if (myhint < s || myhint > strend)
647 DIE("panic: hint in do_match");
648 s = myhint;
649 if (rx->regback >= 0) {
650 s -= rx->regback;
651 if (s < t)
652 s = t;
653 }
654 else
655 s = t;
656 }
657 else if (pm->op_pmshort) {
658 if (pm->op_pmflags & PMf_SCANFIRST) {
659 if (SvSCREAM(TARG)) {
660 if (screamfirst[BmRARE(pm->op_pmshort)] < 0)
661 goto nope;
662 else if (!(s = screaminstr(TARG, pm->op_pmshort)))
663 goto nope;
664 else if (pm->op_pmflags & PMf_ALL)
665 goto yup;
666 }
667 else if (!(s = fbm_instr((unsigned char*)s,
668 (unsigned char*)strend, pm->op_pmshort)))
669 goto nope;
670 else if (pm->op_pmflags & PMf_ALL)
671 goto yup;
672 if (s && rx->regback >= 0) {
673 ++BmUSEFUL(pm->op_pmshort);
674 s -= rx->regback;
675 if (s < t)
676 s = t;
677 }
678 else
679 s = t;
680 }
681 else if (!multiline) {
682 if (*SvPV(pm->op_pmshort) != *s ||
683 bcmp(SvPV(pm->op_pmshort), s, pm->op_pmslen) ) {
684 if (pm->op_pmflags & PMf_FOLD) {
685 if (ibcmp(SvPV(pm->op_pmshort), s, pm->op_pmslen) )
686 goto nope;
687 }
688 else
689 goto nope;
690 }
691 }
692 if (--BmUSEFUL(pm->op_pmshort) < 0) {
693 sv_free(pm->op_pmshort);
694 pm->op_pmshort = Nullsv; /* opt is being useless */
695 }
696 }
697 if (!rx->nparens && !global) {
698 gimme = G_SCALAR; /* accidental array context? */
699 safebase = FALSE;
700 }
701 if (regexec(rx, s, strend, truebase, 0,
702 SvSCREAM(TARG) ? TARG : Nullsv,
703 safebase)) {
704 curpm = pm;
705 if (pm->op_pmflags & PMf_ONCE)
706 pm->op_pmflags |= PMf_USED;
707 goto gotcha;
708 }
709 else {
710 if (global)
711 rx->startp[0] = Nullch;
712 if (gimme == G_ARRAY)
713 RETURN;
714 RETPUSHNO;
715 }
716 /*NOTREACHED*/
717
718 gotcha:
719 if (gimme == G_ARRAY) {
720 I32 iters, i, len;
721
722 iters = rx->nparens;
723 if (global && !iters)
724 i = 1;
725 else
726 i = 0;
727 EXTEND(SP, iters + i);
728 for (i = !i; i <= iters; i++) {
729 PUSHs(sv_mortalcopy(&sv_no));
730 /*SUPPRESS 560*/
731 if (s = rx->startp[i]) {
732 len = rx->endp[i] - s;
733 if (len > 0)
734 sv_setpvn(*SP, s, len);
735 }
736 }
737 if (global) {
738 truebase = rx->subbeg;
739 goto play_it_again;
740 }
741 RETURN;
742 }
743 else {
744 RETPUSHYES;
745 }
746
747yup:
748 ++BmUSEFUL(pm->op_pmshort);
749 curpm = pm;
750 if (pm->op_pmflags & PMf_ONCE)
751 pm->op_pmflags |= PMf_USED;
752 if (global) {
753 rx->subbeg = t;
754 rx->subend = strend;
755 rx->startp[0] = s;
756 rx->endp[0] = s + SvCUR(pm->op_pmshort);
757 goto gotcha;
758 }
759 if (sawampersand) {
760 char *tmps;
761
762 if (rx->subbase)
763 Safefree(rx->subbase);
764 tmps = rx->subbase = nsavestr(t, strend-t);
765 rx->subbeg = tmps;
766 rx->subend = tmps + (strend-t);
767 tmps = rx->startp[0] = tmps + (s - t);
768 rx->endp[0] = tmps + SvCUR(pm->op_pmshort);
769 }
770 RETPUSHYES;
771
772nope:
773 rx->startp[0] = Nullch;
774 if (pm->op_pmshort)
775 ++BmUSEFUL(pm->op_pmshort);
776 if (gimme == G_ARRAY)
777 RETURN;
778 RETPUSHNO;
779}
780
781PP(pp_subst)
782{
783 dSP; dTARG;
784 register PMOP *pm = cPMOP;
785 PMOP *rpm = pm;
786 register SV *dstr;
787 register char *s;
788 char *strend;
789 register char *m;
790 char *c;
791 register char *d;
792 I32 clen;
793 I32 iters = 0;
794 I32 maxiters;
795 register I32 i;
796 bool once;
797 char *orig;
798 I32 safebase;
799 register REGEXP *rx = pm->op_pmregexp;
800
801 if (pm->op_pmflags & PMf_CONST) /* known replacement string? */
802 dstr = POPs;
803 if (op->op_flags & OPf_STACKED)
804 TARG = POPs;
805 else {
806 TARG = GvSV(defgv);
807 EXTEND(SP,1);
808 }
809 s = SvPVn(TARG);
810 if (!pm || !s)
811 DIE("panic: do_subst");
812
813 strend = s + SvCUR(TARG);
814 maxiters = (strend - s) + 10;
815
816 if (!rx->prelen && curpm) {
817 pm = curpm;
818 rx = pm->op_pmregexp;
819 }
820 safebase = ((!rx || !rx->nparens) && !sawampersand);
821 orig = m = s;
822 if (hint) {
823 if (hint < s || hint > strend)
824 DIE("panic: hint in do_match");
825 s = hint;
826 hint = Nullch;
827 if (rx->regback >= 0) {
828 s -= rx->regback;
829 if (s < m)
830 s = m;
831 }
832 else
833 s = m;
834 }
835 else if (pm->op_pmshort) {
836 if (pm->op_pmflags & PMf_SCANFIRST) {
837 if (SvSCREAM(TARG)) {
838 if (screamfirst[BmRARE(pm->op_pmshort)] < 0)
839 goto nope;
840 else if (!(s = screaminstr(TARG, pm->op_pmshort)))
841 goto nope;
842 }
843 else if (!(s = fbm_instr((unsigned char*)s, (unsigned char*)strend,
844 pm->op_pmshort)))
845 goto nope;
846 if (s && rx->regback >= 0) {
847 ++BmUSEFUL(pm->op_pmshort);
848 s -= rx->regback;
849 if (s < m)
850 s = m;
851 }
852 else
853 s = m;
854 }
855 else if (!multiline) {
856 if (*SvPV(pm->op_pmshort) != *s ||
857 bcmp(SvPV(pm->op_pmshort), s, pm->op_pmslen) ) {
858 if (pm->op_pmflags & PMf_FOLD) {
859 if (ibcmp(SvPV(pm->op_pmshort), s, pm->op_pmslen) )
860 goto nope;
861 }
862 else
863 goto nope;
864 }
865 }
866 if (--BmUSEFUL(pm->op_pmshort) < 0) {
867 sv_free(pm->op_pmshort);
868 pm->op_pmshort = Nullsv; /* opt is being useless */
869 }
870 }
871 once = !(rpm->op_pmflags & PMf_GLOBAL);
872 if (rpm->op_pmflags & PMf_CONST) { /* known replacement string? */
873 c = SvPVn(dstr);
874 clen = SvCUR(dstr);
875 if (clen <= rx->minlen) {
876 /* can do inplace substitution */
877 if (regexec(rx, s, strend, orig, 0,
878 SvSCREAM(TARG) ? TARG : Nullsv, safebase)) {
879 if (rx->subbase) /* oops, no we can't */
880 goto long_way;
881 d = s;
882 curpm = pm;
883 SvSCREAM_off(TARG); /* disable possible screamer */
884 if (once) {
885 m = rx->startp[0];
886 d = rx->endp[0];
887 s = orig;
888 if (m - s > strend - d) { /* faster to shorten from end */
889 if (clen) {
890 Copy(c, m, clen, char);
891 m += clen;
892 }
893 i = strend - d;
894 if (i > 0) {
895 Move(d, m, i, char);
896 m += i;
897 }
898 *m = '\0';
899 SvCUR_set(TARG, m - s);
900 SvNOK_off(TARG);
901 SvSETMAGIC(TARG);
902 PUSHs(&sv_yes);
903 RETURN;
904 }
905 /*SUPPRESS 560*/
906 else if (i = m - s) { /* faster from front */
907 d -= clen;
908 m = d;
909 sv_chop(TARG, d-i);
910 s += i;
911 while (i--)
912 *--d = *--s;
913 if (clen)
914 Copy(c, m, clen, char);
915 SvNOK_off(TARG);
916 SvSETMAGIC(TARG);
917 PUSHs(&sv_yes);
918 RETURN;
919 }
920 else if (clen) {
921 d -= clen;
922 sv_chop(TARG, d);
923 Copy(c, d, clen, char);
924 SvNOK_off(TARG);
925 SvSETMAGIC(TARG);
926 PUSHs(&sv_yes);
927 RETURN;
928 }
929 else {
930 sv_chop(TARG, d);
931 SvNOK_off(TARG);
932 SvSETMAGIC(TARG);
933 PUSHs(&sv_yes);
934 RETURN;
935 }
936 /* NOTREACHED */
937 }
938 do {
939 if (iters++ > maxiters)
940 DIE("Substitution loop");
941 m = rx->startp[0];
942 /*SUPPRESS 560*/
943 if (i = m - s) {
944 if (s != d)
945 Move(s, d, i, char);
946 d += i;
947 }
948 if (clen) {
949 Copy(c, d, clen, char);
950 d += clen;
951 }
952 s = rx->endp[0];
953 } while (regexec(rx, s, strend, orig, s == m,
954 Nullsv, TRUE)); /* (don't match same null twice) */
955 if (s != d) {
956 i = strend - s;
957 SvCUR_set(TARG, d - SvPV(TARG) + i);
958 Move(s, d, i+1, char); /* include the Null */
959 }
960 SvNOK_off(TARG);
961 SvSETMAGIC(TARG);
962 PUSHs(sv_2mortal(newSVnv((double)iters)));
963 RETURN;
964 }
965 PUSHs(&sv_no);
966 RETURN;
967 }
968 }
969 else
970 c = Nullch;
971 if (regexec(rx, s, strend, orig, 0,
972 SvSCREAM(TARG) ? TARG : Nullsv, safebase)) {
973 long_way:
974 dstr = NEWSV(25, sv_len(TARG));
975 sv_setpvn(dstr, m, s-m);
976 curpm = pm;
977 if (!c) {
978 register CONTEXT *cx;
979 PUSHSUBST(cx);
980 RETURNOP(cPMOP->op_pmreplroot);
981 }
982 do {
983 if (iters++ > maxiters)
984 DIE("Substitution loop");
985 if (rx->subbase && rx->subbase != orig) {
986 m = s;
987 s = orig;
988 orig = rx->subbase;
989 s = orig + (m - s);
990 strend = s + (strend - m);
991 }
992 m = rx->startp[0];
993 sv_catpvn(dstr, s, m-s);
994 s = rx->endp[0];
995 if (clen)
996 sv_catpvn(dstr, c, clen);
997 if (once)
998 break;
999 } while (regexec(rx, s, strend, orig, s == m, Nullsv,
1000 safebase));
1001 sv_catpvn(dstr, s, strend - s);
1002 sv_replace(TARG, dstr);
1003 SvNOK_off(TARG);
1004 SvSETMAGIC(TARG);
1005 PUSHs(sv_2mortal(newSVnv((double)iters)));
1006 RETURN;
1007 }
1008 PUSHs(&sv_no);
1009 RETURN;
1010
1011nope:
1012 ++BmUSEFUL(pm->op_pmshort);
1013 PUSHs(&sv_no);
1014 RETURN;
1015}
1016
1017PP(pp_substcont)
1018{
1019 dSP;
1020 register PMOP *pm = (PMOP*) cLOGOP->op_other;
1021 register CONTEXT *cx = &cxstack[cxstack_ix];
1022 register SV *dstr = cx->sb_dstr;
1023 register char *s = cx->sb_s;
1024 register char *m = cx->sb_m;
1025 char *orig = cx->sb_orig;
1026 register REGEXP *rx = pm->op_pmregexp;
1027
1028 if (cx->sb_iters++) {
1029 if (cx->sb_iters > cx->sb_maxiters)
1030 DIE("Substitution loop");
1031
1032 sv_catsv(dstr, POPs);
1033 if (rx->subbase)
1034 Safefree(rx->subbase);
1035 rx->subbase = cx->sb_subbase;
1036
1037 /* Are we done */
1038 if (cx->sb_once || !regexec(rx, s, cx->sb_strend, orig,
1039 s == m, Nullsv, cx->sb_safebase))
1040 {
1041 SV *targ = cx->sb_targ;
1042 sv_catpvn(dstr, s, cx->sb_strend - s);
1043 sv_replace(targ, dstr);
1044 SvNOK_off(targ);
1045 SvSETMAGIC(targ);
1046 PUSHs(sv_2mortal(newSVnv((double)(cx->sb_iters - 1))));
1047 POPSUBST(cx);
1048 RETURNOP(pm->op_next);
1049 }
1050 }
1051 if (rx->subbase && rx->subbase != orig) {
1052 m = s;
1053 s = orig;
1054 cx->sb_orig = orig = rx->subbase;
1055 s = orig + (m - s);
1056 cx->sb_strend = s + (cx->sb_strend - m);
1057 }
1058 cx->sb_m = m = rx->startp[0];
1059 sv_catpvn(dstr, s, m-s);
1060 cx->sb_s = rx->endp[0];
1061 cx->sb_subbase = rx->subbase;
1062
1063 rx->subbase = Nullch; /* so recursion works */
1064 RETURNOP(pm->op_pmreplstart);
1065}
1066
1067PP(pp_trans)
1068{
1069 dSP; dTARG;
1070 SV *sv;
1071
1072 if (op->op_flags & OPf_STACKED)
1073 sv = POPs;
1074 else {
1075 sv = GvSV(defgv);
1076 EXTEND(SP,1);
1077 }
1078 TARG = NEWSV(27,0);
1079 PUSHi(do_trans(sv, op));
1080 RETURN;
1081}
1082
1083/* Lvalue operators. */
1084
1085PP(pp_sassign)
1086{
1087 dSP; dPOPTOPssrl;
1088#ifdef TAINT
1089 if (tainted && !lstr->sv_tainted)
1090 TAINT_NOT;
1091#endif
1092 SvSetSV(rstr, lstr);
1093 SvSETMAGIC(rstr);
1094 SETs(rstr);
1095 RETURN;
1096}
1097
1098PP(pp_aassign)
1099{
1100 dSP;
1101 SV **lastlelem = stack_sp;
1102 SV **lastrelem = stack_base + POPMARK;
1103 SV **firstrelem = stack_base + POPMARK + 1;
1104 SV **firstlelem = lastrelem + 1;
1105
1106 register SV **relem;
1107 register SV **lelem;
1108
1109 register SV *sv;
1110 register AV *ary;
1111
1112 HV *hash;
1113 I32 i;
1114
1115 delaymagic = DM_DELAY; /* catch simultaneous items */
1116
1117 /* If there's a common identifier on both sides we have to take
1118 * special care that assigning the identifier on the left doesn't
1119 * clobber a value on the right that's used later in the list.
1120 */
1121 if (op->op_private & OPpASSIGN_COMMON) {
1122 for (relem = firstrelem; relem <= lastrelem; relem++) {
1123 /*SUPPRESS 560*/
1124 if (sv = *relem)
1125 *relem = sv_mortalcopy(sv);
1126 }
1127 }
1128
1129 relem = firstrelem;
1130 lelem = firstlelem;
1131 ary = Null(AV*);
1132 hash = Null(HV*);
1133 while (lelem <= lastlelem) {
1134 sv = *lelem++;
1135 switch (SvTYPE(sv)) {
1136 case SVt_PVAV:
1137 ary = (AV*)sv;
1138 AvREAL_on(ary);
1139 AvFILL(ary) = -1;
1140 i = 0;
1141 while (relem <= lastrelem) { /* gobble up all the rest */
1142 sv = NEWSV(28,0);
1143 if (*relem)
1144 sv_setsv(sv,*relem);
1145 *(relem++) = sv;
1146 (void)av_store(ary,i++,sv);
1147 }
1148 break;
1149 case SVt_PVHV: {
1150 char *tmps;
1151 SV *tmpstr;
1152 MAGIC* magic = 0;
1153 I32 magictype;
1154
1155 hash = (HV*)sv;
1156 hv_clear(hash, TRUE); /* wipe any dbm file too */
1157
1158 while (relem < lastrelem) { /* gobble up all the rest */
1159 if (*relem)
1160 sv = *(relem++);
1161 else
1162 sv = &sv_no, relem++;
1163 tmps = SvPVn(sv);
1164 tmpstr = NEWSV(29,0);
1165 if (*relem)
1166 sv_setsv(tmpstr,*relem); /* value */
1167 *(relem++) = tmpstr;
1168 (void)hv_store(hash,tmps,SvCUR(sv),tmpstr,0);
1169 }
1170 }
1171 break;
1172 default:
1173 if (SvREADONLY(sv)) {
1174 if (sv != &sv_undef && sv != &sv_yes && sv != &sv_no)
1175 DIE(no_modify);
1176 if (relem <= lastrelem)
1177 relem++;
1178 break;
1179 }
1180 if (relem <= lastrelem) {
1181 sv_setsv(sv, *relem);
1182 *(relem++) = sv;
1183 }
1184 else
1185 sv_setsv(sv, &sv_undef);
1186 SvSETMAGIC(sv);
1187 break;
1188 }
1189 }
1190 if (delaymagic & ~DM_DELAY) {
1191 if (delaymagic & DM_UID) {
1192#ifdef HAS_SETREUID
1193 (void)setreuid(uid,euid);
1194#else /* not HAS_SETREUID */
1195#ifdef HAS_SETRUID
1196 if ((delaymagic & DM_UID) == DM_RUID) {
1197 (void)setruid(uid);
1198 delaymagic =~ DM_RUID;
1199 }
1200#endif /* HAS_SETRUID */
1201#ifdef HAS_SETEUID
1202 if ((delaymagic & DM_UID) == DM_EUID) {
1203 (void)seteuid(uid);
1204 delaymagic =~ DM_EUID;
1205 }
1206#endif /* HAS_SETEUID */
1207 if (delaymagic & DM_UID) {
1208 if (uid != euid)
1209 DIE("No setreuid available");
1210 (void)setuid(uid);
1211 }
1212#endif /* not HAS_SETREUID */
1213 uid = (int)getuid();
1214 euid = (int)geteuid();
1215 }
1216 if (delaymagic & DM_GID) {
1217#ifdef HAS_SETREGID
1218 (void)setregid(gid,egid);
1219#else /* not HAS_SETREGID */
1220#ifdef HAS_SETRGID
1221 if ((delaymagic & DM_GID) == DM_RGID) {
1222 (void)setrgid(gid);
1223 delaymagic =~ DM_RGID;
1224 }
1225#endif /* HAS_SETRGID */
1226#ifdef HAS_SETEGID
1227 if ((delaymagic & DM_GID) == DM_EGID) {
1228 (void)setegid(gid);
1229 delaymagic =~ DM_EGID;
1230 }
1231#endif /* HAS_SETEGID */
1232 if (delaymagic & DM_GID) {
1233 if (gid != egid)
1234 DIE("No setregid available");
1235 (void)setgid(gid);
1236 }
1237#endif /* not HAS_SETREGID */
1238 gid = (int)getgid();
1239 egid = (int)getegid();
1240 }
1241 }
1242 delaymagic = 0;
1243 if (GIMME == G_ARRAY) {
1244 if (ary || hash)
1245 SP = lastrelem;
1246 else
1247 SP = firstrelem + (lastlelem - firstlelem);
1248 RETURN;
1249 }
1250 else {
1251 dTARGET;
1252 SP = firstrelem;
1253 SETi(lastrelem - firstrelem + 1);
1254 RETURN;
1255 }
1256}
1257
1258PP(pp_schop)
1259{
1260 dSP; dTARGET;
1261 SV *sv;
1262
1263 if (MAXARG < 1)
1264 sv = GvSV(defgv);
1265 else
1266 sv = POPs;
1267 do_chop(TARG, sv);
1268 PUSHTARG;
1269 RETURN;
1270}
1271
1272PP(pp_chop)
1273{
1274 dSP; dMARK; dTARGET;
1275 while (SP > MARK)
1276 do_chop(TARG, POPs);
1277 PUSHTARG;
1278 RETURN;
1279}
1280
1281PP(pp_defined)
1282{
1283 dSP;
1284 register SV* sv;
1285
1286 if (MAXARG < 1) {
1287 sv = GvSV(defgv);
1288 EXTEND(SP, 1);
1289 }
1290 else
1291 sv = POPs;
1292 if (!sv || !SvANY(sv))
1293 RETPUSHNO;
1294 switch (SvTYPE(sv)) {
1295 case SVt_PVAV:
1296 if (AvMAX(sv) >= 0)
1297 RETPUSHYES;
1298 break;
1299 case SVt_PVHV:
1300 if (HvARRAY(sv))
1301 RETPUSHYES;
1302 break;
1303 case SVt_PVCV:
1304 if (CvROOT(sv))
1305 RETPUSHYES;
1306 break;
1307 default:
1308 if (SvOK(sv))
1309 RETPUSHYES;
1310 }
1311 RETPUSHNO;
1312}
1313
1314PP(pp_undef)
1315{
1316 dSP;
1317 SV *sv;
1318
1319 if (!op->op_private)
1320 RETPUSHUNDEF;
1321
1322 sv = POPs;
1323 if (SvREADONLY(sv))
1324 RETPUSHUNDEF;
1325
1326 switch (SvTYPE(sv)) {
1327 case SVt_NULL:
1328 break;
1329 case SVt_PVAV:
1330 av_undef((AV*)sv);
1331 break;
1332 case SVt_PVHV:
1333 hv_undef((HV*)sv);
1334 break;
1335 case SVt_PVCV: {
1336 CV *cv = (CV*)sv;
1337 op_free(CvROOT(cv));
1338 CvROOT(cv) = 0;
1339 break;
1340 }
1341 default:
1342 if (sv != GvSV(defgv)) {
1343 if (SvPOK(sv) && SvLEN(sv)) {
1344 SvOOK_off(sv);
1345 Safefree(SvPV(sv));
1346 SvPV_set(sv, Nullch);
1347 SvLEN_set(sv, 0);
1348 }
1349 SvOK_off(sv);
1350 SvSETMAGIC(sv);
1351 }
1352 }
1353
1354 RETPUSHUNDEF;
1355}
1356
1357PP(pp_study)
1358{
1359 dSP; dTARGET;
1360 register unsigned char *s;
1361 register I32 pos;
1362 register I32 ch;
1363 register I32 *sfirst;
1364 register I32 *snext;
1365 I32 retval;
1366
1367 s = (unsigned char*)(SvPVn(TARG));
1368 pos = SvCUR(TARG);
1369 if (lastscream)
1370 SvSCREAM_off(lastscream);
1371 lastscream = TARG;
1372 if (pos <= 0) {
1373 retval = 0;
1374 goto ret;
1375 }
1376 if (pos > maxscream) {
1377 if (maxscream < 0) {
1378 maxscream = pos + 80;
1379 New(301, screamfirst, 256, I32);
1380 New(302, screamnext, maxscream, I32);
1381 }
1382 else {
1383 maxscream = pos + pos / 4;
1384 Renew(screamnext, maxscream, I32);
1385 }
1386 }
1387
1388 sfirst = screamfirst;
1389 snext = screamnext;
1390
1391 if (!sfirst || !snext)
1392 DIE("do_study: out of memory");
1393
1394 for (ch = 256; ch; --ch)
1395 *sfirst++ = -1;
1396 sfirst -= 256;
1397
1398 while (--pos >= 0) {
1399 ch = s[pos];
1400 if (sfirst[ch] >= 0)
1401 snext[pos] = sfirst[ch] - pos;
1402 else
1403 snext[pos] = -pos;
1404 sfirst[ch] = pos;
1405
1406 /* If there were any case insensitive searches, we must assume they
1407 * all are. This speeds up insensitive searches much more than
1408 * it slows down sensitive ones.
1409 */
1410 if (sawi)
1411 sfirst[fold[ch]] = pos;
1412 }
1413
1414 SvSCREAM_on(TARG);
1415 retval = 1;
1416 ret:
1417 XPUSHs(sv_2mortal(newSVnv((double)retval)));
1418 RETURN;
1419}
1420
1421PP(pp_preinc)
1422{
1423 dSP;
1424 sv_inc(TOPs);
1425 SvSETMAGIC(TOPs);
1426 return NORMAL;
1427}
1428
1429PP(pp_predec)
1430{
1431 dSP;
1432 sv_dec(TOPs);
1433 SvSETMAGIC(TOPs);
1434 return NORMAL;
1435}
1436
1437PP(pp_postinc)
1438{
1439 dSP; dTARGET;
1440 sv_setsv(TARG, TOPs);
1441 sv_inc(TOPs);
1442 SvSETMAGIC(TOPs);
1443 SETs(TARG);
1444 return NORMAL;
1445}
1446
1447PP(pp_postdec)
1448{
1449 dSP; dTARGET;
1450 sv_setsv(TARG, TOPs);
1451 sv_dec(TOPs);
1452 SvSETMAGIC(TOPs);
1453 SETs(TARG);
1454 return NORMAL;
1455}
1456
1457/* Ordinary operators. */
1458
1459PP(pp_pow)
1460{
1461 dSP; dATARGET; dPOPTOPnnrl;
1462 SETn( pow( left, right) );
1463 RETURN;
1464}
1465
1466PP(pp_multiply)
1467{
1468 dSP; dATARGET; dPOPTOPnnrl;
1469 SETn( left * right );
1470 RETURN;
1471}
1472
1473PP(pp_divide)
1474{
1475 dSP; dATARGET; dPOPnv;
1476 if (value == 0.0)
1477 DIE("Illegal division by zero");
1478#ifdef SLOPPYDIVIDE
1479 /* insure that 20./5. == 4. */
1480 {
1481 double x;
1482 I32 k;
1483 x = POPn;
1484 if ((double)(I32)x == x &&
1485 (double)(I32)value == value &&
1486 (k = (I32)x/(I32)value)*(I32)value == (I32)x) {
1487 value = k;
1488 } else {
1489 value = x/value;
1490 }
1491 }
1492#else
1493 value = POPn / value;
1494#endif
1495 PUSHn( value );
1496 RETURN;
1497}
1498
1499PP(pp_modulo)
1500{
1501 dSP; dATARGET;
1502 register unsigned long tmpulong;
1503 register long tmplong;
1504 I32 value;
1505
1506 tmpulong = (unsigned long) POPn;
1507 if (tmpulong == 0L)
1508 DIE("Illegal modulus zero");
1509 value = TOPn;
1510 if (value >= 0.0)
1511 value = (I32)(((unsigned long)value) % tmpulong);
1512 else {
1513 tmplong = (long)value;
1514 value = (I32)(tmpulong - ((-tmplong - 1) % tmpulong)) - 1;
1515 }
1516 SETi(value);
1517 RETURN;
1518}
1519
1520PP(pp_repeat)
1521{
1522 dSP; dATARGET;
1523 register I32 count = POPi;
1524 if (GIMME == G_ARRAY && op->op_private & OPpREPEAT_DOLIST) {
1525 dMARK;
1526 I32 items = SP - MARK;
1527 I32 max;
1528
1529 max = items * count;
1530 MEXTEND(MARK, max);
1531 if (count > 1) {
1532 while (SP > MARK) {
1533 if (*SP)
1534 SvTEMP_off((*SP));
1535 SP--;
1536 }
1537 MARK++;
1538 repeatcpy(MARK + items, MARK, items * sizeof(SV*), count - 1);
1539 }
1540 SP += max;
1541 }
1542 else { /* Note: mark already snarfed by pp_list */
1543 SV *tmpstr;
1544 char *tmps;
1545
1546 tmpstr = POPs;
1547 SvSetSV(TARG, tmpstr);
1548 if (count >= 1) {
1549 tmpstr = NEWSV(50, 0);
1550 tmps = SvPVn(TARG);
1551 sv_setpvn(tmpstr, tmps, SvCUR(TARG));
1552 tmps = SvPVn(tmpstr); /* force to be string */
1553 SvGROW(TARG, (count * SvCUR(TARG)) + 1);
1554 repeatcpy(SvPV(TARG), tmps, SvCUR(tmpstr), count);
1555 SvCUR(TARG) *= count;
1556 *SvEND(TARG) = '\0';
1557 SvNOK_off(TARG);
1558 sv_free(tmpstr);
1559 }
1560 else {
1561 if (dowarn && SvPOK(SP[1]) && !looks_like_number(SP[1]))
1562 warn("Right operand of x is not numeric");
1563 sv_setsv(TARG, &sv_no);
1564 }
1565 PUSHTARG;
1566 }
1567 RETURN;
1568}
1569
1570PP(pp_add)
1571{
1572 dSP; dATARGET; dPOPTOPnnrl;
1573 SETn( left + right );
1574 RETURN;
1575}
1576
1577PP(pp_intadd)
1578{
1579 dSP; dATARGET; dPOPTOPiirl;
1580 SETi( left + right );
1581 RETURN;
1582}
1583
1584PP(pp_subtract)
1585{
1586 dSP; dATARGET; dPOPTOPnnrl;
1587 SETn( left - right );
1588 RETURN;
1589}
1590
1591PP(pp_concat)
1592{
1593 dSP; dATARGET; dPOPTOPssrl;
1594 SvSetSV(TARG, lstr);
1595 sv_catsv(TARG, rstr);
1596 SETTARG;
1597 RETURN;
1598}
1599
1600PP(pp_left_shift)
1601{
1602 dSP; dATARGET;
1603 I32 anum = POPi;
1604 double value = TOPn;
1605 SETi( U_L(value) << anum );
1606 RETURN;
1607}
1608
1609PP(pp_right_shift)
1610{
1611 dSP; dATARGET;
1612 I32 anum = POPi;
1613 double value = TOPn;
1614 SETi( U_L(value) >> anum );
1615 RETURN;
1616}
1617
1618PP(pp_lt)
1619{
1620 dSP; dPOPnv;
1621 SETs((TOPn < value) ? &sv_yes : &sv_no);
1622 RETURN;
1623}
1624
1625PP(pp_gt)
1626{
1627 dSP; dPOPnv;
1628 SETs((TOPn > value) ? &sv_yes : &sv_no);
1629 RETURN;
1630}
1631
1632PP(pp_le)
1633{
1634 dSP; dPOPnv;
1635 SETs((TOPn <= value) ? &sv_yes : &sv_no);
1636 RETURN;
1637}
1638
1639PP(pp_ge)
1640{
1641 dSP; dPOPnv;
1642 SETs((TOPn >= value) ? &sv_yes : &sv_no);
1643 RETURN;
1644}
1645
1646PP(pp_eq)
1647{
1648 dSP; double value;
1649
1650 if (dowarn) {
1651 if ((!SvNIOK(SP[ 0]) && !looks_like_number(SP[ 0])) ||
1652 (!SvNIOK(SP[-1]) && !looks_like_number(SP[-1])) )
1653 warn("Possible use of == on string value");
1654 }
1655
1656 value = POPn;
1657 SETs((TOPn == value) ? &sv_yes : &sv_no);
1658 RETURN;
1659}
1660
1661PP(pp_ne)
1662{
1663 dSP; dPOPnv;
1664 SETs((TOPn != value) ? &sv_yes : &sv_no);
1665 RETURN;
1666}
1667
1668PP(pp_ncmp)
1669{
1670 dSP; dTARGET; dPOPTOPnnrl;
1671 I32 value;
1672
1673 if (left > right)
1674 value = 1;
1675 else if (left < right)
1676 value = -1;
1677 else
1678 value = 0;
1679 SETi(value);
1680 RETURN;
1681}
1682
1683PP(pp_slt)
1684{
1685 dSP; dPOPTOPssrl;
1686 SETs( sv_cmp(lstr, rstr) < 0 ? &sv_yes : &sv_no );
1687 RETURN;
1688}
1689
1690PP(pp_sgt)
1691{
1692 dSP; dPOPTOPssrl;
1693 SETs( sv_cmp(lstr, rstr) > 0 ? &sv_yes : &sv_no );
1694 RETURN;
1695}
1696
1697PP(pp_sle)
1698{
1699 dSP; dPOPTOPssrl;
1700 SETs( sv_cmp(lstr, rstr) <= 0 ? &sv_yes : &sv_no );
1701 RETURN;
1702}
1703
1704PP(pp_sge)
1705{
1706 dSP; dPOPTOPssrl;
1707 SETs( sv_cmp(lstr, rstr) >= 0 ? &sv_yes : &sv_no );
1708 RETURN;
1709}
1710
1711PP(pp_seq)
1712{
1713 dSP; dPOPTOPssrl;
1714 SETs( sv_eq(lstr, rstr) ? &sv_yes : &sv_no );
1715 RETURN;
1716}
1717
1718PP(pp_sne)
1719{
1720 dSP; dPOPTOPssrl;
1721 SETs( !sv_eq(lstr, rstr) ? &sv_yes : &sv_no );
1722 RETURN;
1723}
1724
1725PP(pp_scmp)
1726{
1727 dSP; dTARGET;
1728 dPOPTOPssrl;
1729 SETi( sv_cmp(lstr, rstr) );
1730 RETURN;
1731}
1732
1733PP(pp_bit_and)
1734{
1735 dSP; dATARGET; dPOPTOPssrl;
1736 if (SvNIOK(lstr) || SvNIOK(rstr)) {
1737 I32 value = SvIVn(lstr);
1738 value = value & SvIVn(rstr);
1739 SETi(value);
1740 }
1741 else {
1742 do_vop(op->op_type, TARG, lstr, rstr);
1743 SETTARG;
1744 }
1745 RETURN;
1746}
1747
1748PP(pp_xor)
1749{
1750 dSP; dATARGET; dPOPTOPssrl;
1751 if (SvNIOK(lstr) || SvNIOK(rstr)) {
1752 I32 value = SvIVn(lstr);
1753 value = value ^ SvIVn(rstr);
1754 SETi(value);
1755 }
1756 else {
1757 do_vop(op->op_type, TARG, lstr, rstr);
1758 SETTARG;
1759 }
1760 RETURN;
1761}
1762
1763PP(pp_bit_or)
1764{
1765 dSP; dATARGET; dPOPTOPssrl;
1766 if (SvNIOK(lstr) || SvNIOK(rstr)) {
1767 I32 value = SvIVn(lstr);
1768 value = value | SvIVn(rstr);
1769 SETi(value);
1770 }
1771 else {
1772 do_vop(op->op_type, TARG, lstr, rstr);
1773 SETTARG;
1774 }
1775 RETURN;
1776}
1777
1778PP(pp_negate)
1779{
1780 dSP; dTARGET;
1781 SETn(-TOPn);
1782 RETURN;
1783}
1784
1785PP(pp_not)
1786{
1787 *stack_sp = SvTRUE(*stack_sp) ? &sv_no : &sv_yes;
1788 return NORMAL;
1789}
1790
1791PP(pp_complement)
1792{
1793 dSP; dTARGET; dTOPss;
1794 register I32 anum;
1795
1796 if (SvNIOK(sv)) {
1797 SETi( ~SvIVn(sv) );
1798 }
1799 else {
1800 register char *tmps;
1801 register long *tmpl;
1802
1803 SvSetSV(TARG, sv);
1804 tmps = SvPVn(TARG);
1805 anum = SvCUR(TARG);
1806#ifdef LIBERAL
1807 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
1808 *tmps = ~*tmps;
1809 tmpl = (long*)tmps;
1810 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
1811 *tmpl = ~*tmpl;
1812 tmps = (char*)tmpl;
1813#endif
1814 for ( ; anum > 0; anum--, tmps++)
1815 *tmps = ~*tmps;
1816
1817 SETs(TARG);
1818 }
1819 RETURN;
1820}
1821
1822/* High falutin' math. */
1823
1824PP(pp_atan2)
1825{
1826 dSP; dTARGET; dPOPTOPnnrl;
1827 SETn(atan2(left, right));
1828 RETURN;
1829}
1830
1831PP(pp_sin)
1832{
1833 dSP; dTARGET;
1834 double value;
1835 if (MAXARG < 1)
1836 value = SvNVnx(GvSV(defgv));
1837 else
1838 value = POPn;
1839 value = sin(value);
1840 XPUSHn(value);
1841 RETURN;
1842}
1843
1844PP(pp_cos)
1845{
1846 dSP; dTARGET;
1847 double value;
1848 if (MAXARG < 1)
1849 value = SvNVnx(GvSV(defgv));
1850 else
1851 value = POPn;
1852 value = cos(value);
1853 XPUSHn(value);
1854 RETURN;
1855}
1856
1857PP(pp_rand)
1858{
1859 dSP; dTARGET;
1860 double value;
1861 if (MAXARG < 1)
1862 value = 1.0;
1863 else
1864 value = POPn;
1865 if (value == 0.0)
1866 value = 1.0;
1867#if RANDBITS == 31
1868 value = rand() * value / 2147483648.0;
1869#else
1870#if RANDBITS == 16
1871 value = rand() * value / 65536.0;
1872#else
1873#if RANDBITS == 15
1874 value = rand() * value / 32768.0;
1875#else
1876 value = rand() * value / (double)(((unsigned long)1) << RANDBITS);
1877#endif
1878#endif
1879#endif
1880 XPUSHn(value);
1881 RETURN;
1882}
1883
1884PP(pp_srand)
1885{
1886 dSP;
1887 I32 anum;
1888 time_t when;
1889
1890 if (MAXARG < 1) {
1891 (void)time(&when);
1892 anum = when;
1893 }
1894 else
1895 anum = POPi;
1896 (void)srand(anum);
1897 EXTEND(SP, 1);
1898 RETPUSHYES;
1899}
1900
1901PP(pp_exp)
1902{
1903 dSP; dTARGET;
1904 double value;
1905 if (MAXARG < 1)
1906 value = SvNVnx(GvSV(defgv));
1907 else
1908 value = POPn;
1909 value = exp(value);
1910 XPUSHn(value);
1911 RETURN;
1912}
1913
1914PP(pp_log)
1915{
1916 dSP; dTARGET;
1917 double value;
1918 if (MAXARG < 1)
1919 value = SvNVnx(GvSV(defgv));
1920 else
1921 value = POPn;
1922 if (value <= 0.0)
1923 DIE("Can't take log of %g\n", value);
1924 value = log(value);
1925 XPUSHn(value);
1926 RETURN;
1927}
1928
1929PP(pp_sqrt)
1930{
1931 dSP; dTARGET;
1932 double value;
1933 if (MAXARG < 1)
1934 value = SvNVnx(GvSV(defgv));
1935 else
1936 value = POPn;
1937 if (value < 0.0)
1938 DIE("Can't take sqrt of %g\n", value);
1939 value = sqrt(value);
1940 XPUSHn(value);
1941 RETURN;
1942}
1943
1944PP(pp_int)
1945{
1946 dSP; dTARGET;
1947 double value;
1948 if (MAXARG < 1)
1949 value = SvNVnx(GvSV(defgv));
1950 else
1951 value = POPn;
1952 if (value >= 0.0)
1953 (void)modf(value, &value);
1954 else {
1955 (void)modf(-value, &value);
1956 value = -value;
1957 }
1958 XPUSHn(value);
1959 RETURN;
1960}
1961
1962PP(pp_hex)
1963{
1964 dSP; dTARGET;
1965 char *tmps;
1966 I32 argtype;
1967
1968 if (MAXARG < 1)
1969 tmps = SvPVnx(GvSV(defgv));
1970 else
1971 tmps = POPp;
1972 XPUSHi( scan_hex(tmps, 99, &argtype) );
1973 RETURN;
1974}
1975
1976PP(pp_oct)
1977{
1978 dSP; dTARGET;
1979 I32 value;
1980 I32 argtype;
1981 char *tmps;
1982
1983 if (MAXARG < 1)
1984 tmps = SvPVnx(GvSV(defgv));
1985 else
1986 tmps = POPp;
1987 while (*tmps && (isSPACE(*tmps) || *tmps == '0'))
1988 tmps++;
1989 if (*tmps == 'x')
1990 value = (I32)scan_hex(++tmps, 99, &argtype);
1991 else
1992 value = (I32)scan_oct(tmps, 99, &argtype);
1993 XPUSHi(value);
1994 RETURN;
1995}
1996
1997/* String stuff. */
1998
1999PP(pp_length)
2000{
2001 dSP; dTARGET;
2002 if (MAXARG < 1) {
2003 XPUSHi( sv_len(GvSV(defgv)) );
2004 }
2005 else
2006 SETi( sv_len(TOPs) );
2007 RETURN;
2008}
2009
2010PP(pp_substr)
2011{
2012 dSP; dTARGET;
2013 SV *sv;
2014 I32 len;
2015 I32 curlen;
2016 I32 pos;
2017 I32 rem;
2018 I32 lvalue = op->op_flags & OPf_LVAL;
2019 char *tmps;
2020
2021 if (MAXARG > 2)
2022 len = POPi;
2023 pos = POPi - arybase;
2024 sv = POPs;
2025 tmps = SvPVn(sv); /* force conversion to string */
2026 curlen = SvCUR(sv);
2027 if (pos < 0)
2028 pos += curlen + arybase;
2029 if (pos < 0 || pos > curlen)
2030 sv_setpvn(TARG, "", 0);
2031 else {
2032 if (MAXARG < 3)
2033 len = curlen;
2034 if (len < 0)
2035 len = 0;
2036 tmps += pos;
2037 rem = curlen - pos; /* rem=how many bytes left*/
2038 if (rem > len)
2039 rem = len;
2040 sv_setpvn(TARG, tmps, rem);
2041 if (lvalue) { /* it's an lvalue! */
2042 LvTYPE(TARG) = 's';
2043 LvTARG(TARG) = sv;
2044 LvTARGOFF(TARG) = tmps - SvPVn(sv);
2045 LvTARGLEN(TARG) = rem;
2046 }
2047 }
2048 PUSHs(TARG); /* avoid SvSETMAGIC here */
2049 RETURN;
2050}
2051
2052PP(pp_vec)
2053{
2054 dSP; dTARGET;
2055 register I32 size = POPi;
2056 register I32 offset = POPi;
2057 register SV *src = POPs;
2058 I32 lvalue = op->op_flags & OPf_LVAL;
2059 unsigned char *s = (unsigned char*)SvPVn(src);
2060 unsigned long retnum;
2061 I32 len;
2062
2063 offset *= size; /* turn into bit offset */
2064 len = (offset + size + 7) / 8;
2065 if (offset < 0 || size < 1)
2066 retnum = 0;
2067 else if (!lvalue && len > SvCUR(src))
2068 retnum = 0;
2069 else {
2070 if (len > SvCUR(src)) {
2071 SvGROW(src, len);
2072 (void)memzero(SvPV(src) + SvCUR(src), len - SvCUR(src));
2073 SvCUR_set(src, len);
2074 }
2075 s = (unsigned char*)SvPVn(src);
2076 if (size < 8)
2077 retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1);
2078 else {
2079 offset >>= 3;
2080 if (size == 8)
2081 retnum = s[offset];
2082 else if (size == 16)
2083 retnum = ((unsigned long) s[offset] << 8) + s[offset+1];
2084 else if (size == 32)
2085 retnum = ((unsigned long) s[offset] << 24) +
2086 ((unsigned long) s[offset + 1] << 16) +
2087 (s[offset + 2] << 8) + s[offset+3];
2088 }
2089
2090 if (lvalue) { /* it's an lvalue! */
2091 LvTYPE(TARG) = 'v';
2092 LvTARG(TARG) = src;
2093 LvTARGOFF(TARG) = offset;
2094 LvTARGLEN(TARG) = size;
2095 }
2096 }
2097
2098 sv_setiv(TARG, (I32)retnum);
2099 PUSHs(TARG);
2100 RETURN;
2101}
2102
2103PP(pp_index)
2104{
2105 dSP; dTARGET;
2106 SV *big;
2107 SV *little;
2108 I32 offset;
2109 I32 retval;
2110 char *tmps;
2111 char *tmps2;
2112
2113 if (MAXARG < 3)
2114 offset = 0;
2115 else
2116 offset = POPi - arybase;
2117 little = POPs;
2118 big = POPs;
2119 tmps = SvPVn(big);
2120 if (offset < 0)
2121 offset = 0;
2122 else if (offset > SvCUR(big))
2123 offset = SvCUR(big);
2124 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2125 (unsigned char*)tmps + SvCUR(big), little)))
2126 retval = -1 + arybase;
2127 else
2128 retval = tmps2 - tmps + arybase;
2129 PUSHi(retval);
2130 RETURN;
2131}
2132
2133PP(pp_rindex)
2134{
2135 dSP; dTARGET;
2136 SV *big;
2137 SV *little;
2138 SV *offstr;
2139 I32 offset;
2140 I32 retval;
2141 char *tmps;
2142 char *tmps2;
2143
2144 if (MAXARG == 3)
2145 offstr = POPs;
2146 little = POPs;
2147 big = POPs;
2148 tmps2 = SvPVn(little);
2149 tmps = SvPVn(big);
2150 if (MAXARG < 3)
2151 offset = SvCUR(big);
2152 else
2153 offset = SvIVn(offstr) - arybase + SvCUR(little);
2154 if (offset < 0)
2155 offset = 0;
2156 else if (offset > SvCUR(big))
2157 offset = SvCUR(big);
2158 if (!(tmps2 = rninstr(tmps, tmps + offset,
2159 tmps2, tmps2 + SvCUR(little))))
2160 retval = -1 + arybase;
2161 else
2162 retval = tmps2 - tmps + arybase;
2163 PUSHi(retval);
2164 RETURN;
2165}
2166
2167PP(pp_sprintf)
2168{
2169 dSP; dMARK; dORIGMARK; dTARGET;
2170 do_sprintf(TARG, SP-MARK, MARK+1);
2171 SP = ORIGMARK;
2172 PUSHTARG;
2173 RETURN;
2174}
2175
2176static void
2177doparseform(sv)
2178SV *sv;
2179{
2180 register char *s = SvPVn(sv);
2181 register char *send = s + SvCUR(sv);
2182 register char *base;
2183 register I32 skipspaces = 0;
2184 bool noblank;
2185 bool repeat;
2186 bool postspace = FALSE;
2187 U16 *fops;
2188 register U16 *fpc;
2189 U16 *linepc;
2190 register I32 arg;
2191 bool ischop;
2192
2193 New(804, fops, send - s, U16); /* Almost certainly too long... */
2194 fpc = fops;
2195
2196 if (s < send) {
2197 linepc = fpc;
2198 *fpc++ = FF_LINEMARK;
2199 noblank = repeat = FALSE;
2200 base = s;
2201 }
2202
2203 while (s <= send) {
2204 switch (*s++) {
2205 default:
2206 skipspaces = 0;
2207 continue;
2208
2209 case '~':
2210 if (*s == '~') {
2211 repeat = TRUE;
2212 *s = ' ';
2213 }
2214 noblank = TRUE;
2215 s[-1] = ' ';
2216 /* FALL THROUGH */
2217 case ' ': case '\t':
2218 skipspaces++;
2219 continue;
2220
2221 case '\n': case 0:
2222 arg = s - base;
2223 skipspaces++;
2224 arg -= skipspaces;
2225 if (arg) {
2226 if (postspace) {
2227 *fpc++ = FF_SPACE;
2228 postspace = FALSE;
2229 }
2230 *fpc++ = FF_LITERAL;
2231 *fpc++ = arg;
2232 }
2233 if (s <= send)
2234 skipspaces--;
2235 if (skipspaces) {
2236 *fpc++ = FF_SKIP;
2237 *fpc++ = skipspaces;
2238 }
2239 skipspaces = 0;
2240 if (s <= send)
2241 *fpc++ = FF_NEWLINE;
2242 if (noblank) {
2243 *fpc++ = FF_BLANK;
2244 if (repeat)
2245 arg = fpc - linepc + 1;
2246 else
2247 arg = 0;
2248 *fpc++ = arg;
2249 }
2250 if (s < send) {
2251 linepc = fpc;
2252 *fpc++ = FF_LINEMARK;
2253 noblank = repeat = FALSE;
2254 base = s;
2255 }
2256 else
2257 s++;
2258 continue;
2259
2260 case '@':
2261 case '^':
2262 ischop = s[-1] == '^';
2263
2264 if (postspace) {
2265 *fpc++ = FF_SPACE;
2266 postspace = FALSE;
2267 }
2268 arg = (s - base) - 1;
2269 if (arg) {
2270 *fpc++ = FF_LITERAL;
2271 *fpc++ = arg;
2272 }
2273
2274 base = s - 1;
2275 *fpc++ = FF_FETCH;
2276 if (*s == '*') {
2277 s++;
2278 *fpc++ = 0;
2279 *fpc++ = FF_LINEGLOB;
2280 }
2281 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
2282 arg = ischop ? 512 : 0;
2283 base = s - 1;
2284 while (*s == '#')
2285 s++;
2286 if (*s == '.') {
2287 char *f;
2288 s++;
2289 f = s;
2290 while (*s == '#')
2291 s++;
2292 arg |= 256 + (s - f);
2293 }
2294 *fpc++ = s - base; /* fieldsize for FETCH */
2295 *fpc++ = FF_DECIMAL;
2296 *fpc++ = arg;
2297 }
2298 else {
2299 I32 prespace = 0;
2300 bool ismore = FALSE;
2301
2302 if (*s == '>') {
2303 while (*++s == '>') ;
2304 prespace = FF_SPACE;
2305 }
2306 else if (*s == '|') {
2307 while (*++s == '|') ;
2308 prespace = FF_HALFSPACE;
2309 postspace = TRUE;
2310 }
2311 else {
2312 if (*s == '<')
2313 while (*++s == '<') ;
2314 postspace = TRUE;
2315 }
2316 if (*s == '.' && s[1] == '.' && s[2] == '.') {
2317 s += 3;
2318 ismore = TRUE;
2319 }
2320 *fpc++ = s - base; /* fieldsize for FETCH */
2321
2322 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
2323
2324 if (prespace)
2325 *fpc++ = prespace;
2326 *fpc++ = FF_ITEM;
2327 if (ismore)
2328 *fpc++ = FF_MORE;
2329 if (ischop)
2330 *fpc++ = FF_CHOP;
2331 }
2332 base = s;
2333 skipspaces = 0;
2334 continue;
2335 }
2336 }
2337 *fpc++ = FF_END;
2338
2339 arg = fpc - fops;
2340 SvGROW(sv, SvCUR(sv) + arg * sizeof(U16) + 4);
2341
2342 s = SvPV(sv) + SvCUR(sv);
2343 s += 2 + (SvCUR(sv) & 1);
2344
2345 Copy(fops, s, arg, U16);
2346 Safefree(fops);
2347}
2348
2349PP(pp_formline)
2350{
2351 dSP; dMARK; dORIGMARK;
2352 register SV *form = *++MARK;
2353 register U16 *fpc;
2354 register char *t;
2355 register char *f;
2356 register char *s;
2357 register char *send;
2358 register I32 arg;
2359 register SV *sv;
2360 I32 itemsize;
2361 I32 fieldsize;
2362 I32 lines = 0;
2363 bool chopspace = (index(chopset, ' ') != Nullch);
2364 char *chophere;
2365 char *linemark;
2366 char *formmark;
2367 SV **markmark;
2368 double value;
2369 bool gotsome;
2370
2371 if (!SvCOMPILED(form))
2372 doparseform(form);
2373
2374 SvGROW(formtarget, SvCUR(formtarget) + SvCUR(form) + 1);
2375 t = SvPVn(formtarget);
2376 t += SvCUR(formtarget);
2377 f = SvPVn(form);
2378
2379 s = f + SvCUR(form);
2380 s += 2 + (SvCUR(form) & 1);
2381
2382 fpc = (U16*)s;
2383
2384 for (;;) {
2385 DEBUG_f( {
2386 char *name = "???";
2387 arg = -1;
2388 switch (*fpc) {
2389 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
2390 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
2391 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
2392 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
2393 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
2394
2395 case FF_CHECKNL: name = "CHECKNL"; break;
2396 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
2397 case FF_SPACE: name = "SPACE"; break;
2398 case FF_HALFSPACE: name = "HALFSPACE"; break;
2399 case FF_ITEM: name = "ITEM"; break;
2400 case FF_CHOP: name = "CHOP"; break;
2401 case FF_LINEGLOB: name = "LINEGLOB"; break;
2402 case FF_NEWLINE: name = "NEWLINE"; break;
2403 case FF_MORE: name = "MORE"; break;
2404 case FF_LINEMARK: name = "LINEMARK"; break;
2405 case FF_END: name = "END"; break;
2406 }
2407 if (arg >= 0)
2408 fprintf(stderr, "%-16s%d\n", name, arg);
2409 else
2410 fprintf(stderr, "%-16s\n", name);
2411 } )
2412 switch (*fpc++) {
2413 case FF_LINEMARK:
2414 linemark = t;
2415 formmark = f;
2416 markmark = MARK;
2417 lines++;
2418 gotsome = FALSE;
2419 break;
2420
2421 case FF_LITERAL:
2422 arg = *fpc++;
2423 while (arg--)
2424 *t++ = *f++;
2425 break;
2426
2427 case FF_SKIP:
2428 f += *fpc++;
2429 break;
2430
2431 case FF_FETCH:
2432 arg = *fpc++;
2433 f += arg;
2434 fieldsize = arg;
2435
2436 if (MARK < SP)
2437 sv = *++MARK;
2438 else {
2439 sv = &sv_no;
2440 if (dowarn)
2441 warn("Not enough format arguments");
2442 }
2443 break;
2444
2445 case FF_CHECKNL:
2446 s = SvPVn(sv);
2447 itemsize = SvCUR(sv);
2448 if (itemsize > fieldsize)
2449 itemsize = fieldsize;
2450 send = chophere = s + itemsize;
2451 while (s < send) {
2452 if (*s & ~31)
2453 gotsome = TRUE;
2454 else if (*s == '\n')
2455 break;
2456 s++;
2457 }
2458 itemsize = s - SvPV(sv);
2459 break;
2460
2461 case FF_CHECKCHOP:
2462 s = SvPVn(sv);
2463 itemsize = SvCUR(sv);
2464 if (itemsize > fieldsize)
2465 itemsize = fieldsize;
2466 send = chophere = s + itemsize;
2467 while (s < send || (s == send && isSPACE(*s))) {
2468 if (isSPACE(*s)) {
2469 if (chopspace)
2470 chophere = s;
2471 if (*s == '\r')
2472 break;
2473 }
2474 else {
2475 if (*s & ~31)
2476 gotsome = TRUE;
2477 if (index(chopset, *s))
2478 chophere = s + 1;
2479 }
2480 s++;
2481 }
2482 itemsize = chophere - SvPV(sv);
2483 break;
2484
2485 case FF_SPACE:
2486 arg = fieldsize - itemsize;
2487 if (arg) {
2488 fieldsize -= arg;
2489 while (arg-- > 0)
2490 *t++ = ' ';
2491 }
2492 break;
2493
2494 case FF_HALFSPACE:
2495 arg = fieldsize - itemsize;
2496 if (arg) {
2497 arg /= 2;
2498 fieldsize -= arg;
2499 while (arg-- > 0)
2500 *t++ = ' ';
2501 }
2502 break;
2503
2504 case FF_ITEM:
2505 arg = itemsize;
2506 s = SvPV(sv);
2507 while (arg--) {
2508 if ((*t++ = *s++) < ' ')
2509 t[-1] = ' ';
2510 }
2511 break;
2512
2513 case FF_CHOP:
2514 s = chophere;
2515 if (chopspace) {
2516 while (*s && isSPACE(*s))
2517 s++;
2518 }
2519 sv_chop(sv,s);
2520 break;
2521
2522 case FF_LINEGLOB:
2523 s = SvPVn(sv);
2524 itemsize = SvCUR(sv);
2525 if (itemsize) {
2526 gotsome = TRUE;
2527 send = s + itemsize;
2528 while (s < send) {
2529 if (*s++ == '\n') {
2530 if (s == send)
2531 itemsize--;
2532 else
2533 lines++;
2534 }
2535 }
2536 SvCUR_set(formtarget, t - SvPV(formtarget));
2537 sv_catpvn(formtarget, SvPV(sv), itemsize);
2538 SvGROW(formtarget, SvCUR(formtarget) + SvCUR(form) + 1);
2539 t = SvPV(formtarget) + SvCUR(formtarget);
2540 }
2541 break;
2542
2543 case FF_DECIMAL:
2544 /* If the field is marked with ^ and the value is undefined,
2545 blank it out. */
2546 arg = *fpc++;
2547 if ((arg & 512) && !SvOK(sv)) {
2548 arg = fieldsize;
2549 while (arg--)
2550 *t++ = ' ';
2551 break;
2552 }
2553 gotsome = TRUE;
2554 value = SvNVn(sv);
2555 if (arg & 256) {
2556 sprintf(t, "%#*.*f", fieldsize, arg & 255, value);
2557 } else {
2558 sprintf(t, "%*.0f", fieldsize, value);
2559 }
2560 t += fieldsize;
2561 break;
2562
2563 case FF_NEWLINE:
2564 f++;
2565 while (t-- > linemark && *t == ' ') ;
2566 t++;
2567 *t++ = '\n';
2568 break;
2569
2570 case FF_BLANK:
2571 arg = *fpc++;
2572 if (gotsome) {
2573 if (arg) { /* repeat until fields exhausted? */
2574 fpc -= arg;
2575 f = formmark;
2576 MARK = markmark;
2577 if (lines == 200) {
2578 arg = t - linemark;
2579 if (strnEQ(linemark, linemark - t, arg))
2580 DIE("Runaway format");
2581 }
2582 arg = t - SvPV(formtarget);
2583 SvGROW(formtarget,
2584 (t - SvPV(formtarget)) + (f - formmark) + 1);
2585 t = SvPV(formtarget) + arg;
2586 }
2587 }
2588 else {
2589 t = linemark;
2590 lines--;
2591 }
2592 break;
2593
2594 case FF_MORE:
2595 if (SvCUR(sv)) {
2596 arg = fieldsize - itemsize;
2597 if (arg) {
2598 fieldsize -= arg;
2599 while (arg-- > 0)
2600 *t++ = ' ';
2601 }
2602 s = t - 3;
2603 if (strnEQ(s," ",3)) {
2604 while (s > SvPV(formtarget) && isSPACE(s[-1]))
2605 s--;
2606 }
2607 *s++ = '.';
2608 *s++ = '.';
2609 *s++ = '.';
2610 }
2611 break;
2612
2613 case FF_END:
2614 *t = '\0';
2615 SvCUR_set(formtarget, t - SvPV(formtarget));
2616 FmLINES(formtarget) += lines;
2617 SP = ORIGMARK;
2618 RETPUSHYES;
2619 }
2620 }
2621}
2622
2623PP(pp_ord)
2624{
2625 dSP; dTARGET;
2626 I32 value;
2627 char *tmps;
2628 I32 anum;
2629
2630 if (MAXARG < 1)
2631 tmps = SvPVnx(GvSV(defgv));
2632 else
2633 tmps = POPp;
2634#ifndef I286
2635 value = (I32) (*tmps & 255);
2636#else
2637 anum = (I32) *tmps;
2638 value = (I32) (anum & 255);
2639#endif
2640 XPUSHi(value);
2641 RETURN;
2642}
2643
2644PP(pp_crypt)
2645{
2646 dSP; dTARGET; dPOPTOPssrl;
2647#ifdef HAS_CRYPT
2648 char *tmps = SvPVn(lstr);
2649#ifdef FCRYPT
2650 sv_setpv(TARG, fcrypt(tmps, SvPVn(rstr)));
2651#else
2652 sv_setpv(TARG, crypt(tmps, SvPVn(rstr)));
2653#endif
2654#else
2655 DIE(
2656 "The crypt() function is unimplemented due to excessive paranoia.");
2657#endif
2658 SETs(TARG);
2659 RETURN;
2660}
2661
2662PP(pp_ucfirst)
2663{
2664 dSP;
2665 SV *sv = TOPs;
2666 register char *s;
2667
2668 if (SvSTORAGE(sv) != 'T') {
2669 dTARGET;
2670 sv_setsv(TARG, sv);
2671 sv = TARG;
2672 SETs(sv);
2673 }
2674 s = SvPVn(sv);
2675 if (isascii(*s) && islower(*s))
2676 *s = toupper(*s);
2677
2678 RETURN;
2679}
2680
2681PP(pp_lcfirst)
2682{
2683 dSP;
2684 SV *sv = TOPs;
2685 register char *s;
2686
2687 if (SvSTORAGE(sv) != 'T') {
2688 dTARGET;
2689 sv_setsv(TARG, sv);
2690 sv = TARG;
2691 SETs(sv);
2692 }
2693 s = SvPVn(sv);
2694 if (isascii(*s) && isupper(*s))
2695 *s = tolower(*s);
2696
2697 SETs(sv);
2698 RETURN;
2699}
2700
2701PP(pp_uc)
2702{
2703 dSP;
2704 SV *sv = TOPs;
2705 register char *s;
2706 register char *send;
2707
2708 if (SvSTORAGE(sv) != 'T') {
2709 dTARGET;
2710 sv_setsv(TARG, sv);
2711 sv = TARG;
2712 SETs(sv);
2713 }
2714 s = SvPVn(sv);
2715 send = s + SvCUR(sv);
2716 while (s < send) {
2717 if (isascii(*s) && islower(*s))
2718 *s = toupper(*s);
2719 s++;
2720 }
2721 RETURN;
2722}
2723
2724PP(pp_lc)
2725{
2726 dSP;
2727 SV *sv = TOPs;
2728 register char *s;
2729 register char *send;
2730
2731 if (SvSTORAGE(sv) != 'T') {
2732 dTARGET;
2733 sv_setsv(TARG, sv);
2734 sv = TARG;
2735 SETs(sv);
2736 }
2737 s = SvPVn(sv);
2738 send = s + SvCUR(sv);
2739 while (s < send) {
2740 if (isascii(*s) && isupper(*s))
2741 *s = tolower(*s);
2742 s++;
2743 }
2744 RETURN;
2745}
2746
2747/* Arrays. */
2748
2749PP(pp_rv2av)
2750{
2751 dSP; dPOPss;
2752
2753 AV *av;
2754
2755 if (SvTYPE(sv) == SVt_REF) {
2756 av = (AV*)SvANY(sv);
2757 if (SvTYPE(av) != SVt_PVAV)
2758 DIE("Not an array reference");
2759 if (op->op_flags & OPf_LVAL) {
2760 if (op->op_flags & OPf_LOCAL)
2761 av = (AV*)save_svref(sv);
2762 PUSHs((SV*)av);
2763 RETURN;
2764 }
2765 }
2766 else {
2767 if (SvTYPE(sv) != SVt_PVGV)
2768 sv = (SV*)gv_fetchpv(SvPVn(sv), TRUE);
2769 av = GvAVn(sv);
2770 if (op->op_flags & OPf_LVAL) {
2771 if (op->op_flags & OPf_LOCAL)
2772 av = save_ary(sv);
2773 PUSHs((SV*)av);
2774 RETURN;
2775 }
2776 }
2777
2778 if (GIMME == G_ARRAY) {
2779 I32 maxarg = AvFILL(av) + 1;
2780 EXTEND(SP, maxarg);
2781 Copy(AvARRAY(av), SP+1, maxarg, SV*);
2782 SP += maxarg;
2783 }
2784 else {
2785 dTARGET;
2786 I32 maxarg = AvFILL(av) + 1;
2787 PUSHi(maxarg);
2788 }
2789 RETURN;
2790}
2791
2792PP(pp_aelemfast)
2793{
2794 dSP;
2795 AV *av = (AV*)cSVOP->op_sv;
2796 SV** svp = av_fetch(av, op->op_private - arybase, FALSE);
2797 PUSHs(svp ? *svp : &sv_undef);
2798 RETURN;
2799}
2800
2801PP(pp_aelem)
2802{
2803 dSP;
2804 SV** svp;
2805 I32 elem = POPi - arybase;
2806 AV *av = (AV*)POPs;
2807
2808 if (op->op_flags & OPf_LVAL) {
2809 svp = av_fetch(av, elem, TRUE);
2810 if (!svp || *svp == &sv_undef)
2811 DIE("Assignment to non-creatable value, subscript %d", elem);
2812 if (op->op_flags & OPf_LOCAL)
2813 save_svref(svp);
2814 else if (!SvOK(*svp)) {
2815 if (op->op_private == OP_RV2HV) {
2816 sv_free(*svp);
2817 *svp = (SV*)newHV(COEFFSIZE);
2818 }
2819 else if (op->op_private == OP_RV2AV) {
2820 sv_free(*svp);
2821 *svp = (SV*)newAV();
2822 }
2823 }
2824 }
2825 else
2826 svp = av_fetch(av, elem, FALSE);
2827 PUSHs(svp ? *svp : &sv_undef);
2828 RETURN;
2829}
2830
2831PP(pp_aslice)
2832{
2833 dSP; dMARK; dORIGMARK;
2834 register SV** svp;
2835 register AV* av = (AV*)POPs;
2836 register I32 lval = op->op_flags & OPf_LVAL;
2837 I32 is_something_there = lval;
2838
2839 while (++MARK <= SP) {
2840 I32 elem = SvIVnx(*MARK);
2841
2842 if (lval) {
2843 svp = av_fetch(av, elem, TRUE);
2844 if (!svp || *svp == &sv_undef)
2845 DIE("Assignment to non-creatable value, subscript \"%d\"",elem);
2846 if (op->op_flags & OPf_LOCAL)
2847 save_svref(svp);
2848 }
2849 else {
2850 svp = av_fetch(av, elem, FALSE);
2851 if (!is_something_there && svp && SvOK(*svp))
2852 is_something_there = TRUE;
2853 }
2854 *MARK = svp ? *svp : &sv_undef;
2855 }
2856 if (!is_something_there)
2857 SP = ORIGMARK;
2858 RETURN;
2859}
2860
2861/* Associative arrays. */
2862
2863PP(pp_each)
2864{
2865 dSP; dTARGET;
2866 HV *hash = (HV*)POPs;
2867 HE *entry = hv_iternext(hash);
2868 I32 i;
2869 char *tmps;
2870
2871 if (mystrk) {
2872 sv_free(mystrk);
2873 mystrk = Nullsv;
2874 }
2875
2876 EXTEND(SP, 2);
2877 if (entry) {
2878 if (GIMME == G_ARRAY) {
2879 tmps = hv_iterkey(entry, &i);
2880 if (!i)
2881 tmps = "";
2882 mystrk = newSVpv(tmps, i);
2883 PUSHs(mystrk);
2884 }
2885 sv_setsv(TARG, hv_iterval(hash, entry));
2886 PUSHs(TARG);
2887 }
2888 else if (GIMME == G_SCALAR)
2889 RETPUSHUNDEF;
2890
2891 RETURN;
2892}
2893
2894PP(pp_values)
2895{
2896 return do_kv(ARGS);
2897}
2898
2899PP(pp_keys)
2900{
2901 return do_kv(ARGS);
2902}
2903
2904PP(pp_delete)
2905{
2906 dSP;
2907 SV *sv;
2908 SV *tmpsv = POPs;
2909 HV *hv = (HV*)POPs;
2910 char *tmps;
2911 if (!hv) {
2912 DIE("Not an associative array reference");
2913 }
2914 tmps = SvPVn(tmpsv);
2915 sv = hv_delete(hv, tmps, SvCUR(tmpsv));
2916 if (!sv)
2917 RETPUSHUNDEF;
2918 PUSHs(sv);
2919 RETURN;
2920}
2921
2922PP(pp_rv2hv)
2923{
2924
2925 dSP; dTOPss;
2926
2927 HV *hv;
2928
2929 if (SvTYPE(sv) == SVt_REF) {
2930 hv = (HV*)SvANY(sv);
2931 if (SvTYPE(hv) != SVt_PVHV)
2932 DIE("Not an associative array reference");
2933 if (op->op_flags & OPf_LVAL) {
2934 if (op->op_flags & OPf_LOCAL)
2935 hv = (HV*)save_svref(sv);
2936 SETs((SV*)hv);
2937 RETURN;
2938 }
2939 }
2940 else {
2941 if (SvTYPE(sv) != SVt_PVGV)
2942 sv = (SV*)gv_fetchpv(SvPVn(sv), TRUE);
2943 hv = GvHVn(sv);
2944 if (op->op_flags & OPf_LVAL) {
2945 if (op->op_flags & OPf_LOCAL)
2946 hv = save_hash(sv);
2947 SETs((SV*)hv);
2948 RETURN;
2949 }
2950 }
2951
2952 if (GIMME == G_ARRAY) { /* array wanted */
2953 *stack_sp = (SV*)hv;
2954 return do_kv(ARGS);
2955 }
2956 else {
2957 dTARGET;
2958 if (HvFILL(hv))
2959 sv_setiv(TARG, 0);
2960 else {
2961 sprintf(buf, "%d/%d", HvFILL(hv),
2962 HvFILL(hv)+1);
2963 sv_setpv(TARG, buf);
2964 }
2965 SETTARG;
2966 RETURN;
2967 }
2968}
2969
2970PP(pp_helem)
2971{
2972 dSP;
2973 SV** svp;
2974 SV *keysv = POPs;
2975 char *key = SvPVn(keysv);
2976 I32 keylen = SvPOK(keysv) ? SvCUR(keysv) : 0;
2977 HV *hv = (HV*)POPs;
2978
2979 if (op->op_flags & OPf_LVAL) {
2980 svp = hv_fetch(hv, key, keylen, TRUE);
2981 if (!svp || *svp == &sv_undef)
2982 DIE("Assignment to non-creatable value, subscript \"%s\"", key);
2983 if (op->op_flags & OPf_LOCAL)
2984 save_svref(svp);
2985 else if (!SvOK(*svp)) {
2986 if (op->op_private == OP_RV2HV) {
2987 sv_free(*svp);
2988 *svp = (SV*)newHV(COEFFSIZE);
2989 }
2990 else if (op->op_private == OP_RV2AV) {
2991 sv_free(*svp);
2992 *svp = (SV*)newAV();
2993 }
2994 }
2995 }
2996 else
2997 svp = hv_fetch(hv, key, keylen, FALSE);
2998 PUSHs(svp ? *svp : &sv_undef);
2999 RETURN;
3000}
3001
3002PP(pp_hslice)
3003{
3004 dSP; dMARK; dORIGMARK;
3005 register SV **svp;
3006 register HV *hv = (HV*)POPs;
3007 register I32 lval = op->op_flags & OPf_LVAL;
3008 I32 is_something_there = lval;
3009
3010 while (++MARK <= SP) {
3011 char *key = SvPVnx(*MARK);
3012 I32 keylen = SvPOK(*MARK) ? SvCUR(*MARK) : 0;
3013
3014 if (lval) {
3015 svp = hv_fetch(hv, key, keylen, TRUE);
3016 if (!svp || *svp == &sv_undef)
3017 DIE("Assignment to non-creatable value, subscript \"%s\"", key);
3018 if (op->op_flags & OPf_LOCAL)
3019 save_svref(svp);
3020 }
3021 else {
3022 svp = hv_fetch(hv, key, keylen, FALSE);
3023 if (!is_something_there && svp && SvOK(*svp))
3024 is_something_there = TRUE;
3025 }
3026 *MARK = svp ? *svp : &sv_undef;
3027 }
3028 if (!is_something_there)
3029 SP = ORIGMARK;
3030 RETURN;
3031}
3032
3033/* Explosives and implosives. */
3034
3035PP(pp_unpack)
3036{
3037 dSP;
3038 dPOPPOPssrl;
3039 SV *sv;
3040 register char *pat = SvPVn(lstr);
3041 register char *s = SvPVn(rstr);
3042 char *strend = s + SvCUR(rstr);
3043 char *strbeg = s;
3044 register char *patend = pat + SvCUR(lstr);
3045 I32 datumtype;
3046 register I32 len;
3047 register I32 bits;
3048
3049 /* These must not be in registers: */
3050 I16 ashort;
3051 int aint;
3052 I32 along;
3053#ifdef QUAD
3054 quad aquad;
3055#endif
3056 U16 aushort;
3057 unsigned int auint;
3058 U32 aulong;
3059#ifdef QUAD
3060 unsigned quad auquad;
3061#endif
3062 char *aptr;
3063 float afloat;
3064 double adouble;
3065 I32 checksum = 0;
3066 register U32 culong;
3067 double cdouble;
3068 static char* bitcount = 0;
3069
3070 if (GIMME != G_ARRAY) { /* arrange to do first one only */
3071 /*SUPPRESS 530*/
3072 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
3073 if (index("aAbBhH", *patend) || *pat == '%') {
3074 patend++;
3075 while (isDIGIT(*patend) || *patend == '*')
3076 patend++;
3077 }
3078 else
3079 patend++;
3080 }
3081 while (pat < patend) {
3082 reparse:
3083 datumtype = *pat++;
3084 if (pat >= patend)
3085 len = 1;
3086 else if (*pat == '*') {
3087 len = strend - strbeg; /* long enough */
3088 pat++;
3089 }
3090 else if (isDIGIT(*pat)) {
3091 len = *pat++ - '0';
3092 while (isDIGIT(*pat))
3093 len = (len * 10) + (*pat++ - '0');
3094 }
3095 else
3096 len = (datumtype != '@');
3097 switch(datumtype) {
3098 default:
3099 break;
3100 case '%':
3101 if (len == 1 && pat[-1] != '1')
3102 len = 16;
3103 checksum = len;
3104 culong = 0;
3105 cdouble = 0;
3106 if (pat < patend)
3107 goto reparse;
3108 break;
3109 case '@':
3110 if (len > strend - strbeg)
3111 DIE("@ outside of string");
3112 s = strbeg + len;
3113 break;
3114 case 'X':
3115 if (len > s - strbeg)
3116 DIE("X outside of string");
3117 s -= len;
3118 break;
3119 case 'x':
3120 if (len > strend - s)
3121 DIE("x outside of string");
3122 s += len;
3123 break;
3124 case 'A':
3125 case 'a':
3126 if (len > strend - s)
3127 len = strend - s;
3128 if (checksum)
3129 goto uchar_checksum;
3130 sv = NEWSV(35, len);
3131 sv_setpvn(sv, s, len);
3132 s += len;
3133 if (datumtype == 'A') {
3134 aptr = s; /* borrow register */
3135 s = SvPV(sv) + len - 1;
3136 while (s >= SvPV(sv) && (!*s || isSPACE(*s)))
3137 s--;
3138 *++s = '\0';
3139 SvCUR_set(sv, s - SvPV(sv));
3140 s = aptr; /* unborrow register */
3141 }
3142 XPUSHs(sv_2mortal(sv));
3143 break;
3144 case 'B':
3145 case 'b':
3146 if (pat[-1] == '*' || len > (strend - s) * 8)
3147 len = (strend - s) * 8;
3148 if (checksum) {
3149 if (!bitcount) {
3150 Newz(601, bitcount, 256, char);
3151 for (bits = 1; bits < 256; bits++) {
3152 if (bits & 1) bitcount[bits]++;
3153 if (bits & 2) bitcount[bits]++;
3154 if (bits & 4) bitcount[bits]++;
3155 if (bits & 8) bitcount[bits]++;
3156 if (bits & 16) bitcount[bits]++;
3157 if (bits & 32) bitcount[bits]++;
3158 if (bits & 64) bitcount[bits]++;
3159 if (bits & 128) bitcount[bits]++;
3160 }
3161 }
3162 while (len >= 8) {
3163 culong += bitcount[*(unsigned char*)s++];
3164 len -= 8;
3165 }
3166 if (len) {
3167 bits = *s;
3168 if (datumtype == 'b') {
3169 while (len-- > 0) {
3170 if (bits & 1) culong++;
3171 bits >>= 1;
3172 }
3173 }
3174 else {
3175 while (len-- > 0) {
3176 if (bits & 128) culong++;
3177 bits <<= 1;
3178 }
3179 }
3180 }
3181 break;
3182 }
3183 sv = NEWSV(35, len + 1);
3184 SvCUR_set(sv, len);
3185 SvPOK_on(sv);
3186 aptr = pat; /* borrow register */
3187 pat = SvPV(sv);
3188 if (datumtype == 'b') {
3189 aint = len;
3190 for (len = 0; len < aint; len++) {
3191 if (len & 7) /*SUPPRESS 595*/
3192 bits >>= 1;
3193 else
3194 bits = *s++;
3195 *pat++ = '0' + (bits & 1);
3196 }
3197 }
3198 else {
3199 aint = len;
3200 for (len = 0; len < aint; len++) {
3201 if (len & 7)
3202 bits <<= 1;
3203 else
3204 bits = *s++;
3205 *pat++ = '0' + ((bits & 128) != 0);
3206 }
3207 }
3208 *pat = '\0';
3209 pat = aptr; /* unborrow register */
3210 XPUSHs(sv_2mortal(sv));
3211 break;
3212 case 'H':
3213 case 'h':
3214 if (pat[-1] == '*' || len > (strend - s) * 2)
3215 len = (strend - s) * 2;
3216 sv = NEWSV(35, len + 1);
3217 SvCUR_set(sv, len);
3218 SvPOK_on(sv);
3219 aptr = pat; /* borrow register */
3220 pat = SvPV(sv);
3221 if (datumtype == 'h') {
3222 aint = len;
3223 for (len = 0; len < aint; len++) {
3224 if (len & 1)
3225 bits >>= 4;
3226 else
3227 bits = *s++;
3228 *pat++ = hexdigit[bits & 15];
3229 }
3230 }
3231 else {
3232 aint = len;
3233 for (len = 0; len < aint; len++) {
3234 if (len & 1)
3235 bits <<= 4;
3236 else
3237 bits = *s++;
3238 *pat++ = hexdigit[(bits >> 4) & 15];
3239 }
3240 }
3241 *pat = '\0';
3242 pat = aptr; /* unborrow register */
3243 XPUSHs(sv_2mortal(sv));
3244 break;
3245 case 'c':
3246 if (len > strend - s)
3247 len = strend - s;
3248 if (checksum) {
3249 while (len-- > 0) {
3250 aint = *s++;
3251 if (aint >= 128) /* fake up signed chars */
3252 aint -= 256;
3253 culong += aint;
3254 }
3255 }
3256 else {
3257 EXTEND(SP, len);
3258 while (len-- > 0) {
3259 aint = *s++;
3260 if (aint >= 128) /* fake up signed chars */
3261 aint -= 256;
3262 sv = NEWSV(36, 0);
3263 sv_setiv(sv, (I32)aint);
3264 PUSHs(sv_2mortal(sv));
3265 }
3266 }
3267 break;
3268 case 'C':
3269 if (len > strend - s)
3270 len = strend - s;
3271 if (checksum) {
3272 uchar_checksum:
3273 while (len-- > 0) {
3274 auint = *s++ & 255;
3275 culong += auint;
3276 }
3277 }
3278 else {
3279 EXTEND(SP, len);
3280 while (len-- > 0) {
3281 auint = *s++ & 255;
3282 sv = NEWSV(37, 0);
3283 sv_setiv(sv, (I32)auint);
3284 PUSHs(sv_2mortal(sv));
3285 }
3286 }
3287 break;
3288 case 's':
3289 along = (strend - s) / sizeof(I16);
3290 if (len > along)
3291 len = along;
3292 if (checksum) {
3293 while (len-- > 0) {
3294 Copy(s, &ashort, 1, I16);
3295 s += sizeof(I16);
3296 culong += ashort;
3297 }
3298 }
3299 else {
3300 EXTEND(SP, len);
3301 while (len-- > 0) {
3302 Copy(s, &ashort, 1, I16);
3303 s += sizeof(I16);
3304 sv = NEWSV(38, 0);
3305 sv_setiv(sv, (I32)ashort);
3306 PUSHs(sv_2mortal(sv));
3307 }
3308 }
3309 break;
3310 case 'v':
3311 case 'n':
3312 case 'S':
3313 along = (strend - s) / sizeof(U16);
3314 if (len > along)
3315 len = along;
3316 if (checksum) {
3317 while (len-- > 0) {
3318 Copy(s, &aushort, 1, U16);
3319 s += sizeof(U16);
3320#ifdef HAS_NTOHS
3321 if (datumtype == 'n')
3322 aushort = ntohs(aushort);
3323#endif
3324#ifdef HAS_VTOHS
3325 if (datumtype == 'v')
3326 aushort = vtohs(aushort);
3327#endif
3328 culong += aushort;
3329 }
3330 }
3331 else {
3332 EXTEND(SP, len);
3333 while (len-- > 0) {
3334 Copy(s, &aushort, 1, U16);
3335 s += sizeof(U16);
3336 sv = NEWSV(39, 0);
3337#ifdef HAS_NTOHS
3338 if (datumtype == 'n')
3339 aushort = ntohs(aushort);
3340#endif
3341#ifdef HAS_VTOHS
3342 if (datumtype == 'v')
3343 aushort = vtohs(aushort);
3344#endif
3345 sv_setiv(sv, (I32)aushort);
3346 PUSHs(sv_2mortal(sv));
3347 }
3348 }
3349 break;
3350 case 'i':
3351 along = (strend - s) / sizeof(int);
3352 if (len > along)
3353 len = along;
3354 if (checksum) {
3355 while (len-- > 0) {
3356 Copy(s, &aint, 1, int);
3357 s += sizeof(int);
3358 if (checksum > 32)
3359 cdouble += (double)aint;
3360 else
3361 culong += aint;
3362 }
3363 }
3364 else {
3365 EXTEND(SP, len);
3366 while (len-- > 0) {
3367 Copy(s, &aint, 1, int);
3368 s += sizeof(int);
3369 sv = NEWSV(40, 0);
3370 sv_setiv(sv, (I32)aint);
3371 PUSHs(sv_2mortal(sv));
3372 }
3373 }
3374 break;
3375 case 'I':
3376 along = (strend - s) / sizeof(unsigned int);
3377 if (len > along)
3378 len = along;
3379 if (checksum) {
3380 while (len-- > 0) {
3381 Copy(s, &auint, 1, unsigned int);
3382 s += sizeof(unsigned int);
3383 if (checksum > 32)
3384 cdouble += (double)auint;
3385 else
3386 culong += auint;
3387 }
3388 }
3389 else {
3390 EXTEND(SP, len);
3391 while (len-- > 0) {
3392 Copy(s, &auint, 1, unsigned int);
3393 s += sizeof(unsigned int);
3394 sv = NEWSV(41, 0);
3395 sv_setiv(sv, (I32)auint);
3396 PUSHs(sv_2mortal(sv));
3397 }
3398 }
3399 break;
3400 case 'l':
3401 along = (strend - s) / sizeof(I32);
3402 if (len > along)
3403 len = along;
3404 if (checksum) {
3405 while (len-- > 0) {
3406 Copy(s, &along, 1, I32);
3407 s += sizeof(I32);
3408 if (checksum > 32)
3409 cdouble += (double)along;
3410 else
3411 culong += along;
3412 }
3413 }
3414 else {
3415 EXTEND(SP, len);
3416 while (len-- > 0) {
3417 Copy(s, &along, 1, I32);
3418 s += sizeof(I32);
3419 sv = NEWSV(42, 0);
3420 sv_setiv(sv, (I32)along);
3421 PUSHs(sv_2mortal(sv));
3422 }
3423 }
3424 break;
3425 case 'V':
3426 case 'N':
3427 case 'L':
3428 along = (strend - s) / sizeof(U32);
3429 if (len > along)
3430 len = along;
3431 if (checksum) {
3432 while (len-- > 0) {
3433 Copy(s, &aulong, 1, U32);
3434 s += sizeof(U32);
3435#ifdef HAS_NTOHL
3436 if (datumtype == 'N')
3437 aulong = ntohl(aulong);
3438#endif
3439#ifdef HAS_VTOHL
3440 if (datumtype == 'V')
3441 aulong = vtohl(aulong);
3442#endif
3443 if (checksum > 32)
3444 cdouble += (double)aulong;
3445 else
3446 culong += aulong;
3447 }
3448 }
3449 else {
3450 EXTEND(SP, len);
3451 while (len-- > 0) {
3452 Copy(s, &aulong, 1, U32);
3453 s += sizeof(U32);
3454 sv = NEWSV(43, 0);
3455#ifdef HAS_NTOHL
3456 if (datumtype == 'N')
3457 aulong = ntohl(aulong);
3458#endif
3459#ifdef HAS_VTOHL
3460 if (datumtype == 'V')
3461 aulong = vtohl(aulong);
3462#endif
3463 sv_setnv(sv, (double)aulong);
3464 PUSHs(sv_2mortal(sv));
3465 }
3466 }
3467 break;
3468 case 'p':
3469 along = (strend - s) / sizeof(char*);
3470 if (len > along)
3471 len = along;
3472 EXTEND(SP, len);
3473 while (len-- > 0) {
3474 if (sizeof(char*) > strend - s)
3475 break;
3476 else {
3477 Copy(s, &aptr, 1, char*);
3478 s += sizeof(char*);
3479 }
3480 sv = NEWSV(44, 0);
3481 if (aptr)
3482 sv_setpv(sv, aptr);
3483 PUSHs(sv_2mortal(sv));
3484 }
3485 break;
3486#ifdef QUAD
3487 case 'q':
3488 EXTEND(SP, len);
3489 while (len-- > 0) {
3490 if (s + sizeof(quad) > strend)
3491 aquad = 0;
3492 else {
3493 Copy(s, &aquad, 1, quad);
3494 s += sizeof(quad);
3495 }
3496 sv = NEWSV(42, 0);
3497 sv_setnv(sv, (double)aquad);
3498 PUSHs(sv_2mortal(sv));
3499 }
3500 break;
3501 case 'Q':
3502 EXTEND(SP, len);
3503 while (len-- > 0) {
3504 if (s + sizeof(unsigned quad) > strend)
3505 auquad = 0;
3506 else {
3507 Copy(s, &auquad, 1, unsigned quad);
3508 s += sizeof(unsigned quad);
3509 }
3510 sv = NEWSV(43, 0);
3511 sv_setnv(sv, (double)auquad);
3512 PUSHs(sv_2mortal(sv));
3513 }
3514 break;
3515#endif
3516 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
3517 case 'f':
3518 case 'F':
3519 along = (strend - s) / sizeof(float);
3520 if (len > along)
3521 len = along;
3522 if (checksum) {
3523 while (len-- > 0) {
3524 Copy(s, &afloat, 1, float);
3525 s += sizeof(float);
3526 cdouble += afloat;
3527 }
3528 }
3529 else {
3530 EXTEND(SP, len);
3531 while (len-- > 0) {
3532 Copy(s, &afloat, 1, float);
3533 s += sizeof(float);
3534 sv = NEWSV(47, 0);
3535 sv_setnv(sv, (double)afloat);
3536 PUSHs(sv_2mortal(sv));
3537 }
3538 }
3539 break;
3540 case 'd':
3541 case 'D':
3542 along = (strend - s) / sizeof(double);
3543 if (len > along)
3544 len = along;
3545 if (checksum) {
3546 while (len-- > 0) {
3547 Copy(s, &adouble, 1, double);
3548 s += sizeof(double);
3549 cdouble += adouble;
3550 }
3551 }
3552 else {
3553 EXTEND(SP, len);
3554 while (len-- > 0) {
3555 Copy(s, &adouble, 1, double);
3556 s += sizeof(double);
3557 sv = NEWSV(48, 0);
3558 sv_setnv(sv, (double)adouble);
3559 PUSHs(sv_2mortal(sv));
3560 }
3561 }
3562 break;
3563 case 'u':
3564 along = (strend - s) * 3 / 4;
3565 sv = NEWSV(42, along);
3566 while (s < strend && *s > ' ' && *s < 'a') {
3567 I32 a, b, c, d;
3568 char hunk[4];
3569
3570 hunk[3] = '\0';
3571 len = (*s++ - ' ') & 077;
3572 while (len > 0) {
3573 if (s < strend && *s >= ' ')
3574 a = (*s++ - ' ') & 077;
3575 else
3576 a = 0;
3577 if (s < strend && *s >= ' ')
3578 b = (*s++ - ' ') & 077;
3579 else
3580 b = 0;
3581 if (s < strend && *s >= ' ')
3582 c = (*s++ - ' ') & 077;
3583 else
3584 c = 0;
3585 if (s < strend && *s >= ' ')
3586 d = (*s++ - ' ') & 077;
3587 else
3588 d = 0;
3589 hunk[0] = a << 2 | b >> 4;
3590 hunk[1] = b << 4 | c >> 2;
3591 hunk[2] = c << 6 | d;
3592 sv_catpvn(sv, hunk, len > 3 ? 3 : len);
3593 len -= 3;
3594 }
3595 if (*s == '\n')
3596 s++;
3597 else if (s[1] == '\n') /* possible checksum byte */
3598 s += 2;
3599 }
3600 XPUSHs(sv_2mortal(sv));
3601 break;
3602 }
3603 if (checksum) {
3604 sv = NEWSV(42, 0);
3605 if (index("fFdD", datumtype) ||
3606 (checksum > 32 && index("iIlLN", datumtype)) ) {
3607 double modf();
3608 double trouble;
3609
3610 adouble = 1.0;
3611 while (checksum >= 16) {
3612 checksum -= 16;
3613 adouble *= 65536.0;
3614 }
3615 while (checksum >= 4) {
3616 checksum -= 4;
3617 adouble *= 16.0;
3618 }
3619 while (checksum--)
3620 adouble *= 2.0;
3621 along = (1 << checksum) - 1;
3622 while (cdouble < 0.0)
3623 cdouble += adouble;
3624 cdouble = modf(cdouble / adouble, &trouble) * adouble;
3625 sv_setnv(sv, cdouble);
3626 }
3627 else {
3628 if (checksum < 32) {
3629 along = (1 << checksum) - 1;
3630 culong &= (U32)along;
3631 }
3632 sv_setnv(sv, (double)culong);
3633 }
3634 XPUSHs(sv_2mortal(sv));
3635 checksum = 0;
3636 }
3637 }
3638 RETURN;
3639}
3640
3641static void
3642doencodes(sv, s, len)
3643register SV *sv;
3644register char *s;
3645register I32 len;
3646{
3647 char hunk[5];
3648
3649 *hunk = len + ' ';
3650 sv_catpvn(sv, hunk, 1);
3651 hunk[4] = '\0';
3652 while (len > 0) {
3653 hunk[0] = ' ' + (077 & (*s >> 2));
3654 hunk[1] = ' ' + (077 & ((*s << 4) & 060 | (s[1] >> 4) & 017));
3655 hunk[2] = ' ' + (077 & ((s[1] << 2) & 074 | (s[2] >> 6) & 03));
3656 hunk[3] = ' ' + (077 & (s[2] & 077));
3657 sv_catpvn(sv, hunk, 4);
3658 s += 3;
3659 len -= 3;
3660 }
3661 for (s = SvPV(sv); *s; s++) {
3662 if (*s == ' ')
3663 *s = '`';
3664 }
3665 sv_catpvn(sv, "\n", 1);
3666}
3667
3668PP(pp_pack)
3669{
3670 dSP; dMARK; dORIGMARK; dTARGET;
3671 register SV *cat = TARG;
3672 register I32 items;
3673 register char *pat = SvPVnx(*++MARK);
3674 register char *patend = pat + SvCUR(*MARK);
3675 register I32 len;
3676 I32 datumtype;
3677 SV *fromstr;
3678 /*SUPPRESS 442*/
3679 static char *null10 = "\0\0\0\0\0\0\0\0\0\0";
3680 static char *space10 = " ";
3681
3682 /* These must not be in registers: */
3683 char achar;
3684 I16 ashort;
3685 int aint;
3686 unsigned int auint;
3687 I32 along;
3688 U32 aulong;
3689#ifdef QUAD
3690 quad aquad;
3691 unsigned quad auquad;
3692#endif
3693 char *aptr;
3694 float afloat;
3695 double adouble;
3696
3697 items = SP - MARK;
3698 MARK++;
3699 sv_setpvn(cat, "", 0);
3700 while (pat < patend) {
3701#define NEXTFROM (items-- > 0 ? *MARK++ : &sv_no)
3702 datumtype = *pat++;
3703 if (*pat == '*') {
3704 len = index("@Xxu", datumtype) ? 0 : items;
3705 pat++;
3706 }
3707 else if (isDIGIT(*pat)) {
3708 len = *pat++ - '0';
3709 while (isDIGIT(*pat))
3710 len = (len * 10) + (*pat++ - '0');
3711 }
3712 else
3713 len = 1;
3714 switch(datumtype) {
3715 default:
3716 break;
3717 case '%':
3718 DIE("% may only be used in unpack");
3719 case '@':
3720 len -= SvCUR(cat);
3721 if (len > 0)
3722 goto grow;
3723 len = -len;
3724 if (len > 0)
3725 goto shrink;
3726 break;
3727 case 'X':
3728 shrink:
3729 if (SvCUR(cat) < len)
3730 DIE("X outside of string");
3731 SvCUR(cat) -= len;
3732 *SvEND(cat) = '\0';
3733 break;
3734 case 'x':
3735 grow:
3736 while (len >= 10) {
3737 sv_catpvn(cat, null10, 10);
3738 len -= 10;
3739 }
3740 sv_catpvn(cat, null10, len);
3741 break;
3742 case 'A':
3743 case 'a':
3744 fromstr = NEXTFROM;
3745 aptr = SvPVn(fromstr);
3746 if (pat[-1] == '*')
3747 len = SvCUR(fromstr);
3748 if (SvCUR(fromstr) > len)
3749 sv_catpvn(cat, aptr, len);
3750 else {
3751 sv_catpvn(cat, aptr, SvCUR(fromstr));
3752 len -= SvCUR(fromstr);
3753 if (datumtype == 'A') {
3754 while (len >= 10) {
3755 sv_catpvn(cat, space10, 10);
3756 len -= 10;
3757 }
3758 sv_catpvn(cat, space10, len);
3759 }
3760 else {
3761 while (len >= 10) {
3762 sv_catpvn(cat, null10, 10);
3763 len -= 10;
3764 }
3765 sv_catpvn(cat, null10, len);
3766 }
3767 }
3768 break;
3769 case 'B':
3770 case 'b':
3771 {
3772 char *savepat = pat;
3773 I32 saveitems;
3774
3775 fromstr = NEXTFROM;
3776 saveitems = items;
3777 aptr = SvPVn(fromstr);
3778 if (pat[-1] == '*')
3779 len = SvCUR(fromstr);
3780 pat = aptr;
3781 aint = SvCUR(cat);
3782 SvCUR(cat) += (len+7)/8;
3783 SvGROW(cat, SvCUR(cat) + 1);
3784 aptr = SvPV(cat) + aint;
3785 if (len > SvCUR(fromstr))
3786 len = SvCUR(fromstr);
3787 aint = len;
3788 items = 0;
3789 if (datumtype == 'B') {
3790 for (len = 0; len++ < aint;) {
3791 items |= *pat++ & 1;
3792 if (len & 7)
3793 items <<= 1;
3794 else {
3795 *aptr++ = items & 0xff;
3796 items = 0;
3797 }
3798 }
3799 }
3800 else {
3801 for (len = 0; len++ < aint;) {
3802 if (*pat++ & 1)
3803 items |= 128;
3804 if (len & 7)
3805 items >>= 1;
3806 else {
3807 *aptr++ = items & 0xff;
3808 items = 0;
3809 }
3810 }
3811 }
3812 if (aint & 7) {
3813 if (datumtype == 'B')
3814 items <<= 7 - (aint & 7);
3815 else
3816 items >>= 7 - (aint & 7);
3817 *aptr++ = items & 0xff;
3818 }
3819 pat = SvPV(cat) + SvCUR(cat);
3820 while (aptr <= pat)
3821 *aptr++ = '\0';
3822
3823 pat = savepat;
3824 items = saveitems;
3825 }
3826 break;
3827 case 'H':
3828 case 'h':
3829 {
3830 char *savepat = pat;
3831 I32 saveitems;
3832
3833 fromstr = NEXTFROM;
3834 saveitems = items;
3835 aptr = SvPVn(fromstr);
3836 if (pat[-1] == '*')
3837 len = SvCUR(fromstr);
3838 pat = aptr;
3839 aint = SvCUR(cat);
3840 SvCUR(cat) += (len+1)/2;
3841 SvGROW(cat, SvCUR(cat) + 1);
3842 aptr = SvPV(cat) + aint;
3843 if (len > SvCUR(fromstr))
3844 len = SvCUR(fromstr);
3845 aint = len;
3846 items = 0;
3847 if (datumtype == 'H') {
3848 for (len = 0; len++ < aint;) {
3849 if (isALPHA(*pat))
3850 items |= ((*pat++ & 15) + 9) & 15;
3851 else
3852 items |= *pat++ & 15;
3853 if (len & 1)
3854 items <<= 4;
3855 else {
3856 *aptr++ = items & 0xff;
3857 items = 0;
3858 }
3859 }
3860 }
3861 else {
3862 for (len = 0; len++ < aint;) {
3863 if (isALPHA(*pat))
3864 items |= (((*pat++ & 15) + 9) & 15) << 4;
3865 else
3866 items |= (*pat++ & 15) << 4;
3867 if (len & 1)
3868 items >>= 4;
3869 else {
3870 *aptr++ = items & 0xff;
3871 items = 0;
3872 }
3873 }
3874 }
3875 if (aint & 1)
3876 *aptr++ = items & 0xff;
3877 pat = SvPV(cat) + SvCUR(cat);
3878 while (aptr <= pat)
3879 *aptr++ = '\0';
3880
3881 pat = savepat;
3882 items = saveitems;
3883 }
3884 break;
3885 case 'C':
3886 case 'c':
3887 while (len-- > 0) {
3888 fromstr = NEXTFROM;
3889 aint = SvIVn(fromstr);
3890 achar = aint;
3891 sv_catpvn(cat, &achar, sizeof(char));
3892 }
3893 break;
3894 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
3895 case 'f':
3896 case 'F':
3897 while (len-- > 0) {
3898 fromstr = NEXTFROM;
3899 afloat = (float)SvNVn(fromstr);
3900 sv_catpvn(cat, (char *)&afloat, sizeof (float));
3901 }
3902 break;
3903 case 'd':
3904 case 'D':
3905 while (len-- > 0) {
3906 fromstr = NEXTFROM;
3907 adouble = (double)SvNVn(fromstr);
3908 sv_catpvn(cat, (char *)&adouble, sizeof (double));
3909 }
3910 break;
3911 case 'n':
3912 while (len-- > 0) {
3913 fromstr = NEXTFROM;
3914 ashort = (I16)SvIVn(fromstr);
3915#ifdef HAS_HTONS
3916 ashort = htons(ashort);
3917#endif
3918 sv_catpvn(cat, (char*)&ashort, sizeof(I16));
3919 }
3920 break;
3921 case 'v':
3922 while (len-- > 0) {
3923 fromstr = NEXTFROM;
3924 ashort = (I16)SvIVn(fromstr);
3925#ifdef HAS_HTOVS
3926 ashort = htovs(ashort);
3927#endif
3928 sv_catpvn(cat, (char*)&ashort, sizeof(I16));
3929 }
3930 break;
3931 case 'S':
3932 case 's':
3933 while (len-- > 0) {
3934 fromstr = NEXTFROM;
3935 ashort = (I16)SvIVn(fromstr);
3936 sv_catpvn(cat, (char*)&ashort, sizeof(I16));
3937 }
3938 break;
3939 case 'I':
3940 while (len-- > 0) {
3941 fromstr = NEXTFROM;
3942 auint = U_I(SvNVn(fromstr));
3943 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
3944 }
3945 break;
3946 case 'i':
3947 while (len-- > 0) {
3948 fromstr = NEXTFROM;
3949 aint = SvIVn(fromstr);
3950 sv_catpvn(cat, (char*)&aint, sizeof(int));
3951 }
3952 break;
3953 case 'N':
3954 while (len-- > 0) {
3955 fromstr = NEXTFROM;
3956 aulong = U_L(SvNVn(fromstr));
3957#ifdef HAS_HTONL
3958 aulong = htonl(aulong);
3959#endif
3960 sv_catpvn(cat, (char*)&aulong, sizeof(U32));
3961 }
3962 break;
3963 case 'V':
3964 while (len-- > 0) {
3965 fromstr = NEXTFROM;
3966 aulong = U_L(SvNVn(fromstr));
3967#ifdef HAS_HTOVL
3968 aulong = htovl(aulong);
3969#endif
3970 sv_catpvn(cat, (char*)&aulong, sizeof(U32));
3971 }
3972 break;
3973 case 'L':
3974 while (len-- > 0) {
3975 fromstr = NEXTFROM;
3976 aulong = U_L(SvNVn(fromstr));
3977 sv_catpvn(cat, (char*)&aulong, sizeof(U32));
3978 }
3979 break;
3980 case 'l':
3981 while (len-- > 0) {
3982 fromstr = NEXTFROM;
3983 along = SvIVn(fromstr);
3984 sv_catpvn(cat, (char*)&along, sizeof(I32));
3985 }
3986 break;
3987#ifdef QUAD
3988 case 'Q':
3989 while (len-- > 0) {
3990 fromstr = NEXTFROM;
3991 auquad = (unsigned quad)SvNVn(fromstr);
3992 sv_catpvn(cat, (char*)&auquad, sizeof(unsigned quad));
3993 }
3994 break;
3995 case 'q':
3996 while (len-- > 0) {
3997 fromstr = NEXTFROM;
3998 aquad = (quad)SvNVn(fromstr);
3999 sv_catpvn(cat, (char*)&aquad, sizeof(quad));
4000 }
4001 break;
4002#endif /* QUAD */
4003 case 'p':
4004 while (len-- > 0) {
4005 fromstr = NEXTFROM;
4006 aptr = SvPVn(fromstr);
4007 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
4008 }
4009 break;
4010 case 'u':
4011 fromstr = NEXTFROM;
4012 aptr = SvPVn(fromstr);
4013 aint = SvCUR(fromstr);
4014 SvGROW(cat, aint * 4 / 3);
4015 if (len <= 1)
4016 len = 45;
4017 else
4018 len = len / 3 * 3;
4019 while (aint > 0) {
4020 I32 todo;
4021
4022 if (aint > len)
4023 todo = len;
4024 else
4025 todo = aint;
4026 doencodes(cat, aptr, todo);
4027 aint -= todo;
4028 aptr += todo;
4029 }
4030 break;
4031 }
4032 }
4033 SvSETMAGIC(cat);
4034 SP = ORIGMARK;
4035 PUSHs(cat);
4036 RETURN;
4037}
4038#undef NEXTFROM
4039
4040PP(pp_split)
4041{
4042 dSP; dTARG;
4043 AV *ary;
4044 register I32 limit = POPi;
4045 register char *s = SvPVn(TOPs);
4046 char *strend = s + SvCURx(POPs);
4047 register PMOP *pm = (PMOP*)POPs;
4048 register SV *dstr;
4049 register char *m;
4050 I32 iters = 0;
4051 I32 maxiters = (strend - s) + 10;
4052 I32 i;
4053 char *orig;
4054 I32 origlimit = limit;
4055 I32 realarray = 0;
4056 I32 base;
4057 AV *oldstack;
4058 register REGEXP *rx = pm->op_pmregexp;
4059 I32 gimme = GIMME;
4060
4061 if (!pm || !s)
4062 DIE("panic: do_split");
4063 if (pm->op_pmreplroot)
4064 ary = GvAVn((GV*)pm->op_pmreplroot);
4065 else
4066 ary = Nullav;
4067 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4068 realarray = 1;
4069 if (!AvREAL(ary)) {
4070 AvREAL_on(ary);
4071 for (i = AvFILL(ary); i >= 0; i--)
4072 AvARRAY(ary)[i] = Nullsv; /* don't free mere refs */
4073 }
4074 av_fill(ary,0); /* force allocation */
4075 av_fill(ary,-1);
4076 /* temporarily switch stacks */
4077 oldstack = stack;
4078 SWITCHSTACK(stack, ary);
4079 }
4080 base = SP - stack_base + 1;
4081 orig = s;
4082 if (pm->op_pmflags & PMf_SKIPWHITE) {
4083 while (isSPACE(*s))
4084 s++;
4085 }
4086 if (!limit)
4087 limit = maxiters + 2;
4088 if (strEQ("\\s+", rx->precomp)) {
4089 while (--limit) {
4090 /*SUPPRESS 530*/
4091 for (m = s; m < strend && !isSPACE(*m); m++) ;
4092 if (m >= strend)
4093 break;
4094 dstr = NEWSV(30, m-s);
4095 sv_setpvn(dstr, s, m-s);
4096 if (!realarray)
4097 sv_2mortal(dstr);
4098 XPUSHs(dstr);
4099 /*SUPPRESS 530*/
4100 for (s = m + 1; s < strend && isSPACE(*s); s++) ;
4101 }
4102 }
4103 else if (strEQ("^", rx->precomp)) {
4104 while (--limit) {
4105 /*SUPPRESS 530*/
4106 for (m = s; m < strend && *m != '\n'; m++) ;
4107 m++;
4108 if (m >= strend)
4109 break;
4110 dstr = NEWSV(30, m-s);
4111 sv_setpvn(dstr, s, m-s);
4112 if (!realarray)
4113 sv_2mortal(dstr);
4114 XPUSHs(dstr);
4115 s = m;
4116 }
4117 }
4118 else if (pm->op_pmshort) {
4119 i = SvCUR(pm->op_pmshort);
4120 if (i == 1) {
4121 I32 fold = (pm->op_pmflags & PMf_FOLD);
4122 i = *SvPV(pm->op_pmshort);
4123 if (fold && isUPPER(i))
4124 i = tolower(i);
4125 while (--limit) {
4126 if (fold) {
4127 for ( m = s;
4128 m < strend && *m != i &&
4129 (!isUPPER(*m) || tolower(*m) != i);
4130 m++) /*SUPPRESS 530*/
4131 ;
4132 }
4133 else /*SUPPRESS 530*/
4134 for (m = s; m < strend && *m != i; m++) ;
4135 if (m >= strend)
4136 break;
4137 dstr = NEWSV(30, m-s);
4138 sv_setpvn(dstr, s, m-s);
4139 if (!realarray)
4140 sv_2mortal(dstr);
4141 XPUSHs(dstr);
4142 s = m + 1;
4143 }
4144 }
4145 else {
4146#ifndef lint
4147 while (s < strend && --limit &&
4148 (m=fbm_instr((unsigned char*)s, (unsigned char*)strend,
4149 pm->op_pmshort)) )
4150#endif
4151 {
4152 dstr = NEWSV(31, m-s);
4153 sv_setpvn(dstr, s, m-s);
4154 if (!realarray)
4155 sv_2mortal(dstr);
4156 XPUSHs(dstr);
4157 s = m + i;
4158 }
4159 }
4160 }
4161 else {
4162 maxiters += (strend - s) * rx->nparens;
4163 while (s < strend && --limit &&
4164 regexec(rx, s, strend, orig, 1, Nullsv, TRUE) ) {
4165 if (rx->subbase
4166 && rx->subbase != orig) {
4167 m = s;
4168 s = orig;
4169 orig = rx->subbase;
4170 s = orig + (m - s);
4171 strend = s + (strend - m);
4172 }
4173 m = rx->startp[0];
4174 dstr = NEWSV(32, m-s);
4175 sv_setpvn(dstr, s, m-s);
4176 if (!realarray)
4177 sv_2mortal(dstr);
4178 XPUSHs(dstr);
4179 if (rx->nparens) {
4180 for (i = 1; i <= rx->nparens; i++) {
4181 s = rx->startp[i];
4182 m = rx->endp[i];
4183 dstr = NEWSV(33, m-s);
4184 sv_setpvn(dstr, s, m-s);
4185 if (!realarray)
4186 sv_2mortal(dstr);
4187 XPUSHs(dstr);
4188 }
4189 }
4190 s = rx->endp[0];
4191 }
4192 }
4193 iters = (SP - stack_base) - base;
4194 if (iters > maxiters)
4195 DIE("Split loop");
4196 if (s < strend || origlimit) { /* keep field after final delim? */
4197 dstr = NEWSV(34, strend-s);
4198 sv_setpvn(dstr, s, strend-s);
4199 if (!realarray)
4200 sv_2mortal(dstr);
4201 XPUSHs(dstr);
4202 iters++;
4203 }
4204 else {
4205 while (iters > 0 && SvCUR(TOPs) == 0)
4206 iters--, SP--;
4207 }
4208 if (realarray) {
4209 SWITCHSTACK(ary, oldstack);
4210 if (gimme == G_ARRAY) {
4211 EXTEND(SP, iters);
4212 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4213 SP += iters;
4214 RETURN;
4215 }
4216 }
4217 else {
4218 if (gimme == G_ARRAY)
4219 RETURN;
4220 }
4221 SP = stack_base + base;
4222 GETTARGET;
4223 PUSHi(iters);
4224 RETURN;
4225}
4226
4227PP(pp_join)
4228{
4229 dSP; dMARK; dTARGET;
4230 MARK++;
4231 do_join(TARG, *MARK, MARK, SP);
4232 SP = MARK;
4233 SETs(TARG);
4234 RETURN;
4235}
4236
4237/* List operators. */
4238
4239PP(pp_list)
4240{
4241 dSP;
4242 if (GIMME != G_ARRAY) {
4243 dMARK;
4244 if (++MARK <= SP)
4245 *MARK = *SP; /* unwanted list, return last item */
4246 else
4247 *MARK = &sv_undef;
4248 SP = MARK;
4249 }
4250 RETURN;
4251}
4252
4253PP(pp_lslice)
4254{
4255 dSP;
4256 SV **lastrelem = stack_sp;
4257 SV **lastlelem = stack_base + POPMARK;
4258 SV **firstlelem = stack_base + POPMARK + 1;
4259 register SV **firstrelem = lastlelem + 1;
4260 I32 lval = op->op_flags & OPf_LVAL;
4261 I32 is_something_there = lval;
4262
4263 register I32 max = lastrelem - lastlelem;
4264 register SV **lelem;
4265 register I32 ix;
4266
4267 if (GIMME != G_ARRAY) {
4268 ix = SvIVnx(*lastlelem) - arybase;
4269 if (ix < 0 || ix >= max)
4270 *firstlelem = &sv_undef;
4271 else
4272 *firstlelem = firstrelem[ix];
4273 SP = firstlelem;
4274 RETURN;
4275 }
4276
4277 if (max == 0) {
4278 SP = firstlelem;
4279 RETURN;
4280 }
4281
4282 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4283 ix = SvIVnx(*lelem) - arybase;
4284 if (ix < 0 || ix >= max || !(*lelem = firstrelem[ix]))
4285 *lelem = &sv_undef;
4286 if (!is_something_there && SvOK(*lelem))
4287 is_something_there = TRUE;
4288 }
4289 if (is_something_there)
4290 SP = lastlelem;
4291 else
4292 SP = firstlelem;
4293 RETURN;
4294}
4295
4296PP(pp_anonlist)
4297{
4298 dSP; dMARK;
4299 I32 items = SP - MARK;
4300 SP = MARK;
4301 XPUSHs((SV*)av_make(items, MARK+1));
4302 RETURN;
4303}
4304
4305PP(pp_anonhash)
4306{
4307 dSP; dMARK; dORIGMARK;
4308 HV* hv = newHV(COEFFSIZE);
4309 SvREFCNT(hv) = 0;
4310 while (MARK < SP) {
4311 SV* key = *++MARK;
4312 SV* val;
4313 char *tmps;
4314 if (MARK < SP)
4315 val = *++MARK;
4316 tmps = SvPV(key);
4317 (void)hv_store(hv,tmps,SvCUR(key),val,0);
4318 }
4319 SP = ORIGMARK;
4320 XPUSHs((SV*)hv);
4321 RETURN;
4322}
4323
4324PP(pp_splice)
4325{
4326 dSP; dMARK; dORIGMARK;
4327 register AV *ary = (AV*)*++MARK;
4328 register SV **src;
4329 register SV **dst;
4330 register I32 i;
4331 register I32 offset;
4332 register I32 length;
4333 I32 newlen;
4334 I32 after;
4335 I32 diff;
4336 SV **tmparyval;
4337
4338 SP++;
4339
4340 if (++MARK < SP) {
4341 offset = SvIVnx(*MARK);
4342 if (offset < 0)
4343 offset += AvFILL(ary) + 1;
4344 else
4345 offset -= arybase;
4346 if (++MARK < SP) {
4347 length = SvIVnx(*MARK++);
4348 if (length < 0)
4349 length = 0;
4350 }
4351 else
4352 length = AvMAX(ary) + 1; /* close enough to infinity */
4353 }
4354 else {
4355 offset = 0;
4356 length = AvMAX(ary) + 1;
4357 }
4358 if (offset < 0) {
4359 length += offset;
4360 offset = 0;
4361 if (length < 0)
4362 length = 0;
4363 }
4364 if (offset > AvFILL(ary) + 1)
4365 offset = AvFILL(ary) + 1;
4366 after = AvFILL(ary) + 1 - (offset + length);
4367 if (after < 0) { /* not that much array */
4368 length += after; /* offset+length now in array */
4369 after = 0;
4370 if (!AvALLOC(ary)) {
4371 av_fill(ary, 0);
4372 av_fill(ary, -1);
4373 }
4374 }
4375
4376 /* At this point, MARK .. SP-1 is our new LIST */
4377
4378 newlen = SP - MARK;
4379 diff = newlen - length;
4380
4381 if (diff < 0) { /* shrinking the area */
4382 if (newlen) {
4383 New(451, tmparyval, newlen, SV*); /* so remember insertion */
4384 Copy(MARK, tmparyval, newlen, SV*);
4385 }
4386
4387 MARK = ORIGMARK + 1;
4388 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4389 MEXTEND(MARK, length);
4390 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4391 if (AvREAL(ary)) {
4392 for (i = length, dst = MARK; i; i--)
4393 sv_2mortal(*dst++); /* free them eventualy */
4394 }
4395 MARK += length - 1;
4396 }
4397 else {
4398 *MARK = AvARRAY(ary)[offset+length-1];
4399 if (AvREAL(ary)) {
4400 sv_2mortal(*MARK);
4401 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4402 sv_free(*dst++); /* free them now */
4403 }
4404 }
4405 AvFILL(ary) += diff;
4406
4407 /* pull up or down? */
4408
4409 if (offset < after) { /* easier to pull up */
4410 if (offset) { /* esp. if nothing to pull */
4411 src = &AvARRAY(ary)[offset-1];
4412 dst = src - diff; /* diff is negative */
4413 for (i = offset; i > 0; i--) /* can't trust Copy */
4414 *dst-- = *src--;
4415 }
4416 Zero(AvARRAY(ary), -diff, SV*);
4417 AvARRAY(ary) -= diff; /* diff is negative */
4418 AvMAX(ary) += diff;
4419 }
4420 else {
4421 if (after) { /* anything to pull down? */
4422 src = AvARRAY(ary) + offset + length;
4423 dst = src + diff; /* diff is negative */
4424 Move(src, dst, after, SV*);
4425 }
4426 Zero(&AvARRAY(ary)[AvFILL(ary)+1], -diff, SV*);
4427 /* avoid later double free */
4428 }
4429 if (newlen) {
4430 for (src = tmparyval, dst = AvARRAY(ary) + offset;
4431 newlen; newlen--) {
4432 *dst = NEWSV(46, 0);
4433 sv_setsv(*dst++, *src++);
4434 }
4435 Safefree(tmparyval);
4436 }
4437 }
4438 else { /* no, expanding (or same) */
4439 if (length) {
4440 New(452, tmparyval, length, SV*); /* so remember deletion */
4441 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4442 }
4443
4444 if (diff > 0) { /* expanding */
4445
4446 /* push up or down? */
4447
4448 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4449 if (offset) {
4450 src = AvARRAY(ary);
4451 dst = src - diff;
4452 Move(src, dst, offset, SV*);
4453 }
4454 AvARRAY(ary) -= diff; /* diff is positive */
4455 AvMAX(ary) += diff;
4456 AvFILL(ary) += diff;
4457 }
4458 else {
4459 if (AvFILL(ary) + diff >= AvMAX(ary)) /* oh, well */
4460 av_store(ary, AvFILL(ary) + diff, Nullsv);
4461 else
4462 AvFILL(ary) += diff;
4463 dst = AvARRAY(ary) + AvFILL(ary);
4464 for (i = diff; i > 0; i--) {
4465 if (*dst) /* stuff was hanging around */
4466 sv_free(*dst); /* after $#foo */
4467 dst--;
4468 }
4469 if (after) {
4470 dst = AvARRAY(ary) + AvFILL(ary);
4471 src = dst - diff;
4472 for (i = after; i; i--) {
4473 *dst-- = *src--;
4474 }
4475 }
4476 }
4477 }
4478
4479 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
4480 *dst = NEWSV(46, 0);
4481 sv_setsv(*dst++, *src++);
4482 }
4483 MARK = ORIGMARK + 1;
4484 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4485 if (length) {
4486 Copy(tmparyval, MARK, length, SV*);
4487 if (AvREAL(ary)) {
4488 for (i = length, dst = MARK; i; i--)
4489 sv_2mortal(*dst++); /* free them eventualy */
4490 }
4491 Safefree(tmparyval);
4492 }
4493 MARK += length - 1;
4494 }
4495 else if (length--) {
4496 *MARK = tmparyval[length];
4497 if (AvREAL(ary)) {
4498 sv_2mortal(*MARK);
4499 while (length-- > 0)
4500 sv_free(tmparyval[length]);
4501 }
4502 Safefree(tmparyval);
4503 }
4504 else
4505 *MARK = &sv_undef;
4506 }
4507 SP = MARK;
4508 RETURN;
4509}
4510
4511PP(pp_push)
4512{
4513 dSP; dMARK; dORIGMARK; dTARGET;
4514 register AV *ary = (AV*)*++MARK;
4515 register SV *sv = &sv_undef;
4516
4517 for (++MARK; MARK <= SP; MARK++) {
4518 sv = NEWSV(51, 0);
4519 if (*MARK)
4520 sv_setsv(sv, *MARK);
4521 (void)av_push(ary, sv);
4522 }
4523 SP = ORIGMARK;
4524 PUSHi( AvFILL(ary) + 1 );
4525 RETURN;
4526}
4527
4528PP(pp_pop)
4529{
4530 dSP;
4531 AV *av = (AV*)POPs;
4532 SV *sv = av_pop(av);
4533 if (!sv)
4534 RETPUSHUNDEF;
4535 if (AvREAL(av))
4536 (void)sv_2mortal(sv);
4537 PUSHs(sv);
4538 RETURN;
4539}
4540
4541PP(pp_shift)
4542{
4543 dSP;
4544 AV *av = (AV*)POPs;
4545 SV *sv = av_shift(av);
4546 EXTEND(SP, 1);
4547 if (!sv)
4548 RETPUSHUNDEF;
4549 if (AvREAL(av))
4550 (void)sv_2mortal(sv);
4551 PUSHs(sv);
4552 RETURN;
4553}
4554
4555PP(pp_unshift)
4556{
4557 dSP; dMARK; dORIGMARK; dTARGET;
4558 register AV *ary = (AV*)*++MARK;
4559 register SV *sv;
4560 register I32 i = 0;
4561
4562 av_unshift(ary, SP - MARK);
4563 while (MARK < SP) {
4564 sv = NEWSV(27, 0);
4565 sv_setsv(sv, *++MARK);
4566 (void)av_store(ary, i++, sv);
4567 }
4568
4569 SP = ORIGMARK;
4570 PUSHi( AvFILL(ary) + 1 );
4571 RETURN;
4572}
4573
4574PP(pp_grepstart)
4575{
4576 dSP;
4577 SV *src;
4578
4579 if (stack_base + *markstack_ptr == sp) {
4580 POPMARK;
4581 RETURNOP(op->op_next->op_next);
4582 }
4583 stack_sp = stack_base + *markstack_ptr + 1;
4584 pp_pushmark(); /* push dst */
4585 pp_pushmark(); /* push src */
4586 ENTER; /* enter outer scope */
4587
4588 SAVETMPS;
4589 SAVESPTR(GvSV(defgv));
4590
4591 ENTER; /* enter inner scope */
4592 SAVESPTR(curpm);
4593
4594 if (src = stack_base[*markstack_ptr]) {
4595 SvTEMP_off(src);
4596 GvSV(defgv) = src;
4597 }
4598 else
4599 GvSV(defgv) = sv_mortalcopy(&sv_undef);
4600
4601 RETURNOP(((LOGOP*)op->op_next)->op_other);
4602}
4603
4604PP(pp_grepwhile)
4605{
4606 dSP;
4607
4608 if (SvTRUEx(POPs))
4609 stack_base[markstack_ptr[-1]++] = stack_base[*markstack_ptr];
4610 ++*markstack_ptr;
4611 LEAVE; /* exit inner scope */
4612
4613 /* All done yet? */
4614 if (stack_base + *markstack_ptr > sp) {
4615 I32 items;
4616
4617 LEAVE; /* exit outer scope */
4618 POPMARK; /* pop src */
4619 items = --*markstack_ptr - markstack_ptr[-1];
4620 POPMARK; /* pop dst */
4621 SP = stack_base + POPMARK; /* pop original mark */
4622 if (GIMME != G_ARRAY) {
4623 dTARGET;
4624 XPUSHi(items);
4625 RETURN;
4626 }
4627 SP += items;
4628 RETURN;
4629 }
4630 else {
4631 SV *src;
4632
4633 ENTER; /* enter inner scope */
4634 SAVESPTR(curpm);
4635
4636 if (src = stack_base[*markstack_ptr]) {
4637 SvTEMP_off(src);
4638 GvSV(defgv) = src;
4639 }
4640 else
4641 GvSV(defgv) = sv_mortalcopy(&sv_undef);
4642
4643 RETURNOP(cLOGOP->op_other);
4644 }
4645}
4646
4647PP(pp_sort)
4648{
4649 dSP; dMARK; dORIGMARK;
4650 register SV **up;
4651 SV **myorigmark = ORIGMARK;
4652 register I32 max;
4653 register I32 i;
4654 int sortcmp();
4655 int sortcv();
4656 HV *stash;
4657 SV *sortcvvar;
4658 GV *gv;
4659 CV *cv;
4660
4661 if (GIMME != G_ARRAY) {
4662 SP = MARK;
4663 RETSETUNDEF;
4664 }
4665
4666 if (op->op_flags & OPf_STACKED) {
4667 if (op->op_flags & OPf_SPECIAL) {
4668 OP *kid = cLISTOP->op_first->op_sibling; /* pass pushmark */
4669 kid = kUNOP->op_first; /* pass rv2gv */
4670 kid = kUNOP->op_first; /* pass leave */
4671 sortcop = kid->op_next;
4672 stash = curcop->cop_stash;
4673 }
4674 else {
4675 cv = sv_2cv(*++MARK, &stash, &gv, 0);
4676 if (!cv) {
4677 if (gv) {
4678 SV *tmpstr = sv_mortalcopy(&sv_undef);
4679 gv_efullname(tmpstr, gv);
4680 DIE("Undefined sort subroutine \"%s\" called",
4681 SvPV(tmpstr));
4682 }
4683 DIE("Undefined subroutine in sort");
4684 }
4685 sortcop = CvSTART(cv);
4686 SAVESPTR(CvROOT(cv)->op_ppaddr);
4687 CvROOT(cv)->op_ppaddr = ppaddr[OP_NULL];
4688 }
4689 }
4690 else {
4691 sortcop = Nullop;
4692 stash = curcop->cop_stash;
4693 }
4694
4695 up = myorigmark + 1;
4696 while (MARK < SP) { /* This may or may not shift down one here. */
4697 /*SUPPRESS 560*/
4698 if (*up = *++MARK) { /* Weed out nulls. */
4699 if (!SvPOK(*up))
4700 (void)sv_2pv(*up);
4701 else
4702 SvTEMP_off(*up);
4703 up++;
4704 }
4705 }
4706 max = --up - myorigmark;
4707 if (max > 1) {
4708 if (sortcop) {
4709 AV *oldstack;
4710
4711 ENTER;
4712 SAVETMPS;
4713 SAVESPTR(op);
4714
4715 oldstack = stack;
4716 if (!sortstack) {
4717 sortstack = newAV();
4718 av_store(sortstack, 32, Nullsv);
4719 av_clear(sortstack);
4720 AvREAL_off(sortstack);
4721 }
4722 SWITCHSTACK(stack, sortstack);
4723 if (sortstash != stash) {
4724 firstgv = gv_fetchpv("a", TRUE);
4725 secondgv = gv_fetchpv("b", TRUE);
4726 sortstash = stash;
4727 }
4728
4729 SAVESPTR(GvSV(firstgv));
4730 SAVESPTR(GvSV(secondgv));
4731
4732 qsort((char*)(myorigmark+1), max, sizeof(SV*), sortcv);
4733
4734 SWITCHSTACK(sortstack, oldstack);
4735
4736 LEAVE;
4737 }
4738 else {
4739 MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */
4740 qsort((char*)(ORIGMARK+1), max, sizeof(SV*), sortcmp);
4741 }
4742 }
4743 SP = ORIGMARK + max;
4744 RETURN;
4745}
4746
4747PP(pp_reverse)
4748{
4749 dSP; dMARK;
4750 register SV *tmp;
4751 SV **oldsp = SP;
4752
4753 if (GIMME == G_ARRAY) {
4754 MARK++;
4755 while (MARK < SP) {
4756 tmp = *MARK;
4757 *MARK++ = *SP;
4758 *SP-- = tmp;
4759 }
4760 SP = oldsp;
4761 }
4762 else {
4763 register char *up;
4764 register char *down;
4765 register I32 tmp;
4766 dTARGET;
4767
4768 if (SP - MARK > 1)
4769 do_join(TARG, sv_no, MARK, SP);
4770 else
4771 sv_setsv(TARG, *SP);
4772 up = SvPVn(TARG);
4773 if (SvCUR(TARG) > 1) {
4774 down = SvPV(TARG) + SvCUR(TARG) - 1;
4775 while (down > up) {
4776 tmp = *up;
4777 *up++ = *down;
4778 *down-- = tmp;
4779 }
4780 }
4781 SP = MARK + 1;
4782 SETTARG;
4783 }
4784 RETURN;
4785}
4786
4787/* Range stuff. */
4788
4789PP(pp_range)
4790{
4791 if (GIMME == G_ARRAY)
4792 return cCONDOP->op_true;
4793 return SvTRUEx(PAD_SV(op->op_targ)) ? cCONDOP->op_false : cCONDOP->op_true;
4794}
4795
4796PP(pp_flip)
4797{
4798 dSP;
4799
4800 if (GIMME == G_ARRAY) {
4801 RETURNOP(((CONDOP*)cUNOP->op_first)->op_false);
4802 }
4803 else {
4804 dTOPss;
4805 SV *targ = PAD_SV(op->op_targ);
4806
4807 if ((op->op_private & OPpFLIP_LINENUM)
4808 ? last_in_gv && SvIVn(sv) == GvIO(last_in_gv)->lines
4809 : SvTRUE(sv) ) {
4810 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
4811 if (op->op_flags & OPf_SPECIAL) {
4812 sv_setiv(targ, 1);
4813 RETURN;
4814 }
4815 else {
4816 sv_setiv(targ, 0);
4817 sp--;
4818 RETURNOP(((CONDOP*)cUNOP->op_first)->op_false);
4819 }
4820 }
4821 sv_setpv(TARG, "");
4822 SETs(targ);
4823 RETURN;
4824 }
4825}
4826
4827PP(pp_flop)
4828{
4829 dSP;
4830
4831 if (GIMME == G_ARRAY) {
4832 dPOPPOPssrl;
4833 register I32 i;
4834 register SV *sv;
4835 I32 max;
4836
4837 if (SvNIOK(lstr) || !SvPOK(lstr) ||
4838 (looks_like_number(lstr) && *SvPV(lstr) != '0') ) {
4839 i = SvIVn(lstr);
4840 max = SvIVn(rstr);
4841 if (max > i)
4842 EXTEND(SP, max - i + 1);
4843 while (i <= max) {
4844 sv = sv_mortalcopy(&sv_no);
4845 sv_setiv(sv,i++);
4846 PUSHs(sv);
4847 }
4848 }
4849 else {
4850 SV *final = sv_mortalcopy(rstr);
4851 char *tmps = SvPVn(final);
4852
4853 sv = sv_mortalcopy(lstr);
4854 while (!SvNIOK(sv) && SvCUR(sv) <= SvCUR(final) &&
4855 strNE(SvPV(sv),tmps) ) {
4856 XPUSHs(sv);
4857 sv = sv_2mortal(newSVsv(sv));
4858 sv_inc(sv);
4859 }
4860 if (strEQ(SvPV(sv),tmps))
4861 XPUSHs(sv);
4862 }
4863 }
4864 else {
4865 dTOPss;
4866 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
4867 sv_inc(targ);
4868 if ((op->op_private & OPpFLIP_LINENUM)
4869 ? last_in_gv && SvIVn(sv) == GvIO(last_in_gv)->lines
4870 : SvTRUE(sv) ) {
4871 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);</