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