3 * Copyright (c) 1991-2001, Larry Wall
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.
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
20 * The compiler on Concurrent CX/UX systems has a subtle bug which only
21 * seems to show up when compiling pp.c - it generates the wrong double
22 * precision constant value for (double)UV_MAX when used inline in the body
23 * of the code below, so this makes a static variable up front (which the
24 * compiler seems to get correct) and uses it in place of UV_MAX below.
26 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
27 static double UV_MAX_cxux = ((double)UV_MAX);
31 * Offset for integer pack/unpack.
33 * On architectures where I16 and I32 aren't really 16 and 32 bits,
34 * which for now are all Crays, pack and unpack have to play games.
38 * These values are required for portability of pack() output.
39 * If they're not right on your machine, then pack() and unpack()
40 * wouldn't work right anyway; you'll need to apply the Cray hack.
41 * (I'd like to check them with #if, but you can't use sizeof() in
42 * the preprocessor.) --???
45 The appropriate SHORTSIZE, INTSIZE, LONGSIZE, and LONGLONGSIZE
46 defines are now in config.h. --Andy Dougherty April 1998
51 /* CROSSCOMPILE and MULTIARCH are going to affect pp_pack() and pp_unpack().
54 #if SHORTSIZE != SIZE16 || LONGSIZE != SIZE32
55 # define PERL_NATINT_PACK
58 #if LONGSIZE > 4 && defined(_CRAY)
59 # if BYTEORDER == 0x12345678
60 # define OFF16(p) (char*)(p)
61 # define OFF32(p) (char*)(p)
63 # if BYTEORDER == 0x87654321
64 # define OFF16(p) ((char*)(p) + (sizeof(U16) - SIZE16))
65 # define OFF32(p) ((char*)(p) + (sizeof(U32) - SIZE32))
67 }}}} bad cray byte order
70 # define COPY16(s,p) (*(p) = 0, Copy(s, OFF16(p), SIZE16, char))
71 # define COPY32(s,p) (*(p) = 0, Copy(s, OFF32(p), SIZE32, char))
72 # define COPYNN(s,p,n) (*(p) = 0, Copy(s, (char *)(p), n, char))
73 # define CAT16(sv,p) sv_catpvn(sv, OFF16(p), SIZE16)
74 # define CAT32(sv,p) sv_catpvn(sv, OFF32(p), SIZE32)
76 # define COPY16(s,p) Copy(s, p, SIZE16, char)
77 # define COPY32(s,p) Copy(s, p, SIZE32, char)
78 # define COPYNN(s,p,n) Copy(s, (char *)(p), n, char)
79 # define CAT16(sv,p) sv_catpvn(sv, (char*)(p), SIZE16)
80 # define CAT32(sv,p) sv_catpvn(sv, (char*)(p), SIZE32)
83 /* variations on pp_null */
85 /* XXX I can't imagine anyone who doesn't have this actually _needs_
86 it, since pid_t is an integral type.
89 #ifdef NEED_GETPID_PROTO
90 extern Pid_t getpid (void);
96 if (GIMME_V == G_SCALAR)
111 if (PL_op->op_private & OPpLVAL_INTRO)
112 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
114 if (PL_op->op_flags & OPf_REF) {
118 if (GIMME == G_SCALAR)
119 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
123 if (GIMME == G_ARRAY) {
124 I32 maxarg = AvFILL((AV*)TARG) + 1;
126 if (SvMAGICAL(TARG)) {
128 for (i=0; i < maxarg; i++) {
129 SV **svp = av_fetch((AV*)TARG, i, FALSE);
130 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
134 Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
139 SV* sv = sv_newmortal();
140 I32 maxarg = AvFILL((AV*)TARG) + 1;
141 sv_setiv(sv, maxarg);
153 if (PL_op->op_private & OPpLVAL_INTRO)
154 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
155 if (PL_op->op_flags & OPf_REF)
158 if (GIMME == G_SCALAR)
159 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
163 if (gimme == G_ARRAY) {
166 else if (gimme == G_SCALAR) {
167 SV* sv = sv_newmortal();
168 if (HvFILL((HV*)TARG))
169 Perl_sv_setpvf(aTHX_ sv, "%ld/%ld",
170 (long)HvFILL((HV*)TARG), (long)HvMAX((HV*)TARG) + 1);
180 DIE(aTHX_ "NOT IMPL LINE %d",__LINE__);
191 tryAMAGICunDEREF(to_gv);
194 if (SvTYPE(sv) == SVt_PVIO) {
195 GV *gv = (GV*) sv_newmortal();
196 gv_init(gv, 0, "", 0, 0);
197 GvIOp(gv) = (IO *)sv;
198 (void)SvREFCNT_inc(sv);
201 else if (SvTYPE(sv) != SVt_PVGV)
202 DIE(aTHX_ "Not a GLOB reference");
205 if (SvTYPE(sv) != SVt_PVGV) {
209 if (SvGMAGICAL(sv)) {
214 if (!SvOK(sv) && sv != &PL_sv_undef) {
215 /* If this is a 'my' scalar and flag is set then vivify
218 if (PL_op->op_private & OPpDEREF) {
221 if (cUNOP->op_targ) {
223 SV *namesv = PL_curpad[cUNOP->op_targ];
224 name = SvPV(namesv, len);
225 gv = (GV*)NEWSV(0,0);
226 gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
229 name = CopSTASHPV(PL_curcop);
232 if (SvTYPE(sv) < SVt_RV)
233 sv_upgrade(sv, SVt_RV);
239 if (PL_op->op_flags & OPf_REF ||
240 PL_op->op_private & HINT_STRICT_REFS)
241 DIE(aTHX_ PL_no_usym, "a symbol");
242 if (ckWARN(WARN_UNINITIALIZED))
247 if ((PL_op->op_flags & OPf_SPECIAL) &&
248 !(PL_op->op_flags & OPf_MOD))
250 sv = (SV*)gv_fetchpv(sym, FALSE, SVt_PVGV);
252 && (!is_gv_magical(sym,len,0)
253 || !(sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV))))
259 if (PL_op->op_private & HINT_STRICT_REFS)
260 DIE(aTHX_ PL_no_symref, sym, "a symbol");
261 sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
265 if (PL_op->op_private & OPpLVAL_INTRO)
266 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
277 tryAMAGICunDEREF(to_sv);
280 switch (SvTYPE(sv)) {
284 DIE(aTHX_ "Not a SCALAR reference");
292 if (SvTYPE(gv) != SVt_PVGV) {
293 if (SvGMAGICAL(sv)) {
299 if (PL_op->op_flags & OPf_REF ||
300 PL_op->op_private & HINT_STRICT_REFS)
301 DIE(aTHX_ PL_no_usym, "a SCALAR");
302 if (ckWARN(WARN_UNINITIALIZED))
307 if ((PL_op->op_flags & OPf_SPECIAL) &&
308 !(PL_op->op_flags & OPf_MOD))
310 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PV);
312 && (!is_gv_magical(sym,len,0)
313 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV))))
319 if (PL_op->op_private & HINT_STRICT_REFS)
320 DIE(aTHX_ PL_no_symref, sym, "a SCALAR");
321 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
326 if (PL_op->op_flags & OPf_MOD) {
327 if (PL_op->op_private & OPpLVAL_INTRO)
328 sv = save_scalar((GV*)TOPs);
329 else if (PL_op->op_private & OPpDEREF)
330 vivify_ref(sv, PL_op->op_private & OPpDEREF);
340 SV *sv = AvARYLEN(av);
342 AvARYLEN(av) = sv = NEWSV(0,0);
343 sv_upgrade(sv, SVt_IV);
344 sv_magic(sv, (SV*)av, '#', Nullch, 0);
352 djSP; dTARGET; dPOPss;
354 if (PL_op->op_flags & OPf_MOD || LVRET) {
355 if (SvTYPE(TARG) < SVt_PVLV) {
356 sv_upgrade(TARG, SVt_PVLV);
357 sv_magic(TARG, Nullsv, '.', Nullch, 0);
361 if (LvTARG(TARG) != sv) {
363 SvREFCNT_dec(LvTARG(TARG));
364 LvTARG(TARG) = SvREFCNT_inc(sv);
366 PUSHs(TARG); /* no SvSETMAGIC */
372 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
373 mg = mg_find(sv, 'g');
374 if (mg && mg->mg_len >= 0) {
378 PUSHi(i + PL_curcop->cop_arybase);
392 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
393 /* (But not in defined().) */
394 CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
397 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
398 if ((PL_op->op_private & OPpLVAL_INTRO)) {
399 if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
402 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
406 cv = (CV*)&PL_sv_undef;
420 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
421 char *s = SvPVX(TOPs);
422 if (strnEQ(s, "CORE::", 6)) {
425 code = keyword(s + 6, SvCUR(TOPs) - 6);
426 if (code < 0) { /* Overridable. */
427 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
428 int i = 0, n = 0, seen_question = 0;
430 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
432 while (i < MAXO) { /* The slow way. */
433 if (strEQ(s + 6, PL_op_name[i])
434 || strEQ(s + 6, PL_op_desc[i]))
440 goto nonesuch; /* Should not happen... */
442 oa = PL_opargs[i] >> OASHIFT;
444 if (oa & OA_OPTIONAL && !seen_question) {
448 else if (n && str[0] == ';' && seen_question)
449 goto set; /* XXXX system, exec */
450 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
451 && (oa & (OA_OPTIONAL - 1)) <= OA_HVREF) {
454 /* What to do with R ((un)tie, tied, (sys)read, recv)? */
455 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
459 ret = sv_2mortal(newSVpvn(str, n - 1));
461 else if (code) /* Non-Overridable */
463 else { /* None such */
465 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
469 cv = sv_2cv(TOPs, &stash, &gv, FALSE);
471 ret = sv_2mortal(newSVpvn(SvPVX(cv), SvCUR(cv)));
480 CV* cv = (CV*)PL_curpad[PL_op->op_targ];
482 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
498 if (GIMME != G_ARRAY) {
502 *MARK = &PL_sv_undef;
503 *MARK = refto(*MARK);
507 EXTEND_MORTAL(SP - MARK);
509 *MARK = refto(*MARK);
514 S_refto(pTHX_ SV *sv)
518 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
521 if (!(sv = LvTARG(sv)))
524 (void)SvREFCNT_inc(sv);
526 else if (SvTYPE(sv) == SVt_PVAV) {
527 if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
530 (void)SvREFCNT_inc(sv);
532 else if (SvPADTMP(sv))
536 (void)SvREFCNT_inc(sv);
539 sv_upgrade(rv, SVt_RV);
553 if (sv && SvGMAGICAL(sv))
556 if (!sv || !SvROK(sv))
560 pv = sv_reftype(sv,TRUE);
561 PUSHp(pv, strlen(pv));
571 stash = CopSTASH(PL_curcop);
577 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
578 Perl_croak(aTHX_ "Attempt to bless into a reference");
580 if (ckWARN(WARN_MISC) && len == 0)
581 Perl_warner(aTHX_ WARN_MISC,
582 "Explicit blessing to '' (assuming package main)");
583 stash = gv_stashpvn(ptr, len, TRUE);
586 (void)sv_bless(TOPs, stash);
600 elem = SvPV(sv, n_a);
604 switch (elem ? *elem : '\0')
607 if (strEQ(elem, "ARRAY"))
608 tmpRef = (SV*)GvAV(gv);
611 if (strEQ(elem, "CODE"))
612 tmpRef = (SV*)GvCVu(gv);
615 if (strEQ(elem, "FILEHANDLE")) /* XXX deprecate in 5.005 */
616 tmpRef = (SV*)GvIOp(gv);
618 if (strEQ(elem, "FORMAT"))
619 tmpRef = (SV*)GvFORM(gv);
622 if (strEQ(elem, "GLOB"))
626 if (strEQ(elem, "HASH"))
627 tmpRef = (SV*)GvHV(gv);
630 if (strEQ(elem, "IO"))
631 tmpRef = (SV*)GvIOp(gv);
634 if (strEQ(elem, "NAME"))
635 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
638 if (strEQ(elem, "PACKAGE"))
639 sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
642 if (strEQ(elem, "SCALAR"))
656 /* Pattern matching */
661 register unsigned char *s;
664 register I32 *sfirst;
668 if (sv == PL_lastscream) {
674 SvSCREAM_off(PL_lastscream);
675 SvREFCNT_dec(PL_lastscream);
677 PL_lastscream = SvREFCNT_inc(sv);
680 s = (unsigned char*)(SvPV(sv, len));
684 if (pos > PL_maxscream) {
685 if (PL_maxscream < 0) {
686 PL_maxscream = pos + 80;
687 New(301, PL_screamfirst, 256, I32);
688 New(302, PL_screamnext, PL_maxscream, I32);
691 PL_maxscream = pos + pos / 4;
692 Renew(PL_screamnext, PL_maxscream, I32);
696 sfirst = PL_screamfirst;
697 snext = PL_screamnext;
699 if (!sfirst || !snext)
700 DIE(aTHX_ "do_study: out of memory");
702 for (ch = 256; ch; --ch)
709 snext[pos] = sfirst[ch] - pos;
716 sv_magic(sv, Nullsv, 'g', Nullch, 0); /* piggyback on m//g magic */
725 if (PL_op->op_flags & OPf_STACKED)
731 TARG = sv_newmortal();
736 /* Lvalue operators. */
748 djSP; dMARK; dTARGET;
758 SETi(do_chomp(TOPs));
764 djSP; dMARK; dTARGET;
765 register I32 count = 0;
768 count += do_chomp(POPs);
779 if (!sv || !SvANY(sv))
781 switch (SvTYPE(sv)) {
783 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
787 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
791 if (CvROOT(sv) || CvXSUB(sv))
808 if (!PL_op->op_private) {
817 if (SvTHINKFIRST(sv))
820 switch (SvTYPE(sv)) {
830 if (ckWARN(WARN_MISC) && cv_const_sv((CV*)sv))
831 Perl_warner(aTHX_ WARN_MISC, "Constant subroutine %s undefined",
832 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
836 /* let user-undef'd sub keep its identity */
837 GV* gv = (GV*)SvREFCNT_inc(CvGV((CV*)sv));
844 SvSetMagicSV(sv, &PL_sv_undef);
848 Newz(602, gp, 1, GP);
849 GvGP(sv) = gp_ref(gp);
850 GvSV(sv) = NEWSV(72,0);
851 GvLINE(sv) = CopLINE(PL_curcop);
857 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
860 SvPV_set(sv, Nullch);
873 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
874 DIE(aTHX_ PL_no_modify);
875 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
876 SvIVX(TOPs) != IV_MIN)
879 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
890 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
891 DIE(aTHX_ PL_no_modify);
892 sv_setsv(TARG, TOPs);
893 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
894 SvIVX(TOPs) != IV_MAX)
897 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
911 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
912 DIE(aTHX_ PL_no_modify);
913 sv_setsv(TARG, TOPs);
914 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
915 SvIVX(TOPs) != IV_MIN)
918 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
927 /* Ordinary operators. */
931 djSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
934 SETn( Perl_pow( left, right) );
941 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
942 #ifdef PERL_PRESERVE_IVUV
945 /* Unless the left argument is integer in range we are going to have to
946 use NV maths. Hence only attempt to coerce the right argument if
947 we know the left is integer. */
948 /* Left operand is defined, so is it IV? */
951 bool auvok = SvUOK(TOPm1s);
952 bool buvok = SvUOK(TOPs);
953 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
954 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
961 alow = SvUVX(TOPm1s);
963 IV aiv = SvIVX(TOPm1s);
966 auvok = TRUE; /* effectively it's a UV now */
968 alow = -aiv; /* abs, auvok == false records sign */
974 IV biv = SvIVX(TOPs);
977 buvok = TRUE; /* effectively it's a UV now */
979 blow = -biv; /* abs, buvok == false records sign */
983 /* If this does sign extension on unsigned it's time for plan B */
984 ahigh = alow >> (4 * sizeof (UV));
986 bhigh = blow >> (4 * sizeof (UV));
988 if (ahigh && bhigh) {
989 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
990 which is overflow. Drop to NVs below. */
991 } else if (!ahigh && !bhigh) {
992 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
993 so the unsigned multiply cannot overflow. */
994 UV product = alow * blow;
995 if (auvok == buvok) {
996 /* -ve * -ve or +ve * +ve gives a +ve result. */
1000 } else if (product <= (UV)IV_MIN) {
1001 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1002 /* -ve result, which could overflow an IV */
1006 } /* else drop to NVs below. */
1008 /* One operand is large, 1 small */
1011 /* swap the operands */
1013 bhigh = blow; /* bhigh now the temp var for the swap */
1017 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1018 multiplies can't overflow. shift can, add can, -ve can. */
1019 product_middle = ahigh * blow;
1020 if (!(product_middle & topmask)) {
1021 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1023 product_middle <<= (4 * sizeof (UV));
1024 product_low = alow * blow;
1026 /* as for pp_add, UV + something mustn't get smaller.
1027 IIRC ANSI mandates this wrapping *behaviour* for
1028 unsigned whatever the actual representation*/
1029 product_low += product_middle;
1030 if (product_low >= product_middle) {
1031 /* didn't overflow */
1032 if (auvok == buvok) {
1033 /* -ve * -ve or +ve * +ve gives a +ve result. */
1035 SETu( product_low );
1037 } else if (product_low <= (UV)IV_MIN) {
1038 /* 2s complement assumption again */
1039 /* -ve result, which could overflow an IV */
1041 SETi( -product_low );
1043 } /* else drop to NVs below. */
1045 } /* product_middle too large */
1046 } /* ahigh && bhigh */
1047 } /* SvIOK(TOPm1s) */
1052 SETn( left * right );
1059 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1064 DIE(aTHX_ "Illegal division by zero");
1066 /* insure that 20./5. == 4. */
1069 if ((NV)I_V(left) == left &&
1070 (NV)I_V(right) == right &&
1071 (k = I_V(left)/I_V(right))*I_V(right) == I_V(left)) {
1075 value = left / right;
1079 value = left / right;
1088 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1094 bool use_double = 0;
1098 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
1100 right = (right_neg = (i < 0)) ? -i : i;
1105 right_neg = dright < 0;
1110 if (!use_double && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
1112 left = (left_neg = (i < 0)) ? -i : i;
1120 left_neg = dleft < 0;
1129 /* Somehow U_V is pessimized even if CASTFLAGS is 0 */
1131 # define CAST_D2UV(d) U_V(d)
1133 # define CAST_D2UV(d) ((UV)(d))
1135 /* Tried to do this only in the case DOUBLESIZE <= UV_SIZE,
1136 * or, in other words, precision of UV more than of NV.
1137 * But in fact the approach below turned out to be an
1138 * optimization - floor() may be slow */
1139 if (dright <= UV_MAX && dleft <= UV_MAX) {
1140 right = CAST_D2UV(dright);
1141 left = CAST_D2UV(dleft);
1146 /* Backward-compatibility clause: */
1147 dright = Perl_floor(dright + 0.5);
1148 dleft = Perl_floor(dleft + 0.5);
1151 DIE(aTHX_ "Illegal modulus zero");
1153 dans = Perl_fmod(dleft, dright);
1154 if ((left_neg != right_neg) && dans)
1155 dans = dright - dans;
1158 sv_setnv(TARG, dans);
1165 DIE(aTHX_ "Illegal modulus zero");
1168 if ((left_neg != right_neg) && ans)
1171 /* XXX may warn: unary minus operator applied to unsigned type */
1172 /* could change -foo to be (~foo)+1 instead */
1173 if (ans <= ~((UV)IV_MAX)+1)
1174 sv_setiv(TARG, ~ans+1);
1176 sv_setnv(TARG, -(NV)ans);
1179 sv_setuv(TARG, ans);
1188 djSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1190 register IV count = POPi;
1191 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1193 I32 items = SP - MARK;
1196 max = items * count;
1205 repeatcpy((char*)(MARK + items), (char*)MARK,
1206 items * sizeof(SV*), count - 1);
1209 else if (count <= 0)
1212 else { /* Note: mark already snarfed by pp_list */
1217 SvSetSV(TARG, tmpstr);
1218 SvPV_force(TARG, len);
1219 isutf = DO_UTF8(TARG);
1224 SvGROW(TARG, (count * len) + 1);
1225 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1226 SvCUR(TARG) *= count;
1228 *SvEND(TARG) = '\0';
1231 (void)SvPOK_only_UTF8(TARG);
1233 (void)SvPOK_only(TARG);
1242 djSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
1243 useleft = USE_LEFT(TOPm1s);
1244 #ifdef PERL_PRESERVE_IVUV
1245 /* We must see if we can perform the addition with integers if possible,
1246 as the integer code detects overflow while the NV code doesn't.
1247 If either argument hasn't had a numeric conversion yet attempt to get
1248 the IV. It's important to do this now, rather than just assuming that
1249 it's not IOK as a PV of "9223372036854775806" may not take well to NV
1250 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
1251 integer in case the second argument is IV=9223372036854775806
1252 We can (now) rely on sv_2iv to do the right thing, only setting the
1253 public IOK flag if the value in the NV (or PV) slot is truly integer.
1255 A side effect is that this also aggressively prefers integer maths over
1256 fp maths for integer values. */
1259 /* Unless the left argument is integer in range we are going to have to
1260 use NV maths. Hence only attempt to coerce the right argument if
1261 we know the left is integer. */
1263 /* left operand is undef, treat as zero. + 0 is identity. */
1265 dPOPuv; /* Scary macros. Lets put a sequence point (;) here */
1266 if (value <= (UV)IV_MIN) {
1267 /* 2s complement assumption. */
1270 } /* else drop through into NVs below */
1277 /* Left operand is defined, so is it IV? */
1278 SvIV_please(TOPm1s);
1279 if (SvIOK(TOPm1s)) {
1280 bool auvok = SvUOK(TOPm1s);
1281 bool buvok = SvUOK(TOPs);
1283 if (!auvok && !buvok) { /* ## IV - IV ## */
1284 IV aiv = SvIVX(TOPm1s);
1285 IV biv = SvIVX(TOPs);
1286 IV result = aiv - biv;
1288 if (biv >= 0 ? (result < aiv) : (result >= aiv)) {
1293 /* +ve - +ve can't overflow. (worst case 0 - IV_MAX) */
1294 /* -ve - -ve can't overflow. (worst case -1 - IV_MIN) */
1295 /* -ve - +ve can only overflow too negative. */
1296 /* leaving +ve - -ve, which will go UV */
1297 if (aiv >= 0 && biv < 0) { /* assert don't need biv <0 */
1298 /* 2s complement assumption for IV_MIN */
1299 UV result = (UV)aiv + (UV)-biv;
1300 /* UV + UV must get bigger. +ve IV + +ve IV +1 can't
1301 overflow UV (2s complement assumption */
1302 assert (result >= (UV) aiv);
1307 /* Overflow, drop through to NVs */
1308 } else if (auvok && buvok) { /* ## UV - UV ## */
1309 UV auv = SvUVX(TOPm1s);
1310 UV buv = SvUVX(TOPs);
1318 /* Blatant 2s complement assumption. */
1319 result = (IV)(auv - buv);
1325 /* Overflow on IV - IV, drop through to NVs */
1326 } else if (auvok) { /* ## Mixed UV - IV ## */
1327 UV auv = SvUVX(TOPm1s);
1328 IV biv = SvIVX(TOPs);
1331 /* 2s complement assumptions for IV_MIN */
1332 UV result = auv + ((UV)-biv);
1333 /* UV + UV can only get bigger... */
1334 if (result >= auv) {
1339 /* and if it gets too big for UV then it's NV time. */
1340 } else if (auv > (UV)IV_MAX) {
1341 /* I think I'm making an implicit 2s complement
1342 assumption that IV_MIN == -IV_MAX - 1 */
1344 UV result = auv - (UV)biv;
1345 assert (result <= auv);
1351 IV result = (IV)auv - biv;
1352 assert (result <= (IV)auv);
1357 } else { /* ## Mixed IV - UV ## */
1358 IV aiv = SvIVX(TOPm1s);
1359 UV buv = SvUVX(TOPs);
1360 IV result = aiv - (IV)buv; /* 2s complement assumption. */
1362 /* result must not get larger. */
1363 if (result <= aiv) {
1367 } /* end of IV-IV / UV-UV / UV-IV / IV-UV */
1376 /* left operand is undef, treat as zero - value */
1380 SETn( TOPn - value );
1387 djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1390 if (PL_op->op_private & HINT_INTEGER) {
1404 djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1407 if (PL_op->op_private & HINT_INTEGER) {
1421 djSP; tryAMAGICbinSET(lt,0);
1422 #ifdef PERL_PRESERVE_IVUV
1425 SvIV_please(TOPm1s);
1426 if (SvIOK(TOPm1s)) {
1427 bool auvok = SvUOK(TOPm1s);
1428 bool buvok = SvUOK(TOPs);
1430 if (!auvok && !buvok) { /* ## IV < IV ## */
1431 IV aiv = SvIVX(TOPm1s);
1432 IV biv = SvIVX(TOPs);
1435 SETs(boolSV(aiv < biv));
1438 if (auvok && buvok) { /* ## UV < UV ## */
1439 UV auv = SvUVX(TOPm1s);
1440 UV buv = SvUVX(TOPs);
1443 SETs(boolSV(auv < buv));
1446 if (auvok) { /* ## UV < IV ## */
1453 /* As (a) is a UV, it's >=0, so it cannot be < */
1458 if (auv >= (UV) IV_MAX) {
1459 /* As (b) is an IV, it cannot be > IV_MAX */
1463 SETs(boolSV(auv < (UV)biv));
1466 { /* ## IV < UV ## */
1470 aiv = SvIVX(TOPm1s);
1472 /* As (b) is a UV, it's >=0, so it must be < */
1479 if (buv > (UV) IV_MAX) {
1480 /* As (a) is an IV, it cannot be > IV_MAX */
1484 SETs(boolSV((UV)aiv < buv));
1492 SETs(boolSV(TOPn < value));
1499 djSP; tryAMAGICbinSET(gt,0);
1500 #ifdef PERL_PRESERVE_IVUV
1503 SvIV_please(TOPm1s);
1504 if (SvIOK(TOPm1s)) {
1505 bool auvok = SvUOK(TOPm1s);
1506 bool buvok = SvUOK(TOPs);
1508 if (!auvok && !buvok) { /* ## IV > IV ## */
1509 IV aiv = SvIVX(TOPm1s);
1510 IV biv = SvIVX(TOPs);
1513 SETs(boolSV(aiv > biv));
1516 if (auvok && buvok) { /* ## UV > UV ## */
1517 UV auv = SvUVX(TOPm1s);
1518 UV buv = SvUVX(TOPs);
1521 SETs(boolSV(auv > buv));
1524 if (auvok) { /* ## UV > IV ## */
1531 /* As (a) is a UV, it's >=0, so it must be > */
1536 if (auv > (UV) IV_MAX) {
1537 /* As (b) is an IV, it cannot be > IV_MAX */
1541 SETs(boolSV(auv > (UV)biv));
1544 { /* ## IV > UV ## */
1548 aiv = SvIVX(TOPm1s);
1550 /* As (b) is a UV, it's >=0, so it cannot be > */
1557 if (buv >= (UV) IV_MAX) {
1558 /* As (a) is an IV, it cannot be > IV_MAX */
1562 SETs(boolSV((UV)aiv > buv));
1570 SETs(boolSV(TOPn > value));
1577 djSP; tryAMAGICbinSET(le,0);
1578 #ifdef PERL_PRESERVE_IVUV
1581 SvIV_please(TOPm1s);
1582 if (SvIOK(TOPm1s)) {
1583 bool auvok = SvUOK(TOPm1s);
1584 bool buvok = SvUOK(TOPs);
1586 if (!auvok && !buvok) { /* ## IV <= IV ## */
1587 IV aiv = SvIVX(TOPm1s);
1588 IV biv = SvIVX(TOPs);
1591 SETs(boolSV(aiv <= biv));
1594 if (auvok && buvok) { /* ## UV <= UV ## */
1595 UV auv = SvUVX(TOPm1s);
1596 UV buv = SvUVX(TOPs);
1599 SETs(boolSV(auv <= buv));
1602 if (auvok) { /* ## UV <= IV ## */
1609 /* As (a) is a UV, it's >=0, so a cannot be <= */
1614 if (auv > (UV) IV_MAX) {
1615 /* As (b) is an IV, it cannot be > IV_MAX */
1619 SETs(boolSV(auv <= (UV)biv));
1622 { /* ## IV <= UV ## */
1626 aiv = SvIVX(TOPm1s);
1628 /* As (b) is a UV, it's >=0, so a must be <= */
1635 if (buv >= (UV) IV_MAX) {
1636 /* As (a) is an IV, it cannot be > IV_MAX */
1640 SETs(boolSV((UV)aiv <= buv));
1648 SETs(boolSV(TOPn <= value));
1655 djSP; tryAMAGICbinSET(ge,0);
1656 #ifdef PERL_PRESERVE_IVUV
1659 SvIV_please(TOPm1s);
1660 if (SvIOK(TOPm1s)) {
1661 bool auvok = SvUOK(TOPm1s);
1662 bool buvok = SvUOK(TOPs);
1664 if (!auvok && !buvok) { /* ## IV >= IV ## */
1665 IV aiv = SvIVX(TOPm1s);
1666 IV biv = SvIVX(TOPs);
1669 SETs(boolSV(aiv >= biv));
1672 if (auvok && buvok) { /* ## UV >= UV ## */
1673 UV auv = SvUVX(TOPm1s);
1674 UV buv = SvUVX(TOPs);
1677 SETs(boolSV(auv >= buv));
1680 if (auvok) { /* ## UV >= IV ## */
1687 /* As (a) is a UV, it's >=0, so it must be >= */
1692 if (auv >= (UV) IV_MAX) {
1693 /* As (b) is an IV, it cannot be > IV_MAX */
1697 SETs(boolSV(auv >= (UV)biv));
1700 { /* ## IV >= UV ## */
1704 aiv = SvIVX(TOPm1s);
1706 /* As (b) is a UV, it's >=0, so a cannot be >= */
1713 if (buv > (UV) IV_MAX) {
1714 /* As (a) is an IV, it cannot be > IV_MAX */
1718 SETs(boolSV((UV)aiv >= buv));
1726 SETs(boolSV(TOPn >= value));
1733 djSP; tryAMAGICbinSET(ne,0);
1734 #ifdef PERL_PRESERVE_IVUV
1737 SvIV_please(TOPm1s);
1738 if (SvIOK(TOPm1s)) {
1739 bool auvok = SvUOK(TOPm1s);
1740 bool buvok = SvUOK(TOPs);
1742 if (!auvok && !buvok) { /* ## IV <=> IV ## */
1743 IV aiv = SvIVX(TOPm1s);
1744 IV biv = SvIVX(TOPs);
1747 SETs(boolSV(aiv != biv));
1750 if (auvok && buvok) { /* ## UV != UV ## */
1751 UV auv = SvUVX(TOPm1s);
1752 UV buv = SvUVX(TOPs);
1755 SETs(boolSV(auv != buv));
1758 { /* ## Mixed IV,UV ## */
1762 /* != is commutative so swap if needed (save code) */
1764 /* swap. top of stack (b) is the iv */
1768 /* As (a) is a UV, it's >0, so it cannot be == */
1777 /* As (b) is a UV, it's >0, so it cannot be == */
1781 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
1783 /* we know iv is >= 0 */
1784 if (uv > (UV) IV_MAX) {
1788 SETs(boolSV((UV)iv != uv));
1796 SETs(boolSV(TOPn != value));
1803 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1804 #ifdef PERL_PRESERVE_IVUV
1805 /* Fortunately it seems NaN isn't IOK */
1808 SvIV_please(TOPm1s);
1809 if (SvIOK(TOPm1s)) {
1810 bool leftuvok = SvUOK(TOPm1s);
1811 bool rightuvok = SvUOK(TOPs);
1813 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
1814 IV leftiv = SvIVX(TOPm1s);
1815 IV rightiv = SvIVX(TOPs);
1817 if (leftiv > rightiv)
1819 else if (leftiv < rightiv)
1823 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
1824 UV leftuv = SvUVX(TOPm1s);
1825 UV rightuv = SvUVX(TOPs);
1827 if (leftuv > rightuv)
1829 else if (leftuv < rightuv)
1833 } else if (leftuvok) { /* ## UV <=> IV ## */
1837 rightiv = SvIVX(TOPs);
1839 /* As (a) is a UV, it's >=0, so it cannot be < */
1842 leftuv = SvUVX(TOPm1s);
1843 if (leftuv > (UV) IV_MAX) {
1844 /* As (b) is an IV, it cannot be > IV_MAX */
1846 } else if (leftuv > (UV)rightiv) {
1848 } else if (leftuv < (UV)rightiv) {
1854 } else { /* ## IV <=> UV ## */
1858 leftiv = SvIVX(TOPm1s);
1860 /* As (b) is a UV, it's >=0, so it must be < */
1863 rightuv = SvUVX(TOPs);
1864 if (rightuv > (UV) IV_MAX) {
1865 /* As (a) is an IV, it cannot be > IV_MAX */
1867 } else if (leftiv > (UV)rightuv) {
1869 } else if (leftiv < (UV)rightuv) {
1887 if (Perl_isnan(left) || Perl_isnan(right)) {
1891 value = (left > right) - (left < right);
1895 else if (left < right)
1897 else if (left > right)
1911 djSP; tryAMAGICbinSET(slt,0);
1914 int cmp = ((PL_op->op_private & OPpLOCALE)
1915 ? sv_cmp_locale(left, right)
1916 : sv_cmp(left, right));
1917 SETs(boolSV(cmp < 0));
1924 djSP; tryAMAGICbinSET(sgt,0);
1927 int cmp = ((PL_op->op_private & OPpLOCALE)
1928 ? sv_cmp_locale(left, right)
1929 : sv_cmp(left, right));
1930 SETs(boolSV(cmp > 0));
1937 djSP; tryAMAGICbinSET(sle,0);
1940 int cmp = ((PL_op->op_private & OPpLOCALE)
1941 ? sv_cmp_locale(left, right)
1942 : sv_cmp(left, right));
1943 SETs(boolSV(cmp <= 0));
1950 djSP; tryAMAGICbinSET(sge,0);
1953 int cmp = ((PL_op->op_private & OPpLOCALE)
1954 ? sv_cmp_locale(left, right)
1955 : sv_cmp(left, right));
1956 SETs(boolSV(cmp >= 0));
1963 djSP; tryAMAGICbinSET(seq,0);
1966 SETs(boolSV(sv_eq(left, right)));
1973 djSP; tryAMAGICbinSET(sne,0);
1976 SETs(boolSV(!sv_eq(left, right)));
1983 djSP; dTARGET; tryAMAGICbin(scmp,0);
1986 int cmp = ((PL_op->op_private & OPpLOCALE)
1987 ? sv_cmp_locale(left, right)
1988 : sv_cmp(left, right));
1996 djSP; dATARGET; tryAMAGICbin(band,opASSIGN);
1999 if (SvNIOKp(left) || SvNIOKp(right)) {
2000 if (PL_op->op_private & HINT_INTEGER) {
2001 IV i = SvIV(left) & SvIV(right);
2005 UV u = SvUV(left) & SvUV(right);
2010 do_vop(PL_op->op_type, TARG, left, right);
2019 djSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
2022 if (SvNIOKp(left) || SvNIOKp(right)) {
2023 if (PL_op->op_private & HINT_INTEGER) {
2024 IV i = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
2028 UV u = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
2033 do_vop(PL_op->op_type, TARG, left, right);
2042 djSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
2045 if (SvNIOKp(left) || SvNIOKp(right)) {
2046 if (PL_op->op_private & HINT_INTEGER) {
2047 IV i = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
2051 UV u = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
2056 do_vop(PL_op->op_type, TARG, left, right);
2065 djSP; dTARGET; tryAMAGICun(neg);
2068 int flags = SvFLAGS(sv);
2071 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2072 /* It's publicly an integer, or privately an integer-not-float */
2075 if (SvIVX(sv) == IV_MIN) {
2076 /* 2s complement assumption. */
2077 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2080 else if (SvUVX(sv) <= IV_MAX) {
2085 else if (SvIVX(sv) != IV_MIN) {
2089 #ifdef PERL_PRESERVE_IVUV
2098 else if (SvPOKp(sv)) {
2100 char *s = SvPV(sv, len);
2101 if (isIDFIRST(*s)) {
2102 sv_setpvn(TARG, "-", 1);
2105 else if (*s == '+' || *s == '-') {
2107 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2109 else if (DO_UTF8(sv) && UTF8_IS_START(*s) && isIDFIRST_utf8((U8*)s)) {
2110 sv_setpvn(TARG, "-", 1);
2116 goto oops_its_an_int;
2117 sv_setnv(TARG, -SvNV(sv));
2129 djSP; tryAMAGICunSET(not);
2130 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2136 djSP; dTARGET; tryAMAGICun(compl);
2140 if (PL_op->op_private & HINT_INTEGER) {
2155 tmps = (U8*)SvPV_force(TARG, len);
2158 /* Calculate exact length, let's not estimate. */
2167 while (tmps < send) {
2168 UV c = utf8_to_uv(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2169 tmps += UTF8SKIP(tmps);
2170 targlen += UNISKIP(~c);
2176 /* Now rewind strings and write them. */
2180 Newz(0, result, targlen + 1, U8);
2181 while (tmps < send) {
2182 UV c = utf8_to_uv(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2183 tmps += UTF8SKIP(tmps);
2184 result = uv_to_utf8(result, ~c);
2188 sv_setpvn(TARG, (char*)result, targlen);
2192 Newz(0, result, nchar + 1, U8);
2193 while (tmps < send) {
2194 U8 c = (U8)utf8_to_uv(tmps, 0, &l, UTF8_ALLOW_ANY);
2195 tmps += UTF8SKIP(tmps);
2200 sv_setpvn(TARG, (char*)result, nchar);
2208 register long *tmpl;
2209 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2212 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2217 for ( ; anum > 0; anum--, tmps++)
2226 /* integer versions of some of the above */
2230 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2233 SETi( left * right );
2240 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2244 DIE(aTHX_ "Illegal division by zero");
2245 value = POPi / value;
2253 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2257 DIE(aTHX_ "Illegal modulus zero");
2258 SETi( left % right );
2265 djSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2268 SETi( left + right );
2275 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2278 SETi( left - right );
2285 djSP; tryAMAGICbinSET(lt,0);
2288 SETs(boolSV(left < right));
2295 djSP; tryAMAGICbinSET(gt,0);
2298 SETs(boolSV(left > right));
2305 djSP; tryAMAGICbinSET(le,0);
2308 SETs(boolSV(left <= right));
2315 djSP; tryAMAGICbinSET(ge,0);
2318 SETs(boolSV(left >= right));
2325 djSP; tryAMAGICbinSET(eq,0);
2328 SETs(boolSV(left == right));
2335 djSP; tryAMAGICbinSET(ne,0);
2338 SETs(boolSV(left != right));
2345 djSP; dTARGET; tryAMAGICbin(ncmp,0);
2352 else if (left < right)
2363 djSP; dTARGET; tryAMAGICun(neg);
2368 /* High falutin' math. */
2372 djSP; dTARGET; tryAMAGICbin(atan2,0);
2375 SETn(Perl_atan2(left, right));
2382 djSP; dTARGET; tryAMAGICun(sin);
2386 value = Perl_sin(value);
2394 djSP; dTARGET; tryAMAGICun(cos);
2398 value = Perl_cos(value);
2404 /* Support Configure command-line overrides for rand() functions.
2405 After 5.005, perhaps we should replace this by Configure support
2406 for drand48(), random(), or rand(). For 5.005, though, maintain
2407 compatibility by calling rand() but allow the user to override it.
2408 See INSTALL for details. --Andy Dougherty 15 July 1998
2410 /* Now it's after 5.005, and Configure supports drand48() and random(),
2411 in addition to rand(). So the overrides should not be needed any more.
2412 --Jarkko Hietaniemi 27 September 1998
2415 #ifndef HAS_DRAND48_PROTO
2416 extern double drand48 (void);
2429 if (!PL_srand_called) {
2430 (void)seedDrand01((Rand_seed_t)seed());
2431 PL_srand_called = TRUE;
2446 (void)seedDrand01((Rand_seed_t)anum);
2447 PL_srand_called = TRUE;
2456 * This is really just a quick hack which grabs various garbage
2457 * values. It really should be a real hash algorithm which
2458 * spreads the effect of every input bit onto every output bit,
2459 * if someone who knows about such things would bother to write it.
2460 * Might be a good idea to add that function to CORE as well.
2461 * No numbers below come from careful analysis or anything here,
2462 * except they are primes and SEED_C1 > 1E6 to get a full-width
2463 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
2464 * probably be bigger too.
2467 # define SEED_C1 1000003
2468 #define SEED_C4 73819
2470 # define SEED_C1 25747
2471 #define SEED_C4 20639
2475 #define SEED_C5 26107
2477 #ifndef PERL_NO_DEV_RANDOM
2482 # include <starlet.h>
2483 /* when[] = (low 32 bits, high 32 bits) of time since epoch
2484 * in 100-ns units, typically incremented ever 10 ms. */
2485 unsigned int when[2];
2487 # ifdef HAS_GETTIMEOFDAY
2488 struct timeval when;
2494 /* This test is an escape hatch, this symbol isn't set by Configure. */
2495 #ifndef PERL_NO_DEV_RANDOM
2496 #ifndef PERL_RANDOM_DEVICE
2497 /* /dev/random isn't used by default because reads from it will block
2498 * if there isn't enough entropy available. You can compile with
2499 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
2500 * is enough real entropy to fill the seed. */
2501 # define PERL_RANDOM_DEVICE "/dev/urandom"
2503 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
2505 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
2514 _ckvmssts(sys$gettim(when));
2515 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
2517 # ifdef HAS_GETTIMEOFDAY
2518 gettimeofday(&when,(struct timezone *) 0);
2519 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
2522 u = (U32)SEED_C1 * when;
2525 u += SEED_C3 * (U32)PerlProc_getpid();
2526 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
2527 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
2528 u += SEED_C5 * (U32)PTR2UV(&when);
2535 djSP; dTARGET; tryAMAGICun(exp);
2539 value = Perl_exp(value);
2547 djSP; dTARGET; tryAMAGICun(log);
2552 SET_NUMERIC_STANDARD();
2553 DIE(aTHX_ "Can't take log of %g", value);
2555 value = Perl_log(value);
2563 djSP; dTARGET; tryAMAGICun(sqrt);
2568 SET_NUMERIC_STANDARD();
2569 DIE(aTHX_ "Can't take sqrt of %g", value);
2571 value = Perl_sqrt(value);
2582 IV iv = TOPi; /* attempt to convert to IV if possible. */
2583 /* XXX it's arguable that compiler casting to IV might be subtly
2584 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2585 else preferring IV has introduced a subtle behaviour change bug. OTOH
2586 relying on floating point to be accurate is a bug. */
2597 if (value < (NV)UV_MAX + 0.5) {
2600 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2601 (void)Perl_modf(value, &value);
2603 double tmp = (double)value;
2604 (void)Perl_modf(tmp, &tmp);
2610 if (value > (NV)IV_MIN - 0.5) {
2613 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2614 (void)Perl_modf(-value, &value);
2617 double tmp = (double)value;
2618 (void)Perl_modf(-tmp, &tmp);
2631 djSP; dTARGET; tryAMAGICun(abs);
2633 /* This will cache the NV value if string isn't actually integer */
2637 /* IVX is precise */
2639 SETu(TOPu); /* force it to be numeric only */
2647 /* 2s complement assumption. Also, not really needed as
2648 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2671 argtype = 1; /* allow underscores */
2672 XPUSHn(scan_hex(tmps, 99, &argtype));
2685 while (*tmps && isSPACE(*tmps))
2689 argtype = 1; /* allow underscores */
2691 value = scan_hex(++tmps, 99, &argtype);
2692 else if (*tmps == 'b')
2693 value = scan_bin(++tmps, 99, &argtype);
2695 value = scan_oct(tmps, 99, &argtype);
2708 SETi(sv_len_utf8(sv));
2724 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2726 I32 arybase = PL_curcop->cop_arybase;
2729 int num_args = PL_op->op_private & 7;
2731 SvTAINTED_off(TARG); /* decontaminate */
2732 SvUTF8_off(TARG); /* decontaminate */
2736 repl = SvPV(sv, repl_len);
2743 tmps = SvPV(sv, curlen);
2745 utfcurlen = sv_len_utf8(sv);
2746 if (utfcurlen == curlen)
2754 if (pos >= arybase) {
2772 else if (len >= 0) {
2774 if (rem > (I32)curlen)
2789 Perl_croak(aTHX_ "substr outside of string");
2790 if (ckWARN(WARN_SUBSTR))
2791 Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string");
2796 sv_pos_u2b(sv, &pos, &rem);
2798 sv_setpvn(TARG, tmps, rem);
2802 sv_insert(sv, pos, rem, repl, repl_len);
2803 else if (lvalue) { /* it's an lvalue! */
2804 if (!SvGMAGICAL(sv)) {
2808 if (ckWARN(WARN_SUBSTR))
2809 Perl_warner(aTHX_ WARN_SUBSTR,
2810 "Attempt to use reference as lvalue in substr");
2812 if (SvOK(sv)) /* is it defined ? */
2813 (void)SvPOK_only_UTF8(sv);
2815 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
2818 if (SvTYPE(TARG) < SVt_PVLV) {
2819 sv_upgrade(TARG, SVt_PVLV);
2820 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
2824 if (LvTARG(TARG) != sv) {
2826 SvREFCNT_dec(LvTARG(TARG));
2827 LvTARG(TARG) = SvREFCNT_inc(sv);
2829 LvTARGOFF(TARG) = pos;
2830 LvTARGLEN(TARG) = rem;
2834 PUSHs(TARG); /* avoid SvSETMAGIC here */
2841 register IV size = POPi;
2842 register IV offset = POPi;
2843 register SV *src = POPs;
2844 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2846 SvTAINTED_off(TARG); /* decontaminate */
2847 if (lvalue) { /* it's an lvalue! */
2848 if (SvTYPE(TARG) < SVt_PVLV) {
2849 sv_upgrade(TARG, SVt_PVLV);
2850 sv_magic(TARG, Nullsv, 'v', Nullch, 0);
2853 if (LvTARG(TARG) != src) {
2855 SvREFCNT_dec(LvTARG(TARG));
2856 LvTARG(TARG) = SvREFCNT_inc(src);
2858 LvTARGOFF(TARG) = offset;
2859 LvTARGLEN(TARG) = size;
2862 sv_setuv(TARG, do_vecget(src, offset, size));
2877 I32 arybase = PL_curcop->cop_arybase;
2882 offset = POPi - arybase;
2885 tmps = SvPV(big, biglen);
2886 if (offset > 0 && DO_UTF8(big))
2887 sv_pos_u2b(big, &offset, 0);
2890 else if (offset > biglen)
2892 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2893 (unsigned char*)tmps + biglen, little, 0)))
2896 retval = tmps2 - tmps;
2897 if (retval > 0 && DO_UTF8(big))
2898 sv_pos_b2u(big, &retval);
2899 PUSHi(retval + arybase);
2914 I32 arybase = PL_curcop->cop_arybase;
2920 tmps2 = SvPV(little, llen);
2921 tmps = SvPV(big, blen);
2925 if (offset > 0 && DO_UTF8(big))
2926 sv_pos_u2b(big, &offset, 0);
2927 offset = offset - arybase + llen;
2931 else if (offset > blen)
2933 if (!(tmps2 = rninstr(tmps, tmps + offset,
2934 tmps2, tmps2 + llen)))
2937 retval = tmps2 - tmps;
2938 if (retval > 0 && DO_UTF8(big))
2939 sv_pos_b2u(big, &retval);
2940 PUSHi(retval + arybase);
2946 djSP; dMARK; dORIGMARK; dTARGET;
2947 do_sprintf(TARG, SP-MARK, MARK+1);
2948 TAINT_IF(SvTAINTED(TARG));
2959 U8 *s = (U8*)SvPVx(argsv, len);
2961 XPUSHu(DO_UTF8(argsv) ? utf8_to_uv_simple(s, 0) : (*s & 0xff));
2971 (void)SvUPGRADE(TARG,SVt_PV);
2973 if ((value > 255 && !IN_BYTE) ||
2974 (UTF8_IS_CONTINUED(value) && (PL_hints & HINT_UTF8)) ) {
2975 SvGROW(TARG, UTF8_MAXLEN+1);
2977 tmps = (char*)uv_to_utf8((U8*)tmps, (UV)value);
2978 SvCUR_set(TARG, tmps - SvPVX(TARG));
2980 (void)SvPOK_only(TARG);
2994 (void)SvPOK_only(TARG);
3001 djSP; dTARGET; dPOPTOPssrl;
3004 char *tmps = SvPV(left, n_a);
3006 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
3008 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
3012 "The crypt() function is unimplemented due to excessive paranoia.");
3025 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
3027 U8 tmpbuf[UTF8_MAXLEN+1];
3029 UV uv = utf8_to_uv(s, slen, &ulen, 0);
3031 if (PL_op->op_private & OPpLOCALE) {
3034 uv = toTITLE_LC_uni(uv);
3037 uv = toTITLE_utf8(s);
3039 tend = uv_to_utf8(tmpbuf, uv);
3041 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
3043 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3044 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3049 s = (U8*)SvPV_force(sv, slen);
3050 Copy(tmpbuf, s, ulen, U8);
3054 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3056 SvUTF8_off(TARG); /* decontaminate */
3061 s = (U8*)SvPV_force(sv, slen);
3063 if (PL_op->op_private & OPpLOCALE) {
3066 *s = toUPPER_LC(*s);
3084 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
3086 U8 tmpbuf[UTF8_MAXLEN+1];
3088 UV uv = utf8_to_uv(s, slen, &ulen, 0);
3090 if (PL_op->op_private & OPpLOCALE) {
3093 uv = toLOWER_LC_uni(uv);
3096 uv = toLOWER_utf8(s);
3098 tend = uv_to_utf8(tmpbuf, uv);
3100 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
3102 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3103 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3108 s = (U8*)SvPV_force(sv, slen);
3109 Copy(tmpbuf, s, ulen, U8);
3113 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3115 SvUTF8_off(TARG); /* decontaminate */
3120 s = (U8*)SvPV_force(sv, slen);
3122 if (PL_op->op_private & OPpLOCALE) {
3125 *s = toLOWER_LC(*s);
3149 s = (U8*)SvPV(sv,len);
3151 SvUTF8_off(TARG); /* decontaminate */
3152 sv_setpvn(TARG, "", 0);
3156 (void)SvUPGRADE(TARG, SVt_PV);
3157 SvGROW(TARG, (len * 2) + 1);
3158 (void)SvPOK_only(TARG);
3159 d = (U8*)SvPVX(TARG);
3161 if (PL_op->op_private & OPpLOCALE) {
3165 d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, len, &ulen, 0)));
3171 d = uv_to_utf8(d, toUPPER_utf8( s ));
3177 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3182 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3184 SvUTF8_off(TARG); /* decontaminate */
3189 s = (U8*)SvPV_force(sv, len);
3191 register U8 *send = s + len;
3193 if (PL_op->op_private & OPpLOCALE) {
3196 for (; s < send; s++)
3197 *s = toUPPER_LC(*s);
3200 for (; s < send; s++)
3223 s = (U8*)SvPV(sv,len);
3225 SvUTF8_off(TARG); /* decontaminate */
3226 sv_setpvn(TARG, "", 0);
3230 (void)SvUPGRADE(TARG, SVt_PV);
3231 SvGROW(TARG, (len * 2) + 1);
3232 (void)SvPOK_only(TARG);
3233 d = (U8*)SvPVX(TARG);
3235 if (PL_op->op_private & OPpLOCALE) {
3239 d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, len, &ulen, 0)));
3245 d = uv_to_utf8(d, toLOWER_utf8(s));
3251 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3256 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3258 SvUTF8_off(TARG); /* decontaminate */
3264 s = (U8*)SvPV_force(sv, len);
3266 register U8 *send = s + len;
3268 if (PL_op->op_private & OPpLOCALE) {
3271 for (; s < send; s++)
3272 *s = toLOWER_LC(*s);
3275 for (; s < send; s++)
3290 register char *s = SvPV(sv,len);
3293 SvUTF8_off(TARG); /* decontaminate */
3295 (void)SvUPGRADE(TARG, SVt_PV);
3296 SvGROW(TARG, (len * 2) + 1);
3300 if (UTF8_IS_CONTINUED(*s)) {
3301 STRLEN ulen = UTF8SKIP(s);
3325 SvCUR_set(TARG, d - SvPVX(TARG));
3326 (void)SvPOK_only_UTF8(TARG);
3329 sv_setpvn(TARG, s, len);
3331 if (SvSMAGICAL(TARG))
3340 djSP; dMARK; dORIGMARK;
3342 register AV* av = (AV*)POPs;
3343 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3344 I32 arybase = PL_curcop->cop_arybase;
3347 if (SvTYPE(av) == SVt_PVAV) {
3348 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3350 for (svp = MARK + 1; svp <= SP; svp++) {
3355 if (max > AvMAX(av))
3358 while (++MARK <= SP) {
3359 elem = SvIVx(*MARK);
3363 svp = av_fetch(av, elem, lval);
3365 if (!svp || *svp == &PL_sv_undef)
3366 DIE(aTHX_ PL_no_aelem, elem);
3367 if (PL_op->op_private & OPpLVAL_INTRO)
3368 save_aelem(av, elem, svp);
3370 *MARK = svp ? *svp : &PL_sv_undef;
3373 if (GIMME != G_ARRAY) {
3381 /* Associative arrays. */
3386 HV *hash = (HV*)POPs;
3388 I32 gimme = GIMME_V;
3389 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
3392 /* might clobber stack_sp */
3393 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
3398 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
3399 if (gimme == G_ARRAY) {
3402 /* might clobber stack_sp */
3404 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
3409 else if (gimme == G_SCALAR)
3428 I32 gimme = GIMME_V;
3429 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3433 if (PL_op->op_private & OPpSLICE) {
3437 hvtype = SvTYPE(hv);
3438 if (hvtype == SVt_PVHV) { /* hash element */
3439 while (++MARK <= SP) {
3440 sv = hv_delete_ent(hv, *MARK, discard, 0);
3441 *MARK = sv ? sv : &PL_sv_undef;
3444 else if (hvtype == SVt_PVAV) {
3445 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3446 while (++MARK <= SP) {
3447 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3448 *MARK = sv ? sv : &PL_sv_undef;
3451 else { /* pseudo-hash element */
3452 while (++MARK <= SP) {
3453 sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
3454 *MARK = sv ? sv : &PL_sv_undef;
3459 DIE(aTHX_ "Not a HASH reference");
3462 else if (gimme == G_SCALAR) {
3471 if (SvTYPE(hv) == SVt_PVHV)
3472 sv = hv_delete_ent(hv, keysv, discard, 0);
3473 else if (SvTYPE(hv) == SVt_PVAV) {
3474 if (PL_op->op_flags & OPf_SPECIAL)
3475 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3477 sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
3480 DIE(aTHX_ "Not a HASH reference");
3495 if (PL_op->op_private & OPpEXISTS_SUB) {
3499 cv = sv_2cv(sv, &hv, &gv, FALSE);
3502 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3508 if (SvTYPE(hv) == SVt_PVHV) {
3509 if (hv_exists_ent(hv, tmpsv, 0))
3512 else if (SvTYPE(hv) == SVt_PVAV) {
3513 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3514 if (av_exists((AV*)hv, SvIV(tmpsv)))
3517 else if (avhv_exists_ent((AV*)hv, tmpsv, 0)) /* pseudo-hash element */
3521 DIE(aTHX_ "Not a HASH reference");
3528 djSP; dMARK; dORIGMARK;
3529 register HV *hv = (HV*)POPs;
3530 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3531 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
3533 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
3534 DIE(aTHX_ "Can't localize pseudo-hash element");
3536 if (realhv || SvTYPE(hv) == SVt_PVAV) {
3537 while (++MARK <= SP) {
3540 I32 preeminent = SvRMAGICAL(hv) ? 1 : hv_exists_ent(hv, keysv, 0);
3542 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
3543 svp = he ? &HeVAL(he) : 0;
3546 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
3549 if (!svp || *svp == &PL_sv_undef) {
3551 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3553 if (PL_op->op_private & OPpLVAL_INTRO) {
3555 save_helem(hv, keysv, svp);
3558 char *key = SvPV(keysv, keylen);
3559 SAVEDELETE(hv, savepvn(key,keylen), keylen);
3563 *MARK = svp ? *svp : &PL_sv_undef;
3566 if (GIMME != G_ARRAY) {
3574 /* List operators. */
3579 if (GIMME != G_ARRAY) {
3581 *MARK = *SP; /* unwanted list, return last item */
3583 *MARK = &PL_sv_undef;
3592 SV **lastrelem = PL_stack_sp;
3593 SV **lastlelem = PL_stack_base + POPMARK;
3594 SV **firstlelem = PL_stack_base + POPMARK + 1;
3595 register SV **firstrelem = lastlelem + 1;
3596 I32 arybase = PL_curcop->cop_arybase;
3597 I32 lval = PL_op->op_flags & OPf_MOD;
3598 I32 is_something_there = lval;
3600 register I32 max = lastrelem - lastlelem;
3601 register SV **lelem;
3604 if (GIMME != G_ARRAY) {
3605 ix = SvIVx(*lastlelem);
3610 if (ix < 0 || ix >= max)
3611 *firstlelem = &PL_sv_undef;
3613 *firstlelem = firstrelem[ix];
3619 SP = firstlelem - 1;
3623 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3629 if (ix < 0 || ix >= max)
3630 *lelem = &PL_sv_undef;
3632 is_something_there = TRUE;
3633 if (!(*lelem = firstrelem[ix]))
3634 *lelem = &PL_sv_undef;
3637 if (is_something_there)
3640 SP = firstlelem - 1;
3646 djSP; dMARK; dORIGMARK;
3647 I32 items = SP - MARK;
3648 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
3649 SP = ORIGMARK; /* av_make() might realloc stack_sp */
3656 djSP; dMARK; dORIGMARK;
3657 HV* hv = (HV*)sv_2mortal((SV*)newHV());
3661 SV *val = NEWSV(46, 0);
3663 sv_setsv(val, *++MARK);
3664 else if (ckWARN(WARN_MISC))
3665 Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
3666 (void)hv_store_ent(hv,key,val,0);
3675 djSP; dMARK; dORIGMARK;
3676 register AV *ary = (AV*)*++MARK;
3680 register I32 offset;
3681 register I32 length;
3688 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3689 *MARK-- = SvTIED_obj((SV*)ary, mg);
3693 call_method("SPLICE",GIMME_V);
3702 offset = i = SvIVx(*MARK);
3704 offset += AvFILLp(ary) + 1;
3706 offset -= PL_curcop->cop_arybase;
3708 DIE(aTHX_ PL_no_aelem, i);
3710 length = SvIVx(*MARK++);
3712 length += AvFILLp(ary) - offset + 1;
3718 length = AvMAX(ary) + 1; /* close enough to infinity */
3722 length = AvMAX(ary) + 1;
3724 if (offset > AvFILLp(ary) + 1)
3725 offset = AvFILLp(ary) + 1;
3726 after = AvFILLp(ary) + 1 - (offset + length);
3727 if (after < 0) { /* not that much array */
3728 length += after; /* offset+length now in array */
3734 /* At this point, MARK .. SP-1 is our new LIST */
3737 diff = newlen - length;
3738 if (newlen && !AvREAL(ary) && AvREIFY(ary))
3741 if (diff < 0) { /* shrinking the area */
3743 New(451, tmparyval, newlen, SV*); /* so remember insertion */
3744 Copy(MARK, tmparyval, newlen, SV*);
3747 MARK = ORIGMARK + 1;
3748 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3749 MEXTEND(MARK, length);
3750 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
3752 EXTEND_MORTAL(length);
3753 for (i = length, dst = MARK; i; i--) {
3754 sv_2mortal(*dst); /* free them eventualy */
3761 *MARK = AvARRAY(ary)[offset+length-1];
3764 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
3765 SvREFCNT_dec(*dst++); /* free them now */
3768 AvFILLp(ary) += diff;
3770 /* pull up or down? */
3772 if (offset < after) { /* easier to pull up */
3773 if (offset) { /* esp. if nothing to pull */
3774 src = &AvARRAY(ary)[offset-1];
3775 dst = src - diff; /* diff is negative */
3776 for (i = offset; i > 0; i--) /* can't trust Copy */
3780 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
3784 if (after) { /* anything to pull down? */
3785 src = AvARRAY(ary) + offset + length;
3786 dst = src + diff; /* diff is negative */
3787 Move(src, dst, after, SV*);
3789 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
3790 /* avoid later double free */
3794 dst[--i] = &PL_sv_undef;
3797 for (src = tmparyval, dst = AvARRAY(ary) + offset;
3799 *dst = NEWSV(46, 0);
3800 sv_setsv(*dst++, *src++);
3802 Safefree(tmparyval);
3805 else { /* no, expanding (or same) */
3807 New(452, tmparyval, length, SV*); /* so remember deletion */
3808 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
3811 if (diff > 0) { /* expanding */
3813 /* push up or down? */
3815 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
3819 Move(src, dst, offset, SV*);
3821 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
3823 AvFILLp(ary) += diff;
3826 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
3827 av_extend(ary, AvFILLp(ary) + diff);
3828 AvFILLp(ary) += diff;
3831 dst = AvARRAY(ary) + AvFILLp(ary);
3833 for (i = after; i; i--) {
3840 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3841 *dst = NEWSV(46, 0);
3842 sv_setsv(*dst++, *src++);
3844 MARK = ORIGMARK + 1;
3845 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3847 Copy(tmparyval, MARK, length, SV*);
3849 EXTEND_MORTAL(length);
3850 for (i = length, dst = MARK; i; i--) {
3851 sv_2mortal(*dst); /* free them eventualy */
3855 Safefree(tmparyval);
3859 else if (length--) {
3860 *MARK = tmparyval[length];
3863 while (length-- > 0)
3864 SvREFCNT_dec(tmparyval[length]);
3866 Safefree(tmparyval);
3869 *MARK = &PL_sv_undef;
3877 djSP; dMARK; dORIGMARK; dTARGET;
3878 register AV *ary = (AV*)*++MARK;
3879 register SV *sv = &PL_sv_undef;
3882 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3883 *MARK-- = SvTIED_obj((SV*)ary, mg);
3887 call_method("PUSH",G_SCALAR|G_DISCARD);
3892 /* Why no pre-extend of ary here ? */
3893 for (++MARK; MARK <= SP; MARK++) {
3896 sv_setsv(sv, *MARK);
3901 PUSHi( AvFILL(ary) + 1 );
3909 SV *sv = av_pop(av);
3911 (void)sv_2mortal(sv);
3920 SV *sv = av_shift(av);
3925 (void)sv_2mortal(sv);
3932 djSP; dMARK; dORIGMARK; dTARGET;
3933 register AV *ary = (AV*)*++MARK;
3938 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3939 *MARK-- = SvTIED_obj((SV*)ary, mg);
3943 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3948 av_unshift(ary, SP - MARK);
3951 sv_setsv(sv, *++MARK);
3952 (void)av_store(ary, i++, sv);
3956 PUSHi( AvFILL(ary) + 1 );
3966 if (GIMME == G_ARRAY) {
3973 /* safe as long as stack cannot get extended in the above */
3978 register char *down;
3983 SvUTF8_off(TARG); /* decontaminate */
3985 do_join(TARG, &PL_sv_no, MARK, SP);
3987 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
3988 up = SvPV_force(TARG, len);
3990 if (DO_UTF8(TARG)) { /* first reverse each character */
3991 U8* s = (U8*)SvPVX(TARG);
3992 U8* send = (U8*)(s + len);
3994 if (UTF8_IS_ASCII(*s)) {
3999 if (!utf8_to_uv_simple(s, 0))
4003 down = (char*)(s - 1);
4004 /* reverse this character */
4014 down = SvPVX(TARG) + len - 1;
4020 (void)SvPOK_only_UTF8(TARG);
4029 S_mul128(pTHX_ SV *sv, U8 m)
4032 char *s = SvPV(sv, len);
4036 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
4037 SV *tmpNew = newSVpvn("0000000000", 10);
4039 sv_catsv(tmpNew, sv);
4040 SvREFCNT_dec(sv); /* free old sv */
4045 while (!*t) /* trailing '\0'? */
4048 i = ((*t - '0') << 7) + m;
4049 *(t--) = '0' + (i % 10);
4055 /* Explosives and implosives. */
4057 #if 'I' == 73 && 'J' == 74
4058 /* On an ASCII/ISO kind of system */
4059 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
4062 Some other sort of character set - use memchr() so we don't match
4065 #define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
4072 I32 start_sp_offset = SP - PL_stack_base;
4073 I32 gimme = GIMME_V;
4077 register char *pat = SvPV(left, llen);
4078 register char *s = SvPV(right, rlen);
4079 char *strend = s + rlen;
4081 register char *patend = pat + llen;
4087 /* These must not be in registers: */
4104 register U32 culong;
4108 #ifdef PERL_NATINT_PACK
4109 int natint; /* native integer */
4110 int unatint; /* unsigned native integer */
4113 if (gimme != G_ARRAY) { /* arrange to do first one only */
4115 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
4116 if (strchr("aAZbBhHP", *patend) || *pat == '%') {
4118 while (isDIGIT(*patend) || *patend == '*')
4124 while (pat < patend) {
4126 datumtype = *pat++ & 0xFF;
4127 #ifdef PERL_NATINT_PACK
4130 if (isSPACE(datumtype))
4132 if (datumtype == '#') {
4133 while (pat < patend && *pat != '\n')
4138 char *natstr = "sSiIlL";
4140 if (strchr(natstr, datumtype)) {
4141 #ifdef PERL_NATINT_PACK
4147 DIE(aTHX_ "'!' allowed only after types %s", natstr);
4152 else if (*pat == '*') {
4153 len = strend - strbeg; /* long enough */
4157 else if (isDIGIT(*pat)) {
4159 while (isDIGIT(*pat)) {
4160 len = (len * 10) + (*pat++ - '0');
4162 DIE(aTHX_ "Repeat count in unpack overflows");
4166 len = (datumtype != '@');
4170 DIE(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
4171 case ',': /* grandfather in commas but with a warning */
4172 if (commas++ == 0 && ckWARN(WARN_UNPACK))
4173 Perl_warner(aTHX_ WARN_UNPACK,
4174 "Invalid type in unpack: '%c'", (int)datumtype);
4177 if (len == 1 && pat[-1] != '1')
4186 if (len > strend - strbeg)
4187 DIE(aTHX_ "@ outside of string");
4191 if (len > s - strbeg)
4192 DIE(aTHX_ "X outside of string");
4196 if (len > strend - s)
4197 DIE(aTHX_ "x outside of string");
4201 if (start_sp_offset >= SP - PL_stack_base)
4202 DIE(aTHX_ "/ must follow a numeric type");
4205 pat++; /* ignore '*' for compatibility with pack */
4207 DIE(aTHX_ "/ cannot take a count" );
4214 if (len > strend - s)
4217 goto uchar_checksum;
4218 sv = NEWSV(35, len);
4219 sv_setpvn(sv, s, len);
4221 if (datumtype == 'A' || datumtype == 'Z') {
4222 aptr = s; /* borrow register */
4223 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
4228 else { /* 'A' strips both nulls and spaces */
4229 s = SvPVX(sv) + len - 1;
4230 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
4234 SvCUR_set(sv, s - SvPVX(sv));
4235 s = aptr; /* unborrow register */
4237 XPUSHs(sv_2mortal(sv));
4241 if (star || len > (strend - s) * 8)
4242 len = (strend - s) * 8;
4245 Newz(601, PL_bitcount, 256, char);
4246 for (bits = 1; bits < 256; bits++) {
4247 if (bits & 1) PL_bitcount[bits]++;
4248 if (bits & 2) PL_bitcount[bits]++;
4249 if (bits & 4) PL_bitcount[bits]++;
4250 if (bits & 8) PL_bitcount[bits]++;
4251 if (bits & 16) PL_bitcount[bits]++;
4252 if (bits & 32) PL_bitcount[bits]++;
4253 if (bits & 64) PL_bitcount[bits]++;
4254 if (bits & 128) PL_bitcount[bits]++;
4258 culong += PL_bitcount[*(unsigned char*)s++];
4263 if (datumtype == 'b') {
4265 if (bits & 1) culong++;
4271 if (bits & 128) culong++;
4278 sv = NEWSV(35, len + 1);
4282 if (datumtype == 'b') {
4284 for (len = 0; len < aint; len++) {
4285 if (len & 7) /*SUPPRESS 595*/
4289 *str++ = '0' + (bits & 1);
4294 for (len = 0; len < aint; len++) {
4299 *str++ = '0' + ((bits & 128) != 0);
4303 XPUSHs(sv_2mortal(sv));
4307 if (star || len > (strend - s) * 2)
4308 len = (strend - s) * 2;
4309 sv = NEWSV(35, len + 1);
4313 if (datumtype == 'h') {
4315 for (len = 0; len < aint; len++) {
4320 *str++ = PL_hexdigit[bits & 15];
4325 for (len = 0; len < aint; len++) {
4330 *str++ = PL_hexdigit[(bits >> 4) & 15];
4334 XPUSHs(sv_2mortal(sv));
4337 if (len > strend - s)
4342 if (aint >= 128) /* fake up signed chars */
4352 if (aint >= 128) /* fake up signed chars */
4355 sv_setiv(sv, (IV)aint);
4356 PUSHs(sv_2mortal(sv));
4361 if (len > strend - s)
4376 sv_setiv(sv, (IV)auint);
4377 PUSHs(sv_2mortal(sv));
4382 if (len > strend - s)
4385 while (len-- > 0 && s < strend) {
4387 auint = utf8_to_uv((U8*)s, strend - s, &alen, 0);
4391 cdouble += (NV)auint;
4399 while (len-- > 0 && s < strend) {
4401 auint = utf8_to_uv((U8*)s, strend - s, &alen, 0);
4405 sv_setuv(sv, (UV)auint);
4406 PUSHs(sv_2mortal(sv));
4411 #if SHORTSIZE == SIZE16
4412 along = (strend - s) / SIZE16;
4414 along = (strend - s) / (natint ? sizeof(short) : SIZE16);
4419 #if SHORTSIZE != SIZE16
4423 COPYNN(s, &ashort, sizeof(short));
4434 #if SHORTSIZE > SIZE16
4446 #if SHORTSIZE != SIZE16
4450 COPYNN(s, &ashort, sizeof(short));
4453 sv_setiv(sv, (IV)ashort);
4454 PUSHs(sv_2mortal(sv));
4462 #if SHORTSIZE > SIZE16
4468 sv_setiv(sv, (IV)ashort);
4469 PUSHs(sv_2mortal(sv));
4477 #if SHORTSIZE == SIZE16
4478 along = (strend - s) / SIZE16;
4480 unatint = natint && datumtype == 'S';
4481 along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
4486 #if SHORTSIZE != SIZE16
4488 unsigned short aushort;
4490 COPYNN(s, &aushort, sizeof(unsigned short));
4491 s += sizeof(unsigned short);
4499 COPY16(s, &aushort);
4502 if (datumtype == 'n')
4503 aushort = PerlSock_ntohs(aushort);
4506 if (datumtype == 'v')
4507 aushort = vtohs(aushort);
4516 #if SHORTSIZE != SIZE16
4518 unsigned short aushort;
4520 COPYNN(s, &aushort, sizeof(unsigned short));
4521 s += sizeof(unsigned short);
4523 sv_setiv(sv, (UV)aushort);
4524 PUSHs(sv_2mortal(sv));
4531 COPY16(s, &aushort);
4535 if (datumtype == 'n')
4536 aushort = PerlSock_ntohs(aushort);
4539 if (datumtype == 'v')
4540 aushort = vtohs(aushort);
4542 sv_setiv(sv, (UV)aushort);
4543 PUSHs(sv_2mortal(sv));
4549 along = (strend - s) / sizeof(int);
4554 Copy(s, &aint, 1, int);
4557 cdouble += (NV)aint;
4566 Copy(s, &aint, 1, int);
4570 /* Without the dummy below unpack("i", pack("i",-1))
4571 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
4572 * cc with optimization turned on.
4574 * The bug was detected in
4575 * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
4576 * with optimization (-O4) turned on.
4577 * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
4578 * does not have this problem even with -O4.
4580 * This bug was reported as DECC_BUGS 1431
4581 * and tracked internally as GEM_BUGS 7775.
4583 * The bug is fixed in
4584 * Tru64 UNIX V5.0: Compaq C V6.1-006 or later
4585 * UNIX V4.0F support: DEC C V5.9-006 or later
4586 * UNIX V4.0E support: DEC C V5.8-011 or later
4589 * See also few lines later for the same bug.
4592 sv_setiv(sv, (IV)aint) :
4594 sv_setiv(sv, (IV)aint);
4595 PUSHs(sv_2mortal(sv));
4600 along = (strend - s) / sizeof(unsigned int);
4605 Copy(s, &auint, 1, unsigned int);
4606 s += sizeof(unsigned int);
4608 cdouble += (NV)auint;
4617 Copy(s, &auint, 1, unsigned int);
4618 s += sizeof(unsigned int);
4621 /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
4622 * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
4623 * See details few lines earlier. */
4625 sv_setuv(sv, (UV)auint) :
4627 sv_setuv(sv, (UV)auint);
4628 PUSHs(sv_2mortal(sv));
4633 #if LONGSIZE == SIZE32
4634 along = (strend - s) / SIZE32;
4636 along = (strend - s) / (natint ? sizeof(long) : SIZE32);
4641 #if LONGSIZE != SIZE32
4644 COPYNN(s, &along, sizeof(long));
4647 cdouble += (NV)along;
4656 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
4660 #if LONGSIZE > SIZE32
4661 if (along > 2147483647)
4662 along -= 4294967296;
4666 cdouble += (NV)along;
4675 #if LONGSIZE != SIZE32
4678 COPYNN(s, &along, sizeof(long));
4681 sv_setiv(sv, (IV)along);
4682 PUSHs(sv_2mortal(sv));
4689 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
4693 #if LONGSIZE > SIZE32
4694 if (along > 2147483647)
4695 along -= 4294967296;
4699 sv_setiv(sv, (IV)along);
4700 PUSHs(sv_2mortal(sv));
4708 #if LONGSIZE == SIZE32
4709 along = (strend - s) / SIZE32;
4711 unatint = natint && datumtype == 'L';
4712 along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
4717 #if LONGSIZE != SIZE32
4719 unsigned long aulong;
4721 COPYNN(s, &aulong, sizeof(unsigned long));
4722 s += sizeof(unsigned long);
4724 cdouble += (NV)aulong;
4736 if (datumtype == 'N')
4737 aulong = PerlSock_ntohl(aulong);
4740 if (datumtype == 'V')
4741 aulong = vtohl(aulong);
4744 cdouble += (NV)aulong;
4753 #if LONGSIZE != SIZE32
4755 unsigned long aulong;
4757 COPYNN(s, &aulong, sizeof(unsigned long));
4758 s += sizeof(unsigned long);
4760 sv_setuv(sv, (UV)aulong);
4761 PUSHs(sv_2mortal(sv));
4771 if (datumtype == 'N')
4772 aulong = PerlSock_ntohl(aulong);
4775 if (datumtype == 'V')
4776 aulong = vtohl(aulong);
4779 sv_setuv(sv, (UV)aulong);
4780 PUSHs(sv_2mortal(sv));
4786 along = (strend - s) / sizeof(char*);
4792 if (sizeof(char*) > strend - s)
4795 Copy(s, &aptr, 1, char*);
4801 PUSHs(sv_2mortal(sv));
4811 while ((len > 0) && (s < strend)) {
4812 auv = (auv << 7) | (*s & 0x7f);
4813 if (UTF8_IS_ASCII(*s++)) {
4817 PUSHs(sv_2mortal(sv));
4821 else if (++bytes >= sizeof(UV)) { /* promote to string */
4825 sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv);
4826 while (s < strend) {
4827 sv = mul128(sv, *s & 0x7f);
4828 if (!(*s++ & 0x80)) {
4837 PUSHs(sv_2mortal(sv));
4842 if ((s >= strend) && bytes)
4843 DIE(aTHX_ "Unterminated compressed integer");
4848 if (sizeof(char*) > strend - s)
4851 Copy(s, &aptr, 1, char*);
4856 sv_setpvn(sv, aptr, len);
4857 PUSHs(sv_2mortal(sv));
4861 along = (strend - s) / sizeof(Quad_t);
4867 if (s + sizeof(Quad_t) > strend)
4870 Copy(s, &aquad, 1, Quad_t);
4871 s += sizeof(Quad_t);
4874 if (aquad >= IV_MIN && aquad <= IV_MAX)
4875 sv_setiv(sv, (IV)aquad);
4877 sv_setnv(sv, (NV)aquad);
4878 PUSHs(sv_2mortal(sv));
4882 along = (strend - s) / sizeof(Quad_t);
4888 if (s + sizeof(Uquad_t) > strend)
4891 Copy(s, &auquad, 1, Uquad_t);
4892 s += sizeof(Uquad_t);
4895 if (auquad <= UV_MAX)
4896 sv_setuv(sv, (UV)auquad);
4898 sv_setnv(sv, (NV)auquad);
4899 PUSHs(sv_2mortal(sv));
4903 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
4906 along = (strend - s) / sizeof(float);
4911 Copy(s, &afloat, 1, float);
4920 Copy(s, &afloat, 1, float);
4923 sv_setnv(sv, (NV)afloat);
4924 PUSHs(sv_2mortal(sv));
4930 along = (strend - s) / sizeof(double);
4935 Copy(s, &adouble, 1, double);
4936 s += sizeof(double);
4944 Copy(s, &adouble, 1, double);
4945 s += sizeof(double);
4947 sv_setnv(sv, (NV)adouble);
4948 PUSHs(sv_2mortal(sv));
4954 * Initialise the decode mapping. By using a table driven
4955 * algorithm, the code will be character-set independent
4956 * (and just as fast as doing character arithmetic)
4958 if (PL_uudmap['M'] == 0) {
4961 for (i = 0; i < sizeof(PL_uuemap); i += 1)
4962 PL_uudmap[(U8)PL_uuemap[i]] = i;
4964 * Because ' ' and '`' map to the same value,
4965 * we need to decode them both the same.
4970 along = (strend - s) * 3 / 4;
4971 sv = NEWSV(42, along);
4974 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
4979 len = PL_uudmap[*(U8*)s++] & 077;
4981 if (s < strend && ISUUCHAR(*s))
4982 a = PL_uudmap[*(U8*)s++] & 077;
4985 if (s < strend && ISUUCHAR(*s))
4986 b = PL_uudmap[*(U8*)s++] & 077;
4989 if (s < strend && ISUUCHAR(*s))
4990 c = PL_uudmap[*(U8*)s++] & 077;
4993 if (s < strend && ISUUCHAR(*s))
4994 d = PL_uudmap[*(U8*)s++] & 077;
4997 hunk[0] = (a << 2) | (b >> 4);
4998 hunk[1] = (b << 4) | (c >> 2);
4999 hunk[2] = (c << 6) | d;
5000 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
5005 else if (s[1] == '\n') /* possible checksum byte */
5008 XPUSHs(sv_2mortal(sv));
5013 if (strchr("fFdD", datumtype) ||
5014 (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
5018 while (checksum >= 16) {
5022 while (checksum >= 4) {
5028 along = (1 << checksum) - 1;
5029 while (cdouble < 0.0)
5031 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
5032 sv_setnv(sv, cdouble);
5035 if (checksum < 32) {
5036 aulong = (1 << checksum) - 1;
5039 sv_setuv(sv, (UV)culong);
5041 XPUSHs(sv_2mortal(sv));
5045 if (SP - PL_stack_base == start_sp_offset && gimme == G_SCALAR)
5046 PUSHs(&PL_sv_undef);
5051 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
5055 *hunk = PL_uuemap[len];
5056 sv_catpvn(sv, hunk, 1);
5059 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
5060 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
5061 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
5062 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
5063 sv_catpvn(sv, hunk, 4);
5068 char r = (len > 1 ? s[1] : '\0');
5069 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
5070 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
5071 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
5072 hunk[3] = PL_uuemap[0];
5073 sv_catpvn(sv, hunk, 4);
5075 sv_catpvn(sv, "\n", 1);
5079 S_is_an_int(pTHX_ char *s, STRLEN l)
5082 SV *result = newSVpvn(s, l);
5083 char *result_c = SvPV(result, n_a); /* convenience */
5084 char *out = result_c;
5094 SvREFCNT_dec(result);
5117 SvREFCNT_dec(result);
5123 SvCUR_set(result, out - result_c);
5127 /* pnum must be '\0' terminated */
5129 S_div128(pTHX_ SV *pnum, bool *done)
5132 char *s = SvPV(pnum, len);
5141 i = m * 10 + (*t - '0');
5143 r = (i >> 7); /* r < 10 */
5150 SvCUR_set(pnum, (STRLEN) (t - s));
5157 djSP; dMARK; dORIGMARK; dTARGET;
5158 register SV *cat = TARG;
5161 register char *pat = SvPVx(*++MARK, fromlen);
5163 register char *patend = pat + fromlen;
5168 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
5169 static char *space10 = " ";
5171 /* These must not be in registers: */
5186 #ifdef PERL_NATINT_PACK
5187 int natint; /* native integer */
5192 sv_setpvn(cat, "", 0);
5194 while (pat < patend) {
5195 SV *lengthcode = Nullsv;
5196 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no)
5197 datumtype = *pat++ & 0xFF;
5198 #ifdef PERL_NATINT_PACK
5201 if (isSPACE(datumtype)) {
5205 if (datumtype == 'U' && pat == patcopy+1)
5207 if (datumtype == '#') {
5208 while (pat < patend && *pat != '\n')
5213 char *natstr = "sSiIlL";
5215 if (strchr(natstr, datumtype)) {
5216 #ifdef PERL_NATINT_PACK
5222 DIE(aTHX_ "'!' allowed only after types %s", natstr);
5225 len = strchr("@Xxu", datumtype) ? 0 : items;
5228 else if (isDIGIT(*pat)) {
5230 while (isDIGIT(*pat)) {
5231 len = (len * 10) + (*pat++ - '0');
5233 DIE(aTHX_ "Repeat count in pack overflows");
5240 if ((*pat != 'a' && *pat != 'A' && *pat != 'Z') || pat[1] != '*')
5241 DIE(aTHX_ "/ must be followed by a*, A* or Z*");
5242 lengthcode = sv_2mortal(newSViv(sv_len(items > 0
5243 ? *MARK : &PL_sv_no)
5244 + (*pat == 'Z' ? 1 : 0)));
5248 DIE(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
5249 case ',': /* grandfather in commas but with a warning */
5250 if (commas++ == 0 && ckWARN(WARN_PACK))
5251 Perl_warner(aTHX_ WARN_PACK,
5252 "Invalid type in pack: '%c'", (int)datumtype);
5255 DIE(aTHX_ "%% may only be used in unpack");
5266 if (SvCUR(cat) < len)
5267 DIE(aTHX_ "X outside of string");
5274 sv_catpvn(cat, null10, 10);
5277 sv_catpvn(cat, null10, len);
5283 aptr = SvPV(fromstr, fromlen);
5284 if (pat[-1] == '*') {
5286 if (datumtype == 'Z')
5289 if (fromlen >= len) {
5290 sv_catpvn(cat, aptr, len);
5291 if (datumtype == 'Z')
5292 *(SvEND(cat)-1) = '\0';
5295 sv_catpvn(cat, aptr, fromlen);
5297 if (datumtype == 'A') {
5299 sv_catpvn(cat, space10, 10);
5302 sv_catpvn(cat, space10, len);
5306 sv_catpvn(cat, null10, 10);
5309 sv_catpvn(cat, null10, len);
5321 str = SvPV(fromstr, fromlen);
5325 SvCUR(cat) += (len+7)/8;
5326 SvGROW(cat, SvCUR(cat) + 1);
5327 aptr = SvPVX(cat) + aint;
5332 if (datumtype == 'B') {
5333 for (len = 0; len++ < aint;) {
5334 items |= *str++ & 1;
5338 *aptr++ = items & 0xff;
5344 for (len = 0; len++ < aint;) {
5350 *aptr++ = items & 0xff;
5356 if (datumtype == 'B')
5357 items <<= 7 - (aint & 7);
5359 items >>= 7 - (aint & 7);
5360 *aptr++ = items & 0xff;
5362 str = SvPVX(cat) + SvCUR(cat);
5377 str = SvPV(fromstr, fromlen);
5381 SvCUR(cat) += (len+1)/2;
5382 SvGROW(cat, SvCUR(cat) + 1);
5383 aptr = SvPVX(cat) + aint;
5388 if (datumtype == 'H') {
5389 for (len = 0; len++ < aint;) {
5391 items |= ((*str++ & 15) + 9) & 15;
5393 items |= *str++ & 15;
5397 *aptr++ = items & 0xff;
5403 for (len = 0; len++ < aint;) {
5405 items |= (((*str++ & 15) + 9) & 15) << 4;
5407 items |= (*str++ & 15) << 4;
5411 *aptr++ = items & 0xff;
5417 *aptr++ = items & 0xff;
5418 str = SvPVX(cat) + SvCUR(cat);
5429 aint = SvIV(fromstr);
5431 sv_catpvn(cat, &achar, sizeof(char));
5437 auint = SvUV(fromstr);
5438 SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN + 1);
5439 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
5444 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
5449 afloat = (float)SvNV(fromstr);
5450 sv_catpvn(cat, (char *)&afloat, sizeof (float));
5457 adouble = (double)SvNV(fromstr);
5458 sv_catpvn(cat, (char *)&adouble, sizeof (double));
5464 ashort = (I16)SvIV(fromstr);
5466 ashort = PerlSock_htons(ashort);
5468 CAT16(cat, &ashort);
5474 ashort = (I16)SvIV(fromstr);
5476 ashort = htovs(ashort);
5478 CAT16(cat, &ashort);
5482 #if SHORTSIZE != SIZE16
5484 unsigned short aushort;
5488 aushort = SvUV(fromstr);
5489 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
5499 aushort = (U16)SvUV(fromstr);
5500 CAT16(cat, &aushort);
5506 #if SHORTSIZE != SIZE16
5512 ashort = SvIV(fromstr);
5513 sv_catpvn(cat, (char *)&ashort, sizeof(short));
5521 ashort = (I16)SvIV(fromstr);
5522 CAT16(cat, &ashort);
5529 auint = SvUV(fromstr);
5530 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
5536 adouble = Perl_floor(SvNV(fromstr));
5539 DIE(aTHX_ "Cannot compress negative numbers");
5542 #if UVSIZE > 4 && UVSIZE >= NVSIZE
5543 adouble <= 0xffffffff
5545 # ifdef CXUX_BROKEN_CONSTANT_CONVERT
5546 adouble <= UV_MAX_cxux
5553 char buf[1 + sizeof(UV)];
5554 char *in = buf + sizeof(buf);
5555 UV auv = U_V(adouble);
5558 *--in = (auv & 0x7f) | 0x80;
5561 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
5562 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
5564 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
5565 char *from, *result, *in;
5570 /* Copy string and check for compliance */
5571 from = SvPV(fromstr, len);
5572 if ((norm = is_an_int(from, len)) == NULL)
5573 DIE(aTHX_ "can compress only unsigned integer");
5575 New('w', result, len, char);
5579 *--in = div128(norm, &done) | 0x80;
5580 result[len - 1] &= 0x7F; /* clear continue bit */
5581 sv_catpvn(cat, in, (result + len) - in);
5583 SvREFCNT_dec(norm); /* free norm */
5585 else if (SvNOKp(fromstr)) {
5586 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
5587 char *in = buf + sizeof(buf);
5590 double next = floor(adouble / 128);
5591 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
5592 if (in <= buf) /* this cannot happen ;-) */
5593 DIE(aTHX_ "Cannot compress integer");
5596 } while (adouble > 0);
5597 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
5598 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
5601 DIE(aTHX_ "Cannot compress non integer");
5607 aint = SvIV(fromstr);
5608 sv_catpvn(cat, (char*)&aint, sizeof(int));
5614 aulong = SvUV(fromstr);
5616 aulong = PerlSock_htonl(aulong);
5618 CAT32(cat, &aulong);
5624 aulong = SvUV(fromstr);
5626 aulong = htovl(aulong);
5628 CAT32(cat, &aulong);
5632 #if LONGSIZE != SIZE32
5634 unsigned long aulong;
5638 aulong = SvUV(fromstr);
5639 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
5647 aulong = SvUV(fromstr);
5648 CAT32(cat, &aulong);
5653 #if LONGSIZE != SIZE32
5659 along = SvIV(fromstr);
5660 sv_catpvn(cat, (char *)&along, sizeof(long));
5668 along = SvIV(fromstr);
5677 auquad = (Uquad_t)SvUV(fromstr);
5678 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
5684 aquad = (Quad_t)SvIV(fromstr);
5685 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
5690 len = 1; /* assume SV is correct length */
5695 if (fromstr == &PL_sv_undef)
5699 /* XXX better yet, could spirit away the string to
5700 * a safe spot and hang on to it until the result
5701 * of pack() (and all copies of the result) are
5704 if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
5705 || (SvPADTMP(fromstr)
5706 && !SvREADONLY(fromstr))))
5708 Perl_warner(aTHX_ WARN_PACK,
5709 "Attempt to pack pointer to temporary value");
5711 if (SvPOK(fromstr) || SvNIOK(fromstr))
5712 aptr = SvPV(fromstr,n_a);
5714 aptr = SvPV_force(fromstr,n_a);
5716 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
5721 aptr = SvPV(fromstr, fromlen);
5722 SvGROW(cat, fromlen * 4 / 3);
5727 while (fromlen > 0) {
5734 doencodes(cat, aptr, todo);
5753 register IV limit = POPi; /* note, negative is forever */
5756 register char *s = SvPV(sv, len);
5757 bool do_utf8 = DO_UTF8(sv);
5758 char *strend = s + len;
5760 register REGEXP *rx;
5764 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
5765 I32 maxiters = slen + 10;
5768 I32 origlimit = limit;
5771 AV *oldstack = PL_curstack;
5772 I32 gimme = GIMME_V;
5773 I32 oldsave = PL_savestack_ix;
5774 I32 make_mortal = 1;
5775 MAGIC *mg = (MAGIC *) NULL;
5778 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5783 DIE(aTHX_ "panic: pp_split");
5784 rx = pm->op_pmregexp;
5786 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
5787 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
5789 if (pm->op_pmreplroot) {
5791 ary = GvAVn((GV*)PL_curpad[(PADOFFSET)pm->op_pmreplroot]);
5793 ary = GvAVn((GV*)pm->op_pmreplroot);
5796 else if (gimme != G_ARRAY)
5798 ary = (AV*)PL_curpad[0];
5800 ary = GvAVn(PL_defgv);
5801 #endif /* USE_THREADS */
5804 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
5810 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
5812 XPUSHs(SvTIED_obj((SV*)ary, mg));
5818 for (i = AvFILLp(ary); i >= 0; i--)
5819 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5821 /* temporarily switch stacks */
5822 SWITCHSTACK(PL_curstack, ary);
5826 base = SP - PL_stack_base;
5828 if (pm->op_pmflags & PMf_SKIPWHITE) {
5829 if (pm->op_pmflags & PMf_LOCALE) {
5830 while (isSPACE_LC(*s))
5838 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
5839 SAVEINT(PL_multiline);
5840 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
5844 limit = maxiters + 2;
5845 if (pm->op_pmflags & PMf_WHITE) {
5848 while (m < strend &&
5849 !((pm->op_pmflags & PMf_LOCALE)
5850 ? isSPACE_LC(*m) : isSPACE(*m)))
5855 dstr = NEWSV(30, m-s);
5856 sv_setpvn(dstr, s, m-s);
5860 (void)SvUTF8_on(dstr);
5864 while (s < strend &&
5865 ((pm->op_pmflags & PMf_LOCALE)
5866 ? isSPACE_LC(*s) : isSPACE(*s)))
5870 else if (strEQ("^", rx->precomp)) {
5873 for (m = s; m < strend && *m != '\n'; m++) ;
5877 dstr = NEWSV(30, m-s);
5878 sv_setpvn(dstr, s, m-s);
5882 (void)SvUTF8_on(dstr);
5887 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
5888 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
5889 && (rx->reganch & ROPT_CHECK_ALL)
5890 && !(rx->reganch & ROPT_ANCH)) {
5891 int tail = (rx->reganch & RE_INTUIT_TAIL);
5892 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
5895 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
5897 char c = *SvPV(csv, n_a);
5900 for (m = s; m < strend && *m != c; m++) ;
5903 dstr = NEWSV(30, m-s);
5904 sv_setpvn(dstr, s, m-s);
5908 (void)SvUTF8_on(dstr);
5910 /* The rx->minlen is in characters but we want to step
5911 * s ahead by bytes. */
5913 s = (char*)utf8_hop((U8*)m, len);
5915 s = m + len; /* Fake \n at the end */
5920 while (s < strend && --limit &&
5921 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5922 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
5925 dstr = NEWSV(31, m-s);
5926 sv_setpvn(dstr, s, m-s);
5930 (void)SvUTF8_on(dstr);
5932 /* The rx->minlen is in characters but we want to step
5933 * s ahead by bytes. */
5935 s = (char*)utf8_hop((U8*)m, len);
5937 s = m + len; /* Fake \n at the end */
5942 maxiters += slen * rx->nparens;
5943 while (s < strend && --limit
5944 /* && (!rx->check_substr
5945 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
5947 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
5948 1 /* minend */, sv, NULL, 0))
5950 TAINT_IF(RX_MATCH_TAINTED(rx));
5951 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
5956 strend = s + (strend - m);
5958 m = rx->startp[0] + orig;
5959 dstr = NEWSV(32, m-s);
5960 sv_setpvn(dstr, s, m-s);
5964 (void)SvUTF8_on(dstr);
5967 for (i = 1; i <= rx->nparens; i++) {
5968 s = rx->startp[i] + orig;
5969 m = rx->endp[i] + orig;
5971 dstr = NEWSV(33, m-s);
5972 sv_setpvn(dstr, s, m-s);
5975 dstr = NEWSV(33, 0);
5979 (void)SvUTF8_on(dstr);
5983 s = rx->endp[0] + orig;
5987 LEAVE_SCOPE(oldsave);
5988 iters = (SP - PL_stack_base) - base;
5989 if (iters > maxiters)
5990 DIE(aTHX_ "Split loop");
5992 /* keep field after final delim? */
5993 if (s < strend || (iters && origlimit)) {
5994 STRLEN l = strend - s;
5995 dstr = NEWSV(34, l);
5996 sv_setpvn(dstr, s, l);
6000 (void)SvUTF8_on(dstr);
6004 else if (!origlimit) {
6005 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
6011 SWITCHSTACK(ary, oldstack);
6012 if (SvSMAGICAL(ary)) {
6017 if (gimme == G_ARRAY) {
6019 Copy(AvARRAY(ary), SP + 1, iters, SV*);
6027 call_method("PUSH",G_SCALAR|G_DISCARD);
6030 if (gimme == G_ARRAY) {
6031 /* EXTEND should not be needed - we just popped them */
6033 for (i=0; i < iters; i++) {
6034 SV **svp = av_fetch(ary, i, FALSE);
6035 PUSHs((svp) ? *svp : &PL_sv_undef);
6042 if (gimme == G_ARRAY)
6045 if (iters || !pm->op_pmreplroot) {
6055 Perl_unlock_condpair(pTHX_ void *svv)
6057 MAGIC *mg = mg_find((SV*)svv, 'm');
6060 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
6061 MUTEX_LOCK(MgMUTEXP(mg));
6062 if (MgOWNER(mg) != thr)
6063 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
6065 COND_SIGNAL(MgOWNERCONDP(mg));
6066 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
6067 PTR2UV(thr), PTR2UV(svv));)
6068 MUTEX_UNLOCK(MgMUTEXP(mg));
6070 #endif /* USE_THREADS */
6079 #endif /* USE_THREADS */
6080 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
6081 || SvTYPE(retsv) == SVt_PVCV) {
6082 retsv = refto(retsv);
6093 if (PL_op->op_private & OPpLVAL_INTRO)
6094 PUSHs(*save_threadsv(PL_op->op_targ));
6096 PUSHs(THREADSV(PL_op->op_targ));
6099 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
6100 #endif /* USE_THREADS */