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