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