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