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);
2579 djSP; dTARGET; tryAMAGICun(int);
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);
2611 if (value > (NV)IV_MIN - 0.5) {
2614 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2615 (void)Perl_modf(-value, &value);
2618 double tmp = (double)value;
2619 (void)Perl_modf(-tmp, &tmp);
2632 djSP; dTARGET; tryAMAGICun(abs);
2634 /* This will cache the NV value if string isn't actually integer */
2638 /* IVX is precise */
2640 SETu(TOPu); /* force it to be numeric only */
2648 /* 2s complement assumption. Also, not really needed as
2649 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2672 argtype = 1; /* allow underscores */
2673 XPUSHn(scan_hex(tmps, 99, &argtype));
2686 while (*tmps && isSPACE(*tmps))
2690 argtype = 1; /* allow underscores */
2692 value = scan_hex(++tmps, 99, &argtype);
2693 else if (*tmps == 'b')
2694 value = scan_bin(++tmps, 99, &argtype);
2696 value = scan_oct(tmps, 99, &argtype);
2709 SETi(sv_len_utf8(sv));
2725 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2727 I32 arybase = PL_curcop->cop_arybase;
2730 int num_args = PL_op->op_private & 7;
2732 SvTAINTED_off(TARG); /* decontaminate */
2733 SvUTF8_off(TARG); /* decontaminate */
2737 repl = SvPV(sv, repl_len);
2744 tmps = SvPV(sv, curlen);
2746 utfcurlen = sv_len_utf8(sv);
2747 if (utfcurlen == curlen)
2755 if (pos >= arybase) {
2773 else if (len >= 0) {
2775 if (rem > (I32)curlen)
2790 Perl_croak(aTHX_ "substr outside of string");
2791 if (ckWARN(WARN_SUBSTR))
2792 Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string");
2799 sv_pos_u2b(sv, &pos, &rem);
2801 sv_setpvn(TARG, tmps, rem);
2805 sv_insert(sv, pos, rem, repl, repl_len);
2806 else if (lvalue) { /* it's an lvalue! */
2807 if (!SvGMAGICAL(sv)) {
2811 if (ckWARN(WARN_SUBSTR))
2812 Perl_warner(aTHX_ WARN_SUBSTR,
2813 "Attempt to use reference as lvalue in substr");
2815 if (SvOK(sv)) /* is it defined ? */
2816 (void)SvPOK_only_UTF8(sv);
2818 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
2821 if (SvTYPE(TARG) < SVt_PVLV) {
2822 sv_upgrade(TARG, SVt_PVLV);
2823 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
2827 if (LvTARG(TARG) != sv) {
2829 SvREFCNT_dec(LvTARG(TARG));
2830 LvTARG(TARG) = SvREFCNT_inc(sv);
2832 LvTARGOFF(TARG) = upos;
2833 LvTARGLEN(TARG) = urem;
2837 PUSHs(TARG); /* avoid SvSETMAGIC here */
2844 register IV size = POPi;
2845 register IV offset = POPi;
2846 register SV *src = POPs;
2847 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2849 SvTAINTED_off(TARG); /* decontaminate */
2850 if (lvalue) { /* it's an lvalue! */
2851 if (SvTYPE(TARG) < SVt_PVLV) {
2852 sv_upgrade(TARG, SVt_PVLV);
2853 sv_magic(TARG, Nullsv, 'v', Nullch, 0);
2856 if (LvTARG(TARG) != src) {
2858 SvREFCNT_dec(LvTARG(TARG));
2859 LvTARG(TARG) = SvREFCNT_inc(src);
2861 LvTARGOFF(TARG) = offset;
2862 LvTARGLEN(TARG) = size;
2865 sv_setuv(TARG, do_vecget(src, offset, size));
2880 I32 arybase = PL_curcop->cop_arybase;
2885 offset = POPi - arybase;
2888 tmps = SvPV(big, biglen);
2889 if (offset > 0 && DO_UTF8(big))
2890 sv_pos_u2b(big, &offset, 0);
2893 else if (offset > biglen)
2895 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2896 (unsigned char*)tmps + biglen, little, 0)))
2899 retval = tmps2 - tmps;
2900 if (retval > 0 && DO_UTF8(big))
2901 sv_pos_b2u(big, &retval);
2902 PUSHi(retval + arybase);
2917 I32 arybase = PL_curcop->cop_arybase;
2923 tmps2 = SvPV(little, llen);
2924 tmps = SvPV(big, blen);
2928 if (offset > 0 && DO_UTF8(big))
2929 sv_pos_u2b(big, &offset, 0);
2930 offset = offset - arybase + llen;
2934 else if (offset > blen)
2936 if (!(tmps2 = rninstr(tmps, tmps + offset,
2937 tmps2, tmps2 + llen)))
2940 retval = tmps2 - tmps;
2941 if (retval > 0 && DO_UTF8(big))
2942 sv_pos_b2u(big, &retval);
2943 PUSHi(retval + arybase);
2949 djSP; dMARK; dORIGMARK; dTARGET;
2950 do_sprintf(TARG, SP-MARK, MARK+1);
2951 TAINT_IF(SvTAINTED(TARG));
2962 U8 *s = (U8*)SvPVx(argsv, len);
2964 XPUSHu(DO_UTF8(argsv) ? utf8_to_uv_simple(s, 0) : (*s & 0xff));
2974 (void)SvUPGRADE(TARG,SVt_PV);
2976 if (value > 255 && !IN_BYTE) {
2977 SvGROW(TARG, UNISKIP(value)+1);
2978 tmps = (char*)uv_to_utf8((U8*)SvPVX(TARG), value);
2979 SvCUR_set(TARG, tmps - SvPVX(TARG));
2981 (void)SvPOK_only(TARG);
2992 (void)SvPOK_only(TARG);
2999 djSP; dTARGET; dPOPTOPssrl;
3002 char *tmps = SvPV(left, n_a);
3004 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
3006 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
3010 "The crypt() function is unimplemented due to excessive paranoia.");
3023 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
3025 U8 tmpbuf[UTF8_MAXLEN+1];
3027 UV uv = utf8_to_uv(s, slen, &ulen, 0);
3029 if (PL_op->op_private & OPpLOCALE) {
3032 uv = toTITLE_LC_uni(uv);
3035 uv = toTITLE_utf8(s);
3037 tend = uv_to_utf8(tmpbuf, uv);
3039 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
3041 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3042 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3047 s = (U8*)SvPV_force(sv, slen);
3048 Copy(tmpbuf, s, ulen, U8);
3052 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3054 SvUTF8_off(TARG); /* decontaminate */
3059 s = (U8*)SvPV_force(sv, slen);
3061 if (PL_op->op_private & OPpLOCALE) {
3064 *s = toUPPER_LC(*s);
3082 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
3084 U8 tmpbuf[UTF8_MAXLEN+1];
3086 UV uv = utf8_to_uv(s, slen, &ulen, 0);
3088 if (PL_op->op_private & OPpLOCALE) {
3091 uv = toLOWER_LC_uni(uv);
3094 uv = toLOWER_utf8(s);
3096 tend = uv_to_utf8(tmpbuf, uv);
3098 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
3100 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3101 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3106 s = (U8*)SvPV_force(sv, slen);
3107 Copy(tmpbuf, s, ulen, U8);
3111 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3113 SvUTF8_off(TARG); /* decontaminate */
3118 s = (U8*)SvPV_force(sv, slen);
3120 if (PL_op->op_private & OPpLOCALE) {
3123 *s = toLOWER_LC(*s);
3147 s = (U8*)SvPV(sv,len);
3149 SvUTF8_off(TARG); /* decontaminate */
3150 sv_setpvn(TARG, "", 0);
3154 (void)SvUPGRADE(TARG, SVt_PV);
3155 SvGROW(TARG, (len * 2) + 1);
3156 (void)SvPOK_only(TARG);
3157 d = (U8*)SvPVX(TARG);
3159 if (PL_op->op_private & OPpLOCALE) {
3163 d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, len, &ulen, 0)));
3169 d = uv_to_utf8(d, toUPPER_utf8( s ));
3175 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3180 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3182 SvUTF8_off(TARG); /* decontaminate */
3187 s = (U8*)SvPV_force(sv, len);
3189 register U8 *send = s + len;
3191 if (PL_op->op_private & OPpLOCALE) {
3194 for (; s < send; s++)
3195 *s = toUPPER_LC(*s);
3198 for (; s < send; s++)
3221 s = (U8*)SvPV(sv,len);
3223 SvUTF8_off(TARG); /* decontaminate */
3224 sv_setpvn(TARG, "", 0);
3228 (void)SvUPGRADE(TARG, SVt_PV);
3229 SvGROW(TARG, (len * 2) + 1);
3230 (void)SvPOK_only(TARG);
3231 d = (U8*)SvPVX(TARG);
3233 if (PL_op->op_private & OPpLOCALE) {
3237 d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, len, &ulen, 0)));
3243 d = uv_to_utf8(d, toLOWER_utf8(s));
3249 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3254 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3256 SvUTF8_off(TARG); /* decontaminate */
3262 s = (U8*)SvPV_force(sv, len);
3264 register U8 *send = s + len;
3266 if (PL_op->op_private & OPpLOCALE) {
3269 for (; s < send; s++)
3270 *s = toLOWER_LC(*s);
3273 for (; s < send; s++)
3288 register char *s = SvPV(sv,len);
3291 SvUTF8_off(TARG); /* decontaminate */
3293 (void)SvUPGRADE(TARG, SVt_PV);
3294 SvGROW(TARG, (len * 2) + 1);
3298 if (UTF8_IS_CONTINUED(*s)) {
3299 STRLEN ulen = UTF8SKIP(s);
3323 SvCUR_set(TARG, d - SvPVX(TARG));
3324 (void)SvPOK_only_UTF8(TARG);
3327 sv_setpvn(TARG, s, len);
3329 if (SvSMAGICAL(TARG))
3338 djSP; dMARK; dORIGMARK;
3340 register AV* av = (AV*)POPs;
3341 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3342 I32 arybase = PL_curcop->cop_arybase;
3345 if (SvTYPE(av) == SVt_PVAV) {
3346 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3348 for (svp = MARK + 1; svp <= SP; svp++) {
3353 if (max > AvMAX(av))
3356 while (++MARK <= SP) {
3357 elem = SvIVx(*MARK);
3361 svp = av_fetch(av, elem, lval);
3363 if (!svp || *svp == &PL_sv_undef)
3364 DIE(aTHX_ PL_no_aelem, elem);
3365 if (PL_op->op_private & OPpLVAL_INTRO)
3366 save_aelem(av, elem, svp);
3368 *MARK = svp ? *svp : &PL_sv_undef;
3371 if (GIMME != G_ARRAY) {
3379 /* Associative arrays. */
3384 HV *hash = (HV*)POPs;
3386 I32 gimme = GIMME_V;
3387 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
3390 /* might clobber stack_sp */
3391 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
3396 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
3397 if (gimme == G_ARRAY) {
3400 /* might clobber stack_sp */
3402 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
3407 else if (gimme == G_SCALAR)
3426 I32 gimme = GIMME_V;
3427 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3431 if (PL_op->op_private & OPpSLICE) {
3435 hvtype = SvTYPE(hv);
3436 if (hvtype == SVt_PVHV) { /* hash element */
3437 while (++MARK <= SP) {
3438 sv = hv_delete_ent(hv, *MARK, discard, 0);
3439 *MARK = sv ? sv : &PL_sv_undef;
3442 else if (hvtype == SVt_PVAV) {
3443 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3444 while (++MARK <= SP) {
3445 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3446 *MARK = sv ? sv : &PL_sv_undef;
3449 else { /* pseudo-hash element */
3450 while (++MARK <= SP) {
3451 sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
3452 *MARK = sv ? sv : &PL_sv_undef;
3457 DIE(aTHX_ "Not a HASH reference");
3460 else if (gimme == G_SCALAR) {
3469 if (SvTYPE(hv) == SVt_PVHV)
3470 sv = hv_delete_ent(hv, keysv, discard, 0);
3471 else if (SvTYPE(hv) == SVt_PVAV) {
3472 if (PL_op->op_flags & OPf_SPECIAL)
3473 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3475 sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
3478 DIE(aTHX_ "Not a HASH reference");
3493 if (PL_op->op_private & OPpEXISTS_SUB) {
3497 cv = sv_2cv(sv, &hv, &gv, FALSE);
3500 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3506 if (SvTYPE(hv) == SVt_PVHV) {
3507 if (hv_exists_ent(hv, tmpsv, 0))
3510 else if (SvTYPE(hv) == SVt_PVAV) {
3511 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3512 if (av_exists((AV*)hv, SvIV(tmpsv)))
3515 else if (avhv_exists_ent((AV*)hv, tmpsv, 0)) /* pseudo-hash element */
3519 DIE(aTHX_ "Not a HASH reference");
3526 djSP; dMARK; dORIGMARK;
3527 register HV *hv = (HV*)POPs;
3528 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3529 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
3531 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
3532 DIE(aTHX_ "Can't localize pseudo-hash element");
3534 if (realhv || SvTYPE(hv) == SVt_PVAV) {
3535 while (++MARK <= SP) {
3538 I32 preeminent = SvRMAGICAL(hv) ? 1 : hv_exists_ent(hv, keysv, 0);
3540 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
3541 svp = he ? &HeVAL(he) : 0;
3544 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
3547 if (!svp || *svp == &PL_sv_undef) {
3549 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3551 if (PL_op->op_private & OPpLVAL_INTRO) {
3553 save_helem(hv, keysv, svp);
3556 char *key = SvPV(keysv, keylen);
3557 SAVEDELETE(hv, savepvn(key,keylen), keylen);
3561 *MARK = svp ? *svp : &PL_sv_undef;
3564 if (GIMME != G_ARRAY) {
3572 /* List operators. */
3577 if (GIMME != G_ARRAY) {
3579 *MARK = *SP; /* unwanted list, return last item */
3581 *MARK = &PL_sv_undef;
3590 SV **lastrelem = PL_stack_sp;
3591 SV **lastlelem = PL_stack_base + POPMARK;
3592 SV **firstlelem = PL_stack_base + POPMARK + 1;
3593 register SV **firstrelem = lastlelem + 1;
3594 I32 arybase = PL_curcop->cop_arybase;
3595 I32 lval = PL_op->op_flags & OPf_MOD;
3596 I32 is_something_there = lval;
3598 register I32 max = lastrelem - lastlelem;
3599 register SV **lelem;
3602 if (GIMME != G_ARRAY) {
3603 ix = SvIVx(*lastlelem);
3608 if (ix < 0 || ix >= max)
3609 *firstlelem = &PL_sv_undef;
3611 *firstlelem = firstrelem[ix];
3617 SP = firstlelem - 1;
3621 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3627 if (ix < 0 || ix >= max)
3628 *lelem = &PL_sv_undef;
3630 is_something_there = TRUE;
3631 if (!(*lelem = firstrelem[ix]))
3632 *lelem = &PL_sv_undef;
3635 if (is_something_there)
3638 SP = firstlelem - 1;
3644 djSP; dMARK; dORIGMARK;
3645 I32 items = SP - MARK;
3646 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
3647 SP = ORIGMARK; /* av_make() might realloc stack_sp */
3654 djSP; dMARK; dORIGMARK;
3655 HV* hv = (HV*)sv_2mortal((SV*)newHV());
3659 SV *val = NEWSV(46, 0);
3661 sv_setsv(val, *++MARK);
3662 else if (ckWARN(WARN_MISC))
3663 Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
3664 (void)hv_store_ent(hv,key,val,0);
3673 djSP; dMARK; dORIGMARK;
3674 register AV *ary = (AV*)*++MARK;
3678 register I32 offset;
3679 register I32 length;
3686 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3687 *MARK-- = SvTIED_obj((SV*)ary, mg);
3691 call_method("SPLICE",GIMME_V);
3700 offset = i = SvIVx(*MARK);
3702 offset += AvFILLp(ary) + 1;
3704 offset -= PL_curcop->cop_arybase;
3706 DIE(aTHX_ PL_no_aelem, i);
3708 length = SvIVx(*MARK++);
3710 length += AvFILLp(ary) - offset + 1;
3716 length = AvMAX(ary) + 1; /* close enough to infinity */
3720 length = AvMAX(ary) + 1;
3722 if (offset > AvFILLp(ary) + 1)
3723 offset = AvFILLp(ary) + 1;
3724 after = AvFILLp(ary) + 1 - (offset + length);
3725 if (after < 0) { /* not that much array */
3726 length += after; /* offset+length now in array */
3732 /* At this point, MARK .. SP-1 is our new LIST */
3735 diff = newlen - length;
3736 if (newlen && !AvREAL(ary) && AvREIFY(ary))
3739 if (diff < 0) { /* shrinking the area */
3741 New(451, tmparyval, newlen, SV*); /* so remember insertion */
3742 Copy(MARK, tmparyval, newlen, SV*);
3745 MARK = ORIGMARK + 1;
3746 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3747 MEXTEND(MARK, length);
3748 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
3750 EXTEND_MORTAL(length);
3751 for (i = length, dst = MARK; i; i--) {
3752 sv_2mortal(*dst); /* free them eventualy */
3759 *MARK = AvARRAY(ary)[offset+length-1];
3762 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
3763 SvREFCNT_dec(*dst++); /* free them now */
3766 AvFILLp(ary) += diff;
3768 /* pull up or down? */
3770 if (offset < after) { /* easier to pull up */
3771 if (offset) { /* esp. if nothing to pull */
3772 src = &AvARRAY(ary)[offset-1];
3773 dst = src - diff; /* diff is negative */
3774 for (i = offset; i > 0; i--) /* can't trust Copy */
3778 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
3782 if (after) { /* anything to pull down? */
3783 src = AvARRAY(ary) + offset + length;
3784 dst = src + diff; /* diff is negative */
3785 Move(src, dst, after, SV*);
3787 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
3788 /* avoid later double free */
3792 dst[--i] = &PL_sv_undef;
3795 for (src = tmparyval, dst = AvARRAY(ary) + offset;
3797 *dst = NEWSV(46, 0);
3798 sv_setsv(*dst++, *src++);
3800 Safefree(tmparyval);
3803 else { /* no, expanding (or same) */
3805 New(452, tmparyval, length, SV*); /* so remember deletion */
3806 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
3809 if (diff > 0) { /* expanding */
3811 /* push up or down? */
3813 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
3817 Move(src, dst, offset, SV*);
3819 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
3821 AvFILLp(ary) += diff;
3824 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
3825 av_extend(ary, AvFILLp(ary) + diff);
3826 AvFILLp(ary) += diff;
3829 dst = AvARRAY(ary) + AvFILLp(ary);
3831 for (i = after; i; i--) {
3838 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3839 *dst = NEWSV(46, 0);
3840 sv_setsv(*dst++, *src++);
3842 MARK = ORIGMARK + 1;
3843 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3845 Copy(tmparyval, MARK, length, SV*);
3847 EXTEND_MORTAL(length);
3848 for (i = length, dst = MARK; i; i--) {
3849 sv_2mortal(*dst); /* free them eventualy */
3853 Safefree(tmparyval);
3857 else if (length--) {
3858 *MARK = tmparyval[length];
3861 while (length-- > 0)
3862 SvREFCNT_dec(tmparyval[length]);
3864 Safefree(tmparyval);
3867 *MARK = &PL_sv_undef;
3875 djSP; dMARK; dORIGMARK; dTARGET;
3876 register AV *ary = (AV*)*++MARK;
3877 register SV *sv = &PL_sv_undef;
3880 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3881 *MARK-- = SvTIED_obj((SV*)ary, mg);
3885 call_method("PUSH",G_SCALAR|G_DISCARD);
3890 /* Why no pre-extend of ary here ? */
3891 for (++MARK; MARK <= SP; MARK++) {
3894 sv_setsv(sv, *MARK);
3899 PUSHi( AvFILL(ary) + 1 );
3907 SV *sv = av_pop(av);
3909 (void)sv_2mortal(sv);
3918 SV *sv = av_shift(av);
3923 (void)sv_2mortal(sv);
3930 djSP; dMARK; dORIGMARK; dTARGET;
3931 register AV *ary = (AV*)*++MARK;
3936 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3937 *MARK-- = SvTIED_obj((SV*)ary, mg);
3941 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3946 av_unshift(ary, SP - MARK);
3949 sv_setsv(sv, *++MARK);
3950 (void)av_store(ary, i++, sv);
3954 PUSHi( AvFILL(ary) + 1 );
3964 if (GIMME == G_ARRAY) {
3971 /* safe as long as stack cannot get extended in the above */
3976 register char *down;
3981 SvUTF8_off(TARG); /* decontaminate */
3983 do_join(TARG, &PL_sv_no, MARK, SP);
3985 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
3986 up = SvPV_force(TARG, len);
3988 if (DO_UTF8(TARG)) { /* first reverse each character */
3989 U8* s = (U8*)SvPVX(TARG);
3990 U8* send = (U8*)(s + len);
3992 if (UTF8_IS_ASCII(*s)) {
3997 if (!utf8_to_uv_simple(s, 0))
4001 down = (char*)(s - 1);
4002 /* reverse this character */
4012 down = SvPVX(TARG) + len - 1;
4018 (void)SvPOK_only_UTF8(TARG);
4027 S_mul128(pTHX_ SV *sv, U8 m)
4030 char *s = SvPV(sv, len);
4034 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
4035 SV *tmpNew = newSVpvn("0000000000", 10);
4037 sv_catsv(tmpNew, sv);
4038 SvREFCNT_dec(sv); /* free old sv */
4043 while (!*t) /* trailing '\0'? */
4046 i = ((*t - '0') << 7) + m;
4047 *(t--) = '0' + (i % 10);
4053 /* Explosives and implosives. */
4055 #if 'I' == 73 && 'J' == 74
4056 /* On an ASCII/ISO kind of system */
4057 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
4060 Some other sort of character set - use memchr() so we don't match
4063 #define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
4070 I32 start_sp_offset = SP - PL_stack_base;
4071 I32 gimme = GIMME_V;
4075 register char *pat = SvPV(left, llen);
4076 register char *s = SvPV(right, rlen);
4077 char *strend = s + rlen;
4079 register char *patend = pat + llen;
4085 /* These must not be in registers: */
4102 register U32 culong;
4106 #ifdef PERL_NATINT_PACK
4107 int natint; /* native integer */
4108 int unatint; /* unsigned native integer */
4111 if (gimme != G_ARRAY) { /* arrange to do first one only */
4113 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
4114 if (strchr("aAZbBhHP", *patend) || *pat == '%') {
4116 while (isDIGIT(*patend) || *patend == '*')
4122 while (pat < patend) {
4124 datumtype = *pat++ & 0xFF;
4125 #ifdef PERL_NATINT_PACK
4128 if (isSPACE(datumtype))
4130 if (datumtype == '#') {
4131 while (pat < patend && *pat != '\n')
4136 char *natstr = "sSiIlL";
4138 if (strchr(natstr, datumtype)) {
4139 #ifdef PERL_NATINT_PACK
4145 DIE(aTHX_ "'!' allowed only after types %s", natstr);
4150 else if (*pat == '*') {
4151 len = strend - strbeg; /* long enough */
4155 else if (isDIGIT(*pat)) {
4157 while (isDIGIT(*pat)) {
4158 len = (len * 10) + (*pat++ - '0');
4160 DIE(aTHX_ "Repeat count in unpack overflows");
4164 len = (datumtype != '@');
4168 DIE(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
4169 case ',': /* grandfather in commas but with a warning */
4170 if (commas++ == 0 && ckWARN(WARN_UNPACK))
4171 Perl_warner(aTHX_ WARN_UNPACK,
4172 "Invalid type in unpack: '%c'", (int)datumtype);
4175 if (len == 1 && pat[-1] != '1')
4184 if (len > strend - strbeg)
4185 DIE(aTHX_ "@ outside of string");
4189 if (len > s - strbeg)
4190 DIE(aTHX_ "X outside of string");
4194 if (len > strend - s)
4195 DIE(aTHX_ "x outside of string");
4199 if (start_sp_offset >= SP - PL_stack_base)
4200 DIE(aTHX_ "/ must follow a numeric type");
4203 pat++; /* ignore '*' for compatibility with pack */
4205 DIE(aTHX_ "/ cannot take a count" );
4212 if (len > strend - s)
4215 goto uchar_checksum;
4216 sv = NEWSV(35, len);
4217 sv_setpvn(sv, s, len);
4219 if (datumtype == 'A' || datumtype == 'Z') {
4220 aptr = s; /* borrow register */
4221 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
4226 else { /* 'A' strips both nulls and spaces */
4227 s = SvPVX(sv) + len - 1;
4228 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
4232 SvCUR_set(sv, s - SvPVX(sv));
4233 s = aptr; /* unborrow register */
4235 XPUSHs(sv_2mortal(sv));
4239 if (star || len > (strend - s) * 8)
4240 len = (strend - s) * 8;
4243 Newz(601, PL_bitcount, 256, char);
4244 for (bits = 1; bits < 256; bits++) {
4245 if (bits & 1) PL_bitcount[bits]++;
4246 if (bits & 2) PL_bitcount[bits]++;
4247 if (bits & 4) PL_bitcount[bits]++;
4248 if (bits & 8) PL_bitcount[bits]++;
4249 if (bits & 16) PL_bitcount[bits]++;
4250 if (bits & 32) PL_bitcount[bits]++;
4251 if (bits & 64) PL_bitcount[bits]++;
4252 if (bits & 128) PL_bitcount[bits]++;
4256 culong += PL_bitcount[*(unsigned char*)s++];
4261 if (datumtype == 'b') {
4263 if (bits & 1) culong++;
4269 if (bits & 128) culong++;
4276 sv = NEWSV(35, len + 1);
4280 if (datumtype == 'b') {
4282 for (len = 0; len < aint; len++) {
4283 if (len & 7) /*SUPPRESS 595*/
4287 *str++ = '0' + (bits & 1);
4292 for (len = 0; len < aint; len++) {
4297 *str++ = '0' + ((bits & 128) != 0);
4301 XPUSHs(sv_2mortal(sv));
4305 if (star || len > (strend - s) * 2)
4306 len = (strend - s) * 2;
4307 sv = NEWSV(35, len + 1);
4311 if (datumtype == 'h') {
4313 for (len = 0; len < aint; len++) {
4318 *str++ = PL_hexdigit[bits & 15];
4323 for (len = 0; len < aint; len++) {
4328 *str++ = PL_hexdigit[(bits >> 4) & 15];
4332 XPUSHs(sv_2mortal(sv));
4335 if (len > strend - s)
4340 if (aint >= 128) /* fake up signed chars */
4350 if (aint >= 128) /* fake up signed chars */
4353 sv_setiv(sv, (IV)aint);
4354 PUSHs(sv_2mortal(sv));
4359 if (len > strend - s)
4374 sv_setiv(sv, (IV)auint);
4375 PUSHs(sv_2mortal(sv));
4380 if (len > strend - s)
4383 while (len-- > 0 && s < strend) {
4385 auint = utf8_to_uv((U8*)s, strend - s, &alen, 0);
4389 cdouble += (NV)auint;
4397 while (len-- > 0 && s < strend) {
4399 auint = utf8_to_uv((U8*)s, strend - s, &alen, 0);
4403 sv_setuv(sv, (UV)auint);
4404 PUSHs(sv_2mortal(sv));
4409 #if SHORTSIZE == SIZE16
4410 along = (strend - s) / SIZE16;
4412 along = (strend - s) / (natint ? sizeof(short) : SIZE16);
4417 #if SHORTSIZE != SIZE16
4421 COPYNN(s, &ashort, sizeof(short));
4432 #if SHORTSIZE > SIZE16
4444 #if SHORTSIZE != SIZE16
4448 COPYNN(s, &ashort, sizeof(short));
4451 sv_setiv(sv, (IV)ashort);
4452 PUSHs(sv_2mortal(sv));
4460 #if SHORTSIZE > SIZE16
4466 sv_setiv(sv, (IV)ashort);
4467 PUSHs(sv_2mortal(sv));
4475 #if SHORTSIZE == SIZE16
4476 along = (strend - s) / SIZE16;
4478 unatint = natint && datumtype == 'S';
4479 along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
4484 #if SHORTSIZE != SIZE16
4486 unsigned short aushort;
4488 COPYNN(s, &aushort, sizeof(unsigned short));
4489 s += sizeof(unsigned short);
4497 COPY16(s, &aushort);
4500 if (datumtype == 'n')
4501 aushort = PerlSock_ntohs(aushort);
4504 if (datumtype == 'v')
4505 aushort = vtohs(aushort);
4514 #if SHORTSIZE != SIZE16
4516 unsigned short aushort;
4518 COPYNN(s, &aushort, sizeof(unsigned short));
4519 s += sizeof(unsigned short);
4521 sv_setiv(sv, (UV)aushort);
4522 PUSHs(sv_2mortal(sv));
4529 COPY16(s, &aushort);
4533 if (datumtype == 'n')
4534 aushort = PerlSock_ntohs(aushort);
4537 if (datumtype == 'v')
4538 aushort = vtohs(aushort);
4540 sv_setiv(sv, (UV)aushort);
4541 PUSHs(sv_2mortal(sv));
4547 along = (strend - s) / sizeof(int);
4552 Copy(s, &aint, 1, int);
4555 cdouble += (NV)aint;
4564 Copy(s, &aint, 1, int);
4568 /* Without the dummy below unpack("i", pack("i",-1))
4569 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
4570 * cc with optimization turned on.
4572 * The bug was detected in
4573 * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
4574 * with optimization (-O4) turned on.
4575 * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
4576 * does not have this problem even with -O4.
4578 * This bug was reported as DECC_BUGS 1431
4579 * and tracked internally as GEM_BUGS 7775.
4581 * The bug is fixed in
4582 * Tru64 UNIX V5.0: Compaq C V6.1-006 or later
4583 * UNIX V4.0F support: DEC C V5.9-006 or later
4584 * UNIX V4.0E support: DEC C V5.8-011 or later
4587 * See also few lines later for the same bug.
4590 sv_setiv(sv, (IV)aint) :
4592 sv_setiv(sv, (IV)aint);
4593 PUSHs(sv_2mortal(sv));
4598 along = (strend - s) / sizeof(unsigned int);
4603 Copy(s, &auint, 1, unsigned int);
4604 s += sizeof(unsigned int);
4606 cdouble += (NV)auint;
4615 Copy(s, &auint, 1, unsigned int);
4616 s += sizeof(unsigned int);
4619 /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
4620 * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
4621 * See details few lines earlier. */
4623 sv_setuv(sv, (UV)auint) :
4625 sv_setuv(sv, (UV)auint);
4626 PUSHs(sv_2mortal(sv));
4631 #if LONGSIZE == SIZE32
4632 along = (strend - s) / SIZE32;
4634 along = (strend - s) / (natint ? sizeof(long) : SIZE32);
4639 #if LONGSIZE != SIZE32
4642 COPYNN(s, &along, sizeof(long));
4645 cdouble += (NV)along;
4654 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
4658 #if LONGSIZE > SIZE32
4659 if (along > 2147483647)
4660 along -= 4294967296;
4664 cdouble += (NV)along;
4673 #if LONGSIZE != SIZE32
4676 COPYNN(s, &along, sizeof(long));
4679 sv_setiv(sv, (IV)along);
4680 PUSHs(sv_2mortal(sv));
4687 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
4691 #if LONGSIZE > SIZE32
4692 if (along > 2147483647)
4693 along -= 4294967296;
4697 sv_setiv(sv, (IV)along);
4698 PUSHs(sv_2mortal(sv));
4706 #if LONGSIZE == SIZE32
4707 along = (strend - s) / SIZE32;
4709 unatint = natint && datumtype == 'L';
4710 along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
4715 #if LONGSIZE != SIZE32
4717 unsigned long aulong;
4719 COPYNN(s, &aulong, sizeof(unsigned long));
4720 s += sizeof(unsigned long);
4722 cdouble += (NV)aulong;
4734 if (datumtype == 'N')
4735 aulong = PerlSock_ntohl(aulong);
4738 if (datumtype == 'V')
4739 aulong = vtohl(aulong);
4742 cdouble += (NV)aulong;
4751 #if LONGSIZE != SIZE32
4753 unsigned long aulong;
4755 COPYNN(s, &aulong, sizeof(unsigned long));
4756 s += sizeof(unsigned long);
4758 sv_setuv(sv, (UV)aulong);
4759 PUSHs(sv_2mortal(sv));
4769 if (datumtype == 'N')
4770 aulong = PerlSock_ntohl(aulong);
4773 if (datumtype == 'V')
4774 aulong = vtohl(aulong);
4777 sv_setuv(sv, (UV)aulong);
4778 PUSHs(sv_2mortal(sv));
4784 along = (strend - s) / sizeof(char*);
4790 if (sizeof(char*) > strend - s)
4793 Copy(s, &aptr, 1, char*);
4799 PUSHs(sv_2mortal(sv));
4809 while ((len > 0) && (s < strend)) {
4810 auv = (auv << 7) | (*s & 0x7f);
4811 if (UTF8_IS_ASCII(*s++)) {
4815 PUSHs(sv_2mortal(sv));
4819 else if (++bytes >= sizeof(UV)) { /* promote to string */
4823 sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv);
4824 while (s < strend) {
4825 sv = mul128(sv, *s & 0x7f);
4826 if (!(*s++ & 0x80)) {
4835 PUSHs(sv_2mortal(sv));
4840 if ((s >= strend) && bytes)
4841 DIE(aTHX_ "Unterminated compressed integer");
4846 if (sizeof(char*) > strend - s)
4849 Copy(s, &aptr, 1, char*);
4854 sv_setpvn(sv, aptr, len);
4855 PUSHs(sv_2mortal(sv));
4859 along = (strend - s) / sizeof(Quad_t);
4865 if (s + sizeof(Quad_t) > strend)
4868 Copy(s, &aquad, 1, Quad_t);
4869 s += sizeof(Quad_t);
4872 if (aquad >= IV_MIN && aquad <= IV_MAX)
4873 sv_setiv(sv, (IV)aquad);
4875 sv_setnv(sv, (NV)aquad);
4876 PUSHs(sv_2mortal(sv));
4880 along = (strend - s) / sizeof(Quad_t);
4886 if (s + sizeof(Uquad_t) > strend)
4889 Copy(s, &auquad, 1, Uquad_t);
4890 s += sizeof(Uquad_t);
4893 if (auquad <= UV_MAX)
4894 sv_setuv(sv, (UV)auquad);
4896 sv_setnv(sv, (NV)auquad);
4897 PUSHs(sv_2mortal(sv));
4901 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
4904 along = (strend - s) / sizeof(float);
4909 Copy(s, &afloat, 1, float);
4918 Copy(s, &afloat, 1, float);
4921 sv_setnv(sv, (NV)afloat);
4922 PUSHs(sv_2mortal(sv));
4928 along = (strend - s) / sizeof(double);
4933 Copy(s, &adouble, 1, double);
4934 s += sizeof(double);
4942 Copy(s, &adouble, 1, double);
4943 s += sizeof(double);
4945 sv_setnv(sv, (NV)adouble);
4946 PUSHs(sv_2mortal(sv));
4952 * Initialise the decode mapping. By using a table driven
4953 * algorithm, the code will be character-set independent
4954 * (and just as fast as doing character arithmetic)
4956 if (PL_uudmap['M'] == 0) {
4959 for (i = 0; i < sizeof(PL_uuemap); i += 1)
4960 PL_uudmap[(U8)PL_uuemap[i]] = i;
4962 * Because ' ' and '`' map to the same value,
4963 * we need to decode them both the same.
4968 along = (strend - s) * 3 / 4;
4969 sv = NEWSV(42, along);
4972 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
4977 len = PL_uudmap[*(U8*)s++] & 077;
4979 if (s < strend && ISUUCHAR(*s))
4980 a = PL_uudmap[*(U8*)s++] & 077;
4983 if (s < strend && ISUUCHAR(*s))
4984 b = PL_uudmap[*(U8*)s++] & 077;
4987 if (s < strend && ISUUCHAR(*s))
4988 c = PL_uudmap[*(U8*)s++] & 077;
4991 if (s < strend && ISUUCHAR(*s))
4992 d = PL_uudmap[*(U8*)s++] & 077;
4995 hunk[0] = (a << 2) | (b >> 4);
4996 hunk[1] = (b << 4) | (c >> 2);
4997 hunk[2] = (c << 6) | d;
4998 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
5003 else if (s[1] == '\n') /* possible checksum byte */
5006 XPUSHs(sv_2mortal(sv));
5011 if (strchr("fFdD", datumtype) ||
5012 (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
5016 while (checksum >= 16) {
5020 while (checksum >= 4) {
5026 along = (1 << checksum) - 1;
5027 while (cdouble < 0.0)
5029 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
5030 sv_setnv(sv, cdouble);
5033 if (checksum < 32) {
5034 aulong = (1 << checksum) - 1;
5037 sv_setuv(sv, (UV)culong);
5039 XPUSHs(sv_2mortal(sv));
5043 if (SP - PL_stack_base == start_sp_offset && gimme == G_SCALAR)
5044 PUSHs(&PL_sv_undef);
5049 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
5053 *hunk = PL_uuemap[len];
5054 sv_catpvn(sv, hunk, 1);
5057 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
5058 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
5059 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
5060 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
5061 sv_catpvn(sv, hunk, 4);
5066 char r = (len > 1 ? s[1] : '\0');
5067 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
5068 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
5069 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
5070 hunk[3] = PL_uuemap[0];
5071 sv_catpvn(sv, hunk, 4);
5073 sv_catpvn(sv, "\n", 1);
5077 S_is_an_int(pTHX_ char *s, STRLEN l)
5080 SV *result = newSVpvn(s, l);
5081 char *result_c = SvPV(result, n_a); /* convenience */
5082 char *out = result_c;
5092 SvREFCNT_dec(result);
5115 SvREFCNT_dec(result);
5121 SvCUR_set(result, out - result_c);
5125 /* pnum must be '\0' terminated */
5127 S_div128(pTHX_ SV *pnum, bool *done)
5130 char *s = SvPV(pnum, len);
5139 i = m * 10 + (*t - '0');
5141 r = (i >> 7); /* r < 10 */
5148 SvCUR_set(pnum, (STRLEN) (t - s));
5155 djSP; dMARK; dORIGMARK; dTARGET;
5156 register SV *cat = TARG;
5159 register char *pat = SvPVx(*++MARK, fromlen);
5161 register char *patend = pat + fromlen;
5166 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
5167 static char *space10 = " ";
5169 /* These must not be in registers: */
5184 #ifdef PERL_NATINT_PACK
5185 int natint; /* native integer */
5190 sv_setpvn(cat, "", 0);
5192 while (pat < patend) {
5193 SV *lengthcode = Nullsv;
5194 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no)
5195 datumtype = *pat++ & 0xFF;
5196 #ifdef PERL_NATINT_PACK
5199 if (isSPACE(datumtype)) {
5203 if (datumtype == 'U' && pat == patcopy+1)
5205 if (datumtype == '#') {
5206 while (pat < patend && *pat != '\n')
5211 char *natstr = "sSiIlL";
5213 if (strchr(natstr, datumtype)) {
5214 #ifdef PERL_NATINT_PACK
5220 DIE(aTHX_ "'!' allowed only after types %s", natstr);
5223 len = strchr("@Xxu", datumtype) ? 0 : items;
5226 else if (isDIGIT(*pat)) {
5228 while (isDIGIT(*pat)) {
5229 len = (len * 10) + (*pat++ - '0');
5231 DIE(aTHX_ "Repeat count in pack overflows");
5238 if ((*pat != 'a' && *pat != 'A' && *pat != 'Z') || pat[1] != '*')
5239 DIE(aTHX_ "/ must be followed by a*, A* or Z*");
5240 lengthcode = sv_2mortal(newSViv(sv_len(items > 0
5241 ? *MARK : &PL_sv_no)
5242 + (*pat == 'Z' ? 1 : 0)));
5246 DIE(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
5247 case ',': /* grandfather in commas but with a warning */
5248 if (commas++ == 0 && ckWARN(WARN_PACK))
5249 Perl_warner(aTHX_ WARN_PACK,
5250 "Invalid type in pack: '%c'", (int)datumtype);
5253 DIE(aTHX_ "%% may only be used in unpack");
5264 if (SvCUR(cat) < len)
5265 DIE(aTHX_ "X outside of string");
5272 sv_catpvn(cat, null10, 10);
5275 sv_catpvn(cat, null10, len);
5281 aptr = SvPV(fromstr, fromlen);
5282 if (pat[-1] == '*') {
5284 if (datumtype == 'Z')
5287 if (fromlen >= len) {
5288 sv_catpvn(cat, aptr, len);
5289 if (datumtype == 'Z')
5290 *(SvEND(cat)-1) = '\0';
5293 sv_catpvn(cat, aptr, fromlen);
5295 if (datumtype == 'A') {
5297 sv_catpvn(cat, space10, 10);
5300 sv_catpvn(cat, space10, len);
5304 sv_catpvn(cat, null10, 10);
5307 sv_catpvn(cat, null10, len);
5319 str = SvPV(fromstr, fromlen);
5323 SvCUR(cat) += (len+7)/8;
5324 SvGROW(cat, SvCUR(cat) + 1);
5325 aptr = SvPVX(cat) + aint;
5330 if (datumtype == 'B') {
5331 for (len = 0; len++ < aint;) {
5332 items |= *str++ & 1;
5336 *aptr++ = items & 0xff;
5342 for (len = 0; len++ < aint;) {
5348 *aptr++ = items & 0xff;
5354 if (datumtype == 'B')
5355 items <<= 7 - (aint & 7);
5357 items >>= 7 - (aint & 7);
5358 *aptr++ = items & 0xff;
5360 str = SvPVX(cat) + SvCUR(cat);
5375 str = SvPV(fromstr, fromlen);
5379 SvCUR(cat) += (len+1)/2;
5380 SvGROW(cat, SvCUR(cat) + 1);
5381 aptr = SvPVX(cat) + aint;
5386 if (datumtype == 'H') {
5387 for (len = 0; len++ < aint;) {
5389 items |= ((*str++ & 15) + 9) & 15;
5391 items |= *str++ & 15;
5395 *aptr++ = items & 0xff;
5401 for (len = 0; len++ < aint;) {
5403 items |= (((*str++ & 15) + 9) & 15) << 4;
5405 items |= (*str++ & 15) << 4;
5409 *aptr++ = items & 0xff;
5415 *aptr++ = items & 0xff;
5416 str = SvPVX(cat) + SvCUR(cat);
5427 aint = SvIV(fromstr);
5429 sv_catpvn(cat, &achar, sizeof(char));
5435 auint = SvUV(fromstr);
5436 SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN + 1);
5437 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
5442 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
5447 afloat = (float)SvNV(fromstr);
5448 sv_catpvn(cat, (char *)&afloat, sizeof (float));
5455 adouble = (double)SvNV(fromstr);
5456 sv_catpvn(cat, (char *)&adouble, sizeof (double));
5462 ashort = (I16)SvIV(fromstr);
5464 ashort = PerlSock_htons(ashort);
5466 CAT16(cat, &ashort);
5472 ashort = (I16)SvIV(fromstr);
5474 ashort = htovs(ashort);
5476 CAT16(cat, &ashort);
5480 #if SHORTSIZE != SIZE16
5482 unsigned short aushort;
5486 aushort = SvUV(fromstr);
5487 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
5497 aushort = (U16)SvUV(fromstr);
5498 CAT16(cat, &aushort);
5504 #if SHORTSIZE != SIZE16
5510 ashort = SvIV(fromstr);
5511 sv_catpvn(cat, (char *)&ashort, sizeof(short));
5519 ashort = (I16)SvIV(fromstr);
5520 CAT16(cat, &ashort);
5527 auint = SvUV(fromstr);
5528 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
5534 adouble = Perl_floor(SvNV(fromstr));
5537 DIE(aTHX_ "Cannot compress negative numbers");
5540 #if UVSIZE > 4 && UVSIZE >= NVSIZE
5541 adouble <= 0xffffffff
5543 # ifdef CXUX_BROKEN_CONSTANT_CONVERT
5544 adouble <= UV_MAX_cxux
5551 char buf[1 + sizeof(UV)];
5552 char *in = buf + sizeof(buf);
5553 UV auv = U_V(adouble);
5556 *--in = (auv & 0x7f) | 0x80;
5559 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
5560 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
5562 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
5563 char *from, *result, *in;
5568 /* Copy string and check for compliance */
5569 from = SvPV(fromstr, len);
5570 if ((norm = is_an_int(from, len)) == NULL)
5571 DIE(aTHX_ "can compress only unsigned integer");
5573 New('w', result, len, char);
5577 *--in = div128(norm, &done) | 0x80;
5578 result[len - 1] &= 0x7F; /* clear continue bit */
5579 sv_catpvn(cat, in, (result + len) - in);
5581 SvREFCNT_dec(norm); /* free norm */
5583 else if (SvNOKp(fromstr)) {
5584 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
5585 char *in = buf + sizeof(buf);
5588 double next = floor(adouble / 128);
5589 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
5590 if (in <= buf) /* this cannot happen ;-) */
5591 DIE(aTHX_ "Cannot compress integer");
5594 } while (adouble > 0);
5595 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
5596 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
5599 DIE(aTHX_ "Cannot compress non integer");
5605 aint = SvIV(fromstr);
5606 sv_catpvn(cat, (char*)&aint, sizeof(int));
5612 aulong = SvUV(fromstr);
5614 aulong = PerlSock_htonl(aulong);
5616 CAT32(cat, &aulong);
5622 aulong = SvUV(fromstr);
5624 aulong = htovl(aulong);
5626 CAT32(cat, &aulong);
5630 #if LONGSIZE != SIZE32
5632 unsigned long aulong;
5636 aulong = SvUV(fromstr);
5637 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
5645 aulong = SvUV(fromstr);
5646 CAT32(cat, &aulong);
5651 #if LONGSIZE != SIZE32
5657 along = SvIV(fromstr);
5658 sv_catpvn(cat, (char *)&along, sizeof(long));
5666 along = SvIV(fromstr);
5675 auquad = (Uquad_t)SvUV(fromstr);
5676 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
5682 aquad = (Quad_t)SvIV(fromstr);
5683 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
5688 len = 1; /* assume SV is correct length */
5693 if (fromstr == &PL_sv_undef)
5697 /* XXX better yet, could spirit away the string to
5698 * a safe spot and hang on to it until the result
5699 * of pack() (and all copies of the result) are
5702 if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
5703 || (SvPADTMP(fromstr)
5704 && !SvREADONLY(fromstr))))
5706 Perl_warner(aTHX_ WARN_PACK,
5707 "Attempt to pack pointer to temporary value");
5709 if (SvPOK(fromstr) || SvNIOK(fromstr))
5710 aptr = SvPV(fromstr,n_a);
5712 aptr = SvPV_force(fromstr,n_a);
5714 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
5719 aptr = SvPV(fromstr, fromlen);
5720 SvGROW(cat, fromlen * 4 / 3);
5725 while (fromlen > 0) {
5732 doencodes(cat, aptr, todo);
5751 register IV limit = POPi; /* note, negative is forever */
5754 register char *s = SvPV(sv, len);
5755 bool do_utf8 = DO_UTF8(sv);
5756 char *strend = s + len;
5758 register REGEXP *rx;
5762 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
5763 I32 maxiters = slen + 10;
5766 I32 origlimit = limit;
5769 AV *oldstack = PL_curstack;
5770 I32 gimme = GIMME_V;
5771 I32 oldsave = PL_savestack_ix;
5772 I32 make_mortal = 1;
5773 MAGIC *mg = (MAGIC *) NULL;
5776 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5781 DIE(aTHX_ "panic: pp_split");
5782 rx = pm->op_pmregexp;
5784 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
5785 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
5787 if (pm->op_pmreplroot) {
5789 ary = GvAVn((GV*)PL_curpad[(PADOFFSET)pm->op_pmreplroot]);
5791 ary = GvAVn((GV*)pm->op_pmreplroot);
5794 else if (gimme != G_ARRAY)
5796 ary = (AV*)PL_curpad[0];
5798 ary = GvAVn(PL_defgv);
5799 #endif /* USE_THREADS */
5802 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
5808 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
5810 XPUSHs(SvTIED_obj((SV*)ary, mg));
5816 for (i = AvFILLp(ary); i >= 0; i--)
5817 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5819 /* temporarily switch stacks */
5820 SWITCHSTACK(PL_curstack, ary);
5824 base = SP - PL_stack_base;
5826 if (pm->op_pmflags & PMf_SKIPWHITE) {
5827 if (pm->op_pmflags & PMf_LOCALE) {
5828 while (isSPACE_LC(*s))
5836 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
5837 SAVEINT(PL_multiline);
5838 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
5842 limit = maxiters + 2;
5843 if (pm->op_pmflags & PMf_WHITE) {
5846 while (m < strend &&
5847 !((pm->op_pmflags & PMf_LOCALE)
5848 ? isSPACE_LC(*m) : isSPACE(*m)))
5853 dstr = NEWSV(30, m-s);
5854 sv_setpvn(dstr, s, m-s);
5858 (void)SvUTF8_on(dstr);
5862 while (s < strend &&
5863 ((pm->op_pmflags & PMf_LOCALE)
5864 ? isSPACE_LC(*s) : isSPACE(*s)))
5868 else if (strEQ("^", rx->precomp)) {
5871 for (m = s; m < strend && *m != '\n'; m++) ;
5875 dstr = NEWSV(30, m-s);
5876 sv_setpvn(dstr, s, m-s);
5880 (void)SvUTF8_on(dstr);
5885 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
5886 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
5887 && (rx->reganch & ROPT_CHECK_ALL)
5888 && !(rx->reganch & ROPT_ANCH)) {
5889 int tail = (rx->reganch & RE_INTUIT_TAIL);
5890 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
5893 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
5895 char c = *SvPV(csv, n_a);
5898 for (m = s; m < strend && *m != c; m++) ;
5901 dstr = NEWSV(30, m-s);
5902 sv_setpvn(dstr, s, m-s);
5906 (void)SvUTF8_on(dstr);
5908 /* The rx->minlen is in characters but we want to step
5909 * s ahead by bytes. */
5911 s = (char*)utf8_hop((U8*)m, len);
5913 s = m + len; /* Fake \n at the end */
5918 while (s < strend && --limit &&
5919 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5920 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
5923 dstr = NEWSV(31, m-s);
5924 sv_setpvn(dstr, s, m-s);
5928 (void)SvUTF8_on(dstr);
5930 /* The rx->minlen is in characters but we want to step
5931 * s ahead by bytes. */
5933 s = (char*)utf8_hop((U8*)m, len);
5935 s = m + len; /* Fake \n at the end */
5940 maxiters += slen * rx->nparens;
5941 while (s < strend && --limit
5942 /* && (!rx->check_substr
5943 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
5945 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
5946 1 /* minend */, sv, NULL, 0))
5948 TAINT_IF(RX_MATCH_TAINTED(rx));
5949 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
5954 strend = s + (strend - m);
5956 m = rx->startp[0] + orig;
5957 dstr = NEWSV(32, m-s);
5958 sv_setpvn(dstr, s, m-s);
5962 (void)SvUTF8_on(dstr);
5965 for (i = 1; i <= rx->nparens; i++) {
5966 s = rx->startp[i] + orig;
5967 m = rx->endp[i] + orig;
5969 dstr = NEWSV(33, m-s);
5970 sv_setpvn(dstr, s, m-s);
5973 dstr = NEWSV(33, 0);
5977 (void)SvUTF8_on(dstr);
5981 s = rx->endp[0] + orig;
5985 LEAVE_SCOPE(oldsave);
5986 iters = (SP - PL_stack_base) - base;
5987 if (iters > maxiters)
5988 DIE(aTHX_ "Split loop");
5990 /* keep field after final delim? */
5991 if (s < strend || (iters && origlimit)) {
5992 STRLEN l = strend - s;
5993 dstr = NEWSV(34, l);
5994 sv_setpvn(dstr, s, l);
5998 (void)SvUTF8_on(dstr);
6002 else if (!origlimit) {
6003 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
6009 SWITCHSTACK(ary, oldstack);
6010 if (SvSMAGICAL(ary)) {
6015 if (gimme == G_ARRAY) {
6017 Copy(AvARRAY(ary), SP + 1, iters, SV*);
6025 call_method("PUSH",G_SCALAR|G_DISCARD);
6028 if (gimme == G_ARRAY) {
6029 /* EXTEND should not be needed - we just popped them */
6031 for (i=0; i < iters; i++) {
6032 SV **svp = av_fetch(ary, i, FALSE);
6033 PUSHs((svp) ? *svp : &PL_sv_undef);
6040 if (gimme == G_ARRAY)
6043 if (iters || !pm->op_pmreplroot) {
6053 Perl_unlock_condpair(pTHX_ void *svv)
6055 MAGIC *mg = mg_find((SV*)svv, 'm');
6058 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
6059 MUTEX_LOCK(MgMUTEXP(mg));
6060 if (MgOWNER(mg) != thr)
6061 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
6063 COND_SIGNAL(MgOWNERCONDP(mg));
6064 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
6065 PTR2UV(thr), PTR2UV(svv));)
6066 MUTEX_UNLOCK(MgMUTEXP(mg));
6068 #endif /* USE_THREADS */
6077 #endif /* USE_THREADS */
6078 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
6079 || SvTYPE(retsv) == SVt_PVCV) {
6080 retsv = refto(retsv);
6091 if (PL_op->op_private & OPpLVAL_INTRO)
6092 PUSHs(*save_threadsv(PL_op->op_targ));
6094 PUSHs(THREADSV(PL_op->op_targ));
6097 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
6098 #endif /* USE_THREADS */