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