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 #ifndef NV_PRESERVES_UV
1718 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1719 SETs(boolSV(SvRV(TOPs) == SvRV(TOPm1s)));
1723 #ifdef PERL_PRESERVE_IVUV
1726 SvIV_please(TOPm1s);
1727 if (SvIOK(TOPm1s)) {
1728 bool auvok = SvUOK(TOPm1s);
1729 bool buvok = SvUOK(TOPs);
1731 if (!auvok && !buvok) { /* ## IV <=> IV ## */
1732 IV aiv = SvIVX(TOPm1s);
1733 IV biv = SvIVX(TOPs);
1736 SETs(boolSV(aiv != biv));
1739 if (auvok && buvok) { /* ## UV != UV ## */
1740 UV auv = SvUVX(TOPm1s);
1741 UV buv = SvUVX(TOPs);
1744 SETs(boolSV(auv != buv));
1747 { /* ## Mixed IV,UV ## */
1751 /* != is commutative so swap if needed (save code) */
1753 /* swap. top of stack (b) is the iv */
1757 /* As (a) is a UV, it's >0, so it cannot be == */
1766 /* As (b) is a UV, it's >0, so it cannot be == */
1770 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
1772 /* we know iv is >= 0 */
1773 if (uv > (UV) IV_MAX) {
1777 SETs(boolSV((UV)iv != uv));
1785 SETs(boolSV(TOPn != value));
1792 dSP; dTARGET; tryAMAGICbin(ncmp,0);
1793 #ifndef NV_PRESERVES_UV
1794 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1795 SETi(PTR2UV(SvRV(TOPs)) - PTR2UV(SvRV(TOPm1s)));
1799 #ifdef PERL_PRESERVE_IVUV
1800 /* Fortunately it seems NaN isn't IOK */
1803 SvIV_please(TOPm1s);
1804 if (SvIOK(TOPm1s)) {
1805 bool leftuvok = SvUOK(TOPm1s);
1806 bool rightuvok = SvUOK(TOPs);
1808 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
1809 IV leftiv = SvIVX(TOPm1s);
1810 IV rightiv = SvIVX(TOPs);
1812 if (leftiv > rightiv)
1814 else if (leftiv < rightiv)
1818 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
1819 UV leftuv = SvUVX(TOPm1s);
1820 UV rightuv = SvUVX(TOPs);
1822 if (leftuv > rightuv)
1824 else if (leftuv < rightuv)
1828 } else if (leftuvok) { /* ## UV <=> IV ## */
1832 rightiv = SvIVX(TOPs);
1834 /* As (a) is a UV, it's >=0, so it cannot be < */
1837 leftuv = SvUVX(TOPm1s);
1838 if (leftuv > (UV) IV_MAX) {
1839 /* As (b) is an IV, it cannot be > IV_MAX */
1841 } else if (leftuv > (UV)rightiv) {
1843 } else if (leftuv < (UV)rightiv) {
1849 } else { /* ## IV <=> UV ## */
1853 leftiv = SvIVX(TOPm1s);
1855 /* As (b) is a UV, it's >=0, so it must be < */
1858 rightuv = SvUVX(TOPs);
1859 if (rightuv > (UV) IV_MAX) {
1860 /* As (a) is an IV, it cannot be > IV_MAX */
1862 } else if (leftiv > (UV)rightuv) {
1864 } else if (leftiv < (UV)rightuv) {
1882 if (Perl_isnan(left) || Perl_isnan(right)) {
1886 value = (left > right) - (left < right);
1890 else if (left < right)
1892 else if (left > right)
1906 dSP; tryAMAGICbinSET(slt,0);
1909 int cmp = ((PL_op->op_private & OPpLOCALE)
1910 ? sv_cmp_locale(left, right)
1911 : sv_cmp(left, right));
1912 SETs(boolSV(cmp < 0));
1919 dSP; tryAMAGICbinSET(sgt,0);
1922 int cmp = ((PL_op->op_private & OPpLOCALE)
1923 ? sv_cmp_locale(left, right)
1924 : sv_cmp(left, right));
1925 SETs(boolSV(cmp > 0));
1932 dSP; tryAMAGICbinSET(sle,0);
1935 int cmp = ((PL_op->op_private & OPpLOCALE)
1936 ? sv_cmp_locale(left, right)
1937 : sv_cmp(left, right));
1938 SETs(boolSV(cmp <= 0));
1945 dSP; tryAMAGICbinSET(sge,0);
1948 int cmp = ((PL_op->op_private & OPpLOCALE)
1949 ? sv_cmp_locale(left, right)
1950 : sv_cmp(left, right));
1951 SETs(boolSV(cmp >= 0));
1958 dSP; tryAMAGICbinSET(seq,0);
1961 SETs(boolSV(sv_eq(left, right)));
1968 dSP; tryAMAGICbinSET(sne,0);
1971 SETs(boolSV(!sv_eq(left, right)));
1978 dSP; dTARGET; tryAMAGICbin(scmp,0);
1979 #ifndef NV_PRESERVES_UV
1980 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1981 SETi(PTR2UV(SvRV(TOPs)) - PTR2UV(SvRV(TOPm1s)));
1987 int cmp = ((PL_op->op_private & OPpLOCALE)
1988 ? sv_cmp_locale(left, right)
1989 : sv_cmp(left, right));
1997 dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
2000 if (SvNIOKp(left) || SvNIOKp(right)) {
2001 if (PL_op->op_private & HINT_INTEGER) {
2002 IV i = SvIV(left) & SvIV(right);
2006 UV u = SvUV(left) & SvUV(right);
2011 do_vop(PL_op->op_type, TARG, left, right);
2020 dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
2023 if (SvNIOKp(left) || SvNIOKp(right)) {
2024 if (PL_op->op_private & HINT_INTEGER) {
2025 IV i = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
2029 UV u = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
2034 do_vop(PL_op->op_type, TARG, left, right);
2043 dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
2046 if (SvNIOKp(left) || SvNIOKp(right)) {
2047 if (PL_op->op_private & HINT_INTEGER) {
2048 IV i = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
2052 UV u = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
2057 do_vop(PL_op->op_type, TARG, left, right);
2066 dSP; dTARGET; tryAMAGICun(neg);
2069 int flags = SvFLAGS(sv);
2072 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2073 /* It's publicly an integer, or privately an integer-not-float */
2076 if (SvIVX(sv) == IV_MIN) {
2077 /* 2s complement assumption. */
2078 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2081 else if (SvUVX(sv) <= IV_MAX) {
2086 else if (SvIVX(sv) != IV_MIN) {
2090 #ifdef PERL_PRESERVE_IVUV
2099 else if (SvPOKp(sv)) {
2101 char *s = SvPV(sv, len);
2102 if (isIDFIRST(*s)) {
2103 sv_setpvn(TARG, "-", 1);
2106 else if (*s == '+' || *s == '-') {
2108 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2110 else if (DO_UTF8(sv) && UTF8_IS_START(*s) && isIDFIRST_utf8((U8*)s)) {
2111 sv_setpvn(TARG, "-", 1);
2117 goto oops_its_an_int;
2118 sv_setnv(TARG, -SvNV(sv));
2130 dSP; tryAMAGICunSET(not);
2131 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2137 dSP; dTARGET; tryAMAGICun(compl);
2141 if (PL_op->op_private & HINT_INTEGER) {
2156 tmps = (U8*)SvPV_force(TARG, len);
2159 /* Calculate exact length, let's not estimate. */
2168 while (tmps < send) {
2169 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2170 tmps += UTF8SKIP(tmps);
2171 targlen += UNISKIP(~c);
2177 /* Now rewind strings and write them. */
2181 Newz(0, result, targlen + 1, U8);
2182 while (tmps < send) {
2183 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2184 tmps += UTF8SKIP(tmps);
2185 result = uvchr_to_utf8(result, ~c);
2189 sv_setpvn(TARG, (char*)result, targlen);
2193 Newz(0, result, nchar + 1, U8);
2194 while (tmps < send) {
2195 U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY);
2196 tmps += UTF8SKIP(tmps);
2201 sv_setpvn(TARG, (char*)result, nchar);
2209 register long *tmpl;
2210 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2213 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2218 for ( ; anum > 0; anum--, tmps++)
2227 /* integer versions of some of the above */
2231 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2234 SETi( left * right );
2241 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2245 DIE(aTHX_ "Illegal division by zero");
2246 value = POPi / value;
2254 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2258 DIE(aTHX_ "Illegal modulus zero");
2259 SETi( left % right );
2266 dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2269 SETi( left + right );
2276 dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2279 SETi( left - right );
2286 dSP; tryAMAGICbinSET(lt,0);
2289 SETs(boolSV(left < right));
2296 dSP; tryAMAGICbinSET(gt,0);
2299 SETs(boolSV(left > right));
2306 dSP; tryAMAGICbinSET(le,0);
2309 SETs(boolSV(left <= right));
2316 dSP; tryAMAGICbinSET(ge,0);
2319 SETs(boolSV(left >= right));
2326 dSP; tryAMAGICbinSET(eq,0);
2329 SETs(boolSV(left == right));
2336 dSP; tryAMAGICbinSET(ne,0);
2339 SETs(boolSV(left != right));
2346 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2353 else if (left < right)
2364 dSP; dTARGET; tryAMAGICun(neg);
2369 /* High falutin' math. */
2373 dSP; dTARGET; tryAMAGICbin(atan2,0);
2376 SETn(Perl_atan2(left, right));
2383 dSP; dTARGET; tryAMAGICun(sin);
2387 value = Perl_sin(value);
2395 dSP; dTARGET; tryAMAGICun(cos);
2399 value = Perl_cos(value);
2405 /* Support Configure command-line overrides for rand() functions.
2406 After 5.005, perhaps we should replace this by Configure support
2407 for drand48(), random(), or rand(). For 5.005, though, maintain
2408 compatibility by calling rand() but allow the user to override it.
2409 See INSTALL for details. --Andy Dougherty 15 July 1998
2411 /* Now it's after 5.005, and Configure supports drand48() and random(),
2412 in addition to rand(). So the overrides should not be needed any more.
2413 --Jarkko Hietaniemi 27 September 1998
2416 #ifndef HAS_DRAND48_PROTO
2417 extern double drand48 (void);
2430 if (!PL_srand_called) {
2431 (void)seedDrand01((Rand_seed_t)seed());
2432 PL_srand_called = TRUE;
2447 (void)seedDrand01((Rand_seed_t)anum);
2448 PL_srand_called = TRUE;
2457 * This is really just a quick hack which grabs various garbage
2458 * values. It really should be a real hash algorithm which
2459 * spreads the effect of every input bit onto every output bit,
2460 * if someone who knows about such things would bother to write it.
2461 * Might be a good idea to add that function to CORE as well.
2462 * No numbers below come from careful analysis or anything here,
2463 * except they are primes and SEED_C1 > 1E6 to get a full-width
2464 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
2465 * probably be bigger too.
2468 # define SEED_C1 1000003
2469 #define SEED_C4 73819
2471 # define SEED_C1 25747
2472 #define SEED_C4 20639
2476 #define SEED_C5 26107
2478 #ifndef PERL_NO_DEV_RANDOM
2483 # include <starlet.h>
2484 /* when[] = (low 32 bits, high 32 bits) of time since epoch
2485 * in 100-ns units, typically incremented ever 10 ms. */
2486 unsigned int when[2];
2488 # ifdef HAS_GETTIMEOFDAY
2489 struct timeval when;
2495 /* This test is an escape hatch, this symbol isn't set by Configure. */
2496 #ifndef PERL_NO_DEV_RANDOM
2497 #ifndef PERL_RANDOM_DEVICE
2498 /* /dev/random isn't used by default because reads from it will block
2499 * if there isn't enough entropy available. You can compile with
2500 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
2501 * is enough real entropy to fill the seed. */
2502 # define PERL_RANDOM_DEVICE "/dev/urandom"
2504 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
2506 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
2515 _ckvmssts(sys$gettim(when));
2516 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
2518 # ifdef HAS_GETTIMEOFDAY
2519 gettimeofday(&when,(struct timezone *) 0);
2520 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
2523 u = (U32)SEED_C1 * when;
2526 u += SEED_C3 * (U32)PerlProc_getpid();
2527 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
2528 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
2529 u += SEED_C5 * (U32)PTR2UV(&when);
2536 dSP; dTARGET; tryAMAGICun(exp);
2540 value = Perl_exp(value);
2548 dSP; dTARGET; tryAMAGICun(log);
2553 SET_NUMERIC_STANDARD();
2554 DIE(aTHX_ "Can't take log of %g", value);
2556 value = Perl_log(value);
2564 dSP; dTARGET; tryAMAGICun(sqrt);
2569 SET_NUMERIC_STANDARD();
2570 DIE(aTHX_ "Can't take sqrt of %g", value);
2572 value = Perl_sqrt(value);
2580 dSP; dTARGET; tryAMAGICun(int);
2583 IV iv = TOPi; /* attempt to convert to IV if possible. */
2584 /* XXX it's arguable that compiler casting to IV might be subtly
2585 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2586 else preferring IV has introduced a subtle behaviour change bug. OTOH
2587 relying on floating point to be accurate is a bug. */
2598 if (value < (NV)UV_MAX + 0.5) {
2601 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2602 (void)Perl_modf(value, &value);
2604 double tmp = (double)value;
2605 (void)Perl_modf(tmp, &tmp);
2612 if (value > (NV)IV_MIN - 0.5) {
2615 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2616 (void)Perl_modf(-value, &value);
2619 double tmp = (double)value;
2620 (void)Perl_modf(-tmp, &tmp);
2633 dSP; dTARGET; tryAMAGICun(abs);
2635 /* This will cache the NV value if string isn't actually integer */
2639 /* IVX is precise */
2641 SETu(TOPu); /* force it to be numeric only */
2649 /* 2s complement assumption. Also, not really needed as
2650 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2673 argtype = 1; /* allow underscores */
2674 XPUSHn(scan_hex(tmps, 99, &argtype));
2687 while (*tmps && isSPACE(*tmps))
2691 argtype = 1; /* allow underscores */
2693 value = scan_hex(++tmps, 99, &argtype);
2694 else if (*tmps == 'b')
2695 value = scan_bin(++tmps, 99, &argtype);
2697 value = scan_oct(tmps, 99, &argtype);
2710 SETi(sv_len_utf8(sv));
2726 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2728 I32 arybase = PL_curcop->cop_arybase;
2732 int num_args = PL_op->op_private & 7;
2733 bool repl_need_utf8_upgrade = FALSE;
2734 bool repl_is_utf8 = FALSE;
2736 SvTAINTED_off(TARG); /* decontaminate */
2737 SvUTF8_off(TARG); /* decontaminate */
2741 repl = SvPV(repl_sv, repl_len);
2742 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
2752 sv_utf8_upgrade(sv);
2754 else if (DO_UTF8(sv))
2755 repl_need_utf8_upgrade = TRUE;
2757 tmps = SvPV(sv, curlen);
2759 utf8_curlen = sv_len_utf8(sv);
2760 if (utf8_curlen == curlen)
2763 curlen = utf8_curlen;
2768 if (pos >= arybase) {
2786 else if (len >= 0) {
2788 if (rem > (I32)curlen)
2803 Perl_croak(aTHX_ "substr outside of string");
2804 if (ckWARN(WARN_SUBSTR))
2805 Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string");
2812 sv_pos_u2b(sv, &pos, &rem);
2814 sv_setpvn(TARG, tmps, rem);
2818 SV* repl_sv_copy = NULL;
2820 if (repl_need_utf8_upgrade) {
2821 repl_sv_copy = newSVsv(repl_sv);
2822 sv_utf8_upgrade(repl_sv_copy);
2823 repl = SvPV(repl_sv_copy, repl_len);
2824 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
2826 sv_insert(sv, pos, rem, repl, repl_len);
2830 SvREFCNT_dec(repl_sv_copy);
2832 else if (lvalue) { /* it's an lvalue! */
2833 if (!SvGMAGICAL(sv)) {
2837 if (ckWARN(WARN_SUBSTR))
2838 Perl_warner(aTHX_ WARN_SUBSTR,
2839 "Attempt to use reference as lvalue in substr");
2841 if (SvOK(sv)) /* is it defined ? */
2842 (void)SvPOK_only_UTF8(sv);
2844 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
2847 if (SvTYPE(TARG) < SVt_PVLV) {
2848 sv_upgrade(TARG, SVt_PVLV);
2849 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
2853 if (LvTARG(TARG) != sv) {
2855 SvREFCNT_dec(LvTARG(TARG));
2856 LvTARG(TARG) = SvREFCNT_inc(sv);
2858 LvTARGOFF(TARG) = upos;
2859 LvTARGLEN(TARG) = urem;
2863 PUSHs(TARG); /* avoid SvSETMAGIC here */
2870 register IV size = POPi;
2871 register IV offset = POPi;
2872 register SV *src = POPs;
2873 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2875 SvTAINTED_off(TARG); /* decontaminate */
2876 if (lvalue) { /* it's an lvalue! */
2877 if (SvTYPE(TARG) < SVt_PVLV) {
2878 sv_upgrade(TARG, SVt_PVLV);
2879 sv_magic(TARG, Nullsv, 'v', Nullch, 0);
2882 if (LvTARG(TARG) != src) {
2884 SvREFCNT_dec(LvTARG(TARG));
2885 LvTARG(TARG) = SvREFCNT_inc(src);
2887 LvTARGOFF(TARG) = offset;
2888 LvTARGLEN(TARG) = size;
2891 sv_setuv(TARG, do_vecget(src, offset, size));
2906 I32 arybase = PL_curcop->cop_arybase;
2911 offset = POPi - arybase;
2914 tmps = SvPV(big, biglen);
2915 if (offset > 0 && DO_UTF8(big))
2916 sv_pos_u2b(big, &offset, 0);
2919 else if (offset > biglen)
2921 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2922 (unsigned char*)tmps + biglen, little, 0)))
2925 retval = tmps2 - tmps;
2926 if (retval > 0 && DO_UTF8(big))
2927 sv_pos_b2u(big, &retval);
2928 PUSHi(retval + arybase);
2943 I32 arybase = PL_curcop->cop_arybase;
2949 tmps2 = SvPV(little, llen);
2950 tmps = SvPV(big, blen);
2954 if (offset > 0 && DO_UTF8(big))
2955 sv_pos_u2b(big, &offset, 0);
2956 offset = offset - arybase + llen;
2960 else if (offset > blen)
2962 if (!(tmps2 = rninstr(tmps, tmps + offset,
2963 tmps2, tmps2 + llen)))
2966 retval = tmps2 - tmps;
2967 if (retval > 0 && DO_UTF8(big))
2968 sv_pos_b2u(big, &retval);
2969 PUSHi(retval + arybase);
2975 dSP; dMARK; dORIGMARK; dTARGET;
2976 do_sprintf(TARG, SP-MARK, MARK+1);
2977 TAINT_IF(SvTAINTED(TARG));
2988 U8 *s = (U8*)SvPVx(argsv, len);
2990 XPUSHu(DO_UTF8(argsv) ? utf8_to_uvchr(s, 0) : (*s & 0xff));
3000 (void)SvUPGRADE(TARG,SVt_PV);
3002 if (value > 255 && !IN_BYTE) {
3003 SvGROW(TARG, UNISKIP(value)+1);
3004 tmps = (char*)uvchr_to_utf8((U8*)SvPVX(TARG), value);
3005 SvCUR_set(TARG, tmps - SvPVX(TARG));
3007 (void)SvPOK_only(TARG);
3018 (void)SvPOK_only(TARG);
3025 dSP; dTARGET; dPOPTOPssrl;
3028 char *tmps = SvPV(left, n_a);
3030 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
3032 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
3036 "The crypt() function is unimplemented due to excessive paranoia.");
3049 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
3051 U8 tmpbuf[UTF8_MAXLEN+1];
3055 if (PL_op->op_private & OPpLOCALE) {
3058 uv = toTITLE_LC_uvchr(utf8n_to_uvchr(s, slen, &ulen, 0));
3061 uv = toTITLE_utf8(s);
3063 tend = uvchr_to_utf8(tmpbuf, uv);
3065 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
3067 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3068 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3073 s = (U8*)SvPV_force(sv, slen);
3074 Copy(tmpbuf, s, ulen, U8);
3078 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3080 SvUTF8_off(TARG); /* decontaminate */
3085 s = (U8*)SvPV_force(sv, slen);
3087 if (PL_op->op_private & OPpLOCALE) {
3090 *s = toUPPER_LC(*s);
3108 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
3110 U8 tmpbuf[UTF8_MAXLEN+1];
3114 if (PL_op->op_private & OPpLOCALE) {
3117 uv = toLOWER_LC_uvchr(utf8n_to_uvchr(s, slen, &ulen, 0));
3120 uv = toLOWER_utf8(s);
3122 tend = uvchr_to_utf8(tmpbuf, uv);
3124 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
3126 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3127 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3132 s = (U8*)SvPV_force(sv, slen);
3133 Copy(tmpbuf, s, ulen, U8);
3137 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3139 SvUTF8_off(TARG); /* decontaminate */
3144 s = (U8*)SvPV_force(sv, slen);
3146 if (PL_op->op_private & OPpLOCALE) {
3149 *s = toLOWER_LC(*s);
3173 s = (U8*)SvPV(sv,len);
3175 SvUTF8_off(TARG); /* decontaminate */
3176 sv_setpvn(TARG, "", 0);
3180 (void)SvUPGRADE(TARG, SVt_PV);
3181 SvGROW(TARG, (len * 2) + 1);
3182 (void)SvPOK_only(TARG);
3183 d = (U8*)SvPVX(TARG);
3185 if (PL_op->op_private & OPpLOCALE) {
3189 d = uvchr_to_utf8(d, toUPPER_LC_uvchr( utf8n_to_uvchr(s, len, &ulen, 0)));
3195 d = uvchr_to_utf8(d, toUPPER_utf8( s ));
3201 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3206 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3208 SvUTF8_off(TARG); /* decontaminate */
3213 s = (U8*)SvPV_force(sv, len);
3215 register U8 *send = s + len;
3217 if (PL_op->op_private & OPpLOCALE) {
3220 for (; s < send; s++)
3221 *s = toUPPER_LC(*s);
3224 for (; s < send; s++)
3247 s = (U8*)SvPV(sv,len);
3249 SvUTF8_off(TARG); /* decontaminate */
3250 sv_setpvn(TARG, "", 0);
3254 (void)SvUPGRADE(TARG, SVt_PV);
3255 SvGROW(TARG, (len * 2) + 1);
3256 (void)SvPOK_only(TARG);
3257 d = (U8*)SvPVX(TARG);
3259 if (PL_op->op_private & OPpLOCALE) {
3263 d = uvchr_to_utf8(d, toLOWER_LC_uvchr( utf8n_to_uvchr(s, len, &ulen, 0)));
3269 d = uvchr_to_utf8(d, toLOWER_utf8(s));
3275 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3280 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3282 SvUTF8_off(TARG); /* decontaminate */
3288 s = (U8*)SvPV_force(sv, len);
3290 register U8 *send = s + len;
3292 if (PL_op->op_private & OPpLOCALE) {
3295 for (; s < send; s++)
3296 *s = toLOWER_LC(*s);
3299 for (; s < send; s++)
3314 register char *s = SvPV(sv,len);
3317 SvUTF8_off(TARG); /* decontaminate */
3319 (void)SvUPGRADE(TARG, SVt_PV);
3320 SvGROW(TARG, (len * 2) + 1);
3324 if (UTF8_IS_CONTINUED(*s)) {
3325 STRLEN ulen = UTF8SKIP(s);
3349 SvCUR_set(TARG, d - SvPVX(TARG));
3350 (void)SvPOK_only_UTF8(TARG);
3353 sv_setpvn(TARG, s, len);
3355 if (SvSMAGICAL(TARG))
3364 dSP; dMARK; dORIGMARK;
3366 register AV* av = (AV*)POPs;
3367 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3368 I32 arybase = PL_curcop->cop_arybase;
3371 if (SvTYPE(av) == SVt_PVAV) {
3372 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3374 for (svp = MARK + 1; svp <= SP; svp++) {
3379 if (max > AvMAX(av))
3382 while (++MARK <= SP) {
3383 elem = SvIVx(*MARK);
3387 svp = av_fetch(av, elem, lval);
3389 if (!svp || *svp == &PL_sv_undef)
3390 DIE(aTHX_ PL_no_aelem, elem);
3391 if (PL_op->op_private & OPpLVAL_INTRO)
3392 save_aelem(av, elem, svp);
3394 *MARK = svp ? *svp : &PL_sv_undef;
3397 if (GIMME != G_ARRAY) {
3405 /* Associative arrays. */
3410 HV *hash = (HV*)POPs;
3412 I32 gimme = GIMME_V;
3413 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
3416 /* might clobber stack_sp */
3417 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
3422 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
3423 if (gimme == G_ARRAY) {
3426 /* might clobber stack_sp */
3428 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
3433 else if (gimme == G_SCALAR)
3452 I32 gimme = GIMME_V;
3453 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3457 if (PL_op->op_private & OPpSLICE) {
3461 hvtype = SvTYPE(hv);
3462 if (hvtype == SVt_PVHV) { /* hash element */
3463 while (++MARK <= SP) {
3464 sv = hv_delete_ent(hv, *MARK, discard, 0);
3465 *MARK = sv ? sv : &PL_sv_undef;
3468 else if (hvtype == SVt_PVAV) {
3469 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3470 while (++MARK <= SP) {
3471 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3472 *MARK = sv ? sv : &PL_sv_undef;
3475 else { /* pseudo-hash element */
3476 while (++MARK <= SP) {
3477 sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
3478 *MARK = sv ? sv : &PL_sv_undef;
3483 DIE(aTHX_ "Not a HASH reference");
3486 else if (gimme == G_SCALAR) {
3495 if (SvTYPE(hv) == SVt_PVHV)
3496 sv = hv_delete_ent(hv, keysv, discard, 0);
3497 else if (SvTYPE(hv) == SVt_PVAV) {
3498 if (PL_op->op_flags & OPf_SPECIAL)
3499 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3501 sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
3504 DIE(aTHX_ "Not a HASH reference");
3519 if (PL_op->op_private & OPpEXISTS_SUB) {
3523 cv = sv_2cv(sv, &hv, &gv, FALSE);
3526 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3532 if (SvTYPE(hv) == SVt_PVHV) {
3533 if (hv_exists_ent(hv, tmpsv, 0))
3536 else if (SvTYPE(hv) == SVt_PVAV) {
3537 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3538 if (av_exists((AV*)hv, SvIV(tmpsv)))
3541 else if (avhv_exists_ent((AV*)hv, tmpsv, 0)) /* pseudo-hash element */
3545 DIE(aTHX_ "Not a HASH reference");
3552 dSP; dMARK; dORIGMARK;
3553 register HV *hv = (HV*)POPs;
3554 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3555 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
3557 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
3558 DIE(aTHX_ "Can't localize pseudo-hash element");
3560 if (realhv || SvTYPE(hv) == SVt_PVAV) {
3561 while (++MARK <= SP) {
3564 I32 preeminent = SvRMAGICAL(hv) ? 1 : hv_exists_ent(hv, keysv, 0);
3566 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
3567 svp = he ? &HeVAL(he) : 0;
3570 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
3573 if (!svp || *svp == &PL_sv_undef) {
3575 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3577 if (PL_op->op_private & OPpLVAL_INTRO) {
3579 save_helem(hv, keysv, svp);
3582 char *key = SvPV(keysv, keylen);
3583 SAVEDELETE(hv, savepvn(key,keylen), keylen);
3587 *MARK = svp ? *svp : &PL_sv_undef;
3590 if (GIMME != G_ARRAY) {
3598 /* List operators. */
3603 if (GIMME != G_ARRAY) {
3605 *MARK = *SP; /* unwanted list, return last item */
3607 *MARK = &PL_sv_undef;
3616 SV **lastrelem = PL_stack_sp;
3617 SV **lastlelem = PL_stack_base + POPMARK;
3618 SV **firstlelem = PL_stack_base + POPMARK + 1;
3619 register SV **firstrelem = lastlelem + 1;
3620 I32 arybase = PL_curcop->cop_arybase;
3621 I32 lval = PL_op->op_flags & OPf_MOD;
3622 I32 is_something_there = lval;
3624 register I32 max = lastrelem - lastlelem;
3625 register SV **lelem;
3628 if (GIMME != G_ARRAY) {
3629 ix = SvIVx(*lastlelem);
3634 if (ix < 0 || ix >= max)
3635 *firstlelem = &PL_sv_undef;
3637 *firstlelem = firstrelem[ix];
3643 SP = firstlelem - 1;
3647 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3653 if (ix < 0 || ix >= max)
3654 *lelem = &PL_sv_undef;
3656 is_something_there = TRUE;
3657 if (!(*lelem = firstrelem[ix]))
3658 *lelem = &PL_sv_undef;
3661 if (is_something_there)
3664 SP = firstlelem - 1;
3670 dSP; dMARK; dORIGMARK;
3671 I32 items = SP - MARK;
3672 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
3673 SP = ORIGMARK; /* av_make() might realloc stack_sp */
3680 dSP; dMARK; dORIGMARK;
3681 HV* hv = (HV*)sv_2mortal((SV*)newHV());
3685 SV *val = NEWSV(46, 0);
3687 sv_setsv(val, *++MARK);
3688 else if (ckWARN(WARN_MISC))
3689 Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
3690 (void)hv_store_ent(hv,key,val,0);
3699 dSP; dMARK; dORIGMARK;
3700 register AV *ary = (AV*)*++MARK;
3704 register I32 offset;
3705 register I32 length;
3712 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3713 *MARK-- = SvTIED_obj((SV*)ary, mg);
3717 call_method("SPLICE",GIMME_V);
3726 offset = i = SvIVx(*MARK);
3728 offset += AvFILLp(ary) + 1;
3730 offset -= PL_curcop->cop_arybase;
3732 DIE(aTHX_ PL_no_aelem, i);
3734 length = SvIVx(*MARK++);
3736 length += AvFILLp(ary) - offset + 1;
3742 length = AvMAX(ary) + 1; /* close enough to infinity */
3746 length = AvMAX(ary) + 1;
3748 if (offset > AvFILLp(ary) + 1)
3749 offset = AvFILLp(ary) + 1;
3750 after = AvFILLp(ary) + 1 - (offset + length);
3751 if (after < 0) { /* not that much array */
3752 length += after; /* offset+length now in array */
3758 /* At this point, MARK .. SP-1 is our new LIST */
3761 diff = newlen - length;
3762 if (newlen && !AvREAL(ary) && AvREIFY(ary))
3765 if (diff < 0) { /* shrinking the area */
3767 New(451, tmparyval, newlen, SV*); /* so remember insertion */
3768 Copy(MARK, tmparyval, newlen, SV*);
3771 MARK = ORIGMARK + 1;
3772 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3773 MEXTEND(MARK, length);
3774 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
3776 EXTEND_MORTAL(length);
3777 for (i = length, dst = MARK; i; i--) {
3778 sv_2mortal(*dst); /* free them eventualy */
3785 *MARK = AvARRAY(ary)[offset+length-1];
3788 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
3789 SvREFCNT_dec(*dst++); /* free them now */
3792 AvFILLp(ary) += diff;
3794 /* pull up or down? */
3796 if (offset < after) { /* easier to pull up */
3797 if (offset) { /* esp. if nothing to pull */
3798 src = &AvARRAY(ary)[offset-1];
3799 dst = src - diff; /* diff is negative */
3800 for (i = offset; i > 0; i--) /* can't trust Copy */
3804 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
3808 if (after) { /* anything to pull down? */
3809 src = AvARRAY(ary) + offset + length;
3810 dst = src + diff; /* diff is negative */
3811 Move(src, dst, after, SV*);
3813 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
3814 /* avoid later double free */
3818 dst[--i] = &PL_sv_undef;
3821 for (src = tmparyval, dst = AvARRAY(ary) + offset;
3823 *dst = NEWSV(46, 0);
3824 sv_setsv(*dst++, *src++);
3826 Safefree(tmparyval);
3829 else { /* no, expanding (or same) */
3831 New(452, tmparyval, length, SV*); /* so remember deletion */
3832 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
3835 if (diff > 0) { /* expanding */
3837 /* push up or down? */
3839 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
3843 Move(src, dst, offset, SV*);
3845 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
3847 AvFILLp(ary) += diff;
3850 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
3851 av_extend(ary, AvFILLp(ary) + diff);
3852 AvFILLp(ary) += diff;
3855 dst = AvARRAY(ary) + AvFILLp(ary);
3857 for (i = after; i; i--) {
3864 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3865 *dst = NEWSV(46, 0);
3866 sv_setsv(*dst++, *src++);
3868 MARK = ORIGMARK + 1;
3869 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3871 Copy(tmparyval, MARK, length, SV*);
3873 EXTEND_MORTAL(length);
3874 for (i = length, dst = MARK; i; i--) {
3875 sv_2mortal(*dst); /* free them eventualy */
3879 Safefree(tmparyval);
3883 else if (length--) {
3884 *MARK = tmparyval[length];
3887 while (length-- > 0)
3888 SvREFCNT_dec(tmparyval[length]);
3890 Safefree(tmparyval);
3893 *MARK = &PL_sv_undef;
3901 dSP; dMARK; dORIGMARK; dTARGET;
3902 register AV *ary = (AV*)*++MARK;
3903 register SV *sv = &PL_sv_undef;
3906 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3907 *MARK-- = SvTIED_obj((SV*)ary, mg);
3911 call_method("PUSH",G_SCALAR|G_DISCARD);
3916 /* Why no pre-extend of ary here ? */
3917 for (++MARK; MARK <= SP; MARK++) {
3920 sv_setsv(sv, *MARK);
3925 PUSHi( AvFILL(ary) + 1 );
3933 SV *sv = av_pop(av);
3935 (void)sv_2mortal(sv);
3944 SV *sv = av_shift(av);
3949 (void)sv_2mortal(sv);
3956 dSP; dMARK; dORIGMARK; dTARGET;
3957 register AV *ary = (AV*)*++MARK;
3962 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3963 *MARK-- = SvTIED_obj((SV*)ary, mg);
3967 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3972 av_unshift(ary, SP - MARK);
3975 sv_setsv(sv, *++MARK);
3976 (void)av_store(ary, i++, sv);
3980 PUSHi( AvFILL(ary) + 1 );
3990 if (GIMME == G_ARRAY) {
3997 /* safe as long as stack cannot get extended in the above */
4002 register char *down;
4007 SvUTF8_off(TARG); /* decontaminate */
4009 do_join(TARG, &PL_sv_no, MARK, SP);
4011 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
4012 up = SvPV_force(TARG, len);
4014 if (DO_UTF8(TARG)) { /* first reverse each character */
4015 U8* s = (U8*)SvPVX(TARG);
4016 U8* send = (U8*)(s + len);
4018 if (UTF8_IS_INVARIANT(*s)) {
4023 if (!utf8_to_uvchr(s, 0))
4027 down = (char*)(s - 1);
4028 /* reverse this character */
4038 down = SvPVX(TARG) + len - 1;
4044 (void)SvPOK_only_UTF8(TARG);
4053 S_mul128(pTHX_ SV *sv, U8 m)
4056 char *s = SvPV(sv, len);
4060 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
4061 SV *tmpNew = newSVpvn("0000000000", 10);
4063 sv_catsv(tmpNew, sv);
4064 SvREFCNT_dec(sv); /* free old sv */
4069 while (!*t) /* trailing '\0'? */
4072 i = ((*t - '0') << 7) + m;
4073 *(t--) = '0' + (i % 10);
4079 /* Explosives and implosives. */
4081 #if 'I' == 73 && 'J' == 74
4082 /* On an ASCII/ISO kind of system */
4083 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
4086 Some other sort of character set - use memchr() so we don't match
4089 #define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
4097 I32 start_sp_offset = SP - PL_stack_base;
4098 I32 gimme = GIMME_V;
4102 register char *pat = SvPV(left, llen);
4103 #ifdef PACKED_IS_OCTETS
4104 /* Packed side is assumed to be octets - so force downgrade if it
4105 has been UTF-8 encoded by accident
4107 register char *s = SvPVbyte(right, rlen);
4109 register char *s = SvPV(right, rlen);
4111 char *strend = s + rlen;
4113 register char *patend = pat + llen;
4119 /* These must not be in registers: */
4136 register U32 culong;
4140 #ifdef PERL_NATINT_PACK
4141 int natint; /* native integer */
4142 int unatint; /* unsigned native integer */
4145 if (gimme != G_ARRAY) { /* arrange to do first one only */
4147 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
4148 if (strchr("aAZbBhHP", *patend) || *pat == '%') {
4150 while (isDIGIT(*patend) || *patend == '*')
4156 while (pat < patend) {
4158 datumtype = *pat++ & 0xFF;
4159 #ifdef PERL_NATINT_PACK
4162 if (isSPACE(datumtype))
4164 if (datumtype == '#') {
4165 while (pat < patend && *pat != '\n')
4170 char *natstr = "sSiIlL";
4172 if (strchr(natstr, datumtype)) {
4173 #ifdef PERL_NATINT_PACK
4179 DIE(aTHX_ "'!' allowed only after types %s", natstr);
4184 else if (*pat == '*') {
4185 len = strend - strbeg; /* long enough */
4189 else if (isDIGIT(*pat)) {
4191 while (isDIGIT(*pat)) {
4192 len = (len * 10) + (*pat++ - '0');
4194 DIE(aTHX_ "Repeat count in unpack overflows");
4198 len = (datumtype != '@');
4202 DIE(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
4203 case ',': /* grandfather in commas but with a warning */
4204 if (commas++ == 0 && ckWARN(WARN_UNPACK))
4205 Perl_warner(aTHX_ WARN_UNPACK,
4206 "Invalid type in unpack: '%c'", (int)datumtype);
4209 if (len == 1 && pat[-1] != '1')
4218 if (len > strend - strbeg)
4219 DIE(aTHX_ "@ outside of string");
4223 if (len > s - strbeg)
4224 DIE(aTHX_ "X outside of string");
4228 if (len > strend - s)
4229 DIE(aTHX_ "x outside of string");
4233 if (start_sp_offset >= SP - PL_stack_base)
4234 DIE(aTHX_ "/ must follow a numeric type");
4237 pat++; /* ignore '*' for compatibility with pack */
4239 DIE(aTHX_ "/ cannot take a count" );
4246 if (len > strend - s)
4249 goto uchar_checksum;
4250 sv = NEWSV(35, len);
4251 sv_setpvn(sv, s, len);
4253 if (datumtype == 'A' || datumtype == 'Z') {
4254 aptr = s; /* borrow register */
4255 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
4260 else { /* 'A' strips both nulls and spaces */
4261 s = SvPVX(sv) + len - 1;
4262 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
4266 SvCUR_set(sv, s - SvPVX(sv));
4267 s = aptr; /* unborrow register */
4269 XPUSHs(sv_2mortal(sv));
4273 if (star || len > (strend - s) * 8)
4274 len = (strend - s) * 8;
4277 Newz(601, PL_bitcount, 256, char);
4278 for (bits = 1; bits < 256; bits++) {
4279 if (bits & 1) PL_bitcount[bits]++;
4280 if (bits & 2) PL_bitcount[bits]++;
4281 if (bits & 4) PL_bitcount[bits]++;
4282 if (bits & 8) PL_bitcount[bits]++;
4283 if (bits & 16) PL_bitcount[bits]++;
4284 if (bits & 32) PL_bitcount[bits]++;
4285 if (bits & 64) PL_bitcount[bits]++;
4286 if (bits & 128) PL_bitcount[bits]++;
4290 culong += PL_bitcount[*(unsigned char*)s++];
4295 if (datumtype == 'b') {
4297 if (bits & 1) culong++;
4303 if (bits & 128) culong++;
4310 sv = NEWSV(35, len + 1);
4314 if (datumtype == 'b') {
4316 for (len = 0; len < aint; len++) {
4317 if (len & 7) /*SUPPRESS 595*/
4321 *str++ = '0' + (bits & 1);
4326 for (len = 0; len < aint; len++) {
4331 *str++ = '0' + ((bits & 128) != 0);
4335 XPUSHs(sv_2mortal(sv));
4339 if (star || len > (strend - s) * 2)
4340 len = (strend - s) * 2;
4341 sv = NEWSV(35, len + 1);
4345 if (datumtype == 'h') {
4347 for (len = 0; len < aint; len++) {
4352 *str++ = PL_hexdigit[bits & 15];
4357 for (len = 0; len < aint; len++) {
4362 *str++ = PL_hexdigit[(bits >> 4) & 15];
4366 XPUSHs(sv_2mortal(sv));
4369 if (len > strend - s)
4374 if (aint >= 128) /* fake up signed chars */
4384 if (aint >= 128) /* fake up signed chars */
4387 sv_setiv(sv, (IV)aint);
4388 PUSHs(sv_2mortal(sv));
4393 if (len > strend - s)
4408 sv_setiv(sv, (IV)auint);
4409 PUSHs(sv_2mortal(sv));
4414 if (len > strend - s)
4417 while (len-- > 0 && s < strend) {
4419 auint = utf8n_to_uvchr((U8*)s, strend - s, &alen, 0);
4423 cdouble += (NV)auint;
4431 while (len-- > 0 && s < strend) {
4433 auint = utf8n_to_uvchr((U8*)s, strend - s, &alen, 0);
4437 sv_setuv(sv, (UV)auint);
4438 PUSHs(sv_2mortal(sv));
4443 #if SHORTSIZE == SIZE16
4444 along = (strend - s) / SIZE16;
4446 along = (strend - s) / (natint ? sizeof(short) : SIZE16);
4451 #if SHORTSIZE != SIZE16
4455 COPYNN(s, &ashort, sizeof(short));
4466 #if SHORTSIZE > SIZE16
4478 #if SHORTSIZE != SIZE16
4482 COPYNN(s, &ashort, sizeof(short));
4485 sv_setiv(sv, (IV)ashort);
4486 PUSHs(sv_2mortal(sv));
4494 #if SHORTSIZE > SIZE16
4500 sv_setiv(sv, (IV)ashort);
4501 PUSHs(sv_2mortal(sv));
4509 #if SHORTSIZE == SIZE16
4510 along = (strend - s) / SIZE16;
4512 unatint = natint && datumtype == 'S';
4513 along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
4518 #if SHORTSIZE != SIZE16
4520 unsigned short aushort;
4522 COPYNN(s, &aushort, sizeof(unsigned short));
4523 s += sizeof(unsigned short);
4531 COPY16(s, &aushort);
4534 if (datumtype == 'n')
4535 aushort = PerlSock_ntohs(aushort);
4538 if (datumtype == 'v')
4539 aushort = vtohs(aushort);
4548 #if SHORTSIZE != SIZE16
4550 unsigned short aushort;
4552 COPYNN(s, &aushort, sizeof(unsigned short));
4553 s += sizeof(unsigned short);
4555 sv_setiv(sv, (UV)aushort);
4556 PUSHs(sv_2mortal(sv));
4563 COPY16(s, &aushort);
4567 if (datumtype == 'n')
4568 aushort = PerlSock_ntohs(aushort);
4571 if (datumtype == 'v')
4572 aushort = vtohs(aushort);
4574 sv_setiv(sv, (UV)aushort);
4575 PUSHs(sv_2mortal(sv));
4581 along = (strend - s) / sizeof(int);
4586 Copy(s, &aint, 1, int);
4589 cdouble += (NV)aint;
4598 Copy(s, &aint, 1, int);
4602 /* Without the dummy below unpack("i", pack("i",-1))
4603 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
4604 * cc with optimization turned on.
4606 * The bug was detected in
4607 * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
4608 * with optimization (-O4) turned on.
4609 * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
4610 * does not have this problem even with -O4.
4612 * This bug was reported as DECC_BUGS 1431
4613 * and tracked internally as GEM_BUGS 7775.
4615 * The bug is fixed in
4616 * Tru64 UNIX V5.0: Compaq C V6.1-006 or later
4617 * UNIX V4.0F support: DEC C V5.9-006 or later
4618 * UNIX V4.0E support: DEC C V5.8-011 or later
4621 * See also few lines later for the same bug.
4624 sv_setiv(sv, (IV)aint) :
4626 sv_setiv(sv, (IV)aint);
4627 PUSHs(sv_2mortal(sv));
4632 along = (strend - s) / sizeof(unsigned int);
4637 Copy(s, &auint, 1, unsigned int);
4638 s += sizeof(unsigned int);
4640 cdouble += (NV)auint;
4649 Copy(s, &auint, 1, unsigned int);
4650 s += sizeof(unsigned int);
4653 /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
4654 * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
4655 * See details few lines earlier. */
4657 sv_setuv(sv, (UV)auint) :
4659 sv_setuv(sv, (UV)auint);
4660 PUSHs(sv_2mortal(sv));
4665 #if LONGSIZE == SIZE32
4666 along = (strend - s) / SIZE32;
4668 along = (strend - s) / (natint ? sizeof(long) : SIZE32);
4673 #if LONGSIZE != SIZE32
4676 COPYNN(s, &along, sizeof(long));
4679 cdouble += (NV)along;
4688 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
4692 #if LONGSIZE > SIZE32
4693 if (along > 2147483647)
4694 along -= 4294967296;
4698 cdouble += (NV)along;
4707 #if LONGSIZE != SIZE32
4710 COPYNN(s, &along, sizeof(long));
4713 sv_setiv(sv, (IV)along);
4714 PUSHs(sv_2mortal(sv));
4721 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
4725 #if LONGSIZE > SIZE32
4726 if (along > 2147483647)
4727 along -= 4294967296;
4731 sv_setiv(sv, (IV)along);
4732 PUSHs(sv_2mortal(sv));
4740 #if LONGSIZE == SIZE32
4741 along = (strend - s) / SIZE32;
4743 unatint = natint && datumtype == 'L';
4744 along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
4749 #if LONGSIZE != SIZE32
4751 unsigned long aulong;
4753 COPYNN(s, &aulong, sizeof(unsigned long));
4754 s += sizeof(unsigned long);
4756 cdouble += (NV)aulong;
4768 if (datumtype == 'N')
4769 aulong = PerlSock_ntohl(aulong);
4772 if (datumtype == 'V')
4773 aulong = vtohl(aulong);
4776 cdouble += (NV)aulong;
4785 #if LONGSIZE != SIZE32
4787 unsigned long aulong;
4789 COPYNN(s, &aulong, sizeof(unsigned long));
4790 s += sizeof(unsigned long);
4792 sv_setuv(sv, (UV)aulong);
4793 PUSHs(sv_2mortal(sv));
4803 if (datumtype == 'N')
4804 aulong = PerlSock_ntohl(aulong);
4807 if (datumtype == 'V')
4808 aulong = vtohl(aulong);
4811 sv_setuv(sv, (UV)aulong);
4812 PUSHs(sv_2mortal(sv));
4818 along = (strend - s) / sizeof(char*);
4824 if (sizeof(char*) > strend - s)
4827 Copy(s, &aptr, 1, char*);
4833 PUSHs(sv_2mortal(sv));
4843 while ((len > 0) && (s < strend)) {
4844 auv = (auv << 7) | (*s & 0x7f);
4845 /* UTF8_IS_XXXXX not right here - using constant 0x80 */
4846 if ((U8)(*s++) < 0x80) {
4850 PUSHs(sv_2mortal(sv));
4854 else if (++bytes >= sizeof(UV)) { /* promote to string */
4858 sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv);
4859 while (s < strend) {
4860 sv = mul128(sv, *s & 0x7f);
4861 if (!(*s++ & 0x80)) {
4870 PUSHs(sv_2mortal(sv));
4875 if ((s >= strend) && bytes)
4876 DIE(aTHX_ "Unterminated compressed integer");
4881 if (sizeof(char*) > strend - s)
4884 Copy(s, &aptr, 1, char*);
4889 sv_setpvn(sv, aptr, len);
4890 PUSHs(sv_2mortal(sv));
4894 along = (strend - s) / sizeof(Quad_t);
4900 if (s + sizeof(Quad_t) > strend)
4903 Copy(s, &aquad, 1, Quad_t);
4904 s += sizeof(Quad_t);
4907 if (aquad >= IV_MIN && aquad <= IV_MAX)
4908 sv_setiv(sv, (IV)aquad);
4910 sv_setnv(sv, (NV)aquad);
4911 PUSHs(sv_2mortal(sv));
4915 along = (strend - s) / sizeof(Quad_t);
4921 if (s + sizeof(Uquad_t) > strend)
4924 Copy(s, &auquad, 1, Uquad_t);
4925 s += sizeof(Uquad_t);
4928 if (auquad <= UV_MAX)
4929 sv_setuv(sv, (UV)auquad);
4931 sv_setnv(sv, (NV)auquad);
4932 PUSHs(sv_2mortal(sv));
4936 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
4939 along = (strend - s) / sizeof(float);
4944 Copy(s, &afloat, 1, float);
4953 Copy(s, &afloat, 1, float);
4956 sv_setnv(sv, (NV)afloat);
4957 PUSHs(sv_2mortal(sv));
4963 along = (strend - s) / sizeof(double);
4968 Copy(s, &adouble, 1, double);
4969 s += sizeof(double);
4977 Copy(s, &adouble, 1, double);
4978 s += sizeof(double);
4980 sv_setnv(sv, (NV)adouble);
4981 PUSHs(sv_2mortal(sv));
4987 * Initialise the decode mapping. By using a table driven
4988 * algorithm, the code will be character-set independent
4989 * (and just as fast as doing character arithmetic)
4991 if (PL_uudmap['M'] == 0) {
4994 for (i = 0; i < sizeof(PL_uuemap); i += 1)
4995 PL_uudmap[(U8)PL_uuemap[i]] = i;
4997 * Because ' ' and '`' map to the same value,
4998 * we need to decode them both the same.
5003 along = (strend - s) * 3 / 4;
5004 sv = NEWSV(42, along);
5007 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
5012 len = PL_uudmap[*(U8*)s++] & 077;
5014 if (s < strend && ISUUCHAR(*s))
5015 a = PL_uudmap[*(U8*)s++] & 077;
5018 if (s < strend && ISUUCHAR(*s))
5019 b = PL_uudmap[*(U8*)s++] & 077;
5022 if (s < strend && ISUUCHAR(*s))
5023 c = PL_uudmap[*(U8*)s++] & 077;
5026 if (s < strend && ISUUCHAR(*s))
5027 d = PL_uudmap[*(U8*)s++] & 077;
5030 hunk[0] = (a << 2) | (b >> 4);
5031 hunk[1] = (b << 4) | (c >> 2);
5032 hunk[2] = (c << 6) | d;
5033 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
5038 else if (s[1] == '\n') /* possible checksum byte */
5041 XPUSHs(sv_2mortal(sv));
5046 if (strchr("fFdD", datumtype) ||
5047 (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
5051 while (checksum >= 16) {
5055 while (checksum >= 4) {
5061 along = (1 << checksum) - 1;
5062 while (cdouble < 0.0)
5064 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
5065 sv_setnv(sv, cdouble);
5068 if (checksum < 32) {
5069 aulong = (1 << checksum) - 1;
5072 sv_setuv(sv, (UV)culong);
5074 XPUSHs(sv_2mortal(sv));
5078 if (SP - PL_stack_base == start_sp_offset && gimme == G_SCALAR)
5079 PUSHs(&PL_sv_undef);
5084 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
5088 *hunk = PL_uuemap[len];
5089 sv_catpvn(sv, hunk, 1);
5092 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
5093 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
5094 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
5095 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
5096 sv_catpvn(sv, hunk, 4);
5101 char r = (len > 1 ? s[1] : '\0');
5102 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
5103 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
5104 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
5105 hunk[3] = PL_uuemap[0];
5106 sv_catpvn(sv, hunk, 4);
5108 sv_catpvn(sv, "\n", 1);
5112 S_is_an_int(pTHX_ char *s, STRLEN l)
5115 SV *result = newSVpvn(s, l);
5116 char *result_c = SvPV(result, n_a); /* convenience */
5117 char *out = result_c;
5127 SvREFCNT_dec(result);
5150 SvREFCNT_dec(result);
5156 SvCUR_set(result, out - result_c);
5160 /* pnum must be '\0' terminated */
5162 S_div128(pTHX_ SV *pnum, bool *done)
5165 char *s = SvPV(pnum, len);
5174 i = m * 10 + (*t - '0');
5176 r = (i >> 7); /* r < 10 */
5183 SvCUR_set(pnum, (STRLEN) (t - s));
5190 dSP; dMARK; dORIGMARK; dTARGET;
5191 register SV *cat = TARG;
5194 register char *pat = SvPVx(*++MARK, fromlen);
5196 register char *patend = pat + fromlen;
5201 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
5202 static char *space10 = " ";
5204 /* These must not be in registers: */
5219 #ifdef PERL_NATINT_PACK
5220 int natint; /* native integer */
5225 sv_setpvn(cat, "", 0);
5227 while (pat < patend) {
5228 SV *lengthcode = Nullsv;
5229 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no)
5230 datumtype = *pat++ & 0xFF;
5231 #ifdef PERL_NATINT_PACK
5234 if (isSPACE(datumtype)) {
5238 #ifndef PACKED_IS_OCTETS
5239 if (datumtype == 'U' && pat == patcopy+1)
5242 if (datumtype == '#') {
5243 while (pat < patend && *pat != '\n')
5248 char *natstr = "sSiIlL";
5250 if (strchr(natstr, datumtype)) {
5251 #ifdef PERL_NATINT_PACK
5257 DIE(aTHX_ "'!' allowed only after types %s", natstr);
5260 len = strchr("@Xxu", datumtype) ? 0 : items;
5263 else if (isDIGIT(*pat)) {
5265 while (isDIGIT(*pat)) {
5266 len = (len * 10) + (*pat++ - '0');
5268 DIE(aTHX_ "Repeat count in pack overflows");
5275 if ((*pat != 'a' && *pat != 'A' && *pat != 'Z') || pat[1] != '*')
5276 DIE(aTHX_ "/ must be followed by a*, A* or Z*");
5277 lengthcode = sv_2mortal(newSViv(sv_len(items > 0
5278 ? *MARK : &PL_sv_no)
5279 + (*pat == 'Z' ? 1 : 0)));
5283 DIE(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
5284 case ',': /* grandfather in commas but with a warning */
5285 if (commas++ == 0 && ckWARN(WARN_PACK))
5286 Perl_warner(aTHX_ WARN_PACK,
5287 "Invalid type in pack: '%c'", (int)datumtype);
5290 DIE(aTHX_ "%% may only be used in unpack");
5301 if (SvCUR(cat) < len)
5302 DIE(aTHX_ "X outside of string");
5309 sv_catpvn(cat, null10, 10);
5312 sv_catpvn(cat, null10, len);
5318 aptr = SvPV(fromstr, fromlen);
5319 if (pat[-1] == '*') {
5321 if (datumtype == 'Z')
5324 if (fromlen >= len) {
5325 sv_catpvn(cat, aptr, len);
5326 if (datumtype == 'Z')
5327 *(SvEND(cat)-1) = '\0';
5330 sv_catpvn(cat, aptr, fromlen);
5332 if (datumtype == 'A') {
5334 sv_catpvn(cat, space10, 10);
5337 sv_catpvn(cat, space10, len);
5341 sv_catpvn(cat, null10, 10);
5344 sv_catpvn(cat, null10, len);
5356 str = SvPV(fromstr, fromlen);
5360 SvCUR(cat) += (len+7)/8;
5361 SvGROW(cat, SvCUR(cat) + 1);
5362 aptr = SvPVX(cat) + aint;
5367 if (datumtype == 'B') {
5368 for (len = 0; len++ < aint;) {
5369 items |= *str++ & 1;
5373 *aptr++ = items & 0xff;
5379 for (len = 0; len++ < aint;) {
5385 *aptr++ = items & 0xff;
5391 if (datumtype == 'B')
5392 items <<= 7 - (aint & 7);
5394 items >>= 7 - (aint & 7);
5395 *aptr++ = items & 0xff;
5397 str = SvPVX(cat) + SvCUR(cat);
5412 str = SvPV(fromstr, fromlen);
5416 SvCUR(cat) += (len+1)/2;
5417 SvGROW(cat, SvCUR(cat) + 1);
5418 aptr = SvPVX(cat) + aint;
5423 if (datumtype == 'H') {
5424 for (len = 0; len++ < aint;) {
5426 items |= ((*str++ & 15) + 9) & 15;
5428 items |= *str++ & 15;
5432 *aptr++ = items & 0xff;
5438 for (len = 0; len++ < aint;) {
5440 items |= (((*str++ & 15) + 9) & 15) << 4;
5442 items |= (*str++ & 15) << 4;
5446 *aptr++ = items & 0xff;
5452 *aptr++ = items & 0xff;
5453 str = SvPVX(cat) + SvCUR(cat);
5464 aint = SvIV(fromstr);
5466 sv_catpvn(cat, &achar, sizeof(char));
5472 auint = SvUV(fromstr);
5473 SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN + 1);
5474 SvCUR_set(cat, (char*)uvchr_to_utf8((U8*)SvEND(cat),auint)
5479 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
5484 afloat = (float)SvNV(fromstr);
5485 sv_catpvn(cat, (char *)&afloat, sizeof (float));
5492 adouble = (double)SvNV(fromstr);
5493 sv_catpvn(cat, (char *)&adouble, sizeof (double));
5499 ashort = (I16)SvIV(fromstr);
5501 ashort = PerlSock_htons(ashort);
5503 CAT16(cat, &ashort);
5509 ashort = (I16)SvIV(fromstr);
5511 ashort = htovs(ashort);
5513 CAT16(cat, &ashort);
5517 #if SHORTSIZE != SIZE16
5519 unsigned short aushort;
5523 aushort = SvUV(fromstr);
5524 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
5534 aushort = (U16)SvUV(fromstr);
5535 CAT16(cat, &aushort);
5541 #if SHORTSIZE != SIZE16
5547 ashort = SvIV(fromstr);
5548 sv_catpvn(cat, (char *)&ashort, sizeof(short));
5556 ashort = (I16)SvIV(fromstr);
5557 CAT16(cat, &ashort);
5564 auint = SvUV(fromstr);
5565 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
5571 adouble = Perl_floor(SvNV(fromstr));
5574 DIE(aTHX_ "Cannot compress negative numbers");
5577 #if UVSIZE > 4 && UVSIZE >= NVSIZE
5578 adouble <= 0xffffffff
5580 # ifdef CXUX_BROKEN_CONSTANT_CONVERT
5581 adouble <= UV_MAX_cxux
5588 char buf[1 + sizeof(UV)];
5589 char *in = buf + sizeof(buf);
5590 UV auv = U_V(adouble);
5593 *--in = (auv & 0x7f) | 0x80;
5596 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
5597 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
5599 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
5600 char *from, *result, *in;
5605 /* Copy string and check for compliance */
5606 from = SvPV(fromstr, len);
5607 if ((norm = is_an_int(from, len)) == NULL)
5608 DIE(aTHX_ "can compress only unsigned integer");
5610 New('w', result, len, char);
5614 *--in = div128(norm, &done) | 0x80;
5615 result[len - 1] &= 0x7F; /* clear continue bit */
5616 sv_catpvn(cat, in, (result + len) - in);
5618 SvREFCNT_dec(norm); /* free norm */
5620 else if (SvNOKp(fromstr)) {
5621 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
5622 char *in = buf + sizeof(buf);
5625 double next = floor(adouble / 128);
5626 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
5627 if (in <= buf) /* this cannot happen ;-) */
5628 DIE(aTHX_ "Cannot compress integer");
5631 } while (adouble > 0);
5632 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
5633 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
5636 DIE(aTHX_ "Cannot compress non integer");
5642 aint = SvIV(fromstr);
5643 sv_catpvn(cat, (char*)&aint, sizeof(int));
5649 aulong = SvUV(fromstr);
5651 aulong = PerlSock_htonl(aulong);
5653 CAT32(cat, &aulong);
5659 aulong = SvUV(fromstr);
5661 aulong = htovl(aulong);
5663 CAT32(cat, &aulong);
5667 #if LONGSIZE != SIZE32
5669 unsigned long aulong;
5673 aulong = SvUV(fromstr);
5674 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
5682 aulong = SvUV(fromstr);
5683 CAT32(cat, &aulong);
5688 #if LONGSIZE != SIZE32
5694 along = SvIV(fromstr);
5695 sv_catpvn(cat, (char *)&along, sizeof(long));
5703 along = SvIV(fromstr);
5712 auquad = (Uquad_t)SvUV(fromstr);
5713 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
5719 aquad = (Quad_t)SvIV(fromstr);
5720 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
5725 len = 1; /* assume SV is correct length */
5730 if (fromstr == &PL_sv_undef)
5734 /* XXX better yet, could spirit away the string to
5735 * a safe spot and hang on to it until the result
5736 * of pack() (and all copies of the result) are
5739 if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
5740 || (SvPADTMP(fromstr)
5741 && !SvREADONLY(fromstr))))
5743 Perl_warner(aTHX_ WARN_PACK,
5744 "Attempt to pack pointer to temporary value");
5746 if (SvPOK(fromstr) || SvNIOK(fromstr))
5747 aptr = SvPV(fromstr,n_a);
5749 aptr = SvPV_force(fromstr,n_a);
5751 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
5756 aptr = SvPV(fromstr, fromlen);
5757 SvGROW(cat, fromlen * 4 / 3);
5762 while (fromlen > 0) {
5769 doencodes(cat, aptr, todo);
5788 register IV limit = POPi; /* note, negative is forever */
5791 register char *s = SvPV(sv, len);
5792 bool do_utf8 = DO_UTF8(sv);
5793 char *strend = s + len;
5795 register REGEXP *rx;
5799 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
5800 I32 maxiters = slen + 10;
5803 I32 origlimit = limit;
5806 AV *oldstack = PL_curstack;
5807 I32 gimme = GIMME_V;
5808 I32 oldsave = PL_savestack_ix;
5809 I32 make_mortal = 1;
5810 MAGIC *mg = (MAGIC *) NULL;
5813 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5818 DIE(aTHX_ "panic: pp_split");
5819 rx = pm->op_pmregexp;
5821 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
5822 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
5824 if (pm->op_pmreplroot) {
5826 ary = GvAVn((GV*)PL_curpad[(PADOFFSET)pm->op_pmreplroot]);
5828 ary = GvAVn((GV*)pm->op_pmreplroot);
5831 else if (gimme != G_ARRAY)
5833 ary = (AV*)PL_curpad[0];
5835 ary = GvAVn(PL_defgv);
5836 #endif /* USE_THREADS */
5839 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
5845 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
5847 XPUSHs(SvTIED_obj((SV*)ary, mg));
5853 for (i = AvFILLp(ary); i >= 0; i--)
5854 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5856 /* temporarily switch stacks */
5857 SWITCHSTACK(PL_curstack, ary);
5861 base = SP - PL_stack_base;
5863 if (pm->op_pmflags & PMf_SKIPWHITE) {
5864 if (pm->op_pmflags & PMf_LOCALE) {
5865 while (isSPACE_LC(*s))
5873 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
5874 SAVEINT(PL_multiline);
5875 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
5879 limit = maxiters + 2;
5880 if (pm->op_pmflags & PMf_WHITE) {
5883 while (m < strend &&
5884 !((pm->op_pmflags & PMf_LOCALE)
5885 ? isSPACE_LC(*m) : isSPACE(*m)))
5890 dstr = NEWSV(30, m-s);
5891 sv_setpvn(dstr, s, m-s);
5895 (void)SvUTF8_on(dstr);
5899 while (s < strend &&
5900 ((pm->op_pmflags & PMf_LOCALE)
5901 ? isSPACE_LC(*s) : isSPACE(*s)))
5905 else if (strEQ("^", rx->precomp)) {
5908 for (m = s; m < strend && *m != '\n'; m++) ;
5912 dstr = NEWSV(30, m-s);
5913 sv_setpvn(dstr, s, m-s);
5917 (void)SvUTF8_on(dstr);
5922 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
5923 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
5924 && (rx->reganch & ROPT_CHECK_ALL)
5925 && !(rx->reganch & ROPT_ANCH)) {
5926 int tail = (rx->reganch & RE_INTUIT_TAIL);
5927 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
5930 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
5932 char c = *SvPV(csv, n_a);
5935 for (m = s; m < strend && *m != c; m++) ;
5938 dstr = NEWSV(30, m-s);
5939 sv_setpvn(dstr, s, m-s);
5943 (void)SvUTF8_on(dstr);
5945 /* The rx->minlen is in characters but we want to step
5946 * s ahead by bytes. */
5948 s = (char*)utf8_hop((U8*)m, len);
5950 s = m + len; /* Fake \n at the end */
5955 while (s < strend && --limit &&
5956 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5957 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
5960 dstr = NEWSV(31, m-s);
5961 sv_setpvn(dstr, s, m-s);
5965 (void)SvUTF8_on(dstr);
5967 /* The rx->minlen is in characters but we want to step
5968 * s ahead by bytes. */
5970 s = (char*)utf8_hop((U8*)m, len);
5972 s = m + len; /* Fake \n at the end */
5977 maxiters += slen * rx->nparens;
5978 while (s < strend && --limit
5979 /* && (!rx->check_substr
5980 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
5982 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
5983 1 /* minend */, sv, NULL, 0))
5985 TAINT_IF(RX_MATCH_TAINTED(rx));
5986 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
5991 strend = s + (strend - m);
5993 m = rx->startp[0] + orig;
5994 dstr = NEWSV(32, m-s);
5995 sv_setpvn(dstr, s, m-s);
5999 (void)SvUTF8_on(dstr);
6002 for (i = 1; i <= rx->nparens; i++) {
6003 s = rx->startp[i] + orig;
6004 m = rx->endp[i] + orig;
6006 dstr = NEWSV(33, m-s);
6007 sv_setpvn(dstr, s, m-s);
6010 dstr = NEWSV(33, 0);
6014 (void)SvUTF8_on(dstr);
6018 s = rx->endp[0] + orig;
6022 LEAVE_SCOPE(oldsave);
6023 iters = (SP - PL_stack_base) - base;
6024 if (iters > maxiters)
6025 DIE(aTHX_ "Split loop");
6027 /* keep field after final delim? */
6028 if (s < strend || (iters && origlimit)) {
6029 STRLEN l = strend - s;
6030 dstr = NEWSV(34, l);
6031 sv_setpvn(dstr, s, l);
6035 (void)SvUTF8_on(dstr);
6039 else if (!origlimit) {
6040 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
6046 SWITCHSTACK(ary, oldstack);
6047 if (SvSMAGICAL(ary)) {
6052 if (gimme == G_ARRAY) {
6054 Copy(AvARRAY(ary), SP + 1, iters, SV*);
6062 call_method("PUSH",G_SCALAR|G_DISCARD);
6065 if (gimme == G_ARRAY) {
6066 /* EXTEND should not be needed - we just popped them */
6068 for (i=0; i < iters; i++) {
6069 SV **svp = av_fetch(ary, i, FALSE);
6070 PUSHs((svp) ? *svp : &PL_sv_undef);
6077 if (gimme == G_ARRAY)
6080 if (iters || !pm->op_pmreplroot) {
6090 Perl_unlock_condpair(pTHX_ void *svv)
6092 MAGIC *mg = mg_find((SV*)svv, 'm');
6095 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
6096 MUTEX_LOCK(MgMUTEXP(mg));
6097 if (MgOWNER(mg) != thr)
6098 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
6100 COND_SIGNAL(MgOWNERCONDP(mg));
6101 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
6102 PTR2UV(thr), PTR2UV(svv));)
6103 MUTEX_UNLOCK(MgMUTEXP(mg));
6105 #endif /* USE_THREADS */
6114 #endif /* USE_THREADS */
6115 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
6116 || SvTYPE(retsv) == SVt_PVCV) {
6117 retsv = refto(retsv);
6128 if (PL_op->op_private & OPpLVAL_INTRO)
6129 PUSHs(*save_threadsv(PL_op->op_targ));
6131 PUSHs(THREADSV(PL_op->op_targ));
6134 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
6135 #endif /* USE_THREADS */