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