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