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