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
Compile(d) at least once with threads on win32
[perl5.git] / pp.c
CommitLineData
a0d0e21e 1/* pp.c
79072805 2 *
9607fc9c 3 * Copyright (c) 1991-1997, Larry Wall
79072805 4 *
a0d0e21e
LW		 5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
79072805 7 *
a0d0e21e
LW		 8 */
9
10/*
11 * "It's a big house this, and very peculiar. Always a bit more to discover,
12 * and no knowing what you'll find around a corner. And Elves, sir!" --Samwise
13 */
79072805
LW		 14
15#include "EXTERN.h"
16#include "perl.h"
17
36477c24 18/*
ef2d312d
TH		 19 * The compiler on Concurrent CX/UX systems has a subtle bug which only
20 * seems to show up when compiling pp.c - it generates the wrong double
21 * precision constant value for (double)UV_MAX when used inline in the body
22 * of the code below, so this makes a static variable up front (which the
23 * compiler seems to get correct) and uses it in place of UV_MAX below.
24 */
25#ifdef CXUX_BROKEN_CONSTANT_CONVERT
26static double UV_MAX_cxux = ((double)UV_MAX);
8ac85365
NIS		 27#endif
28
29#ifdef HAS_CRYPT
30#ifdef __cplusplus
31#ifdef FCRYPT
32extern "C" char *fcrypt(char *,char *);
33#else
34extern "C" char *crypt(char *,char *);
35#endif
36#endif
ef2d312d
TH		 37#endif
38
39/*
36477c24 40 * Types used in bitwise operations.
41 *
42 * Normally we'd just use IV and UV. However, some hardware and
43 * software combinations (e.g. Alpha and current OSF/1) don't have a
44 * floating-point type to use for NV that has adequate bits to fully
45 * hold an IV/UV. (In other words, sizeof(long) == sizeof(double).)
46 *
96e4d5b1 47 * It just so happens that "int" is the right size almost everywhere.
36477c24 48 */
49typedef int IBW;
50typedef unsigned UBW;
51
96e4d5b1 52/*
53 * Mask used after bitwise operations.
54 *
55 * There is at least one realm (Cray word machines) that doesn't
56 * have an integral type (except char) small enough to be represented
57 * in a double without loss; that is, it has no 32-bit type.
58 */
59#if BYTEORDER > 0xFFFF && defined(_CRAY) && !defined(_CRAYMPP)
46fc3d4c 60# define BW_BITS 32
61# define BW_MASK ((1 << BW_BITS) - 1)
62# define BW_SIGN (1 << (BW_BITS - 1))
96e4d5b1 63# define BWi(i) (((i) & BW_SIGN) ? ((i) | ~BW_MASK) : ((i) & BW_MASK))
64# define BWu(u) ((u) & BW_MASK)
65#else
66# define BWi(i) (i)
67# define BWu(u) (u)
68#endif
69
70/*
71 * Offset for integer pack/unpack.
72 *
73 * On architectures where I16 and I32 aren't really 16 and 32 bits,
74 * which for now are all Crays, pack and unpack have to play games.
75 */
76
77/*
78 * These values are required for portability of pack() output.
79 * If they're not right on your machine, then pack() and unpack()
80 * wouldn't work right anyway; you'll need to apply the Cray hack.
81 * (I'd like to check them with #if, but you can't use sizeof() in
82 * the preprocessor.)
83 */
84#define SIZE16 2
85#define SIZE32 4
86
87#if BYTEORDER > 0xFFFF && defined(_CRAY) && !defined(_CRAYMPP)
88# if BYTEORDER == 0x12345678
89# define OFF16(p) (char*)(p)
90# define OFF32(p) (char*)(p)
91# else
92# if BYTEORDER == 0x87654321
93# define OFF16(p) ((char*)(p) + (sizeof(U16) - SIZE16))
94# define OFF32(p) ((char*)(p) + (sizeof(U32) - SIZE32))
95# else
96 }}}} bad cray byte order
97# endif
98# endif
99# define COPY16(s,p) (*(p) = 0, Copy(s, OFF16(p), SIZE16, char))
100# define COPY32(s,p) (*(p) = 0, Copy(s, OFF32(p), SIZE32, char))
101# define CAT16(sv,p) sv_catpvn(sv, OFF16(p), SIZE16)
102# define CAT32(sv,p) sv_catpvn(sv, OFF32(p), SIZE32)
103#else
104# define COPY16(s,p) Copy(s, p, SIZE16, char)
105# define COPY32(s,p) Copy(s, p, SIZE32, char)
106# define CAT16(sv,p) sv_catpvn(sv, (char*)(p), SIZE16)
107# define CAT32(sv,p) sv_catpvn(sv, (char*)(p), SIZE32)
108#endif
109
71be2cbc 110static void doencodes _((SV* sv, char* s, I32 len));
93dc8474
CS		 111static SV* refto _((SV* sv));
112static U32 seed _((void));
113
114static bool srand_called = FALSE;
79072805 115
a0d0e21e 116/* variations on pp_null */
79072805 117
8ac85365
NIS		 118#ifdef DONT_DECLARE_STD
119#ifdef I_UNISTD
120#include <unistd.h>
121#endif
122#else
123extern pid_t getpid (void);
124#endif
125
93a17b20
LW		 126PP(pp_stub)
127{
128 dSP;
54310121 129 if (GIMME_V == G_SCALAR)
93a17b20 130 XPUSHs(&sv_undef);
93a17b20
LW		 131 RETURN;
132}
133
79072805
LW		 134PP(pp_scalar)
135{
136 return NORMAL;
137}
138
139/* Pushy stuff. */
140
93a17b20
LW		 141PP(pp_padav)
142{
143 dSP; dTARGET;
a0d0e21e 144 if (op->op_private & OPpLVAL_INTRO)
8990e307 145 SAVECLEARSV(curpad[op->op_targ]);
85e6fe83 146 EXTEND(SP, 1);
a0d0e21e 147 if (op->op_flags & OPf_REF) {
85e6fe83 148 PUSHs(TARG);
93a17b20 149 RETURN;
85e6fe83
LW		 150 }
151 if (GIMME == G_ARRAY) {
152 I32 maxarg = AvFILL((AV*)TARG) + 1;
153 EXTEND(SP, maxarg);
154 Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
155 SP += maxarg;
156 }
157 else {
158 SV* sv = sv_newmortal();
159 I32 maxarg = AvFILL((AV*)TARG) + 1;
160 sv_setiv(sv, maxarg);
161 PUSHs(sv);
162 }
163 RETURN;
93a17b20
LW		 164}
165
166PP(pp_padhv)
167{
168 dSP; dTARGET;
54310121 169 I32 gimme;
170
93a17b20 171 XPUSHs(TARG);
a0d0e21e 172 if (op->op_private & OPpLVAL_INTRO)
8990e307 173 SAVECLEARSV(curpad[op->op_targ]);
a0d0e21e 174 if (op->op_flags & OPf_REF)
93a17b20 175 RETURN;
54310121 176 gimme = GIMME_V;
177 if (gimme == G_ARRAY) {
a0d0e21e 178 RETURNOP(do_kv(ARGS));
85e6fe83 179 }
54310121 180 else if (gimme == G_SCALAR) {
85e6fe83 181 SV* sv = sv_newmortal();
46fc3d4c 182 if (HvFILL((HV*)TARG))
183 sv_setpvf(sv, "%ld/%ld",
184 (long)HvFILL((HV*)TARG), (long)HvMAX((HV*)TARG) + 1);
85e6fe83
LW		 185 else
186 sv_setiv(sv, 0);
187 SETs(sv);
85e6fe83 188 }
54310121 189 RETURN;
93a17b20
LW		 190}
191
ed6116ce
LW		 192PP(pp_padany)
193{
194 DIE("NOT IMPL LINE %d",__LINE__);
195}
196
79072805
LW		 197/* Translations. */
198
199PP(pp_rv2gv)
200{
201 dSP; dTOPss;
a0d0e21e 202
ed6116ce 203 if (SvROK(sv)) {
a0d0e21e 204 wasref:
ed6116ce 205 sv = SvRV(sv);
b1dadf13 206 if (SvTYPE(sv) == SVt_PVIO) {
207 GV *gv = (GV*) sv_newmortal();
208 gv_init(gv, 0, "", 0, 0);
209 GvIOp(gv) = (IO *)sv;
3e3baf6d 210 (void)SvREFCNT_inc(sv);
b1dadf13 211 sv = (SV*) gv;
212 } else if (SvTYPE(sv) != SVt_PVGV)
a0d0e21e 213 DIE("Not a GLOB reference");
79072805
LW		 214 }
215 else {
93a17b20 216 if (SvTYPE(sv) != SVt_PVGV) {
748a9306
LW		 217 char *sym;
218
a0d0e21e
LW		 219 if (SvGMAGICAL(sv)) {
220 mg_get(sv);
221 if (SvROK(sv))
222 goto wasref;
223 }
224 if (!SvOK(sv)) {
225 if (op->op_flags & OPf_REF ||
226 op->op_private & HINT_STRICT_REFS)
227 DIE(no_usym, "a symbol");
d83e6520
CS		 228 if (dowarn)
229 warn(warn_uninit);
a0d0e21e
LW		 230 RETSETUNDEF;
231 }
748a9306 232 sym = SvPV(sv, na);
85e6fe83 233 if (op->op_private & HINT_STRICT_REFS)
748a9306
LW		 234 DIE(no_symref, sym, "a symbol");
235 sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
93a17b20 236 }
79072805 237 }
5f05dabc 238 if (op->op_private & OPpLVAL_INTRO)
239 save_gp((GV*)sv, !(op->op_flags & OPf_SPECIAL));
79072805
LW		 240 SETs(sv);
241 RETURN;
242}
243
79072805
LW		 244PP(pp_rv2sv)
245{
246 dSP; dTOPss;
247
ed6116ce 248 if (SvROK(sv)) {
a0d0e21e 249 wasref:
ed6116ce 250 sv = SvRV(sv);
79072805
LW		 251 switch (SvTYPE(sv)) {
252 case SVt_PVAV:
253 case SVt_PVHV:
254 case SVt_PVCV:
a0d0e21e 255 DIE("Not a SCALAR reference");
79072805
LW		 256 }
257 }
258 else {
f12c7020 259 GV *gv = (GV*)sv;
748a9306
LW		 260 char *sym;
261
463ee0b2 262 if (SvTYPE(gv) != SVt_PVGV) {
a0d0e21e
LW		 263 if (SvGMAGICAL(sv)) {
264 mg_get(sv);
265 if (SvROK(sv))
266 goto wasref;
267 }
268 if (!SvOK(sv)) {
269 if (op->op_flags & OPf_REF ||
270 op->op_private & HINT_STRICT_REFS)
271 DIE(no_usym, "a SCALAR");
d83e6520
CS		 272 if (dowarn)
273 warn(warn_uninit);
a0d0e21e
LW		 274 RETSETUNDEF;
275 }
748a9306 276 sym = SvPV(sv, na);
85e6fe83 277 if (op->op_private & HINT_STRICT_REFS)
748a9306 278 DIE(no_symref, sym, "a SCALAR");
f12c7020 279 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
463ee0b2
LW		 280 }
281 sv = GvSV(gv);
a0d0e21e
LW		 282 }
283 if (op->op_flags & OPf_MOD) {
284 if (op->op_private & OPpLVAL_INTRO)
285 sv = save_scalar((GV*)TOPs);
5f05dabc 286 else if (op->op_private & OPpDEREF)
68dc0745 287 vivify_ref(sv, op->op_private & OPpDEREF);
79072805 288 }
a0d0e21e 289 SETs(sv);
79072805
LW		 290 RETURN;
291}
292
293PP(pp_av2arylen)
294{
295 dSP;
296 AV *av = (AV*)TOPs;
297 SV *sv = AvARYLEN(av);
298 if (!sv) {
299 AvARYLEN(av) = sv = NEWSV(0,0);
300 sv_upgrade(sv, SVt_IV);
301 sv_magic(sv, (SV*)av, '#', Nullch, 0);
302 }
303 SETs(sv);
304 RETURN;
305}
306
a0d0e21e
LW		 307PP(pp_pos)
308{
309 dSP; dTARGET; dPOPss;
310
311 if (op->op_flags & OPf_MOD) {
5f05dabc 312 if (SvTYPE(TARG) < SVt_PVLV) {
313 sv_upgrade(TARG, SVt_PVLV);
314 sv_magic(TARG, Nullsv, '.', Nullch, 0);
315 }
316
317 LvTYPE(TARG) = '.';
a0d0e21e
LW		 318 LvTARG(TARG) = sv;
319 PUSHs(TARG); /* no SvSETMAGIC */
320 RETURN;
321 }
322 else {
323 MAGIC* mg;
324
325 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
326 mg = mg_find(sv, 'g');
327 if (mg && mg->mg_len >= 0) {
328 PUSHi(mg->mg_len + curcop->cop_arybase);
329 RETURN;
330 }
331 }
332 RETPUSHUNDEF;
333 }
334}
335
79072805
LW		 336PP(pp_rv2cv)
337{
338 dSP;
79072805
LW		 339 GV *gv;
340 HV *stash;
8990e307 341
4633a7c4
LW		 342 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
343 /* (But not in defined().) */
344 CV *cv = sv_2cv(TOPs, &stash, &gv, !(op->op_flags & OPf_SPECIAL));
07055b4c
CS		 345 if (cv) {
346 if (CvCLONE(cv))
347 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
348 }
349 else
4633a7c4 350 cv = (CV*)&sv_undef;
79072805
LW		 351 SETs((SV*)cv);
352 RETURN;
353}
354
c07a80fd 355PP(pp_prototype)
356{
357 dSP;
358 CV *cv;
359 HV *stash;
360 GV *gv;
361 SV *ret;
362
363 ret = &sv_undef;
364 cv = sv_2cv(TOPs, &stash, &gv, FALSE);
5f05dabc 365 if (cv && SvPOK(cv))
366 ret = sv_2mortal(newSVpv(SvPVX(cv), SvCUR(cv)));
c07a80fd 367 SETs(ret);
368 RETURN;
369}
370
a0d0e21e
LW		 371PP(pp_anoncode)
372{
373 dSP;
5f05dabc 374 CV* cv = (CV*)curpad[op->op_targ];
a5f75d66 375 if (CvCLONE(cv))
b355b4e0 376 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
5f05dabc 377 EXTEND(SP,1);
748a9306 378 PUSHs((SV*)cv);
a0d0e21e
LW		 379 RETURN;
380}
381
382PP(pp_srefgen)
79072805 383{
71be2cbc 384 dSP;
385 *SP = refto(*SP);
79072805 386 RETURN;
a0d0e21e
LW		 387}
388
389PP(pp_refgen)
390{
391 dSP; dMARK;
a0d0e21e
LW		 392 if (GIMME != G_ARRAY) {
393 MARK[1] = *SP;
394 SP = MARK + 1;
395 }
bbce6d69 396 EXTEND_MORTAL(SP - MARK);
71be2cbc 397 while (++MARK <= SP)
398 *MARK = refto(*MARK);
a0d0e21e 399 RETURN;
79072805
LW		 400}
401
71be2cbc 402static SV*
8ac85365 403refto(SV *sv)
71be2cbc 404{
405 SV* rv;
406
407 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
408 if (LvTARGLEN(sv))
68dc0745 409 vivify_defelem(sv);
410 if (!(sv = LvTARG(sv)))
411 sv = &sv_undef;
71be2cbc 412 }
413 else if (SvPADTMP(sv))
414 sv = newSVsv(sv);
415 else {
416 SvTEMP_off(sv);
417 (void)SvREFCNT_inc(sv);
418 }
419 rv = sv_newmortal();
420 sv_upgrade(rv, SVt_RV);
421 SvRV(rv) = sv;
422 SvROK_on(rv);
423 return rv;
424}
425
79072805
LW		 426PP(pp_ref)
427{
463ee0b2
LW		 428 dSP; dTARGET;
429 SV *sv;
79072805
LW		 430 char *pv;
431
a0d0e21e 432 sv = POPs;
f12c7020 433
434 if (sv && SvGMAGICAL(sv))
435 mg_get(sv);
436
a0d0e21e 437 if (!sv || !SvROK(sv))
4633a7c4 438 RETPUSHNO;
79072805 439
ed6116ce 440 sv = SvRV(sv);
a0d0e21e 441 pv = sv_reftype(sv,TRUE);
463ee0b2 442 PUSHp(pv, strlen(pv));
79072805
LW		 443 RETURN;
444}
445
446PP(pp_bless)
447{
463ee0b2 448 dSP;
463ee0b2 449 HV *stash;
79072805 450
463ee0b2
LW		 451 if (MAXARG == 1)
452 stash = curcop->cop_stash;
453 else
a0d0e21e
LW		 454 stash = gv_stashsv(POPs, TRUE);
455
5d3fdfeb 456 (void)sv_bless(TOPs, stash);
79072805
LW		 457 RETURN;
458}
459
fb73857a 460PP(pp_gelem)
461{
462 GV *gv;
463 SV *sv;
464 SV *ref;
465 char *elem;
466 dSP;
467
468 sv = POPs;
469 elem = SvPV(sv, na);
470 gv = (GV*)POPs;
471 ref = Nullsv;
472 sv = Nullsv;
473 switch (elem ? *elem : '\0')
474 {
475 case 'A':
476 if (strEQ(elem, "ARRAY"))
477 ref = (SV*)GvAV(gv);
478 break;
479 case 'C':
480 if (strEQ(elem, "CODE"))
481 ref = (SV*)GvCVu(gv);
482 break;
483 case 'F':
484 if (strEQ(elem, "FILEHANDLE")) /* XXX deprecate in 5.005 */
485 ref = (SV*)GvIOp(gv);
486 break;
487 case 'G':
488 if (strEQ(elem, "GLOB"))
489 ref = (SV*)gv;
490 break;
491 case 'H':
492 if (strEQ(elem, "HASH"))
493 ref = (SV*)GvHV(gv);
494 break;
495 case 'I':
496 if (strEQ(elem, "IO"))
497 ref = (SV*)GvIOp(gv);
498 break;
499 case 'N':
500 if (strEQ(elem, "NAME"))
501 sv = newSVpv(GvNAME(gv), GvNAMELEN(gv));
502 break;
503 case 'P':
504 if (strEQ(elem, "PACKAGE"))
505 sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
506 break;
507 case 'S':
508 if (strEQ(elem, "SCALAR"))
509 ref = GvSV(gv);
510 break;
511 }
512 if (ref)
513 sv = newRV(ref);
514 if (sv)
515 sv_2mortal(sv);
516 else
517 sv = &sv_undef;
518 XPUSHs(sv);
519 RETURN;
520}
521
a0d0e21e 522/* Pattern matching */
79072805 523
a0d0e21e 524PP(pp_study)
79072805 525{
c07a80fd 526 dSP; dPOPss;
a0d0e21e
LW		 527 register unsigned char *s;
528 register I32 pos;
529 register I32 ch;
530 register I32 *sfirst;
531 register I32 *snext;
a0d0e21e
LW		 532 STRLEN len;
533
1e422769 534 if (sv == lastscream) {
535 if (SvSCREAM(sv))
536 RETPUSHYES;
537 }
c07a80fd 538 else {
539 if (lastscream) {
540 SvSCREAM_off(lastscream);
541 SvREFCNT_dec(lastscream);
542 }
543 lastscream = SvREFCNT_inc(sv);
544 }
1e422769 545
546 s = (unsigned char*)(SvPV(sv, len));
547 pos = len;
548 if (pos <= 0)
549 RETPUSHNO;
a0d0e21e
LW		 550 if (pos > maxscream) {
551 if (maxscream < 0) {
552 maxscream = pos + 80;
553 New(301, screamfirst, 256, I32);
554 New(302, screamnext, maxscream, I32);
79072805
LW		 555 }
556 else {
a0d0e21e
LW		 557 maxscream = pos + pos / 4;
558 Renew(screamnext, maxscream, I32);
79072805 559 }
79072805 560 }
a0d0e21e
LW		 561
562 sfirst = screamfirst;
563 snext = screamnext;
564
565 if (!sfirst || !snext)
566 DIE("do_study: out of memory");
567
568 for (ch = 256; ch; --ch)
569 *sfirst++ = -1;
570 sfirst -= 256;
571
572 while (--pos >= 0) {
573 ch = s[pos];
574 if (sfirst[ch] >= 0)
575 snext[pos] = sfirst[ch] - pos;
576 else
577 snext[pos] = -pos;
578 sfirst[ch] = pos;
79072805
LW		 579 }
580
c07a80fd 581 SvSCREAM_on(sv);
464e2e8a 582 sv_magic(sv, Nullsv, 'g', Nullch, 0); /* piggyback on m//g magic */
1e422769 583 RETPUSHYES;
79072805
LW		 584}
585
a0d0e21e 586PP(pp_trans)
79072805 587{
a0d0e21e
LW		 588 dSP; dTARG;
589 SV *sv;
590
591 if (op->op_flags & OPf_STACKED)
592 sv = POPs;
79072805 593 else {
a0d0e21e
LW		 594 sv = GvSV(defgv);
595 EXTEND(SP,1);
79072805 596 }
adbc6bb1 597 TARG = sv_newmortal();
a0d0e21e
LW		 598 PUSHi(do_trans(sv, op));
599 RETURN;
79072805
LW		 600}
601
a0d0e21e 602/* Lvalue operators. */
79072805 603
a0d0e21e
LW		 604PP(pp_schop)
605{
606 dSP; dTARGET;
607 do_chop(TARG, TOPs);
608 SETTARG;
609 RETURN;
79072805
LW		 610}
611
a0d0e21e 612PP(pp_chop)
79072805 613{
a0d0e21e
LW		 614 dSP; dMARK; dTARGET;
615 while (SP > MARK)
616 do_chop(TARG, POPs);
617 PUSHTARG;
618 RETURN;
79072805
LW		 619}
620
a0d0e21e 621PP(pp_schomp)
79072805 622{
a0d0e21e
LW		 623 dSP; dTARGET;
624 SETi(do_chomp(TOPs));
625 RETURN;
79072805
LW		 626}
627
a0d0e21e 628PP(pp_chomp)
79072805 629{
a0d0e21e
LW		 630 dSP; dMARK; dTARGET;
631 register I32 count = 0;
632
633 while (SP > MARK)
634 count += do_chomp(POPs);
635 PUSHi(count);
636 RETURN;
79072805
LW		 637}
638
a0d0e21e 639PP(pp_defined)
463ee0b2 640{
a0d0e21e
LW		 641 dSP;
642 register SV* sv;
643
644 sv = POPs;
645 if (!sv || !SvANY(sv))
646 RETPUSHNO;
647 switch (SvTYPE(sv)) {
648 case SVt_PVAV:
fb73857a 649 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv))
a0d0e21e
LW		 650 RETPUSHYES;
651 break;
652 case SVt_PVHV:
fb73857a 653 if (HvARRAY(sv) || SvGMAGICAL(sv))
a0d0e21e
LW		 654 RETPUSHYES;
655 break;
656 case SVt_PVCV:
657 if (CvROOT(sv) || CvXSUB(sv))
658 RETPUSHYES;
659 break;
660 default:
661 if (SvGMAGICAL(sv))
662 mg_get(sv);
663 if (SvOK(sv))
664 RETPUSHYES;
665 }
666 RETPUSHNO;
463ee0b2
LW		 667}
668
a0d0e21e
LW		 669PP(pp_undef)
670{
79072805 671 dSP;
a0d0e21e
LW		 672 SV *sv;
673
774d564b 674 if (!op->op_private) {
675 EXTEND(SP, 1);
a0d0e21e 676 RETPUSHUNDEF;
774d564b 677 }
79072805 678
a0d0e21e
LW		 679 sv = POPs;
680 if (!sv)
681 RETPUSHUNDEF;
85e6fe83 682
a0d0e21e
LW		 683 if (SvTHINKFIRST(sv)) {
684 if (SvREADONLY(sv))
685 RETPUSHUNDEF;
686 if (SvROK(sv))
687 sv_unref(sv);
85e6fe83
LW		 688 }
689
a0d0e21e
LW		 690 switch (SvTYPE(sv)) {
691 case SVt_NULL:
692 break;
693 case SVt_PVAV:
694 av_undef((AV*)sv);
695 break;
696 case SVt_PVHV:
697 hv_undef((HV*)sv);
698 break;
699 case SVt_PVCV:
54310121 700 if (cv_const_sv((CV*)sv))
9607fc9c 701 warn("Constant subroutine %s undefined",
54310121 702 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
9607fc9c 703 /* FALL THROUGH */
704 case SVt_PVFM:
09280a33
CS		 705 { GV* gv = (GV*)SvREFCNT_inc(CvGV((CV*)sv));
706 cv_undef((CV*)sv);
707 CvGV((CV*)sv) = gv; } /* let user-undef'd sub keep its identity */
a0d0e21e 708 break;
8e07c86e 709 case SVt_PVGV:
44a8e56a 710 if (SvFAKE(sv))
711 sv_setsv(sv, &sv_undef);
712 break;
a0d0e21e 713 default:
1e422769 714 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
4633a7c4
LW		 715 (void)SvOOK_off(sv);
716 Safefree(SvPVX(sv));
717 SvPV_set(sv, Nullch);
718 SvLEN_set(sv, 0);
a0d0e21e 719 }
4633a7c4
LW		 720 (void)SvOK_off(sv);
721 SvSETMAGIC(sv);
79072805 722 }
a0d0e21e
LW		 723
724 RETPUSHUNDEF;
79072805
LW		 725}
726
a0d0e21e 727PP(pp_predec)
79072805 728{
a0d0e21e 729 dSP;
68dc0745 730 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
44a8e56a 731 croak(no_modify);
55497cff 732 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
733 SvIVX(TOPs) != IV_MIN)
734 {
748a9306 735 --SvIVX(TOPs);
55497cff 736 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
748a9306
LW		 737 }
738 else
739 sv_dec(TOPs);
a0d0e21e
LW		 740 SvSETMAGIC(TOPs);
741 return NORMAL;
742}
79072805 743
a0d0e21e
LW		 744PP(pp_postinc)
745{
746 dSP; dTARGET;
68dc0745 747 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
44a8e56a 748 croak(no_modify);
a0d0e21e 749 sv_setsv(TARG, TOPs);
55497cff 750 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
751 SvIVX(TOPs) != IV_MAX)
752 {
748a9306 753 ++SvIVX(TOPs);
55497cff 754 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
748a9306
LW		 755 }
756 else
757 sv_inc(TOPs);
a0d0e21e
LW		 758 SvSETMAGIC(TOPs);
759 if (!SvOK(TARG))
760 sv_setiv(TARG, 0);
761 SETs(TARG);
762 return NORMAL;
763}
79072805 764
a0d0e21e
LW		 765PP(pp_postdec)
766{
767 dSP; dTARGET;
68dc0745 768 if(SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
44a8e56a 769 croak(no_modify);
a0d0e21e 770 sv_setsv(TARG, TOPs);
55497cff 771 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
772 SvIVX(TOPs) != IV_MIN)
773 {
748a9306 774 --SvIVX(TOPs);
55497cff 775 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
748a9306
LW		 776 }
777 else
778 sv_dec(TOPs);
a0d0e21e
LW		 779 SvSETMAGIC(TOPs);
780 SETs(TARG);
781 return NORMAL;
782}
79072805 783
a0d0e21e
LW		 784/* Ordinary operators. */
785
786PP(pp_pow)
787{
788 dSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
789 {
790 dPOPTOPnnrl;
791 SETn( pow( left, right) );
792 RETURN;
93a17b20 793 }
a0d0e21e
LW		 794}
795
796PP(pp_multiply)
797{
798 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
799 {
800 dPOPTOPnnrl;
801 SETn( left * right );
802 RETURN;
79072805 803 }
a0d0e21e
LW		 804}
805
806PP(pp_divide)
807{
808 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
809 {
77676ba1 810 dPOPPOPnnrl;
7a4c00b4 811 double value;
812 if (right == 0.0)
a0d0e21e
LW		 813 DIE("Illegal division by zero");
814#ifdef SLOPPYDIVIDE
815 /* insure that 20./5. == 4. */
816 {
7a4c00b4 817 IV k;
818 if ((double)I_V(left) == left &&
819 (double)I_V(right) == right &&
820 (k = I_V(left)/I_V(right))*I_V(right) == I_V(left)) {
a0d0e21e
LW		 821 value = k;
822 } else {
7a4c00b4 823 value = left / right;
79072805 824 }
a0d0e21e
LW		 825 }
826#else
7a4c00b4 827 value = left / right;
a0d0e21e
LW		 828#endif
829 PUSHn( value );
830 RETURN;
79072805 831 }
a0d0e21e
LW		 832}
833
834PP(pp_modulo)
835{
836 dSP; dATARGET; tryAMAGICbin(mod,opASSIGN);
837 {
68dc0745 838 UV left;
839 UV right;
beb18505
CS		 840 bool left_neg;
841 bool right_neg;
68dc0745 842 UV ans;
a0d0e21e 843
68dc0745 844 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
845 IV i = SvIVX(POPs);
beb18505 846 right = (right_neg = (i < 0)) ? -i : i;
68dc0745 847 }
848 else {
849 double n = POPn;
beb18505 850 right = U_V((right_neg = (n < 0)) ? -n : n);
68dc0745 851 }
a0d0e21e 852
36477c24 853 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
68dc0745 854 IV i = SvIVX(POPs);
beb18505 855 left = (left_neg = (i < 0)) ? -i : i;
36477c24 856 }
a0d0e21e 857 else {
68dc0745 858 double n = POPn;
beb18505 859 left = U_V((left_neg = (n < 0)) ? -n : n);
a0d0e21e 860 }
68dc0745 861
862 if (!right)
863 DIE("Illegal modulus zero");
864
865 ans = left % right;
beb18505 866 if ((left_neg != right_neg) && ans)
68dc0745 867 ans = right - ans;
beb18505 868 if (right_neg) {
3e3baf6d
TB		 869 /* XXX may warn: unary minus operator applied to unsigned type */
870 /* could change -foo to be (~foo)+1 instead */
beb18505
CS		 871 if (ans <= -(UV)IV_MAX)
872 sv_setiv(TARG, (IV) -ans);
873 else
874 sv_setnv(TARG, -(double)ans);
875 }
876 else
877 sv_setuv(TARG, ans);
878 PUSHTARG;
a0d0e21e 879 RETURN;
79072805 880 }
a0d0e21e 881}
79072805 882
a0d0e21e
LW		 883PP(pp_repeat)
884{
748a9306
LW		 885 dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
886 {
a0d0e21e
LW		 887 register I32 count = POPi;
888 if (GIMME == G_ARRAY && op->op_private & OPpREPEAT_DOLIST) {
889 dMARK;
890 I32 items = SP - MARK;
891 I32 max;
79072805 892
a0d0e21e
LW		 893 max = items * count;
894 MEXTEND(MARK, max);
895 if (count > 1) {
896 while (SP > MARK) {
897 if (*SP)
898 SvTEMP_off((*SP));
899 SP--;
79072805 900 }
a0d0e21e
LW		 901 MARK++;
902 repeatcpy((char*)(MARK + items), (char*)MARK,
903 items * sizeof(SV*), count - 1);
904 SP += max;
79072805 905 }
a0d0e21e
LW		 906 else if (count <= 0)
907 SP -= items;
79072805 908 }
a0d0e21e
LW		 909 else { /* Note: mark already snarfed by pp_list */
910 SV *tmpstr;
911 STRLEN len;
912
913 tmpstr = POPs;
914 if (TARG == tmpstr && SvTHINKFIRST(tmpstr)) {
915 if (SvREADONLY(tmpstr) && curcop != &compiling)
916 DIE("Can't x= to readonly value");
917 if (SvROK(tmpstr))
918 sv_unref(tmpstr);
93a17b20 919 }
a0d0e21e
LW		 920 SvSetSV(TARG, tmpstr);
921 SvPV_force(TARG, len);
8ebc5c01 922 if (count != 1) {
923 if (count < 1)
924 SvCUR_set(TARG, 0);
925 else {
926 SvGROW(TARG, (count * len) + 1);
a0d0e21e 927 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
8ebc5c01 928 SvCUR(TARG) *= count;
7a4c00b4 929 }
a0d0e21e 930 *SvEND(TARG) = '\0';
a0d0e21e 931 }
8ebc5c01 932 (void)SvPOK_only(TARG);
a0d0e21e 933 PUSHTARG;
79072805 934 }
a0d0e21e 935 RETURN;
748a9306 936 }
a0d0e21e 937}
79072805 938
a0d0e21e
LW		 939PP(pp_subtract)
940{
941 dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
942 {
7a4c00b4 943 dPOPTOPnnrl_ul;
a0d0e21e
LW		 944 SETn( left - right );
945 RETURN;
79072805 946 }
a0d0e21e 947}
79072805 948
a0d0e21e
LW		 949PP(pp_left_shift)
950{
951 dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
952 {
36477c24 953 IBW shift = POPi;
ff68c719 954 if (op->op_private & HINT_INTEGER) {
36477c24 955 IBW i = TOPi;
46fc3d4c 956 i = BWi(i) << shift;
96e4d5b1 957 SETi(BWi(i));
ff68c719 958 }
959 else {
36477c24 960 UBW u = TOPu;
96e4d5b1 961 u <<= shift;
962 SETu(BWu(u));
ff68c719 963 }
55497cff 964 RETURN;
79072805 965 }
a0d0e21e 966}
79072805 967
a0d0e21e
LW		 968PP(pp_right_shift)
969{
970 dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
971 {
36477c24 972 IBW shift = POPi;
ff68c719 973 if (op->op_private & HINT_INTEGER) {
36477c24 974 IBW i = TOPi;
46fc3d4c 975 i = BWi(i) >> shift;
96e4d5b1 976 SETi(BWi(i));
ff68c719 977 }
978 else {
36477c24 979 UBW u = TOPu;
96e4d5b1 980 u >>= shift;
981 SETu(BWu(u));
ff68c719 982 }
a0d0e21e 983 RETURN;
93a17b20 984 }
79072805
LW		 985}
986
a0d0e21e 987PP(pp_lt)
79072805 988{
a0d0e21e
LW		 989 dSP; tryAMAGICbinSET(lt,0);
990 {
991 dPOPnv;
54310121 992 SETs(boolSV(TOPn < value));
a0d0e21e 993 RETURN;
79072805 994 }
a0d0e21e 995}
79072805 996
a0d0e21e
LW		 997PP(pp_gt)
998{
999 dSP; tryAMAGICbinSET(gt,0);
1000 {
1001 dPOPnv;
54310121 1002 SETs(boolSV(TOPn > value));
a0d0e21e 1003 RETURN;
79072805 1004 }
a0d0e21e
LW		 1005}
1006
1007PP(pp_le)
1008{
1009 dSP; tryAMAGICbinSET(le,0);
1010 {
1011 dPOPnv;
54310121 1012 SETs(boolSV(TOPn <= value));
a0d0e21e 1013 RETURN;
79072805 1014 }
a0d0e21e
LW		 1015}
1016
1017PP(pp_ge)
1018{
1019 dSP; tryAMAGICbinSET(ge,0);
1020 {
1021 dPOPnv;
54310121 1022 SETs(boolSV(TOPn >= value));
a0d0e21e 1023 RETURN;
79072805 1024 }
a0d0e21e 1025}
79072805 1026
a0d0e21e
LW		 1027PP(pp_ne)
1028{
1029 dSP; tryAMAGICbinSET(ne,0);
1030 {
1031 dPOPnv;
54310121 1032 SETs(boolSV(TOPn != value));
a0d0e21e
LW		 1033 RETURN;
1034 }
79072805
LW		 1035}
1036
a0d0e21e 1037PP(pp_ncmp)
79072805 1038{
a0d0e21e
LW		 1039 dSP; dTARGET; tryAMAGICbin(ncmp,0);
1040 {
1041 dPOPTOPnnrl;
1042 I32 value;
79072805 1043
ff0cee69 1044 if (left == right)
a0d0e21e 1045 value = 0;
a0d0e21e
LW		 1046 else if (left < right)
1047 value = -1;
44a8e56a 1048 else if (left > right)
1049 value = 1;
1050 else {
1051 SETs(&sv_undef);
1052 RETURN;
1053 }
a0d0e21e
LW		 1054 SETi(value);
1055 RETURN;
79072805 1056 }
a0d0e21e 1057}
79072805 1058
a0d0e21e
LW		 1059PP(pp_slt)
1060{
1061 dSP; tryAMAGICbinSET(slt,0);
1062 {
1063 dPOPTOPssrl;
bbce6d69 1064 int cmp = ((op->op_private & OPpLOCALE)
1065 ? sv_cmp_locale(left, right)
1066 : sv_cmp(left, right));
54310121 1067 SETs(boolSV(cmp < 0));
a0d0e21e
LW		 1068 RETURN;
1069 }
79072805
LW		 1070}
1071
a0d0e21e 1072PP(pp_sgt)
79072805 1073{
a0d0e21e
LW		 1074 dSP; tryAMAGICbinSET(sgt,0);
1075 {
1076 dPOPTOPssrl;
bbce6d69 1077 int cmp = ((op->op_private & OPpLOCALE)
1078 ? sv_cmp_locale(left, right)
1079 : sv_cmp(left, right));
54310121 1080 SETs(boolSV(cmp > 0));
a0d0e21e
LW		 1081 RETURN;
1082 }
1083}
79072805 1084
a0d0e21e
LW		 1085PP(pp_sle)
1086{
1087 dSP; tryAMAGICbinSET(sle,0);
1088 {
1089 dPOPTOPssrl;
bbce6d69 1090 int cmp = ((op->op_private & OPpLOCALE)
1091 ? sv_cmp_locale(left, right)
1092 : sv_cmp(left, right));
54310121 1093 SETs(boolSV(cmp <= 0));
a0d0e21e 1094 RETURN;
79072805 1095 }
79072805
LW		 1096}
1097
a0d0e21e
LW		 1098PP(pp_sge)
1099{
1100 dSP; tryAMAGICbinSET(sge,0);
1101 {
1102 dPOPTOPssrl;
bbce6d69 1103 int cmp = ((op->op_private & OPpLOCALE)
1104 ? sv_cmp_locale(left, right)
1105 : sv_cmp(left, right));
54310121 1106 SETs(boolSV(cmp >= 0));
a0d0e21e
LW		 1107 RETURN;
1108 }
1109}
79072805 1110
36477c24 1111PP(pp_seq)
1112{
1113 dSP; tryAMAGICbinSET(seq,0);
1114 {
1115 dPOPTOPssrl;
54310121 1116 SETs(boolSV(sv_eq(left, right)));
a0d0e21e
LW		 1117 RETURN;
1118 }
1119}
79072805 1120
a0d0e21e 1121PP(pp_sne)
79072805 1122{
a0d0e21e
LW		 1123 dSP; tryAMAGICbinSET(sne,0);
1124 {
1125 dPOPTOPssrl;
54310121 1126 SETs(boolSV(!sv_eq(left, right)));
a0d0e21e 1127 RETURN;
463ee0b2 1128 }
79072805
LW		 1129}
1130
a0d0e21e 1131PP(pp_scmp)
79072805 1132{
a0d0e21e
LW		 1133 dSP; dTARGET; tryAMAGICbin(scmp,0);
1134 {
1135 dPOPTOPssrl;
bbce6d69 1136 int cmp = ((op->op_private & OPpLOCALE)
1137 ? sv_cmp_locale(left, right)
1138 : sv_cmp(left, right));
1139 SETi( cmp );
a0d0e21e
LW		 1140 RETURN;
1141 }
1142}
79072805 1143
55497cff 1144PP(pp_bit_and)
1145{
a0d0e21e
LW		 1146 dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
1147 {
1148 dPOPTOPssrl;
4633a7c4 1149 if (SvNIOKp(left) || SvNIOKp(right)) {
36477c24 1150 if (op->op_private & HINT_INTEGER) {
1151 IBW value = SvIV(left) & SvIV(right);
96e4d5b1 1152 SETi(BWi(value));
36477c24 1153 }
1154 else {
1155 UBW value = SvUV(left) & SvUV(right);
96e4d5b1 1156 SETu(BWu(value));
36477c24 1157 }
a0d0e21e
LW		 1158 }
1159 else {
1160 do_vop(op->op_type, TARG, left, right);
1161 SETTARG;
1162 }
1163 RETURN;
1164 }
1165}
79072805 1166
a0d0e21e
LW		 1167PP(pp_bit_xor)
1168{
1169 dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
1170 {
1171 dPOPTOPssrl;
4633a7c4 1172 if (SvNIOKp(left) || SvNIOKp(right)) {
36477c24 1173 if (op->op_private & HINT_INTEGER) {
1fbd88dc 1174 IBW value = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
96e4d5b1 1175 SETi(BWi(value));
36477c24 1176 }
1177 else {
1fbd88dc 1178 UBW value = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
96e4d5b1 1179 SETu(BWu(value));
36477c24 1180 }
a0d0e21e
LW		 1181 }
1182 else {
1183 do_vop(op->op_type, TARG, left, right);
1184 SETTARG;
1185 }
1186 RETURN;
1187 }
1188}
79072805 1189
a0d0e21e
LW		 1190PP(pp_bit_or)
1191{
1192 dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
1193 {
1194 dPOPTOPssrl;
4633a7c4 1195 if (SvNIOKp(left) || SvNIOKp(right)) {
36477c24 1196 if (op->op_private & HINT_INTEGER) {
8ebc5c01 1197 IBW value = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
96e4d5b1 1198 SETi(BWi(value));
36477c24 1199 }
1200 else {
8ebc5c01 1201 UBW value = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
96e4d5b1 1202 SETu(BWu(value));
36477c24 1203 }
a0d0e21e
LW		 1204 }
1205 else {
1206 do_vop(op->op_type, TARG, left, right);
1207 SETTARG;
1208 }
1209 RETURN;
79072805 1210 }
a0d0e21e 1211}
79072805 1212
a0d0e21e
LW		 1213PP(pp_negate)
1214{
1215 dSP; dTARGET; tryAMAGICun(neg);
1216 {
1217 dTOPss;
4633a7c4
LW		 1218 if (SvGMAGICAL(sv))
1219 mg_get(sv);
55497cff 1220 if (SvIOKp(sv) && !SvNOKp(sv) && !SvPOKp(sv) && SvIVX(sv) != IV_MIN)
1221 SETi(-SvIVX(sv));
1222 else if (SvNIOKp(sv))
a0d0e21e 1223 SETn(-SvNV(sv));
4633a7c4 1224 else if (SvPOKp(sv)) {
a0d0e21e
LW		 1225 STRLEN len;
1226 char *s = SvPV(sv, len);
bbce6d69 1227 if (isIDFIRST(*s)) {
a0d0e21e
LW		 1228 sv_setpvn(TARG, "-", 1);
1229 sv_catsv(TARG, sv);
79072805 1230 }
a0d0e21e
LW		 1231 else if (*s == '+' || *s == '-') {
1232 sv_setsv(TARG, sv);
1233 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
79072805
LW		 1234 }
1235 else
a0d0e21e
LW		 1236 sv_setnv(TARG, -SvNV(sv));
1237 SETTARG;
79072805 1238 }
4633a7c4
LW		 1239 else
1240 SETn(-SvNV(sv));
79072805 1241 }
a0d0e21e 1242 RETURN;
79072805
LW		 1243}
1244
a0d0e21e 1245PP(pp_not)
79072805 1246{
a0d0e21e
LW		 1247#ifdef OVERLOAD
1248 dSP; tryAMAGICunSET(not);
1249#endif /* OVERLOAD */
54310121 1250 *stack_sp = boolSV(!SvTRUE(*stack_sp));
a0d0e21e 1251 return NORMAL;
79072805
LW		 1252}
1253
a0d0e21e 1254PP(pp_complement)
79072805 1255{
a0d0e21e
LW		 1256 dSP; dTARGET; tryAMAGICun(compl);
1257 {
1258 dTOPss;
4633a7c4 1259 if (SvNIOKp(sv)) {
36477c24 1260 if (op->op_private & HINT_INTEGER) {
1261 IBW value = ~SvIV(sv);
96e4d5b1 1262 SETi(BWi(value));
36477c24 1263 }
1264 else {
1265 UBW value = ~SvUV(sv);
96e4d5b1 1266 SETu(BWu(value));
36477c24 1267 }
a0d0e21e
LW		 1268 }
1269 else {
1270 register char *tmps;
1271 register long *tmpl;
55497cff 1272 register I32 anum;
a0d0e21e
LW		 1273 STRLEN len;
1274
1275 SvSetSV(TARG, sv);
1276 tmps = SvPV_force(TARG, len);
1277 anum = len;
1278#ifdef LIBERAL
1279 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
1280 *tmps = ~*tmps;
1281 tmpl = (long*)tmps;
1282 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
1283 *tmpl = ~*tmpl;
1284 tmps = (char*)tmpl;
1285#endif
1286 for ( ; anum > 0; anum--, tmps++)
1287 *tmps = ~*tmps;
1288
1289 SETs(TARG);
1290 }
1291 RETURN;
1292 }
79072805
LW		 1293}
1294
a0d0e21e
LW		 1295/* integer versions of some of the above */
1296
a0d0e21e 1297PP(pp_i_multiply)
79072805 1298{
a0d0e21e
LW		 1299 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1300 {
1301 dPOPTOPiirl;
1302 SETi( left * right );
1303 RETURN;
1304 }
79072805
LW		 1305}
1306
a0d0e21e 1307PP(pp_i_divide)
79072805 1308{
a0d0e21e
LW		 1309 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1310 {
1311 dPOPiv;
1312 if (value == 0)
1313 DIE("Illegal division by zero");
1314 value = POPi / value;
1315 PUSHi( value );
1316 RETURN;
1317 }
79072805
LW		 1318}
1319
a0d0e21e 1320PP(pp_i_modulo)
79072805 1321{
a0d0e21e 1322 dSP; dATARGET; tryAMAGICbin(mod,opASSIGN);
79072805 1323 {
a0d0e21e 1324 dPOPTOPiirl;
aa306039
CS		 1325 if (!right)
1326 DIE("Illegal modulus zero");
a0d0e21e
LW		 1327 SETi( left % right );
1328 RETURN;
79072805 1329 }
79072805
LW		 1330}
1331
a0d0e21e 1332PP(pp_i_add)
79072805 1333{
a0d0e21e
LW		 1334 dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
1335 {
1336 dPOPTOPiirl;
1337 SETi( left + right );
1338 RETURN;
79072805 1339 }
79072805
LW		 1340}
1341
a0d0e21e 1342PP(pp_i_subtract)
79072805 1343{
a0d0e21e
LW		 1344 dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1345 {
1346 dPOPTOPiirl;
1347 SETi( left - right );
1348 RETURN;
79072805 1349 }
79072805
LW		 1350}
1351
a0d0e21e 1352PP(pp_i_lt)
79072805 1353{
a0d0e21e
LW		 1354 dSP; tryAMAGICbinSET(lt,0);
1355 {
1356 dPOPTOPiirl;
54310121 1357 SETs(boolSV(left < right));
a0d0e21e
LW		 1358 RETURN;
1359 }
79072805
LW		 1360}
1361
a0d0e21e 1362PP(pp_i_gt)
79072805 1363{
a0d0e21e
LW		 1364 dSP; tryAMAGICbinSET(gt,0);
1365 {
1366 dPOPTOPiirl;
54310121 1367 SETs(boolSV(left > right));
a0d0e21e
LW		 1368 RETURN;
1369 }
79072805
LW		 1370}
1371
a0d0e21e 1372PP(pp_i_le)
79072805 1373{
a0d0e21e
LW		 1374 dSP; tryAMAGICbinSET(le,0);
1375 {
1376 dPOPTOPiirl;
54310121 1377 SETs(boolSV(left <= right));
a0d0e21e 1378 RETURN;
85e6fe83 1379 }
79072805
LW		 1380}
1381
a0d0e21e 1382PP(pp_i_ge)
79072805 1383{
a0d0e21e
LW		 1384 dSP; tryAMAGICbinSET(ge,0);
1385 {
1386 dPOPTOPiirl;
54310121 1387 SETs(boolSV(left >= right));
a0d0e21e
LW		 1388 RETURN;
1389 }
79072805
LW		 1390}
1391
a0d0e21e 1392PP(pp_i_eq)
79072805 1393{
a0d0e21e
LW		 1394 dSP; tryAMAGICbinSET(eq,0);
1395 {
1396 dPOPTOPiirl;
54310121 1397 SETs(boolSV(left == right));
a0d0e21e
LW		 1398 RETURN;
1399 }
79072805
LW		 1400}
1401
a0d0e21e 1402PP(pp_i_ne)
79072805 1403{
a0d0e21e
LW		 1404 dSP; tryAMAGICbinSET(ne,0);
1405 {
1406 dPOPTOPiirl;
54310121 1407 SETs(boolSV(left != right));
a0d0e21e
LW		 1408 RETURN;
1409 }
79072805
LW		 1410}
1411
a0d0e21e 1412PP(pp_i_ncmp)
79072805 1413{
a0d0e21e
LW		 1414 dSP; dTARGET; tryAMAGICbin(ncmp,0);
1415 {
1416 dPOPTOPiirl;
1417 I32 value;
79072805 1418
a0d0e21e 1419 if (left > right)
79072805 1420 value = 1;
a0d0e21e 1421 else if (left < right)
79072805 1422 value = -1;
a0d0e21e 1423 else
79072805 1424 value = 0;
a0d0e21e
LW		 1425 SETi(value);
1426 RETURN;
79072805 1427 }
85e6fe83
LW		 1428}
1429
1430PP(pp_i_negate)
1431{
a0d0e21e 1432 dSP; dTARGET; tryAMAGICun(neg);
85e6fe83
LW		 1433 SETi(-TOPi);
1434 RETURN;
1435}
1436
79072805
LW		 1437/* High falutin' math. */
1438
1439PP(pp_atan2)
1440{
a0d0e21e
LW		 1441 dSP; dTARGET; tryAMAGICbin(atan2,0);
1442 {
1443 dPOPTOPnnrl;
1444 SETn(atan2(left, right));
1445 RETURN;
1446 }
79072805
LW		 1447}
1448
1449PP(pp_sin)
1450{
a0d0e21e
LW		 1451 dSP; dTARGET; tryAMAGICun(sin);
1452 {
1453 double value;
1454 value = POPn;
1455 value = sin(value);
1456 XPUSHn(value);
1457 RETURN;
1458 }
79072805
LW		 1459}
1460
1461PP(pp_cos)
1462{
a0d0e21e
LW		 1463 dSP; dTARGET; tryAMAGICun(cos);
1464 {
1465 double value;
1466 value = POPn;
1467 value = cos(value);
1468 XPUSHn(value);
1469 RETURN;
1470 }
79072805
LW		 1471}
1472
1473PP(pp_rand)
1474{
1475 dSP; dTARGET;
1476 double value;
1477 if (MAXARG < 1)
1478 value = 1.0;
1479 else
1480 value = POPn;
1481 if (value == 0.0)
1482 value = 1.0;
93dc8474
CS		 1483 if (!srand_called) {
1484 (void)srand((unsigned)seed());
1485 srand_called = TRUE;
1486 }
79072805
LW		 1487#if RANDBITS == 31
1488 value = rand() * value / 2147483648.0;
1489#else
1490#if RANDBITS == 16
1491 value = rand() * value / 65536.0;
1492#else
1493#if RANDBITS == 15
1494 value = rand() * value / 32768.0;
1495#else
1496 value = rand() * value / (double)(((unsigned long)1) << RANDBITS);
1497#endif
1498#endif
1499#endif
1500 XPUSHn(value);
1501 RETURN;
1502}
1503
1504PP(pp_srand)
1505{
1506 dSP;
93dc8474
CS		 1507 UV anum;
1508 if (MAXARG < 1)
1509 anum = seed();
79072805 1510 else
93dc8474
CS		 1511 anum = POPu;
1512 (void)srand((unsigned)anum);
1513 srand_called = TRUE;
79072805
LW		 1514 EXTEND(SP, 1);
1515 RETPUSHYES;
1516}
1517
93dc8474 1518static U32
8ac85365 1519seed(void)
93dc8474 1520{
54310121 1521 /*
1522 * This is really just a quick hack which grabs various garbage
1523 * values. It really should be a real hash algorithm which
1524 * spreads the effect of every input bit onto every output bit,
1525 * if someone who knows about such tings would bother to write it.
1526 * Might be a good idea to add that function to CORE as well.
1527 * No numbers below come from careful analysis or anyting here,
1528 * except they are primes and SEED_C1 > 1E6 to get a full-width
1529 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
1530 * probably be bigger too.
1531 */
1532#if RANDBITS > 16
1533# define SEED_C1 1000003
1534#define SEED_C4 73819
1535#else
1536# define SEED_C1 25747
1537#define SEED_C4 20639
1538#endif
1539#define SEED_C2 3
1540#define SEED_C3 269
1541#define SEED_C5 26107
1542
e858de61 1543 dTHR;
93dc8474 1544 U32 u;
f12c7020 1545#ifdef VMS
1546# include <starlet.h>
43c92808
HF		 1547 /* when[] = (low 32 bits, high 32 bits) of time since epoch
1548 * in 100-ns units, typically incremented ever 10 ms. */
93dc8474
CS		 1549 unsigned int when[2];
1550 _ckvmssts(sys$gettim(when));
54310121 1551 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
f12c7020 1552#else
5f05dabc 1553# ifdef HAS_GETTIMEOFDAY
93dc8474
CS		 1554 struct timeval when;
1555 gettimeofday(&when,(struct timezone *) 0);
54310121 1556 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
f12c7020 1557# else
93dc8474
CS		 1558 Time_t when;
1559 (void)time(&when);
54310121 1560 u = (U32)SEED_C1 * when;
f12c7020 1561# endif
1562#endif
54310121 1563 u += SEED_C3 * (U32)getpid();
1564 u += SEED_C4 * (U32)(UV)stack_sp;
1565#ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
1566 u += SEED_C5 * (U32)(UV)&when;
f12c7020 1567#endif
93dc8474 1568 return u;
79072805
LW		 1569}
1570
1571PP(pp_exp)
1572{
a0d0e21e
LW		 1573 dSP; dTARGET; tryAMAGICun(exp);
1574 {
1575 double value;
1576 value = POPn;
1577 value = exp(value);
1578 XPUSHn(value);
1579 RETURN;
1580 }
79072805
LW		 1581}
1582
1583PP(pp_log)
1584{
a0d0e21e
LW		 1585 dSP; dTARGET; tryAMAGICun(log);
1586 {
1587 double value;
1588 value = POPn;
bbce6d69 1589 if (value <= 0.0) {
36477c24 1590 SET_NUMERIC_STANDARD();
2304df62 1591 DIE("Can't take log of %g", value);
bbce6d69 1592 }
a0d0e21e
LW		 1593 value = log(value);
1594 XPUSHn(value);
1595 RETURN;
1596 }
79072805
LW		 1597}
1598
1599PP(pp_sqrt)
1600{
a0d0e21e
LW		 1601 dSP; dTARGET; tryAMAGICun(sqrt);
1602 {
1603 double value;
1604 value = POPn;
bbce6d69 1605 if (value < 0.0) {
36477c24 1606 SET_NUMERIC_STANDARD();
2304df62 1607 DIE("Can't take sqrt of %g", value);
bbce6d69 1608 }
a0d0e21e
LW		 1609 value = sqrt(value);
1610 XPUSHn(value);
1611 RETURN;
1612 }
79072805
LW		 1613}
1614
1615PP(pp_int)
1616{
1617 dSP; dTARGET;
774d564b 1618 {
1619 double value = TOPn;
1620 IV iv;
1621
1622 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) {
1623 iv = SvIVX(TOPs);
1624 SETi(iv);
1625 }
1626 else {
1627 if (value >= 0.0)
1628 (void)modf(value, &value);
1629 else {
1630 (void)modf(-value, &value);
1631 value = -value;
1632 }
1633 iv = I_V(value);
1634 if (iv == value)
1635 SETi(iv);
1636 else
1637 SETn(value);
1638 }
79072805 1639 }
79072805
LW		 1640 RETURN;
1641}
1642
463ee0b2
LW		 1643PP(pp_abs)
1644{
a0d0e21e
LW		 1645 dSP; dTARGET; tryAMAGICun(abs);
1646 {
774d564b 1647 double value = TOPn;
1648 IV iv;
463ee0b2 1649
774d564b 1650 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs) &&
1651 (iv = SvIVX(TOPs)) != IV_MIN) {
1652 if (iv < 0)
1653 iv = -iv;
1654 SETi(iv);
1655 }
1656 else {
1657 if (value < 0.0)
1658 value = -value;
1659 SETn(value);
1660 }
a0d0e21e 1661 }
774d564b 1662 RETURN;
463ee0b2
LW		 1663}
1664
79072805
LW		 1665PP(pp_hex)
1666{
1667 dSP; dTARGET;
1668 char *tmps;
1669 I32 argtype;
1670
a0d0e21e 1671 tmps = POPp;
55497cff 1672 XPUSHu(scan_hex(tmps, 99, &argtype));
79072805
LW		 1673 RETURN;
1674}
1675
1676PP(pp_oct)
1677{
1678 dSP; dTARGET;
55497cff 1679 UV value;
79072805
LW		 1680 I32 argtype;
1681 char *tmps;
1682
a0d0e21e 1683 tmps = POPp;
464e2e8a 1684 while (*tmps && isSPACE(*tmps))
1685 tmps++;
1686 if (*tmps == '0')
79072805
LW		 1687 tmps++;
1688 if (*tmps == 'x')
464e2e8a 1689 value = scan_hex(++tmps, 99, &argtype);
1690 else
1691 value = scan_oct(tmps, 99, &argtype);
55497cff 1692 XPUSHu(value);
79072805
LW		 1693 RETURN;
1694}
1695
1696/* String stuff. */
1697
1698PP(pp_length)
1699{
1700 dSP; dTARGET;
a0d0e21e 1701 SETi( sv_len(TOPs) );
79072805
LW		 1702 RETURN;
1703}
1704
1705PP(pp_substr)
1706{
1707 dSP; dTARGET;
1708 SV *sv;
1709 I32 len;
463ee0b2 1710 STRLEN curlen;
79072805
LW		 1711 I32 pos;
1712 I32 rem;
84902520 1713 I32 fail;
a0d0e21e 1714 I32 lvalue = op->op_flags & OPf_MOD;
79072805 1715 char *tmps;
a0d0e21e 1716 I32 arybase = curcop->cop_arybase;
79072805
LW		 1717
1718 if (MAXARG > 2)
1719 len = POPi;
84902520 1720 pos = POPi;
79072805 1721 sv = POPs;
a0d0e21e 1722 tmps = SvPV(sv, curlen);
84902520
TB		 1723 if (pos >= arybase) {
1724 pos -= arybase;
1725 rem = curlen-pos;
1726 fail = rem;
1727 if (MAXARG > 2) {
1728 if (len < 0) {
1729 rem += len;
1730 if (rem < 0)
1731 rem = 0;
1732 }
1733 else if (rem > len)
1734 rem = len;
1735 }
68dc0745 1736 }
84902520
TB		 1737 else {
1738 pos += curlen;
1739 if (MAXARG < 3)
1740 rem = curlen;
1741 else if (len >= 0) {
1742 rem = pos+len;
1743 if (rem > (I32)curlen)
1744 rem = curlen;
1745 }
1746 else {
1747 rem = curlen+len;
1748 if (rem < pos)
1749 rem = pos;
1750 }
1751 if (pos < 0)
1752 pos = 0;
1753 fail = rem;
1754 rem -= pos;
1755 }
1756 if (fail < 0) {
1757 if (dowarn || lvalue)
2304df62
AD		 1758 warn("substr outside of string");
1759 RETPUSHUNDEF;
1760 }
79072805 1761 else {
79072805 1762 tmps += pos;
79072805
LW		 1763 sv_setpvn(TARG, tmps, rem);
1764 if (lvalue) { /* it's an lvalue! */
dedeecda 1765 if (!SvGMAGICAL(sv)) {
1766 if (SvROK(sv)) {
1767 SvPV_force(sv,na);
1768 if (dowarn)
1769 warn("Attempt to use reference as lvalue in substr");
1770 }
1771 if (SvOK(sv)) /* is it defined ? */
1772 (void)SvPOK_only(sv);
1773 else
1774 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
1775 }
5f05dabc 1776
a0d0e21e
LW		 1777 if (SvTYPE(TARG) < SVt_PVLV) {
1778 sv_upgrade(TARG, SVt_PVLV);
1779 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
ed6116ce 1780 }
a0d0e21e 1781
5f05dabc 1782 LvTYPE(TARG) = 'x';
79072805 1783 LvTARG(TARG) = sv;
a0d0e21e 1784 LvTARGOFF(TARG) = pos;
79072805
LW		 1785 LvTARGLEN(TARG) = rem;
1786 }
1787 }
1788 PUSHs(TARG); /* avoid SvSETMAGIC here */
1789 RETURN;
1790}
1791
1792PP(pp_vec)
1793{
1794 dSP; dTARGET;
1795 register I32 size = POPi;
1796 register I32 offset = POPi;
1797 register SV *src = POPs;
a0d0e21e 1798 I32 lvalue = op->op_flags & OPf_MOD;
463ee0b2
LW		 1799 STRLEN srclen;
1800 unsigned char *s = (unsigned char*)SvPV(src, srclen);
79072805
LW		 1801 unsigned long retnum;
1802 I32 len;
1803
1804 offset *= size; /* turn into bit offset */
1805 len = (offset + size + 7) / 8;
1806 if (offset < 0 || size < 1)
1807 retnum = 0;
79072805 1808 else {
a0d0e21e
LW		 1809 if (lvalue) { /* it's an lvalue! */
1810 if (SvTYPE(TARG) < SVt_PVLV) {
1811 sv_upgrade(TARG, SVt_PVLV);
1812 sv_magic(TARG, Nullsv, 'v', Nullch, 0);
1813 }
1814
1815 LvTYPE(TARG) = 'v';
1816 LvTARG(TARG) = src;
1817 LvTARGOFF(TARG) = offset;
1818 LvTARGLEN(TARG) = size;
1819 }
93a17b20 1820 if (len > srclen) {
a0d0e21e
LW		 1821 if (size <= 8)
1822 retnum = 0;
1823 else {
1824 offset >>= 3;
748a9306
LW		 1825 if (size == 16) {
1826 if (offset >= srclen)
1827 retnum = 0;
a0d0e21e 1828 else
748a9306
LW		 1829 retnum = (unsigned long) s[offset] << 8;
1830 }
1831 else if (size == 32) {
1832 if (offset >= srclen)
1833 retnum = 0;
1834 else if (offset + 1 >= srclen)
a0d0e21e 1835 retnum = (unsigned long) s[offset] << 24;
748a9306
LW		 1836 else if (offset + 2 >= srclen)
1837 retnum = ((unsigned long) s[offset] << 24) +
1838 ((unsigned long) s[offset + 1] << 16);
1839 else
1840 retnum = ((unsigned long) s[offset] << 24) +
1841 ((unsigned long) s[offset + 1] << 16) +
1842 (s[offset + 2] << 8);
a0d0e21e
LW		 1843 }
1844 }
79072805 1845 }
a0d0e21e 1846 else if (size < 8)
79072805
LW		 1847 retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1);
1848 else {
1849 offset >>= 3;
1850 if (size == 8)
1851 retnum = s[offset];
1852 else if (size == 16)
1853 retnum = ((unsigned long) s[offset] << 8) + s[offset+1];
1854 else if (size == 32)
1855 retnum = ((unsigned long) s[offset] << 24) +
1856 ((unsigned long) s[offset + 1] << 16) +
1857 (s[offset + 2] << 8) + s[offset+3];
1858 }
79072805
LW		 1859 }
1860
1e422769 1861 sv_setiv(TARG, (IV)retnum);
79072805
LW		 1862 PUSHs(TARG);
1863 RETURN;
1864}
1865
1866PP(pp_index)
1867{
1868 dSP; dTARGET;
1869 SV *big;
1870 SV *little;
1871 I32 offset;
1872 I32 retval;
1873 char *tmps;
1874 char *tmps2;
463ee0b2 1875 STRLEN biglen;
a0d0e21e 1876 I32 arybase = curcop->cop_arybase;
79072805
LW		 1877
1878 if (MAXARG < 3)
1879 offset = 0;
1880 else
1881 offset = POPi - arybase;
1882 little = POPs;
1883 big = POPs;
463ee0b2 1884 tmps = SvPV(big, biglen);
79072805
LW		 1885 if (offset < 0)
1886 offset = 0;
93a17b20
LW		 1887 else if (offset > biglen)
1888 offset = biglen;
79072805 1889 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
93a17b20 1890 (unsigned char*)tmps + biglen, little)))
79072805
LW		 1891 retval = -1 + arybase;
1892 else
1893 retval = tmps2 - tmps + arybase;
1894 PUSHi(retval);
1895 RETURN;
1896}
1897
1898PP(pp_rindex)
1899{
1900 dSP; dTARGET;
1901 SV *big;
1902 SV *little;
463ee0b2
LW		 1903 STRLEN blen;
1904 STRLEN llen;
79072805
LW		 1905 SV *offstr;
1906 I32 offset;
1907 I32 retval;
1908 char *tmps;
1909 char *tmps2;
a0d0e21e 1910 I32 arybase = curcop->cop_arybase;
79072805 1911
a0d0e21e 1912 if (MAXARG >= 3)
79072805
LW		 1913 offstr = POPs;
1914 little = POPs;
1915 big = POPs;
463ee0b2
LW		 1916 tmps2 = SvPV(little, llen);
1917 tmps = SvPV(big, blen);
79072805 1918 if (MAXARG < 3)
463ee0b2 1919 offset = blen;
79072805 1920 else
463ee0b2 1921 offset = SvIV(offstr) - arybase + llen;
79072805
LW		 1922 if (offset < 0)
1923 offset = 0;
463ee0b2
LW		 1924 else if (offset > blen)
1925 offset = blen;
79072805 1926 if (!(tmps2 = rninstr(tmps, tmps + offset,
463ee0b2 1927 tmps2, tmps2 + llen)))
79072805
LW		 1928 retval = -1 + arybase;
1929 else
1930 retval = tmps2 - tmps + arybase;
1931 PUSHi(retval);
1932 RETURN;
1933}
1934
1935PP(pp_sprintf)
1936{
1937 dSP; dMARK; dORIGMARK; dTARGET;
36477c24 1938#ifdef USE_LOCALE_NUMERIC
bbce6d69 1939 if (op->op_private & OPpLOCALE)
36477c24 1940 SET_NUMERIC_LOCAL();
bbce6d69 1941 else
36477c24 1942 SET_NUMERIC_STANDARD();
1943#endif
79072805 1944 do_sprintf(TARG, SP-MARK, MARK+1);
bbce6d69 1945 TAINT_IF(SvTAINTED(TARG));
79072805
LW		 1946 SP = ORIGMARK;
1947 PUSHTARG;
1948 RETURN;
1949}
1950
79072805
LW		 1951PP(pp_ord)
1952{
1953 dSP; dTARGET;
1954 I32 value;
1955 char *tmps;
79072805 1956
79072805 1957#ifndef I286
a0d0e21e 1958 tmps = POPp;
79072805
LW		 1959 value = (I32) (*tmps & 255);
1960#else
a0d0e21e
LW		 1961 I32 anum;
1962 tmps = POPp;
79072805
LW		 1963 anum = (I32) *tmps;
1964 value = (I32) (anum & 255);
1965#endif
1966 XPUSHi(value);
1967 RETURN;
1968}
1969
463ee0b2
LW		 1970PP(pp_chr)
1971{
1972 dSP; dTARGET;
1973 char *tmps;
1974
748a9306
LW		 1975 (void)SvUPGRADE(TARG,SVt_PV);
1976 SvGROW(TARG,2);
463ee0b2
LW		 1977 SvCUR_set(TARG, 1);
1978 tmps = SvPVX(TARG);
748a9306
LW		 1979 *tmps++ = POPi;
1980 *tmps = '\0';
a0d0e21e 1981 (void)SvPOK_only(TARG);
463ee0b2
LW		 1982 XPUSHs(TARG);
1983 RETURN;
1984}
1985
79072805
LW		 1986PP(pp_crypt)
1987{
1988 dSP; dTARGET; dPOPTOPssrl;
1989#ifdef HAS_CRYPT
a0d0e21e 1990 char *tmps = SvPV(left, na);
79072805 1991#ifdef FCRYPT
a0d0e21e 1992 sv_setpv(TARG, fcrypt(tmps, SvPV(right, na)));
79072805 1993#else
a0d0e21e 1994 sv_setpv(TARG, crypt(tmps, SvPV(right, na)));
79072805
LW		 1995#endif
1996#else
1997 DIE(
1998 "The crypt() function is unimplemented due to excessive paranoia.");
1999#endif
2000 SETs(TARG);
2001 RETURN;
2002}
2003
2004PP(pp_ucfirst)
2005{
2006 dSP;
2007 SV *sv = TOPs;
2008 register char *s;
2009
ed6116ce 2010 if (!SvPADTMP(sv)) {
79072805
LW		 2011 dTARGET;
2012 sv_setsv(TARG, sv);
2013 sv = TARG;
2014 SETs(sv);
2015 }
a0d0e21e 2016 s = SvPV_force(sv, na);
bbce6d69 2017 if (*s) {
2018 if (op->op_private & OPpLOCALE) {
2019 TAINT;
2020 SvTAINTED_on(sv);
2021 *s = toUPPER_LC(*s);
2022 }
2023 else
2024 *s = toUPPER(*s);
2025 }
79072805
LW		 2026
2027 RETURN;
2028}
2029
2030PP(pp_lcfirst)
2031{
2032 dSP;
2033 SV *sv = TOPs;
2034 register char *s;
2035
ed6116ce 2036 if (!SvPADTMP(sv)) {
79072805
LW		 2037 dTARGET;
2038 sv_setsv(TARG, sv);
2039 sv = TARG;
2040 SETs(sv);
2041 }
a0d0e21e 2042 s = SvPV_force(sv, na);
bbce6d69 2043 if (*s) {
2044 if (op->op_private & OPpLOCALE) {
2045 TAINT;
2046 SvTAINTED_on(sv);
2047 *s = toLOWER_LC(*s);
2048 }
2049 else
2050 *s = toLOWER(*s);
2051 }
79072805
LW		 2052
2053 SETs(sv);
2054 RETURN;
2055}
2056
2057PP(pp_uc)
2058{
2059 dSP;
2060 SV *sv = TOPs;
2061 register char *s;
463ee0b2 2062 STRLEN len;
79072805 2063
ed6116ce 2064 if (!SvPADTMP(sv)) {
79072805
LW		 2065 dTARGET;
2066 sv_setsv(TARG, sv);
2067 sv = TARG;
2068 SETs(sv);
2069 }
bbce6d69 2070
a0d0e21e 2071 s = SvPV_force(sv, len);
bbce6d69 2072 if (len) {
2073 register char *send = s + len;
2074
2075 if (op->op_private & OPpLOCALE) {
2076 TAINT;
2077 SvTAINTED_on(sv);
2078 for (; s < send; s++)
2079 *s = toUPPER_LC(*s);
2080 }
2081 else {
2082 for (; s < send; s++)
2083 *s = toUPPER(*s);
2084 }
79072805
LW		 2085 }
2086 RETURN;
2087}
2088
2089PP(pp_lc)
2090{
2091 dSP;
2092 SV *sv = TOPs;
2093 register char *s;
463ee0b2 2094 STRLEN len;
79072805 2095
ed6116ce 2096 if (!SvPADTMP(sv)) {
79072805
LW		 2097 dTARGET;
2098 sv_setsv(TARG, sv);
2099 sv = TARG;
2100 SETs(sv);
2101 }
bbce6d69 2102
a0d0e21e 2103 s = SvPV_force(sv, len);
bbce6d69 2104 if (len) {
2105 register char *send = s + len;
2106
2107 if (op->op_private & OPpLOCALE) {
2108 TAINT;
2109 SvTAINTED_on(sv);
2110 for (; s < send; s++)
2111 *s = toLOWER_LC(*s);
2112 }
2113 else {
2114 for (; s < send; s++)
2115 *s = toLOWER(*s);
2116 }
79072805
LW		 2117 }
2118 RETURN;
2119}
2120
a0d0e21e 2121PP(pp_quotemeta)
79072805 2122{
a0d0e21e
LW		 2123 dSP; dTARGET;
2124 SV *sv = TOPs;
2125 STRLEN len;
2126 register char *s = SvPV(sv,len);
2127 register char *d;
79072805 2128
a0d0e21e
LW		 2129 if (len) {
2130 (void)SvUPGRADE(TARG, SVt_PV);
c07a80fd 2131 SvGROW(TARG, (len * 2) + 1);
a0d0e21e
LW		 2132 d = SvPVX(TARG);
2133 while (len--) {
2134 if (!isALNUM(*s))
2135 *d++ = '\\';
2136 *d++ = *s++;
79072805 2137 }
a0d0e21e
LW		 2138 *d = '\0';
2139 SvCUR_set(TARG, d - SvPVX(TARG));
2140 (void)SvPOK_only(TARG);
79072805 2141 }
a0d0e21e
LW		 2142 else
2143 sv_setpvn(TARG, s, len);
2144 SETs(TARG);
79072805
LW		 2145 RETURN;
2146}
2147
a0d0e21e 2148/* Arrays. */
79072805 2149
a0d0e21e 2150PP(pp_aslice)
79072805 2151{
a0d0e21e
LW		 2152 dSP; dMARK; dORIGMARK;
2153 register SV** svp;
2154 register AV* av = (AV*)POPs;
2155 register I32 lval = op->op_flags & OPf_MOD;
748a9306
LW		 2156 I32 arybase = curcop->cop_arybase;
2157 I32 elem;
79072805 2158
a0d0e21e 2159 if (SvTYPE(av) == SVt_PVAV) {
748a9306
LW		 2160 if (lval && op->op_private & OPpLVAL_INTRO) {
2161 I32 max = -1;
2162 for (svp = mark + 1; svp <= sp; svp++) {
2163 elem = SvIVx(*svp);
2164 if (elem > max)
2165 max = elem;
2166 }
2167 if (max > AvMAX(av))
2168 av_extend(av, max);
2169 }
a0d0e21e 2170 while (++MARK <= SP) {
748a9306 2171 elem = SvIVx(*MARK);
a0d0e21e 2172
748a9306
LW		 2173 if (elem > 0)
2174 elem -= arybase;
a0d0e21e
LW		 2175 svp = av_fetch(av, elem, lval);
2176 if (lval) {
2177 if (!svp || *svp == &sv_undef)
2178 DIE(no_aelem, elem);
2179 if (op->op_private & OPpLVAL_INTRO)
2180 save_svref(svp);
79072805 2181 }
a0d0e21e 2182 *MARK = svp ? *svp : &sv_undef;
79072805
LW		 2183 }
2184 }
748a9306 2185 if (GIMME != G_ARRAY) {
a0d0e21e
LW		 2186 MARK = ORIGMARK;
2187 *++MARK = *SP;
2188 SP = MARK;
2189 }
79072805
LW		 2190 RETURN;
2191}
2192
2193/* Associative arrays. */
2194
2195PP(pp_each)
2196{
2197 dSP; dTARGET;
2198 HV *hash = (HV*)POPs;
c07a80fd 2199 HE *entry;
54310121 2200 I32 gimme = GIMME_V;
c750a3ec 2201 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
c07a80fd 2202
2203 PUTBACK;
c750a3ec
MB		 2204 /* might clobber stack_sp */
2205 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
c07a80fd 2206 SPAGAIN;
79072805 2207
79072805
LW		 2208 EXTEND(SP, 2);
2209 if (entry) {
54310121 2210 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
2211 if (gimme == G_ARRAY) {
c07a80fd 2212 PUTBACK;
c750a3ec
MB		 2213 /* might clobber stack_sp */
2214 sv_setsv(TARG, realhv ?
2215 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry));
c07a80fd 2216 SPAGAIN;
8990e307 2217 PUSHs(TARG);
79072805 2218 }
79072805 2219 }
54310121 2220 else if (gimme == G_SCALAR)
79072805
LW		 2221 RETPUSHUNDEF;
2222
2223 RETURN;
2224}
2225
2226PP(pp_values)
2227{
2228 return do_kv(ARGS);
2229}
2230
2231PP(pp_keys)
2232{
2233 return do_kv(ARGS);
2234}
2235
2236PP(pp_delete)
2237{
2238 dSP;
54310121 2239 I32 gimme = GIMME_V;
2240 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
79072805 2241 SV *sv;
5f05dabc 2242 HV *hv;
2243
2244 if (op->op_private & OPpSLICE) {
2245 dMARK; dORIGMARK;
97fcbf96 2246 U32 hvtype;
5f05dabc 2247 hv = (HV*)POPs;
97fcbf96 2248 hvtype = SvTYPE(hv);
5f05dabc 2249 while (++MARK <= SP) {
ae77835f
MB		 2250 if (hvtype == SVt_PVHV)
2251 sv = hv_delete_ent(hv, *MARK, discard, 0);
2252 else if (hvtype == SVt_PVAV)
2253 sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
2254 else
2255 DIE("Not a HASH reference");
5f05dabc 2256 *MARK = sv ? sv : &sv_undef;
2257 }
54310121 2258 if (discard)
2259 SP = ORIGMARK;
2260 else if (gimme == G_SCALAR) {
5f05dabc 2261 MARK = ORIGMARK;
2262 *++MARK = *SP;
2263 SP = MARK;
2264 }
2265 }
2266 else {
2267 SV *keysv = POPs;
2268 hv = (HV*)POPs;
97fcbf96
MB		 2269 if (SvTYPE(hv) == SVt_PVHV)
2270 sv = hv_delete_ent(hv, keysv, discard, 0);
2271 else if (SvTYPE(hv) == SVt_PVAV)
2272 sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
2273 else
5f05dabc 2274 DIE("Not a HASH reference");
5f05dabc 2275 if (!sv)
2276 sv = &sv_undef;
54310121 2277 if (!discard)
2278 PUSHs(sv);
79072805 2279 }
79072805
LW		 2280 RETURN;
2281}
2282
a0d0e21e 2283PP(pp_exists)
79072805 2284{
a0d0e21e
LW		 2285 dSP;
2286 SV *tmpsv = POPs;
2287 HV *hv = (HV*)POPs;
c750a3ec 2288 if (SvTYPE(hv) == SVt_PVHV) {
ae77835f 2289 if (hv_exists_ent(hv, tmpsv, 0))
c750a3ec
MB		 2290 RETPUSHYES;
2291 } else if (SvTYPE(hv) == SVt_PVAV) {
ae77835f 2292 if (avhv_exists_ent((AV*)hv, tmpsv, 0))
c750a3ec
MB		 2293 RETPUSHYES;
2294 } else {
a0d0e21e
LW		 2295 DIE("Not a HASH reference");
2296 }
a0d0e21e
LW		 2297 RETPUSHNO;
2298}
79072805 2299
a0d0e21e
LW		 2300PP(pp_hslice)
2301{
2302 dSP; dMARK; dORIGMARK;
f12c7020 2303 register HE *he;
a0d0e21e
LW		 2304 register HV *hv = (HV*)POPs;
2305 register I32 lval = op->op_flags & OPf_MOD;
c750a3ec 2306 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
79072805 2307
c750a3ec 2308 if (realhv || SvTYPE(hv) == SVt_PVAV) {
a0d0e21e 2309 while (++MARK <= SP) {
f12c7020 2310 SV *keysv = *MARK;
ae77835f
MB		 2311 SV **svp;
2312 if (realhv) {
2313 he = hv_fetch_ent(hv, keysv, lval, 0);
2314 svp = he ? &HeVAL(he) : 0;
2315 } else {
97fcbf96 2316 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
ae77835f 2317 }
a0d0e21e 2318 if (lval) {
f12c7020 2319 if (!he || HeVAL(he) == &sv_undef)
2320 DIE(no_helem, SvPV(keysv, na));
a0d0e21e 2321 if (op->op_private & OPpLVAL_INTRO)
f12c7020 2322 save_svref(&HeVAL(he));
93a17b20 2323 }
f12c7020 2324 *MARK = he ? HeVAL(he) : &sv_undef;
79072805
LW		 2325 }
2326 }
a0d0e21e
LW		 2327 if (GIMME != G_ARRAY) {
2328 MARK = ORIGMARK;
2329 *++MARK = *SP;
2330 SP = MARK;
79072805 2331 }
a0d0e21e
LW		 2332 RETURN;
2333}
2334
2335/* List operators. */
2336
2337PP(pp_list)
2338{
2339 dSP; dMARK;
2340 if (GIMME != G_ARRAY) {
2341 if (++MARK <= SP)
2342 *MARK = *SP; /* unwanted list, return last item */
8990e307 2343 else
a0d0e21e
LW		 2344 *MARK = &sv_undef;
2345 SP = MARK;
79072805 2346 }
a0d0e21e 2347 RETURN;
79072805
LW		 2348}
2349
a0d0e21e 2350PP(pp_lslice)
79072805
LW		 2351{
2352 dSP;
a0d0e21e
LW		 2353 SV **lastrelem = stack_sp;
2354 SV **lastlelem = stack_base + POPMARK;
2355 SV **firstlelem = stack_base + POPMARK + 1;
2356 register SV **firstrelem = lastlelem + 1;
2357 I32 arybase = curcop->cop_arybase;
4633a7c4
LW		 2358 I32 lval = op->op_flags & OPf_MOD;
2359 I32 is_something_there = lval;
79072805 2360
a0d0e21e
LW		 2361 register I32 max = lastrelem - lastlelem;
2362 register SV **lelem;
2363 register I32 ix;
2364
2365 if (GIMME != G_ARRAY) {
748a9306
LW		 2366 ix = SvIVx(*lastlelem);
2367 if (ix < 0)
2368 ix += max;
2369 else
2370 ix -= arybase;
a0d0e21e
LW		 2371 if (ix < 0 || ix >= max)
2372 *firstlelem = &sv_undef;
2373 else
2374 *firstlelem = firstrelem[ix];
2375 SP = firstlelem;
2376 RETURN;
2377 }
2378
2379 if (max == 0) {
2380 SP = firstlelem - 1;
2381 RETURN;
2382 }
2383
2384 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
748a9306 2385 ix = SvIVx(*lelem);
a0d0e21e
LW		 2386 if (ix < 0) {
2387 ix += max;
2388 if (ix < 0)
2389 *lelem = &sv_undef;
2390 else if (!(*lelem = firstrelem[ix]))
2391 *lelem = &sv_undef;
79072805 2392 }
748a9306
LW		 2393 else {
2394 ix -= arybase;
2395 if (ix >= max || !(*lelem = firstrelem[ix]))
2396 *lelem = &sv_undef;
2397 }
ff0cee69 2398 if (!is_something_there && (SvOK(*lelem) || SvGMAGICAL(*lelem)))
4633a7c4 2399 is_something_there = TRUE;
79072805 2400 }
4633a7c4
LW		 2401 if (is_something_there)
2402 SP = lastlelem;
2403 else
2404 SP = firstlelem - 1;
79072805
LW		 2405 RETURN;
2406}
2407
a0d0e21e
LW		 2408PP(pp_anonlist)
2409{
44a8e56a 2410 dSP; dMARK; dORIGMARK;
a0d0e21e 2411 I32 items = SP - MARK;
44a8e56a 2412 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
2413 SP = ORIGMARK; /* av_make() might realloc stack_sp */
2414 XPUSHs(av);
a0d0e21e
LW		 2415 RETURN;
2416}
2417
2418PP(pp_anonhash)
79072805
LW		 2419{
2420 dSP; dMARK; dORIGMARK;
a0d0e21e
LW		 2421 HV* hv = (HV*)sv_2mortal((SV*)newHV());
2422
2423 while (MARK < SP) {
2424 SV* key = *++MARK;
a0d0e21e
LW		 2425 SV *val = NEWSV(46, 0);
2426 if (MARK < SP)
2427 sv_setsv(val, *++MARK);
fb73857a 2428 else if (dowarn)
a0d0e21e 2429 warn("Odd number of elements in hash list");
f12c7020 2430 (void)hv_store_ent(hv,key,val,0);
79072805 2431 }
a0d0e21e
LW		 2432 SP = ORIGMARK;
2433 XPUSHs((SV*)hv);
79072805
LW		 2434 RETURN;
2435}
2436
a0d0e21e 2437PP(pp_splice)
79072805 2438{
a0d0e21e
LW		 2439 dSP; dMARK; dORIGMARK;
2440 register AV *ary = (AV*)*++MARK;
2441 register SV **src;
2442 register SV **dst;
2443 register I32 i;
2444 register I32 offset;
2445 register I32 length;
2446 I32 newlen;
2447 I32 after;
2448 I32 diff;
2449 SV **tmparyval = 0;
79072805 2450
a0d0e21e 2451 SP++;
79072805 2452
a0d0e21e 2453 if (++MARK < SP) {
84902520 2454 offset = i = SvIVx(*MARK);
a0d0e21e
LW		 2455 if (offset < 0)
2456 offset += AvFILL(ary) + 1;
2457 else
2458 offset -= curcop->cop_arybase;
84902520
TB		 2459 if (offset < 0)
2460 DIE(no_aelem, i);
a0d0e21e
LW		 2461 if (++MARK < SP) {
2462 length = SvIVx(*MARK++);
2463 if (length < 0)
2464 length = 0;
79072805
LW		 2465 }
2466 else
a0d0e21e 2467 length = AvMAX(ary) + 1; /* close enough to infinity */
79072805 2468 }
a0d0e21e
LW		 2469 else {
2470 offset = 0;
2471 length = AvMAX(ary) + 1;
2472 }
a0d0e21e
LW		 2473 if (offset > AvFILL(ary) + 1)
2474 offset = AvFILL(ary) + 1;
2475 after = AvFILL(ary) + 1 - (offset + length);
2476 if (after < 0) { /* not that much array */
2477 length += after; /* offset+length now in array */
2478 after = 0;
2479 if (!AvALLOC(ary))
2480 av_extend(ary, 0);
2481 }
2482
2483 /* At this point, MARK .. SP-1 is our new LIST */
2484
2485 newlen = SP - MARK;
2486 diff = newlen - length;
fb73857a 2487 if (newlen && !AvREAL(ary)) {
2488 if (AvREIFY(ary))
2489 av_reify(ary);
2490 else
2491 assert(AvREAL(ary)); /* would leak, so croak */
2492 }
a0d0e21e
LW		 2493
2494 if (diff < 0) { /* shrinking the area */
2495 if (newlen) {
2496 New(451, tmparyval, newlen, SV*); /* so remember insertion */
2497 Copy(MARK, tmparyval, newlen, SV*);
79072805 2498 }
a0d0e21e
LW		 2499
2500 MARK = ORIGMARK + 1;
2501 if (GIMME == G_ARRAY) { /* copy return vals to stack */
2502 MEXTEND(MARK, length);
2503 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
2504 if (AvREAL(ary)) {
bbce6d69 2505 EXTEND_MORTAL(length);
36477c24 2506 for (i = length, dst = MARK; i; i--) {
2507 if (!SvIMMORTAL(*dst))
2508 sv_2mortal(*dst); /* free them eventualy */
2509 dst++;
2510 }
a0d0e21e
LW		 2511 }
2512 MARK += length - 1;
79072805 2513 }
a0d0e21e
LW		 2514 else {
2515 *MARK = AvARRAY(ary)[offset+length-1];
2516 if (AvREAL(ary)) {
36477c24 2517 if (!SvIMMORTAL(*MARK))
2518 sv_2mortal(*MARK);
a0d0e21e
LW		 2519 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
2520 SvREFCNT_dec(*dst++); /* free them now */
79072805 2521 }
a0d0e21e
LW		 2522 }
2523 AvFILL(ary) += diff;
2524
2525 /* pull up or down? */
2526
2527 if (offset < after) { /* easier to pull up */
2528 if (offset) { /* esp. if nothing to pull */
2529 src = &AvARRAY(ary)[offset-1];
2530 dst = src - diff; /* diff is negative */
2531 for (i = offset; i > 0; i--) /* can't trust Copy */
2532 *dst-- = *src--;
79072805 2533 }
a0d0e21e
LW		 2534 dst = AvARRAY(ary);
2535 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
2536 AvMAX(ary) += diff;
2537 }
2538 else {
2539 if (after) { /* anything to pull down? */
2540 src = AvARRAY(ary) + offset + length;
2541 dst = src + diff; /* diff is negative */
2542 Move(src, dst, after, SV*);
79072805 2543 }
a0d0e21e
LW		 2544 dst = &AvARRAY(ary)[AvFILL(ary)+1];
2545 /* avoid later double free */
2546 }
2547 i = -diff;
2548 while (i)
2549 dst[--i] = &sv_undef;
2550
2551 if (newlen) {
2552 for (src = tmparyval, dst = AvARRAY(ary) + offset;
2553 newlen; newlen--) {
2554 *dst = NEWSV(46, 0);
2555 sv_setsv(*dst++, *src++);
79072805 2556 }
a0d0e21e
LW		 2557 Safefree(tmparyval);
2558 }
2559 }
2560 else { /* no, expanding (or same) */
2561 if (length) {
2562 New(452, tmparyval, length, SV*); /* so remember deletion */
2563 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
2564 }
2565
2566 if (diff > 0) { /* expanding */
2567
2568 /* push up or down? */
2569
2570 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
2571 if (offset) {
2572 src = AvARRAY(ary);
2573 dst = src - diff;
2574 Move(src, dst, offset, SV*);
79072805 2575 }
a0d0e21e
LW		 2576 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
2577 AvMAX(ary) += diff;
2578 AvFILL(ary) += diff;
79072805
LW		 2579 }
2580 else {
a0d0e21e
LW		 2581 if (AvFILL(ary) + diff >= AvMAX(ary)) /* oh, well */
2582 av_extend(ary, AvFILL(ary) + diff);
2583 AvFILL(ary) += diff;
2584
2585 if (after) {
2586 dst = AvARRAY(ary) + AvFILL(ary);
2587 src = dst - diff;
2588 for (i = after; i; i--) {
2589 *dst-- = *src--;
2590 }
79072805
LW		 2591 }
2592 }
a0d0e21e
LW		 2593 }
2594
2595 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
2596 *dst = NEWSV(46, 0);
2597 sv_setsv(*dst++, *src++);
2598 }
2599 MARK = ORIGMARK + 1;
2600 if (GIMME == G_ARRAY) { /* copy return vals to stack */
2601 if (length) {
2602 Copy(tmparyval, MARK, length, SV*);
2603 if (AvREAL(ary)) {
bbce6d69 2604 EXTEND_MORTAL(length);
36477c24 2605 for (i = length, dst = MARK; i; i--) {
2606 if (!SvIMMORTAL(*dst))
2607 sv_2mortal(*dst); /* free them eventualy */
2608 dst++;
2609 }
79072805 2610 }
a0d0e21e 2611 Safefree(tmparyval);
79072805 2612 }
a0d0e21e
LW		 2613 MARK += length - 1;
2614 }
2615 else if (length--) {
2616 *MARK = tmparyval[length];
2617 if (AvREAL(ary)) {
36477c24 2618 if (!SvIMMORTAL(*MARK))
2619 sv_2mortal(*MARK);
a0d0e21e
LW		 2620 while (length-- > 0)
2621 SvREFCNT_dec(tmparyval[length]);
79072805 2622 }
a0d0e21e 2623 Safefree(tmparyval);
79072805 2624 }
a0d0e21e
LW		 2625 else
2626 *MARK = &sv_undef;
79072805 2627 }
a0d0e21e 2628 SP = MARK;
79072805
LW		 2629 RETURN;
2630}
2631
a0d0e21e 2632PP(pp_push)
79072805
LW		 2633{
2634 dSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW		 2635 register AV *ary = (AV*)*++MARK;
2636 register SV *sv = &sv_undef;
79072805 2637
a0d0e21e
LW		 2638 for (++MARK; MARK <= SP; MARK++) {
2639 sv = NEWSV(51, 0);
2640 if (*MARK)
2641 sv_setsv(sv, *MARK);
2642 av_push(ary, sv);
79072805
LW		 2643 }
2644 SP = ORIGMARK;
a0d0e21e 2645 PUSHi( AvFILL(ary) + 1 );
79072805
LW		 2646 RETURN;
2647}
2648
a0d0e21e 2649PP(pp_pop)
79072805
LW		 2650{
2651 dSP;
a0d0e21e
LW		 2652 AV *av = (AV*)POPs;
2653 SV *sv = av_pop(av);
36477c24 2654 if (!SvIMMORTAL(sv) && AvREAL(av))
a0d0e21e
LW		 2655 (void)sv_2mortal(sv);
2656 PUSHs(sv);
79072805 2657 RETURN;
79072805
LW		 2658}
2659
a0d0e21e 2660PP(pp_shift)
79072805
LW		 2661{
2662 dSP;
a0d0e21e
LW		 2663 AV *av = (AV*)POPs;
2664 SV *sv = av_shift(av);
79072805 2665 EXTEND(SP, 1);
a0d0e21e 2666 if (!sv)
79072805 2667 RETPUSHUNDEF;
36477c24 2668 if (!SvIMMORTAL(sv) && AvREAL(av))
a0d0e21e
LW		 2669 (void)sv_2mortal(sv);
2670 PUSHs(sv);
79072805 2671 RETURN;
79072805
LW		 2672}
2673
a0d0e21e 2674PP(pp_unshift)
79072805 2675{
a0d0e21e
LW		 2676 dSP; dMARK; dORIGMARK; dTARGET;
2677 register AV *ary = (AV*)*++MARK;
2678 register SV *sv;
2679 register I32 i = 0;
79072805 2680
a0d0e21e
LW		 2681 av_unshift(ary, SP - MARK);
2682 while (MARK < SP) {
2683 sv = NEWSV(27, 0);
2684 sv_setsv(sv, *++MARK);
2685 (void)av_store(ary, i++, sv);
79072805 2686 }
79072805 2687
a0d0e21e
LW		 2688 SP = ORIGMARK;
2689 PUSHi( AvFILL(ary) + 1 );
79072805 2690 RETURN;
79072805
LW		 2691}
2692
a0d0e21e 2693PP(pp_reverse)
79072805 2694{
a0d0e21e
LW		 2695 dSP; dMARK;
2696 register SV *tmp;
2697 SV **oldsp = SP;
79072805 2698
a0d0e21e
LW		 2699 if (GIMME == G_ARRAY) {
2700 MARK++;
2701 while (MARK < SP) {
2702 tmp = *MARK;
2703 *MARK++ = *SP;
2704 *SP-- = tmp;
2705 }
2706 SP = oldsp;
79072805
LW		 2707 }
2708 else {
a0d0e21e
LW		 2709 register char *up;
2710 register char *down;
2711 register I32 tmp;
2712 dTARGET;
2713 STRLEN len;
79072805 2714
a0d0e21e
LW		 2715 if (SP - MARK > 1)
2716 do_join(TARG, &sv_no, MARK, SP);
2717 else
54310121 2718 sv_setsv(TARG, (SP > MARK) ? *SP : GvSV(defgv));
a0d0e21e
LW		 2719 up = SvPV_force(TARG, len);
2720 if (len > 1) {
2721 down = SvPVX(TARG) + len - 1;
2722 while (down > up) {
2723 tmp = *up;
2724 *up++ = *down;
2725 *down-- = tmp;
2726 }
2727 (void)SvPOK_only(TARG);
79072805 2728 }
a0d0e21e
LW		 2729 SP = MARK + 1;
2730 SETTARG;
79072805 2731 }
a0d0e21e 2732 RETURN;
79072805
LW		 2733}
2734
55497cff 2735static SV *
8ac85365 2736mul128(SV *sv, U8 m)
55497cff 2737{
2738 STRLEN len;
2739 char *s = SvPV(sv, len);
2740 char *t;
2741 U32 i = 0;
2742
2743 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
8ac85365 2744 SV *New = newSVpv("0000000000", 10);
55497cff 2745
8ac85365 2746 sv_catsv(New, sv);
55497cff 2747 SvREFCNT_dec(sv); /* free old sv */
8ac85365 2748 sv = New;
55497cff 2749 s = SvPV(sv, len);
2750 }
2751 t = s + len - 1;
2752 while (!*t) /* trailing '\0'? */
2753 t--;
2754 while (t > s) {
2755 i = ((*t - '0') << 7) + m;
2756 *(t--) = '0' + (i % 10);
2757 m = i / 10;
2758 }
2759 return (sv);
2760}
2761
a0d0e21e
LW		 2762/* Explosives and implosives. */
2763
2764PP(pp_unpack)
79072805
LW		 2765{
2766 dSP;
a0d0e21e 2767 dPOPPOPssrl;
36477c24 2768 SV **oldsp = sp;
54310121 2769 I32 gimme = GIMME_V;
ed6116ce 2770 SV *sv;
a0d0e21e
LW		 2771 STRLEN llen;
2772 STRLEN rlen;
2773 register char *pat = SvPV(left, llen);
2774 register char *s = SvPV(right, rlen);
2775 char *strend = s + rlen;
2776 char *strbeg = s;
2777 register char *patend = pat + llen;
2778 I32 datumtype;
2779 register I32 len;
2780 register I32 bits;
79072805 2781
a0d0e21e
LW		 2782 /* These must not be in registers: */
2783 I16 ashort;
2784 int aint;
2785 I32 along;
ecfc5424
AD		 2786#ifdef HAS_QUAD
2787 Quad_t aquad;
a0d0e21e
LW		 2788#endif
2789 U16 aushort;
2790 unsigned int auint;
2791 U32 aulong;
ecfc5424
AD		 2792#ifdef HAS_QUAD
2793 unsigned Quad_t auquad;
a0d0e21e
LW		 2794#endif
2795 char *aptr;
2796 float afloat;
2797 double adouble;
2798 I32 checksum = 0;
2799 register U32 culong;
2800 double cdouble;
2801 static char* bitcount = 0;
fb73857a 2802 int commas = 0;
79072805 2803
54310121 2804 if (gimme != G_ARRAY) { /* arrange to do first one only */
a0d0e21e
LW		 2805 /*SUPPRESS 530*/
2806 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
748a9306 2807 if (strchr("aAbBhHP", *patend) || *pat == '%') {
a0d0e21e
LW		 2808 patend++;
2809 while (isDIGIT(*patend) || *patend == '*')
2810 patend++;
2811 }
2812 else
2813 patend++;
79072805 2814 }
a0d0e21e
LW		 2815 while (pat < patend) {
2816 reparse:
bbdab043
CS		 2817 datumtype = *pat++ & 0xFF;
2818 if (isSPACE(datumtype))
2819 continue;
a0d0e21e
LW		 2820 if (pat >= patend)
2821 len = 1;
2822 else if (*pat == '*') {
2823 len = strend - strbeg; /* long enough */
2824 pat++;
2825 }
2826 else if (isDIGIT(*pat)) {
2827 len = *pat++ - '0';
2828 while (isDIGIT(*pat))
2829 len = (len * 10) + (*pat++ - '0');
2830 }
2831 else
2832 len = (datumtype != '@');
2833 switch(datumtype) {
2834 default:
bbdab043 2835 croak("Invalid type in unpack: '%c'", (int)datumtype);
fb73857a 2836 case ',': /* grandfather in commas but with a warning */
2837 if (commas++ == 0 && dowarn)
2838 warn("Invalid type in unpack: '%c'", (int)datumtype);
2839 break;
a0d0e21e
LW		 2840 case '%':
2841 if (len == 1 && pat[-1] != '1')
2842 len = 16;
2843 checksum = len;
2844 culong = 0;
2845 cdouble = 0;
2846 if (pat < patend)
2847 goto reparse;
2848 break;
2849 case '@':
2850 if (len > strend - strbeg)
2851 DIE("@ outside of string");
2852 s = strbeg + len;
2853 break;
2854 case 'X':
2855 if (len > s - strbeg)
2856 DIE("X outside of string");
2857 s -= len;
2858 break;
2859 case 'x':
2860 if (len > strend - s)
2861 DIE("x outside of string");
2862 s += len;
2863 break;
2864 case 'A':
2865 case 'a':
2866 if (len > strend - s)
2867 len = strend - s;
2868 if (checksum)
2869 goto uchar_checksum;
2870 sv = NEWSV(35, len);
2871 sv_setpvn(sv, s, len);
2872 s += len;
2873 if (datumtype == 'A') {
2874 aptr = s; /* borrow register */
2875 s = SvPVX(sv) + len - 1;
2876 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
2877 s--;
2878 *++s = '\0';
2879 SvCUR_set(sv, s - SvPVX(sv));
2880 s = aptr; /* unborrow register */
2881 }
2882 XPUSHs(sv_2mortal(sv));
2883 break;
2884 case 'B':
2885 case 'b':
2886 if (pat[-1] == '*' || len > (strend - s) * 8)
2887 len = (strend - s) * 8;
2888 if (checksum) {
2889 if (!bitcount) {
2890 Newz(601, bitcount, 256, char);
2891 for (bits = 1; bits < 256; bits++) {
2892 if (bits & 1) bitcount[bits]++;
2893 if (bits & 2) bitcount[bits]++;
2894 if (bits & 4) bitcount[bits]++;
2895 if (bits & 8) bitcount[bits]++;
2896 if (bits & 16) bitcount[bits]++;
2897 if (bits & 32) bitcount[bits]++;
2898 if (bits & 64) bitcount[bits]++;
2899 if (bits & 128) bitcount[bits]++;
2900 }
2901 }
2902 while (len >= 8) {
2903 culong += bitcount[*(unsigned char*)s++];
2904 len -= 8;
2905 }
2906 if (len) {
2907 bits = *s;
2908 if (datumtype == 'b') {
2909 while (len-- > 0) {
2910 if (bits & 1) culong++;
2911 bits >>= 1;
2912 }
2913 }
2914 else {
2915 while (len-- > 0) {
2916 if (bits & 128) culong++;
2917 bits <<= 1;
2918 }
2919 }
2920 }
79072805
LW		 2921 break;
2922 }
a0d0e21e
LW		 2923 sv = NEWSV(35, len + 1);
2924 SvCUR_set(sv, len);
2925 SvPOK_on(sv);
2926 aptr = pat; /* borrow register */
2927 pat = SvPVX(sv);
2928 if (datumtype == 'b') {
2929 aint = len;
2930 for (len = 0; len < aint; len++) {
2931 if (len & 7) /*SUPPRESS 595*/
2932 bits >>= 1;
2933 else
2934 bits = *s++;
2935 *pat++ = '0' + (bits & 1);
2936 }
2937 }
2938 else {
2939 aint = len;
2940 for (len = 0; len < aint; len++) {
2941 if (len & 7)
2942 bits <<= 1;
2943 else
2944 bits = *s++;
2945 *pat++ = '0' + ((bits & 128) != 0);
2946 }
2947 }
2948 *pat = '\0';
2949 pat = aptr; /* unborrow register */
2950 XPUSHs(sv_2mortal(sv));
2951 break;
2952 case 'H':
2953 case 'h':
2954 if (pat[-1] == '*' || len > (strend - s) * 2)
2955 len = (strend - s) * 2;
2956 sv = NEWSV(35, len + 1);
2957 SvCUR_set(sv, len);
2958 SvPOK_on(sv);
2959 aptr = pat; /* borrow register */
2960 pat = SvPVX(sv);
2961 if (datumtype == 'h') {
2962 aint = len;
2963 for (len = 0; len < aint; len++) {
2964 if (len & 1)
2965 bits >>= 4;
2966 else
2967 bits = *s++;
2968 *pat++ = hexdigit[bits & 15];
2969 }
2970 }
2971 else {
2972 aint = len;
2973 for (len = 0; len < aint; len++) {
2974 if (len & 1)
2975 bits <<= 4;
2976 else
2977 bits = *s++;
2978 *pat++ = hexdigit[(bits >> 4) & 15];
2979 }
2980 }
2981 *pat = '\0';
2982 pat = aptr; /* unborrow register */
2983 XPUSHs(sv_2mortal(sv));
2984 break;
2985 case 'c':
2986 if (len > strend - s)
2987 len = strend - s;
2988 if (checksum) {
2989 while (len-- > 0) {
2990 aint = *s++;
2991 if (aint >= 128) /* fake up signed chars */
2992 aint -= 256;
2993 culong += aint;
2994 }
2995 }
2996 else {
2997 EXTEND(SP, len);
bbce6d69 2998 EXTEND_MORTAL(len);
a0d0e21e
LW		 2999 while (len-- > 0) {
3000 aint = *s++;
3001 if (aint >= 128) /* fake up signed chars */
3002 aint -= 256;
3003 sv = NEWSV(36, 0);
1e422769 3004 sv_setiv(sv, (IV)aint);
a0d0e21e
LW		 3005 PUSHs(sv_2mortal(sv));
3006 }
3007 }
3008 break;
3009 case 'C':
3010 if (len > strend - s)
3011 len = strend - s;
3012 if (checksum) {
3013 uchar_checksum:
3014 while (len-- > 0) {
3015 auint = *s++ & 255;
3016 culong += auint;
3017 }
3018 }
3019 else {
3020 EXTEND(SP, len);
bbce6d69 3021 EXTEND_MORTAL(len);
a0d0e21e
LW		 3022 while (len-- > 0) {
3023 auint = *s++ & 255;
3024 sv = NEWSV(37, 0);
1e422769 3025 sv_setiv(sv, (IV)auint);
a0d0e21e
LW		 3026 PUSHs(sv_2mortal(sv));
3027 }
3028 }
3029 break;
3030 case 's':
96e4d5b1 3031 along = (strend - s) / SIZE16;
a0d0e21e
LW		 3032 if (len > along)
3033 len = along;
3034 if (checksum) {
3035 while (len-- > 0) {
96e4d5b1 3036 COPY16(s, &ashort);
3037 s += SIZE16;
a0d0e21e
LW		 3038 culong += ashort;
3039 }
3040 }
3041 else {
3042 EXTEND(SP, len);
bbce6d69 3043 EXTEND_MORTAL(len);
a0d0e21e 3044 while (len-- > 0) {
96e4d5b1 3045 COPY16(s, &ashort);
3046 s += SIZE16;
a0d0e21e 3047 sv = NEWSV(38, 0);
1e422769 3048 sv_setiv(sv, (IV)ashort);
a0d0e21e
LW		 3049 PUSHs(sv_2mortal(sv));
3050 }
3051 }
3052 break;
3053 case 'v':
3054 case 'n':
3055 case 'S':
96e4d5b1 3056 along = (strend - s) / SIZE16;
a0d0e21e
LW		 3057 if (len > along)
3058 len = along;
3059 if (checksum) {
3060 while (len-- > 0) {
96e4d5b1 3061 COPY16(s, &aushort);
3062 s += SIZE16;
a0d0e21e
LW		 3063#ifdef HAS_NTOHS
3064 if (datumtype == 'n')
3065 aushort = ntohs(aushort);
79072805 3066#endif
a0d0e21e
LW		 3067#ifdef HAS_VTOHS
3068 if (datumtype == 'v')
3069 aushort = vtohs(aushort);
79072805 3070#endif
a0d0e21e
LW		 3071 culong += aushort;
3072 }
3073 }
3074 else {
3075 EXTEND(SP, len);
bbce6d69 3076 EXTEND_MORTAL(len);
a0d0e21e 3077 while (len-- > 0) {
96e4d5b1 3078 COPY16(s, &aushort);
3079 s += SIZE16;
a0d0e21e
LW		 3080 sv = NEWSV(39, 0);
3081#ifdef HAS_NTOHS
3082 if (datumtype == 'n')
3083 aushort = ntohs(aushort);
79072805 3084#endif
a0d0e21e
LW		 3085#ifdef HAS_VTOHS
3086 if (datumtype == 'v')
3087 aushort = vtohs(aushort);
79072805 3088#endif
1e422769 3089 sv_setiv(sv, (IV)aushort);
a0d0e21e
LW		 3090 PUSHs(sv_2mortal(sv));
3091 }
3092 }
3093 break;
3094 case 'i':
3095 along = (strend - s) / sizeof(int);
3096 if (len > along)
3097 len = along;
3098 if (checksum) {
3099 while (len-- > 0) {
3100 Copy(s, &aint, 1, int);
3101 s += sizeof(int);
3102 if (checksum > 32)
3103 cdouble += (double)aint;
3104 else
3105 culong += aint;
3106 }
3107 }
3108 else {
3109 EXTEND(SP, len);
bbce6d69 3110 EXTEND_MORTAL(len);
a0d0e21e
LW		 3111 while (len-- > 0) {
3112 Copy(s, &aint, 1, int);
3113 s += sizeof(int);
3114 sv = NEWSV(40, 0);
1e422769 3115 sv_setiv(sv, (IV)aint);
a0d0e21e
LW		 3116 PUSHs(sv_2mortal(sv));
3117 }
3118 }
3119 break;
3120 case 'I':
3121 along = (strend - s) / sizeof(unsigned int);
3122 if (len > along)
3123 len = along;
3124 if (checksum) {
3125 while (len-- > 0) {
3126 Copy(s, &auint, 1, unsigned int);
3127 s += sizeof(unsigned int);
3128 if (checksum > 32)
3129 cdouble += (double)auint;
3130 else
3131 culong += auint;
3132 }
3133 }
3134 else {
3135 EXTEND(SP, len);
bbce6d69 3136 EXTEND_MORTAL(len);
a0d0e21e
LW		 3137 while (len-- > 0) {
3138 Copy(s, &auint, 1, unsigned int);
3139 s += sizeof(unsigned int);
3140 sv = NEWSV(41, 0);
1e422769 3141 sv_setuv(sv, (UV)auint);
a0d0e21e
LW		 3142 PUSHs(sv_2mortal(sv));
3143 }
3144 }
3145 break;
3146 case 'l':
96e4d5b1 3147 along = (strend - s) / SIZE32;
a0d0e21e
LW		 3148 if (len > along)
3149 len = along;
3150 if (checksum) {
3151 while (len-- > 0) {
96e4d5b1 3152 COPY32(s, &along);
3153 s += SIZE32;
a0d0e21e
LW		 3154 if (checksum > 32)
3155 cdouble += (double)along;
3156 else
3157 culong += along;
3158 }
3159 }
3160 else {
3161 EXTEND(SP, len);
bbce6d69 3162 EXTEND_MORTAL(len);
a0d0e21e 3163 while (len-- > 0) {
96e4d5b1 3164 COPY32(s, &along);
3165 s += SIZE32;
a0d0e21e 3166 sv = NEWSV(42, 0);
1e422769 3167 sv_setiv(sv, (IV)along);
a0d0e21e
LW		 3168 PUSHs(sv_2mortal(sv));
3169 }
79072805 3170 }
a0d0e21e
LW		 3171 break;
3172 case 'V':
3173 case 'N':
3174 case 'L':
96e4d5b1 3175 along = (strend - s) / SIZE32;
a0d0e21e
LW		 3176 if (len > along)
3177 len = along;
3178 if (checksum) {
3179 while (len-- > 0) {
96e4d5b1 3180 COPY32(s, &aulong);
3181 s += SIZE32;
a0d0e21e
LW		 3182#ifdef HAS_NTOHL
3183 if (datumtype == 'N')
3184 aulong = ntohl(aulong);
79072805 3185#endif
a0d0e21e
LW		 3186#ifdef HAS_VTOHL
3187 if (datumtype == 'V')
3188 aulong = vtohl(aulong);
79072805 3189#endif
a0d0e21e
LW		 3190 if (checksum > 32)
3191 cdouble += (double)aulong;
3192 else
3193 culong += aulong;
3194 }
3195 }
3196 else {
3197 EXTEND(SP, len);
bbce6d69 3198 EXTEND_MORTAL(len);
a0d0e21e 3199 while (len-- > 0) {
96e4d5b1 3200 COPY32(s, &aulong);
3201 s += SIZE32;
a0d0e21e
LW		 3202#ifdef HAS_NTOHL
3203 if (datumtype == 'N')
3204 aulong = ntohl(aulong);
79072805 3205#endif
a0d0e21e
LW		 3206#ifdef HAS_VTOHL
3207 if (datumtype == 'V')
3208 aulong = vtohl(aulong);
79072805 3209#endif
1e422769 3210 sv = NEWSV(43, 0);
3211 sv_setuv(sv, (UV)aulong);
a0d0e21e
LW		 3212 PUSHs(sv_2mortal(sv));
3213 }
3214 }
3215 break;
3216 case 'p':
3217 along = (strend - s) / sizeof(char*);
3218 if (len > along)
3219 len = along;
3220 EXTEND(SP, len);
bbce6d69 3221 EXTEND_MORTAL(len);
a0d0e21e
LW		 3222 while (len-- > 0) {
3223 if (sizeof(char*) > strend - s)
3224 break;
3225 else {
3226 Copy(s, &aptr, 1, char*);
3227 s += sizeof(char*);
3228 }
3229 sv = NEWSV(44, 0);
3230 if (aptr)
3231 sv_setpv(sv, aptr);
3232 PUSHs(sv_2mortal(sv));
3233 }
3234 break;
def98dd4 3235 case 'w':
def98dd4 3236 EXTEND(SP, len);
bbce6d69 3237 EXTEND_MORTAL(len);
3238 {
3239 UV auv = 0;
3240 U32 bytes = 0;
3241
3242 while ((len > 0) && (s < strend)) {
3243 auv = (auv << 7) | (*s & 0x7f);
3244 if (!(*s++ & 0x80)) {
3245 bytes = 0;
3246 sv = NEWSV(40, 0);
3247 sv_setuv(sv, auv);
3248 PUSHs(sv_2mortal(sv));
3249 len--;
3250 auv = 0;
3251 }
3252 else if (++bytes >= sizeof(UV)) { /* promote to string */
bbce6d69 3253 char *t;
3254
fc36a67e 3255 sv = newSVpvf("%.*Vu", (int)TYPE_DIGITS(UV), auv);
bbce6d69 3256 while (s < strend) {
3257 sv = mul128(sv, *s & 0x7f);
3258 if (!(*s++ & 0x80)) {
3259 bytes = 0;
3260 break;
3261 }
3262 }
3263 t = SvPV(sv, na);
3264 while (*t == '0')
3265 t++;
3266 sv_chop(sv, t);
3267 PUSHs(sv_2mortal(sv));
3268 len--;
3269 auv = 0;
3270 }
3271 }
3272 if ((s >= strend) && bytes)
3273 croak("Unterminated compressed integer");
3274 }
def98dd4 3275 break;
a0d0e21e
LW		 3276 case 'P':
3277 EXTEND(SP, 1);
3278 if (sizeof(char*) > strend - s)
3279 break;
3280 else {
3281 Copy(s, &aptr, 1, char*);
3282 s += sizeof(char*);
3283 }
3284 sv = NEWSV(44, 0);
3285 if (aptr)
3286 sv_setpvn(sv, aptr, len);
3287 PUSHs(sv_2mortal(sv));
3288 break;
ecfc5424 3289#ifdef HAS_QUAD
a0d0e21e
LW		 3290 case 'q':
3291 EXTEND(SP, len);
bbce6d69 3292 EXTEND_MORTAL(len);
a0d0e21e 3293 while (len-- > 0) {
ecfc5424 3294 if (s + sizeof(Quad_t) > strend)
a0d0e21e
LW		 3295 aquad = 0;
3296 else {
ecfc5424
AD		 3297 Copy(s, &aquad, 1, Quad_t);
3298 s += sizeof(Quad_t);
a0d0e21e
LW		 3299 }
3300 sv = NEWSV(42, 0);
96e4d5b1 3301 if (aquad >= IV_MIN && aquad <= IV_MAX)
3302 sv_setiv(sv, (IV)aquad);
3303 else
3304 sv_setnv(sv, (double)aquad);
a0d0e21e
LW		 3305 PUSHs(sv_2mortal(sv));
3306 }
3307 break;
3308 case 'Q':
3309 EXTEND(SP, len);
bbce6d69 3310 EXTEND_MORTAL(len);
a0d0e21e 3311 while (len-- > 0) {
ecfc5424 3312 if (s + sizeof(unsigned Quad_t) > strend)
a0d0e21e
LW		 3313 auquad = 0;
3314 else {
ecfc5424
AD		 3315 Copy(s, &auquad, 1, unsigned Quad_t);
3316 s += sizeof(unsigned Quad_t);
a0d0e21e
LW		 3317 }
3318 sv = NEWSV(43, 0);
96e4d5b1 3319 if (aquad <= UV_MAX)
3320 sv_setuv(sv, (UV)auquad);
3321 else
3322 sv_setnv(sv, (double)auquad);
a0d0e21e
LW		 3323 PUSHs(sv_2mortal(sv));
3324 }
3325 break;
79072805 3326#endif
a0d0e21e
LW		 3327 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
3328 case 'f':
3329 case 'F':
3330 along = (strend - s) / sizeof(float);
3331 if (len > along)
3332 len = along;
3333 if (checksum) {
3334 while (len-- > 0) {
3335 Copy(s, &afloat, 1, float);
3336 s += sizeof(float);
3337 cdouble += afloat;
3338 }
3339 }
3340 else {
3341 EXTEND(SP, len);
bbce6d69 3342 EXTEND_MORTAL(len);
a0d0e21e
LW		 3343 while (len-- > 0) {
3344 Copy(s, &afloat, 1, float);
3345 s += sizeof(float);
3346 sv = NEWSV(47, 0);
3347 sv_setnv(sv, (double)afloat);
3348 PUSHs(sv_2mortal(sv));
3349 }
3350 }
3351 break;
3352 case 'd':
3353 case 'D':
3354 along = (strend - s) / sizeof(double);
3355 if (len > along)
3356 len = along;
3357 if (checksum) {
3358 while (len-- > 0) {
3359 Copy(s, &adouble, 1, double);
3360 s += sizeof(double);
3361 cdouble += adouble;
3362 }
3363 }
3364 else {
3365 EXTEND(SP, len);
bbce6d69 3366 EXTEND_MORTAL(len);
a0d0e21e
LW		 3367 while (len-- > 0) {
3368 Copy(s, &adouble, 1, double);
3369 s += sizeof(double);
3370 sv = NEWSV(48, 0);
3371 sv_setnv(sv, (double)adouble);
3372 PUSHs(sv_2mortal(sv));
3373 }
3374 }
3375 break;
3376 case 'u':
3377 along = (strend - s) * 3 / 4;
3378 sv = NEWSV(42, along);
f12c7020 3379 if (along)
3380 SvPOK_on(sv);
a0d0e21e
LW		 3381 while (s < strend && *s > ' ' && *s < 'a') {
3382 I32 a, b, c, d;
3383 char hunk[4];
79072805 3384
a0d0e21e
LW		 3385 hunk[3] = '\0';
3386 len = (*s++ - ' ') & 077;
3387 while (len > 0) {
3388 if (s < strend && *s >= ' ')
3389 a = (*s++ - ' ') & 077;
3390 else
3391 a = 0;
3392 if (s < strend && *s >= ' ')
3393 b = (*s++ - ' ') & 077;
3394 else
3395 b = 0;
3396 if (s < strend && *s >= ' ')
3397 c = (*s++ - ' ') & 077;
3398 else
3399 c = 0;
3400 if (s < strend && *s >= ' ')
3401 d = (*s++ - ' ') & 077;
3402 else
3403 d = 0;
3404 hunk[0] = a << 2 | b >> 4;
3405 hunk[1] = b << 4 | c >> 2;
3406 hunk[2] = c << 6 | d;
3407 sv_catpvn(sv, hunk, len > 3 ? 3 : len);
3408 len -= 3;
3409 }
3410 if (*s == '\n')
3411 s++;
3412 else if (s[1] == '\n') /* possible checksum byte */
3413 s += 2;
79072805 3414 }
a0d0e21e
LW		 3415 XPUSHs(sv_2mortal(sv));
3416 break;
79072805 3417 }
a0d0e21e
LW		 3418 if (checksum) {
3419 sv = NEWSV(42, 0);
3420 if (strchr("fFdD", datumtype) ||
3421 (checksum > 32 && strchr("iIlLN", datumtype)) ) {
3422 double trouble;
79072805 3423
a0d0e21e
LW		 3424 adouble = 1.0;
3425 while (checksum >= 16) {
3426 checksum -= 16;
3427 adouble *= 65536.0;
3428 }
3429 while (checksum >= 4) {
3430 checksum -= 4;
3431 adouble *= 16.0;
3432 }
3433 while (checksum--)
3434 adouble *= 2.0;
3435 along = (1 << checksum) - 1;
3436 while (cdouble < 0.0)
3437 cdouble += adouble;
3438 cdouble = modf(cdouble / adouble, &trouble) * adouble;
3439 sv_setnv(sv, cdouble);
3440 }
3441 else {
3442 if (checksum < 32) {
96e4d5b1 3443 aulong = (1 << checksum) - 1;
3444 culong &= aulong;
a0d0e21e 3445 }
96e4d5b1 3446 sv_setuv(sv, (UV)culong);
a0d0e21e
LW		 3447 }
3448 XPUSHs(sv_2mortal(sv));
3449 checksum = 0;
79072805 3450 }
79072805 3451 }
54310121 3452 if (sp == oldsp && gimme == G_SCALAR)
36477c24 3453 PUSHs(&sv_undef);
79072805 3454 RETURN;
79072805
LW		 3455}
3456
a0d0e21e 3457static void
8ac85365 3458doencodes(register SV *sv, register char *s, register I32 len)
79072805 3459{
a0d0e21e 3460 char hunk[5];
79072805 3461
a0d0e21e
LW		 3462 *hunk = len + ' ';
3463 sv_catpvn(sv, hunk, 1);
3464 hunk[4] = '\0';
3465 while (len > 0) {
3466 hunk[0] = ' ' + (077 & (*s >> 2));
3467 hunk[1] = ' ' + (077 & ((*s << 4) & 060 | (s[1] >> 4) & 017));
3468 hunk[2] = ' ' + (077 & ((s[1] << 2) & 074 | (s[2] >> 6) & 03));
3469 hunk[3] = ' ' + (077 & (s[2] & 077));
3470 sv_catpvn(sv, hunk, 4);
3471 s += 3;
3472 len -= 3;
3473 }
3474 for (s = SvPVX(sv); *s; s++) {
3475 if (*s == ' ')
3476 *s = '`';
3477 }
3478 sv_catpvn(sv, "\n", 1);
79072805
LW		 3479}
3480
55497cff 3481static SV *
8ac85365 3482is_an_int(char *s, STRLEN l)
55497cff 3483{
3484 SV *result = newSVpv("", l);
3485 char *result_c = SvPV(result, na); /* convenience */
3486 char *out = result_c;
3487 bool skip = 1;
3488 bool ignore = 0;
3489
3490 while (*s) {
3491 switch (*s) {
3492 case ' ':
3493 break;
3494 case '+':
3495 if (!skip) {
3496 SvREFCNT_dec(result);
3497 return (NULL);
3498 }
3499 break;
3500 case '0':
3501 case '1':
3502 case '2':
3503 case '3':
3504 case '4':
3505 case '5':
3506 case '6':
3507 case '7':
3508 case '8':
3509 case '9':
3510 skip = 0;
3511 if (!ignore) {
3512 *(out++) = *s;
3513 }
3514 break;
3515 case '.':
3516 ignore = 1;
3517 break;
3518 default:
3519 SvREFCNT_dec(result);
3520 return (NULL);
3521 }
3522 s++;
3523 }
3524 *(out++) = '\0';
3525 SvCUR_set(result, out - result_c);
3526 return (result);
3527}
3528
3529static int
8ac85365
NIS		 3530div128(SV *pnum, char *done)
3531 /* must be '\0' terminated */
3532
55497cff 3533{
3534 STRLEN len;
3535 char *s = SvPV(pnum, len);
3536 int m = 0;
3537 int r = 0;
3538 char *t = s;
3539
3540 *done = 1;
3541 while (*t) {
3542 int i;
3543
3544 i = m * 10 + (*t - '0');
3545 m = i & 0x7F;
3546 r = (i >> 7); /* r < 10 */
3547 if (r) {
3548 *done = 0;
3549 }
3550 *(t++) = '0' + r;
3551 }
3552 *(t++) = '\0';
3553 SvCUR_set(pnum, (STRLEN) (t - s));
3554 return (m);
3555}
3556
3557
a0d0e21e 3558PP(pp_pack)
79072805 3559{
a0d0e21e
LW		 3560 dSP; dMARK; dORIGMARK; dTARGET;
3561 register SV *cat = TARG;
3562 register I32 items;
3563 STRLEN fromlen;
3564 register char *pat = SvPVx(*++MARK, fromlen);
3565 register char *patend = pat + fromlen;
3566 register I32 len;
3567 I32 datumtype;
3568 SV *fromstr;
3569 /*SUPPRESS 442*/
3570 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
3571 static char *space10 = " ";
79072805 3572
a0d0e21e
LW		 3573 /* These must not be in registers: */
3574 char achar;
3575 I16 ashort;
3576 int aint;
3577 unsigned int auint;
3578 I32 along;
3579 U32 aulong;
ecfc5424
AD		 3580#ifdef HAS_QUAD
3581 Quad_t aquad;
3582 unsigned Quad_t auquad;
79072805 3583#endif
a0d0e21e
LW		 3584 char *aptr;
3585 float afloat;
3586 double adouble;
fb73857a 3587 int commas = 0;
79072805 3588
a0d0e21e
LW		 3589 items = SP - MARK;
3590 MARK++;
3591 sv_setpvn(cat, "", 0);
3592 while (pat < patend) {
3593#define NEXTFROM (items-- > 0 ? *MARK++ : &sv_no)
bbdab043
CS		 3594 datumtype = *pat++ & 0xFF;
3595 if (isSPACE(datumtype))
3596 continue;
a0d0e21e
LW		 3597 if (*pat == '*') {
3598 len = strchr("@Xxu", datumtype) ? 0 : items;
3599 pat++;
3600 }
3601 else if (isDIGIT(*pat)) {
3602 len = *pat++ - '0';
3603 while (isDIGIT(*pat))
3604 len = (len * 10) + (*pat++ - '0');
3605 }
3606 else
3607 len = 1;
3608 switch(datumtype) {
3609 default:
bbdab043 3610 croak("Invalid type in pack: '%c'", (int)datumtype);
fb73857a 3611 case ',': /* grandfather in commas but with a warning */
3612 if (commas++ == 0 && dowarn)
3613 warn("Invalid type in pack: '%c'", (int)datumtype);
3614 break;
a0d0e21e
LW		 3615 case '%':
3616 DIE("%% may only be used in unpack");
3617 case '@':
3618 len -= SvCUR(cat);
3619 if (len > 0)
3620 goto grow;
3621 len = -len;
3622 if (len > 0)
3623 goto shrink;
3624 break;
3625 case 'X':
3626 shrink:
3627 if (SvCUR(cat) < len)
3628 DIE("X outside of string");
3629 SvCUR(cat) -= len;
3630 *SvEND(cat) = '\0';
3631 break;
3632 case 'x':
3633 grow:
3634 while (len >= 10) {
3635 sv_catpvn(cat, null10, 10);
3636 len -= 10;
3637 }
3638 sv_catpvn(cat, null10, len);
3639 break;
3640 case 'A':
3641 case 'a':
3642 fromstr = NEXTFROM;
3643 aptr = SvPV(fromstr, fromlen);
3644 if (pat[-1] == '*')
3645 len = fromlen;
3646 if (fromlen > len)
3647 sv_catpvn(cat, aptr, len);
3648 else {
3649 sv_catpvn(cat, aptr, fromlen);
3650 len -= fromlen;
3651 if (datumtype == 'A') {
3652 while (len >= 10) {
3653 sv_catpvn(cat, space10, 10);
3654 len -= 10;
3655 }
3656 sv_catpvn(cat, space10, len);
3657 }
3658 else {
3659 while (len >= 10) {
3660 sv_catpvn(cat, null10, 10);
3661 len -= 10;
3662 }
3663 sv_catpvn(cat, null10, len);
3664 }
3665 }
3666 break;
3667 case 'B':
3668 case 'b':
3669 {
3670 char *savepat = pat;
3671 I32 saveitems;
79072805 3672
a0d0e21e
LW		 3673 fromstr = NEXTFROM;
3674 saveitems = items;
3675 aptr = SvPV(fromstr, fromlen);
3676 if (pat[-1] == '*')
3677 len = fromlen;
3678 pat = aptr;
3679 aint = SvCUR(cat);
3680 SvCUR(cat) += (len+7)/8;
3681 SvGROW(cat, SvCUR(cat) + 1);
3682 aptr = SvPVX(cat) + aint;
3683 if (len > fromlen)
3684 len = fromlen;
3685 aint = len;
3686 items = 0;
3687 if (datumtype == 'B') {
3688 for (len = 0; len++ < aint;) {
3689 items |= *pat++ & 1;
3690 if (len & 7)
3691 items <<= 1;
3692 else {
3693 *aptr++ = items & 0xff;
3694 items = 0;
3695 }
3696 }
3697 }
3698 else {
3699 for (len = 0; len++ < aint;) {
3700 if (*pat++ & 1)
3701 items |= 128;
3702 if (len & 7)
3703 items >>= 1;
3704 else {
3705 *aptr++ = items & 0xff;
3706 items = 0;
3707 }
3708 }
3709 }
3710 if (aint & 7) {
3711 if (datumtype == 'B')
3712 items <<= 7 - (aint & 7);
3713 else
3714 items >>= 7 - (aint & 7);
3715 *aptr++ = items & 0xff;
3716 }
3717 pat = SvPVX(cat) + SvCUR(cat);
3718 while (aptr <= pat)
3719 *aptr++ = '\0';
79072805 3720
a0d0e21e
LW		 3721 pat = savepat;
3722 items = saveitems;
3723 }
3724 break;
3725 case 'H':
3726 case 'h':
3727 {
3728 char *savepat = pat;
3729 I32 saveitems;
79072805 3730
a0d0e21e
LW		 3731 fromstr = NEXTFROM;
3732 saveitems = items;
3733 aptr = SvPV(fromstr, fromlen);
3734 if (pat[-1] == '*')
3735 len = fromlen;
3736 pat = aptr;
3737 aint = SvCUR(cat);
3738 SvCUR(cat) += (len+1)/2;
3739 SvGROW(cat, SvCUR(cat) + 1);
3740 aptr = SvPVX(cat) + aint;
3741 if (len > fromlen)
3742 len = fromlen;
3743 aint = len;
3744 items = 0;
3745 if (datumtype == 'H') {
3746 for (len = 0; len++ < aint;) {
3747 if (isALPHA(*pat))
3748 items |= ((*pat++ & 15) + 9) & 15;
3749 else
3750 items |= *pat++ & 15;
3751 if (len & 1)
3752 items <<= 4;
3753 else {
3754 *aptr++ = items & 0xff;
3755 items = 0;
3756 }
3757 }
3758 }
3759 else {
3760 for (len = 0; len++ < aint;) {
3761 if (isALPHA(*pat))
3762 items |= (((*pat++ & 15) + 9) & 15) << 4;
3763 else
3764 items |= (*pat++ & 15) << 4;
3765 if (len & 1)
3766 items >>= 4;
3767 else {
3768 *aptr++ = items & 0xff;
3769 items = 0;
3770 }
3771 }
3772 }
3773 if (aint & 1)
3774 *aptr++ = items & 0xff;
3775 pat = SvPVX(cat) + SvCUR(cat);
3776 while (aptr <= pat)
3777 *aptr++ = '\0';
79072805 3778
a0d0e21e
LW		 3779 pat = savepat;
3780 items = saveitems;
3781 }
3782 break;
3783 case 'C':
3784 case 'c':
3785 while (len-- > 0) {
3786 fromstr = NEXTFROM;
3787 aint = SvIV(fromstr);
3788 achar = aint;
3789 sv_catpvn(cat, &achar, sizeof(char));
3790 }
3791 break;
3792 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
3793 case 'f':
3794 case 'F':
3795 while (len-- > 0) {
3796 fromstr = NEXTFROM;
3797 afloat = (float)SvNV(fromstr);
3798 sv_catpvn(cat, (char *)&afloat, sizeof (float));
3799 }
3800 break;
3801 case 'd':
3802 case 'D':
3803 while (len-- > 0) {
3804 fromstr = NEXTFROM;
3805 adouble = (double)SvNV(fromstr);
3806 sv_catpvn(cat, (char *)&adouble, sizeof (double));
3807 }
3808 break;
3809 case 'n':
3810 while (len-- > 0) {
3811 fromstr = NEXTFROM;
3812 ashort = (I16)SvIV(fromstr);
3813#ifdef HAS_HTONS
3814 ashort = htons(ashort);
79072805 3815#endif
96e4d5b1 3816 CAT16(cat, &ashort);
a0d0e21e
LW		 3817 }
3818 break;
3819 case 'v':
3820 while (len-- > 0) {
3821 fromstr = NEXTFROM;
3822 ashort = (I16)SvIV(fromstr);
3823#ifdef HAS_HTOVS
3824 ashort = htovs(ashort);
79072805 3825#endif
96e4d5b1 3826 CAT16(cat, &ashort);
a0d0e21e
LW		 3827 }
3828 break;
3829 case 'S':
3830 case 's':
3831 while (len-- > 0) {
3832 fromstr = NEXTFROM;
3833 ashort = (I16)SvIV(fromstr);
96e4d5b1 3834 CAT16(cat, &ashort);
a0d0e21e
LW		 3835 }
3836 break;
3837 case 'I':
3838 while (len-- > 0) {
3839 fromstr = NEXTFROM;
96e4d5b1 3840 auint = SvUV(fromstr);
a0d0e21e
LW		 3841 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
3842 }
3843 break;
def98dd4
UP		 3844 case 'w':
3845 while (len-- > 0) {
bbce6d69 3846 fromstr = NEXTFROM;
3847 adouble = floor(SvNV(fromstr));
3848
3849 if (adouble < 0)
3850 croak("Cannot compress negative numbers");
3851
46fc3d4c 3852 if (
3853#ifdef BW_BITS
3854 adouble <= BW_MASK
3855#else
ef2d312d
TH		 3856#ifdef CXUX_BROKEN_CONSTANT_CONVERT
3857 adouble <= UV_MAX_cxux
3858#else
46fc3d4c 3859 adouble <= UV_MAX
3860#endif
ef2d312d 3861#endif
46fc3d4c 3862 )
3863 {
bbce6d69 3864 char buf[1 + sizeof(UV)];
3865 char *in = buf + sizeof(buf);
3866 UV auv = U_V(adouble);;
3867
3868 do {
3869 *--in = (auv & 0x7f) | 0x80;
3870 auv >>= 7;
3871 } while (auv);
3872 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
3873 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
3874 }
3875 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
3876 char *from, *result, *in;
3877 SV *norm;
3878 STRLEN len;
3879 bool done;
55497cff 3880
bbce6d69 3881 /* Copy string and check for compliance */
3882 from = SvPV(fromstr, len);
3883 if ((norm = is_an_int(from, len)) == NULL)
3884 croak("can compress only unsigned integer");
3885
3886 New('w', result, len, char);
3887 in = result + len;
3888 done = FALSE;
3889 while (!done)
3890 *--in = div128(norm, &done) | 0x80;
3891 result[len - 1] &= 0x7F; /* clear continue bit */
3892 sv_catpvn(cat, in, (result + len) - in);
5f05dabc 3893 Safefree(result);
bbce6d69 3894 SvREFCNT_dec(norm); /* free norm */
def98dd4 3895 }
bbce6d69 3896 else if (SvNOKp(fromstr)) {
3897 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
3898 char *in = buf + sizeof(buf);
3899
3900 do {
3901 double next = floor(adouble / 128);
3902 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
3903 if (--in < buf) /* this cannot happen ;-) */
3904 croak ("Cannot compress integer");
3905 adouble = next;
3906 } while (adouble > 0);
3907 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
3908 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
3909 }
3910 else
3911 croak("Cannot compress non integer");
3912 }
def98dd4 3913 break;
a0d0e21e
LW		 3914 case 'i':
3915 while (len-- > 0) {
3916 fromstr = NEXTFROM;
3917 aint = SvIV(fromstr);
3918 sv_catpvn(cat, (char*)&aint, sizeof(int));
3919 }
3920 break;
3921 case 'N':
3922 while (len-- > 0) {
3923 fromstr = NEXTFROM;
96e4d5b1 3924 aulong = SvUV(fromstr);
a0d0e21e
LW		 3925#ifdef HAS_HTONL
3926 aulong = htonl(aulong);
79072805 3927#endif
96e4d5b1 3928 CAT32(cat, &aulong);
a0d0e21e
LW		 3929 }
3930 break;
3931 case 'V':
3932 while (len-- > 0) {
3933 fromstr = NEXTFROM;
96e4d5b1 3934 aulong = SvUV(fromstr);
a0d0e21e
LW		 3935#ifdef HAS_HTOVL
3936 aulong = htovl(aulong);
79072805 3937#endif
96e4d5b1 3938 CAT32(cat, &aulong);
a0d0e21e
LW		 3939 }
3940 break;
3941 case 'L':
3942 while (len-- > 0) {
3943 fromstr = NEXTFROM;
96e4d5b1 3944 aulong = SvUV(fromstr);
3945 CAT32(cat, &aulong);
a0d0e21e
LW		 3946 }
3947 break;
3948 case 'l':
3949 while (len-- > 0) {
3950 fromstr = NEXTFROM;
3951 along = SvIV(fromstr);
96e4d5b1 3952 CAT32(cat, &along);
a0d0e21e
LW		 3953 }
3954 break;
ecfc5424 3955#ifdef HAS_QUAD
a0d0e21e
LW		 3956 case 'Q':
3957 while (len-- > 0) {
3958 fromstr = NEXTFROM;
ecfc5424
AD		 3959 auquad = (unsigned Quad_t)SvIV(fromstr);
3960 sv_catpvn(cat, (char*)&auquad, sizeof(unsigned Quad_t));
a0d0e21e
LW		 3961 }
3962 break;
3963 case 'q':
3964 while (len-- > 0) {
3965 fromstr = NEXTFROM;
ecfc5424
AD		 3966 aquad = (Quad_t)SvIV(fromstr);
3967 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
a0d0e21e
LW		 3968 }
3969 break;
ecfc5424 3970#endif /* HAS_QUAD */
a0d0e21e
LW		 3971 case 'P':
3972 len = 1; /* assume SV is correct length */
3973 /* FALL THROUGH */
3974 case 'p':
3975 while (len-- > 0) {
3976 fromstr = NEXTFROM;
72dbcb4b 3977 if (fromstr == &sv_undef)
84902520 3978 aptr = NULL;
72dbcb4b 3979 else {
84902520
TB		 3980 /* XXX better yet, could spirit away the string to
3981 * a safe spot and hang on to it until the result
3982 * of pack() (and all copies of the result) are
3983 * gone.
3984 */
3985 if (dowarn && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
3986 warn("Attempt to pack pointer to temporary value");
3987 if (SvPOK(fromstr) || SvNIOK(fromstr))
3988 aptr = SvPV(fromstr,na);
3989 else
3990 aptr = SvPV_force(fromstr,na);
72dbcb4b 3991 }
a0d0e21e
LW		 3992 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
3993 }
3994 break;
3995 case 'u':
3996 fromstr = NEXTFROM;
3997 aptr = SvPV(fromstr, fromlen);
3998 SvGROW(cat, fromlen * 4 / 3);
3999 if (len <= 1)
4000 len = 45;
4001 else
4002 len = len / 3 * 3;
4003 while (fromlen > 0) {
4004 I32 todo;
79072805 4005
a0d0e21e
LW		 4006 if (fromlen > len)
4007 todo = len;
4008 else
4009 todo = fromlen;
4010 doencodes(cat, aptr, todo);
4011 fromlen -= todo;
4012 aptr += todo;
4013 }
4014 break;
4015 }
4016 }
4017 SvSETMAGIC(cat);
4018 SP = ORIGMARK;
4019 PUSHs(cat);
4020 RETURN;
79072805 4021}
a0d0e21e 4022#undef NEXTFROM
79072805 4023
a0d0e21e 4024PP(pp_split)
79072805 4025{
a0d0e21e
LW		 4026 dSP; dTARG;
4027 AV *ary;
4028 register I32 limit = POPi; /* note, negative is forever */
4029 SV *sv = POPs;
4030 STRLEN len;
4031 register char *s = SvPV(sv, len);
4032 char *strend = s + len;
44a8e56a 4033 register PMOP *pm;
4034 register REGEXP *rx;
a0d0e21e
LW		 4035 register SV *dstr;
4036 register char *m;
4037 I32 iters = 0;
4038 I32 maxiters = (strend - s) + 10;
4039 I32 i;
4040 char *orig;
4041 I32 origlimit = limit;
4042 I32 realarray = 0;
4043 I32 base;
f12c7020 4044 AV *oldstack = curstack;
54310121 4045 I32 gimme = GIMME_V;