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