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);
1243 dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
1244 useleft = USE_LEFT(TOPm1s);
1245 #ifdef PERL_PRESERVE_IVUV
1246 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1247 "bad things" happen if you rely on signed integers wrapping. */
1250 /* Unless the left argument is integer in range we are going to have to
1251 use NV maths. Hence only attempt to coerce the right argument if
1252 we know the left is integer. */
1259 a_valid = auvok = 1;
1260 /* left operand is undef, treat as zero. */
1262 /* Left operand is defined, so is it IV? */
1263 SvIV_please(TOPm1s);
1264 if (SvIOK(TOPm1s)) {
1265 if ((auvok = SvUOK(TOPm1s)))
1266 auv = SvUVX(TOPm1s);
1268 register IV aiv = SvIVX(TOPm1s);
1271 auvok = 1; /* Now acting as a sign flag. */
1272 } else { /* 2s complement assumption for IV_MIN */
1280 bool result_good = 0;
1283 bool buvok = SvUOK(TOPs);
1288 register IV biv = SvIVX(TOPs);
1295 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1296 else "IV" now, independant of how it came in.
1297 if a, b represents positive, A, B negative, a maps to -A etc
1302 all UV maths. negate result if A negative.
1303 subtract if signs same, add if signs differ. */
1305 if (auvok ^ buvok) {
1314 /* Must get smaller */
1319 if (result <= buv) {
1320 /* result really should be -(auv-buv). as its negation
1321 of true value, need to swap our result flag */
1333 if (result <= (UV)IV_MIN)
1334 SETi( -(IV)result );
1336 /* result valid, but out of range for IV. */
1337 SETn( -(NV)result );
1341 } /* Overflow, drop through to NVs. */
1345 useleft = USE_LEFT(TOPm1s);
1349 /* left operand is undef, treat as zero - value */
1353 SETn( TOPn - value );
1360 dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1363 if (PL_op->op_private & HINT_INTEGER) {
1377 dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1380 if (PL_op->op_private & HINT_INTEGER) {
1394 dSP; tryAMAGICbinSET(lt,0);
1395 #ifdef PERL_PRESERVE_IVUV
1398 SvIV_please(TOPm1s);
1399 if (SvIOK(TOPm1s)) {
1400 bool auvok = SvUOK(TOPm1s);
1401 bool buvok = SvUOK(TOPs);
1403 if (!auvok && !buvok) { /* ## IV < IV ## */
1404 IV aiv = SvIVX(TOPm1s);
1405 IV biv = SvIVX(TOPs);
1408 SETs(boolSV(aiv < biv));
1411 if (auvok && buvok) { /* ## UV < UV ## */
1412 UV auv = SvUVX(TOPm1s);
1413 UV buv = SvUVX(TOPs);
1416 SETs(boolSV(auv < buv));
1419 if (auvok) { /* ## UV < IV ## */
1426 /* As (a) is a UV, it's >=0, so it cannot be < */
1431 if (auv >= (UV) IV_MAX) {
1432 /* As (b) is an IV, it cannot be > IV_MAX */
1436 SETs(boolSV(auv < (UV)biv));
1439 { /* ## IV < UV ## */
1443 aiv = SvIVX(TOPm1s);
1445 /* As (b) is a UV, it's >=0, so it must be < */
1452 if (buv > (UV) IV_MAX) {
1453 /* As (a) is an IV, it cannot be > IV_MAX */
1457 SETs(boolSV((UV)aiv < buv));
1465 SETs(boolSV(TOPn < value));
1472 dSP; tryAMAGICbinSET(gt,0);
1473 #ifdef PERL_PRESERVE_IVUV
1476 SvIV_please(TOPm1s);
1477 if (SvIOK(TOPm1s)) {
1478 bool auvok = SvUOK(TOPm1s);
1479 bool buvok = SvUOK(TOPs);
1481 if (!auvok && !buvok) { /* ## IV > IV ## */
1482 IV aiv = SvIVX(TOPm1s);
1483 IV biv = SvIVX(TOPs);
1486 SETs(boolSV(aiv > biv));
1489 if (auvok && buvok) { /* ## UV > UV ## */
1490 UV auv = SvUVX(TOPm1s);
1491 UV buv = SvUVX(TOPs);
1494 SETs(boolSV(auv > buv));
1497 if (auvok) { /* ## UV > IV ## */
1504 /* As (a) is a UV, it's >=0, so it must be > */
1509 if (auv > (UV) IV_MAX) {
1510 /* As (b) is an IV, it cannot be > IV_MAX */
1514 SETs(boolSV(auv > (UV)biv));
1517 { /* ## IV > UV ## */
1521 aiv = SvIVX(TOPm1s);
1523 /* As (b) is a UV, it's >=0, so it cannot be > */
1530 if (buv >= (UV) IV_MAX) {
1531 /* As (a) is an IV, it cannot be > IV_MAX */
1535 SETs(boolSV((UV)aiv > buv));
1543 SETs(boolSV(TOPn > value));
1550 dSP; tryAMAGICbinSET(le,0);
1551 #ifdef PERL_PRESERVE_IVUV
1554 SvIV_please(TOPm1s);
1555 if (SvIOK(TOPm1s)) {
1556 bool auvok = SvUOK(TOPm1s);
1557 bool buvok = SvUOK(TOPs);
1559 if (!auvok && !buvok) { /* ## IV <= IV ## */
1560 IV aiv = SvIVX(TOPm1s);
1561 IV biv = SvIVX(TOPs);
1564 SETs(boolSV(aiv <= biv));
1567 if (auvok && buvok) { /* ## UV <= UV ## */
1568 UV auv = SvUVX(TOPm1s);
1569 UV buv = SvUVX(TOPs);
1572 SETs(boolSV(auv <= buv));
1575 if (auvok) { /* ## UV <= IV ## */
1582 /* As (a) is a UV, it's >=0, so a cannot be <= */
1587 if (auv > (UV) IV_MAX) {
1588 /* As (b) is an IV, it cannot be > IV_MAX */
1592 SETs(boolSV(auv <= (UV)biv));
1595 { /* ## IV <= UV ## */
1599 aiv = SvIVX(TOPm1s);
1601 /* As (b) is a UV, it's >=0, so a must be <= */
1608 if (buv >= (UV) IV_MAX) {
1609 /* As (a) is an IV, it cannot be > IV_MAX */
1613 SETs(boolSV((UV)aiv <= buv));
1621 SETs(boolSV(TOPn <= value));
1628 dSP; tryAMAGICbinSET(ge,0);
1629 #ifdef PERL_PRESERVE_IVUV
1632 SvIV_please(TOPm1s);
1633 if (SvIOK(TOPm1s)) {
1634 bool auvok = SvUOK(TOPm1s);
1635 bool buvok = SvUOK(TOPs);
1637 if (!auvok && !buvok) { /* ## IV >= IV ## */
1638 IV aiv = SvIVX(TOPm1s);
1639 IV biv = SvIVX(TOPs);
1642 SETs(boolSV(aiv >= biv));
1645 if (auvok && buvok) { /* ## UV >= UV ## */
1646 UV auv = SvUVX(TOPm1s);
1647 UV buv = SvUVX(TOPs);
1650 SETs(boolSV(auv >= buv));
1653 if (auvok) { /* ## UV >= IV ## */
1660 /* As (a) is a UV, it's >=0, so it must be >= */
1665 if (auv >= (UV) IV_MAX) {
1666 /* As (b) is an IV, it cannot be > IV_MAX */
1670 SETs(boolSV(auv >= (UV)biv));
1673 { /* ## IV >= UV ## */
1677 aiv = SvIVX(TOPm1s);
1679 /* As (b) is a UV, it's >=0, so a cannot be >= */
1686 if (buv > (UV) IV_MAX) {
1687 /* As (a) is an IV, it cannot be > IV_MAX */
1691 SETs(boolSV((UV)aiv >= buv));
1699 SETs(boolSV(TOPn >= value));
1706 dSP; tryAMAGICbinSET(ne,0);
1707 #ifdef PERL_PRESERVE_IVUV
1710 SvIV_please(TOPm1s);
1711 if (SvIOK(TOPm1s)) {
1712 bool auvok = SvUOK(TOPm1s);
1713 bool buvok = SvUOK(TOPs);
1715 if (!auvok && !buvok) { /* ## IV <=> IV ## */
1716 IV aiv = SvIVX(TOPm1s);
1717 IV biv = SvIVX(TOPs);
1720 SETs(boolSV(aiv != biv));
1723 if (auvok && buvok) { /* ## UV != UV ## */
1724 UV auv = SvUVX(TOPm1s);
1725 UV buv = SvUVX(TOPs);
1728 SETs(boolSV(auv != buv));
1731 { /* ## Mixed IV,UV ## */
1735 /* != is commutative so swap if needed (save code) */
1737 /* swap. top of stack (b) is the iv */
1741 /* As (a) is a UV, it's >0, so it cannot be == */
1750 /* As (b) is a UV, it's >0, so it cannot be == */
1754 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
1756 /* we know iv is >= 0 */
1757 if (uv > (UV) IV_MAX) {
1761 SETs(boolSV((UV)iv != uv));
1769 SETs(boolSV(TOPn != value));
1776 dSP; dTARGET; tryAMAGICbin(ncmp,0);
1777 #ifdef PERL_PRESERVE_IVUV
1778 /* Fortunately it seems NaN isn't IOK */
1781 SvIV_please(TOPm1s);
1782 if (SvIOK(TOPm1s)) {
1783 bool leftuvok = SvUOK(TOPm1s);
1784 bool rightuvok = SvUOK(TOPs);
1786 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
1787 IV leftiv = SvIVX(TOPm1s);
1788 IV rightiv = SvIVX(TOPs);
1790 if (leftiv > rightiv)
1792 else if (leftiv < rightiv)
1796 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
1797 UV leftuv = SvUVX(TOPm1s);
1798 UV rightuv = SvUVX(TOPs);
1800 if (leftuv > rightuv)
1802 else if (leftuv < rightuv)
1806 } else if (leftuvok) { /* ## UV <=> IV ## */
1810 rightiv = SvIVX(TOPs);
1812 /* As (a) is a UV, it's >=0, so it cannot be < */
1815 leftuv = SvUVX(TOPm1s);
1816 if (leftuv > (UV) IV_MAX) {
1817 /* As (b) is an IV, it cannot be > IV_MAX */
1819 } else if (leftuv > (UV)rightiv) {
1821 } else if (leftuv < (UV)rightiv) {
1827 } else { /* ## IV <=> UV ## */
1831 leftiv = SvIVX(TOPm1s);
1833 /* As (b) is a UV, it's >=0, so it must be < */
1836 rightuv = SvUVX(TOPs);
1837 if (rightuv > (UV) IV_MAX) {
1838 /* As (a) is an IV, it cannot be > IV_MAX */
1840 } else if (leftiv > (UV)rightuv) {
1842 } else if (leftiv < (UV)rightuv) {
1860 if (Perl_isnan(left) || Perl_isnan(right)) {
1864 value = (left > right) - (left < right);
1868 else if (left < right)
1870 else if (left > right)
1884 dSP; tryAMAGICbinSET(slt,0);
1887 int cmp = ((PL_op->op_private & OPpLOCALE)
1888 ? sv_cmp_locale(left, right)
1889 : sv_cmp(left, right));
1890 SETs(boolSV(cmp < 0));
1897 dSP; tryAMAGICbinSET(sgt,0);
1900 int cmp = ((PL_op->op_private & OPpLOCALE)
1901 ? sv_cmp_locale(left, right)
1902 : sv_cmp(left, right));
1903 SETs(boolSV(cmp > 0));
1910 dSP; tryAMAGICbinSET(sle,0);
1913 int cmp = ((PL_op->op_private & OPpLOCALE)
1914 ? sv_cmp_locale(left, right)
1915 : sv_cmp(left, right));
1916 SETs(boolSV(cmp <= 0));
1923 dSP; tryAMAGICbinSET(sge,0);
1926 int cmp = ((PL_op->op_private & OPpLOCALE)
1927 ? sv_cmp_locale(left, right)
1928 : sv_cmp(left, right));
1929 SETs(boolSV(cmp >= 0));
1936 dSP; tryAMAGICbinSET(seq,0);
1939 SETs(boolSV(sv_eq(left, right)));
1946 dSP; tryAMAGICbinSET(sne,0);
1949 SETs(boolSV(!sv_eq(left, right)));
1956 dSP; dTARGET; tryAMAGICbin(scmp,0);
1959 int cmp = ((PL_op->op_private & OPpLOCALE)
1960 ? sv_cmp_locale(left, right)
1961 : sv_cmp(left, right));
1969 dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
1972 if (SvNIOKp(left) || SvNIOKp(right)) {
1973 if (PL_op->op_private & HINT_INTEGER) {
1974 IV i = SvIV(left) & SvIV(right);
1978 UV u = SvUV(left) & SvUV(right);
1983 do_vop(PL_op->op_type, TARG, left, right);
1992 dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
1995 if (SvNIOKp(left) || SvNIOKp(right)) {
1996 if (PL_op->op_private & HINT_INTEGER) {
1997 IV i = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
2001 UV u = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
2006 do_vop(PL_op->op_type, TARG, left, right);
2015 dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
2018 if (SvNIOKp(left) || SvNIOKp(right)) {
2019 if (PL_op->op_private & HINT_INTEGER) {
2020 IV i = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
2024 UV u = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
2029 do_vop(PL_op->op_type, TARG, left, right);
2038 dSP; dTARGET; tryAMAGICun(neg);
2041 int flags = SvFLAGS(sv);
2044 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2045 /* It's publicly an integer, or privately an integer-not-float */
2048 if (SvIVX(sv) == IV_MIN) {
2049 /* 2s complement assumption. */
2050 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2053 else if (SvUVX(sv) <= IV_MAX) {
2058 else if (SvIVX(sv) != IV_MIN) {
2062 #ifdef PERL_PRESERVE_IVUV
2071 else if (SvPOKp(sv)) {
2073 char *s = SvPV(sv, len);
2074 if (isIDFIRST(*s)) {
2075 sv_setpvn(TARG, "-", 1);
2078 else if (*s == '+' || *s == '-') {
2080 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2082 else if (DO_UTF8(sv) && UTF8_IS_START(*s) && isIDFIRST_utf8((U8*)s)) {
2083 sv_setpvn(TARG, "-", 1);
2089 goto oops_its_an_int;
2090 sv_setnv(TARG, -SvNV(sv));
2102 dSP; tryAMAGICunSET(not);
2103 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2109 dSP; dTARGET; tryAMAGICun(compl);
2113 if (PL_op->op_private & HINT_INTEGER) {
2128 tmps = (U8*)SvPV_force(TARG, len);
2131 /* Calculate exact length, let's not estimate. */
2140 while (tmps < send) {
2141 UV c = utf8_to_uv(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2142 tmps += UTF8SKIP(tmps);
2143 targlen += UNISKIP(~c);
2149 /* Now rewind strings and write them. */
2153 Newz(0, result, targlen + 1, U8);
2154 while (tmps < send) {
2155 UV c = utf8_to_uv(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2156 tmps += UTF8SKIP(tmps);
2157 result = uv_to_utf8(result, ~c);
2161 sv_setpvn(TARG, (char*)result, targlen);
2165 Newz(0, result, nchar + 1, U8);
2166 while (tmps < send) {
2167 U8 c = (U8)utf8_to_uv(tmps, 0, &l, UTF8_ALLOW_ANY);
2168 tmps += UTF8SKIP(tmps);
2173 sv_setpvn(TARG, (char*)result, nchar);
2181 register long *tmpl;
2182 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2185 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2190 for ( ; anum > 0; anum--, tmps++)
2199 /* integer versions of some of the above */
2203 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2206 SETi( left * right );
2213 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2217 DIE(aTHX_ "Illegal division by zero");
2218 value = POPi / value;
2226 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2230 DIE(aTHX_ "Illegal modulus zero");
2231 SETi( left % right );
2238 dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2241 SETi( left + right );
2248 dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2251 SETi( left - right );
2258 dSP; tryAMAGICbinSET(lt,0);
2261 SETs(boolSV(left < right));
2268 dSP; tryAMAGICbinSET(gt,0);
2271 SETs(boolSV(left > right));
2278 dSP; tryAMAGICbinSET(le,0);
2281 SETs(boolSV(left <= right));
2288 dSP; tryAMAGICbinSET(ge,0);
2291 SETs(boolSV(left >= right));
2298 dSP; tryAMAGICbinSET(eq,0);
2301 SETs(boolSV(left == right));
2308 dSP; tryAMAGICbinSET(ne,0);
2311 SETs(boolSV(left != right));
2318 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2325 else if (left < right)
2336 dSP; dTARGET; tryAMAGICun(neg);
2341 /* High falutin' math. */
2345 dSP; dTARGET; tryAMAGICbin(atan2,0);
2348 SETn(Perl_atan2(left, right));
2355 dSP; dTARGET; tryAMAGICun(sin);
2359 value = Perl_sin(value);
2367 dSP; dTARGET; tryAMAGICun(cos);
2371 value = Perl_cos(value);
2377 /* Support Configure command-line overrides for rand() functions.
2378 After 5.005, perhaps we should replace this by Configure support
2379 for drand48(), random(), or rand(). For 5.005, though, maintain
2380 compatibility by calling rand() but allow the user to override it.
2381 See INSTALL for details. --Andy Dougherty 15 July 1998
2383 /* Now it's after 5.005, and Configure supports drand48() and random(),
2384 in addition to rand(). So the overrides should not be needed any more.
2385 --Jarkko Hietaniemi 27 September 1998
2388 #ifndef HAS_DRAND48_PROTO
2389 extern double drand48 (void);
2402 if (!PL_srand_called) {
2403 (void)seedDrand01((Rand_seed_t)seed());
2404 PL_srand_called = TRUE;
2419 (void)seedDrand01((Rand_seed_t)anum);
2420 PL_srand_called = TRUE;
2429 * This is really just a quick hack which grabs various garbage
2430 * values. It really should be a real hash algorithm which
2431 * spreads the effect of every input bit onto every output bit,
2432 * if someone who knows about such things would bother to write it.
2433 * Might be a good idea to add that function to CORE as well.
2434 * No numbers below come from careful analysis or anything here,
2435 * except they are primes and SEED_C1 > 1E6 to get a full-width
2436 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
2437 * probably be bigger too.
2440 # define SEED_C1 1000003
2441 #define SEED_C4 73819
2443 # define SEED_C1 25747
2444 #define SEED_C4 20639
2448 #define SEED_C5 26107
2450 #ifndef PERL_NO_DEV_RANDOM
2455 # include <starlet.h>
2456 /* when[] = (low 32 bits, high 32 bits) of time since epoch
2457 * in 100-ns units, typically incremented ever 10 ms. */
2458 unsigned int when[2];
2460 # ifdef HAS_GETTIMEOFDAY
2461 struct timeval when;
2467 /* This test is an escape hatch, this symbol isn't set by Configure. */
2468 #ifndef PERL_NO_DEV_RANDOM
2469 #ifndef PERL_RANDOM_DEVICE
2470 /* /dev/random isn't used by default because reads from it will block
2471 * if there isn't enough entropy available. You can compile with
2472 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
2473 * is enough real entropy to fill the seed. */
2474 # define PERL_RANDOM_DEVICE "/dev/urandom"
2476 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
2478 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
2487 _ckvmssts(sys$gettim(when));
2488 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
2490 # ifdef HAS_GETTIMEOFDAY
2491 gettimeofday(&when,(struct timezone *) 0);
2492 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
2495 u = (U32)SEED_C1 * when;
2498 u += SEED_C3 * (U32)PerlProc_getpid();
2499 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
2500 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
2501 u += SEED_C5 * (U32)PTR2UV(&when);
2508 dSP; dTARGET; tryAMAGICun(exp);
2512 value = Perl_exp(value);
2520 dSP; dTARGET; tryAMAGICun(log);
2525 SET_NUMERIC_STANDARD();
2526 DIE(aTHX_ "Can't take log of %g", value);
2528 value = Perl_log(value);
2536 dSP; dTARGET; tryAMAGICun(sqrt);
2541 SET_NUMERIC_STANDARD();
2542 DIE(aTHX_ "Can't take sqrt of %g", value);
2544 value = Perl_sqrt(value);
2552 dSP; dTARGET; tryAMAGICun(int);
2555 IV iv = TOPi; /* attempt to convert to IV if possible. */
2556 /* XXX it's arguable that compiler casting to IV might be subtly
2557 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2558 else preferring IV has introduced a subtle behaviour change bug. OTOH
2559 relying on floating point to be accurate is a bug. */
2570 if (value < (NV)UV_MAX + 0.5) {
2573 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2574 (void)Perl_modf(value, &value);
2576 double tmp = (double)value;
2577 (void)Perl_modf(tmp, &tmp);
2584 if (value > (NV)IV_MIN - 0.5) {
2587 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2588 (void)Perl_modf(-value, &value);
2591 double tmp = (double)value;
2592 (void)Perl_modf(-tmp, &tmp);
2605 dSP; dTARGET; tryAMAGICun(abs);
2607 /* This will cache the NV value if string isn't actually integer */
2611 /* IVX is precise */
2613 SETu(TOPu); /* force it to be numeric only */
2621 /* 2s complement assumption. Also, not really needed as
2622 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2645 argtype = 1; /* allow underscores */
2646 XPUSHn(scan_hex(tmps, 99, &argtype));
2659 while (*tmps && isSPACE(*tmps))
2663 argtype = 1; /* allow underscores */
2665 value = scan_hex(++tmps, 99, &argtype);
2666 else if (*tmps == 'b')
2667 value = scan_bin(++tmps, 99, &argtype);
2669 value = scan_oct(tmps, 99, &argtype);
2682 SETi(sv_len_utf8(sv));
2698 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2700 I32 arybase = PL_curcop->cop_arybase;
2703 int num_args = PL_op->op_private & 7;
2705 SvTAINTED_off(TARG); /* decontaminate */
2706 SvUTF8_off(TARG); /* decontaminate */
2710 repl = SvPV(sv, repl_len);
2717 tmps = SvPV(sv, curlen);
2719 utfcurlen = sv_len_utf8(sv);
2720 if (utfcurlen == curlen)
2728 if (pos >= arybase) {
2746 else if (len >= 0) {
2748 if (rem > (I32)curlen)
2763 Perl_croak(aTHX_ "substr outside of string");
2764 if (ckWARN(WARN_SUBSTR))
2765 Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string");
2772 sv_pos_u2b(sv, &pos, &rem);
2774 sv_setpvn(TARG, tmps, rem);
2778 sv_insert(sv, pos, rem, repl, repl_len);
2779 else if (lvalue) { /* it's an lvalue! */
2780 if (!SvGMAGICAL(sv)) {
2784 if (ckWARN(WARN_SUBSTR))
2785 Perl_warner(aTHX_ WARN_SUBSTR,
2786 "Attempt to use reference as lvalue in substr");
2788 if (SvOK(sv)) /* is it defined ? */
2789 (void)SvPOK_only_UTF8(sv);
2791 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
2794 if (SvTYPE(TARG) < SVt_PVLV) {
2795 sv_upgrade(TARG, SVt_PVLV);
2796 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
2800 if (LvTARG(TARG) != sv) {
2802 SvREFCNT_dec(LvTARG(TARG));
2803 LvTARG(TARG) = SvREFCNT_inc(sv);
2805 LvTARGOFF(TARG) = upos;
2806 LvTARGLEN(TARG) = urem;
2810 PUSHs(TARG); /* avoid SvSETMAGIC here */
2817 register IV size = POPi;
2818 register IV offset = POPi;
2819 register SV *src = POPs;
2820 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2822 SvTAINTED_off(TARG); /* decontaminate */
2823 if (lvalue) { /* it's an lvalue! */
2824 if (SvTYPE(TARG) < SVt_PVLV) {
2825 sv_upgrade(TARG, SVt_PVLV);
2826 sv_magic(TARG, Nullsv, 'v', Nullch, 0);
2829 if (LvTARG(TARG) != src) {
2831 SvREFCNT_dec(LvTARG(TARG));
2832 LvTARG(TARG) = SvREFCNT_inc(src);
2834 LvTARGOFF(TARG) = offset;
2835 LvTARGLEN(TARG) = size;
2838 sv_setuv(TARG, do_vecget(src, offset, size));
2853 I32 arybase = PL_curcop->cop_arybase;
2858 offset = POPi - arybase;
2861 tmps = SvPV(big, biglen);
2862 if (offset > 0 && DO_UTF8(big))
2863 sv_pos_u2b(big, &offset, 0);
2866 else if (offset > biglen)
2868 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2869 (unsigned char*)tmps + biglen, little, 0)))
2872 retval = tmps2 - tmps;
2873 if (retval > 0 && DO_UTF8(big))
2874 sv_pos_b2u(big, &retval);
2875 PUSHi(retval + arybase);
2890 I32 arybase = PL_curcop->cop_arybase;
2896 tmps2 = SvPV(little, llen);
2897 tmps = SvPV(big, blen);
2901 if (offset > 0 && DO_UTF8(big))
2902 sv_pos_u2b(big, &offset, 0);
2903 offset = offset - arybase + llen;
2907 else if (offset > blen)
2909 if (!(tmps2 = rninstr(tmps, tmps + offset,
2910 tmps2, tmps2 + llen)))
2913 retval = tmps2 - tmps;
2914 if (retval > 0 && DO_UTF8(big))
2915 sv_pos_b2u(big, &retval);
2916 PUSHi(retval + arybase);
2922 dSP; dMARK; dORIGMARK; dTARGET;
2923 do_sprintf(TARG, SP-MARK, MARK+1);
2924 TAINT_IF(SvTAINTED(TARG));
2935 U8 *s = (U8*)SvPVx(argsv, len);
2937 XPUSHu(DO_UTF8(argsv) ? utf8_to_uv_simple(s, 0) : (*s & 0xff));
2947 (void)SvUPGRADE(TARG,SVt_PV);
2949 if (value > 255 && !IN_BYTE) {
2950 SvGROW(TARG, UNISKIP(value)+1);
2951 tmps = (char*)uv_to_utf8((U8*)SvPVX(TARG), value);
2952 SvCUR_set(TARG, tmps - SvPVX(TARG));
2954 (void)SvPOK_only(TARG);
2965 (void)SvPOK_only(TARG);
2972 dSP; dTARGET; dPOPTOPssrl;
2975 char *tmps = SvPV(left, n_a);
2977 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
2979 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
2983 "The crypt() function is unimplemented due to excessive paranoia.");
2996 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
2998 U8 tmpbuf[UTF8_MAXLEN+1];
3000 UV uv = utf8_to_uv(s, slen, &ulen, 0);
3002 if (PL_op->op_private & OPpLOCALE) {
3005 uv = toTITLE_LC_uni(uv);
3008 uv = toTITLE_utf8(s);
3010 tend = uv_to_utf8(tmpbuf, uv);
3012 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
3014 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3015 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3020 s = (U8*)SvPV_force(sv, slen);
3021 Copy(tmpbuf, s, ulen, U8);
3025 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3027 SvUTF8_off(TARG); /* decontaminate */
3032 s = (U8*)SvPV_force(sv, slen);
3034 if (PL_op->op_private & OPpLOCALE) {
3037 *s = toUPPER_LC(*s);
3055 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
3057 U8 tmpbuf[UTF8_MAXLEN+1];
3059 UV uv = utf8_to_uv(s, slen, &ulen, 0);
3061 if (PL_op->op_private & OPpLOCALE) {
3064 uv = toLOWER_LC_uni(uv);
3067 uv = toLOWER_utf8(s);
3069 tend = uv_to_utf8(tmpbuf, uv);
3071 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
3073 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3074 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3079 s = (U8*)SvPV_force(sv, slen);
3080 Copy(tmpbuf, s, ulen, U8);
3084 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3086 SvUTF8_off(TARG); /* decontaminate */
3091 s = (U8*)SvPV_force(sv, slen);
3093 if (PL_op->op_private & OPpLOCALE) {
3096 *s = toLOWER_LC(*s);
3120 s = (U8*)SvPV(sv,len);
3122 SvUTF8_off(TARG); /* decontaminate */
3123 sv_setpvn(TARG, "", 0);
3127 (void)SvUPGRADE(TARG, SVt_PV);
3128 SvGROW(TARG, (len * 2) + 1);
3129 (void)SvPOK_only(TARG);
3130 d = (U8*)SvPVX(TARG);
3132 if (PL_op->op_private & OPpLOCALE) {
3136 d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, len, &ulen, 0)));
3142 d = uv_to_utf8(d, toUPPER_utf8( s ));
3148 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3153 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3155 SvUTF8_off(TARG); /* decontaminate */
3160 s = (U8*)SvPV_force(sv, len);
3162 register U8 *send = s + len;
3164 if (PL_op->op_private & OPpLOCALE) {
3167 for (; s < send; s++)
3168 *s = toUPPER_LC(*s);
3171 for (; s < send; s++)
3194 s = (U8*)SvPV(sv,len);
3196 SvUTF8_off(TARG); /* decontaminate */
3197 sv_setpvn(TARG, "", 0);
3201 (void)SvUPGRADE(TARG, SVt_PV);
3202 SvGROW(TARG, (len * 2) + 1);
3203 (void)SvPOK_only(TARG);
3204 d = (U8*)SvPVX(TARG);
3206 if (PL_op->op_private & OPpLOCALE) {
3210 d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, len, &ulen, 0)));
3216 d = uv_to_utf8(d, toLOWER_utf8(s));
3222 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3227 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3229 SvUTF8_off(TARG); /* decontaminate */
3235 s = (U8*)SvPV_force(sv, len);
3237 register U8 *send = s + len;
3239 if (PL_op->op_private & OPpLOCALE) {
3242 for (; s < send; s++)
3243 *s = toLOWER_LC(*s);
3246 for (; s < send; s++)
3261 register char *s = SvPV(sv,len);
3264 SvUTF8_off(TARG); /* decontaminate */
3266 (void)SvUPGRADE(TARG, SVt_PV);
3267 SvGROW(TARG, (len * 2) + 1);
3271 if (UTF8_IS_CONTINUED(*s)) {
3272 STRLEN ulen = UTF8SKIP(s);
3296 SvCUR_set(TARG, d - SvPVX(TARG));
3297 (void)SvPOK_only_UTF8(TARG);
3300 sv_setpvn(TARG, s, len);
3302 if (SvSMAGICAL(TARG))
3311 dSP; dMARK; dORIGMARK;
3313 register AV* av = (AV*)POPs;
3314 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3315 I32 arybase = PL_curcop->cop_arybase;
3318 if (SvTYPE(av) == SVt_PVAV) {
3319 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3321 for (svp = MARK + 1; svp <= SP; svp++) {
3326 if (max > AvMAX(av))
3329 while (++MARK <= SP) {
3330 elem = SvIVx(*MARK);
3334 svp = av_fetch(av, elem, lval);
3336 if (!svp || *svp == &PL_sv_undef)
3337 DIE(aTHX_ PL_no_aelem, elem);
3338 if (PL_op->op_private & OPpLVAL_INTRO)
3339 save_aelem(av, elem, svp);
3341 *MARK = svp ? *svp : &PL_sv_undef;
3344 if (GIMME != G_ARRAY) {
3352 /* Associative arrays. */
3357 HV *hash = (HV*)POPs;
3359 I32 gimme = GIMME_V;
3360 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
3363 /* might clobber stack_sp */
3364 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
3369 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
3370 if (gimme == G_ARRAY) {
3373 /* might clobber stack_sp */
3375 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
3380 else if (gimme == G_SCALAR)
3399 I32 gimme = GIMME_V;
3400 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3404 if (PL_op->op_private & OPpSLICE) {
3408 hvtype = SvTYPE(hv);
3409 if (hvtype == SVt_PVHV) { /* hash element */
3410 while (++MARK <= SP) {
3411 sv = hv_delete_ent(hv, *MARK, discard, 0);
3412 *MARK = sv ? sv : &PL_sv_undef;
3415 else if (hvtype == SVt_PVAV) {
3416 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3417 while (++MARK <= SP) {
3418 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3419 *MARK = sv ? sv : &PL_sv_undef;
3422 else { /* pseudo-hash element */
3423 while (++MARK <= SP) {
3424 sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
3425 *MARK = sv ? sv : &PL_sv_undef;
3430 DIE(aTHX_ "Not a HASH reference");
3433 else if (gimme == G_SCALAR) {
3442 if (SvTYPE(hv) == SVt_PVHV)
3443 sv = hv_delete_ent(hv, keysv, discard, 0);
3444 else if (SvTYPE(hv) == SVt_PVAV) {
3445 if (PL_op->op_flags & OPf_SPECIAL)
3446 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3448 sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
3451 DIE(aTHX_ "Not a HASH reference");
3466 if (PL_op->op_private & OPpEXISTS_SUB) {
3470 cv = sv_2cv(sv, &hv, &gv, FALSE);
3473 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3479 if (SvTYPE(hv) == SVt_PVHV) {
3480 if (hv_exists_ent(hv, tmpsv, 0))
3483 else if (SvTYPE(hv) == SVt_PVAV) {
3484 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3485 if (av_exists((AV*)hv, SvIV(tmpsv)))
3488 else if (avhv_exists_ent((AV*)hv, tmpsv, 0)) /* pseudo-hash element */
3492 DIE(aTHX_ "Not a HASH reference");
3499 dSP; dMARK; dORIGMARK;
3500 register HV *hv = (HV*)POPs;
3501 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3502 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
3504 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
3505 DIE(aTHX_ "Can't localize pseudo-hash element");
3507 if (realhv || SvTYPE(hv) == SVt_PVAV) {
3508 while (++MARK <= SP) {
3511 I32 preeminent = SvRMAGICAL(hv) ? 1 : hv_exists_ent(hv, keysv, 0);
3513 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
3514 svp = he ? &HeVAL(he) : 0;
3517 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
3520 if (!svp || *svp == &PL_sv_undef) {
3522 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3524 if (PL_op->op_private & OPpLVAL_INTRO) {
3526 save_helem(hv, keysv, svp);
3529 char *key = SvPV(keysv, keylen);
3530 SAVEDELETE(hv, savepvn(key,keylen), keylen);
3534 *MARK = svp ? *svp : &PL_sv_undef;
3537 if (GIMME != G_ARRAY) {
3545 /* List operators. */
3550 if (GIMME != G_ARRAY) {
3552 *MARK = *SP; /* unwanted list, return last item */
3554 *MARK = &PL_sv_undef;
3563 SV **lastrelem = PL_stack_sp;
3564 SV **lastlelem = PL_stack_base + POPMARK;
3565 SV **firstlelem = PL_stack_base + POPMARK + 1;
3566 register SV **firstrelem = lastlelem + 1;
3567 I32 arybase = PL_curcop->cop_arybase;
3568 I32 lval = PL_op->op_flags & OPf_MOD;
3569 I32 is_something_there = lval;
3571 register I32 max = lastrelem - lastlelem;
3572 register SV **lelem;
3575 if (GIMME != G_ARRAY) {
3576 ix = SvIVx(*lastlelem);
3581 if (ix < 0 || ix >= max)
3582 *firstlelem = &PL_sv_undef;
3584 *firstlelem = firstrelem[ix];
3590 SP = firstlelem - 1;
3594 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3600 if (ix < 0 || ix >= max)
3601 *lelem = &PL_sv_undef;
3603 is_something_there = TRUE;
3604 if (!(*lelem = firstrelem[ix]))
3605 *lelem = &PL_sv_undef;
3608 if (is_something_there)
3611 SP = firstlelem - 1;
3617 dSP; dMARK; dORIGMARK;
3618 I32 items = SP - MARK;
3619 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
3620 SP = ORIGMARK; /* av_make() might realloc stack_sp */
3627 dSP; dMARK; dORIGMARK;
3628 HV* hv = (HV*)sv_2mortal((SV*)newHV());
3632 SV *val = NEWSV(46, 0);
3634 sv_setsv(val, *++MARK);
3635 else if (ckWARN(WARN_MISC))
3636 Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
3637 (void)hv_store_ent(hv,key,val,0);
3646 dSP; dMARK; dORIGMARK;
3647 register AV *ary = (AV*)*++MARK;
3651 register I32 offset;
3652 register I32 length;
3659 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3660 *MARK-- = SvTIED_obj((SV*)ary, mg);
3664 call_method("SPLICE",GIMME_V);
3673 offset = i = SvIVx(*MARK);
3675 offset += AvFILLp(ary) + 1;
3677 offset -= PL_curcop->cop_arybase;
3679 DIE(aTHX_ PL_no_aelem, i);
3681 length = SvIVx(*MARK++);
3683 length += AvFILLp(ary) - offset + 1;
3689 length = AvMAX(ary) + 1; /* close enough to infinity */
3693 length = AvMAX(ary) + 1;
3695 if (offset > AvFILLp(ary) + 1)
3696 offset = AvFILLp(ary) + 1;
3697 after = AvFILLp(ary) + 1 - (offset + length);
3698 if (after < 0) { /* not that much array */
3699 length += after; /* offset+length now in array */
3705 /* At this point, MARK .. SP-1 is our new LIST */
3708 diff = newlen - length;
3709 if (newlen && !AvREAL(ary) && AvREIFY(ary))
3712 if (diff < 0) { /* shrinking the area */
3714 New(451, tmparyval, newlen, SV*); /* so remember insertion */
3715 Copy(MARK, tmparyval, newlen, SV*);
3718 MARK = ORIGMARK + 1;
3719 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3720 MEXTEND(MARK, length);
3721 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
3723 EXTEND_MORTAL(length);
3724 for (i = length, dst = MARK; i; i--) {
3725 sv_2mortal(*dst); /* free them eventualy */
3732 *MARK = AvARRAY(ary)[offset+length-1];
3735 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
3736 SvREFCNT_dec(*dst++); /* free them now */
3739 AvFILLp(ary) += diff;
3741 /* pull up or down? */
3743 if (offset < after) { /* easier to pull up */
3744 if (offset) { /* esp. if nothing to pull */
3745 src = &AvARRAY(ary)[offset-1];
3746 dst = src - diff; /* diff is negative */
3747 for (i = offset; i > 0; i--) /* can't trust Copy */
3751 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
3755 if (after) { /* anything to pull down? */
3756 src = AvARRAY(ary) + offset + length;
3757 dst = src + diff; /* diff is negative */
3758 Move(src, dst, after, SV*);
3760 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
3761 /* avoid later double free */
3765 dst[--i] = &PL_sv_undef;
3768 for (src = tmparyval, dst = AvARRAY(ary) + offset;
3770 *dst = NEWSV(46, 0);
3771 sv_setsv(*dst++, *src++);
3773 Safefree(tmparyval);
3776 else { /* no, expanding (or same) */
3778 New(452, tmparyval, length, SV*); /* so remember deletion */
3779 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
3782 if (diff > 0) { /* expanding */
3784 /* push up or down? */
3786 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
3790 Move(src, dst, offset, SV*);
3792 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
3794 AvFILLp(ary) += diff;
3797 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
3798 av_extend(ary, AvFILLp(ary) + diff);
3799 AvFILLp(ary) += diff;
3802 dst = AvARRAY(ary) + AvFILLp(ary);
3804 for (i = after; i; i--) {
3811 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3812 *dst = NEWSV(46, 0);
3813 sv_setsv(*dst++, *src++);
3815 MARK = ORIGMARK + 1;
3816 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3818 Copy(tmparyval, MARK, length, SV*);
3820 EXTEND_MORTAL(length);
3821 for (i = length, dst = MARK; i; i--) {
3822 sv_2mortal(*dst); /* free them eventualy */
3826 Safefree(tmparyval);
3830 else if (length--) {
3831 *MARK = tmparyval[length];
3834 while (length-- > 0)
3835 SvREFCNT_dec(tmparyval[length]);
3837 Safefree(tmparyval);
3840 *MARK = &PL_sv_undef;
3848 dSP; dMARK; dORIGMARK; dTARGET;
3849 register AV *ary = (AV*)*++MARK;
3850 register SV *sv = &PL_sv_undef;
3853 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3854 *MARK-- = SvTIED_obj((SV*)ary, mg);
3858 call_method("PUSH",G_SCALAR|G_DISCARD);
3863 /* Why no pre-extend of ary here ? */
3864 for (++MARK; MARK <= SP; MARK++) {
3867 sv_setsv(sv, *MARK);
3872 PUSHi( AvFILL(ary) + 1 );
3880 SV *sv = av_pop(av);
3882 (void)sv_2mortal(sv);
3891 SV *sv = av_shift(av);
3896 (void)sv_2mortal(sv);
3903 dSP; dMARK; dORIGMARK; dTARGET;
3904 register AV *ary = (AV*)*++MARK;
3909 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3910 *MARK-- = SvTIED_obj((SV*)ary, mg);
3914 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3919 av_unshift(ary, SP - MARK);
3922 sv_setsv(sv, *++MARK);
3923 (void)av_store(ary, i++, sv);
3927 PUSHi( AvFILL(ary) + 1 );
3937 if (GIMME == G_ARRAY) {
3944 /* safe as long as stack cannot get extended in the above */
3949 register char *down;
3954 SvUTF8_off(TARG); /* decontaminate */
3956 do_join(TARG, &PL_sv_no, MARK, SP);
3958 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
3959 up = SvPV_force(TARG, len);
3961 if (DO_UTF8(TARG)) { /* first reverse each character */
3962 U8* s = (U8*)SvPVX(TARG);
3963 U8* send = (U8*)(s + len);
3965 if (UTF8_IS_ASCII(*s)) {
3970 if (!utf8_to_uv_simple(s, 0))
3974 down = (char*)(s - 1);
3975 /* reverse this character */
3985 down = SvPVX(TARG) + len - 1;
3991 (void)SvPOK_only_UTF8(TARG);
4000 S_mul128(pTHX_ SV *sv, U8 m)
4003 char *s = SvPV(sv, len);
4007 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
4008 SV *tmpNew = newSVpvn("0000000000", 10);
4010 sv_catsv(tmpNew, sv);
4011 SvREFCNT_dec(sv); /* free old sv */
4016 while (!*t) /* trailing '\0'? */
4019 i = ((*t - '0') << 7) + m;
4020 *(t--) = '0' + (i % 10);
4026 /* Explosives and implosives. */
4028 #if 'I' == 73 && 'J' == 74
4029 /* On an ASCII/ISO kind of system */
4030 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
4033 Some other sort of character set - use memchr() so we don't match
4036 #define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
4043 I32 start_sp_offset = SP - PL_stack_base;
4044 I32 gimme = GIMME_V;
4048 register char *pat = SvPV(left, llen);
4049 register char *s = SvPV(right, rlen);
4050 char *strend = s + rlen;
4052 register char *patend = pat + llen;
4058 /* These must not be in registers: */
4075 register U32 culong;
4079 #ifdef PERL_NATINT_PACK
4080 int natint; /* native integer */
4081 int unatint; /* unsigned native integer */
4084 if (gimme != G_ARRAY) { /* arrange to do first one only */
4086 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
4087 if (strchr("aAZbBhHP", *patend) || *pat == '%') {
4089 while (isDIGIT(*patend) || *patend == '*')
4095 while (pat < patend) {
4097 datumtype = *pat++ & 0xFF;
4098 #ifdef PERL_NATINT_PACK
4101 if (isSPACE(datumtype))
4103 if (datumtype == '#') {
4104 while (pat < patend && *pat != '\n')
4109 char *natstr = "sSiIlL";
4111 if (strchr(natstr, datumtype)) {
4112 #ifdef PERL_NATINT_PACK
4118 DIE(aTHX_ "'!' allowed only after types %s", natstr);
4123 else if (*pat == '*') {
4124 len = strend - strbeg; /* long enough */
4128 else if (isDIGIT(*pat)) {
4130 while (isDIGIT(*pat)) {
4131 len = (len * 10) + (*pat++ - '0');
4133 DIE(aTHX_ "Repeat count in unpack overflows");
4137 len = (datumtype != '@');
4141 DIE(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
4142 case ',': /* grandfather in commas but with a warning */
4143 if (commas++ == 0 && ckWARN(WARN_UNPACK))
4144 Perl_warner(aTHX_ WARN_UNPACK,
4145 "Invalid type in unpack: '%c'", (int)datumtype);
4148 if (len == 1 && pat[-1] != '1')
4157 if (len > strend - strbeg)
4158 DIE(aTHX_ "@ outside of string");
4162 if (len > s - strbeg)
4163 DIE(aTHX_ "X outside of string");
4167 if (len > strend - s)
4168 DIE(aTHX_ "x outside of string");
4172 if (start_sp_offset >= SP - PL_stack_base)
4173 DIE(aTHX_ "/ must follow a numeric type");
4176 pat++; /* ignore '*' for compatibility with pack */
4178 DIE(aTHX_ "/ cannot take a count" );
4185 if (len > strend - s)
4188 goto uchar_checksum;
4189 sv = NEWSV(35, len);
4190 sv_setpvn(sv, s, len);
4192 if (datumtype == 'A' || datumtype == 'Z') {
4193 aptr = s; /* borrow register */
4194 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
4199 else { /* 'A' strips both nulls and spaces */
4200 s = SvPVX(sv) + len - 1;
4201 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
4205 SvCUR_set(sv, s - SvPVX(sv));
4206 s = aptr; /* unborrow register */
4208 XPUSHs(sv_2mortal(sv));
4212 if (star || len > (strend - s) * 8)
4213 len = (strend - s) * 8;
4216 Newz(601, PL_bitcount, 256, char);
4217 for (bits = 1; bits < 256; bits++) {
4218 if (bits & 1) PL_bitcount[bits]++;
4219 if (bits & 2) PL_bitcount[bits]++;
4220 if (bits & 4) PL_bitcount[bits]++;
4221 if (bits & 8) PL_bitcount[bits]++;
4222 if (bits & 16) PL_bitcount[bits]++;
4223 if (bits & 32) PL_bitcount[bits]++;
4224 if (bits & 64) PL_bitcount[bits]++;
4225 if (bits & 128) PL_bitcount[bits]++;
4229 culong += PL_bitcount[*(unsigned char*)s++];
4234 if (datumtype == 'b') {
4236 if (bits & 1) culong++;
4242 if (bits & 128) culong++;
4249 sv = NEWSV(35, len + 1);
4253 if (datumtype == 'b') {
4255 for (len = 0; len < aint; len++) {
4256 if (len & 7) /*SUPPRESS 595*/
4260 *str++ = '0' + (bits & 1);
4265 for (len = 0; len < aint; len++) {
4270 *str++ = '0' + ((bits & 128) != 0);
4274 XPUSHs(sv_2mortal(sv));
4278 if (star || len > (strend - s) * 2)
4279 len = (strend - s) * 2;
4280 sv = NEWSV(35, len + 1);
4284 if (datumtype == 'h') {
4286 for (len = 0; len < aint; len++) {
4291 *str++ = PL_hexdigit[bits & 15];
4296 for (len = 0; len < aint; len++) {
4301 *str++ = PL_hexdigit[(bits >> 4) & 15];
4305 XPUSHs(sv_2mortal(sv));
4308 if (len > strend - s)
4313 if (aint >= 128) /* fake up signed chars */
4323 if (aint >= 128) /* fake up signed chars */
4326 sv_setiv(sv, (IV)aint);
4327 PUSHs(sv_2mortal(sv));
4332 if (len > strend - s)
4347 sv_setiv(sv, (IV)auint);
4348 PUSHs(sv_2mortal(sv));
4353 if (len > strend - s)
4356 while (len-- > 0 && s < strend) {
4358 auint = utf8_to_uv((U8*)s, strend - s, &alen, 0);
4362 cdouble += (NV)auint;
4370 while (len-- > 0 && s < strend) {
4372 auint = utf8_to_uv((U8*)s, strend - s, &alen, 0);
4376 sv_setuv(sv, (UV)auint);
4377 PUSHs(sv_2mortal(sv));
4382 #if SHORTSIZE == SIZE16
4383 along = (strend - s) / SIZE16;
4385 along = (strend - s) / (natint ? sizeof(short) : SIZE16);
4390 #if SHORTSIZE != SIZE16
4394 COPYNN(s, &ashort, sizeof(short));
4405 #if SHORTSIZE > SIZE16
4417 #if SHORTSIZE != SIZE16
4421 COPYNN(s, &ashort, sizeof(short));
4424 sv_setiv(sv, (IV)ashort);
4425 PUSHs(sv_2mortal(sv));
4433 #if SHORTSIZE > SIZE16
4439 sv_setiv(sv, (IV)ashort);
4440 PUSHs(sv_2mortal(sv));
4448 #if SHORTSIZE == SIZE16
4449 along = (strend - s) / SIZE16;
4451 unatint = natint && datumtype == 'S';
4452 along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
4457 #if SHORTSIZE != SIZE16
4459 unsigned short aushort;
4461 COPYNN(s, &aushort, sizeof(unsigned short));
4462 s += sizeof(unsigned short);
4470 COPY16(s, &aushort);
4473 if (datumtype == 'n')
4474 aushort = PerlSock_ntohs(aushort);
4477 if (datumtype == 'v')
4478 aushort = vtohs(aushort);
4487 #if SHORTSIZE != SIZE16
4489 unsigned short aushort;
4491 COPYNN(s, &aushort, sizeof(unsigned short));
4492 s += sizeof(unsigned short);
4494 sv_setiv(sv, (UV)aushort);
4495 PUSHs(sv_2mortal(sv));
4502 COPY16(s, &aushort);
4506 if (datumtype == 'n')
4507 aushort = PerlSock_ntohs(aushort);
4510 if (datumtype == 'v')
4511 aushort = vtohs(aushort);
4513 sv_setiv(sv, (UV)aushort);
4514 PUSHs(sv_2mortal(sv));
4520 along = (strend - s) / sizeof(int);
4525 Copy(s, &aint, 1, int);
4528 cdouble += (NV)aint;
4537 Copy(s, &aint, 1, int);
4541 /* Without the dummy below unpack("i", pack("i",-1))
4542 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
4543 * cc with optimization turned on.
4545 * The bug was detected in
4546 * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
4547 * with optimization (-O4) turned on.
4548 * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
4549 * does not have this problem even with -O4.
4551 * This bug was reported as DECC_BUGS 1431
4552 * and tracked internally as GEM_BUGS 7775.
4554 * The bug is fixed in
4555 * Tru64 UNIX V5.0: Compaq C V6.1-006 or later
4556 * UNIX V4.0F support: DEC C V5.9-006 or later
4557 * UNIX V4.0E support: DEC C V5.8-011 or later
4560 * See also few lines later for the same bug.
4563 sv_setiv(sv, (IV)aint) :
4565 sv_setiv(sv, (IV)aint);
4566 PUSHs(sv_2mortal(sv));
4571 along = (strend - s) / sizeof(unsigned int);
4576 Copy(s, &auint, 1, unsigned int);
4577 s += sizeof(unsigned int);
4579 cdouble += (NV)auint;
4588 Copy(s, &auint, 1, unsigned int);
4589 s += sizeof(unsigned int);
4592 /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
4593 * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
4594 * See details few lines earlier. */
4596 sv_setuv(sv, (UV)auint) :
4598 sv_setuv(sv, (UV)auint);
4599 PUSHs(sv_2mortal(sv));
4604 #if LONGSIZE == SIZE32
4605 along = (strend - s) / SIZE32;
4607 along = (strend - s) / (natint ? sizeof(long) : SIZE32);
4612 #if LONGSIZE != SIZE32
4615 COPYNN(s, &along, sizeof(long));
4618 cdouble += (NV)along;
4627 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
4631 #if LONGSIZE > SIZE32
4632 if (along > 2147483647)
4633 along -= 4294967296;
4637 cdouble += (NV)along;
4646 #if LONGSIZE != SIZE32
4649 COPYNN(s, &along, sizeof(long));
4652 sv_setiv(sv, (IV)along);
4653 PUSHs(sv_2mortal(sv));
4660 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
4664 #if LONGSIZE > SIZE32
4665 if (along > 2147483647)
4666 along -= 4294967296;
4670 sv_setiv(sv, (IV)along);
4671 PUSHs(sv_2mortal(sv));
4679 #if LONGSIZE == SIZE32
4680 along = (strend - s) / SIZE32;
4682 unatint = natint && datumtype == 'L';
4683 along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
4688 #if LONGSIZE != SIZE32
4690 unsigned long aulong;
4692 COPYNN(s, &aulong, sizeof(unsigned long));
4693 s += sizeof(unsigned long);
4695 cdouble += (NV)aulong;
4707 if (datumtype == 'N')
4708 aulong = PerlSock_ntohl(aulong);
4711 if (datumtype == 'V')
4712 aulong = vtohl(aulong);
4715 cdouble += (NV)aulong;
4724 #if LONGSIZE != SIZE32
4726 unsigned long aulong;
4728 COPYNN(s, &aulong, sizeof(unsigned long));
4729 s += sizeof(unsigned long);
4731 sv_setuv(sv, (UV)aulong);
4732 PUSHs(sv_2mortal(sv));
4742 if (datumtype == 'N')
4743 aulong = PerlSock_ntohl(aulong);
4746 if (datumtype == 'V')
4747 aulong = vtohl(aulong);
4750 sv_setuv(sv, (UV)aulong);
4751 PUSHs(sv_2mortal(sv));
4757 along = (strend - s) / sizeof(char*);
4763 if (sizeof(char*) > strend - s)
4766 Copy(s, &aptr, 1, char*);
4772 PUSHs(sv_2mortal(sv));
4782 while ((len > 0) && (s < strend)) {
4783 auv = (auv << 7) | (*s & 0x7f);
4784 if (UTF8_IS_ASCII(*s++)) {
4788 PUSHs(sv_2mortal(sv));
4792 else if (++bytes >= sizeof(UV)) { /* promote to string */
4796 sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv);
4797 while (s < strend) {
4798 sv = mul128(sv, *s & 0x7f);
4799 if (!(*s++ & 0x80)) {
4808 PUSHs(sv_2mortal(sv));
4813 if ((s >= strend) && bytes)
4814 DIE(aTHX_ "Unterminated compressed integer");
4819 if (sizeof(char*) > strend - s)
4822 Copy(s, &aptr, 1, char*);
4827 sv_setpvn(sv, aptr, len);
4828 PUSHs(sv_2mortal(sv));
4832 along = (strend - s) / sizeof(Quad_t);
4838 if (s + sizeof(Quad_t) > strend)
4841 Copy(s, &aquad, 1, Quad_t);
4842 s += sizeof(Quad_t);
4845 if (aquad >= IV_MIN && aquad <= IV_MAX)
4846 sv_setiv(sv, (IV)aquad);
4848 sv_setnv(sv, (NV)aquad);
4849 PUSHs(sv_2mortal(sv));
4853 along = (strend - s) / sizeof(Quad_t);
4859 if (s + sizeof(Uquad_t) > strend)
4862 Copy(s, &auquad, 1, Uquad_t);
4863 s += sizeof(Uquad_t);
4866 if (auquad <= UV_MAX)
4867 sv_setuv(sv, (UV)auquad);
4869 sv_setnv(sv, (NV)auquad);
4870 PUSHs(sv_2mortal(sv));
4874 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
4877 along = (strend - s) / sizeof(float);
4882 Copy(s, &afloat, 1, float);
4891 Copy(s, &afloat, 1, float);
4894 sv_setnv(sv, (NV)afloat);
4895 PUSHs(sv_2mortal(sv));
4901 along = (strend - s) / sizeof(double);
4906 Copy(s, &adouble, 1, double);
4907 s += sizeof(double);
4915 Copy(s, &adouble, 1, double);
4916 s += sizeof(double);
4918 sv_setnv(sv, (NV)adouble);
4919 PUSHs(sv_2mortal(sv));
4925 * Initialise the decode mapping. By using a table driven
4926 * algorithm, the code will be character-set independent
4927 * (and just as fast as doing character arithmetic)
4929 if (PL_uudmap['M'] == 0) {
4932 for (i = 0; i < sizeof(PL_uuemap); i += 1)
4933 PL_uudmap[(U8)PL_uuemap[i]] = i;
4935 * Because ' ' and '`' map to the same value,
4936 * we need to decode them both the same.
4941 along = (strend - s) * 3 / 4;
4942 sv = NEWSV(42, along);
4945 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
4950 len = PL_uudmap[*(U8*)s++] & 077;
4952 if (s < strend && ISUUCHAR(*s))
4953 a = PL_uudmap[*(U8*)s++] & 077;
4956 if (s < strend && ISUUCHAR(*s))
4957 b = PL_uudmap[*(U8*)s++] & 077;
4960 if (s < strend && ISUUCHAR(*s))
4961 c = PL_uudmap[*(U8*)s++] & 077;
4964 if (s < strend && ISUUCHAR(*s))
4965 d = PL_uudmap[*(U8*)s++] & 077;
4968 hunk[0] = (a << 2) | (b >> 4);
4969 hunk[1] = (b << 4) | (c >> 2);
4970 hunk[2] = (c << 6) | d;
4971 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
4976 else if (s[1] == '\n') /* possible checksum byte */
4979 XPUSHs(sv_2mortal(sv));
4984 if (strchr("fFdD", datumtype) ||
4985 (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
4989 while (checksum >= 16) {
4993 while (checksum >= 4) {
4999 along = (1 << checksum) - 1;
5000 while (cdouble < 0.0)
5002 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
5003 sv_setnv(sv, cdouble);
5006 if (checksum < 32) {
5007 aulong = (1 << checksum) - 1;
5010 sv_setuv(sv, (UV)culong);
5012 XPUSHs(sv_2mortal(sv));
5016 if (SP - PL_stack_base == start_sp_offset && gimme == G_SCALAR)
5017 PUSHs(&PL_sv_undef);
5022 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
5026 *hunk = PL_uuemap[len];
5027 sv_catpvn(sv, hunk, 1);
5030 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
5031 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
5032 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
5033 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
5034 sv_catpvn(sv, hunk, 4);
5039 char r = (len > 1 ? s[1] : '\0');
5040 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
5041 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
5042 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
5043 hunk[3] = PL_uuemap[0];
5044 sv_catpvn(sv, hunk, 4);
5046 sv_catpvn(sv, "\n", 1);
5050 S_is_an_int(pTHX_ char *s, STRLEN l)
5053 SV *result = newSVpvn(s, l);
5054 char *result_c = SvPV(result, n_a); /* convenience */
5055 char *out = result_c;
5065 SvREFCNT_dec(result);
5088 SvREFCNT_dec(result);
5094 SvCUR_set(result, out - result_c);
5098 /* pnum must be '\0' terminated */
5100 S_div128(pTHX_ SV *pnum, bool *done)
5103 char *s = SvPV(pnum, len);
5112 i = m * 10 + (*t - '0');
5114 r = (i >> 7); /* r < 10 */
5121 SvCUR_set(pnum, (STRLEN) (t - s));
5128 dSP; dMARK; dORIGMARK; dTARGET;
5129 register SV *cat = TARG;
5132 register char *pat = SvPVx(*++MARK, fromlen);
5134 register char *patend = pat + fromlen;
5139 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
5140 static char *space10 = " ";
5142 /* These must not be in registers: */
5157 #ifdef PERL_NATINT_PACK
5158 int natint; /* native integer */
5163 sv_setpvn(cat, "", 0);
5165 while (pat < patend) {
5166 SV *lengthcode = Nullsv;
5167 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no)
5168 datumtype = *pat++ & 0xFF;
5169 #ifdef PERL_NATINT_PACK
5172 if (isSPACE(datumtype)) {
5176 if (datumtype == 'U' && pat == patcopy+1)
5178 if (datumtype == '#') {
5179 while (pat < patend && *pat != '\n')
5184 char *natstr = "sSiIlL";
5186 if (strchr(natstr, datumtype)) {
5187 #ifdef PERL_NATINT_PACK
5193 DIE(aTHX_ "'!' allowed only after types %s", natstr);
5196 len = strchr("@Xxu", datumtype) ? 0 : items;
5199 else if (isDIGIT(*pat)) {
5201 while (isDIGIT(*pat)) {
5202 len = (len * 10) + (*pat++ - '0');
5204 DIE(aTHX_ "Repeat count in pack overflows");
5211 if ((*pat != 'a' && *pat != 'A' && *pat != 'Z') || pat[1] != '*')
5212 DIE(aTHX_ "/ must be followed by a*, A* or Z*");
5213 lengthcode = sv_2mortal(newSViv(sv_len(items > 0
5214 ? *MARK : &PL_sv_no)
5215 + (*pat == 'Z' ? 1 : 0)));
5219 DIE(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
5220 case ',': /* grandfather in commas but with a warning */
5221 if (commas++ == 0 && ckWARN(WARN_PACK))
5222 Perl_warner(aTHX_ WARN_PACK,
5223 "Invalid type in pack: '%c'", (int)datumtype);
5226 DIE(aTHX_ "%% may only be used in unpack");
5237 if (SvCUR(cat) < len)
5238 DIE(aTHX_ "X outside of string");
5245 sv_catpvn(cat, null10, 10);
5248 sv_catpvn(cat, null10, len);
5254 aptr = SvPV(fromstr, fromlen);
5255 if (pat[-1] == '*') {
5257 if (datumtype == 'Z')
5260 if (fromlen >= len) {
5261 sv_catpvn(cat, aptr, len);
5262 if (datumtype == 'Z')
5263 *(SvEND(cat)-1) = '\0';
5266 sv_catpvn(cat, aptr, fromlen);
5268 if (datumtype == 'A') {
5270 sv_catpvn(cat, space10, 10);
5273 sv_catpvn(cat, space10, len);
5277 sv_catpvn(cat, null10, 10);
5280 sv_catpvn(cat, null10, len);
5292 str = SvPV(fromstr, fromlen);
5296 SvCUR(cat) += (len+7)/8;
5297 SvGROW(cat, SvCUR(cat) + 1);
5298 aptr = SvPVX(cat) + aint;
5303 if (datumtype == 'B') {
5304 for (len = 0; len++ < aint;) {
5305 items |= *str++ & 1;
5309 *aptr++ = items & 0xff;
5315 for (len = 0; len++ < aint;) {
5321 *aptr++ = items & 0xff;
5327 if (datumtype == 'B')
5328 items <<= 7 - (aint & 7);
5330 items >>= 7 - (aint & 7);
5331 *aptr++ = items & 0xff;
5333 str = SvPVX(cat) + SvCUR(cat);
5348 str = SvPV(fromstr, fromlen);
5352 SvCUR(cat) += (len+1)/2;
5353 SvGROW(cat, SvCUR(cat) + 1);
5354 aptr = SvPVX(cat) + aint;
5359 if (datumtype == 'H') {
5360 for (len = 0; len++ < aint;) {
5362 items |= ((*str++ & 15) + 9) & 15;
5364 items |= *str++ & 15;
5368 *aptr++ = items & 0xff;
5374 for (len = 0; len++ < aint;) {
5376 items |= (((*str++ & 15) + 9) & 15) << 4;
5378 items |= (*str++ & 15) << 4;
5382 *aptr++ = items & 0xff;
5388 *aptr++ = items & 0xff;
5389 str = SvPVX(cat) + SvCUR(cat);
5400 aint = SvIV(fromstr);
5402 sv_catpvn(cat, &achar, sizeof(char));
5408 auint = SvUV(fromstr);
5409 SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN + 1);
5410 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
5415 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
5420 afloat = (float)SvNV(fromstr);
5421 sv_catpvn(cat, (char *)&afloat, sizeof (float));
5428 adouble = (double)SvNV(fromstr);
5429 sv_catpvn(cat, (char *)&adouble, sizeof (double));
5435 ashort = (I16)SvIV(fromstr);
5437 ashort = PerlSock_htons(ashort);
5439 CAT16(cat, &ashort);
5445 ashort = (I16)SvIV(fromstr);
5447 ashort = htovs(ashort);
5449 CAT16(cat, &ashort);
5453 #if SHORTSIZE != SIZE16
5455 unsigned short aushort;
5459 aushort = SvUV(fromstr);
5460 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
5470 aushort = (U16)SvUV(fromstr);
5471 CAT16(cat, &aushort);
5477 #if SHORTSIZE != SIZE16
5483 ashort = SvIV(fromstr);
5484 sv_catpvn(cat, (char *)&ashort, sizeof(short));
5492 ashort = (I16)SvIV(fromstr);
5493 CAT16(cat, &ashort);
5500 auint = SvUV(fromstr);
5501 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
5507 adouble = Perl_floor(SvNV(fromstr));
5510 DIE(aTHX_ "Cannot compress negative numbers");
5513 #if UVSIZE > 4 && UVSIZE >= NVSIZE
5514 adouble <= 0xffffffff
5516 # ifdef CXUX_BROKEN_CONSTANT_CONVERT
5517 adouble <= UV_MAX_cxux
5524 char buf[1 + sizeof(UV)];
5525 char *in = buf + sizeof(buf);
5526 UV auv = U_V(adouble);
5529 *--in = (auv & 0x7f) | 0x80;
5532 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
5533 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
5535 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
5536 char *from, *result, *in;
5541 /* Copy string and check for compliance */
5542 from = SvPV(fromstr, len);
5543 if ((norm = is_an_int(from, len)) == NULL)
5544 DIE(aTHX_ "can compress only unsigned integer");
5546 New('w', result, len, char);
5550 *--in = div128(norm, &done) | 0x80;
5551 result[len - 1] &= 0x7F; /* clear continue bit */
5552 sv_catpvn(cat, in, (result + len) - in);
5554 SvREFCNT_dec(norm); /* free norm */
5556 else if (SvNOKp(fromstr)) {
5557 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
5558 char *in = buf + sizeof(buf);
5561 double next = floor(adouble / 128);
5562 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
5563 if (in <= buf) /* this cannot happen ;-) */
5564 DIE(aTHX_ "Cannot compress integer");
5567 } while (adouble > 0);
5568 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
5569 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
5572 DIE(aTHX_ "Cannot compress non integer");
5578 aint = SvIV(fromstr);
5579 sv_catpvn(cat, (char*)&aint, sizeof(int));
5585 aulong = SvUV(fromstr);
5587 aulong = PerlSock_htonl(aulong);
5589 CAT32(cat, &aulong);
5595 aulong = SvUV(fromstr);
5597 aulong = htovl(aulong);
5599 CAT32(cat, &aulong);
5603 #if LONGSIZE != SIZE32
5605 unsigned long aulong;
5609 aulong = SvUV(fromstr);
5610 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
5618 aulong = SvUV(fromstr);
5619 CAT32(cat, &aulong);
5624 #if LONGSIZE != SIZE32
5630 along = SvIV(fromstr);
5631 sv_catpvn(cat, (char *)&along, sizeof(long));
5639 along = SvIV(fromstr);
5648 auquad = (Uquad_t)SvUV(fromstr);
5649 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
5655 aquad = (Quad_t)SvIV(fromstr);
5656 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
5661 len = 1; /* assume SV is correct length */
5666 if (fromstr == &PL_sv_undef)
5670 /* XXX better yet, could spirit away the string to
5671 * a safe spot and hang on to it until the result
5672 * of pack() (and all copies of the result) are
5675 if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
5676 || (SvPADTMP(fromstr)
5677 && !SvREADONLY(fromstr))))
5679 Perl_warner(aTHX_ WARN_PACK,
5680 "Attempt to pack pointer to temporary value");
5682 if (SvPOK(fromstr) || SvNIOK(fromstr))
5683 aptr = SvPV(fromstr,n_a);
5685 aptr = SvPV_force(fromstr,n_a);
5687 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
5692 aptr = SvPV(fromstr, fromlen);
5693 SvGROW(cat, fromlen * 4 / 3);
5698 while (fromlen > 0) {
5705 doencodes(cat, aptr, todo);
5724 register IV limit = POPi; /* note, negative is forever */
5727 register char *s = SvPV(sv, len);
5728 bool do_utf8 = DO_UTF8(sv);
5729 char *strend = s + len;
5731 register REGEXP *rx;
5735 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
5736 I32 maxiters = slen + 10;
5739 I32 origlimit = limit;
5742 AV *oldstack = PL_curstack;
5743 I32 gimme = GIMME_V;
5744 I32 oldsave = PL_savestack_ix;
5745 I32 make_mortal = 1;
5746 MAGIC *mg = (MAGIC *) NULL;
5749 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5754 DIE(aTHX_ "panic: pp_split");
5755 rx = pm->op_pmregexp;
5757 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
5758 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
5760 if (pm->op_pmreplroot) {
5762 ary = GvAVn((GV*)PL_curpad[(PADOFFSET)pm->op_pmreplroot]);
5764 ary = GvAVn((GV*)pm->op_pmreplroot);
5767 else if (gimme != G_ARRAY)
5769 ary = (AV*)PL_curpad[0];
5771 ary = GvAVn(PL_defgv);
5772 #endif /* USE_THREADS */
5775 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
5781 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
5783 XPUSHs(SvTIED_obj((SV*)ary, mg));
5789 for (i = AvFILLp(ary); i >= 0; i--)
5790 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5792 /* temporarily switch stacks */
5793 SWITCHSTACK(PL_curstack, ary);
5797 base = SP - PL_stack_base;
5799 if (pm->op_pmflags & PMf_SKIPWHITE) {
5800 if (pm->op_pmflags & PMf_LOCALE) {
5801 while (isSPACE_LC(*s))
5809 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
5810 SAVEINT(PL_multiline);
5811 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
5815 limit = maxiters + 2;
5816 if (pm->op_pmflags & PMf_WHITE) {
5819 while (m < strend &&
5820 !((pm->op_pmflags & PMf_LOCALE)
5821 ? isSPACE_LC(*m) : isSPACE(*m)))
5826 dstr = NEWSV(30, m-s);
5827 sv_setpvn(dstr, s, m-s);
5831 (void)SvUTF8_on(dstr);
5835 while (s < strend &&
5836 ((pm->op_pmflags & PMf_LOCALE)
5837 ? isSPACE_LC(*s) : isSPACE(*s)))
5841 else if (strEQ("^", rx->precomp)) {
5844 for (m = s; m < strend && *m != '\n'; m++) ;
5848 dstr = NEWSV(30, m-s);
5849 sv_setpvn(dstr, s, m-s);
5853 (void)SvUTF8_on(dstr);
5858 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
5859 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
5860 && (rx->reganch & ROPT_CHECK_ALL)
5861 && !(rx->reganch & ROPT_ANCH)) {
5862 int tail = (rx->reganch & RE_INTUIT_TAIL);
5863 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
5866 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
5868 char c = *SvPV(csv, n_a);
5871 for (m = s; m < strend && *m != c; m++) ;
5874 dstr = NEWSV(30, m-s);
5875 sv_setpvn(dstr, s, m-s);
5879 (void)SvUTF8_on(dstr);
5881 /* The rx->minlen is in characters but we want to step
5882 * s ahead by bytes. */
5884 s = (char*)utf8_hop((U8*)m, len);
5886 s = m + len; /* Fake \n at the end */
5891 while (s < strend && --limit &&
5892 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5893 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
5896 dstr = NEWSV(31, m-s);
5897 sv_setpvn(dstr, s, m-s);
5901 (void)SvUTF8_on(dstr);
5903 /* The rx->minlen is in characters but we want to step
5904 * s ahead by bytes. */
5906 s = (char*)utf8_hop((U8*)m, len);
5908 s = m + len; /* Fake \n at the end */
5913 maxiters += slen * rx->nparens;
5914 while (s < strend && --limit
5915 /* && (!rx->check_substr
5916 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
5918 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
5919 1 /* minend */, sv, NULL, 0))
5921 TAINT_IF(RX_MATCH_TAINTED(rx));
5922 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
5927 strend = s + (strend - m);
5929 m = rx->startp[0] + orig;
5930 dstr = NEWSV(32, m-s);
5931 sv_setpvn(dstr, s, m-s);
5935 (void)SvUTF8_on(dstr);
5938 for (i = 1; i <= rx->nparens; i++) {
5939 s = rx->startp[i] + orig;
5940 m = rx->endp[i] + orig;
5942 dstr = NEWSV(33, m-s);
5943 sv_setpvn(dstr, s, m-s);
5946 dstr = NEWSV(33, 0);
5950 (void)SvUTF8_on(dstr);
5954 s = rx->endp[0] + orig;
5958 LEAVE_SCOPE(oldsave);
5959 iters = (SP - PL_stack_base) - base;
5960 if (iters > maxiters)
5961 DIE(aTHX_ "Split loop");
5963 /* keep field after final delim? */
5964 if (s < strend || (iters && origlimit)) {
5965 STRLEN l = strend - s;
5966 dstr = NEWSV(34, l);
5967 sv_setpvn(dstr, s, l);
5971 (void)SvUTF8_on(dstr);
5975 else if (!origlimit) {
5976 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
5982 SWITCHSTACK(ary, oldstack);
5983 if (SvSMAGICAL(ary)) {
5988 if (gimme == G_ARRAY) {
5990 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5998 call_method("PUSH",G_SCALAR|G_DISCARD);
6001 if (gimme == G_ARRAY) {
6002 /* EXTEND should not be needed - we just popped them */
6004 for (i=0; i < iters; i++) {
6005 SV **svp = av_fetch(ary, i, FALSE);
6006 PUSHs((svp) ? *svp : &PL_sv_undef);
6013 if (gimme == G_ARRAY)
6016 if (iters || !pm->op_pmreplroot) {
6026 Perl_unlock_condpair(pTHX_ void *svv)
6028 MAGIC *mg = mg_find((SV*)svv, 'm');
6031 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
6032 MUTEX_LOCK(MgMUTEXP(mg));
6033 if (MgOWNER(mg) != thr)
6034 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
6036 COND_SIGNAL(MgOWNERCONDP(mg));
6037 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
6038 PTR2UV(thr), PTR2UV(svv));)
6039 MUTEX_UNLOCK(MgMUTEXP(mg));
6041 #endif /* USE_THREADS */
6050 #endif /* USE_THREADS */
6051 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
6052 || SvTYPE(retsv) == SVt_PVCV) {
6053 retsv = refto(retsv);
6064 if (PL_op->op_private & OPpLVAL_INTRO)
6065 PUSHs(*save_threadsv(PL_op->op_targ));
6067 PUSHs(THREADSV(PL_op->op_targ));
6070 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
6071 #endif /* USE_THREADS */