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