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 dSP; 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 dSP; dMARK; dTARGET; dORIGMARK;
750 do_chop(TARG, *++MARK);
759 SETi(do_chomp(TOPs));
766 register I32 count = 0;
769 count += do_chomp(POPs);
780 if (!sv || !SvANY(sv))
782 switch (SvTYPE(sv)) {
784 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
788 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
792 if (CvROOT(sv) || CvXSUB(sv))
809 if (!PL_op->op_private) {
818 if (SvTHINKFIRST(sv))
821 switch (SvTYPE(sv)) {
831 if (ckWARN(WARN_MISC) && cv_const_sv((CV*)sv))
832 Perl_warner(aTHX_ WARN_MISC, "Constant subroutine %s undefined",
833 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
837 /* let user-undef'd sub keep its identity */
838 GV* gv = CvGV((CV*)sv);
845 SvSetMagicSV(sv, &PL_sv_undef);
849 Newz(602, gp, 1, GP);
850 GvGP(sv) = gp_ref(gp);
851 GvSV(sv) = NEWSV(72,0);
852 GvLINE(sv) = CopLINE(PL_curcop);
858 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
861 SvPV_set(sv, Nullch);
874 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
875 DIE(aTHX_ PL_no_modify);
876 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
877 SvIVX(TOPs) != IV_MIN)
880 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
891 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
892 DIE(aTHX_ PL_no_modify);
893 sv_setsv(TARG, TOPs);
894 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
895 SvIVX(TOPs) != IV_MAX)
898 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
912 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
913 DIE(aTHX_ PL_no_modify);
914 sv_setsv(TARG, TOPs);
915 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
916 SvIVX(TOPs) != IV_MIN)
919 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
928 /* Ordinary operators. */
932 dSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
935 SETn( Perl_pow( left, right) );
942 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
943 #ifdef PERL_PRESERVE_IVUV
946 /* Unless the left argument is integer in range we are going to have to
947 use NV maths. Hence only attempt to coerce the right argument if
948 we know the left is integer. */
949 /* Left operand is defined, so is it IV? */
952 bool auvok = SvUOK(TOPm1s);
953 bool buvok = SvUOK(TOPs);
954 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
955 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
962 alow = SvUVX(TOPm1s);
964 IV aiv = SvIVX(TOPm1s);
967 auvok = TRUE; /* effectively it's a UV now */
969 alow = -aiv; /* abs, auvok == false records sign */
975 IV biv = SvIVX(TOPs);
978 buvok = TRUE; /* effectively it's a UV now */
980 blow = -biv; /* abs, buvok == false records sign */
984 /* If this does sign extension on unsigned it's time for plan B */
985 ahigh = alow >> (4 * sizeof (UV));
987 bhigh = blow >> (4 * sizeof (UV));
989 if (ahigh && bhigh) {
990 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
991 which is overflow. Drop to NVs below. */
992 } else if (!ahigh && !bhigh) {
993 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
994 so the unsigned multiply cannot overflow. */
995 UV product = alow * blow;
996 if (auvok == buvok) {
997 /* -ve * -ve or +ve * +ve gives a +ve result. */
1001 } else if (product <= (UV)IV_MIN) {
1002 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1003 /* -ve result, which could overflow an IV */
1007 } /* else drop to NVs below. */
1009 /* One operand is large, 1 small */
1012 /* swap the operands */
1014 bhigh = blow; /* bhigh now the temp var for the swap */
1018 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1019 multiplies can't overflow. shift can, add can, -ve can. */
1020 product_middle = ahigh * blow;
1021 if (!(product_middle & topmask)) {
1022 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1024 product_middle <<= (4 * sizeof (UV));
1025 product_low = alow * blow;
1027 /* as for pp_add, UV + something mustn't get smaller.
1028 IIRC ANSI mandates this wrapping *behaviour* for
1029 unsigned whatever the actual representation*/
1030 product_low += product_middle;
1031 if (product_low >= product_middle) {
1032 /* didn't overflow */
1033 if (auvok == buvok) {
1034 /* -ve * -ve or +ve * +ve gives a +ve result. */
1036 SETu( product_low );
1038 } else if (product_low <= (UV)IV_MIN) {
1039 /* 2s complement assumption again */
1040 /* -ve result, which could overflow an IV */
1042 SETi( -product_low );
1044 } /* else drop to NVs below. */
1046 } /* product_middle too large */
1047 } /* ahigh && bhigh */
1048 } /* SvIOK(TOPm1s) */
1053 SETn( left * right );
1060 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1065 DIE(aTHX_ "Illegal division by zero");
1067 /* insure that 20./5. == 4. */
1070 if ((NV)I_V(left) == left &&
1071 (NV)I_V(right) == right &&
1072 (k = I_V(left)/I_V(right))*I_V(right) == I_V(left)) {
1076 value = left / right;
1080 value = left / right;
1089 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1095 bool use_double = 0;
1099 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
1101 right = (right_neg = (i < 0)) ? -i : i;
1106 right_neg = dright < 0;
1111 if (!use_double && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
1113 left = (left_neg = (i < 0)) ? -i : i;
1121 left_neg = dleft < 0;
1130 /* Somehow U_V is pessimized even if CASTFLAGS is 0 */
1132 # define CAST_D2UV(d) U_V(d)
1134 # define CAST_D2UV(d) ((UV)(d))
1136 /* Tried to do this only in the case DOUBLESIZE <= UV_SIZE,
1137 * or, in other words, precision of UV more than of NV.
1138 * But in fact the approach below turned out to be an
1139 * optimization - floor() may be slow */
1140 if (dright <= UV_MAX && dleft <= UV_MAX) {
1141 right = CAST_D2UV(dright);
1142 left = CAST_D2UV(dleft);
1147 /* Backward-compatibility clause: */
1148 dright = Perl_floor(dright + 0.5);
1149 dleft = Perl_floor(dleft + 0.5);
1152 DIE(aTHX_ "Illegal modulus zero");
1154 dans = Perl_fmod(dleft, dright);
1155 if ((left_neg != right_neg) && dans)
1156 dans = dright - dans;
1159 sv_setnv(TARG, dans);
1166 DIE(aTHX_ "Illegal modulus zero");
1169 if ((left_neg != right_neg) && ans)
1172 /* XXX may warn: unary minus operator applied to unsigned type */
1173 /* could change -foo to be (~foo)+1 instead */
1174 if (ans <= ~((UV)IV_MAX)+1)
1175 sv_setiv(TARG, ~ans+1);
1177 sv_setnv(TARG, -(NV)ans);
1180 sv_setuv(TARG, ans);
1189 dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1191 register IV count = POPi;
1192 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1194 I32 items = SP - MARK;
1197 max = items * count;
1206 repeatcpy((char*)(MARK + items), (char*)MARK,
1207 items * sizeof(SV*), count - 1);
1210 else if (count <= 0)
1213 else { /* Note: mark already snarfed by pp_list */
1218 SvSetSV(TARG, tmpstr);
1219 SvPV_force(TARG, len);
1220 isutf = DO_UTF8(TARG);
1225 SvGROW(TARG, (count * len) + 1);
1226 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1227 SvCUR(TARG) *= count;
1229 *SvEND(TARG) = '\0';
1232 (void)SvPOK_only_UTF8(TARG);
1234 (void)SvPOK_only(TARG);
1236 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1237 /* The parser saw this as a list repeat, and there
1238 are probably several items on the stack. But we're
1239 in scalar context, and there's no pp_list to save us
1240 now. So drop the rest of the items -- robin@kitsite.com
1253 dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
1254 useleft = USE_LEFT(TOPm1s);
1255 #ifdef PERL_PRESERVE_IVUV
1256 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1257 "bad things" happen if you rely on signed integers wrapping. */
1260 /* Unless the left argument is integer in range we are going to have to
1261 use NV maths. Hence only attempt to coerce the right argument if
1262 we know the left is integer. */
1269 a_valid = auvok = 1;
1270 /* left operand is undef, treat as zero. */
1272 /* Left operand is defined, so is it IV? */
1273 SvIV_please(TOPm1s);
1274 if (SvIOK(TOPm1s)) {
1275 if ((auvok = SvUOK(TOPm1s)))
1276 auv = SvUVX(TOPm1s);
1278 register IV aiv = SvIVX(TOPm1s);
1281 auvok = 1; /* Now acting as a sign flag. */
1282 } else { /* 2s complement assumption for IV_MIN */
1290 bool result_good = 0;
1293 bool buvok = SvUOK(TOPs);
1298 register IV biv = SvIVX(TOPs);
1305 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1306 else "IV" now, independant of how it came in.
1307 if a, b represents positive, A, B negative, a maps to -A etc
1312 all UV maths. negate result if A negative.
1313 subtract if signs same, add if signs differ. */
1315 if (auvok ^ buvok) {
1324 /* Must get smaller */
1329 if (result <= buv) {
1330 /* result really should be -(auv-buv). as its negation
1331 of true value, need to swap our result flag */
1343 if (result <= (UV)IV_MIN)
1344 SETi( -(IV)result );
1346 /* result valid, but out of range for IV. */
1347 SETn( -(NV)result );
1351 } /* Overflow, drop through to NVs. */
1355 useleft = USE_LEFT(TOPm1s);
1359 /* left operand is undef, treat as zero - value */
1363 SETn( TOPn - value );
1370 dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1373 if (PL_op->op_private & HINT_INTEGER) {
1387 dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1390 if (PL_op->op_private & HINT_INTEGER) {
1404 dSP; tryAMAGICbinSET(lt,0);
1405 #ifdef PERL_PRESERVE_IVUV
1408 SvIV_please(TOPm1s);
1409 if (SvIOK(TOPm1s)) {
1410 bool auvok = SvUOK(TOPm1s);
1411 bool buvok = SvUOK(TOPs);
1413 if (!auvok && !buvok) { /* ## IV < IV ## */
1414 IV aiv = SvIVX(TOPm1s);
1415 IV biv = SvIVX(TOPs);
1418 SETs(boolSV(aiv < biv));
1421 if (auvok && buvok) { /* ## UV < UV ## */
1422 UV auv = SvUVX(TOPm1s);
1423 UV buv = SvUVX(TOPs);
1426 SETs(boolSV(auv < buv));
1429 if (auvok) { /* ## UV < IV ## */
1436 /* As (a) is a UV, it's >=0, so it cannot be < */
1441 if (auv >= (UV) IV_MAX) {
1442 /* As (b) is an IV, it cannot be > IV_MAX */
1446 SETs(boolSV(auv < (UV)biv));
1449 { /* ## IV < UV ## */
1453 aiv = SvIVX(TOPm1s);
1455 /* As (b) is a UV, it's >=0, so it must be < */
1462 if (buv > (UV) IV_MAX) {
1463 /* As (a) is an IV, it cannot be > IV_MAX */
1467 SETs(boolSV((UV)aiv < buv));
1475 SETs(boolSV(TOPn < value));
1482 dSP; tryAMAGICbinSET(gt,0);
1483 #ifdef PERL_PRESERVE_IVUV
1486 SvIV_please(TOPm1s);
1487 if (SvIOK(TOPm1s)) {
1488 bool auvok = SvUOK(TOPm1s);
1489 bool buvok = SvUOK(TOPs);
1491 if (!auvok && !buvok) { /* ## IV > IV ## */
1492 IV aiv = SvIVX(TOPm1s);
1493 IV biv = SvIVX(TOPs);
1496 SETs(boolSV(aiv > biv));
1499 if (auvok && buvok) { /* ## UV > UV ## */
1500 UV auv = SvUVX(TOPm1s);
1501 UV buv = SvUVX(TOPs);
1504 SETs(boolSV(auv > buv));
1507 if (auvok) { /* ## UV > IV ## */
1514 /* As (a) is a UV, it's >=0, so it must be > */
1519 if (auv > (UV) IV_MAX) {
1520 /* As (b) is an IV, it cannot be > IV_MAX */
1524 SETs(boolSV(auv > (UV)biv));
1527 { /* ## IV > UV ## */
1531 aiv = SvIVX(TOPm1s);
1533 /* As (b) is a UV, it's >=0, so it cannot be > */
1540 if (buv >= (UV) IV_MAX) {
1541 /* As (a) is an IV, it cannot be > IV_MAX */
1545 SETs(boolSV((UV)aiv > buv));
1553 SETs(boolSV(TOPn > value));
1560 dSP; tryAMAGICbinSET(le,0);
1561 #ifdef PERL_PRESERVE_IVUV
1564 SvIV_please(TOPm1s);
1565 if (SvIOK(TOPm1s)) {
1566 bool auvok = SvUOK(TOPm1s);
1567 bool buvok = SvUOK(TOPs);
1569 if (!auvok && !buvok) { /* ## IV <= IV ## */
1570 IV aiv = SvIVX(TOPm1s);
1571 IV biv = SvIVX(TOPs);
1574 SETs(boolSV(aiv <= biv));
1577 if (auvok && buvok) { /* ## UV <= UV ## */
1578 UV auv = SvUVX(TOPm1s);
1579 UV buv = SvUVX(TOPs);
1582 SETs(boolSV(auv <= buv));
1585 if (auvok) { /* ## UV <= IV ## */
1592 /* As (a) is a UV, it's >=0, so a cannot be <= */
1597 if (auv > (UV) IV_MAX) {
1598 /* As (b) is an IV, it cannot be > IV_MAX */
1602 SETs(boolSV(auv <= (UV)biv));
1605 { /* ## IV <= UV ## */
1609 aiv = SvIVX(TOPm1s);
1611 /* As (b) is a UV, it's >=0, so a must be <= */
1618 if (buv >= (UV) IV_MAX) {
1619 /* As (a) is an IV, it cannot be > IV_MAX */
1623 SETs(boolSV((UV)aiv <= buv));
1631 SETs(boolSV(TOPn <= value));
1638 dSP; tryAMAGICbinSET(ge,0);
1639 #ifdef PERL_PRESERVE_IVUV
1642 SvIV_please(TOPm1s);
1643 if (SvIOK(TOPm1s)) {
1644 bool auvok = SvUOK(TOPm1s);
1645 bool buvok = SvUOK(TOPs);
1647 if (!auvok && !buvok) { /* ## IV >= IV ## */
1648 IV aiv = SvIVX(TOPm1s);
1649 IV biv = SvIVX(TOPs);
1652 SETs(boolSV(aiv >= biv));
1655 if (auvok && buvok) { /* ## UV >= UV ## */
1656 UV auv = SvUVX(TOPm1s);
1657 UV buv = SvUVX(TOPs);
1660 SETs(boolSV(auv >= buv));
1663 if (auvok) { /* ## UV >= IV ## */
1670 /* As (a) is a UV, it's >=0, so it must be >= */
1675 if (auv >= (UV) IV_MAX) {
1676 /* As (b) is an IV, it cannot be > IV_MAX */
1680 SETs(boolSV(auv >= (UV)biv));
1683 { /* ## IV >= UV ## */
1687 aiv = SvIVX(TOPm1s);
1689 /* As (b) is a UV, it's >=0, so a cannot be >= */
1696 if (buv > (UV) IV_MAX) {
1697 /* As (a) is an IV, it cannot be > IV_MAX */
1701 SETs(boolSV((UV)aiv >= buv));
1709 SETs(boolSV(TOPn >= value));
1716 dSP; tryAMAGICbinSET(ne,0);
1717 #ifdef PERL_PRESERVE_IVUV
1720 SvIV_please(TOPm1s);
1721 if (SvIOK(TOPm1s)) {
1722 bool auvok = SvUOK(TOPm1s);
1723 bool buvok = SvUOK(TOPs);
1725 if (!auvok && !buvok) { /* ## IV <=> IV ## */
1726 IV aiv = SvIVX(TOPm1s);
1727 IV biv = SvIVX(TOPs);
1730 SETs(boolSV(aiv != biv));
1733 if (auvok && buvok) { /* ## UV != UV ## */
1734 UV auv = SvUVX(TOPm1s);
1735 UV buv = SvUVX(TOPs);
1738 SETs(boolSV(auv != buv));
1741 { /* ## Mixed IV,UV ## */
1745 /* != is commutative so swap if needed (save code) */
1747 /* swap. top of stack (b) is the iv */
1751 /* As (a) is a UV, it's >0, so it cannot be == */
1760 /* As (b) is a UV, it's >0, so it cannot be == */
1764 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
1766 /* we know iv is >= 0 */
1767 if (uv > (UV) IV_MAX) {
1771 SETs(boolSV((UV)iv != uv));
1779 SETs(boolSV(TOPn != value));
1786 dSP; dTARGET; tryAMAGICbin(ncmp,0);
1787 #ifndef NV_PRESERVES_UV
1788 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1789 SETi(PTR2UV(SvRV(TOPs)) - PTR2UV(SvRV(TOPm1s)));
1793 #ifdef PERL_PRESERVE_IVUV
1794 /* Fortunately it seems NaN isn't IOK */
1797 SvIV_please(TOPm1s);
1798 if (SvIOK(TOPm1s)) {
1799 bool leftuvok = SvUOK(TOPm1s);
1800 bool rightuvok = SvUOK(TOPs);
1802 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
1803 IV leftiv = SvIVX(TOPm1s);
1804 IV rightiv = SvIVX(TOPs);
1806 if (leftiv > rightiv)
1808 else if (leftiv < rightiv)
1812 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
1813 UV leftuv = SvUVX(TOPm1s);
1814 UV rightuv = SvUVX(TOPs);
1816 if (leftuv > rightuv)
1818 else if (leftuv < rightuv)
1822 } else if (leftuvok) { /* ## UV <=> IV ## */
1826 rightiv = SvIVX(TOPs);
1828 /* As (a) is a UV, it's >=0, so it cannot be < */
1831 leftuv = SvUVX(TOPm1s);
1832 if (leftuv > (UV) IV_MAX) {
1833 /* As (b) is an IV, it cannot be > IV_MAX */
1835 } else if (leftuv > (UV)rightiv) {
1837 } else if (leftuv < (UV)rightiv) {
1843 } else { /* ## IV <=> UV ## */
1847 leftiv = SvIVX(TOPm1s);
1849 /* As (b) is a UV, it's >=0, so it must be < */
1852 rightuv = SvUVX(TOPs);
1853 if (rightuv > (UV) IV_MAX) {
1854 /* As (a) is an IV, it cannot be > IV_MAX */
1856 } else if (leftiv > (UV)rightuv) {
1858 } else if (leftiv < (UV)rightuv) {
1876 if (Perl_isnan(left) || Perl_isnan(right)) {
1880 value = (left > right) - (left < right);
1884 else if (left < right)
1886 else if (left > right)
1900 dSP; tryAMAGICbinSET(slt,0);
1903 int cmp = ((PL_op->op_private & OPpLOCALE)
1904 ? sv_cmp_locale(left, right)
1905 : sv_cmp(left, right));
1906 SETs(boolSV(cmp < 0));
1913 dSP; tryAMAGICbinSET(sgt,0);
1916 int cmp = ((PL_op->op_private & OPpLOCALE)
1917 ? sv_cmp_locale(left, right)
1918 : sv_cmp(left, right));
1919 SETs(boolSV(cmp > 0));
1926 dSP; tryAMAGICbinSET(sle,0);
1929 int cmp = ((PL_op->op_private & OPpLOCALE)
1930 ? sv_cmp_locale(left, right)
1931 : sv_cmp(left, right));
1932 SETs(boolSV(cmp <= 0));
1939 dSP; tryAMAGICbinSET(sge,0);
1942 int cmp = ((PL_op->op_private & OPpLOCALE)
1943 ? sv_cmp_locale(left, right)
1944 : sv_cmp(left, right));
1945 SETs(boolSV(cmp >= 0));
1952 dSP; tryAMAGICbinSET(seq,0);
1955 SETs(boolSV(sv_eq(left, right)));
1962 dSP; tryAMAGICbinSET(sne,0);
1965 SETs(boolSV(!sv_eq(left, right)));
1972 dSP; dTARGET; tryAMAGICbin(scmp,0);
1973 #ifndef NV_PRESERVES_UV
1974 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1975 SETi(PTR2UV(SvRV(TOPs)) - PTR2UV(SvRV(TOPm1s)));
1981 int cmp = ((PL_op->op_private & OPpLOCALE)
1982 ? sv_cmp_locale(left, right)
1983 : sv_cmp(left, right));
1991 dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
1994 if (SvNIOKp(left) || SvNIOKp(right)) {
1995 if (PL_op->op_private & HINT_INTEGER) {
1996 IV i = SvIV(left) & SvIV(right);
2000 UV u = SvUV(left) & SvUV(right);
2005 do_vop(PL_op->op_type, TARG, left, right);
2014 dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
2017 if (SvNIOKp(left) || SvNIOKp(right)) {
2018 if (PL_op->op_private & HINT_INTEGER) {
2019 IV i = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
2023 UV u = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
2028 do_vop(PL_op->op_type, TARG, left, right);
2037 dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
2040 if (SvNIOKp(left) || SvNIOKp(right)) {
2041 if (PL_op->op_private & HINT_INTEGER) {
2042 IV i = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
2046 UV u = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
2051 do_vop(PL_op->op_type, TARG, left, right);
2060 dSP; dTARGET; tryAMAGICun(neg);
2063 int flags = SvFLAGS(sv);
2066 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2067 /* It's publicly an integer, or privately an integer-not-float */
2070 if (SvIVX(sv) == IV_MIN) {
2071 /* 2s complement assumption. */
2072 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2075 else if (SvUVX(sv) <= IV_MAX) {
2080 else if (SvIVX(sv) != IV_MIN) {
2084 #ifdef PERL_PRESERVE_IVUV
2093 else if (SvPOKp(sv)) {
2095 char *s = SvPV(sv, len);
2096 if (isIDFIRST(*s)) {
2097 sv_setpvn(TARG, "-", 1);
2100 else if (*s == '+' || *s == '-') {
2102 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2104 else if (DO_UTF8(sv) && UTF8_IS_START(*s) && isIDFIRST_utf8((U8*)s)) {
2105 sv_setpvn(TARG, "-", 1);
2111 goto oops_its_an_int;
2112 sv_setnv(TARG, -SvNV(sv));
2124 dSP; tryAMAGICunSET(not);
2125 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2131 dSP; dTARGET; tryAMAGICun(compl);
2135 if (PL_op->op_private & HINT_INTEGER) {
2150 tmps = (U8*)SvPV_force(TARG, len);
2153 /* Calculate exact length, let's not estimate. */
2162 while (tmps < send) {
2163 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2164 tmps += UTF8SKIP(tmps);
2165 targlen += UNISKIP(~c);
2171 /* Now rewind strings and write them. */
2175 Newz(0, result, targlen + 1, U8);
2176 while (tmps < send) {
2177 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2178 tmps += UTF8SKIP(tmps);
2179 result = uvchr_to_utf8(result, ~c);
2183 sv_setpvn(TARG, (char*)result, targlen);
2187 Newz(0, result, nchar + 1, U8);
2188 while (tmps < send) {
2189 U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY);
2190 tmps += UTF8SKIP(tmps);
2195 sv_setpvn(TARG, (char*)result, nchar);
2203 register long *tmpl;
2204 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2207 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2212 for ( ; anum > 0; anum--, tmps++)
2221 /* integer versions of some of the above */
2225 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2228 SETi( left * right );
2235 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2239 DIE(aTHX_ "Illegal division by zero");
2240 value = POPi / value;
2248 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2252 DIE(aTHX_ "Illegal modulus zero");
2253 SETi( left % right );
2260 dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2263 SETi( left + right );
2270 dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2273 SETi( left - right );
2280 dSP; tryAMAGICbinSET(lt,0);
2283 SETs(boolSV(left < right));
2290 dSP; tryAMAGICbinSET(gt,0);
2293 SETs(boolSV(left > right));
2300 dSP; tryAMAGICbinSET(le,0);
2303 SETs(boolSV(left <= right));
2310 dSP; tryAMAGICbinSET(ge,0);
2313 SETs(boolSV(left >= right));
2320 dSP; tryAMAGICbinSET(eq,0);
2323 SETs(boolSV(left == right));
2330 dSP; tryAMAGICbinSET(ne,0);
2333 SETs(boolSV(left != right));
2340 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2347 else if (left < right)
2358 dSP; dTARGET; tryAMAGICun(neg);
2363 /* High falutin' math. */
2367 dSP; dTARGET; tryAMAGICbin(atan2,0);
2370 SETn(Perl_atan2(left, right));
2377 dSP; dTARGET; tryAMAGICun(sin);
2381 value = Perl_sin(value);
2389 dSP; dTARGET; tryAMAGICun(cos);
2393 value = Perl_cos(value);
2399 /* Support Configure command-line overrides for rand() functions.
2400 After 5.005, perhaps we should replace this by Configure support
2401 for drand48(), random(), or rand(). For 5.005, though, maintain
2402 compatibility by calling rand() but allow the user to override it.
2403 See INSTALL for details. --Andy Dougherty 15 July 1998
2405 /* Now it's after 5.005, and Configure supports drand48() and random(),
2406 in addition to rand(). So the overrides should not be needed any more.
2407 --Jarkko Hietaniemi 27 September 1998
2410 #ifndef HAS_DRAND48_PROTO
2411 extern double drand48 (void);
2424 if (!PL_srand_called) {
2425 (void)seedDrand01((Rand_seed_t)seed());
2426 PL_srand_called = TRUE;
2441 (void)seedDrand01((Rand_seed_t)anum);
2442 PL_srand_called = TRUE;
2451 * This is really just a quick hack which grabs various garbage
2452 * values. It really should be a real hash algorithm which
2453 * spreads the effect of every input bit onto every output bit,
2454 * if someone who knows about such things would bother to write it.
2455 * Might be a good idea to add that function to CORE as well.
2456 * No numbers below come from careful analysis or anything here,
2457 * except they are primes and SEED_C1 > 1E6 to get a full-width
2458 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
2459 * probably be bigger too.
2462 # define SEED_C1 1000003
2463 #define SEED_C4 73819
2465 # define SEED_C1 25747
2466 #define SEED_C4 20639
2470 #define SEED_C5 26107
2472 #ifndef PERL_NO_DEV_RANDOM
2477 # include <starlet.h>
2478 /* when[] = (low 32 bits, high 32 bits) of time since epoch
2479 * in 100-ns units, typically incremented ever 10 ms. */
2480 unsigned int when[2];
2482 # ifdef HAS_GETTIMEOFDAY
2483 struct timeval when;
2489 /* This test is an escape hatch, this symbol isn't set by Configure. */
2490 #ifndef PERL_NO_DEV_RANDOM
2491 #ifndef PERL_RANDOM_DEVICE
2492 /* /dev/random isn't used by default because reads from it will block
2493 * if there isn't enough entropy available. You can compile with
2494 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
2495 * is enough real entropy to fill the seed. */
2496 # define PERL_RANDOM_DEVICE "/dev/urandom"
2498 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
2500 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
2509 _ckvmssts(sys$gettim(when));
2510 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
2512 # ifdef HAS_GETTIMEOFDAY
2513 gettimeofday(&when,(struct timezone *) 0);
2514 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
2517 u = (U32)SEED_C1 * when;
2520 u += SEED_C3 * (U32)PerlProc_getpid();
2521 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
2522 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
2523 u += SEED_C5 * (U32)PTR2UV(&when);
2530 dSP; dTARGET; tryAMAGICun(exp);
2534 value = Perl_exp(value);
2542 dSP; dTARGET; tryAMAGICun(log);
2547 SET_NUMERIC_STANDARD();
2548 DIE(aTHX_ "Can't take log of %g", value);
2550 value = Perl_log(value);
2558 dSP; dTARGET; tryAMAGICun(sqrt);
2563 SET_NUMERIC_STANDARD();
2564 DIE(aTHX_ "Can't take sqrt of %g", value);
2566 value = Perl_sqrt(value);
2574 dSP; dTARGET; tryAMAGICun(int);
2577 IV iv = TOPi; /* attempt to convert to IV if possible. */
2578 /* XXX it's arguable that compiler casting to IV might be subtly
2579 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2580 else preferring IV has introduced a subtle behaviour change bug. OTOH
2581 relying on floating point to be accurate is a bug. */
2592 if (value < (NV)UV_MAX + 0.5) {
2595 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2596 (void)Perl_modf(value, &value);
2598 double tmp = (double)value;
2599 (void)Perl_modf(tmp, &tmp);
2606 if (value > (NV)IV_MIN - 0.5) {
2609 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2610 (void)Perl_modf(-value, &value);
2613 double tmp = (double)value;
2614 (void)Perl_modf(-tmp, &tmp);
2627 dSP; dTARGET; tryAMAGICun(abs);
2629 /* This will cache the NV value if string isn't actually integer */
2633 /* IVX is precise */
2635 SETu(TOPu); /* force it to be numeric only */
2643 /* 2s complement assumption. Also, not really needed as
2644 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2667 argtype = 1; /* allow underscores */
2668 XPUSHn(scan_hex(tmps, 99, &argtype));
2681 while (*tmps && isSPACE(*tmps))
2685 argtype = 1; /* allow underscores */
2687 value = scan_hex(++tmps, 99, &argtype);
2688 else if (*tmps == 'b')
2689 value = scan_bin(++tmps, 99, &argtype);
2691 value = scan_oct(tmps, 99, &argtype);
2704 SETi(sv_len_utf8(sv));
2720 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2722 I32 arybase = PL_curcop->cop_arybase;
2726 int num_args = PL_op->op_private & 7;
2727 bool repl_need_utf8_upgrade = FALSE;
2728 bool repl_is_utf8 = FALSE;
2730 SvTAINTED_off(TARG); /* decontaminate */
2731 SvUTF8_off(TARG); /* decontaminate */
2735 repl = SvPV(repl_sv, repl_len);
2736 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
2746 sv_utf8_upgrade(sv);
2748 else if (DO_UTF8(sv))
2749 repl_need_utf8_upgrade = TRUE;
2751 tmps = SvPV(sv, curlen);
2753 utf8_curlen = sv_len_utf8(sv);
2754 if (utf8_curlen == curlen)
2757 curlen = utf8_curlen;
2762 if (pos >= arybase) {
2780 else if (len >= 0) {
2782 if (rem > (I32)curlen)
2797 Perl_croak(aTHX_ "substr outside of string");
2798 if (ckWARN(WARN_SUBSTR))
2799 Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string");
2806 sv_pos_u2b(sv, &pos, &rem);
2808 sv_setpvn(TARG, tmps, rem);
2812 SV* repl_sv_copy = NULL;
2814 if (repl_need_utf8_upgrade) {
2815 repl_sv_copy = newSVsv(repl_sv);
2816 sv_utf8_upgrade(repl_sv_copy);
2817 repl = SvPV(repl_sv_copy, repl_len);
2818 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
2820 sv_insert(sv, pos, rem, repl, repl_len);
2824 SvREFCNT_dec(repl_sv_copy);
2826 else if (lvalue) { /* it's an lvalue! */
2827 if (!SvGMAGICAL(sv)) {
2831 if (ckWARN(WARN_SUBSTR))
2832 Perl_warner(aTHX_ WARN_SUBSTR,
2833 "Attempt to use reference as lvalue in substr");
2835 if (SvOK(sv)) /* is it defined ? */
2836 (void)SvPOK_only_UTF8(sv);
2838 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
2841 if (SvTYPE(TARG) < SVt_PVLV) {
2842 sv_upgrade(TARG, SVt_PVLV);
2843 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
2847 if (LvTARG(TARG) != sv) {
2849 SvREFCNT_dec(LvTARG(TARG));
2850 LvTARG(TARG) = SvREFCNT_inc(sv);
2852 LvTARGOFF(TARG) = upos;
2853 LvTARGLEN(TARG) = urem;
2857 PUSHs(TARG); /* avoid SvSETMAGIC here */
2864 register IV size = POPi;
2865 register IV offset = POPi;
2866 register SV *src = POPs;
2867 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2869 SvTAINTED_off(TARG); /* decontaminate */
2870 if (lvalue) { /* it's an lvalue! */
2871 if (SvTYPE(TARG) < SVt_PVLV) {
2872 sv_upgrade(TARG, SVt_PVLV);
2873 sv_magic(TARG, Nullsv, 'v', Nullch, 0);
2876 if (LvTARG(TARG) != src) {
2878 SvREFCNT_dec(LvTARG(TARG));
2879 LvTARG(TARG) = SvREFCNT_inc(src);
2881 LvTARGOFF(TARG) = offset;
2882 LvTARGLEN(TARG) = size;
2885 sv_setuv(TARG, do_vecget(src, offset, size));
2900 I32 arybase = PL_curcop->cop_arybase;
2905 offset = POPi - arybase;
2908 tmps = SvPV(big, biglen);
2909 if (offset > 0 && DO_UTF8(big))
2910 sv_pos_u2b(big, &offset, 0);
2913 else if (offset > biglen)
2915 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2916 (unsigned char*)tmps + biglen, little, 0)))
2919 retval = tmps2 - tmps;
2920 if (retval > 0 && DO_UTF8(big))
2921 sv_pos_b2u(big, &retval);
2922 PUSHi(retval + arybase);
2937 I32 arybase = PL_curcop->cop_arybase;
2943 tmps2 = SvPV(little, llen);
2944 tmps = SvPV(big, blen);
2948 if (offset > 0 && DO_UTF8(big))
2949 sv_pos_u2b(big, &offset, 0);
2950 offset = offset - arybase + llen;
2954 else if (offset > blen)
2956 if (!(tmps2 = rninstr(tmps, tmps + offset,
2957 tmps2, tmps2 + llen)))
2960 retval = tmps2 - tmps;
2961 if (retval > 0 && DO_UTF8(big))
2962 sv_pos_b2u(big, &retval);
2963 PUSHi(retval + arybase);
2969 dSP; dMARK; dORIGMARK; dTARGET;
2970 do_sprintf(TARG, SP-MARK, MARK+1);
2971 TAINT_IF(SvTAINTED(TARG));
2982 U8 *s = (U8*)SvPVx(argsv, len);
2984 XPUSHu(DO_UTF8(argsv) ? utf8_to_uvchr(s, 0) : (*s & 0xff));
2994 (void)SvUPGRADE(TARG,SVt_PV);
2996 if (value > 255 && !IN_BYTE) {
2997 SvGROW(TARG, UNISKIP(value)+1);
2998 tmps = (char*)uvchr_to_utf8((U8*)SvPVX(TARG), value);
2999 SvCUR_set(TARG, tmps - SvPVX(TARG));
3001 (void)SvPOK_only(TARG);
3012 (void)SvPOK_only(TARG);
3019 dSP; dTARGET; dPOPTOPssrl;
3022 char *tmps = SvPV(left, n_a);
3024 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
3026 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
3030 "The crypt() function is unimplemented due to excessive paranoia.");
3043 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
3045 U8 tmpbuf[UTF8_MAXLEN+1];
3049 if (PL_op->op_private & OPpLOCALE) {
3052 uv = toTITLE_LC_uvchr(utf8n_to_uvchr(s, slen, &ulen, 0));
3055 uv = toTITLE_utf8(s);
3057 tend = uvchr_to_utf8(tmpbuf, uv);
3059 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
3061 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3062 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3067 s = (U8*)SvPV_force(sv, slen);
3068 Copy(tmpbuf, s, ulen, U8);
3072 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3074 SvUTF8_off(TARG); /* decontaminate */
3079 s = (U8*)SvPV_force(sv, slen);
3081 if (PL_op->op_private & OPpLOCALE) {
3084 *s = toUPPER_LC(*s);
3102 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
3104 U8 tmpbuf[UTF8_MAXLEN+1];
3108 if (PL_op->op_private & OPpLOCALE) {
3111 uv = toLOWER_LC_uvchr(utf8n_to_uvchr(s, slen, &ulen, 0));
3114 uv = toLOWER_utf8(s);
3116 tend = uvchr_to_utf8(tmpbuf, uv);
3118 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
3120 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3121 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3126 s = (U8*)SvPV_force(sv, slen);
3127 Copy(tmpbuf, s, ulen, U8);
3131 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3133 SvUTF8_off(TARG); /* decontaminate */
3138 s = (U8*)SvPV_force(sv, slen);
3140 if (PL_op->op_private & OPpLOCALE) {
3143 *s = toLOWER_LC(*s);
3167 s = (U8*)SvPV(sv,len);
3169 SvUTF8_off(TARG); /* decontaminate */
3170 sv_setpvn(TARG, "", 0);
3174 (void)SvUPGRADE(TARG, SVt_PV);
3175 SvGROW(TARG, (len * 2) + 1);
3176 (void)SvPOK_only(TARG);
3177 d = (U8*)SvPVX(TARG);
3179 if (PL_op->op_private & OPpLOCALE) {
3183 d = uvchr_to_utf8(d, toUPPER_LC_uvchr( utf8n_to_uvchr(s, len, &ulen, 0)));
3189 d = uvchr_to_utf8(d, toUPPER_utf8( s ));
3195 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3200 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3202 SvUTF8_off(TARG); /* decontaminate */
3207 s = (U8*)SvPV_force(sv, len);
3209 register U8 *send = s + len;
3211 if (PL_op->op_private & OPpLOCALE) {
3214 for (; s < send; s++)
3215 *s = toUPPER_LC(*s);
3218 for (; s < send; s++)
3241 s = (U8*)SvPV(sv,len);
3243 SvUTF8_off(TARG); /* decontaminate */
3244 sv_setpvn(TARG, "", 0);
3248 (void)SvUPGRADE(TARG, SVt_PV);
3249 SvGROW(TARG, (len * 2) + 1);
3250 (void)SvPOK_only(TARG);
3251 d = (U8*)SvPVX(TARG);
3253 if (PL_op->op_private & OPpLOCALE) {
3257 d = uvchr_to_utf8(d, toLOWER_LC_uvchr( utf8n_to_uvchr(s, len, &ulen, 0)));
3263 d = uvchr_to_utf8(d, toLOWER_utf8(s));
3269 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3274 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3276 SvUTF8_off(TARG); /* decontaminate */
3282 s = (U8*)SvPV_force(sv, len);
3284 register U8 *send = s + len;
3286 if (PL_op->op_private & OPpLOCALE) {
3289 for (; s < send; s++)
3290 *s = toLOWER_LC(*s);
3293 for (; s < send; s++)
3308 register char *s = SvPV(sv,len);
3311 SvUTF8_off(TARG); /* decontaminate */
3313 (void)SvUPGRADE(TARG, SVt_PV);
3314 SvGROW(TARG, (len * 2) + 1);
3318 if (UTF8_IS_CONTINUED(*s)) {
3319 STRLEN ulen = UTF8SKIP(s);
3343 SvCUR_set(TARG, d - SvPVX(TARG));
3344 (void)SvPOK_only_UTF8(TARG);
3347 sv_setpvn(TARG, s, len);
3349 if (SvSMAGICAL(TARG))
3358 dSP; dMARK; dORIGMARK;
3360 register AV* av = (AV*)POPs;
3361 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3362 I32 arybase = PL_curcop->cop_arybase;
3365 if (SvTYPE(av) == SVt_PVAV) {
3366 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3368 for (svp = MARK + 1; svp <= SP; svp++) {
3373 if (max > AvMAX(av))
3376 while (++MARK <= SP) {
3377 elem = SvIVx(*MARK);
3381 svp = av_fetch(av, elem, lval);
3383 if (!svp || *svp == &PL_sv_undef)
3384 DIE(aTHX_ PL_no_aelem, elem);
3385 if (PL_op->op_private & OPpLVAL_INTRO)
3386 save_aelem(av, elem, svp);
3388 *MARK = svp ? *svp : &PL_sv_undef;
3391 if (GIMME != G_ARRAY) {
3399 /* Associative arrays. */
3404 HV *hash = (HV*)POPs;
3406 I32 gimme = GIMME_V;
3407 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
3410 /* might clobber stack_sp */
3411 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
3416 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
3417 if (gimme == G_ARRAY) {
3420 /* might clobber stack_sp */
3422 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
3427 else if (gimme == G_SCALAR)
3446 I32 gimme = GIMME_V;
3447 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3451 if (PL_op->op_private & OPpSLICE) {
3455 hvtype = SvTYPE(hv);
3456 if (hvtype == SVt_PVHV) { /* hash element */
3457 while (++MARK <= SP) {
3458 sv = hv_delete_ent(hv, *MARK, discard, 0);
3459 *MARK = sv ? sv : &PL_sv_undef;
3462 else if (hvtype == SVt_PVAV) {
3463 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3464 while (++MARK <= SP) {
3465 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3466 *MARK = sv ? sv : &PL_sv_undef;
3469 else { /* pseudo-hash element */
3470 while (++MARK <= SP) {
3471 sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
3472 *MARK = sv ? sv : &PL_sv_undef;
3477 DIE(aTHX_ "Not a HASH reference");
3480 else if (gimme == G_SCALAR) {
3489 if (SvTYPE(hv) == SVt_PVHV)
3490 sv = hv_delete_ent(hv, keysv, discard, 0);
3491 else if (SvTYPE(hv) == SVt_PVAV) {
3492 if (PL_op->op_flags & OPf_SPECIAL)
3493 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3495 sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
3498 DIE(aTHX_ "Not a HASH reference");
3513 if (PL_op->op_private & OPpEXISTS_SUB) {
3517 cv = sv_2cv(sv, &hv, &gv, FALSE);
3520 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3526 if (SvTYPE(hv) == SVt_PVHV) {
3527 if (hv_exists_ent(hv, tmpsv, 0))
3530 else if (SvTYPE(hv) == SVt_PVAV) {
3531 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3532 if (av_exists((AV*)hv, SvIV(tmpsv)))
3535 else if (avhv_exists_ent((AV*)hv, tmpsv, 0)) /* pseudo-hash element */
3539 DIE(aTHX_ "Not a HASH reference");
3546 dSP; dMARK; dORIGMARK;
3547 register HV *hv = (HV*)POPs;
3548 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3549 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
3551 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
3552 DIE(aTHX_ "Can't localize pseudo-hash element");
3554 if (realhv || SvTYPE(hv) == SVt_PVAV) {
3555 while (++MARK <= SP) {
3558 I32 preeminent = SvRMAGICAL(hv) ? 1 : hv_exists_ent(hv, keysv, 0);
3560 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
3561 svp = he ? &HeVAL(he) : 0;
3564 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
3567 if (!svp || *svp == &PL_sv_undef) {
3569 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3571 if (PL_op->op_private & OPpLVAL_INTRO) {
3573 save_helem(hv, keysv, svp);
3576 char *key = SvPV(keysv, keylen);
3577 SAVEDELETE(hv, savepvn(key,keylen), keylen);
3581 *MARK = svp ? *svp : &PL_sv_undef;
3584 if (GIMME != G_ARRAY) {
3592 /* List operators. */
3597 if (GIMME != G_ARRAY) {
3599 *MARK = *SP; /* unwanted list, return last item */
3601 *MARK = &PL_sv_undef;
3610 SV **lastrelem = PL_stack_sp;
3611 SV **lastlelem = PL_stack_base + POPMARK;
3612 SV **firstlelem = PL_stack_base + POPMARK + 1;
3613 register SV **firstrelem = lastlelem + 1;
3614 I32 arybase = PL_curcop->cop_arybase;
3615 I32 lval = PL_op->op_flags & OPf_MOD;
3616 I32 is_something_there = lval;
3618 register I32 max = lastrelem - lastlelem;
3619 register SV **lelem;
3622 if (GIMME != G_ARRAY) {
3623 ix = SvIVx(*lastlelem);
3628 if (ix < 0 || ix >= max)
3629 *firstlelem = &PL_sv_undef;
3631 *firstlelem = firstrelem[ix];
3637 SP = firstlelem - 1;
3641 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3647 if (ix < 0 || ix >= max)
3648 *lelem = &PL_sv_undef;
3650 is_something_there = TRUE;
3651 if (!(*lelem = firstrelem[ix]))
3652 *lelem = &PL_sv_undef;
3655 if (is_something_there)
3658 SP = firstlelem - 1;
3664 dSP; dMARK; dORIGMARK;
3665 I32 items = SP - MARK;
3666 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
3667 SP = ORIGMARK; /* av_make() might realloc stack_sp */
3674 dSP; dMARK; dORIGMARK;
3675 HV* hv = (HV*)sv_2mortal((SV*)newHV());
3679 SV *val = NEWSV(46, 0);
3681 sv_setsv(val, *++MARK);
3682 else if (ckWARN(WARN_MISC))
3683 Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
3684 (void)hv_store_ent(hv,key,val,0);
3693 dSP; dMARK; dORIGMARK;
3694 register AV *ary = (AV*)*++MARK;
3698 register I32 offset;
3699 register I32 length;
3706 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3707 *MARK-- = SvTIED_obj((SV*)ary, mg);
3711 call_method("SPLICE",GIMME_V);
3720 offset = i = SvIVx(*MARK);
3722 offset += AvFILLp(ary) + 1;
3724 offset -= PL_curcop->cop_arybase;
3726 DIE(aTHX_ PL_no_aelem, i);
3728 length = SvIVx(*MARK++);
3730 length += AvFILLp(ary) - offset + 1;
3736 length = AvMAX(ary) + 1; /* close enough to infinity */
3740 length = AvMAX(ary) + 1;
3742 if (offset > AvFILLp(ary) + 1)
3743 offset = AvFILLp(ary) + 1;
3744 after = AvFILLp(ary) + 1 - (offset + length);
3745 if (after < 0) { /* not that much array */
3746 length += after; /* offset+length now in array */
3752 /* At this point, MARK .. SP-1 is our new LIST */
3755 diff = newlen - length;
3756 if (newlen && !AvREAL(ary) && AvREIFY(ary))
3759 if (diff < 0) { /* shrinking the area */
3761 New(451, tmparyval, newlen, SV*); /* so remember insertion */
3762 Copy(MARK, tmparyval, newlen, SV*);
3765 MARK = ORIGMARK + 1;
3766 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3767 MEXTEND(MARK, length);
3768 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
3770 EXTEND_MORTAL(length);
3771 for (i = length, dst = MARK; i; i--) {
3772 sv_2mortal(*dst); /* free them eventualy */
3779 *MARK = AvARRAY(ary)[offset+length-1];
3782 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
3783 SvREFCNT_dec(*dst++); /* free them now */
3786 AvFILLp(ary) += diff;
3788 /* pull up or down? */
3790 if (offset < after) { /* easier to pull up */
3791 if (offset) { /* esp. if nothing to pull */
3792 src = &AvARRAY(ary)[offset-1];
3793 dst = src - diff; /* diff is negative */
3794 for (i = offset; i > 0; i--) /* can't trust Copy */
3798 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
3802 if (after) { /* anything to pull down? */
3803 src = AvARRAY(ary) + offset + length;
3804 dst = src + diff; /* diff is negative */
3805 Move(src, dst, after, SV*);
3807 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
3808 /* avoid later double free */
3812 dst[--i] = &PL_sv_undef;
3815 for (src = tmparyval, dst = AvARRAY(ary) + offset;
3817 *dst = NEWSV(46, 0);
3818 sv_setsv(*dst++, *src++);
3820 Safefree(tmparyval);
3823 else { /* no, expanding (or same) */
3825 New(452, tmparyval, length, SV*); /* so remember deletion */
3826 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
3829 if (diff > 0) { /* expanding */
3831 /* push up or down? */
3833 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
3837 Move(src, dst, offset, SV*);
3839 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
3841 AvFILLp(ary) += diff;
3844 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
3845 av_extend(ary, AvFILLp(ary) + diff);
3846 AvFILLp(ary) += diff;
3849 dst = AvARRAY(ary) + AvFILLp(ary);
3851 for (i = after; i; i--) {
3858 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3859 *dst = NEWSV(46, 0);
3860 sv_setsv(*dst++, *src++);
3862 MARK = ORIGMARK + 1;
3863 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3865 Copy(tmparyval, MARK, length, SV*);
3867 EXTEND_MORTAL(length);
3868 for (i = length, dst = MARK; i; i--) {
3869 sv_2mortal(*dst); /* free them eventualy */
3873 Safefree(tmparyval);
3877 else if (length--) {
3878 *MARK = tmparyval[length];
3881 while (length-- > 0)
3882 SvREFCNT_dec(tmparyval[length]);
3884 Safefree(tmparyval);
3887 *MARK = &PL_sv_undef;
3895 dSP; dMARK; dORIGMARK; dTARGET;
3896 register AV *ary = (AV*)*++MARK;
3897 register SV *sv = &PL_sv_undef;
3900 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3901 *MARK-- = SvTIED_obj((SV*)ary, mg);
3905 call_method("PUSH",G_SCALAR|G_DISCARD);
3910 /* Why no pre-extend of ary here ? */
3911 for (++MARK; MARK <= SP; MARK++) {
3914 sv_setsv(sv, *MARK);
3919 PUSHi( AvFILL(ary) + 1 );
3927 SV *sv = av_pop(av);
3929 (void)sv_2mortal(sv);
3938 SV *sv = av_shift(av);
3943 (void)sv_2mortal(sv);
3950 dSP; dMARK; dORIGMARK; dTARGET;
3951 register AV *ary = (AV*)*++MARK;
3956 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3957 *MARK-- = SvTIED_obj((SV*)ary, mg);
3961 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3966 av_unshift(ary, SP - MARK);
3969 sv_setsv(sv, *++MARK);
3970 (void)av_store(ary, i++, sv);
3974 PUSHi( AvFILL(ary) + 1 );
3984 if (GIMME == G_ARRAY) {
3991 /* safe as long as stack cannot get extended in the above */
3996 register char *down;
4001 SvUTF8_off(TARG); /* decontaminate */
4003 do_join(TARG, &PL_sv_no, MARK, SP);
4005 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
4006 up = SvPV_force(TARG, len);
4008 if (DO_UTF8(TARG)) { /* first reverse each character */
4009 U8* s = (U8*)SvPVX(TARG);
4010 U8* send = (U8*)(s + len);
4012 if (UTF8_IS_INVARIANT(*s)) {
4017 if (!utf8_to_uvchr(s, 0))
4021 down = (char*)(s - 1);
4022 /* reverse this character */
4032 down = SvPVX(TARG) + len - 1;
4038 (void)SvPOK_only_UTF8(TARG);
4047 S_mul128(pTHX_ SV *sv, U8 m)
4050 char *s = SvPV(sv, len);
4054 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
4055 SV *tmpNew = newSVpvn("0000000000", 10);
4057 sv_catsv(tmpNew, sv);
4058 SvREFCNT_dec(sv); /* free old sv */
4063 while (!*t) /* trailing '\0'? */
4066 i = ((*t - '0') << 7) + m;
4067 *(t--) = '0' + (i % 10);
4073 /* Explosives and implosives. */
4075 #if 'I' == 73 && 'J' == 74
4076 /* On an ASCII/ISO kind of system */
4077 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
4080 Some other sort of character set - use memchr() so we don't match
4083 #define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
4091 I32 start_sp_offset = SP - PL_stack_base;
4092 I32 gimme = GIMME_V;
4096 register char *pat = SvPV(left, llen);
4097 #ifdef PACKED_IS_OCTETS
4098 /* Packed side is assumed to be octets - so force downgrade if it
4099 has been UTF-8 encoded by accident
4101 register char *s = SvPVbyte(right, rlen);
4103 register char *s = SvPV(right, rlen);
4105 char *strend = s + rlen;
4107 register char *patend = pat + llen;
4113 /* These must not be in registers: */
4130 register U32 culong;
4134 #ifdef PERL_NATINT_PACK
4135 int natint; /* native integer */
4136 int unatint; /* unsigned native integer */
4139 if (gimme != G_ARRAY) { /* arrange to do first one only */
4141 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
4142 if (strchr("aAZbBhHP", *patend) || *pat == '%') {
4144 while (isDIGIT(*patend) || *patend == '*')
4150 while (pat < patend) {
4152 datumtype = *pat++ & 0xFF;
4153 #ifdef PERL_NATINT_PACK
4156 if (isSPACE(datumtype))
4158 if (datumtype == '#') {
4159 while (pat < patend && *pat != '\n')
4164 char *natstr = "sSiIlL";
4166 if (strchr(natstr, datumtype)) {
4167 #ifdef PERL_NATINT_PACK
4173 DIE(aTHX_ "'!' allowed only after types %s", natstr);
4178 else if (*pat == '*') {
4179 len = strend - strbeg; /* long enough */
4183 else if (isDIGIT(*pat)) {
4185 while (isDIGIT(*pat)) {
4186 len = (len * 10) + (*pat++ - '0');
4188 DIE(aTHX_ "Repeat count in unpack overflows");
4192 len = (datumtype != '@');
4196 DIE(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
4197 case ',': /* grandfather in commas but with a warning */
4198 if (commas++ == 0 && ckWARN(WARN_UNPACK))
4199 Perl_warner(aTHX_ WARN_UNPACK,
4200 "Invalid type in unpack: '%c'", (int)datumtype);
4203 if (len == 1 && pat[-1] != '1')
4212 if (len > strend - strbeg)
4213 DIE(aTHX_ "@ outside of string");
4217 if (len > s - strbeg)
4218 DIE(aTHX_ "X outside of string");
4222 if (len > strend - s)
4223 DIE(aTHX_ "x outside of string");
4227 if (start_sp_offset >= SP - PL_stack_base)
4228 DIE(aTHX_ "/ must follow a numeric type");
4231 pat++; /* ignore '*' for compatibility with pack */
4233 DIE(aTHX_ "/ cannot take a count" );
4240 if (len > strend - s)
4243 goto uchar_checksum;
4244 sv = NEWSV(35, len);
4245 sv_setpvn(sv, s, len);
4247 if (datumtype == 'A' || datumtype == 'Z') {
4248 aptr = s; /* borrow register */
4249 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
4254 else { /* 'A' strips both nulls and spaces */
4255 s = SvPVX(sv) + len - 1;
4256 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
4260 SvCUR_set(sv, s - SvPVX(sv));
4261 s = aptr; /* unborrow register */
4263 XPUSHs(sv_2mortal(sv));
4267 if (star || len > (strend - s) * 8)
4268 len = (strend - s) * 8;
4271 Newz(601, PL_bitcount, 256, char);
4272 for (bits = 1; bits < 256; bits++) {
4273 if (bits & 1) PL_bitcount[bits]++;
4274 if (bits & 2) PL_bitcount[bits]++;
4275 if (bits & 4) PL_bitcount[bits]++;
4276 if (bits & 8) PL_bitcount[bits]++;
4277 if (bits & 16) PL_bitcount[bits]++;
4278 if (bits & 32) PL_bitcount[bits]++;
4279 if (bits & 64) PL_bitcount[bits]++;
4280 if (bits & 128) PL_bitcount[bits]++;
4284 culong += PL_bitcount[*(unsigned char*)s++];
4289 if (datumtype == 'b') {
4291 if (bits & 1) culong++;
4297 if (bits & 128) culong++;
4304 sv = NEWSV(35, len + 1);
4308 if (datumtype == 'b') {
4310 for (len = 0; len < aint; len++) {
4311 if (len & 7) /*SUPPRESS 595*/
4315 *str++ = '0' + (bits & 1);
4320 for (len = 0; len < aint; len++) {
4325 *str++ = '0' + ((bits & 128) != 0);
4329 XPUSHs(sv_2mortal(sv));
4333 if (star || len > (strend - s) * 2)
4334 len = (strend - s) * 2;
4335 sv = NEWSV(35, len + 1);
4339 if (datumtype == 'h') {
4341 for (len = 0; len < aint; len++) {
4346 *str++ = PL_hexdigit[bits & 15];
4351 for (len = 0; len < aint; len++) {
4356 *str++ = PL_hexdigit[(bits >> 4) & 15];
4360 XPUSHs(sv_2mortal(sv));
4363 if (len > strend - s)
4368 if (aint >= 128) /* fake up signed chars */
4378 if (aint >= 128) /* fake up signed chars */
4381 sv_setiv(sv, (IV)aint);
4382 PUSHs(sv_2mortal(sv));
4387 if (len > strend - s)
4402 sv_setiv(sv, (IV)auint);
4403 PUSHs(sv_2mortal(sv));
4408 if (len > strend - s)
4411 while (len-- > 0 && s < strend) {
4413 auint = utf8n_to_uvchr((U8*)s, strend - s, &alen, 0);
4417 cdouble += (NV)auint;
4425 while (len-- > 0 && s < strend) {
4427 auint = utf8n_to_uvchr((U8*)s, strend - s, &alen, 0);
4431 sv_setuv(sv, (UV)auint);
4432 PUSHs(sv_2mortal(sv));
4437 #if SHORTSIZE == SIZE16
4438 along = (strend - s) / SIZE16;
4440 along = (strend - s) / (natint ? sizeof(short) : SIZE16);
4445 #if SHORTSIZE != SIZE16
4449 COPYNN(s, &ashort, sizeof(short));
4460 #if SHORTSIZE > SIZE16
4472 #if SHORTSIZE != SIZE16
4476 COPYNN(s, &ashort, sizeof(short));
4479 sv_setiv(sv, (IV)ashort);
4480 PUSHs(sv_2mortal(sv));
4488 #if SHORTSIZE > SIZE16
4494 sv_setiv(sv, (IV)ashort);
4495 PUSHs(sv_2mortal(sv));
4503 #if SHORTSIZE == SIZE16
4504 along = (strend - s) / SIZE16;
4506 unatint = natint && datumtype == 'S';
4507 along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
4512 #if SHORTSIZE != SIZE16
4514 unsigned short aushort;
4516 COPYNN(s, &aushort, sizeof(unsigned short));
4517 s += sizeof(unsigned short);
4525 COPY16(s, &aushort);
4528 if (datumtype == 'n')
4529 aushort = PerlSock_ntohs(aushort);
4532 if (datumtype == 'v')
4533 aushort = vtohs(aushort);
4542 #if SHORTSIZE != SIZE16
4544 unsigned short aushort;
4546 COPYNN(s, &aushort, sizeof(unsigned short));
4547 s += sizeof(unsigned short);
4549 sv_setiv(sv, (UV)aushort);
4550 PUSHs(sv_2mortal(sv));
4557 COPY16(s, &aushort);
4561 if (datumtype == 'n')
4562 aushort = PerlSock_ntohs(aushort);
4565 if (datumtype == 'v')
4566 aushort = vtohs(aushort);
4568 sv_setiv(sv, (UV)aushort);
4569 PUSHs(sv_2mortal(sv));
4575 along = (strend - s) / sizeof(int);
4580 Copy(s, &aint, 1, int);
4583 cdouble += (NV)aint;
4592 Copy(s, &aint, 1, int);
4596 /* Without the dummy below unpack("i", pack("i",-1))
4597 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
4598 * cc with optimization turned on.
4600 * The bug was detected in
4601 * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
4602 * with optimization (-O4) turned on.
4603 * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
4604 * does not have this problem even with -O4.
4606 * This bug was reported as DECC_BUGS 1431
4607 * and tracked internally as GEM_BUGS 7775.
4609 * The bug is fixed in
4610 * Tru64 UNIX V5.0: Compaq C V6.1-006 or later
4611 * UNIX V4.0F support: DEC C V5.9-006 or later
4612 * UNIX V4.0E support: DEC C V5.8-011 or later
4615 * See also few lines later for the same bug.
4618 sv_setiv(sv, (IV)aint) :
4620 sv_setiv(sv, (IV)aint);
4621 PUSHs(sv_2mortal(sv));
4626 along = (strend - s) / sizeof(unsigned int);
4631 Copy(s, &auint, 1, unsigned int);
4632 s += sizeof(unsigned int);
4634 cdouble += (NV)auint;
4643 Copy(s, &auint, 1, unsigned int);
4644 s += sizeof(unsigned int);
4647 /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
4648 * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
4649 * See details few lines earlier. */
4651 sv_setuv(sv, (UV)auint) :
4653 sv_setuv(sv, (UV)auint);
4654 PUSHs(sv_2mortal(sv));
4659 #if LONGSIZE == SIZE32
4660 along = (strend - s) / SIZE32;
4662 along = (strend - s) / (natint ? sizeof(long) : SIZE32);
4667 #if LONGSIZE != SIZE32
4670 COPYNN(s, &along, sizeof(long));
4673 cdouble += (NV)along;
4682 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
4686 #if LONGSIZE > SIZE32
4687 if (along > 2147483647)
4688 along -= 4294967296;
4692 cdouble += (NV)along;
4701 #if LONGSIZE != SIZE32
4704 COPYNN(s, &along, sizeof(long));
4707 sv_setiv(sv, (IV)along);
4708 PUSHs(sv_2mortal(sv));
4715 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
4719 #if LONGSIZE > SIZE32
4720 if (along > 2147483647)
4721 along -= 4294967296;
4725 sv_setiv(sv, (IV)along);
4726 PUSHs(sv_2mortal(sv));
4734 #if LONGSIZE == SIZE32
4735 along = (strend - s) / SIZE32;
4737 unatint = natint && datumtype == 'L';
4738 along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
4743 #if LONGSIZE != SIZE32
4745 unsigned long aulong;
4747 COPYNN(s, &aulong, sizeof(unsigned long));
4748 s += sizeof(unsigned long);
4750 cdouble += (NV)aulong;
4762 if (datumtype == 'N')
4763 aulong = PerlSock_ntohl(aulong);
4766 if (datumtype == 'V')
4767 aulong = vtohl(aulong);
4770 cdouble += (NV)aulong;
4779 #if LONGSIZE != SIZE32
4781 unsigned long aulong;
4783 COPYNN(s, &aulong, sizeof(unsigned long));
4784 s += sizeof(unsigned long);
4786 sv_setuv(sv, (UV)aulong);
4787 PUSHs(sv_2mortal(sv));
4797 if (datumtype == 'N')
4798 aulong = PerlSock_ntohl(aulong);
4801 if (datumtype == 'V')
4802 aulong = vtohl(aulong);
4805 sv_setuv(sv, (UV)aulong);
4806 PUSHs(sv_2mortal(sv));
4812 along = (strend - s) / sizeof(char*);
4818 if (sizeof(char*) > strend - s)
4821 Copy(s, &aptr, 1, char*);
4827 PUSHs(sv_2mortal(sv));
4837 while ((len > 0) && (s < strend)) {
4838 auv = (auv << 7) | (*s & 0x7f);
4839 /* UTF8_IS_XXXXX not right here - using constant 0x80 */
4840 if ((U8)(*s++) < 0x80) {
4844 PUSHs(sv_2mortal(sv));
4848 else if (++bytes >= sizeof(UV)) { /* promote to string */
4852 sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv);
4853 while (s < strend) {
4854 sv = mul128(sv, *s & 0x7f);
4855 if (!(*s++ & 0x80)) {
4864 PUSHs(sv_2mortal(sv));
4869 if ((s >= strend) && bytes)
4870 DIE(aTHX_ "Unterminated compressed integer");
4875 if (sizeof(char*) > strend - s)
4878 Copy(s, &aptr, 1, char*);
4883 sv_setpvn(sv, aptr, len);
4884 PUSHs(sv_2mortal(sv));
4888 along = (strend - s) / sizeof(Quad_t);
4894 if (s + sizeof(Quad_t) > strend)
4897 Copy(s, &aquad, 1, Quad_t);
4898 s += sizeof(Quad_t);
4901 if (aquad >= IV_MIN && aquad <= IV_MAX)
4902 sv_setiv(sv, (IV)aquad);
4904 sv_setnv(sv, (NV)aquad);
4905 PUSHs(sv_2mortal(sv));
4909 along = (strend - s) / sizeof(Quad_t);
4915 if (s + sizeof(Uquad_t) > strend)
4918 Copy(s, &auquad, 1, Uquad_t);
4919 s += sizeof(Uquad_t);
4922 if (auquad <= UV_MAX)
4923 sv_setuv(sv, (UV)auquad);
4925 sv_setnv(sv, (NV)auquad);
4926 PUSHs(sv_2mortal(sv));
4930 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
4933 along = (strend - s) / sizeof(float);
4938 Copy(s, &afloat, 1, float);
4947 Copy(s, &afloat, 1, float);
4950 sv_setnv(sv, (NV)afloat);
4951 PUSHs(sv_2mortal(sv));
4957 along = (strend - s) / sizeof(double);
4962 Copy(s, &adouble, 1, double);
4963 s += sizeof(double);
4971 Copy(s, &adouble, 1, double);
4972 s += sizeof(double);
4974 sv_setnv(sv, (NV)adouble);
4975 PUSHs(sv_2mortal(sv));
4981 * Initialise the decode mapping. By using a table driven
4982 * algorithm, the code will be character-set independent
4983 * (and just as fast as doing character arithmetic)
4985 if (PL_uudmap['M'] == 0) {
4988 for (i = 0; i < sizeof(PL_uuemap); i += 1)
4989 PL_uudmap[(U8)PL_uuemap[i]] = i;
4991 * Because ' ' and '`' map to the same value,
4992 * we need to decode them both the same.
4997 along = (strend - s) * 3 / 4;
4998 sv = NEWSV(42, along);
5001 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
5006 len = PL_uudmap[*(U8*)s++] & 077;
5008 if (s < strend && ISUUCHAR(*s))
5009 a = PL_uudmap[*(U8*)s++] & 077;
5012 if (s < strend && ISUUCHAR(*s))
5013 b = PL_uudmap[*(U8*)s++] & 077;
5016 if (s < strend && ISUUCHAR(*s))
5017 c = PL_uudmap[*(U8*)s++] & 077;
5020 if (s < strend && ISUUCHAR(*s))
5021 d = PL_uudmap[*(U8*)s++] & 077;
5024 hunk[0] = (a << 2) | (b >> 4);
5025 hunk[1] = (b << 4) | (c >> 2);
5026 hunk[2] = (c << 6) | d;
5027 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
5032 else if (s[1] == '\n') /* possible checksum byte */
5035 XPUSHs(sv_2mortal(sv));
5040 if (strchr("fFdD", datumtype) ||
5041 (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
5045 while (checksum >= 16) {
5049 while (checksum >= 4) {
5055 along = (1 << checksum) - 1;
5056 while (cdouble < 0.0)
5058 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
5059 sv_setnv(sv, cdouble);
5062 if (checksum < 32) {
5063 aulong = (1 << checksum) - 1;
5066 sv_setuv(sv, (UV)culong);
5068 XPUSHs(sv_2mortal(sv));
5072 if (SP - PL_stack_base == start_sp_offset && gimme == G_SCALAR)
5073 PUSHs(&PL_sv_undef);
5078 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
5082 *hunk = PL_uuemap[len];
5083 sv_catpvn(sv, hunk, 1);
5086 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
5087 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
5088 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
5089 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
5090 sv_catpvn(sv, hunk, 4);
5095 char r = (len > 1 ? s[1] : '\0');
5096 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
5097 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
5098 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
5099 hunk[3] = PL_uuemap[0];
5100 sv_catpvn(sv, hunk, 4);
5102 sv_catpvn(sv, "\n", 1);
5106 S_is_an_int(pTHX_ char *s, STRLEN l)
5109 SV *result = newSVpvn(s, l);
5110 char *result_c = SvPV(result, n_a); /* convenience */
5111 char *out = result_c;
5121 SvREFCNT_dec(result);
5144 SvREFCNT_dec(result);
5150 SvCUR_set(result, out - result_c);
5154 /* pnum must be '\0' terminated */
5156 S_div128(pTHX_ SV *pnum, bool *done)
5159 char *s = SvPV(pnum, len);
5168 i = m * 10 + (*t - '0');
5170 r = (i >> 7); /* r < 10 */
5177 SvCUR_set(pnum, (STRLEN) (t - s));
5184 dSP; dMARK; dORIGMARK; dTARGET;
5185 register SV *cat = TARG;
5188 register char *pat = SvPVx(*++MARK, fromlen);
5190 register char *patend = pat + fromlen;
5195 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
5196 static char *space10 = " ";
5198 /* These must not be in registers: */
5213 #ifdef PERL_NATINT_PACK
5214 int natint; /* native integer */
5219 sv_setpvn(cat, "", 0);
5221 while (pat < patend) {
5222 SV *lengthcode = Nullsv;
5223 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no)
5224 datumtype = *pat++ & 0xFF;
5225 #ifdef PERL_NATINT_PACK
5228 if (isSPACE(datumtype)) {
5232 #ifndef PACKED_IS_OCTETS
5233 if (datumtype == 'U' && pat == patcopy+1)
5236 if (datumtype == '#') {
5237 while (pat < patend && *pat != '\n')
5242 char *natstr = "sSiIlL";
5244 if (strchr(natstr, datumtype)) {
5245 #ifdef PERL_NATINT_PACK
5251 DIE(aTHX_ "'!' allowed only after types %s", natstr);
5254 len = strchr("@Xxu", datumtype) ? 0 : items;
5257 else if (isDIGIT(*pat)) {
5259 while (isDIGIT(*pat)) {
5260 len = (len * 10) + (*pat++ - '0');
5262 DIE(aTHX_ "Repeat count in pack overflows");
5269 if ((*pat != 'a' && *pat != 'A' && *pat != 'Z') || pat[1] != '*')
5270 DIE(aTHX_ "/ must be followed by a*, A* or Z*");
5271 lengthcode = sv_2mortal(newSViv(sv_len(items > 0
5272 ? *MARK : &PL_sv_no)
5273 + (*pat == 'Z' ? 1 : 0)));
5277 DIE(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
5278 case ',': /* grandfather in commas but with a warning */
5279 if (commas++ == 0 && ckWARN(WARN_PACK))
5280 Perl_warner(aTHX_ WARN_PACK,
5281 "Invalid type in pack: '%c'", (int)datumtype);
5284 DIE(aTHX_ "%% may only be used in unpack");
5295 if (SvCUR(cat) < len)
5296 DIE(aTHX_ "X outside of string");
5303 sv_catpvn(cat, null10, 10);
5306 sv_catpvn(cat, null10, len);
5312 aptr = SvPV(fromstr, fromlen);
5313 if (pat[-1] == '*') {
5315 if (datumtype == 'Z')
5318 if (fromlen >= len) {
5319 sv_catpvn(cat, aptr, len);
5320 if (datumtype == 'Z')
5321 *(SvEND(cat)-1) = '\0';
5324 sv_catpvn(cat, aptr, fromlen);
5326 if (datumtype == 'A') {
5328 sv_catpvn(cat, space10, 10);
5331 sv_catpvn(cat, space10, len);
5335 sv_catpvn(cat, null10, 10);
5338 sv_catpvn(cat, null10, len);
5350 str = SvPV(fromstr, fromlen);
5354 SvCUR(cat) += (len+7)/8;
5355 SvGROW(cat, SvCUR(cat) + 1);
5356 aptr = SvPVX(cat) + aint;
5361 if (datumtype == 'B') {
5362 for (len = 0; len++ < aint;) {
5363 items |= *str++ & 1;
5367 *aptr++ = items & 0xff;
5373 for (len = 0; len++ < aint;) {
5379 *aptr++ = items & 0xff;
5385 if (datumtype == 'B')
5386 items <<= 7 - (aint & 7);
5388 items >>= 7 - (aint & 7);
5389 *aptr++ = items & 0xff;
5391 str = SvPVX(cat) + SvCUR(cat);
5406 str = SvPV(fromstr, fromlen);
5410 SvCUR(cat) += (len+1)/2;
5411 SvGROW(cat, SvCUR(cat) + 1);
5412 aptr = SvPVX(cat) + aint;
5417 if (datumtype == 'H') {
5418 for (len = 0; len++ < aint;) {
5420 items |= ((*str++ & 15) + 9) & 15;
5422 items |= *str++ & 15;
5426 *aptr++ = items & 0xff;
5432 for (len = 0; len++ < aint;) {
5434 items |= (((*str++ & 15) + 9) & 15) << 4;
5436 items |= (*str++ & 15) << 4;
5440 *aptr++ = items & 0xff;
5446 *aptr++ = items & 0xff;
5447 str = SvPVX(cat) + SvCUR(cat);
5458 aint = SvIV(fromstr);
5460 sv_catpvn(cat, &achar, sizeof(char));
5466 auint = SvUV(fromstr);
5467 SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN + 1);
5468 SvCUR_set(cat, (char*)uvchr_to_utf8((U8*)SvEND(cat),auint)
5473 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
5478 afloat = (float)SvNV(fromstr);
5479 sv_catpvn(cat, (char *)&afloat, sizeof (float));
5486 adouble = (double)SvNV(fromstr);
5487 sv_catpvn(cat, (char *)&adouble, sizeof (double));
5493 ashort = (I16)SvIV(fromstr);
5495 ashort = PerlSock_htons(ashort);
5497 CAT16(cat, &ashort);
5503 ashort = (I16)SvIV(fromstr);
5505 ashort = htovs(ashort);
5507 CAT16(cat, &ashort);
5511 #if SHORTSIZE != SIZE16
5513 unsigned short aushort;
5517 aushort = SvUV(fromstr);
5518 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
5528 aushort = (U16)SvUV(fromstr);
5529 CAT16(cat, &aushort);
5535 #if SHORTSIZE != SIZE16
5541 ashort = SvIV(fromstr);
5542 sv_catpvn(cat, (char *)&ashort, sizeof(short));
5550 ashort = (I16)SvIV(fromstr);
5551 CAT16(cat, &ashort);
5558 auint = SvUV(fromstr);
5559 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
5565 adouble = Perl_floor(SvNV(fromstr));
5568 DIE(aTHX_ "Cannot compress negative numbers");
5571 #if UVSIZE > 4 && UVSIZE >= NVSIZE
5572 adouble <= 0xffffffff
5574 # ifdef CXUX_BROKEN_CONSTANT_CONVERT
5575 adouble <= UV_MAX_cxux
5582 char buf[1 + sizeof(UV)];
5583 char *in = buf + sizeof(buf);
5584 UV auv = U_V(adouble);
5587 *--in = (auv & 0x7f) | 0x80;
5590 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
5591 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
5593 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
5594 char *from, *result, *in;
5599 /* Copy string and check for compliance */
5600 from = SvPV(fromstr, len);
5601 if ((norm = is_an_int(from, len)) == NULL)
5602 DIE(aTHX_ "can compress only unsigned integer");
5604 New('w', result, len, char);
5608 *--in = div128(norm, &done) | 0x80;
5609 result[len - 1] &= 0x7F; /* clear continue bit */
5610 sv_catpvn(cat, in, (result + len) - in);
5612 SvREFCNT_dec(norm); /* free norm */
5614 else if (SvNOKp(fromstr)) {
5615 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
5616 char *in = buf + sizeof(buf);
5619 double next = floor(adouble / 128);
5620 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
5621 if (in <= buf) /* this cannot happen ;-) */
5622 DIE(aTHX_ "Cannot compress integer");
5625 } while (adouble > 0);
5626 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
5627 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
5630 DIE(aTHX_ "Cannot compress non integer");
5636 aint = SvIV(fromstr);
5637 sv_catpvn(cat, (char*)&aint, sizeof(int));
5643 aulong = SvUV(fromstr);
5645 aulong = PerlSock_htonl(aulong);
5647 CAT32(cat, &aulong);
5653 aulong = SvUV(fromstr);
5655 aulong = htovl(aulong);
5657 CAT32(cat, &aulong);
5661 #if LONGSIZE != SIZE32
5663 unsigned long aulong;
5667 aulong = SvUV(fromstr);
5668 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
5676 aulong = SvUV(fromstr);
5677 CAT32(cat, &aulong);
5682 #if LONGSIZE != SIZE32
5688 along = SvIV(fromstr);
5689 sv_catpvn(cat, (char *)&along, sizeof(long));
5697 along = SvIV(fromstr);
5706 auquad = (Uquad_t)SvUV(fromstr);
5707 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
5713 aquad = (Quad_t)SvIV(fromstr);
5714 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
5719 len = 1; /* assume SV is correct length */
5724 if (fromstr == &PL_sv_undef)
5728 /* XXX better yet, could spirit away the string to
5729 * a safe spot and hang on to it until the result
5730 * of pack() (and all copies of the result) are
5733 if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
5734 || (SvPADTMP(fromstr)
5735 && !SvREADONLY(fromstr))))
5737 Perl_warner(aTHX_ WARN_PACK,
5738 "Attempt to pack pointer to temporary value");
5740 if (SvPOK(fromstr) || SvNIOK(fromstr))
5741 aptr = SvPV(fromstr,n_a);
5743 aptr = SvPV_force(fromstr,n_a);
5745 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
5750 aptr = SvPV(fromstr, fromlen);
5751 SvGROW(cat, fromlen * 4 / 3);
5756 while (fromlen > 0) {
5763 doencodes(cat, aptr, todo);
5782 register IV limit = POPi; /* note, negative is forever */
5785 register char *s = SvPV(sv, len);
5786 bool do_utf8 = DO_UTF8(sv);
5787 char *strend = s + len;
5789 register REGEXP *rx;
5793 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
5794 I32 maxiters = slen + 10;
5797 I32 origlimit = limit;
5800 AV *oldstack = PL_curstack;
5801 I32 gimme = GIMME_V;
5802 I32 oldsave = PL_savestack_ix;
5803 I32 make_mortal = 1;
5804 MAGIC *mg = (MAGIC *) NULL;
5807 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5812 DIE(aTHX_ "panic: pp_split");
5813 rx = pm->op_pmregexp;
5815 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
5816 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
5818 if (pm->op_pmreplroot) {
5820 ary = GvAVn((GV*)PL_curpad[(PADOFFSET)pm->op_pmreplroot]);
5822 ary = GvAVn((GV*)pm->op_pmreplroot);
5825 else if (gimme != G_ARRAY)
5827 ary = (AV*)PL_curpad[0];
5829 ary = GvAVn(PL_defgv);
5830 #endif /* USE_THREADS */
5833 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
5839 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
5841 XPUSHs(SvTIED_obj((SV*)ary, mg));
5847 for (i = AvFILLp(ary); i >= 0; i--)
5848 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5850 /* temporarily switch stacks */
5851 SWITCHSTACK(PL_curstack, ary);
5855 base = SP - PL_stack_base;
5857 if (pm->op_pmflags & PMf_SKIPWHITE) {
5858 if (pm->op_pmflags & PMf_LOCALE) {
5859 while (isSPACE_LC(*s))
5867 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
5868 SAVEINT(PL_multiline);
5869 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
5873 limit = maxiters + 2;
5874 if (pm->op_pmflags & PMf_WHITE) {
5877 while (m < strend &&
5878 !((pm->op_pmflags & PMf_LOCALE)
5879 ? isSPACE_LC(*m) : isSPACE(*m)))
5884 dstr = NEWSV(30, m-s);
5885 sv_setpvn(dstr, s, m-s);
5889 (void)SvUTF8_on(dstr);
5893 while (s < strend &&
5894 ((pm->op_pmflags & PMf_LOCALE)
5895 ? isSPACE_LC(*s) : isSPACE(*s)))
5899 else if (strEQ("^", rx->precomp)) {
5902 for (m = s; m < strend && *m != '\n'; m++) ;
5906 dstr = NEWSV(30, m-s);
5907 sv_setpvn(dstr, s, m-s);
5911 (void)SvUTF8_on(dstr);
5916 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
5917 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
5918 && (rx->reganch & ROPT_CHECK_ALL)
5919 && !(rx->reganch & ROPT_ANCH)) {
5920 int tail = (rx->reganch & RE_INTUIT_TAIL);
5921 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
5924 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
5926 char c = *SvPV(csv, n_a);
5929 for (m = s; m < strend && *m != c; m++) ;
5932 dstr = NEWSV(30, m-s);
5933 sv_setpvn(dstr, s, m-s);
5937 (void)SvUTF8_on(dstr);
5939 /* The rx->minlen is in characters but we want to step
5940 * s ahead by bytes. */
5942 s = (char*)utf8_hop((U8*)m, len);
5944 s = m + len; /* Fake \n at the end */
5949 while (s < strend && --limit &&
5950 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5951 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
5954 dstr = NEWSV(31, m-s);
5955 sv_setpvn(dstr, s, m-s);
5959 (void)SvUTF8_on(dstr);
5961 /* The rx->minlen is in characters but we want to step
5962 * s ahead by bytes. */
5964 s = (char*)utf8_hop((U8*)m, len);
5966 s = m + len; /* Fake \n at the end */
5971 maxiters += slen * rx->nparens;
5972 while (s < strend && --limit
5973 /* && (!rx->check_substr
5974 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
5976 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
5977 1 /* minend */, sv, NULL, 0))
5979 TAINT_IF(RX_MATCH_TAINTED(rx));
5980 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
5985 strend = s + (strend - m);
5987 m = rx->startp[0] + orig;
5988 dstr = NEWSV(32, m-s);
5989 sv_setpvn(dstr, s, m-s);
5993 (void)SvUTF8_on(dstr);
5996 for (i = 1; i <= rx->nparens; i++) {
5997 s = rx->startp[i] + orig;
5998 m = rx->endp[i] + orig;
6000 dstr = NEWSV(33, m-s);
6001 sv_setpvn(dstr, s, m-s);
6004 dstr = NEWSV(33, 0);
6008 (void)SvUTF8_on(dstr);
6012 s = rx->endp[0] + orig;
6016 LEAVE_SCOPE(oldsave);
6017 iters = (SP - PL_stack_base) - base;
6018 if (iters > maxiters)
6019 DIE(aTHX_ "Split loop");
6021 /* keep field after final delim? */
6022 if (s < strend || (iters && origlimit)) {
6023 STRLEN l = strend - s;
6024 dstr = NEWSV(34, l);
6025 sv_setpvn(dstr, s, l);
6029 (void)SvUTF8_on(dstr);
6033 else if (!origlimit) {
6034 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
6040 SWITCHSTACK(ary, oldstack);
6041 if (SvSMAGICAL(ary)) {
6046 if (gimme == G_ARRAY) {
6048 Copy(AvARRAY(ary), SP + 1, iters, SV*);
6056 call_method("PUSH",G_SCALAR|G_DISCARD);
6059 if (gimme == G_ARRAY) {
6060 /* EXTEND should not be needed - we just popped them */
6062 for (i=0; i < iters; i++) {
6063 SV **svp = av_fetch(ary, i, FALSE);
6064 PUSHs((svp) ? *svp : &PL_sv_undef);
6071 if (gimme == G_ARRAY)
6074 if (iters || !pm->op_pmreplroot) {
6084 Perl_unlock_condpair(pTHX_ void *svv)
6086 MAGIC *mg = mg_find((SV*)svv, 'm');
6089 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
6090 MUTEX_LOCK(MgMUTEXP(mg));
6091 if (MgOWNER(mg) != thr)
6092 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
6094 COND_SIGNAL(MgOWNERCONDP(mg));
6095 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
6096 PTR2UV(thr), PTR2UV(svv));)
6097 MUTEX_UNLOCK(MgMUTEXP(mg));
6099 #endif /* USE_THREADS */
6108 #endif /* USE_THREADS */
6109 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
6110 || SvTYPE(retsv) == SVt_PVCV) {
6111 retsv = refto(retsv);
6122 if (PL_op->op_private & OPpLVAL_INTRO)
6123 PUSHs(*save_threadsv(PL_op->op_targ));
6125 PUSHs(THREADSV(PL_op->op_targ));
6128 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
6129 #endif /* USE_THREADS */